Index: formdat.scm
==================================================================
--- formdat.scm
+++ formdat.scm
@@ -16,343 +16,6 @@
 (use html-filter)
 
 (use regex)
 (require-extension srfi-69)
 
-(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-inline (formdat:formdat-get-data   vec)    (vector-ref  vec 0))
-(define-inline (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))
-	       (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)))))
-
-;; (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))
-	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)
-|#
-
 )

Index: html-filter.scm
==================================================================
--- html-filter.scm
+++ html-filter.scm
@@ -16,192 +16,6 @@
 (use misc-stml)
 
 (require-extension regex)
 
 ;; 
-(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")
 )

Index: keystore.scm
==================================================================
--- keystore.scm
+++ keystore.scm
@@ -17,19 +17,6 @@
 (module keystore
     *
 
 (import chicken scheme data-structures extras srfi-13 ports )
 
-
-(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))
-
 )

Index: misc-stml.scm
==================================================================
--- misc-stml.scm
+++ misc-stml.scm
@@ -19,222 +19,6 @@
 (import chicken scheme data-structures extras srfi-13 ports posix)
   
 (use regex (prefix dbi dbi:))
 (use (prefix crypt c:))
 (use (prefix dbi dbi:))
-;; 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 (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))))
-           
-(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))))))))
-
 )

Index: session.scm
==================================================================
--- session.scm
+++ session.scm
@@ -10,887 +10,11 @@
 ;; (declare (unit session))
 (module session
     *
   
 (import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)
-(use formdat html-filter misc-stml)
 
 (use (prefix dbi dbi:) srfi-69)
 (require-extension regex)
-(use cookie) ;; (declare (uses cookie))
-
-;; 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-get-dbtype               vec)    (vector-ref  vec 0))
-(define (sdat-get-dbinit               vec)    (vector-ref  vec 1))
-(define (sdat-get-conn                 vec)    (vector-ref  vec 2))
-(define (sdat-get-pgconn               vec)    (vector-ref (vector-ref vec 2) 1))
-(define (sdat-get-params               vec)    (vector-ref  vec 3))
-(define (sdat-get-path-params          vec)    (vector-ref  vec 4))
-(define (sdat-get-session-key          vec)    (vector-ref  vec 5))
-(define (sdat-get-session-id           vec)    (vector-ref  vec 6))
-(define (sdat-get-domain               vec)    (vector-ref  vec 7))
-(define (sdat-get-toppage              vec)    (vector-ref  vec 8))
-(define (sdat-get-page                 vec)    (vector-ref  vec 9))
-(define (sdat-get-curr-page            vec)    (vector-ref  vec 10))
-(define (sdat-get-content-type         vec)    (vector-ref  vec 11))
-(define (sdat-get-page-type            vec)    (vector-ref  vec 12))
-(define (sdat-get-sroot                vec)    (vector-ref  vec 13))
-(define (sdat-get-twikidir             vec)    (vector-ref  vec 14))
-(define (sdat-get-pagedat              vec)    (vector-ref  vec 15))
-(define (sdat-get-alt-page-dat         vec)    (vector-ref  vec 16))
-(define (sdat-get-pagevars             vec)    (vector-ref  vec 17))
-(define (sdat-get-pagevars-before      vec)    (vector-ref  vec 18))
-(define (sdat-get-sessionvars          vec)    (vector-ref  vec 19))
-(define (sdat-get-sessionvars-before   vec)    (vector-ref  vec 20))
-(define (sdat-get-globalvars           vec)    (vector-ref  vec 21))
-(define (sdat-get-globalvars-before    vec)    (vector-ref  vec 22))
-(define (sdat-get-logpt                vec)    (vector-ref  vec 23))
-(define (sdat-get-formdat              vec)    (vector-ref  vec 24))
-(define (sdat-get-request-method       vec)    (vector-ref  vec 25))
-(define (sdat-get-session-cookie       vec)    (vector-ref  vec 26))
-(define (sdat-get-curr-err             vec)    (vector-ref  vec 27))
-(define (sdat-get-log-port             vec)    (vector-ref  vec 28))
-(define (sdat-get-logfile              vec)    (vector-ref  vec 29))
-(define (sdat-get-seen-pages           vec)    (vector-ref  vec 30))
-(define (sdat-get-page-dir-style       vec)    (vector-ref  vec 31))
-(define (sdat-get-debugmode            vec)    (vector-ref  vec 32))
-(define (sdat-get-shared-hash          vec)    (vector-ref  vec 33))
-(define (sdat-get-script               vec)    (vector-ref  vec 34))
-(define (sdat-get-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-set-dbtype!              vec val)(vector-set! vec 0 val))
-(define (sdat-set-dbinit!              vec val)(vector-set! vec 1 val))
-(define (sdat-set-conn!                vec val)(vector-set! vec 2 val))
-(define (sdat-set-params!              vec val)(vector-set! vec 3 val))
-(define (sdat-set-path-params!         vec val)(vector-set! vec 4 val))
-(define (sdat-set-session-key!         vec val)(vector-set! vec 5 val))
-(define (sdat-set-session-id!          vec val)(vector-set! vec 6 val))
-(define (sdat-set-domain!              vec val)(vector-set! vec 7 val))
-(define (sdat-set-toppage!             vec val)(vector-set! vec 8 val))
-(define (sdat-set-page!                vec val)(vector-set! vec 9 val))
-(define (sdat-set-curr-page!           vec val)(vector-set! vec 10 val))
-(define (sdat-set-content-type!        vec val)(vector-set! vec 11 val))
-(define (sdat-set-page-type!           vec val)(vector-set! vec 12 val))
-(define (sdat-set-sroot!               vec val)(vector-set! vec 13 val))
-(define (sdat-set-twikidir!            vec val)(vector-set! vec 14 val))
-(define (sdat-set-pagedat!             vec val)(vector-set! vec 15 val))
-(define (sdat-set-alt-page-dat!        vec val)(vector-set! vec 16 val))
-(define (sdat-set-pagevars!            vec val)(vector-set! vec 17 val))
-(define (sdat-set-pagevars-before!     vec val)(vector-set! vec 18 val))
-(define (sdat-set-sessionvars!         vec val)(vector-set! vec 19 val))
-(define (sdat-set-sessionvars-before!  vec val)(vector-set! vec 20 val))
-(define (sdat-set-globalvars!          vec val)(vector-set! vec 21 val))
-(define (sdat-set-globalvars-before!   vec val)(vector-set! vec 22 val))
-(define (sdat-set-logpt!               vec val)(vector-set! vec 23 val))
-(define (sdat-set-formdat!             vec val)(vector-set! vec 24 val))
-(define (sdat-set-request-method!      vec val)(vector-set! vec 25 val))
-(define (sdat-set-session-cookie!      vec val)(vector-set! vec 26 val))
-(define (sdat-set-curr-err!            vec val)(vector-set! vec 27 val))
-(define (sdat-set-log-port!            vec val)(vector-set! vec 28 val))
-(define (sdat-set-logfile!             vec val)(vector-set! vec 29 val))
-(define (sdat-set-seen-pages!          vec val)(vector-set! vec 30 val))
-(define (sdat-set-page-dir-style!      vec val)(vector-set! vec 31 val))
-(define (sdat-set-debugmode!           vec val)(vector-set! vec 32 val))
-(define (sdat-set-shared-hash!         vec val)(vector-set! vec 33 val))
-(define (sdat-set-script!              vec val)(vector-set! vec 34 val))
-(define (sdat-set-force-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)
-  (sdat-set-dbtype! self      'pg)
-  (sdat-set-page! self        "home")        ;; these are defaults
-  (sdat-set-curr-page! self   "home")
-  (sdat-set-content-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
-  (sdat-set-page-type! self   'html)
-  (sdat-set-toppage! self     "index")
-  (sdat-set-params! self      '())           ;;
-  (sdat-set-path-params! self '())
-  (sdat-set-session-key! self #f)
-  (sdat-set-pagedat! self     '())
-  (sdat-set-alt-page-dat! self #f)
-  (sdat-set-sroot! self       "./")
-  (sdat-set-session-cookie! self #f)
-  (sdat-set-curr-err! self #f)
-  (sdat-set-log-port! self (current-error-port))
-  (sdat-set-seen-pages! self '())
-  (sdat-set-page-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
-                                      ;; #f : pages/<pagename>/(view|control).scm 
-  (sdat-set-debugmode!          self #f)
-  			     
-  (sdat-set-pagevars!           self (make-hash-table))
-  (sdat-set-sessionvars!        self (make-hash-table))
-  (sdat-set-globalvars!         self (make-hash-table))
-  (sdat-set-pagevars-before!    self (make-hash-table))
-  (sdat-set-sessionvars-before! self (make-hash-table))
-  (sdat-set-globalvars-before!  self (make-hash-table))
-  (sdat-set-domain!             self "locahost")   ;; end of defaults
-  (sdat-set-script!             self #f)
-  (sdat-set-force-ssl!          self #f)
-  (let* ((rawconfigdat (session:read-config self))
-	 (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-set-sroot!    self sroot))
-    (if logfile  (sdat-set-logfile!  self logfile))
-    (if dbtype   (sdat-set-dbtype!   self dbtype))
-    (if dbinit   (sdat-set-dbinit!   self dbinit))
-    (if domain   (sdat-set-domain!   self domain))
-    (if twikidir (sdat-set-twikidir! self twikidir))
-    (if debugmode (sdat-set-debugmode! self debugmode))
-    (if script    (sdat-set-script!    self script))
-    (if force-ssl (sdat-set-force-ssl! self force-ssl))
-    (sdat-set-page-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-set-shared-hash! self (make-hash-table))
-  )
-
-;; Used for the strangely inconsistent handling of the config file. A better way is needed.
-;;
-;;   (let ((dbtype (sdat-get-dbtype self)))
-;;     (print "dbtype: " dbtype)
-;;     (sdat-set-dbtype! self (eval dbtype))))
-
-(define (session:setup self)
-  (let ((dbtype    (sdat-get-dbtype self))
-	(debugmode (sdat-get-debugmode self))
-	(dbinit    (eval (sdat-get-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-set-conn! self (dbi:open dbtype dbinit))
-    (set! *db* (sdat-get-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-set-request-method! self (get-environment-variable "REQUEST_METHOD"))
-    (sdat-set-formdat! self (formdat:load-all))))
-
-;; setup the db with session tables, works for sqlite only right now
-(define (session:setup-db self)
-  (let ((conn (sdat-get-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-set-session-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-set-session-key! self new-key)
-          (sdat-set-session-id! self new-sid)
-          (sdat-set-session-cookie! self (session:make-cookie self)))
-        (sdat-set-session-id! self sid))))
-
-(define (session:make-cookie self)
-  ;; (list (conc "session_key=" (sdat-get-session-key self) "; Path=/; Domain=." (sdat-get-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-get-session-key self)
-		  expires: ,(+ (current-seconds) (* 14 86400)) 
-		  ;; max-age: (* 14 86400)
-		  path: "/" ;; 
-		  domain: ,(string-append "." (sdat-get-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-get-session-key self)))
-  (if session-key
-      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
-            (conn (sdat-get-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-set-page! self (car parts)))
-	  ;; (session:log self "url-path=" url-path " parts=" parts)
-	  (if (> numparts 1)
-	      (sdat-set-path-params! self (cdr parts)))
-          (if query-string
-              (sdat-set-params! self (string-split query-string "&")))))))
-
-;; BUGGY!
-(define (session:get-new-key self)
-  (let ((conn   (sdat-get-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-get-conn self))
-    ;;                        conn)
-    (dbi:for-each-row (lambda (tuple)
-			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
-		      (sdat-get-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-get-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-get-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-get-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-set-session-key! self (list-ref match 1))
-		session-key))
-	     ((null? tail)
-	      #f)
-	     (else
-	      (loop (car tail)
-		    (cdr tail)))))))))
-
-(define (session:set-page! self page_name)
-  (sdat-set-page! self page_name))
-
-(define (session:close self)
-  (dbi:close (sdat-get-conn self)))
-;; (close-output-port (sdat-get-logpt self))
-
-(define (session:err-msg self msg)
-  (hash-table-set! (sdat-get-sessionvars self) "ERROR_MSG"
-		   (string-intersperse (map s:any->string msg) " ")))
-
-(define (session:prev-err self)
-  (let ((prev-err (hash-table-ref/default (sdat-get-sessionvars-before self) "ERROR_MSG" #f))
-	(curr-err (hash-table-ref/default (sdat-get-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-get-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-get-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-get-sessionvars self)
-      (if (string=? page "*globalvars*")
-	  (sdat-get-globalvars self)
-	  (sdat-get-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-get-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-get-session-id self)))
-    (if (not session-id)
-	(err:log "ERROR: No session id in session object! session:get-vars")
-	(let* ((result             #f)
-	       (conn               (sdat-get-conn self))
-	       (pagevars-before    (sdat-get-pagevars-before self))
-	       (sessionvars-before (sdat-get-sessionvars-before self))
-	       (globalvars-before  (sdat-get-globalvars-before self))
-	       (pagevars           (sdat-get-pagevars self))
-	       (sessionvars        (sdat-get-sessionvars self))
-	       (globalvars         (sdat-get-globalvars self))
-	       (page-name          (sdat-get-page self))
-	       (session-key        (sdat-get-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-get-session-id self)))
-    (if (not session-id)
-	(err:log "ERROR: No session id in session object! session:get-vars")
-	(let* ((status      #f)
-	       (conn        (sdat-get-conn self))
-	       (page-name   (sdat-get-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-get-sessionvars self)
-					       (sdat-get-sessionvars-before self)))
-				       ((string=? page "*globalvars*")
-					(vector (sdat-get-globalvars self)
-						(sdat-get-globalvars-before self)))
-				       (else 
-					(vector (sdat-get-pagevars self)
-						(sdat-get-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)
-  (let* ((cgi-path (pathname-directory (car (argv))))
-         (name     (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 defence 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-set-curr-page! self page)
-  (let* ((dir-style    (sdat-get-page-dir-style self));; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
-	 (dir          (string-append (sdat-get-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-get-conn self)         ;; the db connection
-	(sdat-get-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-get-conn self)         ;; the db connection
-		(sdat-get-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 ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
-;; 	(model.so  (string-append (sdat-get-sroot self) "/models/" 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 model)
-;;   (string-append (sdat-get-sroot self) "/models/" model ".scm"))
-
-(define (session:pp-formdat self)
-  (let ((dat (formdat:all->strings (sdat-get-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-get-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-get-domain self)))
-         (force-script  (sdat-get-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-get-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-get-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
-	 (header   (let ((cookie (sdat-get-session-cookie self)))
-		     (if cookie
-			 (cons (string-append "Set-Cookie: " (car cookie))
-			       content)
-			 content)))
-	 (pagedat  (sdat-get-pagedat self)))
-    (s:cgi-out 
-     (cons header pagedat))))
-
-(define (session:log self . msg)
-  (with-output-to-port (sdat-get-log-port self) ;; (sdat-get-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-get-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-get-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-get-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-get-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-get-seen-pages self))))
-
-(define (session:set-called! self page)
-  (sdat-set-seen-pages! self (cons page (sdat-get-seen-pages self))))
-
-;;======================================================================
-;; Alternative data type delivery
-;;======================================================================
-
-(define (session:alt-out self)
-  (let ((dat (sdat-get-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-get-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))))
-
-;; was in setup
-;;
-(define (s:log . msg)
-  (apply session:log s:session msg))
+(use cookie stmlcommon) ;; (declare (uses cookie))
 
 )

Index: setup.scm
==================================================================
--- setup.scm
+++ setup.scm
@@ -10,210 +10,12 @@
 (module setup
     *
 (import chicken scheme data-structures extras srfi-13 ports posix)
 
 (uses session misc-stml)
-;; (declare (unit setup))
+;; (declare (unit setup))se
 ;; (declare (uses session))
 (require-extension srfi-69)
 (require-extension regex)
 
-;; 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))))
-
-(define (s:set-err . args)
-  (sdat-set-curr-err! s:session args))
-
-;; Usage: (s:get-err s:big)
-(define (s:get-err wrapperfunc)
-  (let ((errmsg (sdat-get-curr-err s:session)))
-    (if errmsg ((if wrapperfunc
-                    wrapperfunc
-                    s:strong) errmsg) '())))
-
-(define (s:current-page)
-  (sdat-get-page s:session))
-
-(define (s:delete-session)
-  (session:delete-session s:session (sdat-get-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 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-get-sessionvars s:session))
-
-;; 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 model)
-  (session:model-path s:session model))
-
-;; share data between pages calls. NOTE: This is not persistent
-;; between cgi calls. Use sessionvars for that.
-;;
-(define (s:shared-hash)
-  (sdat-get-shared-hash s:session))
-
-(define (s:shared-set! key val)
-  (hash-table-set! (sdat-get-shared-hash s:session) key val))
-
-;; What to return when no value for key?
-;;
-(define (s:shared-get key)
-  (hash-table-ref/default (sdat-get-shared-hash s:session) key #f))
-
-;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
-;;  #### DEPRECATED ####
-(define (s:get-page-params)
-  (sdat-get-path-params s:session))
-
-(define (s:get-path-params)
-  (sdat-get-path-params s:session))
-	
-
-(define (s:db)
-  (sdat-get-conn s:session))
-
-(define (s:never-called-page? page)
-  (session:never-called-page? s:session page))
-
-;; find out if we are in debugmode
-(define (s:debug-mode?)
-  (sdat-get-debugmode s:session))
 
 )

DELETED sqltbl.scm
Index: sqltbl.scm
==================================================================
--- sqltbl.scm
+++ /dev/null
@@ -1,119 +0,0 @@
-;; Copyright 2007-2011, Matthew Welland. Kiatoa.com All rights reserved.
-;; 
-
-;; DON'T USE THIS!!!! It was a bad idea :-(
-
-;; (require-extension tinyclos)
-
-;; (define-class <sqltbl> ()
-;;   (rows
-;;    fields       ;; list of field
-;;    fields-hash  ;; hash of fields -> number
-;;    query        ;; query string using ?'s
-;;    query-params ;; list of params for the query
-;;    conn         ;; connection to db
-;;    num-rows     ;; whatever 
-;;    curr-row-ptr ;; number of the current row
-;;    curr-row     ;; the current row vector (?? do we really want this ??)
-;;    ))
-
-(module sqltbl
-    *
-
-(import chicken scheme data-structures extras srfi-13 ports )
-
-;; (declare (unit sqltbl))
-
-(define (make-sqltbl:tbl)(make-vector 9))
-(define (sqltbl:tbl-get-rows           vec)    (vector-ref  vec 0))
-(define (sqltbl:tbl-get-fields         vec)    (vector-ref  vec 1))
-(define (sqltbl:tbl-get-fields-hash    vec)    (vector-ref  vec 2))
-(define (sqltbl:tbl-get-query          vec)    (vector-ref  vec 3))
-(define (sqltbl:tbl-get-query-params   vec)    (vector-ref  vec 4))
-(define (sqltbl:tbl-get-conn           vec)    (vector-ref  vec 5))
-(define (sqltbl:tbl-get-num-rows       vec)    (vector-ref  vec 6))
-(define (sqltbl:tbl-get-curr-row-ptr   vec)    (vector-ref  vec 7))
-(define (sqltbl:tbl-get-curr-row       vec)    (vector-ref  vec 8))
-(define (sqltbl:tbl-set-rows!          vec val)(vector-set! vec 0 val))
-(define (sqltbl:tbl-set-fields!        vec val)(vector-set! vec 1 val))
-(define (sqltbl:tbl-set-fields-hash!   vec val)(vector-set! vec 2 val))
-(define (sqltbl:tbl-set-query!         vec val)(vector-set! vec 3 val))
-(define (sqltbl:tbl-set-query-params!  vec val)(vector-set! vec 4 val))
-(define (sqltbl:tbl-set-conn!          vec val)(vector-set! vec 5 val))
-(define (sqltbl:tbl-set-num-rows!      vec val)(vector-set! vec 6 val))
-(define (sqltbl:tbl-set-curr-row-ptr!  vec val)(vector-set! vec 7 val))
-(define (sqltbl:tbl-set-curr-row!      vec val)(vector-set! vec 8 val))
-
-(define  (sqltbl:initialize self);; initargs)
-  (sqltbl:tbl-set-num-rows! self 0)
-  (sqltbl:tbl-set-curr-row-ptr! self 0)
-  (sqltbl:tbl-set-fields! self '())
-  (sqltbl:tbl-set-fields-hash! self (make-hash-table)))
-  ;; (initialize-slots self initargs))
-;;  (if (> (length (sqltbl:tbl-get-rows self) 0))
-;;      (sqltbl:tbl-set-curr-row! self (car rows))))
-
-(define (sqltbl:next-row self)
-  (let ((curr-row-ptr (+ (sqltbl:tbl-get-curr-row-ptr self) 1))
-        (num-rows     (sqltbl:tbl-get-num-rows self))
-        (rows         (sqltbl:tbl-get-rows self)))
-    (if (> curr-row-prt (sqltbl:tbl-get-num-rows self)) #f ;; there is no next row
-        (let ((new-curr-row (list-ref rows curr-row-ptr)))
-          (sqltbl:tbl-set-curr-row! self new-curr-row)
-          (sqltbl:tbl-set-curr-row-prt! self curr-row-prt)
-          new-curr-row))))
-
-;; run the query and fill the rows list 
-(define (sqltbl:run-query self . params)
-  (let* ((query  (sqltbl:tbl-get-query self))
-         (fields (sqltbl:tbl-get-fields self))
-         (rows (let ((result '())
-                     (actual-query (apply s:sqlparam query fields params)))
-                 ;; (s:log "actual-query=" actual-query)
-                 (dbi:for-each-row (lambda (tuple)
-                                      (set! result (cons tuple result)))
-                                    (sqltbl:tbl-get-conn self)
-				actual-query)
-                 (sqltbl:tbl-set-query-params! self params)
-                 (sqltbl:tbl-set-num-rows! self (length result))
-                 (sqltbl:setup-fields self)  ;; update the fields lookup hash
-                 (reverse result))))
-    (sqltbl:tbl-set-rows! self rows)
-    (if (not (null? rows))
-        (sqltbl:tbl-set-curr-row! self (car rows)))
-    (sqltbl:tbl-set-curr-row-ptr! self 0)
-    rows))
-
-(define (sqltbl:setup-fields self)
-  (let ((fields-hash (sqltbl:tbl-get-fields-hash self))
-        (fields-list (sqltbl:tbl-get-fields self)))
-    (let loop ((head (car fields-list))
-               (tail (cdr fields-list))
-               (fnum 0))
-      (hash-table-set! fields-hash head fnum)
-      (if (null? tail) fnum
-          (loop (car tail)(cdr tail)(+ fnum 1))))))
-
-;; get a value from the current row
-(define (sqltbl:get-field-value-curr self field)
-  (let ((curr-row  (sqltbl:tbl-get-curr-row self))
-        (field-num (hash-table-ref/default (sqltbl:tbl-get-fields-hash self) field #f)))
-    (if field-num 
-        (vector-ref curr-row field-num)
-        #f))) ;; not found -> #f
-
-(define (sqltbl:vector->hash self vec)
-  (let ((h      (make-hash-table))
-        (fields (sqltbl:tbl-get-fields self)))
-    (do ((i 0 (+ i 1)))
-        ((>= i (length fields)))
-      (hash-table-set! h (list-ref fields i)(vector-ref vec i)))
-    h))
-
-
-;; runs proc on each row and returns the resulting list
-(define (sqltbl:map self proc)
-  (map (lambda (row)
-         (proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self)))
-   
-)

Index: stml2.scm
==================================================================
--- stml2.scm
+++ stml2.scm
@@ -12,13 +12,13 @@
 ;; (declare (unit stml))
 
 (module stml2
     *
 
-(import chicken scheme data-structures extras srfi-13 ports )
+(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) 
 
-(use stmlcommon cookie misc-stml formdat session sqltbl keystore)
+(use cookie (prefix dbi dbi:) (prefix crypt c:))
 
 ;; (declare (uses misc-stml))
 (use regex)
 
 ;; extract various tokens from the parameter list
@@ -247,11 +247,11 @@
 
 (define (s:print indent inlst)
   (map (lambda (x)
          (cond 
           ((or (string? x)(symbol? x))
-           (print (conc (make-string (* indent 2) #\ ) (any->string 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?
            )))
@@ -285,8 +285,2186 @@
 		((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 model)
+  (session:model-path s:session model))
+
+;; share data between pages calls. NOTE: This is not persistent
+;; between cgi calls. Use sessionvars for that.
+;;
+(define (s:shared-hash)
+  (sdat-get-shared-hash s:session))
+
+(define (s:shared-set! key val)
+  (hash-table-set! (sdat-get-shared-hash s:session) key val))
+
+;; What to return when no value for key?
+;;
+(define (s:shared-get key)
+  (hash-table-ref/default (sdat-get-shared-hash s:session) key #f))
+
+;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
+;;  #### DEPRECATED ####
+(define (s:get-page-params)
+  (sdat-get-path-params s:session))
+
+(define (s:get-path-params)
+  (sdat-get-path-params s:session))
+	
+
+(define (s:db)
+  (sdat-get-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-inline (formdat:formdat-get-data   vec)    (vector-ref  vec 0))
+(define-inline (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))
+	       (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)))))
+
+;; (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))
+	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 (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))))
            
+(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-get-dbtype               vec)    (vector-ref  vec 0))
+(define (sdat-get-dbinit               vec)    (vector-ref  vec 1))
+(define (sdat-get-conn                 vec)    (vector-ref  vec 2))
+(define (sdat-get-pgconn               vec)    (vector-ref (vector-ref vec 2) 1))
+(define (sdat-get-params               vec)    (vector-ref  vec 3))
+(define (sdat-get-path-params          vec)    (vector-ref  vec 4))
+(define (sdat-get-session-key          vec)    (vector-ref  vec 5))
+(define (sdat-get-session-id           vec)    (vector-ref  vec 6))
+(define (sdat-get-domain               vec)    (vector-ref  vec 7))
+(define (sdat-get-toppage              vec)    (vector-ref  vec 8))
+(define (sdat-get-page                 vec)    (vector-ref  vec 9))
+(define (sdat-get-curr-page            vec)    (vector-ref  vec 10))
+(define (sdat-get-content-type         vec)    (vector-ref  vec 11))
+(define (sdat-get-page-type            vec)    (vector-ref  vec 12))
+(define (sdat-get-sroot                vec)    (vector-ref  vec 13))
+(define (sdat-get-twikidir             vec)    (vector-ref  vec 14))
+(define (sdat-get-pagedat              vec)    (vector-ref  vec 15))
+(define (sdat-get-alt-page-dat         vec)    (vector-ref  vec 16))
+(define (sdat-get-pagevars             vec)    (vector-ref  vec 17))
+(define (sdat-get-pagevars-before      vec)    (vector-ref  vec 18))
+(define (sdat-get-sessionvars          vec)    (vector-ref  vec 19))
+(define (sdat-get-sessionvars-before   vec)    (vector-ref  vec 20))
+(define (sdat-get-globalvars           vec)    (vector-ref  vec 21))
+(define (sdat-get-globalvars-before    vec)    (vector-ref  vec 22))
+(define (sdat-get-logpt                vec)    (vector-ref  vec 23))
+(define (sdat-get-formdat              vec)    (vector-ref  vec 24))
+(define (sdat-get-request-method       vec)    (vector-ref  vec 25))
+(define (sdat-get-session-cookie       vec)    (vector-ref  vec 26))
+(define (sdat-get-curr-err             vec)    (vector-ref  vec 27))
+(define (sdat-get-log-port             vec)    (vector-ref  vec 28))
+(define (sdat-get-logfile              vec)    (vector-ref  vec 29))
+(define (sdat-get-seen-pages           vec)    (vector-ref  vec 30))
+(define (sdat-get-page-dir-style       vec)    (vector-ref  vec 31))
+(define (sdat-get-debugmode            vec)    (vector-ref  vec 32))
+(define (sdat-get-shared-hash          vec)    (vector-ref  vec 33))
+(define (sdat-get-script               vec)    (vector-ref  vec 34))
+(define (sdat-get-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-set-dbtype!              vec val)(vector-set! vec 0 val))
+(define (sdat-set-dbinit!              vec val)(vector-set! vec 1 val))
+(define (sdat-set-conn!                vec val)(vector-set! vec 2 val))
+(define (sdat-set-params!              vec val)(vector-set! vec 3 val))
+(define (sdat-set-path-params!         vec val)(vector-set! vec 4 val))
+(define (sdat-set-session-key!         vec val)(vector-set! vec 5 val))
+(define (sdat-set-session-id!          vec val)(vector-set! vec 6 val))
+(define (sdat-set-domain!              vec val)(vector-set! vec 7 val))
+(define (sdat-set-toppage!             vec val)(vector-set! vec 8 val))
+(define (sdat-set-page!                vec val)(vector-set! vec 9 val))
+(define (sdat-set-curr-page!           vec val)(vector-set! vec 10 val))
+(define (sdat-set-content-type!        vec val)(vector-set! vec 11 val))
+(define (sdat-set-page-type!           vec val)(vector-set! vec 12 val))
+(define (sdat-set-sroot!               vec val)(vector-set! vec 13 val))
+(define (sdat-set-twikidir!            vec val)(vector-set! vec 14 val))
+(define (sdat-set-pagedat!             vec val)(vector-set! vec 15 val))
+(define (sdat-set-alt-page-dat!        vec val)(vector-set! vec 16 val))
+(define (sdat-set-pagevars!            vec val)(vector-set! vec 17 val))
+(define (sdat-set-pagevars-before!     vec val)(vector-set! vec 18 val))
+(define (sdat-set-sessionvars!         vec val)(vector-set! vec 19 val))
+(define (sdat-set-sessionvars-before!  vec val)(vector-set! vec 20 val))
+(define (sdat-set-globalvars!          vec val)(vector-set! vec 21 val))
+(define (sdat-set-globalvars-before!   vec val)(vector-set! vec 22 val))
+(define (sdat-set-logpt!               vec val)(vector-set! vec 23 val))
+(define (sdat-set-formdat!             vec val)(vector-set! vec 24 val))
+(define (sdat-set-request-method!      vec val)(vector-set! vec 25 val))
+(define (sdat-set-session-cookie!      vec val)(vector-set! vec 26 val))
+(define (sdat-set-curr-err!            vec val)(vector-set! vec 27 val))
+(define (sdat-set-log-port!            vec val)(vector-set! vec 28 val))
+(define (sdat-set-logfile!             vec val)(vector-set! vec 29 val))
+(define (sdat-set-seen-pages!          vec val)(vector-set! vec 30 val))
+(define (sdat-set-page-dir-style!      vec val)(vector-set! vec 31 val))
+(define (sdat-set-debugmode!           vec val)(vector-set! vec 32 val))
+(define (sdat-set-shared-hash!         vec val)(vector-set! vec 33 val))
+(define (sdat-set-script!              vec val)(vector-set! vec 34 val))
+(define (sdat-set-force-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)
+  (sdat-set-dbtype! self      'pg)
+  (sdat-set-page! self        "home")        ;; these are defaults
+  (sdat-set-curr-page! self   "home")
+  (sdat-set-content-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
+  (sdat-set-page-type! self   'html)
+  (sdat-set-toppage! self     "index")
+  (sdat-set-params! self      '())           ;;
+  (sdat-set-path-params! self '())
+  (sdat-set-session-key! self #f)
+  (sdat-set-pagedat! self     '())
+  (sdat-set-alt-page-dat! self #f)
+  (sdat-set-sroot! self       "./")
+  (sdat-set-session-cookie! self #f)
+  (sdat-set-curr-err! self #f)
+  (sdat-set-log-port! self (current-error-port))
+  (sdat-set-seen-pages! self '())
+  (sdat-set-page-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
+                                      ;; #f : pages/<pagename>/(view|control).scm 
+  (sdat-set-debugmode!          self #f)
+  			     
+  (sdat-set-pagevars!           self (make-hash-table))
+  (sdat-set-sessionvars!        self (make-hash-table))
+  (sdat-set-globalvars!         self (make-hash-table))
+  (sdat-set-pagevars-before!    self (make-hash-table))
+  (sdat-set-sessionvars-before! self (make-hash-table))
+  (sdat-set-globalvars-before!  self (make-hash-table))
+  (sdat-set-domain!             self "locahost")   ;; end of defaults
+  (sdat-set-script!             self #f)
+  (sdat-set-force-ssl!          self #f)
+  (let* ((rawconfigdat (session:read-config self))
+	 (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-set-sroot!    self sroot))
+    (if logfile  (sdat-set-logfile!  self logfile))
+    (if dbtype   (sdat-set-dbtype!   self dbtype))
+    (if dbinit   (sdat-set-dbinit!   self dbinit))
+    (if domain   (sdat-set-domain!   self domain))
+    (if twikidir (sdat-set-twikidir! self twikidir))
+    (if debugmode (sdat-set-debugmode! self debugmode))
+    (if script    (sdat-set-script!    self script))
+    (if force-ssl (sdat-set-force-ssl! self force-ssl))
+    (sdat-set-page-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-set-shared-hash! self (make-hash-table))
+  )
+
+;; Used for the strangely inconsistent handling of the config file. A better way is needed.
+;;
+;;   (let ((dbtype (sdat-get-dbtype self)))
+;;     (print "dbtype: " dbtype)
+;;     (sdat-set-dbtype! self (eval dbtype))))
+
+(define (session:setup self)
+  (let ((dbtype    (sdat-get-dbtype self))
+	(debugmode (sdat-get-debugmode self))
+	(dbinit    (eval (sdat-get-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-set-conn! self (dbi:open dbtype dbinit))
+    (set! *db* (sdat-get-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-set-request-method! self (get-environment-variable "REQUEST_METHOD"))
+    (sdat-set-formdat! self (formdat:load-all))))
+
+;; setup the db with session tables, works for sqlite only right now
+(define (session:setup-db self)
+  (let ((conn (sdat-get-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-set-session-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-set-session-key! self new-key)
+          (sdat-set-session-id! self new-sid)
+          (sdat-set-session-cookie! self (session:make-cookie self)))
+        (sdat-set-session-id! self sid))))
+
+(define (session:make-cookie self)
+  ;; (list (conc "session_key=" (sdat-get-session-key self) "; Path=/; Domain=." (sdat-get-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-get-session-key self)
+		  expires: ,(+ (current-seconds) (* 14 86400)) 
+		  ;; max-age: (* 14 86400)
+		  path: "/" ;; 
+		  domain: ,(string-append "." (sdat-get-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-get-session-key self)))
+  (if session-key
+      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
+            (conn (sdat-get-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-set-page! self (car parts)))
+	  ;; (session:log self "url-path=" url-path " parts=" parts)
+	  (if (> numparts 1)
+	      (sdat-set-path-params! self (cdr parts)))
+          (if query-string
+              (sdat-set-params! self (string-split query-string "&")))))))
+
+;; BUGGY!
+(define (session:get-new-key self)
+  (let ((conn   (sdat-get-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-get-conn self))
+    ;;                        conn)
+    (dbi:for-each-row (lambda (tuple)
+			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
+		      (sdat-get-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-get-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-get-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-get-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-set-session-key! self (list-ref match 1))
+		session-key))
+	     ((null? tail)
+	      #f)
+	     (else
+	      (loop (car tail)
+		    (cdr tail)))))))))
+
+(define (session:set-page! self page_name)
+  (sdat-set-page! self page_name))
+
+(define (session:close self)
+  (dbi:close (sdat-get-conn self)))
+;; (close-output-port (sdat-get-logpt self))
+
+(define (session:err-msg self msg)
+  (hash-table-set! (sdat-get-sessionvars self) "ERROR_MSG"
+		   (string-intersperse (map s:any->string msg) " ")))
+
+(define (session:prev-err self)
+  (let ((prev-err (hash-table-ref/default (sdat-get-sessionvars-before self) "ERROR_MSG" #f))
+	(curr-err (hash-table-ref/default (sdat-get-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-get-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-get-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-get-sessionvars self)
+      (if (string=? page "*globalvars*")
+	  (sdat-get-globalvars self)
+	  (sdat-get-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-get-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-get-session-id self)))
+    (if (not session-id)
+	(err:log "ERROR: No session id in session object! session:get-vars")
+	(let* ((result             #f)
+	       (conn               (sdat-get-conn self))
+	       (pagevars-before    (sdat-get-pagevars-before self))
+	       (sessionvars-before (sdat-get-sessionvars-before self))
+	       (globalvars-before  (sdat-get-globalvars-before self))
+	       (pagevars           (sdat-get-pagevars self))
+	       (sessionvars        (sdat-get-sessionvars self))
+	       (globalvars         (sdat-get-globalvars self))
+	       (page-name          (sdat-get-page self))
+	       (session-key        (sdat-get-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-get-session-id self)))
+    (if (not session-id)
+	(err:log "ERROR: No session id in session object! session:get-vars")
+	(let* ((status      #f)
+	       (conn        (sdat-get-conn self))
+	       (page-name   (sdat-get-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-get-sessionvars self)
+					       (sdat-get-sessionvars-before self)))
+				       ((string=? page "*globalvars*")
+					(vector (sdat-get-globalvars self)
+						(sdat-get-globalvars-before self)))
+				       (else 
+					(vector (sdat-get-pagevars self)
+						(sdat-get-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)
+  (let* ((cgi-path (pathname-directory (car (argv))))
+         (name     (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 defence 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-set-curr-page! self page)
+  (let* ((dir-style    (sdat-get-page-dir-style self));; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
+	 (dir          (string-append (sdat-get-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-get-conn self)         ;; the db connection
+	(sdat-get-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-get-conn self)         ;; the db connection
+		(sdat-get-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 ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
+;; 	(model.so  (string-append (sdat-get-sroot self) "/models/" 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 model)
+;;   (string-append (sdat-get-sroot self) "/models/" model ".scm"))
+
+(define (session:pp-formdat self)
+  (let ((dat (formdat:all->strings (sdat-get-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-get-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-get-domain self)))
+         (force-script  (sdat-get-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-get-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-get-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
+	 (header   (let ((cookie (sdat-get-session-cookie self)))
+		     (if cookie
+			 (cons (string-append "Set-Cookie: " (car cookie))
+			       content)
+			 content)))
+	 (pagedat  (sdat-get-pagedat self)))
+    (s:cgi-out 
+     (cons header pagedat))))
+
+(define (session:log self . msg)
+  (with-output-to-port (sdat-get-log-port self) ;; (sdat-get-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-get-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-get-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-get-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-get-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-get-seen-pages self))))
+
+(define (session:set-called! self page)
+  (sdat-set-seen-pages! self (cons page (sdat-get-seen-pages self))))
+
+;;======================================================================
+;; Alternative data type delivery
+;;======================================================================
+
+(define (session:alt-out self)
+  (let ((dat (sdat-get-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-get-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-get-curr-err s:session)))
+    (if errmsg ((if wrapperfunc
+                    wrapperfunc
+                    s:strong) errmsg) '())))
+(define (stml:cgi-session session)
+  (session:initialize session)
+  (session:setup session)
+  (session:get-vars session)
+
+  (sdat-set-log-port! session ;; (current-error-port))
+		      (open-output-file (sdat-get-logfile session) #:append))
+  (s:validate-inputs)
+  (session:run-actions session)
+  (sdat-set-pagedat! session
+		     (append (sdat-get-pagedat session)
+			     (s:call (sdat-get-toppage session))))
+  (if (eq? (sdat-get-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)
+  (handle-exceptions
+   exn   
+   (if (sdat-get-debugmode 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-get-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))
+ ;; (raise-error)
+ ;; (exit)
+   ))
+
+;; find out if we are in debugmode
+(define (s:debug-mode?)
+  (sdat-get-debugmode s:session))
+
+(define (s:never-called-page? page)
+  (session:never-called-page? s:session page))
+
+(define (s:set-err . args)
+  (sdat-set-curr-err! s:session args))
+
+(define (s:current-page)
+  (sdat-get-page s:session))
+
+(define (s:delete-session)
+  (session:delete-session s:session (sdat-get-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 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-get-sessionvars s:session))
+
+
 
 )

Index: stml2.setup
==================================================================
--- stml2.setup
+++ stml2.setup
@@ -2,28 +2,31 @@
 ;;
 ;;  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
+;;  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 'misc-stml    "0.5") ;; moved to stmlcommon.scm
-(standard-extension 'html-filter  "0.5")
-(standard-extension 'formdat      "0.5")
-(standard-extension 'session      "0.5")
-(standard-extension 'setup        "0.5")
-(standard-extension 'sqltbl       "0.5")
-(standard-extension 'keystore     "0.5")
-(standard-extension 'stmlcommon   "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")
 

Index: stmlcommon.scm
==================================================================
--- stmlcommon.scm
+++ stmlcommon.scm
@@ -11,323 +11,10 @@
 ;; (declare (run-time-macros))
 
 (module stmlcommon
     *
 
-(import  chicken scheme data-structures extras srfi-13 ports )
-
-(use cookie misc-stml formdat session sqltbl keystore)
-
-(include "requirements.scm")
-
-;;(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))
-
-(define (stml:cgi-session session)
-  (session:initialize session)
-  (session:setup session)
-  (session:get-vars session)
-
-  (sdat-set-log-port! session ;; (current-error-port))
-		      (open-output-file (sdat-get-logfile session) #:append))
-  (s:validate-inputs)
-  (session:run-actions session)
-  (sdat-set-pagedat! session
-		     (append (sdat-get-pagedat session)
-			     (s:call (sdat-get-toppage session))))
-  (if (eq? (sdat-get-page-type session) 'html) ;; default is html. 
-      (session:cgi-out session)
-      (session:alt-out session))
-  (session:save-vars session)
-  (session:close session))
-
-(define (stml:main proc)
-  (handle-exceptions
-   exn   
-   (if (sdat-get-debugmode 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-get-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))
- ;; (raise-error)
- ;; (exit)
-   ))
-
-;; 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"))
-
-(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)))))))
-
-;; 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
-	  (s:log "REQUEST URI NOT AVAILABLE!")
-	  (let ((p (open-input-pipe "env")))
-	    (let loop ((l (read-line p))
-		       (res '()))
-	      (if (eof-object? l)
-		  (s:log res)
-		  (loop (read-line p)(cons (list l "<BR>") res)))))
-	  #t))))
-
-(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))))
-
-;; 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))
-
+(import  chicken scheme data-structures extras srfi-13 ports posix)
+
+(use (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)
 
 )