gaim/gaim
Clone
Summary
Browse
Changes
Graph
Make this sucker compile again!!
draft
default
tip
2022-03-31, Gary Kramlich
ea0a68c3b8a8
Make this sucker compile again!!
/**
* @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"
#include
"version.h"
struct
tcl_plugin_data
{
GaimPlugin
*
plugin
;
Tcl_Interp
*
interp
;
};
static
GHashTable
*
tcl_plugins
=
NULL
;
GaimPlugin
*
_tcl_plugin
;
static
gboolean
tcl_loaded
=
FALSE
;
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
;
}
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
;
const
char
*
next
;
int
len
,
found
=
0
,
err
=
0
,
nelems
;
gboolean
status
=
FALSE
;
if
((
fp
=
g_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
);
cur
=
buf
;
while
(
fgets
(
cur
,
(
int
)
buf
-
(
buf
-
cur
),
fp
))
{
cur
+=
strlen
(
cur
);
if
(
feof
(
fp
))
break
;
}
if
(
ferror
(
fp
))
{
gaim_debug
(
GAIM_DEBUG_ERROR
,
"tcl"
,
"error reading %s (%s)
\n
"
,
plugin
->
path
,
strerror
(
errno
));
g_free
(
buf
);
fclose
(
fp
);
return
FALSE
;
}
fclose
(
fp
);
if
((
interp
=
tcl_create_interp
())
==
NULL
)
{
return
FALSE
;
}
next
=
buf
;
do
{
if
(
Tcl_ParseCommand
(
interp
,
next
,
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
)
-
next
;
next
=
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
==
6
)
||
(
nelems
==
7
))
{
info
=
g_new0
(
GaimPluginInfo
,
1
);
info
->
magic
=
GAIM_PLUGIN_MAGIC
;
info
->
major_version
=
GAIM_MAJOR_VERSION
;
info
->
minor_version
=
GAIM_MINOR_VERSION
;
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
->
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
]));
if
(
nelems
==
6
)
info
->
id
=
g_strdup_printf
(
"tcl-%s"
,
Tcl_GetString
(
listitems
[
0
]));
else
if
(
nelems
==
7
)
info
->
id
=
g_strdup_printf
(
"tcl-%s"
,
Tcl_GetString
(
listitems
[
6
]));
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
;
if
(
data
!=
NULL
)
{
g_hash_table_remove
(
tcl_plugins
,
(
gpointer
)(
data
->
interp
));
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
->
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
);
}
return
;
}
static
gboolean
tcl_load
(
GaimPlugin
*
plugin
)
{
if
(
!
tcl_loaded
)
return
FALSE
;
tcl_glib_init
();
tcl_signal_init
();
tcl_plugins
=
g_hash_table_new
(
g_direct_hash
,
g_direct_equal
);
#ifdef HAVE_TK
Tcl_StaticPackage
(
NULL
,
"Tk"
,
Tk_Init
,
Tk_SafeInit
);
#endif
/* HAVE_TK */
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
=
{
GAIM_PLUGIN_MAGIC
,
GAIM_MAJOR_VERSION
,
GAIM_MINOR_VERSION
,
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
,
NULL
,
NULL
};
#ifdef _WIN32
typedef
Tcl_Interp
*
(
CALLBACK
*
LPFNTCLCREATEINTERP
)(
void
);
typedef
void
(
CALLBACK
*
LPFNTKINIT
)(
Tcl_Interp
*
);
LPFNTCLCREATEINTERP
wtcl_CreateInterp
=
NULL
;
LPFNTKINIT
wtk_Init
=
NULL
;
#undef Tcl_CreateInterp
#define Tcl_CreateInterp wtcl_CreateInterp
#undef Tk_Init
#define Tk_Init wtk_Init
static
gboolean
tcl_win32_init
()
{
gaim_debug
(
GAIM_DEBUG_INFO
,
"tcl"
,
"Initializing the Tcl runtime. If Gaim doesn't load, it is "
"most likely because you have cygwin in your PATH and you "
"should remove it. See http://gaim.sf.net/win32 for more "
"information
\n
"
);
if
(
!
(
wtcl_CreateInterp
=
(
LPFNTCLCREATEINTERP
)
wgaim_find_and_loadproc
(
"tcl84.dll"
,
"Tcl_CreateInterp"
)))
{
gaim_debug
(
GAIM_DEBUG_INFO
,
"tcl"
,
"tcl_win32_init error loading Tcl_CreateInterp
\n
"
);
return
FALSE
;
}
if
(
!
(
wtk_Init
=
(
LPFNTKINIT
)
wgaim_find_and_loadproc
(
"tk84.dll"
,
"Tk_Init"
)))
{
HMODULE
mod
;
gaim_debug
(
GAIM_DEBUG_INFO
,
"tcl"
,
"tcl_win32_init error loading Tk_Init
\n
"
);
if
((
mod
=
GetModuleHandle
(
"tcl84.dll"
)))
FreeLibrary
(
mod
);
return
FALSE
;
}
if
(
GetModuleHandle
(
"cygwin1.dll"
))
{
HMODULE
mod
;
gaim_debug
(
GAIM_DEBUG_INFO
,
"tcl"
,
"Cygwin has been loaded by tcl84.dll and/or tk84.dll. Disabling Tcl support to avoid problems.
\n
"
);
if
((
mod
=
GetModuleHandle
(
"tcl84.dll"
)))
FreeLibrary
(
mod
);
if
((
mod
=
GetModuleHandle
(
"tk84.dll"
)))
FreeLibrary
(
mod
);
return
FALSE
;
}
return
TRUE
;
}
#endif
/* _WIN32 */
static
void
tcl_init_plugin
(
GaimPlugin
*
plugin
)
{
#ifdef USE_TCL_STUBS
Tcl_Interp
*
interp
=
NULL
;
#endif
_tcl_plugin
=
plugin
;
#ifdef USE_TCL_STUBS
#ifdef _WIN32
if
(
!
tcl_win32_init
())
return
;
#endif
if
(
!
(
interp
=
Tcl_CreateInterp
()))
return
;
if
(
!
Tcl_InitStubs
(
interp
,
TCL_VERSION
,
0
))
{
gaim_debug
(
GAIM_DEBUG_ERROR
,
"tcl"
,
"Tcl_InitStubs: %s
\n
"
,
interp
->
result
);
return
;
}
#endif
Tcl_FindExecutable
(
"gaim"
);
#if defined(USE_TK_STUBS) && defined(HAVE_TK)
Tk_Init
(
interp
);
if
(
!
Tk_InitStubs
(
interp
,
TK_VERSION
,
0
))
{
gaim_debug
(
GAIM_DEBUG_ERROR
,
"tcl"
,
"Error Tk_InitStubs: %s
\n
"
,
interp
->
result
);
Tcl_DeleteInterp
(
interp
);
return
;
}
#endif
tcl_loaded
=
TRUE
;
#ifdef USE_TCL_STUBS
Tcl_DeleteInterp
(
interp
);
#endif
tcl_loader_info
.
exts
=
g_list_append
(
tcl_loader_info
.
exts
,
"tcl"
);
}
GAIM_INIT_PLUGIN
(
tcl
,
tcl_init_plugin
,
tcl_info
)