www/wtcl.c

   1 /*
   2  * Copyright (c) 1995, the EUROPAGATE consortium (see below).
   3  *
   4  * The EUROPAGATE consortium members are:
   5  *
   6  *    University College Dublin
   7  *    Danmarks Teknologiske Videnscenter
   8  *    An Chomhairle Leabharlanna
   9  *    Consejo Superior de Investigaciones Cientificas
  10  *
  11  * Permission to use, copy, modify, distribute, and sell this software and
  12  * its documentation, in whole or in part, for any purpose, is hereby granted,
  13  * provided that:
  14  *
  15  * 1. This copyright and permission notice appear in all copies of the
  16  * software and its documentation. Notices of copyright or attribution
  17  * which appear at the beginning of any file must remain unchanged.
  18  *
  19  * 2. The names of EUROPAGATE or the project partners may not be used to
  20  * endorse or promote products derived from this software without specific
  21  * prior written permission.
  22  *
  23  * 3. Users of this software (implementors and gateway operators) agree to
  24  * inform the EUROPAGATE consortium of their use of the software. This
  25  * information will be used to evaluate the EUROPAGATE project and the
  26  * software, and to plan further developments. The consortium may use
  27  * the information in later publications.
  28  *
  29  * 4. Users of this software agree to make their best efforts, when
  30  * documenting their use of the software, to acknowledge the EUROPAGATE
  31  * consortium, and the role played by the software in their work.
  32  *
  33  * THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT WARRANTY OF ANY KIND,
  34  * EXPRESS, IMPLIED, OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
  35  * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
  36  * IN NO EVENT SHALL THE EUROPAGATE CONSORTIUM OR ITS MEMBERS BE LIABLE
  37  * FOR ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF
  38  * ANY KIND, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
  39  * OR PROFITS, WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND
  40  * ON ANY THEORY OF LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE
  41  * USE OR PERFORMANCE OF THIS SOFTWARE.
  42  *
  43  * $Log: wtcl.c,v $
  44  * Revision 1.23  1998/03/26 11:29:02  franck
  45  * Fixed some bugs with escape sequences.
  46  *
  47  * Revision 1.22  1997/12/15 15:05:03  adam
  48  * Enhanced the code that deals with FORM variables.
  49  *
  50  * Revision 1.21  1997/02/10 10:15:40  adam
  51  * Bug fix: egw_source <file> <var> didn't work properly.
  52  *
  53  * Revision 1.20  1997/01/31 11:16:01  adam
  54  * Enhanced the egw_source command. An optional parameter specifies the
  55  * name of a variable in which the HTML output is stored.
  56  *
  57  * Revision 1.19  1997/01/27 11:27:17  adam
  58  * Implemented a new command, egw_clear, to clear http output cache.
  59  * Changed prototype for function wo_clear.
  60  *
  61  * Revision 1.18  1997/01/24 13:13:13  adam
  62  * Implemnted egw_source and added a "raw" option to the URL.
  63  * Fixed a bug in the buffering system of wproto; the macro wo_putc could
  64  * override memory if it was the first HTML generating function called.
  65  *
  66  * Revision 1.17  1996/05/31 08:02:56  adam
  67  * Bug fix: egw_enc encoded '/' - it shouldn't.
  68  *
  69  * Revision 1.16  1996/05/23 15:53:12  adam
  70  * Bug fix: egw_enc failed on 8-bit chars.
  71  * New command: egw_parms.
  72  *
  73  * Revision 1.15  1996/05/22  16:50:27  adam
  74  * Bug fix.
  75  *
  76  * Revision 1.14  1996/05/21  14:53:04  adam
  77  * Tcl command wform extented; options -raw and -exists added.
  78  *
  79  * Revision 1.13  1996/03/14  11:48:40  adam
  80  * New function egw_prog that returns name of shell.
  81  *
  82  * Revision 1.12  1996/03/07  12:45:34  adam
  83  * New Tcl calls egw_enc/egw_dec to encode/decode binary URL info.
  84  *
  85  * Revision 1.11  1996/01/24  08:26:56  adam
  86  * All tcl commands prefixed with egw_ (except the html command).
  87  *
  88  * Revision 1.10  1995/11/08  16:14:35  adam
  89  * Many improvements and bug fixes.
  90  * First version that ran on dtbsun.
  91  *
  92  * Revision 1.9  1995/11/07  14:57:00  adam
  93  * Work on search in multiple targets.
  94  * New wtcl command: wlog.
  95  * Optional timeout parameter to zwait.
  96  *
  97  * Revision 1.8  1995/11/06  17:44:23  adam
  98  * State reestablised when shell restarts. History of previous
  99  * result sets.
 100  *
 101  * Revision 1.7  1995/10/31  16:56:25  adam
 102  * Record presentation.
 103  *
 104  * Revision 1.6  1995/10/31  10:03:54  adam
 105  * Work on queries.
 106  * New command implemented - aborts script.
 107  *
 108  * Revision 1.5  1995/10/30  17:35:18  adam
 109  * New function zwait that waits for a variable change - due to i/o events
 110  * that invoke callback routines.
 111  *
 112  * Revision 1.4  1995/10/27  17:30:16  adam
 113  * First search request/response that works.
 114  *
 115  * Revision 1.3  1995/10/27  15:12:14  adam
 116  * IrTcl incorporated in the gateway.
 117  * Better separation of script types.
 118  * Z39.50 gateway scripts entered.
 119  *
 120  * Revision 1.2  1995/10/23  16:55:43  adam
 121  * A lot of changes - really.
 122  *
 123  * Revision 1.1  1995/10/20  14:02:42  adam
 124  * First version of WWW gateway with embedded Tcl.
 125  *
 126  */
 127
 128 #include <stdio.h>
 129 #include <stdlib.h>
 130 #include <string.h>
 131 #include <assert.h>
 132 #include <ctype.h>
 133
 134 #include "wtcl.h"
 135
 136 static void *do_create (WCLIENT wcl, void *args);
 137 static int do_exec (const char *fname, char *parms, void *mydata);
 138 static int do_load (char *parms, void *mydata);
 139 static int do_save (char *parms, void *mydata);
 140
 141 static struct w_interp_type w_interp_t = {
 142     "tcl",
 143     do_create,
 144     do_exec,
 145     do_load,
 146     do_save
 147 };
 148
 149 W_Interp_Type w_interp_tcl = &w_interp_t;
 150
 151
 152 static char *mod = "wtcl";
 153
 154 struct tcl_info {
 155     Tcl_Interp *interp;
 156     char  *fbuf;
 157     int    fbuf_size;
 158     int    fbuf_ptr;
 159     int    wabort;
 160     WCLIENT wcl;
 161 };
 162
 163 static int exec_file (const char *fname, struct tcl_info *p);
 164
 165 Tcl_Interp *w_interp_tcl_get (W_Interp w_interp)
 166 {
 167     struct tcl_info *p;
 168
 169     if (strcmp (w_interp->ctrl->name, "tcl"))
 170     {
 171         gw_log (GW_LOG_FATAL, mod, "Internal failure");
 172         assert (0);
 173     }
 174     p = (struct tcl_info*) w_interp->mydata;
 175     return p->interp;
 176 }
 177
 178 static int proc_wabort_invoke (ClientData clientData, Tcl_Interp *interp,
 179                                int argc, char **argv)
 180 {
 181     struct tcl_info *p = (struct tcl_info*) clientData;
 182
 183     p->wabort = 1;
 184     if (argc > 1)
 185         Tcl_AppendResult (interp, argv[1], NULL);
 186     return TCL_RETURN;
 187 }
 188
 189 static int proc_wflush_invoke (ClientData clientData, Tcl_Interp *interp,
 190                                int argc, char **argv)
 191 {
 192     struct tcl_info *p = (struct tcl_info*) clientData;
 193
 194     wo_flush (p->wcl);
 195     return TCL_OK;
 196 }
 197
 198 static int proc_html_invoke (ClientData clientData, Tcl_Interp *interp,
 199                              int argc, char **argv)
 200 {
 201     struct tcl_info *p = (struct tcl_info*) clientData;
 202     int i;
 203
 204     for (i = 1; i<argc; i++)
 205         wo_write (p->wcl, argv[i], strlen(argv[i]));
 206     return TCL_OK;
 207 }
 208
 209 static int proc_form_invoke (struct tcl_info *p, wform_data *wfdata,
 210                              Tcl_Interp *interp,
 211                              int argc, char **argv)
 212 {
 213     const char *arg = NULL;
 214     int failFlag = 0;
 215
 216     if (argc == 3)
 217     {
 218         if (!strcmp (argv[1], "-raw"))
 219         {
 220             interp->result = p->wcl->raw_data;
 221             return TCL_OK;
 222         }
 223         else if (!strcmp (argv[1], "-exists"))
 224         {
 225             failFlag = 1;
 226             arg = argv[2];
 227         }
 228         else
 229         {
 230             Tcl_AppendResult (p->interp, "bad option to ", argv[0],
 231                               " \"", argv[1], "\"", NULL);
 232             return TCL_ERROR;
 233         }
 234     }
 235     else if (argc == 2)
 236         arg = argv[1];
 237     if (arg)
 238     {
 239         for (; wfdata; wfdata = wfdata->next)
 240             if (!strcmp (arg, wfdata->name))
 241             {
 242                 failFlag = 0;
 243                 if (wfdata->value)
 244                     Tcl_AppendElement (p->interp, wfdata->value);
 245             }
 246         if (failFlag)
 247         {
 248             Tcl_AppendResult (p->interp, arg, " doesn't exist", NULL);
 249             return TCL_ERROR;
 250         }
 251     }
 252     else
 253         for ( ; wfdata; wfdata = wfdata->next)
 254         {
 255             Tcl_AppendResult (p->interp, "{ ", NULL);
 256             Tcl_AppendElement (p->interp, wfdata->name);
 257             Tcl_AppendElement (p->interp, wfdata->value ? wfdata->value : "");
 258             Tcl_AppendResult (p->interp, " }\n", NULL);
 259         }
 260     return TCL_OK;
 261 }
 262
 263 static int proc_wform_invoke (ClientData clientData, Tcl_Interp *interp,
 264                               int argc, char **argv)
 265 {
 266     struct tcl_info *p = (struct tcl_info*) clientData;
 267     wform_data *wfdata = p->wcl->wf_data;
 268     return proc_form_invoke (p, wfdata, interp, argc, argv);
 269 }
 270
 271 static int proc_parms_invoke (ClientData clientData, Tcl_Interp *interp,
 272                               int argc, char **argv)
 273 {
 274     struct tcl_info *p = (struct tcl_info*) clientData;
 275     wform_data *wfdata = p->wcl->wf_parms_var;
 276     return proc_form_invoke (p, wfdata, interp, argc, argv);
 277 }
 278
 279
 280 static int proc_wlog_invoke (ClientData clientData, Tcl_Interp *interp,
 281                              int argc, char **argv)
 282 {
 283     unsigned mask;
 284
 285     if (argc < 3)
 286         return TCL_OK;
 287     if (!strcmp (argv[1], "debug"))
 288         mask = GW_LOG_DEBUG;
 289     else if (!strcmp (argv[1], "fatal"))
 290         mask = GW_LOG_FATAL;
 291     else if (!strcmp (argv[1], "warn"))
 292         mask = GW_LOG_WARN;
 293     else if (!strcmp (argv[1], "acct"))
 294         mask = GW_LOG_ACCT;
 295     else
 296         mask = GW_LOG_DEBUG;
 297     switch (argc)
 298     {
 299     case 3:
 300         gw_log (mask, mod, "%s", argv[2]);
 301         break;
 302     case 4:
 303         gw_log (mask, mod, "%s %s", argv[2], argv[3]);
 304         break;
 305     case 5:
 306         gw_log (mask, mod, "%s %s %s", argv[2], argv[3], argv[4]);
 307         break;
 308     case 6:
 309         gw_log (mask, mod, "%s %s %s %s", argv[2], argv[3], argv[4], argv[5]);
 310         break;
 311     }
 312     return TCL_OK;
 313 }
 314
 315 static int proc_enc (ClientData clientData, Tcl_Interp *interp,
 316                      int argc, char **argv)
 317 {
 318     int i;
 319     char buf1[6];
 320     char buf2[2];
 321
 322     buf1[0] = '%';
 323     buf2[1] = '\0';
 324     for (i = 1; i<argc; i++)
 325     {
 326         const char *cp = argv[i];
 327         while (*cp)
 328         {
 329             if (*cp < ' ' || *cp >= 127 || *cp == '&' || *cp == '?'
 330                 || *cp == '%' || *cp == '+' || *cp == '"' || *cp == '=')
 331             {
 332                 sprintf (buf1+1, "%02X", *cp & 0xff);
 333                 Tcl_AppendResult (interp, buf1, NULL);
 334             }
 335             else if (*cp == ' ')
 336             {
 337                 Tcl_AppendResult (interp, "+", NULL);
 338             }
 339             else
 340             {
 341                 buf2[0] = *cp;
 342                 Tcl_AppendResult (interp, buf2, NULL);
 343             }
 344             cp++;
 345         }
 346     }
 347     return TCL_OK;
 348 }
 349
 350 static int proc_dec (ClientData clientData, Tcl_Interp *interp,
 351                      int argc, char **argv)
 352 {
 353     int i;
 354     unsigned val;
 355     char buf[2];
 356
 357     buf[1] = '\0';
 358     for (i = 1; i<argc; i++)
 359     {
 360         const char *cp = argv[i];
 361         while (*cp)
 362         {
 363             if (*cp == '%' && cp[1] && cp[2])
 364             {
 365                 if (cp[1] >= 'A')
 366                     val = cp[1] - 'A'+10;
 367                 else
 368                     val = cp[1] - '0';
 369
 370
 371                 if (cp[2] >= 'A')
 372                     val = val*16 + (cp[2] - 'A'+10);
 373                 else
 374                     val = val*16 + (cp[2] - '0');
 375                 buf[0] = val;
 376                 cp += 3;
 377             }
 378             else
 379                 buf[0] = *cp++;
 380             Tcl_AppendResult (interp, buf, NULL);
 381         }
 382     }
 383     return TCL_OK;
 384 }
 385
 386 static int proc_prog (ClientData clientData, Tcl_Interp *interp,
 387                       int argc, char **argv)
 388 {
 389     struct tcl_info *p = (struct tcl_info*) clientData;
 390
 391     Tcl_AppendResult (p->interp, p->wcl->prog, NULL);
 392     return TCL_OK;
 393 }
 394
 395 static int proc_source (ClientData clientData, Tcl_Interp *interp,
 396                         int argc, char **argv)
 397 {
 398     struct tcl_info *p = (struct tcl_info*) clientData;
 399     int r, offset = 0;
 400
 401     if (argc < 2 || argc > 3)
 402     {
 403         Tcl_AppendResult (p->interp,
 404                           "wrong # args: should be egw_source file ?var?",
 405                           NULL);
 406         return TCL_ERROR;
 407     }
 408     if (argc == 3)
 409         offset = wproto_save_push (p->wcl);
 410     r = exec_file (argv[1], p);
 411     Tcl_ResetResult (p->interp);
 412     if (argc == 3)
 413     {
 414         char *res = wproto_save_pop (p->wcl, offset);
 415         if (res)
 416             Tcl_SetVar (p->interp, argv[2], res, 0);
 417     }
 418     if (r == -1)
 419     {
 420         Tcl_AppendResult (p->interp, "egw_source: couldn't open ",
 421                           argv[1], NULL);
 422         return TCL_ERROR;
 423     }
 424     else if (r == -2)
 425     {
 426         Tcl_AppendResult (p->interp, "egw_source: Tcl error in script ",
 427                           argv[1], NULL);
 428         return TCL_ERROR;
 429     }
 430     return TCL_OK;
 431 }
 432
 433 static int proc_clear (ClientData clientData, Tcl_Interp *interp,
 434                         int argc, char **argv)
 435 {
 436     struct tcl_info *p = (struct tcl_info*) clientData;
 437
 438     wo_clear (p->wcl);
 439     return TCL_OK;
 440 }
 441
 442 int Tcl_AppInit (Tcl_Interp *interp)
 443 {
 444     if (Tcl_Init (interp) == TCL_ERROR)
 445         return TCL_ERROR;
 446     return TCL_OK;
 447 }
 448
 449 static void *do_create (WCLIENT wcl, void *args)
 450 {
 451     struct tcl_info *p;
 452     char tmp_str[256];
 453
 454     if (!(p = malloc (sizeof(*p))))
 455     {
 456         gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: tcl_info");
 457         exit (1);
 458     }
 459     if (!(p->interp = Tcl_CreateInterp ()))
 460     {
 461         gw_log (GW_LOG_FATAL, mod, "Cannot make Tcl_Interp");
 462         exit (1);
 463     }
 464     p->wcl = wcl;
 465     p->fbuf_size = 1024;
 466     if (!(p->fbuf = malloc (p->fbuf_size)))
 467     {
 468         gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: tcl_info fbuf");
 469         exit (1);
 470     }
 471     Tcl_AppInit (p->interp);
 472     Tcl_CreateCommand (p->interp, "html", proc_html_invoke, p, NULL);
 473     Tcl_CreateCommand (p->interp, "egw_form", proc_wform_invoke, p, NULL);
 474     Tcl_CreateCommand (p->interp, "egw_parms", proc_parms_invoke, p, NULL);
 475     Tcl_CreateCommand (p->interp, "egw_abort", proc_wabort_invoke, p, NULL);
 476     Tcl_CreateCommand (p->interp, "egw_flush", proc_wflush_invoke, p, NULL);
 477     Tcl_CreateCommand (p->interp, "egw_log", proc_wlog_invoke, p, NULL);
 478     Tcl_CreateCommand (p->interp, "egw_enc", proc_enc, p, NULL);
 479     Tcl_CreateCommand (p->interp, "egw_dec", proc_dec, p, NULL);
 480     Tcl_CreateCommand (p->interp, "egw_prog", proc_prog, p, NULL);
 481     Tcl_CreateCommand (p->interp, "egw_source", proc_source, p, NULL);
 482     Tcl_CreateCommand (p->interp, "egw_clear", proc_clear, p, NULL);
 483     sprintf (tmp_str, "%d", wcl->id);
 484     Tcl_SetVar (p->interp, "sessionId", tmp_str, TCL_GLOBAL_ONLY);
 485     return p;
 486 }
 487
 488 static void report_error (struct tcl_info *p, int errorLine,
 489                           const char *pre, const char *msg)
 490 {
 491     if (!msg)
 492         msg = "";
 493     gw_log (GW_LOG_WARN, mod, "%s %d %s", pre, errorLine, msg);
 494     wo_printf (p->wcl, "\n<br><hr>\n<strong>"
 495                "%s %d</strong><br>\n", pre, errorLine);
 496     wo_printf (p->wcl, "<xmp>\n%s</xmp>\n<hr>\n", msg);
 497 }
 498
 499 static int tcl_exec (const char *fname, struct tcl_info *p, FILE *inf,
 500                      int *lineno)
 501 {
 502     int c, escape = 0, level = 0;
 503     int r, fbuf_ptr = 0;
 504     int local_line = 0;
 505
 506     while (1)
 507     {
 508         if (fbuf_ptr == p->fbuf_size-1)
 509         {
 510             char *newb;
 511
 512             if (!(newb = malloc (p->fbuf_size += 16384)))
 513             {
 514                 gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: fbuf");
 515                 exit (1);
 516             }
 517             memcpy (newb, p->fbuf, fbuf_ptr);
 518             free (p->fbuf);
 519             p->fbuf = newb;
 520         }
 521         c = getc (inf);
 522         if (c == EOF)
 523         {
 524             report_error (p, *lineno, "Error in Tcl script starting at line",
 525                                       "Unexpected EOF (missing right brace)");
 526             return TCL_ERROR;
 527         }
 528         if (c == '\\')
 529             escape = 1;
 530         else if (c == '{' && !escape)
 531         {
 532             level++;
 533             escape = 0;
 534         }
 535         else if (c == '}' && !escape)
 536         {
 537             if (--level < 0)
 538                 break;
 539             escape = 0;
 540         }
 541         else
 542         {
 543             if (c == '\n')
 544                 local_line++;
 545             escape = 0;
 546         }
 547         p->fbuf[fbuf_ptr++] = c;
 548     }
 549     p->fbuf[fbuf_ptr] = '\0';
 550     p->wabort = 0;
 551     r = Tcl_Eval (p->interp, p->fbuf);
 552     if (r == TCL_ERROR)
 553         report_error (p, p->interp->errorLine + *lineno - 1,
 554                       "Error in Tcl script in line",
 555                       Tcl_GetVar (p->interp, "errorInfo", 0));
 556     (*lineno) += local_line;
 557     if (p->wabort)
 558         return TCL_RETURN;
 559     return r;
 560 }
 561
 562 static int var_ref (struct tcl_info *p, FILE *inf)
 563 {
 564     int c, i = 0;
 565     char name[32], *vp;
 566
 567     c = getc (inf);
 568     if (c == '{')
 569     {
 570         while ((c = getc(inf)) != EOF)
 571         {
 572             if (c == '\n')
 573                 break;
 574             if (c == '}')
 575             {
 576                 c = getc (inf);
 577                 break;
 578             }
 579             if (i < 31)
 580                 name[i++] = c;
 581         }
 582     }
 583     else
 584     {
 585         while (c != EOF)
 586         {
 587             if (c != '(' && c != ')' && c != '-' && c != '_' && !isalnum(c))
 588                 break;
 589             if (i < 31)
 590                 name[i++] = c;
 591             c = getc (inf);
 592         }
 593     }
 594     name[i] = '\0';
 595     vp = Tcl_GetVar (p->interp, name, 0);
 596     if (vp)
 597         wo_puts (p->wcl, vp);
 598     return c;
 599 }
 600
 601 static int exec_file (const char *fname, struct tcl_info *p)
 602 {
 603     int c, escape = 0;
 604     int lineno = 1;
 605     FILE *inf = fopen (fname, "r");
 606
 607     gw_log (GW_LOG_DEBUG, mod, "Executing %s", fname);
 608     if (!inf)
 609     {
 610         gw_log (GW_LOG_WARN|GW_LOG_ERRNO, mod, "open %s", fname);
 611         return -1;
 612     }
 613     c = getc (inf);
 614     while (c != EOF)
 615     {
 616         switch (c)
 617         {
 618         case '\\':
 619             escape = 1;
 620             c = getc (inf);
 621             break;
 622         case '$':
 623             if (escape)
 624             {
 625                 wo_putc (p->wcl, c);
 626                 escape = 0;
 627                 c = getc (inf);
 628             }
 629             else
 630                 c = var_ref (p, inf);
 631             break;
 632         case '{':
 633             if (escape)
 634             {
 635                 wo_putc (p->wcl, c);
 636                 escape = 0;
 637             }
 638             else
 639             {
 640                 int r = tcl_exec (fname, p, inf, &lineno);
 641                 if (r == TCL_RETURN)
 642                 {
 643                     fclose (inf);
 644                     return 0;
 645                 }
 646                 else if (r == TCL_ERROR)
 647                 {
 648                     fclose (inf);
 649                     return -2;
 650                 }
 651             }
 652             c = getc (inf);
 653             break;
 654         default:
 655             if (c == '\n')
 656                 lineno++;
 657             escape = 0;
 658             wo_putc (p->wcl, c);
 659             c = getc (inf);
 660         }
 661     }
 662     fclose (inf);
 663     return 0;
 664 }
 665
 666 static int do_exec (const char *fname, char *parms, void *mydata)
 667 {
 668     struct tcl_info *p = mydata;
 669
 670     Tcl_SetVar (p->interp, "sessionParms", parms, TCL_GLOBAL_ONLY);
 671     return exec_file (fname, p);
 672 }
 673
 674 static int do_load (char *parms, void *mydata)
 675 {
 676     struct tcl_info *p = mydata;
 677     char fname[80];
 678     int r;
 679
 680     sprintf (fname, "tcl.state.%d", p->wcl->id);
 681     r = Tcl_EvalFile (p->interp, fname);
 682     if (r == TCL_ERROR)
 683         gw_log (GW_LOG_WARN, mod, "Cannot load Tcl state" );
 684     return 0;
 685 }
 686
 687 static int do_save (char *parms, void *mydata)
 688 {
 689     struct tcl_info *p = mydata;
 690     struct Tcl_CmdInfo cinfo;
 691
 692     if (Tcl_GetCommandInfo(p->interp, "saveState", &cinfo))
 693     {
 694         int r;
 695
 696         gw_log (GW_LOG_DEBUG, mod, "saveState");
 697         r = Tcl_Eval (p->interp, "saveState\n");
 698         if (r == TCL_ERROR)
 699             report_error (p, p->interp->errorLine,
 700                           "Error in Tcl saveState in line",
 701                           Tcl_GetVar (p->interp, "errorInfo", 0));
 702     }
 703     return 0;
 704 }
 705