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