Mercurial > pidgin3 / file comparison

comparison: libpurple/plugins/tcl/tcl.c

libpurple/plugins/tcl/tcl.c

changeset 37581
1fb661b5f206
parent 37580
498763742ea4
child 37582
ca3533cdddc7
equal deleted inserted replaced
37580:498763742ea4 37581:1fb661b5f206
1 /**
2 * @file tcl.c Purple Tcl plugin bindings
3 *
4 * purple
5 *
6 * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu>
7 *
8 * This program is free software; you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation; either version 2 of the License, or
11 * (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program; if not, write to the Free Software
20 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301 USA
21 */
22
23 #include "config.h"
24
25 #include <tcl.h>
26
27 #ifdef HAVE_TK
28 #include <tk.h>
29 #endif
30
31 #include <stdio.h>
32 #include <sys/types.h>
33 #include <unistd.h>
34 #include <string.h>
35
36 #include "tcl_glib.h"
37 #include "tcl_purple.h"
38
39 #include "internal.h"
40 #include "connection.h"
41 #include "plugins.h"
42 #include "signals.h"
43 #include "debug.h"
44 #include "util.h"
45 #include "version.h"
46
47 struct tcl_plugin_data {
48 PurplePlugin *plugin;
49 Tcl_Interp *interp;
50 };
51
52 typedef struct {
53 char *id;
54 char *name;
55 char *version;
56 char *summary;
57 char *description;
58 char *author;
59 char *homepage;
60 } tcl_plugin_info_strings;
61
62 PurpleStringref *PurpleTclRefAccount;
63 PurpleStringref *PurpleTclRefConnection;
64 PurpleStringref *PurpleTclRefConversation;
65 PurpleStringref *PurpleTclRefPointer;
66 PurpleStringref *PurpleTclRefPlugin;
67 PurpleStringref *PurpleTclRefPresence;
68 PurpleStringref *PurpleTclRefStatus;
69 PurpleStringref *PurpleTclRefStatusAttr;
70 PurpleStringref *PurpleTclRefStatusType;
71 PurpleStringref *PurpleTclRefXfer;
72 PurpleStringref *PurpleTclRefHandle;
73
74 static GHashTable *tcl_plugins = NULL;
75
76 PurplePlugin *_tcl_plugin;
77
78 static gboolean tcl_loaded = FALSE;
79
80 static void tcl_plugin_info_strings_free(tcl_plugin_info_strings *strings)
81 {
82 if (strings == NULL)
83 return;
84
85 g_free(strings->id);
86 g_free(strings->name);
87 g_free(strings->version);
88 g_free(strings->summary);
89 g_free(strings->description);
90 g_free(strings->author);
91 g_free(strings->homepage);
92 g_free(strings);
93 }
94
95 PurplePlugin *tcl_interp_get_plugin(Tcl_Interp *interp)
96 {
97 struct tcl_plugin_data *data;
98
99 if (tcl_plugins == NULL)
100 return NULL;
101
102 data = g_hash_table_lookup(tcl_plugins, (gpointer)interp);
103 return data != NULL ? data->plugin : NULL;
104 }
105
106 static int tcl_init_interp(Tcl_Interp *interp)
107 {
108 char *rcfile;
109 char init[] =
110 "namespace eval ::purple {\n"
111 " namespace export account buddy connection conversation\n"
112 " namespace export core debug notify prefs send_im\n"
113 " namespace export signal unload\n"
114 " namespace eval _callback { }\n"
115 "\n"
116 " proc conv_send { account who text } {\n"
117 " set gc [purple::account connection $account]\n"
118 " set convo [purple::conversation new $account $who]\n"
119 " set myalias [purple::account alias $account]\n"
120 "\n"
121 " if {![string length $myalias]} {\n"
122 " set myalias [purple::account username $account]\n"
123 " }\n"
124 "\n"
125 " purple::send_im $gc $who $text\n"
126 " purple::conversation write $convo send $myalias $text\n"
127 " }\n"
128 "}\n"
129 "\n"
130 "proc bgerror { message } {\n"
131 " global errorInfo\n"
132 " purple::notify -error \"Tcl Error\" \"Tcl Error: $message\" \"$errorInfo\"\n"
133 "}\n";
134
135 if (Tcl_EvalEx(interp, init, -1, TCL_EVAL_GLOBAL) != TCL_OK) {
136 return 1;
137 }
138
139 Tcl_SetVar(interp, "argc", "0", TCL_GLOBAL_ONLY);
140 Tcl_SetVar(interp, "argv0", "purple", TCL_GLOBAL_ONLY);
141 Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
142 rcfile = g_strdup_printf("%s" G_DIR_SEPARATOR_S "tclrc", purple_user_dir());
143 Tcl_SetVar(interp, "tcl_rcFileName", rcfile, TCL_GLOBAL_ONLY);
144 g_free(rcfile);
145
146 Tcl_SetVar(interp, "::purple::version", VERSION, TCL_GLOBAL_ONLY);
147 Tcl_SetVar(interp, "::purple::user_dir", purple_user_dir(), TCL_GLOBAL_ONLY);
148 #ifdef HAVE_TK
149 Tcl_SetVar(interp, "::purple::tk_available", "1", TCL_GLOBAL_ONLY);
150 #else
151 Tcl_SetVar(interp, "::purple::tk_available", "0", TCL_GLOBAL_ONLY);
152 #endif /* HAVE_TK */
153
154 Tcl_CreateObjCommand(interp, "::purple::account", tcl_cmd_account, (ClientData)NULL, NULL);
155 Tcl_CreateObjCommand(interp, "::purple::buddy", tcl_cmd_buddy, (ClientData)NULL, NULL);
156 Tcl_CreateObjCommand(interp, "::purple::cmd", tcl_cmd_cmd, (ClientData)NULL, NULL);
157 Tcl_CreateObjCommand(interp, "::purple::connection", tcl_cmd_connection, (ClientData)NULL, NULL);
158 Tcl_CreateObjCommand(interp, "::purple::conversation", tcl_cmd_conversation, (ClientData)NULL, NULL);
159 Tcl_CreateObjCommand(interp, "::purple::core", tcl_cmd_core, (ClientData)NULL, NULL);
160 Tcl_CreateObjCommand(interp, "::purple::debug", tcl_cmd_debug, (ClientData)NULL, NULL);
161 Tcl_CreateObjCommand(interp, "::purple::notify", tcl_cmd_notify, (ClientData)NULL, NULL);
162 Tcl_CreateObjCommand(interp, "::purple::plugins", tcl_cmd_plugins, (ClientData)NULL, NULL);
163 Tcl_CreateObjCommand(interp, "::purple::prefs", tcl_cmd_prefs, (ClientData)NULL, NULL);
164 Tcl_CreateObjCommand(interp, "::purple::presence", tcl_cmd_presence, (ClientData)NULL, NULL);
165 Tcl_CreateObjCommand(interp, "::purple::send_im", tcl_cmd_send_im, (ClientData)NULL, NULL);
166 Tcl_CreateObjCommand(interp, "::purple::savedstatus", tcl_cmd_savedstatus, (ClientData)NULL, NULL);
167 Tcl_CreateObjCommand(interp, "::purple::signal", tcl_cmd_signal, (ClientData)NULL, NULL);
168 Tcl_CreateObjCommand(interp, "::purple::status", tcl_cmd_status, (ClientData)NULL, NULL);
169 Tcl_CreateObjCommand(interp, "::purple::status_attr", tcl_cmd_status_attr, (ClientData)NULL, NULL);
170 Tcl_CreateObjCommand(interp, "::purple::status_type", tcl_cmd_status_type, (ClientData)NULL, NULL);
171 Tcl_CreateObjCommand(interp, "::purple::unload", tcl_cmd_unload, (ClientData)NULL, NULL);
172
173 return 0;
174 }
175
176 static Tcl_Interp *tcl_create_interp(void)
177 {
178 Tcl_Interp *interp;
179
180 interp = Tcl_CreateInterp();
181 if (Tcl_Init(interp) == TCL_ERROR) {
182 Tcl_DeleteInterp(interp);
183 return NULL;
184 }
185
186 if (tcl_init_interp(interp)) {
187 Tcl_DeleteInterp(interp);
188 return NULL;
189 }
190 Tcl_StaticPackage(interp, "purple", tcl_init_interp, NULL);
191
192 return interp;
193 }
194
195 static gboolean tcl_probe_plugin(PurplePlugin *plugin)
196 {
197 PurplePluginInfo *info;
198 Tcl_Interp *interp;
199 Tcl_Parse parse;
200 Tcl_Obj *result, **listitems;
201 char *buf;
202 const char *next;
203 int found = 0, err = 0, nelems;
204 gsize len;
205 gboolean status = FALSE;
206
207 if (!g_file_get_contents(plugin->path, &buf, &len, NULL)) {
208 purple_debug(PURPLE_DEBUG_INFO, "tcl", "Error opening plugin %s\n",
209 plugin->path);
210 return FALSE;
211 }
212
213 if ((interp = tcl_create_interp()) == NULL) {
214 return FALSE;
215 }
216
217 next = buf;
218 do {
219 if (Tcl_ParseCommand(interp, next, len, 0, &parse) == TCL_ERROR) {
220 purple_debug(PURPLE_DEBUG_ERROR, "tcl", "parse error in %s: %s\n", plugin->path,
221 Tcl_GetString(Tcl_GetObjResult(interp)));
222 err = 1;
223 break;
224 }
225 if (parse.tokenPtr[0].type == TCL_TOKEN_SIMPLE_WORD
226 && !strncmp(parse.tokenPtr[0].start, "proc", parse.tokenPtr[0].size)) {
227 if (!strncmp(parse.tokenPtr[2].start, "plugin_init", parse.tokenPtr[2].size)) {
228 if (Tcl_EvalEx(interp, parse.commandStart, parse.commandSize, TCL_EVAL_GLOBAL) != TCL_OK) {
229 Tcl_FreeParse(&parse);
230 break;
231 }
232 found = 1;
233 /* We'll continue parsing the file, just in case */
234 }
235 }
236 len -= (parse.commandStart + parse.commandSize) - next;
237 next = parse.commandStart + parse.commandSize;
238 Tcl_FreeParse(&parse);
239 } while (len);
240
241 if (found && !err) {
242 if (Tcl_EvalEx(interp, "plugin_init", -1, TCL_EVAL_GLOBAL) == TCL_OK) {
243 result = Tcl_GetObjResult(interp);
244 if (Tcl_ListObjGetElements(interp, result, &nelems, &listitems) == TCL_OK) {
245 if ((nelems == 6) || (nelems == 7)) {
246 tcl_plugin_info_strings *strings = g_new0(tcl_plugin_info_strings, 1);
247 info = g_new0(PurplePluginInfo, 1);
248 info->extra_info = strings;
249
250 info->magic = PURPLE_PLUGIN_MAGIC;
251 info->major_version = PURPLE_MAJOR_VERSION;
252 info->minor_version = PURPLE_MINOR_VERSION;
253 info->type = PURPLE_PLUGIN_STANDARD;
254 info->dependencies = g_list_append(info->dependencies, "core-tcl");
255
256 info->name = strings->name = g_strdup(Tcl_GetString(listitems[0]));
257 info->version = strings->version = g_strdup(Tcl_GetString(listitems[1]));
258 info->summary = strings->summary = g_strdup(Tcl_GetString(listitems[2]));
259 info->description = strings->description = g_strdup(Tcl_GetString(listitems[3]));
260 info->author = strings->author = g_strdup(Tcl_GetString(listitems[4]));
261 info->homepage = strings->homepage = g_strdup(Tcl_GetString(listitems[5]));
262
263 if (nelems == 6)
264 info->id = strings->id = g_strdup_printf("tcl-%s", Tcl_GetString(listitems[0]));
265 else if (nelems == 7)
266 info->id = strings->id = g_strdup_printf("tcl-%s", Tcl_GetString(listitems[6]));
267
268 plugin->info = info;
269
270 if (purple_plugin_register(plugin))
271 status = TRUE;
272 }
273 }
274 }
275 }
276
277 Tcl_DeleteInterp(interp);
278 g_free(buf);
279 return status;
280 }
281
282 static gboolean tcl_load_plugin(PurplePlugin *plugin)
283 {
284 struct tcl_plugin_data *data;
285 Tcl_Interp *interp;
286 Tcl_Obj *result;
287
288 plugin->extra = NULL;
289
290 if ((interp = tcl_create_interp()) == NULL) {
291 purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Could not initialize Tcl interpreter\n");
292 return FALSE;
293 }
294
295 Tcl_SourceRCFile(interp);
296
297 if (Tcl_EvalFile(interp, plugin->path) != TCL_OK) {
298 result = Tcl_GetObjResult(interp);
299 purple_debug(PURPLE_DEBUG_ERROR, "tcl",
300 "Error evaluating %s: %s\n", plugin->path,
301 Tcl_GetString(result));
302 Tcl_DeleteInterp(interp);
303 return FALSE;
304 }
305
306 Tcl_Preserve((ClientData)interp);
307
308 data = g_new0(struct tcl_plugin_data, 1);
309 data->plugin = plugin;
310 data->interp = interp;
311 plugin->extra = data;
312
313 g_hash_table_insert(tcl_plugins, (gpointer)interp, (gpointer)data);
314
315 return TRUE;
316 }
317
318 static gboolean tcl_unload_plugin(PurplePlugin *plugin)
319 {
320 struct tcl_plugin_data *data;
321
322 if (plugin == NULL)
323 return TRUE;
324
325 data = plugin->extra;
326
327 if (data != NULL) {
328 g_hash_table_remove(tcl_plugins, (gpointer)(data->interp));
329 purple_signals_disconnect_by_handle(data->interp);
330 tcl_cmd_cleanup(data->interp);
331 tcl_signal_cleanup(data->interp);
332 Tcl_Release((ClientData)data->interp);
333 Tcl_DeleteInterp(data->interp);
334 g_free(data);
335 }
336
337 return TRUE;
338 }
339
340 static void tcl_destroy_plugin(PurplePlugin *plugin)
341 {
342 if (plugin->info != NULL) {
343 tcl_plugin_info_strings *info_strings = plugin->info->extra_info;
344 tcl_plugin_info_strings_free(info_strings);
345 plugin->info->extra_info = NULL;
346 }
347
348 return;
349 }
350
351 static PurplePluginLoaderInfo tcl_loader_info =
352 {
353 tcl_probe_plugin,
354 tcl_load_plugin,
355 tcl_unload_plugin,
356 tcl_destroy_plugin,
357 };
358
359 static GPluginPluginInfo *
360 tcl_query(GError **error)
361 {
362 const gchar * const authors[] = {
363 "Ethan Blanton <eblanton@cs.purdue.edu>",
364 NULL
365 };
366
367 return gplugin_plugin_info_new(
368 "id", "core-tcl",
369 "name", N_("Tcl Plugin Loader"),
370 "version", DISPLAY_VERSION,
371 "category", N_("Loader"),
372 "summary", N_("Provides support for loading Tcl plugins"),
373 "description", N_("Provides support for loading Tcl plugins"),
374 "authors", authors,
375 "website", PURPLE_WEBSITE,
376 "abi-version", PURPLE_ABI_VERSION,
377 "internal", TRUE,
378 "load-on-query", TRUE,
379 NULL
380 );
381 }
382
383 static gboolean tcl_load(PurplePlugin *plugin, GError **error)
384 {
385 if(!tcl_loaded)
386 return FALSE;
387 tcl_glib_init();
388 tcl_cmd_init();
389 tcl_signal_init();
390 purple_tcl_ref_init();
391
392 PurpleTclRefAccount = purple_stringref_new("Account");
393 PurpleTclRefConnection = purple_stringref_new("Connection");
394 PurpleTclRefConversation = purple_stringref_new("Conversation");
395 PurpleTclRefPointer = purple_stringref_new("Pointer");
396 PurpleTclRefPlugin = purple_stringref_new("Plugin");
397 PurpleTclRefPresence = purple_stringref_new("Presence");
398 PurpleTclRefStatus = purple_stringref_new("Status");
399 PurpleTclRefStatusAttr = purple_stringref_new("StatusAttr");
400 PurpleTclRefStatusType = purple_stringref_new("StatusType");
401 PurpleTclRefXfer = purple_stringref_new("Xfer");
402 PurpleTclRefHandle = purple_stringref_new("Handle");
403
404 tcl_plugins = g_hash_table_new(g_direct_hash, g_direct_equal);
405
406 #ifdef HAVE_TK
407 Tcl_StaticPackage(NULL, "Tk", Tk_Init, Tk_SafeInit);
408 #endif /* HAVE_TK */
409
410 return TRUE;
411 }
412
413 static gboolean tcl_unload(PurplePlugin *plugin, GError **error)
414 {
415 g_hash_table_destroy(tcl_plugins);
416 tcl_plugins = NULL;
417
418 purple_stringref_unref(PurpleTclRefAccount);
419 purple_stringref_unref(PurpleTclRefConnection);
420 purple_stringref_unref(PurpleTclRefConversation);
421 purple_stringref_unref(PurpleTclRefPointer);
422 purple_stringref_unref(PurpleTclRefPlugin);
423 purple_stringref_unref(PurpleTclRefPresence);
424 purple_stringref_unref(PurpleTclRefStatus);
425 purple_stringref_unref(PurpleTclRefStatusAttr);
426 purple_stringref_unref(PurpleTclRefStatusType);
427 purple_stringref_unref(PurpleTclRefXfer);
428
429 return TRUE;
430 }
431
432 #ifdef _WIN32
433 typedef Tcl_Interp* (__cdecl* LPFNTCLCREATEINTERP)(void);
434 typedef void (__cdecl* LPFNTKINIT)(Tcl_Interp*);
435
436 LPFNTCLCREATEINTERP wtcl_CreateInterp = NULL;
437 LPFNTKINIT wtk_Init = NULL;
438 #undef Tcl_CreateInterp
439 #define Tcl_CreateInterp wtcl_CreateInterp
440 #undef Tk_Init
441 #define Tk_Init wtk_Init
442
443 static gboolean tcl_win32_init() {
444 gboolean retval = FALSE;
445
446 if(!(wtcl_CreateInterp = (LPFNTCLCREATEINTERP) wpurple_find_and_loadproc("tcl85.dll", "Tcl_CreateInterp"))) {
447 purple_debug(PURPLE_DEBUG_INFO, "tcl", "tcl_win32_init error loading Tcl_CreateInterp\n");
448 } else {
449 if(!(wtk_Init = (LPFNTKINIT) wpurple_find_and_loadproc("tk85.dll", "Tk_Init"))) {
450 HMODULE mod;
451 purple_debug(PURPLE_DEBUG_INFO, "tcl", "tcl_win32_init error loading Tk_Init\n");
452 if((mod = GetModuleHandle("tcl85.dll")))
453 FreeLibrary(mod);
454 } else {
455 retval = TRUE;
456 }
457 }
458
459 return retval;
460 }
461
462 #endif /* _WIN32 */
463
464 static void tcl_init_plugin(PurplePlugin *plugin)
465 {
466 #ifdef USE_TCL_STUBS
467 Tcl_Interp *interp = NULL;
468 #endif
469 _tcl_plugin = plugin;
470
471 #ifdef USE_TCL_STUBS
472 #ifdef _WIN32
473 if(!tcl_win32_init())
474 return;
475 #endif
476 if(!(interp = Tcl_CreateInterp()))
477 return;
478
479 if(!Tcl_InitStubs(interp, TCL_VERSION, 0)) {
480 purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Tcl_InitStubs: %s\n", interp->result);
481 return;
482 }
483 #endif
484
485 Tcl_FindExecutable("purple");
486
487 #if defined(USE_TK_STUBS) && defined(HAVE_TK)
488 Tk_Init(interp);
489
490 if(!Tk_InitStubs(interp, TK_VERSION, 0)) {
491 purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Error Tk_InitStubs: %s\n", interp->result);
492 Tcl_DeleteInterp(interp);
493 return;
494 }
495 #endif
496 tcl_loaded = TRUE;
497 #ifdef USE_TCL_STUBS
498 Tcl_DeleteInterp(interp);
499 #endif
500 tcl_loader_info.exts = g_list_append(tcl_loader_info.exts, "tcl");
501 }
502
503 PURPLE_PLUGIN_INIT(tcl, tcl_query, tcl_load, tcl_unload);

Mercurial Repository: pidgin3

mercurial