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

   1 /*
   2  perl-common.c : irssi
   3
   4     Copyright (C) 2000 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 "signals.h"
  25 #include "core.h"
  26 #include "misc.h"
  27 #include "settings.h"
  28
  29 #include "commands.h"
  30 #include "ignore.h"
  31 #include "log.h"
  32 #include "rawlog.h"
  33 #include "servers-reconnect.h"
  34
  35 #include "window-item-def.h"
  36 #include "chat-protocols.h"
  37 #include "chatnets.h"
  38 #include "servers.h"
  39 #include "channels.h"
  40 #include "queries.h"
  41 #include "nicklist.h"
  42
  43 #include "perl-core.h"
  44 #include "perl-common.h"
  45
  46 typedef struct {
  47         char *stash;
  48         PERL_OBJECT_FUNC fill_func;
  49 } PERL_OBJECT_REC;
  50
  51 static GHashTable *iobject_stashes, *plain_stashes;
  52 static GSList *use_protocols;
  53
  54 /* returns the package who called us */
  55 const char *perl_get_package(void)
  56 {
  57         return SvPV(perl_eval_pv("caller", TRUE), PL_na);
  58 }
  59
  60 /* Parses the package part from function name */
  61 char *perl_function_get_package(const char *function)
  62 {
  63         const char *p;
  64         int pos;
  65
  66         pos = 0;
  67         for (p = function; *p != '\0'; p++) {
  68                 if (*p == ':' && p[1] == ':') {
  69                         if (++pos == 3)
  70                                 return g_strndup(function, (int) (p-function));
  71                 }
  72         }
  73
  74         return NULL;
  75 }
  76
  77 SV *perl_func_sv_inc(SV *func, const char *package)
  78 {
  79         char *name;
  80
  81         if (SvPOK(func)) {
  82                 /* prefix with package name */
  83                 name = g_strdup_printf("%s::%s", package,
  84                                        (char *) SvPV(func, PL_na));
  85                 func = new_pv(name);
  86                 g_free(name);
  87         } else {
  88                 SvREFCNT_inc(func);
  89         }
  90
  91         return func;
  92 }
  93
  94 static int magic_free_object(pTHX_ SV *sv, MAGIC *mg)
  95 {
  96         sv_setiv(sv, 0);
  97         return 0;
  98 }
  99
 100 static MGVTBL vtbl_free_object =
 101 {
 102     NULL, NULL, NULL, NULL, magic_free_object
 103 };
 104
 105 static SV *create_sv_ptr(void *object)
 106 {
 107         SV *sv;
 108
 109         sv = newSViv((IV)object);
 110
 111         sv_magic(sv, NULL, '~', NULL, 0);
 112
 113         SvMAGIC(sv)->mg_private = 0x1551; /* HF */
 114         SvMAGIC(sv)->mg_virtual = &vtbl_free_object;
 115
 116         return sv;
 117 }
 118
 119 SV *irssi_bless_iobject(int type, int chat_type, void *object)
 120 {
 121         PERL_OBJECT_REC *rec;
 122         HV *stash, *hv;
 123
 124         g_return_val_if_fail((type & ~0xffff) == 0, NULL);
 125         g_return_val_if_fail((chat_type & ~0xffff) == 0, NULL);
 126
 127         rec = g_hash_table_lookup(iobject_stashes,
 128                                   GINT_TO_POINTER(type | (chat_type << 16)));
 129         if (rec == NULL) {
 130                 /* unknown iobject */
 131                 return create_sv_ptr(object);
 132         }
 133
 134         stash = gv_stashpv(rec->stash, 1);
 135
 136         hv = newHV();
 137         hv_store(hv, "_irssi", 6, create_sv_ptr(object), 0);
 138         rec->fill_func(hv, object);
 139         return sv_bless(newRV_noinc((SV*)hv), stash);
 140 }
 141
 142 SV *irssi_bless_plain(const char *stash, void *object)
 143 {
 144         PERL_OBJECT_FUNC fill_func;
 145         HV *hv;
 146
 147         fill_func = g_hash_table_lookup(plain_stashes, stash);
 148
 149         hv = newHV();
 150         hv_store(hv, "_irssi", 6, create_sv_ptr(object), 0);
 151         if (fill_func != NULL)
 152                 fill_func(hv, object);
 153         return sv_bless(newRV_noinc((SV*)hv), gv_stashpv((char *)stash, 1));
 154 }
 155
 156 int irssi_is_ref_object(SV *o)
 157 {
 158         SV **sv;
 159         HV *hv;
 160
 161         hv = hvref(o);
 162         if (hv != NULL) {
 163                 sv = hv_fetch(hv, "_irssi", 6, 0);
 164                 if (sv != NULL)
 165                         return TRUE;
 166         }
 167
 168         return FALSE;
 169 }
 170
 171 void *irssi_ref_object(SV *o)
 172 {
 173         SV **sv;
 174         HV *hv;
 175         void *p;
 176
 177         hv = hvref(o);
 178         if (hv == NULL)
 179                 return NULL;
 180
 181         sv = hv_fetch(hv, "_irssi", 6, 0);
 182         if (sv == NULL)
 183                 croak("variable is damaged");
 184         p = GINT_TO_POINTER(SvIV(*sv));
 185         return p;
 186 }
 187
 188 void irssi_add_object(int type, int chat_type, const char *stash,
 189                       PERL_OBJECT_FUNC func)
 190 {
 191         PERL_OBJECT_REC *rec;
 192         void *hash;
 193
 194         g_return_if_fail((type & ~0xffff) == 0);
 195         g_return_if_fail((chat_type & ~0xffff) == 0);
 196
 197         hash = GINT_TO_POINTER(type | (chat_type << 16));
 198         rec = g_hash_table_lookup(iobject_stashes, hash);
 199         if (rec == NULL) {
 200                 rec = g_new(PERL_OBJECT_REC, 1);
 201                 rec->stash = g_strdup(stash);
 202                 g_hash_table_insert(iobject_stashes, hash, rec);
 203         }
 204         rec->fill_func = func;
 205 }
 206
 207 void irssi_add_plain(const char *stash, PERL_OBJECT_FUNC func)
 208 {
 209         if (g_hash_table_lookup(plain_stashes, stash) == NULL)
 210                 g_hash_table_insert(plain_stashes, g_strdup(stash), func);
 211 }
 212
 213 void irssi_add_plains(PLAIN_OBJECT_INIT_REC *objects)
 214 {
 215         while (objects->name != NULL) {
 216                 irssi_add_plain(objects->name, objects->fill_func);
 217                 objects++;
 218         }
 219 }
 220
 221 char *perl_get_use_list(void)
 222 {
 223         GString *str;
 224         GSList *tmp;
 225         char *ret;
 226         const char *use_lib;
 227
 228         str = g_string_new(NULL);
 229
 230         use_lib = settings_get_str("perl_use_lib");
 231         g_string_printf(str, "use lib qw(%s/scripts "SCRIPTDIR" %s);",
 232                          get_irssi_dir(), use_lib);
 233
 234         g_string_append(str, "use Irssi;");
 235         if (irssi_gui != IRSSI_GUI_NONE)
 236                 g_string_append(str, "use Irssi::UI;");
 237
 238         for (tmp = use_protocols; tmp != NULL; tmp = tmp->next)
 239                 g_string_append_printf(str, "use Irssi::%s;", (char *) tmp->data);
 240
 241         ret = str->str;
 242         g_string_free(str, FALSE);
 243         return ret;
 244 }
 245
 246 void irssi_callXS(void (*subaddr)(pTHX_ CV* cv), CV *cv, SV **mark)
 247 {
 248         dSP;
 249
 250         PUSHMARK(mark);
 251         (*subaddr)(aTHX_ cv);
 252
 253         PUTBACK;
 254 }
 255
 256 void perl_chatnet_fill_hash(HV *hv, CHATNET_REC *chatnet)
 257 {
 258         char *type, *chat_type;
 259
 260         g_return_if_fail(hv != NULL);
 261         g_return_if_fail(chatnet != NULL);
 262
 263         type = "CHATNET";
 264         chat_type = (char *) chat_protocol_find_id(chatnet->chat_type)->name;
 265
 266         hv_store(hv, "type", 4, new_pv(type), 0);
 267         hv_store(hv, "chat_type", 9, new_pv(chat_type), 0);
 268
 269         hv_store(hv, "name", 4, new_pv(chatnet->name), 0);
 270
 271         hv_store(hv, "nick", 4, new_pv(chatnet->nick), 0);
 272         hv_store(hv, "username", 8, new_pv(chatnet->username), 0);
 273         hv_store(hv, "realname", 8, new_pv(chatnet->realname), 0);
 274
 275         hv_store(hv, "own_host", 8, new_pv(chatnet->own_host), 0);
 276         hv_store(hv, "autosendcmd", 11, new_pv(chatnet->autosendcmd), 0);
 277 }
 278
 279 void perl_connect_fill_hash(HV *hv, SERVER_CONNECT_REC *conn)
 280 {
 281         char *type, *chat_type;
 282
 283         g_return_if_fail(hv != NULL);
 284         g_return_if_fail(conn != NULL);
 285
 286         type = "SERVER CONNECT";
 287         chat_type = (char *) chat_protocol_find_id(conn->chat_type)->name;
 288
 289         hv_store(hv, "type", 4, new_pv(type), 0);
 290         hv_store(hv, "chat_type", 9, new_pv(chat_type), 0);
 291
 292         hv_store(hv, "tag", 3, new_pv(conn->tag), 0);
 293         hv_store(hv, "address", 7, new_pv(conn->address), 0);
 294         hv_store(hv, "port", 4, newSViv(conn->port), 0);
 295         hv_store(hv, "chatnet", 7, new_pv(conn->chatnet), 0);
 296
 297         hv_store(hv, "password", 8, new_pv(conn->password), 0);
 298         hv_store(hv, "wanted_nick", 11, new_pv(conn->nick), 0);
 299         hv_store(hv, "username", 8, new_pv(conn->username), 0);
 300         hv_store(hv, "realname", 8, new_pv(conn->realname), 0);
 301
 302         hv_store(hv, "reconnection", 12, newSViv(conn->reconnection), 0);
 303         hv_store(hv, "no_autojoin_channels", 20, newSViv(conn->no_autojoin_channels), 0);
 304         hv_store(hv, "no_autosendcmd", 14, newSViv(conn->no_autosendcmd), 0);
 305         hv_store(hv, "unix_socket", 11, newSViv(conn->unix_socket), 0);
 306         hv_store(hv, "use_ssl", 7, newSViv(conn->use_ssl), 0);
 307         hv_store(hv, "no_connect", 10, newSViv(conn->no_connect), 0);
 308 }
 309
 310 void perl_server_fill_hash(HV *hv, SERVER_REC *server)
 311 {
 312         char *type;
 313         HV *stash;
 314
 315         g_return_if_fail(hv != NULL);
 316         g_return_if_fail(server != NULL);
 317
 318         perl_connect_fill_hash(hv, server->connrec);
 319
 320         type = "SERVER";
 321         hv_store(hv, "type", 4, new_pv(type), 0);
 322
 323         hv_store(hv, "connect_time", 12, newSViv(server->connect_time), 0);
 324         hv_store(hv, "real_connect_time", 17, newSViv(server->real_connect_time), 0);
 325
 326         hv_store(hv, "tag", 3, new_pv(server->tag), 0);
 327         hv_store(hv, "nick", 4, new_pv(server->nick), 0);
 328
 329         hv_store(hv, "connected", 9, newSViv(server->connected), 0);
 330         hv_store(hv, "connection_lost", 15, newSViv(server->connection_lost), 0);
 331
 332         stash = gv_stashpv("Irssi::Rawlog", 0);
 333         hv_store(hv, "rawlog", 6, sv_bless(newRV_noinc(newSViv((IV)server->rawlog)), stash), 0);
 334
 335         hv_store(hv, "version", 7, new_pv(server->version), 0);
 336         hv_store(hv, "away_reason", 11, new_pv(server->away_reason), 0);
 337         hv_store(hv, "last_invite", 11, new_pv(server->last_invite), 0);
 338         hv_store(hv, "server_operator", 15, newSViv(server->server_operator), 0);
 339         hv_store(hv, "usermode_away", 13, newSViv(server->usermode_away), 0);
 340         hv_store(hv, "banned", 6, newSViv(server->banned), 0);
 341
 342         hv_store(hv, "lag", 3, newSViv(server->lag), 0);
 343 }
 344
 345 void perl_window_item_fill_hash(HV *hv, WI_ITEM_REC *item)
 346 {
 347         char *type, *chat_type;
 348
 349         g_return_if_fail(hv != NULL);
 350         g_return_if_fail(item != NULL);
 351
 352         type = (char *) module_find_id_str("WINDOW ITEM TYPE", item->type);
 353         chat_type = (char *) chat_protocol_find_id(item->chat_type)->name;
 354
 355         hv_store(hv, "type", 4, new_pv(type), 0);
 356         hv_store(hv, "chat_type", 9, new_pv(chat_type), 0);
 357
 358         if (item->server != NULL) {
 359                 hv_store(hv, "server", 6, iobject_bless(item->server), 0);
 360         }
 361         hv_store(hv, "visible_name", 12, new_pv(item->visible_name), 0);
 362
 363         hv_store(hv, "createtime", 10, newSViv(item->createtime), 0);
 364         hv_store(hv, "data_level", 10, newSViv(item->data_level), 0);
 365         hv_store(hv, "hilight_color", 13, new_pv(item->hilight_color), 0);
 366 }
 367
 368 void perl_channel_fill_hash(HV *hv, CHANNEL_REC *channel)
 369 {
 370         g_return_if_fail(hv != NULL);
 371         g_return_if_fail(channel != NULL);
 372
 373         perl_window_item_fill_hash(hv, (WI_ITEM_REC *) channel);
 374
 375         if (channel->ownnick != NULL)
 376                 hv_store(hv, "ownnick", 7, iobject_bless(channel->ownnick), 0);
 377
 378         hv_store(hv, "name", 4, new_pv(channel->name), 0);
 379         hv_store(hv, "topic", 5, new_pv(channel->topic), 0);
 380         hv_store(hv, "topic_by", 8, new_pv(channel->topic_by), 0);
 381         hv_store(hv, "topic_time", 10, newSViv(channel->topic_time), 0);
 382
 383         hv_store(hv, "no_modes", 8, newSViv(channel->no_modes), 0);
 384         hv_store(hv, "mode", 4, new_pv(channel->mode), 0);
 385         hv_store(hv, "limit", 5, newSViv(channel->limit), 0);
 386         hv_store(hv, "key", 3, new_pv(channel->key), 0);
 387
 388         hv_store(hv, "chanop", 6, newSViv(channel->chanop), 0);
 389         hv_store(hv, "names_got", 9, newSViv(channel->names_got), 0);
 390         hv_store(hv, "wholist", 7, newSViv(channel->wholist), 0);
 391         hv_store(hv, "synced", 6, newSViv(channel->synced), 0);
 392
 393         hv_store(hv, "joined", 6, newSViv(channel->joined), 0);
 394         hv_store(hv, "left", 4, newSViv(channel->left), 0);
 395         hv_store(hv, "kicked", 6, newSViv(channel->kicked), 0);
 396 }
 397
 398 void perl_query_fill_hash(HV *hv, QUERY_REC *query)
 399 {
 400         g_return_if_fail(hv != NULL);
 401         g_return_if_fail(query != NULL);
 402
 403         perl_window_item_fill_hash(hv, (WI_ITEM_REC *) query);
 404
 405         hv_store(hv, "name", 4, new_pv(query->name), 0);
 406         hv_store(hv, "last_unread_msg", 15, newSViv(query->last_unread_msg), 0);
 407         hv_store(hv, "address", 7, new_pv(query->address), 0);
 408         hv_store(hv, "server_tag", 10, new_pv(query->server_tag), 0);
 409         hv_store(hv, "unwanted", 8, newSViv(query->unwanted), 0);
 410 }
 411
 412 void perl_nick_fill_hash(HV *hv, NICK_REC *nick)
 413 {
 414         char *type, *chat_type;
 415
 416         g_return_if_fail(hv != NULL);
 417         g_return_if_fail(nick != NULL);
 418
 419         type = "NICK";
 420         chat_type = (char *) chat_protocol_find_id(nick->chat_type)->name;
 421
 422         hv_store(hv, "type", 4, new_pv(type), 0);
 423         hv_store(hv, "chat_type", 9, new_pv(chat_type), 0);
 424
 425         hv_store(hv, "nick", 4, new_pv(nick->nick), 0);
 426         hv_store(hv, "host", 4, new_pv(nick->host), 0);
 427         hv_store(hv, "realname", 8, new_pv(nick->realname), 0);
 428         hv_store(hv, "hops", 4, newSViv(nick->hops), 0);
 429
 430         hv_store(hv, "gone", 4, newSViv(nick->gone), 0);
 431         hv_store(hv, "serverop", 8, newSViv(nick->serverop), 0);
 432
 433         hv_store(hv, "op", 2, newSViv(nick->op), 0);
 434         hv_store(hv, "halfop", 6, newSViv(nick->halfop), 0);
 435         hv_store(hv, "voice", 5, newSViv(nick->voice), 0);
 436         hv_store(hv, "other", 5, newSViv(nick->prefixes[0]), 0);
 437         hv_store(hv, "prefixes", 8, new_pv(nick->prefixes), 0);
 438
 439         hv_store(hv, "last_check", 10, newSViv(nick->last_check), 0);
 440         hv_store(hv, "send_massjoin", 13, newSViv(nick->send_massjoin), 0);
 441 }
 442
 443 static void perl_command_fill_hash(HV *hv, COMMAND_REC *cmd)
 444 {
 445         hv_store(hv, "category", 8, new_pv(cmd->category), 0);
 446         hv_store(hv, "cmd", 3, new_pv(cmd->cmd), 0);
 447 }
 448
 449 static void perl_ignore_fill_hash(HV *hv, IGNORE_REC *ignore)
 450 {
 451         AV *av;
 452         char **tmp;
 453
 454         hv_store(hv, "mask", 4, new_pv(ignore->mask), 0);
 455         hv_store(hv, "servertag", 9, new_pv(ignore->servertag), 0);
 456         av = newAV();
 457         if (ignore->channels != NULL) {
 458                 for (tmp = ignore->channels; *tmp != NULL; tmp++) {
 459                         av_push(av, new_pv(*tmp));
 460                 }
 461         }
 462         hv_store(hv, "channels", 8, newRV_noinc((SV*)av), 0);
 463         hv_store(hv, "pattern", 7, new_pv(ignore->pattern), 0);
 464
 465         hv_store(hv, "level", 5, newSViv(ignore->level), 0);
 466
 467         hv_store(hv, "exception", 9, newSViv(ignore->exception), 0);
 468         hv_store(hv, "regexp", 6, newSViv(ignore->regexp), 0);
 469         hv_store(hv, "fullword", 8, newSViv(ignore->fullword), 0);
 470 }
 471
 472 static void perl_log_fill_hash(HV *hv, LOG_REC *log)
 473 {
 474         AV *av;
 475         GSList *tmp;
 476
 477         hv_store(hv, "fname", 5, new_pv(log->fname), 0);
 478         hv_store(hv, "real_fname", 10, new_pv(log->real_fname), 0);
 479         hv_store(hv, "opened", 6, newSViv(log->opened), 0);
 480         hv_store(hv, "level", 5, newSViv(log->level), 0);
 481         hv_store(hv, "last", 4, newSViv(log->last), 0);
 482         hv_store(hv, "autoopen", 8, newSViv(log->autoopen), 0);
 483         hv_store(hv, "failed", 6, newSViv(log->failed), 0);
 484         hv_store(hv, "temp", 4, newSViv(log->temp), 0);
 485
 486         av = newAV();
 487         for (tmp = log->items; tmp != NULL; tmp = tmp->next) {
 488                 av_push(av, plain_bless(tmp->data, "Irssi::Logitem"));
 489         }
 490         hv_store(hv, "items", 5, newRV_noinc((SV*)av), 0);
 491 }
 492
 493 static void perl_log_item_fill_hash(HV *hv, LOG_ITEM_REC *item)
 494 {
 495         hv_store(hv, "type", 4, newSViv(item->type), 0);
 496         hv_store(hv, "name", 4, new_pv(item->name), 0);
 497         hv_store(hv, "servertag", 9, new_pv(item->servertag), 0);
 498 }
 499
 500 static void perl_rawlog_fill_hash(HV *hv, RAWLOG_REC *rawlog)
 501 {
 502         hv_store(hv, "logging", 7, newSViv(rawlog->logging), 0);
 503         hv_store(hv, "nlines", 6, newSViv(rawlog->nlines), 0);
 504 }
 505
 506 static void perl_reconnect_fill_hash(HV *hv, RECONNECT_REC *reconnect)
 507 {
 508         char *type;
 509
 510         perl_connect_fill_hash(hv, reconnect->conn);
 511
 512         type = "RECONNECT";
 513         hv_store(hv, "type", 4, new_pv(type), 0);
 514
 515         hv_store(hv, "tag", 3, newSViv(reconnect->tag), 0);
 516         hv_store(hv, "next_connect", 12, newSViv(reconnect->next_connect), 0);
 517 }
 518
 519 static void perl_script_fill_hash(HV *hv, PERL_SCRIPT_REC *script)
 520 {
 521         hv_store(hv, "name", 4, new_pv(script->name), 0);
 522         hv_store(hv, "package", 7, new_pv(script->package), 0);
 523         hv_store(hv, "path", 4, new_pv(script->path), 0);
 524         hv_store(hv, "data", 4, new_pv(script->data), 0);
 525 }
 526
 527 static void remove_newlines(char *str)
 528 {
 529         char *writing = str;
 530
 531         for (;*str;str++)
 532                 if (*str != '\n' && *str != '\r')
 533                         *(writing++) = *str;
 534         *writing = '\0';
 535 }
 536
 537 void perl_command(const char *cmd, SERVER_REC *server, WI_ITEM_REC *item)
 538 {
 539         const char *cmdchars;
 540         char *sendcmd = (char *) cmd;
 541
 542         if (*cmd == '\0')
 543                 return;
 544
 545         cmdchars = settings_get_str("cmdchars");
 546         if (strchr(cmdchars, *cmd) == NULL) {
 547                 /* no command char - let's put it there.. */
 548                 sendcmd = g_strdup_printf("%c%s", *cmdchars, cmd);
 549         }
 550
 551         /* remove \r and \n from commands,
 552            to make it harder to introduce a security bug in a script */
 553         if(strpbrk(sendcmd, "\r\n")) {
 554                 if (sendcmd == cmd)
 555                         sendcmd = strdup(cmd);
 556                 remove_newlines(sendcmd);
 557         }
 558
 559         signal_emit("send command", 3, sendcmd, server, item);
 560         if (sendcmd != cmd) g_free(sendcmd);
 561 }
 562
 563 static void perl_register_protocol(CHAT_PROTOCOL_REC *rec)
 564 {
 565         static char *items[] = {
 566                 "Chatnet",
 567                 "Server", "ServerConnect", "ServerSetup",
 568                 "Channel", "Query",
 569                 "Nick"
 570         };
 571         static char *find_use_code =
 572                 "use lib qw(%s);\n"
 573                 "my $pkg = Irssi::%s; $pkg =~ s/::/\\//;\n"
 574                 "foreach my $i (@INC) {\n"
 575                 "  return 1 if (-f \"$i/$pkg.pm\");\n"
 576                 "}\n"
 577                 "return 0;\n";
 578
 579         char *name, stash[100], code[100], *pcode;
 580         int type, chat_type, n;
 581         SV *sv;
 582
 583         chat_type = chat_protocol_lookup(rec->name);
 584         g_return_if_fail(chat_type >= 0);
 585
 586         name = g_ascii_strdown(rec->name,-1);
 587         *name = *(rec->name);
 588
 589         /* window items: channel, query */
 590         type = module_get_uniq_id_str("WINDOW ITEM TYPE", "CHANNEL");
 591         g_snprintf(stash, sizeof(stash), "Irssi::%s::Channel", name);
 592         irssi_add_object(type, chat_type, stash,
 593                          (PERL_OBJECT_FUNC) perl_channel_fill_hash);
 594
 595         type = module_get_uniq_id_str("WINDOW ITEM TYPE", "QUERY");
 596         g_snprintf(stash, sizeof(stash), "Irssi::%s::Query", name);
 597         irssi_add_object(type, chat_type, stash,
 598                          (PERL_OBJECT_FUNC) perl_query_fill_hash);
 599
 600         /* channel nicks */
 601         type = module_get_uniq_id("NICK", 0);
 602         g_snprintf(stash, sizeof(stash), "Irssi::%s::Nick", name);
 603         irssi_add_object(type, chat_type, stash,
 604                          (PERL_OBJECT_FUNC) perl_nick_fill_hash);
 605
 606         /* chatnets */
 607         type = module_get_uniq_id("CHATNET", 0);
 608         g_snprintf(stash, sizeof(stash), "Irssi::%s::Chatnet", name);
 609         irssi_add_object(type, chat_type, stash,
 610                          (PERL_OBJECT_FUNC) perl_chatnet_fill_hash);
 611
 612         /* server specific */
 613         type = module_get_uniq_id("SERVER", 0);
 614         g_snprintf(stash, sizeof(stash), "Irssi::%s::Server", name);
 615         irssi_add_object(type, chat_type, stash,
 616                          (PERL_OBJECT_FUNC) perl_server_fill_hash);
 617
 618         type = module_get_uniq_id("SERVER CONNECT", 0);
 619         g_snprintf(stash, sizeof(stash), "Irssi::%s::Connect", name);
 620         irssi_add_object(type, chat_type, stash,
 621                          (PERL_OBJECT_FUNC) perl_connect_fill_hash);
 622
 623         /* register ISAs */
 624         for (n = 0; n < sizeof(items)/sizeof(items[0]); n++) {
 625                 g_snprintf(code, sizeof(code),
 626                            "@Irssi::%s::%s::ISA = qw(Irssi::%s);",
 627                            name, items[n], items[n]);
 628                 perl_eval_pv(code, TRUE);
 629         }
 630
 631         pcode = g_strdup_printf(find_use_code,
 632                                 settings_get_str("perl_use_lib"), name);
 633         sv = perl_eval_pv(pcode, TRUE);
 634         g_free(pcode);
 635
 636         if (SvIV(sv)) {
 637                 use_protocols =
 638                         g_slist_append(use_protocols, g_strdup(name));
 639         }
 640
 641         g_free(name);
 642 }
 643
 644 static void free_iobject_hash(void *key, PERL_OBJECT_REC *rec)
 645 {
 646         g_free(rec->stash);
 647         g_free(rec);
 648 }
 649
 650 static int free_iobject_proto(void *key, void *value, void *chat_type)
 651 {
 652         if ((GPOINTER_TO_INT(key) >> 16) == GPOINTER_TO_INT(chat_type)) {
 653                 free_iobject_hash(key, value);
 654                 return TRUE;
 655         }
 656
 657         return FALSE;
 658 }
 659
 660 static void perl_unregister_protocol(CHAT_PROTOCOL_REC *rec)
 661 {
 662         GSList *item;
 663         void *data;
 664
 665         item = gslist_find_icase_string(use_protocols, rec->name);
 666         if (item != NULL) {
 667                 data = item->data;
 668                 use_protocols = g_slist_remove(use_protocols, data);
 669                 g_free(data);
 670         }
 671         g_hash_table_foreach_remove(iobject_stashes,
 672                                     (GHRFunc) free_iobject_proto,
 673                                     GINT_TO_POINTER(rec->id));
 674 }
 675
 676 void perl_common_start(void)
 677 {
 678         static PLAIN_OBJECT_INIT_REC core_plains[] = {
 679                 { "Irssi::Command", (PERL_OBJECT_FUNC) perl_command_fill_hash },
 680                 { "Irssi::Ignore", (PERL_OBJECT_FUNC) perl_ignore_fill_hash },
 681                 { "Irssi::Log", (PERL_OBJECT_FUNC) perl_log_fill_hash },
 682                 { "Irssi::Logitem", (PERL_OBJECT_FUNC) perl_log_item_fill_hash },
 683                 { "Irssi::Rawlog", (PERL_OBJECT_FUNC) perl_rawlog_fill_hash },
 684                 { "Irssi::Reconnect", (PERL_OBJECT_FUNC) perl_reconnect_fill_hash },
 685                 { "Irssi::Script", (PERL_OBJECT_FUNC) perl_script_fill_hash },
 686
 687                 { NULL, NULL }
 688         };
 689
 690         iobject_stashes = g_hash_table_new((GHashFunc) g_direct_hash,
 691                                         (GCompareFunc) g_direct_equal);
 692         plain_stashes = g_hash_table_new((GHashFunc) g_str_hash,
 693                                          (GCompareFunc) g_str_equal);
 694         irssi_add_plains(core_plains);
 695
 696         use_protocols = NULL;
 697         g_slist_foreach(chat_protocols, (GFunc) perl_register_protocol, NULL);
 698
 699         signal_add("chat protocol created", (SIGNAL_FUNC) perl_register_protocol);
 700         signal_add("chat protocol destroyed", (SIGNAL_FUNC) perl_unregister_protocol);
 701 }
 702
 703 void perl_common_stop(void)
 704 {
 705         g_hash_table_foreach(iobject_stashes, (GHFunc) free_iobject_hash, NULL);
 706         g_hash_table_destroy(iobject_stashes);
 707         iobject_stashes = NULL;
 708
 709         g_hash_table_foreach(plain_stashes, (GHFunc) g_free, NULL);
 710         g_hash_table_destroy(plain_stashes);
 711         plain_stashes = NULL;
 712
 713         g_slist_foreach(use_protocols, (GFunc) g_free, NULL);
 714         g_slist_free(use_protocols);
 715         use_protocols = NULL;
 716
 717         signal_remove("chat protocol created", (SIGNAL_FUNC) perl_register_protocol);
 718         signal_remove("chat protocol destroyed", (SIGNAL_FUNC) perl_unregister_protocol);
 719 }