X-Git-Url: http://git.indexdata.com/?a=blobdiff_plain;f=www%2Fwtcl.c;h=8053f24b92cde92b6519dc262dc9052a2408941e;hb=1140389ab96fc8ca7bc9c8dc642adbcec625f4a6;hp=ebdabb5681981de52310bc15a71b5fd0b20400d3;hpb=f37ddd57014f51c88ef36050ed08b4c6e226e094;p=egate.git diff --git a/www/wtcl.c b/www/wtcl.c index ebdabb5..8053f24 100644 --- a/www/wtcl.c +++ b/www/wtcl.c @@ -41,7 +41,73 @@ * USE OR PERFORMANCE OF THIS SOFTWARE. * * $Log: wtcl.c,v $ - * Revision 1.1 1995/10/20 14:02:42 adam + * Revision 1.19 1997/01/27 11:27:17 adam + * Implemented a new command, egw_clear, to clear http output cache. + * Changed prototype for function wo_clear. + * + * Revision 1.18 1997/01/24 13:13:13 adam + * Implemnted egw_source and added a "raw" option to the URL. + * Fixed a bug in the buffering system of wproto; the macro wo_putc could + * override memory if it was the first HTML generating function called. + * + * Revision 1.17 1996/05/31 08:02:56 adam + * Bug fix: egw_enc encoded '/' - it shouldn't. + * + * Revision 1.16 1996/05/23 15:53:12 adam + * Bug fix: egw_enc failed on 8-bit chars. + * New command: egw_parms. + * + * Revision 1.15 1996/05/22 16:50:27 adam + * Bug fix. + * + * Revision 1.14 1996/05/21 14:53:04 adam + * Tcl command wform extented; options -raw and -exists added. + * + * Revision 1.13 1996/03/14 11:48:40 adam + * New function egw_prog that returns name of shell. + * + * Revision 1.12 1996/03/07 12:45:34 adam + * New Tcl calls egw_enc/egw_dec to encode/decode binary URL info. + * + * Revision 1.11 1996/01/24 08:26:56 adam + * All tcl commands prefixed with egw_ (except the html command). + * + * Revision 1.10 1995/11/08 16:14:35 adam + * Many improvements and bug fixes. + * First version that ran on dtbsun. + * + * Revision 1.9 1995/11/07 14:57:00 adam + * Work on search in multiple targets. + * New wtcl command: wlog. + * Optional timeout parameter to zwait. + * + * Revision 1.8 1995/11/06 17:44:23 adam + * State reestablised when shell restarts. History of previous + * result sets. + * + * Revision 1.7 1995/10/31 16:56:25 adam + * Record presentation. + * + * Revision 1.6 1995/10/31 10:03:54 adam + * Work on queries. + * New command implemented - aborts script. + * + * Revision 1.5 1995/10/30 17:35:18 adam + * New function zwait that waits for a variable change - due to i/o events + * that invoke callback routines. + * + * Revision 1.4 1995/10/27 17:30:16 adam + * First search request/response that works. + * + * Revision 1.3 1995/10/27 15:12:14 adam + * IrTcl incorporated in the gateway. + * Better separation of script types. + * Z39.50 gateway scripts entered. + * + * Revision 1.2 1995/10/23 16:55:43 adam + * A lot of changes - really. + * + * Revision 1.1 1995/10/20 14:02:42 adam * First version of WWW gateway with embedded Tcl. * */ @@ -52,18 +118,19 @@ #include #include -#include - -#include "wproto.h" -#include "winterp.h" +#include "wtcl.h" -static void *do_create (void *args); -static int do_exec (WCLIENT wcl, const char *fname, char *parms, void *mydata); +static void *do_create (WCLIENT wcl, void *args); +static int do_exec (const char *fname, char *parms, void *mydata); +static int do_load (char *parms, void *mydata); +static int do_save (char *parms, void *mydata); static struct w_interp_type w_interp_t = { "tcl", do_create, - do_exec + do_exec, + do_load, + do_save }; W_Interp_Type w_interp_tcl = &w_interp_t; @@ -76,12 +143,292 @@ struct tcl_info { char *fbuf; int fbuf_size; int fbuf_ptr; + int wabort; + WCLIENT wcl; }; -static void *do_create (void *args) +static int exec_file (const char *fname, struct tcl_info *p); + +Tcl_Interp *w_interp_tcl_get (W_Interp w_interp) { struct tcl_info *p; + if (strcmp (w_interp->ctrl->name, "tcl")) + { + gw_log (GW_LOG_FATAL, mod, "Internal failure"); + assert (0); + } + p = (struct tcl_info*) w_interp->mydata; + return p->interp; +} + +static int proc_wabort_invoke (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + + p->wabort = 1; + if (argc > 1) + Tcl_AppendResult (interp, argv[1], NULL); + return TCL_RETURN; +} + +static int proc_wflush_invoke (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + + wo_flush (p->wcl); + return TCL_OK; +} + +static int proc_html_invoke (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + int i; + + for (i = 1; iwcl, argv[i], strlen(argv[i])); + return TCL_OK; +} + +static int proc_form_invoke (struct tcl_info *p, wform_data *wfdata, + Tcl_Interp *interp, + int argc, char **argv) +{ + const char *arg = NULL; + int failFlag = 0; + int i; + + if (argc == 3) + { + if (!strcmp (argv[1], "-raw")) + { + interp->result = p->wcl->raw_data; + return TCL_OK; + } + else if (!strcmp (argv[1], "-exists")) + { + failFlag = 1; + arg = argv[2]; + } + else + { + Tcl_AppendResult (p->interp, "bad option to ", argv[0], + " \"", argv[1], "\"", NULL); + return TCL_ERROR; + } + } + else if (argc == 2) + arg = argv[1]; + if (arg) + { + for (i = 0; *wfdata[i].name; i++) + if (!strcmp (arg, wfdata[i].name)) + { + failFlag = 0; + if (*wfdata[i].value) + Tcl_AppendElement (p->interp, wfdata[i].value); + } + if (failFlag) + { + Tcl_AppendResult (p->interp, arg, " doesn't exist", NULL); + return TCL_ERROR; + } + return TCL_OK; + } + for (i = 0; *wfdata[i].name; i++) + { + Tcl_AppendResult (p->interp, "{ ", NULL); + Tcl_AppendElement (p->interp, wfdata[i].name); + Tcl_AppendElement (p->interp, wfdata[i].value); + Tcl_AppendResult (p->interp, " }\n", NULL); + } + return TCL_OK; +} + +static int proc_wform_invoke (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + wform_data *wfdata = p->wcl->wf_data; + return proc_form_invoke (p, wfdata, interp, argc, argv); +} + +static int proc_parms_invoke (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + wform_data *wfdata = p->wcl->wf_parms_var; + return proc_form_invoke (p, wfdata, interp, argc, argv); +} + + +static int proc_wlog_invoke (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + unsigned mask; + + if (argc < 3) + return TCL_OK; + if (!strcmp (argv[1], "debug")) + mask = GW_LOG_DEBUG; + else if (!strcmp (argv[1], "fatal")) + mask = GW_LOG_FATAL; + else if (!strcmp (argv[1], "warn")) + mask = GW_LOG_WARN; + else if (!strcmp (argv[1], "acct")) + mask = GW_LOG_ACCT; + else + mask = GW_LOG_DEBUG; + switch (argc) + { + case 3: + gw_log (mask, mod, "%s", argv[2]); + break; + case 4: + gw_log (mask, mod, "%s %s", argv[2], argv[3]); + break; + case 5: + gw_log (mask, mod, "%s %s %s", argv[2], argv[3], argv[4]); + break; + case 6: + gw_log (mask, mod, "%s %s %s %s", argv[2], argv[3], argv[4], argv[5]); + break; + } + return TCL_OK; +} + +static int proc_enc (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + int i; + char buf1[6]; + char buf2[2]; + + buf1[0] = '%'; + buf2[1] = '\0'; + for (i = 1; i= 127 || *cp == '&' || *cp == '?' + || *cp == '%' || *cp == '+') + { + sprintf (buf1+1, "%02X", *cp & 0xff); + Tcl_AppendResult (interp, buf1, NULL); + } + else if (*cp == ' ') + { + Tcl_AppendResult (interp, "+", NULL); + } + else + { + buf2[0] = *cp; + Tcl_AppendResult (interp, buf2, NULL); + } + cp++; + } + } + return TCL_OK; +} + +static int proc_dec (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + int i; + unsigned val; + char buf[2]; + + buf[1] = '\0'; + for (i = 1; i= 'A') + val = cp[1] - 'A'+10; + else + val = cp[1] - '0'; + + + if (cp[2] >= 'A') + val = val*16 + (cp[2] - 'A'+10); + else + val = val*16 + (cp[2] - '0'); + buf[0] = val; + cp += 3; + } + else + buf[0] = *cp++; + Tcl_AppendResult (interp, buf, NULL); + } + } + return TCL_OK; +} + +static int proc_prog (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + + Tcl_AppendResult (p->interp, p->wcl->prog, NULL); + return TCL_OK; +} + +static int proc_source (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + int r; + + if (argc != 2) + { + Tcl_AppendResult (p->interp, + "wrong # args: should be egw_source file", NULL); + return TCL_ERROR; + } + r = exec_file (argv[1], p); + if (r == -2) + { + Tcl_AppendResult (p->interp, "egw_source: couldn't source ", + argv[1], NULL); + return TCL_ERROR; + } + else if (r == -1) + { + Tcl_AppendResult (p->interp, "egw_source: Tcl error in script ", + argv[1], NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int proc_clear (ClientData clientData, Tcl_Interp *interp, + int argc, char **argv) +{ + struct tcl_info *p = (struct tcl_info*) clientData; + + wo_clear (p->wcl); + return TCL_OK; +} + +int Tcl_AppInit (Tcl_Interp *interp) +{ + if (Tcl_Init (interp) == TCL_ERROR) + return TCL_ERROR; + return TCL_OK; +} + +static void *do_create (WCLIENT wcl, void *args) +{ + struct tcl_info *p; + char tmp_str[256]; + if (!(p = malloc (sizeof(*p)))) { gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: tcl_info"); @@ -92,23 +439,48 @@ static void *do_create (void *args) gw_log (GW_LOG_FATAL, mod, "Cannot make Tcl_Interp"); exit (1); } + p->wcl = wcl; p->fbuf_size = 1024; if (!(p->fbuf = malloc (p->fbuf_size))) { gw_log (GW_LOG_FATAL|GW_LOG_ERRNO, mod, "malloc: tcl_info fbuf"); exit (1); } + Tcl_AppInit (p->interp); + Tcl_CreateCommand (p->interp, "html", proc_html_invoke, p, NULL); + Tcl_CreateCommand (p->interp, "egw_form", proc_wform_invoke, p, NULL); + Tcl_CreateCommand (p->interp, "egw_parms", proc_parms_invoke, p, NULL); + Tcl_CreateCommand (p->interp, "egw_abort", proc_wabort_invoke, p, NULL); + Tcl_CreateCommand (p->interp, "egw_flush", proc_wflush_invoke, p, NULL); + Tcl_CreateCommand (p->interp, "egw_log", proc_wlog_invoke, p, NULL); + Tcl_CreateCommand (p->interp, "egw_enc", proc_enc, p, NULL); + Tcl_CreateCommand (p->interp, "egw_dec", proc_dec, p, NULL); + Tcl_CreateCommand (p->interp, "egw_prog", proc_prog, p, NULL); + Tcl_CreateCommand (p->interp, "egw_source", proc_source, p, NULL); + Tcl_CreateCommand (p->interp, "egw_clear", proc_clear, p, NULL); + sprintf (tmp_str, "%d", wcl->id); + Tcl_SetVar (p->interp, "sessionId", tmp_str, TCL_GLOBAL_ONLY); return p; } -static int tcl_exec (WCLIENT wcl, const char *fname, char *parms, - struct tcl_info *p, FILE *inf, int *lineno) +static void report_error (struct tcl_info *p, int errorLine, + const char *pre, const char *msg) +{ + if (!msg) + msg = ""; + gw_log (GW_LOG_WARN, mod, "%s %d %s", pre, errorLine, msg); + wo_printf (p->wcl, "\n
\n" + "%s %d
\n", pre, errorLine); + wo_printf (p->wcl, "\n%s\n
\n", msg); +} + +static int tcl_exec (const char *fname, struct tcl_info *p, FILE *inf, + int *lineno) { int c, escape = 0, level = 0; int r, fbuf_ptr = 0; int local_line = 0; - gw_log (GW_LOG_DEBUG, mod, "tcl_exec. line %d", *lineno); while (1) { if (fbuf_ptr == p->fbuf_size-1) @@ -127,8 +499,9 @@ static int tcl_exec (WCLIENT wcl, const char *fname, char *parms, c = getc (inf); if (c == EOF) { - gw_log (GW_LOG_WARN, mod, "Unexpected EOF: unbalanced braces"); - return -1; + report_error (p, *lineno, "Error in Tcl script starting at line", + "Unexpected EOF (missing right brace)"); + return TCL_ERROR; } if (c == '\\') escape = 1; @@ -152,21 +525,59 @@ static int tcl_exec (WCLIENT wcl, const char *fname, char *parms, p->fbuf[fbuf_ptr++] = c; } p->fbuf[fbuf_ptr] = '\0'; - gw_log (GW_LOG_DEBUG, mod, "Tcl_Eval. %d lines", local_line); + p->wabort = 0; r = Tcl_Eval (p->interp, p->fbuf); - if (r != TCL_OK) + if (r == TCL_ERROR) + report_error (p, p->interp->errorLine + *lineno - 1, + "Error in Tcl script in line", + Tcl_GetVar (p->interp, "errorInfo", 0)); + (*lineno) += local_line; + if (p->wabort) + return TCL_RETURN; + return r; +} + +static int var_ref (struct tcl_info *p, FILE *inf) +{ + int c, i = 0; + char name[32], *vp; + + c = getc (inf); + if (c == '{') + { + while ((c = getc(inf)) != EOF) + { + if (c == '\n') + break; + if (c == '}') + { + c = getc (inf); + break; + } + if (i < 31) + name[i++] = c; + } + } + else { - gw_log (GW_LOG_WARN, mod, "Error in Tcl script starting on line %d", - *lineno); + while (c != EOF) + { + if (c != '(' && c != ')' && c != '-' && c != '_' && !isalnum(c)) + break; + if (i < 31) + name[i++] = c; + c = getc (inf); + } } - (*lineno) += local_line; - return 0; + name[i] = '\0'; + vp = Tcl_GetVar (p->interp, name, 0); + if (vp) + wo_puts (p->wcl, vp); + return c; } -static int do_exec (WCLIENT wcl, const char *fname, char *parms, - void *mydata) +static int exec_file (const char *fname, struct tcl_info *p) { - struct tcl_info *p = mydata; int c, escape = 0; int lineno = 1; FILE *inf = fopen (fname, "r"); @@ -177,32 +588,93 @@ static int do_exec (WCLIENT wcl, const char *fname, char *parms, gw_log (GW_LOG_WARN|GW_LOG_ERRNO, mod, "open %s", fname); return -1; } - while ((c = getc(inf)) != EOF) + c = getc (inf); + while (c != EOF) { - if (c == '\\') - escape = 1; - else if (c == '{') + switch (c) { + case '\\': + escape = 1; + c = getc (inf); + break; + case '$': + if (escape) + { + c = getc (inf); + wo_putc (p->wcl, c); + } + else + c = var_ref (p, inf); + break; + case '{': if (escape) - wo_putc (wcl, c); + wo_putc (p->wcl, c); else { - if (tcl_exec (wcl, fname, parms, p, inf, &lineno)) + int r = tcl_exec (fname, p, inf, &lineno); + if (r == TCL_RETURN) + { + fclose (inf); + return 0; + } + else if (r == TCL_ERROR) { fclose (inf); return -2; } } escape = 0; - } - else - { + c = getc (inf); + break; + default: if (c == '\n') lineno++; escape = 0; - wo_putc (wcl, c); + wo_putc (p->wcl, c); + c = getc (inf); } } fclose (inf); return 0; } + +static int do_exec (const char *fname, char *parms, void *mydata) +{ + struct tcl_info *p = mydata; + + Tcl_SetVar (p->interp, "sessionParms", parms, TCL_GLOBAL_ONLY); + return exec_file (fname, p); +} + +static int do_load (char *parms, void *mydata) +{ + struct tcl_info *p = mydata; + char fname[80]; + int r; + + sprintf (fname, "tcl.state.%d", p->wcl->id); + r = Tcl_EvalFile (p->interp, fname); + if (r == TCL_ERROR) + gw_log (GW_LOG_WARN, mod, "Cannot load Tcl state" ); + return 0; +} + +static int do_save (char *parms, void *mydata) +{ + struct tcl_info *p = mydata; + struct Tcl_CmdInfo cinfo; + + if (Tcl_GetCommandInfo(p->interp, "saveState", &cinfo)) + { + int r; + + gw_log (GW_LOG_DEBUG, mod, "saveState"); + r = Tcl_Eval (p->interp, "saveState\n"); + if (r == TCL_ERROR) + report_error (p, p->interp->errorLine, + "Error in Tcl saveState in line", + Tcl_GetVar (p->interp, "errorInfo", 0)); + } + return 0; +} +