Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -30,11 +30,11 @@
 MSRCFILES = dbmod.scm rmtmod.scm commonmod.scm apimod.scm		\
 archivemod.scm clientmod.scm envmod.scm ezstepsmod.scm itemsmod.scm	\
 keysmod.scm launchmod.scm odsmod.scm processmod.scm runconfigmod.scm	\
 runsmod.scm servermod.scm subrunmod.scm tasksmod.scm testsmod.scm	\
 pkts.scm mtargs.scm mtconfigf.scm ducttape-lib.scm ulex.scm		\
-megamod.scm
+stml2.scm cookie.scm megamod.scm
 
 GMSRCFILES = dcommonmod.scm vgmod.scm treemod.scm
 
 # Eggs to install (straightforward ones)
 
@@ -65,11 +65,11 @@
 # mofiles/ducttape-lib.o : ducttape-lib.scm ducttape/*scm
 #	csc -I ducttape -J -c ducttape-lib.scm -o mofiles/ducttape-lib.o
 
 mofiles/%.o %.import.scm : %.scm
 	mkdir -p mofiles
-	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+	csc $(CSCOPTS) -I $* -J -c $< -o mofiles/$*.o
 	touch $*.import.scm # ensure it is touched after the .o is made
 
 # a.import.o : a.import.scm a.o
 # csc -unit a.import -c a.import.scm -o $*.o
 
@@ -90,71 +90,30 @@
 ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
 # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")
 
 PNGFILES = $(shell cd docs/manual;ls *png)
 
-#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
-
-# IMPORTO = apimod.import.o dbmod.import.o itemsmod.import.o	\
-# odsmod.import.o runsmod.import.o testsmod.import.o		\
-# archivemod.import.o keysmod.import.o processmod.import.o	\
-# servermod.import.o clientmod.import.o envmod.import.o		\
-# launchmod.import.o rmtmod.import.o subrunmod.import.o		\
-# commonmod.import.o ezstepsmod.import.o megamod.import.o		\
-# runconfigmod.import.o tasksmod.import.o pkts.import.o
-
 all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
 
 # why were the files  mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o listed on this target when MOFILES are there?
 # Removed non module .o files (i.e. $(OFILES)
 mtest: readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) mofiles/ducttape-lib.o
-	csc $(CSCOPTS) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
+	csc megatest.o $(CSCOPTS) $(MOFILES) $(MOIMPFILES) -o mtest
 
 showmtesthash:
 	@echo $(MTESTHASH)
 
 # removing $(GOFILES)
 dboard : dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) 
-	csc $(CSCOPTS) dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard
+	csc dashboard.o $(CSCOPTS) $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard
 
 ndboard : newdashboard.scm $(GOFILES)
 	csc $(CSCOPTS) $(GOFILES) newdashboard.scm -o ndboard
 
 mtut:  $(MOFILES) megatest-fossil-hash.scm mtut.scm
 	csc $(CSCOPTS) $(MOFILES) mtut.scm -o mtut
 
-
-#TCMTOBJS = \
-#	api.o \
-#	archive.o \
-#	cgisetup/models/pgdb.o \
-#	client.o \
-#	common.o \
-#	configf.o \
-#	db.o \
-#	env.o \
-#	http-transport.o \
-#	items.o \
-#	keys.o \
-#	launch.o \
-#	lock-queue.o \
-#	margs.o \
-#	mt.o \
-#	megatest-version.o \
-#	ods.o \
-#	portlogger.o \
-#	process.o \
-#	rmt.o \
-#        $(MOFILES) \
-#        rpc-transport.o \
-#	runconfig.o \
-#	runs.o \
-#	server.o \
-#	tasks.o \
-#	tdb.o \
-#	tests.o \
-#	subrun.o \
 TCMTOBJS=
 
 tcmt : $(TCMTOBJS) $(MOFILES) tcmt.scm
 	csc $(CSCOPTS) $(MOFILES) $(TCMTOBJS) tcmt.scm -o tcmt
 
@@ -203,31 +162,31 @@
 
 common_records.scm : altdb.scm
 
 vg.o dashboard.o : vg_records.scm mofiles/dcommonmod.o
 
-dcommon.o : run_records.scm migrate-fix.scm
+dcommon.o : run_records.scm migrate-fix.scm mofiles/stml2.o
+
+mofiles/stml2.o : mofiles/cookie.o
 
 # special include based modules
 mofiles/pkts.o : pkts/pkts.scm
 mofiles/mtargs.o : mtargs/mtargs.scm
 mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
 mofiles/ulex.o : ulex/ulex.scm
-# mofile/ducttape-lib.o : ducttape/ducttape-lib.scm
-
-# Temporary while transitioning to new routine
-# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm
 
 # for the modularized stuff
 
-mofiles/commonmod.o : megatest-fossil-hash.scm
+mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/stml2.o mofiles/mtargs.o
 mofiles/dbmod.o     : mofiles/commonmod.o mofiles/keysmod.o \
                       mofiles/tasksmod.o mofiles/odsmod.o
 mofiles/commonmod.o : mofiles/processmod.o
 mofiles/rmtmod.o    : mofiles/dbmod.o mofiles/commonmod.o \
                       mofiles/apimod.o mofiles/ulex.o
 mofiles/apimod.o    : mofiles/dbmod.o
+mofiles/runsmod.o   : mofiles/testsmod.o
+
 # Removed from megamod.o dep:   mofiles/ftail.o
 mofiles/megamod.o   : \
    mofiles/rmtmod.o \
    mofiles/commonmod.o \
    mofiles/apimod.o \
@@ -249,10 +208,11 @@
    mofiles/testsmod.o \
    mofiles/pkts.o \
    mofiles/mtargs.o \
    mofiles/mtconfigf.o \
    mofiles/ducttape-lib.o \
+   mofiles/stml2.o \
    *-inc.scm
 
 mofiles/dcommonmod.o : \
    mofiles/vgmod.o \
    mofiles/treemod.o \

Index: api-inc.scm
==================================================================
--- api-inc.scm
+++ api-inc.scm
@@ -132,17 +132,17 @@
 ;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
 ;;
 ;;    - returns #( flag result )
 ;;
 (define (api:execute-requests dbstruct dat)
-  (handle-exceptions
-   exn
-   (let ((call-chain (get-call-chain)))
-     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
-     (print-call-chain (current-error-port))
-     (debug:print 0 *default-log-port* " message: "  ((condition-property-accessor 'exn 'message) exn))       
-     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
+  ;; (handle-exceptions
+  ;;  exn
+  ;;  (let ((call-chain (get-call-chain)))
+  ;;    (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
+  ;;    (print-call-chain (current-error-port))
+  ;;    (debug:print 0 *default-log-port* " message: "  ((condition-property-accessor 'exn 'message) exn))       
+  ;;    (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
    (cond
     ((not (vector? dat))                    ;; it is an error to not receive a vector
      (vector #f (vector #f "remote must be called with a vector")))
     ((> *api-process-request-count* 20) ;; 20)
      (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
@@ -353,11 +353,11 @@
 	     (vector #f res))
            (begin
              #;(common:telemetry-log (conc "api-out:"(->string cmd))
                                    payload: `((params . ,params)
                                               (ok-res . #f)))
-             (vector #t res))))))))
+             (vector #t res))))))) ;; )
 
 ;; http-server  send-response
 ;;                 api:process-request
 ;;                    db:*
 ;;

Index: common-inc.scm
==================================================================
--- common-inc.scm
+++ common-inc.scm
@@ -75,113 +75,10 @@
     fullpath))
 (define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
 (define *common:this-exe-dir*      (pathname-directory *common:this-exe-fullpath*))
 (define *common:this-exe-name*     (pathname-strip-directory *common:this-exe-fullpath*))
 
-(define *common:logpro-exit-code->status-sym-alist*
-  '( ( 0 . pass )
-     ( 1 . fail )
-     ( 2 . warn )
-     ( 3 . check )
-     ( 4 . waived )
-     ( 5 . abort )
-     ( 6 . skip )))
-
-(define (common:logpro-exit-code->status-sym exit-code)
-  (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
-
-(define (common:worse-status-sym ss1 ss2)
-  (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
-    (cond
-     ((null? status-syms-remaining)
-      'fail)
-     ((eq? (car status-syms-remaining) ss1)
-      ss1)
-     ((eq? (car status-syms-remaining) ss2)
-      ss2)
-     (else
-      (loop (cdr status-syms-remaining))))))
-
-(define (common:steps-can-proceed-given-status-sym status-sym)
-  (if (member status-sym '(warn waived pass))
-      #t
-      #f))
-
-(define (status-sym->string status-sym)
-  (case status-sym
-      ((pass) "PASS")
-    ((fail) "FAIL")
-    ((warn) "WARN")
-    ((check) "CHECK")
-    ((waived) "WAIVED")
-    ((abort) "ABORT")
-    ((skip) "SKIP")
-    (else "FAIL")))
-
-(define (common:logpro-exit-code->test-status exit-code)
-  (status-sym->string (common:logpro-exit-code->status-sym exit-code)))
-
-(define (common:clear-caches)
-  (set! *target*             (make-hash-table))
-  (set! *keys*               (make-hash-table))
-  (set! *keyvals*            (make-hash-table))
-  (set! *toptest-paths*      (make-hash-table))
-  (set! *test-paths*         (make-hash-table))
-  (set! *test-ids*           (make-hash-table))
-  (set! *test-info*          (make-hash-table))
-  (set! *run-info-cache*     (make-hash-table))
-  (set! *env-vars-by-run-id* (make-hash-table))
-  (set! *test-id-cache*      (make-hash-table)))
-
-;; Generic string database
-(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
-;; Generic path database
-(define *fdb* #f)
-
-(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
-
-;;======================================================================
-;; V E R S I O N
-;;======================================================================
-
-(define (common:get-full-version)
-  (conc megatest-version "-" megatest-fossil-hash))
-
-(define (common:version-signature)
-  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-
-;; from metadat lookup MEGATEST_VERSION
-;;
-(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
-  (rmt:get-var "MEGATEST_VERSION"))
-
-(define (common:get-last-run-version-number)
-  (string->number 
-   (substring (common:get-last-run-version) 0 6)))
-
-(define (common:set-last-run-version)
-  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
-
-;; postive number if megatest version > db version
-;; negative number if megatest version < db version
-(define (common:version-db-delta)
-         (- megatest-version (common:get-last-run-version-number)))
-
-(define (common:version-changed?)
-  (not (equal? (common:get-last-run-version)
-               (common:version-signature))))
-
-(define (common:api-changed?)
-  (not (equal? (substring (->string megatest-version) 0 4)
-               (substring (conc (common:get-last-run-version)) 0 4))))
-
-
-(define (common:get-sync-lock-filepath)
-  (let* ((tmp-area     (common:get-db-tmp-area))
-         (lockfile     (conc tmp-area "/megatest.db.sync-lock")))
-    lockfile))
-    
 ;; Move me elsewhere ...
 ;; RADT => Why do we meed the version check here, this is called only if version misma
 ;;
 (define (common:cleanup-db dbstruct #!key (full #f))
   (apply db:multi-db-sync 
@@ -454,55 +351,10 @@
 
 ;;======================================================================
 ;; U S E F U L   S T U F F
 ;;======================================================================
 
-;; convert things to an alist or assoc list, #f gets converted to ""
-;;
-(define (common:to-alist dat)
-  (cond
-   ((list? dat)   (map common:to-alist dat))
-   ((vector? dat)
-    (map common:to-alist (vector->list dat)))
-   ((pair? dat)
-    (cons (common:to-alist (car dat))
-	  (common:to-alist (cdr dat))))
-   ((hash-table? dat)
-    (map common:to-alist (hash-table->alist dat)))
-   (else
-    (if dat
-	dat
-	""))))
-
-(define (common:alist-ref/default key alist default)
-  (or (alist-ref key alist) default))
-
-(define (common:low-noise-print waitval . keys)
-  (let* ((key      (string-intersperse (map conc keys) "-" ))
-	 (lasttime (hash-table-ref/default *common:denoise* key 0))
-	 (currtime (current-seconds)))
-    (if (> (- currtime lasttime) waitval)
-	(begin
-	  (hash-table-set! *common:denoise* key currtime)
-	  #t)
-	#f)))
-
-(define (common:get-megatest-exe)
-  (or (getenv "MT_MEGATEST") "megatest"))
-
-(define (common:read-encoded-string instr)
-  (handle-exceptions
-   exn
-   (handle-exceptions
-    exn
-    (begin
-      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
-      (print-call-chain (current-error-port))
-      #f)
-    (read (open-input-string (base64:base64-decode instr))))
-   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
-
 ;; dot-locking egg seems not to work, using this for now
 ;; if lock is older than expire-time then remove it and try again
 ;; to get the lock
 ;;
 (define (common:simple-file-lock fname #!key (expire-time 300))
@@ -547,45 +399,35 @@
 ;;======================================================================
 
 ;; (define *verbosity*         1)
 ;; (define *logging*           #f)
 
-(define (get-with-default val default)
-  (let ((val (args:get-arg val)))
-    (if val val default)))
-
-(define (assoc/default key lst . default)
-  (let ((res (assoc key lst)))
-    (if res (cadr res)(if (null? default) #f (car default)))))
-
-(define (common:get-testsuite-name)
-  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
-      (configf:lookup *configdat* "setup" "testsuite" )
-      (getenv "MT_TESTSUITE_NAME")
-      (if (string? *toppath* )
-          (pathname-file *toppath*)
-          #f))) ;; (pathname-file (current-directory)))))
-
-(define common:get-area-name common:get-testsuite-name)
-
-(define (common:get-db-tmp-area . junk)
-  (if *db-cache-path*
-      *db-cache-path*
-      (if *toppath* ;; common:get-create-writeable-dir
-	  (handle-exceptions
-	      exn
-	      (begin
-		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
-		(exit 1))
-	    (let ((dbpath (common:get-create-writeable-dir
-			   (list (conc "/tmp/" (current-user-name)
-				       "/megatest_localdb/"
-				       (common:get-testsuite-name) "/"
-				       (string-translate *toppath* "/" ".")))))) ;;  #t))))
-	      (set! *db-cache-path* dbpath)
-	      dbpath))
-	  #f)))
+(define (common:set-last-run-version)
+  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+;; postive number if megatest version > db version
+;; negative number if megatest version < db version
+(define (common:version-db-delta)
+         (- megatest-version (common:get-last-run-version-number)))
+
+(define (common:version-changed?)
+  (not (equal? (common:get-last-run-version)
+               (common:version-signature))))
+
+;; from metadat lookup MEGATEST_VERSION
+;;
+(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
+  (rmt:get-var "MEGATEST_VERSION"))
+
+(define (common:get-last-run-version-number)
+  (string->number 
+   (substring (common:get-last-run-version) 0 6)))
+
+(define (common:api-changed?)
+  (not (equal? (substring (->string megatest-version) 0 4)
+               (substring (conc (common:get-last-run-version)) 0 4))))
+
 
 ;;======================================================================
 ;; E X I T   H A N D L I N G
 ;;======================================================================
 
@@ -763,105 +605,10 @@
 	(filter (lambda (x)
 		  (patt-list-match x target-patt))
 		targs)
 	targs)))
 
-;; Lookup a value in runconfigs based on -reqtarg or -target
-;; 
-(define (runconfigs-get config var)
-  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
-    (if targ
-	(or (configf:lookup config targ var)
-	    (configf:lookup config "default" var))
-	(configf:lookup config "default" var))))
-
-(define (common:args-get-state)
-  (or (args:get-arg "-state")(args:get-arg ":state")))
-
-(define (common:args-get-status)
-  (or (args:get-arg "-status")(args:get-arg ":status")))
-
-(define (common:args-get-testpatt rconf)
-  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
-         ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
-         (testpatt-key  (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
-         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
-         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
-    (cond
-     ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
-      (if rconf
-	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf testpatt-key)))
-	    (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key " "  patts-from-mode-patt)
-	    patts-from-mode-patt)
-	  (begin
-	    (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key) ;;  " " patts-from-mode-patt)
-	    #f)))     ;; We do NOT fall back to "%"
-     ;; (tags-testpatt
-     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
-     ;;  tags-testpatt)
-     ((and (equal? args-testpatt "%") rtestpatt)
-      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
-      rtestpatt)
-     (else 
-      (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
-      args-testpatt))))
-
-
-
-(define (common:get-linktree)
-  (or (getenv "MT_LINKTREE")
-      (if *configdat*
-	  (configf:lookup *configdat* "setup" "linktree")
-	  (if *toppath*
-	      (conc *toppath* "/lt")
-	      #f))))
-
-(define (common:args-get-runname)
-  (let ((res (or (args:get-arg "-runname")
-		 (args:get-arg ":runname")
-		 (getenv "MT_RUNNAME"))))
-    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
-    res))
-
-(define (common:get-fields cfgdat)
-  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
-    (map car fields)))
-
-(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
-  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
-	 (numkeys (length keys))
-	 (target  (or (args:get-arg "-reqtarg")
-		      (args:get-arg "-target")
-		      (getenv "MT_TARGET")))
-	 (tlist   (if target (string-split target "/" #t) '()))
-	 (valid   (if target
-		      (or (null? keys) ;; probably don't know our keys yet
-			  (and (not (null? tlist))
-			       (eq? numkeys (length tlist))
-			       (null? (filter string-null? tlist))))
-		      #f)))
-    (if valid
-	(if split
-	    tlist
-	    target)
-	(if target
-	    (begin
-	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
-	      (if exit-if-bad (exit 1))
-	      #f)
-	    #f))))
-
-;; looking only (at least for now) at the MT_ variables craft the full testname
-;;
-(define (common:get-full-test-name)
-  (if (getenv "MT_TEST_NAME")
-      (if (and (getenv "MT_ITEMPATH")
-               (not (equal? (getenv "MT_ITEMPATH") "")))
-          (getenv "MT_TEST_NAME")
-          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
-      #f))
-
 ;; logic for getting homehost. Returns (host . at-home)
 ;; IF *toppath* is not set, wait up to five seconds trying every two seconds
 ;; (this is to accomodate the watchdog)
 ;;
 (define (common:get-homehost #!key (trynum 5))

Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -17,12 +17,13 @@
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;======================================================================
 
 (declare (unit commonmod))
-;; (declare (uses processmod))
-
+(declare (uses mtargs))
+(declare (uses stml2))
+	 
 (module commonmod
 	*
 	
 (import scheme chicken data-structures extras)
 	
@@ -31,23 +32,134 @@
 	srfi-69 ports
 	regex-case regex hostinfo srfi-4
 	pkts (prefix dbi dbi:)
 	stack
 	md5
-	message-digest)
-
-;; (import processmod)
-(import stml2)
+	message-digest
+	(prefix mtconfigf configf:)
+	stml2
+	;; (prefix margs args:)
+	z3 (prefix base64 base64:)
+	(prefix mtargs args:))
 
 (include "common_records.scm")
 (include "megatest-fossil-hash.scm")
 (include "megatest-version.scm")
 
  ;; no need to export this
 (define *verbosity-cache* (make-hash-table))
 (define *verbosity* 0)
 
+
+
+;; GLOBALS
+
+;; CONTEXTS
+#;(defstruct cxt
+  (taskdb #f)
+  (cmutex (make-mutex)))
+;; (define *contexts* (make-hash-table))
+;; (define *context-mutex* (make-mutex))
+
+;; ;; safe method for accessing a context given a toppath
+;; ;;
+;; (define (common:with-cxt toppath proc)
+;;   (mutex-lock! *context-mutex*)
+;;   (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
+;;     (if (not cxt)
+;;         (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
+;;     (let ((cxt-mutex (cxt-mutex cxt)))
+;;       (mutex-unlock! *context-mutex*)
+;;       (mutex-lock! cxt-mutex)
+;;       (let ((res (proc cxt)))
+;;         (mutex-unlock! cxt-mutex)
+;;         res))))
+        
+;; A hash table that can be accessed by #{scheme ...} calls in
+;; config files. Allows communicating between confgs
+;;
+(define *user-hash-data* (make-hash-table))
+
+(define *db-keys* #f)
+
+(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
+(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
+(define *runconfigdat* #f)   ;; run configs data
+(define *configdat*    #f)   ;; megatest.config data
+(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
+(define *toppath*      #f)
+(define *already-seen-runconfig-info* #f)
+
+(define *test-meta-updated* (make-hash-table))
+(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
+(define *passnum*           0) ;; when running track calls to run-tests or similar
+;; (define *alt-log-file* #f)  ;; used by -log
+(define *common:denoise*    (make-hash-table)) ;; for low noise printing
+(define *default-log-port*  (current-error-port))
+(define *default-area-tag* "local")
+
+;; DATABASE
+(define *dbstruct-db*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+;; db access
+(define *db-last-access*      (current-seconds)) ;; last db access, used in server
+(define *db-write-access*     #t)
+;; db sync
+(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
+(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
+(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
+;; task db
+(define *task-db*             #f) ;; (vector db path-to-db)
+(define *db-access-allowed*   #t) ;; flag to allow access
+(define *db-access-mutex*     (make-mutex))
+(define *db-transaction-mutex* (make-mutex))
+(define *db-cache-path*       #f)
+(define *db-with-db-mutex*    (make-mutex))
+(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
+;; no sync db
+(define *no-sync-db*          #f)
+
+;; SERVER
+(define *my-client-signature* #f)
+(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
+(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
+;; (define *max-cache-size*    0)
+(define *logged-in-clients* (make-hash-table))
+(define *server-id*         #f)
+(define *server-info*       #f)  ;; good candidate for easily convert to non-global
+(define *time-to-exit*      #f)
+(define *server-run*        #t)
+(define *run-id*            #f)
+(define *server-kind-run*   (make-hash-table))
+(define *home-host*         #f)
+;; (define *total-non-write-delay* 0)
+(define *heartbeat-mutex*   (make-mutex))
+(define *api-process-request-count* 0)
+(define *max-api-process-requests* 0)
+(define *server-overloaded*  #f)
+
+;; client
+(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 
+
+;; RPC transport
+(define *rpc:listener*      #f)
+
+;; KEY info
+(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
+(define *keys*              (make-hash-table)) ;; cache the keys here
+(define *keyvals*           (make-hash-table))
+(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
+(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
+(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
+(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
+
+(define *run-info-cache*     (make-hash-table)) ;; run info is stable, no need to reget
+(define *launch-setup-mutex* (make-mutex))     ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
+(define *homehost-mutex*     (make-mutex))
+
+;; Miscellaneous
+(define *triggers-mutex*     (make-mutex))     ;; block overlapping processing of triggers
+
 ;; this was cached based on results from profiling but it turned out the profiling
 ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
 ;; in for now but can probably take it out later.
 ;;
 (define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
@@ -138,10 +250,105 @@
 	  ;;    (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
 		;; (exec-fn 'db:log-event res))
 	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
 	  (apply print "INFO: (" n ") " params) ;; res)
 	  )))) ;; )
+
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;; 
+(define (runconfigs-get config var)
+  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+    (if targ
+	(or (configf:lookup config targ var)
+	    (configf:lookup config "default" var))
+	(configf:lookup config "default" var))))
+
+(define (common:args-get-state)
+  (or (args:get-arg "-state")(args:get-arg ":state")))
+
+(define (common:args-get-status)
+  (or (args:get-arg "-status")(args:get-arg ":status")))
+
+(define (common:args-get-testpatt rconf)
+  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
+         ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
+         (testpatt-key  (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
+         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
+         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
+    (cond
+     ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
+      (if rconf
+	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf testpatt-key)))
+	    (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key " "  patts-from-mode-patt)
+	    patts-from-mode-patt)
+	  (begin
+	    (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key) ;;  " " patts-from-mode-patt)
+	    #f)))     ;; We do NOT fall back to "%"
+     ;; (tags-testpatt
+     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
+     ;;  tags-testpatt)
+     ((and (equal? args-testpatt "%") rtestpatt)
+      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
+      rtestpatt)
+     (else 
+      (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
+      args-testpatt))))
+
+
+
+(define (common:get-linktree)
+  (or (getenv "MT_LINKTREE")
+      (if *configdat*
+	  (configf:lookup *configdat* "setup" "linktree")
+	  (if *toppath*
+	      (conc *toppath* "/lt")
+	      #f))))
+
+(define (common:args-get-runname)
+  (let ((res (or (args:get-arg "-runname")
+		 (args:get-arg ":runname")
+		 (getenv "MT_RUNNAME"))))
+    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
+    res))
+
+(define (common:get-fields cfgdat)
+  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+    (map car fields)))
+
+(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
+  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
+	 (numkeys (length keys))
+	 (target  (or (args:get-arg "-reqtarg")
+		      (args:get-arg "-target")
+		      (getenv "MT_TARGET")))
+	 (tlist   (if target (string-split target "/" #t) '()))
+	 (valid   (if target
+		      (or (null? keys) ;; probably don't know our keys yet
+			  (and (not (null? tlist))
+			       (eq? numkeys (length tlist))
+			       (null? (filter string-null? tlist))))
+		      #f)))
+    (if valid
+	(if split
+	    tlist
+	    target)
+	(if target
+	    (begin
+	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
+	      (if exit-if-bad (exit 1))
+	      #f)
+	    #f))))
+
+;; looking only (at least for now) at the MT_ variables craft the full testname
+;;
+(define (common:get-full-test-name)
+  (if (getenv "MT_TEST_NAME")
+      (if (and (getenv "MT_ITEMPATH")
+               (not (equal? (getenv "MT_ITEMPATH") "")))
+          (getenv "MT_TEST_NAME")
+          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
+      #f))
 
 
 ;;======================================================================
 ;; S T A T E S   A N D   S T A T U S E S
 ;;======================================================================
@@ -595,569 +802,177 @@
     (length (glob (conc "/proc/" pid "/fd/*")))
     (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
   )
 )
 
-  
-
-;; GLOBALS
-
-;; CONTEXTS
-#;(defstruct cxt
-  (taskdb #f)
-  (cmutex (make-mutex)))
-;; (define *contexts* (make-hash-table))
-;; (define *context-mutex* (make-mutex))
-
-;; ;; safe method for accessing a context given a toppath
-;; ;;
-;; (define (common:with-cxt toppath proc)
-;;   (mutex-lock! *context-mutex*)
-;;   (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
-;;     (if (not cxt)
-;;         (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
-;;     (let ((cxt-mutex (cxt-mutex cxt)))
-;;       (mutex-unlock! *context-mutex*)
-;;       (mutex-lock! cxt-mutex)
-;;       (let ((res (proc cxt)))
-;;         (mutex-unlock! cxt-mutex)
-;;         res))))
-        
-;; A hash table that can be accessed by #{scheme ...} calls in
-;; config files. Allows communicating between confgs
-;;
-(define *user-hash-data* (make-hash-table))
-
-(define *db-keys* #f)
-
-(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
-(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
-(define *runconfigdat* #f)   ;; run configs data
-(define *configdat*    #f)   ;; megatest.config data
-(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
-(define *toppath*      #f)
-(define *already-seen-runconfig-info* #f)
-
-(define *test-meta-updated* (make-hash-table))
-(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
-(define *passnum*           0) ;; when running track calls to run-tests or similar
-;; (define *alt-log-file* #f)  ;; used by -log
-(define *common:denoise*    (make-hash-table)) ;; for low noise printing
-(define *default-log-port*  (current-error-port))
-(define *default-area-tag* "local")
-
-;; DATABASE
-(define *dbstruct-db*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
-;; db access
-(define *db-last-access*      (current-seconds)) ;; last db access, used in server
-(define *db-write-access*     #t)
-;; db sync
-(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
-(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
-(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
-;; task db
-(define *task-db*             #f) ;; (vector db path-to-db)
-(define *db-access-allowed*   #t) ;; flag to allow access
-(define *db-access-mutex*     (make-mutex))
-(define *db-transaction-mutex* (make-mutex))
-(define *db-cache-path*       #f)
-(define *db-with-db-mutex*    (make-mutex))
-(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
-;; no sync db
-(define *no-sync-db*          #f)
-
-;; SERVER
-(define *my-client-signature* #f)
-(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
-(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
-;; (define *max-cache-size*    0)
-(define *logged-in-clients* (make-hash-table))
-(define *server-id*         #f)
-(define *server-info*       #f)  ;; good candidate for easily convert to non-global
-(define *time-to-exit*      #f)
-(define *server-run*        #t)
-(define *run-id*            #f)
-(define *server-kind-run*   (make-hash-table))
-(define *home-host*         #f)
-;; (define *total-non-write-delay* 0)
-(define *heartbeat-mutex*   (make-mutex))
-(define *api-process-request-count* 0)
-(define *max-api-process-requests* 0)
-(define *server-overloaded*  #f)
-
-;; client
-(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 
-
-;; RPC transport
-(define *rpc:listener*      #f)
-
-;; KEY info
-(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
-(define *keys*              (make-hash-table)) ;; cache the keys here
-(define *keyvals*           (make-hash-table))
-(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
-(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
-(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
-(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
-
-(define *run-info-cache*     (make-hash-table)) ;; run info is stable, no need to reget
-(define *launch-setup-mutex* (make-mutex))     ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
-(define *homehost-mutex*     (make-mutex))
-
-;; Miscellaneous
-(define *triggers-mutex*     (make-mutex))     ;; block overlapping processing of triggers
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-;; (define (common:low-noise-print alldat waitval . keys)
-;;   (let* ((key      (string-intersperse (map conc keys) "-" ))
-;; 	 (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
-;; 	 (currtime (current-seconds)))
-;;     (if (> (- currtime lasttime) waitval)
-;; 	(begin
-;; 	  (hash-table-set! (alldat-denoise alldat) key currtime)
-;; 	  #t)
-;; 	#f)))
-;; 
-;; (define (common:version-signature alldat)
-;;   (conc (alldat-megatest-version alldat)
-;; 	"-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
-;; 
-;; (define (common:get-fields cfgdat)
-;;   (let ((fields (hash-table-ref/default cfgdat "fields" '())))
-;;     (map car fields)))
-;; 
-;; ;;======================================================================
-;; ;; T I M E   A N D   D A T E
-;; ;;======================================================================
-;; 
-;; ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
-;; (define (common:hms-string->seconds tstr)
-;;   (let ((parts     (string-split-fields "\\w+" tstr))
-;; 	(time-secs 0)
-;; 	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
-;; 	(trx       (regexp "(\\d+)([smhdMyw])")))
-;;     (for-each (lambda (part)
-;; 		(let ((match  (string-match trx part)))
-;; 		  (if match
-;; 		      (let ((val (string->number (cadr match)))
-;; 			    (unt (caddr match)))
-;; 			(if val 
-;; 			    (set! time-secs (+ time-secs (* val
-;; 							    (case (string->symbol unt)
-;; 							      ((s) 1)
-;; 							      ((m) 60) ;; minutes
-;; 							      ((h) 3600)
-;; 							      ((d) 86400)
-;; 							      ((w) 604800)
-;; 							      ((M) 2628000) ;; aproximately one month
-;; 							      ((y) 31536000)
-;; 							      (else #f))))))))))
-;; 	      parts)
-;;     time-secs))
-;; 		       
-;; (define (seconds->hr-min-sec secs)
-;;   (let* ((hrs (quotient secs 3600))
-;; 	 (min (quotient (- secs (* hrs 3600)) 60))
-;; 	 (sec (- secs (* hrs 3600)(* min 60))))
-;;     (conc (if (> hrs 0)(conc hrs "hr ") "")
-;; 	  (if (> min 0)(conc min "m ")  "")
-;; 	  sec "s")))
-;; 
-;; (define (seconds->time-string sec)
-;;   (time->string 
-;;    (seconds->local-time sec) "%H:%M:%S"))
-;; 
-;; (define (seconds->work-week/day-time sec)
-;;   (time->string
-;;    (seconds->local-time sec) "ww%V.%u %H:%M"))
-;; 
-;; (define (seconds->work-week/day sec)
-;;   (time->string
-;;    (seconds->local-time sec) "ww%V.%u"))
-;; 
-;; (define (seconds->year-work-week/day sec)
-;;   (time->string
-;;    (seconds->local-time sec) "%yww%V.%w"))
-;; 
-;; (define (seconds->year-work-week/day-time sec)
-;;   (time->string
-;;    (seconds->local-time sec) "%Yww%V.%w %H:%M"))
-;; 
-;; (define (seconds->year-week/day-time sec)
-;;   (time->string
-;;    (seconds->local-time sec) "%Yw%V.%w %H:%M"))
-;; 
-;; (define (seconds->quarter sec)
-;;   (case (string->number
-;; 	 (time->string 
-;; 	  (seconds->local-time sec)
-;; 	  "%m"))
-;;     ((1 2 3) 1)
-;;     ((4 5 6) 2)
-;;     ((7 8 9) 3)
-;;     ((10 11 12) 4)
-;;     (else #f)))
-;; 
-;; ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
-;; ;;
-;; (define (common:date-time->seconds datetime)
-;;   (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
-;; 
-;; ;; given span of seconds tstart to tend
-;; ;; find start time to mark and mark delta
-;; ;;
-;; (define (common:find-start-mark-and-mark-delta tstart tend)
-;;   (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
-;; 	 (result   #f)
-;; 	 (min      60)
-;; 	 (hr       (* 60 60))
-;; 	 (day      (* 24 hr))
-;; 	 (yr       (* 365 day)) ;; year
-;; 	 (mo       (/ yr 12))
-;; 	 (wk       (* day 7)))
-;;     (for-each
-;;      (lambda (max-blks)
-;;        (for-each
-;; 	(lambda (span) ;; 5 2 1
-;; 	  (if (not result)
-;; 	      (for-each 
-;; 	       (lambda (timeunit timesym) ;; year month day hr min sec
-;; 		 (if (not result)
-;; 		     (let* ((time-blk (* span timeunit))
-;; 			    (num-blks (quotient deltat time-blk)))
-;; 		       (if (and (> num-blks 4)(< num-blks max-blks))
-;; 			   (let ((first (* (quotient tstart time-blk) time-blk)))
-;; 			     (set! result (list span timeunit time-blk first timesym))
-;; 			     )))))
-;; 	       (list yr mo wk day hr min 1)
-;; 	       '(     y  mo w  d   h  m   s))))
-;; 	(list 8 6 5 2 1)))
-;;      '(5 10 15 20 30 40 50 500))
-;;     (if values
-;; 	(apply values result)
-;; 	(values 0 day 1 0 'd))))
-;; 
-;; ;; given x y lim return the cron expansion
-;; ;;
-;; (define (common:expand-cron-slash x y lim)
-;;   (let loop ((curr x)
-;; 	     (res  `()))
-;;     (if (< curr lim)
-;; 	(loop (+ curr y) (cons curr res))
-;; 	(reverse res))))
-;; 
-;; ;; expand a complex cron string to a list of cron strings
-;; ;;
-;; ;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
-;; ;;  a,b,c => a, b ,c
-;; ;;
-;; ;;   NOTE: with flatten a lot of the crud below can be factored down.
-;; ;;
-;; (define (common:cron-expand cron-str)
-;;   (if (list? cron-str)
-;;       (flatten
-;;        (fold (lambda (x res)
-;; 	       (if (list? x)
-;; 		   (let ((newres (map common:cron-expand x)))
-;; 		     (append x newres))
-;; 		   (cons x res)))
-;; 	     '()
-;; 	     cron-str)) ;; (map common:cron-expand cron-str))
-;;       (let ((cron-items (string-split cron-str))
-;; 	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
-;; 	    (comma-rx   (regexp ".*,.*"))
-;; 	    (max-vals   '((min        . 60)
-;; 			  (hour       . 24)
-;; 			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
-;; 			  (month      . 12)
-;; 			  (dayofweek  . 7))))
-;; 	(if (< (length cron-items) 5) ;; bad spec
-;; 	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
-;; 	    (let loop ((hed  (car cron-items))
-;; 		       (tal  (cdr cron-items))
-;; 		       (type 'min)
-;; 		       (type-tal '(hour dayofmonth month dayofweek))
-;; 		       (res  '()))
-;; 	      (regex-case
-;; 		  hed
-;; 		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
-;; 						 (incrn          (string->number incr))
-;; 						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
-;; 						 (new-list-crons (fold (lambda (x myres)
-;; 									 (cons (conc (if (null? res)
-;; 											 ""
-;; 											 (conc (string-intersperse res " ") " "))
-;; 										     x " " (string-intersperse tal " "))
-;; 									       myres))
-;; 								       '() expanded-vals)))
-;; 					    ;; (print "new-list-crons: " new-list-crons)
-;; 					    ;; (fold (lambda (x res)
-;; 					    ;; 	    (if (list? x)
-;; 					    ;; 		(let ((newres (map common:cron-expand x)))
-;; 					    ;; 		  (append x newres))
-;; 					    ;; 		(cons x res)))
-;; 					    ;; 	  '()
-;; 					    (flatten (map common:cron-expand new-list-crons))))
-;; 		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
-;; 		(else (if (null? tal)
-;; 			  cron-str
-;; 			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
-;; 		      
-;; 	    
-;; ;; given a cron string and the last time event was processed return #t to run or #f to not run
-;; ;;
-;; ;;  min    hour   dayofmonth month  dayofweek
-;; ;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
-;; ;;
-;; ;;  #t => yes, run the job
-;; ;;  #f => no, do not run the job
-;; ;;
-;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
-;;   (let* ((cron-items     (map string->number (string-split cron-str)))
-;; 	 (now-seconds    (or now-seconds-in (current-seconds)))
-;; 	 (now-time       (seconds->local-time now-seconds))
-;; 	 (last-done-time (seconds->local-time last-done))
-;; 	 (all-times      (make-hash-table)))
-;;     ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
-;;     (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
-;; 	#f
-;; 	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
-;; 		     cron-items)
-;; 		    ;; 0     1    2        3         4    5      6
-;; 		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
-;; 		     (vector->list now-time))
-;; 		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
-;; 		     (vector->list last-done-time)))
-;; 	  ;; create all possible time slots
-;; 	  ;; remove invalid slots due to (for example) day of week
-;; 	  ;; get the start and end entries for the ref-seconds (current) time
-;; 	  ;; if last-done > ref-seconds => this is an ERROR!
-;; 	  ;; does the last-done time fall in the legit region?
-;; 	  ;;    yes => #f  do not run again this command
-;; 	  ;;    no  => #t  ok to run the command
-;; 	  (for-each ;; month
-;; 	   (lambda (month)
-;; 	     (for-each ;; dayofmonth
-;; 	      (lambda (dom)
-;; 		(for-each
-;; 		 (lambda (hr) ;; hour
-;; 		   (for-each
-;; 		    (lambda (minute) ;; minute
-;; 		      (let ((copy-now (apply vector (vector->list now-time))))
-;; 			(vector-set! copy-now 0 0) ;; force seconds to zero
-;; 			(vector-set! copy-now 1 minute)
-;; 			(vector-set! copy-now 2 hr)
-;; 			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
-;; 			(vector-set! copy-now 4 month)
-;; 			(let* ((copy-now-secs (local-time->seconds copy-now))
-;; 			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
-;; 			  (if (or (not cdayofweek)
-;; 				  (equal? (vector-ref new-copy 6)
-;; 					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
-;; 			      (if (or (not cdayofmonth)
-;; 				      (equal? (vector-ref new-copy 3)
-;; 					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
-;; 				  (hash-table-set! all-times copy-now-secs new-copy))))))
-;; 		    (if cmin
-;; 			`(,cmin)  ;; if given cmin, have to use it
-;; 			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
-;; 		 (if chour
-;; 		     `(,chour)
-;; 		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
-;; 	      (if cdayofmonth
-;; 		  `(,cdayofmonth)
-;; 		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
-;; 	   (if cmonth
-;; 	       `(,cmonth)
-;; 	       (list (- nmonth 1) nmonth (+ nmonth 1))))
-;; 	  (let ((before #f)
-;; 		(is-in  #f))
-;; 	    (for-each
-;; 	     (lambda (moment)
-;; 	       (if (and before
-;; 			(<= before now-seconds)
-;; 			(>= moment now-seconds))
-;; 		   (begin
-;; 		     ;; (print)
-;; 		     ;; (print "Before: " (time->string (seconds->local-time before)))
-;; 		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
-;; 		     ;; (print "After:  " (time->string (seconds->local-time moment)))
-;; 		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
-;; 		     (if (<  last-done before)
-;; 			 (set! is-in before))
-;; 		     ))
-;; 	       (set! before moment))
-;; 	     (sort (hash-table-keys all-times) <))
-;; 	    is-in)))))
-;; 
-;; (define (common:extended-cron  cron-str now-seconds-in last-done)
-;;   (let ((expanded-cron (common:cron-expand cron-str)))
-;;     (if (string? expanded-cron)
-;; 	(common:cron-event expanded-cron now-seconds-in last-done)
-;; 	(let loop ((hed (car expanded-cron))
-;; 		   (tal (cdr expanded-cron)))
-;; 	  (if (common:cron-event hed now-seconds-in last-done)
-;; 	      #t
-;; 	      (if (null? tal)
-;; 		  #f
-;; 		  (loop (car tal)(cdr tal))))))))
-;; 
-;; ;;======================================================================
-;; ;; C O L O R S
-;; ;;======================================================================
-;;       
-;; (define (common:name->iup-color name)
-;;   (case (string->symbol (string-downcase name))
-;;     ((red)    "223 33 49")
-;;     ((grey)   "192 192 192")
-;;     ((orange) "255 172 13")
-;;     ((purple) "This is unfinished ...")))
-;; 
-;; ;; (define (common:get-color-for-state-status state status)
-;; ;;   (case (string->symbol state)
-;; ;;     ((COMPLETED)
-;; ;;      (case (string->symbol status)
-;; ;;        ((PASS)        "70  249 73")
-;; ;;        ((WARN WAIVED) "255 172 13")
-;; ;;        ((SKIP)        "230 230 0")
-;; ;;        (else "223 33 49")))
-;; ;;     ((LAUNCHED)         "101 123 142")
-;; ;;     ((CHECK)            "255 100 50")
-;; ;;     ((REMOTEHOSTSTART)  "50  130 195")
-;; ;;     ((RUNNING)          "9   131 232")
-;; ;;     ((KILLREQ)          "39  82  206")
-;; ;;     ((KILLED)           "234 101 17")
-;; ;;     ((NOT_STARTED)      "240 240 240")
-;; ;;     (else               "192 192 192")))
-;; 
-;; (define (common:iup-color->rgb-hex instr)
-;;   (string-intersperse 
-;;    (map (lambda (x)
-;;           (number->string x 16))
-;;         (map string->number
-;;              (string-split instr)))
-;;    "/"))
-;; 
-;; ;; dot-locking egg seems not to work, using this for now
-;; ;; if lock is older than expire-time then remove it and try again
-;; ;; to get the lock
-;; ;;
-;; (define (common:simple-file-lock fname #!key (expire-time 300))
-;;     (if (file-exists? fname)
-;; 	(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
-;; 	    (begin
-;;               (handle-exceptions exn #f (delete-file* fname))	
-;; 	      (common:simple-file-lock fname expire-time: expire-time))
-;; 	    #f)
-;; 	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
-;; 	  (with-output-to-file fname
-;; 	    (lambda ()
-;; 	      (print key-string)))
-;; 	  (thread-sleep! 0.25)
-;; 	  (if (file-exists? fname)
-;; 	      (handle-exceptions exn
-;;                 #f 
-;;                 (with-input-from-file fname
-;; 	  	  (lambda ()
-;; 		    (equal? key-string (read-line)))))
-;; 	      #f))))
-;; 
-;; (define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
-;;   (let ((end-time (+ expire-time (current-seconds))))
-;;     (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
-;;       (if got-lock
-;; 	  #t
-;; 	  (if (> end-time (current-seconds))
-;; 	      (begin
-;; 		(thread-sleep! 3)
-;; 		(loop (common:simple-file-lock fname expire-time: expire-time)))
-;; 	      #f)))))
-;; 
-;; (define (common:simple-file-release-lock fname)
-;;   (handle-exceptions
-;;       exn
-;;       #f ;; I don't really care why this failed (at least for now)
-;;     (delete-file* fname)))
-;; 
-;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
-;; ;;
-;; (define (common:lazy-modification-time fpath)
-;;   (handle-exceptions
-;;       exn
-;;       0
-;;       (file-modification-time fpath)))
-;; 
-;; ;; find timestamp of newest file associated with a sqlite db file
-;; (define (common:lazy-sqlite-db-modification-time fpath)
-;;   (let* ((glob-list (handle-exceptions
-;; 			exn
-;; 			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
-;; 		      (glob (conc fpath "*"))))
-;;          (file-list (if (eq? 0 (length glob-list))
-;; 			'("/no/such/file")
-;; 			glob-list)))
-;;   (apply max
-;;    (map
-;;     common:lazy-modification-time 
-;;     file-list))))
-;; 
-;; 
-;; ;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
-;; ;; arguments - thunk, message
-;; (define (common:fail-safe thunk warning-message-on-exception)
-;;   (handle-exceptions
-;;    exn
-;;    (begin
-;;      (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception)
-;;      (debug:print-info 0 *default-log-port*
-;;                        (string-substitute "\n?Error:" "nonfatal condition:"
-;;                                           (with-output-to-string
-;;                                             (lambda ()
-;;                                               (print-error-message exn) ))))
-;;      (debug:print-info 0 *default-log-port* "    -- continuing after nonfatal condition...")
-;;      #f)
-;;    (thunk)))
-;; 
-;; (define getenv get-environment-variable)
-;; (define (safe-setenv key val)
-;;   (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
-;;       (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
-;;       (if (and (string? val)
-;; 	       (string? key))
-;; 	  (handle-exceptions
-;; 	      exn
-;; 	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
-;; 	    (setenv key val))
-;; 	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
-;; 
-;; (define home (getenv "HOME"))
-;; (define user (getenv "USER"))
-;; 
-;; 
-;; ;; returns list of fd count, socket count
-;; (define (get-file-descriptor-count #!key  (pid (current-process-id )))
-;;   (list
-;;     (length (glob (conc "/proc/" pid "/fd/*")))
-;;     (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
-;;   )
-;; )
-;;
+(define *common:logpro-exit-code->status-sym-alist*
+  '( ( 0 . pass )
+     ( 1 . fail )
+     ( 2 . warn )
+     ( 3 . check )
+     ( 4 . waived )
+     ( 5 . abort )
+     ( 6 . skip )))
+
+(define (common:logpro-exit-code->status-sym exit-code)
+  (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
+
+(define (common:worse-status-sym ss1 ss2)
+  (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
+    (cond
+     ((null? status-syms-remaining)
+      'fail)
+     ((eq? (car status-syms-remaining) ss1)
+      ss1)
+     ((eq? (car status-syms-remaining) ss2)
+      ss2)
+     (else
+      (loop (cdr status-syms-remaining))))))
+
+(define (common:steps-can-proceed-given-status-sym status-sym)
+  (if (member status-sym '(warn waived pass))
+      #t
+      #f))
+
+(define (status-sym->string status-sym)
+  (case status-sym
+      ((pass) "PASS")
+    ((fail) "FAIL")
+    ((warn) "WARN")
+    ((check) "CHECK")
+    ((waived) "WAIVED")
+    ((abort) "ABORT")
+    ((skip) "SKIP")
+    (else "FAIL")))
+
+(define (common:logpro-exit-code->test-status exit-code)
+  (status-sym->string (common:logpro-exit-code->status-sym exit-code)))
+
+(define (common:clear-caches)
+  (set! *target*             (make-hash-table))
+  (set! *keys*               (make-hash-table))
+  (set! *keyvals*            (make-hash-table))
+  (set! *toptest-paths*      (make-hash-table))
+  (set! *test-paths*         (make-hash-table))
+  (set! *test-ids*           (make-hash-table))
+  (set! *test-info*          (make-hash-table))
+  (set! *run-info-cache*     (make-hash-table))
+  (set! *env-vars-by-run-id* (make-hash-table))
+  (set! *test-id-cache*      (make-hash-table)))
+
+;; Generic string database
+(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
+;; Generic path database
+(define *fdb* #f)
+
+(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
+
+;;======================================================================
+;; V E R S I O N
+;;======================================================================
+
+(define (common:get-full-version)
+  (conc megatest-version "-" megatest-fossil-hash))
+
+(define (common:version-signature)
+  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
+
+
+(define (common:get-sync-lock-filepath)
+  (let* ((tmp-area     (common:get-db-tmp-area))
+         (lockfile     (conc tmp-area "/megatest.db.sync-lock")))
+    lockfile))
+    
+;;======================================================================
+;; U S E F U L   S T U F F
+;;======================================================================
+
+;; convert things to an alist or assoc list, #f gets converted to ""
+;;
+(define (common:to-alist dat)
+  (cond
+   ((list? dat)   (map common:to-alist dat))
+   ((vector? dat)
+    (map common:to-alist (vector->list dat)))
+   ((pair? dat)
+    (cons (common:to-alist (car dat))
+	  (common:to-alist (cdr dat))))
+   ((hash-table? dat)
+    (map common:to-alist (hash-table->alist dat)))
+   (else
+    (if dat
+	dat
+	""))))
+
+(define (common:alist-ref/default key alist default)
+  (or (alist-ref key alist) default))
+
+(define (common:low-noise-print waitval . keys)
+  (let* ((key      (string-intersperse (map conc keys) "-" ))
+	 (lasttime (hash-table-ref/default *common:denoise* key 0))
+	 (currtime (current-seconds)))
+    (if (> (- currtime lasttime) waitval)
+	(begin
+	  (hash-table-set! *common:denoise* key currtime)
+	  #t)
+	#f)))
+
+(define (common:get-megatest-exe)
+  (or (getenv "MT_MEGATEST") "megatest"))
+
+(define (common:read-encoded-string instr)
+  (handle-exceptions
+   exn
+   (handle-exceptions
+    exn
+    (begin
+      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
+      (print-call-chain (current-error-port))
+      #f)
+    (read (open-input-string (base64:base64-decode instr))))
+   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
+
+;;======================================================================
+;; Configf extentions
+;;======================================================================
+
+(define (get-with-default val default)
+  (let ((val (args:get-arg val)))
+    (if val val default)))
+
+(define (assoc/default key lst . default)
+  (let ((res (assoc key lst)))
+    (if res (cadr res)(if (null? default) #f (car default)))))
+
+(define (common:get-testsuite-name)
+  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
+      (configf:lookup *configdat* "setup" "testsuite" )
+      (getenv "MT_TESTSUITE_NAME")
+      (if (string? *toppath* )
+          (pathname-file *toppath*)
+          #f))) ;; (pathname-file (current-directory)))))
+
+(define common:get-area-name common:get-testsuite-name)
+
+(define (common:get-db-tmp-area . junk)
+  (if *db-cache-path*
+      *db-cache-path*
+      (if *toppath* ;; common:get-create-writeable-dir
+	  (handle-exceptions
+	      exn
+	      (begin
+		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
+		(exit 1))
+	    (let ((dbpath (common:get-create-writeable-dir
+			   (list (conc "/tmp/" (current-user-name)
+				       "/megatest_localdb/"
+				       (common:get-testsuite-name) "/"
+				       (string-translate *toppath* "/" ".")))))) ;;  #t))))
+	      (set! *db-cache-path* dbpath)
+	      dbpath))
+	  #f)))
+
 
 ;; pulled from common_records.scm
 
 ;; globals - modules that include this need these here
 (define *logging* #f)

ADDED   cookie.scm
Index: cookie.scm
==================================================================
--- /dev/null
+++ cookie.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit cookie))
+
+(include "stml2/cookie.scm")

Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -30,70 +30,62 @@
      sparse-vectors srfi-18
      #;(prefix mtconfigf configf:)
      ) 
 (import (prefix sqlite3 sqlite3:))
 
-;; (declare (uses common))
-;; (declare (uses margs))
-;; (declare (uses keys))
-;; (declare (uses items))
-;; (declare (uses db))
-;; (declare (uses process))
-;; (declare (uses launch))
-;; (declare (uses runs))
-;; (declare (uses dashboard-tests))
-;; (declare (uses dashboard-guimonitor))
-;; (declare (uses tree))
-;; (declare (uses dcommon))
-;; (declare (uses dashboard-context-menu))
-;; (declare (uses vg))
-;; (declare (uses subrun))
-;; ;; (declare (uses dashboard-main))
-;; (declare (uses megatest-version))
-;; (declare (uses mt))
+(declare (uses mtargs))
+(import (prefix mtargs args:))
+
+(declare (uses ducttape-lib))
+(import ducttape-lib)
+
+(declare (uses mtconfigf))
+(import (prefix mtconfigf configf:))
+
+;; invoke the imports - ORDER IS IMPORTANT!
+(declare (uses mtargs.import))
+(declare (uses ducttape-lib.import))
+(declare (uses mtconfigf.import))
 
 (declare (uses megamod))
 (import megamod)
 
 (declare (uses commonmod))
 (import commonmod)
+
 (declare (uses rmtmod))
 (import rmtmod)
+
 (declare (uses runsmod))
 (import runsmod)
+
 (declare (uses dbmod))
 (import dbmod)
+
+(declare (uses testsmod))
+(import testsmod)
 
 (declare (uses dcommonmod))
 (import dcommonmod)
-(declare (uses mtargs))
-(import (prefix mtargs args:))
-(declare (uses ducttape-lib))
-(import ducttape-lib)
-(declare (uses mtconfigf))
-(import (prefix mtconfigf configf:))
 
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 (include "task_records.scm")
-;; (include "megatest-fossil-hash.scm") ;; comes from megamod
 (include "vg_records.scm")
 
-;; invoke the imports
+;; invoke the imports - ORDER IS IMPORTANT!
 (declare (uses commonmod.import))
+(declare (uses testsmod.import))
 (declare (uses rmtmod.import))
 (declare (uses runsmod.import))
 (declare (uses megamod.import))
 (declare (uses dcommonmod.import))
-(declare (uses mtargs.import))
-(declare (uses ducttape-lib.import))
-(declare (uses mtconfigf.import))
 
-(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
-(configf:add-eval-string "(import megamod)(import commonmod)")
+(mtconfigf#set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
+(mtconfigf#add-eval-string "(import megamod)(import commonmod)")
 
 
 (define help (conc 
 	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
   version " megatest-version "

Index: db-inc.scm
==================================================================
--- db-inc.scm
+++ db-inc.scm
@@ -2087,31 +2087,10 @@
 	  (set! res val))
 	db
 	(conc "SELECT " key " FROM runs WHERE id=?;")
 	run-id)
        res))))
-
-;; keys list to key1,key2,key3 ...
-(define (runs:get-std-run-fields keys remfields)
-  (let* ((header    (append keys remfields))
-	 (keystr    (conc (keys->keystr keys) ","
-			  (string-intersperse remfields ","))))
-    (list keystr header)))
-
-;; make a query (fieldname like 'patt1' OR fieldname 
-(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
-  (let ((patts (if (string? pattstr)
-		   (string-split pattstr ",")
-		   '("%"))))
-    (string-intersperse (map (lambda (patt)
-			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
-				 (conc fieldname " " wildtype " '" patt "'")))
-			     (if (null? patts)
-				 '("")
-				 patts))
-			comparator)))
-
 
 ;; register a test run with the db, this accesses the main.db and does NOT
 ;; use server api
 ;;
 (define (db:register-run dbstruct keyvals runname state status user contour-in)
@@ -2480,11 +2459,11 @@
 (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update  sort-order ) ;; test-name)
   (let* ((tmp      (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
 	 (keystr   (car tmp))
 	 (header   (cadr tmp))
 	 (key-patt "")
-	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
+	 (runwildtype (if (substring-index "%" (or runnamepatt "%")) "like" "glob"))
 	 (qry-str  #f)
 	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
     (for-each (lambda (keyval)
 		(let* ((key    (car keyval))
 		       (patt   (cadr keyval))
@@ -4325,74 +4304,10 @@
 		  res))))
 
 ;;======================================================================
 ;; M I S C   M A N A G E M E N T   I T E M S 
 ;;======================================================================
-
-;; A routine to map itempaths using a itemmap
-;; patha and pathb must be strings or this will fail
-;;
-;; path-b is waiting on path-a
-;;
-(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
-  (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
-  (let* ((itemmap    (tests:lookup-itemmap itemmaps test-b-name)))
-    (if itemmap
-	(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
-	  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
-	  (equal? path-a path-b-mapped))
-	(equal? path-b path-a))))
-
-;; A routine to convert test/itempath using a itemmap
-;; NOTE: to process only an itempath (i.e. no prepended testname)
-;;       just call db:multi-pattern-apply
-;;
-(define (db:convert-test-itempath path-in itemmap)
-  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
-  (let* ((path-parts  (string-split path-in "/"))
-	 (test-name   (if (null? path-parts) "" (car path-parts)))
-	 (item-path   (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
-    (conc test-name "/" 
-	  (db:multi-pattern-apply item-path itemmap))))
-
-;; patterns are:
-;;    "rx1"  "replacement1"\n
-;;    "rx2"  "replacement2"
-;; etc.
-;;
-(define (db:multi-pattern-apply item-path itemmap)
-  (let ((all-patts (string-split itemmap "\n")))
-    (if (null? all-patts)
-	item-path
-	(let loop ((hed (car all-patts))
-		   (tal (cdr all-patts))
-		   (res item-path))
-	  (let* ((parts (string-split hed))
-		 (patt  (car parts))
-
-		 (repl  (if (> (length parts) 1)(cadr parts) ""))
-
-		 (newr  (if (and patt repl)
-			    (begin
-                              (handle-exceptions
-                               exn
-                               (begin
-                                  (debug:print 0 *default-log-port*
-                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
-                                 res)
-                              (string-substitute patt repl res))
-
-
-                              )
-			    (begin
-                              (debug:print 0 *default-log-port*
-                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
-			      res))))
-	    (if (null? tal)
-		newr
-		(loop (car tal)(cdr tal) newr)))))))
-
 
 
 
 ;; the new prereqs calculation, looks also at itempath if specified
 ;; all prereqs must be met

Index: dcommonmod.scm
==================================================================
--- dcommonmod.scm
+++ dcommonmod.scm
@@ -18,10 +18,11 @@
 
 ;;======================================================================
 
 (declare (unit dcommonmod))
 (declare (uses commonmod))
+(declare (uses testsmod))
 (declare (uses megamod))
 (declare (uses mtargs))
 
 (module dcommonmod
 	*
@@ -81,10 +82,11 @@
 	)
 
 (use (prefix mtconfigf configf:))
 
 (import commonmod)
+(import testsmod)
 (import megamod)
 (import canvas-draw)
 (import canvas-draw-iup)
 (use (prefix iup iup:))
 (import (prefix mtargs args:))

Index: keys-inc.scm
==================================================================
--- keys-inc.scm
+++ keys-inc.scm
@@ -15,62 +15,5 @@
 ;; 
 ;;     You should have received a copy of the GNU General Public License
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 ;;
  
-;;======================================================================
-;; Run keys, these are used to hierarchially organise tests and run areas
-;;======================================================================
-
-(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
-  (string-intersperse keys ","))
-
-(define (args:usage . a) #f)
-
-;;======================================================================
-;; key <=> target routines
-;;======================================================================
-
-;; This invalidates using "/" in item names. Every key will be
-;; available via args:get-arg as :keyfield. Since this only needs to
-;; be called once let's use it to set the environment vars
-;;
-;; The setting of :keyfield in args should be turned off ASAP
-;;
-(define (keys:target-set-args keys target ht)
-  (if target
-      (let ((vals (string-split target "/")))
-	(if (eq? (length vals)(length keys))
-	    (for-each (lambda (key val)
-			(setenv key val)
-			(if ht (hash-table-set! ht (conc ":" key) val)))
-		      keys
-		      vals)
-	    (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
-	vals)
-      (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
-
-;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list
-;; keyval list ( (key1 val1) (key2 val2) ...)
-(define (keys:target->keyval keys target)
-  (let* ((targlist (string-split target "/"))
-	 (numkeys  (length keys))
-	 (numtarg  (length targlist))
-	 (targtweaked (if (> numkeys numtarg)
-			  (append targlist (make-list (- numkeys numtarg) ""))
-			  targlist)))
-    (map (lambda (key targ)
-	   (list key targ))
-	 keys targtweaked)))
-
-;;======================================================================
-;; config file related routines
-;;======================================================================
-
-(define keys:config-get-fields common:get-fields)
-(define (keys:make-key/field-string confdat)
-  (let ((fields (configf:get-section confdat "fields")))
-    (string-join
-     (map (lambda (field)(conc (car field) " " (cadr field)))
-	  fields)
-     ",")))
-

Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -39,16 +39,17 @@
 ;; (declare (uses runconfigmod))
 (declare (uses runsmod))
 ;; (declare (uses servermod))
 ;; (declare (uses subrunmod))
 ;; (declare (uses tasksmod))
-;; (declare (uses testsmod))
+(declare (uses testsmod))
 ;; (declare (uses vgmod))
 (declare (uses pkts))
 (declare (uses mtargs))
 (declare (uses mtconfigf))
 (declare (uses ducttape-lib))
+(declare (uses stml2))
 
 (module megamod
 	*
 	
 (import scheme chicken data-structures extras)
@@ -91,11 +92,10 @@
  srfi-4
  srfi-13
  srfi-18
  srfi-69
  stack
- stml2
  tcp
  typed-records
  udp
  uri-common
  z3
@@ -105,10 +105,11 @@
 (define read-config configf:read-config)
 (define find-and-read-config configf:find-and-read-config)
 (define config:eval-string-in-environment configf:eval-string-in-environment)
 
 (import spiffy)
+(import stml2)
 
 ;; (import apimod)
 ;; (import archivemod)
 ;; (import clientmod)
 (import commonmod)
@@ -126,11 +127,11 @@
 ;; (import runconfigmod)
 (import runsmod)
 ;; (import servermod)
 ;; (import subrunmod)
 ;; (import tasksmod)
-;; (import testsmod)
+(import testsmod)
 ;; (import vgmod)
 (import pkts)
 (import (prefix mtargs args:))
 (import ducttape-lib)
 
@@ -175,11 +176,11 @@
 (include "common-inc.scm")    ;; L5
 (include "db-inc.scm")        ;; L4
 (include "env-inc.scm")
 (include "http-transport-inc.scm")
 (include "items-inc.scm")
-(include "keys-inc.scm")
+;; (include "keys-inc.scm")
 (include "launch-inc.scm")     ;; L1
 ;; (include "margs-inc.scm")
 (include "mt-inc.scm")
 (include "ods-inc.scm")        ;; L1
 (include "pgdb-inc.scm")

Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -30,61 +30,44 @@
 ;;
 (use sparse-vectors)
 
 (require-library mutils)
 
-;; (use zmq)
-
-;; (declare (uses common))
-;; (declare (uses megatest-version))
-;; (declare (uses margs))
-;; (declare (uses runs))
-;; (declare (uses launch))
-;; (declare (uses server))
-;; (declare (uses client))
-;; (declare (uses tests))
-;; (declare (uses genexample))
-;; ;; (declare (uses daemon))
-;; (declare (uses db))
-;; ;; (declare (uses dcommon))
-
-(declare (uses commonmod))
-(import commonmod)
-(declare (uses rmtmod))
-(import rmtmod)
-(declare (uses dbmod))
-(import dbmod)
-(declare (uses runsmod))
-(import runsmod)
-(declare (uses megamod))
-(import megamod)
 (declare (uses mtargs))
 (import (prefix mtargs args:))
 (declare (uses mtconfigf))
 (import (prefix mtconfigf configf:))
 (declare (uses ducttape-lib))
 (import ducttape-lib)
 
 ;; invoke the imports
-(declare (uses commonmod.import))
-(declare (uses rmtmod.import))
-(declare (uses runsmod.import))
-(declare (uses megamod.import))
 (declare (uses mtargs.import))
 (declare (uses mtconfigf.import))
 (declare (uses ducttape-lib.import))
 
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses rmtmod))
+(import rmtmod)
+(declare (uses dbmod))
+(import dbmod)
+(declare (uses runsmod))
+(import runsmod)
+(declare (uses testsmod))
+(import testsmod)
+(declare (uses megamod))
+(import megamod)
+
+;; invoke the imports
+(declare (uses commonmod.import))
+(declare (uses testsmod.import))
+(declare (uses rmtmod.import))
+(declare (uses runsmod.import))
+(declare (uses megamod.import))
 (configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
 
-;; (declare (uses tdb))
-;; (declare (uses mt))
-;; (declare (uses api))
-;; (declare (uses tasks)) ;; only used for debugging.
-;; (declare (uses env))
-;; (declare (uses diff-report))
-;; (declare (uses ftail))
-;; (import ftail)
 
 (define *db* #f) ;; this is only for the repl, do not use in general!!!!
 (define *default-log-port* (current-error-port))
 
 (include "common_records.scm")
@@ -92,11 +75,11 @@
 (include "db_records.scm")
 (include "run_records.scm")
 ;; (include "megatest-fossil-hash.scm") ;; included in megamod
 
 (define getenv get-environment-variable)
-(configf:add-eval-string "(import megamod)(import commonmod)")
+(configf:add-eval-string "(import megamod commonmod (prefix mtconfigf configf:)(prefix mtargs args:))")
 
 (define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
 (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
 
 ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file

Index: rmt-inc.scm
==================================================================
--- rmt-inc.scm
+++ rmt-inc.scm
@@ -71,138 +71,142 @@
 		  #f))))
 
 (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
 
 (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-
-  #;(common:telemetry-log (conc "rmt:"(->string cmd))
-                        payload: `((rid . ,rid)
-                                   (params . ,params)))
-                          
-  ;; do all the prep locked under the rmt-mutex
-  (mutex-lock! *rmt-mutex*)
-  
-  ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
-  ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
-  ;; 3. do the query, if on homehost use local access
-  ;;
-  (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
-         (areapath      *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
-	 (runremote     (or area-dat
-			    *runremote*))
-	 (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
-
-    ;; ensure we have a record for our connection for given area
-    (if (not runremote)                   ;; can remove this one. should never get here.         
-	(begin
-	  (set! *runremote* (make-remote))
-	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
-    
-    ;; ensure we have a homehost record
-    (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
-	(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
-	(remote-hh-dat-set! runremote (common:get-homehost)))
-    
-    ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
-    (cond
-     ;; give up if more than 15 attempts
-     ((> attemptnum 15)
-      (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
-      (exit 1))
-
-     ;; readonly mode, read request-  handle it - case 2
-     ((and readonly-mode
-           (member cmd api:read-only-queries)) 
-      (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
-      (rmt:open-qry-close-locally cmd 0 params)
-      )
-
-     ;; readonly mode, write request.  Do nothing, return #f
-     (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
-
-     ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
-     ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
-     ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
-     ;;
-     ;; reset the connection if it has been unused too long
-     ((and runremote
-           (remote-conndat runremote)
-	   (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
-	      (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
-		 (remote-server-timeout runremote))))
-      (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
-      (http-transport:close-connections area-dat: runremote)
-      (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
-      (mutex-unlock! *rmt-mutex*)
-      (rmt:send-receive cmd rid params attemptnum: attemptnum))
-     
-     ;; on homehost and this is a read
-     ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
-	   (cdr (remote-hh-dat runremote))       ;; on homehost
-           (member cmd api:read-only-queries))   ;; this is a read
-      (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5")
-      (rmt:open-qry-close-locally cmd 0 params))
-
-     ;; on homehost and this is a write, we already have a server, but server has died
-     ((and (cdr (remote-hh-dat runremote))           ;; on homehost
-           (not (member cmd api:read-only-queries))  ;; this is a write
-           (remote-server-url runremote)             ;; have a server
-           (not (server:ping (remote-server-url runremote))))  ;; server has died. NOTE: this is not a cheap call! Need better approach.
-      (set! *runremote* (make-remote))
-      (remote-force-server-set! runremote (common:force-server?))
-      (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6")
-      (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
-     ;; on homehost and this is a write, we already have a server
-     ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
-	   (cdr (remote-hh-dat runremote))           ;; on homehost
-           (not (member cmd api:read-only-queries))  ;; this is a write
-           (remote-server-url runremote))            ;; have a server
-      (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4.1")
-      (rmt:open-qry-close-locally cmd 0 params))
-
-     ;;  on homehost, no server contact made and this is a write, passively start a server 
-     ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
-	   (cdr (remote-hh-dat runremote))           ;; have homehost
-           (not (remote-server-url runremote))       ;; no connection yet
-	   (not (member cmd api:read-only-queries))) ;; not a read-only query
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8")
-      (let ((server-url  (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
-	(if server-url
-	    (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
-	    (if (common:force-server?)
-		(server:start-and-wait *toppath*)
-		(server:kind-run *toppath*))))
-      (remote-force-server-set! runremote (common:force-server?))
-      (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8.1")
-      (rmt:open-qry-close-locally cmd 0 params))
-
-     ((or (and (remote-force-server runremote)              ;; we are forcing a server and don't yet have a connection to one
-	       (not (remote-conndat runremote)))
-	  (and (not (cdr (remote-hh-dat runremote)))        ;; not on a homehost 
-	       (not (remote-conndat runremote))))           ;; and no connection
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
-      (mutex-unlock! *rmt-mutex*)
-      (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
-	  (server:start-and-wait *toppath*))
-      (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
-      (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
-
-     ;; all set up if get this far, dispatch the query
-     ((and (not (remote-force-server runremote))
-	   (cdr (remote-hh-dat runremote))) ;; we are on homehost
-      (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
-      (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
-     ;; not on homehost, do server query
-     (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
+  (rmt:open-qry-close-locally cmd 0 params))
+;;   
+;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
+;; ;; #;(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
+;; ;; 
+;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
+;; ;; payload: `((rid . ,rid)
+;; ;; (params . ,params)))
+;; ;; 
+;;   ;; do all the prep locked under the rmt-mutex
+;;   (mutex-lock! *rmt-mutex*)
+;;   
+;;   ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
+;;   ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
+;;   ;; 3. do the query, if on homehost use local access
+;;   ;;
+;;   (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
+;;          (areapath      *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
+;; 	 (runremote     (or area-dat
+;; 			    *runremote*))
+;; 	 (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
+;; 
+;;     ;; ensure we have a record for our connection for given area
+;;     (if (not runremote)                   ;; can remove this one. should never get here.         
+;; 	(begin
+;; 	  (set! *runremote* (make-remote))
+;; 	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
+;;     
+;;     ;; ensure we have a homehost record
+;;     (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
+;; 	(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
+;; 	(remote-hh-dat-set! runremote (common:get-homehost)))
+;;     
+;;     ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
+;;     (cond
+;;      ;; give up if more than 15 attempts
+;;      ((> attemptnum 15)
+;;       (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
+;;       (exit 1))
+;; 
+;;      ;; readonly mode, read request-  handle it - case 2
+;;      ((and readonly-mode
+;;            (member cmd api:read-only-queries)) 
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
+;;       (rmt:open-qry-close-locally cmd 0 params)
+;;       )
+;; 
+;;      ;; readonly mode, write request.  Do nothing, return #f
+;;      (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
+;; 
+;;      ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+;;      ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+;;      ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+;;      ;;
+;;      ;; reset the connection if it has been unused too long
+;;      ((and runremote
+;;            (remote-conndat runremote)
+;; 	   (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+;; 	      (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
+;; 		 (remote-server-timeout runremote))))
+;;       (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
+;;       (http-transport:close-connections area-dat: runremote)
+;;       (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;      
+;;      ;; on homehost and this is a read
+;;      ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; 	   (cdr (remote-hh-dat runremote))       ;; on homehost
+;;            (member cmd api:read-only-queries))   ;; this is a read
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5")
+;;       (rmt:open-qry-close-locally cmd 0 params))
+;; 
+;;      ;; on homehost and this is a write, we already have a server, but server has died
+;;      ((and (cdr (remote-hh-dat runremote))           ;; on homehost
+;;            (not (member cmd api:read-only-queries))  ;; this is a write
+;;            (remote-server-url runremote)             ;; have a server
+;;            (not (server:ping (remote-server-url runremote))))  ;; server has died. NOTE: this is not a cheap call! Need better approach.
+;;       (set! *runremote* (make-remote))
+;;       (remote-force-server-set! runremote (common:force-server?))
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6")
+;;       (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;; 
+;;      ;; on homehost and this is a write, we already have a server
+;;      ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
+;; 	   (cdr (remote-hh-dat runremote))           ;; on homehost
+;;            (not (member cmd api:read-only-queries))  ;; this is a write
+;;            (remote-server-url runremote))            ;; have a server
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4.1")
+;;       (rmt:open-qry-close-locally cmd 0 params))
+;; 
+;;      ;;  on homehost, no server contact made and this is a write, passively start a server 
+;;      ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
+;; 	   (cdr (remote-hh-dat runremote))           ;; have homehost
+;;            (not (remote-server-url runremote))       ;; no connection yet
+;; 	   (not (member cmd api:read-only-queries))) ;; not a read-only query
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8")
+;;       (let ((server-url  (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+;; 	(if server-url
+;; 	    (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
+;; 	    (if (common:force-server?)
+;; 		(server:start-and-wait *toppath*)
+;; 		(server:kind-run *toppath*))))
+;;       (remote-force-server-set! runremote (common:force-server?))
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8.1")
+;;       (rmt:open-qry-close-locally cmd 0 params))
+;; 
+;;      ((or (and (remote-force-server runremote)              ;; we are forcing a server and don't yet have a connection to one
+;; 	       (not (remote-conndat runremote)))
+;; 	  (and (not (cdr (remote-hh-dat runremote)))        ;; not on a homehost 
+;; 	       (not (remote-conndat runremote))))           ;; and no connection
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
+;; 	  (server:start-and-wait *toppath*))
+;;       (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
+;;       (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
+;; 
+;;      ;; all set up if get this far, dispatch the query
+;;      ((and (not (remote-force-server runremote))
+;; 	   (cdr (remote-hh-dat runremote))) ;; we are on homehost
+;;       (mutex-unlock! *rmt-mutex*)
+;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
+;;       (rmt:open-qry-close-locally cmd (if rid rid 0) params))
+;; 
+;;      ;; not on homehost, do server query
+;;      (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
 
 ;; bunch of small functions factored out of send-receive to make debug easier
 ;;
 
 (define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)

Index: runs-inc.scm
==================================================================
--- runs-inc.scm
+++ runs-inc.scm
@@ -270,14 +270,10 @@
 		  (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
 	      (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
 	      (system (conc run-post-hook " >> " actual-logf " 2>&1"))
 	      (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
 
-;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
-(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
-  (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))
-
 ;;======================================================================
 ;; runs:run-tests is called from megatest.scm and itself
 ;;======================================================================
 ;;
 ;;  test-names: Comma separated patterns same as test-patts but used in selection 

Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -18,17 +18,19 @@
 
 ;;======================================================================
 
 (declare (unit runsmod))
 (declare (uses commonmod))
+(declare (uses testsmod))
 
 (module runsmod
 	*
 	
 (import scheme chicken data-structures extras)
 (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
 (import commonmod)
+(import testsmod)
 ;; (use (prefix ulex ulex:))
 
 ;; (include "common_records.scm")
 (defstruct runs:dat
   reglen regfull
@@ -89,7 +91,11 @@
     (if (> (- currtime lasttime) waitval)
 	(begin
 	  (hash-table-set! *runs:denoise* key currtime)
 	  #t)
 	#f)))
+
+;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
+(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
+  (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))
 
 )

ADDED   stml2.scm
Index: stml2.scm
==================================================================
--- /dev/null
+++ stml2.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit stml2))
+
+(include "stml2/stml2.scm")

ADDED   stml2/COPYING
Index: stml2/COPYING
==================================================================
--- /dev/null
+++ stml2/COPYING
@@ -0,0 +1,724 @@
+		    GNU GENERAL PUBLIC LICENSE
+		       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+                       51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+		    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+			    NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+
+	    How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year  name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Library General
+Public License instead of this License.
+
+
+GNU Free Documentation License
+******************************
+
+                        Version 1.1, March 2000
+     Copyright (C) 2000 Free Software Foundation, Inc.
+     51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+     
+     Everyone is permitted to copy and distribute verbatim copies
+     of this license document, but changing it is not allowed.
+
+  0. PREAMBLE
+
+     The purpose of this License is to make a manual, textbook, or other
+     written document "free" in the sense of freedom: to assure everyone
+     the effective freedom to copy and redistribute it, with or without
+     modifying it, either commercially or noncommercially.  Secondarily,
+     this License preserves for the author and publisher a way to get
+     credit for their work, while not being considered responsible for
+     modifications made by others.
+
+     This License is a kind of "copyleft", which means that derivative
+     works of the document must themselves be free in the same sense.
+     It complements the GNU General Public License, which is a copyleft
+     license designed for free software.
+
+     We have designed this License in order to use it for manuals for
+     free software, because free software needs free documentation: a
+     free program should come with manuals providing the same freedoms
+     that the software does.  But this License is not limited to
+     software manuals; it can be used for any textual work, regardless
+     of subject matter or whether it is published as a printed book.
+     We recommend this License principally for works whose purpose is
+     instruction or reference.
+
+  1. APPLICABILITY AND DEFINITIONS
+
+     This License applies to any manual or other work that contains a
+     notice placed by the copyright holder saying it can be distributed
+     under the terms of this License.  The "Document", below, refers to
+     any such manual or work.  Any member of the public is a licensee,
+     and is addressed as "you".
+
+     A "Modified Version" of the Document means any work containing the
+     Document or a portion of it, either copied verbatim, or with
+     modifications and/or translated into another language.
+
+     A "Secondary Section" is a named appendix or a front-matter
+     section of the Document that deals exclusively with the
+     relationship of the publishers or authors of the Document to the
+     Document's overall subject (or to related matters) and contains
+     nothing that could fall directly within that overall subject.
+     (For example, if the Document is in part a textbook of
+     mathematics, a Secondary Section may not explain any mathematics.)
+     The relationship could be a matter of historical connection with
+     the subject or with related matters, or of legal, commercial,
+     philosophical, ethical or political position regarding them.
+
+     The "Invariant Sections" are certain Secondary Sections whose
+     titles are designated, as being those of Invariant Sections, in
+     the notice that says that the Document is released under this
+     License.
+
+     The "Cover Texts" are certain short passages of text that are
+     listed, as Front-Cover Texts or Back-Cover Texts, in the notice
+     that says that the Document is released under this License.
+
+     A "Transparent" copy of the Document means a machine-readable copy,
+     represented in a format whose specification is available to the
+     general public, whose contents can be viewed and edited directly
+     and straightforwardly with generic text editors or (for images
+     composed of pixels) generic paint programs or (for drawings) some
+     widely available drawing editor, and that is suitable for input to
+     text formatters or for automatic translation to a variety of
+     formats suitable for input to text formatters.  A copy made in an
+     otherwise Transparent file format whose markup has been designed
+     to thwart or discourage subsequent modification by readers is not
+     Transparent.  A copy that is not "Transparent" is called "Opaque".
+
+     Examples of suitable formats for Transparent copies include plain
+     ASCII without markup, Texinfo input format, LaTeX input format,
+     SGML or XML using a publicly available DTD, and
+     standard-conforming simple HTML designed for human modification.
+     Opaque formats include PostScript, PDF, proprietary formats that
+     can be read and edited only by proprietary word processors, SGML
+     or XML for which the DTD and/or processing tools are not generally
+     available, and the machine-generated HTML produced by some word
+     processors for output purposes only.
+
+     The "Title Page" means, for a printed book, the title page itself,
+     plus such following pages as are needed to hold, legibly, the
+     material this License requires to appear in the title page.  For
+     works in formats which do not have any title page as such, "Title
+     Page" means the text near the most prominent appearance of the
+     work's title, preceding the beginning of the body of the text.
+
+  2. VERBATIM COPYING
+
+     You may copy and distribute the Document in any medium, either
+     commercially or noncommercially, provided that this License, the
+     copyright notices, and the license notice saying this License
+     applies to the Document are reproduced in all copies, and that you
+     add no other conditions whatsoever to those of this License.  You
+     may not use technical measures to obstruct or control the reading
+     or further copying of the copies you make or distribute.  However,
+     you may accept compensation in exchange for copies.  If you
+     distribute a large enough number of copies you must also follow
+     the conditions in section 3.
+
+     You may also lend copies, under the same conditions stated above,
+     and you may publicly display copies.
+
+  3. COPYING IN QUANTITY
+
+     If you publish printed copies of the Document numbering more than
+     100, and the Document's license notice requires Cover Texts, you
+     must enclose the copies in covers that carry, clearly and legibly,
+     all these Cover Texts: Front-Cover Texts on the front cover, and
+     Back-Cover Texts on the back cover.  Both covers must also clearly
+     and legibly identify you as the publisher of these copies.  The
+     front cover must present the full title with all words of the
+     title equally prominent and visible.  You may add other material
+     on the covers in addition.  Copying with changes limited to the
+     covers, as long as they preserve the title of the Document and
+     satisfy these conditions, can be treated as verbatim copying in
+     other respects.
+
+     If the required texts for either cover are too voluminous to fit
+     legibly, you should put the first ones listed (as many as fit
+     reasonably) on the actual cover, and continue the rest onto
+     adjacent pages.
+
+     If you publish or distribute Opaque copies of the Document
+     numbering more than 100, you must either include a
+     machine-readable Transparent copy along with each Opaque copy, or
+     state in or with each Opaque copy a publicly-accessible
+     computer-network location containing a complete Transparent copy
+     of the Document, free of added material, which the general
+     network-using public has access to download anonymously at no
+     charge using public-standard network protocols.  If you use the
+     latter option, you must take reasonably prudent steps, when you
+     begin distribution of Opaque copies in quantity, to ensure that
+     this Transparent copy will remain thus accessible at the stated
+     location until at least one year after the last time you
+     distribute an Opaque copy (directly or through your agents or
+     retailers) of that edition to the public.
+
+     It is requested, but not required, that you contact the authors of
+     the Document well before redistributing any large number of
+     copies, to give them a chance to provide you with an updated
+     version of the Document.
+
+  4. MODIFICATIONS
+
+     You may copy and distribute a Modified Version of the Document
+     under the conditions of sections 2 and 3 above, provided that you
+     release the Modified Version under precisely this License, with
+     the Modified Version filling the role of the Document, thus
+     licensing distribution and modification of the Modified Version to
+     whoever possesses a copy of it.  In addition, you must do these
+     things in the Modified Version:
+
+       A. Use in the Title Page (and on the covers, if any) a title
+          distinct from that of the Document, and from those of
+          previous versions (which should, if there were any, be listed
+          in the History section of the Document).  You may use the
+          same title as a previous version if the original publisher of
+          that version gives permission.
+
+       B. List on the Title Page, as authors, one or more persons or
+          entities responsible for authorship of the modifications in
+          the Modified Version, together with at least five of the
+          principal authors of the Document (all of its principal
+          authors, if it has less than five).
+
+       C. State on the Title page the name of the publisher of the
+          Modified Version, as the publisher.
+
+       D. Preserve all the copyright notices of the Document.
+
+       E. Add an appropriate copyright notice for your modifications
+          adjacent to the other copyright notices.
+
+       F. Include, immediately after the copyright notices, a license
+          notice giving the public permission to use the Modified
+          Version under the terms of this License, in the form shown in
+          the Addendum below.
+
+       G. Preserve in that license notice the full lists of Invariant
+          Sections and required Cover Texts given in the Document's
+          license notice.
+
+       H. Include an unaltered copy of this License.
+
+       I. Preserve the section entitled "History", and its title, and
+          add to it an item stating at least the title, year, new
+          authors, and publisher of the Modified Version as given on
+          the Title Page.  If there is no section entitled "History" in
+          the Document, create one stating the title, year, authors,
+          and publisher of the Document as given on its Title Page,
+          then add an item describing the Modified Version as stated in
+          the previous sentence.
+
+       J. Preserve the network location, if any, given in the Document
+          for public access to a Transparent copy of the Document, and
+          likewise the network locations given in the Document for
+          previous versions it was based on.  These may be placed in
+          the "History" section.  You may omit a network location for a
+          work that was published at least four years before the
+          Document itself, or if the original publisher of the version
+          it refers to gives permission.
+
+       K. In any section entitled "Acknowledgments" or "Dedications",
+          preserve the section's title, and preserve in the section all
+          the substance and tone of each of the contributor
+          acknowledgments and/or dedications given therein.
+
+       L. Preserve all the Invariant Sections of the Document,
+          unaltered in their text and in their titles.  Section numbers
+          or the equivalent are not considered part of the section
+          titles.
+
+       M. Delete any section entitled "Endorsements".  Such a section
+          may not be included in the Modified Version.
+
+       N. Do not retitle any existing section as "Endorsements" or to
+          conflict in title with any Invariant Section.
+
+     If the Modified Version includes new front-matter sections or
+     appendices that qualify as Secondary Sections and contain no
+     material copied from the Document, you may at your option
+     designate some or all of these sections as invariant.  To do this,
+     add their titles to the list of Invariant Sections in the Modified
+     Version's license notice.  These titles must be distinct from any
+     other section titles.
+
+     You may add a section entitled "Endorsements", provided it contains
+     nothing but endorsements of your Modified Version by various
+     parties--for example, statements of peer review or that the text
+     has been approved by an organization as the authoritative
+     definition of a standard.
+
+     You may add a passage of up to five words as a Front-Cover Text,
+     and a passage of up to 25 words as a Back-Cover Text, to the end
+     of the list of Cover Texts in the Modified Version.  Only one
+     passage of Front-Cover Text and one of Back-Cover Text may be
+     added by (or through arrangements made by) any one entity.  If the
+     Document already includes a cover text for the same cover,
+     previously added by you or by arrangement made by the same entity
+     you are acting on behalf of, you may not add another; but you may
+     replace the old one, on explicit permission from the previous
+     publisher that added the old one.
+
+     The author(s) and publisher(s) of the Document do not by this
+     License give permission to use their names for publicity for or to
+     assert or imply endorsement of any Modified Version.
+
+  5. COMBINING DOCUMENTS
+
+     You may combine the Document with other documents released under
+     this License, under the terms defined in section 4 above for
+     modified versions, provided that you include in the combination
+     all of the Invariant Sections of all of the original documents,
+     unmodified, and list them all as Invariant Sections of your
+     combined work in its license notice.
+
+     The combined work need only contain one copy of this License, and
+     multiple identical Invariant Sections may be replaced with a single
+     copy.  If there are multiple Invariant Sections with the same name
+     but different contents, make the title of each such section unique
+     by adding at the end of it, in parentheses, the name of the
+     original author or publisher of that section if known, or else a
+     unique number.  Make the same adjustment to the section titles in
+     the list of Invariant Sections in the license notice of the
+     combined work.
+
+     In the combination, you must combine any sections entitled
+     "History" in the various original documents, forming one section
+     entitled "History"; likewise combine any sections entitled
+     "Acknowledgments", and any sections entitled "Dedications".  You
+     must delete all sections entitled "Endorsements."
+
+  6. COLLECTIONS OF DOCUMENTS
+
+     You may make a collection consisting of the Document and other
+     documents released under this License, and replace the individual
+     copies of this License in the various documents with a single copy
+     that is included in the collection, provided that you follow the
+     rules of this License for verbatim copying of each of the
+     documents in all other respects.
+
+     You may extract a single document from such a collection, and
+     distribute it individually under this License, provided you insert
+     a copy of this License into the extracted document, and follow
+     this License in all other respects regarding verbatim copying of
+     that document.
+
+  7. AGGREGATION WITH INDEPENDENT WORKS
+
+     A compilation of the Document or its derivatives with other
+     separate and independent documents or works, in or on a volume of
+     a storage or distribution medium, does not as a whole count as a
+     Modified Version of the Document, provided no compilation
+     copyright is claimed for the compilation.  Such a compilation is
+     called an "aggregate", and this License does not apply to the
+     other self-contained works thus compiled with the Document, on
+     account of their being thus compiled, if they are not themselves
+     derivative works of the Document.
+
+     If the Cover Text requirement of section 3 is applicable to these
+     copies of the Document, then if the Document is less than one
+     quarter of the entire aggregate, the Document's Cover Texts may be
+     placed on covers that surround only the Document within the
+     aggregate.  Otherwise they must appear on covers around the whole
+     aggregate.
+
+  8. TRANSLATION
+
+     Translation is considered a kind of modification, so you may
+     distribute translations of the Document under the terms of section
+     4.  Replacing Invariant Sections with translations requires special
+     permission from their copyright holders, but you may include
+     translations of some or all Invariant Sections in addition to the
+     original versions of these Invariant Sections.  You may include a
+     translation of this License provided that you also include the
+     original English version of this License.  In case of a
+     disagreement between the translation and the original English
+     version of this License, the original English version will prevail.
+
+  9. TERMINATION
+
+     You may not copy, modify, sublicense, or distribute the Document
+     except as expressly provided for under this License.  Any other
+     attempt to copy, modify, sublicense or distribute the Document is
+     void, and will automatically terminate your rights under this
+     License.  However, parties who have received copies, or rights,
+     from you under this License will not have their licenses
+     terminated so long as such parties remain in full compliance.
+
+ 10. FUTURE REVISIONS OF THIS LICENSE
+
+     The Free Software Foundation may publish new, revised versions of
+     the GNU Free Documentation License from time to time.  Such new
+     versions will be similar in spirit to the present version, but may
+     differ in detail to address new problems or concerns.  See
+     `http://www.gnu.org/copyleft/'.
+
+     Each version of the License is given a distinguishing version
+     number.  If the Document specifies that a particular numbered
+     version of this License "or any later version" applies to it, you
+     have the option of following the terms and conditions either of
+     that specified version or of any later version that has been
+     published (not as a draft) by the Free Software Foundation.  If
+     the Document does not specify a version number of this License,
+     you may choose any version ever published (not as a draft) by the
+     Free Software Foundation.
+
+ADDENDUM: How to use this License for your documents
+----------------------------------------------------
+
+  To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and license
+notices just after the title page:
+
+       Copyright (C)  YEAR  YOUR NAME.
+       Permission is granted to copy, distribute and/or modify this document
+       under the terms of the GNU Free Documentation License, Version 1.1
+       or any later version published by the Free Software Foundation;
+       with the Invariant Sections being LIST THEIR TITLES, with the
+       Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST.
+       A copy of the license is included in the section entitled ``GNU
+       Free Documentation License''.
+
+  If you have no Invariant Sections, write "with no Invariant Sections"
+instead of saying which ones are invariant.  If you have no Front-Cover
+Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being
+LIST"; likewise for Back-Cover Texts.
+
+  If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License, to
+permit their use in free software.
+

ADDED   stml2/INSTALL
Index: stml2/INSTALL
==================================================================
--- /dev/null
+++ stml2/INSTALL
@@ -0,0 +1,23 @@
+These are rough installation instructions. Please contact me at matt@kiatoa.com
+if you have trouble installing.
+
+1. Copy install.cfg.template to install.cfg and modify appropriately
+
+2. Copy stml.config.template to your cgi dir as .stml.config and modify appropriately
+    - choose your db
+
+3. Copy requirements.scm.template to requirements.scm and modify as needed
+    - choose your db (must match what you choose in 2. above)
+
+If on 64 bit and you get error in compiling try fPIC:
+
+CSC_OPTIONS='-C "-fPIC"' make
+
+run 
+
+> make 
+
+or 
+
+> CSC_OPTIONS='-C "-fPIC"' make
+

ADDED   stml2/Makefile
Index: stml2/Makefile
==================================================================
--- /dev/null
+++ stml2/Makefile
@@ -0,0 +1,88 @@
+# Copyright 2007-2008, Matthew Welland.
+# 
+#  This program is made available under the GNU GPL version 2.0 or
+#  greater. See the accompanying file COPYING for details.
+# 
+#  This program is distributed WITHOUT ANY WARRANTY; without even the
+#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+#  PURPOSE.
+#
+# Following needed on bluehost (maybe on all 64bit?)
+#
+# CSC_OPTIONS='-C "-fPIC"' make
+#
+include install.cfg
+
+SRCFILES    = stml2.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm keystore.scm html-filter.scm cookie.scm 
+MODULEFILES = $(wildcard modules/*/*-mod.scm)
+SOFILES     = $(MODULEFILES:%.scm=%.so)
+CFILES      = $(MODULEFILES:%.scm=%.c)
+OFILES      = $(SRCFILES:%.scm=%.o)
+TARGFILES   = $(notdir $(SOFILES))
+MODULES     = $(addprefix $(TARGDIR)/modules/,$(TARGFILES))
+
+install : $(TARGDIR)/stmlrun $(LOGDIR) $(MODULES)
+	chicken-install
+
+all : $(SOFILES)
+
+# stmlrun : stmlrun.scm formdat.scm  misc-stml.scm  session.scm stml.scm \
+#           setup.scm html-filter.scm requirements.scm keystore.scm \
+#           cookie.scm sqltbl.scm
+# 	csc stmlrun.scm
+
+$(TARGDIR)/stmlrun : stmlrun stml2.so
+	echo "NOTE: CSC_OPTIONS='-C \"-fPIC\"' make"
+	install stmlrun $(TARGDIR)
+	chmod a+rx $(TARGDIR)/stmlrun
+
+$(TARGDIR)/modules :
+	mkdir -p $(TARGDIR)/modules
+
+$(MODULES) : $(SOFILES) $(TARGDIR)/modules
+	cp $< $@
+
+stmlrun : $(OFILES) stmlrun.scm requirements.scm stmlcommon.scm
+	csc $(CSCOPTS) $(OFILES) stmlrun.scm -o stmlrun
+
+stml.so : stmlmodule.so
+	cp stmlmodule.so stml.so
+
+stmlmodule.so : $(OFILES) stmlmodule.scm requirements.scm stmlcommon.scm
+	csc $(CSCOPTS) $(OFILES) -s stmlmodule.scm
+
+# logging currently relies on this
+#
+$(LOGDIR) :
+	mkdir -p $(LOGDIR)
+	chmod a+rwx $(LOGDIR)
+
+test: kiatoa.db cookie.so
+	echo '(exit)'| csi -q  ./tests/test.scm 
+
+# modules
+#
+%.so : %.scm
+	csc $(CSCOPTS) -I modules/* -s $<
+
+%.o : %.scm
+	csc $(CSCOPTS) -c $<
+
+# Cookie is a special case for now. Make a loadable so for test
+# Complile it in by include (see dependencies above).
+cookie.so : cookie.scm
+	csc i$(CSCOPTS) -s cookie.scm
+
+clean :
+	rm -f doc/*~ modules/*/*.so *.import.scm *.import.so *.o *.so *~
+
+# $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm
+# 	chicken $< -output-file $@
+# 
+# 
+# $(OFILES): src/%.o: src/%.c
+# 	gcc -c $< `chicken-config -cflags` -o $@
+# 
+# $(src_code): %: src/%.o src/laedlib.o src/layobj.o
+# 	gcc src/$*.o src/laedlib.o src/layobj.o -o $* `chicken-config -libs`
+# 

ADDED   stml2/README
Index: stml2/README
==================================================================
--- /dev/null
+++ stml2/README
@@ -0,0 +1,1 @@
+This is the stml, scheme based cgi application framework. 

ADDED   stml2/TODO
Index: stml2/TODO
==================================================================
--- /dev/null
+++ stml2/TODO
@@ -0,0 +1,22 @@
+1. Documentation. 
+      multiple apps in same cgi dir
+      compilation of models for speed and code protection
+      tricks
+2. Hierarchial pages. Currently pages can be hierarchial but the control.scm 
+   doesn't get called at the right time. 
+3. For sqlite3 usage put session into own db?
+4. A mechanism for sharing variables better between control and view
+   would be good.
+   Perhaps:
+     (let ()
+       (load control)
+       (load view))
+5. Change all the "included" files to be seperately compiled units
+   and adj. makefile accordingly. This would speed up compilation
+   when changes are isolated to one or two files.
+6. The dbi interface needs a simple config mecanism alternative to
+   the current list of pairs which is hard to use on the fly. 
+   Something like the perl:
+     "dbi:host:port:user:password"
+
+I'm sure there is more ...

ADDED   stml2/cookie.scm
Index: stml2/cookie.scm
==================================================================
--- /dev/null
+++ stml2/cookie.scm
@@ -0,0 +1,264 @@
+;;;
+;;; cookie.scm - parse and construct http state information
+;;;  
+;;;   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
+;;;   
+;;;   Redistribution and use in source and binary forms, with or without
+;;;   modification, are permitted provided that the following conditions
+;;;   are met:
+;;;   
+;;;   1. Redistributions of source code must retain the above copyright
+;;;      notice, this list of conditions and the following disclaimer.
+;;;  
+;;;   2. Redistributions in binary form must reproduce the above copyright
+;;;      notice, this list of conditions and the following disclaimer in the
+;;;      documentation and/or other materials provided with the distribution.
+;;;  
+;;;   3. Neither the name of the authors nor the names of its contributors
+;;;      may be used to endorse or promote products derived from this
+;;;      software without specific prior written permission.
+;;;  
+;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;  
+;;;  Ported to Chicken by Reed Sheridan
+;;;
+
+;; Parser and constructor of http "Cookies" defined in
+;; RFC 2965 HTTP state managemnet mechanism
+;;   <ftp://ftp.isi.edu/in-notes/rfc2965.txt>
+;; See also
+;; RFC 2964 Use of HTTP state management
+;;   <ftp://ftp.isi.edu/in-notes/rfc2964.txt>
+;; The parser also supports the old Netscape spec
+;;   <http://www.netscape.com/newsref/std/cookie_spec.html>
+
+;; (declare (unit cookie))
+
+(module cookie
+    *
+
+(import chicken scheme data-structures extras srfi-13 ports posix)
+  
+(require-extension srfi-1 srfi-13 srfi-14 regex)
+;; (use  srfi-1 srfi-13 srfi-14 regex)
+;; (declare (export parse-cookie-string construct-cookie-string))
+
+;; #>
+;; #include <time.h>
+;; <#
+;; 
+;; (define fmt-time
+;;   (foreign-lambda* c-string ((long secs_since_epoch))
+;;     "static char buf[256];"
+;;     "time_t t = (time_t) secs_since_epoch;"
+;;     "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
+;;     "return(buf);"))
+
+
+(define (fmt-time seconds)
+   (time->string (seconds->utc-time seconds) "%D"))
+
+ ;; utility fn.  breaks  ``attr=value;attr=value ... '' into alist.
+ ;; version is a cookie version.  if version>0, we allow comma as the
+ ;; delimiter as well as semicolon.
+ (define (parse-av-pairs input version)
+   (define attr-regexp
+     (if (= version 0)
+         (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
+         (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
+   (define attr-delim
+     (if (= version 0) #\; (char-set #\, #\\ #\;)))
+   
+   (define (read-attr input r)
+     (cond ((string-null? input) (reverse! r))
+           ((string-search attr-regexp input)
+            => (lambda (m)
+                 (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
+ 		      (string-prefix? "=" delimiter))
+                     (let ((attr (second m))
+                           (rest (string-search-after attr-regexp input)))
+                       (if (string-prefix? "\"" rest)
+                           (read-token-quoted attr (string-drop rest 1) r)
+                           (read-token attr rest r)))
+                     (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
+                                (alist-cons (second m) #f r)))))
+           (else
+            ;; the input is broken; for now, we ignore the rest.
+            (reverse! r))))
+   (define (read-token attr input r)
+     (cond ((string-index input attr-delim)
+            => (lambda (i)
+                 (read-attr (string-drop input (+ i 1))
+                            (alist-cons attr
+ 				       (string-trim-right (string-take input i))
+ 				       r))))
+           (else
+            (reverse! (alist-cons attr (string-trim-right input) r)))))
+   (define (read-token-quoted attr input r)
+     (let loop ((input input)
+                (partial '()))
+       (cond ((string-index input (char-set #\\ #\"))
+              => (lambda (i)
+                   (let ((c (string-ref input i)))
+                     (if (char=? c #\\)
+                         (if (< (string-length input) (+ i 1))
+                             (error-unterminated attr)
+                             (loop (string-drop input (+ i 2))
+                                   (cons* (string (string-ref input (+ i 1)))
+                                          (string-take input i)
+                                          partial)))
+                         (read-attr (string-drop input (+ i 1))
+                                    (alist-cons attr
+ 					       (string-concatenate-reverse
+ 						(cons (string-take input i)
+ 						      partial))
+ 					       r))))))
+             (else (error-unterminated attr)))))
+   (define (error-unterminated attr)
+     (error "Unterminated quoted value given for attribute" attr))
+ 
+   (read-attr input '()))
+ 
+ ;; Parses the header value of "Cookie" request header.
+ ;; If cookie version is known by "Cookie2" request header, it should
+ ;; be passed to version (as integer).  Otherwise, it figures out
+ ;; the cookie version from input.
+ ;;
+ ;; Returns the following format.
+ ;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
+ ;;    ...)
+ 
+ (define (parse-cookie-string input #!optional version)
+   (let ((ver (cond ((integer? version) version)
+                    ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
+                     => (lambda (m)
+                          (string->number (cadr m))))
+                    (else 0))))
+     (let loop ((av-pairs (parse-av-pairs input ver))
+                (r '())
+                (current '()))
+       (cond ((null? av-pairs)
+              (if (null? current)
+                  (reverse r)
+                  (reverse (cons (reverse current) r))))
+             ((string-ci=? "$path" (caar av-pairs))
+              (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
+             ((string-ci=? "$domain" (caar av-pairs))
+              (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
+             ((string-ci=? "$port" (caar av-pairs))
+              (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
+             (else
+              (if (null? current)
+                  (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
+                  (loop (cdr av-pairs)
+                        (cons (reverse current) r)
+                        (list (cdar av-pairs) (caar av-pairs)))))))))
+ 
+ ;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
+ ;; specs is the following format.
+ ;;
+ ;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
+ ;;                    [:discard <bool>] [:domain <domain>]
+ ;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
+ ;;                    [:secure <bool>] [:version <version>] [:expires <date>]
+ ;;    ) ...)
+ ;;
+ ;; Returns a list of cookie strings for each <name>=<value> pair.  In the
+ ;; ``new cookie'' implementation, you can join them by comma and send it
+ ;; at once with Set-cookie2 header.  For the old netscape protocol, you
+ ;; must send each of them by Set-cookie header.
+ 
+ 
+ (define (construct-cookie-string specs #!optional (version 1))
+   (map (lambda (spec) (construct-cookie-string-1 spec version))
+        specs))
+ 
+ (define (construct-cookie-string-1 spec ver)
+   (when (< (length spec) 2)
+     (error "bad cookie spec: at least <name> and <value> required" spec))
+   (let ((name (car spec))
+         (value (cadr spec)))
+     (let loop ((attr (cddr spec))
+                (r    (list (if value
+                                (string-append name "="
+                                               (quote-if-needed value))
+                                name))))
+       (define (next s) (loop (cddr attr) (cons s r)))
+       (define (ignore) (loop (cddr attr) r))
+       (cond
+        ((null? attr) (string-join (reverse r) ";"))
+        ((null? (cdr attr))
+         (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
+        ((eqv? comment: (car attr))
+         (if (> ver 0)
+ 	    (next (string-append "Comment=" (quote-if-needed (cadr attr))))
+             (ignore)))
+        ((eqv? comment-url: (car attr))
+         (if (> ver 0)
+             (next (string-append "CommentURL=" (quote-value (cadr attr))))
+             (ignore)))
+        ((eqv? discard: (car attr))
+         (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
+        ((eqv? domain: (car attr))
+         (next (string-append "Domain=" (cadr attr))))
+        ((eqv? max-age: (car attr))
+         (if (> ver 0)
+             (next (sprintf "Max-Age=~a" (cadr attr)))
+             (ignore)))
+        ((eqv? path: (car attr))
+         (next (string-append "Path=" (quote-if-needed (cadr attr)))))
+        ((eqv? port: (car attr))
+         (if (> ver 0)
+             (next (string-append "Port=" (quote-value (cadr attr))))
+             (ignore)))
+        ((eqv? secure: (car attr))
+         (if (cadr attr) (next "Secure") (ignore)))
+        ((eqv? version: (car attr))
+         (if (> ver 0)
+             (next (sprintf "Version=~a" (cadr attr)))
+             (ignore)))
+        ((eqv? expires: (car attr))
+         (if (> ver 0)
+             (ignore)
+             (next (make-expires-attr (cadr attr)))))
+        (else (error "Unknown cookie attribute" (car attr))))
+       ))
+   )
+ 
+ 
+ ;; (define (quote-value value)
+ ;;   (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
+ 
+ (define (quote-value value)
+   (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
+ 
+ (define quote-if-needed
+   (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
+     (lambda (value)
+       (if (string-search rx value)
+ 	  (quote-value value)
+ 	  value))))
+ 
+ (define (make-expires-attr time)
+   (sprintf "Expires=~a"
+ 	   (if (number? time)
+ 	       (fmt-time time)
+ 	       time)))
+ 
+ ;;;; Added support functions from my utils, split this out
+ 
+ (define (string-search-after r s #!optional (start 0))
+   (and-let* ((match-indices (string-search-positions r s start))
+ 	     (right-match (second (first match-indices))))
+     (substring s right-match)))
+)

ADDED   stml2/doc/Makefile
Index: stml2/doc/Makefile
==================================================================
--- /dev/null
+++ stml2/doc/Makefile
@@ -0,0 +1,7 @@
+all : manual.pdf web-page.html
+
+manual.pdf : manual.txt
+	a2x -a toc -f pdf manual.txt
+	# asciidoc -a toc plan.txt
+	a2x -f chunked -a toc manual.txt
+

ADDED   stml2/doc/howto.txt
Index: stml2/doc/howto.txt
==================================================================
--- /dev/null
+++ stml2/doc/howto.txt
@@ -0,0 +1,177 @@
+Gotchas!
+=======
+
+All items for a page *must* be part of a list!
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+   OK:     (list (function1 param1)(function2 param2))
+   NOT OK: (begin (function1 param1)(function2 param2))
+
+
+Various components
+~~~~~~~~~~~~~~~~~~
+
+The URL:
+
+http://the.domain.com/pagename/p1/p2/p3?param1=value1
+
+(s:get-page-params) => '("p1" "p2")
+
+(s:get-param 'param1) => "value1"
+(s:get-param 'param1 'number) => number or #f 
+
+NOTE: it is often practical to use the generic (s:get-inp ...) which
+      will first look for the POST input variable and then fall back
+      to the GET param. This allows one to switch back and forth
+      between GET and POST during development without changing the code.
+
+(s:get-inp 'param1)  ;; trys to find input by name of param1, followed by trying get-param
+
+Create a link.
+~~~~~~~~~~~~~~
+
+(s:a name 'href 
+    (s:link-to "pagename/blah" ""))
+
+Call current page with new param
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In view.scm:
+
+ (s:center "[" (s:a 'href (s:link-to "polls"
+                           'id
+                            (begin
+                              (poll:poll 'fill-polls)
+                              (poll:poll 'get-next-poll)))
+                          "Go to the next poll")  "]")
+
+In control.scm:
+
+(let ((poll-id (s:get-param 'id)))
+ ;; do stuff based on poll-id
+
+
+Call an action on a specific page
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ (s:a 'href (s:link-to "polls" 'id (poll:poll 'get 'id) 
+			       'action "poll.edit")
+            "Suggest changes to this poll")
+
+ NOT TRUE! This calls fuction poll.edit (should be in control.scm). Parameter set is 'id to a poll num.
+
+
+A complex link example
+~~~~~~~~~~~~~~~~~~~~~~
+
+(s:a "Reply" 'href (s:link-to (s:current-page) 
+	           'action "discussion.reply" ;; <page>.<action>
+	           'reply_to (number->string (hash-table-ref row 'posts.id)) 
+	           'id (s:get "discussion.parent_object_id")) "reply")
+
+;; use (s:get-param to get the 'id, or 'reply_to values
+
+
+Get and set a session var
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(s:session-var-get "keyname")
+(s:session-var-get "keyname" 'number) 
+(s:session-var-set! "keyname" "value")
+
+5.1 Page local vars
+
+(s:set! key val)
+(s:get key)
+
+
+make a selection drop down
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+;; items is a hierarchial alist
+;; ( (label1 value1 dispval1 #t) ;; <== this one is selected
+;;   (label2 (label3 value2 dispval2)
+;;           (label4 value3 dispval3)))
+
+In view.scm: 
+
+;;                                   Label   Value visible-str selected
+(s:select '(("World" 0)("Country" 1)("State" 2     "The state" #t       )("Town/City" 3)) 'name 'scope)
+
+Visible str will be shown if provided. Selected will set that entry to pre-selected.
+
+To select a specific entry:
+
+(s:select '(("World" 0 "world" #f)("Country" 1 "country" #t)("State" 2 "state" #f)("Town/City" 3 "town" #f)) 'name 'scope)
+
+In control.scm:
+
+(let ((scope     (s:get-input 'scope))
+      (scope-num (s:get-input 'scope 'number))) ;; 'number, 'raw or 'escaped
+  ....
+
+The optional fourth entry sets that item as selected if true
+
+Simple error reporting
+~~~~~~~~~~~~~~~~~~~~~~
+
+In control.scm:
+(s:set-err "You must provide an email address")
+
+In view.scm:
+(s:get-err s:err-font)
+
+Or:
+(s:get-err (lambda (x)(s:err-font x (s:br))))
+
+
+Sharing data between pages
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+NOTE: This data is *not* preserved between cgi calls.
+
+;; In first page called
+(s:shared-set! "somekey" somevalue)
+
+;; In a page called later
+(let ((dat (s:shared-get "somekey")))
+  ( .... ))
+
+
+Misc useful stuff
+~~~~~~~~~~~~~~~~~
+
+  i. Lazy/safe string->number 
+
+(s:any->number val)
+
+  ii. Random string
+
+(session:make-rand-string len)
+
+ iii. string to number for pgint
+ 
+(s:any->pgint val)
+
+
+Forms and input
+~~~~~~~~~~~~~~~
+
+(s:form 'action "login.login" 'method "post"
+   (s:input-preserve 'type "text" 'name "email-address" 'size "16" 'maxlength "30")
+   (s:input 'type "submit"   'name "form-name" 'value "login"))
+
+(s:get-input 'email-address)
+
+To preserve the input simply do a set of the value on the 'name field:
+(s:set! "email-address" "matt@kiatoa.com")
+
+Radio buttons:
+
+	(s:div 'class "col_3"
+		       (s:input 'type "radio" 'id "group-type1" 'name "group-type" 'value "private" 'checked "checked")
+		       (s:label 'for "group-type1" 'class "inline" "Private")
+		       (s:input 'type "radio" 'id "group-type2" 'name "group-type" 'value "public")
+		       (s:label 'for "group-type2" 'class "inline" "Public"))
+
+       (s:get-input 'group-type) ==> returns private or public depending on which is selected.

ADDED   stml2/doc/manual.txt
Index: stml2/doc/manual.txt
==================================================================
--- /dev/null
+++ stml2/doc/manual.txt
@@ -0,0 +1,56 @@
+STML User Manual
+================
+Matt Welland <matt@kiatoa.com>
+v1.0, 2012-6
+
+NOT DONE YET! :( sorry.
+
+:numbered!:
+[abstract]
+Example Abstract
+----------------
+
+Yada about stml
+
+:numbered:
+
+User Data Specification
+-----------------------
+
+.User Data
+[width="100%",options="header",cols="<s,2m,2e,2e,2e",frame="topbot"]
+|==============================
+| Field            | Field Template    |Short form| Example                              | Description
+| Likes            | :likes            |:l        | :likes rock, jazz, blues             | List of things liked, used to narrow down music liked etc.
+|==============================
+
+.Example stuff
+-----------------------------
+stuff eh
+-----------------------------
+
+// -----------------------
+
+<<<<<<<<<<<<<<<<<
+
+Plan
+----
+
+Today
+~~~~~
+
+. Nothing scheduled
+
+Done Stuff
+~~~~~~~~~~
+
+Phase 3
+~~~~~~~
+
+. Error printing with debug levels
+. Complete the manual
+. Get working with Chromium, test with Internet Explorer and other browsers
+
+Notes
+-----
+

ADDED   stml2/doc/stml-snapshot.png
Index: stml2/doc/stml-snapshot.png
==================================================================
--- /dev/null
+++ stml2/doc/stml-snapshot.png
cannot compute difference between binary files

ADDED   stml2/example/Makefile
Index: stml2/example/Makefile
==================================================================
--- /dev/null
+++ stml2/example/Makefile
@@ -0,0 +1,26 @@
+# Copyright 2007-2008, Matthew Welland.
+# 
+#  This program is made available under the GNU GPL version 2.0 or
+#  greater. See the accompanying file COPYING for details.
+# 
+#  This program is distributed WITHOUT ANY WARRANTY; without even the
+#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+#  PURPOSE.
+
+# Uncomment and fix path if you want your models to be compiled
+#
+MODELS := $(wildcard models/*scm)
+SOFILES := $(patsubst %.scm,%.so,$(MODELS))
+
+
+# all : $(SOFILES)
+
+# If you want compiled models uncomment the following
+#
+# $(SOFILES) : %.so: %.scm
+#	csc -s $<
+
+test: # $(SOFILES)
+	echo '(exit)'| csi -q  ./tests/test.scm 
+
+# cgi-util proplist cgi-util cookie

ADDED   stml2/example/POLICY
Index: stml2/example/POLICY
==================================================================
--- /dev/null
+++ stml2/example/POLICY

ADDED   stml2/example/README
Index: stml2/example/README
==================================================================
--- /dev/null
+++ stml2/example/README
@@ -0,0 +1,3 @@
+This is an (unfinished) example application. 
+
+To see it live go to: www.approvalvote.org

ADDED   stml2/example/TODO
Index: stml2/example/TODO
==================================================================
--- /dev/null
+++ stml2/example/TODO
@@ -0,0 +1,2 @@
+
+

ADDED   stml2/example/db/db-tweaks.sql
Index: stml2/example/db/db-tweaks.sql
==================================================================
--- /dev/null
+++ stml2/example/db/db-tweaks.sql
@@ -0,0 +1,172 @@
+>-- create table polls(id serial not null,poll_type text,title text,description text,poll_state text);
+-- create table poll_categories(id serial not null,poll_id integer,description text);
+-- create table poll_votes(id serial not null,period integer,poll_type text,poll_category text,voter_group integer, votes integer);
+
+-- create table vote_items (id serial primary key,type integer,item_id integer,item_level text,town_votes integer,state_votes integer,country_votes integer,world_votes integer);
+-- 
+-- alter table vote_items alter column town_votes set default 0;
+-- alter table vote_items alter column state_votes set default 0;
+-- alter table vote_items alter column country_votes set default 0;
+-- alter table vote_items alter column world_votes set default 0;
+-- 
+-- alter table poll_items add column class_0 int4;
+-- alter table poll_items add column class_1 int4;
+-- alter table poll_items add column class_2 int4;
+-- 
+-- alter table poll_items add column classp_0 int4;
+-- alter table poll_items add column classp_1 int4;
+-- alter table poll_items add column classp_2 int4;
+-- 
+-- alter table poll_items alter column classp_0 set default 0;
+-- alter table poll_items alter column classp_1 set default 0;
+-- alter table poll_items alter column classp_2 set default 0;
+-- 
+-- alter table poll_items add column suggestor int4;
+-- 
+-- alter table poll_items alter column class_0 set default 0;
+-- alter table poll_items alter column class_1 set default 0;
+-- alter table poll_items alter column class_2 set default 0;
+-- 
+-- alter table poll_items add column status int4;
+-- alter table poll_items alter column status set default 0;
+
+-- alter table poll_items add column url text;
+-- alter table vote_items add column submit_date date;
+-- alter table poll_items add column submit_date date;
+
+-- alter table people add column pt_balance int4;
+-- alter table people alter column pt_balance set default 0;
+
+-- alter table people add column cert_date date;
+-- alter table people alter column pt_balance set default 0;
+
+-- create table pt_transactions (id serial not null,from_id integer,to_id integer,amount integer,transaction_time timestamp);
+-- alter table pt_transactions alter column amount set default 0;
+
+-- alter table classifieds add column points int4;
+-- alter table classifieds alter column points set default 0;
+
+-- alter table pt_transactions add column comment text;
+-- alter table pt_transactions add column comment text;
+
+-- create table temp_key(id serial not null,key  text,sent_date date);
+-- alter table people add column lastlogin timestamp;
+
+-- create table pictures(id serial not null,owner integer,size integer,name  text,type text,md5sum text,uploaded date);
+-- alter table pictures add column status text;
+
+-- create table pic_allocation(id serial not null,picnum integer,used_by integer);
+
+-- alter table posts add column url text;
+-- alter table posts add column blurb text;
+
+insert into subjects (subjectid,subject,item_type,description) values('VoSp','Spanish','lang','Basic Spanish Vocabulary');
+insert into subjects (subjectid,subject,item_type,description) values('HoMe','Homeopathy','Info','Basic Homeopathy');
+
+alter table items add column group_name text;
+alter table items add column state int4;
+
+create table sessions (id serial not null,session_key text);
+create table session_vars (id serial not null,session_id integer,page text,key text,value text);
+
+alter table poll_items add column num_voted  integer default 0;
+alter table poll_items add column vote_tot   integer default 0;
+alter table poll_items add column item_votes integer default 0;
+
+-- remember ballots are used for many things other than polls!!!!!!!!
+create table ballots (id serial not null, item_id integer, class_id integer, votes integer, type_id integer);
+create table ballot_classes (id serial not null, name text, pts_per_vote integer); -- join with ballots to sum up votes (pts are really votes)
+insert into ballot_classes values (0,'',1);
+insert into ballot_classes values (1,'',2);
+insert into ballot_classes values (2,'',10);
+insert into ballot_classes values (3,'',20);
+insert into ballot_classes values (4,'',45);
+insert into ballot_classes values (5,'',90);
+insert into ballot_classes values (6,'',105);
+insert into ballot_classes values (7,'',145);
+insert into ballot_classes values (8,'',205);
+insert into ballot_classes values (9,'',245);
+
+create table ballot_types (id serial not null, name text);                         -- poll plurality = 0, poll approval = 1
+insert into ballot_types (id,name) values (0,'poll plurality');
+insert into ballot_types (id,name) values (1,'poll approval');
+
+alter table voted add column type_id integer;
+alter table voted add column id serial not null;
+create table voted_types (id serial not null, name text);
+insert into voted_types (id, name) values (0, 'poll vote');                -- YES!!! WE DO NEED voted_types SEPERATE FROM ballot_types
+insert into voted_types (id, name) values (1, 'council vote for poll');    -- yes, they are similar but I think combining them would be
+insert into voted_types (id, name) values (2, 'council vote for item');    -- painful.
+insert into voted_types (id, name) values (3, 'council vote for story');
+
+alter table people add column email_validated integer default 0;  -- has email been validated? Hmmm... should this be a seperate table
+alter table people add column grade integer default 0;            -- 
+
+alter table voted add column grade integer default 0;
+
+-- grade
+-- 
+-- 0 - no status (refusing cookies)
+-- 1 - has session
+-- 2 - logged in, has user id
+-- 3 - email validated
+-- 4 ++ add 1 for every 20 points of cert_level
+
+alter table poll_items drop column class_0  ;
+alter table poll_items drop column class_1  ;
+alter table poll_items drop column class_2  ;
+alter table poll_items drop column classp_0 ;
+alter table poll_items drop column classp_1 ;
+alter table poll_items drop column classp_2 ;
+alter table poll_items drop column votes    ;
+alter table poll_items drop column vote_tot ;
+alter table poll_items drop column num_voted;
+
+alter table poll_items add column a_vote_tot integer default 0; -- approval  votes total
+alter table poll_items add column p_vote_tot integer default 0; -- plurality votes total
+
+alter table people alter column num set default 0;
+alter table polls add column discussion_id integer default 0;
+
+create table poll_status (id serial not null, name text);
+insert into poll_status (id,name) values (0, 'In queue'); -- just posted and in queue
+insert into poll_status (id,name) values (1, 'Posted');   -- published to discussion
+
+-- fix default cert_level
+alter table people alter column cert_level set default 0;
+update people set cert_level=0 where cert_level is NULL;
+
+create table discussions (id serial not null,type_id integer,activity_state integer);
+update posts set thread=id where parent=0; -- was this necessary?
+
+insert into discussions select id,0,1 from posts where parent=0;
+
+-- ======================================================================
+-- New council stuff
+--======================================================================
+
+create table councils (id serial not null, name text, discussion_id integer default 0);
+alter table  council_members add column join_date date;
+
+-- DONE ON TANG UP TO HERE
+
+--======================================================================
+-- New locations table
+--======================================================================
+
+create table locations
+         (id serial not null, parent_id integer default 0, 
+          council_id integer,nick text, fullname text, 
+          level_id integer, blurb text, pict_id integer);
+insert into locations(council_id,nick,fullname,level_id,blurb)
+    values(0,'','World',0,'Our beloved Planet Earth');
+insert into locations(council_id,nick,fullname,level_id,blurb)
+    values(1,'us','United States',1,'The Land of the Free');
+insert into locations(parent_id,council_id,nick,fullname,level_id,blurb)
+    values(1,2,'az','Arizona',2,'It''s a dry heat');
+
+drop table location;
+drop table towns;
+drop table states;
+drop table neighborhoods ;
+drop table countries;

ADDED   stml2/example/db/dump_db
Index: stml2/example/db/dump_db
==================================================================
--- /dev/null
+++ stml2/example/db/dump_db
@@ -0,0 +1,1 @@
+pg_dump -d kiatoa | grep -v 'INSERT INTO session_vars' | grep -v 'INSERT INTO sessions' > Kiatoa.sql

ADDED   stml2/example/docs/Setup-notes.txt
Index: stml2/example/docs/Setup-notes.txt
==================================================================
--- /dev/null
+++ stml2/example/docs/Setup-notes.txt
@@ -0,0 +1,15 @@
+1) add:
+
+host    all         all         192.168.1.1/32        password
+
+to the bottom of /etc/postgresql/8.2/main/pg_hba.conf
+
+2)
+
+ln -s /home/matt/kiatoa/kiatoa-scm/kiatoa /var/www
+
+3) copy/update the stml.conf file
+
+sudo cp stml.conf.template /usr/lib/cgi-bin/.stml.conf
+sudo vi /usr/lib/cgi-bin/.stml.conf
+

ADDED   stml2/example/docs/comments.txt
Index: stml2/example/docs/comments.txt
==================================================================
--- /dev/null
+++ stml2/example/docs/comments.txt
@@ -0,0 +1,20 @@
+
+If we had any at all of the alternative voting ideas like instant runoff, Condorcet, any of them, I think it might make the whole process better
+
+My thought was to get people familiar with approval voting, then get people to pledge only to vote for a candidate if that candidate supported approval voting. I put the beginings of a site together here: http://approvalvote.org but stopped working on it because I decided not to push the idea for this election. Morally, in my opinion, letting the neocons in for another term is unacceptable, I suspect (but don't know) that McCain is a participant of the neocon movement. Since these elections can hinge on a few hundreds of votes I thought it wasn't worth even the infintesimal risk of any activity that would get people thinking about the alternatives to the top two pulling votes away from Obama. I did think of pushing the idea in venues dominated by interest in Ron Paul but there was some beer in the fridge and, well, you can guess the rest of that story.
+
+Although the current implementation needs major rework I do think the idea has potential.
+
+   1. Get people to experience plurality vs approval voting. IMHO once you've tried it going back to plurality is actually quite uncomfortable.
+   2. Get people to pledge to vote only for candidates that support approval voting.
+   3. Get candidates to address approval voting.
+
+Now why approval and not Condorcet, range, IRV or any one of the dozens of other voting techniques?
+
+   1. Approval is 100% doable using existing election machines
+   2. Approval is highly resistant to any meaningful strategic voting.
+   3. Approval is easy for the end users. Go try doing some condorcet or IRV ranked voting. It is really tedious.
+   4. IRV is *worse* than Plurality in its vunerablity to strategic voting.
+   5. Condorcet is too hard to grok for most folks. I knew once how it worked but couldn't explain it to someone right now for the life of me.
+
+In short the marginal improvement of the more complex voting solutions over approval doesn't buy much.

ADDED   stml2/example/example/layout.css
Index: stml2/example/example/layout.css
==================================================================
--- /dev/null
+++ stml2/example/example/layout.css
@@ -0,0 +1,244 @@
+
+/*-General-----------------------------------------------*/
+
+html, body {
+	margin:0px;
+	padding:0px;
+}
+
+form {
+	display:inline;
+	margin:0px;
+	padding:0px;
+}
+
+a img {
+	border:none;
+	margin:0px;
+	padding:0px;
+}
+
+h1, h2, h3, h4, h5, h6, p, div {
+	margin:0px;
+	padding:0px;
+}
+
+.right {
+	float:right;
+}
+
+.left{
+	float:left;
+}
+
+/*-Main Layout-------------------------------------------*/
+
+#overall {
+	margin:5px 12px 0px 12px;
+	padding:0px;
+}
+
+/*-Header-------------*/
+
+.header {
+	position:relative;
+	height:90px;
+}
+
+/*-Footer-------------*/
+
+.footer {
+	padding:40px 0px 0px 0px;
+	position:relative;
+	clear:both;
+}
+
+/*-Content Area-------*/
+
+.content {
+	width:100%;
+}
+
+/*-Left Column--------*/
+
+.leftcolumn	{
+  float:left;
+  width:145px;
+  margin:5px;
+}
+
+.leftcolumn .node {
+	margin:0px 0px 15px 0px;
+}
+
+.leftcolumn .node h1 {
+	padding:0px 0px 0px 3px;
+}
+
+.leftcolumn .node ul {
+	margin:0px;
+	padding:0px;
+}
+
+.leftcolumn .node li {
+	display:block;
+	padding:0px 0px 0px 3px;
+	margin:0px;
+}
+
+.leftcolumn .node li.more{
+	padding:0px 0px 0px 6px;
+}
+
+/*-Center Column------*/
+
+.centercolumn {
+        margin: 5px;
+	margin-left:152px;
+        margin-right:200px;
+	font-family:"\"}\"";
+	font-family:inherit;
+}
+
+.centercolumn .node h1 {
+	padding: 0px 0px 0px 13px;
+}
+
+.centercolumn .node h4 {
+	margin: 15px 0px 10px 0px;
+}
+
+.centercolumn .node p {
+	margin: 0px 0px 10px 0px; */
+	padding: 0px 0px 0px 0px;
+}  /* this seemed not to work */
+
+.posts_0  {
+	margin: 0px 0px 0px 0px;
+}
+
+.posts_1  {
+	margin: 0px 0px 0px 20px;
+}
+
+.posts_2  {
+	margin: 0px 0px 0px 40px;
+}
+
+.posts_3  {
+	margin: 0px 0px 0px 60px;
+}
+
+.posts_4  {
+	margin: 0px 0px 0px 80px;
+}
+
+.posts_5  {
+	margin: 0px 0px 0px 100px;
+}
+
+.posts_6  {
+	margin: 0px 0px 0px 120px;
+}
+
+.posts_7  {
+	margin: 0px 0px 0px 140px;
+}
+
+.posts_8  {
+	margin: 0px 0px 0px 160px;
+}
+
+.posts_9  {
+	margin: 0px 0px 0px 160px;
+}
+
+.posts_10  {
+	margin: 0px 0px 0px 180px;
+}
+
+/*-Right Column-------*/
+
+.rightcolumn {
+	float:right;
+        width:190px;
+	margin:5px 5px 0px 0px;
+}
+
+* html .rightcolumn {
+	margin:3px 3px 3px 3px;
+}
+
+body>div .rightcolumn {
+	margin:0px 0px 0px 0px;
+}
+
+.rightcolumn .node {
+	margin:0px 0px 5px 0px;
+	padding:0px;
+}
+
+.rightcolumn .node h2 {
+	margin:3px 3px 3px 2px;
+}
+
+.rightcolumn .node ul {
+  list-style-position:inside;
+  margin:0px;
+  padding:1px;
+}
+
+.rightcolumn .node ul.none {
+	list-style-position:inside;
+}
+
+.rightcolumn .node ul.dot {
+	list-style-position:inside;
+}
+
+.rightcolumn .node ul.books {
+	list-style-position:outside;
+	margin:0px 0px 0px 35px;
+}
+
+.rightcolumn .node li {
+	padding:0px 0px 0px 3px;
+	margin:0px;
+}
+
+/*-Remaining layout--------------------------------------*/
+
+#title {
+	top: 0px;
+	left: 0px;
+	position: absolute;
+}
+
+#search {
+	float:left;
+	margin:0px 0px 0px 30px;
+}
+
+#randomquote {
+	float:right;
+	margin:0px 30px 0px 0px;
+}
+
+#copyright {
+	text-align:center;
+	padding:15px 0px 0px 0px;
+	margin:0px 0px 0px 0px;
+	clear:both;
+}
+
+#bottomNav {
+	text-align:center;
+	margin:0px 0px 20px 0px;
+	padding:0px;
+}
+
+#oldStuffNav {
+	font-weight:bold;
+	text-align:right;
+}
+

ADDED   stml2/example/example/markup.css
Index: stml2/example/example/markup.css
==================================================================
--- /dev/null
+++ stml2/example/example/markup.css
@@ -0,0 +1,299 @@
+/*-General-----------------------------------------------*/
+
+body {
+  background-color:#ffffff;
+  color:#0f0f0f;
+  font-family:serif;
+  font-weight:normal;
+  text-decoration:none; 
+/*  font-size:x-small; */
+  voice-family:"\"}\"";
+  voice-family:inherit;
+  font-size:small;
+}
+
+html>body {
+  font-size:small;
+}
+
+.strong {
+  font-weight:bold;
+}
+
+#red { 
+  color: #ff0000
+}
+
+/*-Main Markup-------------------------------------------*/
+
+#overall {
+  background-color: #ffffff;
+  color:#000000;
+}
+
+/*-Left Column--------*/
+
+.leftcolumn .node a {
+  color:#006666;
+  background-color:transparent;
+}
+
+.leftcolumn .node p {
+  font-size:1.2em;
+  font-weight:normal;
+}
+
+.leftcolumn .node h1 {
+  font-weight:normal;
+  font-size:1.2em;
+  color:#ffffff;
+  background-color:#000000; /* #005991;  #7f9bff #006666; */
+}
+
+.leftcolumn .node h1 a {
+  color:#ffffff;
+  background-color:transparent;
+}
+
+.leftcolumn .node h2 {
+  font-weight:bold;
+  font-size:.95em;
+}
+
+.leftcolumn .node ul {
+  list-style-type:none;
+}
+
+.leftcolumn .node li.more {
+  font-weight:bold;
+  font-size:.75em;
+}
+
+.leftcolumn .node li.selected {
+  font-weight:bold;
+  font-size:1.18em;
+  color:#000000;
+  background-color:#cccccc;
+}
+
+.leftcolumn .node li.selected a {
+  color:#000000;
+  background-color:transparent;
+}
+
+/*-Center Column for classifieds-*/
+
+.centercolumn .classifieds h1 { 
+  font-family:Arial, Helvetica, serif;
+  font-weight:bold;
+  font-size:1.38em;
+  color:#000000; /* ffffff; */
+  background: #5390b7; /* a6bcac; #0c1e0f; 043b0d; 1a6126; */
+}
+
+/*-Center Column------*/
+.centercolumn .node {
+  font-family:serif;
+}
+
+.centercolumn .node a {
+  color:#006666;
+  background-color:transparent;
+}
+
+.centercolumn .node h1 {
+  font-family:Arial, Helvetica, serif;
+  font-weight:bold;
+  font-size:1.38em;
+  color:#ffffff;
+  background:#000000; /* #005991; */
+} /* #006666 /* url('../images/slc.gif') no-repeat; */
+     
+.centercolumn .node h1 a {
+  color:#ffffff;
+  background-color:transparent;
+}
+
+.centercolumn .node h2 {
+  font-weight:bold;
+  font-size:1.18em;
+}
+
+.centercolumn .node h3 {
+  font-weight:bold;
+  font-size:.95em;
+}
+
+.centercolumn .node h4 {
+  font-weight:normal;
+  font-size:1.2em;
+}
+
+.centercolumn .node h4 a {
+  font-weight:bold;
+}
+
+.centercolumn .node p {
+  font-weight:normal;
+}
+
+.centercolumn .posts_0 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_1 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_2 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_3 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_4 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_5 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_6 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_7 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_8 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_9 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_10 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+/*-Right Column-------*/
+
+.rightcolumn .node {
+  color:#000000;
+  background-color:#cccccc;
+  font-family:serif;
+}
+
+.rightcolumn .node a {
+  color:#000000; /* #005991;  #006666; */
+  background-color:transparent;
+}
+
+.rightcolumn .node h1 {
+  font-family:Arial, Helvetica, serif;
+  font-weight:bold;
+  font-size:0.95em; /* 1.38em; */
+  color:#ffffff;
+  background-color: #000000; /* #005991;  #006666; */
+}
+
+.rightcolumn .node h1 a {
+  color:#ffffff;
+  background-color:transparent;
+}
+
+.rightcolumn .node h2 {
+  font-weight:bold;
+  font-size:.95em;
+}
+
+.rightcolumn .node ul.none {
+  list-style-type:none;
+}
+
+.rightcolumn .node ul.dot {
+  list-style-type:none;
+  /* list-style-image:url('../images/listdot.gif'); */
+}
+
+.rightcolumn .node ul.books {
+  list-style-type:disc;
+}
+
+/*-OSDN Navagation bar-----------------------------------*/
+
+#OSDNNavbar {
+  background-color:#999999;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#OSDNNavbar div#links {
+  background-color:#999999;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#OSDNNavbar a {
+  background-color: transparent;
+  color: #000000; /* #005991; /* #006666; */
+}
+
+/*-Remaining layout--------------------------------------*/
+
+#randomquote {
+  font-size:1.2em;
+  font-style:italic;
+}
+
+#copyright {
+  font-size:.75em;
+  font-family:Arial, Helvetica, serif;
+  background-color:transparent;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#copyright a {
+  background-color:transparent;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#bottomNav {
+  background-color:transparent;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#bottomNav a {
+  background-color:transparent;
+  color:#ffffff;
+}
+
+#oldStuffNav {
+  font-weight:bold;
+}
+

ADDED   stml2/example/models/candidate.scm
Index: stml2/example/models/candidate.scm
==================================================================
--- /dev/null
+++ stml2/example/models/candidate.scm
@@ -0,0 +1,67 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;; 
+;; models/candidates.scm
+;;
+
+(define (candidate:get-top n)
+  (dbi:get-rows 
+   (s:db) 
+   "SELECT DISTINCT id,name,url,party,desc,supports_av,date_added,score,pscore FROM candidates AS c ORDER BY score DESC LIMIT ?;" n))
+
+;; HERE !!!! getting vote counts... DONT'USE- SEE VOTED INSTEAD
+(define (candidate:get-votes candidates vote_type)
+  (let ((ids (map (lambda (c)(candidate:get-id c)) candidates)))
+    (dbi:get-rows (s:db)
+		  (conc
+		   "SELECT id,sum(votes*(1+score)) WHERE vote_date>"
+		   (- (current-time) (* 24 60 60 7)) ;; seven days
+		   " AND id IN "
+		   (apply conc (intersperse ids ","))))))
+		   
+(define (candidate:get-by-name name)
+  (dbi:get-one-row (s:db) "SELECT id,name,url,party,desc,supports_av,date_added,score,pscore FROM candidates WHERE name=?;" name))
+
+;; update an existing candidate or create if new
+(define (candidate:update dat)
+  (let* ((name   (candidate:get-name dat))
+	 (olddat (candidate:get-by-name name)))
+    (if olddat
+	(begin
+	  (dbi:exec (s:db) 
+		    "UPDATE candidates SET url=?,party=?,desc=?,supports_av=? WHERE name=?;"
+		    (candidate:get-url   dat)
+		    (candidate:get-party dat)
+		    (candidate:get-desc  dat)
+		    (candidate:get-supports-av dat)
+		    name)
+	  (candidate:get-by-name name))
+	(begin
+	  (dbi:exec (s:db)
+		    "INSERT INTO candidates (name,url,party,desc,supports_av) VALUES(?,?,?,?,?);"
+		    name
+		    (candidate:get-url   dat)
+		    (candidate:get-party dat)
+		    (candidate:get-desc  dat)
+		    (candidate:get-supports-av dat))
+	  (candidate:get-by-name name)))))
+
+
+(define (candidate:get-id           dat)(vector-ref dat 0)) 
+(define (candidate:get-name         dat)(vector-ref dat 1)) 
+(define (candidate:get-url          dat)(vector-ref dat 2))
+(define (candidate:get-party        dat)(vector-ref dat 3))
+(define (candidate:get-desc         dat)(vector-ref dat 4))
+(define (candidate:get-supports-av  dat)(vector-ref dat 5))
+(define (candidate:get-date-added   dat)(vector-ref dat 6))
+(define (candidate:get-score        dat)(vector-ref dat 7))
+(define (candidate:get-pscore       dat)(vector-ref dat 8))
+
+(define (candidate:set-id!          dat val)(vector-set! dat 0 val)) 
+(define (candidate:set-name!        dat val)(vector-set! dat 1 val)) 
+(define (candidate:set-url!         dat val)(vector-set! dat 2 val))
+(define (candidate:set-party!       dat val)(vector-set! dat 3 val))
+(define (candidate:set-desc!        dat val)(vector-set! dat 4 val))
+(define (candidate:set-supports-av! dat val)(vector-set! dat 5 val))
+(define (candidate:set-date-added!  dat val)(vector-set! dat 6 val))
+(define (candidate:set-score!       dat val)(vector-set! dat 7 val))
+

ADDED   stml2/example/models/maint.scm
Index: stml2/example/models/maint.scm
==================================================================
--- /dev/null
+++ stml2/example/models/maint.scm
@@ -0,0 +1,57 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;; 
+;; maint/control.scm
+;;
+
+;; evolve your schema here!
+;; Add entries and then go to http:/your-url/maint
+;;
+;; first make maint:db available as a global
+;;
+(define maint:db (slot-ref s:session 'conn))
+
+;; you can store lambda's or SQL queries to be exectuted
+;; be extremely careful - especially with the lambda's!!!
+(define maint:schema-updates
+  (list (list 1 (lambda ()(keystore:set! maint:db "MAINTPW" "Abc123")))
+	(list 2 "CREATE TABLE people (id INTEGER PRIMARY KEY,name TEXT DEFAULT '',nick TEXT DEFAULT '',email TEXT,password TEXT,status INTEGER DEFAULT 0,score INTEGER DEFAULT 0,location_id INTEGER DEFAULT 0);")
+	(list 3 "CREATE TABLE candidates (id INTEGER PRIMARY KEY,name TEXT DEFAULT '',url TEXT DEFAULT '',party TEXT DEFAULT '',desc TEXT DEFAULT '',supports_av INTEGER,date_added DATETIME,score INTEGER DEFAULT 0);")
+	(list 4 "CREATE TABLE votes (id INTEGER PRIMARY KEY,candidate_id INTEGER,vote_date INTEGER,votes INTEGER,score INTEGER,vote_type INTEGER);")
+	(list 5 "CREATE TABLE voted (id INTEGER PRIMARY KEY,user_id INTEGER,vote_date INTEGER,score INTEGER);")
+	;; location_type can be: city, town, state, region, county etc
+	(list 6 "CREATE TABLE locations (id INTEGER PRIMARY KEY,parent_id INTEGER,codename TEXT,name TEXT,location_type TEXT,desc TEXT,url TEXT);")
+	(list 7 "INSERT INTO locations VALUES(0,0,'ea','earth','planet','Home Planet of Humans','');")
+	(list 8 "ALTER TABLE candidates ADD column pscore INTEGER DEFAULT 0;")
+	))
+
+(define (maint:am-i-maint?)
+  ;; Enter a maint password - return #t if good
+  #t)
+
+(define (maint:update-tables)
+  (let* ((db       (slot-ref s:session 'conn))
+	 (curr-ver (s:any->number (keystore:get db "SCHEMA-VERSION"))))
+    (if (not curr-ver)
+	(begin
+	  (keystore:set! (slot-ref s:session 'conn) "SCHEMA-VERSION" 0)
+	  (set! curr-ver 0)))
+    (if (null? maint:schema-updates)
+	(keystore:set! (slot-ref s:session 'conn) "SCHEMA-VERSION" 0)
+	(let loop ((hed (car  maint:schema-updates))
+		   (tal (cdr maint:schema-updates))
+		   (highest-ver 0))
+	  (if (< (length hed) 2)
+	      (s:log "Malformed maint:schema-updates table in maint/control.scm")
+	      (let ((ver (car hed))
+		    (act (cadr hed)))
+		(if (> ver curr-ver) ;; need to apply this one
+		    (begin
+		      (if (string? act)
+			  (dbi:exec db act)
+			  (act))
+		      ;; yes, do this for each one, just in case of a crash
+		      (keystore:set! db "SCHEMA-VERSION" ver)))
+		(if (null? tal)
+		    highest-ver
+		    (loop (car tal)(cdr tal) ver))))))))
+

ADDED   stml2/example/models/person.scm
Index: stml2/example/models/person.scm
==================================================================
--- /dev/null
+++ stml2/example/models/person.scm
@@ -0,0 +1,68 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;; 
+;; models/person.scm
+;;
+(require "md5")
+
+(define (person:get-dat email)
+  (dbi:get-one-row (s:db) "SELECT id,name,email,status,password,score FROM people WHERE email=?;" email))
+
+;; this effectively auto logs in using "" as the password
+(define (person:create-or-get email)
+  (let ((dat (person:get-dat email)))
+    (if dat
+	(person:authenticate email "")
+	(person:set-password email ""))))
+
+(define (person:password-match? password cryptedpw)
+  (string=? (md5:digest password) cryptedpw))
+
+(define (person:authenticate email password)
+  (let ((pdat (person:get-dat email)))
+    (if pdat
+	;; (if (s:password-match? password (vector-ref pdat 4))
+	(if (person:password-match? password (vector-ref pdat 4))
+	    pdat ;; password matched, return basic record id,name,email,status
+	    #f)
+	#f)))
+
+;; sets password, creates user if doesn't exist
+(define (person:set-password email password)
+  (let ((pdat (person:get-dat email))
+	;; (cpwd (s:crypt-passwd password #f)))
+        (cpwd (md5:digest password)))
+    (if pdat
+	(dbi:exec (s:db)
+		  "UPDATE people SET password=? WHERE email=?;" 
+		  cpwd
+		  email)
+	(dbi:exec (s:db)
+		  "INSERT INTO people (name,email,password) VALUES(?,?,?);"
+		  ""
+		  email
+		  cpwd))
+    (if pdat 
+	pdat
+	(person:get-dat email))))
+
+(define (person:learn_enabled? email)
+  (eq? (dbi:get-one (s:db) "SELECT status FROM people WHERE email=?;" email)
+       1))
+
+(define(person:files_enabled? email)
+  #f)
+
+;; id,name,email,status,password,score
+(define (person:get-id       dat)(vector-ref dat 0))
+(define (person:get-name     dat)(vector-ref dat 1))
+(define (person:get-email    dat)(vector-ref dat 2))
+(define (person:get-status   dat)(vector-ref dat 3))
+(define (person:get-password dat)(vector-ref dat 4))
+(define (person:get-score    dat)(vector-ref dat 5))
+
+(define (person:set-id!       dat val)(vector-set! dat 0 val))
+(define (person:set-name!     dat val)(vector-set! dat 1 val))
+(define (person:set-email!    dat val)(vector-set! dat 2 val))
+(define (person:set-status!   dat val)(vector-set! dat 3 val))
+(define (person:set-password! dat val)(vector-set! dat 4 val))
+(define (person:set-score!    dat val)(vector-set! dat 5 val))

ADDED   stml2/example/models/voting.scm
Index: stml2/example/models/voting.scm
==================================================================
--- /dev/null
+++ stml2/example/models/voting.scm
@@ -0,0 +1,61 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;; 
+;; models/voting.scm
+;;
+;; store the votes!
+
+;; look up the entry to which to add 
+(define (voting:get-entry-id candidate-id score type)
+  (dbi:get-one (s:db) "SELECT id FROM votes WHERE candidate_id=? AND score=? AND vote_type=? AND vote_date>?;"
+	       candidate-id
+	       score
+	       type
+	       (- (current-seconds) 86400))) ;; i.e. since 24 hrs ago
+  
+(define (voting:apply-vote dat candidate-id vote-type)
+  (let* ((score (person:get-score dat))
+	 (vote-entry-id (voting:get-entry-id candidate-id score vote-type)))
+    (if vote-entry-id
+	(dbi:exec (s:db) "UPDATE votes SET votes=votes+1 WHERE id=?;" vote-entry-id)
+	(dbi:exec (s:db) "INSERT INTO votes (candidate_id,vote_date,votes,score,vote_type) VALUES(?,?,?,?,?);" 
+		  candidate-id
+		  (current-seconds)
+		  1
+		  score
+		  vote-type))))
+
+(define (voting:rollup-votes)
+  (let ((adat (dbi:get-rows (s:db) 
+			    "SELECT candidate_id AS id,SUM(votes*(score+1)) AS score FROM votes WHERE vote_date>? AND vote_type=1 GROUP BY candidate_id;"
+			    (- (current-seconds) (* 24 60 60 7))))
+	(pdat (dbi:get-rows (s:db) 
+			    "SELECT candidate_id AS id,SUM(votes*(score+1)) AS score FROM votes WHERE vote_date>? AND vote_type=0 GROUP BY candidate_id;"
+			    (- (current-seconds) (* 24 60 60 7)))))
+    (for-each
+     (lambda (row)
+       (dbi:exec (s:db) "UPDATE candidates SET score=? WHERE id=?;" (vector-ref row 1)(vector-ref row 0)))
+     adat)
+    (for-each
+     (lambda (row)
+       (dbi:exec (s:db) "UPDATE candidates SET pscore=? WHERE id=?;" (vector-ref row 1)(vector-ref row 0)))
+     pdat)))
+
+;; vote_type: 0=plurality, 1=approval
+(define (voting:handle-votes email approval plurality)
+  (let* ((pdat (let ((e (s:session-var-get "email")))
+		 (if e 
+		     (person:get-dat e)
+		     (person:create-or-get (if (or (not (string? email)) 
+						   (string-match (regexp "^\\s*$") email))
+					       "noname" 
+					       email)))))) ;; is this really the logic I wanted?
+    ;; (s:log "Got here eh!" " pdat: " pdat)
+    (if (not pdat)
+	(s:set! "errmsg" "Failed to auto log in/register, email or nick already in use. Consider reseting your password")
+	(begin
+	  (s:session-var-set! "email" (person:get-email pdat))
+	  (voting:apply-vote pdat plurality 0)
+	  (map (lambda (candidate-id)
+		 (voting:apply-vote pdat candidate-id 1))
+	       approval)
+	  (voting:rollup-votes)))))

ADDED   stml2/example/pages/action/view.scm
Index: stml2/example/pages/action/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/action/view.scm
@@ -0,0 +1,51 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+(s:div 'class "node" 
+       (s:h1 "Approval voting works")
+       "<p>Approval voting is very resistant to strategic voting and it is 
+        extremely easy to implement using existing ballot technology.
+       <p>Every four years voters must
+       make a painful strategic choice, either vote for the candidate
+       they <b><i>really</i></b> want and risk getting saddled
+       with a candidate they <b><i>don't</b></i> want, OR
+       vote for the most palatable frontrunner, and send a false
+       message of disinterest in their true choice."
+       (s:h1 "Thinking is required for a democracy to work")
+       "<p>Consider trying the &quot;fool test&quot; on an unsuspecting friend or aquaintence.
+        . Pick a popular smear or other known distortion aimed at a candidate you suspect your
+        &quot;person under test&quot;, or PUT,
+        doesn't like. Research the item and find out the truth about it as
+        best you can. Start with <A target=\"_blank\" href=\"http://factcheck.org\">
+        factcheck.org</a> but don't stop there. Use google or other search 
+        engines to build up a picture of what is true.
+
+        <p>Once you are armed with information you can apply the test. Ask your
+        friend or collegue for the truth behind the smear. Be neutral. Accept
+        their answer without judgement if it is incorrect. Say &quot;oh&quot;, or 
+        &quot;thanks&quot; and let it be at that. Again, DO NOT CORRECT THEM!
+
+        <p>If your PUT fails the test don't harp on them or correct them. 
+        Although everyone is responsible for researching the facts many people will
+        lock onto their existing ideas if challenged. Instead say something like,
+        &quot;you may want to research that&quot; and accept that you are dealing with
+        someone who just might be a fool, unwilling or unable to look at their
+        favorite candidate with a critical eye.
+        <p>Finally, be prepared to be tested yourself,
+        aggressively research the smears your favored candidates put out. If they are true
+        be prepared to prove it, if they are false, be prepared to put them in 
+        context or simply admit they are false. No candidate will be perfect."
+	(s:h1 "A strategy for change")
+	"<p>Get a yes/no answer from your favored candidate about approval voting.
+         If your candidate refuses to support approval voting first hear them out. If their 
+         reasons are good then publish them so we can all learn from it. If their
+         reasons are weak then look for an alternative candidate to support.
+
+         <p>Improve your score here on approvalvote.org and then vote again in our front 
+         page poll. Your score will adjust the power of your vote such that the poll 
+         will reflect the choices of those who are willing to think. 
+       
+         We will advocate that everyone votes for an approval vote supporting independant 
+         candidate if that candidate is at least 10% ahead of the next candidate of 
+         the same leaning (i.e. liberal or conservative). Otherwise you should vote 
+         for the frontrunner candidate of your choosen leaning due to the dangers of 
+         plurality voting.")

ADDED   stml2/example/pages/footer/view.scm
Index: stml2/example/pages/footer/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/footer/view.scm
@@ -0,0 +1,5 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; footer
+(list
+ (s:div 'class "node" "This is the footer"))

ADDED   stml2/example/pages/header/control.scm
Index: stml2/example/pages/header/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/header/control.scm
@@ -0,0 +1,9 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; header/control.scm
+
+;; (load (s:model-path "blah"))
+(define header:menu-items '(("home" "Home")("learn" "Learn")("action" "Take Action")("discussion" "Discussion")
+			    ("preferences" "Preferences")))
+(define header:title (let ((t (s:get-param 'section)))
+		       (if t t "Home")))

ADDED   stml2/example/pages/header/view.scm
Index: stml2/example/pages/header/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/header/view.scm
@@ -0,0 +1,30 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; header/view.scm
+;;
+(list
+ ;; (s:div 'id "titlebar"
+	(s:table
+	 (s:tr
+	  (s:td (s:img 'src "/www/images/approvalvote.png" 
+		       'alt "ApprovalVote.com" 
+		       'title "Welcome to ApprovalVote.com"))
+	  (s:td 'valign "top" 'align "right"
+		(s:table 'border "0" 'cellspacing "0"
+			 (s:tr 
+			  (s:td 'valign "center" ;; 'width "250" ;; 'rowspan "2"
+				(s:a (s:small " *      NOW IS A GREAT TIME TO PUSH FOR APPROVAL VOTING!     * "))
+				(s:br)))
+			 (s:tr 
+			  (s:td 'columnspan="3" 
+				(s:center "*********")))))) ;;  header:title))))))
+	 ;; this is the horizontal menus
+	 (s:tr 'columnspan "4"
+	       (s:table
+		(s:tr
+		  (map (lambda (m-item)
+			 (s:td (s:small  "[" 
+					 (s:a 'href (s:link-to (car m-item))(cadr m-item))
+					 "]")))
+		       header:menu-items)
+		  )))));; )

ADDED   stml2/example/pages/home/view.scm
Index: stml2/example/pages/home/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/home/view.scm
@@ -0,0 +1,12 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+(s:div 'class "node" 
+       (s:h1 "Please Help Save Our Democracy.")
+      "<p>We need approval voting to re-energize our democracy.
+       Our system is in danger of failing us since it leaves us powerless
+       to force change. Arguably the biggest problem lies in our use of
+       plurality voting to choose leaders.
+      ")
+(s:div 'class "node"
+       (s:h1 "Practice some approval voting now!")
+       (s:call "uspresident"))

ADDED   stml2/example/pages/index/control.scm
Index: stml2/example/pages/index/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/index/control.scm
@@ -0,0 +1,6 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; this gets read for ALL pages. Don't weigh it down excessively!
+;;
+;; index/control.scm
+

ADDED   stml2/example/pages/index/view.scm
Index: stml2/example/pages/index/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/index/view.scm
@@ -0,0 +1,21 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; index
+
+(list
+ (s:html
+  (s:head
+   (s:title "Approval Voting Now!")
+   (s:link  'rel "stylesheet" 'type "text/css" 'href "/approvalvote/markup.css")
+   (s:link  'rel "stylesheet" 'type "text/css" 'href "/approvalvote/layout.css"))
+  (s:body
+   (s:div 'class "header"       (s:call "header"))
+   (s:div 'class "rightcolumn"  (s:call "rightcol"))
+   (s:div 'class "leftcolumn"   (s:call "leftnav"))
+   (s:div 'class "centercolumn"
+          (let ((page    (slot-ref s:session 'page)))
+            (if page
+                (s:call page)
+                (list (s:h2 "Home")
+		      (s:call "sys-state")))))
+   (s:div 'class "footer" (s:call "footer")))))

ADDED   stml2/example/pages/learn/view.scm
Index: stml2/example/pages/learn/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/learn/view.scm
@@ -0,0 +1,7 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+(s:div 'class "node" 
+       (s:h1 "Resources")
+        "<p>Two excellent sites with more information on approval voting:
+         <p><A target=\"_blank\" href=\"http://approvalvoting.org\">approvalvoting.org</a>
+         <p><a target=\"_blank\" href=\"http://approvalvoting.com\">approvalvoting.com</a>")

ADDED   stml2/example/pages/leftnav/control.scm
Index: stml2/example/pages/leftnav/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/leftnav/control.scm
@@ -0,0 +1,11 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; leftnav/control.scm 
+
+;; nothing needed here yet!
+
+(define (leftnav-action action)
+  (case action
+    ('logout
+     (s:logout))))
+

ADDED   stml2/example/pages/leftnav/view.scm
Index: stml2/example/pages/leftnav/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/leftnav/view.scm
@@ -0,0 +1,38 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; leftnav/view.scm
+
+(list
+    (s:div 
+     'class "node"
+     (s:h1 "Navigation")
+     (let ((section (slot-ref s:session 'page)))
+       (cond
+	((or (not section) ;; this is home
+	     (string=? section "home"))
+	 "Home menu")
+	((string=? section "discussions")
+	 (list
+	  (s:a "Filter"         'href (s:link-to "discussions" 'filter "on"))))
+	((string=? section "learn")
+	 (list
+	  (s:a "Learn"  'href (s:link-to "learn"  'action "learn.teach"))(s:br)
+	  (s:a "Test"   'href (s:link-to "learn"  'action "learn.test"))(s:br)
+	  ))
+	((string=? section "preferences")
+	 (list 
+	  (s:a "Password"       'href (s:link-to "preferences" 'action "password"))(s:br)
+	  (s:a "Messages"       'href (s:link-to "preferences" 'action "messages"))(s:br)
+	  (s:a "Preferences"    'href (s:link-to "preferences" 'action "preferences"))(s:br)))
+	(else '( "nada" ))))
+     (s:br))
+    (s:div
+     'class "node"
+     (s:h1 "About you")
+     (let ((email (s:session-var-get "email")))
+       (if email
+           (list email (s:br))
+           "Not logged in")))
+    (s:div
+     'class "node"
+     (s:call "pledge")))

ADDED   stml2/example/pages/login/control.scm
Index: stml2/example/pages/login/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/login/control.scm
@@ -0,0 +1,25 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+(load (s:model-path "person"))
+
+(define (login-action action)
+  (case (string->symbol action)
+    ('login
+     ;; the actual login code
+     (s:log "Got here, doing login")
+     (let ((email  (s:get-input 'email-address))
+           (passwd (s:get-input 'password)))
+	   ;; (person (make-person))) ;; DO WE NEED A PERSON "OBJECT"?
+       (s:set! "email-address" email) ;; preserve user as email-address
+       (if (and email passwd)
+	   (let ((good-login (person:authenticate email passwd)))
+	     (if good-login
+		 (begin
+		   (s:set! "msg" "Login successful!")
+		   (s:session-var-set! "email" email))
+		 (s:set! "msg" "Bad password or email. Please try again")))
+	   (s:set! "msg" "Missing password or email"))))
+    ('logout
+     (s:delete-session))
+    ('nada
+     (s:log "Got here, action=" action))))

ADDED   stml2/example/pages/login/view.scm
Index: stml2/example/pages/login/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/login/view.scm
@@ -0,0 +1,24 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; Login view
+
+(s:div 'class "node"
+       ;; (s:p (s:get-err s:strong)) ;; error message
+       (if (s:session-var-get "email") 
+           (s:a "Log out" 'href (s:link-to (s:current-page) 'action "login.logout"))
+           (list 
+            (s:center (s:p (s:strong "Log in here!")))
+	    (let ((msg (s:get "msg")))
+	      (if msg
+		  (begin
+		    (s:del! "msg")
+		    (s:err-font msg))
+		  (s:null "")))
+            (s:form 'action "login.login" 'method "post"
+                    (s:strong "Id: (*)")(s:br)
+                    (s:input-preserve 'type "text" 'name "email-address" 'size "14" 'maxlength "30")(s:br)
+                    (s:strong "Password:")(s:br)
+                    (s:input 'type "password" 'name "password" 'size "14" 'maxlength "30")(s:br)
+                    (s:input 'type "submit"   'name "form-name"    'value "login")(s:br)
+                    (s:a "Create account" 'href (s:link-to "new_account"))
+                    ))))

ADDED   stml2/example/pages/maint/control.scm
Index: stml2/example/pages/maint/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/maint/control.scm
@@ -0,0 +1,13 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;; 
+;; maint/control.scm
+;;
+(s:load-model "maint")
+
+;; remember that the system will call the function <pagename>-action with the action as a parameter
+(define (maint-action action)
+  (let ((asym (string->symbol action)))
+    (s:log "Doing action! " action)
+    (case asym
+      ('update_tables
+       (maint:update-tables)))))

ADDED   stml2/example/pages/maint/view.scm
Index: stml2/example/pages/maint/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/maint/view.scm
@@ -0,0 +1,12 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; maint/view.scm
+;;
+(if (maint:am-i-maint?)
+    (list
+     (s:h1 "Hello Maint!")
+     (s:p (s:a "Update Tables" 'href (s:link-to (s:current-page) 
+					'action "maint.update_tables"))))
+    '())
+
+	

ADDED   stml2/example/pages/new_account/control.scm
Index: stml2/example/pages/new_account/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/new_account/control.scm
@@ -0,0 +1,53 @@
+;; Copyright 2007-2008, Matthew Welland. matt@iatoa.com All rights reserved.
+;; 
+;; new_account/control.scm
+
+(load (s:model-path "person"))
+
+(define (new_account:validate-inputs password password-again email-address email-address-again)
+  (cond
+   ((or (not password)(not password-again)
+        (not email-address)(not email-address-again))
+    (s:set-err "Form is incomplete. Please fill in all fields and try again")
+    #f)
+   ((< (string-length password) 2)
+    (s:set-err "Password is too short. Please try again")
+    #f)
+   ((not (string=? password password-again))
+    (s:set-err "Passwords do not match. Please try again")
+    #f)
+   ((> (string-length password) 9)
+    (s:set-err "Password is too long. Please try again")
+    #f)
+   ((not (string=? email-address email-address-again))
+    (s:set-err "Email addresses provided do not match. Please try again")
+    #f)
+   ((and (not (string-match (regexp "^\\s*$") email-address))
+         (not (string-match (regexp "^[^@]+@[^@]+\\.[^@]+$") email-address)))
+    (s:set-err "Not a valid email address, please try again")
+    #f)
+   (else #t)))
+
+(define (new_account-action action)
+  (case (string->symbol action)
+    ('create
+     (s:log "Got here, doing create new account")
+     (let ((password            (s:get-input 'password))
+           (password-again      (s:get-input 'password-again))
+           (email-address       (s:string-downcase (s:get-input 'email-address)))
+           (email-address-again (s:string-downcase (s:get-input 'email-address-again))))
+       ;; save preserved inputs
+       (s:set! "email-address" email-address)
+       (s:log "Saved inputs. Now check inputs")
+       (if (new_account:validate-inputs password password-again email-address 
+                                        email-address-again)
+           ;; Great!! Now have good inputs
+           (if (person:get-dat email-address)
+	       (s:set-err "There is already an account for that email address!")
+	       (let ((pdat (person:set-password email-address password)))
+		 (if pdat
+		     (s:set-err "SUCCESS!! You can now log in with " email-address " and your password")
+		     (s:set-err "ERROR!! Unable to automatically log you on with the same credentials used to create your account. This shouldn't happen. Please send email to matt@kiatoa.com about this"))))
+           ;; bad inputs
+           #f)))
+    ('else (s:log "Placeholder for future actions. Shouldn't get here"))))

ADDED   stml2/example/pages/new_account/view.scm
Index: stml2/example/pages/new_account/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/new_account/view.scm
@@ -0,0 +1,27 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; new_account/view.scm
+;;
+(list 
+ (s:div 'class "node"
+        ;; (s:p (s:get-err s:strong)) ;; error message
+        (s:p "")(s:p (s:get-err s:err-font))
+        (if (not (s:session-var-get "email")) ;; setting email defines "logged in"
+            (s:form 'action "new_account.create" 'method "post"
+                    (s:table 'border "0" 'spacing "0"
+                             
+                             (s:tr (s:td (s:strong "Email address:")) ;; (s:br)
+                                   (s:td (s:input-preserve 'type "text" 'name "email-address" 'size "16" 'maxlength "30"))) ;; (s:br)
+                             
+                             (s:tr (s:td (s:strong "Email address again:")) ;; (s:br)
+                                   (s:td (s:input-preserve 'type "text" 'name "email-address-again" 'size "16" 'maxlength "30"))) ;; (s:br)
+                    
+                             (s:tr (s:td (s:strong "Password:")) ;; (s:br)
+                                   (s:td (s:input 'type "password" 'name "password" 'size "16" 'maxlength "16"))) ;; (s:br)
+                             
+                             (s:tr (s:td (s:strong "Password again:")) ;; (s:br)
+                                   (s:td (s:input 'type "password" 'name "password-again" 'size "16" 'maxlength "16")))); (s:br)
+                             
+                    (s:input 'type "submit"   'name "form-name"    'value "submit"))
+            (s:h1 "Welcome " (s:session-var-get "email") ":" (s:session-var-get "location") "!"))))
+ 

ADDED   stml2/example/pages/pledge/view.scm
Index: stml2/example/pages/pledge/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/pledge/view.scm
@@ -0,0 +1,16 @@
+;; Copyright 2007-2008, Matthew Welland. matt@iatoa.com All rights reserved.
+;; 
+(s:if-sessionvar 
+ "email"
+ (list
+  (s:h1 "Pledge now!")
+  (s:fieldset 
+   "Pledge"
+   (s:form 'action "pledge.pledge"
+	   'method "post"
+	   (s:i " - I will vote" (s:b "ONLY") " for a candidate who supports approval voting!")
+	   (s:table
+	    (s:tr (s:td "Yes")  (s:td (s:input 'type "radio"    'name "pledge_answer" 'value "yes")))
+	    (s:tr (s:td "No")   (s:td (s:input 'type "radio"    'name "pledge_answer" 'value "no")))
+	    (s:tr (s:td "Maybe")(s:td (s:input 'type "radio"    'name "pledge_answer" 'value "maybe"))))
+	   (s:input 'type "button" 'name "pledge_answer" 'value "Submit")))))

ADDED   stml2/example/pages/preferences/view.scm
Index: stml2/example/pages/preferences/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/preferences/view.scm
@@ -0,0 +1,12 @@
+;; Copyright 2007-2008, Matthew Welland. matt@iatoa.com All rights reserved.
+;; 
+;; preferences/view.scm
+;;
+(s:div
+ 'class "node"
+ (s:h1 "Register your email address")
+ (s:p "Adds 9 pts to your score the first time you do it and enables very occasional email updates. If you change your email address
+       you need to re-register to keep your 9 pts.")
+ (s:form 'action "preferences.register_email"
+	 'method "post"
+	  (s:input 'type "submit" 'name "register_email" 'value "Register Email"))) 

ADDED   stml2/example/pages/rightcol/view.scm
Index: stml2/example/pages/rightcol/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/rightcol/view.scm
@@ -0,0 +1,9 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+
+;; rightcol
+(list
+  (s:div 'class "node" 
+	 (s:call "login")))
+
+;; "This is the right-most column"))

ADDED   stml2/example/pages/sys-state/view.scm
Index: stml2/example/pages/sys-state/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/sys-state/view.scm
@@ -0,0 +1,16 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+
+;; sys-state
+
+(list (let ((p (open-input-pipe "env")))
+	(let loop ((l (read-line p))
+		   (res '()))
+	  (if (not (eof-object? l))
+	      (loop (read-line p)(cons (list l "<BR>") res))
+	      res)))
+      ;; "USER=" (user-information (current-user-id))
+
+      (s:h2 "Form data")
+      (session:pp-formdat s:session)
+      "argv=" (argv))

ADDED   stml2/example/pages/uspresident/control.scm
Index: stml2/example/pages/uspresident/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/uspresident/control.scm
@@ -0,0 +1,72 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; this gets read for ALL pages. Don't weigh it down excessively!
+;;
+;; uspresident/control.scm
+
+(s:load-model "candidate")
+(s:load-model "voting")
+(s:load-model "person")
+
+(define candidates (candidate:get-top 10))
+(define candidates:vote-sum-approval  (apply + (map candidate:get-score candidates)))
+(define candidates:vote-sum-plurality (apply + (map candidate:get-pscore candidates)))
+(define candidates:top-plurality-id   (let ((id       #f)
+					    (topscore 0))
+					(for-each (lambda (cand)
+						    (if (> (candidate:get-pscore cand) topscore)
+							(begin 
+							  (set! topscore (candidate:get-pscore cand))
+							  (set! id       (candidate:get-id cand)))))
+						  candidates)
+					id))
+(define candidates:top-approval-id   (let ((id       #f)
+					   (topscore 0))
+				       (for-each (lambda (cand)
+						   (if (> (candidate:get-score cand) topscore)
+						       (begin 
+							 (set! topscore (candidate:get-score cand))
+							 (set! id       (candidate:get-id cand)))))
+						 candidates)
+				       id))
+							   
+
+(define (uspresident-action action)
+  (let ((acsym (string->symbol action)))
+    (cond
+     ('vote
+      (let ((button (s:get-input 'vote)))
+	(cond
+	 ((equal? button "Vote")
+	  (let* ((approval    (s:get-input 'approval))
+		 (plurality   (s:get-input 'plurality))
+		 (newdat      (make-vector 9 ""))
+		 (email       (s:session-var-get "email"))
+		 (newcandname (s:get-input 'poll_name))
+		 (nick-email  (if email email (s:get-input 'users_email))))
+	    (if (not (list? approval))
+		(set! approval (list approval)))
+	    (if (string-match (regexp "^[a-zA-Z]+") newcandname)
+		(let* ((dat (candidate:get-by-name newcandname)))
+		  (if dat ;; i.e. this is a new candidate
+		      (set! newdat dat)
+		      (begin
+			(candidate:set-name! newdat newcandname)
+			(candidate:set-supports-av! newdat (s:get-input 'poll_supports_av))
+			(candidate:set-party! newdat (s:get-input 'poll_party))
+			(candidate:set-url! newdat (s:get-input 'poll_url))
+			(set! newdat (candidate:update newdat))))
+		  (s:log "cid: " (candidate:get-id newdat))
+		  (set! approval  (cons (candidate:get-id newdat) approval))
+		  (set! plurality (candidate:get-id newdat))))
+	    (set! approval (filter (lambda (x)(or (number? x)(string? x))) approval)) ;; clean the approval list
+	    (s:log "using email: " nick-email)
+	    (s:log "approval: " approval)
+	    (s:log "plurality: " plurality)
+	    (if (and approval plurality (not (null? approval)))
+		(begin
+		  (voting:handle-votes nick-email
+				       approval
+				       plurality)
+		  (s:session-var-set! "voted" "yes"))
+		(s:set! "errmsg" "Please select one plurality vote and one or more approval votes"))))))))))

ADDED   stml2/example/pages/uspresident/view.scm
Index: stml2/example/pages/uspresident/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/uspresident/view.scm
@@ -0,0 +1,85 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+
+;; Note: the (list is actually no longer needed. 
+
+(list
+ (s:if-sessionvar 
+  "email"
+  (s:if-sessionvar 
+   "voted"
+   "We are glad you tried approval voting. Try again to see how the system works. Don't worry about the poll numbers. This poll is for you to play with."))
+ (s:fieldset
+  "Poll"
+  (s:center
+   (s:if-param "errmsg"
+	       (let ((err (s:get "errmsg")))
+		 (s:del! "errmsg")
+		 (s:err-font err)))
+   (s:form  'action "uspresident.vote"
+	    'method "post"
+	    (s:table 'border "1" 'cellspacing "0"
+		     (s:tr 
+		      (s:td "Candidate")(s:td "Party")(s:td "Supports approval?")
+		      (s:if-sessionvar 
+		       "voted"
+		       (list (s:td "Plurality")
+			     (s:td "Approval")
+			     (s:td "Plurality" (conc "(" candidates:vote-sum-plurality "votes" ")"))
+			     (s:td "Approval"  (conc "(" candidates:vote-sum-plurality "votes" ")")))
+		       (list (s:td "Plurality (vote for one only)")(s:td "Approval (vote for all which you approve of)"))))
+		     ;; map the poll items for each row
+		     (map (lambda (candidate)
+			    (let ((poll-item-id          (number->string (candidate:get-id candidate)))
+				  (poll-item-url         (s:tidy-url (candidate:get-url candidate)))
+				  (poll-item-name        (candidate:get-name candidate))
+				  (poll-item-description (candidate:get-desc candidate))
+				  (poll-item-percent-a   (quotient (* 100 (candidate:get-score candidate)) candidates:vote-sum-plurality))
+				  (poll-item-percent-p   (quotient (* 100 (candidate:get-pscore candidate)) candidates:vote-sum-plurality)))
+			      (list
+			       (s:tr
+				(s:td
+				 (if poll-item-url
+				     (s:a 'href poll-item-url 'target "_blank" poll-item-name)
+				     poll-item-name))
+				;; (if (poll:poll 'have-description?)
+				;;     (s:td 'bgcolor "#f0f0f0" poll-item-description) ;; description
+				;;     '())
+				(s:td (candidate:get-party       candidate))
+				(s:td (candidate:get-supports-av candidate))
+				;; (if (not (s:session-var-get "voted")) ;; here are the check buttons for plurality and approval voting
+				;;    (list 
+				(s:td (s:center
+				       (s:input 'type "radio"    'name "plurality" 'value poll-item-id)))
+				(s:td (s:center
+				       (s:input 'type "checkbox" 'name "approval"  'value poll-item-id)))
+				(s:if-sessionvar "voted"
+						 (list
+						  (s:td (conc poll-item-percent-p "%") 'bgcolor (if (eq? (candidate:get-id candidate)  candidates:top-plurality-id)
+												    "cyan"
+												    "lightgrey")
+							(conc "(" (candidate:get-pscore candidate) ")") 'align "center")
+						  (s:td (conc poll-item-percent-a "%")  'bgcolor (if (eq? (candidate:get-id candidate)  candidates:top-approval-id)
+												    "cyan"
+												    "lightgrey")
+							(conc "(" (candidate:get-score candidate) ")")  'align "center"))))))) ;; % votes
+			  candidates)
+		     (s:tr 
+		      (s:td "Write in (name):<br>"
+			    (s:input-preserve 'type "text" 'name "poll_name"  'size "15" 'maxlength "40"))
+		      (s:td "Party:<br>" (s:input-preserve 'type "text" 'name "poll_party" 'size "10" 'maxlength "40"))
+		      (s:td "Supports approval:<br>" (s:input-preserve 'type "text" 'name "poll_supports_av"  'size "10" 'maxlength "40"))
+		      (s:td "Url:<br>"   (s:input-preserve 'type "text" 'name "poll_url"   'size "40" 'maxlength "120") 'colspan 4))
+		     (s:tr
+		      (s:td 'colspan 7
+			    (s:center (s:input 'type "submit" 'name "vote" 'value "Vote") 
+				      (s:if-sessionvar "email"
+						       '()
+						       (list
+							"Email or nickname:" 
+							(s:input-preserve 'type "text" 'name "users_email" 'size 20 'maxlength 40)
+							"(required), Country code:"
+							(s:input-preserve 'type "text" 'name "users_country_code" 'size 2 'maxlength 2)
+							"(optional)"
+							))
+				       ))))))))

ADDED   stml2/example/tests/test.scm
Index: stml2/example/tests/test.scm
==================================================================
--- /dev/null
+++ stml2/example/tests/test.scm
@@ -0,0 +1,85 @@
+#!/usr/local/bin/csi -q 
+
+;; This currently requires that the stml code is available in a parallel directory.
+
+(use test)
+(if (file-exists? "test.db")
+    (begin
+      (print "Removing old test.db")
+      (system "rm -f test.db")))
+
+(load "../stml/misc-stml.scm")
+(load "../stml/formdat.scm")
+(load "../stml/stml.scm")
+(load "../stml/session.scm")
+(load "../stml/sqltbl.scm")
+(load "../stml/html-filter.scm") ;; required for s:split-string 
+(load "../stml/dbi.scm")
+(load "../stml/keystore.scm")
+(load "../stml/sugar.scm")
+
+;; create a session to work with")
+(setenv "REQUEST_URI" "/stmlrun?action=maint.nada")
+(setenv "SCRIPT_NAME" "/cgi-bin/stmlrun")
+(setenv "PATH_INFO" "/maint")
+(setenv "QUERY_STRING" "action=maint.nada")
+(setenv "SERVER_NAME" "localhost")
+(setenv "REQUEST_METHOD" "GET")
+;; (define session-name "pfNOeqUHkJ26BpU6y49IN") ;; ensure this session already exists
+;; (setenv "HTTP_COOKIE" (string-append "session_key=" session-name)) ;; to09ipFJ9_2KXT96b2f9Q")
+
+(load "../stml/setup.scm")
+;; (test (string-append "Session set to existing session " session-name)
+;;       session-name (slot-ref s:session 'session-key))
+
+(s:validate-inputs)
+
+;; test session variables
+
+;; lazy stuff
+(define *conn* (slot-ref s:session 'conn))
+
+;; setup tables
+(load "models/maint.scm")
+(test "Create tables" #t (> (maint:update-tables)
+			    0))
+
+;; test person
+(let ((fh (open-input-pipe "ls models/*.scm")))
+  (let loop ((l (read-line fh)))
+    (if (not (eof-object? l))
+        (begin
+          (print "loading " l)
+          (load l)
+          (loop (read-line fh)))))
+  (close-input-port fh))
+
+(let ((fh (open-input-pipe "find pages -name control.scm"))) ;; ls pages/*/control.scm")))
+  (let loop ((l (read-line fh)))
+    (if (not (eof-object? l))
+        (begin
+          (print "loading " l)
+          (load l)
+          (loop (read-line fh)))))
+  (close-input-port fh))
+
+(let ((fh (open-input-pipe "ls pages/*/view.scm")))
+  (let loop ((l (read-line fh)))
+    (if (not (eof-object? l))
+        (begin
+          (print "loading " l)
+          (load l)
+          (loop (read-line fh)))))
+  (close-input-port fh))
+
+;;======================================================================
+;; Maint
+;;======================================================================
+;; 
+(load "models/maint.scm")
+
+(test "Update tables"   #t                (> (maint:update-tables))) ;;  *conn* 2 "us") 0))
+(test "Add user"        "matt@kiatoa.com" (vector-ref (person:set-password "matt@kiatoa.com" "Password") 2))
+(test "Authenticate"    "matt@kiatoa.com" (vector-ref (person:authenticate "matt@kiatoa.com" "Password") 2))
+(test "Validate inputs" #t                (new_account:validate-inputs "Password" "Password" "matt@kiatoa.com" "matt@kiatoa.com"))
+

ADDED   stml2/example/www/layout.css
Index: stml2/example/www/layout.css
==================================================================
--- /dev/null
+++ stml2/example/www/layout.css
@@ -0,0 +1,245 @@
+
+/*-General-----------------------------------------------*/
+
+html, body {
+	margin:0px;
+	padding:0px;
+}
+
+form {
+	display:inline;
+	margin:0px;
+	padding:0px;
+}
+
+a img {
+	border:none;
+	margin:0px;
+	padding:0px;
+}
+
+h1, h2, h3, h4, h5, h6, p, div {
+	margin:0px;
+	padding:0px;
+}
+
+.right {
+	float:right;
+}
+
+.left{
+	float:left;
+}
+
+/*-Main Layout-------------------------------------------*/
+
+#overall {
+	/* margin:5px 12px 0px 12px; */
+	padding:0px;
+}
+
+/*-Header-------------*/
+
+.header {
+        /* float:top; */
+	position:relative; 
+	height:55px;
+}
+
+/*-Footer-------------*/
+
+.footer {
+	padding:40px 0px 0px 0px;
+	position:relative;
+	clear:both;
+}
+
+/*-Content Area-------*/
+
+.content {
+	width:100%;
+}
+
+/*-Left Column--------*/
+
+.leftcolumn	{
+  float:left;
+  width:145px;
+  margin:5px;
+}
+
+.leftcolumn .node {
+	margin:0px 0px 15px 0px;
+}
+
+.leftcolumn .node h1 {
+	padding:0px 0px 0px 3px;
+}
+
+.leftcolumn .node ul {
+	margin:0px;
+	padding:0px;
+}
+
+.leftcolumn .node li {
+	display:block;
+	padding:0px 0px 0px 3px;
+	margin:0px;
+}
+
+.leftcolumn .node li.more{
+	padding:0px 0px 0px 6px;
+}
+
+/*-Center Column------*/
+
+.centercolumn {
+        margin: 5px;
+	margin-left:152px;
+        margin-right:140px;
+	font-family:"\"}\"";
+	font-family:inherit;
+}
+
+.centercolumn .node h1 {
+	padding: 0px 0px 0px 13px;
+}
+
+.centercolumn .node h4 {
+	margin: 15px 0px 10px 0px;
+}
+
+.centercolumn .node p {
+	margin: 0px 0px 10px 0px; */
+	padding: 0px 0px 0px 0px;
+}  /* this seemed not to work */
+
+.posts_0  {
+	margin: 0px 0px 0px 0px;
+}
+
+.posts_1  {
+	margin: 0px 0px 0px 20px;
+}
+
+.posts_2  {
+	margin: 0px 0px 0px 40px;
+}
+
+.posts_3  {
+	margin: 0px 0px 0px 60px;
+}
+
+.posts_4  {
+	margin: 0px 0px 0px 80px;
+}
+
+.posts_5  {
+	margin: 0px 0px 0px 100px;
+}
+
+.posts_6  {
+	margin: 0px 0px 0px 120px;
+}
+
+.posts_7  {
+	margin: 0px 0px 0px 140px;
+}
+
+.posts_8  {
+	margin: 0px 0px 0px 160px;
+}
+
+.posts_9  {
+	margin: 0px 0px 0px 160px;
+}
+
+.posts_10  {
+	margin: 0px 0px 0px 180px;
+}
+
+/*-Right Column-------*/
+
+.rightcolumn {
+	float:right;
+        width:130px;
+	margin:5px 5px 0px 0px;
+}
+
+* html .rightcolumn {
+	margin:3px 3px 3px 3px;
+}
+
+body>div .rightcolumn {
+	margin:0px 0px 0px 0px;
+}
+
+.rightcolumn .node {
+	margin:0px 0px 5px 0px;
+	padding:0px;
+}
+
+.rightcolumn .node h2 {
+	margin:3px 3px 3px 2px;
+}
+
+.rightcolumn .node ul {
+  list-style-position:inside;
+  margin:0px;
+  padding:1px;
+}
+
+.rightcolumn .node ul.none {
+	list-style-position:inside;
+}
+
+.rightcolumn .node ul.dot {
+	list-style-position:inside;
+}
+
+.rightcolumn .node ul.books {
+	list-style-position:outside;
+	margin:0px 0px 0px 35px;
+}
+
+.rightcolumn .node li {
+	padding:0px 0px 0px 3px;
+	margin:0px;
+}
+
+/*-Remaining layout--------------------------------------*/
+
+#title {
+	top: 0px;
+	left: 0px;
+	position: absolute;
+}
+
+#search {
+	float:left;
+	margin:0px 0px 0px 30px;
+}
+
+#randomquote {
+	float:right;
+	margin:0px 30px 0px 0px;
+}
+
+#copyright {
+	text-align:center;
+	padding:15px 0px 0px 0px;
+	margin:0px 0px 0px 0px;
+	clear:both;
+}
+
+#bottomNav {
+	text-align:center;
+	margin:0px 0px 20px 0px;
+	padding:0px;
+}
+
+#oldStuffNav {
+	font-weight:bold;
+	text-align:right;
+}
+

ADDED   stml2/example/www/markup.css
Index: stml2/example/www/markup.css
==================================================================
--- /dev/null
+++ stml2/example/www/markup.css
@@ -0,0 +1,299 @@
+/*-General-----------------------------------------------*/
+
+body {
+  background-color:#ffffff;
+  color:#0f0f0f;
+/*  font-family:serif; */
+  font-weight:normal;
+  text-decoration:none; 
+  font-size:x-small; 
+  voice-family:"\"}\"";
+  voice-family:inherit;
+  font-size:small;
+}
+
+html>body {
+  font-size:small;
+}
+
+.strong {
+  font-weight:bold;
+}
+
+#red { 
+  color: #ff0000
+}
+
+/*-Main Markup-------------------------------------------*/
+
+#overall {
+  background-color: #ffffff;
+  color:#000000;
+}
+
+/*-Left Column--------*/
+
+.leftcolumn .node a {
+  color:#006666;
+  background-color:transparent;
+}
+
+.leftcolumn .node p {
+  font-size:1.2em;
+  font-weight:normal;
+}
+
+.leftcolumn .node h1 {
+  font-weight:normal;
+  font-size:1.2em;
+  color:#ffffff;
+  background-color:#000000; /* #005991;  #7f9bff #006666; */
+}
+
+.leftcolumn .node h1 a {
+  color:#ffffff;
+  background-color:transparent;
+}
+
+.leftcolumn .node h2 {
+  font-weight:bold;
+  font-size:.95em;
+}
+
+.leftcolumn .node ul {
+  list-style-type:none;
+}
+
+.leftcolumn .node li.more {
+  font-weight:bold;
+  font-size:.75em;
+}
+
+.leftcolumn .node li.selected {
+  font-weight:bold;
+  font-size:1.18em;
+  color:#000000;
+  background-color:#cccccc;
+}
+
+.leftcolumn .node li.selected a {
+  color:#000000;
+  background-color:transparent;
+}
+
+/*-Center Column for classifieds-*/
+
+.centercolumn .classifieds h1 { 
+  font-family:Arial, Helvetica, serif;
+  font-weight:bold;
+  font-size:1.38em;
+  color:#000000; /* ffffff; */
+  background: #5390b7; /* a6bcac; #0c1e0f; 043b0d; 1a6126; */
+}
+
+/*-Center Column------*/
+.centercolumn .node {
+/*  font-family:serif; */
+}
+
+.centercolumn .node a {
+  color:#006666;
+  background-color:transparent;
+}
+
+.centercolumn .node h1 {
+  font-family:Arial, Helvetica, serif;
+  font-weight:bold;
+  font-size:1.38em;
+  color:#ffffff;
+  background:#000000; /* #005991; */
+} /* #006666 /* url('../images/slc.gif') no-repeat; */
+     
+.centercolumn .node h1 a {
+  color:#ffffff;
+  background-color:transparent;
+}
+
+.centercolumn .node h2 {
+  font-weight:bold;
+  font-size:1.18em;
+}
+
+.centercolumn .node h3 {
+  font-weight:bold;
+  font-size:.95em;
+}
+
+.centercolumn .node h4 {
+  font-weight:normal;
+  font-size:1.2em;
+}
+
+.centercolumn .node h4 a {
+  font-weight:bold;
+}
+
+.centercolumn .node p {
+  font-weight:normal;
+}
+
+.centercolumn .posts_0 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_1 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_2 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_3 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_4 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_5 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_6 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_7 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_8 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_9 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+.centercolumn .posts_10 h1 { 
+  color:#ffffff;
+  background-color:#606060;
+  font-size:1.18em;
+}
+
+/*-Right Column-------*/
+
+.rightcolumn .node {
+  color:#000000;
+  background-color:#cccccc;
+  font-family:serif;
+}
+
+.rightcolumn .node a {
+  color:#000000; /* #005991;  #006666; */
+  background-color:transparent;
+}
+
+.rightcolumn .node h1 {
+  font-family:Arial, Helvetica, serif;
+  font-weight:bold;
+  font-size:0.95em; /* 1.38em; */
+  color:#ffffff;
+  background-color: #000000; /* #005991;  #006666; */
+}
+
+.rightcolumn .node h1 a {
+  color:#ffffff;
+  background-color:transparent;
+}
+
+.rightcolumn .node h2 {
+  font-weight:bold;
+  font-size:.95em;
+}
+
+.rightcolumn .node ul.none {
+  list-style-type:none;
+}
+
+.rightcolumn .node ul.dot {
+  list-style-type:none;
+  /* list-style-image:url('../images/listdot.gif'); */
+}
+
+.rightcolumn .node ul.books {
+  list-style-type:disc;
+}
+
+/*-OSDN Navagation bar-----------------------------------*/
+
+#OSDNNavbar {
+  background-color:#999999;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#OSDNNavbar div#links {
+  background-color:#999999;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#OSDNNavbar a {
+  background-color: transparent;
+  color: #000000; /* #005991; /* #006666; */
+}
+
+/*-Remaining layout--------------------------------------*/
+
+#randomquote {
+  font-size:1.2em;
+  font-style:italic;
+}
+
+#copyright {
+  font-size:.75em;
+  font-family:Arial, Helvetica, serif;
+  background-color:transparent;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#copyright a {
+  background-color:transparent;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#bottomNav {
+  background-color:transparent;
+  color:#000000; /* #005991; /* #006666; */
+}
+
+#bottomNav a {
+  background-color:transparent;
+  color:#ffffff;
+}
+
+#oldStuffNav {
+  font-weight:bold;
+}
+

ADDED   stml2/formdat.scm
Index: stml2/formdat.scm
==================================================================
--- /dev/null
+++ stml2/formdat.scm
@@ -0,0 +1,21 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; (declare (unit formdat))
+
+(module formdat
+    *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+(use html-filter)
+
+(use regex)
+(require-extension srfi-69)
+
+)

ADDED   stml2/html-filter.scm
Index: stml2/html-filter.scm
==================================================================
--- /dev/null
+++ stml2/html-filter.scm
@@ -0,0 +1,21 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; (declare (unit html-filter))
+
+(module html-filter
+    *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+(use misc-stml)
+
+(require-extension regex)
+
+;; 
+)

ADDED   stml2/install.cfg.template
Index: stml2/install.cfg.template
==================================================================
--- /dev/null
+++ stml2/install.cfg.template
@@ -0,0 +1,6 @@
+
+TARGDIR=/usr/lib/cgi-bin
+LOGDIR=/tmp/stmlrun
+SQLITE3=/usr/bin/sqlite3
+# this was needed on the nokia n800 :-)
+# SQLITE3=/tmp/sqlite3

ADDED   stml2/keystore.scm
Index: stml2/keystore.scm
==================================================================
--- /dev/null
+++ stml2/keystore.scm
@@ -0,0 +1,22 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;;======================================================================
+;; The meta data key store, just a general dumping ground for values
+;; only used occasionally
+;;======================================================================
+
+;; (declare (unit keystore))
+
+(module keystore
+    *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+
+)

ADDED   stml2/misc-stml.scm
Index: stml2/misc-stml.scm
==================================================================
--- /dev/null
+++ stml2/misc-stml.scm
@@ -0,0 +1,24 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;;======================================================================
+;; dumbobj helpers
+;;======================================================================
+
+;; (declare (unit misc-stml))
+
+(module misc-stml
+  *
+
+(import chicken scheme data-structures extras srfi-13 ports posix)
+  
+(use regex (prefix dbi dbi:))
+(use (prefix crypt c:))
+(use (prefix dbi dbi:))
+)

ADDED   stml2/modules/twiki/Makefile
Index: stml2/modules/twiki/Makefile
==================================================================
--- /dev/null
+++ stml2/modules/twiki/Makefile
@@ -0,0 +1,10 @@
+
+twiki.l.scm : twiki.l
+	csi -batch -eval '(use silex)(if (lex "twiki.l" "twiki.l.scm")(exit 0)(exit 1))'
+
+test-silex : twiki.l.scm test-silex.scm
+	csc test-silex.scm
+
+twikicount : twiki.l.scm twikicount.scm
+	csc twikicount.scm
+

ADDED   stml2/modules/twiki/misc-notes.txt
Index: stml2/modules/twiki/misc-notes.txt
==================================================================
--- /dev/null
+++ stml2/modules/twiki/misc-notes.txt
@@ -0,0 +1,46 @@
+#|
+telnet localhost 80
+GET cgi-bin/kiatoa/twiki?image=4&wiki_key=bG9jYXRpb25zIHdvcmxk HTTP/1.1
+Accept: */*
+Accept-Language: en-us
+Connection: Keep-Alive
+Host: localhost
+Referer: http://localhost/links.asp
+User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.0)
+Accept-Encoding: gzip, deflate
+
+GET /kiatoa/images/kiatoa.png HTTP/1.1
+Accept: */*
+Accept-Language: en-us
+Connection: Keep-Alive
+Host: localhost
+Referer: http://localhost/links.asp
+
+GET index.html HTTP/1.1
+Accept: */*
+Accept-Language: en-us
+Connection: Keep-Alive
+Host: localhost
+Referer: http://localhost/links.asp
+
+GET /cgi-bin/kiatoa/twiki?image=2&wiki_key=bG9jYXRpb25zIHdvcmxk HTTP/1.1
+Accept: */*
+Accept-Language: en-us
+Connection: Keep-Alive
+Host: localhost
+Referer: http://192.168.2.1/cgi-bin/kiatoa/location/?twiki_maint=2
+User-Agent: Mozilla/4.0
+Accept-Encoding: gzip, deflate
+
+HTTP/1.1 200 OK
+Date: Tue, 01 Sep 2009 02:18:16 GMT
+Server: Apache/2.2.11 (Ubuntu) PHP/5.2.6-3ubuntu4.2 with Suhosin-Patch
+Last-Modified: Sun, 19 Jul 2009 02:47:52 GMT
+ETag: "a38005-12c2-46f060c330600"
+Accept-Ranges: bytes
+Content-Length: 4802
+Keep-Alive: timeout=15, max=100
+Connection: Keep-Alive
+Content-Type: image/png
+
+|#

ADDED   stml2/modules/twiki/tlayout.css
Index: stml2/modules/twiki/tlayout.css
==================================================================
--- /dev/null
+++ stml2/modules/twiki/tlayout.css
@@ -0,0 +1,172 @@
+/*{{{*/
+* html .tiddler {height:1%;}
+
+body {font-size:.75em; font-family:arial,helvetica; margin:0; padding:0;}
+
+h1,h2,h3,h4,h5,h6 {font-weight:bold; text-decoration:none;}
+h1,h2,h3 {padding-bottom:1px; margin-top:1.2em;margin-bottom:0.3em;}
+h4,h5,h6 {margin-top:1em;}
+h1 {font-size:1.35em;}
+h2 {font-size:1.25em;}
+h3 {font-size:1.1em;}
+h4 {font-size:1em;}
+h5 {font-size:.9em;}
+
+hr {height:1px;}
+
+a {text-decoration:none;}
+
+dt {font-weight:bold;}
+
+ol {list-style-type:decimal;}
+ol ol {list-style-type:lower-alpha;}
+ol ol ol {list-style-type:lower-roman;}
+ol ol ol ol {list-style-type:decimal;}
+ol ol ol ol ol {list-style-type:lower-alpha;}
+ol ol ol ol ol ol {list-style-type:lower-roman;}
+ol ol ol ol ol ol ol {list-style-type:decimal;}
+
+.txtOptionInput {width:11em;}
+
+#contentWrapper .chkOptionInput {border:0;}
+
+.externalLink {text-decoration:underline;}
+
+.indent {margin-left:3em;}
+.outdent {margin-left:3em; text-indent:-3em;}
+code.escaped {white-space:nowrap;}
+
+.tiddlyLinkExisting {font-weight:bold;}
+.tiddlyLinkNonExisting {font-style:italic;}
+
+/* the 'a' is required for IE, otherwise it renders the whole tiddler in bold */
+a.tiddlyLinkNonExisting.shadow {font-weight:bold;}
+
+#mainMenu .tiddlyLinkExisting,
+	#mainMenu .tiddlyLinkNonExisting,
+	#sidebarTabs .tiddlyLinkNonExisting {font-weight:normal; font-style:normal;}
+#sidebarTabs .tiddlyLinkExisting {font-weight:bold; font-style:normal;}
+
+.header {position:relative;}
+.header a:hover {background:transparent;}
+.headerShadow {position:relative; padding:4.5em 0em 1em 1em; left:-1px; top:-1px;}
+.headerForeground {position:absolute; padding:4.5em 0em 1em 1em; left:0px; top:0px;}
+
+.siteTitle {font-size:3em;}
+.siteSubtitle {font-size:1.2em;}
+
+#mainMenu {position:absolute; left:0; width:10em; text-align:right; line-height:1.6em; padding:1.5em 0.5em 0.5em 0.5em; font-size:1.1em;}
+
+#sidebar {position:absolute; right:3px; width:16em; font-size:.9em;}
+#sidebarOptions {padding-top:0.3em;}
+#sidebarOptions a {margin:0em 0.2em; padding:0.2em 0.3em; display:block;}
+#sidebarOptions input {margin:0.4em 0.5em;}
+#sidebarOptions .sliderPanel {margin-left:1em; padding:0.5em; font-size:.85em;}
+#sidebarOptions .sliderPanel a {font-weight:bold; display:inline; padding:0;}
+#sidebarOptions .sliderPanel input {margin:0 0 .3em 0;}
+#sidebarTabs .tabContents {width:15em; overflow:hidden;}
+
+.wizard {padding:0.1em 1em 0em 2em;}
+.wizard h1 {font-size:2em; font-weight:bold; background:none; padding:0em 0em 0em 0em; margin:0.4em 0em 0.2em 0em;}
+.wizard h2 {font-size:1.2em; font-weight:bold; background:none; padding:0em 0em 0em 0em; margin:0.4em 0em 0.2em 0em;}
+.wizardStep {padding:1em 1em 1em 1em;}
+.wizard .button {margin:0.5em 0em 0em 0em; font-size:1.2em;}
+.wizardFooter {padding:0.8em 0.4em 0.8em 0em;}
+.wizardFooter .status {padding:0em 0.4em 0em 0.4em; margin-left:1em;}
+.wizard .button {padding:0.1em 0.2em 0.1em 0.2em;}
+
+#messageArea {position:fixed; top:2em; right:0em; margin:0.5em; padding:0.5em; z-index:2000; _position:absolute;}
+.messageToolbar {display:block; text-align:right; padding:0.2em 0.2em 0.2em 0.2em;}
+#messageArea a {text-decoration:underline;}
+
+.tiddlerPopupButton {padding:0.2em 0.2em 0.2em 0.2em;}
+.popupTiddler {position: absolute; z-index:300; padding:1em 1em 1em 1em; margin:0;}
+
+.popup {position:absolute; z-index:300; font-size:.9em; padding:0; list-style:none; margin:0;}
+.popup .popupMessage {padding:0.4em;}
+.popup hr {display:block; height:1px; width:auto; padding:0; margin:0.2em 0em;}
+.popup li.disabled {padding:0.4em;}
+.popup li a {display:block; padding:0.4em; font-weight:normal; cursor:pointer;}
+.listBreak {font-size:1px; line-height:1px;}
+.listBreak div {margin:2px 0;}
+
+.tabset {padding:1em 0em 0em 0.5em;}
+.tab {margin:0em 0em 0em 0.25em; padding:2px;}
+.tabContents {padding:0.5em;}
+.tabContents ul, .tabContents ol {margin:0; padding:0;}
+.txtMainTab .tabContents li {list-style:none;}
+.tabContents li.listLink { margin-left:.75em;}
+
+#contentWrapper {display:block;}
+#splashScreen {display:none;}
+
+#displayArea {margin:1em 17em 0em 14em;}
+
+.toolbar {text-align:right; font-size:.9em;}
+
+.tiddler {padding:1em 1em 0em 1em;}
+
+.missing .viewer,.missing .title {font-style:italic;}
+
+.title {font-size:1.6em; font-weight:bold;}
+
+.missing .subtitle {display:none;}
+.subtitle {font-size:1.1em;}
+
+.tiddler .button {padding:0.2em 0.4em;}
+
+.tagging {margin:0.5em 0.5em 0.5em 0; float:left; display:none;}
+.isTag .tagging {display:block;}
+.tagged {margin:0.5em; float:right;}
+.tagging, .tagged {font-size:0.9em; padding:0.25em;}
+.tagging ul, .tagged ul {list-style:none; margin:0.25em; padding:0;}
+.tagClear {clear:both;}
+
+.footer {font-size:.9em;}
+.footer li {display:inline;}
+
+.annotation {padding:0.5em; margin:0.5em;}
+
+* html .viewer pre {width:99%; padding:0 0 1em 0;}
+.viewer {line-height:1.4em; padding-top:0.5em;}
+.viewer .button {margin:0em 0.25em; padding:0em 0.25em;}
+.viewer blockquote {line-height:1.5em; padding-left:0.8em;margin-left:2.5em;}
+.viewer ul, .viewer ol {margin-left:0.5em; padding-left:1.5em;}
+
+.viewer table, table.twtable {border-collapse:collapse; margin:0.8em 1.0em;}
+.viewer th, .viewer td, .viewer tr,.viewer caption,.twtable th, .twtable td, .twtable tr,.twtable caption {padding:3px;}
+table.listView {font-size:0.85em; margin:0.8em 1.0em;}
+table.listView th, table.listView td, table.listView tr {padding:0px 3px 0px 3px;}
+
+.viewer pre {padding:0.5em; margin-left:0.5em; font-size:1.2em; line-height:1.4em; overflow:auto;}
+.viewer code {font-size:1.2em; line-height:1.4em;}
+
+.editor {font-size:1.1em;}
+.editor input, .editor textarea {display:block; width:100%; font:inherit;}
+.editorFooter {padding:0.25em 0em; font-size:.9em;}
+.editorFooter .button {padding-top:0px; padding-bottom:0px;}
+
+.fieldsetFix {border:0; padding:0; margin:1px 0px 1px 0px;}
+
+.sparkline {line-height:1em;}
+.sparktick {outline:0;}
+
+.zoomer {font-size:1.1em; position:absolute; overflow:hidden;}
+.zoomer div {padding:1em;}
+
+* html #backstage {width:99%;}
+* html #backstageArea {width:99%;}
+#backstageArea {display:none; position:relative; overflow: hidden; z-index:150; padding:0.3em 0.5em 0.3em 0.5em;}
+#backstageToolbar {position:relative;}
+#backstageArea a {font-weight:bold; margin-left:0.5em; padding:0.3em 0.5em 0.3em 0.5em;}
+#backstageButton {display:none; position:absolute; z-index:175; top:0em; right:0em;}
+#backstageButton a {padding:0.1em 0.4em 0.1em 0.4em; margin:0.1em 0.1em 0.1em 0.1em;}
+#backstage {position:relative; width:100%; z-index:50;}
+#backstagePanel {display:none; z-index:100; position:absolute; width:90%; margin:0em 3em 0em 3em; padding:1em 1em 1em 1em;}
+.backstagePanelFooter {padding-top:0.2em; float:right;}
+.backstagePanelFooter a {padding:0.2em 0.4em 0.2em 0.4em;}
+#backstageCloak {display:none; z-index:20; position:absolute; width:100%; height:100px;}
+
+.whenBackstage {display:none;}
+.backstageVisible .whenBackstage {display:block;}
+/*}}}*/

ADDED   stml2/modules/twiki/twiki-mod.scm
Index: stml2/modules/twiki/twiki-mod.scm
==================================================================
--- /dev/null
+++ stml2/modules/twiki/twiki-mod.scm
@@ -0,0 +1,984 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;;
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; twiki module
+(require-extension sqlite3 regex posix md5 message-digest base64)
+(import (prefix base64 base64:))
+
+;; TODO
+;;
+;; * Inline tiddlers [inline[TiddlerName]]
+;; * Pics            [pic X Y[picname.jpg]]
+;; * Move twiki parsing/expanding to mattsutils as loadable module
+
+;; Routines intended to be overridden by end users
+;;  (twiki:access keys wiki-name user-id)
+;; search the code for "override" for more.
+
+;; twiki css
+;; =========
+;; Block                tag
+;; -----                ---
+;; twiki                twiki
+;; twiki body div       twiki-node
+;; twiki main menu      twiki-main-menu
+
+;; This is the currently supported mechanism. Postgres will be added later -mrw- 7/26/2009
+;;
+(define (twiki:open-db key . create-not-ok)
+  ;; (s:log "Got to twiki:open-db with key: " key)
+  (let* ((create-ok (if (null? create-not-ok) #t (car create-not-ok)))
+	 (fdat      (twiki:key->fname key))
+	 (basepath  (sdat-get-twikidir s:session))
+	 (fpath     (car fdat))
+	 (fname     (cadr fdat))
+	 (fulldir   (conc basepath "/" fpath))
+	 (fullname  (let ((fn (conc fulldir "/" fname)))
+		      (if (sdat-get-debugmode s:session)(s:log "\ntwikipath: " fn))
+		      fn))
+	 (fexists   (file-exists? fullname))
+	 (db        (if fexists (dbi:open 'sqlite3 (list (cons 'dbname fullname))) #f)))
+    (if (and (not db)
+	     (not create-ok))
+	(exit 100)
+	(begin
+	  (if (not fexists)
+	      (begin
+		;; (print "fullname: " fullname)
+		(if (sdat-get-debugmode s:session)
+		    (s:log "\ncreating fulldir: " fulldir))
+		(twiki:register-wiki key fullname)
+		(system (conc "mkdir -p " fulldir)) ;; create the path
+		(if (file-exists? fpath)
+		    (s:log "OK: dir " fpath " has been made")
+		    (s:log "ERROR: Failed to make the path for the twiki"))
+		(set! db (dbi:open 'sqlite3 (list (cons 'dbname fullname))))
+		(for-each 
+		 (lambda (sqry)
+		   ;; (print sqry)
+		   (dbi:exec db sqry))
+		 ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come...
+		 (list
+		  "CREATE TABLE pics      (id INTEGER PRIMARY KEY,name TEXT,wiki_id INTEGER,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
+		  "CREATE TABLE dats      (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);"
+		  ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do:
+		  ;;    select where created_on < somedate order by created_on desc limit 1
+		  "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
+		  ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag
+		  "CREATE TABLE revs     (id INTEGER PRIMARY KEY,tag TEXT);"
+		  ;; wikis is here for when postgresql support is added or if a sub wiki is created. 
+		  "CREATE TABLE wikis    (id INTEGER PRIMARY KEY,name TEXT,created_on INTEGER);"
+		  ;; access control, negative numbered groups are private groups, postive numbered groups are system groups
+		  ;; permissions are on a per-wiki granularity
+		  ;; access; 0=none,1=read,2=read/write
+		  "CREATE TABLE perms    (id INTEGER PRIMARY KEY,wiki_id INTEGER,group_id INTEGER,access INTEGER);"
+		  "CREATE TABLE groups   (id INTEGER PRIMARY KEY,name TEXT);"
+		  "CREATE TABLE members  (id INTEGER PRIMARY KEY,person_id INTEGER,group_id INTEGER);"
+		  ;; setup and configuration data
+		  "CREATE TABLE meta     (id INTEGER PRIMARY KEY,key TEXT,val TEXT);"
+		  ;; need to create an entry for *this* twiki
+		  (conc "INSERT INTO wikis (id,name,created_on) VALUES (1,'main'," (current-seconds) ");")))
+		;;     (conc "INSERT INTO tiddlers (wiki_id,name,created_on) VALUES(1,'MainMenu'," (current-seconds) ");")))))
+		(twiki:save-tiddler db "MainMenu" "[[FirstTiddler]]" "" 1 1)))
+	  ;; (sqlite3:set-busy-timeout!(dbi:db-conn db) 1000000)
+	  db))))
+
+;;======================================================================
+;; twikis (db naming, sqlite vs postgresql, keys etc.
+;;======================================================================
+
+;; A wiki is specified by a list of keys, here we convert that list to a single string
+(define (twiki:keys->key keys)
+  (if (not (null? keys))
+      (string-intersperse (map conc keys) " ")
+      " "))
+
+(define (twiki:key->fname key)
+  (let* (;; (md5keypath (md5:digest key)) ;; (twiki:keys->key keys)))
+	 (keypath    (twiki:web64enc key))
+	 (delta      (quotient (string-length keypath) 3)) ;; 
+	 (p1         (substring keypath 0           delta)) ;;  0  8))
+	 (p2         (substring keypath delta       (* delta 2)));;  8 16))
+	 (p3         (substring keypath (* delta 2) (* delta 3)))) ;; 16 24))
+    (list (string-intersperse (list "dbs" p1 p2 p3) "/") keypath)))
+
+;; look up the wid based on the keys, this is used for sub wikis only. I.e. a wiki instantiated inside another wiki 
+;; giving a separate namespace to all the tiddlers
+(define (twiki:name->wid db name) 
+  (let ((wid (dbi:get-one db "SELECT id FROM wikis WHERE name=?;" name)))
+    (if wid wid
+	(begin
+	  (dbi:exec db "INSERT INTO wikis (name,created_on) VALUES(?,?);" name (current-seconds))
+	  (twiki:name->wid db name)))))
+
+;;======================================================================
+;; twiki record
+;;======================================================================
+
+;; make-vector-record twiki wiki wid name key dbh
+(define (make-twiki:wiki)(make-vector 5))
+(define-inline (twiki:wiki-get-wid    vec)    (vector-ref  vec 0))
+(define-inline (twiki:wiki-get-name   vec)    (vector-ref  vec 1))
+(define-inline (twiki:wiki-get-key    vec)    (vector-ref  vec 2))
+(define-inline (twiki:wiki-get-dbh    vec)    (vector-ref  vec 3))
+(define-inline (twiki:wiki-get-perms  vec)    (vector-ref  vec 4))
+
+(define-inline (twiki:wiki-set-wid!   vec val)(vector-set! vec 0 val))
+(define-inline (twiki:wiki-set-name!  vec val)(vector-set! vec 1 val))
+(define-inline (twiki:wiki-set-key!   vec val)(vector-set! vec 2 val))
+(define-inline (twiki:wiki-set-dbh!   vec val)(vector-set! vec 3 val))
+(define-inline (twiki:wiki-set-perms! vec val)(vector-set! vec 4 val))
+
+;;======================================================================
+;; twiki misc
+;;======================================================================
+
+;; returns help html
+(define (twiki:help section)
+  (let ((main (twiki:div 
+	       'node "twiki-help"
+	       (list 
+		(twiki:h3 "Help stuff")
+		(twiki:pre "
+Link to page:      [[Page Title]]
+Heading3:          !!! The heading
+Underline:         __underlined__
+Table:             | cell1 | cell2 |
+List:              # item1
+                   ## item2
+Bullet:            * item1
+                   ** item2
+Preformatted:      {{{stuff here}}}
+Insert a picture:  [pic[PicName]]
+Or with size:      [pic100x100[PicName]]
+Upload the picture using the \"Pic\" link first")))))
+	;;(case section
+    main))
+
+;;======================================================================
+;; twiki access control
+;;======================================================================
+
+;; idea here is for the end user to redefine this routine,
+;; and call twiki:interal-access if desired
+;; 
+;; if override is #t then give access no matter what
+(define (twiki:access keys wiki-name user-id)
+  '(r w))
+
+;; Add support for storing groups, users and access internally
+;; 
+(define (twiki:internal-access keys wiki-name user-id)
+  #f)
+
+;;======================================================================
+;; twiki registry
+;;======================================================================
+
+;; these can be overridden by end user (just create a new routine by the same name)
+
+(define (twiki:open-registry)
+  (let* ((basepath  (sdat-get-twikidir s:session))
+	 (regfile   (conc basepath "/registry.db"))
+	 (regexists (file-exists? regfile))
+	 (db        #f))
+    (if (sdat-get-debugmode s:session)
+	(s:log "regfile: " regfile " regexists: " regexists " db: " db))
+    (set! db (dbi:open 'sqlite3 (list (cons 'dbname regfile))))
+    (if regexists
+	db
+	(begin
+	  (for-each (lambda (stmt)(dbi:exec db stmt))
+		    (list "CREATE TABLE wikis (key TEXT PRIMARY KEY,path TEXT,creation_date INTEGER,creator_id INTEGER);"))
+	  db))))
+
+(define (twiki:register-wiki key path)
+  (let ((db (twiki:open-registry)))
+    (dbi:exec db 
+	      "INSERT OR REPLACE INTO wikis (key,path,creation_date,creator_id) VALUES(?,?,?,?);"
+	      key path (current-seconds) (twiki:get-id))
+    (dbi:close db)))
+
+;;======================================================================
+;; tiddlers
+;;======================================================================
+
+(define twiki:tiddler-selector "SELECT t.id,t.name,t.rev,t.dat_id,t.created_on,t.owner_id FROM tiddlers AS t INNER JOIN dats AS d ON t.dat_id=d.id")
+(define (twiki:tiddler-make)(make-vector 8 #f))
+(define-inline (twiki:tiddler-get-id           vec)    (vector-ref  vec 0))
+(define-inline (twiki:tiddler-get-name         vec)    (vector-ref  vec 1))
+(define-inline (twiki:tiddler-get-rev          vec)    (vector-ref  vec 2))
+(define-inline (twiki:tiddler-get-dat-id       vec)    (vector-ref  vec 3))
+(define-inline (twiki:tiddler-get-created_on   vec)    (vector-ref  vec 4))
+(define-inline (twiki:tiddler-get-owner_id     vec)    (vector-ref  vec 5))
+;; (define-inline (twiki:tiddler-get-dat-type     vec)    (vector-ref  vec 6))
+
+(define-inline (twiki:tiddler-set-id!          vec val)(vector-set! vec 0 val) vec)
+(define-inline (twiki:tiddler-set-name!        vec val)(vector-set! vec 1 val) vec)
+(define-inline (twiki:tiddler-set-rev!         vec val)(vector-set! vec 2 val) vec)
+(define-inline (twiki:tiddler-set-dat-id!      vec val)(vector-set! vec 3 val) vec)
+(define-inline (twiki:tiddler-set-created_on!  vec val)(vector-set! vec 4 val) vec)
+;; (define-inline (twiki:tiddler-set-owner_id!    vec val)(vector-set! vec 5 val))
+
+;;======================================================================
+;; Routines for displaying, editing, browsing etc. tiddlers
+;;======================================================================	
+
+;; should change this to take a tiddler structure?
+;; This is the display of a single tiddler
+(define (twiki:view dat  tkey wid tiddler wiki) ;; close, close others, edit, more
+  (let ((is-not-main  (not (equal? "MainMenu" (twiki:tiddler-get-name tiddler))))
+	(edit-allowed (member 'w (twiki:wiki-get-perms wiki))))
+    (s:div 'class "tiddler"
+	   (s:div 'class "tiddler-menu"
+		  (if (equal? "MainMenu" (twiki:tiddler-get-name tiddler))
+		      (if edit-allowed
+			  (list (s:a "edit" 'href
+				     (s:link-to (twiki:get-link-back-to-current)
+						'edit_tiddler (twiki:tiddler-get-id tiddler))))
+			  '())
+		      (s:div 'class "tiddler-menu-internal"
+		       (s:a "close" 'href (s:link-to (twiki:get-link-back-to-current) 'close_tiddler (twiki:tiddler-get-id tiddler))) "."
+		       (s:a "close others" 'href (s:link-to (twiki:get-link-back-to-current) 'close_other_tiddlers (twiki:tiddler-get-id tiddler))) "."
+		       (if edit-allowed
+			   (s:a "edit"  'href (s:link-to (twiki:get-link-back-to-current) 'edit_tiddler (twiki:tiddler-get-id tiddler)))
+			   '()))))
+	    (s:p (twiki:dat->html dat wiki)))))
+
+(define (twiki:view-tiddler db  tkey wid tiddler wiki)
+  (let* ((dat-id (twiki:tiddler-get-dat-id tiddler))
+	 (dat    (twiki:get-dat db dat-id))
+	 (tnum   (twiki:tiddler-get-id tiddler)))
+    ;; (s:log "twid: " dat-id " dat: " dat)
+    (twiki:view dat  tkey wid tiddler wiki)))
+
+;; call with param => action-name-key e.g. save-bWFpbg__-aGVsbG8gbnVyc2U_ (save main "hello nurse")
+;; this one is called when an edit form is submitted (i.e. POST)
+(define (twiki:action params)
+  (if (and (list? params)
+	   (> (length params) 0))
+      (let* ((cmdln (string-split (car params) "-"))
+	     (cmd   (string->symbol (car cmdln)))
+	     (tkey  (twiki:web64dec (caddr cmdln)))
+	     (wid   (string->number (cadr cmdln)))
+	     (tdb   (twiki:open-db tkey)))
+	(s:log "cmdln: " cmdln " cmd: " cmd " tkey: " tkey " wid: " wid)
+	(case cmd
+	  ((save)
+	   (twiki:save-curr-tiddler tdb wid))
+	  ((savepic)
+	   (s:log "twiki:action got to savepic")
+	   (twiki:save-pic-from-form tdb wid))
+	  ((cancel) ;; deprecated. Use a link for this (i.e in the twiki:twiki proc
+	   (s:del! (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
+	   )))))
+
+;; generate a form for editing a twiddler tnum
+(define (twiki:edit-tiddler db tkey wid tnum)
+  (s:log "twiki:edit-tiddler: tkey=" tkey " wid: " wid)
+  (let* ((enc-key  (twiki:web64enc tkey))
+	 (tiddats  (twiki:get-tiddlers-by-num db wid (list tnum))))
+    (if (null? tiddats)
+	(let* ((tid    0)
+	       (dat-id 0))
+	  (s:set! "twiki_title" "")
+	  (s:set! "twiki_body"  ""))
+	(let* ((tid    (car tiddats))
+	       (dat-id (twiki:tiddler-get-dat-id tid)))
+	  ;; (s:log "tid: " tid " dat-id: " dat-id)
+	  (s:set! "twiki_title" (twiki:tiddler-get-name tid))
+	  (s:set! "twiki_body"  (twiki:get-dat db dat-id))))
+    (s:form 'action (s:link-to (twiki:get-link-back-to-current)
+			       'action (conc "twiki.save-" (number->string wid) "-" enc-key))
+	    'method "post" ;; 'twikiname tkey ;; done, cancel, delete
+	    (s:input 'type "submit"   'name "form-name" 'value "save" 'twikiname tkey)
+	    ;; (s:a "done" 'href (s:link-to (twiki:get-link-back-to-current) 'save_tmenu tnum))
+	    (s:a "cancel" 'href (s:link-to (twiki:get-link-back-to-current) 'cancel_tedit tnum)) "."
+	    (s:a "delete" 'href (s:link-to (twiki:get-link-back-to-current) 'delete_tiddler tnum))(s:br)
+	    (s:input-preserve 'type "text" 'name "twiki_title" 'size "58" 'maxlength "150")
+	    (s:textarea-preserve 'type "textarea" 'name "twiki_body" 'rows "10" 'cols "65")
+	    (s:p "Tags" (s:input-preserve 'type "text" 'name "twiki_tags" 'size "55" 'maxlength "150")))))
+
+;; save a tiddler to the db for the twiki twik, getting data from the INPUT
+(define (twiki:save-curr-tiddler tdb wid)
+  (formdat:printall (sdat-get-formdat s:session) s:log)
+  (let* ((heading (s:get-input 'twiki_title))
+	 (body    (s:get-input 'twiki_body))
+	 (tags    (s:get-input 'twiki_tags))
+	 (uid     (twiki:get-id)))
+    ;; (s:log "twiki:save-curr-tiddler heading: " heading " body: " body " tags: " tags)
+    (s:set! 'twiki_title heading)
+    (if body
+	(begin
+	  (set! body (string-chomp body))
+	  (s:set! 'twiki_body  body)))
+    (s:set! 'twiki_tags  tags)
+    (s:del! (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
+    (let ((res (twiki:save-tiddler tdb heading body tags wid uid)))
+      ;; Now, replace this twiddler number in the view list with 
+      ;; the new number from the db
+      (twiki:normalize-current-twiddlers tdb wid)
+      (s:del! 'twiki_title)
+      (s:del! 'twiki_body)
+      (s:del! 'twiki_tags)
+      res)
+    ))
+
+(define (twiki:normalize-current-twiddlers tdb wid)
+  (let* ((cvar      (conc "CURRENT_TWIDLERS:" wid))
+	 (curr-slst (s:get cvar))
+	 (curr-lst  (map string->number (string-split curr-slst ",")))
+	 (tdlrs     (twiki:get-tiddlers-by-num tdb wid curr-lst))
+	 (names     (remove (lambda (t)(string=? "MainMenu" t))
+			    (map twiki:tiddler-get-name tdlrs)))
+	 (newnums   (map twiki:tiddler-get-id 
+			 (map (lambda (tn)
+				(twiki:get-tiddler-by-name tdb wid tn))
+			      names))))
+    (s:set! cvar (string-intersperse (map number->string newnums)
+				     ","))))
+    
+;; generic save tiddler
+(define (twiki:save-tiddler tdb heading body tags wid uid)
+    (if (misc:non-zero-string heading)
+	(let* ((prev-tid (twiki:get-tiddler-by-name tdb wid heading))
+	       (prev-dat-id (if prev-tid 
+				(twiki:tiddler-get-dat-id prev-tid)
+				-1))
+	       (dat-id (twiki:save-dat tdb body 0))) ;; 0=text
+	  ;; (s:log "twiki:save-tiddler dat-id: " dat-id " body: " body)
+	  (if (equal? prev-dat-id dat-id) ;; no need to insert a new record if the dat didn't change
+	      #t
+	      (dbi:exec tdb 
+			"INSERT INTO tiddlers (wiki_id,name,dat_id,created_on,owner_id) VALUES(?,?,?,?,?);"
+			wid heading dat-id (current-seconds) uid))
+	  #t) ;; success
+	#f))  ;; non-success
+
+;; text=0, jpg=1, png=2
+(define (twiki:save-dat db dat type)
+  (let* ((md5sum (message-digest-string (md5-primitive) dat)) ;; (md5-digest dat))
+	 (datid  (twiki:dat-exists? db md5sum type))
+	 (datblob (if (string? dat)
+		      (string->blob dat)
+		      dat)))
+    (if datid
+	datid
+	(begin
+	  (case type
+	    ((0)   (dbi:exec db "INSERT INTO dats (md5sum,dat,type) VALUES(?,?,?);" md5sum datblob 0))
+	    ((1)   (dbi:exec db "INSERT INTO dats (md5sum,dat,type) VALUES(?,?,?);" md5sum datblob 1))
+	    (else  (dbi:exec db "INSERT INTO dats (md5sum,dat,type) VALUES(?,?,?);" md5sum datblob type)))
+	  (twiki:dat-exists? db md5sum type)))))
+       
+(define (twiki:dat-exists? db md5sum type)
+  (dbi:get-one db "SELECT id FROM dats WHERE md5sum=? AND type=?;" md5sum type))
+
+(define (twiki:get-dat db id)
+  (if (and id (number? id))
+      (if (< id 0)
+	  ""
+	  (let ((res (dbi:get-one-row db "SELECT dat,type FROM dats WHERE id=?;" id)))
+	    (if res
+		(case (vector-ref res 1)
+		  ((0)(blob->string (vector-ref res 0)))
+		  (else (vector-ref res 0)))
+		#f)))
+      #f))
+
+(define (twiki:maint_area tdb wid tkey wiki)
+  (let ((maint (s:get-param 'twiki_maint))
+	(write-perm (member 'w (twiki:wiki-get-perms wiki))))
+    (s:div 'class "twiki-menu-internal"
+     (if write-perm
+	 (list (s:a "Orphans"  'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 1))(s:br)
+	       (s:a "Pics"     'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 2))(s:br)
+	       (s:a "Help"     'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 4))(s:br))
+	 '())
+     (s:a "Search"   'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 3))(s:br)
+     (case maint
+       ((1)
+	(twiki:list-orphans tdb))
+       (else
+	 '())))))
+
+;;======================================================================
+;; Orphans
+;;======================================================================
+(define (twiki:make-tiddler-list tdlrs . tnums)
+  (conc (string-intersperse 
+	 (map conc (delete-duplicates
+		    (append (map twiki:tiddler-get-id tdlrs) tnums)))
+	 ",")))
+
+(define (twiki:get-orphans tdb)
+  '())
+
+(define (twiki:list-orphans tdb)
+  '())
+
+;;======================================================================
+;; Pictures
+;;======================================================================
+(define (twiki:pic_mgmt tdb wid tkey)
+  (s:div 
+   (s:a "Add pic" 'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 2 'twiki_maint_add_pics 1))(s:br)
+   (if (s:get-param "twiki_maint_add_pics")
+       (s:form 'enctype "multipart/form-data" ;; 'name "does-a-form-have-a-name"
+	       (s:input 'type "file" 'name "input-picture" 'value "Upload pic")
+	       (s:input 'type "submit" 'name "submit-picture" 'value "Submit")
+	       'method "post" 
+	       'action (s:link-to (twiki:get-link-back-to-current) 'action (conc "twiki.savepic-" (number->string wid) "-" (twiki:web64enc tkey)))
+	       (s:input 'type "text" 'name "picture-name" 'value ""))
+       '())
+   (let ((pics (dbi:get-rows tdb "SELECT id,name,dat_id,thumb_dat_id FROM pics WHERE wiki_id=?;" wid)))
+     (map (lambda (pic)
+	    (s:div 'class "tiddlerthumb"
+		   (s:img 'title (vector-ref pic 1) 'alt (vector-ref pic 1)
+		 	  ;; 'src (s:link-to "twiki" 'wiki_key (twiki:web64enc tkey) 'image  (vector-ref pic 0)))
+		 	  'src (s:link-to "twiki" 'wiki_key (conc (number->string wid) "-" (twiki:web64enc tkey))
+					  'thumb  (vector-ref pic 0)))
+		   ;;       (conc "twiki/" wid "/thumbs/" (vector-ref pic 0))))
+		   (vector-ref pic 0) (vector-ref pic 1)))
+	  pics))))
+
+(define  (twiki:save-pic-from-form tdb wid)
+  (let* ((pic-dat  (s:get-input 'input-picture))
+	 (alt-name (s:get-input 'picture-name)))
+    (if pic-dat
+	(begin
+	  (s:log "twiki:save-pic-from-form with pic-dat=" pic-dat " and alt-name=" alt-name)
+	  (twiki:save-pic tdb pic-dat wid alt-name))
+	#f)))
+
+;; get pic id for a pic name, returns the latest
+(define (twiki:get-pic-id tdb pic-name wid)
+  (dbi:get-one tdb "SELECT pics.id FROM pics WHERE pics.name=? AND pics.wiki_id=? ORDER BY pics.id DESC LIMIT 1;" pic-name wid))
+
+(define (twiki:save-pic tdb pic-dat wid alt)
+  (let ((pic-name (car pic-dat))
+	(pic-type (cadr pic-dat))
+	(pic-data (caddr pic-dat))
+	;; I'm not too happy with this solution but I can't seem to chomp the \n\d from the end of the string
+	(alt-name (if alt (string-substitute (regexp "[^\\w ]") "" alt #t) #f)))
+    (if (and alt-name
+	     (string-match (regexp "\\w+") alt-name))
+	(set! pic-name alt-name))
+    (s:log "alt: " alt " alt-name: " alt-name)
+    (if pic-data
+	(let ((dat-id (twiki:save-dat tdb pic-data (twiki:mime->twiki-type pic-type)))
+	      (creation-time (current-seconds)))
+	  ;; (twiki:delete-pic-by-name tdb pic-name)
+	  (dbi:exec tdb 
+		    "INSERT INTO pics (name,wiki_id,dat_id,created_on,owner_id) VALUES(?,?,?,?,?);"
+		    pic-name wid dat-id creation-time (twiki:get-id))
+	  (let ((pic-id (twiki:get-pic-id tdb pic-name wid)))
+	    (twiki:make-thumbnail tdb pic-id wid))
+	  #t)
+	#f)))
+
+(define (twiki:get-pic-dat tdb wid pic-id)
+  (dbi:get-one tdb "SELECT dat FROM pics INNER JOIN dats ON pics.dat_id=dats.id WHERE pics.id=? AND wiki_id=?;" pic-id wid))
+
+(define (twiki:get-thumb-dat tdb wid pic-id)
+  (dbi:get-one tdb "SELECT dat FROM pics INNER JOIN dats ON pics.thumb_dat_id=dats.id WHERE pics.id=? AND wiki_id=?;" pic-id wid))
+
+;; this one sets up the Content type, puts the data into page-dat and is done
+(define (twiki:return-image-dat tdb wid pic-id)
+  (let ((dat  (twiki:get-pic-dat tdb wid pic-id)))
+    (s:log "twiki:return-image-dat dat is: " dat " of size: " (if (blob? dat)(blob-size dat) "[not a blob]"))
+    (sdat-set-page-type!    s:session 'image)
+    (sdat-set-content-type! s:session "image/jpeg")
+    (sdat-set-alt-page-dat! s:session dat)))
+    ;; (session:alt-out s:session)))
+
+;; this one sets up the Content type, puts the data into page-dat and is done
+(define (twiki:return-thumb-dat tdb wid pic-id)
+  (let ((dat  (twiki:get-thumb-dat tdb wid pic-id)))
+    (s:log "twiki:return-image-dat dat is: " dat " of size: " (if (blob? dat)(blob-size dat) "[not a blob]"))
+    (sdat-set-page-type!    s:session 'image)
+    (sdat-set-content-type! s:session "image/jpeg")
+    (sdat-set-alt-page-dat! s:session dat)))
+    ;; (session:alt-out s:session)))
+  
+(define (twiki:make-thumbnail tdb pic-id wid)
+  (let ((indat  (twiki:get-pic-dat tdb wid pic-id)))
+    ;;   (outdat (open-output-string)))
+    (let-values (((inp oup pid)(process "convert" (list "-size" "500x180" "-" "-thumbnail" "250x90" "-unsharp" "0x.5" "-"))))
+		(write-string (blob->string indat) #f oup)
+		(close-input-port oup)
+		;; (write-string #f inp (blob->string indat))
+		(let ((l (read-string #f inp)))
+		  (close-output-port inp)
+		  ;; (write-string l #f outdat)
+		  (let* ((newdat (string->blob l)) ;; (get-output-string outdat)))
+			 (dat-id (twiki:save-dat tdb newdat 2))) ;; bug?
+		    (dbi:exec tdb "UPDATE pics SET thumb_dat_id=? WHERE id=?;" dat-id pic-id)
+		    dat-id)))))
+
+;; not tested
+(define (twiki:picdat->thumbdat picdat)
+  (let-values (((inp oup pid)(process "convert" ;; (list "-size" "500x180" "-" "-thumbnail" "250x90" "-unsharp" "0x.5" "-"))))
+				      (list "-size" "500x180" "-" "-thumbnail" "200x70" "-unsharp" "0x.5" "-"))))
+	      (write-string (blob->string picdat) #f oup)
+	      (close-input-port oup)
+	      ;; (write-string #f inp (blob->string indat))
+	      (let ((l (read-string #f inp)))
+		(close-output-port inp)
+		(write-string l #f oup)
+		(string->blob l))))
+
+(define (twiki:mime->twiki-type mime-type)
+  (case (string->symbol mime-type)
+    ((image/jpeg) 1)
+    ((image/png)  2)
+    (else 0)))
+
+;;======================================================================
+;; Wiki stuff
+;;======================================================================
+
+;; curr-tiddlers is a list of the names of the current tiddlers displayed
+;; tiddler-under-edit is the tiddler being edited (or #f for none).
+(define (twiki:wiki name keys)
+  (let ((perms   (twiki:access name keys (twiki:get-id))))
+    ;; (s:log "twiki:wiki name: \"" name "\" keys: " keys)
+    (if (or (not name)
+	    (string=? name "")) ;; name must be "" or #f to get here and return an image
+	;; handle returning pictures, note keys and name are ignored for these. They are called out in
+	;; the twiki/view.scm (twiki:twiki "blah" '(nada foo)) call.
+	(let ((image   (s:get-param "image"))
+	      (thumb   (s:get-param "thumb")))
+	  (s:log "image: " image " thumb: " thumb " wiki_key: " (s:get-param 'wiki_key))
+	  (if (and (member 'r perms) image)
+	      (let* ((varlst (string-split (s:get-param 'wiki_key) "-"))
+		     (tkey (twiki:web64dec (cadr varlst)))
+		     (wid  (string->number (car  varlst)))
+		     (tdbn (twiki:open-db tkey #f)))
+		(s:log "tkey: " tkey " image number: " image)
+		(twiki:return-image-dat tdbn wid (string->number image)))) ;; do not return from twiki:return-image
+	  (if (and (member 'r perms) thumb)
+	      (let* ((varlst (string-split (s:get-param 'wiki_key) "-"))
+		     (tkey   (twiki:web64dec (cadr varlst)))
+		     (wid    (string->number (car  varlst)))
+		     (tdbn   (twiki:open-db tkey #f)))
+		(s:log "tkey: " tkey " thumb number: " image)
+		(twiki:return-thumb-dat tdbn wid (string->number thumb))))) ;; do not return from twiki:return-image
+	(if (not (member 'r perms)) ;; read access
+	    '() ;; return a blank slate
+	    (twiki:display-wiki name keys perms)))))
+
+(define (twiki:display-wiki name keys perms)
+  (let* ((wikidat  (make-twiki:wiki))
+	 (tkey     (twiki:keys->key keys))
+	 (tdb      (twiki:open-db tkey))
+	 (wid      (twiki:name->wid tdb name))
+	 (cvar     (conc "CURRENT_TWIDLERS:" wid)) ;; page var to store current twiddlers being viewed
+	 (cvar-ed  (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
+	 (tnumedit (if (s:get cvar-ed) 
+		       (string->number (s:get cvar-ed))
+		       #f)) ;; #f => nothing to edit, -1 create a new tiddler
+	 (tnumview #f)
+	 (lmenu    (twiki:get-tiddlers tdb wid (list "MainMenu")))
+	 ;; store tiddlers for this page/twiki in cvar (i.e. CURRENT_TWIDLERS:<wid>
+	 (tdlnums  (if (s:get cvar)
+		       (map string->number (string-split (s:get cvar) ","))
+		       '())) ;; list of tiddler numbers
+	 (tdlrs    '())
+	 (tedited  (if (member 'w perms) #f #t)) ;; force no edits if not a writer
+	 (edit-tmenu-id (if (and (member 'w perms)
+				 (s:get-param "edit_tmenu"))
+			    (string->number (s:get-param "edit_tmenu"))
+			    #f))
+	 (edit-tiddler (if  (and (member 'w perms)
+				 (s:get-param "edit_tiddler")) ;; this handles the "edit" link in the tiddler control bar
+			    (let ((t (twiki:get-tiddlers-by-num tdb wid (list (string->number (s:get-param "edit_tiddler"))))))
+			      (s:log "t: " t)
+			      (if t
+				  (car t ) ;; should be a list of one
+				  (twiki:tiddler-set-name!
+				   (twiki:tiddler-set-id! (twiki:tiddler-make) -1) "NewTiddler")))
+			    #f))
+	 (view-tiddler (if (s:get-param "view_tiddler")
+			   (let* ((tname (twiki:web64dec (s:get-param "view_tiddler")))
+				  (t     (twiki:get-tiddler-by-name tdb wid tname)))
+			     (s:log "t: " t)
+			     (if t
+				 t 
+				 (begin
+				   (twiki:save-tiddler tdb tname (conc "!" tname) "" wid (twiki:get-id))
+				   (twiki:get-tiddler-by-name tdb wid tname))))
+			   #f))
+	 ) ;; image is the dat_id, keep it simple silly.
+
+    (twiki:wiki-set-wid!  wikidat wid)
+    (twiki:wiki-set-key!  wikidat tkey)
+    (twiki:wiki-set-name! wikidat name)
+    (twiki:wiki-set-dbh!  wikidat tdb)
+    (twiki:wiki-set-perms! wikidat perms)
+
+    ;; (s:log "edit-tmenu-id: " edit-tmenu-id " edit-tiddler: " edit-tiddler)
+
+    ;; Handle other URI commands here
+    (if (s:get-param "cancel_tedit") ;; doesn't matter which tiddler - just use this to cancel any edit
+	(begin
+	  (s:del! (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
+	  (set! edit-tiddler #f)
+	  (set! tnumedit #f)
+	  (set! view-tiddler #f)
+	  (twiki:normalize-current-twiddlers tdb wid)
+	  (if (s:get cvar)
+	      (set! tdlnums (map string->number (string-split (s:get cvar) ","))))))
+    (if (s:get-param "delete_tiddler") '())
+    ;; (twiki:delete_tiddler tdb wid (string->number (s:get-param "delete_tiddler"))))
+
+    (s:set! "TWIKI_KEY" tkey) ;; this mechanism will fail for hierarchial twikis
+    ;; override the twiddler to edit when editing MainMenu
+    (if edit-tiddler
+	(begin
+	  (set! tnumedit (twiki:tiddler-get-id edit-tiddler))
+	  (s:set! 'twiki_title (twiki:tiddler-get-name edit-tiddler))
+	  (s:set! 'twiki_body  (twiki:get-dat tdb (twiki:tiddler-get-dat-id edit-tiddler)))))
+    (if view-tiddler
+	(begin
+	  (set! tnumview (twiki:tiddler-get-id view-tiddler))))
+    
+    ;; NOW WHAT FOR VIEW - fix the links, add to tdlst
+
+
+    (if edit-tmenu-id   (set! tnumedit edit-tmenu-id))
+    (if tnumedit (set! tdlnums (cons tnumedit tdlnums)))
+    (if tnumview (set! tdlnums (cons tnumview tdlnums)))
+    (set! tdlrs (twiki:get-tiddlers-by-num tdb wid tdlnums))
+
+    ;; remove tdlrs from the list if close_tiddler called
+    (if (s:get-param "close_tiddler")
+	(set! tdlrs (let ((tnum (string->number (s:get-param "close_tiddler"))))
+		      (remove (lambda (t)
+				(equal? (twiki:tiddler-get-id t) tnum))
+			      tdlrs))))
+
+    ;; remove all others if close_other_tiddlers called
+    (if (s:get-param "close_other_tiddlers")
+	(set! tdlrs (let ((tnum (string->number (s:get-param "close_other_tiddlers"))))
+		      (remove (lambda (t)
+				(not (equal? (twiki:tiddler-get-id t) tnum)))
+			      tdlrs))))
+    
+    (s:set! cvar (twiki:make-tiddler-list tdlrs))
+    (if tnumedit 
+	(s:set! cvar-ed tnumedit)
+	(s:del! cvar-ed))
+
+    ;; must have a MainMenu tiddler by now
+    (if (null? lmenu)
+	(begin
+	  (twiki:save-tiddler tdb "MainMenu" "" "" wid (twiki:get-id))
+	  (set! lmenu (twiki:get-tiddlers tdb wid (list "MainMenu")))))
+    
+    ;; get the tiddlers from the db now
+    (set! result
+	  (s:div 'class "twiki"
+	   ;; float to the right the control menu
+	   (s:div 'class "twiki-main-menu" (twiki:maint_area tdb wid tkey wikidat))
+	   (twiki:view-tiddler tdb  tkey wid (car lmenu) wikidat)
+	   ;; this is probably not needed as there is no reason to create tiddlers this way
+	   ;; (if (eq? tnumedit -1)(twiki:edit-tiddler tdb tkey wid tnumedit) '())
+	   ;; insert the picture editor window if enabled
+	   (if (equal? (s:get-param "twiki_maint") "2")(twiki:pic_mgmt tdb wid tkey) '())
+	   (if (equal? (s:get-param "twiki_maint") "4")(twiki:help 1) '())
+	   (if (not (null? tdlrs))
+	       (map (lambda (tdlr)
+		      (let ((tnum  (twiki:tiddler-get-id tdlr)))
+			(s:log "tnum: " tnum " tnumedit: " tnumedit)
+			(if (and tnumedit (not tedited) (equal? tnumedit tnum))
+			    (begin
+			      (set! tedited #t) ;; only allow editing one tiddler at a time
+			      (twiki:edit-tiddler tdb tkey wid tnum))
+			    (twiki:view-tiddler tdb  tkey wid tdlr wikidat))))
+		    tdlrs)
+	       '())))
+    (dbi:close tdb)
+    result))
+
+;; should do a single more efficient query but this is good enough
+(define (twiki:get-tiddlers db wid tnames)
+  (apply twiki:get-tiddlers-by-name db wid tnames))
+;;   (let* ((tdlrs '())
+;; 	 ;; (conn   (sdat-get-conn s:session))
+;; 	 (namelst (conc "('" (string-intersperse (map conc tnames) "','") "')"))
+;; 	 (qry     (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.id IN " namelst ";")))
+;;     ;; (print qry)
+;;     (dbi:for-each-row
+;;      (lambda (row)
+;;        (set! tdlrs (cons row tdlrs)))
+;;      db qry wid)
+;;     (reverse tdlrs))) ;; !Twiki\
+
+;; tlst is a list of tiddler nums
+(define (twiki:get-tiddlers-by-num db wid tlst)
+  ;; (s:log "Got to twiki:get-tiddlers with keys: " tlst " and wid: " wid)
+  ;; select where created_on < somedate order by created_on desc limit 1
+  (let* ((tdlrs '())
+	 (tlststr (string-intersperse (map number->string tlst) ","))
+	 (already-got (make-hash-table))
+	 (qry    (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.id IN (" tlststr ") ORDER BY created_on DESC;")))
+    (dbi:for-each-row
+     (lambda (row)
+       (let ((tname (twiki:tiddler-get-name row)))
+	 (if (not (hash-table-ref/default already-got tname #f))
+	     (begin
+	       (set! tdlrs (cons row tdlrs))
+	       (hash-table-set! already-got tname #t)))))
+     db qry wid)
+    (if (null? tdlrs) tdlrs (reverse tdlrs)))) ;; !Twiki\nTitle, pictures, etc.\n{{{\nCode\n}}}\n[[links]]\n|table|of|stuff|\n|more|stuff|here|\n"))
+
+;; wid = wiki id
+;; returns a list of twiki:tiddlers
+(define (twiki:get-tiddlers-by-name tdb wid . names)
+  (let ((tdlrs '()))
+    (for-each (lambda (name)
+		(let ((tdlr (twiki:get-tiddler-by-name tdb wid name)))
+		  (if tdlr (set! tdlrs (cons tdlr tdlrs)))))
+	      names)
+    (reverse tdlrs)))
+;; with the right query it should be possible to do this much faster approach for twiki:get-tiddlers-by-name
+;;   (let ((tdlrs '())
+;; 	(namelst (conc "('" (string-intersperse names "','") "')")))
+;;     (dbi:for-each-row
+;;      (lambda (row)
+;;        (set! tdlrs (cons row tdlrs)))
+;;      tdb
+;;      (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.name IN " namelst) wid)
+;;     (reverse tdlrs)))
+
+;; get the tiddler with the given name and the max date
+(define (twiki:get-tiddler-by-name tdb wid name)
+  (dbi:get-one-row tdb (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.name=? ORDER BY created_on DESC LIMIT 1;") wid name))
+
+(define (twiki:tiddler-name->id db tname)
+  (dbi:get-one db "SELECT id FROM tiddlers WHERE name=?;" tname))
+
+;;======================================================================
+;; twiki text formating, parsing and display
+;;======================================================================
+
+;; twiki formating routines (override these to change your look and feel
+(define twiki:twiki-tag  s:b)
+(define twiki:h3         s:h3)
+(define twiki:h2         s:h2)
+(define twiki:h1         s:h1)
+;; (define twiki:make-tlink s:i)
+(define twiki:ul         s:ul)
+(define twiki:ol         s:ol)
+(define twiki:li         s:li)
+(define twiki:pre        s:pre)
+(define twiki:p          s:p)
+(define twiki:u          s:u)
+(define twiki:td         s:td)
+(define twiki:tr         s:tr)
+(define twiki:table      s:table)
+(define twiki:div        s:div)
+
+(define (twiki:web64enc str)
+  (string-substitute "=" "_" (base64:base64-encode str) #t))
+
+(define (twiki:web64dec str)
+  (base64:base64-decode (string-substitute "_" "=" str #t)))
+    
+(define (twiki:make-tlink text tiddlername)
+  (s:a text 'href (s:link-to (twiki:get-link-back-to-current) 'view_tiddler (twiki:web64enc tiddlername))))
+
+(define (twiki:pic pic-name size wiki)
+  (let* ((tdb    (twiki:wiki-get-dbh wiki))
+	 (tkey   (twiki:wiki-get-key wiki))
+	 (xy     (string-split size "x"))
+	 (pic-id (twiki:get-pic-id tdb pic-name (twiki:wiki-get-wid wiki)))
+	 (img-lnk  (s:link-to "twiki" 'wiki_key (conc (number->string (twiki:wiki-get-wid wiki)) "-" (twiki:web64enc tkey))
+			      'image  pic-id)))
+    (if (and (> (length xy) 1)
+	     (car xy)
+	     (cadr xy)) ;; yep, have two numbers
+	(s:img 'title pic-name 'alt pic-name 'width (car xy) 'height (cadr xy) 'src img-lnk)
+	(s:img 'title pic-name 'alt pic-name 'src img-lnk))))
+
+;; override these also
+(define (twiki:get-id)
+  (s:session-var-get "id"))
+
+;; override this to set links inside wiki's
+(define (twiki:get-link-back-to-current)
+  (s:current-page))
+
+
+;; regexes are listed in the order in which they should be checked
+
+(define twiki:h3-patt (regexp "^!!!(.*)$"))
+(define twiki:h2-patt (regexp "^!!(.*)$"))
+(define twiki:h1-patt (regexp "^!(.*)$"))
+
+(define twiki:tlink-patt     (regexp "^(.*)\\[\\[([^\\[\\]]*)\\]\\](.*)$"))
+(define twiki:pic-patt       (regexp "^(.*)\\[pic([0-9%]*x*[0-9%]*)\\[([^\\[\\]]+)\\]\\](.*)$"))
+(define twiki:underline-patt (regexp "^(.*)__(.*)__(.*)$"))
+(define twiki:table-patt     (regexp "^\\|(.*)\\|$"))
+
+;; these are for multi-line formating
+(define twiki:list-patt    (regexp "^(\\*+|\\#+)(.*)$"))
+(define twiki:bullet-patt  (regexp "^(\\*+)(.*)$"))
+(define twiki:number-patt  (regexp "^(\\#+)(.*)$"))
+(define twiki:prefor-patt  (regexp "^\\{\\{\\{$"))
+(define twiki:prefor-end-patt (regexp "^\\}\\}\\}$"))
+
+;; regex
+(define t:match  #f)
+(define (t-match r s)
+  (let ((res (string-match r s)))
+    (set! t:match res)
+    res))
+
+;; should switch to recursively processing by block?
+;; (process-block dat)
+;;   ...
+;;   (process-block remdat)
+(define (twiki:dat->html dat wiki)
+  (let* ((inp        (open-input-string dat))
+	 (nest-depth 0) ;; depth of nested lists
+	 ;; token (i.e. line) handling stuff
+	 (next-line  #f)
+	 (peek-line  (lambda ()
+		       next-line))
+	 (get-line   (lambda ()
+		       (let ((res next-line))
+			 (set! next-line (read-line inp))
+			 ;; (print "get-line: prev=" res " next=" next-line "\n")
+			 res)))
+	 (l          (get-line))) ;; discard the #f in next-line
+    (twiki:read-block peek-line get-line nest-depth #f wiki)))
+
+;; blk-type is #f for not in a block (i.e. at top level), 'pre for preformated, 'ul or 'ol
+;; call with first line as legit data
+;; i.e. for preform - skip the {{{ line then call read-block
+;;      for # or * call with first line
+(define (twiki:read-block peek-line get-line nest-depth blk-type wiki)
+  (let loop ((res '())
+	     (l   (peek-line))) ;; should this be a peek-line? yes!!
+    ;; (print "twiki:read-block loop nest-depth="nest-depth " blk-type=" blk-type " l=" l "\n  res=" res)
+    (if (eof-object? l)
+	;; we are done! return the list
+	res
+	;; process it!
+	(cond
+	 ;; handle preformated text
+	 ((eq? blk-type 'pre)
+	  (if (t-match  twiki:prefor-end-patt l)
+	      (begin
+		(get-line) ;; discard the }}}
+		res)       ;; end of preformatted
+	      (begin
+		;; (get-line) ;; discard the {{{
+		(loop (append res (list (get-line)))
+		      (peek-line)))))
+	 ;; handle tables
+	 ((eq? blk-type 'table)
+	  (if (t-match twiki:table-patt l)
+	      (let ((cels  (string-split (cadr t:match) "|")))
+		(get-line)
+		(loop (append res (twiki:tr (map twiki:td 
+						 (map (lambda (x)(twiki:line->html x #f wiki)) cels))))
+		      (get-line)))
+	      res))
+	 ;; handle lists
+	 ((or (t-match twiki:bullet-patt l) ;; have *
+	      (t-match twiki:number-patt l))
+	  (let* ((directive (cadr t:match))
+		 (levelnum (string-length directive))
+		 (text     (twiki:line->html (caddr t:match) #t wiki))
+		 (btype    (if (string=? "#" (substring directive 0 1))
+			       'ol
+			       'ul))
+		 (func     (if (eq? btype 'ul)
+			       twiki:ul
+			       twiki:ol)))
+	    ;; (print "handling " btype ": levelnum=" levelnum " text=" text " nest-depth=" nest-depth " blk-type=" blk-type)
+	    (cond
+	     ((not blk-type) ;; i.e first member of the list!
+	      (loop (append res (func (twiki:read-block peek-line get-line levelnum btype wiki)))
+		    (get-line)))
+	     ((> levelnum nest-depth)
+	      (loop (append res (func (twiki:read-block peek-line get-line (+ nest-depth 1) btype wiki)))
+		    (peek-line)))
+	     ((< levelnum nest-depth)
+	      (append res (twiki:li text))) ;; return the bulleted item, don't get the next line??
+	     (else
+	      (get-line)
+	      (loop (append res (twiki:li text))
+		    (peek-line))))))
+	 ((t-match twiki:prefor-patt l)
+	  (get-line) ;; discard the {{{
+	  (loop (append res (twiki:pre (twiki:read-block peek-line get-line nest-depth 'pre wiki)))
+		(peek-line)))
+	 ((t-match twiki:table-patt l)
+	  (get-line)
+	  (loop (append res (twiki:table 'border 1 'cellspacing 0 (twiki:read-block peek-line get-line 0 'table wiki)))
+		(peek-line)))
+	 (else
+	  (get-line)
+	  (loop (append res (twiki:line->html l #t wiki))
+		(peek-line)))))))
+
+(define (twiki:line->html dat firstcall wiki)
+  (if firstcall 
+      ;; process the patterns that test for beginning of line only on the first call
+      (cond
+       ((t-match twiki:h3-patt dat)
+	(twiki:h3 (twiki:line->html (cadr t:match) #f wiki)))
+       ((t-match twiki:h2-patt dat)
+	(twiki:h2 (twiki:line->html (cadr t:match) #f wiki)))
+       ((t-match twiki:h1-patt dat)
+	(twiki:h1 (twiki:line->html (cadr t:match) #f wiki)))
+       ;; why was the (s:br) here? trying without
+       (else (twiki:line->html dat #f wiki)))
+       ;; (else  (append (twiki:line->html dat #f wiki)(list (s:br)))));; (s:p 'class "tiddlerpar"
+      ;; not firstcall so process other patterns
+      (cond
+       ((t-match twiki:tlink-patt dat)
+	(let ((pre  (cadr   t:match))
+	      (lnk  (caddr  t:match))
+	      (post (cadddr t:match)))
+	  (list (twiki:line->html pre #f wiki)
+		(twiki:make-tlink (twiki:line->html lnk #f wiki) lnk) ;; special handling
+		(twiki:line->html post #f wiki))))
+       ((t-match twiki:pic-patt dat)
+	(let ((pre  (cadr    t:match))
+	      (size (caddr   t:match)) 
+	      (pic  (cadddr  t:match))
+	      (post (list-ref t:match 4)))
+	  (list (twiki:line->html pre #f wiki)
+		(twiki:pic pic size wiki)
+		(twiki:line->html post #t wiki))))
+       ((t-match twiki:underline-patt dat)
+	(let ((pre  (cadr   t:match))
+	      (lnk  (caddr  t:match))
+	      (post (cadddr t:match)))
+	  (list (twiki:line->html pre #f wiki)
+		(twiki:u (twiki:line->html lnk #f wiki))
+		(twiki:line->html post #f wiki))))
+       ((t-match twiki:table-patt dat)
+	(let ((cels  (string-split (cadr t:match) "|")))
+	  (twiki:tr (map twiki:td (twiki:line->html cels #f wiki)))))
+       (else (list dat)))))
+
+
+#|
+(twiki:dat->html "a\n{{{\nb\nc\nd\n}}}\n!e\n[[f]]\n[[g]]\n*h" wiki)
+(s:output (current-output-port) (twiki:dat->html "!Testing [[my first link]]\n* Test\n* Foo\nblah" wiki))   
+(s:output (current-output-port) (twiki:dat->html "[[a]]\n{{{\nb\n  c\n   d\n}}}\n*x\n[[f]]\n[[g]]\n*h" wiki))
+(s:output (current-output-port)
+|#
+

ADDED   stml2/modules/twiki/twiki-test.scm
Index: stml2/modules/twiki/twiki-test.scm
==================================================================
--- /dev/null
+++ stml2/modules/twiki/twiki-test.scm
@@ -0,0 +1,5 @@
+(include "../../stml.scm")
+;; (include "../../session.scm")
+(include "../../misc-stml.scm")
+(include "twiki-mod.scm")
+

ADDED   stml2/modules/twiki/twiki.l
Index: stml2/modules/twiki/twiki.l
==================================================================
--- /dev/null
+++ stml2/modules/twiki/twiki.l
@@ -0,0 +1,33 @@
+;; twiki
+
+period           \.
+comma            ,
+semicolon        \;
+opensq           \[
+closesq          \]
+opensquig        \{
+closesquig       \}
+
+digit            [0-9]
+letter           [a-zA-Z]
+okchars          [_%\/\.:\*\+\-\(\)\\#']
+escape           \\ 
+whitespace       [ \9]
+linefeed         \n
+bang             !
+plaintext        ({letter}|{digit}|{okchars}|{whitespace}|{linefeed})+
+
+%%
+
+{opensq}                        (list 'opensq     yytext)
+{closesq}                       (list 'closesq    yytext)
+
+{opensquig}                     (list 'opensquig  yytext)
+{closesquig}                    (list 'closesquig yytext)
+
+{bang}                          (list 'bang       yytext)
+{plaintext}                     (list 'plaintext  yytext)
+
+<<EOF>>                         (list 'end-of-input #f ) ;; yyline)
+
+<<ERROR>>                       (lex-error (conc yyline " : illegal character ") (yygetc))

ADDED   stml2/modules/twiki/twiki.l.scm
Index: stml2/modules/twiki/twiki.l.scm
==================================================================
--- /dev/null
+++ stml2/modules/twiki/twiki.l.scm
@@ -0,0 +1,1194 @@
+; *** This file starts with a copy of the file multilex.scm ***
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+;   lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+  (lambda (buffer read-ptr input-f counters)
+    (let ((input-f          input-f)                ; Entree reelle
+	  (buffer           buffer)                 ; Buffer
+	  (buflen           (string-length buffer))
+	  (read-ptr         read-ptr)
+	  (start-ptr        1)                      ; Marque de debut de lexeme
+	  (start-line       1)
+	  (start-column     1)
+	  (start-offset     0)
+	  (end-ptr          1)                      ; Marque de fin de lexeme
+	  (point-ptr        1)                      ; Le point
+	  (user-ptr         1)                      ; Marque de l'usager
+	  (user-line        1)
+	  (user-column      1)
+	  (user-offset      0)
+	  (user-up-to-date? #t))                    ; Concerne la colonne seul.
+      (letrec
+	  ((start-go-to-end-none         ; Fonctions de depl. des marques
+	    (lambda ()
+	      (set! start-ptr end-ptr)))
+	   (start-go-to-end-line
+	    (lambda ()
+	      (let loop ((ptr start-ptr) (line start-line))
+		(if (= ptr end-ptr)
+		    (begin
+		      (set! start-ptr ptr)
+		      (set! start-line line))
+		    (if (char=? (string-ref buffer ptr) #\newline)
+			(loop (+ ptr 1) (+ line 1))
+			(loop (+ ptr 1) line))))))
+	   (start-go-to-end-all
+	    (lambda ()
+	      (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+	      (let loop ((ptr start-ptr)
+			 (line start-line)
+			 (column start-column))
+		(if (= ptr end-ptr)
+		    (begin
+		      (set! start-ptr ptr)
+		      (set! start-line line)
+		      (set! start-column column))
+		    (if (char=? (string-ref buffer ptr) #\newline)
+			(loop (+ ptr 1) (+ line 1) 1)
+			(loop (+ ptr 1) line (+ column 1)))))))
+	   (start-go-to-user-none
+	    (lambda ()
+	      (set! start-ptr user-ptr)))
+	   (start-go-to-user-line
+	    (lambda ()
+	      (set! start-ptr user-ptr)
+	      (set! start-line user-line)))
+	   (start-go-to-user-all
+	    (lambda ()
+	      (set! start-line user-line)
+	      (set! start-offset user-offset)
+	      (if user-up-to-date?
+		  (begin
+		    (set! start-ptr user-ptr)
+		    (set! start-column user-column))
+		  (let loop ((ptr start-ptr) (column start-column))
+		    (if (= ptr user-ptr)
+			(begin
+			  (set! start-ptr ptr)
+			  (set! start-column column))
+			(if (char=? (string-ref buffer ptr) #\newline)
+			    (loop (+ ptr 1) 1)
+			    (loop (+ ptr 1) (+ column 1))))))))
+	   (end-go-to-point
+	    (lambda ()
+	      (set! end-ptr point-ptr)))
+	   (point-go-to-start
+	    (lambda ()
+	      (set! point-ptr start-ptr)))
+	   (user-go-to-start-none
+	    (lambda ()
+	      (set! user-ptr start-ptr)))
+	   (user-go-to-start-line
+	    (lambda ()
+	      (set! user-ptr start-ptr)
+	      (set! user-line start-line)))
+	   (user-go-to-start-all
+	    (lambda ()
+	      (set! user-ptr start-ptr)
+	      (set! user-line start-line)
+	      (set! user-column start-column)
+	      (set! user-offset start-offset)
+	      (set! user-up-to-date? #t)))
+	   (init-lexeme-none             ; Debute un nouveau lexeme
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-none))
+	      (point-go-to-start)))
+	   (init-lexeme-line
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-line))
+	      (point-go-to-start)))
+	   (init-lexeme-all
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-all))
+	      (point-go-to-start)))
+	   (get-start-line               ; Obtention des stats du debut du lxm
+	    (lambda ()
+	      start-line))
+	   (get-start-column
+	    (lambda ()
+	      start-column))
+	   (get-start-offset
+	    (lambda ()
+	      start-offset))
+	   (peek-left-context            ; Obtention de caracteres (#f si EOF)
+	    (lambda ()
+	      (char->integer (string-ref buffer (- start-ptr 1)))))
+	   (peek-char
+	    (lambda ()
+	      (if (< point-ptr read-ptr)
+		  (char->integer (string-ref buffer point-ptr))
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer point-ptr c)
+			  (set! read-ptr (+ point-ptr 1))
+			  (char->integer c))
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  #f))))))
+	   (read-char
+	    (lambda ()
+	      (if (< point-ptr read-ptr)
+		  (let ((c (string-ref buffer point-ptr)))
+		    (set! point-ptr (+ point-ptr 1))
+		    (char->integer c))
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer point-ptr c)
+			  (set! read-ptr (+ point-ptr 1))
+			  (set! point-ptr read-ptr)
+			  (char->integer c))
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  #f))))))
+	   (get-start-end-text           ; Obtention du lexeme
+	    (lambda ()
+	      (substring buffer start-ptr end-ptr)))
+	   (get-user-line-line           ; Fonctions pour l'usager
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-line))
+	      user-line))
+	   (get-user-line-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      user-line))
+	   (get-user-column-all
+	    (lambda ()
+	      (cond ((< user-ptr start-ptr)
+		     (user-go-to-start-all)
+		     user-column)
+		    (user-up-to-date?
+		     user-column)
+		    (else
+		     (let loop ((ptr start-ptr) (column start-column))
+		       (if (= ptr user-ptr)
+			   (begin
+			     (set! user-column column)
+			     (set! user-up-to-date? #t)
+			     column)
+			   (if (char=? (string-ref buffer ptr) #\newline)
+			       (loop (+ ptr 1) 1)
+			       (loop (+ ptr 1) (+ column 1)))))))))
+	   (get-user-offset-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      user-offset))
+	   (user-getc-none
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-none))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-getc-line
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-line))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    (if (char=? c #\newline)
+			(set! user-line (+ user-line 1)))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  (if (char=? c #\newline)
+			      (set! user-line (+ user-line 1)))
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-getc-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    (if (char=? c #\newline)
+			(begin
+			  (set! user-line (+ user-line 1))
+			  (set! user-column 1))
+			(set! user-column (+ user-column 1)))
+		    (set! user-offset (+ user-offset 1))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  (if (char=? c #\newline)
+			      (begin
+				(set! user-line (+ user-line 1))
+				(set! user-column 1))
+			      (set! user-column (+ user-column 1)))
+			  (set! user-offset (+ user-offset 1))
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-ungetc-none
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (set! user-ptr (- user-ptr 1)))))
+	   (user-ungetc-line
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (begin
+		    (set! user-ptr (- user-ptr 1))
+		    (let ((c (string-ref buffer user-ptr)))
+		      (if (char=? c #\newline)
+			  (set! user-line (- user-line 1))))))))
+	   (user-ungetc-all
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (begin
+		    (set! user-ptr (- user-ptr 1))
+		    (let ((c (string-ref buffer user-ptr)))
+		      (if (char=? c #\newline)
+			  (begin
+			    (set! user-line (- user-line 1))
+			    (set! user-up-to-date? #f))
+			  (set! user-column (- user-column 1)))
+		      (set! user-offset (- user-offset 1)))))))
+	   (reorganize-buffer            ; Decaler ou agrandir le buffer
+	    (lambda ()
+	      (if (< (* 2 start-ptr) buflen)
+		  (let* ((newlen (* 2 buflen))
+			 (newbuf (make-string newlen))
+			 (delta (- start-ptr 1)))
+		    (let loop ((from (- start-ptr 1)))
+		      (if (< from buflen)
+			  (begin
+			    (string-set! newbuf
+					 (- from delta)
+					 (string-ref buffer from))
+			    (loop (+ from 1)))))
+		    (set! buffer    newbuf)
+		    (set! buflen    newlen)
+		    (set! read-ptr  (- read-ptr delta))
+		    (set! start-ptr (- start-ptr delta))
+		    (set! end-ptr   (- end-ptr delta))
+		    (set! point-ptr (- point-ptr delta))
+		    (set! user-ptr  (- user-ptr delta)))
+		  (let ((delta (- start-ptr 1)))
+		    (let loop ((from (- start-ptr 1)))
+		      (if (< from buflen)
+			  (begin
+			    (string-set! buffer
+					 (- from delta)
+					 (string-ref buffer from))
+			    (loop (+ from 1)))))
+		    (set! read-ptr  (- read-ptr delta))
+		    (set! start-ptr (- start-ptr delta))
+		    (set! end-ptr   (- end-ptr delta))
+		    (set! point-ptr (- point-ptr delta))
+		    (set! user-ptr  (- user-ptr delta)))))))
+	(list (cons 'start-go-to-end
+		    (cond ((eq? counters 'none) start-go-to-end-none)
+			  ((eq? counters 'line) start-go-to-end-line)
+			  ((eq? counters 'all ) start-go-to-end-all)))
+	      (cons 'end-go-to-point
+		    end-go-to-point)
+	      (cons 'init-lexeme
+		    (cond ((eq? counters 'none) init-lexeme-none)
+			  ((eq? counters 'line) init-lexeme-line)
+			  ((eq? counters 'all ) init-lexeme-all)))
+	      (cons 'get-start-line
+		    get-start-line)
+	      (cons 'get-start-column
+		    get-start-column)
+	      (cons 'get-start-offset
+		    get-start-offset)
+	      (cons 'peek-left-context
+		    peek-left-context)
+	      (cons 'peek-char
+		    peek-char)
+	      (cons 'read-char
+		    read-char)
+	      (cons 'get-start-end-text
+		    get-start-end-text)
+	      (cons 'get-user-line
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) get-user-line-line)
+			  ((eq? counters 'all ) get-user-line-all)))
+	      (cons 'get-user-column
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) #f)
+			  ((eq? counters 'all ) get-user-column-all)))
+	      (cons 'get-user-offset
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) #f)
+			  ((eq? counters 'all ) get-user-offset-all)))
+	      (cons 'user-getc
+		    (cond ((eq? counters 'none) user-getc-none)
+			  ((eq? counters 'line) user-getc-line)
+			  ((eq? counters 'all ) user-getc-all)))
+	      (cons 'user-ungetc
+		    (cond ((eq? counters 'none) user-ungetc-none)
+			  ((eq? counters 'line) user-ungetc-line)
+			  ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi "port", "procedure" ou "string"
+; Prend un parametre facultatif qui doit etre parmi
+; "none", "line" ou "all"
+(define lexer-make-IS
+  (lambda (input-type input . largs)
+    (let ((counters-type (cond ((null? largs)
+				'line)
+			       ((memq (car largs) '(none line all))
+				(car largs))
+			       (else
+				'line))))
+      (cond ((and (eq? input-type 'port) (input-port? input))
+	     (let* ((buffer   (make-string lexer-init-buffer-len #\newline))
+		    (read-ptr 1)
+		    (input-f  (lambda () (read-char input))))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    ((and (eq? input-type 'procedure) (procedure? input))
+	     (let* ((buffer   (make-string lexer-init-buffer-len #\newline))
+		    (read-ptr 1)
+		    (input-f  input))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    ((and (eq? input-type 'string) (string? input))
+	     (let* ((buffer   (string-append (string #\newline) input))
+		    (read-ptr (string-length buffer))
+		    (input-f  (lambda () 'eof)))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    (else
+	     (let* ((buffer   (string #\newline))
+		    (read-ptr 1)
+		    (input-f  (lambda () 'eof)))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+;   lexer-get-func-getc, lexer-get-func-ungetc,
+;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+  (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+  (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+  (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+  (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+  (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+  (lambda (tables IS)
+    (letrec
+	(; Contenu de la table
+	 (counters-type        (vector-ref tables 0))
+	 (<<EOF>>-pre-action   (vector-ref tables 1))
+	 (<<ERROR>>-pre-action (vector-ref tables 2))
+	 (rules-pre-actions    (vector-ref tables 3))
+	 (table-nl-start       (vector-ref tables 5))
+	 (table-no-nl-start    (vector-ref tables 6))
+	 (trees-v              (vector-ref tables 7))
+	 (acc-v                (vector-ref tables 8))
+
+	 ; Contenu du IS
+	 (IS-start-go-to-end    (cdr (assq 'start-go-to-end IS)))
+	 (IS-end-go-to-point    (cdr (assq 'end-go-to-point IS)))
+	 (IS-init-lexeme        (cdr (assq 'init-lexeme IS)))
+	 (IS-get-start-line     (cdr (assq 'get-start-line IS)))
+	 (IS-get-start-column   (cdr (assq 'get-start-column IS)))
+	 (IS-get-start-offset   (cdr (assq 'get-start-offset IS)))
+	 (IS-peek-left-context  (cdr (assq 'peek-left-context IS)))
+	 (IS-peek-char          (cdr (assq 'peek-char IS)))
+	 (IS-read-char          (cdr (assq 'read-char IS)))
+	 (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+	 (IS-get-user-line      (cdr (assq 'get-user-line IS)))
+	 (IS-get-user-column    (cdr (assq 'get-user-column IS)))
+	 (IS-get-user-offset    (cdr (assq 'get-user-offset IS)))
+	 (IS-user-getc          (cdr (assq 'user-getc IS)))
+	 (IS-user-ungetc        (cdr (assq 'user-ungetc IS)))
+
+	 ; Resultats
+	 (<<EOF>>-action   #f)
+	 (<<ERROR>>-action #f)
+	 (rules-actions    #f)
+	 (states           #f)
+	 (final-lexer      #f)
+
+	 ; Gestion des hooks
+	 (hook-list '())
+	 (add-hook
+	  (lambda (thunk)
+	    (set! hook-list (cons thunk hook-list))))
+	 (apply-hooks
+	  (lambda ()
+	    (let loop ((l hook-list))
+	      (if (pair? l)
+		  (begin
+		    ((car l))
+		    (loop (cdr l)))))))
+
+	 ; Preparation des actions
+	 (set-action-statics
+	  (lambda (pre-action)
+	    (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+	 (prepare-special-action-none
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda ()
+		       (action "")))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action-line
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (action "" yyline)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action-all
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (action "" yyline yycolumn yyoffset)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-special-action-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-special-action-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-special-action-all  pre-action)))))
+	 (prepare-action-yytext-none
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda ()
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext-line
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext yyline))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext-all
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext yyline yycolumn yyoffset))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-action-yytext-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-action-yytext-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-action-yytext-all  pre-action)))))
+	 (prepare-action-no-yytext-none
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda ()
+		       (start-go-to-end)
+		       (action)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext-line
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (start-go-to-end)
+		       (action yyline)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext-all
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (start-go-to-end)
+		       (action yyline yycolumn yyoffset)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-action-no-yytext-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-action-no-yytext-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-action-no-yytext-all  pre-action)))))
+
+	 ; Fabrique les fonctions de dispatch
+	 (prepare-dispatch-err
+	  (lambda (leaf)
+	    (lambda (c)
+	      #f)))
+	 (prepare-dispatch-number
+	  (lambda (leaf)
+	    (let ((state-function #f))
+	      (let ((result
+		     (lambda (c)
+		       state-function))
+		    (hook
+		     (lambda ()
+		       (set! state-function (vector-ref states leaf)))))
+		(add-hook hook)
+		result))))
+	 (prepare-dispatch-leaf
+	  (lambda (leaf)
+	    (if (eq? leaf 'err)
+		(prepare-dispatch-err leaf)
+		(prepare-dispatch-number leaf))))
+	 (prepare-dispatch-<
+	  (lambda (tree)
+	    (let ((left-tree  (list-ref tree 1))
+		  (right-tree (list-ref tree 2)))
+	      (let ((bound      (list-ref tree 0))
+		    (left-func  (prepare-dispatch-tree left-tree))
+		    (right-func (prepare-dispatch-tree right-tree)))
+		(lambda (c)
+		  (if (< c bound)
+		      (left-func c)
+		      (right-func c)))))))
+	 (prepare-dispatch-=
+	  (lambda (tree)
+	    (let ((left-tree  (list-ref tree 2))
+		  (right-tree (list-ref tree 3)))
+	      (let ((bound      (list-ref tree 1))
+		    (left-func  (prepare-dispatch-tree left-tree))
+		    (right-func (prepare-dispatch-tree right-tree)))
+		(lambda (c)
+		  (if (= c bound)
+		      (left-func c)
+		      (right-func c)))))))
+	 (prepare-dispatch-tree
+	  (lambda (tree)
+	    (cond ((not (pair? tree))
+		   (prepare-dispatch-leaf tree))
+		  ((eq? (car tree) '=)
+		   (prepare-dispatch-= tree))
+		  (else
+		   (prepare-dispatch-< tree)))))
+	 (prepare-dispatch
+	  (lambda (tree)
+	    (let ((dicho-func (prepare-dispatch-tree tree)))
+	      (lambda (c)
+		(and c (dicho-func c))))))
+
+	 ; Fabrique les fonctions de transition (read & go) et (abort)
+	 (prepare-read-n-go
+	  (lambda (tree)
+	    (let ((dispatch-func (prepare-dispatch tree))
+		  (read-char     IS-read-char))
+	      (lambda ()
+		(dispatch-func (read-char))))))
+	 (prepare-abort
+	  (lambda (tree)
+	    (lambda ()
+	      #f)))
+	 (prepare-transition
+	  (lambda (tree)
+	    (if (eq? tree 'err)
+		(prepare-abort     tree)
+		(prepare-read-n-go tree))))
+
+	 ; Fabrique les fonctions d'etats ([set-end] & trans)
+	 (prepare-state-no-acc
+	   (lambda (s r1 r2)
+	     (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+	       (lambda (action)
+		 (let ((next-state (trans-func)))
+		   (if next-state
+		       (next-state action)
+		       action))))))
+	 (prepare-state-yes-no
+	  (lambda (s r1 r2)
+	    (let ((peek-char       IS-peek-char)
+		  (end-go-to-point IS-end-go-to-point)
+		  (new-action1     #f)
+		  (trans-func (prepare-transition (vector-ref trees-v s))))
+	      (let ((result
+		     (lambda (action)
+		       (let* ((c (peek-char))
+			      (new-action
+			       (if (or (not c) (= c lexer-integer-newline))
+				   (begin
+				     (end-go-to-point)
+				     new-action1)
+				   action))
+			      (next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action1 (vector-ref rules-actions r1)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state-diff-acc
+	  (lambda (s r1 r2)
+	    (let ((end-go-to-point IS-end-go-to-point)
+		  (peek-char       IS-peek-char)
+		  (new-action1     #f)
+		  (new-action2     #f)
+		  (trans-func (prepare-transition (vector-ref trees-v s))))
+	      (let ((result
+		     (lambda (action)
+		       (end-go-to-point)
+		       (let* ((c (peek-char))
+			      (new-action
+			       (if (or (not c) (= c lexer-integer-newline))
+				   new-action1
+				   new-action2))
+			      (next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action1 (vector-ref rules-actions r1))
+		       (set! new-action2 (vector-ref rules-actions r2)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state-same-acc
+	  (lambda (s r1 r2)
+	    (let ((end-go-to-point IS-end-go-to-point)
+		  (trans-func (prepare-transition (vector-ref trees-v s)))
+		  (new-action #f))
+	      (let ((result
+		     (lambda (action)
+		       (end-go-to-point)
+		       (let ((next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action (vector-ref rules-actions r1)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state
+	  (lambda (s)
+	    (let* ((acc (vector-ref acc-v s))
+		   (r1 (car acc))
+		   (r2 (cdr acc)))
+	      (cond ((not r1)  (prepare-state-no-acc   s r1 r2))
+		    ((not r2)  (prepare-state-yes-no   s r1 r2))
+		    ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+		    (else      (prepare-state-same-acc s r1 r2))))))
+
+	 ; Fabrique la fonction de lancement du lexage a l'etat de depart
+	 (prepare-start-same
+	  (lambda (s1 s2)
+	    (let ((peek-char    IS-peek-char)
+		  (eof-action   #f)
+		  (start-state  #f)
+		  (error-action #f))
+	      (let ((result
+		     (lambda ()
+		       (if (not (peek-char))
+			   eof-action
+			   (start-state error-action))))
+		    (hook
+		     (lambda ()
+		       (set! eof-action   <<EOF>>-action)
+		       (set! start-state  (vector-ref states s1))
+		       (set! error-action <<ERROR>>-action))))
+		(add-hook hook)
+		result))))
+	 (prepare-start-diff
+	  (lambda (s1 s2)
+	    (let ((peek-char         IS-peek-char)
+		  (eof-action        #f)
+		  (peek-left-context IS-peek-left-context)
+		  (start-state1      #f)
+		  (start-state2      #f)
+		  (error-action      #f))
+	      (let ((result
+		     (lambda ()
+		       (cond ((not (peek-char))
+			      eof-action)
+			     ((= (peek-left-context) lexer-integer-newline)
+			      (start-state1 error-action))
+			     (else
+			      (start-state2 error-action)))))
+		    (hook
+		     (lambda ()
+		       (set! eof-action <<EOF>>-action)
+		       (set! start-state1 (vector-ref states s1))
+		       (set! start-state2 (vector-ref states s2))
+		       (set! error-action <<ERROR>>-action))))
+		(add-hook hook)
+		result))))
+	 (prepare-start
+	  (lambda ()
+	    (let ((s1 table-nl-start)
+		  (s2 table-no-nl-start))
+	      (if (= s1 s2)
+		  (prepare-start-same s1 s2)
+		  (prepare-start-diff s1 s2)))))
+
+	 ; Fabrique la fonction principale
+	 (prepare-lexer-none
+	  (lambda ()
+	    (let ((init-lexeme IS-init-lexeme)
+		  (start-func  (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		((start-func))))))
+	 (prepare-lexer-line
+	  (lambda ()
+	    (let ((init-lexeme    IS-init-lexeme)
+		  (get-start-line IS-get-start-line)
+		  (start-func     (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		(let ((yyline (get-start-line)))
+		  ((start-func) yyline))))))
+	 (prepare-lexer-all
+	  (lambda ()
+	    (let ((init-lexeme      IS-init-lexeme)
+		  (get-start-line   IS-get-start-line)
+		  (get-start-column IS-get-start-column)
+		  (get-start-offset IS-get-start-offset)
+		  (start-func       (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		(let ((yyline   (get-start-line))
+		      (yycolumn (get-start-column))
+		      (yyoffset (get-start-offset)))
+		  ((start-func) yyline yycolumn yyoffset))))))
+	 (prepare-lexer
+	  (lambda ()
+	    (cond ((eq? counters-type 'none) (prepare-lexer-none))
+		  ((eq? counters-type 'line) (prepare-lexer-line))
+		  ((eq? counters-type 'all)  (prepare-lexer-all))))))
+
+      ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+      (set! <<EOF>>-action   (prepare-special-action <<EOF>>-pre-action))
+      (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+      ; Calculer la valeur de rules-actions
+      (let* ((len (quotient (vector-length rules-pre-actions) 2))
+	     (v (make-vector len)))
+	(let loop ((r (- len 1)))
+	  (if (< r 0)
+	      (set! rules-actions v)
+	      (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+		     (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+		     (action (if yytext?
+				 (prepare-action-yytext    pre-action)
+				 (prepare-action-no-yytext pre-action))))
+		(vector-set! v r action)
+		(loop (- r 1))))))
+
+      ; Calculer la valeur de states
+      (let* ((len (vector-length trees-v))
+	     (v (make-vector len)))
+	(let loop ((s (- len 1)))
+	  (if (< s 0)
+	      (set! states v)
+	      (begin
+		(vector-set! v s (prepare-state s))
+		(loop (- s 1))))))
+
+      ; Calculer la valeur de final-lexer
+      (set! final-lexer (prepare-lexer))
+
+      ; Executer les hooks
+      (apply-hooks)
+
+      ; Resultat
+      final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+  (let* ((char->class
+	  (lambda (c)
+	    (let ((n (char->integer c)))
+	      (list (cons n n)))))
+	 (merge-sort
+	  (lambda (l combine zero-elt)
+	    (if (null? l)
+		zero-elt
+		(let loop1 ((l l))
+		  (if (null? (cdr l))
+		      (car l)
+		      (loop1
+		       (let loop2 ((l l))
+			 (cond ((null? l)
+				l)
+			       ((null? (cdr l))
+				l)
+			       (else
+				(cons (combine (car l) (cadr l))
+				      (loop2 (cddr l))))))))))))
+	 (finite-class-union
+	  (lambda (c1 c2)
+	    (let loop ((c1 c1) (c2 c2) (u '()))
+	      (if (null? c1)
+		  (if (null? c2)
+		      (reverse u)
+		      (loop c1 (cdr c2) (cons (car c2) u)))
+		  (if (null? c2)
+		      (loop (cdr c1) c2 (cons (car c1) u))
+		      (let* ((r1 (car c1))
+			     (r2 (car c2))
+			     (r1start (car r1))
+			     (r1end (cdr r1))
+			     (r2start (car r2))
+			     (r2end (cdr r2)))
+			(if (<= r1start r2start)
+			    (cond ((< (+ r1end 1) r2start)
+				   (loop (cdr c1) c2 (cons r1 u)))
+				  ((<= r1end r2end)
+				   (loop (cdr c1)
+					 (cons (cons r1start r2end) (cdr c2))
+					 u))
+				  (else
+				   (loop c1 (cdr c2) u)))
+			    (cond ((> r1start (+ r2end 1))
+				   (loop c1 (cdr c2) (cons r2 u)))
+				  ((>= r1end r2end)
+				   (loop (cons (cons r2start r1end) (cdr c1))
+					 (cdr c2)
+					 u))
+				  (else
+				   (loop (cdr c1) c2 u))))))))))
+	 (char-list->class
+	  (lambda (cl)
+	    (let ((classes (map char->class cl)))
+	      (merge-sort classes finite-class-union '()))))
+	 (class-<
+	  (lambda (b1 b2)
+	    (cond ((eq? b1 'inf+) #f)
+		  ((eq? b2 'inf-) #f)
+		  ((eq? b1 'inf-) #t)
+		  ((eq? b2 'inf+) #t)
+		  (else (< b1 b2)))))
+	 (finite-class-compl
+	  (lambda (c)
+	    (let loop ((c c) (start 'inf-))
+	      (if (null? c)
+		  (list (cons start 'inf+))
+		  (let* ((r (car c))
+			 (rstart (car r))
+			 (rend (cdr r)))
+		    (if (class-< start rstart)
+			(cons (cons start (- rstart 1))
+			      (loop c rstart))
+			(loop (cdr c) (+ rend 1))))))))
+	 (tagged-chars->class
+	  (lambda (tcl)
+	    (let* ((inverse? (car tcl))
+		   (cl (cdr tcl))
+		   (class-tmp (char-list->class cl)))
+	      (if inverse? (finite-class-compl class-tmp) class-tmp))))
+	 (charc->arc
+	  (lambda (charc)
+	    (let* ((tcl (car charc))
+		   (dest (cdr charc))
+		   (class (tagged-chars->class tcl)))
+	      (cons class dest))))
+	 (arc->sharcs
+	  (lambda (arc)
+	    (let* ((range-l (car arc))
+		   (dest (cdr arc))
+		   (op (lambda (range) (cons range dest))))
+	      (map op range-l))))
+	 (class-<=
+	  (lambda (b1 b2)
+	    (cond ((eq? b1 'inf-) #t)
+		  ((eq? b2 'inf+) #t)
+		  ((eq? b1 'inf+) #f)
+		  ((eq? b2 'inf-) #f)
+		  (else (<= b1 b2)))))
+	 (sharc-<=
+	  (lambda (sharc1 sharc2)
+	    (class-<= (caar sharc1) (caar sharc2))))
+	 (merge-sharcs
+	  (lambda (l1 l2)
+	    (let loop ((l1 l1) (l2 l2))
+	      (cond ((null? l1)
+		     l2)
+		    ((null? l2)
+		     l1)
+		    (else
+		     (let ((sharc1 (car l1))
+			   (sharc2 (car l2)))
+		       (if (sharc-<= sharc1 sharc2)
+			   (cons sharc1 (loop (cdr l1) l2))
+			   (cons sharc2 (loop l1 (cdr l2))))))))))
+	 (class-= eqv?)
+	 (fill-error
+	  (lambda (sharcs)
+	    (let loop ((sharcs sharcs) (start 'inf-))
+	      (cond ((class-= start 'inf+)
+		     '())
+		    ((null? sharcs)
+		     (cons (cons (cons start 'inf+) 'err)
+			   (loop sharcs 'inf+)))
+		    (else
+		     (let* ((sharc (car sharcs))
+			    (h (caar sharc))
+			    (t (cdar sharc)))
+		       (if (class-< start h)
+			   (cons (cons (cons start (- h 1)) 'err)
+				 (loop sharcs h))
+			   (cons sharc (loop (cdr sharcs)
+					     (if (class-= t 'inf+)
+						 'inf+
+						 (+ t 1)))))))))))
+	 (charcs->tree
+	  (lambda (charcs)
+	    (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+		   (sharcs-l (map op charcs))
+		   (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+		   (full-sharcs (fill-error sorted-sharcs))
+		   (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+		   (table (list->vector (map op full-sharcs))))
+	      (let loop ((left 0) (right (- (vector-length table) 1)))
+		(if (= left right)
+		    (cdr (vector-ref table left))
+		    (let ((mid (quotient (+ left right 1) 2)))
+		      (if (and (= (+ left 2) right)
+			       (= (+ (car (vector-ref table mid)) 1)
+				  (car (vector-ref table right)))
+			       (eqv? (cdr (vector-ref table left))
+				     (cdr (vector-ref table right))))
+			  (list '=
+				(car (vector-ref table mid))
+				(cdr (vector-ref table mid))
+				(cdr (vector-ref table left)))
+			  (list (car (vector-ref table mid))
+				(loop left (- mid 1))
+				(loop mid right))))))))))
+    (lambda (tables IS)
+      (let ((counters         (vector-ref tables 0))
+	    (<<EOF>>-action   (vector-ref tables 1))
+	    (<<ERROR>>-action (vector-ref tables 2))
+	    (rules-actions    (vector-ref tables 3))
+	    (nl-start         (vector-ref tables 5))
+	    (no-nl-start      (vector-ref tables 6))
+	    (charcs-v         (vector-ref tables 7))
+	    (acc-v            (vector-ref tables 8)))
+	(let* ((len (vector-length charcs-v))
+	       (v (make-vector len)))
+	  (let loop ((i (- len 1)))
+	    (if (>= i 0)
+		(begin
+		  (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+		  (loop (- i 1)))
+		(lexer-make-tree-lexer
+		 (vector counters
+			 <<EOF>>-action
+			 <<ERROR>>-action
+			 rules-actions
+			 'decision-trees
+			 nl-start
+			 no-nl-start
+			 v
+			 acc-v)
+		 IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+  (lambda (tables IS)
+    (let ((<<EOF>>-pre-action   (vector-ref tables 1))
+	  (<<ERROR>>-pre-action (vector-ref tables 2))
+	  (rules-pre-action     (vector-ref tables 3))
+	  (code                 (vector-ref tables 5)))
+      (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+  (lambda (tables IS)
+    (let ((automaton-type (vector-ref tables 4)))
+      (cond ((eq? automaton-type 'decision-trees)
+	     (lexer-make-tree-lexer tables IS))
+	    ((eq? automaton-type 'tagged-chars-lists)
+	     (lexer-make-char-lexer tables IS))
+	    ((eq? automaton-type 'code)
+	     (lexer-make-code-lexer tables IS))))))
+
+;
+; Table generated from the file twiki.l by SILex 1.0
+;
+
+(define lexer-default-table
+  (vector
+   'line
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline)
+                                (list 'end-of-input #f ) ;; yyline)
+       ))
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline)
+                                (lex-error (conc yyline " : illegal character ") (yygetc))
+       ))
+   (vector
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline)
+                                (list 'opensq     yytext)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline)
+                                (list 'closesq    yytext)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline)
+                                (list 'opensquig  yytext)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline)
+                                (list 'closesquig yytext)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline)
+                                (list 'bang       yytext)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline)
+                                (list 'plaintext  yytext)
+        )))
+   'decision-trees
+   0
+   0
+   '#((59 (35 (32 (9 err (11 1 err)) (33 1 (34 2 err))) (38 (= 36 err 1)
+    (44 (39 err 1) (45 err 1)))) (95 (92 (65 err (91 1 6)) (93 1 (94 5
+    err))) (123 (= 96 err 1) (125 (124 4 err) (126 3 err))))) (44 (35 (11
+    (9 err 1) (= 32 1 err)) (37 (36 1 err) (= 38 err 1))) (92 (59 (45 err
+    1) (65 err (91 1 err))) (96 (93 1 (95 err 1)) (97 err (123 1 err)))))
+    err err err err err)
+   '#((#f . #f) (5 . 5) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (0 . 0))))
+
+;
+; User functions
+;
+
+(define lexer #f)
+
+(define lexer-get-line   #f)
+(define lexer-getc       #f)
+(define lexer-ungetc     #f)
+
+(define lexer-init
+  (lambda (input-type input)
+    (let ((IS (lexer-make-IS input-type input 'line)))
+      (set! lexer (lexer-make-lexer lexer-default-table IS))
+      (set! lexer-get-line   (lexer-get-func-line IS))
+      (set! lexer-getc       (lexer-get-func-getc IS))
+      (set! lexer-ungetc     (lexer-get-func-ungetc IS)))))

ADDED   stml2/modules/twiki/twiki.scm
Index: stml2/modules/twiki/twiki.scm
==================================================================
--- /dev/null
+++ stml2/modules/twiki/twiki.scm
@@ -0,0 +1,68 @@
+;; twiki module
+(require-extension silex sqlite3 regex posix)
+
+(include "twiki.l.scm")
+
+(define (twiki:open-db keys)
+  (let* ((fname   (twiki:keys->fname keys))
+	 (fexists (file-exists? fname))
+	 (db (dbi:open 'sqlite3 '((dbname . fname)))))
+    (if (not fexists)
+	(for-each 
+	 (lambda (sqry)
+	   (dbi:exec db sqry))
+	 '("CREATE TABLE dats     (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);"
+	   "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,changed_on INTEGER,owner_id INTEGER);"
+	   "CREATE TABLE revs     (id INTEGER PRIMARY KEY,tag TEXT);"
+	   "CREATE TABLE wikis    (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);")))
+    (sqlite3:set-busy-timeout!(dbi:db-conn db) 1000000)
+    db))
+	
+(define (twiki:view)
+  (s:div 'class "node"
+  (s:h1 "Twiki")
+  "Title, pictures, etc."
+   (let ()
+     "blah")))
+
+
+(define (twiki:wiki . keys)
+  (let ((key (conc keys)))
+    (twiki:view)))
+
+(define (twiki:extract-tiddlers dat)
+  (let* ((inp (open-input-string dat))
+	 (prev-state #f)
+	 (stack      (list 'start))
+	 (links      '())
+	 (currlnk    #f))
+    (lexer-init 'port inp)
+    (let loop ((token          (lexer)))
+      (let ((token-type (car token))
+	    (token-val  (cadr token))
+	    (state      (car  stack)))
+	(if (not (eq? prev-state state))
+	    (begin
+	      (print "state: " state)
+	      (set! prev-state state)))
+	(case token-type
+	  ('end-of-input       (print "Done")(close-input-port inp))
+	  ('twikilink-start
+	   (set! stack (cons 'twikilink-start stack))
+	   (loop (lexer)))
+	  ('twikilink-end
+	   (set! links (cons currlnk links))
+	   (set! stack (cdr stack))
+	   (loop (lexer)))
+	  ('twikitext
+	   (if (eq? state 'twikilink-start)
+	       (set! currlnk (cadr token))
+	       (print "Got " token))
+	   (loop (lexer)))
+	  ('anydat
+	   (loop (lexer)))
+	  (else
+	   (print "ERROR: unknown token " token " on line " (lexer-get-line))
+	   (loop (lexer))))))
+    links))
+     

ADDED   stml2/modules/twiki/twikiparser.scm
Index: stml2/modules/twiki/twikiparser.scm
==================================================================
--- /dev/null
+++ stml2/modules/twiki/twikiparser.scm
@@ -0,0 +1,457 @@
+
+(require-extension sqlite3 regex posix eformat silex stack regex)
+
+(define help "
+Usage: nldb [options]
+
+
+General
+  -h                      : this help
+
+Netlist data queries
+
+  -findpath start,end     : find path from start to end. % is a wildcard
+
+Managing netlist data
+
+  -load /path/to/netlist  : load a model into the db
+  -d dbname               : name of the .db file
+  -dump fname             : dump the netlist in to verilog file
+
+")
+
+(include "/nfs/an/home/mrwellan/stuff/tools/lnkmkr/args.scm")
+(include "verilog.l.scm")
+
+;; process args
+(define remargs (get-args (argv)
+			  (list "-load"
+				"-d"          "-dump" 
+				"-findpath")
+			  
+			  (list "-h"
+				)
+			  arg-hash
+			  0)) ;;
+
+(define dbpaths (list "testing.db"))
+
+(define dbpath #f)
+
+(if (get-arg "-d")
+    (set! dbpath (get-arg "-d"))
+    (for-each
+     (lambda (path)
+       (if (file-exists? path)
+	   (set! dbpath path)))
+     dbpaths))
+
+(if (and (not dbpath) (get-arg "-d"))
+    (begin
+      (print "Can't find db. " (get-arg "-d") " Try again or contact Matt!")
+      (exit 1)))
+
+(define dbexists (file-exists? dbpath))
+
+(define realuser (getenv "USER"))
+(define user realuser)
+
+(define db (sqlite3:open dbpath))
+(sqlite3:set-busy-timeout! db 1000000)
+
+(define (mk-tables)
+  (for-each
+   (lambda (sqlstmt)
+     (sqlite3:exec db sqlstmt))
+   (list "CREATE TABLE modules(id INTEGER PRIMARY KEY,name_id INTEGER);"
+	 "CREATE TABLE nets   (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER);"
+	 "CREATE TABLE insts  (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER,parent_id INTEGER);"
+	 "CREATE TABLE pins   (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER,net_id INTEGER,type_id INTEGER);"
+	 "CREATE TABLE conns  (id INTEGER PRIMARY KEY,net_id  INTEGER,inst_id INTEGER,pin_id INTEGER);"
+	 "CREATE TABLE names  (id INTEGER PRIMARY KEY,name TEXT);"
+	 "CREATE TABLE types(id INTEGER PRIMARY KEY,type TEXT);"
+	 "INSERT INTO types VALUES(1, 'undef');"
+	 "INSERT INTO types VALUES(2, 'input');"
+	 "INSERT INTO types VALUES(3, 'output');"
+	 "INSERT INTO types VALUES(4, 'inout');"
+	 "INSERT INTO types VALUES(5, 'pwr');"
+	 "PRAGMA synchronous=OFF;")))
+
+(if (not dbexists)(mk-tables))
+
+;;======================================================================
+;; NETLIST READING
+;;======================================================================
+
+;; Use a stack to tracking state
+;;
+(define nldb:*stack* (make-stack))
+
+(define (nldb:read-files fnames) ;; read in a list of files
+  (for-each 
+   (lambda (fname)
+     (if (file-exists? fname)
+	 (nldb:read-file fname)))
+   fnames))
+
+;;======================================================================
+;; PRECOMPILED REGEXS
+;;======================================================================
+
+(define nldb:escaped-name     (regexp "^\\s*\\\\([^\\s]+)\\s*"))
+(define nldb:trailing-garbage (regexp "^\\s*([^\\s,;]+)[,;\\s]*$"))
+(define nldb:module-pin       (regexp "^\\s*([^\\s]+)\\s*([,\\s\\)]*)"))
+(define nldb:pins-end         (regexp "\\)\\s*;"))
+(define nldb:input-output     (regexp "\\s*(input|output)\\s+([^\\s]+)[\\s;,]"))
+
+;;                                           modname instname( .\pinname[35] (\netname ),
+(define nldb:instance         (regexp "^\\s*([^\\s]+)\\s+([^\\s]+)\\s*\\(\\s*\\.([^\\s]+)\\s*\\(\\s*([^\\s]+)\\s*\\)\\s*,"))
+(define nldb:inst-conn        (regexp "^\\s*\\.([^\\s]+)\\s*\\(\\s*([^\\s])+\\s+\\)\\s*([\\),;]+)"))
+
+;;                                                 module_name         netname (opt)
+(define nldb:module-regex (regexp "^\\s*module\\s+([^\\s]+)\\s*\\(\\s*([^\\s,]+\\s*,|)$"))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+;; apply regex and set nldb:match-val
+(define nldb:match-val #f)
+(define (nldb:regex-match r l)
+  (let ((m (string-match r l)))
+    (set! nldb:match-val m) m))
+
+;; stmt can only return *one* value!!
+(define (nldb:sqlite3:get-one stmt . params)
+  (let ((sqlstmt (sqlite3:prepare db stmt))
+	(result  #f))
+    (apply sqlite3:for-each-row
+	   (lambda (x)
+	     (set! result x)) sqlstmt params)
+    (sqlite3:finalize! sqlstmt)
+    result))
+
+;;======================================================================
+;; CACHE
+;;======================================================================
+
+(define *cache*             (make-hash-table))
+(define *module-name-cache* (make-hash-table))
+
+(define (cache-get-module-hash module)
+  (sub-hash-create-get *cache* module))
+
+(define (sub-hash-create-get subhash key)
+  (let ((shash (hash-table-get/default subhash key)))
+    (if shash shash
+	(let ((newh (make-hash-table)))
+	  (hash-table-set! subhash key newh)
+	  newh))))
+
+;; (cache-set! "abc_adder" 'pin "addrin" 0)
+(define (cache-set! module objtype objname value)
+  (let* ((mhash (cache-get-module-hash module))
+	 (thash (sub-hash-create-get mhash objtype)))
+    (hash-table-set! thash objname value)))
+
+(define (cache-ref module objtype objname)
+  (let ((mhash (hash-table-ref/default *cache* module)))
+    (if mhash
+	(let ((ohash (hash-table-ref/default mhash objtype)))
+	  (if ohash
+	      (hash-table-ref/default ohash objname)
+	      #f))
+	#f)))
+    
+;;======================================================================
+;; NAMES
+;;======================================================================
+
+(define nldb:names-hash (make-hash-table))
+
+;; always sucessful. inserts name if not found
+(define (nldb:get-name-id name)
+  (let ((cached-id (hash-table-ref/default nldb:names-hash name #f)))
+    (if cached-id cached-id
+	(let ((id (nldb:sqlite3:get-one "SELECT id FROM names WHERE name=?;" name)))
+	  (if id
+	      (begin
+		(hash-table-set! nldb:names-hash name id )
+		id)
+	      (begin
+		(sqlite3:exec db "INSERT INTO names (name) VALUES (?);" name)
+		(nldb:get-name-id name)))))))
+
+(define (nldb:clean-name name)
+  (if (nldb:regex-match nldb:escaped-name name) ;; process escaped identifiers
+      (list-ref nldb:match-val 1)
+      (if (nldb:regex-match nldb:trailing-garbage name)
+	  (list-ref nldb:match-val 1)
+	  name)))
+
+;;======================================================================
+;; MODULES
+;;======================================================================
+
+;; add a module and return its id.
+(define (nldb:get-module-id name-id)
+  (let ((id  (nldb:sqlite3:get-one 
+	      "SELECT id FROM modules WHERE name_id=?;" name-id)))
+    (if id id
+	(begin
+	  (nldb:insert-module name-id)
+	  (nldb:get-module-id name-id))))) ;; now retrieve and return the id
+
+;; not safe to use outside of get-module-id - could add duplicates
+(define (nldb:insert-module name-id)
+  (sqlite3:exec db "INSERT INTO modules (name_id) VALUES (?);" name-id))
+
+;; module namespace is unique so this is ok, should check for redefining though.
+(define (nldb:get-module-by-name name)
+  (let ((module-id (hash-table-ref *module-name-cache* name)))
+    (if module-id module-id
+	(let ((mid (nldb:get-module-id (nldb:get-name-id name))))
+	  (hash-table-set! *module-name-cache* name mid)))))
+
+;;======================================================================
+;; PINS
+;;======================================================================
+
+(define (nldb:get-pin-id module-id name-id)
+  (nldb:sqlite3:get-one 
+   (string-append "SELECT id FROM pins WHERE module_id=? AND name_id=?;") 
+   module-id name-id))
+
+(define (nldb:add-pin module-id name-id type-id)
+  (let ((pin-id (nldb:get-pin-id module-id name-id)))
+    (if pin-id pin-id
+	(begin	
+	  (nldb:insert-pin module-id name-id type-id)
+	  (nldb:get-pin-id module-id name-id)))))
+
+(define (nldb:insert-pin module-id name-id type-id)
+  (sqlite3:exec db "INSERT INTO pins (module_id,name_id,type_id) VALUES (?,?,?);"
+		module-id name-id (if type-id type-id 0)))
+
+(define (nldb:set-pin-direction pin-id direction)
+  (sqlite3:exec db "UPDATE pins SET type_id=(SELECT id FROM types WHERE type=?) WHERE id=?;" direction pin-id))
+
+(define (nldb:set-pin-net pin-id net-id)
+  (sqlite3:exec db "UPDATE pins SET net_id=? WHERE id=?;" net-id pin-id))
+
+;;====================================================================
+;; CONNS
+;;======================================================================
+
+(define (nldb:get-conn-id inst-id pin-id)
+  ;; (if (not (and inst-id pin-id))(print "ERROR: nldb:get-conn-id called with bad params: inst-id " inst-id " pin-id " pin-id)
+  (nldb:sqlite3:get-one  "SELECT id FROM conns WHERE inst_id=? AND pin_id=?;" inst-id pin-id))
+
+(define (nldb:add-conn inst-id pin-id net-id)
+  ;;  (if (not (and inst-id pin-id net-id))(print "ERROR: nldb:add-conn called with bad params: inst-id " inst-id " pin-id " pin-id " net-id " net-id)
+  (let ((conn-id (nldb:get-conn-id inst-id pin-id)))
+    (if conn-id conn-id
+	(begin	
+	  (nldb:insert-conn inst-id pin-id net-id)
+	  (nldb:get-conn-id inst-id pin-id)))))
+
+(define (nldb:insert-conn inst-id pin-id net-id)
+  ;;  (if (not (and inst-id pin-id net-id))(print "ERROR: nldb:insert-conn called with bad params: inst-id " inst-id " pin-id " pin-id " net-id " net-id)
+  (sqlite3:exec db "INSERT INTO conns (inst_id,pin_id,net_id) VALUES (?,?,?);"
+		inst-id pin-id net-id ))
+
+;;======================================================================
+;; NET
+;;======================================================================
+
+(define (nldb:get-net-id module-id name-id)
+  (nldb:sqlite3:get-one "SELECT id FROM nets WHERE name_id=?;" name-id))
+
+(define (nldb:add-net module-id name-id)
+  (let ((net-id (nldb:get-net-id module-id name-id)))
+    (if net-id net-id
+	(begin
+	  (nldb:insert-net module-id name-id)
+	  (nldb:get-net-id module-id name-id)))))
+
+(define (nldb:insert-net module-id name-id)
+  (sqlite3:exec db "INSERT INTO nets (module_id,name_id) VALUES(?,?);" module-id name-id))
+
+;;======================================================================
+;; INSTANCES
+;;======================================================================
+
+(define (nldb:get-inst-id parent-id name-id)
+  (nldb:sqlite3:get-one "SELECT id FROM insts WHERE parent_id=? AND name_id=?;" parent-id name-id))
+
+;; sub-mod-id = type of instance, parent-id = where instantiated
+(define (nldb:add-inst module-id parent-id name-id)
+  (let ((inst-id (nldb:get-inst-id parent-id name-id))) ;; parent and name are enough to identify it
+    (if inst-id inst-id
+	(begin
+	  (nldb:insert-inst module-id parent-id name-id)
+	  (nldb:get-inst-id parent-id name-id)))))
+
+(define (nldb:insert-inst module-id parent-id name-id)
+  (sqlite3:exec db "INSERT INTO insts (module_id,parent_id,name_id) VALUES(?,?,?);" module-id parent-id name-id))
+
+;;======================================================================
+;; RECORD FOR STATE
+;;======================================================================
+
+(define *statevec* (make-vector 5))
+
+(define-inline (curr-pin-id)           (vector-ref  *statevec* 0))
+(define-inline (curr-inst-id)          (vector-ref  *statevec* 1))
+(define-inline (curr-module-id)        (vector-ref  *statevec* 2))
+(define-inline (curr-inst-module-id)   (vector-ref  *statevec* 3))
+
+(define-inline (set-curr-pin-id!         id)(vector-set! *statevec* 0 id))
+(define-inline (set-curr-inst-id!        id)(vector-set! *statevec* 1 id))
+(define-inline (set-curr-module-id!      id)(vector-set! *statevec* 2 id))
+(define-inline (set-curr-inst-module-id! id)(vector-set! *statevec* 3 id))
+
+;;======================================================================
+;; FILE I/O
+;;======================================================================
+
+;; Initialization and support routines for nldb:read-file
+(stack-push! nldb:*stack* 'start)
+(define nldb:esc-regex  (regexp "^\\\\([^\\s]*)\\s*$") )
+(define (nldb:clean-identifier token)
+  (let* ((t   (car token))
+	 (v   (cadr token))
+	 (ctm (string-match nldb:esc-regex v)))
+    (list 'identifier (list-ref ctm 1))))
+
+
+(define (nldb:read-file fname)
+  (let* ((inp (open-input-file fname))
+	 (prev-state #f))
+    (lexer-init 'port inp)
+    (let loop ((token          (lexer)))
+      (let ((token-type (car token))
+	    (token-val  (cadr token))
+	    (state      (stack-peek herc:*stack*)))
+	(if (not (eq? prev-state state))
+	    (begin
+	      (print "state: " state)
+	      (set! prev-state state)))
+	(case token-type
+	  ('end-of-input       (print "Done")(close-input-port inp))
+	  ('whitespace         (loop (lexer)))  ;; skip whitespace
+	  ('comment-begin      
+	   (stack-push! herc:*stack* 'comment )
+	   (loop (lexer)))
+	  ('comment-end        (stack-pop! herc:*stack*)(loop (lexer)))
+	  ('begin              (stack-push! herc:*stack* 'begin)(loop (lexer)))
+	  ('end                (stack-pop! herc:*stack*)(loop (lexer)))
+	  ('cell
+	   (case state
+	     ('begin
+	       (stack-push! herc:*stack* 'cell-name)
+	       (loop (lexer)))
+	     (else
+	      (loop (lexer)))))
+	  ('plainidentifier
+	   (case state
+	     ('cell-name
+
+	  ('statementend       (stack-pop! nldb:*stack*)(loop (lexer)))
+	  ('endparen           (stack-pop! nldb:*stack*)(loop (lexer)))
+	  ('endmodule          (stack-pop! nldb:*stack*)(loop (lexer)))
+
+	  ('startparen 
+	   (case state
+	     ('module-pins     (loop (lexer)))
+	     ('inst-def        (loop (lexer)))
+	     ('inst-conn-def   (loop (lexer)))
+	     ('pin-net         (loop (lexer)))
+	     (else             (print "ERROR: Didn't expect an open paren here! Line " (lexer-get-line)))))
+
+	  ('comma
+	   (case state
+	     ('module-pins     (loop (lexer)))
+	     ('input-pin       (loop (lexer)))
+	     ('output-pin      (loop (lexer)))
+	     ('wire            (loop (lexer)))
+	     ('inst-conn-def   (loop (lexer))) ;; (stack-pop! nldb:*stack*) (loop (lexer)))
+	     (else             (print "ERROR: Didn't expect a comma here! Line " (lexer-get-line)))))
+
+	  ('module 
+	   (case state
+	     ('start 
+	      (stack-push! nldb:*stack* 'module)      ;; we will be in a module
+	      (stack-push! nldb:*stack* 'module-def)) ;; starting in the def
+	     (else
+	      (print "ERROR: Didn't expect module declaration here! Line " (lexer-get-line))))
+	   (loop (lexer)))
+
+	  ('input 
+	   (case state
+	     ('module      (stack-push! nldb:*stack* 'input-pin))
+	     (else         (print "ERROR: Didn't expect \"input\" statement here! Linenum " (lexer-get-line))))
+	   (loop (lexer)))
+
+	  ('output
+	   (case state
+	     ('module      (stack-push! nldb:*stack* 'output-pin))
+	     (else         (print "ERROR: Didn't expect \"output\" statement here! Linenum " (lexer-get-line))))
+	   (loop (lexer)))
+	  
+	  ('inout
+	   (case state
+	     ('module      (stack-push! nldb:*stack* 'inout-pin))
+	     (else         (print "ERROR: Didn't expect \"inout\" statement here! Linenum " (lexer-get-line))))
+	   (loop (lexer)))
+
+	  ('pin 
+	   (case state
+	     ('inst-conn-def
+	      (let* ((pin-name    (substring token-val 1 (string-length token-val)))
+		     (pin-name-id (nldb:get-name-id pin-name))
+		     (pin-id      (nldb:add-pin (curr-module-id) pin-name-id #f)))
+		(stack-push! nldb:*stack* 'pin-net)
+		(set-curr-pin-id! pin-id)
+		(loop (lexer))))
+	     (else  (print "ERROR: Didn't expect pin here " token-val " Linenum: " (lexer-get-line)))))
+
+	  ('identifier
+	   (case state
+	     ('module  ;; this must be an instance, an identifier at the top level
+	      (let* ((inst-mod-id (nldb:get-module-by-name token-val)))
+		(set-curr-inst-module-id! inst-mod-id)
+		(stack-push! nldb:*stack* 'inst-def))
+	      (loop (lexer)))
+	     ('inst-def                  ;;     inst-module type  parent-id    inst-name-id
+	      (let* ((inst-id (nldb:add-inst (curr-inst-module-id)(curr-module-id)(nldb:get-name-id token-val))))
+		(set-curr-inst-id! inst-id))
+	      (stack-push! nldb:*stack* 'inst-conn-def)
+	      (loop (lexer)))
+	     ('module-def
+	      (let* ((m-id (nldb:get-module-by-name token-val)))
+		(set-curr-module-id! m-id))
+	      (stack-push! nldb:*stack* 'module-pins))
+	     ('module-pins
+	      (nldb:add-pin (curr-module-id) (nldb:get-name-id token-val) #f))
+	     ('input-pin
+	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
+		(nldb:set-pin-direction pin-id "input")))
+	     ('output-pin
+	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
+		(nldb:set-pin-direction pin-id "output")))
+	     ('inout-pin
+	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
+		(nldb:set-pin-direction pin-id "inout")))
+	     ('pin-net
+	      (let* ((net-name-id (nldb:get-name-id token-val))
+		     (net-id      (nldb:add-net (curr-inst-module-id) net-name-id)))
+		(nldb:add-conn (curr-inst-id) (curr-pin-id) net-id)))
+	     (else
+	      (print "ERROR: Didn't expect an identifier here! Token " token-val " Line " (lexer-get-line))))
+	   (loop (lexer)))
+
+	  (else
+	   (print "ERROR: unknown token " token " on line " (lexer-get-line))
+	   (loop (lexer))))))))
+     

ADDED   stml2/requirements.scm.template
Index: stml2/requirements.scm.template
==================================================================
--- /dev/null
+++ stml2/requirements.scm.template
@@ -0,0 +1,16 @@
+;; choose your db interface as appropriate
+(require-extension sqlite3)
+(import (prefix sqlite3 sqlite3:))
+
+;; (require-extension postgresql)
+;; (import (prefix postgresql pg:))
+
+;; (require-extension cgi-util)
+;; (require-extension cookie)
+(use posix)
+;; (require-extension proplist)
+(use regex)
+(use srfi-1) 
+;; (require-extension tinyclos)
+(use srfi-69)
+(use data-structures)

ADDED   stml2/rollup-pages.scm
Index: stml2/rollup-pages.scm
==================================================================
--- /dev/null
+++ stml2/rollup-pages.scm
@@ -0,0 +1,49 @@
+(use regex posix srfi-69 srfi-1)
+
+(define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm"))
+
+(define (print-page-wrapper lookup page)
+  (print "(define (pages:" page " session db shared)")
+  (if (hash-table-ref/default lookup (conc page "_ctrl") #f)
+      (print "(include \"pages/" page "_ctrl.scm\")"))
+  (if (hash-table-ref/default lookup (conc page "_view") #f)
+      (print "(include \"pages/" page "_view.scm\")"))
+  (print ")\n"))
+
+(let* ((views  (glob "pages/*_view.scm"))
+       (ctrls  (glob "pages/*_ctrl.scm"))
+       (all    (append views ctrls))
+       (lookup (make-hash-table))
+       (pages  (delete-duplicates
+		(map (lambda (x)
+		       (let* ((res  (string-match extract-rx x))
+			      (page (cadr res))
+			      (type (caddr res)))
+			 (hash-table-set! lookup (conc page "_" type) #t)
+			 (cadr res)))
+		     all))))
+  (if (null? all)(begin (print "No page files matching pages/*_(view|ctrl).scm")(exit)))
+  (print "Pages: " pages)
+  ;; first the individual rollup wrappers (used by the dynamic load)
+  (for-each 
+   (lambda (page)
+     (let ((pagefile  (conc "pages/" page ".scm")))
+       (print "page " page " ")
+       (if (not (file-exists? pagefile))
+	   (begin
+	     (with-output-to-file pagefile
+	       (lambda ()
+		 (print-page-wrapper lookup page)))
+	     (print " created"))
+	   (print " already created"))))
+   pages)
+  ;; then the monolithic rollup wrapper (used in compiling the single-executable)
+  (with-output-to-file "all_pages.scm"
+    (lambda ()
+      (for-each
+       (lambda (page)
+	 (print-page-wrapper lookup page))
+       pages))))
+
+
+  

ADDED   stml2/session.scm
Index: stml2/session.scm
==================================================================
--- /dev/null
+++ stml2/session.scm
@@ -0,0 +1,20 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; (declare (unit session))
+(module session
+    *
+  
+(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)
+
+(use (prefix dbi dbi:) srfi-69)
+(require-extension regex)
+(use cookie stmlcommon) ;; (declare (uses cookie))
+
+)

ADDED   stml2/sessions.sql
Index: stml2/sessions.sql
==================================================================
--- /dev/null
+++ stml2/sessions.sql
@@ -0,0 +1,5 @@
+CREATE TABLE session_vars (id integer primary key,  session_id integer, page text, key text, value text);
+
+CREATE TABLE sessions ( id integer primary key, session_key text); 
+	
+

ADDED   stml2/setup.scm
Index: stml2/setup.scm
==================================================================
--- /dev/null
+++ stml2/setup.scm
@@ -0,0 +1,21 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+(module setup
+    *
+(import chicken scheme data-structures extras srfi-13 ports posix)
+
+(uses session misc-stml)
+;; (declare (unit setup))se
+;; (declare (uses session))
+(require-extension srfi-69)
+(require-extension regex)
+
+
+)

ADDED   stml2/spiffyserver.scm
Index: stml2/spiffyserver.scm
==================================================================
--- /dev/null
+++ stml2/spiffyserver.scm
@@ -0,0 +1,13 @@
+;; This doesn't work yet
+;;
+(use spiffy cgi-handler)
+
+(spiffy-debug-mode #t)
+
+(spiffy-file-ext-handlers 
+ `(("drcdb" . ,(cgi-handler* "/path/to/drcdb"))))
+
+(spiffy-root-path "/path/to/web")
+
+(start-server location: (get-host-name)
+                init: noop)

ADDED   stml2/sqlite3.scm
Index: stml2/sqlite3.scm
==================================================================
--- /dev/null
+++ stml2/sqlite3.scm
@@ -0,0 +1,54 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;
+
+;; I used this to get a simple interactive sqlite editor on the nokia n800
+;; since I couldn't get sqlite3 to install (for reasons I can't remember).
+
+(use sqlite3)
+
+(define args (argv))
+(define num-args (length args))
+
+(define dbname #f)
+(define cmd    #f)
+
+(if (> num-args 1)
+  (set! dbname (cadr args))
+  (exit 0))
+
+(if (> num-args 2)
+  (set! cmd (caddr args)))
+
+(define db (sqlite3:open dbname))
+
+(define (interactive db)
+  (let ((prompt " > "))
+    (display prompt)
+  (let loop ((cmd (read-line)))
+    (cond 
+      ((> (string-length cmd) 0)
+       (process-cmd db cmd)
+       (display prompt)
+       (loop (read-line)))
+      (else
+	(loop (read-line)))))))
+ 
+(define (process-cmd db cmd)
+  (sqlite3:for-each-row
+    (lambda (a . b)
+      (print a " " (string-intersperse b " ")))
+    db cmd))
+
+(if cmd
+  (process-cmd db cmd)
+  (interactive db))
+
+(sqlite3:finalize! db)    
+

ADDED   stml2/stml.config.template
Index: stml2/stml.config.template
==================================================================
--- /dev/null
+++ stml2/stml.config.template
@@ -0,0 +1,8 @@
+'(sroot   "/path/to/{pages,models}/dir"
+  logfile "/tmp/stmlrun/logs.log"
+  dbtype  sqlite3
+  dbinit   ((dbname   . "test-stml.db")
+            (user     . "nobody")
+            (password . "Dapassword")
+            (host     . "localhost"))
+  domain  "192.168.1.150")

ADDED   stml2/stml2.meta
Index: stml2/stml2.meta
==================================================================
--- /dev/null
+++ stml2/stml2.meta
@@ -0,0 +1,20 @@
+(
+; Your egg's license:
+(license "LGPL")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category misc)
+
+; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+(needs srfi-69)
+
+; A list of eggs required for TESTING ONLY.  See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "Primitive argument processor."))

ADDED   stml2/stml2.scm
Index: stml2/stml2.scm
==================================================================
--- /dev/null
+++ stml2/stml2.scm
@@ -0,0 +1,2687 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; stml is a list of html strings
+
+;; (declare (unit stml))
+
+(module stml2
+    *
+
+(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) 
+
+(use cookie (prefix dbi dbi:) (prefix crypt c:) typed-records)
+
+;; (declare (uses misc-stml))
+(use regex)
+
+;; The (usually global) sdat contains everything about the session
+;;
+(defstruct sdat
+  ;; database
+  (dbtype 'pg)
+  (dbinit #f)
+  (conn   #f)
+  ;; page info
+  (page "index")
+  (page-type 'html)
+  (toppage "index")
+  (curr-page    "index")
+  (content-type "Content-type: text/html; charset=iso-8859-1\n\n")
+  ;; forms and variables
+  (formdat      #f)
+  (params '())
+  (path-params '())
+  (session-key #f)
+  (pagedat     '())
+  (alt-page-dat #f)
+  (session-cookie #f)
+  (pagevars        (make-hash-table))
+  (pagevars-before (make-hash-table))
+  (sessionvars     (make-hash-table))
+  (sessionvars-before (make-hash-table))
+  (globalvars      (make-hash-table))
+  (globalvars-before (make-hash-table))
+  ;; ports and log file
+  (curr-err       #f)
+  (log-port       (current-error-port))
+  (logfile        "/tmp/stml.log")
+  (seen-pages     '())
+  (page-dir-style  'flat)
+  (debug-mode      #f)
+  (session-id      #f)
+  (request-method  #f)
+  (domain          "localhost")
+  (twikidir        #f)
+  (script          #f)
+  (force-ssl       #f)
+  (shared-hash     (make-hash-table))
+  ;; paths
+  (sroot         "./")
+  (models        #f)
+  (views         #f)
+)
+
+(define (sdat-set-if session configdat var settor)
+  (let ((val (s:find-param var configdat)))
+    (if val (settor session val))))
+
+(define (session:initialize session #!optional (configf #f))
+  ;; (let* ((rawconfigdat (session:read-config session configf))
+  ;;	 (configdat (if rawconfigdat (eval rawconfigdat) '())))
+    ;; (sdat-set-if session configdat 'sroot     sdat-root-set!)
+    ;; (sdat-set-if session configdat 'logfile   sdat-logfile-set!)
+    ;; (sdat-set-if session configdat 'dbtype    sdat-dbtype-set!)
+    ;; (sdat-set-if session configdat 'dbinit    sdat-dbinit-set!)
+    ;; (sdat-set-if session configdat 'domain    sdat-domain-set!)
+    ;; (sdat-set-if session configdat 'twikidir  sdat-twikidir-set!)
+    ;; (sdat-set-if session configdat 'page-dir-style sdat-page-set!)
+    ;; (sdat-set-if session configdat 'sroot sdat-root-set!)
+    ;; (sdat-set-if session configdat 'sroot sdat-root-set!)
+    ;; (sdat-set-if session configdat 'sroot sdat-root-set!)
+    ;; following are set always from config
+    ;; (sdat-page-dir-style-set! session (s:find-param 'page-dir-style configdat))
+  (let* ((rawconfigdat (session:read-config session configf))
+	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
+	 (sroot     (s:find-param 'sroot    configdat))
+	 (models    (s:find-param 'models   configdat))
+	 (views     (s:find-param 'views    configdat))
+	 (logfile   (s:find-param 'logfile  configdat))
+	 (dbtype    (s:find-param 'dbtype   configdat))
+	 (dbinit    (s:find-param 'dbinit   configdat))
+	 (domain    (s:find-param 'domain   configdat))
+	 (twikidir  (s:find-param 'twikidir configdat))
+	 (page-dir  (s:find-param 'page-dir-style configdat))
+	 (debugmode (or (s:find-param 'debug-mode configdat)(s:find-param 'debugmode configdat)))
+         (script    (s:find-param 'script    configdat))
+	 (force-ssl (s:find-param 'force-ssl configdat)))
+    (if sroot    (sdat-sroot-set!      session sroot))
+    (if models   (sdat-models-set!     session models))
+    (if views    (sdat-views-set!      session views))
+    (if logfile  (sdat-logfile-set!    session logfile))
+    (if dbtype   (sdat-dbtype-set!     session dbtype))
+    (if dbinit   (sdat-dbinit-set!     session dbinit))
+    (if domain   (sdat-domain-set!     session domain))
+    (if twikidir (sdat-twikidir-set!   session twikidir))
+    (if debugmode (sdat-debug-mode-set! session debugmode))
+    (if script    (sdat-script-set!    session script))
+    (if force-ssl (sdat-force-ssl-set! session force-ssl))
+    (sdat-page-dir-style-set! session page-dir)
+    ;; (print "configdat: ")(pp configdat)
+    (if debugmode
+	(session:log session "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
+		     " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
+    ))
+
+;; extract various tokens from the parameter list
+;;   'key val => put in the params list
+;;   strings  => maintain order and add to the datalist <<== IMPORTANT
+(define (s:extract inlst)
+  (if (null? inlst) inlst
+      (let loop ((data '())
+                 (params '())
+                 (head (car inlst))
+                 (tail (cdr inlst)))
+        ;; (print "head=" head " tail=" tail)
+        (cond 
+         ((null? tail)
+          (if (symbol? head) ;; the last item is a param - borked
+              (s:log "ERROR: param with no value"))
+          (list (append data (list (s:any->string head))) params))
+         ((or (string? head)(list? head)(number? head))
+          (loop (append data (list  (s:any->string head))) params (car tail)   (cdr tail)))
+         ((symbol? head)
+          (let ((new-params (cons (list head (car tail)) params))
+                (new-tail  (cdr tail)))
+            (if (null? new-tail) ;; we are done, no more params etc.
+                (list data new-params)
+                (loop data new-params (car new-tail)(cdr new-tail)))))
+         (else
+          (s:log "WARNING: Malformed input, you have broken stml, remember that all stml calls should return a result (null list or empty string is ok):\n  head=" head 
+	          "\n  tail=" tail 
+                  "\n  inlst=" inlst 
+                  "\n  params=" params)
+	  (if (null? tail)
+	      (list data params)
+	      (loop data params (car tail)(cdr tail))))))))
+
+;; most tags can be handled by this routine
+(define (s:common-tag tagname args)
+  (let* ((inputs (s:extract args))
+         (data   (car inputs))
+         (params (s:process-params (cadr inputs))))
+    (list (conc "<" tagname params ">")
+          data
+          (conc "</" tagname ">"))))
+
+;; Suggestion: order these alphabetically
+(define (s:a      . args) (s:common-tag "A"      args))
+(define (s:b      . args) (s:common-tag "B"      args))
+(define (s:u      . args) (s:common-tag "U"      args))
+(define (s:big    . args) (s:common-tag "BIG"    args))
+(define (s:body   . args) (s:common-tag "BODY"   args))
+(define (s:button . args) (s:common-tag "BUTTON" args))
+(define (s:center . args) (s:common-tag "CENTER" args))
+(define (s:code   . args) (s:common-tag "CODE"   args))
+(define (s:div    . args) (s:common-tag "DIV"    args))
+(define (s:h1     . args) (s:common-tag "H1"     args))
+(define (s:h2     . args) (s:common-tag "H2"     args))
+(define (s:h3     . args) (s:common-tag "H3"     args))
+(define (s:h4     . args) (s:common-tag "H4"     args))
+(define (s:h5     . args) (s:common-tag "H5"     args))
+(define (s:head   . args) (s:common-tag "HEAD"   args))
+(define (s:html   . args) (s:common-tag "HTML"   args))
+(define (s:i      . args) (s:common-tag "I"      args))
+(define (s:img    . args) (s:common-tag "IMG"    args))
+(define (s:input  . args) (s:common-tag "INPUT"  args))
+(define (s:output . args) (s:common-tag "OUTPUT" args))
+(define (s:link   . args) (s:common-tag "LINK"   args))
+(define (s:p      . args) (s:common-tag "P"      args))
+(define (s:strong . args) (s:common-tag "STRONG" args))
+(define (s:table  . args) (s:common-tag "TABLE"  args))
+(define (s:tbody  . args) (s:common-tag "TBODY"  args))
+(define (s:thead  . args) (s:common-tag "THEAD"  args))
+(define (s:th     . args) (s:common-tag "TH"     args))
+(define (s:td     . args) (s:common-tag "TD"     args))
+(define (s:title  . args) (s:common-tag "TITLE"  args))
+(define (s:tr     . args) (s:common-tag "TR"     args))
+(define (s:small  . args) (s:common-tag "SMALL"  args))
+(define (s:quote  . args) (s:common-tag "QUOTE"  args))
+(define (s:hr     . args) (s:common-tag "HR"     args))
+(define (s:li     . args) (s:common-tag "LI"     args))
+(define (s:ul     . args) (s:common-tag "UL"     args))
+(define (s:ol     . args) (s:common-tag "OL"     args))
+(define (s:dl     . args) (s:common-tag "DL"     args))
+(define (s:dt     . args) (s:common-tag "DT"     args))
+(define (s:dd     . args) (s:common-tag "DD"     args))
+(define (s:pre    . args) (s:common-tag "PRE"    args))
+(define (s:span   . args) (s:common-tag "SPAN"   args))
+(define (s:label  . args) (s:common-tag "LABEL"  args))
+(define (s:script . args) (s:common-tag "SCRIPT" args))
+
+(define (s:dblquote  . args)
+  (let* ((inputs (s:extract args))
+         (data   (caar inputs))
+         (params (s:process-params (cadr inputs))))
+    (conc "&quot;" data "&quot;")))
+
+(define (s:br     . args) "<BR>") ;;  THIS MAY NOT WORK!!!! BR CAN (MISTAKENLY) GET PARAM TEXT
+;; (define (s:br     . args) (s:common-tag "BR"     args))
+(define (s:font   . args) (s:common-tag "FONT"   args))
+(define (s:err-font . args)
+  (s:b (s:font 'color "red" args)))
+
+(define (s:comment . args)
+  (let* ((inputs (s:extract args))
+         (data   (car inputs))
+         (params (s:process-params (cadr inputs))))
+    (list "<!--" data "-->")))
+
+(define (s:null   . args) ;; nop
+  (let* ((inputs (s:extract args))
+         (data   (car inputs))
+         (params (s:process-params (cadr inputs))))
+    (list data)))
+
+;; puts a nice box around a chunk of stuff
+(define (s:fieldset legend . args)
+  (list "<FIELDSET><LEGEND>" legend "</LEGEND>" args "</FIELDSET>"))
+
+;; given a string return the string if it is non-white space or &nbsp; otherwise
+(define (s:nbsp str)
+  (if (string-match "^\\s*$" str)
+      "&nbsp;"
+      str))
+
+;; USE 'page_override to override a linkto page from a button
+(define (s:form   . args)
+  ;; create a link for calling back into the current page and calling a specified 
+  ;; function
+  (let* ((action     (let ((v (s:find-param 'action args)))
+                       (if v v "default")))
+	 (id         (let ((i (s:find-param 'id args)))
+		       (if i i #f)))
+         (page       (let ((p (sdat-page s:session)))
+                       (if p p "home")))
+	 ;; (link       (session:link-to s:session page (if id
+         ;;                                                 (list 'action action 'id id)
+         ;;                                                 (list 'action action)))))
+	 (link       (if (string=? (substring action 0 5) "http:") ;; if first part of string is http:
+	        	 action
+	        	 (session:link-to s:session 
+	        			  page 
+	        			  (if id
+	        			      (list 'action action 'id id)
+	        			      (list 'action action))))))
+    ;; (script     (slot-ref s:session 'script))
+    ;; (action-str (string-append script "/" page "?action=" action)))
+    (s:common-tag "FORM" (append (s:remove-param-matching (s:remove-param-matching args 'action) 'id)
+                                 (list 'action link)))))
+
+;; look up the variable name (via the 'name tag) then inject the value from the session var
+;; replacing the 'value value if it is already there, adding it if it is not.
+(define (s:preserve tag args)
+  (let* ((var-name (s:find-param 'name args)) ;; name='varname'
+	 (value    (let ((v (s:get var-name)))
+		     (if v v #f)))
+	 (newargs  (append (s:remove-param-matching args 'value) (if value (list 'value value) '()))))
+    (s:common-tag tag newargs)))
+
+(define (s:input-preserve  . args)
+  (s:preserve "INPUT" args))
+
+;; text areas are done a little differently. The value is stored between the tags <textarea ...>the value goes here</textarea>
+(define (s:textarea-preserve . args)
+  (let* ((var-name (s:find-param 'name args))
+	 (value    (let ((v (s:get var-name)))
+		     (if v v #f))))
+    (s:common-tag "TEXTAREA" (if value (cons value args) args))))
+
+(define (s:option dat)
+  (let ((len      (length dat)))
+    (cond
+     ((eq? len 1)
+      (let ((item (car dat)))
+	(s:option (list item item item))))
+     ((eq? len 2)
+      (s:option (append dat (list (car dat)))))
+     (else
+      (let ((label    (car dat))
+	    (value    (cadr dat))
+	    (dispval  (caddr dat))
+	    (selected (if (> len 3)(cadddr dat) #f)))
+	(list (conc "<OPTION " 
+		    (if selected " selected " "")
+		    "label=\"" label
+		    "\" value=\"" value
+		    "\">" dispval "</OPTION>")))))))
+
+;; call only with (label (label value dispval [#t]) ...)
+;; NB// sadly this block is redundantly almost identical to the s:select
+;; fix that later ...
+(define (s:optgroup dat)
+  (let ((label (car dat))
+	(rem   (cdr dat)))
+    (if (null? rem)
+	(s:common-tag "OPTGROUP" `('label ,label))
+	(let loop ((hed (car rem))
+		   (tal (cdr rem))
+		   (res (list (conc "<OPTGROUP label=" label))))
+	  ;; (print "hed: " hed " tal: " tal " res: " res)
+	  (let ((new (append res (list (if (list? (cadr hed))
+					   (s:optgroup hed)
+					   (s:option hed))))))
+	    (if (null? tal)
+		(append new (list "</OPTGROUP>"))
+		(loop (car tal)(cdr tal) new)))))))
+    
+;; items is a hierarchial alist
+;; ( (label1 value1 dispval1 #t) ;; <== this one is selected
+;;   (label2 (label3 value2 dispval2)
+;;           (label4 value3 dispval3)))
+;;     
+;;  required arg is 'name
+(define (s:select items . args)
+  (if (null? items)
+      (s:common-tag "SELECT" args)
+      (let loop ((hed (car items))
+		 (tal (cdr items))
+		 (res '()))
+	;; (print "hed: " hed " tal: " tal " res: " res)
+	(let ((new (append res (list (if (and (> (length hed) 1)
+					      (list? (cadr hed)))
+					 (s:optgroup hed)
+					 (s:option hed))))))
+	  (if (null? tal)
+	      (s:common-tag "SELECT" (cons new args))
+	      (loop (car tal)(cdr tal) new))))))
+
+(define (s:color  . args)
+  "#00ff00")
+
+(define (s:print indent inlst)
+  (map (lambda (x)
+         (cond 
+          ((or (string? x)(symbol? x))
+           (print (conc (make-string (* indent 2) #\ ) (s:any->string x))))
+          ((list? x)
+           (s:print (+ indent 1) x))
+          (else
+           ;; (print "ERROR: Bad input 01") ;; why do anything with junk?
+           )))
+       inlst))
+
+;; Moved to misc-stml
+;;
+#;(define (s:cgi-out inlst)
+  (s:output (current-output-port) inlst))
+
+#;(define (s:output port inlst)
+  (map (lambda (x)
+	 (cond 
+	  ((string? x) (print x)) ;; (print x))
+	  ((symbol? x) (print x)) ;; (print x))
+	  ((list? x)   (s:output port x))
+	  (else ""
+	   ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk.
+	   )))
+       inlst))
+;  (if (> (length inlst) 2)
+;      (print)))
+
+#;(define (s:output-new port inlst)
+  (with-output-to-port port
+      (lambda ()
+	(map (lambda (x)
+	       (cond 
+		((string? x) (print x))
+		((symbol? x) (print x))
+		((list? x)   (s:output port x))
+		(else
+		 ;; (print "ERROR: Bad input 03")
+     )))
+	     inlst))))
+
+;;======================================================================
+;; Not sure where these should go
+;;======================================================================
+
+;; (include "requirements.scm"), dbi has autoload, should not need this any more.
+
+;;======================================================================
+;; setup - convience calls to functions wrapped with a global s:session
+;;======================================================================
+
+;; macros in sugar don't work, have to load in all files or use compiled mode?
+;;
+;; (include "sugar.scm")
+
+;; use this for getting data from page to page when scope and evals
+;; get in the way
+;; save data for use in the page generation here. Does NOT persist across page reads.
+
+(define *page-data* (make-hash-table))
+
+(define (s:lset! var val)
+  (hash-table-set! *page-data* var val))
+(define (s:lget var . default)
+  (hash-table-ref/default *page-data* var (if (null? default)
+					      #f
+					      (car default))))
+
+;; to obscure and indirect database ids use one time keys
+;;
+;;  (s:get-key 'n 1)     => "n99e1882" n=number 99e is the week number since 1970, remainder is random
+;;  (s:key->val "n1882") => 1
+;;
+;;  first letter is a type: n=number, s=string, b=boolean
+(define (s:get-key key-type val)
+  (let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
+	(week      (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
+    (let loop ((siz 1000)
+	       (key (conc key-type week (mkrandstr 100)))
+	       (num 0))
+      (if (s:session-var-get key) ;; have a collision
+	  (loop (cond                 ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
+		 ((< num 50)  100)
+		 ((< num 100) 1000)
+		 ((< num 200) 10000)
+		 ((< num 300) 100000)
+		 ((< num 400) 1000000) ;; can't imagine needing to get here. remember that this is for a single user
+		 (else 100000000))
+		(conc key-type (mkrandstr siz))
+		(+ num 1))
+	  (begin
+	    (s:session-var-set! key val)
+	    key)))))
+
+;; given a key Xnnnn, look up the stored value and convert it appropriately, then
+;; destroy the stored session var
+;;
+(define (s:key->val key)
+  (let ((val (s:session-var-get key))
+	(typ (string->symbol (substring key 0 1))))
+    (if val
+	(begin
+	  (s:session-var-del! key)
+	  ;; we take this opportunity to clean up old keyed session vars
+	  ;; if more than 100 vars, remove all that are over 1-2 weeks old
+					;(s:cleanup-session-vars)
+	  (case typ
+	    ((n)(string->number val))
+	    ((s) val)
+	    (else val)))
+	val)))
+  
+;; clean up session vars
+;;
+(define (s:cleanup-session-vars)
+  (let* ((session-vars (hash-table-keys (s:session-get-sessionvars)))
+	 (week-num     (quotient (current-seconds) (* 7 24 60 60)))
+	 (week         (number->string week-num  16)))
+    (if (> (length session-vars) 100)
+	(for-each
+	 (lambda (var)
+	   (if (> (string-length var) 5) ;; can't have keyed values with keys less than 5 characters long
+	       (let ((var-week (string->number (substring var 1 4) 16)))
+		 (if (and var-week
+			  (>= (- week-num var-week) 2))
+		     (s:session-var-del! var)))))
+	 session-vars))))
+
+;; inputs
+;;
+;; param: (dtype [tag1 tag2 ...])
+;; dtype:
+;;    'raw     : do no conversion
+;;    'number  : convert to number, return #f if fails
+;;    'escaped : use html-escape to protect the input
+;;
+(define (s:get-input key . params)
+  (session:get-input s:session key params))
+
+(define (s:get-input-keys)
+  (session:get-input-keys s:session))
+
+;; get-input else, get-param else #f
+;;
+(define (s:get-inp key . params)
+  (or (apply s:get-input key params)
+      (apply s:get-param key params)))
+
+(define (s:load-model model)
+  (session:load-model s:session model))
+
+(define (s:model-path)
+  (session:model-path s:session))
+
+;; share data between pages calls. NOTE: This is not persistent
+;; between cgi calls. Use sessionvars for that.
+;;
+(define (s:shared-hash)
+  (sdat-shared-hash s:session))
+
+(define (s:shared-set! key val)
+  (hash-table-set! (sdat-shared-hash s:session) key val))
+
+;; What to return when no value for key?
+;;
+(define (s:shared-get key)
+  (hash-table-ref/default (sdat-shared-hash s:session) key #f))
+
+;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
+;;  #### DEPRECATED ####
+(define (s:get-page-params)
+  (sdat-path-params s:session))
+
+(define (s:get-path-params)
+  (sdat-path-params s:session))
+	
+
+(define (s:db)
+  (sdat-conn s:session))
+
+;;======================================================================
+;; cgi and session stuff
+;;======================================================================
+
+;;(declare (uses cookie))
+;;(declare (uses html-filter))
+;;(declare (uses misc-stml))
+;;(declare (uses formdat))
+;;(declare (uses stml))
+;;(declare (uses session))
+;;(declare (uses setup)) ;; s:session gets created here
+;;(declare (uses sqltbl))
+;;(declare (uses keystore))
+
+;; given a list of symbols give the count of the matching symbol
+;; l => '(a b c)  (dumobj:indx a 'b) => 1
+(define (s:get-fieldnum lst field-name)
+  (let loop ((head (car lst))
+             (tail (cdr lst))
+             (fnum 0))
+    (if (eq? head field-name) fnum
+        (if (null? tail) #f
+            (loop (car tail)(cdr tail)(+ fnum 1))))))
+
+(define (s:fields->string lst)
+  (string-join (map symbol->string lst) ","))
+
+(define (s:vector-get-field vec field field-list)
+  (vector-ref vec (s:get-fieldnum field-list field)))
+
+;;======================================================================
+;;
+;;======================================================================
+
+;; moved to misc-stml
+;;
+#;(define (err:log . msg)
+  (with-output-to-port (current-error-port) ;; (slot-ref self 'logpt)
+    (lambda () 
+      (apply print msg))))
+
+(define (s:tidy-url url)
+  (if url
+      (let ((r1 (regexp "^http:\\/\\/"))
+            (r2 (regexp "^[ \\t]*$"))) ;; blank
+        (if (string-match r1 url) url
+            (if (string-match r2 url) #f ;; convert a blank to #f
+                (conc "http://" url))))
+      url))
+
+(define (s:lazy->num num)
+  (if (number? num) num
+      (if (string->number num) (string->number num)
+	    (if num 1 0)))) ;; wierd eh! yep, #f=>0 #t=>1 
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+;; convert values to appropriate strings
+;;
+#;(define (s:sqlparam-val->string val)
+  (cond
+   ((list?   val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c
+   ((string? val)(conc "'" (dbi:escape-string val) "'"))
+   ((number? val)(number->string val))
+   ((symbol? val)(dbi:escape-string (symbol->string val)))
+   ((boolean? val)
+    (if val "TRUE" "FALSE"))  ;; should this be "TRUE" or 1?
+                              ;; should this be "FALSE" or 0 or NULL?
+   (else
+    (err:log "sqlparam: unknown type for value: " val)
+    "")))
+
+;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
+;; NB// 1. values only!! 
+;;      2. terminating semicolon required (used as part of logic)
+;;
+;; a=? 1 (number) => a=1
+;; a=? 1 (string) => a='1'
+;; a=? #f         => a=FALSE 
+;; a=? a (symbol) => a=a 
+;;
+#;(define (s:sqlparam query . args)
+  (let* ((query-parts (string-split query "?"))
+         (num-parts    (length query-parts))
+         (num-args    (length args)))
+    (if (not (= (+ num-args 1) num-parts))
+        (err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
+        (if (= num-args 0) query
+            (let loop ((section (car query-parts))
+                       (tail    (cdr query-parts))
+                       (result  "")
+                       (arg     (car args))
+                       (argtail (cdr args)))
+              (let* ((valstr    (s:sqlparam-val->string arg))
+                     (newresult (conc result section valstr)))
+                (if (null? argtail) ;; we are done
+                    (conc newresult (car tail))
+                    (loop
+                     (car tail)
+                     (cdr tail)
+                     newresult
+                     (car argtail)
+                     (cdr argtail)))))))))
+
+;;======================================================================
+;; M I S C   S T R I N G   S T U F F
+;;======================================================================
+
+(define (s:string-downcase str)
+  (if (string? str)
+      (string-translate str "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz")
+      str)) 
+
+;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
+#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
+#;(define session:num-valid-chars (string-length session:valid-chars))
+
+#;(define (session:get-nth-char nth)
+  (substring session:valid-chars nth  (+ nth 1)))
+
+#;(define (session:get-rand-char)
+  (session:get-nth-char (random session:num-valid-chars)))
+
+#;(define (session:make-rand-string len)
+  (let loop ((res "")
+             (n   1))
+    (if (> n len) res
+        (loop (string-append res (session:get-rand-char))
+              (+ n 1)))))
+
+;; maybe replace above make-rand-string with this someday?
+;;
+#;(define (session:generic-make-rand-string len seed-string)
+  (let ((num-chars (string-length seed-string)))
+    (let loop ((res "")
+	       (n   1))
+      (let ((char-num (random num-chars)))
+	(if (> n len) res
+	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
+		  (+ n 1)))))))
+
+;; Rely on crypt egg's default settings being secure enough, accept
+;; backwards-compatible OpenSSL crypt passwords too.
+;;
+(define (s:crypt-passwd pw s)
+  (c:crypt pw (or s (c:crypt-gensalt))))
+
+(define (s:password-match? password crypted)
+  (let* ((salt (substring crypted 0 2))
+         (pcrypted (s:crypt-passwd password salt)))
+    ;; (s:log "INFO: pcrypted=" pcrypted " crypted=" crypted)
+    (and (string? password)
+         (string? pcrypted)
+         (string=? pcrypted crypted))))
+
+;; (read-line (open-input-pipe "echo foo | mkpasswd -S ab -s"))
+
+;; BUG: The regex implements a rule, but what rule? AH! usaztempe, get rid of this? No, this also looks for &key=value ...
+(define (s:validate-uri)
+  (let ((uri (get-environment-variable "REQUEST_URI"))
+	(qrs (get-environment-variable "QUERY_STRING")))
+    (if (not uri)
+	(set! uri qrs))
+    (if uri
+	(string-match 
+	 (regexp "^(/[a-z\\-\\._:0-9]*)*(|\\?([A-Za-z0-9_\\-\\+]+=[A-Za-z0-9_\\-\\.\\+]*&{0,1})*)$") uri)
+	(begin
+	  "REQUEST URI NOT AVAILABLE!"
+	  (let ((p (open-input-pipe "env")))
+	    (let loop ((l (read-line p))
+		       (res '()))
+	      (if (eof-object? l)
+		  res
+		  (loop (read-line p)(cons (list l "<BR>") res)))))
+	  #t))))
+
+;; moved to misc-stml
+;;
+;; anything except a list is converted to a string!!!
+#;(define (s:any->string val)
+  (cond
+   ((string? val) val)
+   ((number? val) (number->string val))
+   ((symbol? val) (symbol->string val))
+   ((eq? val #f) "")
+   ((eq? val #t) "TRUE")
+   ((list? val) val)
+   (else 
+    (let ((ostr (open-output-string)))
+      (with-output-to-port ostr
+	(lambda ()
+	  (display val)))
+      (get-output-string ostr)))))
+
+#;(define (s:any->number val)
+  (cond
+   ((number? val)  val)
+   ((string? val)  (string->number val))
+   ((symbol? val)  (string->number (symbol->string val)))
+   (else     #f)))
+
+;; NB// this is *illegal* pgint
+(define (s:illegal-pgint val)
+  (cond
+   ((> val 2147483647) 1)
+   ((< val -2147483648) -1)
+   (else #f)))
+
+(define (s:any->pgint val)
+  (let ((n (s:any->number val)))
+    (if n
+	(if (s:illegal-pgint n)
+	    #f
+	    n)
+	n)))
+
+;; string is a string and non-zero length
+(define (misc:non-zero-string str)
+  (if (and (string? str)
+           (> (string-length str) 0))
+      str
+      #f))
+
+;;======================================================================
+;; html-filter
+;;======================================================================
+(define (s:split-string strng delim)
+  (if (eq? (string-length strng) 0) (list strng)
+      (let loop ((head (make-string 1 (car (string->list strng))))
+		 (tail (cdr (string->list strng)))
+		 (dest '())
+		 (temp ""))
+	(cond ((equal? head delim)
+	       (set! dest (append dest (list temp)))
+	       (set! temp ""))
+	      ((null? head) 
+	       (set! dest (append dest (list temp))))
+	      (else (set! temp (string-append temp head)))) ;; end if
+	(cond ((null? tail)
+	       (set! dest (append dest (list temp))) dest)
+	      (else (loop (make-string 1 (car tail)) (cdr tail) dest temp))))))
+
+;; allowed-tags is a list of tags as symbols:
+;;   '(a b center p a)
+;; parsing is simplistic and the response conservative
+;; if a < is found without the tag and closing > then
+;; the < or > is replaced with &lt; or &gt; without 
+;; even trying hard to figure out if there is a legit tag 
+;; buried in the text somewhere.
+;; a list of strings is returned.
+;;
+;; NOTES
+;; 1. case is important in the allowed-tags list!
+;; 2. only "solid" tags are supported i.e. <a href="foo"> will not work?
+;;
+
+;; (s:cgi-out (eval (s:output (s:html-filter "hello<b>goodbye</b><b> eh" '(a b i))))
+
+;; strategy
+;; 1. convert \n to <linefeed>
+;; 2. Split on "<"
+;; 3. Split on ">"
+;; 4. Fix
+(define (s:html-filter input-text allowed-tags)
+  (let* ((toks   (s:str->toks input-text))
+	 (tmp    (s:toks->stml '(s:null) #f toks allowed-tags))
+	 (res    (car tmp))
+	 (nxttag (cadr tmp))
+	 (rem    (caddr tmp)))
+    res))
+
+(define (s:html-filter->string input-text allowed-tags)
+  (let ((ostr (open-output-string)))
+    ;;; (s:output-new ostr (s:html-filter input-text allowed-tags))
+    (s:output-new ostr (car (eval (s:html-filter input-text allowed-tags))))
+    (string-chomp (get-output-string ostr)))) ;; don't need the linefeed, could stop adding it ...
+	
+;;     (if (null? rem)
+;; 	res '())
+;; 	(s:toks->stml (if (list? res) res '()) #f rem allowed-tags))))
+
+(define (s:str->toks str)
+  (apply append (map (lambda (tok)
+		       (intersperse (s:split-string tok ">") ">")) 
+		     (intersperse (s:split-string str "<") "<"))))
+
+(define (s:tag->stml tag)
+  (string->symbol (string-append "s:" (symbol->string tag))))
+
+
+(define (s:toks->stml res tag rem allowed)
+  ;; (print "tag: " tag " rem: " rem)
+  (if (null? rem)
+      (list (append res (if tag
+			    (list (s:tag->stml tag))
+				'())) #f '() allowed) ;; the case of a lone tag 
+      ;; handle a starting tag
+      (let* ((tmp       (s:upto-tag rem allowed))
+	     (txt       (car tmp))      ;; this txt goes with tag!!!
+	     (nexttag   (cadr tmp))     ;; this is the NEXT DAMN tag!
+	     (begin-tag (caddr tmp))
+	     (newrem    (cadddr tmp)))
+	;; (print "txt:        " txt "\nnexttag:    " nexttag "\nbegin-tag:  " begin-tag "\nnewrem:     " newrem "\nres:        " res "\n")
+	(if begin-tag ;; nest the following stuff
+	    (let* ((childdat (s:toks->stml '() nexttag newrem allowed))
+		   (child    (car childdat))
+		   (newtag   (cadr childdat))
+		   (newrem2  (caddr childdat))
+		   (allowed  (cadddr childdat))) ;; ya, it shouldn't have changed
+	      (if tag 
+		  (s:toks->stml (append res (list (append (list (s:tag->stml tag)) child (list txt))))
+				newtag newrem2 allowed)
+		  (s:toks->stml (append res (list txt) child)
+				newtag newrem2 allowed)))
+	    ;; it must have been an end tag
+	    (list (append res (list 
+			       (if tag
+				   (list (s:tag->stml tag) txt)
+				   txt)))
+		  #f
+		  newrem
+		  allowed)))))
+
+
+;; "<" "b" ">"  => "<b>"
+;; "<"
+;; (define (s:rebuild-tags input-list)
+
+;; ("blah blah" "<" "b" ">" "more stuff" "<" "i" ">" ) 
+;;     => ("blah blah" b #t ( "more stuff" "<" "i" ">" ))
+;; ("blah blah" "<" "/b" ">" "more stuff" "<" "i" ">" ) 
+;;     => ("blah blah" b #f ( "more stuff" "<" "i" ">" ))
+(define (s:upto-tag inlst allowed-tags)
+  (if (null? inlst) inlst
+      (let loop ((tok  (car inlst))
+		 (tail (cdr inlst))
+		 (prel "")) ;; create a string or a list of string parts?
+	(if (string=? tok "<") ;; might have a tag
+	    (if (> (length tail) 1) ;; to be a tag, need tag and closing ">"
+		(let ((tag (car tail))
+		      (end (cadr tail))
+		      (rem (cddr tail))) 
+		  (if (string=? end ">") ;; yep, it is probably a tag
+		      (let* ((trim-tag (if  (string=? "/" (substring tag 0 1))
+					    (substring tag 1 (string-length tag)) #f))
+			     (tag-sym  (string->symbol (if trim-tag trim-tag tag))))
+			(if (member tag-sym allowed-tags)
+			    ;; have a valid tag, rebuild it and return the result
+			    (list prel tag-sym (if trim-tag #f #t) rem)
+			    ;; not a valid tag, convert "<" and ">" and add all to prel
+			    (let ((newprel (string-append prel "&lt;" tag "&gt;")))
+			      (if (null? rem)(list newprel #f #f '()) ;; return newprel - add #f #f ???
+				  (loop (car rem)(cdr rem) newprel)))))
+		      ;; so, it wasn't a tag
+		      (let ((newprel (string-append prel "&lt;" tag)))
+			(if (null? tail)
+			    (list newprel #f #f '())
+			    (loop (car rem)(cdr rem) newprel)))))
+		;; too short to be a tag
+		(list (apply string-append prel "&lt;" tail) #f #f '()))
+	    (if (null? tail) 
+		;; we're done
+		(list (string-append prel tok) #f #f '())
+		(loop (car tail)(cdr tail)(string-append prel tok)))))))
+
+
+(define (s:divy-up-cgi-str instr)
+  (map (lambda (x) (string-split x "=")) (string-split instr "&")))
+
+(define (s:decode-str instr)
+  (let* ((abc (string-substitute "\\+" " " instr #t))
+	 (toks (s:split-string abc "%")))
+    (if (< (length toks) 2) abc
+	(let loop ((head (cadr toks))
+		   (tail (cddr toks))
+		   (result (car toks)))
+	  (if (string=? head "")
+	      (if (null? tail)
+		  result
+		  (loop (car tail)(cdr tail) result))
+	      (let* ((key (substring head 0 2))
+		     (rem (substring head 2 (string-length head)))
+		     (num (string->number key 16))
+		     (ch  (if (and (number? num)
+                                   (exact? num))
+			      (integer->char num)
+			      #f)) ;; this is an error. I will probably regret this some day
+		     (chstr  (if ch (make-string 1 ch) ""))
+		     (newres (if ch
+				 (string-append result chstr rem)
+				 (string-append result head))))
+		;; (print "head: " head " num: " num " ch: |" ch "| chstr: " chstr)
+		(if (null? tail)
+		    newres
+		    (loop (car tail)(cdr tail) newres))))))))
+
+;; probably a bug:
+;;
+;; (s:process-cgi-input "=bar")
+;; => ((bar ""))
+;;
+(define (s:process-cgi-input instr)
+  (map (lambda (xy)
+         (list (string->symbol (s:decode-str (car xy)))
+               (if (eq? (length xy) 1) 
+                   ""
+                   (s:decode-str (cadr xy)))))
+         (s:divy-up-cgi-str instr)))
+
+;; for testing -- deletme
+;; (define blah "post_title=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&post_body=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&new_post=Submit")
+;; (define blah2 "post_title=5%25&post_body=and+10%25&new_post=Submit")
+
+;;======================================================================
+;; formdat
+;;======================================================================
+
+(define formdat:*debug* #f)
+
+;; Old data format was something like this. BUT! 
+;; Forms do not have names so the hierarcy is
+;; unnecessary (I think)
+;;
+;; hashtable
+;;   |-formname --> <formdat> 'form-name=formname
+;;   |                        'form-data=hashtable
+;;   |                                       | name => value
+;;
+;; New data format is only the <formdat> portion from above
+
+;; (define-class <formdat> ()
+;;    (form-data
+;;    ))
+(define (make-formdat:formdat)(vector (make-hash-table)))
+(define (formdat:formdat-get-data   vec)    (vector-ref  vec 0))
+(define (formdat:formdat-set-data!  vec val)(vector-set! vec 0 val))
+
+(define (formdat:initialize self)
+  (formdat:formdat-set-data! self (make-hash-table)))
+
+(define (formdat:get self key)
+  (hash-table-ref/default 
+   (formdat:formdat-get-data self)
+   (cond 
+    ((symbol? key) key)
+    ((string? key) (string->symbol key))
+    (else key))
+   #f))
+
+;; change to convert data to list and append val if already exists
+;; or is a list
+(define (formdat:set! self key val)
+  (let ((prev-val (formdat:get self key))
+        (ht       (formdat:formdat-get-data self)))
+    (if prev-val
+        (if (list? prev-val)
+            (hash-table-set! ht key (cons val prev-val))
+            (hash-table-set! ht key (list val prev-val)))
+        (hash-table-set! ht key val))
+    self))
+
+(define (formdat:keys self)
+  (hash-table-keys (formdat:formdat-get-data self)))
+
+(define (formdat:printall self printproc)
+  (printproc "formdat:printall " (formdat:keys self))
+  (for-each (lambda (k)
+	      (printproc k " => " (formdat:get self k)))
+	    (formdat:keys self)))
+
+(define (formdat:all->strings self)
+  (let ((res '()))
+    (for-each (lambda (k)
+                 (set! res (cons (conc k "=>" (formdat:get self k)) res)))
+              (formdat:keys self))
+        res))
+
+;; call with *one* of the lists in the list of lists created by CGI:url-unquote
+(define (formdat:load self formlist)
+  (let ((ht             (formdat:formdat-get-data self)))
+    (if (null? formlist) self ;; no values provided, return self for no good reason
+        (let loop ((head (car formlist))
+                   (tail (cdr formlist)))
+          (let ((key (car head))
+                (val (cdr head)))
+            ;; (err:log "key=" key " val=" val)
+	    (if (> (length val) 1)
+		(formdat:set! self key val)
+		(formdat:set! self key (car val)))
+            (if (null? tail) self   ;; we are done
+                (loop (car tail)(cdr tail))))))))
+
+;; get the header from datstr
+(define (formdat:read-header datstr) ;; datstr is an input string port
+  (let loop ((hs (read-line datstr))
+	     (header '()))
+    (if (or (eof-object? hs)
+	    (string=? hs ""))
+	header
+	(loop (read-line datstr)(append header (list hs))))))
+
+;; get the data up to the next key. if there is no key then return #f
+;; return (dat remdat)
+(define (formdat:read-dat dat key)
+  (let ((index (substring-index key dat))) ;; (string-search-positions key dat)))
+    (if (or (not index)
+	    (null? index)) ;; the key was not found
+	#f
+	(let* ((datstr (open-input-string dat))
+	       ;; (result (read-string (caar index) datstr))
+	       (result (read-string index datstr))
+	       (remdat (read-string #f datstr)))
+	  (close-input-port datstr)
+	  (list result remdat)))))
+
+ ;; inp is port to read data from, maxsize is max data allowed to read (total)
+(define (formdat:dat->list inp maxsize #!key (debug-port #f))
+  ;; read 1Meg chunks from the input port. If a block is not complete
+  ;; tack on the next 1Meg chunk as needed. Set up so the header is always
+  ;; at the beginning of the chunk
+  ;;-----------------------------29932024411502323332136214973
+  ;;Content-Disposition: form-data; name="input-picture"; filename="breadfruit.jpg"
+  ;;Content-Type: image/jpeg
+  (let loop ((dat (read-string 1000000 inp))
+	     (res '())
+	     (siz 0))
+    (if debug-port (format debug-port "dat: ~A\n" dat))
+    (if debug-port (format debug-port "eof: ~A\n" (eof-object? (read inp))))
+    
+    (if (> siz maxsize)
+	(begin
+	  (print "DATA TOO BIG")
+	  res)
+	(let* ((datstr (open-input-string dat))
+	       (header (formdat:read-header datstr))
+	       (key    (if (not (null? header))(car header) #f))
+	       (remdat (read-string #f datstr))          ;; used in next line, discard if got data, else revert to
+	       (alldat (if key (formdat:read-dat remdat key) #f))    ;; try to extract the data
+	       (thsdat (if alldat (car alldat)  #f))     ;; the data
+	       (newdat (if alldat (cadr alldat) #f))     ;; left over data, must process ...
+	       (thsres (list header thsdat))             ;; speculatively construct results
+	       (newres (append res (list thsres))))      ;; speculatively construct results
+	  (close-input-port datstr)
+	  (cond
+	   ;; either no header or single input
+	   ((and (not alldat)
+		 (or (null? header)
+		     (not (string-match formdat:delim-patt-rex (car header)))))
+	    ;; (print "Got here")
+	    (cons (list header "") res)) ;; note use header as dat and use "" as header????
+	   ;; didn't find end key in this block
+	   ((not alldat)
+	    (let ((mordat (read-string 1000000 inp)))
+	      (if (string=? mordat "") ;; there is no more data, discard results and use remdat as data, this input is broken
+		  (cons (list header remdat) res)
+		  (loop (string-append dat mordat) res (+ siz 2000000))))) ;; add the extra 1000000
+	   (alldat ;; got data, don't attempt to check if there is more, just loop and rely on (not alldat) to get more data
+	    (loop newdat newres (+ siz 1000000))))))))
+
+(define formdat:bin-data-disp-rex (regexp "^Content-Disposition:\\s+form-data;"))
+(define formdat:bin-data-name-rex (regexp "\\Wname=\"([^\"]+)\""))
+(define formdat:bin-file-name-rex (regexp "\\Wfilename=\"([^\"]+)\""))
+(define formdat:bin-file-type-rex (regexp "Content-Type:\\s+([^\\s]+)"))
+(define formdat:delim-patt-rex    (regexp "^\\-+[0-9]+\\-*$"))
+
+;; returns a hash with entries for all forms - could well use a proplist?
+(define (formdat:load-all)
+  (let ((request-method (get-environment-variable "REQUEST_METHOD")))
+    (if (and request-method
+	     (string=? request-method "POST"))
+	(formdat:load-all-port (current-input-port))
+	(make-formdat:formdat))))
+
+;; (s:process-cgi-input (caaar dat))
+(define (formdat:load-all-port inp)
+  (let* ((formdat        (make-formdat:formdat))
+	 (debugp         #f))
+			 ;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
+    ;; (write-string (read-string #f inp) #f debugp)  ;; destroys all data!
+    (formdat:initialize formdat)
+    (let ((alldats (formdat:dat->list inp 10e6 debug-port: debugp)))
+      
+      (if debugp (format debugp "formdat : alldats: ~A\n" alldats))
+
+      (let ((firstitem   (car alldats))
+	    (multipass #f)) 
+	(if (and (not (null? firstitem))
+		 (not (null? (car firstitem))))
+	    (if (string-match formdat:delim-patt-rex (caar firstitem))
+		(set! multipass #t)))
+	(if multipass
+	    ;; handle multi-part form
+	    (for-each (lambda (datlst)
+			(let* ((header (formdat:extract-header-info (car datlst)))
+			       (name   (if (assoc 'name header)
+					   (string->symbol (cadr (assoc 'name header)))
+					   "")) ;; grumble
+			       (fnamel  (assoc 'filename header))
+			       (content (assoc 'content header))
+			       (dat    (cadr datlst)))
+			  ;; (print "header: " header " name: " name " fnamel: " fnamel " content: " content) ;;  " dat: " (dat)
+			  (formdat:set! formdat 
+					name
+					(if fnamel 
+					    (list (cadr fnamel)
+						  (if content
+						      (cadr content)
+						      "unknown")
+						  (string->blob dat))
+					    dat))))
+		      alldats)
+	    ;; handle single part form
+	    ;; 	(if (and (string? name)
+	    ;; 		     (string=? name "")) ;; this is the short form input I guess
+	    ;; 		(let* ((datstr (caar datlst))
+	    ;; 		       (munged (s:process-cgi-input datstr)))
+	    ;; 		  (print "datstr: " datstr " munged: " munged)
+	    (if (and (not (null? alldats))
+		     (not (null? (car alldats)))
+		     (not (null? (caar alldats))))
+		(formdat:load formdat  (s:process-cgi-input (caaar alldats))))) ;; munged))
+	;;		    (format debugp "formdat : name: ~A content: ~A\n" name content)
+	(if debugp (close-output-port debugp))
+	;; (sdat-formdat-set! s:session formdat)
+	formdat))))
+		
+#|
+(define inp (open-input-file "tests/example.post.in"))
+(define dat (read-string #f inp))
+(define datstr (open-input-string dat))
+
+;; or
+
+(define inp (open-input-file "tests/example.post.binary.in"))
+(define dat (read-string #f inp))
+(define datstr (open-input-string dat))
+
+(formdat:read-header datstr)
+
+(define dat (formdat:dat->list inp 10e6))
+(close-input-port inp)
+|#
+  
+(define (formdat:extract-header-info header)
+  (if (null? header)
+      '()
+      (let loop ((hed (car header))
+		 (tal (cdr header))
+		 (res '()))
+	(if (string-match formdat:bin-data-disp-rex hed) ;; 
+	    (let* ((data-namem (string-match formdat:bin-data-name-rex hed))
+		   (file-namem (string-match formdat:bin-file-name-rex hed))
+		   (data-name  (if data-namem (cadr data-namem) #f))
+		   (this       (if file-namem
+				   (list (list 'name data-name)(list 'filename (cadr file-namem)))
+				   (list (list 'name data-name)))))
+	      (if (null? tal)
+		  (append res this)
+		  (loop (car tal)(cdr tal)(append res this))))
+	    (let ((content (string-match formdat:bin-file-type-rex hed))) ;; this is the stanza for the content type
+	      (if content
+		  (let ((newres (cons (list 'content (cadr content)) res)))
+		    (if (null? tal)
+			newres
+			(loop (car tal)(cdr tal) newres)))
+		  (if (null? tal)
+		      res
+		      (loop (car tal)(cdr tal) res)
+		      )))))))
+
+;;	      (let loop ((l       (read-line)) ;; (if (eq? mode 'norm)(read-line)(read-char)))
+;;			 (endline #f)
+;;			 (num     0))
+;;		;; (format debugp "~A\n" l)
+;;              (if (or (not (eof-object? l))
+;;		      (not (and (eq? mode 'bin)
+;;				(string=? l "")))) ;; if in bin mode empty string is end of file
+;;		  (case mode
+;;		    ((start)
+;;		     (set! mode 'norm)
+;;		     (if (string-match delim-patt-rex l)
+;;			 (begin
+;;			   (set! delim-string l)
+;;			   (set! delim-len    (string-length l))
+;;			   (loop (read-line) #f 0))
+;;			 (loop l #f 0)))
+;;		    ((norm)
+;;		     ;; I don't like how this gets checked on every single input. Must be a better way. FIXME
+;;		     (if (and (string-match bin-data-disp-rex l)
+;;			      (string-match bin-data-name-rex l)
+;;			      (string-match bin-file-name-rex l))
+;;			 (begin
+;;			   (set! data-name (cadr (string-match bin-data-name-rex l)))
+;;			   (set! file-name (cadr (string-match bin-file-name-rex l)))
+;;			   (set! mode 'content)
+;;			   (loop (read-line) #f num)))
+;;		     (let* ((dat  (s:process-cgi-input l))) ;; (CGI:url-unquote l))
+;;		       (format debugp "PROCESS-CGI-INPUT: ~A\n" (intersperse dat ","))
+;;		       (formdat:load formdat dat)
+;;		       (loop (read-line) #f num)))
+;;		    ((content)
+;;		     (if (string-match bin-file-type-rex l)
+;;			 (begin 
+;;			   (set! mode 'bin)
+;;			   (set! data-type (cadr (string-match bin-file-type-rex l)))
+;;			   (loop (read-string 1) #f num))))
+;;		    ((bin)
+;;		     ;; delim-string: \n"---------------12345"
+;;		     ;;                  012345678901234567890
+;;		     ;; endline:        "---------------12"
+;;		     ;; l = "3"
+;;		     ;; delim-len = 20
+;;		     ;; (substring  "---------------12345" 17 18) => "3"
+;;		     ;;
+;;		     (cond
+;;		       ;; haven't found the start of an endline, is the next char a newline?
+;;		      ((and (not endline)
+;;			    (string=? l "\n")) ;; required first character 
+;;		       (let ((newendline (open-output-string)))
+;;			 ;; (write-line l newendline) ;; discard the newline. add it back if don't have a lock on delim-string
+;;			 (loop (read-string 1) newendline (+ num 1))))
+;;		      ((not endline)
+;;		       (write-string l #f bin-dat)
+;;		       (loop (read-string 1) #f (+ num 1)))
+;;		      ;; string so far matches delim-string
+;;		      (endline
+;;		       (let* ((endstr (get-output-string endline))
+;;			      (endlen (string-length endstr)))
+;;			 (if (> endlen 0)
+;;			     (format debugp " delim: ~A\nendstr: ~A\n" delim-string endstr))
+;;			 (if (and (> delim-len endlen)
+;;				  (string=? l (substring delim-string endlen (+ endlen 1))))
+;;			     ;; yes, this character matches the next in the delim-string
+;;			     (if (eq? delim-len endlen) ;; have a match! Ignore that a newline is required. Lazy bugger.
+;;				 (let* ((fn      (string->symbol data-name)))
+;;				   (formdat:set! formdat fn (list file-name data-type (string->blob (get-output-string bin-dat))))
+;;				   (set! mode 'norm)
+;;				   (loop (read-line) #f 0))
+;;				 (begin
+;;				   (write-string l #f endline)
+;;				   (loop (read-string 1) endline (+ num 1))))
+;;			     ;; no, this character does NOT match the next in line in delim-string
+;;			     (begin
+;;			       (write-string "\n" #f bin-dat) ;; don't forget that newline we dropped
+;;			       (write-string endstr #f bin-dat)
+;;			       (write-string l #f bin-dat)
+;;			       (loop (read-string 1) #f (+ num 1))))))))
+;;		    )))))
+
+;;    (formdat:printall formdat (lambda (x)(write-line x debugp)))
+
+#|
+(define inp (open-input-file "/tmp/stmlrun/delme-33.log.keep-for-ref"))
+(define dat (read-string #f inp))
+(close-input-port inp)
+|#
+
+;;======================================================================
+;; use a table in your db called metadat to store key value pairs
+;;======================================================================
+
+
+(define (keystore:get db key)
+  (dbi:get-one db "SELECT value FROM metadata WHERE key=?;" key))
+
+(define (keystore:set! db key value)
+  (let ((curr-val (keystore:get db key)))
+    (if curr-val
+	(dbi:exec db "UPDATE metadata SET value=? WHERE key=?;" value key)
+	(dbi:exec db "INSERT INTO metadata (key,value) VALUES (?,?);" key value))))
+
+(define (keystore:del! db key)
+  (dbi:exec db "DELETE FROM metadata WHERE key=?;" key))
+
+;;======================================================================
+;; stuff from misc-stml.scm
+;;======================================================================
+
+;; moved to stmlcommon
+;; (bunch of stuff)
+
+;; moved from stmlcommon
+;;
+;; anything except a list is converted to a string!!!
+(define (s:any->string val)
+  (cond
+   ((string? val) val)
+   ((number? val) (number->string val))
+   ((symbol? val) (symbol->string val))
+   ((eq? val #f) "")
+   ((eq? val #t) "TRUE")
+   ((list? val) val)
+   (else 
+    (let ((ostr (open-output-string)))
+      (with-output-to-port ostr
+	(lambda ()
+	  (display val)))
+      (get-output-string ostr)))))
+
+(define (s:any->number val)
+  (cond
+   ((number? val)  val)
+   ((string? val)  (string->number val))
+   ((symbol? val)  (string->number (symbol->string val)))
+   (else     #f)))
+
+;; Moved from stmlcommon
+;;
+(define (s:cgi-out inlst)
+  (s:output-new (current-output-port) inlst))
+
+#;(define (s:output port inlst)
+  (map (lambda (x)
+	 (cond 
+	  ((string? x) (print x)) ;; (print x))
+	  ((symbol? x) (print x)) ;; (print x))
+	  ((list? x)   (s:output port x))
+	  (else ""
+	   ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk.
+	   )))
+       inlst))
+;  (if (> (length inlst) 2)
+;      (print)))
+
+(define (s:output-new port inlst)
+  (with-output-to-port port
+      (lambda ()
+	(map (lambda (x)
+	       (cond 
+		((string? x) (print x))
+		((symbol? x) (print x))
+		((list? x)   (s:output-new port x))
+		(else
+		 ;; (print "ERROR: Bad input 03")
+     )))
+	     inlst))))
+           
+(define (err:log . msg)
+  (with-output-to-port (current-error-port) ;; (slot-ref self 'logpt)
+    (lambda () 
+      (apply print msg))))
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+;; convert values to appropriate strings
+;;
+(define (s:sqlparam-val->string val)
+  (cond
+   ((list?   val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c
+   ((string? val)(conc "'" (dbi:escape-string val) "'"))
+   ((number? val)(number->string val))
+   ((symbol? val)(dbi:escape-string (symbol->string val)))
+   ((boolean? val)
+    (if val "TRUE" "FALSE"))  ;; should this be "TRUE" or 1?
+                              ;; should this be "FALSE" or 0 or NULL?
+   (else
+    (err:log "sqlparam: unknown type for value: " val)
+    "")))
+
+;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
+;; NB// 1. values only!! 
+;;      2. terminating semicolon required (used as part of logic)
+;;
+;; a=? 1 (number) => a=1
+;; a=? 1 (string) => a='1'
+;; a=? #f         => a=FALSE 
+;; a=? a (symbol) => a=a 
+;;
+(define (s:sqlparam query . args)
+  (let* ((query-parts (string-split query "?"))
+         (num-parts    (length query-parts))
+         (num-args    (length args)))
+    (if (not (= (+ num-args 1) num-parts))
+        (err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
+        (if (= num-args 0) query
+            (let loop ((section (car query-parts))
+                       (tail    (cdr query-parts))
+                       (result  "")
+                       (arg     (car args))
+                       (argtail (cdr args)))
+              (let* ((valstr    (s:sqlparam-val->string arg))
+                     (newresult (conc result section valstr)))
+                (if (null? argtail) ;; we are done
+                    (conc newresult (car tail))
+                    (loop
+                     (car tail)
+                     (cdr tail)
+                     newresult
+                     (car argtail)
+                     (cdr argtail)))))))))
+
+;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
+(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
+(define session:num-valid-chars (string-length session:valid-chars))
+
+(define (session:get-nth-char nth)
+  (substring session:valid-chars nth  (+ nth 1)))
+
+(define (session:get-rand-char)
+  (session:get-nth-char (random session:num-valid-chars)))
+
+(define (session:make-rand-string len)
+  (let loop ((res "")
+             (n   1))
+    (if (> n len) res
+        (loop (string-append res (session:get-rand-char))
+              (+ n 1)))))
+
+;; maybe replace above make-rand-string with this someday?
+;;
+(define (session:generic-make-rand-string len seed-string)
+  (let ((num-chars (string-length seed-string)))
+    (let loop ((res "")
+	       (n   1))
+      (let ((char-num (random num-chars)))
+	(if (> n len) res
+	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
+		  (+ n 1)))))))
+
+
+;;======================================================================
+;; P A R A M S
+;;======================================================================
+
+;; input: 'a ('a "val a" 'b "val b") => "val a"
+(define (s:find-param key param-lst)
+  (let loop ((head (car param-lst))
+	     (tail (cdr param-lst)))
+    (if (eq? head key)
+	(car tail)
+	(if (< (length tail) 2) #f
+	    (loop (cadr tail)(cddr tail))))))
+
+(define (s:param->string param)
+  (conc (symbol->string (car param)) "=" "\"" (cadr param) "\""))
+
+;; remove 'foo "bar" from ('foo "bar" 'bar "foo")
+(define (s:remove-param-matching params key)
+  (if (= (length params) 0)'() ;;  proper params list >= 2 items
+      (let loop ((head     (car params))
+                 (tail     (cdr params))
+                 (result   '()))
+        (if (symbol? head) ;; symbols have params
+            (let ((val     (car tail))
+                  (newtail (cdr tail)))
+              (if (eq? head key)  ;; get rid of this one
+                  (if (null? newtail) result
+                      (loop (car newtail)(cdr newtail) result))
+                  (let ((newresult (append result (list head val))))
+                    (if (null? newtail) newresult
+                        (loop (car newtail)(cdr newtail) newresult)))))
+            (let ((newresult (append result (list head))))
+              (if (null? tail) newresult
+                  (loop (car tail)(cdr tail) newresult)))))))
+
+(define (session:get-param-from params key)
+  (let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$"))))
+    (if (null? params) #f
+        (let loop ((head (car params))
+                   (tail (cdr params)))
+          (let ((match (string-match r1 head)))
+            (if match
+                (list-ref match 1)
+                (if (null? tail) #f
+                    (loop (car tail)(cdr tail)))))))))
+
+(define (s:process-params params)
+  (if (null? params) ""
+      (let loop ((res "")
+                 (head (car params))
+                 (tail (cdr params)))
+        (if (null? tail)
+            (conc res " " (s:param->string head))
+            (loop
+             (conc res " " (s:param->string head))
+             (car tail)
+             (cdr tail))))))
+
+;; remove key=var from (key=var key1=var1 key2=var2 ...)
+(define (k=v-params:remove-matching params key)
+  (if (= (length params) 0) params
+      (let ((r1 (regexp (conc "^" key "="))))
+        (let loop ((head (car params))
+                   (tail (cdr params))
+                   (result '()))
+          (if (string-match r1 head)
+              (if (null? tail) result
+                  (loop (car tail)(cdr tail) result))
+              (let ((newlst (cons head result)))
+                (if (null? tail) newlst
+                    (loop (car tail)(cdr tail) newlst))))))))
+
+;;======================================================================
+;; stuff pulled from session
+;;======================================================================
+
+
+;; sessions table
+;; id session_id session_key
+;; create table sessions (id serial not null,session-key text);
+
+;; session_vars table
+;; id session_id page_id key value
+;; create table session_vars (id serial not null,session_id integer,page text,key text,value text);
+
+;; TODO
+;;  Concept of order num incremented with each page access
+;;     if a branch is taken then a new session would need to be created
+;;
+
+;; make-vector-record session session dbtype dbinit conn params path-params session-key session-id domain toppage page curr-page content-type page-type sroot twikidir pagedat alt-page-dat pagevars pagevars-before sessionvars sessionvars-before globalvars globalvars-before logpt formdat request-method session-cookie curr-err log-port logfile seen-pages page-dir-style debugmode
+;; (define (make-sdat)(make-vector 36))
+;; (define (sdat-dbtype               vec)    (vector-ref  vec 0))
+;; (define (sdat-dbinit               vec)    (vector-ref  vec 1))
+;; (define (sdat-conn                 vec)    (vector-ref  vec 2))
+;; (define (sdat-pgconn               vec)    (vector-ref (vector-ref vec 2) 1))
+;; (define (sdat-params               vec)    (vector-ref  vec 3))
+;; (define (sdat-path-params          vec)    (vector-ref  vec 4))
+;; (define (sdat-session-key          vec)    (vector-ref  vec 5))
+;; (define (sdat-session-id           vec)    (vector-ref  vec 6))
+;; (define (sdat-domain               vec)    (vector-ref  vec 7))
+;; (define (sdat-toppage              vec)    (vector-ref  vec 8))
+;; (define (sdat-page                 vec)    (vector-ref  vec 9))
+;; (define (sdat-curr-page            vec)    (vector-ref  vec 10))
+;; (define (sdat-content-type         vec)    (vector-ref  vec 11))
+;; (define (sdat-page-type            vec)    (vector-ref  vec 12))
+;; (define (sdat-sroot                vec)    (vector-ref  vec 13))
+;; (define (sdat-twikidir             vec)    (vector-ref  vec 14))
+;; (define (sdat-pagedat              vec)    (vector-ref  vec 15))
+;; (define (sdat-alt-page-dat         vec)    (vector-ref  vec 16))
+;; (define (sdat-pagevars             vec)    (vector-ref  vec 17))
+;; (define (sdat-pagevars-before      vec)    (vector-ref  vec 18))
+;; (define (sdat-sessionvars          vec)    (vector-ref  vec 19))
+;; (define (sdat-sessionvars-before   vec)    (vector-ref  vec 20))
+;; (define (sdat-globalvars           vec)    (vector-ref  vec 21))
+;; (define (sdat-globalvars-before    vec)    (vector-ref  vec 22))
+;; (define (sdat-logpt                vec)    (vector-ref  vec 23))
+;; (define (sdat-formdat              vec)    (vector-ref  vec 24))
+;; (define (sdat-request-method       vec)    (vector-ref  vec 25))
+;; (define (sdat-session-cookie       vec)    (vector-ref  vec 26))
+;; (define (sdat-curr-err             vec)    (vector-ref  vec 27))
+;; (define (sdat-log-port             vec)    (vector-ref  vec 28))
+;; (define (sdat-logfile              vec)    (vector-ref  vec 29))
+;; (define (sdat-seen-pages           vec)    (vector-ref  vec 30))
+;; (define (sdat-page-dir-style       vec)    (vector-ref  vec 31))
+;; (define (sdat-debugmode            vec)    (vector-ref  vec 32))
+;; (define (sdat-shared-hash          vec)    (vector-ref  vec 33))
+;; (define (sdat-script               vec)    (vector-ref  vec 34))
+;; (define (sdat-force-ssl            vec)    (vector-ref  vec 35))
+;; 
+;; (define (session:get-shared vec varname)
+;;   (hash-table-ref/default (vector-ref vec 33) varname #f))
+;; 
+;; (define (sdat-dbtype-set!              vec val)(vector-set! vec 0 val))
+;; (define (sdat-dbinit-set!              vec val)(vector-set! vec 1 val))
+;; (define (sdat-conn-set!                vec val)(vector-set! vec 2 val))
+;; (define (sdat-params-set!              vec val)(vector-set! vec 3 val))
+;; (define (sdat-path-set-params!         vec val)(vector-set! vec 4 val))
+;; (define (sdat-session-set-key!         vec val)(vector-set! vec 5 val))
+;; (define (sdat-session-set-id!          vec val)(vector-set! vec 6 val))
+;; (define (sdat-domain-set!              vec val)(vector-set! vec 7 val))
+;; (define (sdat-toppage-set!             vec val)(vector-set! vec 8 val))
+;; (define (sdat-page-set!                vec val)(vector-set! vec 9 val))
+;; (define (sdat-curr-set-page!           vec val)(vector-set! vec 10 val))
+;; (define (sdat-content-set-type!        vec val)(vector-set! vec 11 val))
+;; (define (sdat-page-set-type!           vec val)(vector-set! vec 12 val))
+;; (define (sdat-sroot-set!               vec val)(vector-set! vec 13 val))
+;; (define (sdat-twikidir-set!            vec val)(vector-set! vec 14 val))
+;; (define (sdat-pagedat-set!             vec val)(vector-set! vec 15 val))
+;; (define (sdat-alt-set-page-dat!        vec val)(vector-set! vec 16 val))
+;; (define (sdat-pagevars-set!            vec val)(vector-set! vec 17 val))
+;; (define (sdat-pagevars-set-before!     vec val)(vector-set! vec 18 val))
+;; (define (sdat-sessionvars-set!         vec val)(vector-set! vec 19 val))
+;; (define (sdat-sessionvars-set-before!  vec val)(vector-set! vec 20 val))
+;; (define (sdat-globalvars-set!          vec val)(vector-set! vec 21 val))
+;; (define (sdat-globalvars-set-before!   vec val)(vector-set! vec 22 val))
+;; (define (sdat-logpt-set!               vec val)(vector-set! vec 23 val))
+;; (define (sdat-formdat-set!             vec val)(vector-set! vec 24 val))
+;; (define (sdat-request-set-method!      vec val)(vector-set! vec 25 val))
+;; (define (sdat-session-set-cookie!      vec val)(vector-set! vec 26 val))
+;; (define (sdat-curr-set-err!            vec val)(vector-set! vec 27 val))
+;; (define (sdat-log-set-port!            vec val)(vector-set! vec 28 val))
+;; (define (sdat-logfile-set!             vec val)(vector-set! vec 29 val))
+;; (define (sdat-seen-set-pages!          vec val)(vector-set! vec 30 val))
+;; (define (sdat-page-set-dir-style!      vec val)(vector-set! vec 31 val))
+;; (define (sdat-debugmode-set!           vec val)(vector-set! vec 32 val))
+;; (define (sdat-shared-set-hash!         vec val)(vector-set! vec 33 val))
+;; (define (sdat-script-set!              vec val)(vector-set! vec 34 val))
+;; (define (sdat-force-set-ssl!           vec val)(vector-set! vec 35 val))
+;; 
+;; (define (session:set-shared! vec varname val)
+;;   (hash-table-set! (vector-ref vec 33) varname val))
+
+;; The global session
+(define s:session (make-sdat))
+
+;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT
+#;(define (session:initialize self #!optional (configf #f))
+  (sdat-dbtype-set! self      'pg)
+  (sdat-page-set! self        "home")        ;; these are defaults
+  (sdat-curr-set-page! self   "home")
+  (sdat-content-set-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
+  (sdat-page-set-type! self   'html)
+  (sdat-toppage-set! self     "index")
+  (sdat-params-set! self      '())           ;;
+  (sdat-path-set-params! self '())
+  (sdat-session-set-key! self #f)
+  (sdat-pagedat-set! self     '())
+  (sdat-alt-set-page-dat! self #f)
+  (sdat-sroot-set! self       "./")
+  (sdat-session-set-cookie! self #f)
+  (sdat-curr-set-err! self #f)
+  (sdat-log-set-port! self (current-error-port))
+  (sdat-seen-set-pages! self '())
+  (sdat-page-set-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
+                                      ;; #f : pages/<pagename>/(view|control).scm 
+  (sdat-debugmode-set!          self #f)
+  			     
+  (sdat-pagevars-set!           self (make-hash-table))
+  (sdat-sessionvars-set!        self (make-hash-table))
+  (sdat-globalvars-set!         self (make-hash-table))
+  (sdat-pagevars-set-before!    self (make-hash-table))
+  (sdat-sessionvars-set-before! self (make-hash-table))
+  (sdat-globalvars-set-before!  self (make-hash-table))
+  (sdat-domain-set!             self "locahost")   ;; end of defaults
+  (sdat-script-set!             self #f)
+  (sdat-force-set-ssl!          self #f)
+  (let* ((rawconfigdat (session:read-config self configf))
+	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
+	 (sroot     (s:find-param 'sroot    configdat))
+	 (logfile   (s:find-param 'logfile  configdat))
+	 (dbtype    (s:find-param 'dbtype   configdat))
+	 (dbinit    (s:find-param 'dbinit   configdat))
+	 (domain    (s:find-param 'domain   configdat))
+	 (twikidir  (s:find-param 'twikidir configdat))
+	 (page-dir  (s:find-param 'page-dir-style configdat))
+	 (debugmode (s:find-param 'debugmode configdat))
+         (script    (s:find-param 'script    configdat))
+	 (force-ssl (s:find-param 'force-ssl configdat)))
+    (if sroot    (sdat-sroot-set!    self sroot))
+    (if logfile  (sdat-logfile-set!  self logfile))
+    (if dbtype   (sdat-dbtype-set!   self dbtype))
+    (if dbinit   (sdat-dbinit-set!   self dbinit))
+    (if domain   (sdat-domain-set!   self domain))
+    (if twikidir (sdat-twikidir-set! self twikidir))
+    (if debugmode (sdat-debugmode-set! self debugmode))
+    (if script    (sdat-script-set!    self script))
+    (if force-ssl (sdat-force-set-ssl! self force-ssl))
+    (sdat-page-set-dir-style! self page-dir)
+    ;; (print "configdat: ")(pp configdat)
+    (if debugmode
+	(session:log self "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
+		     " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
+    )
+  (sdat-shared-set-hash! self (make-hash-table))
+  )
+
+;; Used for the strangely inconsistent handling of the config file. A better way is needed.
+;;
+;;   (let ((dbtype (sdat-dbtype self)))
+;;     (print "dbtype: " dbtype)
+;;     (sdat-dbtype-set! self (eval dbtype))))
+
+(define (session:setup self #!optional (configf #f))
+  (session:initialize self configf)
+  (let ((dbtype    (sdat-dbtype self))
+	(debugmode (sdat-debug-mode self))
+	(dbinit    (eval (sdat-dbinit self)))
+	(dbexists  #f))
+    (let ((dbfname (alist-ref 'dbname dbinit)))
+      (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
+      (if (eq? dbtype 'sqlite3)
+	  ;; The 'auto method will distribute dbs across the disk using hash
+	  ;; of user host and user. TODO
+	  ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
+	  (let ((dbpath (pathname-directory dbfname)))  ;; do a couple sanity checks here to make setting up easier
+	    (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
+	    (if (not (file-write-access? dbpath))
+		(session:log self "WARNING: Cannot write to " dbpath)
+		(if debugmode (session:log self "INFO: " dbpath " is writeable")))
+	    (if (file-exists? dbfname)
+		(begin
+		  ;; (session:log self "setting dbexists to #t")
+		  (set! dbexists #t))))
+	  (if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))
+      (if debugmode (session:log self "dbtype: " dbtype " dbfname: " dbfname " dbexists: " dbexists)))
+    (sdat-conn-set! self (dbi:open dbtype dbinit))
+    (set! *db* (sdat-conn self))
+    (if (and (not dbexists)(eq? dbtype 'sqlite3))
+ 	(begin
+	  (print "WARNING: Setting up session db with sqlite3")
+	  (session:setup-db self)))
+    (session:process-url-path self)
+    (session:setup-session-key self)
+    ;; capture stdin if this is a POST
+    (sdat-request-method-set! self (get-environment-variable "REQUEST_METHOD"))
+    (sdat-formdat-set! self (formdat:load-all))))
+
+;; setup the db with session tables, works for sqlite only right now
+(define (session:setup-db self)
+  (let ((conn (sdat-conn self)))
+    (for-each 
+     (lambda (stmt)
+       (dbi:exec conn stmt))
+     (list "CREATE TABLE session_vars (id INTEGER PRIMARY KEY,session_id INTEGER,page TEXT,key TEXT,value TEXT);"
+	   "CREATE TABLE sessions (id INTEGER PRIMARY KEY,session_key TEXT,last_used TIMESTAMP);"
+           "CREATE TABLE metadata (id INTEGER PRIMARY KEY,key TEXT,value TEXT);"))))
+;;  ;; if we have a session_key look up the session-id and store it
+;;  (sdat-session-set-id! self (session:get-id self)))
+
+;; only set session-cookie when a new session is created
+(define (session:setup-session-key self)  
+  (let* ((sk  (session:extract-session-key self))
+         (sid (if sk (session:get-id self sk) #f)))
+    (if (not sid) ;; need a new key
+        (let* ((new-key (session:get-new-key self))
+               (new-sid (session:get-id self new-key)))
+          (sdat-session-key-set! self new-key)
+          (sdat-session-id-set! self new-sid)
+          (sdat-session-cookie-set! self (session:make-cookie self)))
+        (sdat-session-id-set! self sid))))
+
+(define (session:make-cookie self)
+  ;; (list (conc "session_key=" (sdat-session-key self) "; Path=/; Domain=." (sdat-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) 
+  ;; According to 
+  ;;    http://www.codemarvels.com/2010/11/apache-rewriterule-set-a-cookie-on-localhost/
+
+  ;;  Here are the 2 (often left out) requirements to set a cookie using
+  ;;  httpd-F�s rewrite rule (mod_rewrite), while working on localhost:-A
+  ;;
+  ;;  Use the IP 127.0.0.1 instead of localhost/machine-name as the
+  ;;  domain; e.g. [CO=someCookie:someValue:127.0.0.1:2:/], which says
+  ;;  create a cookie -Y�someCookie� with value �someValue� for the
+  ;;  domain �127.0.0.1$B!m(B having a life time of 2 mins, for any path in
+  ;;  the domain (path=/). (Obviously you will have to run the
+  ;;  application with this value in the URL)
+  ;;
+  ;;  To make a session cookie, limit the flag statement to just three
+  ;;  attributes: name, value and domain. e.g
+  ;;  [CO=someCookie:someValue:127.0.0.1] %G–%@ Any further
+  ;;  settings, apache writes an� expires� attribute for the set-cookie
+  ;;  header, which makes the cookie a persistent one (not really
+  ;;  persistent, as the expires value set is the current server time
+  ;;  %G–%@ so you don-F-F�t even get to see your cookie!)-A
+  (list (string-substitute 
+	 ";" "; " 
+	 (car (construct-cookie-string 
+	       ;; warning! messing up this itty bitty bit of code will cost much time!
+	       `(("session_key" ,(sdat-session-key self)
+		  expires: ,(+ (current-seconds) (* 14 86400)) 
+		  ;; max-age: (* 14 86400)
+		  path: "/" ;; 
+		  domain: ,(string-append "." (sdat-domain self))
+		  version: 1)) 0)))))
+
+;; look up a given session key and return the id if found, #f if not found
+(define (session:get-id self session-key)
+  ;; (let ((session-key (sdat-session-key self)))
+  (if session-key
+      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
+            (conn (sdat-conn self))
+            (result #f))
+	(dbi:for-each-row 
+	 (lambda (tuple)
+	   (set! result (vector-ref tuple 0)))
+	 conn query)
+	(if result (dbi:exec conn (conc "UPDATE sessions SET last_used=" (dbi:now conn) " WHERE session_key=?;") session-key))
+        result)
+      #f))
+
+;; 
+(define (session:process-url-path self)
+  (let ((path-info    (get-environment-variable "PATH_INFO"))
+	(query-string (get-environment-variable "QUERY_STRING")))
+    ;; (session:log self "path-info=" path-info " query-string=" query-string)
+    (if path-info
+	(let* ((parts    (string-split path-info "/"))
+	       (numparts (length parts)))
+	  (if (> numparts 0)
+	      (sdat-page-set! self (car parts)))
+	  ;; (session:log self "url-path=" url-path " parts=" parts)
+	  (if (> numparts 1)
+	      (sdat-path-params-set! self (cdr parts)))
+          (if query-string
+              (sdat-params-set! self (string-split query-string "&")))))))
+
+;; BUGGY!
+(define (session:get-new-key self)
+  (let ((conn   (sdat-conn self))
+        (tmpkey (session:make-rand-string 20))
+        (status #f))
+    (dbi:for-each-row (lambda (tuple)
+			(set! status #t))
+		      conn (string-append "INSERT INTO sessions (session_key) VALUES ('" tmpkey "')"))
+    tmpkey))
+
+;; returns session key IFF it is in the HTTP_COOKIE 
+(define (session:extract-session-key self)
+  (let ((http-cookie (get-environment-variable "HTTP_COOKIE")))
+    ;; (err:log "http-cookie: " http-cookie)
+    (if http-cookie
+        (session:extract-key-from-param self (string-split-fields  ";\\s+" http-cookie infix:) "session_key")
+        #f)))
+
+(define (session:get-session-id self session-key)
+  (let ((query "SELECT id FROM sessions WHERE session_key=?;")
+        (result #f))
+    ;;     (pg:query-for-each (lambda (tuple)
+    ;;                          (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
+    ;;                        (s:sqlparam query session-key)
+    ;;                        (sdat-conn self))
+    ;;                        conn)
+    (dbi:for-each-row (lambda (tuple)
+			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
+		      (sdat-conn self)
+		      (s:sqlparam query session-key))
+    result))
+
+;; delete all records for a session
+;; 
+;; NEEDS TO BE TRANSACTIONIZED!
+;;
+(define (session:delete-session self session-key)
+  (let ((session-id (session:get-session-id self session-key))
+        (qry1        ;; (conc "BEGIN;"
+			  "DELETE FROM session_vars WHERE session_id=?;")
+	(qry2             "DELETE FROM sessions WHERE id=?;")
+		     ;;  "COMMIT;"))
+        (conn              (sdat-conn self)))
+    (if session-id
+        (begin
+          (dbi:exec conn qry1 session-id) ;; session-id)
+	  (dbi:exec conn qry2 session-id)
+	  ;; (session:initialize self)
+	  (session:setup self)))
+    (not (session:get-session-id self session-key))))
+
+;; (define (session:delete-session self session-key)
+;;   (let ((session-id (session:get-session-id self session-key))
+;;         (queries    (list "BEGIN;"
+;; 			  "DELETE FROM session_vars WHERE session_id=?;"
+;;                           "DELETE FROM sessions WHERE id=?;"
+;; 			  "COMMIT;"))
+;;         (conn              (sdat-conn self)))
+;;     (if session-id
+;;         (begin
+;;           (for-each
+;;            (lambda (query)
+;;              (dbi:exec conn query session-id))
+;; 	   queries)
+;; 	  (initialize self '())
+;; 	  (session:setup self)))
+;;     (not (session:get-session-id self session-key))))
+
+(define (session:extract-key self key)
+  (let ((params (sdat-params self)))
+    (session:extract-key-from-param self params key)))
+
+(define (session:extract-key-from-param self params key)
+  (let ((r1     (regexp (string-append "^" key "=([^=]+)$"))))
+    (err:log "INFO: Looking for " key " in " params)
+    (if (< (length params) 1) #f
+	(let loop ((head   (car params))
+		   (tail   (cdr params)))
+	  (let ((match (string-match r1 head)))
+	    (cond
+	     (match
+	      (let ((session-key (list-ref match 1)))
+		(err:log "INFO: Found session key=" session-key)
+		(sdat-session-key-set! self (list-ref match 1))
+		session-key))
+	     ((null? tail)
+	      #f)
+	     (else
+	      (loop (car tail)
+		    (cdr tail)))))))))
+
+(define (session:set-page! self page_name)
+  (sdat-page-set! self page_name))
+
+(define (session:close self)
+  (dbi:close (sdat-conn self)))
+;; (close-output-port (sdat-logpt self))
+
+(define (session:err-msg self msg)
+  (hash-table-set! (sdat-sessionvars self) "ERROR_MSG"
+		   (string-intersperse (map s:any->string msg) " ")))
+
+(define (session:prev-err self)
+  (let ((prev-err (hash-table-ref/default (sdat-sessionvars-before self) "ERROR_MSG" #f))
+	(curr-err (hash-table-ref/default (sdat-sessionvars self) "ERROR_MSG" #f)))
+    (if prev-err prev-err
+	(if curr-err curr-err #f))))
+
+;; session vars
+;; 1. keys are always a string NOT a symbol
+;; 2. values are always a string conversion is the responsibility of the 
+;;    consuming function (at least for now, I'd like to change this)
+
+;; set a session var for the current page
+;;
+(define (session:curr-page-set! self key value)
+  (hash-table-set! (sdat-pagevars self) (s:any->string key) (s:any->string value)))
+
+;; del a var for the current page
+;;
+(define (session:page-var-del! self key)
+  (hash-table-delete! (sdat-pagevars self) (s:any->string key)))
+
+;; get the appropriate hash given a page "*sessionvars*, *globalvars* or page
+;;
+(define (session:get-page-hash self page)
+  (if (string=? page "*sessionvars*")
+      (sdat-sessionvars self)
+      (if (string=? page "*globalvars*")
+	  (sdat-globalvars self)
+	  (sdat-pagevars self))))
+
+;; set a session var for a given page
+;;
+(define (session:set! self page key value)
+  (let ((ht (session:get-page-hash self page)))
+    (hash-table-set! ht (s:any->string key) (s:any->string value))))
+
+;; get session vars for the current page
+;;
+(define (session:page-get self key)
+  (hash-table-ref/default (sdat-pagevars self) key #f))
+
+;; get session vars for a specified page
+;;
+(define (session:get self page key params)
+  (let* ((ht  (session:get-page-hash self page))
+	 (res (hash-table-ref/default ht (s:any->string key) #f)))
+    (session:apply-type-preference res params)))
+
+;; delete a session var for a specified page
+;;
+(define (session:del! self page key)
+  (let ((ht (session:get-page-hash self page)))
+    (hash-table-delete! ht (s:any->string key))))
+
+;; get ALL keys for this page and store in the session pagevars hash
+;;
+(define (session:get-vars self)
+  (let ((session-id  (sdat-session-id self)))
+    (if (not session-id)
+	(err:log "ERROR: No session id in session object! session:get-vars")
+	(let* ((result             #f)
+	       (conn               (sdat-conn self))
+	       (pagevars-before    (sdat-pagevars-before self))
+	       (sessionvars-before (sdat-sessionvars-before self))
+	       (globalvars-before  (sdat-globalvars-before self))
+	       (pagevars           (sdat-pagevars self))
+	       (sessionvars        (sdat-sessionvars self))
+	       (globalvars         (sdat-globalvars self))
+	       (page-name          (sdat-page self))
+	       (session-key        (sdat-session-key self))
+	       (query              (string-append
+				    "SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id "
+				    "WHERE session_key=? AND page=?;")))
+	  ;; first the page specific vars
+	  (dbi:for-each-row (lambda (tuple)
+			      (let ((k (vector-ref tuple 0))
+				    (v (vector-ref tuple 1)))
+				(hash-table-set! pagevars-before k v)
+				(hash-table-set! pagevars        k v)))
+			    conn
+			    (s:sqlparam query session-key page-name))
+	  ;; then the session specific vars
+	  (dbi:for-each-row (lambda (tuple)
+			      (let ((k (vector-ref tuple 0))
+				    (v (vector-ref tuple 1)))
+				(hash-table-set! sessionvars-before k v)
+				(hash-table-set! sessionvars        k v)))
+			    conn
+			    (s:sqlparam query session-key "*sessionvars*"))
+	  ;; and finally the global vars
+	  (dbi:for-each-row (lambda (tuple)
+			      (let ((k (vector-ref tuple 0))
+				    (v (vector-ref tuple 1)))
+				(hash-table-set! globalvars-before k v)
+				(hash-table-set! globalvars        k v)))
+			    conn
+			    (s:sqlparam query session-key "*globalvars"))
+	  ))))
+
+(define (session:save-vars self)
+  (let ((session-id  (sdat-session-id self)))
+    (if (not session-id)
+	(err:log "ERROR: No session id in session object! session:get-vars")
+	(let* ((status      #f)
+	       (conn        (sdat-conn self))
+	       (page-name   (sdat-page self))
+	       (del-query   "DELETE FROM session_vars WHERE session_id=? AND page=? AND key=?;")
+	       (ins-query   "INSERT INTO session_vars (session_id,page,key,value) VALUES(?,?,?,?);")
+	       (upd-query   "UPDATE session_vars set value=? WHERE key=? AND session_id=? AND page=?;")
+	       (changed-count 0))
+	  ;; save the delta only
+	  (for-each
+	   (lambda (page) ;; page is: "*globalvars*" "*sessionvars*" or otherstring
+	     (let* ((before-after-ht (cond
+				      ((string=? page "*sessionvars*")
+				       (vector (sdat-sessionvars self)
+					       (sdat-sessionvars-before self)))
+				       ((string=? page "*globalvars*")
+					(vector (sdat-globalvars self)
+						(sdat-globalvars-before self)))
+				       (else 
+					(vector (sdat-pagevars self)
+						(sdat-pagevars-before self)))))
+		    (master-ht   (vector-ref before-after-ht 0))
+		    (before-ht   (vector-ref before-after-ht 1))
+		    (master-keys (hash-table-keys master-ht))
+		    (before-keys (hash-table-keys before-ht))
+		    (all-keys (delete-duplicates (append master-keys before-keys))))
+	       (for-each 
+		(lambda (key)
+		  (let ((master-value (hash-table-ref/default master-ht key #f))
+			(before-value (hash-table-ref/default before-ht key #f)))
+		    (cond
+		     ;; before and after exist and value unchanged - do nothing
+		     ((and master-value before-value (equal? master-value before-value)))
+		     ;; before and after exist but are changed
+		     ((and master-value before-value)
+		      (dbi:for-each-row (lambda (tuple)
+					  (set! changed-count (+ changed-count 1)))
+					conn
+					(s:sqlparam upd-query master-value key session-id page)))
+		     ;; master-value no longer exists (i.e. #f) - remove item
+		     ((not master-value)
+		      (dbi:for-each-row (lambda (tuple)
+					  (set! changed-count (+ changed-count 1)))
+					conn
+					(s:sqlparam del-query session-id page key)))
+		     ;; before-value doesn't exist - insert a new value
+		     ((not before-value)
+		      (dbi:for-each-row (lambda (tuple)
+					  (set! changed-count (+ changed-count 1)))
+					conn
+					(s:sqlparam ins-query session-id page key master-value)))
+		     (else (err:log "Shouldn't get here")))))
+		all-keys))) ;; process all keys
+	   (list "*sessionvars*" "*globalvars*" page-name))))))
+
+;; (pg:sql-null-object? element)
+(define (session:read-config self #!optional (fname #f))
+  (let* ((cgi-path (pathname-directory (car (argv))))
+         (name     (or fname (string-append (if cgi-path (conc cgi-path "/") "") "." (pathname-file (car (argv))) ".config"))))
+    (if (not (file-exists? name))
+	(print name " not found at " (current-directory))
+	(let* ((fp (open-input-file name))
+	       (initargs (read fp)))
+	  (close-input-port fp)
+	  initargs))))
+
+;; call the controller if it exists
+;; 
+;; WARNING - this code needs a defense agains recursive calling!!!!!
+;;
+;;   I suggest a limit of 100 calls. Plenty for allowing multiple instances
+;;   of a page inside another page. 
+;;
+;; parts = 'both | 'control | 'view
+;;
+
+(define (files-read->string . files)
+  (string-intersperse 
+   (apply append (map file-read->string files)) "\n"))
+
+(define (file-read->string f) 
+  (let ((p (open-input-file f)))
+    (let loop ((hed (read-line p))
+	       (res '()))
+      (if (eof-object? hed)
+	  res
+	  (loop (read-line p)(append res (list hed)))))))
+
+(define (process-port p)
+  (let ((e (interaction-environment)))
+    (map 
+     (lambda (x)
+       (cond
+	((list? x) x)
+	((string? x) x)
+	(else '())))
+     (port-map (lambda (s)
+		 (eval s e))
+	       (lambda ()(read p))))))
+
+(define (session:process-file f)
+  (let* ((p    (open-input-file f))
+	 (dat  (process-port p)))
+    (close-input-port p)
+    dat))
+
+;; May 2011, putting all pages into one directory for the following reasons:
+;;   1. want filename to reflect page name (emacs limitation)
+;;   2. that's it! no other reason. could make it configurable ...
+;; page-dir-style is:
+;;  'stored   => stored in executable
+;;  'flat     => pages flat directory
+;;  'dir      => directory tree pages/<pagename>/{view,control}.scm
+;; parts:
+;;  'both     => load control and view (anything other than view or control and the default)
+;;  'view     => load view only
+;;  'control  => load control only
+(define (session:call-parts self page #!key (parts 'both))
+  (sdat-curr-page-set! self page)
+  (let* ((dir-style    (sdat-page-dir-style self));; (equal? (sdat-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
+	 (dir          (string-append (sdat-sroot self) 
+				      (if dir-style 
+					  (conc "/pages/")
+					  (conc "/pages/" page)))))
+    (case dir-style
+      ;; NB// Stored always loads both control and view
+      ((stored)
+       ((eval (string->symbol (conc "pages:" page))) 
+	self                         ;; the session
+	(sdat-conn self)         ;; the db connection
+	(sdat-shared-hash self)  ;; a shared hash table for passing data to/from page calls
+	))
+      ((flat)   
+       (let* ((so-file  (conc dir page ".so"))
+	      (scm-file (conc dir page ".scm"))
+	      (src-file (or (file-exists? so-file)
+			    (file-exists? scm-file))))
+	 (if src-file
+	     (begin
+	       (load src-file)
+	       ((eval (string->symbol (conc "pages:" page))) 
+		self                         ;; the session
+		(sdat-conn self)         ;; the db connection
+		(sdat-shared-hash self)  ;; a shared hash table for passing data to/from page calls
+		))
+	     (list "<p>Page not found " page " </p>"))))
+       ;; first the control
+       ;; (let ((control-file (conc "pages/" page "_ctrl.scm"))
+       ;;       (view-file    (conc "pages/" page "_view.scm")))
+       ;;   (if (and (file-exists? control-file)
+       ;;  	  (not (eq? parts 'view)))
+       ;;       (begin
+       ;;         (session:set-called! self page)
+       ;;         (load control-file)))
+       ;;   (if (file-exists? view-file)
+       ;;       (if (not (eq? parts 'control))
+       ;;  	 (session:process-file view-file))
+       ;;       (list "<p>Page not found " page " </p>")))
+      ((dir) "ERROR:  dir style not yet re-implemented")
+      (else
+       (list "ERROR: page-dir-style must be stored, dir or flat, got " dir-style)))))
+
+(define (session:call self page parts)
+  (session:call-parts self page 'both))
+
+(define (session:load-model self model)
+  (let* ((mpath     (session:model-path self))
+	 (model.scm (string-append mpath "/" model ".scm"))
+	 (model.so  (string-append mpath "/" model ".so")))
+    (if (file-exists? model.so)
+	(load model.so)
+	(if (file-exists? model.scm)
+	    (load model.scm)
+	    (s:log "ERROR: model " model.scm " not found")))))
+
+(define (session:model-path self)
+  (or (sdat-models self)
+      (string-append (sdat-sroot self) "/models/")))
+
+(define (session:pp-formdat self)
+  (let ((dat (formdat:all->strings (sdat-formdat self))))
+    (string-intersperse dat "<br> ")))
+
+(define (session:param->string params)
+  ;; (err:log "params=" params)
+  (if (< (length params) 1)
+      ""
+      (let loop ((key (car params))
+		 (val (cadr params))
+		 (tail (cddr params))
+		 (result '()))
+	(let ((newresult (cons (string-append (s:any->string key) "=" (s:any->string val))
+			       result)))
+	  (if (< (length tail) 1) ;; true if done
+	      (string-intersperse newresult "&")
+	      (loop (car tail)(cadr tail)(cddr tail) newresult))))))
+
+(define (session:link-to self page params)
+  (let* ((https-host   (get-environment-variable "HTTPS_HOST"))
+         (force-ssl    (sdat-force-ssl self))
+	 (server       (or https-host ;; Assuming HTTPS_HOST is only set if available
+			   (get-environment-variable "HTTP_HOST")
+			   (get-environment-variable "SERVER_NAME")
+			   (sdat-domain self)))
+         (force-script  (sdat-script self))
+	 (script        (or force-script
+			    (let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/")))
+			      (if (> (length script-name) 1)
+				  (string-append (car script-name) "/" (cadr script-name))
+				  (get-environment-variable "SCRIPT_NAME"))))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL.)
+         (session-key   (sdat-session-key self))
+	 (paramstr      (session:param->string params)))
+    (session:log self "server=" server " script=" script " page=" page)
+    (string-append (if (or https-host force-ssl)
+		      "https://"
+		      "http://")
+		   server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key)))
+
+(define (session:cgi-out self)
+  (let* ((content  (list (sdat-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
+	 (header   (let ((cookie (sdat-session-cookie self)))
+		     (if cookie
+			 (cons (string-append "Set-Cookie: " (car cookie))
+			       content)
+			 content)))
+	 (pagedat  (sdat-pagedat self)))
+    (s:cgi-out 
+     (cons header pagedat))))
+
+(define (session:log self . msg)
+  (with-output-to-port (sdat-log-port self) ;; (sdat-logpt self)
+    (lambda () 
+      (apply print msg))))
+
+;; escape, convert or return raw when given user input data that potentially
+;; could be malicious
+;;
+(define (session:apply-type-preference res params)
+  (let* ((dtype    (if (null? params)
+		       'escaped
+		       (car params)))
+	 (tags    (if (null? params)
+		      '()
+		      (cdr params))))
+    (case dtype
+      ((raw)     res)
+      ((number)  (if (string? res)(string->number res) #f))
+      ((escaped) (if (string? res)
+		     (s:html-filter->string res tags)
+		     res))
+      ((escaped-nl) (if (string? res) ;; escape \n and \r
+			(string-intersperse
+			 (string-split
+			  (string-intersperse
+			   (string-split (s:html-filter->string res tags) "\n")
+			   "\\n")
+			  "\r")
+			 "\\r")
+			res)) ;; should return #f if not a string and can't escape it?
+      (else      (if (string? res)
+		     (s:html-filter->string res '())
+		     res)))))
+
+#;(define (session:get-param-from params key)
+  (let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$"))))
+    (if (null? params) #f
+        (let loop ((head (car params))
+                   (tail (cdr params)))
+          (let ((match (string-match r1 head)))
+            (if match
+                (list-ref match 1)
+                (if (null? tail) #f
+                    (loop (car tail)(cdr tail)))))))))
+
+;; params are stored as list of key=val
+;;
+(define (session:get-param self key type-params)
+  ;; (session:log s:session "params=" (slot-ref s:session 'params))
+  (let* ((params (sdat-params self))
+	 (res    (session:get-param-from params key)))
+    (session:apply-type-preference res type-params)))
+
+;; This one will get the first value found regardless of form
+;; param: (dtype [tag1 tag2 ...])
+;; dtype:
+;;    'raw     : do no conversion
+;;    'number  : convert to number, return #f if fails
+;;    'escaped : use html-escape to protect the input -- this is the default
+;;
+(define (session:get-input self key params)
+  (let* ((dtype    (if (null? params)
+		       'escaped
+		       (car params)))
+	 (tags    (if (null? params)
+		      '()
+		      (cdr params)))
+	 (formdat (sdat-formdat self))
+	 (res     (if (not formdat) #f
+		      (if (or (string? key)(number? key)(symbol? key))
+			  (if (and (vector? formdat)
+				   (eq? (vector-length formdat) 1)
+				   (hash-table? (vector-ref formdat 0)))
+			      (formdat:get formdat key)
+			      (begin
+				(session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
+				#f))
+			  (begin
+			    (session:log self "ERROR: bad key " key)
+			    #f)))))
+    (case dtype
+      ((raw)     res)
+      ((number)  (if (string? res)(string->number res) #f))
+      ((escaped) (if (string? res)
+		     (s:html-filter->string res tags)
+		     res))
+      (else      (if (string? res)
+		     (s:html-filter->string res '())
+		     res)))))
+
+;; This one will get the first value found regardless of form
+(define (session:get-input-keys self)
+  (let* ((formdat (sdat-formdat self)))
+    (if (not formdat) #f
+	(if (and (vector? formdat)
+		 (eq? (vector-length formdat) 1)
+		 (hash-table? (vector-ref formdat 0)))
+	    (formdat:keys formdat)
+	    (begin
+	      (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
+	      #f)))))
+
+(define (session:run-actions self)
+  (let* ((action    (session:get-param self 'action '(raw)))
+	 (page      (sdat-page self)))
+    ;; (print "action=" action " page=" page)
+    (if action
+	(let ((action-lst  (string-split action ".")))
+	  ;; (print "action-lst=" action-lst)
+	  (if (not (= (length action-lst) 2)) 
+	      (err:log "Action should be of form: module.action")
+	      (let* ((targ-page   (car action-lst))
+		     (proc-name   (string-append targ-page "-action"))
+		     (targ-action (cadr action-lst)))
+		;; (err:log "targ-page=" targ-page " proc-name=" proc-name " targ-action=" targ-action)
+
+		;; call here only if never called before
+		(if (session:never-called-page? self targ-page)
+		    (session:call-parts self targ-page 'control))
+		;;                    proc                         action    
+
+		(if #t ;; set to #t to see better error messages during debuggin :-)
+		    ((eval (string->symbol proc-name)) targ-action) ;; unsafe execution
+		    (condition-case ((eval (string->symbol proc-name)) targ-action)
+				    ((exn file) (s:log "file error"))
+				    ((exn i/o)  (s:log "i/o error"))
+				    ((exn )     (s:log "Action not implemented: " proc-name " action: " targ-action))
+				    (var ()     (s:log "Unknown Error"))))))))))
+
+(define (session:never-called-page? self page)
+  (session:log self "Checking for page: " page)
+  (not (member page (sdat-seen-pages self))))
+
+(define (session:set-called! self page)
+  (sdat-seen-pages-set! self (cons page (sdat-seen-pages self))))
+
+;;======================================================================
+;; Alternative data type delivery
+;;======================================================================
+
+(define (session:alt-out self)
+  (let ((dat (sdat-alt-page-dat self)))
+    ;; (s:log "dat is: " dat)
+    ;; (print "HTTP/1.1 200 OK")
+    (print "Date: " (time->string (seconds->utc-time (current-seconds))))
+    (print "Content-Type: " (sdat-content-type self))
+    (print "Accept-Ranges: bytes")
+    (print "Content-Length: " (if (blob? dat)
+				  (blob-size dat)
+				  0))
+    (print "Keep-Alive: timeout=15, max=100")
+    (print "Connection: Keep-Alive")
+    (print "")
+    (write-string (blob->string dat) #f (current-output-port))))
+
+;;======================================================================
+;; Orphaned functions
+;;======================================================================
+
+;; was in setup
+;;
+(define (s:log . msg)
+  (apply session:log s:session msg))
+
+
+;; Usage: (s:get-err s:big)
+(define (s:get-err wrapperfunc)
+  (let ((errmsg (sdat-curr-err s:session)))
+    (if errmsg ((if wrapperfunc
+                    wrapperfunc
+                    s:strong) errmsg) '())))
+(define (stml:cgi-session session #!optional (configf #f))
+  ;; (session:initialize session)
+  (session:setup session configf)
+  (session:get-vars session)
+
+  (sdat-log-port-set! session ;; (current-error-port))
+		      (open-output-file (sdat-logfile session) #:append))
+  (s:validate-inputs)
+  (change-directory (sdat-sroot session))
+  (session:run-actions session)
+  (sdat-pagedat-set! session
+		     (append (sdat-pagedat session)
+			     (s:call (sdat-toppage session))))
+  (if (eq? (sdat-page-type session) 'html) ;; default is html. 
+      (session:cgi-out session)
+      (session:alt-out session))
+  (session:save-vars session)
+  (session:close session))
+
+
+(define (s:validate-inputs)
+  (if (not (s:validate-uri))
+      (begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER")))
+				       (if ref
+					   (list "referred from" ref)
+					   "")))
+	     (exit))))
+
+(define (s:error-page . err)
+  (s:cgi-out (cons "Content-type: text/html; charset=iso-8859-1\n\n"
+		   (s:html (s:head 
+			    (s:title err)
+			    (s:body
+			     (s:h1 "ERROR")
+			     (s:p err)))))))           
+
+
+(define (stml:main proc #!optional (configf #f))
+  (handle-exceptions
+   exn   
+   (if (sdat-debug-mode s:session)
+       (begin
+	 (print "Content-type: text/html")
+	 (print "")
+	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
+	 (print "   QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </b> <br>")
+	 (print "<pre>")
+	 ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+	 (print-error-message exn)
+	 (print-call-chain)
+	 (print "</pre>")
+	 (print "<table>")
+	 (for-each (lambda (var)
+		     (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
+		   (get-environment-variables))
+	 (print "</table>")
+	 (print "</body></html>"))
+       (begin
+	 (with-output-to-file (conc "/tmp/stml-crash-" (current-process-id) ".log")
+	   (lambda ()
+	     (print "EXCEPTION")
+	     (print "   QUERY_STRING is: " (get-environment-variable "QUERY_STRING") )
+	     (print "")
+	     ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+	     (print-error-message exn)
+	     (print-call-chain)
+	     (print "")
+	     (for-each (lambda (var)
+			 (print (car var) "\t" (cdr var)))
+		       (get-environment-variables))))
+	 ;; return something useful to the user
+	 (print "Content-type: text/html")
+	 (print "")
+	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
+	 (print "<h1>CRASH!</h1>")
+	 (print "   Please notify support at " (sdat-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log</b> <br>")
+	 ;; (print "<pre>")
+	 ;; ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+	 ;; ;; (print-error-message exn)
+	 ;; ;; (print-call-chain)
+	 ;; (print "</pre>")
+	 ;; (print "<table>")
+	 ;; (for-each (lambda (var)
+	 ;; 	     (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
+	 ;; 	   (get-environment-variables))
+	 ;; (print "</table>")
+	 (print "</body></html>")))
+   (if proc (proc s:session) (stml:cgi-session s:session configf))
+ ;; (raise-error)
+ ;; (exit)
+   ))
+
+;; find out if we are in debugmode
+(define (s:debug-mode?)
+  (sdat-debug-mode s:session))
+
+(define (s:never-called-page? page)
+  (session:never-called-page? s:session page))
+
+(define (s:set-err . args)
+  (sdat-curr-err-set! s:session args))
+
+(define (s:current-page)
+  (sdat-page s:session))
+
+(define (s:delete-session)
+  (session:delete-session s:session (sdat-session-key s:session)))
+
+(define (s:call page . partsl)
+  (if (null? partsl)
+      (session:call s:session page #f)
+      (session:call s:session page (car partsl))))
+
+(define (s:link-to page . params)
+  (session:link-to s:session page params))
+
+(define (s:get-param key . type-params)
+  (session:get-param s:session key type-params))
+
+;; these are page local
+(define (s:get key) 
+  (session:page-get s:session key))
+
+(define (s:set! key val)
+  (session:curr-page-set! s:session key val))
+
+(define (s:del! key)
+  (session:page-var-del! s:session key))
+
+#;(define (s:get-n-del! key)
+  (let ((val (session:page-get s:session key)))
+    (session:del! s:session val key)
+    val))
+
+;; these are session wide
+(define (s:session-var-get key . params) 
+  (session:get s:session "*sessionvars*" key params))
+
+(define (s:session-var-set! key val)
+  (session:set! s:session "*sessionvars*" key val))
+
+(define (s:session-var-get-n-del! key)
+  (let ((val (session:page-get s:session key)))
+     (session:del! s:session "*sessionvars*" key)
+     val))
+
+(define (s:session-var-del! key)
+  (session:del! s:session "*sessionvars*" key))
+
+(define s:session-var-delete! s:session-var-del!)
+
+;; utility to get all vars as hash table
+(define (s:session-get-sessionvars)
+  (sdat-sessionvars s:session))
+
+;;======================================================================
+;; Sugar
+;;======================================================================
+;;
+;; (require 'syntax-case)
+;; 
+;; (define-syntax s:if-param
+;;   (syntax-rules ()
+;;     [(_ s x)   (if (s:get s) x (s:comment "s:if not"))]
+;;     [(_ s x y) (if (s:get s) x y)]))
+;; ;; 
+;; (define-syntax s:if-test
+;;   (syntax-rules ()
+;;     [(_ s x) (if   (string=? "yep" s)   x (list "s:if not"))]
+;;     [(_ s x y) (if (string=? "yep" s) x y)]))
+
+;; Some of these routines use:
+;;
+;;     http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
+;;
+;; Syntax for defining macros in a simple style similar to function definiton,
+;;  when there is a single pattern for the argument list and there are no keywords.
+;;
+;; (define-simple-syntax (name arg ...) body ...)
+;;
+
+(define-syntax define-simple-syntax
+  (syntax-rules ()
+    ((_ (name arg ...) body ...)
+     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
+
+;;======================================================================
+;; syntatic sugar items
+;;======================================================================
+
+;; We often seem to want to include stuff if a conditional is met
+;; otherwise not include it. This routine makes that slightly cleaner
+;; since using a pure if results in #<undefined> objects. (admittedly they 
+;; should be ignored but this is slightly cleaner I think). 
+;;
+;; NOTE: This has to be a macro or the true clause will be evaluated 
+;; whether "a" is true or false
+
+;; If a is true return b, else return '()
+(define-simple-syntax (s:if a b)
+  (if a b '()))
+
+
+;; Using the Simple-Syntax System
+;; 
+;; The syntax for defining macros in this system is similar to that for defining functions. In fact if the macro has a fixed number of arguments the syntax is identical. For example:
+;; 
+;;   ; Define a simple macro to add a value to a variable.
+;;   ;
+;;   (define-simple-syntax (+= variable value)
+;;     (set! variable (+ variable value)))
+;; 
+;;   ; Use it.
+;;   ;
+;;   (define v 2)
+;;   (+= v 7)
+;;   v ; => 9
+;; 
+;; For a fixed number of arguments followed by an unknown number of arguments we use ... after a single argument to represent the unknown number (possibly zero) of arguments. For example, let's revise our definition of += to allow zero or more values to be added:
+;; 
+;;   ; Define a simple macro to add a zero or more values to a variable
+;;   ;
+;;   (define-simple-syntax (+= variable value ...)
+;;     (set! variable (+ variable value ...)))
+;; 
+;;   ; Use it
+;;   ;
+;;   (define v 2)
+;;   (+= v 7)
+;;   v ; => 9
+;;   (+= v 3 4)
+;;   v ; => 16
+;;   (+= v)
+;;   v ; => 16
+;; 
+
+(define-simple-syntax (s:if-param varname first ...)
+  (if (s:get varname)
+      (begin
+	first
+	...)
+      '()))
+
+(define-simple-syntax (s:if-sessionvar varname first ...)
+  (if (s:session-var-get varname)
+      (begin
+	first
+	...)
+      '()))
+
+;; (define-macro (s:if-param varname ...)
+;;   (match dat
+;; 	 (()    '())
+;; 	 ((a)    `(if (s:get ,varname) ,a '()))
+;; 	 ((a b)  `(if (s:get ,varname) ,a ,b))))
+;; 
+;; (define-macro (s:if-sessionvar varname . dat)
+;;   (match dat
+;; 	 (()    '())
+;; 	 ((a)    `(if (s:session-var-get ,varname) ,a '()))
+;; 	 ((a b)  `(if (s:session-var-get ,varname) ,a ,b))))
+;; 
+
+)

ADDED   stml2/stml2.setup
Index: stml2/stml2.setup
==================================================================
--- /dev/null
+++ stml2/stml2.setup
@@ -0,0 +1,32 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;;
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNlmESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;;;; margs.setup
+
+;; compile the code into a dynamically loadable shared object
+;; (will generate margs.so)
+;; (compile -s margs.scm)
+
+;; Install as extension library
+
+;; handle cookies
+(standard-extension 'cookie       "0.5")
+;; (standard-extension 'stmlcommon   "0.5")
+(standard-extension 'stml2        "0.5")
+
+;; (standard-extension 'session      "0.5")
+;; (standard-extension 'misc-stml    "0.5") ;; moved to stmlcommon.scm
+;; (standard-extension 'html-filter  "0.5") ;; moved to stmlcommon.scm
+;; (standard-extension 'formdat      "0.5") ;; moved into stmlcommon.scm
+;; (standard-extension 'setup        "0.5") ;; moved into stmlcommon.scm
+;; (standard-extension 'keystore     "0.5") ;; moved into stmlcommon.scm
+;; (standard-extension 'sqltbl       "0.5") ;; eliminated
+
+;; (install-extension 'stml "stml.so")
+

ADDED   stml2/stmlcommon.scm
Index: stml2/stmlcommon.scm
==================================================================
--- /dev/null
+++ stml2/stmlcommon.scm
@@ -0,0 +1,20 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; (require-extension syntax-case)
+;; (declare (run-time-macros))
+
+(module stmlcommon
+    *
+
+(import  chicken scheme data-structures extras srfi-13 ports posix)
+
+(use (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)
+
+)

ADDED   stml2/stmlmodule.scm
Index: stml2/stmlmodule.scm
==================================================================
--- /dev/null
+++ stml2/stmlmodule.scm
@@ -0,0 +1,14 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; (require-extension syntax-case)
+;; (declare (run-time-macros))
+
+(include "stmlcommon.scm")
+

ADDED   stml2/stmlrun.scm
Index: stml2/stmlrun.scm
==================================================================
--- /dev/null
+++ stml2/stmlrun.scm
@@ -0,0 +1,19 @@
+#!/usr/local/bin/csi -q
+
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;; (require-extension syntax-case)
+;; (declare (run-time-macros))
+
+;; (include "stmlcommon.scm")
+(require-library stml)
+
+
+(stml:main #f)

ADDED   stml2/sugar.scm
Index: stml2/sugar.scm
==================================================================
--- /dev/null
+++ stml2/sugar.scm
@@ -0,0 +1,113 @@
+;; Copyright 2007-2011, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;
+
+;;======================================================================
+;; Sugar
+;;======================================================================
+;;
+;; (require 'syntax-case)
+;; 
+;; (define-syntax s:if-param
+;;   (syntax-rules ()
+;;     [(_ s x)   (if (s:get s) x (s:comment "s:if not"))]
+;;     [(_ s x y) (if (s:get s) x y)]))
+;; ;; 
+;; (define-syntax s:if-test
+;;   (syntax-rules ()
+;;     [(_ s x) (if   (string=? "yep" s)   x (list "s:if not"))]
+;;     [(_ s x y) (if (string=? "yep" s) x y)]))
+
+;; Some of these routines use:
+;;
+;;     http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
+;;
+;; Syntax for defining macros in a simple style similar to function definiton,
+;;  when there is a single pattern for the argument list and there are no keywords.
+;;
+;; (define-simple-syntax (name arg ...) body ...)
+;;
+
+(define-syntax define-simple-syntax
+  (syntax-rules ()
+    ((_ (name arg ...) body ...)
+     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
+
+;;======================================================================
+;; syntatic sugar items
+;;======================================================================
+
+;; We often seem to want to include stuff if a conditional is met
+;; otherwise not include it. This routine makes that slightly cleaner
+;; since using a pure if results in #<undefined> objects. (admittedly they 
+;; should be ignored but this is slightly cleaner I think). 
+;;
+;; NOTE: This has to be a macro or the true clause will be evaluated 
+;; whether "a" is true or false
+
+;; If a is true return b, else return '()
+(define-simple-syntax (s:if a b)
+  (if a b '()))
+
+
+;; Using the Simple-Syntax System
+;; 
+;; The syntax for defining macros in this system is similar to that for defining functions. In fact if the macro has a fixed number of arguments the syntax is identical. For example:
+;; 
+;;   ; Define a simple macro to add a value to a variable.
+;;   ;
+;;   (define-simple-syntax (+= variable value)
+;;     (set! variable (+ variable value)))
+;; 
+;;   ; Use it.
+;;   ;
+;;   (define v 2)
+;;   (+= v 7)
+;;   v ; => 9
+;; 
+;; For a fixed number of arguments followed by an unknown number of arguments we use ... after a single argument to represent the unknown number (possibly zero) of arguments. For example, let's revise our definition of += to allow zero or more values to be added:
+;; 
+;;   ; Define a simple macro to add a zero or more values to a variable
+;;   ;
+;;   (define-simple-syntax (+= variable value ...)
+;;     (set! variable (+ variable value ...)))
+;; 
+;;   ; Use it
+;;   ;
+;;   (define v 2)
+;;   (+= v 7)
+;;   v ; => 9
+;;   (+= v 3 4)
+;;   v ; => 16
+;;   (+= v)
+;;   v ; => 16
+;; 
+
+(define-simple-syntax (s:if-param varname first ...)
+  (if (s:get varname)
+      first
+      ...))
+
+(define-simple-syntax (s:if-sessionvar varname first ...)
+  (if (s:session-var-get varname)
+      first
+      ...))
+
+;; (define-macro (s:if-param varname ...)
+;;   (match dat
+;; 	 (()    '())
+;; 	 ((a)    `(if (s:get ,varname) ,a '()))
+;; 	 ((a b)  `(if (s:get ,varname) ,a ,b))))
+;; 
+;; (define-macro (s:if-sessionvar varname . dat)
+;;   (match dat
+;; 	 (()    '())
+;; 	 ((a)    `(if (s:session-var-get ,varname) ,a '()))
+;; 	 ((a b)  `(if (s:session-var-get ,varname) ,a ,b))))
+;; 

ADDED   stml2/test.scm
Index: stml2/test.scm
==================================================================
--- /dev/null
+++ stml2/test.scm
@@ -0,0 +1,22 @@
+(use test md5)
+
+(require-extension sqlite3)
+(import (prefix sqlite3 sqlite3:))
+
+(require-library dbi)
+
+;; (declare (uses stml))
+
+(include "requirements.scm")
+(include "cookie.scm")
+(include "misc-stml.scm")
+(include "formdat.scm")
+(include "stml.scm")
+(include "session.scm")
+(include "sqltbl.scm")
+(include "html-filter.scm")
+(include "keystore.scm")
+
+(define p (open-input-file "test.stml"))
+(print (process-port p))
+(close-input-port p)

ADDED   stml2/test.stml
Index: stml2/test.stml
==================================================================
--- /dev/null
+++ stml2/test.stml
@@ -0,0 +1,10 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;; 
+;; index
+
+(list
+ (s:html
+  (s:head
+   (s:title "Kiatoa")
+   (s:link  'rel "stylesheet" 'type "text/css" 'href "/kiatoa/markup.css")
+   (s:link  'rel "stylesheet" 'type "text/css" 'href "/kiatoa/layout.css"))))

ADDED   stml2/tests/example.post.binary.in
Index: stml2/tests/example.post.binary.in
==================================================================
--- /dev/null
+++ stml2/tests/example.post.binary.in
cannot compute difference between binary files

ADDED   stml2/tests/example.post.in
Index: stml2/tests/example.post.in
==================================================================
--- /dev/null
+++ stml2/tests/example.post.in
@@ -0,0 +1,1 @@
+email-address=matt%3A1&password=Blah&form-name=login

ADDED   stml2/tests/models/test.scm
Index: stml2/tests/models/test.scm
==================================================================
--- /dev/null
+++ stml2/tests/models/test.scm
@@ -0,0 +1,11 @@
+;; Copyright 2007-2008, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;
+
+;; models/test.scm

ADDED   stml2/tests/pages/test/control.scm
Index: stml2/tests/pages/test/control.scm
==================================================================
--- /dev/null
+++ stml2/tests/pages/test/control.scm
@@ -0,0 +1,11 @@
+;; Copyright 2007-2008, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;
+
+;; pages/test/control.scm

ADDED   stml2/tests/pages/test/view.scm
Index: stml2/tests/pages/test/view.scm
==================================================================
--- /dev/null
+++ stml2/tests/pages/test/view.scm
@@ -0,0 +1,11 @@
+;; Copyright 2007-2008, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;
+
+;; pages/test/view.scm

ADDED   stml2/tests/test.scm
Index: stml2/tests/test.scm
==================================================================
--- /dev/null
+++ stml2/tests/test.scm
@@ -0,0 +1,225 @@
+#!/usr/local/bin/csi -q 
+
+;; Copyright 2007-2008, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+(use test md5)
+
+(require-extension sqlite3)
+(import (prefix sqlite3 sqlite3:))
+
+;; (require-library dbi)
+(use (prefix dbi dbi:))
+
+(load "./requirements.scm")
+(load "./cookie.scm")
+(load "./misc-stml.scm")
+(load "./formdat.scm")
+(load "./stml.scm")
+(load "./session.scm")
+(load "./sqltbl.scm")
+(load "./html-filter.scm")
+(load "./keystore.scm")
+
+;; Test the primitive dbi interface
+
+(system "rm -f tests/test.db")
+(define db (dbi:open 'sqlite3 '((dbname . "tests/test.db"))))
+(dbi:exec db "CREATE TABLE foo(id INTEGER PRIMARY KEY,name TEXT);")
+(dbi:exec db "INSERT INTO foo(name) VALUES(?);" "Matt")
+(dbi:for-each-row 
+ (lambda (tuple)
+   (print (vector-ref tuple 0) " " (vector-ref tuple 1)))
+ db "SELECT * FROM foo;")
+(test "dbi:get-one" "Matt" (dbi:get-one db "SELECT name FROM foo WHERE name='Matt';"))
+
+;; keystore
+(dbi:exec db "CREATE TABLE metadata (id INTEGER PRIMARY KEY,key TEXT,value TEXT);")
+
+(keystore:set! db "SCHEMA-VERSION" 1.2)
+(test "Keystore get" "1.2"  (keystore:get  db "SCHEMA-VERSION"))
+(keystore:del! db "SCHEMA-VERSION") 
+(test "Keystore get deleted" #f (keystore:get db "SCHEMA-VERSION"))
+
+(system "rm -f tests/test.db")
+
+;; create a session to work with")
+(setenv "REQUEST_URI" "/stmlrun?action=test.test")
+(setenv "SCRIPT_NAME" "/cgi-bin/stmlrun")
+(setenv "PATH_INFO" "/test")
+(setenv "QUERY_STRING" "action=test.test")
+(setenv "SERVER_NAME" "localhost")
+(setenv "REQUEST_METHOD" "GET")
+
+(load "./setup.scm")
+
+(s:validate-inputs)
+
+;; test session variables
+
+(session:get-vars s:session)
+(define nada "andnndhhshaas")
+(s:session-var-set! "nick" nada)
+(test "Session var set/get" nada  (s:session-var-get "nick"))
+(print "got here")
+(session:save-vars s:session)
+(session:get-vars  s:session)
+(test "Session var set/get after save/get" nada (s:session-var-get "nick"))
+(session:del! s:session "*sessionvars*" "nick")
+(test "Session var del"                    #f   (s:session-var-get "nick"))
+(session:save-vars s:session)
+(session:get-vars s:session)
+(s:session-var-set! "nick" nada)
+(session:save-vars s:session)
+
+;; (test "Session var del"                    #f   (s:session-var-get "nick"))
+
+;; test person
+
+(load "./tests/models/test.scm")
+
+(print "Session key is " (sdat-get-session-key s:session))
+
+(test "Delete session" #t (s:delete-session))
+
+(let ((fh (open-input-pipe "ls ./tests/pages/*/control.scm")))
+  (let loop ((l (read-line fh)))
+    (if (not (eof-object? l))
+        (begin
+          ;; (print "loading " l)
+          (load l)
+          (loop (read-line fh)))))
+  (close-input-port fh))
+
+;; Should have poll:poll defined now.
+(test "Make a random string" 2 (string-length (session:make-rand-string 2)))
+(test "Create an encrypted password using DES (backwards compat)" "abQ9KY.KfrYrc" (s:crypt-passwd "foo" "ab"))
+(test "Create an encrypted password using Blowfish" "$2a$12$GyoKHX/UOxMLGtwdSTr7EOF9KQzlyyyRqFTKx1YvLA3sMukbV4WBC" (s:crypt-passwd "foo" "$2a$12$GyoKHX/UOxMLGtwdSTr7EO"))
+
+(test "s:any->string on a hash-table" "#<hash-table>" (s:any->string (make-hash-table)))
+
+(define select-list
+  '((a b c)(d (e f g)(h i j #t))))
+(define result '("<SELECT name=\"efg\">" 
+		 ((("<OPTION label=\"a\" value=\"b\">c</OPTION>") 
+		   ("<OPTGROUP label=d" 
+		    ("<OPTION label=\"e\" value=\"f\">g</OPTION>")
+		    ("<OPTION  selected label=\"h\" value=\"i\">j</OPTION>") 
+		    "</OPTGROUP>")))
+		 "</SELECT>"))
+
+(test "Select list" result (s:select select-list 'name "efg"))
+
+;; Test modules
+
+(test "misc:non-zero-string \"\"" #f (misc:non-zero-string ""))
+(test "misc:non-zero-string #f" #f (misc:non-zero-string #f))
+(test "misc:non-zero-string 'blah" #f (misc:non-zero-string 'blah))
+
+;; forms
+(define form #f)
+(test "make <formdat>" #t (let ((f (make-formdat:formdat)))
+			    (set! form f)
+			    #t))
+(test "formdat: set!/get" "Yep!" (begin
+				   (formdat:set! form "blah" "Yep!")
+				   (formdat:get  form "blah")))
+
+(test "s:string->pgint"   123 (s:any->pgint "123"))
+(test "s:illegal-pgint (legal)"        #f (s:illegal-pgint 1011))
+(test "s:illegal-pgint (illegal big)"   1 (s:illegal-pgint  9999999999))
+(test "s:illegalpgint (illegal small)" -1 (s:illegal-pgint -9999999999))
+
+;; The twiki module
+
+;; clean up
+(system "rm -rf twikis/*")
+(load "modules/twiki/twiki-mod.scm")
+(define keys (list "blah" 1 'nada))
+(test "twiki:keys->key"  "blah 1 nada" (twiki:keys->key keys))
+(define key (twiki:keys->key keys))
+
+(define *tdb* #f)
+(test "twiki:open-db"   #t (let ((db (twiki:open-db key)))
+			     (set! *tdb* db)
+			     (if *tdb* #t #f)))
+(define wiki (make-twiki:wiki))
+(twiki:wiki-set-wid! wiki 1)
+(twiki:wiki-set-name! wiki "main")
+(twiki:wiki-set-perms! wiki '(r w))
+
+(test "twiki:dat->html" '("Hello" "<BR>") (twiki:dat->html "Hello" wiki))
+(test "twiki:keys->fname" '("twikis/Ymxha/CAxIG/5hZGE" "YmxhaCAxIG5hZGE_") ;; ("twikis/d99a2de9/6808493b/23770f70" "d99a2de96808493b23770f70c76dffe4")
+      (twiki:key->fname key))
+
+(test "twiki:name->wid"     1     (twiki:name->wid *tdb* "main"))
+(test "twiki:get-tiddlers-by-num" '() (twiki:get-tiddlers-by-num  *tdb* 0 (list 1 2 3)))
+(test "twiki:get-tiddlers-by-name" '() (twiki:get-tiddlers-by-name *tdb* 0 "MainMenu"))
+(test "twiki:get-tiddlers"  '()  (twiki:get-tiddlers *tdb* 0 (list "MainMenu")))
+(test "twiki:get-tiddlers"  '()  (twiki:get-tiddlers *tdb* 0 (list "MainMenu" "AnotherOne")))
+(test "twiki:wiki" "<TABLE>"     (car (twiki:wiki "main" (list "blah" 1 'nada))))
+(test "twiki:view"  "<DIV class=\"node\">" (car (twiki:view "" "" 0 (twiki:tiddler-make) wiki)))
+
+(test "s:td"              '("<TD>" (()) "</TD>") (s:td '()))
+;; (test "twiki:get-tiddlers-by-name" '() (twiki:get-tiddlers-by-name 1 "fred"))
+(test "twiki:tiddler-name->id" 1 (twiki:tiddler-name->id *tdb* "MainMenu"))
+(test "s:set! a var to #f"     ""
+      (begin (s:set! "BLAH" #f)
+	     (s:get "BLAH"))) ;; don't know if this one makes sense. Setting to #f should really delete the value
+(test "twiki:save-dat"           2        (twiki:save-dat *tdb* "dat" 0))
+(test "twiki:get-dat"            "dat"    (twiki:get-dat *tdb* 2))
+(test "twiki:get-dat"            #f       (twiki:get-dat *tdb* 5))
+;; (test "twiki:get-dat"      #f    (twiki:get-dat *tdb* #f))
+(test "twiki:save-tiddler"       #t       (twiki:save-tiddler *tdb* "heading" "body" "tags" key 0))
+;; (test "twiki:save-curr-tiddler"  #f       (twiki:save-curr-tiddler *tdb* 1))
+(test "twiki:edit-twiddler"      #t       (list? (twiki:edit-tiddler *tdb* key 0 0)))
+(test "twiki:maint_area"         "<DIV>"  (car (twiki:maint_area *tdb* 1 key wiki)))
+(test "twiki:pic_mgmt"           "<DIV>"  (car (twiki:pic_mgmt *tdb* 1 key)))
+
+;; get a blob jpg to process
+(define inp2 (open-input-file "tests/kiatoa.png"))
+(define dat  (string->blob (read-string #f inp2)))
+(close-input-port inp2)
+
+
+(test "twiki:save-pic"           #t       (twiki:save-pic *tdb* (list "mypic.jpg" "image/jpeg" dat) 0)) ;; (string->blob "testing eh!")))) 
+;; (test "twiki:save-pic-from-form" #f       (twiki:save-pic-from-form *tdb* 1))
+
+;; more tests on dats
+
+(define dat #f)
+(let ((inp (open-input-file "tests/kiatoa.png")))
+  (set! dat (read-string #f inp))
+  (close-input-port inp))
+(use md5)
+(define dat-md5 (md5:digest dat))
+(test "twiki:save-dat (binary)" 4        (twiki:save-dat *tdb* dat 1))
+(test "twiki:get-dat (binary)"  dat-md5  (let ((d (twiki:get-dat *tdb* 4)))
+					   (md5:digest d)))
+;; forms
+;; (define inp (open-input-file "tests/example.post.in"))
+;; (define dat (read-string #f inp))
+;; (define datstr (open-input-string dat))
+
+;; binary inputs
+(define inp (open-input-file "tests/example.post.binary.in"))
+(define dat #f)
+
+(test "formdat:load-all-port multipart" #t (let ((idat (formdat:load-all-port inp)))
+				   (set! dat idat)
+				   #t))
+(test "formdat:keys" '(picture-name input-picture "" submit-picture) (formdat:keys dat))
+
+(define inp (open-input-file "tests/example.post.in"))
+(test "formdat:load-all-port single part" #t (let ((idat (formdat:load-all-port inp)))
+				   (set! dat idat)
+				   #t))
+(test "formdat:keys" '(email-address form-name password) (formdat:keys dat))
+
+(close-input-port inp)

ADDED   stml2/testscript.sh
Index: stml2/testscript.sh
==================================================================
--- /dev/null
+++ stml2/testscript.sh
@@ -0,0 +1,7 @@
+export REQUEST_URI='/stmlrun?action=login.login'
+export SCRIPT_NAME=/cgi-bin/stmlrun
+export PATH_INFO=/classifieds
+export QUERY_STRING='action=login.login'
+export SERVER_NAME=localhost
+export REQUEST_METHOD=GET
+export HTTP_COOKIE='session_key=to09ipFJ9_2KXT96b2f9Q'

Index: tests-inc.scm
==================================================================
--- tests-inc.scm
+++ tests-inc.scm
@@ -20,105 +20,10 @@
 
 ;;======================================================================
 ;; Tests
 ;;======================================================================
 
-(define *java-script-lib* #f)
-
-(define (init-java-script-lib)
-  (set! *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
-  )
-
-;; Call this one to do all the work and get a standardized list of tests
-;;   gets paths from configs and finds valid tests 
-;;   returns hash of testname --> fullpath
-;;
-(define (tests:get-all)
-  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))
-    (tests:get-valid-tests (make-hash-table) test-search-path)))
-
-(define (tests:get-tests-search-path cfgdat)
-  (let ((paths (let ((section (if cfgdat
-				  (configf:get-section cfgdat "tests-paths")
-				  #f)))
-		 (if section
-		     (map cadr section)
-		     '()))))
-    (filter (lambda (d)
-	      (if (directory-exists? d)
-		  d
-		  (begin
-		    (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
-			(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
-		    #f)))
-	    (append paths (list (conc *toppath* "/tests"))))))
-
-(define (tests:get-valid-tests test-registry tests-paths)
-  (if (null? tests-paths) 
-      test-registry
-      (let loop ((hed (car tests-paths))
-		 (tal (cdr tests-paths)))
-	(if (common:file-exists? hed)
-	    (for-each (lambda (test-path)
-			(let* ((tname   (last (string-split test-path "/")))
-			       (tconfig (conc test-path "/testconfig")))
-			  (if (and (not (hash-table-ref/default test-registry tname #f))
-				   (common:file-exists? tconfig))
-			      (hash-table-set! test-registry tname test-path))))
-		      (glob (conc hed "/*"))))
-	(if (null? tal)
-	    test-registry
-	    (loop (car tal)(cdr tal))))))
-
-(define (tests:filter-test-names-not-matched test-names test-patts)
-  (delete-duplicates
-   (filter (lambda (testname)
-	     (not (tests:match test-patts testname #f)))
-	   test-names)))
-
-
-(define (tests:filter-test-names test-names test-patts)
-  (delete-duplicates
-   (filter (lambda (testname)
-	     (tests:match test-patts testname #f))
-	   test-names)))
-
-;; itemmap is a list of testname patterns to maps
-;;     test1 .*/bar/(\d+) foo/\1
-;;     %     foo/([^/]+)  \1/bar
-;;
-;; # NOTE: the line with the single % could be the result of
-;; #       itemmap entry in requirements (legacy). The itemmap
-;; #       requirements entry is deprecated
-;;
-(define (tests:get-itemmaps tconfig)
-  (let ((base-itemmap  (configf:lookup tconfig "requirements" "itemmap"))
-	(itemmap-table (configf:get-section tconfig "itemmap")))
-    (append (if base-itemmap
-		(list (list "%" base-itemmap))
-		'())
-	    (if itemmap-table
-		itemmap-table
-		'()))))
-
-;; given a list of itemmaps (testname . map), return the first match
-;;
-(define (tests:lookup-itemmap itemmaps testname)
-  (let ((best-matches (filter (lambda (itemmap)
-				(tests:match (car itemmap) testname #f))
-			      itemmaps)))
-    (if (null? best-matches)
-	#f
-	(let ((res (car best-matches)))
-	  ;; (debug:print 0 *default-log-port* "res=" res)
-	  (cond
-	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
-	   ((null? res)   #f)
-	   ((string? (cdr res)) (cdr res))  ;; it is a pair
-	   ((string? (cadr res))(cadr res)) ;; it is a list
-	   (else cadr res))))))
-
 ;; return items given config
 ;;
 (define (tests:get-items tconfig)
   (let ((items      (hash-table-ref/default tconfig "items" #f)) ;; items 4
 	(itemstable (hash-table-ref/default tconfig "itemstable" #f))) 
@@ -195,135 +100,10 @@
 			  (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
 			  #f)))
 		  newwaitors)
 	  config)))))
 					     
-;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
-;;
-;;  genlib/testconfig               sim/testconfig
-;;  genlib/sch                      sim/sch/cell1
-;;
-;;  [requirements]                  [requirements]
-;;                                  mode itemwait
-;;                                  # trim off the cell to determine what to run for genlib
-;;                                  itemmap /.*
-;;
-;;                                  waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
-;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
-;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
-;; expected -> "normal-first,normal-second/2,normal-second/"
-;; testpatt = normal-second/2
-;; waiting-test = normal-second
-;; waiton-test = normal-first
-;; itemmaps = ()
-
-(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
-  (cond
-   (itemized-waiton
-    (let* ((itemmap          (tests:lookup-itemmap itemmaps waiton-test))
-           (patts            (string-split test-patt ","))
-           (waiting-test-len (+ (string-length waiting-test) 1))
-           (patts-waiton     (map (lambda (x)  ;; for each incoming patt that matches the waiting test
-                                    (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
-                                           (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
-                                      ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
-                                      ;; (print "in map, x=" x ", newpatt=" newpatt)
-                                      newpatt))
-                                  (filter (lambda (x)
-                                            (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
-                                          patts)))
-           (extended-test-patt   (append patts (if (null? patts-waiton)
-                                                   (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
-                                                   patts-waiton)))
-           (extended-test-patt-with-toplevels
-            (fold (lambda (testpatt-item accum )
-                    (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
-                      (cons testpatt-item
-                            (if my-match
-                                (cons
-                                 (conc (cadr my-match) "/")
-                                 accum)
-                                accum))))
-                  '()
-                  extended-test-patt)))
-      (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))
-   (else ;; not waiting on items, waiting on entire waiton test.
-    (let* ((patts (string-split test-patt ","))
-           (new-patts (if (member waiton-test patts)
-                          patts
-                          (cons waiton-test patts))))
-      (string-intersperse (delete-duplicates new-patts) ",")))))
-
-
-  
-;; tests:glob-like-match 
-(define (tests:glob-like-match patt str) 
-  (let ((like (substring-index "%" patt)))
-    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
-	   (newpatt  (if notpatt (substring patt 1) patt))
-	   (finpatt  (if like
-			(string-substitute (regexp "%") ".*" newpatt #f)
-			(string-substitute (regexp "\\*") ".*" newpatt #f)))
-	   (res      #f))
-      ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
-      (set! res (string-match (regexp finpatt (if like #t #f)) str))
-      (if notpatt (not res) res))))
-
-;; if itempath is #f then look only at the testname part
-;;
-(define (tests:match patterns testname itempath #!key (required '()))
-  (if (string? patterns)
-      (let ((patts (append (string-split patterns ",") required)))
-	(if (null? patts) ;;; no pattern(s) means no match
-	    #f
-	    (let loop ((patt (car patts))
-		       (tal  (cdr patts)))
-	      ;; (print "loop: patt: " patt ", tal " tal)
-	      (if (string=? patt "")
-		  #f ;; nothing ever matches empty string - policy
-		  (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
-			 (test-patt  (cadr patt-parts))
-			 (item-patt  (cadddr patt-parts)))
-		    ;; special case: test vs. test/
-		    ;;   test  => "test" "%"
-		    ;;   test/ => "test" ""
-		    (if (and (not (substring-index "/" patt)) ;; no slash in the original
-			     (or (not item-patt)
-				 (equal? item-patt "")))      ;; should always be true that item-patt is ""
-			(set! item-patt "%"))
-		    ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
-		    (if (and (tests:glob-like-match test-patt testname)
-			     (or (not itempath)
-				 (tests:glob-like-match (if item-patt item-patt "") itempath)))
-			#t
-			(if (null? tal)
-			    #f
-			    (loop (car tal)(cdr tal)))))))))))
-
-;; if itempath is #f then look only at the testname part
-;;
-(define (tests:match->sqlqry patterns)
-  (if (string? patterns)
-      (let ((patts (string-split patterns ",")))
-	(if (null? patts) ;;; no pattern(s) means no match, we will do no query
-	    #f
-	    (let loop ((patt (car patts))
-		       (tal  (cdr patts))
-		       (res  '()))
-	      ;; (print "loop: patt: " patt ", tal " tal)
-	      (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
-		     (test-patt  (cadr patt-parts))
-		     (item-patt  (cadddr patt-parts))
-		     (test-qry   (db:patt->like "testname" test-patt))
-		     (item-qry   (db:patt->like "item_path" item-patt))
-		     (qry        (conc "(" test-qry " AND " item-qry ")")))
-		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
-		(if (null? tal)
-		    (string-intersperse (append (reverse res)(list qry)) " OR ")
-		    (loop (car tal)(cdr tal)(cons qry res)))))))
-      #f))
-
 ;; Check for waiver eligibility
 ;;
 (define (tests:check-waiver-eligibility testdat prev-testdat)
   (let* ((test-registry (make-hash-table))
 	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))

Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -18,17 +18,380 @@
 
 ;;======================================================================
 
 (declare (unit testsmod))
 (declare (uses commonmod))
+(declare (uses mtargs))
 
 (module testsmod
 	*
 	
 (import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
-(import commonmod)
-;; (use (prefix ulex ulex:))
+
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
+	(prefix mtconfigf configf:)
+	regex srfi-13
+	commonmod
+	(prefix mtargs args:))
+
+(define *java-script-lib* #f)
+
+(define (init-java-script-lib)
+  (set! *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
+  )
+
+;; A routine to map itempaths using a itemmap
+;; patha and pathb must be strings or this will fail
+;;
+;; path-b is waiting on path-a
+;;
+(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
+  (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
+  (let* ((itemmap    (tests:lookup-itemmap itemmaps test-b-name)))
+    (if itemmap
+	(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
+	  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
+	  (equal? path-a path-b-mapped))
+	(equal? path-b path-a))))
+
+;; A routine to convert test/itempath using a itemmap
+;; NOTE: to process only an itempath (i.e. no prepended testname)
+;;       just call db:multi-pattern-apply
+;;
+(define (db:convert-test-itempath path-in itemmap)
+  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
+  (let* ((path-parts  (string-split path-in "/"))
+	 (test-name   (if (null? path-parts) "" (car path-parts)))
+	 (item-path   (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
+    (conc test-name "/" 
+	  (db:multi-pattern-apply item-path itemmap))))
+
+;;======================================================================
+;; Run keys, these are used to hierarchially organise tests and run areas
+;;======================================================================
+
+(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
+  (string-intersperse keys ","))
+
+(define (args:usage . a) #f)
+
+;;======================================================================
+;; key <=> target routines
+;;======================================================================
+
+;; This invalidates using "/" in item names. Every key will be
+;; available via args:get-arg as :keyfield. Since this only needs to
+;; be called once let's use it to set the environment vars
+;;
+;; The setting of :keyfield in args should be turned off ASAP
+;;
+(define (keys:target-set-args keys target ht)
+  (if target
+      (let ((vals (string-split target "/")))
+	(if (eq? (length vals)(length keys))
+	    (for-each (lambda (key val)
+			(setenv key val)
+			(if ht (hash-table-set! ht (conc ":" key) val)))
+		      keys
+		      vals)
+	    (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
+	vals)
+      (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
+
+;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list
+;; keyval list ( (key1 val1) (key2 val2) ...)
+(define (keys:target->keyval keys target)
+  (let* ((targlist (string-split target "/"))
+	 (numkeys  (length keys))
+	 (numtarg  (length targlist))
+	 (targtweaked (if (> numkeys numtarg)
+			  (append targlist (make-list (- numkeys numtarg) ""))
+			  targlist)))
+    (map (lambda (key targ)
+	   (list key targ))
+	 keys targtweaked)))
+
+;;======================================================================
+;; config file related routines
+;;======================================================================
+
+(define keys:config-get-fields common:get-fields)
+(define (keys:make-key/field-string confdat)
+  (let ((fields (configf:get-section confdat "fields")))
+    (string-join
+     (map (lambda (field)(conc (car field) " " (cadr field)))
+	  fields)
+     ",")))
+
+;; patterns are:
+;;    "rx1"  "replacement1"\n
+;;    "rx2"  "replacement2"
+;; etc.
+;;
+(define (db:multi-pattern-apply item-path itemmap)
+  (let ((all-patts (string-split itemmap "\n")))
+    (if (null? all-patts)
+	item-path
+	(let loop ((hed (car all-patts))
+		   (tal (cdr all-patts))
+		   (res item-path))
+	  (let* ((parts (string-split hed))
+		 (patt  (car parts))
+
+		 (repl  (if (> (length parts) 1)(cadr parts) ""))
+
+		 (newr  (if (and patt repl)
+			    (begin
+                              (handle-exceptions
+                               exn
+                               (begin
+                                  (debug:print 0 *default-log-port*
+                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+                                 res)
+                              (string-substitute patt repl res))
+
+
+                              )
+			    (begin
+                              (debug:print 0 *default-log-port*
+                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+			      res))))
+	    (if (null? tal)
+		newr
+		(loop (car tal)(cdr tal) newr)))))))
+
+;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
+;;
+;;  genlib/testconfig               sim/testconfig
+;;  genlib/sch                      sim/sch/cell1
+;;
+;;  [requirements]                  [requirements]
+;;                                  mode itemwait
+;;                                  # trim off the cell to determine what to run for genlib
+;;                                  itemmap /.*
+;;
+;;                                  waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
+;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
+;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
+;; expected -> "normal-first,normal-second/2,normal-second/"
+;; testpatt = normal-second/2
+;; waiting-test = normal-second
+;; waiton-test = normal-first
+;; itemmaps = ()
+
+(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
+  (cond
+   (itemized-waiton
+    (let* ((itemmap          (tests:lookup-itemmap itemmaps waiton-test))
+           (patts            (string-split test-patt ","))
+           (waiting-test-len (+ (string-length waiting-test) 1))
+           (patts-waiton     (map (lambda (x)  ;; for each incoming patt that matches the waiting test
+                                    (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
+                                           (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
+                                      ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
+                                      ;; (print "in map, x=" x ", newpatt=" newpatt)
+                                      newpatt))
+                                  (filter (lambda (x)
+                                            (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
+                                          patts)))
+           (extended-test-patt   (append patts (if (null? patts-waiton)
+                                                   (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
+                                                   patts-waiton)))
+           (extended-test-patt-with-toplevels
+            (fold (lambda (testpatt-item accum )
+                    (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
+                      (cons testpatt-item
+                            (if my-match
+                                (cons
+                                 (conc (cadr my-match) "/")
+                                 accum)
+                                accum))))
+                  '()
+                  extended-test-patt)))
+      (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))
+   (else ;; not waiting on items, waiting on entire waiton test.
+    (let* ((patts (string-split test-patt ","))
+           (new-patts (if (member waiton-test patts)
+                          patts
+                          (cons waiton-test patts))))
+      (string-intersperse (delete-duplicates new-patts) ",")))))
+
+
+  
+;; tests:glob-like-match 
+(define (tests:glob-like-match patt str) 
+  (let ((like (substring-index "%" patt)))
+    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
+	   (newpatt  (if notpatt (substring patt 1) patt))
+	   (finpatt  (if like
+			(string-substitute (regexp "%") ".*" newpatt #f)
+			(string-substitute (regexp "\\*") ".*" newpatt #f)))
+	   (res      #f))
+      ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
+      (set! res (string-match (regexp finpatt (if like #t #f)) str))
+      (if notpatt (not res) res))))
+
+;; if itempath is #f then look only at the testname part
+;;
+(define (tests:match patterns testname itempath #!key (required '()))
+  (if (string? patterns)
+      (let ((patts (append (string-split patterns ",") required)))
+	(if (null? patts) ;;; no pattern(s) means no match
+	    #f
+	    (let loop ((patt (car patts))
+		       (tal  (cdr patts)))
+	      ;; (print "loop: patt: " patt ", tal " tal)
+	      (if (string=? patt "")
+		  #f ;; nothing ever matches empty string - policy
+		  (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
+			 (test-patt  (cadr patt-parts))
+			 (item-patt  (cadddr patt-parts)))
+		    ;; special case: test vs. test/
+		    ;;   test  => "test" "%"
+		    ;;   test/ => "test" ""
+		    (if (and (not (substring-index "/" patt)) ;; no slash in the original
+			     (or (not item-patt)
+				 (equal? item-patt "")))      ;; should always be true that item-patt is ""
+			(set! item-patt "%"))
+		    ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
+		    (if (and (tests:glob-like-match test-patt testname)
+			     (or (not itempath)
+				 (tests:glob-like-match (if item-patt item-patt "") itempath)))
+			#t
+			(if (null? tal)
+			    #f
+			    (loop (car tal)(cdr tal)))))))))))
+
+;; if itempath is #f then look only at the testname part
+;;
+(define (tests:match->sqlqry patterns)
+  (if (string? patterns)
+      (let ((patts (string-split patterns ",")))
+	(if (null? patts) ;;; no pattern(s) means no match, we will do no query
+	    #f
+	    (let loop ((patt (car patts))
+		       (tal  (cdr patts))
+		       (res  '()))
+	      ;; (print "loop: patt: " patt ", tal " tal)
+	      (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
+		     (test-patt  (cadr patt-parts))
+		     (item-patt  (cadddr patt-parts))
+		     (test-qry   (db:patt->like "testname" test-patt))
+		     (item-qry   (db:patt->like "item_path" item-patt))
+		     (qry        (conc "(" test-qry " AND " item-qry ")")))
+		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
+		(if (null? tal)
+		    (string-intersperse (append (reverse res)(list qry)) " OR ")
+		    (loop (car tal)(cdr tal)(cons qry res)))))))
+      #f))
+
+;; keys list to key1,key2,key3 ...
+(define (runs:get-std-run-fields keys remfields)
+  (let* ((header    (append keys remfields))
+	 (keystr    (conc (keys->keystr keys) ","
+			  (string-intersperse remfields ","))))
+    (list keystr header)))
+
+;; make a query (fieldname like 'patt1' OR fieldname 
+(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
+  (let ((patts (if (string? pattstr)
+		   (string-split pattstr ",")
+		   '("%"))))
+    (string-intersperse (map (lambda (patt)
+			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
+				 (conc fieldname " " wildtype " '" patt "'")))
+			     (if (null? patts)
+				 '("")
+				 patts))
+			comparator)))
+
+;; Call this one to do all the work and get a standardized list of tests
+;;   gets paths from configs and finds valid tests 
+;;   returns hash of testname --> fullpath
+;;
+(define (tests:get-all)
+  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))
+    (tests:get-valid-tests (make-hash-table) test-search-path)))
+
+(define (tests:get-tests-search-path cfgdat)
+  (let ((paths (let ((section (if cfgdat
+				  (configf:get-section cfgdat "tests-paths")
+				  #f)))
+		 (if section
+		     (map cadr section)
+		     '()))))
+    (filter (lambda (d)
+	      (if (directory-exists? d)
+		  d
+		  (begin
+		    (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
+			(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
+		    #f)))
+	    (append paths (list (conc *toppath* "/tests"))))))
+
+(define (tests:get-valid-tests test-registry tests-paths)
+  (if (null? tests-paths) 
+      test-registry
+      (let loop ((hed (car tests-paths))
+		 (tal (cdr tests-paths)))
+	(if (common:file-exists? hed)
+	    (for-each (lambda (test-path)
+			(let* ((tname   (last (string-split test-path "/")))
+			       (tconfig (conc test-path "/testconfig")))
+			  (if (and (not (hash-table-ref/default test-registry tname #f))
+				   (common:file-exists? tconfig))
+			      (hash-table-set! test-registry tname test-path))))
+		      (glob (conc hed "/*"))))
+	(if (null? tal)
+	    test-registry
+	    (loop (car tal)(cdr tal))))))
+
+(define (tests:filter-test-names-not-matched test-names test-patts)
+  (delete-duplicates
+   (filter (lambda (testname)
+	     (not (tests:match test-patts testname #f)))
+	   test-names)))
+
+
+(define (tests:filter-test-names test-names test-patts)
+  (delete-duplicates
+   (filter (lambda (testname)
+	     (tests:match test-patts testname #f))
+	   test-names)))
+
+;; itemmap is a list of testname patterns to maps
+;;     test1 .*/bar/(\d+) foo/\1
+;;     %     foo/([^/]+)  \1/bar
+;;
+;; # NOTE: the line with the single % could be the result of
+;; #       itemmap entry in requirements (legacy). The itemmap
+;; #       requirements entry is deprecated
+;;
+(define (tests:get-itemmaps tconfig)
+  (let ((base-itemmap  (configf:lookup tconfig "requirements" "itemmap"))
+	(itemmap-table (configf:get-section tconfig "itemmap")))
+    (append (if base-itemmap
+		(list (list "%" base-itemmap))
+		'())
+	    (if itemmap-table
+		itemmap-table
+		'()))))
 
-(include "common_records.scm")
+;; given a list of itemmaps (testname . map), return the first match
+;;
+(define (tests:lookup-itemmap itemmaps testname)
+  (let ((best-matches (filter (lambda (itemmap)
+				(tests:match (car itemmap) testname #f))
+			      itemmaps)))
+    (if (null? best-matches)
+	#f
+	(let ((res (car best-matches)))
+	  ;; (debug:print 0 *default-log-port* "res=" res)
+	  (cond
+	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
+	   ((null? res)   #f)
+	   ((string? (cdr res)) (cdr res))  ;; it is a pair
+	   ((string? (cadr res))(cadr res)) ;; it is a list
+	   (else cadr res))))))
+
 
 )