* @file tcl.c Purple Tcl plugin bindings * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu> * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301 USA PurpleStringref * PurpleTclRefAccount ; PurpleStringref * PurpleTclRefConnection ; PurpleStringref * PurpleTclRefConversation ; PurpleStringref * PurpleTclRefPointer ; PurpleStringref * PurpleTclRefPlugin ; PurpleStringref * PurpleTclRefPresence ; PurpleStringref * PurpleTclRefStatus ; PurpleStringref * PurpleTclRefStatusAttr ; PurpleStringref * PurpleTclRefStatusType ; PurpleStringref * PurpleTclRefXfer ; PurpleStringref * PurpleTclRefHandle ; static GHashTable * tcl_plugins = NULL ; PurplePlugin * _tcl_plugin ; static gboolean tcl_loaded = FALSE ; PurplePlugin * tcl_interp_get_plugin ( Tcl_Interp * interp ) struct tcl_plugin_data * data ; data = g_hash_table_lookup ( tcl_plugins , ( gpointer ) interp ); return data != NULL ? data -> plugin : NULL ; static int tcl_init_interp ( Tcl_Interp * interp ) "namespace eval ::purple { \n " " namespace export account buddy connection conversation \n " " namespace export core debug notify prefs send_im \n " " namespace export signal unload \n " " namespace eval _callback { } \n " " proc conv_send { account who text } { \n " " set gc [purple::account connection $account] \n " " set convo [purple::conversation new $account $who] \n " " set myalias [purple::account alias $account] \n " " if {![string length $myalias]} { \n " " set myalias [purple::account username $account] \n " " purple::send_im $gc $who $text \n " " purple::conversation write $convo send $myalias $text \n " "proc bgerror { message } { \n " " purple::notify -error \" Tcl Error \" \" Tcl Error: $message \" \" $errorInfo \"\n " if ( Tcl_EvalEx ( interp , init , -1 , TCL_EVAL_GLOBAL ) != TCL_OK ) { Tcl_SetVar ( interp , "argc" , "0" , TCL_GLOBAL_ONLY ); Tcl_SetVar ( interp , "argv0" , "purple" , TCL_GLOBAL_ONLY ); Tcl_SetVar ( interp , "tcl_interactive" , "0" , TCL_GLOBAL_ONLY ); rcfile = g_strdup_printf ( "%s" G_DIR_SEPARATOR_S "tclrc" , purple_user_dir ()); Tcl_SetVar ( interp , "tcl_rcFileName" , rcfile , TCL_GLOBAL_ONLY ); Tcl_SetVar ( interp , "::purple::version" , VERSION , TCL_GLOBAL_ONLY ); Tcl_SetVar ( interp , "::purple::user_dir" , purple_user_dir (), TCL_GLOBAL_ONLY ); Tcl_SetVar ( interp , "::purple::tk_available" , "1" , TCL_GLOBAL_ONLY ); Tcl_SetVar ( interp , "::purple::tk_available" , "0" , TCL_GLOBAL_ONLY ); Tcl_CreateObjCommand ( interp , "::purple::account" , tcl_cmd_account , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::buddy" , tcl_cmd_buddy , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::cmd" , tcl_cmd_cmd , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::connection" , tcl_cmd_connection , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::conversation" , tcl_cmd_conversation , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::core" , tcl_cmd_core , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::debug" , tcl_cmd_debug , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::notify" , tcl_cmd_notify , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::plugins" , tcl_cmd_plugins , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::prefs" , tcl_cmd_prefs , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::presence" , tcl_cmd_presence , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::send_im" , tcl_cmd_send_im , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::savedstatus" , tcl_cmd_savedstatus , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::signal" , tcl_cmd_signal , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::status" , tcl_cmd_status , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::status_attr" , tcl_cmd_status_attr , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::status_type" , tcl_cmd_status_type , ( ClientData ) NULL , NULL ); Tcl_CreateObjCommand ( interp , "::purple::unload" , tcl_cmd_unload , ( ClientData ) NULL , NULL ); static Tcl_Interp * tcl_create_interp ( void ) interp = Tcl_CreateInterp (); if ( Tcl_Init ( interp ) == TCL_ERROR ) { Tcl_DeleteInterp ( interp ); if ( tcl_init_interp ( interp )) { Tcl_DeleteInterp ( interp ); Tcl_StaticPackage ( interp , "purple" , tcl_init_interp , NULL ); static gboolean tcl_probe_plugin ( PurplePlugin * plugin ) Tcl_Obj * result , ** listitems ; int found = 0 , err = 0 , nelems ; if ( ! g_file_get_contents ( plugin -> path , & buf , & len , NULL )) { purple_debug ( PURPLE_DEBUG_INFO , "tcl" , "Error opening plugin %s \n " , if (( interp = tcl_create_interp ()) == NULL ) { if ( Tcl_ParseCommand ( interp , next , len , 0 , & parse ) == TCL_ERROR ) { purple_debug ( PURPLE_DEBUG_ERROR , "tcl" , "parse error in %s: %s \n " , plugin -> path , Tcl_GetString ( Tcl_GetObjResult ( interp ))); if ( parse . tokenPtr [ 0 ]. type == TCL_TOKEN_SIMPLE_WORD && ! strncmp ( parse . tokenPtr [ 0 ]. start , "proc" , parse . tokenPtr [ 0 ]. size )) { if ( ! strncmp ( parse . tokenPtr [ 2 ]. start , "plugin_init" , parse . tokenPtr [ 2 ]. size )) { if ( Tcl_EvalEx ( interp , parse . commandStart , parse . commandSize , TCL_EVAL_GLOBAL ) != TCL_OK ) { /* We'll continue parsing the file, just in case */ len -= ( parse . commandStart + parse . commandSize ) - next ; next = parse . commandStart + parse . commandSize ; if ( Tcl_EvalEx ( interp , "plugin_init" , -1 , TCL_EVAL_GLOBAL ) == TCL_OK ) { result = Tcl_GetObjResult ( interp ); if ( Tcl_ListObjGetElements ( interp , result , & nelems , & listitems ) == TCL_OK ) { if (( nelems == 6 ) || ( nelems == 7 )) { info = g_new0 ( PurplePluginInfo , 1 ); info -> magic = PURPLE_PLUGIN_MAGIC ; info -> major_version = PURPLE_MAJOR_VERSION ; info -> minor_version = PURPLE_MINOR_VERSION ; info -> type = PURPLE_PLUGIN_STANDARD ; info -> dependencies = g_list_append ( info -> dependencies , "core-tcl" ); info -> name = g_strdup ( Tcl_GetString ( listitems [ 0 ])); info -> version = g_strdup ( Tcl_GetString ( listitems [ 1 ])); info -> summary = g_strdup ( Tcl_GetString ( listitems [ 2 ])); info -> description = g_strdup ( Tcl_GetString ( listitems [ 3 ])); info -> author = g_strdup ( Tcl_GetString ( listitems [ 4 ])); info -> homepage = g_strdup ( Tcl_GetString ( listitems [ 5 ])); info -> id = g_strdup_printf ( "tcl-%s" , Tcl_GetString ( listitems [ 0 ])); info -> id = g_strdup_printf ( "tcl-%s" , Tcl_GetString ( listitems [ 6 ])); if ( purple_plugin_register ( plugin )) Tcl_DeleteInterp ( interp ); static gboolean tcl_load_plugin ( PurplePlugin * plugin ) struct tcl_plugin_data * data ; if (( interp = tcl_create_interp ()) == NULL ) { purple_debug ( PURPLE_DEBUG_ERROR , "tcl" , "Could not initialize Tcl interpreter \n " ); Tcl_SourceRCFile ( interp ); if ( Tcl_EvalFile ( interp , plugin -> path ) != TCL_OK ) { result = Tcl_GetObjResult ( interp ); purple_debug ( PURPLE_DEBUG_ERROR , "tcl" , "Error evaluating %s: %s \n " , plugin -> path , Tcl_DeleteInterp ( interp ); Tcl_Preserve (( ClientData ) interp ); data = g_new0 ( struct tcl_plugin_data , 1 ); g_hash_table_insert ( tcl_plugins , ( gpointer ) interp , ( gpointer ) data ); static gboolean tcl_unload_plugin ( PurplePlugin * plugin ) struct tcl_plugin_data * data ; g_hash_table_remove ( tcl_plugins , ( gpointer )( data -> interp )); purple_signals_disconnect_by_handle ( data -> interp ); tcl_cmd_cleanup ( data -> interp ); tcl_signal_cleanup ( data -> interp ); Tcl_Release (( ClientData ) data -> interp ); Tcl_DeleteInterp ( data -> interp ); static void tcl_destroy_plugin ( PurplePlugin * plugin ) if ( plugin -> info != NULL ) { g_free ( plugin -> info -> id ); g_free ( plugin -> info -> name ); g_free ( plugin -> info -> version ); g_free ( plugin -> info -> description ); g_free ( plugin -> info -> author ); g_free ( plugin -> info -> homepage ); static gboolean tcl_load ( PurplePlugin * plugin ) PurpleTclRefAccount = purple_stringref_new ( "Account" ); PurpleTclRefConnection = purple_stringref_new ( "Connection" ); PurpleTclRefConversation = purple_stringref_new ( "Conversation" ); PurpleTclRefPointer = purple_stringref_new ( "Pointer" ); PurpleTclRefPlugin = purple_stringref_new ( "Plugin" ); PurpleTclRefPresence = purple_stringref_new ( "Presence" ); PurpleTclRefStatus = purple_stringref_new ( "Status" ); PurpleTclRefStatusAttr = purple_stringref_new ( "StatusAttr" ); PurpleTclRefStatusType = purple_stringref_new ( "StatusType" ); PurpleTclRefXfer = purple_stringref_new ( "Xfer" ); PurpleTclRefHandle = purple_stringref_new ( "Handle" ); tcl_plugins = g_hash_table_new ( g_direct_hash , g_direct_equal ); Tcl_StaticPackage ( NULL , "Tk" , Tk_Init , Tk_SafeInit ); static gboolean tcl_unload ( PurplePlugin * plugin ) g_hash_table_destroy ( tcl_plugins ); purple_stringref_unref ( PurpleTclRefAccount ); purple_stringref_unref ( PurpleTclRefConnection ); purple_stringref_unref ( PurpleTclRefConversation ); purple_stringref_unref ( PurpleTclRefPointer ); purple_stringref_unref ( PurpleTclRefPlugin ); purple_stringref_unref ( PurpleTclRefPresence ); purple_stringref_unref ( PurpleTclRefStatus ); purple_stringref_unref ( PurpleTclRefStatusAttr ); purple_stringref_unref ( PurpleTclRefStatusType ); purple_stringref_unref ( PurpleTclRefXfer ); static PurplePluginLoaderInfo tcl_loader_info = static PurplePluginInfo tcl_info = N_ ( "Provides support for loading Tcl plugins" ), N_ ( "Provides support for loading Tcl plugins" ), "Ethan Blanton <eblanton@cs.purdue.edu>" , typedef Tcl_Interp * ( __cdecl * LPFNTCLCREATEINTERP )( void ); typedef void ( __cdecl * LPFNTKINIT )( Tcl_Interp * ); LPFNTCLCREATEINTERP wtcl_CreateInterp = NULL ; LPFNTKINIT wtk_Init = NULL ; #define Tcl_CreateInterp wtcl_CreateInterp static gboolean tcl_win32_init () { const char regkey [] = "SOFTWARE \\ ActiveState \\ ActiveTcl \\ " ; if (( version = wpurple_read_reg_string ( HKEY_LOCAL_MACHINE , regkey , "CurrentVersion" )) || ( version = wpurple_read_reg_string ( HKEY_CURRENT_USER , regkey , "CurrentVersion" ))) { int major = 0 , minor = 0 , micro = 0 ; tokens = g_strsplit ( version , "." , 0 ); if ( tokens [ 0 ] && tokens [ 1 ] && tokens [ 2 ]) { regkey2 = g_strdup_printf ( "%s%s \\ " , regkey , version ); if ( ! ( major == 8 && minor == 4 && micro >= 5 )) purple_debug ( PURPLE_DEBUG_INFO , "tcl" , "Unsupported ActiveTCL version %s found. \n " , version ); else if (( path = wpurple_read_reg_string ( HKEY_LOCAL_MACHINE , regkey2 , NULL )) || ( path = wpurple_read_reg_string ( HKEY_CURRENT_USER , regkey2 , NULL ))) { purple_debug ( PURPLE_DEBUG_INFO , "tcl" , "Loading ActiveTCL version %s from \" %s \"\n " , version , path ); tclpath = g_build_filename ( path , "bin" , "tcl84.dll" , NULL ); tkpath = g_build_filename ( path , "bin" , "tk84.dll" , NULL ); if ( ! ( wtcl_CreateInterp = ( LPFNTCLCREATEINTERP ) wpurple_find_and_loadproc ( tclpath , "Tcl_CreateInterp" ))) { purple_debug ( PURPLE_DEBUG_INFO , "tcl" , "tcl_win32_init error loading Tcl_CreateInterp \n " ); if ( ! ( wtk_Init = ( LPFNTKINIT ) wpurple_find_and_loadproc ( tkpath , "Tk_Init" ))) { purple_debug ( PURPLE_DEBUG_INFO , "tcl" , "tcl_win32_init error loading Tk_Init \n " ); if (( mod = GetModuleHandle ( "tcl84.dll" ))) purple_debug ( PURPLE_DEBUG_INFO , "tcl" , _ ( "Unable to detect ActiveTCL installation. If you wish to use TCL plugins, install ActiveTCL from http://www.activestate.com \n " )); static void tcl_init_plugin ( PurplePlugin * plugin ) Tcl_Interp * interp = NULL ; if ( ! ( interp = Tcl_CreateInterp ())) if ( ! Tcl_InitStubs ( interp , TCL_VERSION , 0 )) { purple_debug ( PURPLE_DEBUG_ERROR , "tcl" , "Tcl_InitStubs: %s \n " , interp -> result ); Tcl_FindExecutable ( "purple" ); #if defined(USE_TK_STUBS) && defined(HAVE_TK) if ( ! Tk_InitStubs ( interp , TK_VERSION , 0 )) { purple_debug ( PURPLE_DEBUG_ERROR , "tcl" , "Error Tk_InitStubs: %s \n " , interp -> result ); Tcl_DeleteInterp ( interp ); Tcl_DeleteInterp ( interp ); tcl_loader_info . exts = g_list_append ( tcl_loader_info . exts , "tcl" ); PURPLE_INIT_PLUGIN ( tcl , tcl_init_plugin , tcl_info )