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