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