tcl-mod_dtcl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From dav...@apache.org
Subject cvs commit: tcl-moddtcl/tests dtcl-test2.ttml README dtcl.test
Date Mon, 21 May 2001 19:49:35 GMT
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 <davidw@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 <davidw@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 Ms 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 Ms ] } {
  	hputs "VARS(Ms) = [var get Ms]\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"
      }
  }
  
  ?>
  
  

Mime
View raw message