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