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