apps/irssi/src/perl/perl-core.c

   1 /*
   2  perl-core.c : irssi
   3
   4     Copyright (C) 1999-2001 Timo Sirainen
   5
   6     This program is free software; you can redistribute it and/or modify
   7     it under the terms of the GNU General Public License as published by
   8     the Free Software Foundation; either version 2 of the License, or
   9     (at your option) any later version.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14     GNU General Public License for more details.
  15
  16     You should have received a copy of the GNU General Public License
  17     along with this program; if not, write to the Free Software
  18     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19 */
  20
  21 #define NEED_PERL_H
  22 #include "module.h"
  23 #include "modules.h"
  24 #include "core.h"
  25 #include "signals.h"
  26 #include "misc.h"
  27 #include "settings.h"
  28 #include "lib-config/iconfig.h" /* FIXME: remove before .99 */
  29
  30 #include "perl-core.h"
  31 #include "perl-common.h"
  32 #include "perl-signals.h"
  33 #include "perl-sources.h"
  34
  35 #include "XSUB.h"
  36 #include "irssi-core.pl.h"
  37
  38 /* For compatibility with perl 5.004 and older */
  39 #ifndef HAVE_PL_PERL
  40 #  define PL_perl_destruct_level perl_destruct_level
  41 #endif
  42
  43 GSList *perl_scripts;
  44 PerlInterpreter *my_perl;
  45
  46 static int print_script_errors;
  47
  48 #define IS_PERL_SCRIPT(file) \
  49         (strlen(file) > 3 && strcmp(file+strlen(file)-3, ".pl") == 0)
  50
  51 static void perl_script_destroy_package(PERL_SCRIPT_REC *script)
  52 {
  53         dSP;
  54
  55         ENTER;
  56         SAVETMPS;
  57
  58         PUSHMARK(SP);
  59         XPUSHs(sv_2mortal(new_pv(script->package)));
  60         PUTBACK;
  61
  62         perl_call_pv("Irssi::Core::destroy", G_VOID|G_EVAL|G_DISCARD);
  63
  64         SPAGAIN;
  65
  66         PUTBACK;
  67         FREETMPS;
  68         LEAVE;
  69 }
  70
  71 static void perl_script_destroy(PERL_SCRIPT_REC *script)
  72 {
  73         perl_scripts = g_slist_remove(perl_scripts, script);
  74
  75         signal_emit("script destroyed", 1, script);
  76
  77         perl_signal_remove_script(script);
  78         perl_source_remove_script(script);
  79
  80         g_free(script->name);
  81         g_free(script->package);
  82         g_free_not_null(script->path);
  83         g_free_not_null(script->data);
  84         g_free(script);
  85 }
  86
  87 extern void boot_DynaLoader(pTHX_ CV* cv);
  88
  89 #if PERL_STATIC_LIBS == 1
  90 extern void boot_Irssi(CV *cv);
  91
  92 XS(boot_Irssi_Core)
  93 {
  94         dXSARGS;
  95
  96         irssi_callXS(boot_Irssi, cv, mark);
  97         irssi_boot(Irc);
  98         irssi_boot(UI);
  99         irssi_boot(TextUI);
 100         XSRETURN_YES;
 101 }
 102 #endif
 103
 104 static void xs_init(pTHX)
 105 {
 106         dXSUB_SYS;
 107
 108 #if PERL_STATIC_LIBS == 1
 109         newXS("Irssi::Core::boot_Irssi_Core", boot_Irssi_Core, __FILE__);
 110 #endif
 111
 112         /* boot the dynaloader too, if we want to use some
 113            other dynamic modules.. */
 114         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
 115 }
 116
 117 /* Initialize perl interpreter */
 118 void perl_scripts_init(void)
 119 {
 120         char *args[] = {"", "-e", "0"};
 121         char *code, *use_code;
 122
 123         perl_scripts = NULL;
 124         perl_sources_start();
 125         perl_signals_start();
 126
 127         my_perl = perl_alloc();
 128         perl_construct(my_perl);
 129
 130         perl_parse(my_perl, xs_init, 3, args, NULL);
 131 #if PERL_STATIC_LIBS == 1
 132         perl_eval_pv("Irssi::Core::boot_Irssi_Core();", TRUE);
 133 #endif
 134
 135         perl_common_start();
 136
 137         use_code = perl_get_use_list();
 138         code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code);
 139         perl_eval_pv(code, TRUE);
 140
 141         g_free(code);
 142         g_free(use_code);
 143 }
 144
 145 /* Destroy all perl scripts and deinitialize perl interpreter */
 146 void perl_scripts_deinit(void)
 147 {
 148         if (my_perl == NULL)
 149                 return;
 150
 151         /* unload all scripts */
 152         while (perl_scripts != NULL)
 153                 perl_script_unload(perl_scripts->data);
 154
 155         signal_emit("perl scripts deinit", 0);
 156
 157         perl_signals_stop();
 158         perl_sources_stop();
 159         perl_common_stop();
 160
 161         /* Unload all perl libraries loaded with dynaloader */
 162         perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE);
 163
 164         /* We could unload all libraries .. but this crashes with some
 165            libraries, probably because we don't call some deinit function..
 166            Anyway, this would free some memory with /SCRIPT RESET, but it
 167            leaks memory anyway. */
 168         /*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/
 169
 170         /* perl interpreter */
 171         perl_destruct(my_perl);
 172         perl_free(my_perl);
 173         my_perl = NULL;
 174 }
 175
 176 /* Modify the script name so that all non-alphanumeric characters are
 177    translated to '_' */
 178 void script_fix_name(char *name)
 179 {
 180         char *p;
 181
 182         p = strrchr(name, '.');
 183         if (p != NULL) *p = '\0';
 184
 185         while (*name != '\0') {
 186                 if (*name != '_' && !i_isalnum(*name))
 187                         *name = '_';
 188                 name++;
 189         }
 190 }
 191
 192 static char *script_file_get_name(const char *path)
 193 {
 194         char *name;
 195
 196         name = g_strdup(g_basename(path));
 197         script_fix_name(name);
 198         return name;
 199 }
 200
 201 static char *script_data_get_name(void)
 202 {
 203         GString *name;
 204         char *ret;
 205         int n;
 206
 207         name = g_string_new(NULL);
 208         n = 1;
 209         do {
 210                 g_string_sprintf(name, "data%d", n);
 211                 n++;
 212         } while (perl_script_find(name->str) != NULL);
 213
 214         ret = name->str;
 215         g_string_free(name, FALSE);
 216         return ret;
 217 }
 218
 219 static int perl_script_eval(PERL_SCRIPT_REC *script)
 220 {
 221         dSP;
 222         char *error;
 223         int retcount;
 224         SV *ret;
 225
 226         ENTER;
 227         SAVETMPS;
 228
 229         PUSHMARK(SP);
 230         XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path :
 231                                  script->data)));
 232         XPUSHs(sv_2mortal(new_pv(script->name)));
 233         PUTBACK;
 234
 235         retcount = perl_call_pv(script->path != NULL ?
 236                                 "Irssi::Core::eval_file" :
 237                                 "Irssi::Core::eval_data",
 238                                 G_EVAL|G_SCALAR);
 239         SPAGAIN;
 240
 241         error = NULL;
 242         if (SvTRUE(ERRSV)) {
 243                 error = SvPV(ERRSV, PL_na);
 244
 245                 if (error != NULL) {
 246                         error = g_strdup(error);
 247                         signal_emit("script error", 2, script, error);
 248                         g_free(error);
 249                 }
 250         } else if (retcount > 0) {
 251                 /* if script returns 0, it means the script wanted to die
 252                    immediately without any error message */
 253                 ret = POPs;
 254                 if (ret != &PL_sv_undef && SvIOK(ret) && SvIV(ret) == 0)
 255                         error = "";
 256         }
 257
 258         PUTBACK;
 259         FREETMPS;
 260         LEAVE;
 261
 262         return error == NULL;
 263 }
 264
 265 /* NOTE: name must not be free'd */
 266 static PERL_SCRIPT_REC *script_load(char *name, const char *path,
 267                                     const char *data)
 268 {
 269         PERL_SCRIPT_REC *script;
 270
 271         /* if there's a script with a same name, destroy it */
 272         script = perl_script_find(name);
 273         if (script != NULL)
 274                 perl_script_destroy(script);
 275
 276         script = g_new0(PERL_SCRIPT_REC, 1);
 277         script->name = name;
 278         script->package = g_strdup_printf("Irssi::Script::%s", name);
 279         script->path = g_strdup(path);
 280         script->data = g_strdup(data);
 281
 282         perl_scripts = g_slist_append(perl_scripts, script);
 283         signal_emit("script created", 1, script);
 284
 285         if (!perl_script_eval(script))
 286                 script = NULL; /* the script is destroyed in "script error" signal */
 287         return script;
 288 }
 289
 290 /* Load a perl script, path must be a full path. */
 291 PERL_SCRIPT_REC *perl_script_load_file(const char *path)
 292 {
 293         char *name;
 294
 295         g_return_val_if_fail(path != NULL, NULL);
 296
 297         name = script_file_get_name(path);
 298         return script_load(name, path, NULL);
 299 }
 300
 301 /* Load a perl script from given data */
 302 PERL_SCRIPT_REC *perl_script_load_data(const char *data)
 303 {
 304         char *name;
 305
 306         g_return_val_if_fail(data != NULL, NULL);
 307
 308         name = script_data_get_name();
 309         return script_load(name, NULL, data);
 310 }
 311
 312 /* Unload perl script */
 313 void perl_script_unload(PERL_SCRIPT_REC *script)
 314 {
 315         g_return_if_fail(script != NULL);
 316
 317         perl_script_destroy_package(script);
 318         perl_script_destroy(script);
 319 }
 320
 321 /* Find loaded script by name */
 322 PERL_SCRIPT_REC *perl_script_find(const char *name)
 323 {
 324         GSList *tmp;
 325
 326         g_return_val_if_fail(name != NULL, NULL);
 327
 328         for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) {
 329                 PERL_SCRIPT_REC *rec = tmp->data;
 330
 331                 if (strcmp(rec->name, name) == 0)
 332                         return rec;
 333         }
 334
 335         return NULL;
 336 }
 337
 338 /* Find loaded script by package */
 339 PERL_SCRIPT_REC *perl_script_find_package(const char *package)
 340 {
 341         GSList *tmp;
 342
 343         g_return_val_if_fail(package != NULL, NULL);
 344
 345         for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) {
 346                 PERL_SCRIPT_REC *rec = tmp->data;
 347
 348                 if (strcmp(rec->package, package) == 0)
 349                         return rec;
 350         }
 351
 352         return NULL;
 353 }
 354
 355 /* Returns full path for the script */
 356 char *perl_script_get_path(const char *name)
 357 {
 358         struct stat statbuf;
 359         char *file, *path;
 360
 361         if (g_path_is_absolute(name) || (name[0] == '~' && name[1] == '/')) {
 362                 /* full path specified */
 363                 return convert_home(name);
 364         }
 365
 366         /* add .pl suffix if it's missing */
 367         file = IS_PERL_SCRIPT(name) ? g_strdup(name) :
 368                 g_strdup_printf("%s.pl", name);
 369
 370         /* check from ~/.irssi/scripts/ */
 371         path = g_strdup_printf("%s/scripts/%s", get_irssi_dir(), file);
 372         if (stat(path, &statbuf) != 0) {
 373                 /* check from SCRIPTDIR */
 374                 g_free(path);
 375                 path = g_strdup_printf(SCRIPTDIR"/%s", file);
 376                 if (stat(path, &statbuf) != 0) {
 377                         g_free(path);
 378                         path = NULL;
 379                 }
 380         }
 381         g_free(file);
 382         return path;
 383 }
 384
 385 /* If core should handle printing script errors */
 386 void perl_core_print_script_error(int print)
 387 {
 388         print_script_errors = print;
 389 }
 390
 391 /* Returns the perl module's API version. */
 392 int perl_get_api_version(void)
 393 {
 394         return IRSSI_PERL_API_VERSION;
 395 }
 396
 397 static void perl_scripts_autorun(void)
 398 {
 399         DIR *dirp;
 400         struct dirent *dp;
 401         struct stat statbuf;
 402         char *path, *fname;
 403
 404         /* run *.pl scripts from ~/.irssi/scripts/autorun/ */
 405         path = g_strdup_printf("%s/scripts/autorun", get_irssi_dir());
 406         dirp = opendir(path);
 407         if (dirp == NULL) {
 408                 g_free(path);
 409                 return;
 410         }
 411
 412         while ((dp = readdir(dirp)) != NULL) {
 413                 if (!IS_PERL_SCRIPT(dp->d_name))
 414                         continue;
 415
 416                 fname = g_strdup_printf("%s/%s", path, dp->d_name);
 417                 if (stat(fname, &statbuf) == 0 && !S_ISDIR(statbuf.st_mode))
 418                         perl_script_load_file(fname);
 419                 g_free(fname);
 420         }
 421         closedir(dirp);
 422         g_free(path);
 423 }
 424
 425 static void sig_script_error(PERL_SCRIPT_REC *script, const char *error)
 426 {
 427         char *str;
 428
 429         if (print_script_errors) {
 430                 str = g_strdup_printf("Script '%s' error:",
 431                                       script == NULL ? "??" : script->name);
 432                 signal_emit("gui dialog", 2, "error", str);
 433                 signal_emit("gui dialog", 2, "error", error);
 434                 g_free(str);
 435         }
 436
 437         if (script != NULL) {
 438                 perl_script_unload(script);
 439                 signal_stop();
 440         }
 441 }
 442
 443 static void sig_autorun(void)
 444 {
 445         signal_remove("irssi init finished", (SIGNAL_FUNC) sig_autorun);
 446
 447         perl_scripts_autorun();
 448 }
 449
 450 void perl_core_init(void)
 451 {
 452         print_script_errors = 1;
 453         settings_add_str("perl", "perl_use_lib", PERL_USE_LIB);
 454
 455         /*PL_perl_destruct_level = 1; - this crashes with some people.. */
 456         perl_signals_init();
 457         signal_add_last("script error", (SIGNAL_FUNC) sig_script_error);
 458
 459         perl_scripts_init();
 460
 461         if (irssi_init_finished)
 462                 perl_scripts_autorun();
 463         else {
 464                 signal_add("irssi init finished", (SIGNAL_FUNC) sig_autorun);
 465                 settings_check();
 466         }
 467
 468         module_register("perl", "core");
 469 }
 470
 471 void perl_core_deinit(void)
 472 {
 473         perl_scripts_deinit();
 474         perl_signals_deinit();
 475
 476         signal_remove("script error", (SIGNAL_FUNC) sig_script_error);
 477 }