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.8  1995/11/06 17:44:23  adam
  45  * State reestablised when shell restarts. History of previous
  46  * result sets.
  47  *
  48  * Revision 1.7  1995/10/31  16:56:25  adam
  49  * Record presentation.
  50  *
  51  * Revision 1.6  1995/10/31  10:03:54  adam
  52  * Work on queries.
  53  * New command implemented - aborts script.
  54  *
  55  * Revision 1.5  1995/10/30  17:35:18  adam
  56  * New function zwait that waits for a variable change - due to i/o events
  57  * that invoke callback routines.
  58  *
  59  * Revision 1.4  1995/10/27  17:30:16  adam
  60  * First search request/response that works.
  61  *
  62  * Revision 1.3  1995/10/27  15:12:14  adam
  63  * IrTcl incorporated in the gateway.
  64  * Better separation of script types.
  65  * Z39.50 gateway scripts entered.
  66  *
  67  * Revision 1.2  1995/10/23  16:55:43  adam
  68  * A lot of changes - really.
  69  *
  70  * Revision 1.1  1995/10/20  14:02:42  adam
  71  * First version of WWW gateway with embedded Tcl.
  72  *
  73  */
  74
  75 #include <stdio.h>
  76 #include <stdlib.h>
  77 #include <string.h>
  78 #include <assert.h>
  79 #include <ctype.h>
  80
  81 #include "wtcl.h"
  82
  83 static void *do_create (WCLIENT wcl, void *args);
  84 static int do_exec (const char *fname, char *parms, void *mydata);
  85 static int do_load (char *parms, void *mydata);
  86 static int do_save (char *parms, void *mydata);
  87
  88 static struct w_interp_type w_interp_t = {
  89     "tcl",
  90     do_create,
  91     do_exec,
  92     do_load,
  93     do_save
  94 };
  95
  96 W_Interp_Type w_interp_tcl = &w_interp_t;
  97
  98
  99 static char *mod = "wtcl";
 100
 101 struct tcl_info {
 102     Tcl_Interp *interp;
 103     char  *fbuf;
 104     int    fbuf_size;
 105     int    fbuf_ptr;
 106     int    wabort;
 107     WCLIENT wcl;
 108 };
 109
 110 Tcl_Interp *w_interp_tcl_get (W_Interp w_interp)
 111 {
 112     struct tcl_info *p;
 113
 114     if (strcmp (w_interp->ctrl->name, "tcl"))
 115     {
 116         gw_log (GW_LOG_FATAL, mod, "Internal failure");
 117         assert (0);
 118     }
 119     p = (struct tcl_info*) w_interp->mydata;
 120     return p->interp;
 121 }
 122
 123 static int proc_wabort_invoke (ClientData clientData, Tcl_Interp *interp,
 124                                int argc, char **argv)
 125 {
 126     struct tcl_info *p = (struct tcl_info*) clientData;
 127
 128     p->wabort = 1;
 129     if (argc > 1)
 130         Tcl_AppendResult (interp, argv[1], NULL);
 131     return TCL_RETURN;
 132 }
 133
 134 static int proc_wflush_invoke (ClientData clientData, Tcl_Interp *interp,
 135                                int argc, char **argv)
 136 {
 137     struct tcl_info *p = (struct tcl_info*) clientData;
 138
 139     wo_flush (p->wcl);
 140     return TCL_OK;
 141 }
 142
 143 static int proc_html_invoke (ClientData clientData, Tcl_Interp *interp,
 144                              int argc, char **argv)
 145 {
 146     struct tcl_info *p = (struct tcl_info*) clientData;
 147     int i;
 148
 149     for (i = 1; i<argc; i++)
 150         wo_puts (p->wcl, argv[i]);
 151     return TCL_OK;
 152 }
 153
 154 static int proc_htmlr_invoke (ClientData clientData, Tcl_Interp *interp,
 155                               int argc, char **argv)
 156 {
 157     struct tcl_info *p = (struct tcl_info*) clientData;
 158     int r;
 159
 160     r = proc_html_invoke (clientData, interp, argc, argv);
 161     wo_putc (p->wcl, '\n');
 162     return r;
 163 }
 164
 165 static int proc_wform_invoke (ClientData clientData, Tcl_Interp *interp,
 166                               int argc, char **argv)
 167 {
 168     struct tcl_info *p = (struct tcl_info*) clientData;
 169     int i;
 170     if (argc == 2)
 171     {
 172         for (i = 0; *p->wcl->wf_data[i].name; i++)
 173             if (!strcmp (argv[1], p->wcl->wf_data[i].name) &&
 174                 *p->wcl->wf_data[i].value)
 175                 Tcl_AppendElement (p->interp, p->wcl->wf_data[i].value);
 176         return TCL_OK;
 177     }
 178     for (i = 0; *p->wcl->wf_data[i].name; i++)
 179     {
 180         Tcl_AppendResult (p->interp, "{ ", NULL);
 181         Tcl_AppendElement (p->interp, p->wcl->wf_data[i].name);
 182         Tcl_AppendElement (p->interp, p->wcl->wf_data[i].value);
 183         Tcl_AppendResult (p->interp, " }\n", NULL);
 184     }
 185     return TCL_OK;
 186 }
 187
 188 int Tcl_AppInit (Tcl_Interp *interp)
 189 {
 190     if (Tcl_Init (interp) == TCL_ERROR)
 191         return TCL_ERROR;
 192     return TCL_OK;
 193 }
 194
 195 static void *do_create (WCLIENT wcl, void *args)
 196 {
 197     struct tcl_info *p;
 198     char tmp_str[256];
 199
 200     if (!(p = malloc (sizeof(*p))))
 201     {
 202         gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: tcl_info");
 203         exit (1);
 204     }
 205     if (!(p->interp = Tcl_CreateInterp ()))
 206     {
 207         gw_log (GW_LOG_FATAL, mod, "Cannot make Tcl_Interp");
 208         exit (1);
 209     }
 210     p->wcl = wcl;
 211     p->fbuf_size = 1024;
 212     if (!(p->fbuf = malloc (p->fbuf_size)))
 213     {
 214         gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: tcl_info fbuf");
 215         exit (1);
 216     }
 217     Tcl_AppInit (p->interp);
 218     Tcl_CreateCommand (p->interp, "html", proc_html_invoke, p, NULL);
 219     Tcl_CreateCommand (p->interp, "htmlr", proc_htmlr_invoke, p, NULL);
 220     Tcl_CreateCommand (p->interp, "wform", proc_wform_invoke, p, NULL);
 221     Tcl_CreateCommand (p->interp, "wabort", proc_wabort_invoke, p, NULL);
 222     Tcl_CreateCommand (p->interp, "wflush", proc_wflush_invoke, p, NULL);
 223     sprintf (tmp_str, "%d", wcl->id);
 224     Tcl_SetVar (p->interp, "sessionId", tmp_str, TCL_GLOBAL_ONLY);
 225     return p;
 226 }
 227
 228 static void report_error (struct tcl_info *p, int errorLine,
 229                           const char *pre, const char *msg)
 230 {
 231     gw_log (GW_LOG_WARN, mod, "%s %d %s", pre, errorLine, msg);
 232     wo_printf (p->wcl, "\n<br><hr>\n<strong>"
 233                "%s %d</strong><br>\n", pre, errorLine);
 234     wo_printf (p->wcl, "<xmp>\n%s</xmp>\n<hr>\n", msg);
 235 }
 236
 237 static int tcl_exec (const char *fname, char *parms,
 238                      struct tcl_info *p, FILE *inf, int *lineno)
 239 {
 240     int c, escape = 0, level = 0;
 241     int r, fbuf_ptr = 0;
 242     int local_line = 0;
 243
 244     while (1)
 245     {
 246         if (fbuf_ptr == p->fbuf_size-1)
 247         {
 248             char *newb;
 249
 250             if (!(newb = malloc (p->fbuf_size += 16384)))
 251             {
 252                 gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: fbuf");
 253                 exit (1);
 254             }
 255             memcpy (newb, p->fbuf, fbuf_ptr);
 256             free (p->fbuf);
 257             p->fbuf = newb;
 258         }
 259         c = getc (inf);
 260         if (c == EOF)
 261         {
 262             report_error (p, *lineno, "Error in Tcl script starting at line",
 263                                       "Unexpected EOF (missing right brace)");
 264             return TCL_ERROR;
 265         }
 266         if (c == '\\')
 267             escape = 1;
 268         else if (c == '{' && !escape)
 269         {
 270             level++;
 271             escape = 0;
 272         }
 273         else if (c == '}' && !escape)
 274         {
 275             if (--level < 0)
 276                 break;
 277             escape = 0;
 278         }
 279         else
 280         {
 281             if (c == '\n')
 282                 local_line++;
 283             escape = 0;
 284         }
 285         p->fbuf[fbuf_ptr++] = c;
 286     }
 287     p->fbuf[fbuf_ptr] = '\0';
 288     p->wabort = 0;
 289     r = Tcl_Eval (p->interp, p->fbuf);
 290     if (r == TCL_ERROR)
 291         report_error (p, p->interp->errorLine + *lineno - 1,
 292                       "Error in Tcl script in line",
 293                       Tcl_GetVar (p->interp, "errorInfo", 0));
 294     (*lineno) += local_line;
 295     if (p->wabort)
 296         return TCL_RETURN;
 297     return r;
 298 }
 299
 300 static int do_exec (const char *fname, char *parms, void *mydata)
 301 {
 302     struct tcl_info *p = mydata;
 303     int c, escape = 0;
 304     int lineno = 1;
 305     FILE *inf = fopen (fname, "r");
 306
 307     gw_log (GW_LOG_DEBUG, mod, "Executing %s", fname);
 308     if (!inf)
 309     {
 310         gw_log (GW_LOG_WARN|GW_LOG_ERRNO, mod, "open %s", fname);
 311         return -1;
 312     }
 313     Tcl_SetVar (p->interp, "sessionParms", parms, TCL_GLOBAL_ONLY);
 314     while ((c = getc(inf)) != EOF)
 315     {
 316         if (c == '\\')
 317             escape = 1;
 318         else if (c == '{')
 319         {
 320             if (escape)
 321                 wo_putc (p->wcl, c);
 322             else
 323             {
 324                 int r = tcl_exec (fname, parms, p, inf, &lineno);
 325                 if (r == TCL_RETURN)
 326                 {
 327                     fclose (inf);
 328                     return 0;
 329                 }
 330                 else if (r == TCL_ERROR)
 331                 {
 332                     fclose (inf);
 333                     return -2;
 334                 }
 335             }
 336             escape = 0;
 337         }
 338         else
 339         {
 340             if (c == '\n')
 341                 lineno++;
 342             escape = 0;
 343             wo_putc (p->wcl, c);
 344         }
 345     }
 346     fclose (inf);
 347     return 0;
 348 }
 349
 350
 351 static int do_load (char *parms, void *mydata)
 352 {
 353     struct tcl_info *p = mydata;
 354     char fname[80];
 355     int r;
 356
 357     sprintf (fname, "tcl.state.%d", p->wcl->id);
 358     r = Tcl_EvalFile (p->interp, fname);
 359     if (r == TCL_ERROR)
 360         report_error (p, p->interp->errorLine,
 361                       "Error in Tcl loadState in line",
 362                       Tcl_GetVar (p->interp, "errorInfo", 0));
 363     return 0;
 364 }
 365
 366 static int do_save (char *parms, void *mydata)
 367 {
 368     struct tcl_info *p = mydata;
 369     struct Tcl_CmdInfo cinfo;
 370
 371     if (Tcl_GetCommandInfo(p->interp, "saveState", &cinfo))
 372     {
 373         int r;
 374
 375         gw_log (GW_LOG_DEBUG, mod, "saveState");
 376         r = Tcl_Eval (p->interp, "saveState\n");
 377         if (r == TCL_ERROR)
 378             report_error (p, p->interp->errorLine,
 379                           "Error in Tcl saveState in line",
 380                           Tcl_GetVar (p->interp, "errorInfo", 0));
 381     }
 382     return 0;
 383 }
 384