/[cvs]/eggdrop1.4/src/tcl.c
ViewVC logotype

Annotation of /eggdrop1.4/src/tcl.c

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.27 - (hide annotations) (download) (as text)
Mon Jan 17 16:14:45 2000 UTC (19 years, 9 months ago) by per
Branch: MAIN
CVS Tags: eggdrop104030RC2, eggdrop10403RC1, eggdrop10402RC1, eggdrop10404, eggdrop10403, eggdrop10402
Changes since 1.26: +3 -7 lines
File MIME type: text/x-chdr
relayfix, extern_cleanup

1 guppy 1.24 /*
2 segfault 1.1 * tcl.c -- handles:
3 guppy 1.24 * the code for every command eggdrop adds to Tcl
4     * Tcl initialization
5     * getting and setting Tcl/eggdrop variables
6 segfault 1.1 *
7     * dprintf'ized, 4feb1996
8 guppy 1.24 *
9 per 1.27 * $Id: tcl.c,v 1.26 2000/01/08 21:23:14 per Exp $
10 segfault 1.1 */
11 guppy 1.24 /*
12     * Copyright (C) 1997 Robey Pointer
13 per 1.26 * Copyright (C) 1999, 2000 Eggheads
14 guppy 1.24 *
15     * This program is free software; you can redistribute it and/or
16     * modify it under the terms of the GNU General Public License
17     * as published by the Free Software Foundation; either version 2
18     * of the License, or (at your option) any later version.
19     *
20     * This program is distributed in the hope that it will be useful,
21     * but WITHOUT ANY WARRANTY; without even the implied warranty of
22     * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23     * GNU General Public License for more details.
24     *
25     * You should have received a copy of the GNU General Public License
26     * along with this program; if not, write to the Free Software
27     * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 segfault 1.1 */
29    
30     #include "main.h"
31    
32     /* used for read/write to internal strings */
33     typedef struct {
34     char *str; /* pointer to actual string in eggdrop */
35     int max; /* max length (negative: read-only var when protect is on) */
36     /* (0: read-only ALWAYS) */
37     int flags; /* 1 = directory */
38     } strinfo;
39    
40     typedef struct {
41     int *var;
42     int ro;
43     } intinfo;
44    
45     int protect_readonly = 0; /* turn on/off readonly protection */
46     char whois_fields[121] = ""; /* fields to display in a .whois */
47     Tcl_Interp *interp; /* eggdrop always uses the same interpreter */
48    
49     extern int backgrd, flood_telnet_thr, flood_telnet_time;
50     extern int shtime, share_greet, require_p, keep_all_logs;
51 guppy 1.12 extern int allow_new_telnets, stealth_telnets, use_telnet_banner;
52 segfault 1.1 extern int default_flags, conmask, switch_logfiles_at, connect_timeout;
53     extern int firewallport, reserved_port, notify_users_at;
54     extern int flood_thr, ignore_time;
55     extern char origbotname[], botuser[], motdfile[], admin[], userfile[],
56     firewall[], helpdir[], notify_new[], hostname[], myip[], moddir[],
57 segfault 1.3 tempdir[], owner[], network[], botnetnick[], bannerfile[];
58 segfault 1.1 extern int die_on_sighup, die_on_sigterm, max_logs, max_logsize, enable_simul;
59     extern int dcc_total, debug_output, identtimeout, protect_telnet;
60     extern int egg_numver, share_unlinks, dcc_sanitycheck, sort_users;
61 per 1.27 extern int tands, resolve_timeout, default_uflags, strict_host;
62 segfault 1.1 extern struct dcc_t *dcc;
63 per 1.27 extern char egg_version[], natip[];
64 segfault 1.1 extern tcl_timer_t *timer, *utimer;
65     extern time_t online_since;
66     extern log_t *logs;
67    
68     /* confvar patch by aaronwl */
69     extern char configfile[];
70     int dcc_flood_thr = 3;
71     int debug_tcl = 0;
72     int use_silence = 0;
73 poptix 1.6 int use_invites = 0; /* Jason/drummer */
74     int use_exempts = 0; /* Jason/drummer */
75 guppy 1.7 int force_expire = 0; /* Rufus */
76 segfault 1.1 int remote_boots = 2;
77     int allow_dk_cmds = 1;
78     int must_be_owner = 1;
79     int max_dcc = 20; /* needs at least 4 or 5 just to get started
80     * 20 should be enough */
81     int min_dcc_port = 1024; /* dcc-portrange, min port - dw/guppy */
82     int max_dcc_port = 65535; /* dcc-portrange, max port - dw/guppy */
83     int quick_logs = 0; /* quick write logs?
84     * flush em every min instead of every 5 */
85 segfault 1.2 int par_telnet_flood = 1; /* trigger telnet flood for +f ppl? - dw */
86 guppy 1.11 int quiet_save = 0; /* quiet-save patch by Lucas */
87 segfault 1.2
88 segfault 1.1 /* prototypes for tcl */
89     Tcl_Interp *Tcl_CreateInterp();
90     int strtot = 0;
91    
92     int expmem_tcl()
93     {
94     int i, tot = 0;
95    
96 guppy 1.22 Context;
97 segfault 1.1 for (i = 0; i < max_logs; i++)
98     if (logs[i].filename != NULL) {
99     tot += strlen(logs[i].filename) + 1;
100     tot += strlen(logs[i].chname) + 1;
101     }
102     return tot + strtot;
103     }
104    
105     /***********************************************************************/
106    
107     /* logfile [<modes> <channel> <filename>] */
108     static int tcl_logfile STDVAR
109     {
110     int i;
111     char s[151];
112    
113     BADARGS(1, 4, " ?logModes channel logFile?");
114     if (argc == 1) {
115     /* they just want a list of the logfiles and modes */
116     for (i = 0; i < max_logs; i++)
117     if (logs[i].filename != NULL) {
118     strcpy(s, masktype(logs[i].mask));
119     strcat(s, " ");
120     strcat(s, logs[i].chname);
121     strcat(s, " ");
122     strcat(s, logs[i].filename);
123     Tcl_AppendElement(interp, s);
124     }
125     return TCL_OK;
126     }
127     BADARGS(4, 4, " ?logModes channel logFile?");
128     for (i = 0; i < max_logs; i++)
129     if ((logs[i].filename != NULL) && (!strcmp(logs[i].filename, argv[3]))) {
130 guppy 1.12 logs[i].flags &= ~LF_EXPIRING;
131 segfault 1.1 logs[i].mask = logmodes(argv[1]);
132     nfree(logs[i].chname);
133     logs[i].chname = NULL;
134     if (!logs[i].mask) {
135     /* ending logfile */
136     nfree(logs[i].filename);
137     logs[i].filename = NULL;
138     if (logs[i].f != NULL) {
139     fclose(logs[i].f);
140     logs[i].f = NULL;
141     }
142 guppy 1.12 logs[i].flags = 0;
143 segfault 1.1 } else {
144     logs[i].chname = (char *) nmalloc(strlen(argv[2]) + 1);
145     strcpy(logs[i].chname, argv[2]);
146     }
147     Tcl_AppendResult(interp, argv[3], NULL);
148     return TCL_OK;
149     }
150 guppy 1.12 /* do not add logfiles without any flags to log ++rtc */
151     if (!logmodes (argv [1])) {
152     Tcl_AppendResult (interp, "can't remove \"", argv[3],
153     "\" from list: no such logfile", NULL);
154     return TCL_ERROR;
155     }
156 segfault 1.1 for (i = 0; i < max_logs; i++)
157     if (logs[i].filename == NULL) {
158 guppy 1.12 logs[i].flags = 0;
159 segfault 1.1 logs[i].mask = logmodes(argv[1]);
160     logs[i].filename = (char *) nmalloc(strlen(argv[3]) + 1);
161     strcpy(logs[i].filename, argv[3]);
162     logs[i].chname = (char *) nmalloc(strlen(argv[2]) + 1);
163     strcpy(logs[i].chname, argv[2]);
164     Tcl_AppendResult(interp, argv[3], NULL);
165     return TCL_OK;
166     }
167     Tcl_AppendResult(interp, "reached max # of logfiles", NULL);
168     return TCL_ERROR;
169     }
170    
171     int findidx(int z)
172     {
173     int j;
174    
175     for (j = 0; j < dcc_total; j++)
176     if ((dcc[j].sock == z) && (dcc[j].type->flags & DCT_VALIDIDX))
177     return j;
178     return -1;
179     }
180    
181     static void botnet_change(char *new)
182     {
183     if (strcasecmp(botnetnick, new) != 0) {
184     /* trying to change bot's nickname */
185     if (tands > 0) {
186     putlog(LOG_MISC, "*", "* Tried to change my botnet nick, but I'm still linked to a botnet.");
187     putlog(LOG_MISC, "*", "* (Unlink and try again.)");
188     return;
189     } else {
190     if (botnetnick[0])
191     putlog(LOG_MISC, "*", "* IDENTITY CHANGE: %s -> %s", botnetnick, new);
192     strcpy(botnetnick, new);
193     }
194     }
195     }
196    
197     /**********************************************************************/
198    
199     int init_dcc_max(), init_misc();
200    
201     /* used for read/write to integer couplets */
202     typedef struct {
203     int *left; /* left side of couplet */
204     int *right; /* right side */
205     } coupletinfo;
206    
207     /* read/write integer couplets (int1:int2) */
208     static char *tcl_eggcouplet(ClientData cdata, Tcl_Interp * irp, char *name1,
209     char *name2, int flags)
210     {
211     char *s, s1[41];
212     coupletinfo *cp = (coupletinfo *) cdata;
213    
214     if (flags & (TCL_TRACE_READS | TCL_TRACE_UNSETS)) {
215     sprintf(s1, "%d:%d", *(cp->left), *(cp->right));
216     Tcl_SetVar2(interp, name1, name2, s1, TCL_GLOBAL_ONLY);
217 segfault 1.8 if (flags & TCL_TRACE_UNSETS)
218     Tcl_TraceVar(interp, name1,
219     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
220     tcl_eggcouplet, cdata);
221 segfault 1.1 } else { /* writes */
222     s = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
223     if (s != NULL) {
224     int nr1, nr2;
225    
226     if (strlen(s) > 40)
227     s[40] = 0;
228     sscanf(s, "%d%*c%d", &nr1, &nr2);
229     *(cp->left) = nr1;
230     *(cp->right) = nr2;
231     }
232     }
233     return NULL;
234     }
235    
236     /* read/write normal integer */
237     static char *tcl_eggint(ClientData cdata, Tcl_Interp * irp, char *name1,
238     char *name2, int flags)
239     {
240     char *s, s1[40];
241     long l;
242     intinfo *ii = (intinfo *) cdata;
243    
244     if (flags & (TCL_TRACE_READS | TCL_TRACE_UNSETS)) {
245     /* special cases */
246     if ((int *) ii->var == &conmask)
247     strcpy(s1, masktype(conmask));
248     else if ((int *) ii->var == &default_flags) {
249     struct flag_record fr =
250     {FR_GLOBAL, 0, 0, 0, 0, 0};
251     fr.global = default_flags;
252 guppy 1.4 fr.udef_global = default_uflags;
253 segfault 1.1 build_flags(s1, &fr, 0);
254     } else
255     sprintf(s1, "%d", *(int *) ii->var);
256     Tcl_SetVar2(interp, name1, name2, s1, TCL_GLOBAL_ONLY);
257 segfault 1.8 if (flags & TCL_TRACE_UNSETS)
258     Tcl_TraceVar(interp, name1,
259     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
260     tcl_eggint, cdata);
261 segfault 1.1 return NULL;
262     } else { /* writes */
263     s = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
264     if (s != NULL) {
265     if ((int *) ii->var == &conmask) {
266     if (s[0])
267     conmask = logmodes(s);
268     else
269     conmask = LOG_MODES | LOG_MISC | LOG_CMDS;
270     } else if ((int *) ii->var == &default_flags) {
271     struct flag_record fr =
272     {FR_GLOBAL, 0, 0, 0, 0, 0};
273    
274     break_down_flags(s, &fr, 0);
275 guppy 1.4 default_flags = sanity_check(fr.global); /* drummer */
276     default_uflags = fr.udef_global;
277 segfault 1.1 } else if ((ii->ro == 2) || ((ii->ro == 1) && protect_readonly)) {
278     return "read-only variable";
279     } else {
280     if (Tcl_ExprLong(interp, s, &l) == TCL_ERROR)
281     return interp->result;
282     if ((int *) ii->var == &max_dcc) {
283     if (l < max_dcc)
284     return "you can't DECREASE max-dcc";
285     max_dcc = l;
286     init_dcc_max();
287     } else if ((int *) ii->var == &max_logs) {
288     if (l < max_logs)
289     return "you can't DECREASE max-logs";
290     max_logs = l;
291     init_misc();
292     } else
293     *(ii->var) = (int) l;
294     }
295     }
296     return NULL;
297     }
298     }
299    
300     /* read/write normal string variable */
301     static char *tcl_eggstr(ClientData cdata, Tcl_Interp * irp, char *name1,
302     char *name2, int flags)
303     {
304     char *s;
305     strinfo *st = (strinfo *) cdata;
306    
307     if (flags & (TCL_TRACE_READS | TCL_TRACE_UNSETS)) {
308     if ((st->str == firewall) && (firewall[0])) {
309     char s1[161];
310    
311     sprintf(s1, "%s:%d", firewall, firewallport);
312     Tcl_SetVar2(interp, name1, name2, s1, TCL_GLOBAL_ONLY);
313     } else
314     Tcl_SetVar2(interp, name1, name2, st->str, TCL_GLOBAL_ONLY);
315 segfault 1.8 if (flags & TCL_TRACE_UNSETS) {
316     Tcl_TraceVar(interp, name1, TCL_TRACE_READS | TCL_TRACE_WRITES |
317     TCL_TRACE_UNSETS, tcl_eggstr, cdata);
318     if ((st->max <= 0) && (protect_readonly || (st->max == 0)))
319     return "read-only variable"; /* it won't return the error... */
320 segfault 1.1 }
321     return NULL;
322     } else { /* writes */
323     if ((st->max <= 0) && (protect_readonly || (st->max == 0))) {
324     Tcl_SetVar2(interp, name1, name2, st->str, TCL_GLOBAL_ONLY);
325     return "read-only variable";
326     }
327     s = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
328     if (s != NULL) {
329     if (strlen(s) > abs(st->max))
330     s[abs(st->max)] = 0;
331     if (st->str == botnetnick)
332     botnet_change(s);
333     else if (st->str == firewall) {
334     splitc(firewall, s, ':');
335     if (!firewall[0])
336     strcpy(firewall, s);
337     else
338     firewallport = atoi(s);
339     } else
340     strcpy(st->str, s);
341     if ((st->flags) && (s[0])) {
342     if (st->str[strlen(st->str) - 1] != '/')
343     strcat(st->str, "/");
344     }
345     }
346     return NULL;
347     }
348     }
349    
350     /* add/remove tcl commands */
351     void add_tcl_commands(tcl_cmds * tab)
352     {
353     int i;
354    
355     for (i = 0; tab[i].name; i++)
356     Tcl_CreateCommand(interp, tab[i].name, tab[i].func, NULL, NULL);
357     }
358    
359     void rem_tcl_commands(tcl_cmds * tab)
360     {
361     int i;
362    
363     for (i = 0; tab[i].name; i++)
364     Tcl_DeleteCommand(interp, tab[i].name);
365     }
366    
367     static tcl_strings def_tcl_strings[] =
368     {
369     {"botnet-nick", botnetnick, HANDLEN, 0},
370     {"userfile", userfile, 120, STR_PROTECT},
371     {"motd", motdfile, 120, STR_PROTECT},
372     {"admin", admin, 120, 0},
373     {"help-path", helpdir, 120, STR_DIR | STR_PROTECT},
374     {"temp-path", tempdir, 120, STR_DIR | STR_PROTECT},
375     #ifndef STATIC
376     {"mod-path", moddir, 120, STR_DIR | STR_PROTECT},
377     #endif
378     {"notify-newusers", notify_new, 120, 0},
379     {"owner", owner, 120, STR_PROTECT},
380     {"my-hostname", hostname, 120, 0},
381     {"my-ip", myip, 120, 0},
382     {"network", network, 40, 0},
383     {"whois-fields", whois_fields, 120, 0},
384     {"nat-ip", natip, 120, 0},
385     {"username", botuser, 10, 0},
386     {"version", egg_version, 0, 0},
387     {"firewall", firewall, 120, 0},
388     /* confvar patch by aaronwl */
389     {"config", configfile, 0, 0},
390 segfault 1.3 {"telnet-banner", bannerfile, 120, STR_PROTECT},
391 segfault 1.1 {0, 0, 0, 0}
392     };
393    
394     /* ints */
395    
396     static tcl_ints def_tcl_ints[] =
397     {
398     {"ignore-time", &ignore_time, 0},
399     {"dcc-flood-thr", &dcc_flood_thr, 0},
400     {"hourly-updates", &notify_users_at, 0},
401     {"switch-logfiles-at", &switch_logfiles_at, 0},
402     {"connect-timeout", &connect_timeout, 0},
403     {"reserved-port", &reserved_port, 0},
404     /* booleans (really just ints) */
405     {"require-p", &require_p, 0},
406     {"keep-all-logs", &keep_all_logs, 0},
407     {"open-telnets", &allow_new_telnets, 0},
408     {"stealth-telnets", &stealth_telnets, 0},
409 guppy 1.9 {"use-telnet-banner", &use_telnet_banner, 0},
410 segfault 1.1 {"uptime", (int *) &online_since, 2},
411     {"console", &conmask, 0},
412     {"default-flags", &default_flags, 0},
413     /* moved from eggdrop.h */
414     {"numversion", &egg_numver, 2},
415     {"debug-tcl", &debug_tcl, 1},
416     {"die-on-sighup", &die_on_sighup, 1},
417     {"die-on-sigterm", &die_on_sigterm, 1},
418     {"remote-boots", &remote_boots, 1},
419     {"max-dcc", &max_dcc, 0},
420     {"max-logs", &max_logs, 0},
421     {"max-logsize", &max_logsize, 0},
422     {"quick-logs", &quick_logs, 0},
423     {"enable-simul", &enable_simul, 1},
424     {"debug-output", &debug_output, 1},
425     {"protect-telnet", &protect_telnet, 0},
426     {"dcc-sanitycheck", &dcc_sanitycheck, 0},
427     {"sort-users", &sort_users, 0},
428     {"ident-timeout", &identtimeout, 0},
429     {"share-unlinks", &share_unlinks, 0},
430     {"log-time", &shtime, 0},
431     {"allow-dk-cmds", &allow_dk_cmds, 0},
432     {"resolve-timeout", &resolve_timeout, 0},
433     {"must-be-owner", &must_be_owner, 1},
434     {"use-silence", &use_silence, 0}, /* arthur2 */
435 segfault 1.2 {"paranoid-telnet-flood", &par_telnet_flood, 0},
436 poptix 1.6 {"use-exempts", &use_exempts, 0}, /* Jason/drummer */
437     {"use-invites", &use_invites, 0}, /* Jason/drummer */
438 guppy 1.11 {"quiet-save", &quiet_save, 0}, /* Lucas */
439 guppy 1.7 {"force-expire", &force_expire, 0}, /* Rufus */
440 guppy 1.25 {"strict-host", &strict_host, 0}, /* moved from server.mod & irc.mod */
441 segfault 1.1 {0, 0, 0} /* arthur2 */
442     };
443    
444     static tcl_coups def_tcl_coups[] =
445     {
446     {"telnet-flood", &flood_telnet_thr, &flood_telnet_time},
447     {"dcc-portrange", &min_dcc_port, &max_dcc_port}, /* dw */
448     {0, 0, 0}
449     };
450    
451     /* set up Tcl variables that will hook into eggdrop internal vars via */
452     /* trace callbacks */
453     static void init_traces()
454     {
455     add_tcl_coups(def_tcl_coups);
456     add_tcl_strings(def_tcl_strings);
457     add_tcl_ints(def_tcl_ints);
458     }
459    
460     void kill_tcl()
461     {
462 guppy 1.22 Context;
463 segfault 1.1 rem_tcl_coups(def_tcl_coups);
464     rem_tcl_strings(def_tcl_strings);
465     rem_tcl_ints(def_tcl_ints);
466     kill_bind();
467     Tcl_DeleteInterp(interp);
468     }
469    
470     extern tcl_cmds tcluser_cmds[], tcldcc_cmds[], tclmisc_cmds[];
471    
472     /* not going through Tcl's crazy main() system (what on earth was he
473     * smoking?!) so we gotta initialize the Tcl interpreter */
474 guppy 1.19 void init_tcl(int argc, char **argv)
475 segfault 1.1 {
476 guppy 1.18 #ifndef HAVE_PRE7_5_TCL
477 guppy 1.14 int i;
478     char pver[1024] = "";
479 arthur2 1.17 #endif
480 segfault 1.1
481 guppy 1.22 Context;
482 guppy 1.19 #ifndef HAVE_PRE7_5_TCL
483     /* This is used for 'info nameofexecutable'.
484     * The filename in argv[0] must exist in a directory listed in
485     * the environment variable PATH for it to register anything. */
486     Tcl_FindExecutable(argv[0]);
487     #endif
488    
489 segfault 1.1 /* initialize the interpreter */
490     interp = Tcl_CreateInterp();
491     Tcl_Init(interp);
492 guppy 1.19
493 guppy 1.22 #ifdef DEBUG_MEM
494 guppy 1.19 /* initialize Tcl's memory debugging if we have it */
495     Tcl_InitMemory(interp);
496     #endif
497    
498     /* set Tcl variable tcl_interactive to 0 */
499     Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
500    
501     /* initialize binds and traces */
502 segfault 1.1 init_bind();
503     init_traces();
504 guppy 1.19
505 segfault 1.1 /* add new commands */
506 guppy 1.19 Tcl_CreateCommand(interp, "logfile", tcl_logfile, NULL, NULL);
507 segfault 1.1 /* isnt this much neater :) */
508     add_tcl_commands(tcluser_cmds);
509     add_tcl_commands(tcldcc_cmds);
510     add_tcl_commands(tclmisc_cmds);
511 guppy 1.19
512 guppy 1.18 #ifndef HAVE_PRE7_5_TCL
513 arthur2 1.15 /* add eggdrop to Tcl's package list */
514 guppy 1.14 for (i = 0; i <= strlen(egg_version); i++) {
515     if ((egg_version[i] == ' ') || (egg_version[i] == '+'))
516     break;
517     pver[strlen(pver)] = egg_version[i];
518     }
519 segfault 1.1 Tcl_PkgProvide(interp, "eggdrop", pver);
520 arthur2 1.17 #endif
521 segfault 1.1 }
522    
523     /**********************************************************************/
524    
525     void do_tcl(char *whatzit, char *script)
526     {
527     int code;
528     FILE *f = 0;
529    
530     if (debug_tcl) {
531     f = fopen("DEBUG.TCL", "a");
532     if (f != NULL)
533     fprintf(f, "eval: %s\n", script);
534     }
535 guppy 1.22 Context;
536 segfault 1.1 code = Tcl_Eval(interp, script);
537     if (debug_tcl && (f != NULL)) {
538     fprintf(f, "done eval, result=%d\n", code);
539     fclose(f);
540     }
541     if (code != TCL_OK) {
542     putlog(LOG_MISC, "*", "Tcl error in script for '%s':", whatzit);
543     putlog(LOG_MISC, "*", "%s", interp->result);
544     }
545     }
546    
547     /* read and interpret the configfile given */
548     /* return 1 if everything was okay */
549     int readtclprog(char *fname)
550     {
551     int code;
552     FILE *f;
553    
554     f = fopen(fname, "r");
555     if (f == NULL)
556     return 0;
557     fclose(f);
558     if (debug_tcl) {
559     f = fopen("DEBUG.TCL", "a");
560     if (f != NULL) {
561     fprintf(f, "Sourcing file %s ...\n", fname);
562     fclose(f);
563     }
564     }
565     code = Tcl_EvalFile(interp, fname);
566     if (code != TCL_OK) {
567 guppy 1.12 putlog(LOG_MISC, "*", "Tcl error in file '%s':", fname);
568     putlog(LOG_MISC, "*", "%s",
569     Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
570 segfault 1.1 /* try to go on anyway (shrug) */
571     /* no dont it's to risky now */
572     return 0;
573     }
574     /* refresh internal variables */
575     return 1;
576     }
577    
578     void add_tcl_strings(tcl_strings * list)
579     {
580 guppy 1.21 int i, tmp;
581 segfault 1.1 strinfo *st;
582    
583     for (i = 0; list[i].name; i++) {
584     st = (strinfo *) nmalloc(sizeof(strinfo));
585     strtot += sizeof(strinfo);
586     st->max = list[i].length - (list[i].flags & STR_DIR);
587     if (list[i].flags & STR_PROTECT)
588     st->max = -st->max;
589     st->str = list[i].buf;
590     st->flags = (list[i].flags & STR_DIR);
591 guppy 1.21 tmp = protect_readonly;
592     protect_readonly = 0;
593 guppy 1.16 tcl_eggstr((ClientData) st, interp, list[i].name, NULL, TCL_TRACE_WRITES);
594 guppy 1.21 protect_readonly = tmp;
595 guppy 1.20 tcl_eggstr((ClientData) st, interp, list[i].name, NULL, TCL_TRACE_READS);
596 segfault 1.1 Tcl_TraceVar(interp, list[i].name, TCL_TRACE_READS | TCL_TRACE_WRITES |
597     TCL_TRACE_UNSETS, tcl_eggstr, (ClientData) st);
598     }
599     }
600    
601     void rem_tcl_strings(tcl_strings * list)
602     {
603     int i;
604     strinfo *st;
605    
606     for (i = 0; list[i].name; i++) {
607     st = (strinfo *) Tcl_VarTraceInfo(interp, list[i].name,
608     TCL_TRACE_READS |
609     TCL_TRACE_WRITES |
610     TCL_TRACE_UNSETS,
611     tcl_eggstr, NULL);
612     Tcl_UntraceVar(interp, list[i].name,
613     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
614     tcl_eggstr, st);
615     if (st != NULL) {
616     strtot -= sizeof(strinfo);
617     nfree(st);
618     }
619     }
620     }
621    
622     void add_tcl_ints(tcl_ints * list)
623     {
624 guppy 1.21 int i, tmp;
625 segfault 1.1 intinfo *ii;
626    
627     for (i = 0; list[i].name; i++) {
628     ii = nmalloc(sizeof(intinfo));
629     strtot += sizeof(intinfo);
630     ii->var = list[i].val;
631     ii->ro = list[i].readonly;
632 guppy 1.21 tmp = protect_readonly;
633     protect_readonly = 0;
634 guppy 1.16 tcl_eggint((ClientData) ii, interp, list[i].name, NULL, TCL_TRACE_WRITES);
635 guppy 1.23 protect_readonly = tmp;
636 guppy 1.20 tcl_eggint((ClientData) ii, interp, list[i].name, NULL, TCL_TRACE_READS);
637 segfault 1.1 Tcl_TraceVar(interp, list[i].name,
638     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
639     tcl_eggint, (ClientData) ii);
640     }
641    
642     }
643    
644     void rem_tcl_ints(tcl_ints * list)
645     {
646     int i;
647     intinfo *ii;
648    
649     for (i = 0; list[i].name; i++) {
650     ii = (intinfo *) Tcl_VarTraceInfo(interp, list[i].name,
651     TCL_TRACE_READS |
652     TCL_TRACE_WRITES |
653     TCL_TRACE_UNSETS,
654     tcl_eggint, NULL);
655     Tcl_UntraceVar(interp, list[i].name,
656     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
657     tcl_eggint, (ClientData) ii);
658     if (ii) {
659     strtot -= sizeof(intinfo);
660     nfree(ii);
661     }
662     }
663     }
664    
665     /* allocate couplet space for tracing couplets */
666     void add_tcl_coups(tcl_coups * list)
667     {
668     coupletinfo *cp;
669     int i;
670    
671     for (i = 0; list[i].name; i++) {
672     cp = (coupletinfo *) nmalloc(sizeof(coupletinfo));
673     strtot += sizeof(coupletinfo);
674     cp->left = list[i].lptr;
675     cp->right = list[i].rptr;
676 guppy 1.21
677 guppy 1.16 tcl_eggcouplet((ClientData) cp, interp, list[i].name, NULL, TCL_TRACE_WRITES);
678 guppy 1.20 tcl_eggcouplet((ClientData) cp, interp, list[i].name, NULL, TCL_TRACE_READS);
679 segfault 1.1 Tcl_TraceVar(interp, list[i].name,
680     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
681     tcl_eggcouplet, (ClientData) cp);
682     }
683     }
684    
685     void rem_tcl_coups(tcl_coups * list)
686     {
687     coupletinfo *cp;
688     int i;
689    
690     for (i = 0; list[i].name; i++) {
691     cp = (coupletinfo *) Tcl_VarTraceInfo(interp, list[i].name,
692     TCL_TRACE_READS |
693     TCL_TRACE_WRITES |
694     TCL_TRACE_UNSETS,
695     tcl_eggcouplet, NULL);
696     strtot -= sizeof(coupletinfo);
697     Tcl_UntraceVar(interp, list[i].name,
698     TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
699     tcl_eggcouplet, (ClientData) cp);
700     nfree(cp);
701     }
702     }

webmaster@eggheads.org
ViewVC Help
Powered by ViewVC 1.1.23