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