You are viewing a plain text version of this content. The canonical link for it is here.
Posted to mod_dtcl-cvs@tcl.apache.org by da...@apache.org on 2001/05/21 21:49:35 UTC
cvs commit: tcl-moddtcl/tests dtcl-test2.ttml README dtcl.test
davidw 01/05/21 12:49:34
Modified: . mod_dtcl.c mod_dtcl.h tcl_commands.c tcl_commands.h
tests README dtcl.test
Added: tests dtcl-test2.ttml
Log:
Added 'var' command, duplicated dtcl-test.html to use it. Passes all
dtcl.test tests!
Revision Changes Path
1.29 +13 -8 tcl-moddtcl/mod_dtcl.c
Index: mod_dtcl.c
===================================================================
RCS file: /home/cvs/tcl-moddtcl/mod_dtcl.c,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- mod_dtcl.c 2001/05/08 11:05:06 1.28
+++ mod_dtcl.c 2001/05/21 19:49:19 1.29
@@ -58,7 +58,7 @@
* University of Illinois, Urbana-Champaign.
*/
-/* $Id: mod_dtcl.c,v 1.28 2001/05/08 11:05:06 davidw Exp $ */
+/* $Id: mod_dtcl.c,v 1.29 2001/05/21 19:49:19 davidw Exp $ */
/* mod_dtcl.c by David Welton <da...@apache.org> - originally mod_include. */
/* See http://tcl.apache.org/mod_dtcl/credits.ttml for additional credits. */
@@ -90,6 +90,7 @@
/* *** Global variables *** */
request_rec *global_rr; /* request rec */
+ApacheRequest *global_req; /* libapreq request */
Tcl_Encoding system_encoding; /* Default encoding */
/* output buffer for initial buffer_add. We use traditional memory
@@ -674,7 +675,7 @@
Tcl_Interp *interp;
- ApacheRequest *req;
+ ApacheRequest *req = NULL;
ApacheUpload *upload;
global_rr = r; /* Assign request to global request var */
@@ -722,15 +723,17 @@
/* Apache Request stuff */
req = ApacheRequest_new(r);
- if (upload_files_to_var)
- {
- req->hook_data = interp;
- req->upload_hook = dtcl_upload_hook;
- }
-
+ global_req = req;
+ if (upload_files_to_var)
+ {
+ req->hook_data = interp;
+ req->upload_hook = dtcl_upload_hook;
+ }
+
ApacheRequest___parse(req);
/* take results and create tcl variables from them */
+#if USE_ONLY_VAR_COMMAND == 1
if (req->parms)
{
int i;
@@ -761,6 +764,7 @@
}
}
+#endif
upload = req->upload;
/* Loop through uploaded files */
@@ -843,6 +847,7 @@
Tcl_CreateObjCommand(interp, "buffered", Buffered, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "headers", Headers, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "hgetvars", HGetVars, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+ Tcl_CreateObjCommand(interp, "var", Var, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "include", Include, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "parse", Parse, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "hflush", HFlush, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
1.3 +4 -0 tcl-moddtcl/mod_dtcl.h
Index: mod_dtcl.h
===================================================================
RCS file: /home/cvs/tcl-moddtcl/mod_dtcl.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mod_dtcl.h 2001/03/01 18:31:32 1.2
+++ mod_dtcl.h 2001/05/21 19:49:20 1.3
@@ -34,6 +34,10 @@
use <? ?> tags. */
#define USE_OLD_TAGS 1
+/* Turn off 'old-style' $VARS variable handling, and use only the
+ 'var' command. */
+#define USE_ONLY_VAR_COMMAND 0
+
/* End Configuration options */
#define STARTING_SEQUENCE "<?"
1.6 +173 -22 tcl-moddtcl/tcl_commands.c
Index: tcl_commands.c
===================================================================
RCS file: /home/cvs/tcl-moddtcl/tcl_commands.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- tcl_commands.c 2001/03/13 12:00:45 1.5
+++ tcl_commands.c 2001/05/21 19:49:21 1.6
@@ -24,6 +24,8 @@
extern int headers_printed;
extern int cacheFreeSize;
+extern ApacheRequest *global_req;
+
/* Include and parse a file */
int Parse(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
@@ -142,8 +144,8 @@
Tcl_WrongNumArgs(interp, 1, objv, "?-error? string");
return TCL_ERROR;
}
- ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE,
- global_rr->server, "Mod_Dtcl Error: %s",
+ ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE,
+ global_rr->server, "Mod_Dtcl Error: %s",
Tcl_GetStringFromObj (objv[2], (int *)NULL));
} else {
if (objc != 2)
@@ -156,7 +158,7 @@
memwrite(&obuffer, arg1, length);
} else {
print_headers(global_rr);
- flush_output_buffer(global_rr);
+ flush_output_buffer(global_rr);
ap_rwrite(arg1, length, global_rr);
}
}
@@ -171,7 +173,7 @@
char *opt;
if (objc < 2)
{
- Tcl_WrongNumArgs(interp, 1, objv, "headers option arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
if (headers_printed != 0)
@@ -190,8 +192,8 @@
if (objc < 4 || objc > 14)
{
- Tcl_WrongNumArgs(interp, 1, objv,
- "headers setcookie -name cookie-name -value cookie-value ?-expires expires? ?-domain domain? ?-path path? ?-secure on/off?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "-name cookie-name -value cookie-value ?-expires expires? ?-domain domain? ?-path path? ?-secure on/off?");
return TCL_ERROR;
}
@@ -215,7 +217,7 @@
{
if (objc != 3)
{
- Tcl_WrongNumArgs(interp, 1, objv, "headers redirect new-url");
+ Tcl_WrongNumArgs(interp, 2, objv, "new-url");
return TCL_ERROR;
}
ap_table_set(global_rr->headers_out, "Location", Tcl_GetStringFromObj (objv[2], (int *)NULL));
@@ -226,7 +228,7 @@
{
if (objc != 4)
{
- Tcl_WrongNumArgs(interp, 1, objv, "set headername value");
+ Tcl_WrongNumArgs(interp, 2, objv, "headername value");
return TCL_ERROR;
}
ap_table_set(global_rr->headers_out,
@@ -237,7 +239,7 @@
{
if (objc != 3)
{
- Tcl_WrongNumArgs(interp, 1, objv, "type mime/type");
+ Tcl_WrongNumArgs(interp, 2, objv, "mime/type");
return TCL_ERROR;
}
set_header_type(global_rr, Tcl_GetStringFromObj(objv[2], (int *)NULL));
@@ -247,7 +249,7 @@
if (objc != 3)
{
- Tcl_WrongNumArgs(interp, 1, objv, "numeric response code");
+ Tcl_WrongNumArgs(interp, 2, objv, "response code");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[2], &st) != TCL_ERROR)
@@ -329,10 +331,10 @@
/* retrieve cgi variables */
ap_add_cgi_vars(global_rr);
ap_add_common_vars(global_rr);
-
+
hdrs_arr = ap_table_elts(global_rr->headers_in);
hdrs = (table_entry *) hdrs_arr->elts;
-
+
env_arr = ap_table_elts(global_rr->subprocess_env);
env = (table_entry *) env_arr->elts;
@@ -347,15 +349,15 @@
tmp = ap_pbase64decode(global_rr->pool, authorization);
user = ap_getword_nulls_nc(global_rr->pool, &tmp, ':');
pass = tmp;
- Tcl_ObjSetVar2(interp, Tcl_NewStringObj("::request::USER", -1),
+ Tcl_ObjSetVar2(interp, Tcl_NewStringObj("::request::USER", -1),
Tcl_NewStringObj("user", -1),
STRING_TO_UTF_TO_OBJ(user),
- 0);
- Tcl_ObjSetVar2(interp, Tcl_NewStringObj("::request::USER", -1),
+ 0);
+ Tcl_ObjSetVar2(interp, Tcl_NewStringObj("::request::USER", -1),
Tcl_NewStringObj("pass", -1),
STRING_TO_UTF_TO_OBJ(pass),
- 0);
- }
+ 0);
+ }
/* These were the "include vars" */
Tcl_ObjSetVar2(interp, EnvsObj, Tcl_NewStringObj("DATE_LOCAL", -1), STRING_TO_UTF_TO_OBJ(ap_ht_time(global_rr->pool, date, timefmt, 0)), 0);
@@ -415,20 +417,169 @@
for (j = 0; j < ApacheCookieItems(c); j++) {
char *name = c->name;
char *value = ApacheCookieFetch(c, j);
- Tcl_ObjSetVar2(interp, cookieobj,
+ Tcl_ObjSetVar2(interp, cookieobj,
STRING_TO_UTF_TO_OBJ(name),
STRING_TO_UTF_TO_OBJ(value), 0);
}
-
- }
+
+ }
} while (0);
-
+
/* cleanup system cgi variables */
ap_clear_table(global_rr->subprocess_env);
return TCL_OK;
}
+/* Tcl command to return a particular variable. */
+
+/* Use:
+ var get foo
+ var list foo
+ var names
+ var number
+ */
+
+int Var(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+{
+ char *command;
+ int i;
+ Tcl_Obj *result = NULL;
+ array_header *parmsarray = ap_table_elts(global_req->parms);
+ table_entry *parms = (table_entry *)parmsarray->elts;
+
+ if (objc < 2 || objc > 3)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "(get varname|list varname|exists varname|names|number)");
+ return TCL_ERROR;
+ }
+ command = Tcl_GetStringFromObj(objv[1], NULL);
+
+ if (!strcmp(command, "get"))
+ {
+ char *key = NULL;
+ if (objc != 3)
+ {
+ Tcl_WrongNumArgs(interp, 2, objv, "variablename");
+ return TCL_ERROR;
+ }
+ key = Tcl_GetStringFromObj(objv[2], NULL);
+
+ /* This isn't real efficient - move to hash table later
+ on... */
+ for (i = 0; i < parmsarray->nelts; ++i)
+ {
+ if (!strncmp(key, StringToUtf(parms[i].key), strlen(key)))
+ {
+ /* The following makes sure that we get one string,
+ with no sub lists. */
+ if (result == NULL)
+ {
+ result = STRING_TO_UTF_TO_OBJ(parms[i].val);
+ Tcl_IncrRefCount(result);
+ } else {
+ Tcl_Obj *tmpobjv[2];
+ tmpobjv[0] = result;
+ tmpobjv[1] = STRING_TO_UTF_TO_OBJ(parms[i].val);
+ result = Tcl_ConcatObj(2, tmpobjv);
+ }
+ }
+ }
+
+ if (result == NULL)
+ Tcl_AppendResult(interp, "", NULL);
+ else
+ Tcl_SetObjResult(interp, result);
+ } else if(!strcmp(command, "exists")) {
+ char *key;
+ if (objc != 3)
+ {
+ Tcl_WrongNumArgs(interp, 2, objv, "variablename");
+ return TCL_ERROR;
+ }
+ key = Tcl_GetString(objv[2]);
+
+ /* This isn't real efficient - move to hash table later on. */
+ for (i = 0; i < parmsarray->nelts; ++i)
+ {
+ if (!strncmp(key, StringToUtf(parms[i].key), strlen(key)))
+ {
+ result = Tcl_NewIntObj(1);
+ Tcl_IncrRefCount(result);
+ }
+ }
+
+ if (result == NULL)
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ else
+ Tcl_SetObjResult(interp, result);
+
+ } else if(!strcmp(command, "list")) {
+ char *key;
+ if (objc != 3)
+ {
+ Tcl_WrongNumArgs(interp, 2, objv, "variablename");
+ return TCL_ERROR;
+ }
+ key = Tcl_GetStringFromObj(objv[2], NULL);
+
+ /* This isn't real efficient - move to hash table later on. */
+ for (i = 0; i < parmsarray->nelts; ++i)
+ {
+ if (!strncmp(key, StringToUtf(parms[i].key), strlen(key)))
+ {
+ if (result == NULL)
+ {
+ result = Tcl_NewObj();
+ Tcl_IncrRefCount(result);
+ }
+ Tcl_ListObjAppendElement(interp, result,
+ STRING_TO_UTF_TO_OBJ(parms[i].val));
+ }
+ }
+
+ if (result == NULL)
+ Tcl_AppendResult(interp, "", NULL);
+ else
+ Tcl_SetObjResult(interp, result);
+ } else if(!strcmp(command, "names")) {
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ result = Tcl_NewObj();
+ Tcl_IncrRefCount(result);
+ for (i = 0; i < parmsarray->nelts; ++i)
+ {
+ Tcl_ListObjAppendElement(interp, result,
+ STRING_TO_UTF_TO_OBJ(parms[i].key));
+ }
+
+ if (result == NULL)
+ Tcl_AppendResult(interp, "", NULL);
+ else
+ Tcl_SetObjResult(interp, result);
+
+ } else if(!strcmp(command, "number")) {
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ result = Tcl_NewIntObj(parmsarray->nelts);
+ Tcl_IncrRefCount(result);
+ Tcl_SetObjResult(interp, result);
+ } else {
+ /* bad command */
+ Tcl_AddErrorInfo(interp, "bad option: must be one of 'get, list, names, number'");
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+
/* Tcl command to get, and print some information about the current
state of affairs */
@@ -460,6 +611,6 @@
print_headers(global_rr);
Tcl_Free(obuffer.buf);
obuffer.buf = NULL;
- obuffer.len = 0;
+ obuffer.len = 0;
return TCL_OK;
}
1.3 +13 -0 tcl-moddtcl/tcl_commands.h
Index: tcl_commands.h
===================================================================
RCS file: /home/cvs/tcl-moddtcl/tcl_commands.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- tcl_commands.h 2000/12/27 21:01:40 1.2
+++ tcl_commands.h 2001/05/21 19:49:22 1.3
@@ -1,10 +1,23 @@
+
int Parse(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int Include(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int Buffer_Add(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int Hputs(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int Headers(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int Buffered(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int HFlush(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int HGetVars(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
+int Var(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int Dtcl_Info(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
int No_Body(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
+
1.2 +2 -2 tcl-moddtcl/tests/README
Index: README
===================================================================
RCS file: /home/cvs/tcl-moddtcl/tests/README,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- README 2000/10/04 22:37:10 1.1
+++ README 2001/05/21 19:49:28 1.2
@@ -1,6 +1,6 @@
Test Suite for mod_dtcl
-$Id: README,v 1.1 2000/10/04 22:37:10 davidw Exp $
+$Id: README,v 1.2 2001/05/21 19:49:28 davidw Exp $
These tests are intended to automate the testing of core mod_dtcl
features. They are not complete at this point, and work on them would
@@ -11,7 +11,7 @@
Assuming you have a system which runs mod_dtcl, put the dtcl-test.ttml
file somewhere under your document root, and modify this line:
-set urlbase "http://eugene.i.linuxcare.it/~davidw/tests/"
+set urlbase "http://localhost/"
to something like
1.8 +2 -2 tcl-moddtcl/tests/dtcl.test
Index: dtcl.test
===================================================================
RCS file: /home/cvs/tcl-moddtcl/tests/dtcl.test,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- dtcl.test 2001/05/08 11:57:35 1.7
+++ dtcl.test 2001/05/21 19:49:30 1.8
@@ -2,13 +2,13 @@
# mod_dtcl test suite, by David N. Welton <da...@apache.org>
-# $Id: dtcl.test,v 1.7 2001/05/08 11:57:35 davidw Exp $
+# $Id: dtcl.test,v 1.8 2001/05/21 19:49:30 davidw Exp $
package require tcltest
package require http 2.1
set urlbase "http://localhost/"
-set testfilename "dtcl-test.ttml"
+set testfilename "dtcl-test2.ttml"
::tcltest::test hello-1.1 {hello world test} {
set page [ ::http::geturl "${urlbase}$testfilename" ]
1.1 tcl-moddtcl/tests/dtcl-test2.ttml
Index: dtcl-test2.ttml
===================================================================
<?
# $Id: dtcl-test2.ttml,v 1.1 2001/05/21 19:49:30 davidw Exp $
# dtcl page used with mod_dtcl's dtcl.test
# place in DocumentRoot of http://localhost/
hgetvars
headers setcookie -name mod -value dtcl -expires 01-01-2003
# hello-1.1
hputs "Hello, World\n"
# i18n-1.1
hputs "� � � � � � - El Burro Sabe M�s Que T�!\n"
if { [ var number ] > 0 } {
# get/post variables 1.1
if { [ var exists foobar ] } {
hputs "VARS(foobar) = [var get foobar]\n"
}
# get/post variables 1.{2,3}
if { [ var exists M�s ] } {
hputs "VARS(M�s) = [var get M�s]\n"
}
}
# env
hputs "ENVS(DOCUMENT_NAME) = $ENVS(DOCUMENT_NAME)\n"
# cookies
if { [ array exists COOKIES ] } {
foreach { ck } [ array names COOKIES ] {
hputs "COOKIES($ck) = $COOKIES($ck)\n"
}
}
?>