Mercurial > pidgin
changeset 6694:2d2f04c5c7d2
[gaim-migrate @ 7220]
Sean probably won't think this is contact support. This is in fact a
Tcl script plugin loader. That's probably what he'll think it is.
committer: Tailor Script <tailor@pidgin.im>
| author | Ethan Blanton <elb@pidgin.im> |
|---|---|
| date | Tue, 02 Sep 2003 03:34:37 +0000 |
| parents | 8c1b5dd87fbf |
| children | 0c5637b5462e |
| files | configure.ac plugins/Makefile.am plugins/tcl/.cvsignore plugins/tcl/Makefile.am plugins/tcl/TCL-HOWTO plugins/tcl/signal-test.tcl plugins/tcl/tcl.c plugins/tcl/tcl_cmds.c plugins/tcl/tcl_gaim.h plugins/tcl/tcl_glib.c plugins/tcl/tcl_glib.h plugins/tcl/tcl_signals.c |
| diffstat | 12 files changed, 2437 insertions(+), 2 deletions(-) [+] |
line wrap: on
line diff
--- a/configure.ac Tue Sep 02 03:29:53 2003 +0000 +++ b/configure.ac Tue Sep 02 03:34:37 2003 +0000 @@ -125,6 +125,10 @@ AC_ARG_ENABLE(nas, [ --enable-nas enable NAS (Network Audio System) support],,enable_nas=no) AC_ARG_ENABLE(plugins, [ --disable-plugins compile without plugin support],,enable_plugins=yes) AC_ARG_ENABLE(perl, [ --disable-perl compile without perl scripting],,enable_perl=yes) +AC_ARG_ENABLE(tcl, [ --disable-tcl compile without Tcl scripting],,enable_tcl=yes) +AC_ARG_WITH(tclconfig, [ --with-tclconfig=DIR directory containing tclConfig.sh]) +AC_ARG_ENABLE(tk, [ --disable-tk compile without Tcl support for Tk],,enable_tk=yes) +AC_ARG_WITH(tkconfig, [ --with-tkconfig=DIR directory containing tkConfig.sh]) AC_ARG_ENABLE(gtkspell, [ --disable-gtkspell compile without GtkSpell automatic spell checking],,enable_gtkspell=yes) AC_ARG_ENABLE(debug, [ --enable-debug compile with debugging support],,enable_debug=no) AC_ARG_ENABLE(screensaver, [ --disable-screensaver compile without X screensaver extension],,enable_xss=yes) @@ -330,6 +334,75 @@ AM_CONDITIONAL(USE_PERL, false) fi +dnl Check for Tcl +if test "$enable_tcl" = yes; then + AC_MSG_CHECKING([for tclConfig.sh]) + TCLCONFIG=no + for dir in $with_tclconfig /usr/lib /usr/local/lib; do + if test -f $dir/tclConfig.sh; then + TCLCONFIG=$dir/tclConfig.sh + AC_MSG_RESULT([yes ($TCLCONFIG)]) + fi + done + if test "$TCLONFIG" = "no"; then + AC_MSG_RESULT([no]) + enable_tcl=no + else + . $TCLCONFIG + eval "TCL_LIB_SPEC=\"$TCL_LIB_SPEC\"" + AC_MSG_CHECKING([for Tcl linkability]) + oldLIBS=$LIBS + LIBS="$LIBS $TCL_LIB_SPEC" + AC_TRY_LINK([#include <tcl.h>], [Tcl_Interp *interp; Tcl_Init(interp)], + [AC_MSG_RESULT([yes]);enable_tcl=yes], + [AC_MSG_RESULT([no]);enable_tcl=no]) + LIBS="$oldLIBS" + fi +fi + +if test "$enable_tcl" = yes; then + AM_CONDITIONAL(USE_TCL, true) + TCL_LIBS=$TCL_LIB_SPEC + AC_SUBST(TCL_LIBS) +else + AM_CONDITIONAL(USE_TCL, false) +fi + +dnl Check for Tk +if test "$enable_tcl" = yes -a "$enable_tk" = yes; then + AC_MSG_CHECKING([for tkConfig.sh]) + TKCONFIG=no + for dir in $with_tkconfig /usr/lib /usr/local/lib; do + if test -f $dir/tkConfig.sh; then + TKCONFIG=$dir/tkConfig.sh + AC_MSG_RESULT([yes ($TKCONFIG)]) + fi + done + if test "$TKCONFIG" = "no"; then + AC_MSG_RESULT([no]) + enable_tk=no + else + . $TKCONFIG + eval "TK_LIB_SPEC=\"$TK_LIB_SPEC\"" + AC_MSG_CHECKING([for Tk linkability]) + oldLIBS=$LIBS + LIBS="$LIBS $TCL_LIB_SPEC $TK_LIB_SPEC" + AC_TRY_LINK([#include <tk.h>], [Tcl_Interp *interp; Tcl_Init(interp); Tk_Init(interp);], + [AC_MSG_RESULT([yes]);enable_tk=yes], + [AC_MSG_RESULT([no]);enable_tk=no]) + LIBS="$oldLIBS" + fi +fi + +if test "$enable_tk" = yes; then + AM_CONDITIONAL(USE_TK, true) + AC_DEFINE(HAVE_TK, [1], [Compile with support for the Tk toolkit]) + TK_LIBS=$TK_LIB_SPEC + AC_SUBST(TK_LIBS) +else + AM_CONDITIONAL(USE_TK, false) +fi + dnl Thanks, Evan. if test "$enable_gtkspell" = yes ; then PKG_CHECK_MODULES(GTKSPELL, gtkspell-2.0 >= 2.0.2, , enable_gtkspell=no) @@ -463,6 +536,7 @@ plugins/gestures/Makefile plugins/perl/Makefile plugins/perl/common/Makefile.PL + plugins/tcl/Makefile plugins/ticker/Makefile po/Makefile.in sounds/Makefile @@ -492,6 +566,8 @@ echo echo Build with Plugin support..... : $enable_plugins echo Build with Perl support....... : $enable_perl +echo Build with Tcl support........ : $enable_tcl +echo Build with Tk support......... : $enable_tk echo Build with Audio support...... : $enable_audio echo Build with NAS support........ : $enable_nas echo Build with GtkSpell support... : $enable_gtkspell
--- a/plugins/Makefile.am Tue Sep 02 03:29:53 2003 +0000 +++ b/plugins/Makefile.am Tue Sep 02 03:34:37 2003 +0000 @@ -1,10 +1,14 @@ -DIST_SUBDIRS = docklet gaim-remote gestures perl ticker +DIST_SUBDIRS = docklet gaim-remote gestures perl tcl ticker if USE_PERL PERL_DIR = perl endif -SUBDIRS = docklet gaim-remote gestures $(PERL_DIR) ticker +if USE_TCL +TCL_DIR = tcl +endif + +SUBDIRS = docklet gaim-remote gestures $(PERL_DIR) $(TCL_DIR) ticker plugindir = $(libdir)/gaim
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/.cvsignore Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,7 @@ +Makefile.in +Makefile +tcl.so +tcl.la +.deps +.libs +*.lo
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/Makefile.am Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,17 @@ +plugindir = $(libdir)/gaim + +tcl_la_LDFLAGS = -module -avoid-version $(TCL_LIBS) $(TK_LIBS) + +plugin_LTLIBRARIES = tcl.la + +tcl_la_SOURCES = tcl.c tcl_glib.c tcl_cmds.c tcl_signals.c tcl_gaim.h + +AM_CPPFLAGS = \ + -DVERSION=\"$(VERSION)\" \ + -I$(top_srcdir) \ + -I$(top_srcdir)/src \ + $(DEBUG_CFLAGS) \ + $(GLIB_CFLAGS) \ + $(PLUGIN_CFLAGS) \ + $(TK_CFLAGS) \ + $(TCL_CFLAGS)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/TCL-HOWTO Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,310 @@ +Gaim Tcl plugin-writing HOWTO + +INTRODUCTION + +The Gaim Tcl interface provides a Tcl API for many useful gaim +functions. Like the perl API, the Tcl API does not provide access to +every corner of gaim exposed by the C interface. It does, however, +provide a very powerful interface to many of Gaim's functions through +a simple to learn and extend scripting language. + +If you are not familiar with Tcl, you will probably find it somewhat +different from what you are used to. Despite being somewhat unique +(more akin to shell programming than other traditional scripting +languages such as perl or python), it is simple to learn for beginners +and experienced programmers alike. There are numerous books on the +subject, we will not discuss it any further here. + +GETTING STARTED + +The only requirement placed on a Gaim Tcl script by Gaim is the +existence of a procedure called 'plugin_init'. This procedure has +some limitations placed upon it; it will be parsed and evaluated +before the rest of the Tcl script, so it cannot reference any other +variables or procedures declared in the script. In practice this is +not a problem, as the only thing this procedure should do is return a +simple list containing five items: the name of the script, its version +number, a short description, the author, and a web page. For example: + +proc plugin_init { } { + return [ list "Example Plugin" \ + "1.0" \ + "Example of how to register a plugin for the Tcl HOWTO" \ + "Ethan Blanton <eblanton@cs.purdue.edu>" \ + "http://gaim.sf.net/" ] +} + +The rest of the script will generally be registration to recieve +notification of various Gaim signals (more about this below) and +definitions of procedures to be executed when those signals occur. + +INTERPRETER DETAILS + +Gaim initializes and drives the Tcl event loop (similar to Tk), +meaning that commands like fileevent and after are available and +do not require 'vwait' etc. 'vwait' actually seems to be somewhat +broken due to a bug somewhere in the Tcl/Glib event loop glue, and it +should not be used for now. + +The gaim-specific functions are provided in a statically-linked +package called 'gaim'; this means that if you spawn a child +interpreter and wish to use the gaim-specific functions, you will need +to execute 'load {} gaim' in that interpreter. + +GAIM INTERNAL PROCEDURES AND VARIABLES + +All of the information provided for your use by Gaim will be in the +::gaim namespace. This means that in order to access it you will +either have to import the gaim namespace (e.g. via the command +'namespace import gaim::*') or reference it explicitly. The following +descriptions will reference it explicitly for clarity. + +* Variables + +gaim::version + + This contains the version of the gaim process which loaded the + script. + +* Commands + +gaim::account alias account +gaim::account connect account +gaim::account connection account +gaim::account disconnect account +gaim::account find username protocol +gaim::account handle +gaim::account isconnected account +gaim::account list ?option? +gaim::account protocol account +gaim::account username account + + The 'gaim::account' command consists of a set of subcommands + pertaining to gaim accounts. + + 'alias' returns the alias for the account 'account'. If there is no + alias for the given account, it returns the empty string. + + The subcommand 'connect' connects the named account if it is not + connected, and does nothing if it is. In either case, it returns + the gc for the account. + + 'connection' returns the gc of the given account if it is connected, + or 0 if it is not. This gc is the gc used by gaim::connection and + other functions. + + 'disconnect' disconnects the given account if it is connected, or + does nothing if it is. + + 'find' finds an account by its username and protocol (as returned by + 'gaim::account username' and 'gaim::account protocol') and returns + the account if found, or 0 otherwise. + + 'handle' returns the instance handle required to connect to account + signals. (See 'gaim::signal connect'). + + The 'isconnected' query returns true if the given account is + connected and false otherwise. + + The 'list' subcommand returns a list of all of the accounts known to + Gaim. The elements of this lists are accounts appropriate for the + 'account' argument of the other subcommands. The '-all' option + (default) returns all accounts, while the '-online' option returns + only those accounts which are online. + + The 'protocol' subcommand returns the protocol ID (e.g. "prpl-msn") + for the given account. + + The 'username' subcommand returns the username for the account + 'account'. + +gaim::buddy alias buddy +gaim::buddy handle +gaim::buddy info ( buddy | account username ) +gaim::buddy list + + 'gaim::buddy' is a set of commands for retrieving information about + buddies and manipulating the buddy list. For the purposes of Tcl, + a "buddy" is currently a list of several elements, the first of + which being the type. The currently recognized types are "group", + "buddy", and "chat". A group node looks like: + { group name { buddies } } + A buddy node is: + { buddy name account } + And a chat node is: + { chat alias account } + + The 'alias' subcommand returns the alias for the given buddy if it + exists, or the empty string if it does not. + + 'handle' returns the blist handle for the purposes of connecting + signals to buddy list events. (See 'gaim::signal connect'). + + 'info' causes gaim to display the info dialog for the given buddy. + Since it is possible to request user info for a buddy not in your + buddy list, you may also specify a buddy by his or her username and + the account through which you wish to retrieve info. + + 'list' returns a list of 'group' structures, filled out with buddies + and chats as described above. + +gaim::connection account gc +gaim::connection handle +gaim::connection list + + 'gaim::connection' is a collection of subcommands pertaining to + account connections. + + 'account' returns the Gaim account associated with 'gc'. This + account is the same account used by gaim::account and other + commands. + + 'handle' returns the gaim connections instance handle. (See + 'gaim::signal connect'). + + 'list' returns a list of all known connections. The elements of + this list are appropriate as 'gc' arguments to the other + gaim::connection subcommands or other commands requiring a gc. + + +gaim::conv_send account who text + + 'gaim::conv' is simply a convenience wrapper for 'gaim::send_im' and + 'gaim::conversation write'. It sends the IM, determines the from + and to arguments for 'gaim::conversation write', and prints the text + sent to the conversation as one would expect. For the curious, you + may view the source for it by typing 'info body gaim::conv_send' at + a Gaim Commander prompt. + + Note that an error in either gaim::send_im or 'gaim::conversation + write' will not be caught by this procedure, and will be propagated + to the caller. + +gaim::conversation find ?-account account? name +gaim::conversation handle +gaim::conversation list +gaim::conversation new ?-chat? ?-im? account name +gaim::conversation write conversation style from to text + + 'gaim::conversation' provides an API for dealing with conversations. + Given that Gaim is an instant messenger program, you'll probably + spend a lot of time here. + + The command 'find' attempts to find an existing conversation with + username 'name'. If the '-account' option is given, it refines its + search to include only conversations on that account. + + 'handle' returns the conversations instance handle for the purposes + of signal connection. (See 'gaim::signal connect'). + + 'list' returns a list of all currently open conversations. + + The 'new' subcommand can be used to create a new conversation with + a specified user on a specified account if one does not exist, or + retrieve the existing conversation if it does. The '-chat' and + '-im' options specify whether the created conversation should be a + chat or a standard IM, respectively. + + 'write' is used to write to the specified conversation. The 'style' + argument specifies how the text should be printed -- as text coming + from the gaim user (style 'send'), being sent to the gaim user + (style 'recv'), or as a system message (such as "so-and-so has + signed off", style 'system'). From is the name to whom the text + should be attributed -- you probably want to check for aliases here, + lest you confuse the user. 'text' is the text to print. + +gaim::core handle +gaim::core quit + + This command exposes functionality provided by the gaim core API. + + 'gaim::core handle' returns a handle to the gaim core for signal + connection. (See 'gaim::signal connect'). + + 'quit' exits gaim cleanly, and should be used in preference to the + tcl 'exit' command. (Note that 'exit' has not been removed, + however.) + +gaim::debug level category message + + Equivalent to the C gaim_debug function, this command outputs + debugging information to the gaim debug window (or stdout if gaim is + invoked with -n). The valid levels are, in increasing level of + severity, -misc, -info, -warning, and -error. 'category' is a short + (a few characters ... for instance, "tcl" or "tcl plugin") "topic" + type name for this message, and 'message' is the text of the + message. In the style of Tcl 'puts' (and differing from gaim_debug), + no trailing \n is required. (However, embedded newlines may be + generated with \n). + +gaim::notify ?type? title primary secondary + + Also a direct equivalent to a C function, gaim_notify, this command + causes gaim to present the provided notification information to the + user via some appropriate UI method. The 'type' argument, if + present, must be one of -error, -warning, or -info. The following + three arguments' absolute meanings may vary with the Gaim UI being + used (presently only a Gtk2 UI is available), but 'title' should + generally be the title of the window, and 'primary' and 'secondary' + text within that window; in the Gtk2 UI, 'primary' is slightly + larger than 'secondary' and displayed in a boldface font. + +gaim::send_im gc who text + + This sends an IM in the fashion of serv_send_im. 'gc' is the GC of + the connection on which you wish to send (as returned by most event + handlers), 'who' is the nick of the buddy to which you wish to send, + and 'text' is the text of the message. + +gaim::signal connect instance signal args proc +gaim::signal disconnect instance signal + + 'gaim::signal' is a set of subcommands for dealing with gaim signals + (known as "events" prior to gaim 0.68). + + The 'connect' subcommand registers the procedure 'proc' as a handler + for the signal 'signal' on the instance 'instance'. 'instance' + should be an instance handle as returned by one of the 'handle' + commands from the various parts of gaim. 'args' and 'proc' are as in + the Tcl 'proc' command; note that the number of arguments in 'args' + must match the number of arguments emitted by the signal exactly, + although you need not use them all. The procedure 'proc' may be + either a simple command or a procedure in curly brackets. Note that + only one procedure may be associated with each signal; an attempt to + connect a second procedure to the same signal will remove the + existing binding and replace it with the new procedure. + 'gaim::signal connect' returns 0 on success and 1 on failure. + + 'disconnect' removes any existing signal handler for the named + signal and instance. + +gaim::unload + + This unloads the current plugin. Note that preferences will not be + updated (yet). + +SIGNALS + +Check the file SIGNALS for the meaning of these signals; this is +intended to be a list only of their arguments. Signal callbacks will +be made in their own namespace, and arguments to those signal +callbacks will live in the namespace 'event' underneath that +namespace. To briefly illustrate, the signal received-im-msg is +provided with three arguments; the account on which the IM was +received, the screen name of the user sending the IM, and the text of +the IM. These arguments live in the variables event::account, +event::sender, and event::buffer, respectively. Therefore a callback +which notifies the user of an incoming IM containing the word 'shizzle' +might look like this: + +gaim::add_event_handler received-im-msg { + if {[ string match "*shizzle*" $event::buffer ]} { + gaim::notify -info "tcl plugin" "Fo' shizzle" \ + "$event::sender is down with the shizzle" + } +} + +Note that for some signals (notably received-im-msg, sending-im-msg, +and their chat counterparts), changes to the event arguments will +change the message itself from Gaim's vantage. For those signals +whose return value is meaningful, returning a value from the Tcl event
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/signal-test.tcl Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,105 @@ +gaim::signal connect [gaim::account handle] account-away { account state message } { + gaim::debug -info "tcl signal" "account-away [gaim::account username $account] \"$state\" \"$message\"" +} + +gaim::signal connect [gaim::account handle] account-connecting { account } { + gaim::debug -info "tcl signal" "account-connecting [gaim::account username $account]" +} + +gaim::signal connect [gaim::account handle] account-set-info { account info } { + gaim::debug -info "tcl signal" "account-set-info [gaim::account username $account] $info" +} + +gaim::signal connect [gaim::account handle] account-setting-info { account info } { + gaim::debug -info "tcl signal" "account-set-info [gaim::account username $account] $info" +} + +gaim::signal connect [gaim::account handle] account-warned { account who level } { + gaim::debug -info "tcl signal" "account-warned [gaim::account username $account] $who $level" +} + +gaim::signal connect [gaim::buddy handle] buddy-away { buddy } { + gaim::debug -info "tcl signal" "buddy-away [gaim::account username [lindex $buddy 2]] [lindex $buddy 1]" +} + +gaim::signal connect [gaim::buddy handle] buddy-back { buddy } { + gaim::debug -info "tcl signal" "buddy-back [gaim::account username [lindex $buddy 2]] [lindex $buddy 1]" +} + +gaim::signal connect [gaim::buddy handle] buddy-idle { buddy } { + gaim::debug -info "tcl signal" "buddy-idle [gaim::account username [lindex $buddy 2]] [lindex $buddy 1]" +} + +gaim::signal connect [gaim::buddy handle] buddy-unidle { buddy } { + gaim::debug -info "tcl signal" "buddy-unidle [gaim::account username [lindex $buddy 2]] [lindex $buddy 1]" +} + +gaim::signal connect [gaim::buddy handle] buddy-signed-on { buddy } { + gaim::debug -info "tcl signal" "buddy-signed-on [gaim::account username [lindex $buddy 2]] [lindex $buddy 1]" +} + +gaim::signal connect [gaim::buddy handle] buddy-signed-off { buddy } { + gaim::debug -info "tcl signal" "buddy-signed-off [gaim::account username [lindex $buddy 2]] [lindex $buddy 1]" +} + +gaim::signal connect [gaim::core handle] quitting {} { + gaim::debug -info "tcl signal" "quitting" +} + +gaim::signal connect [gaim::conversation handle] received-chat-msg { account who what id } { + gaim::debug -info "tcl signal" "received-chat-msg [gaim::account username $account] $id $who \"$what\"" + return 0 +} + +gaim::signal connect [gaim::conversation handle] received-im-msg { account who what flags } { + gaim::debug -info "tcl signal" "received-im-msg [gaim::account username $account] $flags $who \"$what\"" + return 0 +} + +gaim::signal connect [gaim::conversation handle] sending-chat-msg { account what id } { + gaim::debug -info "tcl signal" "sending-chat-msg [gaim::account username $account] $id \"$what\"" + return 0 +} + +gaim::signal connect [gaim::conversation handle] sending-im-msg { account who what } { + gaim::debug -info "tcl signal" "sending-im-msg [gaim::account username $account] $who \"$what\"" + return 0 +} + +gaim::signal connect [gaim::conversation handle] sent-chat-msg { account id what } { + gaim::debug -info "tcl signal" "sent-chat-msg [gaim::account username $account] $id \"$what\"" +} + +gaim::signal connect [gaim::conversation handle] sent-im-msg { account who what } { + gaim::debug -info "tcl signal" "sent-im-msg [gaim::account username $account] $who \"$what\"" +} + +gaim::signal connect [gaim::connection handle] signed-on { gc } { + gaim::debug -info "tcl signal" "signed-on [gaim::account username [gaim::connection account $gc]" +} + +gaim::signal connect [gaim::connection handle] signed-off { gc } { + gaim::debug -info "tcl signal" "signed-off [gaim::account username [gaim::connection account $gc]]" +} + +gaim::signal connect [gaim::connection handle] signing-on { gc } { + gaim::debug -info "tcl signal" "signing-on [gaim::account username [gaim::connection account $gc]]" +} + +if { 0 } { +gaim::signal connect signing-off { + gaim::debug -info "tcl signal" "signing-off [gaim::account username [gaim::connection account $event::gc]]" +} + +gaim::signal connect update-idle { + gaim::debug -info "tcl signal" "update-idle" +} +} + +proc plugin_init { } { + list "Tcl Signal Test" \ + "$gaim::version" \ + "Debugs a ridiculous amount of signal information." \ + "Ethan Blanton <eblanton@cs.purdue.edu>" \ + "http://gaim.sourceforge.net/" +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/tcl.c Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,366 @@ +/** + * @file tcl.c Gaim Tcl plugin bindings + * + * gaim + * + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "config.h" + +#include <tcl.h> + +#ifdef HAVE_TK +#include <tk.h> +#endif + +#include <stdio.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <unistd.h> +#include <string.h> + +#include "tcl_glib.h" +#include "tcl_gaim.h" + +#include "internal.h" +#include "connection.h" +#include "plugin.h" +#include "signals.h" +#include "debug.h" +#include "util.h" + +struct tcl_plugin_data { + GaimPlugin *plugin; + Tcl_Interp *interp; +}; + +static GHashTable *tcl_plugins = NULL; + +GaimPlugin *_tcl_plugin; + +GaimPlugin *tcl_interp_get_plugin(Tcl_Interp *interp) +{ + struct tcl_plugin_data *data; + + if (tcl_plugins == NULL) + return NULL; + + data = g_hash_table_lookup(tcl_plugins, (gpointer)interp); + return data != NULL ? data->plugin : NULL; +} + +static int tcl_init_interp(Tcl_Interp *interp) +{ + char *rcfile; + char init[] = + "namespace eval ::gaim {\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" + "\n" + " proc conv_send { account who text } {\n" + " set gc [gaim::account connection $account]\n" + " set convo [gaim::conversation new $account $who]\n" + " set myalias [gaim::account alias $account]\n" + "\n" + " if {![string length $myalias]} {\n" + " set myalias [gaim::account username $account]\n" + " }\n" + "\n" + " gaim::send_im $gc $who $text\n" + " gaim::conversation write $convo send $myalias $text\n" + " }\n" + "}\n" + "\n" + "proc bgerror { message } {\n" + " global errorInfo\n" + " gaim::notify -error \"Tcl Error\" \"Tcl Error: $message\" \"$errorInfo\"\n" + "}\n"; + + if (Tcl_EvalEx(interp, init, -1, TCL_EVAL_GLOBAL) != TCL_OK) { + return 1; + } + + Tcl_SetVar(interp, "argc", "0", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", "gaim", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + rcfile = g_strdup_printf("%s" G_DIR_SEPARATOR_S "tclrc", gaim_user_dir()); + Tcl_SetVar(interp, "tcl_rcFileName", rcfile, TCL_GLOBAL_ONLY); + g_free(rcfile); + + Tcl_SetVar(interp, "::gaim::version", VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "::gaim::user_dir", gaim_user_dir(), TCL_GLOBAL_ONLY); +#ifdef HAVE_TK + Tcl_SetVar(interp, "::gaim::tk_available", "1", TCL_GLOBAL_ONLY); +#else + Tcl_SetVar(interp, "::gaim::tk_available", "0", TCL_GLOBAL_ONLY); +#endif /* HAVE_TK */ + + Tcl_CreateObjCommand(interp, "::gaim::account", tcl_cmd_account, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::buddy", tcl_cmd_buddy, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::connection", tcl_cmd_connection, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::conversation", tcl_cmd_conversation, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::core", tcl_cmd_core, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::debug", tcl_cmd_debug, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::notify", tcl_cmd_notify, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::prefs", tcl_cmd_prefs, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::send_im", tcl_cmd_send_im, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::signal", tcl_cmd_signal, (ClientData)NULL, NULL); + Tcl_CreateObjCommand(interp, "::gaim::unload", tcl_cmd_unload, (ClientData)NULL, NULL); + + return 0; +} + +static Tcl_Interp *tcl_create_interp() +{ + Tcl_Interp *interp; + + interp = Tcl_CreateInterp(); + if (Tcl_Init(interp) == TCL_ERROR) { + Tcl_DeleteInterp(interp); + return NULL; + } + +#ifdef HAVE_TK + Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); +#endif /* HAVE_TK */ + + if (tcl_init_interp(interp)) { + Tcl_DeleteInterp(interp); + return NULL; + } + Tcl_StaticPackage(interp, "gaim", tcl_init_interp, NULL); + + return interp; +} + +static gboolean tcl_probe_plugin(GaimPlugin *plugin) +{ + GaimPluginInfo *info; + Tcl_Interp *interp; + Tcl_Parse parse; + Tcl_Obj *result, **listitems; + struct stat st; + FILE *fp; + char *buf, *cur; + int len, found = 0, err = 0, nelems; + gboolean status = FALSE; + + if ((fp = fopen(plugin->path, "r")) == NULL) + return FALSE; + if (fstat(fileno(fp), &st)) { + fclose(fp); + return FALSE; + } + len = st.st_size; + + buf = g_malloc(len + 1); + if ((fread(buf, len, 1, fp)) != 1) { + g_free(buf); + fclose(fp); + return FALSE; + } + fclose(fp); + buf[len] = '\0'; + + if ((interp = tcl_create_interp()) == NULL) { + return FALSE; + } + + cur = buf; + do { + if (Tcl_ParseCommand(interp, cur, len, 0, &parse) == TCL_ERROR) { + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "parse error in %s: %s\n", plugin->path, + Tcl_GetString(Tcl_GetObjResult(interp))); + err = 1; + break; + } + 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) { + Tcl_FreeParse(&parse); + break; + } + found = 1; + /* We'll continue parsing the file, just in case */ + } + } + len -= (parse.commandStart + parse.commandSize) - cur; + cur = parse.commandStart + parse.commandSize; + Tcl_FreeParse(&parse); + } while (len); + + if (found && !err) { + 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 == 5) { + info = g_new0(GaimPluginInfo, 1); + + info->api_version = 2; + info->type = GAIM_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->description = g_strdup(Tcl_GetString(listitems[2]));; + info->author = g_strdup(Tcl_GetString(listitems[3])); + info->homepage = g_strdup(Tcl_GetString(listitems[4])); + + plugin->info = info; + + if (gaim_plugin_register(plugin)) + status = TRUE; + } + } + } + } + + Tcl_DeleteInterp(interp); + g_free(buf); + return status; +} + +static gboolean tcl_load_plugin(GaimPlugin *plugin) +{ + struct tcl_plugin_data *data; + Tcl_Interp *interp; + Tcl_Obj *result; + + plugin->extra = NULL; + + if ((interp = tcl_create_interp()) == NULL) { + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "Could not initialize Tcl interpreter\n"); + return FALSE; + } + + Tcl_SourceRCFile(interp); + + if (Tcl_EvalFile(interp, plugin->path) != TCL_OK) { + result = Tcl_GetObjResult(interp); + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "Error evaluating %s: %s\n", plugin->path, Tcl_GetString(result)); + Tcl_DeleteInterp(interp); + return FALSE; + } + + Tcl_Preserve((ClientData)interp); + + data = g_new0(struct tcl_plugin_data, 1); + data->plugin = plugin; + data->interp = interp; + plugin->extra = data; + + g_hash_table_insert(tcl_plugins, (gpointer)interp, (gpointer)data); + + return TRUE; +} + +static gboolean tcl_unload_plugin(GaimPlugin *plugin) +{ + struct tcl_plugin_data *data; + + if (plugin == NULL) + return TRUE; + + data = plugin->extra; + + g_hash_table_remove(tcl_plugins, (gpointer)data); + if (data != NULL) { + gaim_signals_disconnect_by_handle(data->interp); + tcl_signal_cleanup(data->interp); + Tcl_Release((ClientData)data->interp); + Tcl_DeleteInterp(data->interp); + g_free(data); + } + + return TRUE; +} + +static void tcl_destroy_plugin(GaimPlugin *plugin) +{ + if (plugin->info != NULL) { + 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); + } + + return; +} + +static gboolean tcl_load(GaimPlugin *plugin) +{ + tcl_glib_init(); + tcl_signal_init(); + tcl_plugins = g_hash_table_new(g_direct_hash, g_direct_equal); + + return TRUE; +} + +static gboolean tcl_unload(GaimPlugin *plugin) +{ + g_hash_table_destroy(tcl_plugins); + tcl_plugins = NULL; + + return TRUE; +} + +static GaimPluginLoaderInfo tcl_loader_info = +{ + NULL, + tcl_probe_plugin, + tcl_load_plugin, + tcl_unload_plugin, + tcl_destroy_plugin, +}; + +static GaimPluginInfo tcl_info = +{ + 2, + GAIM_PLUGIN_LOADER, + NULL, + 0, + NULL, + GAIM_PRIORITY_DEFAULT, + "core-tcl", + N_("Tcl Plugin Loader"), + VERSION, + N_("Provides support for loading Tcl plugins"), + N_("Provides support for loading Tcl plugins"), + "Ethan Blanton <eblanton@cs.purdue.edu>", + GAIM_WEBSITE, + tcl_load, + tcl_unload, + NULL, + NULL, + &tcl_loader_info +}; + +static void tcl_init_plugin(GaimPlugin *plugin) +{ + _tcl_plugin = plugin; + + Tcl_FindExecutable("gaim"); + + tcl_loader_info.exts = g_list_append(tcl_loader_info.exts, "tcl"); +} + +GAIM_INIT_PLUGIN(tcl, tcl_init_plugin, tcl_info);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/tcl_cmds.c Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,913 @@ +/** + * @file tcl_cmds.c Commands for the Gaim Tcl plugin bindings + * + * gaim + * + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include <tcl.h> + +#include "internal.h" +#include "conversation.h" +#include "connection.h" +#include "account.h" +#include "server.h" +#include "notify.h" +#include "debug.h" +#include "prefs.h" +#include "core.h" + +#include "tcl_gaim.h" + +static gboolean tcl_validate_account(GaimAccount *account, Tcl_Interp *interp); +static gboolean tcl_validate_gc(GaimConnection *gc); + +static gboolean tcl_validate_account(GaimAccount *account, Tcl_Interp *interp) +{ + GList *cur; + for (cur = gaim_accounts_get_all(); cur != NULL; cur = g_list_next(cur)) { + if (account == cur->data) + return TRUE; + } + if (interp != NULL) + Tcl_SetStringObj(Tcl_GetObjResult(interp), "invalid account", -1); + return FALSE; +} + +static gboolean tcl_validate_conversation(GaimConversation *convo, Tcl_Interp *interp) +{ + GList *cur; + + for (cur = gaim_get_conversations(); cur != NULL; cur = g_list_next(cur)) { + if (convo == cur->data) + return TRUE; + } + if (interp != NULL) + Tcl_SetStringObj(Tcl_GetObjResult(interp), "invalid account", -1); + return FALSE; +} + +static gboolean tcl_validate_gc(GaimConnection *gc) +{ + GList *cur; + for (cur = gaim_connections_get_all(); cur != NULL; cur = g_list_next(cur)) { + if (gc == cur->data) + return TRUE; + } + return FALSE; +} + +int tcl_cmd_account(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + Tcl_Obj *result = Tcl_GetObjResult(interp), *list, *elem; + char *cmds[] = { "alias", "connect", "connection", "disconnect", "find", + "handle", "isconnected", "list", "protocol", "username", + NULL }; + enum { CMD_ACCOUNT_ALIAS, CMD_ACCOUNT_CONNECT, CMD_ACCOUNT_CONNECTION, + CMD_ACCOUNT_DISCONNECT, CMD_ACCOUNT_FIND, CMD_ACCOUNT_HANDLE, + CMD_ACCOUNT_ISCONNECTED, CMD_ACCOUNT_LIST, CMD_ACCOUNT_PROTOCOL, + CMD_ACCOUNT_USERNAME } cmd; + char *listopts[] = { "-all", "-online", NULL }; + enum { CMD_ACCOUNTLIST_ALL, CMD_ACCOUNTLIST_ONLINE } listopt; + const char *alias; + GList *cur; + GaimAccount *account; + int error; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + switch (cmd) { + case CMD_ACCOUNT_ALIAS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + alias = gaim_account_get_alias(account); + Tcl_SetStringObj(result, alias ? (char *)alias : "", -1); + break; + case CMD_ACCOUNT_CONNECT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + if (gaim_account_is_connected(account)) + Tcl_SetIntObj(result, (int)gaim_account_get_connection(account)); + else + Tcl_SetIntObj(result, (int)gaim_account_connect(account)); + break; + case CMD_ACCOUNT_CONNECTION: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + Tcl_SetIntObj(result, (int)gaim_account_get_connection(account)); + break; + case CMD_ACCOUNT_DISCONNECT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + gaim_account_disconnect(account); + break; + case CMD_ACCOUNT_FIND: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "username protocol"); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_accounts_find_with_prpl_id(Tcl_GetString(objv[2]), + Tcl_GetString(objv[3]))); + break; + case CMD_ACCOUNT_HANDLE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_accounts_get_handle()); + break; + case CMD_ACCOUNT_ISCONNECTED: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + Tcl_SetBooleanObj(result, gaim_account_is_connected(account)); + break; + case CMD_ACCOUNT_LIST: + listopt = CMD_ACCOUNTLIST_ALL; + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?option?"); + return TCL_ERROR; + } + if (objc == 3) { + if ((error = Tcl_GetIndexFromObj(interp, objv[2], listopts, "option", 0, (int *)&listopt)) != TCL_OK) + return error; + } + list = Tcl_NewListObj(0, NULL); + for (cur = gaim_accounts_get_all(); cur != NULL; cur = g_list_next(cur)) { + account = cur->data; + if (listopt == CMD_ACCOUNTLIST_ONLINE && !gaim_account_is_connected(account)) + continue; + elem = Tcl_NewIntObj((int)account); + Tcl_ListObjAppendElement(interp, list, elem); + } + Tcl_SetObjResult(interp, list); + break; + case CMD_ACCOUNT_PROTOCOL: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + Tcl_SetStringObj(result, (char *)gaim_account_get_protocol_id(account), -1); + break; + case CMD_ACCOUNT_USERNAME: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "account"); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account); + if (error || !tcl_validate_account(account, interp)) + return TCL_ERROR; + Tcl_SetStringObj(result, (char *)gaim_account_get_username(account), -1); + break; + } + + return TCL_OK; +} + +static GaimBlistNode *tcl_list_to_buddy(Tcl_Interp *interp, int count, Tcl_Obj **elems) +{ + GaimBlistNode *node = NULL; + GaimAccount *account; + char *name; + char *type; + + if (count < 3) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), "list too short", -1); + return NULL; + } + + type = Tcl_GetString(elems[0]); + name = Tcl_GetString(elems[1]); + if (Tcl_GetIntFromObj(interp, elems[2], (int *)&account) != TCL_OK) + return NULL; + if (!tcl_validate_account(account, interp)) + return NULL; + + if (!strcmp(type, "buddy")) { + node = (GaimBlistNode *)gaim_find_buddy(account, name); + } else if (!strcmp(type, "group")) { + node = (GaimBlistNode *)gaim_blist_find_chat(account, name); + } + + return node; +} + +int tcl_cmd_buddy(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + Tcl_Obj *list, *tclgroup, *tclgrouplist, *tclbud, **elems, *result; + char *cmds[] = { "alias", "handle", "info", "list", NULL }; + enum { CMD_BUDDY_ALIAS, CMD_BUDDY_HANDLE, CMD_BUDDY_INFO, CMD_BUDDY_LIST } cmd; + struct gaim_buddy_list *blist; + GaimBlistNode *node, *gnode; + GaimAccount *account; + struct buddy *bnode; + struct chat *cnode; + int error, all = 0, count; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + result = Tcl_GetObjResult(interp); + + switch (cmd) { + case CMD_BUDDY_ALIAS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "buddy"); + return TCL_ERROR; + } + if ((error = Tcl_ListObjGetElements(interp, objv[2], &count, &elems)) != TCL_OK) + return error; + if ((node = tcl_list_to_buddy(interp, count, elems)) == NULL) + return TCL_ERROR; + if (node->type == GAIM_BLIST_CHAT_NODE) + Tcl_SetStringObj(result, ((struct chat *)node)->alias, -1); + else if (node->type == GAIM_BLIST_BUDDY_NODE) + Tcl_SetStringObj(result, gaim_get_buddy_alias((struct buddy *)node), -1); + return TCL_OK; + break; + case CMD_BUDDY_HANDLE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_blist_get_handle()); + break; + case CMD_BUDDY_INFO: + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "( buddy | account username )"); + return TCL_ERROR; + } + if (objc == 3) { + if ((error = Tcl_ListObjGetElements(interp, objv[2], &count, &elems)) != TCL_OK) + return error; + if (count < 3) { + Tcl_SetStringObj(result, "buddy too short", -1); + return TCL_ERROR; + } + if (strcmp("buddy", Tcl_GetString(elems[0]))) { + Tcl_SetStringObj(result, "invalid buddy", -1); + return TCL_ERROR; + } + if ((error = Tcl_GetIntFromObj(interp, elems[2], (int *)&account)) != TCL_OK) + return TCL_ERROR; + if (!tcl_validate_account(account, interp)) + return TCL_ERROR; + serv_get_info(gaim_account_get_connection(account), Tcl_GetString(elems[1])); + } else { + if ((error = Tcl_GetIntFromObj(interp, objv[2], (int *)&account)) != TCL_OK) + return error; + if (!tcl_validate_account(account, interp)) + return TCL_ERROR; + serv_get_info(gaim_account_get_connection(account), Tcl_GetString(objv[3])); + } + break; + case CMD_BUDDY_LIST: + if (objc == 3) { + if (!strcmp("-all", Tcl_GetString(objv[2]))) { + all = 1; + } else { + Tcl_SetStringObj(result, "", -1); + Tcl_AppendStringsToObj(result, "unknown option: ", Tcl_GetString(objv[2]), NULL); + return TCL_ERROR; + } + } + list = Tcl_NewListObj(0, NULL); + blist = gaim_get_blist(); + for (gnode = blist->root; gnode != NULL; gnode = gnode->next) { + tclgroup = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, tclgroup, Tcl_NewStringObj("group", -1)); + Tcl_ListObjAppendElement(interp, tclgroup, + Tcl_NewStringObj(((struct group *)gnode)->name, -1)); + tclgrouplist = Tcl_NewListObj(0, NULL); + for (node = gnode->child; node != NULL; node = node->next) { + switch (node->type) { + case GAIM_BLIST_BUDDY_NODE: + bnode = (struct buddy *)node; + if (!all && !gaim_account_is_connected(bnode->account)) + continue; + tclbud = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj("buddy", -1)); + Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj(bnode->name, -1)); + Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewIntObj((int)bnode->account)); + break; + case GAIM_BLIST_CHAT_NODE: + cnode = (struct chat *)node; + if (!all && !gaim_account_is_connected(cnode->account)) + continue; + tclbud = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj("chat", -1)); + Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj(cnode->alias, -1)); + Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewIntObj((int)cnode->account)); + break; + default: + continue; + } + Tcl_ListObjAppendElement(interp, tclgrouplist, tclbud); + } + Tcl_ListObjAppendElement(interp, tclgroup, tclgrouplist); + Tcl_ListObjAppendElement(interp, list, tclgroup); + } + Tcl_SetObjResult(interp, list); + break; + } + + return TCL_OK; +} + +int tcl_cmd_connection(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + Tcl_Obj *result = Tcl_GetObjResult(interp), *list, *elem; + char *cmds[] = { "account", "handle", "list", NULL }; + enum { CMD_CONN_ACCOUNT, CMD_CONN_HANDLE, CMD_CONN_LIST } cmd; + int error; + GList *cur; + GaimConnection *gc; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + switch (cmd) { + case CMD_CONN_ACCOUNT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, _("gc")); + return TCL_ERROR; + } + error = Tcl_GetIntFromObj(interp, objv[2], (int *)&gc); + if (error || !tcl_validate_gc(gc)) { + Tcl_SetStringObj(result, "invalid gc", -1); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_connection_get_account(gc)); + break; + case CMD_CONN_HANDLE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_connections_get_handle()); + break; + case CMD_CONN_LIST: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + list = Tcl_NewListObj(0, NULL); + for (cur = gaim_connections_get_all(); cur != NULL; cur = g_list_next(cur)) { + elem = Tcl_NewIntObj((int)cur->data); + Tcl_ListObjAppendElement(interp, list, elem); + } + Tcl_SetObjResult(interp, list); + break; + } + + return TCL_OK; +} + +int tcl_cmd_conversation(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + Tcl_Obj *list, *elem, *result = Tcl_GetObjResult(interp); + char *cmds[] = { "find", "handle", "list", "new", "write", NULL }; + enum { CMD_CONV_FIND, CMD_CONV_HANDLE, CMD_CONV_LIST, CMD_CONV_NEW, CMD_CONV_WRITE } cmd; + char *styles[] = { "send", "recv", "system", NULL }; + enum { CMD_CONV_WRITE_SEND, CMD_CONV_WRITE_RECV, CMD_CONV_WRITE_SYSTEM } style; + char *findopts[] = { "-account", NULL }; + enum { CMD_CONV_FIND_ACCOUNT } findopt; + char *newopts[] = { "-chat", "-im" }; + enum { CMD_CONV_NEW_CHAT, CMD_CONV_NEW_IM } newopt; + GaimConversation *convo; + GaimAccount *account; + GaimConversationType type; + GList *cur; + char *opt, *from, *what; + int error, argsused, flags; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + switch (cmd) { + case CMD_CONV_FIND: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?options? name"); + return TCL_ERROR; + } + argsused = 2; + account = NULL; + while (argsused < objc) { + opt = Tcl_GetString(objv[argsused]); + if (*opt == '-') { + if ((error = Tcl_GetIndexFromObj(interp, objv[argsused], findopts, + "option", 0, (int *)&findopt)) != TCL_OK) + return error; + argsused++; + switch (findopt) { + case CMD_CONV_FIND_ACCOUNT: + if (argsused == objc - 1) { + Tcl_SetStringObj(result, "-account requires an argument", -1); + return TCL_ERROR; + } + if ((error = Tcl_GetIntFromObj(interp, objv[argsused], + (int *)&account)) != TCL_OK) + return error; + if (!tcl_validate_account(account, interp)) + return TCL_ERROR; + argsused++; + break; + } + } else { + break; + } + } + if (objc - argsused != 1) { + Tcl_WrongNumArgs(interp, 2, objv, "?options? name"); + return error; + } + if (account != NULL) { + convo = gaim_find_conversation_with_account(Tcl_GetString(objv[argsused]), account); + } else { + convo = gaim_find_conversation(Tcl_GetString(objv[argsused])); + } + Tcl_SetIntObj(result, (int)convo); + break; + case CMD_CONV_HANDLE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_conversations_get_handle()); + break; + case CMD_CONV_LIST: + list = Tcl_NewListObj(0, NULL); + for (cur = gaim_get_conversations(); cur != NULL; cur = g_list_next(cur)) { + elem = Tcl_NewIntObj((int)cur->data); + Tcl_ListObjAppendElement(interp, list, elem); + } + Tcl_SetObjResult(interp, list); + break; + case CMD_CONV_NEW: + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "?options? account name"); + return TCL_ERROR; + } + argsused = 2; + type = GAIM_CONV_IM; + while (argsused < objc) { + opt = Tcl_GetString(objv[argsused]); + if (*opt == '-') { + if ((error = Tcl_GetIndexFromObj(interp, objv[argsused], newopts, + "option", 0, (int *)&newopt)) != TCL_OK) + return error; + argsused++; + switch (newopt) { + case CMD_CONV_NEW_CHAT: + type = GAIM_CONV_CHAT; + break; + case CMD_CONV_NEW_IM: + type = GAIM_CONV_IM; + break; + } + } else { + break; + } + } + if (objc - argsused != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?options? account name"); + return TCL_ERROR; + } + if ((error = Tcl_GetIntFromObj(interp, objv[argsused++], (int *)&account)) != TCL_OK) + return error; + if (!tcl_validate_account(account, interp)) + return TCL_ERROR; + convo = gaim_conversation_new(type, account, Tcl_GetString(objv[argsused])); + Tcl_SetIntObj(result, (int)convo); + break; + case CMD_CONV_WRITE: + if (objc != 6) { + Tcl_WrongNumArgs(interp, 2, objv, "conversation style from what"); + return TCL_ERROR; + } + if ((error = Tcl_GetIntFromObj(interp, objv[2], (int *)&convo)) != TCL_OK) + return error; + if ((error = Tcl_GetIndexFromObj(interp, objv[3], styles, "style", 0, (int *)&style)) != TCL_OK) + return error; + if (!tcl_validate_conversation(convo, interp)) + return TCL_ERROR; + from = Tcl_GetString(objv[4]); + what = Tcl_GetString(objv[5]); + + switch (style) { + case CMD_CONV_WRITE_SEND: + flags = GAIM_MESSAGE_SEND; + break; + case CMD_CONV_WRITE_RECV: + flags = GAIM_MESSAGE_RECV; + break; + case CMD_CONV_WRITE_SYSTEM: + flags = GAIM_MESSAGE_SYSTEM; + break; + } + if (gaim_conversation_get_type(convo) == GAIM_CONV_CHAT) + gaim_chat_write(GAIM_CHAT(convo), from, what, flags, time(NULL)); + else + gaim_im_write(GAIM_IM(convo), from, what, -1, flags, time(NULL)); + break; + } + + return TCL_OK; +} + +int tcl_cmd_core(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + Tcl_Obj *result = Tcl_GetObjResult(interp); + char *cmds[] = { "handle", "quit", NULL }; + enum { CMD_CORE_HANDLE, CMD_CORE_QUIT } cmd; + int error; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + switch (cmd) { + case CMD_CORE_HANDLE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + Tcl_SetIntObj(result, (int)gaim_get_core()); + break; + case CMD_CORE_QUIT: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + gaim_core_quit(); + break; + } + + return TCL_OK; +} + +int tcl_cmd_debug(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + char *category, *message; + int lev; + char *levels[] = { "-misc", "-info", "-warning", "-error", NULL }; + GaimDebugLevel levelind[] = { GAIM_DEBUG_MISC, GAIM_DEBUG_INFO, GAIM_DEBUG_WARNING, GAIM_DEBUG_ERROR }; + int error; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "level category message"); + return TCL_ERROR; + } + + error = Tcl_GetIndexFromObj(interp, objv[1], levels, "debug level", 0, &lev); + if (error != TCL_OK) + return error; + + category = Tcl_GetString(objv[2]); + message = Tcl_GetString(objv[3]); + + gaim_debug(levelind[lev], category, "%s\n", message); + + return TCL_OK; +} + +int tcl_cmd_notify(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + int error, type; + char *opts[] = { "-error", "-warning", "-info", NULL }; + GaimNotifyMsgType optind[] = { GAIM_NOTIFY_MSG_ERROR, GAIM_NOTIFY_MSG_WARNING, GAIM_NOTIFY_MSG_INFO }; + char *title, *msg1, *msg2; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "?type? title primary secondary"); + return TCL_ERROR; + } + + if (objc == 4) { + title = Tcl_GetString(objv[1]); + msg1 = Tcl_GetString(objv[2]); + msg2 = Tcl_GetString(objv[3]); + } else { + error = Tcl_GetIndexFromObj(interp, objv[1], opts, "message type", 0, &type); + if (error != TCL_OK) + return error; + title = Tcl_GetString(objv[2]); + msg1 = Tcl_GetString(objv[3]); + msg2 = Tcl_GetString(objv[4]); + } + + gaim_notify_message(_tcl_plugin, optind[type], title, msg1, msg2, NULL, NULL); + + return TCL_OK; +} + +int tcl_cmd_prefs(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + Tcl_Obj *result, *list, *elem, **elems; + char *cmds[] = { "get", "set", "type", NULL }; + enum { CMD_PREFS_GET, CMD_PREFS_SET, CMD_PREFS_TYPE } cmd; + /* char *types[] = { "none", "boolean", "int", "string", "stringlist", NULL }; */ + /* enum { TCL_PREFS_NONE, TCL_PREFS_BOOL, TCL_PREFS_INT, TCL_PREFS_STRING, TCL_PREFS_STRINGLIST } type; */ + GaimPrefType preftype; + GList *cur; + int error, intval, nelem, i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + result = Tcl_GetObjResult(interp); + switch (cmd) { + case CMD_PREFS_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "path"); + return TCL_ERROR; + } + preftype = gaim_prefs_get_type(Tcl_GetString(objv[2])); + switch (preftype) { + case GAIM_PREF_NONE: + Tcl_SetStringObj(result, "pref type none", -1); + return TCL_ERROR; + break; + case GAIM_PREF_BOOLEAN: + Tcl_SetBooleanObj(result, gaim_prefs_get_bool(Tcl_GetString(objv[2]))); + break; + case GAIM_PREF_INT: + Tcl_SetIntObj(result, gaim_prefs_get_int(Tcl_GetString(objv[2]))); + break; + case GAIM_PREF_STRING: + Tcl_SetStringObj(result, (char *)gaim_prefs_get_string(Tcl_GetString(objv[2])), -1); + break; + case GAIM_PREF_STRING_LIST: + cur = gaim_prefs_get_string_list(Tcl_GetString(objv[2])); + list = Tcl_NewListObj(0, NULL); + while (cur != NULL) { + elem = Tcl_NewStringObj((char *)cur->data, -1); + Tcl_ListObjAppendElement(interp, list, elem); + cur = g_list_next(cur); + } + Tcl_SetObjResult(interp, list); + break; + default: + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype); + Tcl_SetStringObj(result, "unknown pref type", -1); + return TCL_ERROR; + } + break; + case CMD_PREFS_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "path value"); + return TCL_ERROR; + } + preftype = gaim_prefs_get_type(Tcl_GetString(objv[2])); + switch (preftype) { + case GAIM_PREF_NONE: + Tcl_SetStringObj(result, "bad path or pref type none", -1); + return TCL_ERROR; + break; + case GAIM_PREF_BOOLEAN: + if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &intval)) != TCL_OK) + return error; + gaim_prefs_set_bool(Tcl_GetString(objv[2]), intval); + break; + case GAIM_PREF_INT: + if ((error = Tcl_GetIntFromObj(interp, objv[3], &intval)) != TCL_OK) + return error; + gaim_prefs_set_int(Tcl_GetString(objv[2]), intval); + break; + case GAIM_PREF_STRING: + gaim_prefs_set_string(Tcl_GetString(objv[2]), Tcl_GetString(objv[3])); + break; + case GAIM_PREF_STRING_LIST: + if ((error = Tcl_ListObjGetElements(interp, objv[3], &nelem, &elems)) != TCL_OK) + return error; + cur = NULL; + for (i = 0; i < nelem; i++) { + cur = g_list_append(cur, (gpointer)Tcl_GetString(elems[i])); + } + gaim_prefs_set_string_list(Tcl_GetString(objv[2]), cur); + g_list_free(cur); + break; + default: + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype); + return TCL_ERROR; + } + break; + case CMD_PREFS_TYPE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "path"); + return TCL_ERROR; + } + preftype = gaim_prefs_get_type(Tcl_GetString(objv[2])); + switch (preftype) { + case GAIM_PREF_NONE: + Tcl_SetStringObj(result, "none", -1); + break; + case GAIM_PREF_BOOLEAN: + Tcl_SetStringObj(result, "boolean", -1); + break; + case GAIM_PREF_INT: + Tcl_SetStringObj(result, "int", -1); + break; + case GAIM_PREF_STRING: + Tcl_SetStringObj(result, "string", -1); + break; + case GAIM_PREF_STRING_LIST: + Tcl_SetStringObj(result, "stringlist", -1); + break; + default: + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype); + Tcl_SetStringObj(result, "unknown", -1); + } + break; + } + + return TCL_OK; +} + +int tcl_cmd_send_im(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + GaimConnection *gc; + char *who, *text; + int error; + Tcl_Obj *result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "gc who text"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIntFromObj(interp, objv[1], (int *)&gc)) != TCL_OK) + return error; + if (!tcl_validate_gc(gc)) { + result = Tcl_GetObjResult(interp); + Tcl_SetStringObj(result, "invalid gc", -1); + return TCL_ERROR; + } + + who = Tcl_GetString(objv[2]); + text = Tcl_GetString(objv[3]); + + serv_send_im(gc, who, text, -1, 0); + + return TCL_OK; +} + +int tcl_cmd_signal(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + char *cmds[] = { "connect", "disconnect", NULL }; + enum { CMD_SIGNAL_CONNECT, CMD_SIGNAL_DISCONNECT } cmd; + struct tcl_signal_handler *handler; + Tcl_Obj **elems, *result = Tcl_GetObjResult(interp); + void *instance; + int error, nelems, i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + + if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) + return error; + + switch (cmd) { + case CMD_SIGNAL_CONNECT: + if (objc != 6) { + Tcl_WrongNumArgs(interp, 2, objv, "instance signal args proc"); + return TCL_ERROR; + } + if ((error = Tcl_ListObjGetElements(interp, objv[4], &nelems, &elems)) != TCL_OK) + return error; + handler = g_new0(struct tcl_signal_handler, 1); + if ((error = Tcl_GetIntFromObj(interp, objv[2], (int *)&handler->instance)) != TCL_OK) { + g_free(handler); + return error; + } + handler->signal = g_strdup(Tcl_GetString(objv[3])); + if (nelems) { + handler->argnames = g_new0(char *, nelems); + for (i = 0; i < nelems; i++) { + handler->argnames[i] = g_strdup(Tcl_GetString(elems[i])); + } + } + handler->nnames = nelems; + handler->proc = Tcl_NewStringObj("namespace eval ::gaim::_callback { ", -1); + Tcl_AppendStringsToObj(handler->proc, Tcl_GetString(objv[5]), " }", NULL); + Tcl_IncrRefCount(handler->proc); + handler->interp = interp; + if (!tcl_signal_connect(handler)) { + tcl_signal_handler_free(handler); + Tcl_SetIntObj(result, 1); + } else { + Tcl_SetIntObj(result, 0); + } + break; + case CMD_SIGNAL_DISCONNECT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "signal"); + return TCL_ERROR; + } + if ((error = Tcl_GetIntFromObj(interp, objv[2], (int *)&instance)) != TCL_OK) + return error; + tcl_signal_disconnect(instance, Tcl_GetString(objv[3]), interp); + break; + } + + return TCL_OK; +} + +static gboolean unload_self(gpointer data) +{ + GaimPlugin *plugin = data; + gaim_plugin_unload(plugin); + return FALSE; +} + +int tcl_cmd_unload(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +{ + GaimPlugin *plugin; + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + if ((plugin = tcl_interp_get_plugin(interp)) == NULL) { + /* This isn't exactly OK, but heh. What do you do? */ + return TCL_OK; + } + /* We can't unload immediately, but we can unload at the first + * known safe opportunity. */ + g_idle_add(unload_self, (gpointer)plugin); + + return TCL_OK; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/tcl_gaim.h Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,69 @@ +/** + * @file tcl_gaim.h Gaim Tcl definitions + * + * gaim + * + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef _GAIM_TCL_GAIM_H_ +#define _GAIM_TCL_GAIM_H_ + +#include <tcl.h> + +#include "internal.h" +#include "plugin.h" +#include "value.h" + +struct tcl_signal_handler { + char *signal; + Tcl_Interp *interp; + + void *instance; + Tcl_Obj *proc; + int nnames; + char **argnames; + + GaimValue *returntype; + int nargs; + GaimValue **argtypes; +}; + +extern GaimPlugin *_tcl_plugin; + +GaimPlugin *tcl_interp_get_plugin(Tcl_Interp *interp); + +void tcl_signal_init(); +void tcl_signal_handler_free(struct tcl_signal_handler *handler); +void tcl_signal_cleanup(Tcl_Interp *interp); +gboolean tcl_signal_connect(struct tcl_signal_handler *handler); +void tcl_signal_disconnect(void *instance, const char *signal, Tcl_Interp *interp); + +Tcl_ObjCmdProc tcl_cmd_account; +Tcl_ObjCmdProc tcl_cmd_signal_connect; +Tcl_ObjCmdProc tcl_cmd_buddy; +Tcl_ObjCmdProc tcl_cmd_connection; +Tcl_ObjCmdProc tcl_cmd_conversation; +Tcl_ObjCmdProc tcl_cmd_core; +Tcl_ObjCmdProc tcl_cmd_debug; +Tcl_ObjCmdProc tcl_cmd_notify; +Tcl_ObjCmdProc tcl_cmd_prefs; +Tcl_ObjCmdProc tcl_cmd_send_im; +Tcl_ObjCmdProc tcl_cmd_signal; +Tcl_ObjCmdProc tcl_cmd_unload; + +#endif /* _GAIM_TCL_GAIM_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/tcl_glib.c Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,225 @@ +/* + * Tcl/Glib glue + * + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + * NOTES + * + * This file was developed for the Gaim project. It inserts the Tcl + * event loop into the glib2 event loop for the purposes of providing + * Tcl bindings in a glib2 (e.g. Gtk2) program. To use it, simply + * link it into your executable, include tcl_glib.h, and call the + * function tcl_glib_init() before creating or using any Tcl + * interpreters. Then go ahead and use Tcl, Tk, whatever to your + * heart's content. + * + * BUGS + * + * tcl_wait_for_event seems to have a bug that makes vwait not work so + * well... I'm not sure why, yet, but I haven't put much time into + * it. Hopefully I will figure it out soon. In the meantime, this + * means that Tk's bgerror function (which is called when there is an + * error in a callback function) causes some Bad Mojo -- you should + * override it with a function that does not use Tk + */ + +#include <tcl.h> +#include <glib.h> +#include <string.h> + +#include "tcl_glib.h" + +struct tcl_file_handler { + int source; + int fd; + int mask; + int pending; + Tcl_FileProc *proc; + ClientData data; +}; + +struct tcl_file_event { + Tcl_Event header; + int fd; +}; + +static guint tcl_timer; +static gboolean tcl_timer_pending; +static GHashTable *tcl_file_handlers; + +static void tcl_set_timer(Tcl_Time *timePtr); +static int tcl_wait_for_event(Tcl_Time *timePtr); +static void tcl_create_file_handler(int fd, int mask, Tcl_FileProc *proc, ClientData data); +static void tcl_delete_file_handler(int fd); + +static gboolean tcl_kick(gpointer data); +static gboolean tcl_file_callback(GIOChannel *source, GIOCondition condition, gpointer data); +static int tcl_file_event_callback(Tcl_Event *event, int flags); + +ClientData Tcl_InitNotifier() +{ + return NULL; +} + +void tcl_glib_init () +{ + Tcl_NotifierProcs notifier; + + notifier.createFileHandlerProc = tcl_create_file_handler; + notifier.deleteFileHandlerProc = tcl_delete_file_handler; + notifier.setTimerProc = tcl_set_timer; + notifier.waitForEventProc = tcl_wait_for_event; + + Tcl_SetNotifier(¬ifier); + Tcl_SetServiceMode(TCL_SERVICE_ALL); + + tcl_timer_pending = FALSE; + tcl_file_handlers = g_hash_table_new(g_direct_hash, g_direct_equal); +} + +static void tcl_set_timer(Tcl_Time *timePtr) +{ + guint interval; + + if (tcl_timer_pending) + g_source_remove(tcl_timer); + + if (timePtr == NULL) { + tcl_timer_pending = FALSE; + return; + } + + interval = timePtr->sec * 1000 + (timePtr->usec ? timePtr->usec / 1000 : 0); + tcl_timer = g_timeout_add(interval, tcl_kick, NULL); + tcl_timer_pending = TRUE; +} + +static int tcl_wait_for_event(Tcl_Time *timePtr) +{ + if (!timePtr || (timePtr->sec == 0 && timePtr->usec == 0)) { + g_main_context_iteration(NULL, FALSE); + return 1; + } else { + tcl_set_timer(timePtr); + } + + g_main_context_iteration(NULL, TRUE); + + return 1; +} + +static void tcl_create_file_handler(int fd, int mask, Tcl_FileProc *proc, ClientData data) +{ + struct tcl_file_handler *tfh = g_new0(struct tcl_file_handler, 1); + GIOChannel *channel; + GIOCondition cond = 0; + + if (g_hash_table_lookup(tcl_file_handlers, (gpointer)fd)) + tcl_delete_file_handler(fd); + + if (mask & TCL_READABLE) + cond |= G_IO_IN; + if (mask & TCL_WRITABLE) + cond |= G_IO_OUT; + if (mask & TCL_EXCEPTION) + cond |= G_IO_ERR|G_IO_HUP|G_IO_NVAL; + + tfh->fd = fd; + tfh->mask = mask; + tfh->proc = proc; + tfh->data = data; + + channel = g_io_channel_unix_new(fd); + tfh->source = g_io_add_watch_full(channel, G_PRIORITY_DEFAULT, cond, tcl_file_callback, tfh, g_free); + g_io_channel_unref(channel); + + g_hash_table_insert(tcl_file_handlers, (gpointer)fd, tfh); + + Tcl_ServiceAll(); +} + +static void tcl_delete_file_handler(int fd) +{ + struct tcl_file_handler *tfh = g_hash_table_lookup(tcl_file_handlers, (gpointer)fd); + + if (tfh == NULL) + return; + + g_source_remove(tfh->source); + g_hash_table_remove(tcl_file_handlers, (gpointer)fd); + + Tcl_ServiceAll(); +} + +static gboolean tcl_kick(gpointer data) +{ + tcl_timer_pending = FALSE; + + Tcl_ServiceAll(); + + return FALSE; +} + +static gboolean tcl_file_callback(GIOChannel *source, GIOCondition condition, gpointer data) +{ + struct tcl_file_handler *tfh = data; + struct tcl_file_event *fev; + int mask = 0; + + if (condition & G_IO_IN) + mask |= TCL_READABLE; + if (condition & G_IO_OUT) + mask |= TCL_WRITABLE; + if (condition & (G_IO_ERR|G_IO_HUP|G_IO_NVAL)) + mask |= TCL_EXCEPTION; + + if (!(tfh->mask & (mask & ~tfh->pending))) + return TRUE; + + tfh->pending |= mask; + fev = (struct tcl_file_event *)ckalloc(sizeof(struct tcl_file_event)); + memset(fev, 0, sizeof(struct tcl_file_event)); + fev->header.proc = tcl_file_event_callback; + fev->fd = tfh->fd; + Tcl_QueueEvent((Tcl_Event *)fev, TCL_QUEUE_TAIL); + + Tcl_ServiceAll(); + + return TRUE; +} + +int tcl_file_event_callback(Tcl_Event *event, int flags) +{ + struct tcl_file_handler *tfh; + struct tcl_file_event *fev = (struct tcl_file_event *)event; + int mask; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + tfh = g_hash_table_lookup(tcl_file_handlers, (gpointer)fev->fd); + if (tfh == NULL) + return 1; + + mask = tfh->mask & tfh->pending; + if (mask) + (*tfh->proc)(tfh->data, mask); + tfh->pending = 0; + + return 1; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/tcl_glib.h Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,29 @@ +/* + * Tcl/Glib glue + * + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef _GAIM_TCL_GLIB_H_ +#define _GAIM_TCL_GLIB_H_ + +#include <tcl.h> +#include <glib.h> + +void tcl_glib_init(); + +#endif /* _GAIM_TCL_GLIB_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/tcl/tcl_signals.c Tue Sep 02 03:34:37 2003 +0000 @@ -0,0 +1,314 @@ +/** + * @file tcl_signals.c Gaim Tcl signal API + * + * gaim + * + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ +#include <tcl.h> +#include <stdarg.h> + +#include "tcl_gaim.h" + +#include "internal.h" +#include "connection.h" +#include "conversation.h" +#include "signals.h" +#include "debug.h" +#include "value.h" +#include "core.h" + +static GList *tcl_callbacks; + +static void *tcl_signal_callback(va_list args, struct tcl_signal_handler *handler); + +void tcl_signal_init() +{ + tcl_callbacks = NULL; +} + +void tcl_signal_handler_free(struct tcl_signal_handler *handler) +{ + if (handler == NULL) + return; + + g_free(handler->signal); + if (handler->argnames != NULL) + g_free(handler->argnames); + Tcl_DecrRefCount(handler->proc); + g_free(handler); +} + +void tcl_signal_cleanup(Tcl_Interp *interp) +{ + GList *cur; + struct tcl_signal_handler *handler; + + for (cur = tcl_callbacks; cur != NULL; cur = g_list_next(cur)) { + handler = cur->data; + if (handler->interp == interp) { + tcl_signal_handler_free(handler); + cur->data = NULL; + } + } + tcl_callbacks = g_list_remove_all(tcl_callbacks, NULL); +} + +gboolean tcl_signal_connect(struct tcl_signal_handler *handler) +{ + gaim_signal_get_values(handler->instance, handler->signal, &handler->returntype, + &handler->nargs, &handler->argtypes); + + if (handler->nargs != handler->nnames) + return FALSE; + + tcl_signal_disconnect(handler->interp, handler->signal, handler->interp); + + if (!gaim_signal_connect_vargs(handler->instance, handler->signal, (void *)handler->interp, + GAIM_CALLBACK(tcl_signal_callback), (void *)handler)) + return FALSE; + + tcl_callbacks = g_list_append(tcl_callbacks, (gpointer)handler); + + return TRUE; +} + +void tcl_signal_disconnect(void *instance, const char *signal, Tcl_Interp *interp) +{ + GList *cur; + struct tcl_signal_handler *handler; + gboolean found = FALSE; + + for (cur = tcl_callbacks; cur != NULL; cur = g_list_next(cur)) { + handler = cur->data; + if (handler->interp == interp && handler->instance == instance + && !strcmp(signal, handler->signal)) { + gaim_signal_disconnect(instance, signal, handler->interp, + GAIM_CALLBACK(tcl_signal_callback)); + tcl_signal_handler_free(handler); + cur->data = NULL; + found = TRUE; + break; + } + } + if (found) + tcl_callbacks = g_list_remove_all(tcl_callbacks, NULL); +} + +static void *tcl_signal_callback(va_list args, struct tcl_signal_handler *handler) +{ + struct var { + void *val; + char *str; + } *vars; + GString *val, *name; + GaimBlistNode *node; + int error, i; + void *retval = NULL; + Tcl_Obj *result; + + vars = g_new0(struct var, handler->nargs); + val = g_string_sized_new(32); + name = g_string_sized_new(32); + + for (i = 0; i < handler->nargs; i++) { + g_string_printf(name, "::gaim::_callback::%s", handler->argnames[i]); + + switch(gaim_value_get_type(handler->argtypes[i])) { + default: /* Yes, at the top */ + case GAIM_TYPE_UNKNOWN: /* What? I guess just pass the word ... */ + /* treat this as a pointer, but complain first */ + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "unknown GaimValue type %d\n", + gaim_value_get_type(handler->argtypes[i])); + case GAIM_TYPE_POINTER: + case GAIM_TYPE_OBJECT: + case GAIM_TYPE_BOXED: + /* These are all "pointer" types to us */ + if (gaim_value_is_outgoing(handler->argtypes[i])) { + vars[i].val = va_arg(args, void **); + Tcl_LinkVar(handler->interp, name->str, vars[i].val, TCL_LINK_INT); + } else { + vars[i].val = va_arg(args, void *); + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].val, + TCL_LINK_INT|TCL_LINK_READ_ONLY); + } + break; + case GAIM_TYPE_BOOLEAN: + if (gaim_value_is_outgoing(handler->argtypes[i])) { + vars[i].val = va_arg(args, gboolean *); + Tcl_LinkVar(handler->interp, name->str, vars[i].val, TCL_LINK_BOOLEAN); + } else { + vars[i].val = (void *)va_arg(args, gboolean); + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].val, + TCL_LINK_BOOLEAN|TCL_LINK_READ_ONLY); + } + break; + case GAIM_TYPE_CHAR: + case GAIM_TYPE_UCHAR: + case GAIM_TYPE_SHORT: + case GAIM_TYPE_USHORT: + case GAIM_TYPE_INT: + case GAIM_TYPE_UINT: + case GAIM_TYPE_LONG: + case GAIM_TYPE_ULONG: + case GAIM_TYPE_ENUM: + /* These next two are totally bogus */ + case GAIM_TYPE_INT64: + case GAIM_TYPE_UINT64: + /* I should really cast these individually to + * preserve as much information as possible ... + * but heh */ + if (gaim_value_is_outgoing(handler->argtypes[i])) { + vars[i].val = (void *)va_arg(args, int *); + Tcl_LinkVar(handler->interp, name->str, vars[i].val, TCL_LINK_INT); + } else { + vars[i].val = (void *)va_arg(args, int); + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].val, + TCL_LINK_INT|TCL_LINK_READ_ONLY); + } + break; + case GAIM_TYPE_STRING: + if (gaim_value_is_outgoing(handler->argtypes[i])) { + vars[i].val = (void *)va_arg(args, char **); + if (vars[i].val != NULL && *(char **)vars[i].val != NULL) { + vars[i].str = (char *)ckalloc(strlen(*(char **)vars[i].val) + 1); + strcpy(vars[i].str, *(char **)vars[i].val); + } else { + vars[i].str = (char *)ckalloc(1); + *vars[i].str = '\0'; + } + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].str, TCL_LINK_STRING); + } else { + vars[i].val = (void *)va_arg(args, char *); + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].val, + TCL_LINK_STRING|TCL_LINK_READ_ONLY); + } + break; + case GAIM_TYPE_SUBTYPE: + switch (gaim_value_get_subtype(handler->argtypes[i])) { + default: + case GAIM_SUBTYPE_UNKNOWN: + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "subtype unknown\n"); + case GAIM_SUBTYPE_ACCOUNT: + case GAIM_SUBTYPE_CONNECTION: + case GAIM_SUBTYPE_CONVERSATION: + case GAIM_SUBTYPE_CONV_WINDOW: + case GAIM_SUBTYPE_PLUGIN: + /* pointers again */ + if (gaim_value_is_outgoing(handler->argtypes[i])) { + vars[i].val = va_arg(args, void **); + Tcl_LinkVar(handler->interp, name->str, vars[i].val, TCL_LINK_INT); + } else { + vars[i].val = va_arg(args, void *); + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].val, + TCL_LINK_INT|TCL_LINK_READ_ONLY); + } + break; + case GAIM_SUBTYPE_BLIST: + case GAIM_SUBTYPE_BLIST_BUDDY: + case GAIM_SUBTYPE_BLIST_GROUP: + case GAIM_SUBTYPE_BLIST_CHAT: + /* We're going to switch again for code-deduping */ + if (gaim_value_is_outgoing(handler->argtypes[i])) + node = *va_arg(args, GaimBlistNode **); + else + node = va_arg(args, GaimBlistNode *); + switch (node->type) { + case GAIM_BLIST_GROUP_NODE: + g_string_printf(val, "group {%s}", ((struct group *)node)->name); + break; + case GAIM_BLIST_BUDDY_NODE: + g_string_printf(val, "buddy {%s} %lu", ((struct buddy *)node)->name, + (unsigned long)((struct buddy *)node)->account); + break; + case GAIM_BLIST_CHAT_NODE: + g_string_printf(val, "chat {%s} %lu", ((struct chat *)node)->alias, + (unsigned long)((struct chat *)node)->account); + break; + case GAIM_BLIST_OTHER_NODE: + g_string_printf(val, "other"); + break; + } + vars[i].str = g_strdup(val->str); + Tcl_LinkVar(handler->interp, name->str, (char *)&vars[i].str, + TCL_LINK_STRING|TCL_LINK_READ_ONLY); + break; + } + } + } + + /* Call the friggin' procedure already */ + if ((error = Tcl_EvalObjEx(handler->interp, handler->proc, TCL_EVAL_GLOBAL)) != TCL_OK) { + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "error evaluating callback: %s\n", + Tcl_GetString(Tcl_GetObjResult(handler->interp))); + } else { + result = Tcl_GetObjResult(handler->interp); + /* handle return values -- strings and words only */ + if (handler->returntype) { + if (gaim_value_get_type(handler->returntype) == GAIM_TYPE_STRING) { + retval = (void *)g_strdup(Tcl_GetString(result)); + } else { + if ((error = Tcl_GetIntFromObj(handler->interp, result, (int *)&retval)) != TCL_OK) { + gaim_debug(GAIM_DEBUG_ERROR, "tcl", "Error retrieving procedure result: %s\n", + Tcl_GetString(Tcl_GetObjResult(handler->interp))); + retval = NULL; + } + } + } + } + + /* And finally clean up */ + for (i = 0; i < handler->nargs; i++) { + g_string_printf(name, "::gaim::_callback::%s", handler->argnames[i]); + Tcl_UnlinkVar(handler->interp, name->str); + /* We basically only have to deal with strings and buddies + * on the way out */ + switch (gaim_value_get_type(handler->argtypes[i])) { + case GAIM_TYPE_STRING: + if (gaim_value_is_outgoing(handler->argtypes[i])) { + if (vars[i].val != NULL && *(char **)vars[i].val != NULL) { + g_free(*(char **)vars[i].val); + *(char **)vars[i].val = g_strdup(vars[i].str); + } + ckfree(vars[i].str); + } + break; + case GAIM_TYPE_SUBTYPE: + switch(gaim_value_get_subtype(handler->argtypes[i])) { + case GAIM_SUBTYPE_BLIST: + case GAIM_SUBTYPE_BLIST_BUDDY: + case GAIM_SUBTYPE_BLIST_GROUP: + case GAIM_SUBTYPE_BLIST_CHAT: + g_free(vars[i].str); + break; + default: + /* nothing */ + ; + } + break; + default: + /* nothing */ + ; + } + } + + g_string_free(name, TRUE); + g_string_free(val, FALSE); + g_free(vars); + + return retval; +}