Added test-suite files in tests/
Moved two-mode-mode.el to contrib/
Changed behaviour of Apache dtcl 'script' commands.
PR:
diff --git a/Makefile b/Makefile
index 1f34f81..97aed4a 100644
--- a/Makefile
+++ b/Makefile
@@ -12,7 +12,6 @@
CFLAGS_SHLIB=-fpic -DSHARED_MODULE
LDFLAGS_SHLIB=-Bshareable
CFLAGS1= -Wall -DLINUX=2 -DSTATUS -DNO_DBM_REWRITEMAP -DUSE_HSREGEX -fpic -DSHARED_CORE
-MFLAGS_STATIC=--no-print-directory
CFLAGS=$(OPTIM) $(CFLAGS1) $(EXTRA_CFLAGS)
# You must change the following line unless you have the Debian apache-dev package
@@ -24,60 +23,21 @@
all: lib shlib
-other: all txt testdtcl
-
-extra: other code2html
-
lib: $(LIB)
shlib: $(SHLIBS)
-
-.SUFFIXES: .o .so
-
-.c.o:
- $(CC) -g -c $(INCLUDES) $(CFLAGS) $(SPACER) $<
+.SUFFIXES: .so
.c.so:
- $(CC) -g -c $(INCLUDES) $(CFLAGS) $(CFLAGS_SHLIB) $(SPACER) $< && mv $*.o $*-so.o
+ $(CC) -g -c $(INCLUDES) $(CFLAGS) $(CFLAGS_SHLIB) $(SPACER) -DDTCL_VERSION=\"`cat VERSION`\" $< && mv $*.o $*-so.o
$(LD) $(LDFLAGS_SHLIB) -o $@ $*-so.o -ltcl$(TCL_VERSION)
-clean: txtclean
+clean:
rm -f $(SHLIBS) $(SHLIBS_OBJ) $(LIB) $(SHLIB)
- -rm testdtcl
-testdtcl: testdtcl.c
- $(CC) -g -o testdtcl -O3 testdtcl.c -ltcl$(TCL_VERSION) -DDEBUG_SCRIPT_DIR=\"$(DEBUG_SCRIPT_DIR)\"
+version:
+ ./cvsversion.tcl
-txtclean:
- -rm readme.txt INSTALL.txt dtcl-tcl.txt use.txt
-
-txt: readme.txt INSTALL.txt dtcl-tcl.txt use.txt TODO.txt readme.hpux.txt
-
-readme.hpux.html: readme.hpux.txt
- lynx -dump readme.hpux.html > readme.hpux.txt
-
-readme.txt: readme.html
- lynx -dump readme.html > readme.txt
-
-INSTALL.txt: INSTALL.html
- lynx -dump INSTALL.html > INSTALL.txt
-
-dtcl-tcl.txt: dtcl-tcl.html
- lynx -dump dtcl-tcl.html > dtcl-tcl.txt
-
-use.txt: use.html
- lynx -dump use.html > use.txt
-
-TODO.txt: TODO.html
- lynx -dump TODO.html > TODO.txt
-
-readme.hpux.txt: readme.hpux.html
- lynx -dump readme.hpux.html > readme.hpux.txt
-
-# Need to be running under X for this to work!
-code2html: font-lock-stuff.el
- if [ -n "$$DISPLAY" ] ; then emacs -r -l font-lock-stuff.el -f flscreate --kill ; fi
-
-code2htmlclean:
- emacs -r -l font-lock-stuff.el -f flsclean -kill
\ No newline at end of file
+dist: clean version all
+ (cd .. ; tar -czvf mod_dtcl-`cat mod_dtcl/VERSION`.tar.gz mod_dtcl/ ; )
diff --git a/docs/two-mode-mode.el b/contrib/two-mode-mode.el
similarity index 92%
rename from docs/two-mode-mode.el
rename to contrib/two-mode-mode.el
index 4e09c6e..67c1972 100644
--- a/docs/two-mode-mode.el
+++ b/contrib/two-mode-mode.el
@@ -1,6 +1,8 @@
-;; two-mode-mode.el -- switches between tcl and sgml(html) modes $Id:
-;; two-mode-mode.el,v 1.2.2.1 2000/06/21 23:55:05 davidw Exp $
+;; two-mode-mode.el -- switches between tcl and sgml(html) modes
+;; $Id$
+
;; two-mode-mode.el is Copyright David Welton <davidw@efn.org> 1999, 2000
+
;; two-mode-mode.el may be distributed under the terms of the Apache
;; Software License, Version 1.1
@@ -19,8 +21,8 @@
(defvar two-mode-lmatch "<+")
(defvar two-mode-rmatch "+>")
-(defvar default-mode (list 'sgml-mode "SGML"))
-(defvar second-mode (list 'tcl-mode "TCL"))
+(defvar default-mode (list 'sgml-mode "SGML")) ;; outside the above tokens
+(defvar second-mode (list 'tcl-mode "TCL")) ;; inside
;; ----------------
(defun two-mode-mode-setup ()
diff --git a/cvsversion.tcl b/cvsversion.tcl
new file mode 100755
index 0000000..acfc2e5
--- /dev/null
+++ b/cvsversion.tcl
@@ -0,0 +1,108 @@
+#!/usr/bin/tclsh
+# By David N. Welton <davidw@linuxcare.com>
+# $Id$
+
+# This is a script to aid in keeping a coherent version number
+# attached to the program.
+
+set newversionvar 0
+
+proc newversion { } {
+ global newversionvar
+ puts stderr "New version"
+ set newversionvar 1
+}
+
+proc diffentries { {dir .} } {
+ global newversionvar
+
+ puts stderr "Diffentries for $dir"
+ set currentdir [ pwd ]
+ cd $dir
+ if { ! [ file exists ./CVS/Entries ] } {
+ puts stderr "You must be in a directory with a path to ./CVS/Entries."
+ }
+
+ if { ! [ file exists ./.OLDEntries ] } {
+ puts stderr "No OLDEntries file. It will be created."
+ set fl [ open ./.OLDEntries w ]
+ close $fl
+ }
+
+ set entries [ open ./CVS/Entries ]
+ set blob ""
+ while { [ gets $entries ln ] != -1 } {
+ lappend blob $ln
+ }
+ close $entries
+
+ set oldentries [ open ./.OLDEntries ]
+ set blob2 ""
+ while { [ gets $oldentries ln ] != -1 } {
+ lappend blob2 $ln
+ }
+ close $oldentries
+
+ if { $blob != $blob2 } {
+ newversion
+ }
+ foreach ln $blob {
+ # the regexp below scans for directories in CVS Entries files
+ if { [ regexp {^D/(.*)////$} "$ln" match dir ] } {
+ diffentries $dir
+ }
+ }
+
+ file copy -force ./CVS/Entries ./.OLDEntries
+ cd $currentdir
+}
+
+diffentries
+
+if { $newversionvar == 0 } {
+ puts stderr "No changes, exiting."
+} else {
+ if { [ file exists ./VERSION ] } {
+ set versionfile [ open ./VERSION "r" ]
+ gets $versionfile versionstring
+ close $versionfile
+ } else {
+ set versionstring "0.0.0"
+ }
+
+ if { ! [ regexp {([0-9]+)\.([0-9]+)\.([0-9]+)} $versionstring match major minor point ] } {
+ puts stderr "Problem with versionstring '$versionstring', exiting"
+ exit 1
+ }
+
+ set versionfile [ open ./VERSION "w" ]
+ while { 1 } {
+ puts -nonewline stderr "Current version: $major.$minor.$point. "
+ puts -nonewline stderr {Increment [M]ajor, m[I]nor, [P]oint release, or [A]bort? >>> }
+ gets stdin answer
+ switch [ string tolower $answer ] {
+ m {
+ incr major
+ set minor 0
+ set point 0
+ break
+ }
+ i {
+ incr minor
+ set point 0
+ break
+ }
+ p {
+ incr point
+ break
+ }
+ a {
+ puts stderr "Aborted"
+ break
+ }
+ }
+ }
+ puts $versionfile "$major.$minor.$point"
+ close $versionfile
+ puts stderr "Done, version is $major.$minor.$point"
+}
\ No newline at end of file
diff --git a/debian/rules b/debian/rules
index 6c2d1a1..0e5f09e 100755
--- a/debian/rules
+++ b/debian/rules
@@ -36,7 +36,7 @@
cp testdtcl debian/tmp/usr/bin/
# Must have debmake installed for this to work. Otherwise please copy
# /usr/bin/debstd into the debian directory and change debstd to debian/debstd
- dh_installdocs *.html *.ttml INSTALL.txt use.txt readme.txt dtcl-tcl.txt dtcl.tcl two-mode-mode.el dtcl.gif
+ dh_installdocs docs/ contrib/
dh_installchangelogs
dh_installmanpages
dh_movefiles
diff --git a/mod_dtcl.c b/mod_dtcl.c
index 196b7c5..fc8c77b 100644
--- a/mod_dtcl.c
+++ b/mod_dtcl.c
@@ -128,7 +128,7 @@
#define DEFAULT_ERROR_MSG "[an error occurred while processing this directive]"
#define DEFAULT_TIME_FORMAT "%A, %d-%b-%Y %H:%M:%S %Z"
#define DEFAULT_HEADER_TYPE "text/html"
-#define DTCL_VERSION "0.8.5"
+/* #define DTCL_VERSION "0.8.5" */
/* *** Global variables *** */
static Tcl_Interp *interp; /* Tcl interpreter */
@@ -1315,9 +1315,11 @@
}
typedef struct {
- char *dtcl_global_script;
- char *dtcl_init_script;
- char *dtcl_exit_script;
+ Tcl_Obj *dtcl_global_init_script;
+ Tcl_Obj *dtcl_child_init_script;
+ Tcl_Obj *dtcl_child_exit_script;
+ Tcl_Obj *dtcl_before_script;
+ Tcl_Obj *dtcl_after_script;
int dtcl_cache_size;
} dtcl_server_conf;
@@ -1375,13 +1377,13 @@
Tcl_IncrRefCount(namespacePrologue);
#if DBG
- ap_log_error(APLOG_MARK, APLOG_ERR, s, "Config string = \"%s\"", dsc->dtcl_global_script); /* XXX */
+ ap_log_error(APLOG_MARK, APLOG_ERR, s, "Config string = \"%s\"", Tcl_GetStringFromObj(dsc->dtcl_global_init_script, NULL)); /* XXX */
ap_log_error(APLOG_MARK, APLOG_ERR, s, "Cache size = \"%d\"", dsc->dtcl_cache_size); /* XXX */
#endif
- if (dsc->dtcl_global_script != NULL)
+ if (dsc->dtcl_global_init_script != NULL)
{
- rslt = Tcl_EvalFile(interp, dsc->dtcl_global_script);
+ rslt = Tcl_EvalObjEx(interp, dsc->dtcl_global_init_script, 0);
if (rslt != TCL_OK)
{
ap_log_error(APLOG_MARK, APLOG_ERR, s, "%s",
@@ -1396,7 +1398,7 @@
if (ap_max_requests_per_child != 0)
cacheSize = ap_max_requests_per_child / 2;
else
- cacheSize = 50; /* Arbitrary number */
+ cacheSize = 10; /* Arbitrary number FIXME */
cacheFreeSize = cacheSize;
}
/* Initializing cache structures */
@@ -1412,27 +1414,32 @@
ap_add_version_component("Mod_dtcl " DTCL_VERSION);
}
-static const char *set_globalscript(cmd_parms *cmd, void *dummy, char *arg)
+static const char *set_script(cmd_parms *cmd, void *dummy, char *arg, char *arg2)
{
+ Tcl_Obj *objarg;
server_rec *s = cmd->server;
dtcl_server_conf *conf = (dtcl_server_conf *)ap_get_module_config(s->module_config, &dtcl_module);
- conf->dtcl_global_script = arg;
- return NULL;
-}
-static const char *set_initscript(cmd_parms *cmd, void *dummy, char *arg)
-{
- server_rec *s = cmd->server;
- dtcl_server_conf *conf = (dtcl_server_conf *)ap_get_module_config(s->module_config, &dtcl_module);
- conf->dtcl_init_script = arg;
- return NULL;
-}
-
-static const char *set_exitscript(cmd_parms *cmd, void *dummy, char *arg)
-{
- server_rec *s = cmd->server;
- dtcl_server_conf *conf = (dtcl_server_conf *)ap_get_module_config(s->module_config, &dtcl_module);
- conf->dtcl_exit_script = arg;
+ if (arg == NULL || arg2 == NULL)
+ {
+ ap_log_error(APLOG_MARK, APLOG_ERR, global_rr->server, "Mod_Dtcl Error: Dtcl_Script requires two arguments");
+ return NULL;
+ }
+
+ objarg = Tcl_NewStringObj(arg2, -1);
+ if (strcmp(arg, "GlobalInitScript") == 0) {
+ conf->dtcl_global_init_script = objarg;
+ } else if (strcmp(arg, "ChildInitScript") == 0) {
+ conf->dtcl_child_init_script = objarg;
+ } else if (strcmp(arg, "ChildExitScript") == 0) {
+ conf->dtcl_child_exit_script = objarg;
+ } else if (strcmp(arg, "BeforeScript") == 0) {
+ conf->dtcl_before_script = objarg;
+ } else if (strcmp(arg, "AfterScript") == 0) {
+ conf->dtcl_after_script = objarg;
+ } else {
+ ap_log_error(APLOG_MARK, APLOG_ERR, global_rr->server, "Mod_Dtcl Error: Dtcl_Script must have a second argument, which is one of: GlobalInitScript, ChildInitScript, ChildExitScript, BeforeScript, AfterScript");
+ }
return NULL;
}
@@ -1447,19 +1454,20 @@
static void *create_dtcl_config(pool *p, server_rec *s)
{
dtcl_server_conf *dts = (dtcl_server_conf *) ap_pcalloc(p, sizeof(dtcl_server_conf));
- dts->dtcl_global_script = NULL;
- dts->dtcl_init_script = NULL;
- dts->dtcl_exit_script = NULL;
+ dts->dtcl_global_init_script = NULL;
+ dts->dtcl_child_init_script = NULL;
+ dts->dtcl_child_exit_script = NULL;
+ dts->dtcl_before_script = NULL;
+ dts->dtcl_after_script = NULL;
return dts;
}
static void *merge_dtcl_config(pool *p, void *basev, void *overridesv)
{
dtcl_server_conf *base = (dtcl_server_conf *) basev, *overrides = (dtcl_server_conf *) overridesv;
- return overrides->dtcl_global_script ? overrides : base;
+ return overrides->dtcl_global_init_script ? overrides : base;
}
-
static void dtcl_child_init(server_rec *s, pool *p)
{
dtcl_server_conf *dsc = (dtcl_server_conf *) ap_get_module_config(s->module_config, &dtcl_module);
@@ -1468,20 +1476,20 @@
tcl_init_stuff(s, p);
#endif
- if (dsc->dtcl_init_script != NULL)
- if (Tcl_EvalFile(interp, dsc->dtcl_init_script) != TCL_OK)
+ if (dsc->dtcl_child_init_script != NULL)
+ if (Tcl_EvalObjEx(interp, dsc->dtcl_child_init_script, 0) != TCL_OK)
ap_log_error(APLOG_MARK, APLOG_ERR, s,
- "Problem running child init script: %s", dsc->dtcl_init_script);
+ "Problem running child init script: %s", Tcl_GetStringFromObj(dsc->dtcl_child_init_script, NULL));
}
static void dtcl_child_exit(server_rec *s, pool *p)
{
dtcl_server_conf *dsc = (dtcl_server_conf *) ap_get_module_config(s->module_config, &dtcl_module);
- if (dsc->dtcl_exit_script != NULL)
- if (Tcl_EvalFile(interp, dsc->dtcl_exit_script) != TCL_OK)
+ if (dsc->dtcl_child_exit_script != NULL)
+ if (Tcl_EvalObjEx(interp, dsc->dtcl_child_exit_script, 0) != TCL_OK)
ap_log_error(APLOG_MARK, APLOG_ERR, s,
- "Problem running child exit script: %s", dsc->dtcl_exit_script);
+ "Problem running child exit script: %s", Tcl_GetStringFromObj(dsc->dtcl_child_exit_script, NULL));
}
static const handler_rec dtcl_handlers[] =
@@ -1493,9 +1501,7 @@
static const command_rec dtcl_cmds[] =
{
- {"Dtcl_GlobalScript", set_globalscript, NULL, RSRC_CONF, TAKE1, "the name of the global configuration script"},
- {"Dtcl_ChildInitScript", set_initscript, NULL, RSRC_CONF, TAKE1, "the name of the per child init configuration script"},
- {"Dtcl_ChildExitScript", set_exitscript, NULL, RSRC_CONF, TAKE1, "the name of the per child exit configuration script"},
+ {"Dtcl_Script", set_script, NULL, RSRC_CONF, TAKE2, "general script command"},
{"Dtcl_CacheSize", set_cachesize, NULL, RSRC_CONF, TAKE1, "number of ttml scripts cached"},
{NULL}
};
diff --git a/tests/dtcl-test.ttml b/tests/dtcl-test.ttml
new file mode 100644
index 0000000..b458e93
--- /dev/null
+++ b/tests/dtcl-test.ttml
@@ -0,0 +1,32 @@
+<+
+
+hgetvars
+
+# hello-1.1
+hputs "Hello, World\n"
+
+# i18n-1.1
+hputs "¡ À È Ì Ò Ù - El Burro Sabe Más Que Tú!\n"
+
+if { [ array exists VARS ] } {
+ # get/post variables 1.1
+ if { [ info exists VARS(foobar) ] } {
+ hputs "VARS(foobar) = $VARS(foobar)\n"
+ }
+ # get/post variables 1.{2,3}
+ if { [ info exists VARS(Más) ] } {
+ hputs "VARS(Más) = $VARS(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"
+ }
+}
+
++>
\ No newline at end of file
diff --git a/tests/dtcl.test b/tests/dtcl.test
new file mode 100755
index 0000000..9f5840d
--- /dev/null
+++ b/tests/dtcl.test
@@ -0,0 +1,73 @@
+#!/usr/bin/tclsh
+
+# mod_dtcl test suite, by David N. Welton <davidw@linuxcare.com>
+
+# $Id$
+
+package require tcltest
+package require http 2.1
+
+set urlbase "http://eugene.i.prosa.it/~davidw/tests/"
+set testfilename "dtcl-test.ttml"
+
+::tcltest::test hello-1.1 {hello world test} {
+ set page [ ::http::geturl "${urlbase}$testfilename" ]
+ regexp -line {^Hello, World$} [ ::http::data $page ]
+} 1
+
+::tcltest::test i18n-1.1 {I18N test} {
+ set page [ ::http::geturl "${urlbase}$testfilename" ]
+ regexp -line {^¡ À È Ì Ò Ù - El Burro Sabe Más Que Tú!$} [ ::http::data $page ]
+} 1
+
+::tcltest::test getvariables-1.1 {GET variables} {
+ set page [ ::http::geturl "${urlbase}$testfilename?foobar=goober" ]
+ regexp -line {^VARS\(foobar\) = goober$} [ ::http::data $page ]
+} 1
+
+::tcltest::test getvariables-1.2 {GET variables + I18N} {
+ set page [ ::http::geturl "${urlbase}$testfilename?Más=Tú" ]
+ regexp -line {^VARS\(Más\) = Tú$} [ ::http::data $page ]
+} 1
+
+::tcltest::test getvariables-1.3 {GET variables + I18N + encoding} {
+ set page [ ::http::geturl [ format "${urlbase}$testfilename?%s" [ ::http::formatQuery Más Tú ] ] ]
+ regexp -line {^VARS\(Más\) = Tú$} [ ::http::data $page ]
+} 1
+
+::tcltest::test postvariables-1.1 {POST variables} {
+ set page [ ::http::geturl "${urlbase}$testfilename" -query foobar=goober ]
+ regexp -line {^VARS\(foobar\) = goober$} [ ::http::data $page ]
+} 1
+
+::tcltest::test postvariables-1.2 {POST variables + I18N} {
+ set page [ ::http::geturl "${urlbase}$testfilename" -query Más=Tú ]
+ regexp -line {^VARS\(Más\) = Tú$} [ ::http::data $page ]
+} 1
+
+::tcltest::test postvariables-1.3 {POST variables + I18N + encoding} {
+ set page [ ::http::geturl "${urlbase}$testfilename" -query [ ::http::formatQuery Más Tú ] ]
+ regexp -line {^VARS\(Más\) = Tú$} [ ::http::data $page ]
+} 1
+
+::tcltest::test env-1.1 {Environment variable} {
+ set page [ ::http::geturl "${urlbase}$testfilename" ]
+ regexp -line "^ENVS\\(DOCUMENT_NAME\\) = $testfilename\$" [ ::http::data $page ]
+} 1
+
+::tcltest::test cookies-1.1 {Cookies} {
+ set page [ ::http::geturl "${urlbase}$testfilename" -headers {Cookie "foo=bar"} ]
+ regexp -line {^COOKIES\(foo\) = bar$} [ ::http::data $page ]
+} 1
+
+::tcltest::test cookies-1.2 {Cookies + I18N} {
+ set page [ ::http::geturl "${urlbase}$testfilename" -headers {Cookie "Más=Tú"} ]
+ regexp -line {^COOKIES\(Más\) = Tú$} [ ::http::data $page ]
+} 1
+
+::tcltest::test cookies-1.3 {Cookies + I18N + encoding} {
+ set page [ ::http::geturl "${urlbase}$testfilename" -headers [ list Cookie [ ::http::formatQuery Más Tú ] ] ]
+ regexp -line {^COOKIES\(Más\) = Tú$} [ ::http::data $page ]
+} 1
+
+puts "Done"
\ No newline at end of file
