00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020 #ifndef lint
00021 static const char rcsid[] = "$Id: tclscript.c,v 1.52 2007-04-14 15:21:13 sven Exp $";
00022 #endif
00023
00024 #include <string.h>
00025 #include <stdlib.h>
00026
00027 #include <tcl.h>
00028
00029 #include <eggdrop/eggdrop.h>
00030
00031 #if (((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 1)) || (TCL_MAJOR_VERSION > 8))
00032 # define USE_TCL_BYTE_ARRAYS
00033 #endif
00034
00035
00036 typedef struct {
00037 Tcl_Interp *myinterp;
00038 Tcl_Obj *command;
00039 char *name;
00040 } my_callback_cd_t;
00041
00042
00043 typedef struct {
00044 Tcl_Interp *irp;
00045 Tcl_Obj *CONST *objv;
00046 } my_args_data_t;
00047
00048 static int my_command_handler(ClientData client_data, Tcl_Interp *myinterp, int objc, Tcl_Obj *CONST objv[]);
00049 static Tcl_Obj *c_to_tcl_var(Tcl_Interp *myinterp, script_var_t *v);
00050 static int tcl_to_c_var(Tcl_Interp *myinterp, Tcl_Obj *obj, script_var_t *var, int type);
00051 static int my_tcl_cb_delete(event_owner_t *owner, void *me);
00052
00053
00054 static int my_load_script(void *ignore, char *fname);
00055 static int my_link_var(void *ignore, script_linked_var_t *var);
00056 static int my_unlink_var(void *ignore, script_linked_var_t *var);
00057 static int my_create_command(void *ignore, script_raw_command_t *info);
00058 static int my_delete_command(void *ignore, script_raw_command_t *info);
00059 static int my_get_arg(void *ignore, script_args_t *args, int num, script_var_t *var, int type);
00060
00061 static event_owner_t tcl_owner = {
00062 "tclscript", 0,
00063 0, 0,
00064 my_tcl_cb_delete
00065 };
00066
00067 static script_module_t my_script_interface = {
00068 "Tcl", NULL,
00069 my_load_script,
00070 my_link_var, my_unlink_var,
00071 my_create_command, my_delete_command,
00072 my_get_arg
00073 };
00074
00075 static Tcl_Interp *ginterp;
00076
00077 static char *error_logfile = NULL;
00078
00079 #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 2)
00080
00081 static Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *myinterp, const char *name1, const char *name2, Tcl_Obj *newval, int flags) {
00082 Tcl_Obj *part1, *part2, *obj;
00083
00084 part1 = Tcl_NewStringObj((char *)name1, -1);
00085 part2 = Tcl_NewStringObj((char *)name2, -1);
00086 obj = Tcl_ObjSetVar2(myinterp, part1, part2, newval, flags);
00087 Tcl_DecrRefCount(part1);
00088 Tcl_DecrRefCount(part2);
00089 return(obj);
00090 }
00091
00092 static Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *myinterp, const char *name1, const char *name2, int flags) {
00093 Tcl_Obj *part1, *part2, *obj;
00094
00095 part1 = Tcl_NewStringObj((char *)name1, -1);
00096 part2 = Tcl_NewStringObj((char *)name2, -1);
00097 obj = Tcl_ObjGetVar2(myinterp, part1, part2, flags);
00098 Tcl_DecrRefCount(part1);
00099 Tcl_DecrRefCount(part2);
00100 return(obj);
00101 }
00102 #endif
00103
00104
00105 static int my_load_script(void *ignore, char *fname)
00106 {
00107 int result;
00108 int len;
00109
00110
00111 len = strlen(fname);
00112 if (len < 4 || fname[len-1] != 'l' || fname[len-2] != 'c' || fname[len-3] != 't' || fname[len-4] != '.') {
00113
00114 return SCRIPT_ERR_NOT_RESPONSIBLE;
00115 }
00116
00117 result = Tcl_EvalFile (ginterp, fname);
00118 if (result != TCL_OK) {
00119 putlog (LOG_MISC, "*", _("Failed to load script %s: %s"),
00120 fname, Tcl_GetStringResult (ginterp));
00121 return SCRIPT_ERR_CODE;
00122 }
00123
00124 return SCRIPT_OK;
00125 }
00126
00127
00128 static void set_linked_var(script_linked_var_t *var, script_var_t *val)
00129 {
00130 Tcl_Obj *obj;
00131 script_var_t script_var;
00132
00133 if (!val || !val->type) {
00134 script_var.type = var->type & SCRIPT_TYPE_MASK;
00135 script_var.len = -1;
00136 script_var.value = *(void **)var->value;
00137 val = &script_var;
00138 }
00139
00140 obj = c_to_tcl_var(ginterp, val);
00141
00142 if (var->class && strlen(var->class)) {
00143 Tcl_SetVar2Ex(ginterp, var->class, var->name, obj, TCL_GLOBAL_ONLY);
00144 }
00145 else {
00146 Tcl_SetVar2Ex(ginterp, var->name, NULL, obj, TCL_GLOBAL_ONLY);
00147 }
00148 }
00149
00150
00151 static char *my_trace_callback(ClientData client_data, Tcl_Interp *irp, char *name1, char *name2, int flags)
00152 {
00153 script_linked_var_t *linked_var = (script_linked_var_t *)client_data;
00154 script_var_t newvalue = {0};
00155
00156 if (flags & TCL_INTERP_DESTROYED) return(NULL);
00157
00158 if (flags & TCL_TRACE_READS) {
00159 if (linked_var->callbacks && linked_var->callbacks->on_read) {
00160 int r = (linked_var->callbacks->on_read)(linked_var, &newvalue);
00161 if (r) return(NULL);
00162 }
00163 set_linked_var(linked_var, &newvalue);
00164 }
00165 else if (flags & TCL_TRACE_WRITES) {
00166 Tcl_Obj *obj;
00167
00168 if (linked_var->type & SCRIPT_READONLY) return("read only variable");
00169
00170 obj = Tcl_GetVar2Ex(irp, name1, name2, 0);
00171 if (!obj) return("Error setting variable");
00172
00173 tcl_to_c_var(irp, obj, &newvalue, linked_var->type);
00174 script_linked_var_on_write(linked_var, &newvalue);
00175 }
00176 else if (flags & TCL_TRACE_UNSETS) {
00177
00178 if (flags & TCL_TRACE_DESTROYED) my_link_var(NULL, linked_var);
00179 else set_linked_var(linked_var, NULL);
00180 return("read only variable");
00181 }
00182 return(NULL);
00183 }
00184
00185
00186 static int my_link_var(void *ignore, script_linked_var_t *var)
00187 {
00188 char *varname;
00189
00190 if (var->class && strlen(var->class)) varname = egg_mprintf("%s(%s)", var->class, var->name);
00191 else varname = strdup(var->name);
00192
00193 set_linked_var(var, NULL);
00194 Tcl_TraceVar(ginterp, varname, TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, (Tcl_VarTraceProc *)my_trace_callback, var);
00195
00196 free(varname);
00197 return(0);
00198 }
00199
00200
00201 static int my_unlink_var(void *ignore, script_linked_var_t *var)
00202 {
00203 char *varname;
00204
00205 if (var->class && strlen(var->class)) varname = egg_mprintf("%s(%s)", var->class, var->name);
00206 else varname = strdup(var->name);
00207
00208 Tcl_UntraceVar(ginterp, varname, TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, (Tcl_VarTraceProc *)my_trace_callback, var);
00209
00210 free(varname);
00211 return(0);
00212 }
00213
00214 static void log_error_message(Tcl_Interp *myinterp)
00215 {
00216 FILE *fp;
00217 const char *errmsg;
00218 time_t timenow;
00219
00220 errmsg = Tcl_GetStringResult(myinterp);
00221 putlog(LOG_MISC, "*", "Tcl Error: %s", errmsg);
00222
00223 if (!error_logfile || !error_logfile[0]) return;
00224
00225 timenow = time(NULL);
00226 fp = fopen(error_logfile, "a");
00227 if (!fp) putlog(LOG_MISC, "*", _("Error opening Tcl error log (%s)!"), error_logfile);
00228 else {
00229 errmsg = Tcl_GetVar(myinterp, "errorInfo", TCL_GLOBAL_ONLY);
00230 fprintf(fp, "%s", asctime(localtime(&timenow)));
00231 fprintf(fp, "%s\n\n", errmsg);
00232 fclose(fp);
00233 }
00234 }
00235
00236
00237
00238 static int my_tcl_callbacker(script_callback_t *me, ...)
00239 {
00240 Tcl_Obj *arg, *final_command, *result;
00241 Tcl_Interp *interp;
00242 script_var_t var;
00243 my_callback_cd_t *cd;
00244 int i, n, retval;
00245 va_list va;
00246
00247
00248 cd = (my_callback_cd_t *)me->callback_data;
00249
00250
00251 final_command = Tcl_DuplicateObj(cd->command);
00252
00253 if (me->syntax) n = strlen(me->syntax);
00254 else n = 0;
00255
00256 va_start(va, me);
00257 for (i = 0; i < n; i++) {
00258 var.type = me->syntax[i];
00259 if (var.type == SCRIPT_INTEGER || var.type == SCRIPT_UNSIGNED) var.value = (void *) (va_arg(va, int));
00260 else var.value = va_arg(va, void *);
00261 var.len = -1;
00262 arg = c_to_tcl_var(cd->myinterp, &var);
00263 Tcl_ListObjAppendElement(cd->myinterp, final_command, arg);
00264 }
00265 va_end(va);
00266
00267 interp = cd->myinterp;
00268
00269 #ifdef USE_TCL_BYTE_ARRAYS
00270 n = Tcl_EvalObjEx(interp, final_command, TCL_EVAL_GLOBAL);
00271 #else
00272 n = Tcl_GlobalEvalObj(interp, final_command);
00273 #endif
00274
00275 if (n == TCL_OK) {
00276 result = Tcl_GetObjResult(interp);
00277 Tcl_GetIntFromObj(interp, result, &retval);
00278 }
00279 else {
00280 log_error_message(interp);
00281 Tcl_BackgroundError(interp);
00282 }
00283
00284
00285 Tcl_ResetResult(interp);
00286
00287 return(retval);
00288 }
00289
00290
00291 static int my_tcl_cb_delete(event_owner_t *owner, void *data)
00292 {
00293 script_callback_t *me = data;
00294 my_callback_cd_t *cd;
00295
00296 cd = me->callback_data;
00297 Tcl_DecrRefCount(cd->command);
00298 if (cd->name) free(cd->name);
00299 if (me->syntax) free(me->syntax);
00300 if (me->name) free(me->name);
00301 free(cd);
00302 free(me);
00303 return(0);
00304 }
00305
00306
00307 static int my_create_command(void *ignore, script_raw_command_t *info)
00308 {
00309 char *cmdname;
00310
00311 if (info->class && strlen(info->class)) {
00312 cmdname = egg_mprintf("%s_%s", info->class, info->name);
00313 }
00314 else {
00315 cmdname = strdup(info->name);
00316 }
00317 Tcl_CreateObjCommand(ginterp, cmdname, my_command_handler, (ClientData) info, NULL);
00318 free(cmdname);
00319
00320 return(0);
00321 }
00322
00323
00324 static int my_delete_command(void *ignore, script_raw_command_t *info)
00325 {
00326 char *cmdname;
00327
00328 if (info->class && strlen(info->class)) {
00329 cmdname = egg_mprintf("%s_%s", info->class, info->name);
00330 }
00331 else {
00332 cmdname = strdup(info->name);
00333 }
00334 Tcl_DeleteCommand(ginterp, cmdname);
00335 free(cmdname);
00336
00337 return(0);
00338 }
00339
00340
00341 static Tcl_Obj *c_to_tcl_var(Tcl_Interp *myinterp, script_var_t *v)
00342 {
00343 Tcl_Obj *result;
00344
00345 result = NULL;
00346
00347 if (v->type & SCRIPT_ARRAY) {
00348 Tcl_Obj *element;
00349 int i;
00350
00351 result = Tcl_NewListObj(0, NULL);
00352
00353 if ((v->type & SCRIPT_TYPE_MASK) == SCRIPT_VAR) {
00354 script_var_t **v_list;
00355
00356 v_list = (script_var_t **)v->value;
00357 for (i = 0; i < v->len; i++) {
00358 element = c_to_tcl_var(myinterp, v_list[i]);
00359 Tcl_ListObjAppendElement(myinterp, result, element);
00360 }
00361 }
00362 else {
00363
00364 script_var_t v_sub;
00365 void **values;
00366
00367 values = (void **)v->value;
00368 for (i = 0; i < v->len; i++) {
00369 v_sub.type = v->type & (~SCRIPT_ARRAY);
00370 v_sub.value = values[i];
00371 v_sub.len = -1;
00372 element = c_to_tcl_var(myinterp, &v_sub);
00373 Tcl_ListObjAppendElement(myinterp, result, element);
00374 }
00375 }
00376
00377 if (v->type & SCRIPT_FREE) free(v->value);
00378 if (v->type & SCRIPT_FREE_VAR) free(v);
00379 return(result);
00380 }
00381
00382
00383 switch (v->type & SCRIPT_TYPE_MASK) {
00384 case SCRIPT_INTEGER:
00385 case SCRIPT_UNSIGNED:
00386 result = Tcl_NewIntObj((int) v->value);
00387 break;
00388 case SCRIPT_STRING: {
00389 char *str = v->value;
00390
00391 if (!str) str = "";
00392 if (v->len == -1) v->len = strlen(str);
00393 #ifdef USE_TCL_BYTE_ARRAYS
00394 result = Tcl_NewByteArrayObj((unsigned char *) str, v->len);
00395 #else
00396 result = Tcl_NewStringObj(str, v->len);
00397 #endif
00398 if (v->value && v->type & SCRIPT_FREE) free(v->value);
00399 break;
00400 }
00401 case SCRIPT_STRING_LIST: {
00402 char **str = v->value;
00403 Tcl_Obj *element;
00404
00405 result = Tcl_NewListObj(0, NULL);
00406 while (str && *str) {
00407 #ifdef USE_TCL_BYTE_ARRAYS
00408 element = Tcl_NewByteArrayObj((unsigned char *) (*str), strlen(*str));
00409 #else
00410 element = Tcl_NewStringObj(*str, strlen(*str));
00411 #endif
00412 Tcl_ListObjAppendElement(myinterp, result, element);
00413 str++;
00414 }
00415 break;
00416 }
00417 case SCRIPT_BYTES: {
00418 byte_array_t *bytes = v->value;
00419 #ifdef USE_TCL_BYTE_ARRAYS
00420 result = Tcl_NewByteArrayObj(bytes->bytes, bytes->len);
00421 #else
00422 result = Tcl_NewStringObj(bytes->bytes, bytes->len);
00423 #endif
00424 if (bytes->do_free) free(bytes->bytes);
00425 if (v->type & SCRIPT_FREE) free(bytes);
00426 break;
00427 }
00428 case SCRIPT_POINTER: {
00429 char str[32];
00430
00431 sprintf(str, "#%u", (unsigned int) v->value);
00432 result = Tcl_NewStringObj(str, -1);
00433 break;
00434 }
00435 case SCRIPT_PARTIER: {
00436 partymember_t *p = v->value;
00437
00438 if (p) result = Tcl_NewStringObj(p->full_id_name, -1);
00439 else result = Tcl_NewStringObj("*", -1);
00440 break;
00441 }
00442 case SCRIPT_USER: {
00443
00444 char *handle;
00445 user_t *u = v->value;
00446
00447 if (u) handle = u->handle;
00448 else handle = "*";
00449 result = Tcl_NewStringObj(handle, -1);
00450 break;
00451 }
00452 default:
00453
00454 result = Tcl_NewStringObj("unsupported type", -1);
00455 }
00456 if (v->type & SCRIPT_FREE_VAR) free(v);
00457 return(result);
00458 }
00459
00460
00461
00462
00463 static int tcl_to_c_var(Tcl_Interp *myinterp, Tcl_Obj *obj, script_var_t *var, int type)
00464 {
00465 int err = TCL_OK;
00466
00467 var->type = type;
00468 var->len = -1;
00469 var->value = NULL;
00470
00471 switch (type & SCRIPT_TYPE_MASK) {
00472 case SCRIPT_STRING: {
00473 char *str;
00474 int len;
00475
00476 #ifdef USE_TCL_BYTE_ARRAYS
00477 unsigned char *bytes;
00478
00479 bytes = Tcl_GetByteArrayFromObj(obj, &len);
00480 str = malloc(len+1);
00481 memcpy(str, bytes, len);
00482 str[len] = 0;
00483 var->type |= SCRIPT_FREE;
00484 #else
00485 str = Tcl_GetStringFromObj(obj, &len);
00486 #endif
00487 var->value = str;
00488 var->len = len;
00489 break;
00490 }
00491 case SCRIPT_BYTES: {
00492 byte_array_t *byte_array;
00493
00494 byte_array = malloc(sizeof(*byte_array));
00495
00496 #ifdef USE_TCL_BYTE_ARRAYS
00497 byte_array->bytes = Tcl_GetByteArrayFromObj(obj, &byte_array->len);
00498 #else
00499 byte_array->bytes = Tcl_GetStringFromObj(obj, &byte_array->len);
00500 #endif
00501
00502 var->value = byte_array;
00503 var->type |= SCRIPT_FREE;
00504 break;
00505 }
00506 case SCRIPT_UNSIGNED:
00507 case SCRIPT_INTEGER: {
00508 int intval = 0;
00509
00510 err = Tcl_GetIntFromObj(myinterp, obj, &intval);
00511 var->value = (void *) intval;
00512 break;
00513 }
00514 case SCRIPT_CALLBACK: {
00515 script_callback_t *cback;
00516 my_callback_cd_t *cdata;
00517
00518 cback = calloc(1, sizeof(*cback));
00519 cdata = calloc(1, sizeof(*cdata));
00520 cback->callback = (Function) my_tcl_callbacker;
00521 cback->callback_data = cdata;
00522 cback->name = strdup(Tcl_GetString(obj));
00523 cback->owner = &tcl_owner;
00524 cdata->myinterp = myinterp;
00525 cdata->command = obj;
00526 Tcl_IncrRefCount(obj);
00527
00528 var->value = cback;
00529 break;
00530 }
00531 case SCRIPT_PARTIER: {
00532 const char *name;
00533
00534 name = Tcl_GetString(obj);
00535 var->value = partymember_lookup(name, NULL, -1);
00536 break;
00537 }
00538 case SCRIPT_USER: {
00539 user_t *u;
00540 script_var_t handle;
00541
00542
00543 tcl_to_c_var(myinterp, obj, &handle, SCRIPT_STRING);
00544 u = user_lookup_by_handle((char *)handle.value);
00545 if (handle.type & SCRIPT_FREE) free(handle.value);
00546 var->value = u;
00547 if (!u) {
00548 Tcl_AppendResult(myinterp, "User not found", NULL);
00549 err++;
00550 }
00551 break;
00552 }
00553 default: {
00554 char vartype[2];
00555
00556 vartype[0] = type;
00557 vartype[1] = 0;
00558 Tcl_AppendResult(myinterp, _("Cannot convert Tcl object to unknown variable type '"), vartype, "'.", NULL);
00559 err++;
00560 }
00561 }
00562
00563 return(err);
00564 }
00565
00566
00567 static int my_command_handler(ClientData client_data, Tcl_Interp *myinterp, int objc, Tcl_Obj *CONST objv[])
00568 {
00569 script_raw_command_t *cmd = (script_raw_command_t *)client_data;
00570 script_var_t retval;
00571 Tcl_Obj *tcl_retval = NULL;
00572 script_args_t args;
00573 my_args_data_t argdata;
00574 int err;
00575
00576
00577 argdata.irp = myinterp;
00578 argdata.objv = objv;
00579 args.module = &my_script_interface;
00580 args.client_data = &argdata;
00581 args.len = objc-1;
00582
00583
00584 retval.type = 0;
00585 retval.value = NULL;
00586 retval.len = -1;
00587
00588
00589 cmd->callback(cmd->client_data, &args, &retval);
00590 err = retval.type & SCRIPT_ERROR;
00591
00592
00593 tcl_retval = c_to_tcl_var(myinterp, &retval);
00594
00595 if (tcl_retval) Tcl_SetObjResult(myinterp, tcl_retval);
00596 else Tcl_ResetResult(myinterp);
00597
00598 if (err) return TCL_ERROR;
00599 return TCL_OK;
00600 }
00601
00602 static int my_get_arg(void *ignore, script_args_t *args, int num, script_var_t *var, int type)
00603 {
00604 my_args_data_t *argdata;
00605
00606 argdata = (my_args_data_t *)args->client_data;
00607 return tcl_to_c_var(argdata->irp, argdata->objv[num+1], var, type);
00608 }
00609
00610 static int party_tcl(partymember_t *p, char *nick, user_t *u, char *cmd, char *text)
00611 {
00612 const char *str;
00613
00614 if (!u || !egg_isowner(u->handle)) {
00615 partymember_write(p, _("You must be a permanent owner (defined in the config file) to use this command.\n"), -1);
00616 return(BIND_RET_LOG);
00617 }
00618
00619 if (!text) {
00620 partymember_write(p, _("Syntax: .tcl <tclexpression>"), -1);
00621 return(0);
00622 }
00623
00624 if (Tcl_GlobalEval(ginterp, text) != TCL_OK) {
00625 str = Tcl_GetVar(ginterp, "errorInfo", TCL_GLOBAL_ONLY);
00626 if (!str) str = Tcl_GetStringResult(ginterp);
00627 partymember_printf(p, _("Tcl error: %s\n\n"), str);
00628 }
00629 else {
00630 str = Tcl_GetStringResult(ginterp);
00631 partymember_printf(p, _("Tcl: %s\n\n"), str);
00632 }
00633 return(0);
00634 }
00635
00636 typedef struct tcl_listener {
00637 struct tcl_listener *next;
00638 char *name;
00639 int fd;
00640 } tcl_listener_t;
00641
00642 static tcl_listener_t *listener_list_head = NULL;
00643
00644
00645 static int add_tcl_chan(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
00646 {
00647 Tcl_Channel chan;
00648 char *chan_name;
00649 int modes;
00650 void *fd;
00651 tcl_listener_t *listener;
00652
00653 if (objc != 2) {
00654 Tcl_WrongNumArgs(interp, 0, NULL, "channel-name");
00655 return(TCL_ERROR);
00656 }
00657
00658 chan_name = Tcl_GetStringFromObj(objv[1], NULL);
00659 if (!chan_name) return(TCL_ERROR);
00660 chan = Tcl_GetChannel(interp, chan_name, &modes);
00661 if (!chan) return(TCL_ERROR);
00662 if (Tcl_GetChannelHandle(chan, TCL_READABLE, &fd)) return(TCL_ERROR);
00663 listener = malloc(sizeof(*listener));
00664 listener->next = listener_list_head;
00665 listener->name = strdup(chan_name);
00666 listener->fd = (int) fd;
00667 listener_list_head = listener;
00668 sockbuf_attach_listener((int) fd);
00669 return(0);
00670 }
00671
00672 static int rem_tcl_chan(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
00673 {
00674 char *chan_name;
00675 tcl_listener_t *listener, *prev;
00676
00677 if (objc != 2) {
00678 Tcl_WrongNumArgs(interp, 0, NULL, "channel-name");
00679 return(TCL_ERROR);
00680 }
00681
00682 chan_name = Tcl_GetStringFromObj(objv[1], NULL);
00683 if (!chan_name) return(TCL_ERROR);
00684
00685 prev = NULL;
00686 for (listener = listener_list_head; listener; listener = listener->next) {
00687 if (!strcasecmp(listener->name, chan_name)) break;
00688 prev = listener;
00689 }
00690 if (!listener) return(TCL_ERROR);
00691
00692 if (prev) prev->next = listener->next;
00693 else listener_list_head = listener->next;
00694 sockbuf_detach_listener(listener->fd);
00695 free(listener->name);
00696 free(listener);
00697 return(0);
00698 }
00699
00700 static int tclscript_secondly()
00701 {
00702 Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT);
00703 return(0);
00704 }
00705
00706 #if 0
00707 static void tclscript_report(int idx, int details)
00708 {
00709 char script[512];
00710 char *reported;
00711
00712 if (!details) {
00713 dprintf(idx, _("Using Tcl version %d.%d (by header).\n"), TCL_MAJOR_VERSION, TCL_MINOR_VERSION);
00714 return;
00715 }
00716
00717 dprintf(idx, _(" Using Tcl version %d.%d (by header).\n"), TCL_MAJOR_VERSION, TCL_MINOR_VERSION);
00718 sprintf(script, _("return \" Library: [info library]\\n Reported version: [info tclversion]\\n Reported patchlevel: [info patchlevel]\""));
00719 Tcl_GlobalEval(ginterp, script);
00720 reported = Tcl_GetStringResult(ginterp);
00721 dprintf(idx, "%s\n", reported);
00722 }
00723 #endif
00724
00725 static bind_list_t party_commands[] = {
00726 {"n", "tcl", (Function) party_tcl},
00727 {0}
00728 };
00729
00730 static bind_list_t secondly_binds[] = {
00731 {NULL, NULL, tclscript_secondly},
00732 {0}
00733 };
00734
00735 static int tclscript_close(int why)
00736 {
00737 Tcl_DeleteInterp(ginterp);
00738
00739 bind_rem_list("party", party_commands);
00740 bind_rem_list("secondly", secondly_binds);
00741
00742 script_unregister_module(&my_script_interface);
00743 return(0);
00744 }
00745
00746 EXPORT_SCOPE int tclscript_LTX_start(egg_module_t *modinfo);
00747
00748 int tclscript_LTX_start(egg_module_t *modinfo)
00749 {
00750 tcl_owner.module = modinfo;
00751
00752 modinfo->name = "tclscript";
00753 modinfo->author = "eggdev";
00754 modinfo->version = "1.0.0";
00755 modinfo->description = "provides tcl scripting support";
00756 modinfo->close_func = tclscript_close;
00757
00758
00759 ginterp = Tcl_CreateInterp();
00760 Tcl_Init(ginterp);
00761
00762 error_logfile = strdup("logs/tcl_errors.log");
00763 Tcl_LinkVar(ginterp, "error_logfile", (char *)&error_logfile, TCL_LINK_STRING);
00764
00765 script_register_module(&my_script_interface);
00766 script_playback(&my_script_interface);
00767
00768 bind_add_list("party", party_commands);
00769 bind_add_list("secondly", secondly_binds);
00770
00771 Tcl_CreateObjCommand(ginterp, "net_add_tcl", add_tcl_chan, NULL, NULL);
00772 Tcl_CreateObjCommand(ginterp, "net_rem_tcl", rem_tcl_chan, NULL, NULL);
00773 return(0);
00774 }
00775