0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 7-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 73 74 6d PURPOSE...;; stm
0150: 6c 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 68 l is a list of h
0160: 74 6d 6c 20 73 74 72 69 6e 67 73 0a 0a 3b 3b 20 tml strings..;;
0170: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 73 (declare (unit s
0180: 74 6d 6c 29 29 0a 0a 28 6d 6f 64 75 6c 65 20 73 tml))..(module s
0190: 74 6d 6c 32 0a 20 20 20 20 2a 0a 0a 28 69 6d 70 tml2. *..(imp
01a0: 6f 72 74 20 63 68 69 63 6b 65 6e 20 73 63 68 65 ort chicken sche
01b0: 6d 65 20 64 61 74 61 2d 73 74 72 75 63 74 75 72 me data-structur
01c0: 65 73 20 65 78 74 72 61 73 20 73 72 66 69 2d 31 es extras srfi-1
01d0: 33 20 70 6f 72 74 73 20 70 6f 73 69 78 20 73 72 3 ports posix sr
01e0: 66 69 2d 36 39 20 66 69 6c 65 73 20 73 72 66 69 fi-69 files srfi
01f0: 2d 31 29 20 0a 0a 28 75 73 65 20 63 6f 6f 6b 69 -1) ..(use cooki
0200: 65 20 28 70 72 65 66 69 78 20 64 62 69 20 64 62 e (prefix dbi db
0210: 69 3a 29 20 28 70 72 65 66 69 78 20 63 72 79 70 i:) (prefix cryp
0220: 74 20 63 3a 29 20 74 79 70 65 64 2d 72 65 63 6f t c:) typed-reco
0230: 72 64 73 29 0a 0a 3b 3b 20 28 64 65 63 6c 61 72 rds)..;; (declar
0240: 65 20 28 75 73 65 73 20 6d 69 73 63 2d 73 74 6d e (uses misc-stm
0250: 6c 29 29 0a 28 75 73 65 20 72 65 67 65 78 29 0a l)).(use regex).
0260: 0a 3b 3b 20 54 68 65 20 28 75 73 75 61 6c 6c 79 .;; The (usually
0270: 20 67 6c 6f 62 61 6c 29 20 73 64 61 74 20 63 6f global) sdat co
0280: 6e 74 61 69 6e 73 20 65 76 65 72 79 74 68 69 6e ntains everythin
0290: 67 20 61 62 6f 75 74 20 74 68 65 20 73 65 73 73 g about the sess
02a0: 69 6f 6e 0a 3b 3b 0a 28 64 65 66 73 74 72 75 63 ion.;;.(defstruc
02b0: 74 20 73 64 61 74 0a 20 20 28 64 62 74 79 70 65 t sdat. (dbtype
02c0: 20 27 70 67 29 0a 20 20 28 64 62 69 6e 69 74 20 'pg). (dbinit
02d0: 23 66 29 0a 20 20 28 63 6f 6e 6e 20 20 20 23 66 #f). (conn #f
02e0: 29 0a 20 20 28 70 61 67 65 20 22 68 6f 6d 65 22 ). (page "home"
02f0: 29 0a 20 20 28 70 61 67 65 2d 74 79 70 65 20 27 ). (page-type '
0300: 68 74 6d 6c 29 0a 20 20 28 74 6f 70 70 61 67 65 html). (toppage
0310: 20 22 69 6e 64 65 78 22 29 0a 20 20 28 63 6f 6e "index"). (con
0320: 74 65 6e 74 2d 74 79 70 65 20 22 43 6f 6e 74 65 tent-type "Conte
0330: 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 nt-type: text/ht
0340: 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d ml; charset=iso-
0350: 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 8859-1\n\n"). (
0360: 66 6f 72 6d 64 61 74 20 20 20 20 20 20 23 66 29 formdat #f)
0370: 0a 20 20 28 70 61 72 61 6d 73 20 27 28 29 29 0a . (params '()).
0380: 20 20 28 70 61 74 68 2d 70 61 72 61 6d 73 20 27 (path-params '
0390: 28 29 29 0a 20 20 28 73 65 73 73 69 6f 6e 2d 6b ()). (session-k
03a0: 65 79 20 23 66 29 0a 20 20 28 70 61 67 65 64 61 ey #f). (pageda
03b0: 74 20 20 20 20 20 27 28 29 29 0a 20 20 28 63 75 t '()). (cu
03c0: 72 72 2d 70 61 67 65 20 20 20 20 22 68 6f 6d 65 rr-page "home
03d0: 22 29 0a 20 20 28 61 6c 74 2d 70 61 67 65 2d 64 "). (alt-page-d
03e0: 61 74 20 23 66 29 0a 20 20 28 73 72 6f 6f 74 20 at #f). (sroot
03f0: 20 20 20 20 20 20 20 20 22 2e 2f 22 29 0a 20 20 "./").
0400: 28 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 (session-cookie
0410: 23 66 29 0a 20 20 28 63 75 72 72 2d 65 72 72 20 #f). (curr-err
0420: 20 20 20 20 20 20 23 66 29 0a 20 20 28 6c 6f 67 #f). (log
0430: 2d 70 6f 72 74 20 20 20 20 20 20 20 28 63 75 72 -port (cur
0440: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
0450: 29 0a 20 20 28 6c 6f 67 66 69 6c 65 20 20 20 20 ). (logfile
0460: 20 20 20 20 22 2f 74 6d 70 2f 73 74 6d 6c 2e 6c "/tmp/stml.l
0470: 6f 67 22 29 0a 20 20 28 73 65 65 6e 2d 70 61 67 og"). (seen-pag
0480: 65 73 20 20 20 20 20 27 28 29 29 0a 20 20 28 70 es '()). (p
0490: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 23 age-dir-style #
04a0: 74 29 0a 20 20 28 64 65 62 75 67 2d 6d 6f 64 65 t). (debug-mode
04b0: 20 20 20 20 20 20 23 66 29 0a 20 20 28 73 65 73 #f). (ses
04c0: 73 69 6f 6e 2d 69 64 20 20 20 20 20 20 23 66 29 sion-id #f)
04d0: 0a 20 20 28 70 61 67 65 76 61 72 73 20 20 20 20 . (pagevars
04e0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
04f0: 61 62 6c 65 29 29 0a 20 20 28 70 61 67 65 76 61 able)). (pageva
0500: 72 73 2d 62 65 66 6f 72 65 20 28 6d 61 6b 65 2d rs-before (make-
0510: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
0520: 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
0530: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0540: 29 29 0a 20 20 28 73 65 73 73 69 6f 6e 76 61 72 )). (sessionvar
0550: 73 2d 62 65 66 6f 72 65 20 28 6d 61 6b 65 2d 68 s-before (make-h
0560: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 67 ash-table)). (g
0570: 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 28 lobalvars (
0580: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0590: 29 0a 20 20 28 67 6c 6f 62 61 6c 76 61 72 73 2d ). (globalvars-
05a0: 62 65 66 6f 72 65 20 28 6d 61 6b 65 2d 68 61 73 before (make-has
05b0: 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 72 65 71 h-table)). (req
05c0: 75 65 73 74 2d 6d 65 74 68 6f 64 20 20 23 66 29 uest-method #f)
05d0: 0a 20 20 28 64 6f 6d 61 69 6e 20 20 20 20 20 20 . (domain
05e0: 20 20 20 20 22 6c 6f 63 61 6c 68 6f 73 74 22 29 "localhost")
05f0: 0a 20 20 28 74 77 69 6b 69 64 69 72 20 20 20 20 . (twikidir
0600: 20 20 20 20 23 66 29 0a 20 20 28 73 63 72 69 70 #f). (scrip
0610: 74 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 t #f).
0620: 20 28 66 6f 72 63 65 2d 73 73 6c 20 20 20 20 20 (force-ssl
0630: 20 20 23 66 29 0a 20 20 28 73 68 61 72 65 64 2d #f). (shared-
0640: 68 61 73 68 20 20 20 20 20 28 6d 61 6b 65 2d 68 hash (make-h
0650: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a 28 64 ash-table)))..(d
0660: 65 66 69 6e 65 20 28 61 70 70 6c 79 2d 63 6f 6e efine (apply-con
0670: 66 69 67 2d 66 69 6c 65 20 73 65 73 73 69 6f 6e fig-file session
0680: 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 63 6f 6e #!optional (con
0690: 66 69 67 66 20 23 66 29 29 0a 20 20 28 6c 65 74 figf #f)). (let
06a0: 2a 20 28 28 72 61 77 63 6f 6e 66 69 67 64 61 74 * ((rawconfigdat
06b0: 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 (session:read-c
06c0: 6f 6e 66 69 67 20 73 65 73 73 69 6f 6e 20 63 6f onfig session co
06d0: 6e 66 69 67 66 29 29 0a 09 20 28 63 6f 6e 66 69 nfigf)).. (confi
06e0: 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e 66 gdat (if rawconf
06f0: 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 63 igdat (eval rawc
0700: 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 0a onfigdat) '())).
0710: 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 3a . (sroot (s:
0720: 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f 6f find-param 'sroo
0730: 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 t configdat))
0740: 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 73 .. (logfile (s
0750: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f 67 :find-param 'log
0760: 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 29 file configdat)
0770: 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 28 ).. (dbtype (
0780: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 s:find-param 'db
0790: 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 74 type configdat
07a0: 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 20 )).. (dbinit
07b0: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
07c0: 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 61 binit configda
07d0: 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 20 t)).. (domain
07e0: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
07f0: 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 64 domain configd
0800: 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 72 at)).. (twikidir
0810: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
0820: 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 67 'twikidir config
0830: 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 69 dat)).. (page-di
0840: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
0850: 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 'page-dir-style
0860: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
0870: 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 6e debugmode (s:fin
0880: 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d 6f d-param 'debugmo
0890: 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 20 de configdat)).
08a0: 20 20 20 20 20 20 20 20 28 73 63 72 69 70 74 20 (script
08b0: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
08c0: 20 27 73 63 72 69 70 74 20 20 20 20 63 6f 6e 66 'script conf
08d0: 69 67 64 61 74 29 29 0a 09 20 28 66 6f 72 63 65 igdat)).. (force
08e0: 2d 73 73 6c 20 28 73 3a 66 69 6e 64 2d 70 61 72 -ssl (s:find-par
08f0: 61 6d 20 27 66 6f 72 63 65 2d 73 73 6c 20 63 6f am 'force-ssl co
0900: 6e 66 69 67 64 61 74 29 29 29 0a 20 20 20 20 28 nfigdat))). (
0910: 69 66 20 73 72 6f 6f 74 20 20 20 20 28 73 64 61 if sroot (sda
0920: 74 2d 73 72 6f 6f 74 2d 73 65 74 21 20 20 20 20 t-sroot-set!
0930: 20 20 73 65 73 73 69 6f 6e 20 73 72 6f 6f 74 29 session sroot)
0940: 29 0a 20 20 20 20 28 69 66 20 6c 6f 67 66 69 6c ). (if logfil
0950: 65 20 20 28 73 64 61 74 2d 6c 6f 67 66 69 6c 65 e (sdat-logfile
0960: 2d 73 65 74 21 20 20 20 20 73 65 73 73 69 6f 6e -set! session
0970: 20 6c 6f 67 66 69 6c 65 29 29 0a 20 20 20 20 28 logfile)). (
0980: 69 66 20 64 62 74 79 70 65 20 20 20 28 73 64 61 if dbtype (sda
0990: 74 2d 64 62 74 79 70 65 2d 73 65 74 21 20 20 20 t-dbtype-set!
09a0: 20 20 73 65 73 73 69 6f 6e 20 64 62 74 79 70 65 session dbtype
09b0: 29 29 0a 20 20 20 20 28 69 66 20 64 62 69 6e 69 )). (if dbini
09c0: 74 20 20 20 28 73 64 61 74 2d 64 62 69 6e 69 74 t (sdat-dbinit
09d0: 2d 73 65 74 21 20 20 20 20 20 73 65 73 73 69 6f -set! sessio
09e0: 6e 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 n dbinit)). (
09f0: 69 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 64 61 if domain (sda
0a00: 74 2d 64 6f 6d 61 69 6e 2d 73 65 74 21 20 20 20 t-domain-set!
0a10: 20 20 73 65 73 73 69 6f 6e 20 64 6f 6d 61 69 6e session domain
0a20: 29 29 0a 20 20 20 20 28 69 66 20 74 77 69 6b 69 )). (if twiki
0a30: 64 69 72 20 28 73 64 61 74 2d 74 77 69 6b 69 64 dir (sdat-twikid
0a40: 69 72 2d 73 65 74 21 20 20 20 73 65 73 73 69 6f ir-set! sessio
0a50: 6e 20 74 77 69 6b 69 64 69 72 29 29 0a 20 20 20 n twikidir)).
0a60: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
0a70: 73 64 61 74 2d 64 65 62 75 67 2d 6d 6f 64 65 2d sdat-debug-mode-
0a80: 73 65 74 21 20 73 65 73 73 69 6f 6e 20 64 65 62 set! session deb
0a90: 75 67 6d 6f 64 65 29 29 0a 20 20 20 20 28 69 66 ugmode)). (if
0aa0: 20 73 63 72 69 70 74 20 20 20 20 28 73 64 61 74 script (sdat
0ab0: 2d 73 63 72 69 70 74 2d 73 65 74 21 20 20 20 20 -script-set!
0ac0: 73 65 73 73 69 6f 6e 20 73 63 72 69 70 74 29 29 session script))
0ad0: 0a 20 20 20 20 28 69 66 20 66 6f 72 63 65 2d 73 . (if force-s
0ae0: 73 6c 20 28 73 64 61 74 2d 66 6f 72 63 65 2d 73 sl (sdat-force-s
0af0: 73 6c 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 20 sl-set! session
0b00: 66 6f 72 63 65 2d 73 73 6c 29 29 0a 20 20 20 20 force-ssl)).
0b10: 28 73 64 61 74 2d 70 61 67 65 2d 64 69 72 2d 73 (sdat-page-dir-s
0b20: 74 79 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f tyle-set! sessio
0b30: 6e 20 70 61 67 65 2d 64 69 72 29 0a 20 20 20 20 n page-dir).
0b40: 3b 3b 20 28 70 72 69 6e 74 20 22 63 6f 6e 66 69 ;; (print "confi
0b50: 67 64 61 74 3a 20 22 29 28 70 70 20 63 6f 6e 66 gdat: ")(pp conf
0b60: 69 67 64 61 74 29 0a 20 20 20 20 28 69 66 20 64 igdat). (if d
0b70: 65 62 75 67 6d 6f 64 65 0a 09 28 73 65 73 73 69 ebugmode..(sessi
0b80: 6f 6e 3a 6c 6f 67 20 73 65 73 73 69 6f 6e 20 22 on:log session "
0b90: 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f 74 20 22 sroot: " sroot "
0ba0: 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c 6f 67 66 logfile: " logf
0bb0: 69 6c 65 20 22 20 64 62 74 79 70 65 3a 20 22 20 ile " dbtype: "
0bc0: 64 62 74 79 70 65 20 0a 09 09 20 20 20 20 20 22 dbtype ... "
0bd0: 20 64 62 69 6e 69 74 3a 20 22 20 64 62 69 6e 69 dbinit: " dbini
0be0: 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 20 64 6f t " domain: " do
0bf0: 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 69 72 2d main " page-dir-
0c00: 73 74 79 6c 65 3a 20 22 20 70 61 67 65 2d 64 69 style: " page-di
0c10: 72 29 29 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 65 r)). ))..;; e
0c20: 78 74 72 61 63 74 20 76 61 72 69 6f 75 73 20 74 xtract various t
0c30: 6f 6b 65 6e 73 20 66 72 6f 6d 20 74 68 65 20 70 okens from the p
0c40: 61 72 61 6d 65 74 65 72 20 6c 69 73 74 0a 3b 3b arameter list.;;
0c50: 20 20 20 27 6b 65 79 20 76 61 6c 20 3d 3e 20 70 'key val => p
0c60: 75 74 20 69 6e 20 74 68 65 20 70 61 72 61 6d 73 ut in the params
0c70: 20 6c 69 73 74 0a 3b 3b 20 20 20 73 74 72 69 6e list.;; strin
0c80: 67 73 20 20 3d 3e 20 6d 61 69 6e 74 61 69 6e 20 gs => maintain
0c90: 6f 72 64 65 72 20 61 6e 64 20 61 64 64 20 74 6f order and add to
0ca0: 20 74 68 65 20 64 61 74 61 6c 69 73 74 20 3c 3c the datalist <<
0cb0: 3d 3d 20 49 4d 50 4f 52 54 41 4e 54 0a 28 64 65 == IMPORTANT.(de
0cc0: 66 69 6e 65 20 28 73 3a 65 78 74 72 61 63 74 20 fine (s:extract
0cd0: 69 6e 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 inlst). (if (nu
0ce0: 6c 6c 3f 20 69 6e 6c 73 74 29 20 69 6e 6c 73 74 ll? inlst) inlst
0cf0: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
0d00: 20 28 28 64 61 74 61 20 27 28 29 29 0a 20 20 20 ((data '()).
0d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
0d20: 61 72 61 6d 73 20 27 28 29 29 0a 20 20 20 20 20 arams '()).
0d30: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 65 61 (hea
0d40: 64 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 20 d (car inlst)).
0d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d60: 28 74 61 69 6c 20 28 63 64 72 20 69 6e 6c 73 74 (tail (cdr inlst
0d70: 29 29 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 28 ))). ;; (
0d80: 70 72 69 6e 74 20 22 68 65 61 64 3d 22 20 68 65 print "head=" he
0d90: 61 64 20 22 20 74 61 69 6c 3d 22 20 74 61 69 6c ad " tail=" tail
0da0: 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 64 20 ). (cond
0db0: 0a 20 20 20 20 20 20 20 20 20 28 28 6e 75 6c 6c . ((null
0dc0: 3f 20 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 ? tail).
0dd0: 20 20 28 69 66 20 28 73 79 6d 62 6f 6c 3f 20 68 (if (symbol? h
0de0: 65 61 64 29 20 3b 3b 20 74 68 65 20 6c 61 73 74 ead) ;; the last
0df0: 20 69 74 65 6d 20 69 73 20 61 20 70 61 72 61 6d item is a param
0e00: 20 2d 20 62 6f 72 6b 65 64 0a 20 20 20 20 20 20 - borked.
0e10: 20 20 20 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 (s:log "
0e20: 45 52 52 4f 52 3a 20 70 61 72 61 6d 20 77 69 74 ERROR: param wit
0e30: 68 20 6e 6f 20 76 61 6c 75 65 22 29 29 0a 20 20 h no value")).
0e40: 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 61 (list (a
0e50: 70 70 65 6e 64 20 64 61 74 61 20 28 6c 69 73 74 ppend data (list
0e60: 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
0e70: 68 65 61 64 29 29 29 20 70 61 72 61 6d 73 29 29 head))) params))
0e80: 0a 20 20 20 20 20 20 20 20 20 28 28 6f 72 20 28 . ((or (
0e90: 73 74 72 69 6e 67 3f 20 68 65 61 64 29 28 6c 69 string? head)(li
0ea0: 73 74 3f 20 68 65 61 64 29 28 6e 75 6d 62 65 72 st? head)(number
0eb0: 3f 20 68 65 61 64 29 29 0a 20 20 20 20 20 20 20 ? head)).
0ec0: 20 20 20 28 6c 6f 6f 70 20 28 61 70 70 65 6e 64 (loop (append
0ed0: 20 64 61 74 61 20 28 6c 69 73 74 20 20 28 73 3a data (list (s:
0ee0: 61 6e 79 2d 3e 73 74 72 69 6e 67 20 68 65 61 64 any->string head
0ef0: 29 29 29 20 70 61 72 61 6d 73 20 28 63 61 72 20 ))) params (car
0f00: 74 61 69 6c 29 20 20 20 28 63 64 72 20 74 61 69 tail) (cdr tai
0f10: 6c 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 l))). ((
0f20: 73 79 6d 62 6f 6c 3f 20 68 65 61 64 29 0a 20 20 symbol? head).
0f30: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e (let ((n
0f40: 65 77 2d 70 61 72 61 6d 73 20 28 63 6f 6e 73 20 ew-params (cons
0f50: 28 6c 69 73 74 20 68 65 61 64 20 28 63 61 72 20 (list head (car
0f60: 74 61 69 6c 29 29 20 70 61 72 61 6d 73 29 29 0a tail)) params)).
0f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f80: 28 6e 65 77 2d 74 61 69 6c 20 20 28 63 64 72 20 (new-tail (cdr
0f90: 74 61 69 6c 29 29 29 0a 20 20 20 20 20 20 20 20 tail))).
0fa0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6e (if (null? n
0fb0: 65 77 2d 74 61 69 6c 29 20 3b 3b 20 77 65 20 61 ew-tail) ;; we a
0fc0: 72 65 20 64 6f 6e 65 2c 20 6e 6f 20 6d 6f 72 65 re done, no more
0fd0: 20 70 61 72 61 6d 73 20 65 74 63 2e 0a 20 20 20 params etc..
0fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
0ff0: 73 74 20 64 61 74 61 20 6e 65 77 2d 70 61 72 61 st data new-para
1000: 6d 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ms).
1010: 20 20 20 20 28 6c 6f 6f 70 20 64 61 74 61 20 6e (loop data n
1020: 65 77 2d 70 61 72 61 6d 73 20 28 63 61 72 20 6e ew-params (car n
1030: 65 77 2d 74 61 69 6c 29 28 63 64 72 20 6e 65 77 ew-tail)(cdr new
1040: 2d 74 61 69 6c 29 29 29 29 29 0a 20 20 20 20 20 -tail))))).
1050: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
1060: 20 20 20 20 28 73 3a 6c 6f 67 20 22 57 41 52 4e (s:log "WARN
1070: 49 4e 47 3a 20 4d 61 6c 66 6f 72 6d 65 64 20 69 ING: Malformed i
1080: 6e 70 75 74 2c 20 79 6f 75 20 68 61 76 65 20 62 nput, you have b
1090: 72 6f 6b 65 6e 20 73 74 6d 6c 2c 20 72 65 6d 65 roken stml, reme
10a0: 6d 62 65 72 20 74 68 61 74 20 61 6c 6c 20 73 74 mber that all st
10b0: 6d 6c 20 63 61 6c 6c 73 20 73 68 6f 75 6c 64 20 ml calls should
10c0: 72 65 74 75 72 6e 20 61 20 72 65 73 75 6c 74 20 return a result
10d0: 28 6e 75 6c 6c 20 6c 69 73 74 20 6f 72 20 65 6d (null list or em
10e0: 70 74 79 20 73 74 72 69 6e 67 20 69 73 20 6f 6b pty string is ok
10f0: 29 3a 5c 6e 20 20 68 65 61 64 3d 22 20 68 65 61 ):\n head=" hea
1100: 64 20 0a 09 20 20 20 20 20 20 20 20 20 20 22 5c d .. "\
1110: 6e 20 20 74 61 69 6c 3d 22 20 74 61 69 6c 20 0a n tail=" tail .
1120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1130: 20 20 22 5c 6e 20 20 69 6e 6c 73 74 3d 22 20 69 "\n inlst=" i
1140: 6e 6c 73 74 20 0a 20 20 20 20 20 20 20 20 20 20 nlst .
1150: 20 20 20 20 20 20 20 20 22 5c 6e 20 20 70 61 72 "\n par
1160: 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 09 20 ams=" params)..
1170: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c (if (null? tail
1180: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 64 ).. (list d
1190: 61 74 61 20 70 61 72 61 6d 73 29 0a 09 20 20 20 ata params)..
11a0: 20 20 20 28 6c 6f 6f 70 20 64 61 74 61 20 70 61 (loop data pa
11b0: 72 61 6d 73 20 28 63 61 72 20 74 61 69 6c 29 28 rams (car tail)(
11c0: 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 29 cdr tail))))))))
11d0: 0a 0a 3b 3b 20 6d 6f 73 74 20 74 61 67 73 20 63 ..;; most tags c
11e0: 61 6e 20 62 65 20 68 61 6e 64 6c 65 64 20 62 79 an be handled by
11f0: 20 74 68 69 73 20 72 6f 75 74 69 6e 65 0a 28 64 this routine.(d
1200: 65 66 69 6e 65 20 28 73 3a 63 6f 6d 6d 6f 6e 2d efine (s:common-
1210: 74 61 67 20 74 61 67 6e 61 6d 65 20 61 72 67 73 tag tagname args
1220: 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 6e 70 75 ). (let* ((inpu
1230: 74 73 20 28 73 3a 65 78 74 72 61 63 74 20 61 72 ts (s:extract ar
1240: 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 64 gs)). (d
1250: 61 74 61 20 20 20 28 63 61 72 20 69 6e 70 75 74 ata (car input
1260: 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 61 s)). (pa
1270: 72 61 6d 73 20 28 73 3a 70 72 6f 63 65 73 73 2d rams (s:process-
1280: 70 61 72 61 6d 73 20 28 63 61 64 72 20 69 6e 70 params (cadr inp
1290: 75 74 73 29 29 29 29 0a 20 20 20 20 28 6c 69 73 uts)))). (lis
12a0: 74 20 28 63 6f 6e 63 20 22 3c 22 20 74 61 67 6e t (conc "<" tagn
12b0: 61 6d 65 20 70 61 72 61 6d 73 20 22 3e 22 29 0a ame params ">").
12c0: 20 20 20 20 20 20 20 20 20 20 64 61 74 61 0a 20 data.
12d0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 (conc "
12e0: 3c 2f 22 20 74 61 67 6e 61 6d 65 20 22 3e 22 29 </" tagname ">")
12f0: 29 29 29 0a 0a 3b 3b 20 53 75 67 67 65 73 74 69 )))..;; Suggesti
1300: 6f 6e 3a 20 6f 72 64 65 72 20 74 68 65 73 65 20 on: order these
1310: 61 6c 70 68 61 62 65 74 69 63 61 6c 6c 79 0a 28 alphabetically.(
1320: 64 65 66 69 6e 65 20 28 73 3a 61 20 20 20 20 20 define (s:a
1330: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1340: 6f 6e 2d 74 61 67 20 22 41 22 20 20 20 20 20 20 on-tag "A"
1350: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1360: 73 3a 62 20 20 20 20 20 20 2e 20 61 72 67 73 29 s:b . args)
1370: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1380: 42 22 20 20 20 20 20 20 61 72 67 73 29 29 0a 28 B" args)).(
1390: 64 65 66 69 6e 65 20 28 73 3a 75 20 20 20 20 20 define (s:u
13a0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
13b0: 6f 6e 2d 74 61 67 20 22 55 22 20 20 20 20 20 20 on-tag "U"
13c0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
13d0: 73 3a 62 69 67 20 20 20 20 2e 20 61 72 67 73 29 s:big . args)
13e0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
13f0: 42 49 47 22 20 20 20 20 61 72 67 73 29 29 0a 28 BIG" args)).(
1400: 64 65 66 69 6e 65 20 28 73 3a 62 6f 64 79 20 20 define (s:body
1410: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1420: 6f 6e 2d 74 61 67 20 22 42 4f 44 59 22 20 20 20 on-tag "BODY"
1430: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1440: 73 3a 62 75 74 74 6f 6e 20 2e 20 61 72 67 73 29 s:button . args)
1450: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1460: 42 55 54 54 4f 4e 22 20 61 72 67 73 29 29 0a 28 BUTTON" args)).(
1470: 64 65 66 69 6e 65 20 28 73 3a 63 65 6e 74 65 72 define (s:center
1480: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1490: 6f 6e 2d 74 61 67 20 22 43 45 4e 54 45 52 22 20 on-tag "CENTER"
14a0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
14b0: 73 3a 63 6f 64 65 20 20 20 2e 20 61 72 67 73 29 s:code . args)
14c0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
14d0: 43 4f 44 45 22 20 20 20 61 72 67 73 29 29 0a 28 CODE" args)).(
14e0: 64 65 66 69 6e 65 20 28 73 3a 64 69 76 20 20 20 define (s:div
14f0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1500: 6f 6e 2d 74 61 67 20 22 44 49 56 22 20 20 20 20 on-tag "DIV"
1510: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1520: 73 3a 68 31 20 20 20 20 20 2e 20 61 72 67 73 29 s:h1 . args)
1530: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1540: 48 31 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 H1" args)).(
1550: 64 65 66 69 6e 65 20 28 73 3a 68 32 20 20 20 20 define (s:h2
1560: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1570: 6f 6e 2d 74 61 67 20 22 48 32 22 20 20 20 20 20 on-tag "H2"
1580: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1590: 73 3a 68 33 20 20 20 20 20 2e 20 61 72 67 73 29 s:h3 . args)
15a0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
15b0: 48 33 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 H3" args)).(
15c0: 64 65 66 69 6e 65 20 28 73 3a 68 34 20 20 20 20 define (s:h4
15d0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
15e0: 6f 6e 2d 74 61 67 20 22 48 34 22 20 20 20 20 20 on-tag "H4"
15f0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1600: 73 3a 68 35 20 20 20 20 20 2e 20 61 72 67 73 29 s:h5 . args)
1610: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1620: 48 35 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 H5" args)).(
1630: 64 65 66 69 6e 65 20 28 73 3a 68 65 61 64 20 20 define (s:head
1640: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1650: 6f 6e 2d 74 61 67 20 22 48 45 41 44 22 20 20 20 on-tag "HEAD"
1660: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1670: 73 3a 68 74 6d 6c 20 20 20 2e 20 61 72 67 73 29 s:html . args)
1680: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1690: 48 54 4d 4c 22 20 20 20 61 72 67 73 29 29 0a 28 HTML" args)).(
16a0: 64 65 66 69 6e 65 20 28 73 3a 69 20 20 20 20 20 define (s:i
16b0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
16c0: 6f 6e 2d 74 61 67 20 22 49 22 20 20 20 20 20 20 on-tag "I"
16d0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
16e0: 73 3a 69 6d 67 20 20 20 20 2e 20 61 72 67 73 29 s:img . args)
16f0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1700: 49 4d 47 22 20 20 20 20 61 72 67 73 29 29 0a 28 IMG" args)).(
1710: 64 65 66 69 6e 65 20 28 73 3a 69 6e 70 75 74 20 define (s:input
1720: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1730: 6f 6e 2d 74 61 67 20 22 49 4e 50 55 54 22 20 20 on-tag "INPUT"
1740: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1750: 73 3a 6c 69 6e 6b 20 20 20 2e 20 61 72 67 73 29 s:link . args)
1760: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1770: 4c 49 4e 4b 22 20 20 20 61 72 67 73 29 29 0a 28 LINK" args)).(
1780: 64 65 66 69 6e 65 20 28 73 3a 70 20 20 20 20 20 define (s:p
1790: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
17a0: 6f 6e 2d 74 61 67 20 22 50 22 20 20 20 20 20 20 on-tag "P"
17b0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
17c0: 73 3a 73 74 72 6f 6e 67 20 2e 20 61 72 67 73 29 s:strong . args)
17d0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
17e0: 53 54 52 4f 4e 47 22 20 61 72 67 73 29 29 0a 28 STRONG" args)).(
17f0: 64 65 66 69 6e 65 20 28 73 3a 74 61 62 6c 65 20 define (s:table
1800: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1810: 6f 6e 2d 74 61 67 20 22 54 41 42 4c 45 22 20 20 on-tag "TABLE"
1820: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1830: 73 3a 74 62 6f 64 79 20 20 2e 20 61 72 67 73 29 s:tbody . args)
1840: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1850: 54 42 4f 44 59 22 20 20 61 72 67 73 29 29 0a 28 TBODY" args)).(
1860: 64 65 66 69 6e 65 20 28 73 3a 74 68 65 61 64 20 define (s:thead
1870: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1880: 6f 6e 2d 74 61 67 20 22 54 48 45 41 44 22 20 20 on-tag "THEAD"
1890: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
18a0: 73 3a 74 68 20 20 20 20 20 2e 20 61 72 67 73 29 s:th . args)
18b0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
18c0: 54 48 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 TH" args)).(
18d0: 64 65 66 69 6e 65 20 28 73 3a 74 64 20 20 20 20 define (s:td
18e0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
18f0: 6f 6e 2d 74 61 67 20 22 54 44 22 20 20 20 20 20 on-tag "TD"
1900: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1910: 73 3a 74 69 74 6c 65 20 20 2e 20 61 72 67 73 29 s:title . args)
1920: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1930: 54 49 54 4c 45 22 20 20 61 72 67 73 29 29 0a 28 TITLE" args)).(
1940: 64 65 66 69 6e 65 20 28 73 3a 74 72 20 20 20 20 define (s:tr
1950: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1960: 6f 6e 2d 74 61 67 20 22 54 52 22 20 20 20 20 20 on-tag "TR"
1970: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1980: 73 3a 73 6d 61 6c 6c 20 20 2e 20 61 72 67 73 29 s:small . args)
1990: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
19a0: 53 4d 41 4c 4c 22 20 20 61 72 67 73 29 29 0a 28 SMALL" args)).(
19b0: 64 65 66 69 6e 65 20 28 73 3a 71 75 6f 74 65 20 define (s:quote
19c0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
19d0: 6f 6e 2d 74 61 67 20 22 51 55 4f 54 45 22 20 20 on-tag "QUOTE"
19e0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
19f0: 73 3a 68 72 20 20 20 20 20 2e 20 61 72 67 73 29 s:hr . args)
1a00: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1a10: 48 52 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 HR" args)).(
1a20: 64 65 66 69 6e 65 20 28 73 3a 6c 69 20 20 20 20 define (s:li
1a30: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1a40: 6f 6e 2d 74 61 67 20 22 4c 49 22 20 20 20 20 20 on-tag "LI"
1a50: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1a60: 73 3a 75 6c 20 20 20 20 20 2e 20 61 72 67 73 29 s:ul . args)
1a70: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1a80: 55 4c 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 UL" args)).(
1a90: 64 65 66 69 6e 65 20 28 73 3a 6f 6c 20 20 20 20 define (s:ol
1aa0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1ab0: 6f 6e 2d 74 61 67 20 22 4f 4c 22 20 20 20 20 20 on-tag "OL"
1ac0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1ad0: 73 3a 64 6c 20 20 20 20 20 2e 20 61 72 67 73 29 s:dl . args)
1ae0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1af0: 44 4c 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 DL" args)).(
1b00: 64 65 66 69 6e 65 20 28 73 3a 64 74 20 20 20 20 define (s:dt
1b10: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1b20: 6f 6e 2d 74 61 67 20 22 44 54 22 20 20 20 20 20 on-tag "DT"
1b30: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1b40: 73 3a 64 64 20 20 20 20 20 2e 20 61 72 67 73 29 s:dd . args)
1b50: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1b60: 44 44 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 DD" args)).(
1b70: 64 65 66 69 6e 65 20 28 73 3a 70 72 65 20 20 20 define (s:pre
1b80: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1b90: 6f 6e 2d 74 61 67 20 22 50 52 45 22 20 20 20 20 on-tag "PRE"
1ba0: 61 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 args)).(define (
1bb0: 73 3a 73 70 61 6e 20 20 20 2e 20 61 72 67 73 29 s:span . args)
1bc0: 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 (s:common-tag "
1bd0: 53 50 41 4e 22 20 20 20 61 72 67 73 29 29 0a 28 SPAN" args)).(
1be0: 64 65 66 69 6e 65 20 28 73 3a 6c 61 62 65 6c 20 define (s:label
1bf0: 20 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d . args) (s:comm
1c00: 6f 6e 2d 74 61 67 20 22 4c 41 42 45 4c 22 20 20 on-tag "LABEL"
1c10: 61 72 67 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 args))..(define
1c20: 28 73 3a 64 62 6c 71 75 6f 74 65 20 20 2e 20 61 (s:dblquote . a
1c30: 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 rgs). (let* ((i
1c40: 6e 70 75 74 73 20 28 73 3a 65 78 74 72 61 63 74 nputs (s:extract
1c50: 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 args)).
1c60: 20 28 64 61 74 61 20 20 20 28 63 61 61 72 20 69 (data (caar i
1c70: 6e 70 75 74 73 29 29 0a 20 20 20 20 20 20 20 20 nputs)).
1c80: 20 28 70 61 72 61 6d 73 20 28 73 3a 70 72 6f 63 (params (s:proc
1c90: 65 73 73 2d 70 61 72 61 6d 73 20 28 63 61 64 72 ess-params (cadr
1ca0: 20 69 6e 70 75 74 73 29 29 29 29 0a 20 20 20 20 inputs)))).
1cb0: 28 63 6f 6e 63 20 22 26 71 75 6f 74 3b 22 20 64 (conc """ d
1cc0: 61 74 61 20 22 26 71 75 6f 74 3b 22 29 29 29 0a ata """))).
1cd0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 62 72 20 20 .(define (s:br
1ce0: 20 20 20 2e 20 61 72 67 73 29 20 22 3c 42 52 3e . args) "<BR>
1cf0: 22 29 20 3b 3b 20 20 54 48 49 53 20 4d 41 59 20 ") ;; THIS MAY
1d00: 4e 4f 54 20 57 4f 52 4b 21 21 21 21 20 42 52 20 NOT WORK!!!! BR
1d10: 43 41 4e 20 28 4d 49 53 54 41 4b 45 4e 4c 59 29 CAN (MISTAKENLY)
1d20: 20 47 45 54 20 50 41 52 41 4d 20 54 45 58 54 0a GET PARAM TEXT.
1d30: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 3a 62 72 ;; (define (s:br
1d40: 20 20 20 20 20 2e 20 61 72 67 73 29 20 28 73 3a . args) (s:
1d50: 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 42 52 22 20 common-tag "BR"
1d60: 20 20 20 20 61 72 67 73 29 29 0a 28 64 65 66 69 args)).(defi
1d70: 6e 65 20 28 73 3a 66 6f 6e 74 20 20 20 2e 20 61 ne (s:font . a
1d80: 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 rgs) (s:common-t
1d90: 61 67 20 22 46 4f 4e 54 22 20 20 20 61 72 67 73 ag "FONT" args
1da0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 3a 65 72 )).(define (s:er
1db0: 72 2d 66 6f 6e 74 20 2e 20 61 72 67 73 29 0a 20 r-font . args).
1dc0: 20 28 73 3a 62 20 28 73 3a 66 6f 6e 74 20 27 63 (s:b (s:font 'c
1dd0: 6f 6c 6f 72 20 22 72 65 64 22 20 61 72 67 73 29 olor "red" args)
1de0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 63 ))..(define (s:c
1df0: 6f 6d 6d 65 6e 74 20 2e 20 61 72 67 73 29 0a 20 omment . args).
1e00: 20 28 6c 65 74 2a 20 28 28 69 6e 70 75 74 73 20 (let* ((inputs
1e10: 28 73 3a 65 78 74 72 61 63 74 20 61 72 67 73 29 (s:extract args)
1e20: 29 0a 20 20 20 20 20 20 20 20 20 28 64 61 74 61 ). (data
1e30: 20 20 20 28 63 61 72 20 69 6e 70 75 74 73 29 29 (car inputs))
1e40: 0a 20 20 20 20 20 20 20 20 20 28 70 61 72 61 6d . (param
1e50: 73 20 28 73 3a 70 72 6f 63 65 73 73 2d 70 61 72 s (s:process-par
1e60: 61 6d 73 20 28 63 61 64 72 20 69 6e 70 75 74 73 ams (cadr inputs
1e70: 29 29 29 29 0a 20 20 20 20 28 6c 69 73 74 20 22 )))). (list "
1e80: 3c 21 2d 2d 22 20 64 61 74 61 20 22 2d 2d 3e 22 <!--" data "-->"
1e90: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a )))..(define (s:
1ea0: 6e 75 6c 6c 20 20 20 2e 20 61 72 67 73 29 20 3b null . args) ;
1eb0: 3b 20 6e 6f 70 0a 20 20 28 6c 65 74 2a 20 28 28 ; nop. (let* ((
1ec0: 69 6e 70 75 74 73 20 28 73 3a 65 78 74 72 61 63 inputs (s:extrac
1ed0: 74 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 t args)).
1ee0: 20 20 28 64 61 74 61 20 20 20 28 63 61 72 20 69 (data (car i
1ef0: 6e 70 75 74 73 29 29 0a 20 20 20 20 20 20 20 20 nputs)).
1f00: 20 28 70 61 72 61 6d 73 20 28 73 3a 70 72 6f 63 (params (s:proc
1f10: 65 73 73 2d 70 61 72 61 6d 73 20 28 63 61 64 72 ess-params (cadr
1f20: 20 69 6e 70 75 74 73 29 29 29 29 0a 20 20 20 20 inputs)))).
1f30: 28 6c 69 73 74 20 64 61 74 61 29 29 29 0a 0a 3b (list data)))..;
1f40: 3b 20 70 75 74 73 20 61 20 6e 69 63 65 20 62 6f ; puts a nice bo
1f50: 78 20 61 72 6f 75 6e 64 20 61 20 63 68 75 6e 6b x around a chunk
1f60: 20 6f 66 20 73 74 75 66 66 0a 28 64 65 66 69 6e of stuff.(defin
1f70: 65 20 28 73 3a 66 69 65 6c 64 73 65 74 20 6c 65 e (s:fieldset le
1f80: 67 65 6e 64 20 2e 20 61 72 67 73 29 0a 20 20 28 gend . args). (
1f90: 6c 69 73 74 20 22 3c 46 49 45 4c 44 53 45 54 3e list "<FIELDSET>
1fa0: 3c 4c 45 47 45 4e 44 3e 22 20 6c 65 67 65 6e 64 <LEGEND>" legend
1fb0: 20 22 3c 2f 4c 45 47 45 4e 44 3e 22 20 61 72 67 "</LEGEND>" arg
1fc0: 73 20 22 3c 2f 46 49 45 4c 44 53 45 54 3e 22 29 s "</FIELDSET>")
1fd0: 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 73 74 )..;; given a st
1fe0: 72 69 6e 67 20 72 65 74 75 72 6e 20 74 68 65 20 ring return the
1ff0: 73 74 72 69 6e 67 20 69 66 20 69 74 20 69 73 20 string if it is
2000: 6e 6f 6e 2d 77 68 69 74 65 20 73 70 61 63 65 20 non-white space
2010: 6f 72 20 26 6e 62 73 70 3b 20 6f 74 68 65 72 77 or otherw
2020: 69 73 65 0a 28 64 65 66 69 6e 65 20 28 73 3a 6e ise.(define (s:n
2030: 62 73 70 20 73 74 72 29 0a 20 20 28 69 66 20 28 bsp str). (if (
2040: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 5c string-match "^\
2050: 5c 73 2a 24 22 20 73 74 72 29 0a 20 20 20 20 20 \s*$" str).
2060: 20 22 26 6e 62 73 70 3b 22 0a 20 20 20 20 20 20 " ".
2070: 73 74 72 29 29 0a 0a 3b 3b 20 55 53 45 20 27 70 str))..;; USE 'p
2080: 61 67 65 5f 6f 76 65 72 72 69 64 65 20 74 6f 20 age_override to
2090: 6f 76 65 72 72 69 64 65 20 61 20 6c 69 6e 6b 74 override a linkt
20a0: 6f 20 70 61 67 65 20 66 72 6f 6d 20 61 20 62 75 o page from a bu
20b0: 74 74 6f 6e 0a 28 64 65 66 69 6e 65 20 28 73 3a tton.(define (s:
20c0: 66 6f 72 6d 20 20 20 2e 20 61 72 67 73 29 0a 20 form . args).
20d0: 20 3b 3b 20 63 72 65 61 74 65 20 61 20 6c 69 6e ;; create a lin
20e0: 6b 20 66 6f 72 20 63 61 6c 6c 69 6e 67 20 62 61 k for calling ba
20f0: 63 6b 20 69 6e 74 6f 20 74 68 65 20 63 75 72 72 ck into the curr
2100: 65 6e 74 20 70 61 67 65 20 61 6e 64 20 63 61 6c ent page and cal
2110: 6c 69 6e 67 20 61 20 73 70 65 63 69 66 69 65 64 ling a specified
2120: 20 0a 20 20 3b 3b 20 66 75 6e 63 74 69 6f 6e 0a . ;; function.
2130: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e (let* ((action
2140: 20 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 73 (let ((v (s
2150: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 61 63 74 :find-param 'act
2160: 69 6f 6e 20 61 72 67 73 29 29 29 0a 20 20 20 20 ion args))).
2170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2180: 20 20 20 28 69 66 20 76 20 76 20 22 64 65 66 61 (if v v "defa
2190: 75 6c 74 22 29 29 29 0a 09 20 28 69 64 20 20 20 ult"))).. (id
21a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 20 28 (let ((i (
21b0: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 69 64 s:find-param 'id
21c0: 20 61 72 67 73 29 29 29 0a 09 09 20 20 20 20 20 args)))...
21d0: 20 20 28 69 66 20 69 20 69 20 23 66 29 29 29 0a (if i i #f))).
21e0: 20 20 20 20 20 20 20 20 20 28 70 61 67 65 20 20 (page
21f0: 20 20 20 20 20 28 6c 65 74 20 28 28 70 20 28 73 (let ((p (s
2200: 64 61 74 2d 70 61 67 65 20 73 3a 73 65 73 73 69 dat-page s:sessi
2210: 6f 6e 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 on))).
2220: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
2230: 20 70 20 70 20 22 68 6f 6d 65 22 29 29 29 0a 09 p p "home")))..
2240: 20 3b 3b 20 28 6c 69 6e 6b 20 20 20 20 20 20 20 ;; (link
2250: 28 73 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f (session:link-to
2260: 20 73 3a 73 65 73 73 69 6f 6e 20 70 61 67 65 20 s:session page
2270: 28 69 66 20 69 64 0a 20 20 20 20 20 20 20 20 20 (if id.
2280: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22b0: 20 20 20 28 6c 69 73 74 20 27 61 63 74 69 6f 6e (list 'action
22c0: 20 61 63 74 69 6f 6e 20 27 69 64 20 69 64 29 0a action 'id id).
22d0: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
22e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2300: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
2310: 74 20 27 61 63 74 69 6f 6e 20 61 63 74 69 6f 6e t 'action action
2320: 29 29 29 29 29 0a 09 20 28 6c 69 6e 6b 20 20 20 ))))).. (link
2330: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d (if (string=
2340: 3f 20 28 73 75 62 73 74 72 69 6e 67 20 61 63 74 ? (substring act
2350: 69 6f 6e 20 30 20 35 29 20 22 68 74 74 70 3a 22 ion 0 5) "http:"
2360: 29 20 3b 3b 20 69 66 20 66 69 72 73 74 20 70 61 ) ;; if first pa
2370: 72 74 20 6f 66 20 73 74 72 69 6e 67 20 69 73 20 rt of string is
2380: 68 74 74 70 3a 0a 09 20 20 20 20 20 20 20 20 09 http:.. .
2390: 20 61 63 74 69 6f 6e 0a 09 20 20 20 20 20 20 20 action..
23a0: 20 09 20 28 73 65 73 73 69 6f 6e 3a 6c 69 6e 6b . (session:link
23b0: 2d 74 6f 20 73 3a 73 65 73 73 69 6f 6e 20 0a 09 -to s:session ..
23c0: 20 20 20 20 20 20 20 20 09 09 09 20 20 70 61 67 ... pag
23d0: 65 20 0a 09 20 20 20 20 20 20 20 20 09 09 09 20 e .. ...
23e0: 20 28 69 66 20 69 64 0a 09 20 20 20 20 20 20 20 (if id..
23f0: 20 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 ... (list
2400: 27 61 63 74 69 6f 6e 20 61 63 74 69 6f 6e 20 27 'action action '
2410: 69 64 20 69 64 29 0a 09 20 20 20 20 20 20 20 20 id id)..
2420: 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 27 ... (list '
2430: 61 63 74 69 6f 6e 20 61 63 74 69 6f 6e 29 29 29 action action)))
2440: 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 63 72 69 ))). ;; (scri
2450: 70 74 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 pt (slot-ref
2460: 20 73 3a 73 65 73 73 69 6f 6e 20 27 73 63 72 69 s:session 'scri
2470: 70 74 29 29 0a 20 20 20 20 3b 3b 20 28 61 63 74 pt)). ;; (act
2480: 69 6f 6e 2d 73 74 72 20 28 73 74 72 69 6e 67 2d ion-str (string-
2490: 61 70 70 65 6e 64 20 73 63 72 69 70 74 20 22 2f append script "/
24a0: 22 20 70 61 67 65 20 22 3f 61 63 74 69 6f 6e 3d " page "?action=
24b0: 22 20 61 63 74 69 6f 6e 29 29 29 0a 20 20 20 20 " action))).
24c0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 46 (s:common-tag "F
24d0: 4f 52 4d 22 20 28 61 70 70 65 6e 64 20 28 73 3a ORM" (append (s:
24e0: 72 65 6d 6f 76 65 2d 70 61 72 61 6d 2d 6d 61 74 remove-param-mat
24f0: 63 68 69 6e 67 20 28 73 3a 72 65 6d 6f 76 65 2d ching (s:remove-
2500: 70 61 72 61 6d 2d 6d 61 74 63 68 69 6e 67 20 61 param-matching a
2510: 72 67 73 20 27 61 63 74 69 6f 6e 29 20 27 69 64 rgs 'action) 'id
2520: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2540: 20 20 20 28 6c 69 73 74 20 27 61 63 74 69 6f 6e (list 'action
2550: 20 6c 69 6e 6b 29 29 29 29 29 0a 0a 3b 3b 20 6c link)))))..;; l
2560: 6f 6f 6b 20 75 70 20 74 68 65 20 76 61 72 69 61 ook up the varia
2570: 62 6c 65 20 6e 61 6d 65 20 28 76 69 61 20 74 68 ble name (via th
2580: 65 20 27 6e 61 6d 65 20 74 61 67 29 20 74 68 65 e 'name tag) the
2590: 6e 20 69 6e 6a 65 63 74 20 74 68 65 20 76 61 6c n inject the val
25a0: 75 65 20 66 72 6f 6d 20 74 68 65 20 73 65 73 73 ue from the sess
25b0: 69 6f 6e 20 76 61 72 0a 3b 3b 20 72 65 70 6c 61 ion var.;; repla
25c0: 63 69 6e 67 20 74 68 65 20 27 76 61 6c 75 65 20 cing the 'value
25d0: 76 61 6c 75 65 20 69 66 20 69 74 20 69 73 20 61 value if it is a
25e0: 6c 72 65 61 64 79 20 74 68 65 72 65 2c 20 61 64 lready there, ad
25f0: 64 69 6e 67 20 69 74 20 69 66 20 69 74 20 69 73 ding it if it is
2600: 20 6e 6f 74 2e 0a 28 64 65 66 69 6e 65 20 28 73 not..(define (s
2610: 3a 70 72 65 73 65 72 76 65 20 74 61 67 20 61 72 :preserve tag ar
2620: 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 76 61 gs). (let* ((va
2630: 72 2d 6e 61 6d 65 20 28 73 3a 66 69 6e 64 2d 70 r-name (s:find-p
2640: 61 72 61 6d 20 27 6e 61 6d 65 20 61 72 67 73 29 aram 'name args)
2650: 29 20 3b 3b 20 6e 61 6d 65 3d 27 76 61 72 6e 61 ) ;; name='varna
2660: 6d 65 27 0a 09 20 28 76 61 6c 75 65 20 20 20 20 me'.. (value
2670: 28 6c 65 74 20 28 28 76 20 28 73 3a 67 65 74 20 (let ((v (s:get
2680: 76 61 72 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 var-name)))...
2690: 20 20 20 28 69 66 20 76 20 76 20 23 66 29 29 29 (if v v #f)))
26a0: 0a 09 20 28 6e 65 77 61 72 67 73 20 20 28 61 70 .. (newargs (ap
26b0: 70 65 6e 64 20 28 73 3a 72 65 6d 6f 76 65 2d 70 pend (s:remove-p
26c0: 61 72 61 6d 2d 6d 61 74 63 68 69 6e 67 20 61 72 aram-matching ar
26d0: 67 73 20 27 76 61 6c 75 65 29 20 28 69 66 20 76 gs 'value) (if v
26e0: 61 6c 75 65 20 28 6c 69 73 74 20 27 76 61 6c 75 alue (list 'valu
26f0: 65 20 76 61 6c 75 65 29 20 27 28 29 29 29 29 29 e value) '()))))
2700: 0a 20 20 20 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 . (s:common-t
2710: 61 67 20 74 61 67 20 6e 65 77 61 72 67 73 29 29 ag tag newargs))
2720: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 69 6e )..(define (s:in
2730: 70 75 74 2d 70 72 65 73 65 72 76 65 20 20 2e 20 put-preserve .
2740: 61 72 67 73 29 0a 20 20 28 73 3a 70 72 65 73 65 args). (s:prese
2750: 72 76 65 20 22 49 4e 50 55 54 22 20 61 72 67 73 rve "INPUT" args
2760: 29 29 0a 0a 3b 3b 20 74 65 78 74 20 61 72 65 61 ))..;; text area
2770: 73 20 61 72 65 20 64 6f 6e 65 20 61 20 6c 69 74 s are done a lit
2780: 74 6c 65 20 64 69 66 66 65 72 65 6e 74 6c 79 2e tle differently.
2790: 20 54 68 65 20 76 61 6c 75 65 20 69 73 20 73 74 The value is st
27a0: 6f 72 65 64 20 62 65 74 77 65 65 6e 20 74 68 65 ored between the
27b0: 20 74 61 67 73 20 3c 74 65 78 74 61 72 65 61 20 tags <textarea
27c0: 2e 2e 2e 3e 74 68 65 20 76 61 6c 75 65 20 67 6f ...>the value go
27d0: 65 73 20 68 65 72 65 3c 2f 74 65 78 74 61 72 65 es here</textare
27e0: 61 3e 0a 28 64 65 66 69 6e 65 20 28 73 3a 74 65 a>.(define (s:te
27f0: 78 74 61 72 65 61 2d 70 72 65 73 65 72 76 65 20 xtarea-preserve
2800: 2e 20 61 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 . args). (let*
2810: 28 28 76 61 72 2d 6e 61 6d 65 20 28 73 3a 66 69 ((var-name (s:fi
2820: 6e 64 2d 70 61 72 61 6d 20 27 6e 61 6d 65 20 61 nd-param 'name a
2830: 72 67 73 29 29 0a 09 20 28 76 61 6c 75 65 20 20 rgs)).. (value
2840: 20 20 28 6c 65 74 20 28 28 76 20 28 73 3a 67 65 (let ((v (s:ge
2850: 74 20 76 61 72 2d 6e 61 6d 65 29 29 29 0a 09 09 t var-name)))...
2860: 20 20 20 20 20 28 69 66 20 76 20 76 20 23 66 29 (if v v #f)
2870: 29 29 29 0a 20 20 20 20 28 73 3a 63 6f 6d 6d 6f ))). (s:commo
2880: 6e 2d 74 61 67 20 22 54 45 58 54 41 52 45 41 22 n-tag "TEXTAREA"
2890: 20 28 69 66 20 76 61 6c 75 65 20 28 63 6f 6e 73 (if value (cons
28a0: 20 76 61 6c 75 65 20 61 72 67 73 29 20 61 72 67 value args) arg
28b0: 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s))))..(define (
28c0: 73 3a 6f 70 74 69 6f 6e 20 64 61 74 29 0a 20 20 s:option dat).
28d0: 28 6c 65 74 20 28 28 6c 65 6e 20 20 20 20 20 20 (let ((len
28e0: 28 6c 65 6e 67 74 68 20 64 61 74 29 29 29 0a 20 (length dat))).
28f0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
2900: 65 71 3f 20 6c 65 6e 20 31 29 0a 20 20 20 20 20 eq? len 1).
2910: 20 28 6c 65 74 20 28 28 69 74 65 6d 20 28 63 61 (let ((item (ca
2920: 72 20 64 61 74 29 29 29 0a 09 28 73 3a 6f 70 74 r dat)))..(s:opt
2930: 69 6f 6e 20 28 6c 69 73 74 20 69 74 65 6d 20 69 ion (list item i
2940: 74 65 6d 20 69 74 65 6d 29 29 29 29 0a 20 20 20 tem item)))).
2950: 20 20 28 28 65 71 3f 20 6c 65 6e 20 32 29 0a 20 ((eq? len 2).
2960: 20 20 20 20 20 28 73 3a 6f 70 74 69 6f 6e 20 28 (s:option (
2970: 61 70 70 65 6e 64 20 64 61 74 20 28 6c 69 73 74 append dat (list
2980: 20 28 63 61 72 20 64 61 74 29 29 29 29 29 0a 20 (car dat))))).
2990: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
29a0: 28 6c 65 74 20 28 28 6c 61 62 65 6c 20 20 20 20 (let ((label
29b0: 28 63 61 72 20 64 61 74 29 29 0a 09 20 20 20 20 (car dat))..
29c0: 28 76 61 6c 75 65 20 20 20 20 28 63 61 64 72 20 (value (cadr
29d0: 64 61 74 29 29 0a 09 20 20 20 20 28 64 69 73 70 dat)).. (disp
29e0: 76 61 6c 20 20 28 63 61 64 64 72 20 64 61 74 29 val (caddr dat)
29f0: 29 0a 09 20 20 20 20 28 73 65 6c 65 63 74 65 64 ).. (selected
2a00: 20 28 69 66 20 28 3e 20 6c 65 6e 20 33 29 28 63 (if (> len 3)(c
2a10: 61 64 64 64 72 20 64 61 74 29 20 23 66 29 29 29 adddr dat) #f)))
2a20: 0a 09 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 3c ..(list (conc "<
2a30: 4f 50 54 49 4f 4e 20 22 20 0a 09 09 20 20 20 20 OPTION " ...
2a40: 28 69 66 20 73 65 6c 65 63 74 65 64 20 22 20 73 (if selected " s
2a50: 65 6c 65 63 74 65 64 20 22 20 22 22 29 0a 09 09 elected " "")...
2a60: 20 20 20 20 22 6c 61 62 65 6c 3d 5c 22 22 20 6c "label=\"" l
2a70: 61 62 65 6c 0a 09 09 20 20 20 20 22 5c 22 20 76 abel... "\" v
2a80: 61 6c 75 65 3d 5c 22 22 20 76 61 6c 75 65 0a 09 alue=\"" value..
2a90: 09 20 20 20 20 22 5c 22 3e 22 20 64 69 73 70 76 . "\">" dispv
2aa0: 61 6c 20 22 3c 2f 4f 50 54 49 4f 4e 3e 22 29 29 al "</OPTION>"))
2ab0: 29 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 6f )))))..;; call o
2ac0: 6e 6c 79 20 77 69 74 68 20 28 6c 61 62 65 6c 20 nly with (label
2ad0: 28 6c 61 62 65 6c 20 76 61 6c 75 65 20 64 69 73 (label value dis
2ae0: 70 76 61 6c 20 5b 23 74 5d 29 20 2e 2e 2e 29 0a pval [#t]) ...).
2af0: 3b 3b 20 4e 42 2f 2f 20 73 61 64 6c 79 20 74 68 ;; NB// sadly th
2b00: 69 73 20 62 6c 6f 63 6b 20 69 73 20 72 65 64 75 is block is redu
2b10: 6e 64 61 6e 74 6c 79 20 61 6c 6d 6f 73 74 20 69 ndantly almost i
2b20: 64 65 6e 74 69 63 61 6c 20 74 6f 20 74 68 65 20 dentical to the
2b30: 73 3a 73 65 6c 65 63 74 0a 3b 3b 20 66 69 78 20 s:select.;; fix
2b40: 74 68 61 74 20 6c 61 74 65 72 20 2e 2e 2e 0a 28 that later ....(
2b50: 64 65 66 69 6e 65 20 28 73 3a 6f 70 74 67 72 6f define (s:optgro
2b60: 75 70 20 64 61 74 29 0a 20 20 28 6c 65 74 20 28 up dat). (let (
2b70: 28 6c 61 62 65 6c 20 28 63 61 72 20 64 61 74 29 (label (car dat)
2b80: 29 0a 09 28 72 65 6d 20 20 20 28 63 64 72 20 64 )..(rem (cdr d
2b90: 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e at))). (if (n
2ba0: 75 6c 6c 3f 20 72 65 6d 29 0a 09 28 73 3a 63 6f ull? rem)..(s:co
2bb0: 6d 6d 6f 6e 2d 74 61 67 20 22 4f 50 54 47 52 4f mmon-tag "OPTGRO
2bc0: 55 50 22 20 60 28 27 6c 61 62 65 6c 20 2c 6c 61 UP" `('label ,la
2bd0: 62 65 6c 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 bel))..(let loop
2be0: 20 28 28 68 65 64 20 28 63 61 72 20 72 65 6d 29 ((hed (car rem)
2bf0: 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 )... (tal (cdr
2c00: 20 72 65 6d 29 29 0a 09 09 20 20 20 28 72 65 73 rem))... (res
2c10: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 3c 4f (list (conc "<O
2c20: 50 54 47 52 4f 55 50 20 6c 61 62 65 6c 3d 22 20 PTGROUP label="
2c30: 6c 61 62 65 6c 29 29 29 29 0a 09 20 20 3b 3b 20 label)))).. ;;
2c40: 28 70 72 69 6e 74 20 22 68 65 64 3a 20 22 20 68 (print "hed: " h
2c50: 65 64 20 22 20 74 61 6c 3a 20 22 20 74 61 6c 20 ed " tal: " tal
2c60: 22 20 72 65 73 3a 20 22 20 72 65 73 29 0a 09 20 " res: " res)..
2c70: 20 28 6c 65 74 20 28 28 6e 65 77 20 28 61 70 70 (let ((new (app
2c80: 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 28 69 end res (list (i
2c90: 66 20 28 6c 69 73 74 3f 20 28 63 61 64 72 20 68 f (list? (cadr h
2ca0: 65 64 29 29 0a 09 09 09 09 09 20 20 20 28 73 3a ed))...... (s:
2cb0: 6f 70 74 67 72 6f 75 70 20 68 65 64 29 0a 09 09 optgroup hed)...
2cc0: 09 09 09 20 20 20 28 73 3a 6f 70 74 69 6f 6e 20 ... (s:option
2cd0: 68 65 64 29 29 29 29 29 29 0a 09 20 20 20 20 28 hed)))))).. (
2ce0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
2cf0: 09 28 61 70 70 65 6e 64 20 6e 65 77 20 28 6c 69 .(append new (li
2d00: 73 74 20 22 3c 2f 4f 50 54 47 52 4f 55 50 3e 22 st "</OPTGROUP>"
2d10: 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 ))...(loop (car
2d20: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 tal)(cdr tal) ne
2d30: 77 29 29 29 29 29 29 29 0a 20 20 20 20 0a 3b 3b w))))))). .;;
2d40: 20 69 74 65 6d 73 20 69 73 20 61 20 68 69 65 72 items is a hier
2d50: 61 72 63 68 69 61 6c 20 61 6c 69 73 74 0a 3b 3b archial alist.;;
2d60: 20 28 20 28 6c 61 62 65 6c 31 20 76 61 6c 75 65 ( (label1 value
2d70: 31 20 64 69 73 70 76 61 6c 31 20 23 74 29 20 3b 1 dispval1 #t) ;
2d80: 3b 20 3c 3d 3d 20 74 68 69 73 20 6f 6e 65 20 69 ; <== this one i
2d90: 73 20 73 65 6c 65 63 74 65 64 0a 3b 3b 20 20 20 s selected.;;
2da0: 28 6c 61 62 65 6c 32 20 28 6c 61 62 65 6c 33 20 (label2 (label3
2db0: 76 61 6c 75 65 32 20 64 69 73 70 76 61 6c 32 29 value2 dispval2)
2dc0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 6c .;; (l
2dd0: 61 62 65 6c 34 20 76 61 6c 75 65 33 20 64 69 73 abel4 value3 dis
2de0: 70 76 61 6c 33 29 29 29 0a 3b 3b 20 20 20 20 20 pval3))).;;
2df0: 0a 3b 3b 20 20 72 65 71 75 69 72 65 64 20 61 72 .;; required ar
2e00: 67 20 69 73 20 27 6e 61 6d 65 0a 28 64 65 66 69 g is 'name.(defi
2e10: 6e 65 20 28 73 3a 73 65 6c 65 63 74 20 69 74 65 ne (s:select ite
2e20: 6d 73 20 2e 20 61 72 67 73 29 0a 20 20 28 69 66 ms . args). (if
2e30: 20 28 6e 75 6c 6c 3f 20 69 74 65 6d 73 29 0a 20 (null? items).
2e40: 20 20 20 20 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 (s:common-t
2e50: 61 67 20 22 53 45 4c 45 43 54 22 20 61 72 67 73 ag "SELECT" args
2e60: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ). (let loo
2e70: 70 20 28 28 68 65 64 20 28 63 61 72 20 69 74 65 p ((hed (car ite
2e80: 6d 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 ms))... (tal (cd
2e90: 72 20 69 74 65 6d 73 29 29 0a 09 09 20 28 72 65 r items))... (re
2ea0: 73 20 27 28 29 29 29 0a 09 3b 3b 20 28 70 72 69 s '()))..;; (pri
2eb0: 6e 74 20 22 68 65 64 3a 20 22 20 68 65 64 20 22 nt "hed: " hed "
2ec0: 20 74 61 6c 3a 20 22 20 74 61 6c 20 22 20 72 65 tal: " tal " re
2ed0: 73 3a 20 22 20 72 65 73 29 0a 09 28 6c 65 74 20 s: " res)..(let
2ee0: 28 28 6e 65 77 20 28 61 70 70 65 6e 64 20 72 65 ((new (append re
2ef0: 73 20 28 6c 69 73 74 20 28 69 66 20 28 61 6e 64 s (list (if (and
2f00: 20 28 3e 20 28 6c 65 6e 67 74 68 20 68 65 64 29 (> (length hed)
2f10: 20 31 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 1)...... (
2f20: 6c 69 73 74 3f 20 28 63 61 64 72 20 68 65 64 29 list? (cadr hed)
2f30: 29 29 0a 09 09 09 09 09 20 28 73 3a 6f 70 74 67 ))...... (s:optg
2f40: 72 6f 75 70 20 68 65 64 29 0a 09 09 09 09 09 20 roup hed)......
2f50: 28 73 3a 6f 70 74 69 6f 6e 20 68 65 64 29 29 29 (s:option hed)))
2f60: 29 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c ))).. (if (null
2f70: 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 73 ? tal).. (s
2f80: 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 53 45 4c :common-tag "SEL
2f90: 45 43 54 22 20 28 63 6f 6e 73 20 6e 65 77 20 61 ECT" (cons new a
2fa0: 72 67 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f rgs)).. (lo
2fb0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
2fc0: 20 74 61 6c 29 20 6e 65 77 29 29 29 29 29 29 0a tal) new)))))).
2fd0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 63 6f 6c 6f .(define (s:colo
2fe0: 72 20 20 2e 20 61 72 67 73 29 0a 20 20 22 23 30 r . args). "#0
2ff0: 30 66 66 30 30 22 29 0a 0a 28 64 65 66 69 6e 65 0ff00")..(define
3000: 20 28 73 3a 70 72 69 6e 74 20 69 6e 64 65 6e 74 (s:print indent
3010: 20 69 6e 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 inlst). (map (
3020: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
3030: 20 20 20 20 28 63 6f 6e 64 20 0a 20 20 20 20 20 (cond .
3040: 20 20 20 20 20 28 28 6f 72 20 28 73 74 72 69 6e ((or (strin
3050: 67 3f 20 78 29 28 73 79 6d 62 6f 6c 3f 20 78 29 g? x)(symbol? x)
3060: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 72 ). (pr
3070: 69 6e 74 20 28 63 6f 6e 63 20 28 6d 61 6b 65 2d int (conc (make-
3080: 73 74 72 69 6e 67 20 28 2a 20 69 6e 64 65 6e 74 string (* indent
3090: 20 32 29 20 23 5c 20 29 20 28 73 3a 61 6e 79 2d 2) #\ ) (s:any-
30a0: 3e 73 74 72 69 6e 67 20 78 29 29 29 29 0a 20 20 >string x)))).
30b0: 20 20 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 ((list?
30c0: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 x). (s
30d0: 3a 70 72 69 6e 74 20 28 2b 20 69 6e 64 65 6e 74 :print (+ indent
30e0: 20 31 29 20 78 29 29 0a 20 20 20 20 20 20 20 20 1) x)).
30f0: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
3100: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 ;; (print "ER
3110: 52 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 20 30 ROR: Bad input 0
3120: 31 22 29 20 3b 3b 20 77 68 79 20 64 6f 20 61 6e 1") ;; why do an
3130: 79 74 68 69 6e 67 20 77 69 74 68 20 6a 75 6e 6b ything with junk
3140: 3f 0a 20 20 20 20 20 20 20 20 20 20 20 29 29 29 ?. )))
3150: 0a 20 20 20 20 20 20 20 69 6e 6c 73 74 29 29 0a . inlst)).
3160: 0a 3b 3b 20 4d 6f 76 65 64 20 74 6f 20 6d 69 73 .;; Moved to mis
3170: 63 2d 73 74 6d 6c 0a 3b 3b 0a 23 3b 28 64 65 66 c-stml.;;.#;(def
3180: 69 6e 65 20 28 73 3a 63 67 69 2d 6f 75 74 20 69 ine (s:cgi-out i
3190: 6e 6c 73 74 29 0a 20 20 28 73 3a 6f 75 74 70 75 nlst). (s:outpu
31a0: 74 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 t (current-outpu
31b0: 74 2d 70 6f 72 74 29 20 69 6e 6c 73 74 29 29 0a t-port) inlst)).
31c0: 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 6f 75 .#;(define (s:ou
31d0: 74 70 75 74 20 70 6f 72 74 20 69 6e 6c 73 74 29 tput port inlst)
31e0: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
31f0: 28 78 29 0a 09 20 28 63 6f 6e 64 20 0a 09 20 20 (x).. (cond ..
3200: 28 28 73 74 72 69 6e 67 3f 20 78 29 20 28 70 72 ((string? x) (pr
3210: 69 6e 74 20 78 29 29 20 3b 3b 20 28 70 72 69 6e int x)) ;; (prin
3220: 74 20 78 29 29 0a 09 20 20 28 28 73 79 6d 62 6f t x)).. ((symbo
3230: 6c 3f 20 78 29 20 28 70 72 69 6e 74 20 78 29 29 l? x) (print x))
3240: 20 3b 3b 20 28 70 72 69 6e 74 20 78 29 29 0a 09 ;; (print x))..
3250: 20 20 28 28 6c 69 73 74 3f 20 78 29 20 20 20 28 ((list? x) (
3260: 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 20 78 29 s:output port x)
3270: 29 0a 09 20 20 28 65 6c 73 65 20 22 22 0a 09 20 ).. (else ""..
3280: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 52 ;; (print "ERR
3290: 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 20 30 32 OR: Bad input 02
32a0: 22 29 20 3b 3b 20 77 68 79 20 64 6f 20 61 6e 79 ") ;; why do any
32b0: 74 68 69 6e 67 3f 20 64 6f 6e 27 74 20 6f 75 74 thing? don't out
32c0: 70 75 74 20 6a 75 6e 6b 2e 0a 09 20 20 20 29 29 put junk... ))
32d0: 29 0a 20 20 20 20 20 20 20 69 6e 6c 73 74 29 29 ). inlst))
32e0: 0a 3b 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 .; (if (> (leng
32f0: 74 68 20 69 6e 6c 73 74 29 20 32 29 0a 3b 20 20 th inlst) 2).;
3300: 20 20 20 20 28 70 72 69 6e 74 29 29 29 0a 0a 23 (print)))..#
3310: 3b 28 64 65 66 69 6e 65 20 28 73 3a 6f 75 74 70 ;(define (s:outp
3320: 75 74 2d 6e 65 77 20 70 6f 72 74 20 69 6e 6c 73 ut-new port inls
3330: 74 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 t). (with-outpu
3340: 74 2d 74 6f 2d 70 6f 72 74 20 70 6f 72 74 0a 20 t-to-port port.
3350: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
3360: 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 .(map (lambda (x
3370: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 64 20 ).. (cond
3380: 0a 09 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 ...((string? x)
3390: 28 70 72 69 6e 74 20 78 29 29 0a 09 09 28 28 73 (print x))...((s
33a0: 79 6d 62 6f 6c 3f 20 78 29 20 28 70 72 69 6e 74 ymbol? x) (print
33b0: 20 78 29 29 0a 09 09 28 28 6c 69 73 74 3f 20 78 x))...((list? x
33c0: 29 20 20 20 28 73 3a 6f 75 74 70 75 74 20 70 6f ) (s:output po
33d0: 72 74 20 78 29 29 0a 09 09 28 65 6c 73 65 0a 09 rt x))...(else..
33e0: 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 52 . ;; (print "ERR
33f0: 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 20 30 33 OR: Bad input 03
3400: 22 29 0a 20 20 20 20 20 29 29 29 0a 09 20 20 20 "). )))..
3410: 20 20 69 6e 6c 73 74 29 29 29 29 0a 0a 3b 3b 3d inlst))))..;;=
3420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3460: 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 6f 74 20 73 75 72 =====.;; Not sur
3470: 65 20 77 68 65 72 65 20 74 68 65 73 65 20 73 68 e where these sh
3480: 6f 75 6c 64 20 67 6f 0a 3b 3b 3d 3d 3d 3d 3d 3d ould go.;;======
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34d0: 0a 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 72 ..;; (include "r
34e0: 65 71 75 69 72 65 6d 65 6e 74 73 2e 73 63 6d 22 equirements.scm"
34f0: 29 2c 20 64 62 69 20 68 61 73 20 61 75 74 6f 6c ), dbi has autol
3500: 6f 61 64 2c 20 73 68 6f 75 6c 64 20 6e 6f 74 20 oad, should not
3510: 6e 65 65 64 20 74 68 69 73 20 61 6e 79 20 6d 6f need this any mo
3520: 72 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d re...;;=========
3530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
3570: 20 73 65 74 75 70 20 2d 20 63 6f 6e 76 69 65 6e setup - convien
3580: 63 65 20 63 61 6c 6c 73 20 74 6f 20 66 75 6e 63 ce calls to func
3590: 74 69 6f 6e 73 20 77 72 61 70 70 65 64 20 77 69 tions wrapped wi
35a0: 74 68 20 61 20 67 6c 6f 62 61 6c 20 73 3a 73 65 th a global s:se
35b0: 73 73 69 6f 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ssion.;;========
35c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
3600: 3b 3b 20 6d 61 63 72 6f 73 20 69 6e 20 73 75 67 ;; macros in sug
3610: 61 72 20 64 6f 6e 27 74 20 77 6f 72 6b 2c 20 68 ar don't work, h
3620: 61 76 65 20 74 6f 20 6c 6f 61 64 20 69 6e 20 61 ave to load in a
3630: 6c 6c 20 66 69 6c 65 73 20 6f 72 20 75 73 65 20 ll files or use
3640: 63 6f 6d 70 69 6c 65 64 20 6d 6f 64 65 3f 0a 3b compiled mode?.;
3650: 3b 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 73 ;.;; (include "s
3660: 75 67 61 72 2e 73 63 6d 22 29 0a 0a 3b 3b 20 75 ugar.scm")..;; u
3670: 73 65 20 74 68 69 73 20 66 6f 72 20 67 65 74 74 se this for gett
3680: 69 6e 67 20 64 61 74 61 20 66 72 6f 6d 20 70 61 ing data from pa
3690: 67 65 20 74 6f 20 70 61 67 65 20 77 68 65 6e 20 ge to page when
36a0: 73 63 6f 70 65 20 61 6e 64 20 65 76 61 6c 73 0a scope and evals.
36b0: 3b 3b 20 67 65 74 20 69 6e 20 74 68 65 20 77 61 ;; get in the wa
36c0: 79 0a 3b 3b 20 73 61 76 65 20 64 61 74 61 20 66 y.;; save data f
36d0: 6f 72 20 75 73 65 20 69 6e 20 74 68 65 20 70 61 or use in the pa
36e0: 67 65 20 67 65 6e 65 72 61 74 69 6f 6e 20 68 65 ge generation he
36f0: 72 65 2e 20 44 6f 65 73 20 4e 4f 54 20 70 65 72 re. Does NOT per
3700: 73 69 73 74 20 61 63 72 6f 73 73 20 70 61 67 65 sist across page
3710: 20 72 65 61 64 73 2e 0a 0a 28 64 65 66 69 6e 65 reads...(define
3720: 20 2a 70 61 67 65 2d 64 61 74 61 2a 20 28 6d 61 *page-data* (ma
3730: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
3740: 0a 28 64 65 66 69 6e 65 20 28 73 3a 6c 73 65 74 .(define (s:lset
3750: 21 20 76 61 72 20 76 61 6c 29 0a 20 20 28 68 61 ! var val). (ha
3760: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 70 sh-table-set! *p
3770: 61 67 65 2d 64 61 74 61 2a 20 76 61 72 20 76 61 age-data* var va
3780: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 3a 6c l)).(define (s:l
3790: 67 65 74 20 76 61 72 20 2e 20 64 65 66 61 75 6c get var . defaul
37a0: 74 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 t). (hash-table
37b0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 70 61 -ref/default *pa
37c0: 67 65 2d 64 61 74 61 2a 20 76 61 72 20 28 69 66 ge-data* var (if
37d0: 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c 74 29 (null? default)
37e0: 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 0a 09 ...... #f..
37f0: 09 09 09 09 20 20 20 20 20 20 28 63 61 72 20 64 .... (car d
3800: 65 66 61 75 6c 74 29 29 29 29 0a 0a 3b 3b 20 74 efault))))..;; t
3810: 6f 20 6f 62 73 63 75 72 65 20 61 6e 64 20 69 6e o obscure and in
3820: 64 69 72 65 63 74 20 64 61 74 61 62 61 73 65 20 direct database
3830: 69 64 73 20 75 73 65 20 6f 6e 65 20 74 69 6d 65 ids use one time
3840: 20 6b 65 79 73 0a 3b 3b 0a 3b 3b 20 20 28 73 3a keys.;;.;; (s:
3850: 67 65 74 2d 6b 65 79 20 27 6e 20 31 29 20 20 20 get-key 'n 1)
3860: 20 20 3d 3e 20 22 6e 39 39 65 31 38 38 32 22 20 => "n99e1882"
3870: 6e 3d 6e 75 6d 62 65 72 20 39 39 65 20 69 73 20 n=number 99e is
3880: 74 68 65 20 77 65 65 6b 20 6e 75 6d 62 65 72 20 the week number
3890: 73 69 6e 63 65 20 31 39 37 30 2c 20 72 65 6d 61 since 1970, rema
38a0: 69 6e 64 65 72 20 69 73 20 72 61 6e 64 6f 6d 0a inder is random.
38b0: 3b 3b 20 20 28 73 3a 6b 65 79 2d 3e 76 61 6c 20 ;; (s:key->val
38c0: 22 6e 31 38 38 32 22 29 20 3d 3e 20 31 0a 3b 3b "n1882") => 1.;;
38d0: 0a 3b 3b 20 20 66 69 72 73 74 20 6c 65 74 74 65 .;; first lette
38e0: 72 20 69 73 20 61 20 74 79 70 65 3a 20 6e 3d 6e r is a type: n=n
38f0: 75 6d 62 65 72 2c 20 73 3d 73 74 72 69 6e 67 2c umber, s=string,
3900: 20 62 3d 62 6f 6f 6c 65 61 6e 0a 28 64 65 66 69 b=boolean.(defi
3910: 6e 65 20 28 73 3a 67 65 74 2d 6b 65 79 20 6b 65 ne (s:get-key ke
3920: 79 2d 74 79 70 65 20 76 61 6c 29 0a 20 20 28 6c y-type val). (l
3930: 65 74 20 28 28 6d 6b 72 61 6e 64 73 74 72 20 28 et ((mkrandstr (
3940: 6c 61 6d 62 64 61 20 28 69 6e 6e 75 6d 29 28 6e lambda (innum)(n
3950: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 72 umber->string (r
3960: 61 6e 64 6f 6d 20 69 6e 6e 75 6d 29 20 31 36 29 andom innum) 16)
3970: 29 29 0a 09 28 77 65 65 6b 20 20 20 20 20 20 28 ))..(week (
3980: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 number->string (
3990: 71 75 6f 74 69 65 6e 74 20 28 63 75 72 72 65 6e quotient (curren
39a0: 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a 20 37 20 t-seconds) (* 7
39b0: 32 34 20 36 30 20 36 30 29 29 20 31 36 29 29 29 24 60 60)) 16)))
39c0: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
39d0: 28 73 69 7a 20 31 30 30 30 29 0a 09 20 20 20 20 (siz 1000)..
39e0: 20 20 20 28 6b 65 79 20 28 63 6f 6e 63 20 6b 65 (key (conc ke
39f0: 79 2d 74 79 70 65 20 77 65 65 6b 20 28 6d 6b 72 y-type week (mkr
3a00: 61 6e 64 73 74 72 20 31 30 30 29 29 29 0a 09 20 andstr 100)))..
3a10: 20 20 20 20 20 20 28 6e 75 6d 20 30 29 29 0a 20 (num 0)).
3a20: 20 20 20 20 20 28 69 66 20 28 73 3a 73 65 73 73 (if (s:sess
3a30: 69 6f 6e 2d 76 61 72 2d 67 65 74 20 6b 65 79 29 ion-var-get key)
3a40: 20 3b 3b 20 68 61 76 65 20 61 20 63 6f 6c 6c 69 ;; have a colli
3a50: 73 69 6f 6e 0a 09 20 20 28 6c 6f 6f 70 20 28 63 sion.. (loop (c
3a60: 6f 6e 64 20 20 20 20 20 20 20 20 20 20 20 20 20 ond
3a70: 20 20 20 20 3b 3b 20 69 6e 20 74 68 65 20 75 6e ;; in the un
3a80: 6c 69 6b 65 79 20 65 76 65 6e 74 20 77 65 20 68 likey event we h
3a90: 61 76 65 20 74 72 6f 75 62 6c 65 20 67 65 74 74 ave trouble gett
3aa0: 69 6e 67 20 61 20 6e 65 77 20 76 61 72 2c 20 6b ing a new var, k
3ab0: 65 65 70 20 69 6e 63 72 65 61 73 69 6e 67 20 74 eep increasing t
3ac0: 68 65 20 73 69 7a 65 20 6f 66 20 74 68 65 20 6e he size of the n
3ad0: 75 6d 62 65 72 0a 09 09 20 28 28 3c 20 6e 75 6d umber... ((< num
3ae0: 20 35 30 29 20 20 31 30 30 29 0a 09 09 20 28 28 50) 100)... ((
3af0: 3c 20 6e 75 6d 20 31 30 30 29 20 31 30 30 30 29 < num 100) 1000)
3b00: 0a 09 09 20 28 28 3c 20 6e 75 6d 20 32 30 30 29 ... ((< num 200)
3b10: 20 31 30 30 30 30 29 0a 09 09 20 28 28 3c 20 6e 10000)... ((< n
3b20: 75 6d 20 33 30 30 29 20 31 30 30 30 30 30 29 0a um 300) 100000).
3b30: 09 09 20 28 28 3c 20 6e 75 6d 20 34 30 30 29 20 .. ((< num 400)
3b40: 31 30 30 30 30 30 30 29 20 3b 3b 20 63 61 6e 27 1000000) ;; can'
3b50: 74 20 69 6d 61 67 69 6e 65 20 6e 65 65 64 69 6e t imagine needin
3b60: 67 20 74 6f 20 67 65 74 20 68 65 72 65 2e 20 72 g to get here. r
3b70: 65 6d 65 6d 62 65 72 20 74 68 61 74 20 74 68 69 emember that thi
3b80: 73 20 69 73 20 66 6f 72 20 61 20 73 69 6e 67 6c s is for a singl
3b90: 65 20 75 73 65 72 0a 09 09 20 28 65 6c 73 65 20 e user... (else
3ba0: 31 30 30 30 30 30 30 30 30 29 29 0a 09 09 28 63 100000000))...(c
3bb0: 6f 6e 63 20 6b 65 79 2d 74 79 70 65 20 28 6d 6b onc key-type (mk
3bc0: 72 61 6e 64 73 74 72 20 73 69 7a 29 29 0a 09 09 randstr siz))...
3bd0: 28 2b 20 6e 75 6d 20 31 29 29 0a 09 20 20 28 62 (+ num 1)).. (b
3be0: 65 67 69 6e 0a 09 20 20 20 20 28 73 3a 73 65 73 egin.. (s:ses
3bf0: 73 69 6f 6e 2d 76 61 72 2d 73 65 74 21 20 6b 65 sion-var-set! ke
3c00: 79 20 76 61 6c 29 0a 09 20 20 20 20 6b 65 79 29 y val).. key)
3c10: 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 ))))..;; given a
3c20: 20 6b 65 79 20 58 6e 6e 6e 6e 2c 20 6c 6f 6f 6b key Xnnnn, look
3c30: 20 75 70 20 74 68 65 20 73 74 6f 72 65 64 20 76 up the stored v
3c40: 61 6c 75 65 20 61 6e 64 20 63 6f 6e 76 65 72 74 alue and convert
3c50: 20 69 74 20 61 70 70 72 6f 70 72 69 61 74 65 6c it appropriatel
3c60: 79 2c 20 74 68 65 6e 0a 3b 3b 20 64 65 73 74 72 y, then.;; destr
3c70: 6f 79 20 74 68 65 20 73 74 6f 72 65 64 20 73 65 oy the stored se
3c80: 73 73 69 6f 6e 20 76 61 72 0a 3b 3b 0a 28 64 65 ssion var.;;.(de
3c90: 66 69 6e 65 20 28 73 3a 6b 65 79 2d 3e 76 61 6c fine (s:key->val
3ca0: 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 76 key). (let ((v
3cb0: 61 6c 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 al (s:session-va
3cc0: 72 2d 67 65 74 20 6b 65 79 29 29 0a 09 28 74 79 r-get key))..(ty
3cd0: 70 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f p (string->symbo
3ce0: 6c 20 28 73 75 62 73 74 72 69 6e 67 20 6b 65 79 l (substring key
3cf0: 20 30 20 31 29 29 29 29 0a 20 20 20 20 28 69 66 0 1)))). (if
3d00: 20 76 61 6c 0a 09 28 62 65 67 69 6e 0a 09 20 20 val..(begin..
3d10: 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d 64 (s:session-var-d
3d20: 65 6c 21 20 6b 65 79 29 0a 09 20 20 3b 3b 20 77 el! key).. ;; w
3d30: 65 20 74 61 6b 65 20 74 68 69 73 20 6f 70 70 6f e take this oppo
3d40: 72 74 75 6e 69 74 79 20 74 6f 20 63 6c 65 61 6e rtunity to clean
3d50: 20 75 70 20 6f 6c 64 20 6b 65 79 65 64 20 73 65 up old keyed se
3d60: 73 73 69 6f 6e 20 76 61 72 73 0a 09 20 20 3b 3b ssion vars.. ;;
3d70: 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 if more than 10
3d80: 30 20 76 61 72 73 2c 20 72 65 6d 6f 76 65 20 61 0 vars, remove a
3d90: 6c 6c 20 74 68 61 74 20 61 72 65 20 6f 76 65 72 ll that are over
3da0: 20 31 2d 32 20 77 65 65 6b 73 20 6f 6c 64 0a 09 1-2 weeks old..
3db0: 09 09 09 09 3b 28 73 3a 63 6c 65 61 6e 75 70 2d ....;(s:cleanup-
3dc0: 73 65 73 73 69 6f 6e 2d 76 61 72 73 29 0a 09 20 session-vars)..
3dd0: 20 28 63 61 73 65 20 74 79 70 0a 09 20 20 20 20 (case typ..
3de0: 28 28 6e 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ((n)(string->num
3df0: 62 65 72 20 76 61 6c 29 29 0a 09 20 20 20 20 28 ber val)).. (
3e00: 28 73 29 20 76 61 6c 29 0a 09 20 20 20 20 28 65 (s) val).. (e
3e10: 6c 73 65 20 76 61 6c 29 29 29 0a 09 76 61 6c 29 lse val)))..val)
3e20: 29 29 0a 20 20 0a 3b 3b 20 63 6c 65 61 6e 20 75 )). .;; clean u
3e30: 70 20 73 65 73 73 69 6f 6e 20 76 61 72 73 0a 3b p session vars.;
3e40: 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 63 6c 65 ;.(define (s:cle
3e50: 61 6e 75 70 2d 73 65 73 73 69 6f 6e 2d 76 61 72 anup-session-var
3e60: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 73 s). (let* ((ses
3e70: 73 69 6f 6e 2d 76 61 72 73 20 28 68 61 73 68 2d sion-vars (hash-
3e80: 74 61 62 6c 65 2d 6b 65 79 73 20 28 73 3a 73 65 table-keys (s:se
3e90: 73 73 69 6f 6e 2d 67 65 74 2d 73 65 73 73 69 6f ssion-get-sessio
3ea0: 6e 76 61 72 73 29 29 29 0a 09 20 28 77 65 65 6b nvars))).. (week
3eb0: 2d 6e 75 6d 20 20 20 20 20 28 71 75 6f 74 69 65 -num (quotie
3ec0: 6e 74 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f nt (current-seco
3ed0: 6e 64 73 29 20 28 2a 20 37 20 32 34 20 36 30 20 nds) (* 7 24 60
3ee0: 36 30 29 29 29 0a 09 20 28 77 65 65 6b 20 20 20 60))).. (week
3ef0: 20 20 20 20 20 20 28 6e 75 6d 62 65 72 2d 3e 73 (number->s
3f00: 74 72 69 6e 67 20 77 65 65 6b 2d 6e 75 6d 20 20 tring week-num
3f10: 31 36 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e 16))). (if (>
3f20: 20 28 6c 65 6e 67 74 68 20 73 65 73 73 69 6f 6e (length session
3f30: 2d 76 61 72 73 29 20 31 30 30 29 0a 09 28 66 6f -vars) 100)..(fo
3f40: 72 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 64 61 r-each.. (lambda
3f50: 20 28 76 61 72 29 0a 09 20 20 20 28 69 66 20 28 (var).. (if (
3f60: 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 > (string-length
3f70: 20 76 61 72 29 20 35 29 20 3b 3b 20 63 61 6e 27 var) 5) ;; can'
3f80: 74 20 68 61 76 65 20 6b 65 79 65 64 20 76 61 6c t have keyed val
3f90: 75 65 73 20 77 69 74 68 20 6b 65 79 73 20 6c 65 ues with keys le
3fa0: 73 73 20 74 68 61 6e 20 35 20 63 68 61 72 61 63 ss than 5 charac
3fb0: 74 65 72 73 20 6c 6f 6e 67 0a 09 20 20 20 20 20 ters long..
3fc0: 20 20 28 6c 65 74 20 28 28 76 61 72 2d 77 65 65 (let ((var-wee
3fd0: 6b 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 k (string->numbe
3fe0: 72 20 28 73 75 62 73 74 72 69 6e 67 20 76 61 72 r (substring var
3ff0: 20 31 20 34 29 20 31 36 29 29 29 0a 09 09 20 28 1 4) 16)))... (
4000: 69 66 20 28 61 6e 64 20 76 61 72 2d 77 65 65 6b if (and var-week
4010: 0a 09 09 09 20 20 28 3e 3d 20 28 2d 20 77 65 65 .... (>= (- wee
4020: 6b 2d 6e 75 6d 20 76 61 72 2d 77 65 65 6b 29 20 k-num var-week)
4030: 32 29 29 0a 09 09 20 20 20 20 20 28 73 3a 73 65 2))... (s:se
4040: 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c 21 20 76 ssion-var-del! v
4050: 61 72 29 29 29 29 29 0a 09 20 73 65 73 73 69 6f ar))))).. sessio
4060: 6e 2d 76 61 72 73 29 29 29 29 0a 0a 3b 3b 20 69 n-vars))))..;; i
4070: 6e 70 75 74 73 0a 3b 3b 0a 3b 3b 20 70 61 72 61 nputs.;;.;; para
4080: 6d 3a 20 28 64 74 79 70 65 20 5b 74 61 67 31 20 m: (dtype [tag1
4090: 74 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 tag2 ...]).;; dt
40a0: 79 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 20 ype:.;; 'raw
40b0: 20 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e 76 : do no conv
40c0: 65 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e 75 ersion.;; 'nu
40d0: 6d 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 20 mber : convert
40e0: 74 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 72 to number, retur
40f0: 6e 20 23 66 20 69 66 20 66 61 69 6c 73 0a 3b 3b n #f if fails.;;
4100: 20 20 20 20 27 65 73 63 61 70 65 64 20 3a 20 75 'escaped : u
4110: 73 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 74 se html-escape t
4120: 6f 20 70 72 6f 74 65 63 74 20 74 68 65 20 69 6e o protect the in
4130: 70 75 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 put.;;.(define (
4140: 73 3a 67 65 74 2d 69 6e 70 75 74 20 6b 65 79 20 s:get-input key
4150: 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 73 65 73 . params). (ses
4160: 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 20 73 sion:get-input s
4170: 3a 73 65 73 73 69 6f 6e 20 6b 65 79 20 70 61 72 :session key par
4180: 61 6d 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ams))..(define (
4190: 73 3a 67 65 74 2d 69 6e 70 75 74 2d 6b 65 79 73 s:get-input-keys
41a0: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ). (session:get
41b0: 2d 69 6e 70 75 74 2d 6b 65 79 73 20 73 3a 73 65 -input-keys s:se
41c0: 73 73 69 6f 6e 29 29 0a 0a 3b 3b 20 67 65 74 2d ssion))..;; get-
41d0: 69 6e 70 75 74 20 65 6c 73 65 2c 20 67 65 74 2d input else, get-
41e0: 70 61 72 61 6d 20 65 6c 73 65 20 23 66 0a 3b 3b param else #f.;;
41f0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 74 2d .(define (s:get-
4200: 69 6e 70 20 6b 65 79 20 2e 20 70 61 72 61 6d 73 inp key . params
4210: 29 0a 20 20 28 6f 72 20 28 61 70 70 6c 79 20 73 ). (or (apply s
4220: 3a 67 65 74 2d 69 6e 70 75 74 20 6b 65 79 20 70 :get-input key p
4230: 61 72 61 6d 73 29 0a 20 20 20 20 20 20 28 61 70 arams). (ap
4240: 70 6c 79 20 73 3a 67 65 74 2d 70 61 72 61 6d 20 ply s:get-param
4250: 6b 65 79 20 70 61 72 61 6d 73 29 29 29 0a 0a 23 key params)))..#
4260: 3b 28 64 65 66 69 6e 65 20 28 73 3a 6c 6f 61 64 ;(define (s:load
4270: 2d 6d 6f 64 65 6c 20 6d 6f 64 65 6c 29 0a 20 20 -model model).
4280: 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f (session:load-mo
4290: 64 65 6c 20 73 3a 73 65 73 73 69 6f 6e 20 6d 6f del s:session mo
42a0: 64 65 6c 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 del))..#;(define
42b0: 20 28 73 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 6d (s:model-path m
42c0: 6f 64 65 6c 29 0a 20 20 28 73 65 73 73 69 6f 6e odel). (session
42d0: 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 3a 73 65 :model-path s:se
42e0: 73 73 69 6f 6e 20 6d 6f 64 65 6c 29 29 0a 0a 3b ssion model))..;
42f0: 3b 20 73 68 61 72 65 20 64 61 74 61 20 62 65 74 ; share data bet
4300: 77 65 65 6e 20 70 61 67 65 73 20 63 61 6c 6c 73 ween pages calls
4310: 2e 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 . NOTE: This is
4320: 6e 6f 74 20 70 65 72 73 69 73 74 65 6e 74 0a 3b not persistent.;
4330: 3b 20 62 65 74 77 65 65 6e 20 63 67 69 20 63 61 ; between cgi ca
4340: 6c 6c 73 2e 20 55 73 65 20 73 65 73 73 69 6f 6e lls. Use session
4350: 76 61 72 73 20 66 6f 72 20 74 68 61 74 2e 0a 3b vars for that..;
4360: 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 68 61 ;.(define (s:sha
4370: 72 65 64 2d 68 61 73 68 29 0a 20 20 28 73 64 61 red-hash). (sda
4380: 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 3a t-shared-hash s:
4390: 73 65 73 73 69 6f 6e 29 29 0a 0a 28 64 65 66 69 session))..(defi
43a0: 6e 65 20 28 73 3a 73 68 61 72 65 64 2d 73 65 74 ne (s:shared-set
43b0: 21 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 68 61 ! key val). (ha
43c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 sh-table-set! (s
43d0: 64 61 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 dat-shared-hash
43e0: 73 3a 73 65 73 73 69 6f 6e 29 20 6b 65 79 20 76 s:session) key v
43f0: 61 6c 29 29 0a 0a 3b 3b 20 57 68 61 74 20 74 6f al))..;; What to
4400: 20 72 65 74 75 72 6e 20 77 68 65 6e 20 6e 6f 20 return when no
4410: 76 61 6c 75 65 20 66 6f 72 20 6b 65 79 3f 0a 3b value for key?.;
4420: 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 68 61 ;.(define (s:sha
4430: 72 65 64 2d 67 65 74 20 6b 65 79 29 0a 20 20 28 red-get key). (
4440: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4450: 65 66 61 75 6c 74 20 28 73 64 61 74 2d 73 68 61 efault (sdat-sha
4460: 72 65 64 2d 68 61 73 68 20 73 3a 73 65 73 73 69 red-hash s:sessi
4470: 6f 6e 29 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b on) key #f))..;;
4480: 20 68 74 74 70 3a 2f 2f 66 6f 6f 2e 62 61 72 2e http://foo.bar.
4490: 63 6f 6d 2f 70 61 67 65 6e 61 6d 65 2f 70 31 2f com/pagename/p1/
44a0: 70 32 20 3d 3e 20 27 28 22 70 31 22 20 22 70 32 p2 => '("p1" "p2
44b0: 22 29 0a 3b 3b 20 20 23 23 23 23 20 44 45 50 52 ").;; #### DEPR
44c0: 45 43 41 54 45 44 20 23 23 23 23 0a 28 64 65 66 ECATED ####.(def
44d0: 69 6e 65 20 28 73 3a 67 65 74 2d 70 61 67 65 2d ine (s:get-page-
44e0: 70 61 72 61 6d 73 29 0a 20 20 28 73 64 61 74 2d params). (sdat-
44f0: 70 61 74 68 2d 70 61 72 61 6d 73 20 73 3a 73 65 path-params s:se
4500: 73 73 69 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 ssion))..(define
4510: 20 28 73 3a 67 65 74 2d 70 61 74 68 2d 70 61 72 (s:get-path-par
4520: 61 6d 73 29 0a 20 20 28 73 64 61 74 2d 70 61 74 ams). (sdat-pat
4530: 68 2d 70 61 72 61 6d 73 20 73 3a 73 65 73 73 69 h-params s:sessi
4540: 6f 6e 29 29 0a 09 0a 0a 28 64 65 66 69 6e 65 20 on))....(define
4550: 28 73 3a 64 62 29 0a 20 20 28 73 64 61 74 2d 63 (s:db). (sdat-c
4560: 6f 6e 6e 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a onn s:session)).
4570: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 63 67 69 =========.;; cgi
45c0: 20 61 6e 64 20 73 65 73 73 69 6f 6e 20 73 74 75 and session stu
45d0: 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ff.;;===========
45e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 28 ===========..;;(
4620: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co
4630: 6f 6b 69 65 29 29 0a 3b 3b 28 64 65 63 6c 61 72 okie)).;;(declar
4640: 65 20 28 75 73 65 73 20 68 74 6d 6c 2d 66 69 6c e (uses html-fil
4650: 74 65 72 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 ter)).;;(declare
4660: 20 28 75 73 65 73 20 6d 69 73 63 2d 73 74 6d 6c (uses misc-stml
4670: 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 )).;;(declare (u
4680: 73 65 73 20 66 6f 72 6d 64 61 74 29 29 0a 3b 3b ses formdat)).;;
4690: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 (declare (uses s
46a0: 74 6d 6c 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 tml)).;;(declare
46b0: 20 28 75 73 65 73 20 73 65 73 73 69 6f 6e 29 29 (uses session))
46c0: 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 .;;(declare (use
46d0: 73 20 73 65 74 75 70 29 29 20 3b 3b 20 73 3a 73 s setup)) ;; s:s
46e0: 65 73 73 69 6f 6e 20 67 65 74 73 20 63 72 65 61 ession gets crea
46f0: 74 65 64 20 68 65 72 65 0a 3b 3b 28 64 65 63 6c ted here.;;(decl
4700: 61 72 65 20 28 75 73 65 73 20 73 71 6c 74 62 6c are (uses sqltbl
4710: 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 )).;;(declare (u
4720: 73 65 73 20 6b 65 79 73 74 6f 72 65 29 29 0a 0a ses keystore))..
4730: 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 ;; given a list
4740: 6f 66 20 73 79 6d 62 6f 6c 73 20 67 69 76 65 20 of symbols give
4750: 74 68 65 20 63 6f 75 6e 74 20 6f 66 20 74 68 65 the count of the
4760: 20 6d 61 74 63 68 69 6e 67 20 73 79 6d 62 6f 6c matching symbol
4770: 0a 3b 3b 20 6c 20 3d 3e 20 27 28 61 20 62 20 63 .;; l => '(a b c
4780: 29 20 20 28 64 75 6d 6f 62 6a 3a 69 6e 64 78 20 ) (dumobj:indx
4790: 61 20 27 62 29 20 3d 3e 20 31 0a 28 64 65 66 69 a 'b) => 1.(defi
47a0: 6e 65 20 28 73 3a 67 65 74 2d 66 69 65 6c 64 6e ne (s:get-fieldn
47b0: 75 6d 20 6c 73 74 20 66 69 65 6c 64 2d 6e 61 6d um lst field-nam
47c0: 65 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 e). (let loop (
47d0: 28 68 65 61 64 20 28 63 61 72 20 6c 73 74 29 29 (head (car lst))
47e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 . (t
47f0: 61 69 6c 20 28 63 64 72 20 6c 73 74 29 29 0a 20 ail (cdr lst)).
4800: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 75 (fnu
4810: 6d 20 30 29 29 0a 20 20 20 20 28 69 66 20 28 65 m 0)). (if (e
4820: 71 3f 20 68 65 61 64 20 66 69 65 6c 64 2d 6e 61 q? head field-na
4830: 6d 65 29 20 66 6e 75 6d 0a 20 20 20 20 20 20 20 me) fnum.
4840: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c (if (null? tail
4850: 29 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 ) #f.
4860: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
4870: 29 28 63 64 72 20 74 61 69 6c 29 28 2b 20 66 6e )(cdr tail)(+ fn
4880: 75 6d 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 um 1))))))..(def
4890: 69 6e 65 20 28 73 3a 66 69 65 6c 64 73 2d 3e 73 ine (s:fields->s
48a0: 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 73 74 tring lst). (st
48b0: 72 69 6e 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 ring-join (map s
48c0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6c 73 ymbol->string ls
48d0: 74 29 20 22 2c 22 29 29 0a 0a 28 64 65 66 69 6e t) ","))..(defin
48e0: 65 20 28 73 3a 76 65 63 74 6f 72 2d 67 65 74 2d e (s:vector-get-
48f0: 66 69 65 6c 64 20 76 65 63 20 66 69 65 6c 64 20 field vec field
4900: 66 69 65 6c 64 2d 6c 69 73 74 29 0a 20 20 28 76 field-list). (v
4910: 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 28 73 ector-ref vec (s
4920: 3a 67 65 74 2d 66 69 65 6c 64 6e 75 6d 20 66 69 :get-fieldnum fi
4930: 65 6c 64 2d 6c 69 73 74 20 66 69 65 6c 64 29 29 eld-list field))
4940: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
4950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b ===========.;;.;
4990: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
49a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49d0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6d 6f 76 65 =======..;; move
49e0: 64 20 74 6f 20 6d 69 73 63 2d 73 74 6d 6c 0a 3b d to misc-stml.;
49f0: 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 65 72 72 ;.#;(define (err
4a00: 3a 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 20 28 77 :log . msg). (w
4a10: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
4a20: 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f rt (current-erro
4a30: 72 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c 6f 74 r-port) ;; (slot
4a40: 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 70 74 -ref self 'logpt
4a50: 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 ). (lambda ()
4a60: 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 . (apply p
4a70: 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 rint msg))))..(d
4a80: 65 66 69 6e 65 20 28 73 3a 74 69 64 79 2d 75 72 efine (s:tidy-ur
4a90: 6c 20 75 72 6c 29 0a 20 20 28 69 66 20 75 72 6c l url). (if url
4aa0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 31 . (let ((r1
4ab0: 20 28 72 65 67 65 78 70 20 22 5e 68 74 74 70 3a (regexp "^http:
4ac0: 5c 5c 2f 5c 5c 2f 22 29 29 0a 20 20 20 20 20 20 \\/\\/")).
4ad0: 20 20 20 20 20 20 28 72 32 20 28 72 65 67 65 78 (r2 (regex
4ae0: 70 20 22 5e 5b 20 5c 5c 74 5d 2a 24 22 29 29 29 p "^[ \\t]*$")))
4af0: 20 3b 3b 20 62 6c 61 6e 6b 0a 20 20 20 20 20 20 ;; blank.
4b00: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
4b10: 74 63 68 20 72 31 20 75 72 6c 29 20 75 72 6c 0a tch r1 url) url.
4b20: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
4b30: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 32 (string-match r2
4b40: 20 75 72 6c 29 20 23 66 20 3b 3b 20 63 6f 6e 76 url) #f ;; conv
4b50: 65 72 74 20 61 20 62 6c 61 6e 6b 20 74 6f 20 23 ert a blank to #
4b60: 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f.
4b70: 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f (conc "http://
4b80: 22 20 75 72 6c 29 29 29 29 0a 20 20 20 20 20 20 " url)))).
4b90: 75 72 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 url))..(define (
4ba0: 73 3a 6c 61 7a 79 2d 3e 6e 75 6d 20 6e 75 6d 29 s:lazy->num num)
4bb0: 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 . (if (number?
4bc0: 6e 75 6d 29 20 6e 75 6d 0a 20 20 20 20 20 20 28 num) num. (
4bd0: 69 66 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 if (string->numb
4be0: 65 72 20 6e 75 6d 29 20 28 73 74 72 69 6e 67 2d er num) (string-
4bf0: 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a 09 20 20 >number num)..
4c00: 20 20 28 69 66 20 6e 75 6d 20 31 20 30 29 29 29 (if num 1 0)))
4c10: 29 20 3b 3b 20 77 69 65 72 64 20 65 68 21 20 79 ) ;; wierd eh! y
4c20: 65 70 2c 20 23 66 3d 3e 30 20 23 74 3d 3e 31 20 ep, #f=>0 #t=>1
4c30: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
4c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 ==========.;; D
4c80: 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d B.;;============
4c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 ==========..;; c
4cd0: 6f 6e 76 65 72 74 20 76 61 6c 75 65 73 20 74 6f onvert values to
4ce0: 20 61 70 70 72 6f 70 72 69 61 74 65 20 73 74 72 appropriate str
4cf0: 69 6e 67 73 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e ings.;;.#;(defin
4d00: 65 20 28 73 3a 73 71 6c 70 61 72 61 6d 2d 76 61 e (s:sqlparam-va
4d10: 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 l->string val).
4d20: 20 28 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 (cond. ((list
4d30: 3f 20 20 20 76 61 6c 29 28 73 74 72 69 6e 67 2d ? val)(string-
4d40: 6a 6f 69 6e 20 28 6d 61 70 20 73 79 6d 62 6f 6c join (map symbol
4d50: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 20 22 2c ->string val) ",
4d60: 22 29 29 20 3b 3b 20 28 61 20 62 20 63 29 20 3d ")) ;; (a b c) =
4d70: 3e 20 61 2c 62 2c 63 0a 20 20 20 28 28 73 74 72 > a,b,c. ((str
4d80: 69 6e 67 3f 20 76 61 6c 29 28 63 6f 6e 63 20 22 ing? val)(conc "
4d90: 27 22 20 28 64 62 69 3a 65 73 63 61 70 65 2d 73 '" (dbi:escape-s
4da0: 74 72 69 6e 67 20 76 61 6c 29 20 22 27 22 29 29 tring val) "'"))
4db0: 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 . ((number? va
4dc0: 6c 29 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e l)(number->strin
4dd0: 67 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d g val)). ((sym
4de0: 62 6f 6c 3f 20 76 61 6c 29 28 64 62 69 3a 65 73 bol? val)(dbi:es
4df0: 63 61 70 65 2d 73 74 72 69 6e 67 20 28 73 79 6d cape-string (sym
4e00: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
4e10: 29 29 0a 20 20 20 28 28 62 6f 6f 6c 65 61 6e 3f )). ((boolean?
4e20: 20 76 61 6c 29 0a 20 20 20 20 28 69 66 20 76 61 val). (if va
4e30: 6c 20 22 54 52 55 45 22 20 22 46 41 4c 53 45 22 l "TRUE" "FALSE"
4e40: 29 29 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 )) ;; should th
4e50: 69 73 20 62 65 20 22 54 52 55 45 22 20 6f 72 20 is be "TRUE" or
4e60: 31 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1?.
4e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e80: 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 ;; should this
4e90: 62 65 20 22 46 41 4c 53 45 22 20 6f 72 20 30 20 be "FALSE" or 0
4ea0: 6f 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 or NULL?. (els
4eb0: 65 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 e. (err:log "
4ec0: 73 71 6c 70 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 sqlparam: unknow
4ed0: 6e 20 74 79 70 65 20 66 6f 72 20 76 61 6c 75 65 n type for value
4ee0: 3a 20 22 20 76 61 6c 29 0a 20 20 20 20 22 22 29 : " val). "")
4ef0: 29 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 72 61 6d ))..;; (sqlparam
4f00: 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 66 6f "INSERT INTO fo
4f10: 6f 28 6e 61 6d 65 2c 61 67 65 29 20 56 41 4c 55 o(name,age) VALU
4f20: 45 53 28 3f 2c 3f 29 3b 22 20 22 62 6f 62 22 20 ES(?,?);" "bob"
4f30: 32 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 20).;; NB// 1. v
4f40: 61 6c 75 65 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b alues only!! .;;
4f50: 20 20 20 20 20 20 32 2e 20 74 65 72 6d 69 6e 61 2. termina
4f60: 74 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 ting semicolon r
4f70: 65 71 75 69 72 65 64 20 28 75 73 65 64 20 61 73 equired (used as
4f80: 20 70 61 72 74 20 6f 66 20 6c 6f 67 69 63 29 0a part of logic).
4f90: 3b 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 6e 75 6d ;;.;; a=? 1 (num
4fa0: 62 65 72 29 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 ber) => a=1.;; a
4fb0: 3d 3f 20 31 20 28 73 74 72 69 6e 67 29 20 3d 3e =? 1 (string) =>
4fc0: 20 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 a='1'.;; a=? #f
4fd0: 20 20 20 20 20 20 20 20 20 3d 3e 20 61 3d 46 41 => a=FA
4fe0: 4c 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 LSE .;; a=? a (s
4ff0: 79 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b ymbol) => a=a .;
5000: 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 73 ;.#;(define (s:s
5010: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 2e 20 qlparam query .
5020: 61 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 args). (let* ((
5030: 71 75 65 72 79 2d 70 61 72 74 73 20 28 73 74 72 query-parts (str
5040: 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 79 20 ing-split query
5050: 22 3f 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "?")). (
5060: 6e 75 6d 2d 70 61 72 74 73 20 20 20 20 28 6c 65 num-parts (le
5070: 6e 67 74 68 20 71 75 65 72 79 2d 70 61 72 74 73 ngth query-parts
5080: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d )). (num
5090: 2d 61 72 67 73 20 20 20 20 28 6c 65 6e 67 74 68 -args (length
50a0: 20 61 72 67 73 29 29 29 0a 20 20 20 20 28 69 66 args))). (if
50b0: 20 28 6e 6f 74 20 28 3d 20 28 2b 20 6e 75 6d 2d (not (= (+ num-
50c0: 61 72 67 73 20 31 29 20 6e 75 6d 2d 70 61 72 74 args 1) num-part
50d0: 73 29 29 0a 20 20 20 20 20 20 20 20 28 65 72 72 s)). (err
50e0: 3a 6c 6f 67 20 22 45 52 52 4f 52 2c 20 73 71 6c :log "ERROR, sql
50f0: 70 61 72 61 6d 3a 20 77 72 6f 6e 67 20 6e 75 6d param: wrong num
5100: 62 65 72 20 6f 66 20 61 72 67 75 6d 65 6e 74 73 ber of arguments
5110: 20 6f 72 20 6d 69 73 73 69 6e 67 20 73 65 6d 69 or missing semi
5120: 63 6f 6c 6f 6e 2c 20 22 20 6e 75 6d 2d 61 72 67 colon, " num-arg
5130: 73 20 22 20 66 6f 72 20 71 75 65 72 79 20 22 20 s " for query "
5140: 71 75 65 72 79 29 0a 20 20 20 20 20 20 20 20 28 query). (
5150: 69 66 20 28 3d 20 6e 75 6d 2d 61 72 67 73 20 30 if (= num-args 0
5160: 29 20 71 75 65 72 79 0a 20 20 20 20 20 20 20 20 ) query.
5170: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
5180: 73 65 63 74 69 6f 6e 20 28 63 61 72 20 71 75 65 section (car que
5190: 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 20 20 ry-parts)).
51a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51b0: 20 20 28 74 61 69 6c 20 20 20 20 28 63 64 72 20 (tail (cdr
51c0: 71 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 query-parts)).
51d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51e0: 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 22 22 (result ""
51f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5200: 20 20 20 20 20 20 20 20 20 28 61 72 67 20 20 20 (arg
5210: 20 20 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 (car args)).
5220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5230: 20 20 20 20 20 28 61 72 67 74 61 69 6c 20 28 63 (argtail (c
5240: 64 72 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 dr args))).
5250: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
5260: 28 76 61 6c 73 74 72 20 20 20 20 28 73 3a 73 71 (valstr (s:sq
5270: 6c 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 74 72 69 lparam-val->stri
5280: 6e 67 20 61 72 67 29 29 0a 20 20 20 20 20 20 20 ng arg)).
5290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
52a0: 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 72 ewresult (conc r
52b0: 65 73 75 6c 74 20 73 65 63 74 69 6f 6e 20 76 61 esult section va
52c0: 6c 73 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 lstr))).
52d0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
52e0: 6c 3f 20 61 72 67 74 61 69 6c 29 20 3b 3b 20 77 l? argtail) ;; w
52f0: 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 20 20 20 e are done.
5300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5310: 63 6f 6e 63 20 6e 65 77 72 65 73 75 6c 74 20 28 conc newresult (
5320: 63 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 20 car tail)).
5330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5340: 6c 6f 6f 70 0a 20 20 20 20 20 20 20 20 20 20 20 loop.
5350: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 74 (car t
5360: 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ail).
5370: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 (cdr t
5380: 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ail).
5390: 20 20 20 20 20 20 20 20 20 20 6e 65 77 72 65 73 newres
53a0: 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ult.
53b0: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 61 72 (car ar
53c0: 67 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 gtail).
53d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 72 (cdr
53e0: 20 61 72 67 74 61 69 6c 29 29 29 29 29 29 29 29 argtail))))))))
53f0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
5400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d ===========.;; M
5440: 20 49 20 53 20 43 20 20 20 53 20 54 20 52 20 49 I S C S T R I
5450: 20 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 46 N G S T U F F
5460: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
5470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
54b0: 6e 65 20 28 73 3a 73 74 72 69 6e 67 2d 64 6f 77 ne (s:string-dow
54c0: 6e 63 61 73 65 20 73 74 72 29 0a 20 20 28 69 66 ncase str). (if
54d0: 20 28 73 74 72 69 6e 67 3f 20 73 74 72 29 0a 20 (string? str).
54e0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 (string-tra
54f0: 6e 73 6c 61 74 65 20 73 74 72 20 22 41 42 43 44 nslate str "ABCD
5500: 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 EFGHIJKLMNOPQRST
5510: 55 56 57 58 59 5a 22 20 22 61 62 63 64 65 66 67 UVWXYZ" "abcdefg
5520: 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 hijklmnopqrstuvw
5530: 78 79 7a 22 29 0a 20 20 20 20 20 20 73 74 72 29 xyz"). str)
5540: 29 20 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 73 ) ..;; (define s
5550: 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 ession:valid-cha
5560: 72 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c rs "abcdefghijkl
5570: 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 41 42 mnopqrstuvwxyzAB
5580: 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 CDEFGHIJKLMNOPQR
5590: 53 54 55 56 57 58 59 5a 30 31 32 33 34 35 36 37 STUVWXYZ01234567
55a0: 38 39 22 29 0a 23 3b 28 64 65 66 69 6e 65 20 73 89").#;(define s
55b0: 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 ession:valid-cha
55c0: 72 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c rs "abcdefghijkl
55d0: 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 30 31 mnopqrstuvwxyz01
55e0: 32 33 34 35 36 37 38 39 22 29 20 3b 3b 20 63 6f 23456789") ;; co
55f0: 6f 6b 69 65 73 20 61 72 65 20 63 61 73 65 20 69 okies are case i
5600: 6e 73 65 6e 73 69 74 69 76 65 2e 0a 23 3b 28 64 nsensitive..#;(d
5610: 65 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a 6e 75 efine session:nu
5620: 6d 2d 76 61 6c 69 64 2d 63 68 61 72 73 20 28 73 m-valid-chars (s
5630: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 65 73 tring-length ses
5640: 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 sion:valid-chars
5650: 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 ))..#;(define (s
5660: 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 68 2d 63 ession:get-nth-c
5670: 68 61 72 20 6e 74 68 29 0a 20 20 28 73 75 62 73 har nth). (subs
5680: 74 72 69 6e 67 20 73 65 73 73 69 6f 6e 3a 76 61 tring session:va
5690: 6c 69 64 2d 63 68 61 72 73 20 6e 74 68 20 20 28 lid-chars nth (
56a0: 2b 20 6e 74 68 20 31 29 29 29 0a 0a 23 3b 28 64 + nth 1)))..#;(d
56b0: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
56c0: 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 0a 20 20 et-rand-char).
56d0: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 68 (session:get-nth
56e0: 2d 63 68 61 72 20 28 72 61 6e 64 6f 6d 20 73 65 -char (random se
56f0: 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 2d ssion:num-valid-
5700: 63 68 61 72 73 29 29 29 0a 0a 23 3b 28 64 65 66 chars)))..#;(def
5710: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b ine (session:mak
5720: 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 6c 65 e-rand-string le
5730: 6e 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 n). (let loop (
5740: 28 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 (res "").
5750: 20 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 (n 1)).
5760: 20 20 20 28 69 66 20 28 3e 20 6e 20 6c 65 6e 29 (if (> n len)
5770: 20 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c 6f res. (lo
5780: 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e op (string-appen
5790: 64 20 72 65 73 20 28 73 65 73 73 69 6f 6e 3a 67 d res (session:g
57a0: 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 29 0a 20 et-rand-char)).
57b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 (+
57c0: 6e 20 31 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 79 n 1)))))..;; may
57d0: 62 65 20 72 65 70 6c 61 63 65 20 61 62 6f 76 65 be replace above
57e0: 20 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e make-rand-strin
57f0: 67 20 77 69 74 68 20 74 68 69 73 20 73 6f 6d 65 g with this some
5800: 64 61 79 3f 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e day?.;;.#;(defin
5810: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 6e 65 72 e (session:gener
5820: 69 63 2d 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 ic-make-rand-str
5830: 69 6e 67 20 6c 65 6e 20 73 65 65 64 2d 73 74 72 ing len seed-str
5840: 69 6e 67 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 ing). (let ((nu
5850: 6d 2d 63 68 61 72 73 20 28 73 74 72 69 6e 67 2d m-chars (string-
5860: 6c 65 6e 67 74 68 20 73 65 65 64 2d 73 74 72 69 length seed-stri
5870: 6e 67 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c ng))). (let l
5880: 6f 6f 70 20 28 28 72 65 73 20 22 22 29 0a 09 20 oop ((res "")..
5890: 20 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 (n 1)).
58a0: 20 20 20 20 20 28 6c 65 74 20 28 28 63 68 61 72 (let ((char
58b0: 2d 6e 75 6d 20 28 72 61 6e 64 6f 6d 20 6e 75 6d -num (random num
58c0: 2d 63 68 61 72 73 29 29 29 0a 09 28 69 66 20 28 -chars)))..(if (
58d0: 3e 20 6e 20 6c 65 6e 29 20 72 65 73 0a 09 20 20 > n len) res..
58e0: 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d (loop (string-
58f0: 61 70 70 65 6e 64 20 72 65 73 20 28 73 75 62 73 append res (subs
5900: 74 72 69 6e 67 20 73 65 65 64 2d 73 74 72 69 6e tring seed-strin
5910: 67 20 63 68 61 72 2d 6e 75 6d 20 28 2b 20 63 68 g char-num (+ ch
5920: 61 72 2d 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 ar-num 1)))...
5930: 28 2b 20 6e 20 31 29 29 29 29 29 29 29 0a 0a 3b (+ n 1)))))))..;
5940: 3b 20 52 65 6c 79 20 6f 6e 20 63 72 79 70 74 20 ; Rely on crypt
5950: 65 67 67 27 73 20 64 65 66 61 75 6c 74 20 73 65 egg's default se
5960: 74 74 69 6e 67 73 20 62 65 69 6e 67 20 73 65 63 ttings being sec
5970: 75 72 65 20 65 6e 6f 75 67 68 2c 20 61 63 63 65 ure enough, acce
5980: 70 74 0a 3b 3b 20 62 61 63 6b 77 61 72 64 73 2d pt.;; backwards-
5990: 63 6f 6d 70 61 74 69 62 6c 65 20 4f 70 65 6e 53 compatible OpenS
59a0: 53 4c 20 63 72 79 70 74 20 70 61 73 73 77 6f 72 SL crypt passwor
59b0: 64 73 20 74 6f 6f 2e 0a 3b 3b 0a 28 64 65 66 69 ds too..;;.(defi
59c0: 6e 65 20 28 73 3a 63 72 79 70 74 2d 70 61 73 73 ne (s:crypt-pass
59d0: 77 64 20 70 77 20 73 29 0a 20 20 28 63 3a 63 72 wd pw s). (c:cr
59e0: 79 70 74 20 70 77 20 28 6f 72 20 73 20 28 63 3a ypt pw (or s (c:
59f0: 63 72 79 70 74 2d 67 65 6e 73 61 6c 74 29 29 29 crypt-gensalt)))
5a00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 61 )..(define (s:pa
5a10: 73 73 77 6f 72 64 2d 6d 61 74 63 68 3f 20 70 61 ssword-match? pa
5a20: 73 73 77 6f 72 64 20 63 72 79 70 74 65 64 29 0a ssword crypted).
5a30: 20 20 28 6c 65 74 2a 20 28 28 73 61 6c 74 20 28 (let* ((salt (
5a40: 73 75 62 73 74 72 69 6e 67 20 63 72 79 70 74 65 substring crypte
5a50: 64 20 30 20 32 29 29 0a 20 20 20 20 20 20 20 20 d 0 2)).
5a60: 20 28 70 63 72 79 70 74 65 64 20 28 73 3a 63 72 (pcrypted (s:cr
5a70: 79 70 74 2d 70 61 73 73 77 64 20 70 61 73 73 77 ypt-passwd passw
5a80: 6f 72 64 20 73 61 6c 74 29 29 29 0a 20 20 20 20 ord salt))).
5a90: 3b 3b 20 28 73 3a 6c 6f 67 20 22 49 4e 46 4f 3a ;; (s:log "INFO:
5aa0: 20 70 63 72 79 70 74 65 64 3d 22 20 70 63 72 79 pcrypted=" pcry
5ab0: 70 74 65 64 20 22 20 63 72 79 70 74 65 64 3d 22 pted " crypted="
5ac0: 20 63 72 79 70 74 65 64 29 0a 20 20 20 20 28 61 crypted). (a
5ad0: 6e 64 20 28 73 74 72 69 6e 67 3f 20 70 61 73 73 nd (string? pass
5ae0: 77 6f 72 64 29 0a 20 20 20 20 20 20 20 20 20 28 word). (
5af0: 73 74 72 69 6e 67 3f 20 70 63 72 79 70 74 65 64 string? pcrypted
5b00: 29 0a 20 20 20 20 20 20 20 20 20 28 73 74 72 69 ). (stri
5b10: 6e 67 3d 3f 20 70 63 72 79 70 74 65 64 20 63 72 ng=? pcrypted cr
5b20: 79 70 74 65 64 29 29 29 29 0a 0a 3b 3b 20 28 72 ypted))))..;; (r
5b30: 65 61 64 2d 6c 69 6e 65 20 28 6f 70 65 6e 2d 69 ead-line (open-i
5b40: 6e 70 75 74 2d 70 69 70 65 20 22 65 63 68 6f 20 nput-pipe "echo
5b50: 66 6f 6f 20 7c 20 6d 6b 70 61 73 73 77 64 20 2d foo | mkpasswd -
5b60: 53 20 61 62 20 2d 73 22 29 29 0a 0a 3b 3b 20 42 S ab -s"))..;; B
5b70: 55 47 3a 20 54 68 65 20 72 65 67 65 78 20 69 6d UG: The regex im
5b80: 70 6c 65 6d 65 6e 74 73 20 61 20 72 75 6c 65 2c plements a rule,
5b90: 20 62 75 74 20 77 68 61 74 20 72 75 6c 65 3f 20 but what rule?
5ba0: 41 48 21 20 75 73 61 7a 74 65 6d 70 65 2c 20 67 AH! usaztempe, g
5bb0: 65 74 20 72 69 64 20 6f 66 20 74 68 69 73 3f 20 et rid of this?
5bc0: 4e 6f 2c 20 74 68 69 73 20 61 6c 73 6f 20 6c 6f No, this also lo
5bd0: 6f 6b 73 20 66 6f 72 20 26 6b 65 79 3d 76 61 6c oks for &key=val
5be0: 75 65 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 ue ....(define (
5bf0: 73 3a 76 61 6c 69 64 61 74 65 2d 75 72 69 29 0a s:validate-uri).
5c00: 20 20 28 6c 65 74 20 28 28 75 72 69 20 28 67 65 (let ((uri (ge
5c10: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
5c20: 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f riable "REQUEST_
5c30: 55 52 49 22 29 29 0a 09 28 71 72 73 20 28 67 65 URI"))..(qrs (ge
5c40: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
5c50: 72 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 riable "QUERY_ST
5c60: 52 49 4e 47 22 29 29 29 0a 20 20 20 20 28 69 66 RING"))). (if
5c70: 20 28 6e 6f 74 20 75 72 69 29 0a 09 28 73 65 74 (not uri)..(set
5c80: 21 20 75 72 69 20 71 72 73 29 29 0a 20 20 20 20 ! uri qrs)).
5c90: 28 69 66 20 75 72 69 0a 09 28 73 74 72 69 6e 67 (if uri..(string
5ca0: 2d 6d 61 74 63 68 20 0a 09 20 28 72 65 67 65 78 -match .. (regex
5cb0: 70 20 22 5e 28 2f 5b 61 2d 7a 5c 5c 2d 5c 5c 2e p "^(/[a-z\\-\\.
5cc0: 5f 3a 30 2d 39 5d 2a 29 2a 28 7c 5c 5c 3f 28 5b _:0-9]*)*(|\\?([
5cd0: 41 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d 5c 5c 2b A-Za-z0-9_\\-\\+
5ce0: 5d 2b 3d 5b 41 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c ]+=[A-Za-z0-9_\\
5cf0: 2d 5c 5c 2e 5c 5c 2b 5d 2a 26 7b 30 2c 31 7d 29 -\\.\\+]*&{0,1})
5d00: 2a 29 24 22 29 20 75 72 69 29 0a 09 28 62 65 67 *)$") uri)..(beg
5d10: 69 6e 0a 09 20 20 22 52 45 51 55 45 53 54 20 55 in.. "REQUEST U
5d20: 52 49 20 4e 4f 54 20 41 56 41 49 4c 41 42 4c 45 RI NOT AVAILABLE
5d30: 21 22 0a 09 20 20 28 6c 65 74 20 28 28 70 20 28 !".. (let ((p (
5d40: 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 open-input-pipe
5d50: 22 65 6e 76 22 29 29 29 0a 09 20 20 20 20 28 6c "env"))).. (l
5d60: 65 74 20 6c 6f 6f 70 20 28 28 6c 20 28 72 65 61 et loop ((l (rea
5d70: 64 2d 6c 69 6e 65 20 70 29 29 0a 09 09 20 20 20 d-line p))...
5d80: 20 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 09 (res '()))..
5d90: 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
5da0: 62 6a 65 63 74 3f 20 6c 29 0a 09 09 20 20 72 65 bject? l)... re
5db0: 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 s... (loop (rea
5dc0: 64 2d 6c 69 6e 65 20 70 29 28 63 6f 6e 73 20 28 d-line p)(cons (
5dd0: 6c 69 73 74 20 6c 20 22 3c 42 52 3e 22 29 20 72 list l "<BR>") r
5de0: 65 73 29 29 29 29 29 0a 09 20 20 23 74 29 29 29 es))))).. #t)))
5df0: 29 0a 0a 3b 3b 20 6d 6f 76 65 64 20 74 6f 20 6d )..;; moved to m
5e00: 69 73 63 2d 73 74 6d 6c 0a 3b 3b 0a 3b 3b 20 61 isc-stml.;;.;; a
5e10: 6e 79 74 68 69 6e 67 20 65 78 63 65 70 74 20 61 nything except a
5e20: 20 6c 69 73 74 20 69 73 20 63 6f 6e 76 65 72 74 list is convert
5e30: 65 64 20 74 6f 20 61 20 73 74 72 69 6e 67 21 21 ed to a string!!
5e40: 21 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 61 !.#;(define (s:a
5e50: 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a ny->string val).
5e60: 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 73 74 72 (cond. ((str
5e70: 69 6e 67 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 ing? val) val).
5e80: 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 ((number? val)
5e90: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
5ea0: 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 val)). ((symb
5eb0: 6f 6c 3f 20 76 61 6c 29 20 28 73 79 6d 62 6f 6c ol? val) (symbol
5ec0: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 20 ->string val)).
5ed0: 20 20 28 28 65 71 3f 20 76 61 6c 20 23 66 29 20 ((eq? val #f)
5ee0: 22 22 29 0a 20 20 20 28 28 65 71 3f 20 76 61 6c ""). ((eq? val
5ef0: 20 23 74 29 20 22 54 52 55 45 22 29 0a 20 20 20 #t) "TRUE").
5f00: 28 28 6c 69 73 74 3f 20 76 61 6c 29 20 76 61 6c ((list? val) val
5f10: 29 0a 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 ). (else .
5f20: 28 6c 65 74 20 28 28 6f 73 74 72 20 28 6f 70 65 (let ((ostr (ope
5f30: 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 n-output-string)
5f40: 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f )). (with-o
5f50: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 6f 73 utput-to-port os
5f60: 74 72 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 tr..(lambda ()..
5f70: 20 20 28 64 69 73 70 6c 61 79 20 76 61 6c 29 29 (display val))
5f80: 29 0a 20 20 20 20 20 20 28 67 65 74 2d 6f 75 74 ). (get-out
5f90: 70 75 74 2d 73 74 72 69 6e 67 20 6f 73 74 72 29 put-string ostr)
5fa0: 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 ))))..#;(define
5fb0: 28 73 3a 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 (s:any->number v
5fc0: 61 6c 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 al). (cond. (
5fd0: 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 20 76 (number? val) v
5fe0: 61 6c 29 0a 20 20 20 28 28 73 74 72 69 6e 67 3f al). ((string?
5ff0: 20 76 61 6c 29 20 20 28 73 74 72 69 6e 67 2d 3e val) (string->
6000: 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 20 20 number val)).
6010: 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 20 ((symbol? val)
6020: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
6030: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
6040: 76 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 val))). (else
6050: 20 20 20 20 23 66 29 29 29 0a 0a 3b 3b 20 4e 42 #f)))..;; NB
6060: 2f 2f 20 74 68 69 73 20 69 73 20 2a 69 6c 6c 65 // this is *ille
6070: 67 61 6c 2a 20 70 67 69 6e 74 0a 28 64 65 66 69 gal* pgint.(defi
6080: 6e 65 20 28 73 3a 69 6c 6c 65 67 61 6c 2d 70 67 ne (s:illegal-pg
6090: 69 6e 74 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 int val). (cond
60a0: 0a 20 20 20 28 28 3e 20 76 61 6c 20 32 31 34 37 . ((> val 2147
60b0: 34 38 33 36 34 37 29 20 31 29 0a 20 20 20 28 28 483647) 1). ((
60c0: 3c 20 76 61 6c 20 2d 32 31 34 37 34 38 33 36 34 < val -214748364
60d0: 38 29 20 2d 31 29 0a 20 20 20 28 65 6c 73 65 20 8) -1). (else
60e0: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
60f0: 73 3a 61 6e 79 2d 3e 70 67 69 6e 74 20 76 61 6c s:any->pgint val
6100: 29 0a 20 20 28 6c 65 74 20 28 28 6e 20 28 73 3a ). (let ((n (s:
6110: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 any->number val)
6120: 29 29 0a 20 20 20 20 28 69 66 20 6e 0a 09 28 69 )). (if n..(i
6130: 66 20 28 73 3a 69 6c 6c 65 67 61 6c 2d 70 67 69 f (s:illegal-pgi
6140: 6e 74 20 6e 29 0a 09 20 20 20 20 23 66 0a 09 20 nt n).. #f..
6150: 20 20 20 6e 29 0a 09 6e 29 29 29 0a 0a 3b 3b 20 n)..n)))..;;
6160: 73 74 72 69 6e 67 20 69 73 20 61 20 73 74 72 69 string is a stri
6170: 6e 67 20 61 6e 64 20 6e 6f 6e 2d 7a 65 72 6f 20 ng and non-zero
6180: 6c 65 6e 67 74 68 0a 28 64 65 66 69 6e 65 20 28 length.(define (
6190: 6d 69 73 63 3a 6e 6f 6e 2d 7a 65 72 6f 2d 73 74 misc:non-zero-st
61a0: 72 69 6e 67 20 73 74 72 29 0a 20 20 28 69 66 20 ring str). (if
61b0: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 73 74 (and (string? st
61c0: 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 3e r). (>
61d0: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
61e0: 73 74 72 29 20 30 29 29 0a 20 20 20 20 20 20 73 str) 0)). s
61f0: 74 72 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b tr. #f))..;
6200: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
6210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6240: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 74 6d 6c 2d =======.;; html-
6250: 66 69 6c 74 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d filter.;;=======
6260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
62a0: 28 64 65 66 69 6e 65 20 28 73 3a 73 70 6c 69 74 (define (s:split
62b0: 2d 73 74 72 69 6e 67 20 73 74 72 6e 67 20 64 65 -string strng de
62c0: 6c 69 6d 29 0a 20 20 28 69 66 20 28 65 71 3f 20 lim). (if (eq?
62d0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s
62e0: 74 72 6e 67 29 20 30 29 20 28 6c 69 73 74 20 73 trng) 0) (list s
62f0: 74 72 6e 67 29 0a 20 20 20 20 20 20 28 6c 65 74 trng). (let
6300: 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 6d 61 loop ((head (ma
6310: 6b 65 2d 73 74 72 69 6e 67 20 31 20 28 63 61 72 ke-string 1 (car
6320: 20 28 73 74 72 69 6e 67 2d 3e 6c 69 73 74 20 73 (string->list s
6330: 74 72 6e 67 29 29 29 29 0a 09 09 20 28 74 61 69 trng))))... (tai
6340: 6c 20 28 63 64 72 20 28 73 74 72 69 6e 67 2d 3e l (cdr (string->
6350: 6c 69 73 74 20 73 74 72 6e 67 29 29 29 0a 09 09 list strng)))...
6360: 20 28 64 65 73 74 20 27 28 29 29 0a 09 09 20 28 (dest '())... (
6370: 74 65 6d 70 20 22 22 29 29 0a 09 28 63 6f 6e 64 temp ""))..(cond
6380: 20 28 28 65 71 75 61 6c 3f 20 68 65 61 64 20 64 ((equal? head d
6390: 65 6c 69 6d 29 0a 09 20 20 20 20 20 20 20 28 73 elim).. (s
63a0: 65 74 21 20 64 65 73 74 20 28 61 70 70 65 6e 64 et! dest (append
63b0: 20 64 65 73 74 20 28 6c 69 73 74 20 74 65 6d 70 dest (list temp
63c0: 29 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 ))).. (set
63d0: 21 20 74 65 6d 70 20 22 22 29 29 0a 09 20 20 20 ! temp ""))..
63e0: 20 20 20 28 28 6e 75 6c 6c 3f 20 68 65 61 64 29 ((null? head)
63f0: 20 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 20 .. (set!
6400: 64 65 73 74 20 28 61 70 70 65 6e 64 20 64 65 73 dest (append des
6410: 74 20 28 6c 69 73 74 20 74 65 6d 70 29 29 29 29 t (list temp))))
6420: 0a 09 20 20 20 20 20 20 28 65 6c 73 65 20 28 73 .. (else (s
6430: 65 74 21 20 74 65 6d 70 20 28 73 74 72 69 6e 67 et! temp (string
6440: 2d 61 70 70 65 6e 64 20 74 65 6d 70 20 68 65 61 -append temp hea
6450: 64 29 29 29 29 20 3b 3b 20 65 6e 64 20 69 66 0a d)))) ;; end if.
6460: 09 28 63 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 74 .(cond ((null? t
6470: 61 69 6c 29 0a 09 20 20 20 20 20 20 20 28 73 65 ail).. (se
6480: 74 21 20 64 65 73 74 20 28 61 70 70 65 6e 64 20 t! dest (append
6490: 64 65 73 74 20 28 6c 69 73 74 20 74 65 6d 70 29 dest (list temp)
64a0: 29 29 20 64 65 73 74 29 0a 09 20 20 20 20 20 20 )) dest)..
64b0: 28 65 6c 73 65 20 28 6c 6f 6f 70 20 28 6d 61 6b (else (loop (mak
64c0: 65 2d 73 74 72 69 6e 67 20 31 20 28 63 61 72 20 e-string 1 (car
64d0: 74 61 69 6c 29 29 20 28 63 64 72 20 74 61 69 6c tail)) (cdr tail
64e0: 29 20 64 65 73 74 20 74 65 6d 70 29 29 29 29 29 ) dest temp)))))
64f0: 29 0a 0a 3b 3b 20 61 6c 6c 6f 77 65 64 2d 74 61 )..;; allowed-ta
6500: 67 73 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 gs is a list of
6510: 74 61 67 73 20 61 73 20 73 79 6d 62 6f 6c 73 3a tags as symbols:
6520: 0a 3b 3b 20 20 20 27 28 61 20 62 20 63 65 6e 74 .;; '(a b cent
6530: 65 72 20 70 20 61 29 0a 3b 3b 20 70 61 72 73 69 er p a).;; parsi
6540: 6e 67 20 69 73 20 73 69 6d 70 6c 69 73 74 69 63 ng is simplistic
6550: 20 61 6e 64 20 74 68 65 20 72 65 73 70 6f 6e 73 and the respons
6560: 65 20 63 6f 6e 73 65 72 76 61 74 69 76 65 0a 3b e conservative.;
6570: 3b 20 69 66 20 61 20 3c 20 69 73 20 66 6f 75 6e ; if a < is foun
6580: 64 20 77 69 74 68 6f 75 74 20 74 68 65 20 74 61 d without the ta
6590: 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 3e 20 g and closing >
65a0: 74 68 65 6e 0a 3b 3b 20 74 68 65 20 3c 20 6f 72 then.;; the < or
65b0: 20 3e 20 69 73 20 72 65 70 6c 61 63 65 64 20 77 > is replaced w
65c0: 69 74 68 20 26 6c 74 3b 20 6f 72 20 26 67 74 3b ith < or >
65d0: 20 77 69 74 68 6f 75 74 20 0a 3b 3b 20 65 76 65 without .;; eve
65e0: 6e 20 74 72 79 69 6e 67 20 68 61 72 64 20 74 6f n trying hard to
65f0: 20 66 69 67 75 72 65 20 6f 75 74 20 69 66 20 74 figure out if t
6600: 68 65 72 65 20 69 73 20 61 20 6c 65 67 69 74 20 here is a legit
6610: 74 61 67 20 0a 3b 3b 20 62 75 72 69 65 64 20 69 tag .;; buried i
6620: 6e 20 74 68 65 20 74 65 78 74 20 73 6f 6d 65 77 n the text somew
6630: 68 65 72 65 2e 0a 3b 3b 20 61 20 6c 69 73 74 20 here..;; a list
6640: 6f 66 20 73 74 72 69 6e 67 73 20 69 73 20 72 65 of strings is re
6650: 74 75 72 6e 65 64 2e 0a 3b 3b 0a 3b 3b 20 4e 4f turned..;;.;; NO
6660: 54 45 53 0a 3b 3b 20 31 2e 20 63 61 73 65 20 69 TES.;; 1. case i
6670: 73 20 69 6d 70 6f 72 74 61 6e 74 20 69 6e 20 74 s important in t
6680: 68 65 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 20 he allowed-tags
6690: 6c 69 73 74 21 0a 3b 3b 20 32 2e 20 6f 6e 6c 79 list!.;; 2. only
66a0: 20 22 73 6f 6c 69 64 22 20 74 61 67 73 20 61 72 "solid" tags ar
66b0: 65 20 73 75 70 70 6f 72 74 65 64 20 69 2e 65 2e e supported i.e.
66c0: 20 3c 61 20 68 72 65 66 3d 22 66 6f 6f 22 3e 20 <a href="foo">
66d0: 77 69 6c 6c 20 6e 6f 74 20 77 6f 72 6b 3f 0a 3b will not work?.;
66e0: 3b 0a 0a 3b 3b 20 28 73 3a 63 67 69 2d 6f 75 74 ;..;; (s:cgi-out
66f0: 20 28 65 76 61 6c 20 28 73 3a 6f 75 74 70 75 74 (eval (s:output
6700: 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 20 (s:html-filter
6710: 22 68 65 6c 6c 6f 3c 62 3e 67 6f 6f 64 62 79 65 "hello<b>goodbye
6720: 3c 2f 62 3e 3c 62 3e 20 65 68 22 20 27 28 61 20 </b><b> eh" '(a
6730: 62 20 69 29 29 29 29 0a 0a 3b 3b 20 73 74 72 61 b i))))..;; stra
6740: 74 65 67 79 0a 3b 3b 20 31 2e 20 63 6f 6e 76 65 tegy.;; 1. conve
6750: 72 74 20 5c 6e 20 74 6f 20 3c 6c 69 6e 65 66 65 rt \n to <linefe
6760: 65 64 3e 0a 3b 3b 20 32 2e 20 53 70 6c 69 74 20 ed>.;; 2. Split
6770: 6f 6e 20 22 3c 22 0a 3b 3b 20 33 2e 20 53 70 6c on "<".;; 3. Spl
6780: 69 74 20 6f 6e 20 22 3e 22 0a 3b 3b 20 34 2e 20 it on ">".;; 4.
6790: 46 69 78 0a 28 64 65 66 69 6e 65 20 28 73 3a 68 Fix.(define (s:h
67a0: 74 6d 6c 2d 66 69 6c 74 65 72 20 69 6e 70 75 74 tml-filter input
67b0: 2d 74 65 78 74 20 61 6c 6c 6f 77 65 64 2d 74 61 -text allowed-ta
67c0: 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 6f gs). (let* ((to
67d0: 6b 73 20 20 20 28 73 3a 73 74 72 2d 3e 74 6f 6b ks (s:str->tok
67e0: 73 20 69 6e 70 75 74 2d 74 65 78 74 29 29 0a 09 s input-text))..
67f0: 20 28 74 6d 70 20 20 20 20 28 73 3a 74 6f 6b 73 (tmp (s:toks
6800: 2d 3e 73 74 6d 6c 20 27 28 73 3a 6e 75 6c 6c 29 ->stml '(s:null)
6810: 20 23 66 20 74 6f 6b 73 20 61 6c 6c 6f 77 65 64 #f toks allowed
6820: 2d 74 61 67 73 29 29 0a 09 20 28 72 65 73 20 20 -tags)).. (res
6830: 20 20 28 63 61 72 20 74 6d 70 29 29 0a 09 20 28 (car tmp)).. (
6840: 6e 78 74 74 61 67 20 28 63 61 64 72 20 74 6d 70 nxttag (cadr tmp
6850: 29 29 0a 09 20 28 72 65 6d 20 20 20 20 28 63 61 )).. (rem (ca
6860: 64 64 72 20 74 6d 70 29 29 29 0a 20 20 20 20 72 ddr tmp))). r
6870: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 es))..(define (s
6880: 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 :html-filter->st
6890: 72 69 6e 67 20 69 6e 70 75 74 2d 74 65 78 74 20 ring input-text
68a0: 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 0a 20 20 allowed-tags).
68b0: 28 6c 65 74 20 28 28 6f 73 74 72 20 28 6f 70 65 (let ((ostr (ope
68c0: 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 n-output-string)
68d0: 29 29 0a 20 20 20 20 3b 3b 3b 20 28 73 3a 6f 75 )). ;;; (s:ou
68e0: 74 70 75 74 2d 6e 65 77 20 6f 73 74 72 20 28 73 tput-new ostr (s
68f0: 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 20 69 6e 70 :html-filter inp
6900: 75 74 2d 74 65 78 74 20 61 6c 6c 6f 77 65 64 2d ut-text allowed-
6910: 74 61 67 73 29 29 0a 20 20 20 20 28 73 3a 6f 75 tags)). (s:ou
6920: 74 70 75 74 2d 6e 65 77 20 6f 73 74 72 20 28 63 tput-new ostr (c
6930: 61 72 20 28 65 76 61 6c 20 28 73 3a 68 74 6d 6c ar (eval (s:html
6940: 2d 66 69 6c 74 65 72 20 69 6e 70 75 74 2d 74 65 -filter input-te
6950: 78 74 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 xt allowed-tags)
6960: 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ))). (string-
6970: 63 68 6f 6d 70 20 28 67 65 74 2d 6f 75 74 70 75 chomp (get-outpu
6980: 74 2d 73 74 72 69 6e 67 20 6f 73 74 72 29 29 29 t-string ostr)))
6990: 29 20 3b 3b 20 64 6f 6e 27 74 20 6e 65 65 64 20 ) ;; don't need
69a0: 74 68 65 20 6c 69 6e 65 66 65 65 64 2c 20 63 6f the linefeed, co
69b0: 75 6c 64 20 73 74 6f 70 20 61 64 64 69 6e 67 20 uld stop adding
69c0: 69 74 20 2e 2e 2e 0a 09 0a 3b 3b 20 20 20 20 20 it ......;;
69d0: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 29 0a (if (null? rem).
69e0: 3b 3b 20 09 72 65 73 20 27 28 29 29 0a 3b 3b 20 ;; .res '()).;;
69f0: 09 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 28 .(s:toks->stml (
6a00: 69 66 20 28 6c 69 73 74 3f 20 72 65 73 29 20 72 if (list? res) r
6a10: 65 73 20 27 28 29 29 20 23 66 20 72 65 6d 20 61 es '()) #f rem a
6a20: 6c 6c 6f 77 65 64 2d 74 61 67 73 29 29 29 29 0a llowed-tags)))).
6a30: 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 74 72 2d .(define (s:str-
6a40: 3e 74 6f 6b 73 20 73 74 72 29 0a 20 20 28 61 70 >toks str). (ap
6a50: 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 70 20 ply append (map
6a60: 28 6c 61 6d 62 64 61 20 28 74 6f 6b 29 0a 09 09 (lambda (tok)...
6a70: 20 20 20 20 20 20 20 28 69 6e 74 65 72 73 70 65 (interspe
6a80: 72 73 65 20 28 73 3a 73 70 6c 69 74 2d 73 74 72 rse (s:split-str
6a90: 69 6e 67 20 74 6f 6b 20 22 3e 22 29 20 22 3e 22 ing tok ">") ">"
6aa0: 29 29 20 0a 09 09 20 20 20 20 20 28 69 6e 74 65 )) ... (inte
6ab0: 72 73 70 65 72 73 65 20 28 73 3a 73 70 6c 69 74 rsperse (s:split
6ac0: 2d 73 74 72 69 6e 67 20 73 74 72 20 22 3c 22 29 -string str "<")
6ad0: 20 22 3c 22 29 29 29 29 0a 0a 28 64 65 66 69 6e "<"))))..(defin
6ae0: 65 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 e (s:tag->stml t
6af0: 61 67 29 0a 20 20 28 73 74 72 69 6e 67 2d 3e 73 ag). (string->s
6b00: 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 61 70 ymbol (string-ap
6b10: 70 65 6e 64 20 22 73 3a 22 20 28 73 79 6d 62 6f pend "s:" (symbo
6b20: 6c 2d 3e 73 74 72 69 6e 67 20 74 61 67 29 29 29 l->string tag)))
6b30: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 74 )...(define (s:t
6b40: 6f 6b 73 2d 3e 73 74 6d 6c 20 72 65 73 20 74 61 oks->stml res ta
6b50: 67 20 72 65 6d 20 61 6c 6c 6f 77 65 64 29 0a 20 g rem allowed).
6b60: 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 61 67 3a ;; (print "tag:
6b70: 20 22 20 74 61 67 20 22 20 72 65 6d 3a 20 22 20 " tag " rem: "
6b80: 72 65 6d 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c rem). (if (null
6b90: 3f 20 72 65 6d 29 0a 20 20 20 20 20 20 28 6c 69 ? rem). (li
6ba0: 73 74 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 st (append res (
6bb0: 69 66 20 74 61 67 0a 09 09 09 20 20 20 20 28 6c if tag.... (l
6bc0: 69 73 74 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c ist (s:tag->stml
6bd0: 20 74 61 67 29 29 0a 09 09 09 09 27 28 29 29 29 tag)).....'()))
6be0: 20 23 66 20 27 28 29 20 61 6c 6c 6f 77 65 64 29 #f '() allowed)
6bf0: 20 3b 3b 20 74 68 65 20 63 61 73 65 20 6f 66 20 ;; the case of
6c00: 61 20 6c 6f 6e 65 20 74 61 67 20 0a 20 20 20 20 a lone tag .
6c10: 20 20 3b 3b 20 68 61 6e 64 6c 65 20 61 20 73 74 ;; handle a st
6c20: 61 72 74 69 6e 67 20 74 61 67 0a 20 20 20 20 20 arting tag.
6c30: 20 28 6c 65 74 2a 20 28 28 74 6d 70 20 20 20 20 (let* ((tmp
6c40: 20 20 20 28 73 3a 75 70 74 6f 2d 74 61 67 20 72 (s:upto-tag r
6c50: 65 6d 20 61 6c 6c 6f 77 65 64 29 29 0a 09 20 20 em allowed))..
6c60: 20 20 20 28 74 78 74 20 20 20 20 20 20 20 28 63 (txt (c
6c70: 61 72 20 74 6d 70 29 29 20 20 20 20 20 20 3b 3b ar tmp)) ;;
6c80: 20 74 68 69 73 20 74 78 74 20 67 6f 65 73 20 77 this txt goes w
6c90: 69 74 68 20 74 61 67 21 21 21 0a 09 20 20 20 20 ith tag!!!..
6ca0: 20 28 6e 65 78 74 74 61 67 20 20 20 28 63 61 64 (nexttag (cad
6cb0: 72 20 74 6d 70 29 29 20 20 20 20 20 3b 3b 20 74 r tmp)) ;; t
6cc0: 68 69 73 20 69 73 20 74 68 65 20 4e 45 58 54 20 his is the NEXT
6cd0: 44 41 4d 4e 20 74 61 67 21 0a 09 20 20 20 20 20 DAMN tag!..
6ce0: 28 62 65 67 69 6e 2d 74 61 67 20 28 63 61 64 64 (begin-tag (cadd
6cf0: 72 20 74 6d 70 29 29 0a 09 20 20 20 20 20 28 6e r tmp)).. (n
6d00: 65 77 72 65 6d 20 20 20 20 28 63 61 64 64 64 72 ewrem (cadddr
6d10: 20 74 6d 70 29 29 29 0a 09 3b 3b 20 28 70 72 69 tmp)))..;; (pri
6d20: 6e 74 20 22 74 78 74 3a 20 20 20 20 20 20 20 20 nt "txt:
6d30: 22 20 74 78 74 20 22 5c 6e 6e 65 78 74 74 61 67 " txt "\nnexttag
6d40: 3a 20 20 20 20 22 20 6e 65 78 74 74 61 67 20 22 : " nexttag "
6d50: 5c 6e 62 65 67 69 6e 2d 74 61 67 3a 20 20 22 20 \nbegin-tag: "
6d60: 62 65 67 69 6e 2d 74 61 67 20 22 5c 6e 6e 65 77 begin-tag "\nnew
6d70: 72 65 6d 3a 20 20 20 20 20 22 20 6e 65 77 72 65 rem: " newre
6d80: 6d 20 22 5c 6e 72 65 73 3a 20 20 20 20 20 20 20 m "\nres:
6d90: 20 22 20 72 65 73 20 22 5c 6e 22 29 0a 09 28 69 " res "\n")..(i
6da0: 66 20 62 65 67 69 6e 2d 74 61 67 20 3b 3b 20 6e f begin-tag ;; n
6db0: 65 73 74 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e est the followin
6dc0: 67 20 73 74 75 66 66 0a 09 20 20 20 20 28 6c 65 g stuff.. (le
6dd0: 74 2a 20 28 28 63 68 69 6c 64 64 61 74 20 28 73 t* ((childdat (s
6de0: 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 27 28 29 20 :toks->stml '()
6df0: 6e 65 78 74 74 61 67 20 6e 65 77 72 65 6d 20 61 nexttag newrem a
6e00: 6c 6c 6f 77 65 64 29 29 0a 09 09 20 20 20 28 63 llowed))... (c
6e10: 68 69 6c 64 20 20 20 20 28 63 61 72 20 63 68 69 hild (car chi
6e20: 6c 64 64 61 74 29 29 0a 09 09 20 20 20 28 6e 65 lddat))... (ne
6e30: 77 74 61 67 20 20 20 28 63 61 64 72 20 63 68 69 wtag (cadr chi
6e40: 6c 64 64 61 74 29 29 0a 09 09 20 20 20 28 6e 65 lddat))... (ne
6e50: 77 72 65 6d 32 20 20 28 63 61 64 64 72 20 63 68 wrem2 (caddr ch
6e60: 69 6c 64 64 61 74 29 29 0a 09 09 20 20 20 28 61 ilddat))... (a
6e70: 6c 6c 6f 77 65 64 20 20 28 63 61 64 64 64 72 20 llowed (cadddr
6e80: 63 68 69 6c 64 64 61 74 29 29 29 20 3b 3b 20 79 childdat))) ;; y
6e90: 61 2c 20 69 74 20 73 68 6f 75 6c 64 6e 27 74 20 a, it shouldn't
6ea0: 68 61 76 65 20 63 68 61 6e 67 65 64 0a 09 20 20 have changed..
6eb0: 20 20 20 20 28 69 66 20 74 61 67 20 0a 09 09 20 (if tag ...
6ec0: 20 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 28 (s:toks->stml (
6ed0: 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 append res (list
6ee0: 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 28 (append (list (
6ef0: 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 61 67 29 s:tag->stml tag)
6f00: 29 20 63 68 69 6c 64 20 28 6c 69 73 74 20 74 78 ) child (list tx
6f10: 74 29 29 29 29 0a 09 09 09 09 6e 65 77 74 61 67 t)))).....newtag
6f20: 20 6e 65 77 72 65 6d 32 20 61 6c 6c 6f 77 65 64 newrem2 allowed
6f30: 29 0a 09 09 20 20 28 73 3a 74 6f 6b 73 2d 3e 73 )... (s:toks->s
6f40: 74 6d 6c 20 28 61 70 70 65 6e 64 20 72 65 73 20 tml (append res
6f50: 28 6c 69 73 74 20 74 78 74 29 20 63 68 69 6c 64 (list txt) child
6f60: 29 0a 09 09 09 09 6e 65 77 74 61 67 20 6e 65 77 ).....newtag new
6f70: 72 65 6d 32 20 61 6c 6c 6f 77 65 64 29 29 29 0a rem2 allowed))).
6f80: 09 20 20 20 20 3b 3b 20 69 74 20 6d 75 73 74 20 . ;; it must
6f90: 68 61 76 65 20 62 65 65 6e 20 61 6e 20 65 6e 64 have been an end
6fa0: 20 74 61 67 0a 09 20 20 20 20 28 6c 69 73 74 20 tag.. (list
6fb0: 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 (append res (lis
6fc0: 74 20 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 t .... (if
6fd0: 20 74 61 67 0a 09 09 09 09 20 20 20 28 6c 69 73 tag..... (lis
6fe0: 74 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 t (s:tag->stml t
6ff0: 61 67 29 20 74 78 74 29 0a 09 09 09 09 20 20 20 ag) txt).....
7000: 74 78 74 29 29 29 0a 09 09 20 20 23 66 0a 09 09 txt)))... #f...
7010: 20 20 6e 65 77 72 65 6d 0a 09 09 20 20 61 6c 6c newrem... all
7020: 6f 77 65 64 29 29 29 29 29 0a 0a 0a 3b 3b 20 22 owed)))))...;; "
7030: 3c 22 20 22 62 22 20 22 3e 22 20 20 3d 3e 20 22 <" "b" ">" => "
7040: 3c 62 3e 22 0a 3b 3b 20 22 3c 22 0a 3b 3b 20 28 <b>".;; "<".;; (
7050: 64 65 66 69 6e 65 20 28 73 3a 72 65 62 75 69 6c define (s:rebuil
7060: 64 2d 74 61 67 73 20 69 6e 70 75 74 2d 6c 69 73 d-tags input-lis
7070: 74 29 0a 0a 3b 3b 20 28 22 62 6c 61 68 20 62 6c t)..;; ("blah bl
7080: 61 68 22 20 22 3c 22 20 22 62 22 20 22 3e 22 20 ah" "<" "b" ">"
7090: 22 6d 6f 72 65 20 73 74 75 66 66 22 20 22 3c 22 "more stuff" "<"
70a0: 20 22 69 22 20 22 3e 22 20 29 20 0a 3b 3b 20 20 "i" ">" ) .;;
70b0: 20 20 20 3d 3e 20 28 22 62 6c 61 68 20 62 6c 61 => ("blah bla
70c0: 68 22 20 62 20 23 74 20 28 20 22 6d 6f 72 65 20 h" b #t ( "more
70d0: 73 74 75 66 66 22 20 22 3c 22 20 22 69 22 20 22 stuff" "<" "i" "
70e0: 3e 22 20 29 29 0a 3b 3b 20 28 22 62 6c 61 68 20 >" )).;; ("blah
70f0: 62 6c 61 68 22 20 22 3c 22 20 22 2f 62 22 20 22 blah" "<" "/b" "
7100: 3e 22 20 22 6d 6f 72 65 20 73 74 75 66 66 22 20 >" "more stuff"
7110: 22 3c 22 20 22 69 22 20 22 3e 22 20 29 20 0a 3b "<" "i" ">" ) .;
7120: 3b 20 20 20 20 20 3d 3e 20 28 22 62 6c 61 68 20 ; => ("blah
7130: 62 6c 61 68 22 20 62 20 23 66 20 28 20 22 6d 6f blah" b #f ( "mo
7140: 72 65 20 73 74 75 66 66 22 20 22 3c 22 20 22 69 re stuff" "<" "i
7150: 22 20 22 3e 22 20 29 29 0a 28 64 65 66 69 6e 65 " ">" )).(define
7160: 20 28 73 3a 75 70 74 6f 2d 74 61 67 20 69 6e 6c (s:upto-tag inl
7170: 73 74 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 st allowed-tags)
7180: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 69 6e . (if (null? in
7190: 6c 73 74 29 20 69 6e 6c 73 74 0a 20 20 20 20 20 lst) inlst.
71a0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 6f 6b (let loop ((tok
71b0: 20 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 (car inlst))..
71c0: 09 20 28 74 61 69 6c 20 28 63 64 72 20 69 6e 6c . (tail (cdr inl
71d0: 73 74 29 29 0a 09 09 20 28 70 72 65 6c 20 22 22 st))... (prel ""
71e0: 29 29 20 3b 3b 20 63 72 65 61 74 65 20 61 20 73 )) ;; create a s
71f0: 74 72 69 6e 67 20 6f 72 20 61 20 6c 69 73 74 20 tring or a list
7200: 6f 66 20 73 74 72 69 6e 67 20 70 61 72 74 73 3f of string parts?
7210: 0a 09 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 ..(if (string=?
7220: 74 6f 6b 20 22 3c 22 29 20 3b 3b 20 6d 69 67 68 tok "<") ;; migh
7230: 74 20 68 61 76 65 20 61 20 74 61 67 0a 09 20 20 t have a tag..
7240: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
7250: 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 6f 20 tail) 1) ;; to
7260: 62 65 20 61 20 74 61 67 2c 20 6e 65 65 64 20 74 be a tag, need t
7270: 61 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 22 ag and closing "
7280: 3e 22 0a 09 09 28 6c 65 74 20 28 28 74 61 67 20 >"...(let ((tag
7290: 28 63 61 72 20 74 61 69 6c 29 29 0a 09 09 20 20 (car tail))...
72a0: 20 20 20 20 28 65 6e 64 20 28 63 61 64 72 20 74 (end (cadr t
72b0: 61 69 6c 29 29 0a 09 09 20 20 20 20 20 20 28 72 ail))... (r
72c0: 65 6d 20 28 63 64 64 72 20 74 61 69 6c 29 29 29 em (cddr tail)))
72d0: 20 0a 09 09 20 20 28 69 66 20 28 73 74 72 69 6e ... (if (strin
72e0: 67 3d 3f 20 65 6e 64 20 22 3e 22 29 20 3b 3b 20 g=? end ">") ;;
72f0: 79 65 70 2c 20 69 74 20 69 73 20 70 72 6f 62 61 yep, it is proba
7300: 62 6c 79 20 61 20 74 61 67 0a 09 09 20 20 20 20 bly a tag...
7310: 20 20 28 6c 65 74 2a 20 28 28 74 72 69 6d 2d 74 (let* ((trim-t
7320: 61 67 20 28 69 66 20 20 28 73 74 72 69 6e 67 3d ag (if (string=
7330: 3f 20 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 ? "/" (substring
7340: 20 74 61 67 20 30 20 31 29 29 0a 09 09 09 09 09 tag 0 1))......
7350: 20 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 74 (substring t
7360: 61 67 20 31 20 28 73 74 72 69 6e 67 2d 6c 65 6e ag 1 (string-len
7370: 67 74 68 20 74 61 67 29 29 20 23 66 29 29 0a 09 gth tag)) #f))..
7380: 09 09 20 20 20 20 20 28 74 61 67 2d 73 79 6d 20 .. (tag-sym
7390: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
73a0: 20 28 69 66 20 74 72 69 6d 2d 74 61 67 20 74 72 (if trim-tag tr
73b0: 69 6d 2d 74 61 67 20 74 61 67 29 29 29 29 0a 09 im-tag tag))))..
73c0: 09 09 28 69 66 20 28 6d 65 6d 62 65 72 20 74 61 ..(if (member ta
73d0: 67 2d 73 79 6d 20 61 6c 6c 6f 77 65 64 2d 74 61 g-sym allowed-ta
73e0: 67 73 29 0a 09 09 09 20 20 20 20 3b 3b 20 68 61 gs).... ;; ha
73f0: 76 65 20 61 20 76 61 6c 69 64 20 74 61 67 2c 20 ve a valid tag,
7400: 72 65 62 75 69 6c 64 20 69 74 20 61 6e 64 20 72 rebuild it and r
7410: 65 74 75 72 6e 20 74 68 65 20 72 65 73 75 6c 74 eturn the result
7420: 0a 09 09 09 20 20 20 20 28 6c 69 73 74 20 70 72 .... (list pr
7430: 65 6c 20 74 61 67 2d 73 79 6d 20 28 69 66 20 74 el tag-sym (if t
7440: 72 69 6d 2d 74 61 67 20 23 66 20 23 74 29 20 72 rim-tag #f #t) r
7450: 65 6d 29 0a 09 09 09 20 20 20 20 3b 3b 20 6e 6f em).... ;; no
7460: 74 20 61 20 76 61 6c 69 64 20 74 61 67 2c 20 63 t a valid tag, c
7470: 6f 6e 76 65 72 74 20 22 3c 22 20 61 6e 64 20 22 onvert "<" and "
7480: 3e 22 20 61 6e 64 20 61 64 64 20 61 6c 6c 20 74 >" and add all t
7490: 6f 20 70 72 65 6c 0a 09 09 09 20 20 20 20 28 6c o prel.... (l
74a0: 65 74 20 28 28 6e 65 77 70 72 65 6c 20 28 73 74 et ((newprel (st
74b0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 70 72 65 6c ring-append prel
74c0: 20 22 26 6c 74 3b 22 20 74 61 67 20 22 26 67 74 "<" tag ">
74d0: 3b 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 ;"))).... (
74e0: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 29 28 6c if (null? rem)(l
74f0: 69 73 74 20 6e 65 77 70 72 65 6c 20 23 66 20 23 ist newprel #f #
7500: 66 20 27 28 29 29 20 3b 3b 20 72 65 74 75 72 6e f '()) ;; return
7510: 20 6e 65 77 70 72 65 6c 20 2d 20 61 64 64 20 23 newprel - add #
7520: 66 20 23 66 20 3f 3f 3f 0a 09 09 09 09 20 20 28 f #f ???..... (
7530: 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 29 28 63 loop (car rem)(c
7540: 64 72 20 72 65 6d 29 20 6e 65 77 70 72 65 6c 29 dr rem) newprel)
7550: 29 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 ))))... ;;
7560: 73 6f 2c 20 69 74 20 77 61 73 6e 27 74 20 61 20 so, it wasn't a
7570: 74 61 67 0a 09 09 20 20 20 20 20 20 28 6c 65 74 tag... (let
7580: 20 28 28 6e 65 77 70 72 65 6c 20 28 73 74 72 69 ((newprel (stri
7590: 6e 67 2d 61 70 70 65 6e 64 20 70 72 65 6c 20 22 ng-append prel "
75a0: 26 6c 74 3b 22 20 74 61 67 29 29 29 0a 09 09 09 <" tag)))....
75b0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 (if (null? tail)
75c0: 0a 09 09 09 20 20 20 20 28 6c 69 73 74 20 6e 65 .... (list ne
75d0: 77 70 72 65 6c 20 23 66 20 23 66 20 27 28 29 29 wprel #f #f '())
75e0: 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 .... (loop (c
75f0: 61 72 20 72 65 6d 29 28 63 64 72 20 72 65 6d 29 ar rem)(cdr rem)
7600: 20 6e 65 77 70 72 65 6c 29 29 29 29 29 0a 09 09 newprel)))))...
7610: 3b 3b 20 74 6f 6f 20 73 68 6f 72 74 20 74 6f 20 ;; too short to
7620: 62 65 20 61 20 74 61 67 0a 09 09 28 6c 69 73 74 be a tag...(list
7630: 20 28 61 70 70 6c 79 20 73 74 72 69 6e 67 2d 61 (apply string-a
7640: 70 70 65 6e 64 20 70 72 65 6c 20 22 26 6c 74 3b ppend prel "<
7650: 22 20 74 61 69 6c 29 20 23 66 20 23 66 20 27 28 " tail) #f #f '(
7660: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 75 ))).. (if (nu
7670: 6c 6c 3f 20 74 61 69 6c 29 20 0a 09 09 3b 3b 20 ll? tail) ...;;
7680: 77 65 27 72 65 20 64 6f 6e 65 0a 09 09 28 6c 69 we're done...(li
7690: 73 74 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e st (string-appen
76a0: 64 20 70 72 65 6c 20 74 6f 6b 29 20 23 66 20 23 d prel tok) #f #
76b0: 66 20 27 28 29 29 0a 09 09 28 6c 6f 6f 70 20 28 f '())...(loop (
76c0: 63 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 car tail)(cdr ta
76d0: 69 6c 29 28 73 74 72 69 6e 67 2d 61 70 70 65 6e il)(string-appen
76e0: 64 20 70 72 65 6c 20 74 6f 6b 29 29 29 29 29 29 d prel tok))))))
76f0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 64 )...(define (s:d
7700: 69 76 79 2d 75 70 2d 63 67 69 2d 73 74 72 20 69 ivy-up-cgi-str i
7710: 6e 73 74 72 29 0a 20 20 28 6d 61 70 20 28 6c 61 nstr). (map (la
7720: 6d 62 64 61 20 28 78 29 20 28 73 74 72 69 6e 67 mbda (x) (string
7730: 2d 73 70 6c 69 74 20 78 20 22 3d 22 29 29 20 28 -split x "=")) (
7740: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e 73 string-split ins
7750: 74 72 20 22 26 22 29 29 29 0a 0a 28 64 65 66 69 tr "&")))..(defi
7760: 6e 65 20 28 73 3a 64 65 63 6f 64 65 2d 73 74 72 ne (s:decode-str
7770: 20 69 6e 73 74 72 29 0a 20 20 28 6c 65 74 2a 20 instr). (let*
7780: 28 28 61 62 63 20 28 73 74 72 69 6e 67 2d 73 75 ((abc (string-su
7790: 62 73 74 69 74 75 74 65 20 22 5c 5c 2b 22 20 22 bstitute "\\+" "
77a0: 20 22 20 69 6e 73 74 72 20 23 74 29 29 0a 09 20 " instr #t))..
77b0: 28 74 6f 6b 73 20 28 73 3a 73 70 6c 69 74 2d 73 (toks (s:split-s
77c0: 74 72 69 6e 67 20 61 62 63 20 22 25 22 29 29 29 tring abc "%")))
77d0: 0a 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e . (if (< (len
77e0: 67 74 68 20 74 6f 6b 73 29 20 32 29 20 61 62 63 gth toks) 2) abc
77f0: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
7800: 61 64 20 28 63 61 64 72 20 74 6f 6b 73 29 29 0a ad (cadr toks)).
7810: 09 09 20 20 20 28 74 61 69 6c 20 28 63 64 64 72 .. (tail (cddr
7820: 20 74 6f 6b 73 29 29 0a 09 09 20 20 20 28 72 65 toks))... (re
7830: 73 75 6c 74 20 28 63 61 72 20 74 6f 6b 73 29 29 sult (car toks))
7840: 29 0a 09 20 20 28 69 66 20 28 73 74 72 69 6e 67 ).. (if (string
7850: 3d 3f 20 68 65 61 64 20 22 22 29 0a 09 20 20 20 =? head "")..
7860: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
7870: 69 6c 29 0a 09 09 20 20 72 65 73 75 6c 74 0a 09 il)... result..
7880: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
7890: 69 6c 29 28 63 64 72 20 74 61 69 6c 29 20 72 65 il)(cdr tail) re
78a0: 73 75 6c 74 29 29 0a 09 20 20 20 20 20 20 28 6c sult)).. (l
78b0: 65 74 2a 20 28 28 6b 65 79 20 28 73 75 62 73 74 et* ((key (subst
78c0: 72 69 6e 67 20 68 65 61 64 20 30 20 32 29 29 0a ring head 0 2)).
78d0: 09 09 20 20 20 20 20 28 72 65 6d 20 28 73 75 62 .. (rem (sub
78e0: 73 74 72 69 6e 67 20 68 65 61 64 20 32 20 28 73 string head 2 (s
78f0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 68 65 61 tring-length hea
7900: 64 29 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d d)))... (num
7910: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
7920: 20 6b 65 79 20 31 36 29 29 0a 09 09 20 20 20 20 key 16))...
7930: 20 28 63 68 20 20 28 69 66 20 28 61 6e 64 20 28 (ch (if (and (
7940: 6e 75 6d 62 65 72 3f 20 6e 75 6d 29 0a 20 20 20 number? num).
7950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7970: 28 65 78 61 63 74 3f 20 6e 75 6d 29 29 0a 09 09 (exact? num))...
7980: 09 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d . (integer-
7990: 3e 63 68 61 72 20 6e 75 6d 29 0a 09 09 09 20 20 >char num)....
79a0: 20 20 20 20 23 66 29 29 20 3b 3b 20 74 68 69 73 #f)) ;; this
79b0: 20 69 73 20 61 6e 20 65 72 72 6f 72 2e 20 49 20 is an error. I
79c0: 77 69 6c 6c 20 70 72 6f 62 61 62 6c 79 20 72 65 will probably re
79d0: 67 72 65 74 20 74 68 69 73 20 73 6f 6d 65 20 64 gret this some d
79e0: 61 79 0a 09 09 20 20 20 20 20 28 63 68 73 74 72 ay... (chstr
79f0: 20 20 28 69 66 20 63 68 20 28 6d 61 6b 65 2d 73 (if ch (make-s
7a00: 74 72 69 6e 67 20 31 20 63 68 29 20 22 22 29 29 tring 1 ch) ""))
7a10: 0a 09 09 20 20 20 20 20 28 6e 65 77 72 65 73 20 ... (newres
7a20: 28 69 66 20 63 68 0a 09 09 09 09 20 28 73 74 72 (if ch..... (str
7a30: 69 6e 67 2d 61 70 70 65 6e 64 20 72 65 73 75 6c ing-append resul
7a40: 74 20 63 68 73 74 72 20 72 65 6d 29 0a 09 09 09 t chstr rem)....
7a50: 09 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 . (string-append
7a60: 20 72 65 73 75 6c 74 20 68 65 61 64 29 29 29 29 result head))))
7a70: 0a 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 68 65 ...;; (print "he
7a80: 61 64 3a 20 22 20 68 65 61 64 20 22 20 6e 75 6d ad: " head " num
7a90: 3a 20 22 20 6e 75 6d 20 22 20 63 68 3a 20 7c 22 : " num " ch: |"
7aa0: 20 63 68 20 22 7c 20 63 68 73 74 72 3a 20 22 20 ch "| chstr: "
7ab0: 63 68 73 74 72 29 0a 09 09 28 69 66 20 28 6e 75 chstr)...(if (nu
7ac0: 6c 6c 3f 20 74 61 69 6c 29 0a 09 09 20 20 20 20 ll? tail)...
7ad0: 6e 65 77 72 65 73 0a 09 09 20 20 20 20 28 6c 6f newres... (lo
7ae0: 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 64 op (car tail)(cd
7af0: 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 29 29 r tail) newres))
7b00: 29 29 29 29 29 29 0a 0a 3b 3b 20 70 72 6f 62 61 ))))))..;; proba
7b10: 62 6c 79 20 61 20 62 75 67 3a 0a 3b 3b 0a 3b 3b bly a bug:.;;.;;
7b20: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
7b30: 69 6e 70 75 74 20 22 3d 62 61 72 22 29 0a 3b 3b input "=bar").;;
7b40: 20 3d 3e 20 28 28 62 61 72 20 22 22 29 29 0a 3b => ((bar "")).;
7b50: 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 72 6f ;.(define (s:pro
7b60: 63 65 73 73 2d 63 67 69 2d 69 6e 70 75 74 20 69 cess-cgi-input i
7b70: 6e 73 74 72 29 0a 20 20 28 6d 61 70 20 28 6c 61 nstr). (map (la
7b80: 6d 62 64 61 20 28 78 79 29 0a 20 20 20 20 20 20 mbda (xy).
7b90: 20 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 (list (string
7ba0: 2d 3e 73 79 6d 62 6f 6c 20 28 73 3a 64 65 63 6f ->symbol (s:deco
7bb0: 64 65 2d 73 74 72 20 28 63 61 72 20 78 79 29 29 de-str (car xy))
7bc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7bd0: 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 (if (eq? (lengt
7be0: 68 20 78 79 29 20 31 29 20 0a 20 20 20 20 20 20 h xy) 1) .
7bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 22 0a "".
7c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c10: 20 20 20 28 73 3a 64 65 63 6f 64 65 2d 73 74 72 (s:decode-str
7c20: 20 28 63 61 64 72 20 78 79 29 29 29 29 29 0a 20 (cadr xy))))).
7c30: 20 20 20 20 20 20 20 20 28 73 3a 64 69 76 79 2d (s:divy-
7c40: 75 70 2d 63 67 69 2d 73 74 72 20 69 6e 73 74 72 up-cgi-str instr
7c50: 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 74 65 73 74 )))..;; for test
7c60: 69 6e 67 20 2d 2d 20 64 65 6c 65 74 6d 65 0a 3b ing -- deletme.;
7c70: 3b 20 28 64 65 66 69 6e 65 20 62 6c 61 68 20 22 ; (define blah "
7c80: 70 6f 73 74 5f 74 69 74 6c 65 3d 25 32 42 25 32 post_title=%2B%2
7c90: 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 B%2B%2B%2B%2B%2B
7ca0: 25 32 42 25 32 42 25 32 42 25 32 42 68 65 6c 6c %2B%2B%2B%2Bhell
7cb0: 6f 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2b 2b o-------------++
7cc0: 2b 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 36 25 +++++++++%26%26%
7cd0: 32 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 26%26%26%26%26%2
7ce0: 36 25 32 36 25 34 30 25 34 30 25 34 30 25 34 30 6%26%40%40%40%40
7cf0: 25 34 30 25 34 30 25 34 30 25 34 30 25 34 30 26 %40%40%40%40%40&
7d00: 70 6f 73 74 5f 62 6f 64 79 3d 25 32 42 25 32 42 post_body=%2B%2B
7d10: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 %2B%2B%2B%2B%2B%
7d20: 32 42 25 32 42 25 32 42 25 32 42 68 65 6c 6c 6f 2B%2B%2B%2Bhello
7d30: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2b 2b 2b -------------+++
7d40: 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 36 25 32 ++++++++%26%26%2
7d50: 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 6%26%26%26%26%26
7d60: 25 32 36 25 34 30 25 34 30 25 34 30 25 34 30 25 %26%40%40%40%40%
7d70: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 30 40%40%40%40%40%0
7d80: 44 25 30 41 25 30 44 25 30 41 25 32 42 25 32 42 D%0A%0D%0A%2B%2B
7d90: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 %2B%2B%2B%2B%2B%
7da0: 32 42 25 32 42 25 32 42 25 32 42 68 65 6c 6c 6f 2B%2B%2B%2Bhello
7db0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2b 2b 2b -------------+++
7dc0: 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 36 25 32 ++++++++%26%26%2
7dd0: 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 6%26%26%26%26%26
7de0: 25 32 36 25 34 30 25 34 30 25 34 30 25 34 30 25 %26%40%40%40%40%
7df0: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 30 40%40%40%40%40%0
7e00: 44 25 30 41 25 30 44 25 30 41 25 30 44 25 30 41 D%0A%0D%0A%0D%0A
7e10: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 %2B%2B%2B%2B%2B%
7e20: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 2B%2B%2B%2B%2B%2
7e30: 42 68 65 6c 6c 6f 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d Bhello----------
7e40: 2d 2d 2d 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 25 32 ---+++++++++++%2
7e50: 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 6%26%26%26%26%26
7e60: 25 32 36 25 32 36 25 32 36 25 34 30 25 34 30 25 %26%26%26%40%40%
7e70: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 34 40%40%40%40%40%4
7e80: 30 25 34 30 26 6e 65 77 5f 70 6f 73 74 3d 53 75 0%40&new_post=Su
7e90: 62 6d 69 74 22 29 0a 3b 3b 20 28 64 65 66 69 6e bmit").;; (defin
7ea0: 65 20 62 6c 61 68 32 20 22 70 6f 73 74 5f 74 69 e blah2 "post_ti
7eb0: 74 6c 65 3d 35 25 32 35 26 70 6f 73 74 5f 62 6f tle=5%25&post_bo
7ec0: 64 79 3d 61 6e 64 2b 31 30 25 32 35 26 6e 65 77 dy=and+10%25&new
7ed0: 5f 70 6f 73 74 3d 53 75 62 6d 69 74 22 29 0a 0a _post=Submit")..
7ee0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
7ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f20: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 66 6f 72 6d ========.;; form
7f30: 64 61 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d dat.;;==========
7f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
7f80: 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 2a 64 efine formdat:*d
7f90: 65 62 75 67 2a 20 23 66 29 0a 0a 3b 3b 20 4f 6c ebug* #f)..;; Ol
7fa0: 64 20 64 61 74 61 20 66 6f 72 6d 61 74 20 77 61 d data format wa
7fb0: 73 20 73 6f 6d 65 74 68 69 6e 67 20 6c 69 6b 65 s something like
7fc0: 20 74 68 69 73 2e 20 42 55 54 21 20 0a 3b 3b 20 this. BUT! .;;
7fd0: 46 6f 72 6d 73 20 64 6f 20 6e 6f 74 20 68 61 76 Forms do not hav
7fe0: 65 20 6e 61 6d 65 73 20 73 6f 20 74 68 65 20 68 e names so the h
7ff0: 69 65 72 61 72 63 79 20 69 73 0a 3b 3b 20 75 6e ierarcy is.;; un
8000: 6e 65 63 65 73 73 61 72 79 20 28 49 20 74 68 69 necessary (I thi
8010: 6e 6b 29 0a 3b 3b 0a 3b 3b 20 68 61 73 68 74 61 nk).;;.;; hashta
8020: 62 6c 65 0a 3b 3b 20 20 20 7c 2d 66 6f 72 6d 6e ble.;; |-formn
8030: 61 6d 65 20 2d 2d 3e 20 3c 66 6f 72 6d 64 61 74 ame --> <formdat
8040: 3e 20 27 66 6f 72 6d 2d 6e 61 6d 65 3d 66 6f 72 > 'form-name=for
8050: 6d 6e 61 6d 65 0a 3b 3b 20 20 20 7c 20 20 20 20 mname.;; |
8060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8070: 20 20 20 20 27 66 6f 72 6d 2d 64 61 74 61 3d 68 'form-data=h
8080: 61 73 68 74 61 62 6c 65 0a 3b 3b 20 20 20 7c 20 ashtable.;; |
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80b0: 20 20 20 20 20 20 7c 20 6e 61 6d 65 20 3d 3e 20 | name =>
80c0: 76 61 6c 75 65 0a 3b 3b 0a 3b 3b 20 4e 65 77 20 value.;;.;; New
80d0: 64 61 74 61 20 66 6f 72 6d 61 74 20 69 73 20 6f data format is o
80e0: 6e 6c 79 20 74 68 65 20 3c 66 6f 72 6d 64 61 74 nly the <formdat
80f0: 3e 20 70 6f 72 74 69 6f 6e 20 66 72 6f 6d 20 61 > portion from a
8100: 62 6f 76 65 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 bove..;; (define
8110: 2d 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e -class <formdat>
8120: 20 28 29 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 2d ().;; (form-
8130: 64 61 74 61 0a 3b 3b 20 20 20 20 29 29 0a 28 64 data.;; )).(d
8140: 65 66 69 6e 65 20 28 6d 61 6b 65 2d 66 6f 72 6d efine (make-form
8150: 64 61 74 3a 66 6f 72 6d 64 61 74 29 28 76 65 63 dat:formdat)(vec
8160: 74 6f 72 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 tor (make-hash-t
8170: 61 62 6c 65 29 29 29 0a 28 64 65 66 69 6e 65 2d able))).(define-
8180: 69 6e 6c 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a inline (formdat:
8190: 66 6f 72 6d 64 61 74 2d 67 65 74 2d 64 61 74 61 formdat-get-data
81a0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
81b0: 6f 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a or-ref vec 0)).
81c0: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
81d0: 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d formdat:formdat-
81e0: 73 65 74 2d 64 61 74 61 21 20 20 76 65 63 20 76 set-data! vec v
81f0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
8200: 76 65 63 20 30 20 76 61 6c 29 29 0a 0a 28 64 65 vec 0 val))..(de
8210: 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 69 6e fine (formdat:in
8220: 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 20 itialize self).
8230: 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 (formdat:formda
8240: 74 2d 73 65 74 2d 64 61 74 61 21 20 73 65 6c 66 t-set-data! self
8250: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
8260: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 e)))..(define (f
8270: 6f 72 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 20 ormdat:get self
8280: 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 key). (hash-tab
8290: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a le-ref/default .
82a0: 20 20 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d (formdat:form
82b0: 64 61 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c dat-get-data sel
82c0: 66 29 0a 20 20 20 28 63 6f 6e 64 20 0a 20 20 20 f). (cond .
82d0: 20 28 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 20 ((symbol? key)
82e0: 6b 65 79 29 0a 20 20 20 20 28 28 73 74 72 69 6e key). ((strin
82f0: 67 3f 20 6b 65 79 29 20 28 73 74 72 69 6e 67 2d g? key) (string-
8300: 3e 73 79 6d 62 6f 6c 20 6b 65 79 29 29 0a 20 20 >symbol key)).
8310: 20 20 28 65 6c 73 65 20 6b 65 79 29 29 0a 20 20 (else key)).
8320: 20 23 66 29 29 0a 0a 3b 3b 20 63 68 61 6e 67 65 #f))..;; change
8330: 20 74 6f 20 63 6f 6e 76 65 72 74 20 64 61 74 61 to convert data
8340: 20 74 6f 20 6c 69 73 74 20 61 6e 64 20 61 70 70 to list and app
8350: 65 6e 64 20 76 61 6c 20 69 66 20 61 6c 72 65 61 end val if alrea
8360: 64 79 20 65 78 69 73 74 73 0a 3b 3b 20 6f 72 20 dy exists.;; or
8370: 69 73 20 61 20 6c 69 73 74 0a 28 64 65 66 69 6e is a list.(defin
8380: 65 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 e (formdat:set!
8390: 73 65 6c 66 20 6b 65 79 20 76 61 6c 29 0a 20 20 self key val).
83a0: 28 6c 65 74 20 28 28 70 72 65 76 2d 76 61 6c 20 (let ((prev-val
83b0: 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 73 65 6c (formdat:get sel
83c0: 66 20 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 f key)).
83d0: 28 68 74 20 20 20 20 20 20 20 28 66 6f 72 6d 64 (ht (formd
83e0: 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 74 2d 64 at:formdat-get-d
83f0: 61 74 61 20 73 65 6c 66 29 29 29 0a 20 20 20 20 ata self))).
8400: 28 69 66 20 70 72 65 76 2d 76 61 6c 0a 20 20 20 (if prev-val.
8410: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
8420: 70 72 65 76 2d 76 61 6c 29 0a 20 20 20 20 20 20 prev-val).
8430: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
8440: 65 2d 73 65 74 21 20 68 74 20 6b 65 79 20 28 63 e-set! ht key (c
8450: 6f 6e 73 20 76 61 6c 20 70 72 65 76 2d 76 61 6c ons val prev-val
8460: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
8470: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8480: 68 74 20 6b 65 79 20 28 6c 69 73 74 20 76 61 6c ht key (list val
8490: 20 70 72 65 76 2d 76 61 6c 29 29 29 0a 20 20 20 prev-val))).
84a0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
84b0: 2d 73 65 74 21 20 68 74 20 6b 65 79 20 76 61 6c -set! ht key val
84c0: 29 29 0a 20 20 20 20 73 65 6c 66 29 29 0a 0a 28 )). self))..(
84d0: 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a define (formdat:
84e0: 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 28 68 61 keys self). (ha
84f0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 66 sh-table-keys (f
8500: 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 67 ormdat:formdat-g
8510: 65 74 2d 64 61 74 61 20 73 65 6c 66 29 29 29 0a et-data self))).
8520: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
8530: 74 3a 70 72 69 6e 74 61 6c 6c 20 73 65 6c 66 20 t:printall self
8540: 70 72 69 6e 74 70 72 6f 63 29 0a 20 20 28 70 72 printproc). (pr
8550: 69 6e 74 70 72 6f 63 20 22 66 6f 72 6d 64 61 74 intproc "formdat
8560: 3a 70 72 69 6e 74 61 6c 6c 20 22 20 28 66 6f 72 :printall " (for
8570: 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c 66 29 29 mdat:keys self))
8580: 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 . (for-each (la
8590: 6d 62 64 61 20 28 6b 29 0a 09 20 20 20 20 20 20 mbda (k)..
85a0: 28 70 72 69 6e 74 70 72 6f 63 20 6b 20 22 20 3d (printproc k " =
85b0: 3e 20 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 > " (formdat:get
85c0: 20 73 65 6c 66 20 6b 29 29 29 0a 09 20 20 20 20 self k)))..
85d0: 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 (formdat:keys se
85e0: 6c 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 lf)))..(define (
85f0: 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 formdat:all->str
8600: 69 6e 67 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 ings self). (le
8610: 74 20 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 t ((res '())).
8620: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
8630: 62 64 61 20 28 6b 29 0a 20 20 20 20 20 20 20 20 bda (k).
8640: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 (set! r
8650: 65 73 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 6b es (cons (conc k
8660: 20 22 3d 3e 22 20 28 66 6f 72 6d 64 61 74 3a 67 "=>" (formdat:g
8670: 65 74 20 73 65 6c 66 20 6b 29 29 20 72 65 73 29 et self k)) res)
8680: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8690: 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 (formdat:keys s
86a0: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 72 65 elf)). re
86b0: 73 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 s))..;; call wit
86c0: 68 20 2a 6f 6e 65 2a 20 6f 66 20 74 68 65 20 6c h *one* of the l
86d0: 69 73 74 73 20 69 6e 20 74 68 65 20 6c 69 73 74 ists in the list
86e0: 20 6f 66 20 6c 69 73 74 73 20 63 72 65 61 74 65 of lists create
86f0: 64 20 62 79 20 43 47 49 3a 75 72 6c 2d 75 6e 71 d by CGI:url-unq
8700: 75 6f 74 65 0a 28 64 65 66 69 6e 65 20 28 66 6f uote.(define (fo
8710: 72 6d 64 61 74 3a 6c 6f 61 64 20 73 65 6c 66 20 rmdat:load self
8720: 66 6f 72 6d 6c 69 73 74 29 0a 20 20 28 6c 65 74 formlist). (let
8730: 20 28 28 68 74 20 20 20 20 20 20 20 20 20 20 20 ((ht
8740: 20 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 (formdat:formd
8750: 61 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 at-get-data self
8760: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
8770: 6c 3f 20 66 6f 72 6d 6c 69 73 74 29 20 73 65 6c l? formlist) sel
8780: 66 20 3b 3b 20 6e 6f 20 76 61 6c 75 65 73 20 70 f ;; no values p
8790: 72 6f 76 69 64 65 64 2c 20 72 65 74 75 72 6e 20 rovided, return
87a0: 73 65 6c 66 20 66 6f 72 20 6e 6f 20 67 6f 6f 64 self for no good
87b0: 20 72 65 61 73 6f 6e 0a 20 20 20 20 20 20 20 20 reason.
87c0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 (let loop ((head
87d0: 20 28 63 61 72 20 66 6f 72 6d 6c 69 73 74 29 29 (car formlist))
87e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
87f0: 20 20 20 20 28 74 61 69 6c 20 28 63 64 72 20 66 (tail (cdr f
8800: 6f 72 6d 6c 69 73 74 29 29 29 0a 20 20 20 20 20 ormlist))).
8810: 20 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 20 (let ((key
8820: 28 63 61 72 20 68 65 61 64 29 29 0a 20 20 20 20 (car head)).
8830: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 61 6c (val
8840: 20 28 63 64 72 20 68 65 61 64 29 29 29 0a 20 20 (cdr head))).
8850: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 65 72 ;; (er
8860: 72 3a 6c 6f 67 20 22 6b 65 79 3d 22 20 6b 65 79 r:log "key=" key
8870: 20 22 20 76 61 6c 3d 22 20 76 61 6c 29 0a 09 20 " val=" val)..
8880: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
8890: 68 20 76 61 6c 29 20 31 29 0a 09 09 28 66 6f 72 h val) 1)...(for
88a0: 6d 64 61 74 3a 73 65 74 21 20 73 65 6c 66 20 6b mdat:set! self k
88b0: 65 79 20 76 61 6c 29 0a 09 09 28 66 6f 72 6d 64 ey val)...(formd
88c0: 61 74 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 79 at:set! self key
88d0: 20 28 63 61 72 20 76 61 6c 29 29 29 0a 20 20 20 (car val))).
88e0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
88f0: 6c 6c 3f 20 74 61 69 6c 29 20 73 65 6c 66 20 20 ll? tail) self
8900: 20 3b 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a ;; we are done.
8910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8920: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
8930: 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 (cdr tail)))))))
8940: 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 68 65 )..;; get the he
8950: 61 64 65 72 20 66 72 6f 6d 20 64 61 74 73 74 72 ader from datstr
8960: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
8970: 74 3a 72 65 61 64 2d 68 65 61 64 65 72 20 64 61 t:read-header da
8980: 74 73 74 72 29 20 3b 3b 20 64 61 74 73 74 72 20 tstr) ;; datstr
8990: 69 73 20 61 6e 20 69 6e 70 75 74 20 73 74 72 69 is an input stri
89a0: 6e 67 20 70 6f 72 74 0a 20 20 28 6c 65 74 20 6c ng port. (let l
89b0: 6f 6f 70 20 28 28 68 73 20 28 72 65 61 64 2d 6c oop ((hs (read-l
89c0: 69 6e 65 20 64 61 74 73 74 72 29 29 0a 09 20 20 ine datstr))..
89d0: 20 20 20 28 68 65 61 64 65 72 20 27 28 29 29 29 (header '()))
89e0: 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 6f . (if (or (eo
89f0: 66 2d 6f 62 6a 65 63 74 3f 20 68 73 29 0a 09 20 f-object? hs)..
8a00: 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 68 73 20 (string=? hs
8a10: 22 22 29 29 0a 09 68 65 61 64 65 72 0a 09 28 6c ""))..header..(l
8a20: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 64 oop (read-line d
8a30: 61 74 73 74 72 29 28 61 70 70 65 6e 64 20 68 65 atstr)(append he
8a40: 61 64 65 72 20 28 6c 69 73 74 20 68 73 29 29 29 ader (list hs)))
8a50: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 )))..;; get the
8a60: 64 61 74 61 20 75 70 20 74 6f 20 74 68 65 20 6e data up to the n
8a70: 65 78 74 20 6b 65 79 2e 20 69 66 20 74 68 65 72 ext key. if ther
8a80: 65 20 69 73 20 6e 6f 20 6b 65 79 20 74 68 65 6e e is no key then
8a90: 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b 20 72 65 return #f.;; re
8aa0: 74 75 72 6e 20 28 64 61 74 20 72 65 6d 64 61 74 turn (dat remdat
8ab0: 29 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 ).(define (formd
8ac0: 61 74 3a 72 65 61 64 2d 64 61 74 20 64 61 74 20 at:read-dat dat
8ad0: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 69 6e key). (let ((in
8ae0: 64 65 78 20 28 73 75 62 73 74 72 69 6e 67 2d 69 dex (substring-i
8af0: 6e 64 65 78 20 6b 65 79 20 64 61 74 29 29 29 20 ndex key dat)))
8b00: 3b 3b 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 ;; (string-searc
8b10: 68 2d 70 6f 73 69 74 69 6f 6e 73 20 6b 65 79 20 h-positions key
8b20: 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 dat))). (if (
8b30: 6f 72 20 28 6e 6f 74 20 69 6e 64 65 78 29 0a 09 or (not index)..
8b40: 20 20 20 20 28 6e 75 6c 6c 3f 20 69 6e 64 65 78 (null? index
8b50: 29 29 20 3b 3b 20 74 68 65 20 6b 65 79 20 77 61 )) ;; the key wa
8b60: 73 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 23 66 0a s not found..#f.
8b70: 09 28 6c 65 74 2a 20 28 28 64 61 74 73 74 72 20 .(let* ((datstr
8b80: 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 (open-input-stri
8b90: 6e 67 20 64 61 74 29 29 0a 09 20 20 20 20 20 20 ng dat))..
8ba0: 20 3b 3b 20 28 72 65 73 75 6c 74 20 28 72 65 61 ;; (result (rea
8bb0: 64 2d 73 74 72 69 6e 67 20 28 63 61 61 72 20 69 d-string (caar i
8bc0: 6e 64 65 78 29 20 64 61 74 73 74 72 29 29 0a 09 ndex) datstr))..
8bd0: 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 28 (result (
8be0: 72 65 61 64 2d 73 74 72 69 6e 67 20 69 6e 64 65 read-string inde
8bf0: 78 20 64 61 74 73 74 72 29 29 0a 09 20 20 20 20 x datstr))..
8c00: 20 20 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 (remdat (read
8c10: 2d 73 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 -string #f datst
8c20: 72 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 r))).. (close-i
8c30: 6e 70 75 74 2d 70 6f 72 74 20 64 61 74 73 74 72 nput-port datstr
8c40: 29 0a 09 20 20 28 6c 69 73 74 20 72 65 73 75 6c ).. (list resul
8c50: 74 20 72 65 6d 64 61 74 29 29 29 29 29 0a 0a 20 t remdat)))))..
8c60: 3b 3b 20 69 6e 70 20 69 73 20 70 6f 72 74 20 74 ;; inp is port t
8c70: 6f 20 72 65 61 64 20 64 61 74 61 20 66 72 6f 6d o read data from
8c80: 2c 20 6d 61 78 73 69 7a 65 20 69 73 20 6d 61 78 , maxsize is max
8c90: 20 64 61 74 61 20 61 6c 6c 6f 77 65 64 20 74 6f data allowed to
8ca0: 20 72 65 61 64 20 28 74 6f 74 61 6c 29 0a 28 64 read (total).(d
8cb0: 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 64 efine (formdat:d
8cc0: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 6d 61 78 at->list inp max
8cd0: 73 69 7a 65 20 23 21 6b 65 79 20 28 64 65 62 75 size #!key (debu
8ce0: 67 2d 70 6f 72 74 20 23 66 29 29 0a 20 20 3b 3b g-port #f)). ;;
8cf0: 20 72 65 61 64 20 31 4d 65 67 20 63 68 75 6e 6b read 1Meg chunk
8d00: 73 20 66 72 6f 6d 20 74 68 65 20 69 6e 70 75 74 s from the input
8d10: 20 70 6f 72 74 2e 20 49 66 20 61 20 62 6c 6f 63 port. If a bloc
8d20: 6b 20 69 73 20 6e 6f 74 20 63 6f 6d 70 6c 65 74 k is not complet
8d30: 65 0a 20 20 3b 3b 20 74 61 63 6b 20 6f 6e 20 74 e. ;; tack on t
8d40: 68 65 20 6e 65 78 74 20 31 4d 65 67 20 63 68 75 he next 1Meg chu
8d50: 6e 6b 20 61 73 20 6e 65 65 64 65 64 2e 20 53 65 nk as needed. Se
8d60: 74 20 75 70 20 73 6f 20 74 68 65 20 68 65 61 64 t up so the head
8d70: 65 72 20 69 73 20 61 6c 77 61 79 73 0a 20 20 3b er is always. ;
8d80: 3b 20 61 74 20 74 68 65 20 62 65 67 69 6e 6e 69 ; at the beginni
8d90: 6e 67 20 6f 66 20 74 68 65 20 63 68 75 6e 6b 0a ng of the chunk.
8da0: 20 20 3b 3b 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ;;------------
8db0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
8dc0: 2d 32 39 39 33 32 30 32 34 34 31 31 35 30 32 33 -299320244115023
8dd0: 32 33 33 33 32 31 33 36 32 31 34 39 37 33 0a 20 23332136214973.
8de0: 20 3b 3b 43 6f 6e 74 65 6e 74 2d 44 69 73 70 6f ;;Content-Dispo
8df0: 73 69 74 69 6f 6e 3a 20 66 6f 72 6d 2d 64 61 74 sition: form-dat
8e00: 61 3b 20 6e 61 6d 65 3d 22 69 6e 70 75 74 2d 70 a; name="input-p
8e10: 69 63 74 75 72 65 22 3b 20 66 69 6c 65 6e 61 6d icture"; filenam
8e20: 65 3d 22 62 72 65 61 64 66 72 75 69 74 2e 6a 70 e="breadfruit.jp
8e30: 67 22 0a 20 20 3b 3b 43 6f 6e 74 65 6e 74 2d 54 g". ;;Content-T
8e40: 79 70 65 3a 20 69 6d 61 67 65 2f 6a 70 65 67 0a ype: image/jpeg.
8e50: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 64 61 (let loop ((da
8e60: 74 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 t (read-string 1
8e70: 30 30 30 30 30 30 20 69 6e 70 29 29 0a 09 20 20 000000 inp))..
8e80: 20 20 20 28 72 65 73 20 27 28 29 29 0a 09 20 20 (res '())..
8e90: 20 20 20 28 73 69 7a 20 30 29 29 0a 20 20 20 20 (siz 0)).
8ea0: 28 69 66 20 64 65 62 75 67 2d 70 6f 72 74 20 28 (if debug-port (
8eb0: 66 6f 72 6d 61 74 20 64 65 62 75 67 2d 70 6f 72 format debug-por
8ec0: 74 20 22 64 61 74 3a 20 7e 41 5c 6e 22 20 64 61 t "dat: ~A\n" da
8ed0: 74 29 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 t)). (if debu
8ee0: 67 2d 70 6f 72 74 20 28 66 6f 72 6d 61 74 20 64 g-port (format d
8ef0: 65 62 75 67 2d 70 6f 72 74 20 22 65 6f 66 3a 20 ebug-port "eof:
8f00: 7e 41 5c 6e 22 20 28 65 6f 66 2d 6f 62 6a 65 63 ~A\n" (eof-objec
8f10: 74 3f 20 28 72 65 61 64 20 69 6e 70 29 29 29 29 t? (read inp))))
8f20: 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 28 3e . . (if (>
8f30: 20 73 69 7a 20 6d 61 78 73 69 7a 65 29 0a 09 28 siz maxsize)..(
8f40: 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 begin.. (print
8f50: 22 44 41 54 41 20 54 4f 4f 20 42 49 47 22 29 0a "DATA TOO BIG").
8f60: 09 20 20 72 65 73 29 0a 09 28 6c 65 74 2a 20 28 . res)..(let* (
8f70: 28 64 61 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e (datstr (open-in
8f80: 70 75 74 2d 73 74 72 69 6e 67 20 64 61 74 29 29 put-string dat))
8f90: 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 72 .. (header
8fa0: 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 (formdat:read-h
8fb0: 65 61 64 65 72 20 64 61 74 73 74 72 29 29 0a 09 eader datstr))..
8fc0: 20 20 20 20 20 20 20 28 6b 65 79 20 20 20 20 28 (key (
8fd0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 68 if (not (null? h
8fe0: 65 61 64 65 72 29 29 28 63 61 72 20 68 65 61 64 eader))(car head
8ff0: 65 72 29 20 23 66 29 29 0a 09 20 20 20 20 20 20 er) #f))..
9000: 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 2d 73 (remdat (read-s
9010: 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 72 29 tring #f datstr)
9020: 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 75 73 ) ;; us
9030: 65 64 20 69 6e 20 6e 65 78 74 20 6c 69 6e 65 2c ed in next line,
9040: 20 64 69 73 63 61 72 64 20 69 66 20 67 6f 74 20 discard if got
9050: 64 61 74 61 2c 20 65 6c 73 65 20 72 65 76 65 72 data, else rever
9060: 74 20 74 6f 0a 09 20 20 20 20 20 20 20 28 61 6c t to.. (al
9070: 6c 64 61 74 20 28 69 66 20 6b 65 79 20 28 66 6f ldat (if key (fo
9080: 72 6d 64 61 74 3a 72 65 61 64 2d 64 61 74 20 72 rmdat:read-dat r
9090: 65 6d 64 61 74 20 6b 65 79 29 20 23 66 29 29 20 emdat key) #f))
90a0: 20 20 20 3b 3b 20 74 72 79 20 74 6f 20 65 78 74 ;; try to ext
90b0: 72 61 63 74 20 74 68 65 20 64 61 74 61 0a 09 20 ract the data..
90c0: 20 20 20 20 20 20 28 74 68 73 64 61 74 20 28 69 (thsdat (i
90d0: 66 20 61 6c 6c 64 61 74 20 28 63 61 72 20 61 6c f alldat (car al
90e0: 6c 64 61 74 29 20 20 23 66 29 29 20 20 20 20 20 ldat) #f))
90f0: 3b 3b 20 74 68 65 20 64 61 74 61 0a 09 20 20 20 ;; the data..
9100: 20 20 20 20 28 6e 65 77 64 61 74 20 28 69 66 20 (newdat (if
9110: 61 6c 6c 64 61 74 20 28 63 61 64 72 20 61 6c 6c alldat (cadr all
9120: 64 61 74 29 20 23 66 29 29 20 20 20 20 20 3b 3b dat) #f)) ;;
9130: 20 6c 65 66 74 20 6f 76 65 72 20 64 61 74 61 2c left over data,
9140: 20 6d 75 73 74 20 70 72 6f 63 65 73 73 20 2e 2e must process ..
9150: 2e 0a 09 20 20 20 20 20 20 20 28 74 68 73 72 65 ... (thsre
9160: 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 20 74 s (list header t
9170: 68 73 64 61 74 29 29 20 20 20 20 20 20 20 20 20 hsdat))
9180: 20 20 20 20 3b 3b 20 73 70 65 63 75 6c 61 74 69 ;; speculati
9190: 76 65 6c 79 20 63 6f 6e 73 74 72 75 63 74 20 72 vely construct r
91a0: 65 73 75 6c 74 73 0a 09 20 20 20 20 20 20 20 28 esults.. (
91b0: 6e 65 77 72 65 73 20 28 61 70 70 65 6e 64 20 72 newres (append r
91c0: 65 73 20 28 6c 69 73 74 20 74 68 73 72 65 73 29 es (list thsres)
91d0: 29 29 29 20 20 20 20 20 20 3b 3b 20 73 70 65 63 ))) ;; spec
91e0: 75 6c 61 74 69 76 65 6c 79 20 63 6f 6e 73 74 72 ulatively constr
91f0: 75 63 74 20 72 65 73 75 6c 74 73 0a 09 20 20 28 uct results.. (
9200: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
9210: 20 64 61 74 73 74 72 29 0a 09 20 20 28 63 6f 6e datstr).. (con
9220: 64 0a 09 20 20 20 3b 3b 20 65 69 74 68 65 72 20 d.. ;; either
9230: 6e 6f 20 68 65 61 64 65 72 20 6f 72 20 73 69 6e no header or sin
9240: 67 6c 65 20 69 6e 70 75 74 0a 09 20 20 20 28 28 gle input.. ((
9250: 61 6e 64 20 28 6e 6f 74 20 61 6c 6c 64 61 74 29 and (not alldat)
9260: 0a 09 09 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 68 ... (or (null? h
9270: 65 61 64 65 72 29 0a 09 09 20 20 20 20 20 28 6e eader)... (n
9280: 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ot (string-match
9290: 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d 2d 70 formdat:delim-p
92a0: 61 74 74 2d 72 65 78 20 28 63 61 72 20 68 65 61 att-rex (car hea
92b0: 64 65 72 29 29 29 29 29 0a 09 20 20 20 20 3b 3b der))))).. ;;
92c0: 20 28 70 72 69 6e 74 20 22 47 6f 74 20 68 65 72 (print "Got her
92d0: 65 22 29 0a 09 20 20 20 20 28 63 6f 6e 73 20 28 e").. (cons (
92e0: 6c 69 73 74 20 68 65 61 64 65 72 20 22 22 29 20 list header "")
92f0: 72 65 73 29 29 20 3b 3b 20 6e 6f 74 65 20 75 73 res)) ;; note us
9300: 65 20 68 65 61 64 65 72 20 61 73 20 64 61 74 20 e header as dat
9310: 61 6e 64 20 75 73 65 20 22 22 20 61 73 20 68 65 and use "" as he
9320: 61 64 65 72 3f 3f 3f 3f 0a 09 20 20 20 3b 3b 20 ader????.. ;;
9330: 64 69 64 6e 27 74 20 66 69 6e 64 20 65 6e 64 20 didn't find end
9340: 6b 65 79 20 69 6e 20 74 68 69 73 20 62 6c 6f 63 key in this bloc
9350: 6b 0a 09 20 20 20 28 28 6e 6f 74 20 61 6c 6c 64 k.. ((not alld
9360: 61 74 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 at).. (let ((
9370: 6d 6f 72 64 61 74 20 28 72 65 61 64 2d 73 74 72 mordat (read-str
9380: 69 6e 67 20 31 30 30 30 30 30 30 20 69 6e 70 29 ing 1000000 inp)
9390: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 )).. (if (s
93a0: 74 72 69 6e 67 3d 3f 20 6d 6f 72 64 61 74 20 22 tring=? mordat "
93b0: 22 29 20 3b 3b 20 74 68 65 72 65 20 69 73 20 6e ") ;; there is n
93c0: 6f 20 6d 6f 72 65 20 64 61 74 61 2c 20 64 69 73 o more data, dis
93d0: 63 61 72 64 20 72 65 73 75 6c 74 73 20 61 6e 64 card results and
93e0: 20 75 73 65 20 72 65 6d 64 61 74 20 61 73 20 64 use remdat as d
93f0: 61 74 61 2c 20 74 68 69 73 20 69 6e 70 75 74 20 ata, this input
9400: 69 73 20 62 72 6f 6b 65 6e 0a 09 09 20 20 28 63 is broken... (c
9410: 6f 6e 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 ons (list header
9420: 20 72 65 6d 64 61 74 29 20 72 65 73 29 0a 09 09 remdat) res)...
9430: 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d (loop (string-
9440: 61 70 70 65 6e 64 20 64 61 74 20 6d 6f 72 64 61 append dat morda
9450: 74 29 20 72 65 73 20 28 2b 20 73 69 7a 20 32 30 t) res (+ siz 20
9460: 30 30 30 30 30 29 29 29 29 29 20 3b 3b 20 61 64 00000))))) ;; ad
9470: 64 20 74 68 65 20 65 78 74 72 61 20 31 30 30 30 d the extra 1000
9480: 30 30 30 0a 09 20 20 20 28 61 6c 6c 64 61 74 20 000.. (alldat
9490: 3b 3b 20 67 6f 74 20 64 61 74 61 2c 20 64 6f 6e ;; got data, don
94a0: 27 74 20 61 74 74 65 6d 70 74 20 74 6f 20 63 68 't attempt to ch
94b0: 65 63 6b 20 69 66 20 74 68 65 72 65 20 69 73 20 eck if there is
94c0: 6d 6f 72 65 2c 20 6a 75 73 74 20 6c 6f 6f 70 20 more, just loop
94d0: 61 6e 64 20 72 65 6c 79 20 6f 6e 20 28 6e 6f 74 and rely on (not
94e0: 20 61 6c 6c 64 61 74 29 20 74 6f 20 67 65 74 20 alldat) to get
94f0: 6d 6f 72 65 20 64 61 74 61 0a 09 20 20 20 20 28 more data.. (
9500: 6c 6f 6f 70 20 6e 65 77 64 61 74 20 6e 65 77 72 loop newdat newr
9510: 65 73 20 28 2b 20 73 69 7a 20 31 30 30 30 30 30 es (+ siz 100000
9520: 30 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 0))))))))..(defi
9530: 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 ne formdat:bin-d
9540: 61 74 61 2d 64 69 73 70 2d 72 65 78 20 28 72 65 ata-disp-rex (re
9550: 67 65 78 70 20 22 5e 43 6f 6e 74 65 6e 74 2d 44 gexp "^Content-D
9560: 69 73 70 6f 73 69 74 69 6f 6e 3a 5c 5c 73 2b 66 isposition:\\s+f
9570: 6f 72 6d 2d 64 61 74 61 3b 22 29 29 0a 28 64 65 orm-data;")).(de
9580: 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e fine formdat:bin
9590: 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 28 -data-name-rex (
95a0: 72 65 67 65 78 70 20 22 5c 5c 57 6e 61 6d 65 3d regexp "\\Wname=
95b0: 5c 22 28 5b 5e 5c 22 5d 2b 29 5c 22 22 29 29 0a \"([^\"]+)\"")).
95c0: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
95d0: 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d 72 65 bin-file-name-re
95e0: 78 20 28 72 65 67 65 78 70 20 22 5c 5c 57 66 69 x (regexp "\\Wfi
95f0: 6c 65 6e 61 6d 65 3d 5c 22 28 5b 5e 5c 22 5d 2b lename=\"([^\"]+
9600: 29 5c 22 22 29 29 0a 28 64 65 66 69 6e 65 20 66 )\"")).(define f
9610: 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c 65 2d ormdat:bin-file-
9620: 74 79 70 65 2d 72 65 78 20 28 72 65 67 65 78 70 type-rex (regexp
9630: 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 5c "Content-Type:\
9640: 5c 73 2b 28 5b 5e 5c 5c 73 5d 2b 29 22 29 29 0a \s+([^\\s]+)")).
9650: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
9660: 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 20 delim-patt-rex
9670: 20 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 2d 2b (regexp "^\\-+
9680: 5b 30 2d 39 5d 2b 5c 5c 2d 2a 24 22 29 29 0a 0a [0-9]+\\-*$"))..
9690: 3b 3b 20 72 65 74 75 72 6e 73 20 61 20 68 61 73 ;; returns a has
96a0: 68 20 77 69 74 68 20 65 6e 74 72 69 65 73 20 66 h with entries f
96b0: 6f 72 20 61 6c 6c 20 66 6f 72 6d 73 20 2d 20 63 or all forms - c
96c0: 6f 75 6c 64 20 77 65 6c 6c 20 75 73 65 20 61 20 ould well use a
96d0: 70 72 6f 70 6c 69 73 74 3f 0a 28 64 65 66 69 6e proplist?.(defin
96e0: 65 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d e (formdat:load-
96f0: 61 6c 6c 29 0a 20 20 28 6c 65 74 20 28 28 72 65 all). (let ((re
9700: 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 28 67 65 quest-method (ge
9710: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
9720: 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f riable "REQUEST_
9730: 4d 45 54 48 4f 44 22 29 29 29 0a 20 20 20 20 28 METHOD"))). (
9740: 69 66 20 28 61 6e 64 20 72 65 71 75 65 73 74 2d if (and request-
9750: 6d 65 74 68 6f 64 0a 09 20 20 20 20 20 28 73 74 method.. (st
9760: 72 69 6e 67 3d 3f 20 72 65 71 75 65 73 74 2d 6d ring=? request-m
9770: 65 74 68 6f 64 20 22 50 4f 53 54 22 29 29 0a 09 ethod "POST"))..
9780: 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c (formdat:load-al
9790: 6c 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d l-port (current-
97a0: 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 29 29 0a input-port))))).
97b0: 0a 3b 3b 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 .;; (s:process-c
97c0: 67 69 2d 69 6e 70 75 74 20 28 63 61 61 61 72 20 gi-input (caaar
97d0: 64 61 74 29 29 0a 28 64 65 66 69 6e 65 20 28 66 dat)).(define (f
97e0: 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 2d ormdat:load-all-
97f0: 70 6f 72 74 20 69 6e 70 29 0a 20 20 28 6c 65 74 port inp). (let
9800: 2a 20 28 28 66 6f 72 6d 64 61 74 20 20 20 20 20 * ((formdat
9810: 20 20 20 28 6d 61 6b 65 2d 66 6f 72 6d 64 61 74 (make-formdat
9820: 3a 66 6f 72 6d 64 61 74 29 29 0a 09 20 28 64 65 :formdat)).. (de
9830: 62 75 67 70 20 20 20 20 20 20 20 20 20 23 66 29 bugp #f)
9840: 29 0a 09 09 09 20 3b 3b 20 28 6f 70 65 6e 2d 6f ).... ;; (open-o
9850: 75 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 utput-file (conc
9860: 20 22 2f 74 6d 70 2f 64 65 6c 6d 65 2d 22 20 28 "/tmp/delme-" (
9870: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
9880: 20 22 2e 6c 6f 67 22 29 29 29 29 0a 20 20 20 20 ".log")))).
9890: 3b 3b 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 ;; (write-string
98a0: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 (read-string #f
98b0: 20 69 6e 70 29 20 23 66 20 64 65 62 75 67 70 29 inp) #f debugp)
98c0: 20 20 3b 3b 20 64 65 73 74 72 6f 79 73 20 61 6c ;; destroys al
98d0: 6c 20 64 61 74 61 21 0a 20 20 20 20 28 66 6f 72 l data!. (for
98e0: 6d 64 61 74 3a 69 6e 69 74 69 61 6c 69 7a 65 20 mdat:initialize
98f0: 66 6f 72 6d 64 61 74 29 0a 20 20 20 20 28 6c 65 formdat). (le
9900: 74 20 28 28 61 6c 6c 64 61 74 73 20 28 66 6f 72 t ((alldats (for
9910: 6d 64 61 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 mdat:dat->list i
9920: 6e 70 20 31 30 65 36 20 64 65 62 75 67 2d 70 6f np 10e6 debug-po
9930: 72 74 3a 20 64 65 62 75 67 70 29 29 29 0a 20 20 rt: debugp))).
9940: 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 64 . (if d
9950: 65 62 75 67 70 20 28 66 6f 72 6d 61 74 20 64 65 ebugp (format de
9960: 62 75 67 70 20 22 66 6f 72 6d 64 61 74 20 3a 20 bugp "formdat :
9970: 61 6c 6c 64 61 74 73 3a 20 7e 41 5c 6e 22 20 61 alldats: ~A\n" a
9980: 6c 6c 64 61 74 73 29 29 0a 0a 20 20 20 20 20 20 lldats))..
9990: 28 6c 65 74 20 28 28 66 69 72 73 74 69 74 65 6d (let ((firstitem
99a0: 20 20 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 (car alldats)
99b0: 29 0a 09 20 20 20 20 28 6d 75 6c 74 69 70 61 73 ).. (multipas
99c0: 73 20 23 66 29 29 20 0a 09 28 69 66 20 28 61 6e s #f)) ..(if (an
99d0: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 69 d (not (null? fi
99e0: 72 73 74 69 74 65 6d 29 29 0a 09 09 20 28 6e 6f rstitem))... (no
99f0: 74 20 28 6e 75 6c 6c 3f 20 28 63 61 72 20 66 69 t (null? (car fi
9a00: 72 73 74 69 74 65 6d 29 29 29 29 0a 09 20 20 20 rstitem))))..
9a10: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
9a20: 63 68 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d ch formdat:delim
9a30: 2d 70 61 74 74 2d 72 65 78 20 28 63 61 61 72 20 -patt-rex (caar
9a40: 66 69 72 73 74 69 74 65 6d 29 29 0a 09 09 28 73 firstitem))...(s
9a50: 65 74 21 20 6d 75 6c 74 69 70 61 73 73 20 23 74 et! multipass #t
9a60: 29 29 29 0a 09 28 69 66 20 6d 75 6c 74 69 70 61 )))..(if multipa
9a70: 73 73 0a 09 20 20 20 20 3b 3b 20 68 61 6e 64 6c ss.. ;; handl
9a80: 65 20 6d 75 6c 74 69 2d 70 61 72 74 20 66 6f 72 e multi-part for
9a90: 6d 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 m.. (for-each
9aa0: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 6c 73 74 (lambda (datlst
9ab0: 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 68 65 61 )....(let* ((hea
9ac0: 64 65 72 20 28 66 6f 72 6d 64 61 74 3a 65 78 74 der (formdat:ext
9ad0: 72 61 63 74 2d 68 65 61 64 65 72 2d 69 6e 66 6f ract-header-info
9ae0: 20 28 63 61 72 20 64 61 74 6c 73 74 29 29 29 0a (car datlst))).
9af0: 09 09 09 20 20 20 20 20 20 20 28 6e 61 6d 65 20 ... (name
9b00: 20 20 28 69 66 20 28 61 73 73 6f 63 20 27 6e 61 (if (assoc 'na
9b10: 6d 65 20 68 65 61 64 65 72 29 0a 09 09 09 09 09 me header)......
9b20: 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 (string->symb
9b30: 6f 6c 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 ol (cadr (assoc
9b40: 27 6e 61 6d 65 20 68 65 61 64 65 72 29 29 29 0a 'name header))).
9b50: 09 09 09 09 09 20 20 20 22 22 29 29 20 3b 3b 20 ..... "")) ;;
9b60: 67 72 75 6d 62 6c 65 0a 09 09 09 20 20 20 20 20 grumble....
9b70: 20 20 28 66 6e 61 6d 65 6c 20 20 28 61 73 73 6f (fnamel (asso
9b80: 63 20 27 66 69 6c 65 6e 61 6d 65 20 68 65 61 64 c 'filename head
9b90: 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 er)).... (
9ba0: 63 6f 6e 74 65 6e 74 20 28 61 73 73 6f 63 20 27 content (assoc '
9bb0: 63 6f 6e 74 65 6e 74 20 68 65 61 64 65 72 29 29 content header))
9bc0: 0a 09 09 09 20 20 20 20 20 20 20 28 64 61 74 20 .... (dat
9bd0: 20 20 20 28 63 61 64 72 20 64 61 74 6c 73 74 29 (cadr datlst)
9be0: 29 29 0a 09 09 09 20 20 3b 3b 20 28 70 72 69 6e )).... ;; (prin
9bf0: 74 20 22 68 65 61 64 65 72 3a 20 22 20 68 65 61 t "header: " hea
9c00: 64 65 72 20 22 20 6e 61 6d 65 3a 20 22 20 6e 61 der " name: " na
9c10: 6d 65 20 22 20 66 6e 61 6d 65 6c 3a 20 22 20 66 me " fnamel: " f
9c20: 6e 61 6d 65 6c 20 22 20 63 6f 6e 74 65 6e 74 3a namel " content:
9c30: 20 22 20 63 6f 6e 74 65 6e 74 29 20 3b 3b 20 20 " content) ;;
9c40: 22 20 64 61 74 3a 20 22 20 28 64 61 74 29 0a 09 " dat: " (dat)..
9c50: 09 09 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 .. (formdat:set
9c60: 21 20 66 6f 72 6d 64 61 74 20 0a 09 09 09 09 09 ! formdat ......
9c70: 6e 61 6d 65 0a 09 09 09 09 09 28 69 66 20 66 6e name......(if fn
9c80: 61 6d 65 6c 20 0a 09 09 09 09 09 20 20 20 20 28 amel ...... (
9c90: 6c 69 73 74 20 28 63 61 64 72 20 66 6e 61 6d 65 list (cadr fname
9ca0: 6c 29 0a 09 09 09 09 09 09 20 20 28 69 66 20 63 l)....... (if c
9cb0: 6f 6e 74 65 6e 74 0a 09 09 09 09 09 09 20 20 20 ontent.......
9cc0: 20 20 20 28 63 61 64 72 20 63 6f 6e 74 65 6e 74 (cadr content
9cd0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 22 75 )....... "u
9ce0: 6e 6b 6e 6f 77 6e 22 29 0a 09 09 09 09 09 09 20 nknown").......
9cf0: 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f 62 20 64 (string->blob d
9d00: 61 74 29 29 0a 09 09 09 09 09 20 20 20 20 64 61 at))...... da
9d10: 74 29 29 29 29 0a 09 09 20 20 20 20 20 20 61 6c t))))... al
9d20: 6c 64 61 74 73 29 0a 09 20 20 20 20 3b 3b 20 68 ldats).. ;; h
9d30: 61 6e 64 6c 65 20 73 69 6e 67 6c 65 20 70 61 72 andle single par
9d40: 74 20 66 6f 72 6d 0a 09 20 20 20 20 3b 3b 20 09 t form.. ;; .
9d50: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
9d60: 3f 20 6e 61 6d 65 29 0a 09 20 20 20 20 3b 3b 20 ? name).. ;;
9d70: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 3d 3f .. (string=?
9d80: 20 6e 61 6d 65 20 22 22 29 29 20 3b 3b 20 74 68 name "")) ;; th
9d90: 69 73 20 69 73 20 74 68 65 20 73 68 6f 72 74 20 is is the short
9da0: 66 6f 72 6d 20 69 6e 70 75 74 20 49 20 67 75 65 form input I gue
9db0: 73 73 0a 09 20 20 20 20 3b 3b 20 09 09 28 6c 65 ss.. ;; ..(le
9dc0: 74 2a 20 28 28 64 61 74 73 74 72 20 28 63 61 61 t* ((datstr (caa
9dd0: 72 20 64 61 74 6c 73 74 29 29 0a 09 20 20 20 20 r datlst))..
9de0: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 6d 75 6e ;; .. (mun
9df0: 67 65 64 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 ged (s:process-c
9e00: 67 69 2d 69 6e 70 75 74 20 64 61 74 73 74 72 29 gi-input datstr)
9e10: 29 29 0a 09 20 20 20 20 3b 3b 20 09 09 20 20 28 )).. ;; .. (
9e20: 70 72 69 6e 74 20 22 64 61 74 73 74 72 3a 20 22 print "datstr: "
9e30: 20 64 61 74 73 74 72 20 22 20 6d 75 6e 67 65 64 datstr " munged
9e40: 3a 20 22 20 6d 75 6e 67 65 64 29 0a 09 20 20 20 : " munged)..
9e50: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
9e60: 6e 75 6c 6c 3f 20 61 6c 6c 64 61 74 73 29 29 0a null? alldats)).
9e70: 09 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c .. (not (nul
9e80: 6c 3f 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 l? (car alldats)
9e90: 29 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 28 ))... (not (
9ea0: 6e 75 6c 6c 3f 20 28 63 61 61 72 20 61 6c 6c 64 null? (caar alld
9eb0: 61 74 73 29 29 29 29 0a 09 09 28 66 6f 72 6d 64 ats))))...(formd
9ec0: 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 at:load formdat
9ed0: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
9ee0: 69 6e 70 75 74 20 28 63 61 61 61 72 20 61 6c 6c input (caaar all
9ef0: 64 61 74 73 29 29 29 29 29 20 3b 3b 20 6d 75 6e dats))))) ;; mun
9f00: 67 65 64 29 29 0a 09 3b 3b 09 09 20 20 20 20 28 ged))..;;.. (
9f10: 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 66 format debugp "f
9f20: 6f 72 6d 64 61 74 20 3a 20 6e 61 6d 65 3a 20 7e ormdat : name: ~
9f30: 41 20 63 6f 6e 74 65 6e 74 3a 20 7e 41 5c 6e 22 A content: ~A\n"
9f40: 20 6e 61 6d 65 20 63 6f 6e 74 65 6e 74 29 0a 09 name content)..
9f50: 28 69 66 20 64 65 62 75 67 70 20 28 63 6c 6f 73 (if debugp (clos
9f60: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 64 65 e-output-port de
9f70: 62 75 67 70 29 29 0a 09 66 6f 72 6d 64 61 74 29 bugp))..formdat)
9f80: 29 29 29 0a 09 09 0a 23 7c 0a 28 64 65 66 69 6e )))....#|.(defin
9f90: 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 e inp (open-inpu
9fa0: 74 2d 66 69 6c 65 20 22 74 65 73 74 73 2f 65 78 t-file "tests/ex
9fb0: 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 6e 22 29 29 ample.post.in"))
9fc0: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
9fd0: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
9fe0: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 73 74 )).(define datst
9ff0: 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 r (open-input-st
a000: 72 69 6e 67 20 64 61 74 29 29 0a 0a 3b 3b 20 6f ring dat))..;; o
a010: 72 0a 0a 28 64 65 66 69 6e 65 20 69 6e 70 20 28 r..(define inp (
a020: 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 open-input-file
a030: 22 74 65 73 74 73 2f 65 78 61 6d 70 6c 65 2e 70 "tests/example.p
a040: 6f 73 74 2e 62 69 6e 61 72 79 2e 69 6e 22 29 29 ost.binary.in"))
a050: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
a060: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
a070: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 73 74 )).(define datst
a080: 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 r (open-input-st
a090: 72 69 6e 67 20 64 61 74 29 29 0a 0a 28 66 6f 72 ring dat))..(for
a0a0: 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 64 65 72 mdat:read-header
a0b0: 20 64 61 74 73 74 72 29 0a 0a 28 64 65 66 69 6e datstr)..(defin
a0c0: 65 20 64 61 74 20 28 66 6f 72 6d 64 61 74 3a 64 e dat (formdat:d
a0d0: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 30 65 at->list inp 10e
a0e0: 36 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 74 6)).(close-input
a0f0: 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a 20 20 -port inp).|#.
a100: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
a110: 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 65 72 t:extract-header
a120: 2d 69 6e 66 6f 20 68 65 61 64 65 72 29 0a 20 20 -info header).
a130: 28 69 66 20 28 6e 75 6c 6c 3f 20 68 65 61 64 65 (if (null? heade
a140: 72 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 r). '().
a150: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
a160: 65 64 20 28 63 61 72 20 68 65 61 64 65 72 29 29 ed (car header))
a170: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 68 65 ... (tal (cdr he
a180: 61 64 65 72 29 29 0a 09 09 20 28 72 65 73 20 27 ader))... (res '
a190: 28 29 29 29 0a 09 28 69 66 20 28 73 74 72 69 6e ()))..(if (strin
a1a0: 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a g-match formdat:
a1b0: 62 69 6e 2d 64 61 74 61 2d 64 69 73 70 2d 72 65 bin-data-disp-re
a1c0: 78 20 68 65 64 29 20 3b 3b 20 0a 09 20 20 20 20 x hed) ;; ..
a1d0: 28 6c 65 74 2a 20 28 28 64 61 74 61 2d 6e 61 6d (let* ((data-nam
a1e0: 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 em (string-match
a1f0: 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 61 74 formdat:bin-dat
a200: 61 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 29 a-name-rex hed))
a210: 0a 09 09 20 20 20 28 66 69 6c 65 2d 6e 61 6d 65 ... (file-name
a220: 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 m (string-match
a230: 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c 65 formdat:bin-file
a240: 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 29 0a -name-rex hed)).
a250: 09 09 20 20 20 28 64 61 74 61 2d 6e 61 6d 65 20 .. (data-name
a260: 20 28 69 66 20 64 61 74 61 2d 6e 61 6d 65 6d 20 (if data-namem
a270: 28 63 61 64 72 20 64 61 74 61 2d 6e 61 6d 65 6d (cadr data-namem
a280: 29 20 23 66 29 29 0a 09 09 20 20 20 28 74 68 69 ) #f))... (thi
a290: 73 20 20 20 20 20 20 20 28 69 66 20 66 69 6c 65 s (if file
a2a0: 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 20 20 28 6c -namem..... (l
a2b0: 69 73 74 20 28 6c 69 73 74 20 27 6e 61 6d 65 20 ist (list 'name
a2c0: 64 61 74 61 2d 6e 61 6d 65 29 28 6c 69 73 74 20 data-name)(list
a2d0: 27 66 69 6c 65 6e 61 6d 65 20 28 63 61 64 72 20 'filename (cadr
a2e0: 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 29 0a 09 09 file-namem)))...
a2f0: 09 09 20 20 20 28 6c 69 73 74 20 28 6c 69 73 74 .. (list (list
a300: 20 27 6e 61 6d 65 20 64 61 74 61 2d 6e 61 6d 65 'name data-name
a310: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 ))))).. (if
a320: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
a330: 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 (append res thi
a340: 73 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 s)... (loop (ca
a350: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
a360: 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 73 29 append res this)
a370: 29 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 ))).. (let ((
a380: 63 6f 6e 74 65 6e 74 20 28 73 74 72 69 6e 67 2d content (string-
a390: 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 match formdat:bi
a3a0: 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 n-file-type-rex
a3b0: 68 65 64 29 29 29 20 3b 3b 20 74 68 69 73 20 69 hed))) ;; this i
a3c0: 73 20 74 68 65 20 73 74 61 6e 7a 61 20 66 6f 72 s the stanza for
a3d0: 20 74 68 65 20 63 6f 6e 74 65 6e 74 20 74 79 70 the content typ
a3e0: 65 0a 09 20 20 20 20 20 20 28 69 66 20 63 6f 6e e.. (if con
a3f0: 74 65 6e 74 0a 09 09 20 20 28 6c 65 74 20 28 28 tent... (let ((
a400: 6e 65 77 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 newres (cons (li
a410: 73 74 20 27 63 6f 6e 74 65 6e 74 20 28 63 61 64 st 'content (cad
a420: 72 20 63 6f 6e 74 65 6e 74 29 29 20 72 65 73 29 r content)) res)
a430: 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 ))... (if (nu
a440: 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 6e 65 77 72 ll? tal)....newr
a450: 65 73 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 es....(loop (car
a460: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e tal)(cdr tal) n
a470: 65 77 72 65 73 29 29 29 0a 09 09 20 20 28 69 66 ewres)))... (if
a480: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
a490: 20 20 20 20 20 72 65 73 0a 09 09 20 20 20 20 20 res...
a4a0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
a4b0: 28 63 64 72 20 74 61 6c 29 20 72 65 73 29 0a 09 (cdr tal) res)..
a4c0: 09 20 20 20 20 20 20 29 29 29 29 29 29 29 0a 0a . )))))))..
a4d0: 3b 3b 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ;;. (let lo
a4e0: 6f 70 20 28 28 6c 20 20 20 20 20 20 20 28 72 65 op ((l (re
a4f0: 61 64 2d 6c 69 6e 65 29 29 20 3b 3b 20 28 69 66 ad-line)) ;; (if
a500: 20 28 65 71 3f 20 6d 6f 64 65 20 27 6e 6f 72 6d (eq? mode 'norm
a510: 29 28 72 65 61 64 2d 6c 69 6e 65 29 28 72 65 61 )(read-line)(rea
a520: 64 2d 63 68 61 72 29 29 29 0a 3b 3b 09 09 09 20 d-char))).;;...
a530: 28 65 6e 64 6c 69 6e 65 20 23 66 29 0a 3b 3b 09 (endline #f).;;.
a540: 09 09 20 28 6e 75 6d 20 20 20 20 20 30 29 29 0a .. (num 0)).
a550: 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 61 74 20 64 ;;..;; (format d
a560: 65 62 75 67 70 20 22 7e 41 5c 6e 22 20 6c 29 0a ebugp "~A\n" l).
a570: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
a580: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 65 6f (if (or (not (eo
a590: 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 29 0a 3b 3b f-object? l)).;;
a5a0: 09 09 20 20 20 20 20 20 28 6e 6f 74 20 28 61 6e .. (not (an
a5b0: 64 20 28 65 71 3f 20 6d 6f 64 65 20 27 62 69 6e d (eq? mode 'bin
a5c0: 29 0a 3b 3b 09 09 09 09 28 73 74 72 69 6e 67 3d ).;;....(string=
a5d0: 3f 20 6c 20 22 22 29 29 29 29 20 3b 3b 20 69 66 ? l "")))) ;; if
a5e0: 20 69 6e 20 62 69 6e 20 6d 6f 64 65 20 65 6d 70 in bin mode emp
a5f0: 74 79 20 73 74 72 69 6e 67 20 69 73 20 65 6e 64 ty string is end
a600: 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 09 20 20 28 of file.;;.. (
a610: 63 61 73 65 20 6d 6f 64 65 0a 3b 3b 09 09 20 20 case mode.;;..
a620: 20 20 28 28 73 74 61 72 74 29 0a 3b 3b 09 09 20 ((start).;;..
a630: 20 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 (set! mode '
a640: 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 28 norm).;;.. (
a650: 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 if (string-match
a660: 20 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 delim-patt-rex
a670: 6c 29 0a 3b 3b 09 09 09 20 28 62 65 67 69 6e 0a l).;;... (begin.
a680: 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 64 65 ;;... (set! de
a690: 6c 69 6d 2d 73 74 72 69 6e 67 20 6c 29 0a 3b 3b lim-string l).;;
a6a0: 09 09 09 20 20 20 28 73 65 74 21 20 64 65 6c 69 ... (set! deli
a6b0: 6d 2d 6c 65 6e 20 20 20 20 28 73 74 72 69 6e 67 m-len (string
a6c0: 2d 6c 65 6e 67 74 68 20 6c 29 29 0a 3b 3b 09 09 -length l)).;;..
a6d0: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
a6e0: 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b 3b 09 line) #f 0)).;;.
a6f0: 09 09 20 28 6c 6f 6f 70 20 6c 20 23 66 20 30 29 .. (loop l #f 0)
a700: 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 6e 6f 72 )).;;.. ((nor
a710: 6d 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 49 m).;;.. ;; I
a720: 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 6f 77 20 don't like how
a730: 74 68 69 73 20 67 65 74 73 20 63 68 65 63 6b 65 this gets checke
a740: 64 20 6f 6e 20 65 76 65 72 79 20 73 69 6e 67 6c d on every singl
a750: 65 20 69 6e 70 75 74 2e 20 4d 75 73 74 20 62 65 e input. Must be
a760: 20 61 20 62 65 74 74 65 72 20 77 61 79 2e 20 46 a better way. F
a770: 49 58 4d 45 0a 3b 3b 09 09 20 20 20 20 20 28 69 IXME.;;.. (i
a780: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d f (and (string-m
a790: 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 64 69 atch bin-data-di
a7a0: 73 70 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 sp-rex l).;;...
a7b0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
a7c0: 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 ch bin-data-name
a7d0: 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 20 20 -rex l).;;...
a7e0: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
a7f0: 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d 72 bin-file-name-r
a800: 65 78 20 6c 29 29 0a 3b 3b 09 09 09 20 28 62 65 ex l)).;;... (be
a810: 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 gin.;;... (set
a820: 21 20 64 61 74 61 2d 6e 61 6d 65 20 28 63 61 64 ! data-name (cad
a830: 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 r (string-match
a840: 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 bin-data-name-re
a850: 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 20 28 x l))).;;... (
a860: 73 65 74 21 20 66 69 6c 65 2d 6e 61 6d 65 20 28 set! file-name (
a870: 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 cadr (string-mat
a880: 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 ch bin-file-name
a890: 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 -rex l))).;;...
a8a0: 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 63 6f (set! mode 'co
a8b0: 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 20 20 20 28 ntent).;;... (
a8c0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
a8d0: 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 09 20 #f num))).;;..
a8e0: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 20 (let* ((dat
a8f0: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
a900: 69 6e 70 75 74 20 6c 29 29 29 20 3b 3b 20 28 43 input l))) ;; (C
a910: 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 65 20 6c GI:url-unquote l
a920: 29 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 66 )).;;.. (f
a930: 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 50 52 ormat debugp "PR
a940: 4f 43 45 53 53 2d 43 47 49 2d 49 4e 50 55 54 3a OCESS-CGI-INPUT:
a950: 20 7e 41 5c 6e 22 20 28 69 6e 74 65 72 73 70 65 ~A\n" (interspe
a960: 72 73 65 20 64 61 74 20 22 2c 22 29 29 0a 3b 3b rse dat ",")).;;
a970: 09 09 20 20 20 20 20 20 20 28 66 6f 72 6d 64 61 .. (formda
a980: 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 64 t:load formdat d
a990: 61 74 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 at).;;.. (
a9a0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
a9b0: 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 09 20 #f num))).;;..
a9c0: 20 20 20 28 28 63 6f 6e 74 65 6e 74 29 0a 3b 3b ((content).;;
a9d0: 09 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 .. (if (stri
a9e0: 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d 66 69 6c ng-match bin-fil
a9f0: 65 2d 74 79 70 65 2d 72 65 78 20 6c 29 0a 3b 3b e-type-rex l).;;
aa00: 09 09 09 20 28 62 65 67 69 6e 20 0a 3b 3b 09 09 ... (begin .;;..
aa10: 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 . (set! mode '
aa20: 62 69 6e 29 0a 3b 3b 09 09 09 20 20 20 28 73 65 bin).;;... (se
aa30: 74 21 20 64 61 74 61 2d 74 79 70 65 20 28 63 61 t! data-type (ca
aa40: 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 dr (string-match
aa50: 20 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 bin-file-type-r
aa60: 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 20 ex l))).;;...
aa70: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 73 74 72 69 (loop (read-stri
aa80: 6e 67 20 31 29 20 23 66 20 6e 75 6d 29 29 29 29 ng 1) #f num))))
aa90: 0a 3b 3b 09 09 20 20 20 20 28 28 62 69 6e 29 0a .;;.. ((bin).
aaa0: 3b 3b 09 09 20 20 20 20 20 3b 3b 20 64 65 6c 69 ;;.. ;; deli
aab0: 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e 22 2d 2d 2d m-string: \n"---
aac0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 33 34 ------------1234
aad0: 35 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 20 5".;;.. ;;
aae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aaf0: 30 31 32 33 34 35 36 37 38 39 30 31 32 33 34 35 0123456789012345
ab00: 36 37 38 39 30 0a 3b 3b 09 09 20 20 20 20 20 3b 67890.;;.. ;
ab10: 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 20 20 20 20 ; endline:
ab20: 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "-------------
ab30: 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 20 20 20 3b --12".;;.. ;
ab40: 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b 09 09 20 20 ; l = "3".;;..
ab50: 20 20 20 3b 3b 20 64 65 6c 69 6d 2d 6c 65 6e 20 ;; delim-len
ab60: 3d 20 32 30 0a 3b 3b 09 09 20 20 20 20 20 3b 3b = 20.;;.. ;;
ab70: 20 28 73 75 62 73 74 72 69 6e 67 20 20 22 2d 2d (substring "--
ab80: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 33 -------------123
ab90: 34 35 22 20 31 37 20 31 38 29 20 3d 3e 20 22 33 45" 17 18) => "3
aba0: 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 0a 3b 3b ".;;.. ;;.;;
abb0: 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 09 .. (cond.;;.
abc0: 09 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 6e . ;; haven
abd0: 27 74 20 66 6f 75 6e 64 20 74 68 65 20 73 74 61 't found the sta
abe0: 72 74 20 6f 66 20 61 6e 20 65 6e 64 6c 69 6e 65 rt of an endline
abf0: 2c 20 69 73 20 74 68 65 20 6e 65 78 74 20 63 68 , is the next ch
ac00: 61 72 20 61 20 6e 65 77 6c 69 6e 65 3f 0a 3b 3b ar a newline?.;;
ac10: 09 09 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e .. ((and (n
ac20: 6f 74 20 65 6e 64 6c 69 6e 65 29 0a 3b 3b 09 09 ot endline).;;..
ac30: 09 20 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 6c . (string=? l
ac40: 20 22 5c 6e 22 29 29 20 3b 3b 20 72 65 71 75 69 "\n")) ;; requi
ac50: 72 65 64 20 66 69 72 73 74 20 63 68 61 72 61 63 red first charac
ac60: 74 65 72 20 0a 3b 3b 09 09 20 20 20 20 20 20 20 ter .;;..
ac70: 28 6c 65 74 20 28 28 6e 65 77 65 6e 64 6c 69 6e (let ((newendlin
ac80: 65 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 e (open-output-s
ac90: 74 72 69 6e 67 29 29 29 0a 3b 3b 09 09 09 20 3b tring))).;;... ;
aca0: 3b 20 28 77 72 69 74 65 2d 6c 69 6e 65 20 6c 20 ; (write-line l
acb0: 6e 65 77 65 6e 64 6c 69 6e 65 29 20 3b 3b 20 64 newendline) ;; d
acc0: 69 73 63 61 72 64 20 74 68 65 20 6e 65 77 6c 69 iscard the newli
acd0: 6e 65 2e 20 61 64 64 20 69 74 20 62 61 63 6b 20 ne. add it back
ace0: 69 66 20 64 6f 6e 27 74 20 68 61 76 65 20 61 20 if don't have a
acf0: 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 6d 2d 73 74 lock on delim-st
ad00: 72 69 6e 67 0a 3b 3b 09 09 09 20 28 6c 6f 6f 70 ring.;;... (loop
ad10: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 (read-string 1)
ad20: 20 6e 65 77 65 6e 64 6c 69 6e 65 20 28 2b 20 6e newendline (+ n
ad30: 75 6d 20 31 29 29 29 29 0a 3b 3b 09 09 20 20 20 um 1)))).;;..
ad40: 20 20 20 28 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 ((not endline
ad50: 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 77 72 ).;;.. (wr
ad60: 69 74 65 2d 73 74 72 69 6e 67 20 6c 20 23 66 20 ite-string l #f
ad70: 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 20 20 20 bin-dat).;;..
ad80: 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d (loop (read-
ad90: 73 74 72 69 6e 67 20 31 29 20 23 66 20 28 2b 20 string 1) #f (+
ada0: 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 09 20 20 20 num 1))).;;..
adb0: 20 20 20 3b 3b 20 73 74 72 69 6e 67 20 73 6f 20 ;; string so
adc0: 66 61 72 20 6d 61 74 63 68 65 73 20 64 65 6c 69 far matches deli
add0: 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 20 20 20 m-string.;;..
ade0: 20 20 20 28 65 6e 64 6c 69 6e 65 0a 3b 3b 09 09 (endline.;;..
adf0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
ae00: 6e 64 73 74 72 20 28 67 65 74 2d 6f 75 74 70 75 ndstr (get-outpu
ae10: 74 2d 73 74 72 69 6e 67 20 65 6e 64 6c 69 6e 65 t-string endline
ae20: 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 28 65 )).;;... (e
ae30: 6e 64 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 ndlen (string-le
ae40: 6e 67 74 68 20 65 6e 64 73 74 72 29 29 29 0a 3b ngth endstr))).;
ae50: 3b 09 09 09 20 28 69 66 20 28 3e 20 65 6e 64 6c ;... (if (> endl
ae60: 65 6e 20 30 29 0a 3b 3b 09 09 09 20 20 20 20 20 en 0).;;...
ae70: 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 (format debugp "
ae80: 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e 65 6e 64 73 delim: ~A\nends
ae90: 74 72 3a 20 7e 41 5c 6e 22 20 64 65 6c 69 6d 2d tr: ~A\n" delim-
aea0: 73 74 72 69 6e 67 20 65 6e 64 73 74 72 29 29 0a string endstr)).
aeb0: 3b 3b 09 09 09 20 28 69 66 20 28 61 6e 64 20 28 ;;... (if (and (
aec0: 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c > delim-len endl
aed0: 65 6e 29 0a 3b 3b 09 09 09 09 20 20 28 73 74 72 en).;;.... (str
aee0: 69 6e 67 3d 3f 20 6c 20 28 73 75 62 73 74 72 69 ing=? l (substri
aef0: 6e 67 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 ng delim-string
af00: 65 6e 64 6c 65 6e 20 28 2b 20 65 6e 64 6c 65 6e endlen (+ endlen
af10: 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 1)))).;;...
af20: 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 63 68 ;; yes, this ch
af30: 61 72 61 63 74 65 72 20 6d 61 74 63 68 65 73 20 aracter matches
af40: 74 68 65 20 6e 65 78 74 20 69 6e 20 74 68 65 20 the next in the
af50: 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 delim-string.;;.
af60: 09 09 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 .. (if (eq?
af70: 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c 65 6e delim-len endlen
af80: 29 20 3b 3b 20 68 61 76 65 20 61 20 6d 61 74 63 ) ;; have a matc
af90: 68 21 20 49 67 6e 6f 72 65 20 74 68 61 74 20 61 h! Ignore that a
afa0: 20 6e 65 77 6c 69 6e 65 20 69 73 20 72 65 71 75 newline is requ
afb0: 69 72 65 64 2e 20 4c 61 7a 79 20 62 75 67 67 65 ired. Lazy bugge
afc0: 72 2e 0a 3b 3b 09 09 09 09 20 28 6c 65 74 2a 20 r..;;.... (let*
afd0: 28 28 66 6e 20 20 20 20 20 20 28 73 74 72 69 6e ((fn (strin
afe0: 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 74 61 2d 6e g->symbol data-n
aff0: 61 6d 65 29 29 29 0a 3b 3b 09 09 09 09 20 20 20 ame))).;;....
b000: 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 66 6f (formdat:set! fo
b010: 72 6d 64 61 74 20 66 6e 20 28 6c 69 73 74 20 66 rmdat fn (list f
b020: 69 6c 65 2d 6e 61 6d 65 20 64 61 74 61 2d 74 79 ile-name data-ty
b030: 70 65 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f 62 pe (string->blob
b040: 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 (get-output-str
b050: 69 6e 67 20 62 69 6e 2d 64 61 74 29 29 29 29 0a ing bin-dat)))).
b060: 3b 3b 09 09 09 09 20 20 20 28 73 65 74 21 20 6d ;;.... (set! m
b070: 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 09 ode 'norm).;;...
b080: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
b090: 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b 3b 09 line) #f 0)).;;.
b0a0: 09 09 09 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 ... (begin.;;...
b0b0: 09 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e . (write-strin
b0c0: 67 20 6c 20 23 66 20 65 6e 64 6c 69 6e 65 29 0a g l #f endline).
b0d0: 3b 3b 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 ;;.... (loop (
b0e0: 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 65 read-string 1) e
b0f0: 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 6d 20 31 29 ndline (+ num 1)
b100: 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 3b 3b ))).;;... ;;
b110: 20 6e 6f 2c 20 74 68 69 73 20 63 68 61 72 61 63 no, this charac
b120: 74 65 72 20 64 6f 65 73 20 4e 4f 54 20 6d 61 74 ter does NOT mat
b130: 63 68 20 74 68 65 20 6e 65 78 74 20 69 6e 20 6c ch the next in l
b140: 69 6e 65 20 69 6e 20 64 65 6c 69 6d 2d 73 74 72 ine in delim-str
b150: 69 6e 67 0a 3b 3b 09 09 09 20 20 20 20 20 28 62 ing.;;... (b
b160: 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 20 20 20 egin.;;...
b170: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 22 (write-string "
b180: 5c 6e 22 20 23 66 20 62 69 6e 2d 64 61 74 29 20 \n" #f bin-dat)
b190: 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 67 65 74 20 ;; don't forget
b1a0: 74 68 61 74 20 6e 65 77 6c 69 6e 65 20 77 65 20 that newline we
b1b0: 64 72 6f 70 70 65 64 0a 3b 3b 09 09 09 20 20 20 dropped.;;...
b1c0: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
b1d0: 67 20 65 6e 64 73 74 72 20 23 66 20 62 69 6e 2d g endstr #f bin-
b1e0: 64 61 74 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 dat).;;...
b1f0: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c (write-string l
b200: 20 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 #f bin-dat).;;.
b210: 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 .. (loop (
b220: 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 23 read-string 1) #
b230: 66 20 28 2b 20 6e 75 6d 20 31 29 29 29 29 29 29 f (+ num 1))))))
b240: 29 29 0a 3b 3b 09 09 20 20 20 20 29 29 29 29 29 )).;;.. )))))
b250: 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 64 61 74 ..;; (formdat
b260: 3a 70 72 69 6e 74 61 6c 6c 20 66 6f 72 6d 64 61 :printall formda
b270: 74 20 28 6c 61 6d 62 64 61 20 28 78 29 28 77 72 t (lambda (x)(wr
b280: 69 74 65 2d 6c 69 6e 65 20 78 20 64 65 62 75 67 ite-line x debug
b290: 70 29 29 29 0a 0a 23 7c 0a 28 64 65 66 69 6e 65 p)))..#|.(define
b2a0: 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 inp (open-input
b2b0: 2d 66 69 6c 65 20 22 2f 74 6d 70 2f 73 74 6d 6c -file "/tmp/stml
b2c0: 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 2e 6c 6f 67 run/delme-33.log
b2d0: 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 66 22 29 29 .keep-for-ref"))
b2e0: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
b2f0: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
b300: 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d )).(close-input-
b310: 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a 0a 3b 3b port inp).|#..;;
b320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b360: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 73 65 20 61 20 ======.;; use a
b370: 74 61 62 6c 65 20 69 6e 20 79 6f 75 72 20 64 62 table in your db
b380: 20 63 61 6c 6c 65 64 20 6d 65 74 61 64 61 74 20 called metadat
b390: 74 6f 20 73 74 6f 72 65 20 6b 65 79 20 76 61 6c to store key val
b3a0: 75 65 20 70 61 69 72 73 0a 3b 3b 3d 3d 3d 3d 3d ue pairs.;;=====
b3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3f0: 3d 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6b 65 79 =...(define (key
b400: 73 74 6f 72 65 3a 67 65 74 20 64 62 20 6b 65 79 store:get db key
b410: 29 0a 20 20 28 64 62 69 3a 67 65 74 2d 6f 6e 65 ). (dbi:get-one
b420: 20 64 62 20 22 53 45 4c 45 43 54 20 76 61 6c 75 db "SELECT valu
b430: 65 20 46 52 4f 4d 20 6d 65 74 61 64 61 74 61 20 e FROM metadata
b440: 57 48 45 52 45 20 6b 65 79 3d 3f 3b 22 20 6b 65 WHERE key=?;" ke
b450: 79 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6b 65 y))..(define (ke
b460: 79 73 74 6f 72 65 3a 73 65 74 21 20 64 62 20 6b ystore:set! db k
b470: 65 79 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 ey value). (let
b480: 20 28 28 63 75 72 72 2d 76 61 6c 20 28 6b 65 79 ((curr-val (key
b490: 73 74 6f 72 65 3a 67 65 74 20 64 62 20 6b 65 79 store:get db key
b4a0: 29 29 29 0a 20 20 20 20 28 69 66 20 63 75 72 72 ))). (if curr
b4b0: 2d 76 61 6c 0a 09 28 64 62 69 3a 65 78 65 63 20 -val..(dbi:exec
b4c0: 64 62 20 22 55 50 44 41 54 45 20 6d 65 74 61 64 db "UPDATE metad
b4d0: 61 74 61 20 53 45 54 20 76 61 6c 75 65 3d 3f 20 ata SET value=?
b4e0: 57 48 45 52 45 20 6b 65 79 3d 3f 3b 22 20 76 61 WHERE key=?;" va
b4f0: 6c 75 65 20 6b 65 79 29 0a 09 28 64 62 69 3a 65 lue key)..(dbi:e
b500: 78 65 63 20 64 62 20 22 49 4e 53 45 52 54 20 49 xec db "INSERT I
b510: 4e 54 4f 20 6d 65 74 61 64 61 74 61 20 28 6b 65 NTO metadata (ke
b520: 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 20 y,value) VALUES
b530: 28 3f 2c 3f 29 3b 22 20 6b 65 79 20 76 61 6c 75 (?,?);" key valu
b540: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 e))))..(define (
b550: 6b 65 79 73 74 6f 72 65 3a 64 65 6c 21 20 64 62 keystore:del! db
b560: 20 6b 65 79 29 0a 20 20 28 64 62 69 3a 65 78 65 key). (dbi:exe
b570: 63 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 4f c db "DELETE FRO
b580: 4d 20 6d 65 74 61 64 61 74 61 20 57 48 45 52 45 M metadata WHERE
b590: 20 6b 65 79 3d 3f 3b 22 20 6b 65 79 29 29 0a 0a key=?;" key))..
b5a0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b5b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5e0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 74 75 66 ========.;; stuf
b5f0: 66 20 66 72 6f 6d 20 6d 69 73 63 2d 73 74 6d 6c f from misc-stml
b600: 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .scm.;;=========
b610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
b650: 3b 20 6d 6f 76 65 64 20 74 6f 20 73 74 6d 6c 63 ; moved to stmlc
b660: 6f 6d 6d 6f 6e 0a 3b 3b 20 28 62 75 6e 63 68 20 ommon.;; (bunch
b670: 6f 66 20 73 74 75 66 66 29 0a 0a 3b 3b 20 6d 6f of stuff)..;; mo
b680: 76 65 64 20 66 72 6f 6d 20 73 74 6d 6c 63 6f 6d ved from stmlcom
b690: 6d 6f 6e 0a 3b 3b 0a 3b 3b 20 61 6e 79 74 68 69 mon.;;.;; anythi
b6a0: 6e 67 20 65 78 63 65 70 74 20 61 20 6c 69 73 74 ng except a list
b6b0: 20 69 73 20 63 6f 6e 76 65 72 74 65 64 20 74 6f is converted to
b6c0: 20 61 20 73 74 72 69 6e 67 21 21 21 0a 28 64 65 a string!!!.(de
b6d0: 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 73 74 72 fine (s:any->str
b6e0: 69 6e 67 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 ing val). (cond
b6f0: 0a 20 20 20 28 28 73 74 72 69 6e 67 3f 20 76 61 . ((string? va
b700: 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 6e 75 6d l) val). ((num
b710: 62 65 72 3f 20 76 61 6c 29 20 28 6e 75 6d 62 65 ber? val) (numbe
b720: 72 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a r->string val)).
b730: 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c ((symbol? val
b740: 29 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e ) (symbol->strin
b750: 67 20 76 61 6c 29 29 0a 20 20 20 28 28 65 71 3f g val)). ((eq?
b760: 20 76 61 6c 20 23 66 29 20 22 22 29 0a 20 20 20 val #f) "").
b770: 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 54 ((eq? val #t) "T
b780: 52 55 45 22 29 0a 20 20 20 28 28 6c 69 73 74 3f RUE"). ((list?
b790: 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 65 val) val). (e
b7a0: 6c 73 65 20 0a 20 20 20 20 28 6c 65 74 20 28 28 lse . (let ((
b7b0: 6f 73 74 72 20 28 6f 70 65 6e 2d 6f 75 74 70 75 ostr (open-outpu
b7c0: 74 2d 73 74 72 69 6e 67 29 29 29 0a 20 20 20 20 t-string))).
b7d0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
b7e0: 6f 2d 70 6f 72 74 20 6f 73 74 72 0a 09 28 6c 61 o-port ostr..(la
b7f0: 6d 62 64 61 20 28 29 0a 09 20 20 28 64 69 73 70 mbda ().. (disp
b800: 6c 61 79 20 76 61 6c 29 29 29 0a 20 20 20 20 20 lay val))).
b810: 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 (get-output-str
b820: 69 6e 67 20 6f 73 74 72 29 29 29 29 29 0a 0a 28 ing ostr)))))..(
b830: 64 65 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 6e define (s:any->n
b840: 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f umber val). (co
b850: 6e 64 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 nd. ((number?
b860: 76 61 6c 29 20 20 76 61 6c 29 0a 20 20 20 28 28 val) val). ((
b870: 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 20 28 73 string? val) (s
b880: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 tring->number va
b890: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
b8a0: 20 76 61 6c 29 20 20 28 73 74 72 69 6e 67 2d 3e val) (string->
b8b0: 6e 75 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e number (symbol->
b8c0: 73 74 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 string val))).
b8d0: 20 28 65 6c 73 65 20 20 20 20 20 23 66 29 29 29 (else #f)))
b8e0: 0a 0a 3b 3b 20 4d 6f 76 65 64 20 66 72 6f 6d 20 ..;; Moved from
b8f0: 73 74 6d 6c 63 6f 6d 6d 6f 6e 0a 3b 3b 0a 28 64 stmlcommon.;;.(d
b900: 65 66 69 6e 65 20 28 73 3a 63 67 69 2d 6f 75 74 efine (s:cgi-out
b910: 20 69 6e 6c 73 74 29 0a 20 20 28 73 3a 6f 75 74 inlst). (s:out
b920: 70 75 74 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 put (current-out
b930: 70 75 74 2d 70 6f 72 74 29 20 69 6e 6c 73 74 29 put-port) inlst)
b940: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 6f 75 )..(define (s:ou
b950: 74 70 75 74 20 70 6f 72 74 20 69 6e 6c 73 74 29 tput port inlst)
b960: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
b970: 28 78 29 0a 09 20 28 63 6f 6e 64 20 0a 09 20 20 (x).. (cond ..
b980: 28 28 73 74 72 69 6e 67 3f 20 78 29 20 28 70 72 ((string? x) (pr
b990: 69 6e 74 20 78 29 29 20 3b 3b 20 28 70 72 69 6e int x)) ;; (prin
b9a0: 74 20 78 29 29 0a 09 20 20 28 28 73 79 6d 62 6f t x)).. ((symbo
b9b0: 6c 3f 20 78 29 20 28 70 72 69 6e 74 20 78 29 29 l? x) (print x))
b9c0: 20 3b 3b 20 28 70 72 69 6e 74 20 78 29 29 0a 09 ;; (print x))..
b9d0: 20 20 28 28 6c 69 73 74 3f 20 78 29 20 20 20 28 ((list? x) (
b9e0: 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 20 78 29 s:output port x)
b9f0: 29 0a 09 20 20 28 65 6c 73 65 20 22 22 0a 09 20 ).. (else ""..
ba00: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 52 ;; (print "ERR
ba10: 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 20 30 32 OR: Bad input 02
ba20: 22 29 20 3b 3b 20 77 68 79 20 64 6f 20 61 6e 79 ") ;; why do any
ba30: 74 68 69 6e 67 3f 20 64 6f 6e 27 74 20 6f 75 74 thing? don't out
ba40: 70 75 74 20 6a 75 6e 6b 2e 0a 09 20 20 20 29 29 put junk... ))
ba50: 29 0a 20 20 20 20 20 20 20 69 6e 6c 73 74 29 29 ). inlst))
ba60: 0a 3b 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 .; (if (> (leng
ba70: 74 68 20 69 6e 6c 73 74 29 20 32 29 0a 3b 20 20 th inlst) 2).;
ba80: 20 20 20 20 28 70 72 69 6e 74 29 29 29 0a 0a 28 (print)))..(
ba90: 64 65 66 69 6e 65 20 28 73 3a 6f 75 74 70 75 74 define (s:output
baa0: 2d 6e 65 77 20 70 6f 72 74 20 69 6e 6c 73 74 29 -new port inlst)
bab0: 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
bac0: 74 6f 2d 70 6f 72 74 20 70 6f 72 74 0a 20 20 20 to-port port.
bad0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
bae0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
baf0: 09 20 20 20 20 20 20 20 28 63 6f 6e 64 20 0a 09 . (cond ..
bb00: 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 28 70 .((string? x) (p
bb10: 72 69 6e 74 20 78 29 29 0a 09 09 28 28 73 79 6d rint x))...((sym
bb20: 62 6f 6c 3f 20 78 29 20 28 70 72 69 6e 74 20 78 bol? x) (print x
bb30: 29 29 0a 09 09 28 28 6c 69 73 74 3f 20 78 29 20 ))...((list? x)
bb40: 20 20 28 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 (s:output port
bb50: 20 78 29 29 0a 09 09 28 65 6c 73 65 0a 09 09 20 x))...(else...
bb60: 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 ;; (print "ERROR
bb70: 3a 20 42 61 64 20 69 6e 70 75 74 20 30 33 22 29 : Bad input 03")
bb80: 0a 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 20 . )))..
bb90: 69 6e 6c 73 74 29 29 29 29 0a 20 20 20 20 20 20 inlst)))).
bba0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 65 .(define (e
bbb0: 72 72 3a 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 20 rr:log . msg).
bbc0: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
bbd0: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 port (current-er
bbe0: 72 6f 72 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c ror-port) ;; (sl
bbf0: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 ot-ref self 'log
bc00: 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 pt). (lambda
bc10: 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 () . (apply
bc20: 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a print msg))))..
bc30: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
bc40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bc50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bc60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bc70: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 42 0a ========.;; D B.
bc80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
bc90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bcb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bcc0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e ========..;; con
bcd0: 76 65 72 74 20 76 61 6c 75 65 73 20 74 6f 20 61 vert values to a
bce0: 70 70 72 6f 70 72 69 61 74 65 20 73 74 72 69 6e ppropriate strin
bcf0: 67 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 gs.;;.(define (s
bd00: 3a 73 71 6c 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 :sqlparam-val->s
bd10: 74 72 69 6e 67 20 76 61 6c 29 0a 20 20 28 63 6f tring val). (co
bd20: 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 20 20 nd. ((list?
bd30: 76 61 6c 29 28 73 74 72 69 6e 67 2d 6a 6f 69 6e val)(string-join
bd40: 20 28 6d 61 70 20 73 79 6d 62 6f 6c 2d 3e 73 74 (map symbol->st
bd50: 72 69 6e 67 20 76 61 6c 29 20 22 2c 22 29 29 20 ring val) ","))
bd60: 3b 3b 20 28 61 20 62 20 63 29 20 3d 3e 20 61 2c ;; (a b c) => a,
bd70: 62 2c 63 0a 20 20 20 28 28 73 74 72 69 6e 67 3f b,c. ((string?
bd80: 20 76 61 6c 29 28 63 6f 6e 63 20 22 27 22 20 28 val)(conc "'" (
bd90: 64 62 69 3a 65 73 63 61 70 65 2d 73 74 72 69 6e dbi:escape-strin
bda0: 67 20 76 61 6c 29 20 22 27 22 29 29 0a 20 20 20 g val) "'")).
bdb0: 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 28 6e ((number? val)(n
bdc0: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 76 61 umber->string va
bdd0: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
bde0: 20 76 61 6c 29 28 64 62 69 3a 65 73 63 61 70 65 val)(dbi:escape
bdf0: 2d 73 74 72 69 6e 67 20 28 73 79 6d 62 6f 6c 2d -string (symbol-
be00: 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 >string val))).
be10: 20 20 28 28 62 6f 6f 6c 65 61 6e 3f 20 76 61 6c ((boolean? val
be20: 29 0a 20 20 20 20 28 69 66 20 76 61 6c 20 22 54 ). (if val "T
be30: 52 55 45 22 20 22 46 41 4c 53 45 22 29 29 20 20 RUE" "FALSE"))
be40: 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 62 ;; should this b
be50: 65 20 22 54 52 55 45 22 20 6f 72 20 31 3f 0a 20 e "TRUE" or 1?.
be60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be70: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
be80: 73 68 6f 75 6c 64 20 74 68 69 73 20 62 65 20 22 should this be "
be90: 46 41 4c 53 45 22 20 6f 72 20 30 20 6f 72 20 4e FALSE" or 0 or N
bea0: 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 65 0a 20 20 ULL?. (else.
beb0: 20 20 28 65 72 72 3a 6c 6f 67 20 22 73 71 6c 70 (err:log "sqlp
bec0: 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 6e 20 74 79 aram: unknown ty
bed0: 70 65 20 66 6f 72 20 76 61 6c 75 65 3a 20 22 20 pe for value: "
bee0: 76 61 6c 29 0a 20 20 20 20 22 22 29 29 29 0a 0a val). "")))..
bef0: 3b 3b 20 28 73 71 6c 70 61 72 61 6d 20 22 49 4e ;; (sqlparam "IN
bf00: 53 45 52 54 20 49 4e 54 4f 20 66 6f 6f 28 6e 61 SERT INTO foo(na
bf10: 6d 65 2c 61 67 65 29 20 56 41 4c 55 45 53 28 3f me,age) VALUES(?
bf20: 2c 3f 29 3b 22 20 22 62 6f 62 22 20 32 30 29 0a ,?);" "bob" 20).
bf30: 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 61 6c 75 65 ;; NB// 1. value
bf40: 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b 20 20 20 20 s only!! .;;
bf50: 20 20 32 2e 20 74 65 72 6d 69 6e 61 74 69 6e 67 2. terminating
bf60: 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 65 71 75 69 semicolon requi
bf70: 72 65 64 20 28 75 73 65 64 20 61 73 20 70 61 72 red (used as par
bf80: 74 20 6f 66 20 6c 6f 67 69 63 29 0a 3b 3b 0a 3b t of logic).;;.;
bf90: 3b 20 61 3d 3f 20 31 20 28 6e 75 6d 62 65 72 29 ; a=? 1 (number)
bfa0: 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 3d 3f 20 31 => a=1.;; a=? 1
bfb0: 20 28 73 74 72 69 6e 67 29 20 3d 3e 20 61 3d 27 (string) => a='
bfc0: 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 20 20 20 20 1'.;; a=? #f
bfd0: 20 20 20 20 20 3d 3e 20 61 3d 46 41 4c 53 45 20 => a=FALSE
bfe0: 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 79 6d 62 6f .;; a=? a (symbo
bff0: 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b 3b 0a 28 64 l) => a=a .;;.(d
c000: 65 66 69 6e 65 20 28 73 3a 73 71 6c 70 61 72 61 efine (s:sqlpara
c010: 6d 20 71 75 65 72 79 20 2e 20 61 72 67 73 29 0a m query . args).
c020: 20 20 28 6c 65 74 2a 20 28 28 71 75 65 72 79 2d (let* ((query-
c030: 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 73 70 parts (string-sp
c040: 6c 69 74 20 71 75 65 72 79 20 22 3f 22 29 29 0a lit query "?")).
c050: 20 20 20 20 20 20 20 20 20 28 6e 75 6d 2d 70 61 (num-pa
c060: 72 74 73 20 20 20 20 28 6c 65 6e 67 74 68 20 71 rts (length q
c070: 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 uery-parts)).
c080: 20 20 20 20 20 20 28 6e 75 6d 2d 61 72 67 73 20 (num-args
c090: 20 20 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 (length args)
c0a0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
c0b0: 28 3d 20 28 2b 20 6e 75 6d 2d 61 72 67 73 20 31 (= (+ num-args 1
c0c0: 29 20 6e 75 6d 2d 70 61 72 74 73 29 29 0a 20 20 ) num-parts)).
c0d0: 20 20 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 (err:log "
c0e0: 45 52 52 4f 52 2c 20 73 71 6c 70 61 72 61 6d 3a ERROR, sqlparam:
c0f0: 20 77 72 6f 6e 67 20 6e 75 6d 62 65 72 20 6f 66 wrong number of
c100: 20 61 72 67 75 6d 65 6e 74 73 20 6f 72 20 6d 69 arguments or mi
c110: 73 73 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 2c ssing semicolon,
c120: 20 22 20 6e 75 6d 2d 61 72 67 73 20 22 20 66 6f " num-args " fo
c130: 72 20 71 75 65 72 79 20 22 20 71 75 65 72 79 29 r query " query)
c140: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 3d 20 . (if (=
c150: 6e 75 6d 2d 61 72 67 73 20 30 29 20 71 75 65 72 num-args 0) quer
c160: 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c y. (l
c170: 65 74 20 6c 6f 6f 70 20 28 28 73 65 63 74 69 6f et loop ((sectio
c180: 6e 20 28 63 61 72 20 71 75 65 72 79 2d 70 61 72 n (car query-par
c190: 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ts)).
c1a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 69 (tai
c1b0: 6c 20 20 20 20 28 63 64 72 20 71 75 65 72 79 2d l (cdr query-
c1c0: 70 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 parts)).
c1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c1e0: 72 65 73 75 6c 74 20 20 22 22 29 0a 20 20 20 20 result "").
c1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c200: 20 20 20 28 61 72 67 20 20 20 20 20 28 63 61 72 (arg (car
c210: 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 args)).
c220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c230: 61 72 67 74 61 69 6c 20 28 63 64 72 20 61 72 67 argtail (cdr arg
c240: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s))).
c250: 20 20 20 28 6c 65 74 2a 20 28 28 76 61 6c 73 74 (let* ((valst
c260: 72 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d r (s:sqlparam
c270: 2d 76 61 6c 2d 3e 73 74 72 69 6e 67 20 61 72 67 -val->string arg
c280: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
c290: 20 20 20 20 20 20 20 20 28 6e 65 77 72 65 73 75 (newresu
c2a0: 6c 74 20 28 63 6f 6e 63 20 72 65 73 75 6c 74 20 lt (conc result
c2b0: 73 65 63 74 69 6f 6e 20 76 61 6c 73 74 72 29 29 section valstr))
c2c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c2d0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 67 (if (null? arg
c2e0: 74 61 69 6c 29 20 3b 3b 20 77 65 20 61 72 65 20 tail) ;; we are
c2f0: 64 6f 6e 65 0a 20 20 20 20 20 20 20 20 20 20 20 done.
c300: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 6e (conc n
c310: 65 77 72 65 73 75 6c 74 20 28 63 61 72 20 74 61 ewresult (car ta
c320: 69 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 il)).
c330: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 0a 20 (loop.
c340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c350: 20 20 20 20 28 63 61 72 20 74 61 69 6c 29 0a 20 (car tail).
c360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c370: 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 0a 20 (cdr tail).
c380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c390: 20 20 20 20 6e 65 77 72 65 73 75 6c 74 0a 20 20 newresult.
c3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c3b0: 20 20 20 28 63 61 72 20 61 72 67 74 61 69 6c 29 (car argtail)
c3c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c3d0: 20 20 20 20 20 20 28 63 64 72 20 61 72 67 74 61 (cdr argta
c3e0: 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 il)))))))))..;;
c3f0: 28 64 65 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a (define session:
c400: 76 61 6c 69 64 2d 63 68 61 72 73 20 22 61 62 63 valid-chars "abc
c410: 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 defghijklmnopqrs
c420: 74 75 76 77 78 79 7a 41 42 43 44 45 46 47 48 49 tuvwxyzABCDEFGHI
c430: 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 JKLMNOPQRSTUVWXY
c440: 5a 30 31 32 33 34 35 36 37 38 39 22 29 0a 28 64 Z0123456789").(d
c450: 65 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a 76 61 efine session:va
c460: 6c 69 64 2d 63 68 61 72 73 20 22 61 62 63 64 65 lid-chars "abcde
c470: 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 fghijklmnopqrstu
c480: 76 77 78 79 7a 30 31 32 33 34 35 36 37 38 39 22 vwxyz0123456789"
c490: 29 20 3b 3b 20 63 6f 6f 6b 69 65 73 20 61 72 65 ) ;; cookies are
c4a0: 20 63 61 73 65 20 69 6e 73 65 6e 73 69 74 69 76 case insensitiv
c4b0: 65 2e 0a 28 64 65 66 69 6e 65 20 73 65 73 73 69 e..(define sessi
c4c0: 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 2d 63 68 61 on:num-valid-cha
c4d0: 72 73 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 rs (string-lengt
c4e0: 68 20 73 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d h session:valid-
c4f0: 63 68 61 72 73 29 29 0a 0a 28 64 65 66 69 6e 65 chars))..(define
c500: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 (session:get-nt
c510: 68 2d 63 68 61 72 20 6e 74 68 29 0a 20 20 28 73 h-char nth). (s
c520: 75 62 73 74 72 69 6e 67 20 73 65 73 73 69 6f 6e ubstring session
c530: 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 6e 74 68 :valid-chars nth
c540: 20 20 28 2b 20 6e 74 68 20 31 29 29 29 0a 0a 28 (+ nth 1)))..(
c550: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
c560: 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 0a 20 get-rand-char).
c570: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 (session:get-nt
c580: 68 2d 63 68 61 72 20 28 72 61 6e 64 6f 6d 20 73 h-char (random s
c590: 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 ession:num-valid
c5a0: 2d 63 68 61 72 73 29 29 29 0a 0a 28 64 65 66 69 -chars)))..(defi
c5b0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 ne (session:make
c5c0: 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 6c 65 6e -rand-string len
c5d0: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
c5e0: 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 20 res "").
c5f0: 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 20 (n 1)).
c600: 20 20 28 69 66 20 28 3e 20 6e 20 6c 65 6e 29 20 (if (> n len)
c610: 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c 6f 6f res. (loo
c620: 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 p (string-append
c630: 20 72 65 73 20 28 73 65 73 73 69 6f 6e 3a 67 65 res (session:ge
c640: 74 2d 72 61 6e 64 2d 63 68 61 72 29 29 0a 20 20 t-rand-char)).
c650: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 6e (+ n
c660: 20 31 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 79 62 1)))))..;; mayb
c670: 65 20 72 65 70 6c 61 63 65 20 61 62 6f 76 65 20 e replace above
c680: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
c690: 20 77 69 74 68 20 74 68 69 73 20 73 6f 6d 65 64 with this somed
c6a0: 61 79 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ay?.;;.(define (
c6b0: 73 65 73 73 69 6f 6e 3a 67 65 6e 65 72 69 63 2d session:generic-
c6c0: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
c6d0: 20 6c 65 6e 20 73 65 65 64 2d 73 74 72 69 6e 67 len seed-string
c6e0: 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 63 ). (let ((num-c
c6f0: 68 61 72 73 20 28 73 74 72 69 6e 67 2d 6c 65 6e hars (string-len
c700: 67 74 68 20 73 65 65 64 2d 73 74 72 69 6e 67 29 gth seed-string)
c710: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
c720: 20 28 28 72 65 73 20 22 22 29 0a 09 20 20 20 20 ((res "")..
c730: 20 20 20 28 6e 20 20 20 31 29 29 0a 20 20 20 20 (n 1)).
c740: 20 20 28 6c 65 74 20 28 28 63 68 61 72 2d 6e 75 (let ((char-nu
c750: 6d 20 28 72 61 6e 64 6f 6d 20 6e 75 6d 2d 63 68 m (random num-ch
c760: 61 72 73 29 29 29 0a 09 28 69 66 20 28 3e 20 6e ars)))..(if (> n
c770: 20 6c 65 6e 29 20 72 65 73 0a 09 20 20 20 20 28 len) res.. (
c780: 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 70 loop (string-app
c790: 65 6e 64 20 72 65 73 20 28 73 75 62 73 74 72 69 end res (substri
c7a0: 6e 67 20 73 65 65 64 2d 73 74 72 69 6e 67 20 63 ng seed-string c
c7b0: 68 61 72 2d 6e 75 6d 20 28 2b 20 63 68 61 72 2d har-num (+ char-
c7c0: 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 28 2b 20 num 1)))... (+
c7d0: 6e 20 31 29 29 29 29 29 29 29 0a 0a 0a 3b 3b 3d n 1)))))))...;;=
c7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c820: 3d 3d 3d 3d 3d 0a 3b 3b 20 50 20 41 20 52 20 41 =====.;; P A R A
c830: 20 4d 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d M S.;;=========
c840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
c880: 3b 20 69 6e 70 75 74 3a 20 27 61 20 28 27 61 20 ; input: 'a ('a
c890: 22 76 61 6c 20 61 22 20 27 62 20 22 76 61 6c 20 "val a" 'b "val
c8a0: 62 22 29 20 3d 3e 20 22 76 61 6c 20 61 22 0a 28 b") => "val a".(
c8b0: 64 65 66 69 6e 65 20 28 73 3a 66 69 6e 64 2d 70 define (s:find-p
c8c0: 61 72 61 6d 20 6b 65 79 20 70 61 72 61 6d 2d 6c aram key param-l
c8d0: 73 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 st). (let loop
c8e0: 28 28 68 65 61 64 20 28 63 61 72 20 70 61 72 61 ((head (car para
c8f0: 6d 2d 6c 73 74 29 29 0a 09 20 20 20 20 20 28 74 m-lst)).. (t
c900: 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 2d 6c ail (cdr param-l
c910: 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 65 st))). (if (e
c920: 71 3f 20 68 65 61 64 20 6b 65 79 29 0a 09 28 63 q? head key)..(c
c930: 61 72 20 74 61 69 6c 29 0a 09 28 69 66 20 28 3c ar tail)..(if (<
c940: 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 32 (length tail) 2
c950: 29 20 23 66 0a 09 20 20 20 20 28 6c 6f 6f 70 20 ) #f.. (loop
c960: 28 63 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 (cadr tail)(cddr
c970: 20 74 61 69 6c 29 29 29 29 29 29 0a 0a 28 64 65 tail))))))..(de
c980: 66 69 6e 65 20 28 73 3a 70 61 72 61 6d 2d 3e 73 fine (s:param->s
c990: 74 72 69 6e 67 20 70 61 72 61 6d 29 0a 20 20 28 tring param). (
c9a0: 63 6f 6e 63 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 conc (symbol->st
c9b0: 72 69 6e 67 20 28 63 61 72 20 70 61 72 61 6d 29 ring (car param)
c9c0: 29 20 22 3d 22 20 22 5c 22 22 20 28 63 61 64 72 ) "=" "\"" (cadr
c9d0: 20 70 61 72 61 6d 29 20 22 5c 22 22 29 29 0a 0a param) "\""))..
c9e0: 3b 3b 20 72 65 6d 6f 76 65 20 27 66 6f 6f 20 22 ;; remove 'foo "
c9f0: 62 61 72 22 20 66 72 6f 6d 20 28 27 66 6f 6f 20 bar" from ('foo
ca00: 22 62 61 72 22 20 27 62 61 72 20 22 66 6f 6f 22 "bar" 'bar "foo"
ca10: 29 0a 28 64 65 66 69 6e 65 20 28 73 3a 72 65 6d ).(define (s:rem
ca20: 6f 76 65 2d 70 61 72 61 6d 2d 6d 61 74 63 68 69 ove-param-matchi
ca30: 6e 67 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 ng params key).
ca40: 20 28 69 66 20 28 3d 20 28 6c 65 6e 67 74 68 20 (if (= (length
ca50: 70 61 72 61 6d 73 29 20 30 29 27 28 29 20 3b 3b params) 0)'() ;;
ca60: 20 20 70 72 6f 70 65 72 20 70 61 72 61 6d 73 20 proper params
ca70: 6c 69 73 74 20 3e 3d 20 32 20 69 74 65 6d 73 0a list >= 2 items.
ca80: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
ca90: 28 28 68 65 61 64 20 20 20 20 20 28 63 61 72 20 ((head (car
caa0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 params)).
cab0: 20 20 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 (tail
cac0: 20 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 (cdr params)
cad0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
cae0: 20 20 20 28 72 65 73 75 6c 74 20 20 20 27 28 29 (result '()
caf0: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
cb00: 73 79 6d 62 6f 6c 3f 20 68 65 61 64 29 20 3b 3b symbol? head) ;;
cb10: 20 73 79 6d 62 6f 6c 73 20 68 61 76 65 20 70 61 symbols have pa
cb20: 72 61 6d 73 0a 20 20 20 20 20 20 20 20 20 20 20 rams.
cb30: 20 28 6c 65 74 20 28 28 76 61 6c 20 20 20 20 20 (let ((val
cb40: 28 63 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 (car tail)).
cb50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
cb60: 65 77 74 61 69 6c 20 28 63 64 72 20 74 61 69 6c ewtail (cdr tail
cb70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
cb80: 20 20 28 69 66 20 28 65 71 3f 20 68 65 61 64 20 (if (eq? head
cb90: 6b 65 79 29 20 20 3b 3b 20 67 65 74 20 72 69 64 key) ;; get rid
cba0: 20 6f 66 20 74 68 69 73 20 6f 6e 65 0a 20 20 20 of this one.
cbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cbc0: 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 61 69 if (null? newtai
cbd0: 6c 29 20 72 65 73 75 6c 74 0a 20 20 20 20 20 20 l) result.
cbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbf0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
cc00: 69 6c 29 28 63 64 72 20 6e 65 77 74 61 69 6c 29 il)(cdr newtail)
cc10: 20 72 65 73 75 6c 74 29 29 0a 20 20 20 20 20 20 result)).
cc20: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
cc30: 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 61 70 ((newresult (ap
cc40: 70 65 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 73 pend result (lis
cc50: 74 20 68 65 61 64 20 76 61 6c 29 29 29 29 0a 20 t head val)))).
cc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc70: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 (if (null? ne
cc80: 77 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 wtail) newresult
cc90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cca0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
ccb0: 63 61 72 20 6e 65 77 74 61 69 6c 29 28 63 64 72 car newtail)(cdr
ccc0: 20 6e 65 77 74 61 69 6c 29 20 6e 65 77 72 65 73 newtail) newres
ccd0: 75 6c 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 ult))))).
cce0: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 72 (let ((newr
ccf0: 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 esult (append re
cd00: 73 75 6c 74 20 28 6c 69 73 74 20 68 65 61 64 29 sult (list head)
cd10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
cd20: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 (if (null? tai
cd30: 6c 29 20 6e 65 77 72 65 73 75 6c 74 0a 20 20 20 l) newresult.
cd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cd50: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
cd60: 63 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 cdr tail) newres
cd70: 75 6c 74 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ult)))))))..(def
cd80: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
cd90: 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 -param-from para
cda0: 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ms key). (let (
cdb0: 28 72 31 20 28 72 65 67 65 78 70 20 28 63 6f 6e (r1 (regexp (con
cdc0: 63 20 22 5e 22 20 28 73 3a 61 6e 79 2d 3e 73 74 c "^" (s:any->st
cdd0: 72 69 6e 67 20 6b 65 79 29 20 22 3d 28 2e 2a 29 ring key) "=(.*)
cde0: 24 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 $")))). (if (
cdf0: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 23 66 null? params) #f
ce00: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f . (let lo
ce10: 6f 70 20 28 28 68 65 61 64 20 28 63 61 72 20 70 op ((head (car p
ce20: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
ce30: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 69 6c (tail
ce40: 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a (cdr params))).
ce50: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
ce60: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
ce70: 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 0a atch r1 head))).
ce80: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
ce90: 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 20 match.
cea0: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
ceb0: 6d 61 74 63 68 20 31 29 0a 20 20 20 20 20 20 20 match 1).
cec0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
ced0: 6c 6c 3f 20 74 61 69 6c 29 20 23 66 0a 20 20 20 ll? tail) #f.
cee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cef0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
cf00: 29 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 )(cdr tail))))))
cf10: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a )))..(define (s:
cf20: 70 72 6f 63 65 73 73 2d 70 61 72 61 6d 73 20 70 process-params p
cf30: 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 6e 75 arams). (if (nu
cf40: 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 22 0a 20 ll? params) "".
cf50: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
cf60: 28 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 (res "").
cf70: 20 20 20 20 20 20 20 20 20 20 28 68 65 61 64 20 (head
cf80: 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 (car params)).
cf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cfa0: 74 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 tail (cdr params
cfb0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ))). (if
cfc0: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 20 (null? tail).
cfd0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 (conc r
cfe0: 65 73 20 22 20 22 20 28 73 3a 70 61 72 61 6d 2d es " " (s:param-
cff0: 3e 73 74 72 69 6e 67 20 68 65 61 64 29 29 0a 20 >string head)).
d000: 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 (loop
d010: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 . (c
d020: 6f 6e 63 20 72 65 73 20 22 20 22 20 28 73 3a 70 onc res " " (s:p
d030: 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 68 65 61 aram->string hea
d040: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
d050: 20 28 63 61 72 20 74 61 69 6c 29 0a 20 20 20 20 (car tail).
d060: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 61 (cdr ta
d070: 69 6c 29 29 29 29 29 29 0a 0a 3b 3b 20 72 65 6d il))))))..;; rem
d080: 6f 76 65 20 6b 65 79 3d 76 61 72 20 66 72 6f 6d ove key=var from
d090: 20 28 6b 65 79 3d 76 61 72 20 6b 65 79 31 3d 76 (key=var key1=v
d0a0: 61 72 31 20 6b 65 79 32 3d 76 61 72 32 20 2e 2e ar1 key2=var2 ..
d0b0: 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b 3d 76 2d .).(define (k=v-
d0c0: 70 61 72 61 6d 73 3a 72 65 6d 6f 76 65 2d 6d 61 params:remove-ma
d0d0: 74 63 68 69 6e 67 20 70 61 72 61 6d 73 20 6b 65 tching params ke
d0e0: 79 29 0a 20 20 28 69 66 20 28 3d 20 28 6c 65 6e y). (if (= (len
d0f0: 67 74 68 20 70 61 72 61 6d 73 29 20 30 29 20 70 gth params) 0) p
d100: 61 72 61 6d 73 0a 20 20 20 20 20 20 28 6c 65 74 arams. (let
d110: 20 28 28 72 31 20 28 72 65 67 65 78 70 20 28 63 ((r1 (regexp (c
d120: 6f 6e 63 20 22 5e 22 20 6b 65 79 20 22 3d 22 29 onc "^" key "=")
d130: 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 ))). (let
d140: 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 63 61 loop ((head (ca
d150: 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 r params)).
d160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
d170: 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 29 ail (cdr params)
d180: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d190: 20 20 20 20 20 28 72 65 73 75 6c 74 20 27 28 29 (result '()
d1a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
d1b0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 (string-match r
d1c0: 31 20 68 65 61 64 29 0a 20 20 20 20 20 20 20 20 1 head).
d1d0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
d1e0: 20 74 61 69 6c 29 20 72 65 73 75 6c 74 0a 20 20 tail) result.
d1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d200: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
d210: 28 63 64 72 20 74 61 69 6c 29 20 72 65 73 75 6c (cdr tail) resul
d220: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
d230: 20 20 28 6c 65 74 20 28 28 6e 65 77 6c 73 74 20 (let ((newlst
d240: 28 63 6f 6e 73 20 68 65 61 64 20 72 65 73 75 6c (cons head resul
d250: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
d260: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
d270: 74 61 69 6c 29 20 6e 65 77 6c 73 74 0a 20 20 20 tail) newlst.
d280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d290: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
d2a0: 29 28 63 64 72 20 74 61 69 6c 29 20 6e 65 77 6c )(cdr tail) newl
d2b0: 73 74 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d st))))))))..;;==
d2c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d2d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d300: 3d 3d 3d 3d 0a 3b 3b 20 73 74 75 66 66 20 70 75 ====.;; stuff pu
d310: 6c 6c 65 64 20 66 72 6f 6d 20 73 65 73 73 69 6f lled from sessio
d320: 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d n.;;============
d330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 0a 3b 3b 20 ==========...;;
d370: 73 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a 3b sessions table.;
d380: 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 ; id session_id
d390: 73 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 session_key.;; c
d3a0: 72 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 73 reate table sess
d3b0: 69 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c 20 ions (id serial
d3c0: 6e 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e not null,session
d3d0: 2d 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 -key text);..;;
d3e0: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 62 session_vars tab
d3f0: 6c 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e le.;; id session
d400: 5f 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 20 _id page_id key
d410: 76 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 20 value.;; create
d420: 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 61 table session_va
d430: 72 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e 6f rs (id serial no
d440: 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f 69 t null,session_i
d450: 64 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 74 d integer,page t
d460: 65 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 6c ext,key text,val
d470: 75 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 4f ue text);..;; TO
d480: 44 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 6f DO.;; Concept o
d490: 66 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 72 f order num incr
d4a0: 65 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 63 emented with eac
d4b0: 68 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b 3b h page access.;;
d4c0: 20 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 68 if a branch
d4d0: 20 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 61 is taken then a
d4e0: 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f 75 new session wou
d4f0: 6c 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 72 ld need to be cr
d500: 65 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b eated.;;..;; mak
d510: 65 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 e-vector-record
d520: 73 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e 20 session session
d530: 64 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 6f dbtype dbinit co
d540: 6e 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d 70 nn params path-p
d550: 61 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b 65 arams session-ke
d560: 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f 6d y session-id dom
d570: 61 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 65 ain toppage page
d580: 20 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 65 curr-page conte
d590: 6e 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 70 nt-type page-typ
d5a0: 65 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 72 e sroot twikidir
d5b0: 20 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 67 pagedat alt-pag
d5c0: 65 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 70 e-dat pagevars p
d5d0: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 agevars-before s
d5e0: 65 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 69 essionvars sessi
d5f0: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 6c onvars-before gl
d600: 6f 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c 76 obalvars globalv
d610: 61 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 74 ars-before logpt
d620: 20 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 74 formdat request
d630: 2d 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e 2d -method session-
d640: 63 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 20 cookie curr-err
d650: 6c 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c 65 log-port logfile
d660: 20 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 65 seen-pages page
d670: 2d 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 67 -dir-style debug
d680: 6d 6f 64 65 0a 3b 3b 20 28 64 65 66 69 6e 65 20 mode.;; (define
d690: 28 6d 61 6b 65 2d 73 64 61 74 29 28 6d 61 6b 65 (make-sdat)(make
d6a0: 2d 76 65 63 74 6f 72 20 33 36 29 29 0a 3b 3b 20 -vector 36)).;;
d6b0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 64 62 (define (sdat-db
d6c0: 74 79 70 65 20 20 20 20 20 20 20 20 20 20 20 20 type
d6d0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
d6e0: 6f 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a or-ref vec 0)).
d6f0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
d700: 2d 64 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 -dbinit
d710: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
d720: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
d730: 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 )).;; (define (s
d740: 64 61 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 20 dat-conn
d750: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
d760: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
d770: 63 20 32 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 c 2)).;; (define
d780: 20 28 73 64 61 74 2d 70 67 63 6f 6e 6e 20 20 20 (sdat-pgconn
d790: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
d7a0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
d7b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 (vector-ref vec
d7c0: 32 29 20 31 29 29 0a 3b 3b 20 28 64 65 66 69 6e 2) 1)).;; (defin
d7d0: 65 20 28 73 64 61 74 2d 70 61 72 61 6d 73 20 20 e (sdat-params
d7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
d7f0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
d800: 20 20 76 65 63 20 33 29 29 0a 3b 3b 20 28 64 65 vec 3)).;; (de
d810: 66 69 6e 65 20 28 73 64 61 74 2d 70 61 74 68 2d fine (sdat-path-
d820: 70 61 72 61 6d 73 20 20 20 20 20 20 20 20 20 20 params
d830: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
d840: 72 65 66 20 20 76 65 63 20 34 29 29 0a 3b 3b 20 ref vec 4)).;;
d850: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
d860: 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 ssion-key
d870: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
d880: 6f 72 2d 72 65 66 20 20 76 65 63 20 35 29 29 0a or-ref vec 5)).
d890: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
d8a0: 2d 73 65 73 73 69 6f 6e 2d 69 64 20 20 20 20 20 -session-id
d8b0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
d8c0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 36 ector-ref vec 6
d8d0: 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 )).;; (define (s
d8e0: 64 61 74 2d 64 6f 6d 61 69 6e 20 20 20 20 20 20 dat-domain
d8f0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
d900: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
d910: 63 20 37 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 c 7)).;; (define
d920: 20 28 73 64 61 74 2d 74 6f 70 70 61 67 65 20 20 (sdat-toppage
d930: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
d940: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
d950: 20 76 65 63 20 38 29 29 0a 3b 3b 20 28 64 65 66 vec 8)).;; (def
d960: 69 6e 65 20 28 73 64 61 74 2d 70 61 67 65 20 20 ine (sdat-page
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
d980: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
d990: 65 66 20 20 76 65 63 20 39 29 29 0a 3b 3b 20 28 ef vec 9)).;; (
d9a0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 63 75 72 define (sdat-cur
d9b0: 72 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 r-page
d9c0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
d9d0: 72 2d 72 65 66 20 20 76 65 63 20 31 30 29 29 0a r-ref vec 10)).
d9e0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
d9f0: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 20 20 -content-type
da00: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
da10: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
da20: 31 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 1)).;; (define (
da30: 73 64 61 74 2d 70 61 67 65 2d 74 79 70 65 20 20 sdat-page-type
da40: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
da50: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
da60: 65 63 20 31 32 29 29 0a 3b 3b 20 28 64 65 66 69 ec 12)).;; (defi
da70: 6e 65 20 28 73 64 61 74 2d 73 72 6f 6f 74 20 20 ne (sdat-sroot
da80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
da90: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
daa0: 66 20 20 76 65 63 20 31 33 29 29 0a 3b 3b 20 28 f vec 13)).;; (
dab0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 74 77 69 define (sdat-twi
dac0: 6b 69 64 69 72 20 20 20 20 20 20 20 20 20 20 20 kidir
dad0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
dae0: 72 2d 72 65 66 20 20 76 65 63 20 31 34 29 29 0a r-ref vec 14)).
daf0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
db00: 2d 70 61 67 65 64 61 74 20 20 20 20 20 20 20 20 -pagedat
db10: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
db20: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
db30: 35 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 5)).;; (define (
db40: 73 64 61 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 sdat-alt-page-da
db50: 74 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 t vec)
db60: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
db70: 65 63 20 31 36 29 29 0a 3b 3b 20 28 64 65 66 69 ec 16)).;; (defi
db80: 6e 65 20 28 73 64 61 74 2d 70 61 67 65 76 61 72 ne (sdat-pagevar
db90: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 s ve
dba0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
dbb0: 66 20 20 76 65 63 20 31 37 29 29 0a 3b 3b 20 28 f vec 17)).;; (
dbc0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 70 61 67 define (sdat-pag
dbd0: 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 evars-before
dbe0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
dbf0: 72 2d 72 65 66 20 20 76 65 63 20 31 38 29 29 0a r-ref vec 18)).
dc00: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
dc10: 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 -sessionvars
dc20: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
dc30: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
dc40: 39 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 9)).;; (define (
dc50: 73 64 61 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 sdat-sessionvars
dc60: 2d 62 65 66 6f 72 65 20 20 20 76 65 63 29 20 20 -before vec)
dc70: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
dc80: 65 63 20 32 30 29 29 0a 3b 3b 20 28 64 65 66 69 ec 20)).;; (defi
dc90: 6e 65 20 28 73 64 61 74 2d 67 6c 6f 62 61 6c 76 ne (sdat-globalv
dca0: 61 72 73 20 20 20 20 20 20 20 20 20 20 20 76 65 ars ve
dcb0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
dcc0: 66 20 20 76 65 63 20 32 31 29 29 0a 3b 3b 20 28 f vec 21)).;; (
dcd0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 6c 6f define (sdat-glo
dce0: 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 balvars-before
dcf0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
dd00: 72 2d 72 65 66 20 20 76 65 63 20 32 32 29 29 0a r-ref vec 22)).
dd10: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
dd20: 2d 6c 6f 67 70 74 20 20 20 20 20 20 20 20 20 20 -logpt
dd30: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
dd40: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
dd50: 33 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 3)).;; (define (
dd60: 73 64 61 74 2d 66 6f 72 6d 64 61 74 20 20 20 20 sdat-formdat
dd70: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
dd80: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
dd90: 65 63 20 32 34 29 29 0a 3b 3b 20 28 64 65 66 69 ec 24)).;; (defi
dda0: 6e 65 20 28 73 64 61 74 2d 72 65 71 75 65 73 74 ne (sdat-request
ddb0: 2d 6d 65 74 68 6f 64 20 20 20 20 20 20 20 76 65 -method ve
ddc0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
ddd0: 66 20 20 76 65 63 20 32 35 29 29 0a 3b 3b 20 28 f vec 25)).;; (
dde0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 73 define (sdat-ses
ddf0: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 20 20 20 20 20 sion-cookie
de00: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
de10: 72 2d 72 65 66 20 20 76 65 63 20 32 36 29 29 0a r-ref vec 26)).
de20: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
de30: 2d 63 75 72 72 2d 65 72 72 20 20 20 20 20 20 20 -curr-err
de40: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
de50: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
de60: 37 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 7)).;; (define (
de70: 73 64 61 74 2d 6c 6f 67 2d 70 6f 72 74 20 20 20 sdat-log-port
de80: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
de90: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
dea0: 65 63 20 32 38 29 29 0a 3b 3b 20 28 64 65 66 69 ec 28)).;; (defi
deb0: 6e 65 20 28 73 64 61 74 2d 6c 6f 67 66 69 6c 65 ne (sdat-logfile
dec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
ded0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
dee0: 66 20 20 76 65 63 20 32 39 29 29 0a 3b 3b 20 28 f vec 29)).;; (
def0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 65 define (sdat-see
df00: 6e 2d 70 61 67 65 73 20 20 20 20 20 20 20 20 20 n-pages
df10: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
df20: 72 2d 72 65 66 20 20 76 65 63 20 33 30 29 29 0a r-ref vec 30)).
df30: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
df40: 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 -page-dir-style
df50: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
df60: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 ector-ref vec 3
df70: 31 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 1)).;; (define (
df80: 73 64 61 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 sdat-debugmode
df90: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
dfa0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
dfb0: 65 63 20 33 32 29 29 0a 3b 3b 20 28 64 65 66 69 ec 32)).;; (defi
dfc0: 6e 65 20 28 73 64 61 74 2d 73 68 61 72 65 64 2d ne (sdat-shared-
dfd0: 68 61 73 68 20 20 20 20 20 20 20 20 20 20 76 65 hash ve
dfe0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
dff0: 66 20 20 76 65 63 20 33 33 29 29 0a 3b 3b 20 28 f vec 33)).;; (
e000: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 63 72 define (sdat-scr
e010: 69 70 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ipt
e020: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
e030: 72 2d 72 65 66 20 20 76 65 63 20 33 34 29 29 0a r-ref vec 34)).
e040: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
e050: 2d 66 6f 72 63 65 2d 73 73 6c 20 20 20 20 20 20 -force-ssl
e060: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
e070: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 ector-ref vec 3
e080: 35 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 5)).;; .;; (defi
e090: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
e0a0: 73 68 61 72 65 64 20 76 65 63 20 76 61 72 6e 61 shared vec varna
e0b0: 6d 65 29 0a 3b 3b 20 20 20 28 68 61 73 68 2d 74 me).;; (hash-t
e0c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
e0d0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 (vector-ref vec
e0e0: 20 33 33 29 20 76 61 72 6e 61 6d 65 20 23 66 29 33) varname #f)
e0f0: 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 ).;; .;; (define
e100: 20 28 73 64 61 74 2d 64 62 74 79 70 65 2d 73 65 (sdat-dbtype-se
e110: 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t!
e120: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
e130: 73 65 74 21 20 76 65 63 20 30 20 76 61 6c 29 29 set! vec 0 val))
e140: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 .;; (define (sda
e150: 74 2d 64 62 69 6e 69 74 2d 73 65 74 21 20 20 20 t-dbinit-set!
e160: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
e170: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
e180: 76 65 63 20 31 20 76 61 6c 29 29 0a 3b 3b 20 28 vec 1 val)).;; (
e190: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 63 6f 6e define (sdat-con
e1a0: 6e 2d 73 65 74 21 20 20 20 20 20 20 20 20 20 20 n-set!
e1b0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
e1c0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
e1d0: 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e val)).;; (defin
e1e0: 65 20 28 73 64 61 74 2d 70 61 72 61 6d 73 2d 73 e (sdat-params-s
e1f0: 65 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 et!
e200: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
e210: 2d 73 65 74 21 20 76 65 63 20 33 20 76 61 6c 29 -set! vec 3 val)
e220: 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 ).;; (define (sd
e230: 61 74 2d 70 61 74 68 2d 73 65 74 2d 70 61 72 61 at-path-set-para
e240: 6d 73 21 20 20 20 20 20 20 20 20 20 76 65 63 20 ms! vec
e250: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
e260: 20 76 65 63 20 34 20 76 61 6c 29 29 0a 3b 3b 20 vec 4 val)).;;
e270: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
e280: 73 73 69 6f 6e 2d 73 65 74 2d 6b 65 79 21 20 20 ssion-set-key!
e290: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
e2a0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
e2b0: 35 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 5 val)).;; (defi
e2c0: 6e 65 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e ne (sdat-session
e2d0: 2d 73 65 74 2d 69 64 21 20 20 20 20 20 20 20 20 -set-id!
e2e0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e2f0: 72 2d 73 65 74 21 20 76 65 63 20 36 20 76 61 6c r-set! vec 6 val
e300: 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 )).;; (define (s
e310: 64 61 74 2d 64 6f 6d 61 69 6e 2d 73 65 74 21 20 dat-domain-set!
e320: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
e330: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
e340: 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a 3b 3b ! vec 7 val)).;;
e350: 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 74 (define (sdat-t
e360: 6f 70 70 61 67 65 2d 73 65 74 21 20 20 20 20 20 oppage-set!
e370: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
e380: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
e390: 20 38 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 8 val)).;; (def
e3a0: 69 6e 65 20 28 73 64 61 74 2d 70 61 67 65 2d 73 ine (sdat-page-s
e3b0: 65 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 et!
e3c0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
e3d0: 6f 72 2d 73 65 74 21 20 76 65 63 20 39 20 76 61 or-set! vec 9 va
e3e0: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
e3f0: 73 64 61 74 2d 63 75 72 72 2d 73 65 74 2d 70 61 sdat-curr-set-pa
e400: 67 65 21 20 20 20 20 20 20 20 20 20 20 20 76 65 ge! ve
e410: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
e420: 74 21 20 76 65 63 20 31 30 20 76 61 6c 29 29 0a t! vec 10 val)).
e430: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
e440: 2d 63 6f 6e 74 65 6e 74 2d 73 65 74 2d 74 79 70 -content-set-typ
e450: 65 21 20 20 20 20 20 20 20 20 76 65 63 20 76 61 e! vec va
e460: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
e470: 65 63 20 31 31 20 76 61 6c 29 29 0a 3b 3b 20 28 ec 11 val)).;; (
e480: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 70 61 67 define (sdat-pag
e490: 65 2d 73 65 74 2d 74 79 70 65 21 20 20 20 20 20 e-set-type!
e4a0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
e4b0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
e4c0: 32 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 2 val)).;; (defi
e4d0: 6e 65 20 28 73 64 61 74 2d 73 72 6f 6f 74 2d 73 ne (sdat-sroot-s
e4e0: 65 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 et!
e4f0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e500: 72 2d 73 65 74 21 20 76 65 63 20 31 33 20 76 61 r-set! vec 13 va
e510: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
e520: 73 64 61 74 2d 74 77 69 6b 69 64 69 72 2d 73 65 sdat-twikidir-se
e530: 74 21 20 20 20 20 20 20 20 20 20 20 20 20 76 65 t! ve
e540: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
e550: 74 21 20 76 65 63 20 31 34 20 76 61 6c 29 29 0a t! vec 14 val)).
e560: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
e570: 2d 70 61 67 65 64 61 74 2d 73 65 74 21 20 20 20 -pagedat-set!
e580: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
e590: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
e5a0: 65 63 20 31 35 20 76 61 6c 29 29 0a 3b 3b 20 28 ec 15 val)).;; (
e5b0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 61 6c 74 define (sdat-alt
e5c0: 2d 73 65 74 2d 70 61 67 65 2d 64 61 74 21 20 20 -set-page-dat!
e5d0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
e5e0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
e5f0: 36 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6 val)).;; (defi
e600: 6e 65 20 28 73 64 61 74 2d 70 61 67 65 76 61 72 ne (sdat-pagevar
e610: 73 2d 73 65 74 21 20 20 20 20 20 20 20 20 20 20 s-set!
e620: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e630: 72 2d 73 65 74 21 20 76 65 63 20 31 37 20 76 61 r-set! vec 17 va
e640: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
e650: 73 64 61 74 2d 70 61 67 65 76 61 72 73 2d 73 65 sdat-pagevars-se
e660: 74 2d 62 65 66 6f 72 65 21 20 20 20 20 20 76 65 t-before! ve
e670: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
e680: 74 21 20 76 65 63 20 31 38 20 76 61 6c 29 29 0a t! vec 18 val)).
e690: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
e6a0: 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 73 65 74 -sessionvars-set
e6b0: 21 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 ! vec va
e6c0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
e6d0: 65 63 20 31 39 20 76 61 6c 29 29 0a 3b 3b 20 28 ec 19 val)).;; (
e6e0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 73 define (sdat-ses
e6f0: 73 69 6f 6e 76 61 72 73 2d 73 65 74 2d 62 65 66 sionvars-set-bef
e700: 6f 72 65 21 20 20 76 65 63 20 76 61 6c 29 28 76 ore! vec val)(v
e710: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
e720: 30 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 0 val)).;; (defi
e730: 6e 65 20 28 73 64 61 74 2d 67 6c 6f 62 61 6c 76 ne (sdat-globalv
e740: 61 72 73 2d 73 65 74 21 20 20 20 20 20 20 20 20 ars-set!
e750: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e760: 72 2d 73 65 74 21 20 76 65 63 20 32 31 20 76 61 r-set! vec 21 va
e770: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
e780: 73 64 61 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d sdat-globalvars-
e790: 73 65 74 2d 62 65 66 6f 72 65 21 20 20 20 76 65 set-before! ve
e7a0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
e7b0: 74 21 20 76 65 63 20 32 32 20 76 61 6c 29 29 0a t! vec 22 val)).
e7c0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
e7d0: 2d 6c 6f 67 70 74 2d 73 65 74 21 20 20 20 20 20 -logpt-set!
e7e0: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
e7f0: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
e800: 65 63 20 32 33 20 76 61 6c 29 29 0a 3b 3b 20 28 ec 23 val)).;; (
e810: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 66 6f 72 define (sdat-for
e820: 6d 64 61 74 2d 73 65 74 21 20 20 20 20 20 20 20 mdat-set!
e830: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
e840: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
e850: 34 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 4 val)).;; (defi
e860: 6e 65 20 28 73 64 61 74 2d 72 65 71 75 65 73 74 ne (sdat-request
e870: 2d 73 65 74 2d 6d 65 74 68 6f 64 21 20 20 20 20 -set-method!
e880: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e890: 72 2d 73 65 74 21 20 76 65 63 20 32 35 20 76 61 r-set! vec 25 va
e8a0: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
e8b0: 73 64 61 74 2d 73 65 73 73 69 6f 6e 2d 73 65 74 sdat-session-set
e8c0: 2d 63 6f 6f 6b 69 65 21 20 20 20 20 20 20 76 65 -cookie! ve
e8d0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
e8e0: 74 21 20 76 65 63 20 32 36 20 76 61 6c 29 29 0a t! vec 26 val)).
e8f0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
e900: 2d 63 75 72 72 2d 73 65 74 2d 65 72 72 21 20 20 -curr-set-err!
e910: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
e920: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
e930: 65 63 20 32 37 20 76 61 6c 29 29 0a 3b 3b 20 28 ec 27 val)).;; (
e940: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 6c 6f 67 define (sdat-log
e950: 2d 73 65 74 2d 70 6f 72 74 21 20 20 20 20 20 20 -set-port!
e960: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
e970: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
e980: 38 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 8 val)).;; (defi
e990: 6e 65 20 28 73 64 61 74 2d 6c 6f 67 66 69 6c 65 ne (sdat-logfile
e9a0: 2d 73 65 74 21 20 20 20 20 20 20 20 20 20 20 20 -set!
e9b0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e9c0: 72 2d 73 65 74 21 20 76 65 63 20 32 39 20 76 61 r-set! vec 29 va
e9d0: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
e9e0: 73 64 61 74 2d 73 65 65 6e 2d 73 65 74 2d 70 61 sdat-seen-set-pa
e9f0: 67 65 73 21 20 20 20 20 20 20 20 20 20 20 76 65 ges! ve
ea00: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
ea10: 74 21 20 76 65 63 20 33 30 20 76 61 6c 29 29 0a t! vec 30 val)).
ea20: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
ea30: 2d 70 61 67 65 2d 73 65 74 2d 64 69 72 2d 73 74 -page-set-dir-st
ea40: 79 6c 65 21 20 20 20 20 20 20 76 65 63 20 76 61 yle! vec va
ea50: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
ea60: 65 63 20 33 31 20 76 61 6c 29 29 0a 3b 3b 20 28 ec 31 val)).;; (
ea70: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 64 65 62 define (sdat-deb
ea80: 75 67 6d 6f 64 65 2d 73 65 74 21 20 20 20 20 20 ugmode-set!
ea90: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
eaa0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 ector-set! vec 3
eab0: 32 20 76 61 6c 29 29 0a 3b 3b 20 28 64 65 66 69 2 val)).;; (defi
eac0: 6e 65 20 28 73 64 61 74 2d 73 68 61 72 65 64 2d ne (sdat-shared-
ead0: 73 65 74 2d 68 61 73 68 21 20 20 20 20 20 20 20 set-hash!
eae0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
eaf0: 72 2d 73 65 74 21 20 76 65 63 20 33 33 20 76 61 r-set! vec 33 va
eb00: 6c 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 l)).;; (define (
eb10: 73 64 61 74 2d 73 63 72 69 70 74 2d 73 65 74 21 sdat-script-set!
eb20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
eb30: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
eb40: 74 21 20 76 65 63 20 33 34 20 76 61 6c 29 29 0a t! vec 34 val)).
eb50: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 64 61 74 ;; (define (sdat
eb60: 2d 66 6f 72 63 65 2d 73 65 74 2d 73 73 6c 21 20 -force-set-ssl!
eb70: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
eb80: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
eb90: 65 63 20 33 35 20 76 61 6c 29 29 0a 3b 3b 20 0a ec 35 val)).;; .
eba0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;; (define (sess
ebb0: 69 6f 6e 3a 73 65 74 2d 73 68 61 72 65 64 21 20 ion:set-shared!
ebc0: 76 65 63 20 76 61 72 6e 61 6d 65 20 76 61 6c 29 vec varname val)
ebd0: 0a 3b 3b 20 20 20 28 68 61 73 68 2d 74 61 62 6c .;; (hash-tabl
ebe0: 65 2d 73 65 74 21 20 28 76 65 63 74 6f 72 2d 72 e-set! (vector-r
ebf0: 65 66 20 76 65 63 20 33 33 29 20 76 61 72 6e 61 ef vec 33) varna
ec00: 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b 20 54 68 65 me val))..;; The
ec10: 20 67 6c 6f 62 61 6c 20 73 65 73 73 69 6f 6e 0a global session.
ec20: 28 64 65 66 69 6e 65 20 73 3a 73 65 73 73 69 6f (define s:sessio
ec30: 6e 20 28 6d 61 6b 65 2d 73 64 61 74 29 29 0a 0a n (make-sdat))..
ec40: 3b 3b 20 53 50 4c 49 54 20 49 4e 54 4f 20 53 54 ;; SPLIT INTO ST
ec50: 52 41 49 47 48 54 20 46 4f 52 57 41 52 44 20 49 RAIGHT FORWARD I
ec60: 4e 49 54 20 41 4e 44 20 43 4f 4d 50 4c 45 58 20 NIT AND COMPLEX
ec70: 49 4e 49 54 0a 23 3b 28 64 65 66 69 6e 65 20 28 INIT.#;(define (
ec80: 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 session:initiali
ec90: 7a 65 20 73 65 6c 66 20 23 21 6f 70 74 69 6f 6e ze self #!option
eca0: 61 6c 20 28 63 6f 6e 66 69 67 66 20 23 66 29 29 al (configf #f))
ecb0: 0a 20 20 28 73 64 61 74 2d 64 62 74 79 70 65 2d . (sdat-dbtype-
ecc0: 73 65 74 21 20 73 65 6c 66 20 20 20 20 20 20 27 set! self '
ecd0: 70 67 29 0a 20 20 28 73 64 61 74 2d 70 61 67 65 pg). (sdat-page
ece0: 2d 73 65 74 21 20 73 65 6c 66 20 20 20 20 20 20 -set! self
ecf0: 20 20 22 68 6f 6d 65 22 29 20 20 20 20 20 20 20 "home")
ed00: 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 64 65 ;; these are de
ed10: 66 61 75 6c 74 73 0a 20 20 28 73 64 61 74 2d 63 faults. (sdat-c
ed20: 75 72 72 2d 73 65 74 2d 70 61 67 65 21 20 73 65 urr-set-page! se
ed30: 6c 66 20 20 20 22 68 6f 6d 65 22 29 0a 20 20 28 lf "home"). (
ed40: 73 64 61 74 2d 63 6f 6e 74 65 6e 74 2d 73 65 74 sdat-content-set
ed50: 2d 74 79 70 65 21 20 73 65 6c 66 20 22 43 6f 6e -type! self "Con
ed60: 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f tent-type: text/
ed70: 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 html; charset=is
ed80: 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 0a 20 o-8859-1\n\n").
ed90: 20 28 73 64 61 74 2d 70 61 67 65 2d 73 65 74 2d (sdat-page-set-
eda0: 74 79 70 65 21 20 73 65 6c 66 20 20 20 27 68 74 type! self 'ht
edb0: 6d 6c 29 0a 20 20 28 73 64 61 74 2d 74 6f 70 70 ml). (sdat-topp
edc0: 61 67 65 2d 73 65 74 21 20 73 65 6c 66 20 20 20 age-set! self
edd0: 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 73 64 "index"). (sd
ede0: 61 74 2d 70 61 72 61 6d 73 2d 73 65 74 21 20 73 at-params-set! s
edf0: 65 6c 66 20 20 20 20 20 20 27 28 29 29 20 20 20 elf '())
ee00: 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 73 64 ;;. (sd
ee10: 61 74 2d 70 61 74 68 2d 73 65 74 2d 70 61 72 61 at-path-set-para
ee20: 6d 73 21 20 73 65 6c 66 20 27 28 29 29 0a 20 20 ms! self '()).
ee30: 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 2d 73 65 (sdat-session-se
ee40: 74 2d 6b 65 79 21 20 73 65 6c 66 20 23 66 29 0a t-key! self #f).
ee50: 20 20 28 73 64 61 74 2d 70 61 67 65 64 61 74 2d (sdat-pagedat-
ee60: 73 65 74 21 20 73 65 6c 66 20 20 20 20 20 27 28 set! self '(
ee70: 29 29 0a 20 20 28 73 64 61 74 2d 61 6c 74 2d 73 )). (sdat-alt-s
ee80: 65 74 2d 70 61 67 65 2d 64 61 74 21 20 73 65 6c et-page-dat! sel
ee90: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 72 f #f). (sdat-sr
eea0: 6f 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 20 20 oot-set! self
eeb0: 20 20 20 20 22 2e 2f 22 29 0a 20 20 28 73 64 61 "./"). (sda
eec0: 74 2d 73 65 73 73 69 6f 6e 2d 73 65 74 2d 63 6f t-session-set-co
eed0: 6f 6b 69 65 21 20 73 65 6c 66 20 23 66 29 0a 20 okie! self #f).
eee0: 20 28 73 64 61 74 2d 63 75 72 72 2d 73 65 74 2d (sdat-curr-set-
eef0: 65 72 72 21 20 73 65 6c 66 20 23 66 29 0a 20 20 err! self #f).
ef00: 28 73 64 61 74 2d 6c 6f 67 2d 73 65 74 2d 70 6f (sdat-log-set-po
ef10: 72 74 21 20 73 65 6c 66 20 28 63 75 72 72 65 6e rt! self (curren
ef20: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
ef30: 20 28 73 64 61 74 2d 73 65 65 6e 2d 73 65 74 2d (sdat-seen-set-
ef40: 70 61 67 65 73 21 20 73 65 6c 66 20 27 28 29 29 pages! self '())
ef50: 0a 20 20 28 73 64 61 74 2d 70 61 67 65 2d 73 65 . (sdat-page-se
ef60: 74 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 65 6c t-dir-style! sel
ef70: 66 20 23 74 29 20 3b 3b 20 23 74 20 3a 20 70 61 f #t) ;; #t : pa
ef80: 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 5f 28 ges/<pagename>_(
ef90: 76 69 65 77 7c 63 6e 74 6c 29 2e 73 63 6d 0a 20 view|cntl).scm.
efa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
efb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
efc0: 20 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 61 67 ;; #f : pag
efd0: 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 28 76 es/<pagename>/(v
efe0: 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 63 6d iew|control).scm
eff0: 20 0a 20 20 28 73 64 61 74 2d 64 65 62 75 67 6d . (sdat-debugm
f000: 6f 64 65 2d 73 65 74 21 20 20 20 20 20 20 20 20 ode-set!
f010: 20 20 73 65 6c 66 20 23 66 29 0a 20 20 09 09 09 self #f). ...
f020: 20 20 20 20 20 0a 20 20 28 73 64 61 74 2d 70 61 . (sdat-pa
f030: 67 65 76 61 72 73 2d 73 65 74 21 20 20 20 20 20 gevars-set!
f040: 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 self (make
f050: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
f060: 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 76 61 72 (sdat-sessionvar
f070: 73 2d 73 65 74 21 20 20 20 20 20 20 20 20 73 65 s-set! se
f080: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
f090: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 67 6c ble)). (sdat-gl
f0a0: 6f 62 61 6c 76 61 72 73 2d 73 65 74 21 20 20 20 obalvars-set!
f0b0: 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 self (make
f0c0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
f0d0: 28 73 64 61 74 2d 70 61 67 65 76 61 72 73 2d 73 (sdat-pagevars-s
f0e0: 65 74 2d 62 65 66 6f 72 65 21 20 20 20 20 73 65 et-before! se
f0f0: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
f100: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ble)). (sdat-se
f110: 73 73 69 6f 6e 76 61 72 73 2d 73 65 74 2d 62 65 ssionvars-set-be
f120: 66 6f 72 65 21 20 73 65 6c 66 20 28 6d 61 6b 65 fore! self (make
f130: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
f140: 28 73 64 61 74 2d 67 6c 6f 62 61 6c 76 61 72 73 (sdat-globalvars
f150: 2d 73 65 74 2d 62 65 66 6f 72 65 21 20 20 73 65 -set-before! se
f160: 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 lf (make-hash-ta
f170: 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 64 6f ble)). (sdat-do
f180: 6d 61 69 6e 2d 73 65 74 21 20 20 20 20 20 20 20 main-set!
f190: 20 20 20 20 20 20 73 65 6c 66 20 22 6c 6f 63 61 self "loca
f1a0: 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e 64 20 host") ;; end
f1b0: 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 28 73 of defaults. (s
f1c0: 64 61 74 2d 73 63 72 69 70 74 2d 73 65 74 21 20 dat-script-set!
f1d0: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 self
f1e0: 20 23 66 29 0a 20 20 28 73 64 61 74 2d 66 6f 72 #f). (sdat-for
f1f0: 63 65 2d 73 65 74 2d 73 73 6c 21 20 20 20 20 20 ce-set-ssl!
f200: 20 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 self #f).
f210: 28 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e 66 69 (let* ((rawconfi
f220: 67 64 61 74 20 28 73 65 73 73 69 6f 6e 3a 72 65 gdat (session:re
f230: 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 20 63 ad-config self c
f240: 6f 6e 66 69 67 66 29 29 0a 09 20 28 63 6f 6e 66 onfigf)).. (conf
f250: 69 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e igdat (if rawcon
f260: 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 figdat (eval raw
f270: 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 configdat) '()))
f280: 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 .. (sroot (s
f290: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f :find-param 'sro
f2a0: 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 ot configdat)
f2b0: 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 ).. (logfile (
f2c0: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f s:find-param 'lo
f2d0: 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 gfile configdat
f2e0: 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 )).. (dbtype
f2f0: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
f300: 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 btype configda
f310: 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 t)).. (dbinit
f320: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
f330: 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 dbinit configd
f340: 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 at)).. (domain
f350: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
f360: 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 'domain config
f370: 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 dat)).. (twikidi
f380: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
f390: 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 'twikidir confi
f3a0: 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 gdat)).. (page-d
f3b0: 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 ir (s:find-para
f3c0: 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c m 'page-dir-styl
f3d0: 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 e configdat))..
f3e0: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 (debugmode (s:fi
f3f0: 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d nd-param 'debugm
f400: 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a ode configdat)).
f410: 20 20 20 20 20 20 20 20 20 28 73 63 72 69 70 74 (script
f420: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
f430: 6d 20 27 73 63 72 69 70 74 20 20 20 20 63 6f 6e m 'script con
f440: 66 69 67 64 61 74 29 29 0a 09 20 28 66 6f 72 63 figdat)).. (forc
f450: 65 2d 73 73 6c 20 28 73 3a 66 69 6e 64 2d 70 61 e-ssl (s:find-pa
f460: 72 61 6d 20 27 66 6f 72 63 65 2d 73 73 6c 20 63 ram 'force-ssl c
f470: 6f 6e 66 69 67 64 61 74 29 29 29 0a 20 20 20 20 onfigdat))).
f480: 28 69 66 20 73 72 6f 6f 74 20 20 20 20 28 73 64 (if sroot (sd
f490: 61 74 2d 73 72 6f 6f 74 2d 73 65 74 21 20 20 20 at-sroot-set!
f4a0: 20 73 65 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 self sroot)).
f4b0: 20 20 28 69 66 20 6c 6f 67 66 69 6c 65 20 20 28 (if logfile (
f4c0: 73 64 61 74 2d 6c 6f 67 66 69 6c 65 2d 73 65 74 sdat-logfile-set
f4d0: 21 20 20 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 ! self logfile)
f4e0: 29 0a 20 20 20 20 28 69 66 20 64 62 74 79 70 65 ). (if dbtype
f4f0: 20 20 20 28 73 64 61 74 2d 64 62 74 79 70 65 2d (sdat-dbtype-
f500: 73 65 74 21 20 20 20 73 65 6c 66 20 64 62 74 79 set! self dbty
f510: 70 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 69 pe)). (if dbi
f520: 6e 69 74 20 20 20 28 73 64 61 74 2d 64 62 69 6e nit (sdat-dbin
f530: 69 74 2d 73 65 74 21 20 20 20 73 65 6c 66 20 64 it-set! self d
f540: 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 66 20 binit)). (if
f550: 64 6f 6d 61 69 6e 20 20 20 28 73 64 61 74 2d 64 domain (sdat-d
f560: 6f 6d 61 69 6e 2d 73 65 74 21 20 20 20 73 65 6c omain-set! sel
f570: 66 20 64 6f 6d 61 69 6e 29 29 0a 20 20 20 20 28 f domain)). (
f580: 69 66 20 74 77 69 6b 69 64 69 72 20 28 73 64 61 if twikidir (sda
f590: 74 2d 74 77 69 6b 69 64 69 72 2d 73 65 74 21 20 t-twikidir-set!
f5a0: 73 65 6c 66 20 74 77 69 6b 69 64 69 72 29 29 0a self twikidir)).
f5b0: 20 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 (if debugmod
f5c0: 65 20 28 73 64 61 74 2d 64 65 62 75 67 6d 6f 64 e (sdat-debugmod
f5d0: 65 2d 73 65 74 21 20 73 65 6c 66 20 64 65 62 75 e-set! self debu
f5e0: 67 6d 6f 64 65 29 29 0a 20 20 20 20 28 69 66 20 gmode)). (if
f5f0: 73 63 72 69 70 74 20 20 20 20 28 73 64 61 74 2d script (sdat-
f600: 73 63 72 69 70 74 2d 73 65 74 21 20 20 20 20 73 script-set! s
f610: 65 6c 66 20 73 63 72 69 70 74 29 29 0a 20 20 20 elf script)).
f620: 20 28 69 66 20 66 6f 72 63 65 2d 73 73 6c 20 28 (if force-ssl (
f630: 73 64 61 74 2d 66 6f 72 63 65 2d 73 65 74 2d 73 sdat-force-set-s
f640: 73 6c 21 20 73 65 6c 66 20 66 6f 72 63 65 2d 73 sl! self force-s
f650: 73 6c 29 29 0a 20 20 20 20 28 73 64 61 74 2d 70 sl)). (sdat-p
f660: 61 67 65 2d 73 65 74 2d 64 69 72 2d 73 74 79 6c age-set-dir-styl
f670: 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 e! self page-dir
f680: 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
f690: 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 "configdat: ")(p
f6a0: 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 p configdat).
f6b0: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 0a 09 (if debugmode..
f6c0: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
f6d0: 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f f "sroot: " sroo
f6e0: 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c t " logfile: " l
f6f0: 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 3a ogfile " dbtype:
f700: 20 22 20 64 62 74 79 70 65 20 0a 09 09 20 20 20 " dbtype ...
f710: 20 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 " dbinit: " db
f720: 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 init " domain: "
f730: 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 domain " page-d
f740: 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 ir-style: " page
f750: 2d 64 69 72 29 29 0a 20 20 20 20 29 0a 20 20 28 -dir)). ). (
f760: 73 64 61 74 2d 73 68 61 72 65 64 2d 73 65 74 2d sdat-shared-set-
f770: 68 61 73 68 21 20 73 65 6c 66 20 28 6d 61 6b 65 hash! self (make
f780: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
f790: 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 20 74 )..;; Used for t
f7a0: 68 65 20 73 74 72 61 6e 67 65 6c 79 20 69 6e 63 he strangely inc
f7b0: 6f 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 6c 69 onsistent handli
f7c0: 6e 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 69 67 ng of the config
f7d0: 20 66 69 6c 65 2e 20 41 20 62 65 74 74 65 72 20 file. A better
f7e0: 77 61 79 20 69 73 20 6e 65 65 64 65 64 2e 0a 3b way is needed..;
f7f0: 3b 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 ;.;; (let ((db
f800: 74 79 70 65 20 28 73 64 61 74 2d 64 62 74 79 70 type (sdat-dbtyp
f810: 65 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 e self))).;;
f820: 20 28 70 72 69 6e 74 20 22 64 62 74 79 70 65 3a (print "dbtype:
f830: 20 22 20 64 62 74 79 70 65 29 0a 3b 3b 20 20 20 " dbtype).;;
f840: 20 20 28 73 64 61 74 2d 64 62 74 79 70 65 2d 73 (sdat-dbtype-s
f850: 65 74 21 20 73 65 6c 66 20 28 65 76 61 6c 20 64 et! self (eval d
f860: 62 74 79 70 65 29 29 29 29 0a 0a 28 64 65 66 69 btype))))..(defi
f870: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 ne (session:setu
f880: 70 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 p self). (let (
f890: 28 64 62 74 79 70 65 20 20 20 20 28 73 64 61 74 (dbtype (sdat
f8a0: 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 0a 09 -dbtype self))..
f8b0: 28 64 65 62 75 67 6d 6f 64 65 20 28 73 64 61 74 (debugmode (sdat
f8c0: 2d 64 65 62 75 67 2d 6d 6f 64 65 20 73 65 6c 66 -debug-mode self
f8d0: 29 29 0a 09 28 64 62 69 6e 69 74 20 20 20 20 28 ))..(dbinit (
f8e0: 65 76 61 6c 20 28 73 64 61 74 2d 64 62 69 6e 69 eval (sdat-dbini
f8f0: 74 20 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 t self)))..(dbex
f900: 69 73 74 73 20 20 23 66 29 29 0a 20 20 20 20 28 ists #f)). (
f910: 6c 65 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 let ((dbfname (a
f920: 6c 69 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 list-ref 'dbname
f930: 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 dbinit))).
f940: 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 (if debugmode (
f950: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
f960: 20 22 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 "session:setup
f970: 64 62 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 6d dbfname=" dbfnam
f980: 65 20 22 2c 20 64 62 74 79 70 65 3d 22 20 64 62 e ", dbtype=" db
f990: 74 79 70 65 20 22 2c 20 64 62 69 6e 69 74 3d 22 type ", dbinit="
f9a0: 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 20 20 dbinit)).
f9b0: 28 69 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 (if (eq? dbtype
f9c0: 27 73 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 20 'sqlite3).. ;;
f9d0: 54 68 65 20 27 61 75 74 6f 20 6d 65 74 68 6f 64 The 'auto method
f9e0: 20 77 69 6c 6c 20 64 69 73 74 72 69 62 75 74 65 will distribute
f9f0: 20 64 62 73 20 61 63 72 6f 73 73 20 74 68 65 20 dbs across the
fa00: 64 69 73 6b 20 75 73 69 6e 67 20 68 61 73 68 0a disk using hash.
fa10: 09 20 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 6f . ;; of user ho
fa20: 73 74 20 61 6e 64 20 75 73 65 72 2e 20 54 4f 44 st and user. TOD
fa30: 4f 0a 09 20 20 3b 3b 20 28 69 66 20 28 65 71 3f O.. ;; (if (eq?
fa40: 20 64 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 20 dbfname 'auto)
fa50: 3b 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 61 ;; This is the a
fa60: 75 74 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 6f uto assignment o
fa70: 66 20 61 20 64 62 20 62 61 73 65 64 20 6f 6e 20 f a db based on
fa80: 68 61 73 68 20 6f 66 20 49 50 0a 09 20 20 28 6c hash of IP.. (l
fa90: 65 74 20 28 28 64 62 70 61 74 68 20 28 70 61 74 et ((dbpath (pat
faa0: 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
fab0: 64 62 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 64 dbfname))) ;; d
fac0: 6f 20 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 74 o a couple sanit
fad0: 79 20 63 68 65 63 6b 73 20 68 65 72 65 20 74 6f y checks here to
fae0: 20 6d 61 6b 65 20 73 65 74 74 69 6e 67 20 75 70 make setting up
faf0: 20 65 61 73 69 65 72 0a 09 20 20 20 20 28 69 66 easier.. (if
fb00: 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 debugmode (sess
fb10: 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e ion:log self "IN
fb20: 46 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 FO: setting up f
fb30: 6f 72 20 73 71 6c 69 74 65 33 20 64 62 20 61 63 or sqlite3 db ac
fb40: 63 65 73 73 20 74 6f 20 22 20 64 62 66 6e 61 6d cess to " dbfnam
fb50: 65 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f e)).. (if (no
fb60: 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 t (file-write-ac
fb70: 63 65 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 cess? dbpath))..
fb80: 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 .(session:log se
fb90: 6c 66 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e lf "WARNING: Can
fba0: 6e 6f 74 20 77 72 69 74 65 20 74 6f 20 22 20 64 not write to " d
fbb0: 62 70 61 74 68 29 0a 09 09 28 69 66 20 64 65 62 bpath)...(if deb
fbc0: 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a ugmode (session:
fbd0: 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 log self "INFO:
fbe0: 22 20 64 62 70 61 74 68 20 22 20 69 73 20 77 72 " dbpath " is wr
fbf0: 69 74 65 61 62 6c 65 22 29 29 29 0a 09 20 20 20 iteable")))..
fc00: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
fc10: 73 3f 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 62 s? dbfname)...(b
fc20: 65 67 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 73 egin... ;; (ses
fc30: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 sion:log self "s
fc40: 65 74 74 69 6e 67 20 64 62 65 78 69 73 74 73 20 etting dbexists
fc50: 74 6f 20 23 74 22 29 0a 09 09 20 20 28 73 65 74 to #t")... (set
fc60: 21 20 64 62 65 78 69 73 74 73 20 23 74 29 29 29 ! dbexists #t)))
fc70: 29 0a 09 20 20 28 69 66 20 64 65 62 75 67 6d 6f ).. (if debugmo
fc80: 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 de (session:log
fc90: 73 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 self "INFO: sett
fca0: 69 6e 67 20 75 70 20 66 6f 72 20 70 67 20 64 62 ing up for pg db
fcb0: 20 61 63 63 65 73 73 20 74 6f 20 61 63 63 6f 75 access to accou
fcc0: 6e 74 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 74 nt info " dbinit
fcd0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 ))). (if de
fce0: 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e bugmode (session
fcf0: 3a 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 79 70 :log self "dbtyp
fd00: 65 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 62 e: " dbtype " db
fd10: 66 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 fname: " dbfname
fd20: 20 22 20 64 62 65 78 69 73 74 73 3a 20 22 20 64 " dbexists: " d
fd30: 62 65 78 69 73 74 73 29 29 29 0a 20 20 20 20 28 bexists))). (
fd40: 73 64 61 74 2d 63 6f 6e 6e 2d 73 65 74 21 20 73 sdat-conn-set! s
fd50: 65 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 elf (dbi:open db
fd60: 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 20 type dbinit)).
fd70: 20 20 28 73 65 74 21 20 2a 64 62 2a 20 28 73 64 (set! *db* (sd
fd80: 61 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 at-conn self)).
fd90: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
fda0: 20 64 62 65 78 69 73 74 73 29 28 65 71 3f 20 64 dbexists)(eq? d
fdb0: 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 29 29 btype 'sqlite3))
fdc0: 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 . .(begin.. (pr
fdd0: 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 53 65 int "WARNING: Se
fde0: 74 74 69 6e 67 20 75 70 20 73 65 73 73 69 6f 6e tting up session
fdf0: 20 64 62 20 77 69 74 68 20 73 71 6c 69 74 65 33 db with sqlite3
fe00: 22 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 ").. (session:s
fe10: 65 74 75 70 2d 64 62 20 73 65 6c 66 29 29 29 0a etup-db self))).
fe20: 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 72 6f (session:pro
fe30: 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 73 65 cess-url-path se
fe40: 6c 66 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e lf). (session
fe50: 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b :setup-session-k
fe60: 65 79 20 73 65 6c 66 29 0a 20 20 20 20 3b 3b 20 ey self). ;;
fe70: 63 61 70 74 75 72 65 20 73 74 64 69 6e 20 69 66 capture stdin if
fe80: 20 74 68 69 73 20 69 73 20 61 20 50 4f 53 54 0a this is a POST.
fe90: 20 20 20 20 28 73 64 61 74 2d 72 65 71 75 65 73 (sdat-reques
fea0: 74 2d 6d 65 74 68 6f 64 2d 73 65 74 21 20 73 65 t-method-set! se
feb0: 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d lf (get-environm
fec0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 52 45 ent-variable "RE
fed0: 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 29 0a QUEST_METHOD")).
fee0: 20 20 20 20 28 73 64 61 74 2d 66 6f 72 6d 64 61 (sdat-formda
fef0: 74 2d 73 65 74 21 20 73 65 6c 66 20 28 66 6f 72 t-set! self (for
ff00: 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 29 29 mdat:load-all)))
ff10: 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 65 20 )..;; setup the
ff20: 64 62 20 77 69 74 68 20 73 65 73 73 69 6f 6e 20 db with session
ff30: 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 66 6f tables, works fo
ff40: 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 72 69 r sqlite only ri
ff50: 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e 65 20 ght now.(define
ff60: 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 64 (session:setup-d
ff70: 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 b self). (let (
ff80: 28 63 6f 6e 6e 20 28 73 64 61 74 2d 63 6f 6e 6e (conn (sdat-conn
ff90: 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 66 6f self))). (fo
ffa0: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
ffb0: 6d 62 64 61 20 28 73 74 6d 74 29 0a 20 20 20 20 mbda (stmt).
ffc0: 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
ffd0: 6e 20 73 74 6d 74 29 29 0a 20 20 20 20 20 28 6c n stmt)). (l
ffe0: 69 73 74 20 22 43 52 45 41 54 45 20 54 41 42 4c ist "CREATE TABL
fff0: 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 E session_vars (
10000 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
10010 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 69 RY KEY,session_i
10020 64 20 49 4e 54 45 47 45 52 2c 70 61 67 65 20 54 d INTEGER,page T
10030 45 58 54 2c 6b 65 79 20 54 45 58 54 2c 76 61 6c EXT,key TEXT,val
10040 75 65 20 54 45 58 54 29 3b 22 0a 09 20 20 20 22 ue TEXT);".. "
10050 43 52 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 CREATE TABLE ses
10060 73 69 6f 6e 73 20 28 69 64 20 49 4e 54 45 47 45 sions (id INTEGE
10070 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 R PRIMARY KEY,se
10080 73 73 69 6f 6e 5f 6b 65 79 20 54 45 58 54 2c 6c ssion_key TEXT,l
10090 61 73 74 5f 75 73 65 64 20 54 49 4d 45 53 54 41 ast_used TIMESTA
100a0 4d 50 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 MP);".
100b0 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 6d "CREATE TABLE m
100c0 65 74 61 64 61 74 61 20 28 69 64 20 49 4e 54 45 etadata (id INTE
100d0 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
100e0 6b 65 79 20 54 45 58 54 2c 76 61 6c 75 65 20 54 key TEXT,value T
100f0 45 58 54 29 3b 22 29 29 29 29 0a 3b 3b 20 20 3b EXT);")))).;; ;
10100 3b 20 69 66 20 77 65 20 68 61 76 65 20 61 20 73 ; if we have a s
10110 65 73 73 69 6f 6e 5f 6b 65 79 20 6c 6f 6f 6b 20 ession_key look
10120 75 70 20 74 68 65 20 73 65 73 73 69 6f 6e 2d 69 up the session-i
10130 64 20 61 6e 64 20 73 74 6f 72 65 20 69 74 0a 3b d and store it.;
10140 3b 20 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e ; (sdat-session
10150 2d 73 65 74 2d 69 64 21 20 73 65 6c 66 20 28 73 -set-id! self (s
10160 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 ession:get-id se
10170 6c 66 29 29 29 0a 0a 3b 3b 20 6f 6e 6c 79 20 73 lf)))..;; only s
10180 65 74 20 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 et session-cooki
10190 65 20 77 68 65 6e 20 61 20 6e 65 77 20 73 65 73 e when a new ses
101a0 73 69 6f 6e 20 69 73 20 63 72 65 61 74 65 64 0a sion is created.
101b0 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
101c0 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e 2d 6b :setup-session-k
101d0 65 79 20 73 65 6c 66 29 20 20 0a 20 20 28 6c 65 ey self) . (le
101e0 74 2a 20 28 28 73 6b 20 20 28 73 65 73 73 69 6f t* ((sk (sessio
101f0 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f n:extract-sessio
10200 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 20 20 n-key self)).
10210 20 20 20 20 20 20 28 73 69 64 20 28 69 66 20 73 (sid (if s
10220 6b 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 k (session:get-i
10230 64 20 73 65 6c 66 20 73 6b 29 20 23 66 29 29 29 d self sk) #f)))
10240 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 69 . (if (not si
10250 64 29 20 3b 3b 20 6e 65 65 64 20 61 20 6e 65 77 d) ;; need a new
10260 20 6b 65 79 0a 20 20 20 20 20 20 20 20 28 6c 65 key. (le
10270 74 2a 20 28 28 6e 65 77 2d 6b 65 79 20 28 73 65 t* ((new-key (se
10280 73 73 69 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 ssion:get-new-ke
10290 79 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 y self)).
102a0 20 20 20 20 20 20 20 20 28 6e 65 77 2d 73 69 64 (new-sid
102b0 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 64 (session:get-id
102c0 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 29 29 self new-key)))
102d0 0a 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 . (sdat
102e0 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 2d 73 65 74 -session-key-set
102f0 21 20 73 65 6c 66 20 6e 65 77 2d 6b 65 79 29 0a ! self new-key).
10300 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
10310 73 65 73 73 69 6f 6e 2d 69 64 2d 73 65 74 21 20 session-id-set!
10320 73 65 6c 66 20 6e 65 77 2d 73 69 64 29 0a 20 20 self new-sid).
10330 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 (sdat-se
10340 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 2d 73 65 74 ssion-cookie-set
10350 21 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a ! self (session:
10360 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 make-cookie self
10370 29 29 29 0a 20 20 20 20 20 20 20 20 28 73 64 61 ))). (sda
10380 74 2d 73 65 73 73 69 6f 6e 2d 69 64 2d 73 65 74 t-session-id-set
10390 21 20 73 65 6c 66 20 73 69 64 29 29 29 29 0a 0a ! self sid))))..
103a0 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
103b0 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 65 20 73 65 6c :make-cookie sel
103c0 66 29 0a 20 20 3b 3b 20 28 6c 69 73 74 20 28 63 f). ;; (list (c
103d0 6f 6e 63 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 onc "session_key
103e0 3d 22 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e =" (sdat-session
103f0 2d 6b 65 79 20 73 65 6c 66 29 20 22 3b 20 50 61 -key self) "; Pa
10400 74 68 3d 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 20 th=/; Domain=."
10410 28 73 64 61 74 2d 64 6f 6d 61 69 6e 20 73 65 6c (sdat-domain sel
10420 66 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 f) "; Max-Age="
10430 28 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 (* 86400 14) ";
10440 56 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 Version=1"))) .
10450 20 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 6f ;; According to
10460 20 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a 2f . ;; http:/
10470 2f 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c 73 /www.codemarvels
10480 2e 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 61 .com/2010/11/apa
10490 63 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 2d che-rewriterule-
104a0 73 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e 2d set-a-cookie-on-
104b0 6c 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b 3b localhost/.. ;;
104c0 20 20 48 65 72 65 20 61 72 65 20 74 68 65 20 32 Here are the 2
104d0 20 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 74 (often left out
104e0 29 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 74 ) requirements t
104f0 6f 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 75 o set a cookie u
10500 73 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 64 sing. ;; httpd
10510 1b 2d 46 ef bf bd 73 20 72 65 77 72 69 74 65 20 .-F�s rewrite
10520 72 75 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 rule (mod_rewrit
10530 65 29 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e e), while workin
10540 67 20 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b g on localhost:.
10550 2d 41 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 -A. ;;. ;; Us
10560 65 20 74 68 65 20 49 50 20 31 32 37 2e 30 2e 30 e the IP 127.0.0
10570 2e 31 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f .1 instead of lo
10580 63 61 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d calhost/machine-
10590 6e 61 6d 65 20 61 73 20 74 68 65 0a 20 20 3b 3b name as the. ;;
105a0 20 20 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b domain; e.g. [
105b0 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f CO=someCookie:so
105c0 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e meValue:127.0.0.
105d0 31 3a 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 1:2:/], which sa
105e0 79 73 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 20 ys. ;; create
105f0 61 20 63 6f 6f 6b 69 65 20 1b 2d 59 ef bf bd 73 a cookie .-Y�s
10600 6f 6d 65 43 6f 6f 6b 69 65 ef bf bd 20 77 69 74 omeCookie� wit
10610 68 20 76 61 6c 75 65 20 ef bf bd 73 6f 6d 65 56 h value �someV
10620 61 6c 75 65 ef bf bd 20 66 6f 72 20 74 68 65 0a alue� for the.
10630 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 20 ef bf bd ;; domain �
10640 31 32 37 2e 30 2e 30 2e 31 1b 24 42 21 6d 1b 28 127.0.0.1.$B!m.(
10650 42 20 68 61 76 69 6e 67 20 61 20 6c 69 66 65 20 B having a life
10660 74 69 6d 65 20 6f 66 20 32 20 6d 69 6e 73 2c 20 time of 2 mins,
10670 66 6f 72 20 61 6e 79 20 70 61 74 68 20 69 6e 0a for any path in.
10680 20 20 3b 3b 20 20 74 68 65 20 64 6f 6d 61 69 6e ;; the domain
10690 20 28 70 61 74 68 3d 2f 29 2e 20 28 4f 62 76 69 (path=/). (Obvi
106a0 6f 75 73 6c 79 20 79 6f 75 20 77 69 6c 6c 20 68 ously you will h
106b0 61 76 65 20 74 6f 20 72 75 6e 20 74 68 65 0a 20 ave to run the.
106c0 20 3b 3b 20 20 61 70 70 6c 69 63 61 74 69 6f 6e ;; application
106d0 20 77 69 74 68 20 74 68 69 73 20 76 61 6c 75 65 with this value
106e0 20 69 6e 20 74 68 65 20 55 52 4c 29 0a 20 20 3b in the URL). ;
106f0 3b 0a 20 20 3b 3b 20 20 54 6f 20 6d 61 6b 65 20 ;. ;; To make
10700 61 20 73 65 73 73 69 6f 6e 20 63 6f 6f 6b 69 65 a session cookie
10710 2c 20 6c 69 6d 69 74 20 74 68 65 20 66 6c 61 67 , limit the flag
10720 20 73 74 61 74 65 6d 65 6e 74 20 74 6f 20 6a 75 statement to ju
10730 73 74 20 74 68 72 65 65 0a 20 20 3b 3b 20 20 61 st three. ;; a
10740 74 74 72 69 62 75 74 65 73 3a 20 6e 61 6d 65 2c ttributes: name,
10750 20 76 61 6c 75 65 20 61 6e 64 20 64 6f 6d 61 69 value and domai
10760 6e 2e 20 65 2e 67 0a 20 20 3b 3b 20 20 5b 43 4f n. e.g. ;; [CO
10770 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 =someCookie:some
10780 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 5d Value:127.0.0.1]
10790 20 1b 25 47 e2 80 93 1b 25 40 20 41 6e 79 20 66 .%G–.%@ Any f
107a0 75 72 74 68 65 72 0a 20 20 3b 3b 20 20 73 65 74 urther. ;; set
107b0 74 69 6e 67 73 2c 20 61 70 61 63 68 65 20 77 72 tings, apache wr
107c0 69 74 65 73 20 61 6e ef bf bd 20 65 78 70 69 72 ites an� expir
107d0 65 73 ef bf bd 20 61 74 74 72 69 62 75 74 65 20 es� attribute
107e0 66 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f 6b for the set-cook
107f0 69 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 2c ie. ;; header,
10800 20 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 65 which makes the
10810 20 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 73 cookie a persis
10820 74 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 65 tent one (not re
10830 61 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 69 ally. ;; persi
10840 73 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 78 stent, as the ex
10850 70 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 20 pires value set
10860 69 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 is the current s
10870 65 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b 20 erver time. ;;
10880 20 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 6f .%G–.%@ so yo
10890 75 20 64 6f 6e 1b 2d 46 1b 2d 46 ef bf bd 74 20 u don.-F.-F�t
108a0 65 76 65 6e 20 67 65 74 20 74 6f 20 73 65 65 20 even get to see
108b0 79 6f 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 your cookie!).-A
108c0 0a 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 . (list (string
108d0 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 20 22 -substitute .. "
108e0 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 61 72 20 ;" "; " .. (car
108f0 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 (construct-cooki
10900 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 20 20 e-string ..
10910 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 ;; warning! me
10920 73 73 69 6e 67 20 75 70 20 74 68 69 73 20 69 74 ssing up this it
10930 74 79 20 62 69 74 74 79 20 62 69 74 20 6f 66 20 ty bitty bit of
10940 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d code will cost m
10950 75 63 68 20 74 69 6d 65 21 0a 09 20 20 20 20 20 uch time!..
10960 20 20 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 `(("session_ke
10970 79 22 20 2c 28 73 64 61 74 2d 73 65 73 73 69 6f y" ,(sdat-sessio
10980 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 20 20 n-key self)...
10990 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 63 75 expires: ,(+ (cu
109a0 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
109b0 2a 20 31 34 20 38 36 34 30 30 29 29 20 0a 09 09 * 14 86400)) ...
109c0 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a 20 28 2a ;; max-age: (*
109d0 20 31 34 20 38 36 34 30 30 29 0a 09 09 20 20 70 14 86400)... p
109e0 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a 09 09 20 ath: "/" ;; ...
109f0 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 72 69 6e domain: ,(strin
10a00 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 73 64 g-append "." (sd
10a10 61 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 29 at-domain self))
10a20 0a 09 09 20 20 76 65 72 73 69 6f 6e 3a 20 31 29 ... version: 1)
10a30 29 20 30 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f ) 0)))))..;; loo
10a40 6b 20 75 70 20 61 20 67 69 76 65 6e 20 73 65 73 k up a given ses
10a50 73 69 6f 6e 20 6b 65 79 20 61 6e 64 20 72 65 74 sion key and ret
10a60 75 72 6e 20 74 68 65 20 69 64 20 69 66 20 66 6f urn the id if fo
10a70 75 6e 64 2c 20 23 66 20 69 66 20 6e 6f 74 20 66 und, #f if not f
10a80 6f 75 6e 64 0a 28 64 65 66 69 6e 65 20 28 73 65 ound.(define (se
10a90 73 73 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c ssion:get-id sel
10aa0 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 f session-key).
10ab0 20 3b 3b 20 28 6c 65 74 20 28 28 73 65 73 73 69 ;; (let ((sessi
10ac0 6f 6e 2d 6b 65 79 20 28 73 64 61 74 2d 73 65 73 on-key (sdat-ses
10ad0 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 29 sion-key self)))
10ae0 0a 20 20 28 69 66 20 73 65 73 73 69 6f 6e 2d 6b . (if session-k
10af0 65 79 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 ey. (let ((
10b00 71 75 65 72 79 20 28 73 74 72 69 6e 67 2d 61 70 query (string-ap
10b10 70 65 6e 64 20 22 53 45 4c 45 43 54 20 69 64 20 pend "SELECT id
10b20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
10b30 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
10b40 27 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 '" session-key "
10b50 27 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 '")).
10b60 20 28 63 6f 6e 6e 20 28 73 64 61 74 2d 63 6f 6e (conn (sdat-con
10b70 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 n self)).
10b80 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 (result #f)
10b90 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 )..(dbi:for-each
10ba0 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 -row .. (lambda
10bb0 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 (tuple).. (set
10bc0 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
10bd0 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a -ref tuple 0))).
10be0 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 . conn query)..(
10bf0 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 if result (dbi:e
10c00 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 xec conn (conc "
10c10 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 UPDATE sessions
10c20 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 SET last_used="
10c30 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 (dbi:now conn) "
10c40 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b WHERE session_k
10c50 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d ey=?;") session-
10c60 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 key)). re
10c70 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 sult). #f))
10c80 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 ..;; .(define (s
10c90 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 ession:process-u
10ca0 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 rl-path self).
10cb0 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f (let ((path-info
10cc0 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (get-environ
10cd0 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 ment-variable "P
10ce0 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 ATH_INFO"))..(qu
10cf0 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d ery-string (get-
10d00 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
10d10 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 able "QUERY_STRI
10d20 4e 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 NG"))). ;; (s
10d30 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
10d40 22 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 "path-info=" pat
10d50 68 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 h-info " query-s
10d60 74 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 tring=" query-st
10d70 72 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 ring). (if pa
10d80 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 th-info..(let* (
10d90 28 70 61 72 74 73 20 20 20 20 28 73 74 72 69 6e (parts (strin
10da0 67 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 g-split path-inf
10db0 6f 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 o "/"))..
10dc0 28 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 (numparts (lengt
10dd0 68 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 h parts))).. (i
10de0 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 f (> numparts 0)
10df0 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 70 61 .. (sdat-pa
10e00 67 65 2d 73 65 74 21 20 73 65 6c 66 20 28 63 61 ge-set! self (ca
10e10 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b r parts))).. ;;
10e20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
10e30 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 lf "url-path=" u
10e40 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d rl-path " parts=
10e50 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 " parts).. (if
10e60 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 (> numparts 1)..
10e70 20 20 20 20 20 20 28 73 64 61 74 2d 70 61 74 68 (sdat-path
10e80 2d 70 61 72 61 6d 73 2d 73 65 74 21 20 73 65 6c -params-set! sel
10e90 66 20 28 63 64 72 20 70 61 72 74 73 29 29 29 0a f (cdr parts))).
10ea0 20 20 20 20 20 20 20 20 20 20 28 69 66 20 71 75 (if qu
10eb0 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 ery-string.
10ec0 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 70 (sdat-p
10ed0 61 72 61 6d 73 2d 73 65 74 21 20 73 65 6c 66 20 arams-set! self
10ee0 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 (string-split qu
10ef0 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 ery-string "&"))
10f00 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 )))))..;; BUGGY!
10f10 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
10f20 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 n:get-new-key se
10f30 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e lf). (let ((con
10f40 6e 20 20 20 28 73 64 61 74 2d 63 6f 6e 6e 20 73 n (sdat-conn s
10f50 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 28 74 elf)). (t
10f60 6d 70 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 6d mpkey (session:m
10f70 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 ake-rand-string
10f80 32 30 29 29 0a 20 20 20 20 20 20 20 20 28 73 74 20)). (st
10f90 61 74 75 73 20 23 66 29 29 0a 20 20 20 20 28 64 atus #f)). (d
10fa0 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 bi:for-each-row
10fb0 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
10fc0 09 09 09 28 73 65 74 21 20 73 74 61 74 75 73 20 ...(set! status
10fd0 23 74 29 29 0a 09 09 20 20 20 20 20 20 63 6f 6e #t))... con
10fe0 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 n (string-append
10ff0 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 "INSERT INTO se
11000 73 73 69 6f 6e 73 20 28 73 65 73 73 69 6f 6e 5f ssions (session_
11010 6b 65 79 29 20 56 41 4c 55 45 53 20 28 27 22 20 key) VALUES ('"
11020 74 6d 70 6b 65 79 20 22 27 29 22 29 29 0a 20 20 tmpkey "')")).
11030 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b 3b 20 72 tmpkey))..;; r
11040 65 74 75 72 6e 73 20 73 65 73 73 69 6f 6e 20 6b eturns session k
11050 65 79 20 49 46 46 20 69 74 20 69 73 20 69 6e 20 ey IFF it is in
11060 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b 49 45 20 the HTTP_COOKIE
11070 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
11080 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 69 6f n:extract-sessio
11090 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 28 6c n-key self). (l
110a0 65 74 20 28 28 68 74 74 70 2d 63 6f 6f 6b 69 65 et ((http-cookie
110b0 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
110c0 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 t-variable "HTTP
110d0 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 20 20 20 _COOKIE"))).
110e0 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 68 74 74 ;; (err:log "htt
110f0 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 74 74 70 p-cookie: " http
11100 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 28 69 66 -cookie). (if
11110 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a 20 20 20 http-cookie.
11120 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 (session:ex
11130 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 tract-key-from-p
11140 61 72 61 6d 20 73 65 6c 66 20 28 73 74 72 69 6e aram self (strin
11150 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 73 20 20 g-split-fields
11160 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d 63 6f 6f ";\\s+" http-coo
11170 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 73 65 73 kie infix:) "ses
11180 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 20 20 sion_key").
11190 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e #f)))..(defin
111a0 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 e (session:get-s
111b0 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
111c0 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c ession-key). (l
111d0 65 74 20 28 28 71 75 65 72 79 20 22 53 45 4c 45 et ((query "SELE
111e0 43 54 20 69 64 20 46 52 4f 4d 20 73 65 73 73 69 CT id FROM sessi
111f0 6f 6e 73 20 57 48 45 52 45 20 73 65 73 73 69 6f ons WHERE sessio
11200 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 20 20 20 n_key=?;").
11210 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a (result #f)).
11220 20 20 20 20 3b 3b 20 20 20 20 20 28 70 67 3a 71 ;; (pg:q
11230 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 20 28 6c uery-for-each (l
11240 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 20 20 ambda (tuple).
11250 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
11260 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
11270 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 et! result (vect
11280 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 or-ref tuple 0))
11290 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
112a0 20 74 75 70 6c 65 20 30 29 29 29 0a 20 20 20 20 tuple 0))).
112b0 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
112c0 20 20 20 20 20 20 20 20 20 20 28 73 3a 73 71 6c (s:sql
112d0 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 param query sess
112e0 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 3b 3b 20 ion-key). ;;
112f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11300 20 20 20 20 20 20 20 28 73 64 61 74 2d 63 6f 6e (sdat-con
11310 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 3b 3b 20 n self)). ;;
11320 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11330 20 20 20 20 20 20 20 63 6f 6e 6e 29 0a 20 20 20 conn).
11340 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
11350 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
11360 65 29 0a 09 09 09 28 73 65 74 21 20 72 65 73 75 e)....(set! resu
11370 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 lt (vector-ref t
11380 75 70 6c 65 20 30 29 29 29 20 3b 3b 20 28 76 65 uple 0))) ;; (ve
11390 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
113a0 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 64 61 )))... (sda
113b0 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 20 t-conn self)...
113c0 20 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d (s:sqlparam
113d0 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b query session-k
113e0 65 79 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 ey)). result)
113f0 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c )..;; delete all
11400 20 72 65 63 6f 72 64 73 20 66 6f 72 20 61 20 73 records for a s
11410 65 73 73 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 ession.;; .;; NE
11420 45 44 53 20 54 4f 20 42 45 20 54 52 41 4e 53 41 EDS TO BE TRANSA
11430 43 54 49 4f 4e 49 5a 45 44 21 0a 3b 3b 0a 28 64 CTIONIZED!.;;.(d
11440 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 efine (session:d
11450 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 elete-session se
11460 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a lf session-key).
11470 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
11480 2d 69 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 -id (session:get
11490 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
114a0 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 session-key)).
114b0 20 20 20 20 20 20 20 28 71 72 79 31 20 20 20 20 (qry1
114c0 20 20 20 20 3b 3b 20 28 63 6f 6e 63 20 22 42 45 ;; (conc "BE
114d0 47 49 4e 3b 22 0a 09 09 09 20 20 22 44 45 4c 45 GIN;".... "DELE
114e0 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f TE FROM session_
114f0 76 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 vars WHERE sessi
11500 6f 6e 5f 69 64 3d 3f 3b 22 29 0a 09 28 71 72 79 on_id=?;")..(qry
11510 32 20 20 20 20 20 20 20 20 20 20 20 20 20 22 44 2 "D
11520 45 4c 45 54 45 20 46 52 4f 4d 20 73 65 73 73 69 ELETE FROM sessi
11530 6f 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 ons WHERE id=?;"
11540 29 0a 09 09 20 20 20 20 20 3b 3b 20 20 22 43 4f )... ;; "CO
11550 4d 4d 49 54 3b 22 29 29 0a 20 20 20 20 20 20 20 MMIT;")).
11560 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 (conn
11570 20 20 20 20 28 73 64 61 74 2d 63 6f 6e 6e 20 73 (sdat-conn s
11580 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 elf))). (if s
11590 65 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 ession-id.
115a0 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
115b0 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e (dbi:exec con
115c0 6e 20 71 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 n qry1 session-i
115d0 64 29 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 d) ;; session-id
115e0 29 0a 09 20 20 28 64 62 69 3a 65 78 65 63 20 63 ).. (dbi:exec c
115f0 6f 6e 6e 20 71 72 79 32 20 73 65 73 73 69 6f 6e onn qry2 session
11600 2d 69 64 29 0a 09 20 20 3b 3b 20 28 73 65 73 73 -id).. ;; (sess
11610 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 ion:initialize s
11620 65 6c 66 29 0a 09 20 20 28 73 65 73 73 69 6f 6e elf).. (session
11630 3a 73 65 74 75 70 20 73 65 6c 66 29 29 29 0a 20 :setup self))).
11640 20 20 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e (not (session
11650 3a 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 :get-session-id
11660 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 self session-key
11670 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 ))))..;; (define
11680 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 (session:delete
11690 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 -session self se
116a0 73 73 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 ssion-key).;;
116b0 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 (let ((session-i
116c0 64 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 d (session:get-s
116d0 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
116e0 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 ession-key)).;;
116f0 20 20 20 20 20 20 20 20 28 71 75 65 72 69 65 73 (queries
11700 20 20 20 20 28 6c 69 73 74 20 22 42 45 47 49 4e (list "BEGIN
11710 3b 22 0a 3b 3b 20 09 09 09 20 20 22 44 45 4c 45 ;".;; ... "DELE
11720 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f TE FROM session_
11730 76 61 72 73 20 57 48 45 52 45 20 73 65 73 73 69 vars WHERE sessi
11740 6f 6e 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 on_id=?;".;;
11750 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11760 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 46 "DELETE F
11770 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 ROM sessions WHE
11780 52 45 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 RE id=?;".;; ...
11790 20 20 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b "COMMIT;")).;;
117a0 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 (conn
117b0 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 (sda
117c0 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b t-conn self))).;
117d0 3b 20 20 20 20 20 28 69 66 20 73 65 73 73 69 6f ; (if sessio
117e0 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 n-id.;;
117f0 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 (begin.;;
11800 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b (for-each.;;
11810 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
11820 62 64 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 bda (query).;;
11830 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 69 (dbi
11840 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 :exec conn query
11850 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b session-id)).;;
11860 20 09 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b . queries).;;
11870 20 09 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 . (initialize
11880 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 self '()).;; .
11890 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 (session:setup s
118a0 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e elf))).;; (n
118b0 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ot (session:get-
118c0 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
118d0 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a session-key)))).
118e0 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
118f0 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 n:extract-key se
11900 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 lf key). (let (
11910 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d 70 61 (params (sdat-pa
11920 72 61 6d 73 20 73 65 6c 66 29 29 29 0a 20 20 20 rams self))).
11930 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 (session:extrac
11940 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d t-key-from-param
11950 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 self params key
11960 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
11970 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 ssion:extract-ke
11980 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c y-from-param sel
11990 66 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 f params key).
119a0 28 6c 65 74 20 28 28 72 31 20 20 20 20 20 28 72 (let ((r1 (r
119b0 65 67 65 78 70 20 28 73 74 72 69 6e 67 2d 61 70 egexp (string-ap
119c0 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 22 3d 28 pend "^" key "=(
119d0 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a 20 20 20 [^=]+)$")))).
119e0 20 28 65 72 72 3a 6c 6f 67 20 22 49 4e 46 4f 3a (err:log "INFO:
119f0 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 20 22 20 6b Looking for " k
11a00 65 79 20 22 20 69 6e 20 22 20 70 61 72 61 6d 73 ey " in " params
11a10 29 0a 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 ). (if (< (le
11a20 6e 67 74 68 20 70 61 72 61 6d 73 29 20 31 29 20 ngth params) 1)
11a30 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 #f..(let loop ((
11a40 68 65 61 64 20 20 20 28 63 61 72 20 70 61 72 61 head (car para
11a50 6d 73 29 29 0a 09 09 20 20 20 28 74 61 69 6c 20 ms))... (tail
11a60 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 (cdr params)))
11a70 0a 09 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 .. (let ((match
11a80 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 (string-match r
11a90 31 20 68 65 61 64 29 29 29 0a 09 20 20 20 20 28 1 head))).. (
11aa0 63 6f 6e 64 0a 09 20 20 20 20 20 28 6d 61 74 63 cond.. (matc
11ab0 68 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 h.. (let ((
11ac0 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 6c 69 73 session-key (lis
11ad0 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 29 29 t-ref match 1)))
11ae0 0a 09 09 28 65 72 72 3a 6c 6f 67 20 22 49 4e 46 ...(err:log "INF
11af0 4f 3a 20 46 6f 75 6e 64 20 73 65 73 73 69 6f 6e O: Found session
11b00 20 6b 65 79 3d 22 20 73 65 73 73 69 6f 6e 2d 6b key=" session-k
11b10 65 79 29 0a 09 09 28 73 64 61 74 2d 73 65 73 73 ey)...(sdat-sess
11b20 69 6f 6e 2d 6b 65 79 2d 73 65 74 21 20 73 65 6c ion-key-set! sel
11b30 66 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 f (list-ref matc
11b40 68 20 31 29 29 0a 09 09 73 65 73 73 69 6f 6e 2d h 1))...session-
11b50 6b 65 79 29 29 0a 09 20 20 20 20 20 28 28 6e 75 key)).. ((nu
11b60 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 20 20 20 20 ll? tail)..
11b70 20 23 66 29 0a 09 20 20 20 20 20 28 65 6c 73 65 #f).. (else
11b80 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
11b90 61 72 20 74 61 69 6c 29 0a 09 09 20 20 20 20 28 ar tail)... (
11ba0 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 29 cdr tail))))))))
11bb0 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
11bc0 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 20 73 65 ion:set-page! se
11bd0 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 0a 20 20 lf page_name).
11be0 28 73 64 61 74 2d 70 61 67 65 2d 73 65 74 21 20 (sdat-page-set!
11bf0 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 29 self page_name))
11c00 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
11c10 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 29 0a 20 on:close self).
11c20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 73 64 61 (dbi:close (sda
11c30 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b t-conn self))).;
11c40 3b 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d ; (close-output-
11c50 70 6f 72 74 20 28 73 64 61 74 2d 6c 6f 67 70 74 port (sdat-logpt
11c60 20 73 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 self))..(define
11c70 20 28 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 (session:err-ms
11c80 67 20 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 68 g self msg). (h
11c90 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
11ca0 73 64 61 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 sdat-sessionvars
11cb0 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 self) "ERROR_MS
11cc0 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d G"... (string-
11cd0 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
11ce0 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d s:any->string m
11cf0 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 sg) " ")))..(def
11d00 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 ine (session:pre
11d10 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c v-err self). (l
11d20 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 et ((prev-err (h
11d30 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
11d40 66 61 75 6c 74 20 28 73 64 61 74 2d 73 65 73 73 fault (sdat-sess
11d50 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 ionvars-before s
11d60 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 47 22 elf) "ERROR_MSG"
11d70 20 23 66 29 29 0a 09 28 63 75 72 72 2d 65 72 72 #f))..(curr-err
11d80 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
11d90 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 73 /default (sdat-s
11da0 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 essionvars self)
11db0 20 22 45 52 52 4f 52 5f 4d 53 47 22 20 23 66 29 "ERROR_MSG" #f)
11dc0 29 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 2d )). (if prev-
11dd0 65 72 72 20 70 72 65 76 2d 65 72 72 0a 09 28 69 err prev-err..(i
11de0 66 20 63 75 72 72 2d 65 72 72 20 63 75 72 72 2d f curr-err curr-
11df0 65 72 72 20 23 66 29 29 29 29 0a 0a 3b 3b 20 73 err #f))))..;; s
11e00 65 73 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 20 31 ession vars.;; 1
11e10 2e 20 6b 65 79 73 20 61 72 65 20 61 6c 77 61 79 . keys are alway
11e20 73 20 61 20 73 74 72 69 6e 67 20 4e 4f 54 20 61 s a string NOT a
11e30 20 73 79 6d 62 6f 6c 0a 3b 3b 20 32 2e 20 76 61 symbol.;; 2. va
11e40 6c 75 65 73 20 61 72 65 20 61 6c 77 61 79 73 20 lues are always
11e50 61 20 73 74 72 69 6e 67 20 63 6f 6e 76 65 72 73 a string convers
11e60 69 6f 6e 20 69 73 20 74 68 65 20 72 65 73 70 6f ion is the respo
11e70 6e 73 69 62 69 6c 69 74 79 20 6f 66 20 74 68 65 nsibility of the
11e80 20 0a 3b 3b 20 20 20 20 63 6f 6e 73 75 6d 69 6e .;; consumin
11e90 67 20 66 75 6e 63 74 69 6f 6e 20 28 61 74 20 6c g function (at l
11ea0 65 61 73 74 20 66 6f 72 20 6e 6f 77 2c 20 49 27 east for now, I'
11eb0 64 20 6c 69 6b 65 20 74 6f 20 63 68 61 6e 67 65 d like to change
11ec0 20 74 68 69 73 29 0a 0a 3b 3b 20 73 65 74 20 61 this)..;; set a
11ed0 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
11ee0 20 74 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 the current pag
11ef0 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
11f00 73 73 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d ssion:curr-page-
11f10 73 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 set! self key va
11f20 6c 75 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 lue). (hash-tab
11f30 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 70 61 le-set! (sdat-pa
11f40 67 65 76 61 72 73 20 73 65 6c 66 29 20 28 73 3a gevars self) (s:
11f50 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
11f60 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
11f70 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c value)))..;; del
11f80 20 61 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 a var for the c
11f90 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
11fa0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
11fb0 70 61 67 65 2d 76 61 72 2d 64 65 6c 21 20 73 65 page-var-del! se
11fc0 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d lf key). (hash-
11fd0 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 73 table-delete! (s
11fe0 64 61 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c dat-pagevars sel
11ff0 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e f) (s:any->strin
12000 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 g key)))..;; get
12010 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 the appropriate
12020 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 hash given a pa
12030 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
12040 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 *, *globalvars*
12050 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 or page.;;.(defi
12060 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
12070 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
12080 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 age). (if (stri
12090 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 ng=? page "*sess
120a0 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 ionvars*").
120b0 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 76 61 (sdat-sessionva
120c0 72 73 20 73 65 6c 66 29 0a 20 20 20 20 20 20 28 rs self). (
120d0 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 if (string=? pag
120e0 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 e "*globalvars*"
120f0 29 0a 09 20 20 28 73 64 61 74 2d 67 6c 6f 62 61 ).. (sdat-globa
12100 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 20 20 28 lvars self).. (
12110 73 64 61 74 2d 70 61 67 65 76 61 72 73 20 73 65 sdat-pagevars se
12120 6c 66 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 61 lf))))..;; set a
12130 20 73 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 session var for
12140 20 61 20 67 69 76 65 6e 20 70 61 67 65 0a 3b 3b a given page.;;
12150 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
12160 6e 3a 73 65 74 21 20 73 65 6c 66 20 70 61 67 65 n:set! self page
12170 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 6c key value). (l
12180 65 74 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e et ((ht (session
12190 3a 67 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 :get-page-hash s
121a0 65 6c 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 elf page))).
121b0 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
121c0 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ht (s:any->stri
121d0 6e 67 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e ng key) (s:any->
121e0 73 74 72 69 6e 67 20 76 61 6c 75 65 29 29 29 29 string value))))
121f0 0a 0a 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e ..;; get session
12200 20 76 61 72 73 20 66 6f 72 20 74 68 65 20 63 75 vars for the cu
12210 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 rrent page.;;.(d
12220 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
12230 61 67 65 2d 67 65 74 20 73 65 6c 66 20 6b 65 79 age-get self key
12240 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
12250 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 ref/default (sda
12260 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 t-pagevars self)
12270 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 key #f))..;; ge
12280 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 t session vars f
12290 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 or a specified p
122a0 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 age.;;.(define (
122b0 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 session:get self
122c0 20 70 61 67 65 20 6b 65 79 20 70 61 72 61 6d 73 page key params
122d0 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 20 20 ). (let* ((ht
122e0 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 (session:get-pag
122f0 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 e-hash self page
12300 29 29 0a 09 20 28 72 65 73 20 28 68 61 73 68 2d )).. (res (hash-
12310 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
12320 74 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 t ht (s:any->str
12330 69 6e 67 20 6b 65 79 29 20 23 66 29 29 29 0a 20 ing key) #f))).
12340 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c (session:appl
12350 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 y-type-preferenc
12360 65 20 72 65 73 20 70 61 72 61 6d 73 29 29 29 0a e res params))).
12370 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 .;; delete a ses
12380 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 sion var for a s
12390 70 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b pecified page.;;
123a0 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
123b0 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 n:del! self page
123c0 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 key). (let ((h
123d0 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 t (session:get-p
123e0 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
123f0 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d ge))). (hash-
12400 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 table-delete! ht
12410 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
12420 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 key))))..;; get
12430 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 ALL keys for thi
12440 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 s page and store
12450 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 in the session
12460 70 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b pagevars hash.;;
12470 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
12480 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 n:get-vars self)
12490 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f . (let ((sessio
124a0 6e 2d 69 64 20 20 28 73 64 61 74 2d 73 65 73 73 n-id (sdat-sess
124b0 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 29 0a 20 ion-id self))).
124c0 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 73 73 (if (not sess
124d0 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 3a 6c 6f ion-id)..(err:lo
124e0 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 73 65 73 g "ERROR: No ses
124f0 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 73 73 69 sion id in sessi
12500 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 73 73 69 on object! sessi
12510 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 0a 09 28 on:get-vars")..(
12520 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 20 20 20 let* ((result
12530 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
12540 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 (conn
12550 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
12560 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 09 20 20 20 conn self))..
12570 20 20 20 20 28 70 61 67 65 76 61 72 73 2d 62 65 (pagevars-be
12580 66 6f 72 65 20 20 20 20 28 73 64 61 74 2d 70 61 fore (sdat-pa
12590 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 gevars-before se
125a0 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
125b0 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
125c0 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 76 61 (sdat-sessionva
125d0 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 rs-before self))
125e0 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c .. (global
125f0 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 vars-before (sd
12600 61 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 at-globalvars-be
12610 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 20 20 20 fore self))..
12620 20 20 20 20 28 70 61 67 65 76 61 72 73 20 20 20 (pagevars
12630 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 70 61 (sdat-pa
12640 67 65 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 gevars self))..
12650 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 76 61 (sessionva
12660 72 73 20 20 20 20 20 20 20 20 28 73 64 61 74 2d rs (sdat-
12670 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 sessionvars self
12680 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
12690 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 28 alvars (
126a0 73 64 61 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 sdat-globalvars
126b0 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 self)).. (
126c0 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 page-name
126d0 20 20 20 28 73 64 61 74 2d 70 61 67 65 20 73 65 (sdat-page se
126e0 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
126f0 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 20 20 20 ssion-key
12700 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 2d 6b (sdat-session-k
12710 65 79 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 ey self))..
12720 20 20 28 71 75 65 72 79 20 20 20 20 20 20 20 20 (query
12730 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 (string-ap
12740 70 65 6e 64 0a 09 09 09 09 20 20 20 20 22 53 45 pend..... "SE
12750 4c 45 43 54 20 6b 65 79 2c 76 61 6c 75 65 20 46 LECT key,value F
12760 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 ROM session_vars
12770 20 49 4e 4e 45 52 20 4a 4f 49 4e 20 73 65 73 73 INNER JOIN sess
12780 69 6f 6e 73 20 4f 4e 20 73 65 73 73 69 6f 6e 5f ions ON session_
12790 76 61 72 73 2e 73 65 73 73 69 6f 6e 5f 69 64 3d vars.session_id=
127a0 73 65 73 73 69 6f 6e 73 2e 69 64 20 22 0a 09 09 sessions.id "...
127b0 09 09 20 20 20 20 22 57 48 45 52 45 20 73 65 73 .. "WHERE ses
127c0 73 69 6f 6e 5f 6b 65 79 3d 3f 20 41 4e 44 20 70 sion_key=? AND p
127d0 61 67 65 3d 3f 3b 22 29 29 29 0a 09 20 20 3b 3b age=?;"))).. ;;
127e0 20 66 69 72 73 74 20 74 68 65 20 70 61 67 65 20 first the page
127f0 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 20 specific vars..
12800 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
12810 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
12820 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 e).... (let
12830 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 ((k (vector-ref
12840 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 tuple 0)).....
12850 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 (v (vector-re
12860 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 f tuple 1)))....
12870 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
12880 21 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 ! pagevars-befor
12890 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
128a0 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 -table-set! page
128b0 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 76 29 vars k v)
128c0 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 )).... conn..
128d0 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 .. (s:sqlpara
128e0 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d m query session-
128f0 6b 65 79 20 70 61 67 65 2d 6e 61 6d 65 29 29 0a key page-name)).
12900 09 20 20 3b 3b 20 74 68 65 6e 20 74 68 65 20 73 . ;; then the s
12910 65 73 73 69 6f 6e 20 73 70 65 63 69 66 69 63 20 ession specific
12920 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 vars.. (dbi:for
12930 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
12940 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 a (tuple)....
12950 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 (let ((k (vec
12960 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
12970 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 )..... (v (ve
12980 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 ctor-ref tuple 1
12990 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 ))).....(hash-ta
129a0 62 6c 65 2d 73 65 74 21 20 73 65 73 73 69 6f 6e ble-set! session
129b0 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
129c0 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
129d0 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 76 61 72 -set! sessionvar
129e0 73 20 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a s k v))).
129f0 09 09 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 ... conn....
12a00 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 (s:sqlparam q
12a10 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 uery session-key
12a20 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
12a30 29 29 0a 09 20 20 3b 3b 20 61 6e 64 20 66 69 6e )).. ;; and fin
12a40 61 6c 6c 79 20 74 68 65 20 67 6c 6f 62 61 6c 20 ally the global
12a50 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 vars.. (dbi:for
12a60 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
12a70 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 a (tuple)....
12a80 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 (let ((k (vec
12a90 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
12aa0 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 )..... (v (ve
12ab0 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 ctor-ref tuple 1
12ac0 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 ))).....(hash-ta
12ad0 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 61 6c 76 ble-set! globalv
12ae0 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a ars-before k v).
12af0 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
12b00 73 65 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 20 set! globalvars
12b10 20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 k v)))...
12b20 09 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 . conn....
12b30 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 (s:sqlparam que
12b40 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 ry session-key "
12b50 2a 67 6c 6f 62 61 6c 76 61 72 73 22 29 29 0a 09 *globalvars"))..
12b60 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))..(define
12b70 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 2d 76 61 (session:save-va
12b80 72 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 rs self). (let
12b90 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 20 28 73 ((session-id (s
12ba0 64 61 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 dat-session-id s
12bb0 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
12bc0 6e 6f 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a not session-id).
12bd0 09 28 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 .(err:log "ERROR
12be0 3a 20 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 : No session id
12bf0 69 6e 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 in session objec
12c00 74 21 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 t! session:get-v
12c10 61 72 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 ars")..(let* ((s
12c20 74 61 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 tatus #f)..
12c30 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 (conn
12c40 20 20 20 20 28 73 64 61 74 2d 63 6f 6e 6e 20 73 (sdat-conn s
12c50 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
12c60 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 age-name (sdat
12c70 2d 70 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 -page self))..
12c80 20 20 20 20 20 28 64 65 6c 2d 71 75 65 72 79 20 (del-query
12c90 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 "DELETE FROM s
12ca0 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 48 45 52 ession_vars WHER
12cb0 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 E session_id=? A
12cc0 4e 44 20 70 61 67 65 3d 3f 20 41 4e 44 20 6b 65 ND page=? AND ke
12cd0 79 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 y=?;").. (
12ce0 69 6e 73 2d 71 75 65 72 79 20 20 20 22 49 4e 53 ins-query "INS
12cf0 45 52 54 20 49 4e 54 4f 20 73 65 73 73 69 6f 6e ERT INTO session
12d00 5f 76 61 72 73 20 28 73 65 73 73 69 6f 6e 5f 69 _vars (session_i
12d10 64 2c 70 61 67 65 2c 6b 65 79 2c 76 61 6c 75 65 d,page,key,value
12d20 29 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f ) VALUES(?,?,?,?
12d30 29 3b 22 29 0a 09 20 20 20 20 20 20 20 28 75 70 );").. (up
12d40 64 2d 71 75 65 72 79 20 20 20 22 55 50 44 41 54 d-query "UPDAT
12d50 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 73 E session_vars s
12d60 65 74 20 76 61 6c 75 65 3d 3f 20 57 48 45 52 45 et value=? WHERE
12d70 20 6b 65 79 3d 3f 20 41 4e 44 20 73 65 73 73 69 key=? AND sessi
12d80 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 on_id=? AND page
12d90 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 20 28 63 =?;").. (c
12da0 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 30 29 29 hanged-count 0))
12db0 0a 09 20 20 3b 3b 20 73 61 76 65 20 74 68 65 20 .. ;; save the
12dc0 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 20 28 66 delta only.. (f
12dd0 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d or-each.. (lam
12de0 62 64 61 20 28 70 61 67 65 29 20 3b 3b 20 70 61 bda (page) ;; pa
12df0 67 65 20 69 73 3a 20 22 2a 67 6c 6f 62 61 6c 76 ge is: "*globalv
12e00 61 72 73 2a 22 20 22 2a 73 65 73 73 69 6f 6e 76 ars*" "*sessionv
12e10 61 72 73 2a 22 20 6f 72 20 6f 74 68 65 72 73 74 ars*" or otherst
12e20 72 69 6e 67 0a 09 20 20 20 20 20 28 6c 65 74 2a ring.. (let*
12e30 20 28 28 62 65 66 6f 72 65 2d 61 66 74 65 72 2d ((before-after-
12e40 68 74 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 ht (cond.....
12e50 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 ((string=? pa
12e60 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 ge "*sessionvars
12e70 2a 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 *")..... (
12e80 76 65 63 74 6f 72 20 28 73 64 61 74 2d 73 65 73 vector (sdat-ses
12e90 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 09 sionvars self)..
12ea0 09 09 09 09 20 20 20 20 20 20 20 28 73 64 61 74 .... (sdat
12eb0 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 -sessionvars-bef
12ec0 6f 72 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 ore self))).....
12ed0 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d ((string=
12ee0 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 ? page "*globalv
12ef0 61 72 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 ars*")......(vec
12f00 74 6f 72 20 28 73 64 61 74 2d 67 6c 6f 62 61 6c tor (sdat-global
12f10 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 vars self)......
12f20 09 28 73 64 61 74 2d 67 6c 6f 62 61 6c 76 61 72 .(sdat-globalvar
12f30 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 29 s-before self)))
12f40 0a 09 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 ..... (els
12f50 65 20 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 e ......(vector
12f60 28 73 64 61 74 2d 70 61 67 65 76 61 72 73 20 73 (sdat-pagevars s
12f70 65 6c 66 29 0a 09 09 09 09 09 09 28 73 64 61 74 elf).......(sdat
12f80 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
12f90 20 73 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 self)))))...
12fa0 20 28 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 (master-ht (v
12fb0 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 ector-ref before
12fc0 2d 61 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 -after-ht 0))...
12fd0 20 20 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 (before-ht
12fe0 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 (vector-ref bef
12ff0 6f 72 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 ore-after-ht 1))
13000 0a 09 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b ... (master-k
13010 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
13020 6b 65 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 keys master-ht))
13030 0a 09 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b ... (before-k
13040 65 79 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d eys (hash-table-
13050 6b 65 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 keys before-ht))
13060 0a 09 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 ... (all-keys
13070 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
13080 74 65 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 tes (append mast
13090 65 72 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b er-keys before-k
130a0 65 79 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 eys))))..
130b0 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 (for-each ...(la
130c0 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 mbda (key)... (
130d0 6c 65 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c let ((master-val
130e0 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ue (hash-table-r
130f0 65 66 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 ef/default maste
13100 72 2d 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 r-ht key #f))...
13110 09 28 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 .(before-value (
13120 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
13130 65 66 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 efault before-ht
13140 20 6b 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 key #f)))...
13150 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b (cond... ;;
13160 20 62 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 before and afte
13170 72 20 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 r exist and valu
13180 65 20 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f e unchanged - do
13190 20 6e 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 nothing...
131a0 28 28 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c ((and master-val
131b0 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 ue before-value
131c0 28 65 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 (equal? master-v
131d0 61 6c 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 alue before-valu
131e0 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 e)))... ;; b
131f0 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
13200 65 78 69 73 74 20 62 75 74 20 61 72 65 20 63 68 exist but are ch
13210 61 6e 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 anged... ((a
13220 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 nd master-value
13230 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 before-value)...
13240 20 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 (dbi:for-e
13250 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 ach-row (lambda
13260 28 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 (tuple)...... (
13270 73 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 set! changed-cou
13280 6e 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f nt (+ changed-co
13290 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f unt 1)))......co
132a0 6e 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 nn......(s:sqlpa
132b0 72 61 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 ram upd-query ma
132c0 73 74 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 ster-value key s
132d0 65 73 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 ession-id page))
132e0 29 0a 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 )... ;; mast
132f0 65 72 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 er-value no long
13300 65 72 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 er exists (i.e.
13310 23 66 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 #f) - remove ite
13320 6d 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d m... ((not m
13330 61 73 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 aster-value)...
13340 20 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 (dbi:for-ea
13350 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 ch-row (lambda (
13360 74 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 tuple)...... (s
13370 65 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e et! changed-coun
13380 74 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 t (+ changed-cou
13390 6e 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e nt 1)))......con
133a0 6e 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 n......(s:sqlpar
133b0 61 6d 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 am del-query ses
133c0 73 69 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 sion-id page key
133d0 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 )))... ;; be
133e0 66 6f 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e fore-value doesn
133f0 27 74 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 't exist - inser
13400 74 20 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 t a new value...
13410 20 20 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 ((not befor
13420 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
13430 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
13440 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
13450 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
13460 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
13470 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
13480 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
13490 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 ...(s:sqlparam i
134a0 6e 73 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e ns-query session
134b0 2d 69 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 -id page key mas
134c0 74 65 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 ter-value)))...
134d0 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c (else (err:l
134e0 6f 67 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 og "Shouldn't ge
134f0 74 20 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 t here")))))...a
13500 6c 6c 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 ll-keys))) ;; pr
13510 6f 63 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 ocess all keys..
13520 20 20 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 (list "*sessi
13530 6f 6e 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 onvars*" "*globa
13540 6c 76 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d lvars*" page-nam
13550 65 29 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a e))))))..;; (pg:
13560 73 71 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f sql-null-object?
13570 20 65 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e element).(defin
13580 65 20 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d e (session:read-
13590 63 6f 6e 66 69 67 20 73 65 6c 66 20 23 21 6f 70 config self #!op
135a0 74 69 6f 6e 61 6c 20 28 66 6e 61 6d 65 20 23 66 tional (fname #f
135b0 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 67 69 )). (let* ((cgi
135c0 2d 70 61 74 68 20 28 70 61 74 68 6e 61 6d 65 2d -path (pathname-
135d0 64 69 72 65 63 74 6f 72 79 20 28 63 61 72 20 28 directory (car (
135e0 61 72 67 76 29 29 29 29 0a 20 20 20 20 20 20 20 argv)))).
135f0 20 20 28 6e 61 6d 65 20 20 20 20 20 28 6f 72 20 (name (or
13600 66 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 61 70 fname (string-ap
13610 70 65 6e 64 20 28 69 66 20 63 67 69 2d 70 61 74 pend (if cgi-pat
13620 68 20 28 63 6f 6e 63 20 63 67 69 2d 70 61 74 68 h (conc cgi-path
13630 20 22 2f 22 29 20 22 22 29 20 22 2e 22 20 28 70 "/") "") "." (p
13640 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 athname-file (ca
13650 72 20 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e r (argv))) ".con
13660 66 69 67 22 29 29 29 29 0a 20 20 20 20 28 69 66 fig")))). (if
13670 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
13680 74 73 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 ts? name))..(pri
13690 6e 74 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f nt name " not fo
136a0 75 6e 64 20 61 74 20 22 20 28 63 75 72 72 65 6e und at " (curren
136b0 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 t-directory))..(
136c0 6c 65 74 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d let* ((fp (open-
136d0 69 6e 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 input-file name)
136e0 29 0a 09 20 20 20 20 20 20 20 28 69 6e 69 74 61 ).. (inita
136f0 72 67 73 20 28 72 65 61 64 20 66 70 29 29 29 0a rgs (read fp))).
13700 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d . (close-input-
13710 70 6f 72 74 20 66 70 29 0a 09 20 20 69 6e 69 74 port fp).. init
13720 61 72 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c args))))..;; cal
13730 6c 20 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 l the controller
13740 20 69 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b if it exists.;;
13750 20 0a 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 .;; WARNING - t
13760 68 69 73 20 63 6f 64 65 20 6e 65 65 64 73 20 61 his code needs a
13770 20 64 65 66 65 6e 63 65 20 61 67 61 69 6e 73 20 defence agains
13780 72 65 63 75 72 73 69 76 65 20 63 61 6c 6c 69 6e recursive callin
13790 67 21 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 g!!!!!.;;.;; I
137a0 20 73 75 67 67 65 73 74 20 61 20 6c 69 6d 69 74 suggest a limit
137b0 20 6f 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 of 100 calls. P
137c0 6c 65 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 lenty for allowi
137d0 6e 67 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 ng multiple inst
137e0 61 6e 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 ances.;; of a
137f0 70 61 67 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 page inside anot
13800 68 65 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b her page. .;;.;;
13810 20 70 61 72 74 73 20 3d 20 27 62 6f 74 68 20 7c parts = 'both |
13820 20 27 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 'control | 'vie
13830 77 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 w.;;..(define (f
13840 69 6c 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e iles-read->strin
13850 67 20 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 74 g . files). (st
13860 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
13870 20 0a 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 . (apply appe
13880 6e 64 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 nd (map file-rea
13890 64 2d 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 29 d->string files)
138a0 29 20 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e ) "\n"))..(defin
138b0 65 20 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 e (file-read->st
138c0 72 69 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 20 ring f) . (let
138d0 28 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d ((p (open-input-
138e0 66 69 6c 65 20 66 29 29 29 0a 20 20 20 20 28 6c file f))). (l
138f0 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 et loop ((hed (r
13900 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 ead-line p))..
13910 20 20 20 20 20 28 72 65 73 20 27 28 29 29 29 0a (res '())).
13920 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
13930 62 6a 65 63 74 3f 20 68 65 64 29 0a 09 20 20 72 bject? hed).. r
13940 65 73 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 es.. (loop (rea
13950 64 2d 6c 69 6e 65 20 70 29 28 61 70 70 65 6e 64 d-line p)(append
13960 20 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 res (list hed))
13970 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
13980 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 0a process-port p).
13990 20 20 28 6c 65 74 20 28 28 65 20 28 69 6e 74 65 (let ((e (inte
139a0 72 61 63 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d raction-environm
139b0 65 6e 74 29 29 29 0a 20 20 20 20 28 6d 61 70 20 ent))). (map
139c0 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 . (lambda (x
139d0 29 0a 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 ). (cond..
139e0 28 28 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 28 ((list? x) x)..(
139f0 28 73 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 (string? x) x)..
13a00 28 65 6c 73 65 20 27 28 29 29 29 29 0a 20 20 20 (else '()))).
13a10 20 20 28 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d (port-map (lam
13a20 62 64 61 20 28 73 29 0a 09 09 20 28 65 76 61 6c bda (s)... (eval
13a30 20 73 20 65 29 29 0a 09 20 20 20 20 20 20 20 28 s e)).. (
13a40 6c 61 6d 62 64 61 20 28 29 28 72 65 61 64 20 70 lambda ()(read p
13a50 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
13a60 28 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 (session:process
13a70 2d 66 69 6c 65 20 66 29 0a 20 20 28 6c 65 74 2a -file f). (let*
13a80 20 28 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e ((p (open-in
13a90 70 75 74 2d 66 69 6c 65 20 66 29 29 0a 09 20 28 put-file f)).. (
13aa0 64 61 74 20 20 28 70 72 6f 63 65 73 73 2d 70 6f dat (process-po
13ab0 72 74 20 70 29 29 29 0a 20 20 20 20 28 63 6c 6f rt p))). (clo
13ac0 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 se-input-port p)
13ad0 0a 20 20 20 20 64 61 74 29 29 0a 0a 3b 3b 20 4d . dat))..;; M
13ae0 61 79 20 32 30 31 31 2c 20 70 75 74 74 69 6e 67 ay 2011, putting
13af0 20 61 6c 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 all pages into
13b00 6f 6e 65 20 64 69 72 65 63 74 6f 72 79 20 66 6f one directory fo
13b10 72 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 r the following
13b20 72 65 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e reasons:.;; 1.
13b30 20 77 61 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 want filename t
13b40 6f 20 72 65 66 6c 65 63 74 20 70 61 67 65 20 6e o reflect page n
13b50 61 6d 65 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 ame (emacs limit
13b60 61 74 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 ation).;; 2. t
13b70 68 61 74 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 hat's it! no oth
13b80 65 72 20 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 er reason. could
13b90 20 6d 61 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 make it configu
13ba0 72 61 62 6c 65 20 2e 2e 2e 0a 3b 3b 20 70 61 67 rable ....;; pag
13bb0 65 2d 64 69 72 2d 73 74 79 6c 65 20 69 73 3a 0a e-dir-style is:.
13bc0 3b 3b 20 20 27 73 74 6f 72 65 64 20 20 20 3d 3e ;; 'stored =>
13bd0 20 73 74 6f 72 65 64 20 69 6e 20 65 78 65 63 75 stored in execu
13be0 74 61 62 6c 65 0a 3b 3b 20 20 27 66 6c 61 74 20 table.;; 'flat
13bf0 20 20 20 20 3d 3e 20 70 61 67 65 73 20 66 6c 61 => pages fla
13c00 74 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b 20 20 t directory.;;
13c10 27 64 69 72 20 20 20 20 20 20 3d 3e 20 64 69 72 'dir => dir
13c20 65 63 74 6f 72 79 20 74 72 65 65 20 70 61 67 65 ectory tree page
13c30 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f 7b 76 69 s/<pagename>/{vi
13c40 65 77 2c 63 6f 6e 74 72 6f 6c 7d 2e 73 63 6d 0a ew,control}.scm.
13c50 3b 3b 20 70 61 72 74 73 3a 0a 3b 3b 20 20 27 62 ;; parts:.;; 'b
13c60 6f 74 68 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 oth => load
13c70 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 77 control and view
13c80 20 28 61 6e 79 74 68 69 6e 67 20 6f 74 68 65 72 (anything other
13c90 20 74 68 61 6e 20 76 69 65 77 20 6f 72 20 63 6f than view or co
13ca0 6e 74 72 6f 6c 20 61 6e 64 20 74 68 65 20 64 65 ntrol and the de
13cb0 66 61 75 6c 74 29 0a 3b 3b 20 20 27 76 69 65 77 fault).;; 'view
13cc0 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 76 69 65 => load vie
13cd0 77 20 6f 6e 6c 79 0a 3b 3b 20 20 27 63 6f 6e 74 w only.;; 'cont
13ce0 72 6f 6c 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e rol => load con
13cf0 74 72 6f 6c 20 6f 6e 6c 79 0a 28 64 65 66 69 6e trol only.(defin
13d00 65 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d e (session:call-
13d10 70 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 parts self page
13d20 23 21 6b 65 79 20 28 70 61 72 74 73 20 27 62 6f #!key (parts 'bo
13d30 74 68 29 29 0a 20 20 28 73 64 61 74 2d 63 75 72 th)). (sdat-cur
13d40 72 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c 66 r-page-set! self
13d50 20 70 61 67 65 29 0a 20 20 28 6c 65 74 2a 20 28 page). (let* (
13d60 28 64 69 72 2d 73 74 79 6c 65 20 20 20 20 28 73 (dir-style (s
13d70 64 61 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 dat-page-dir-sty
13d80 6c 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 le self));; (equ
13d90 61 6c 3f 20 28 73 64 61 74 2d 70 61 67 65 2d 64 al? (sdat-page-d
13da0 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 20 22 ir-style self) "
13db0 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 66 6c 61 onedir")) ;; fla
13dc0 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 69 72 2c g #t for onedir,
13dd0 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 74 79 6c #f for old styl
13de0 65 0a 09 20 28 64 69 72 20 20 20 20 20 20 20 20 e.. (dir
13df0 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
13e00 20 28 73 64 61 74 2d 73 72 6f 6f 74 20 73 65 6c (sdat-sroot sel
13e10 66 29 20 0a 09 09 09 09 20 20 20 20 20 20 28 69 f) ..... (i
13e20 66 20 64 69 72 2d 73 74 79 6c 65 20 0a 09 09 09 f dir-style ....
13e30 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 .. (conc "/page
13e40 73 2f 22 29 0a 09 09 09 09 09 20 20 28 63 6f 6e s/")...... (con
13e50 63 20 22 2f 70 61 67 65 73 2f 22 20 70 61 67 65 c "/pages/" page
13e60 29 29 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 ))))). (case
13e70 64 69 72 2d 73 74 79 6c 65 0a 20 20 20 20 20 20 dir-style.
13e80 3b 3b 20 4e 42 2f 2f 20 53 74 6f 72 65 64 20 61 ;; NB// Stored a
13e90 6c 77 61 79 73 20 6c 6f 61 64 73 20 62 6f 74 68 lways loads both
13ea0 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 control and vie
13eb0 77 0a 20 20 20 20 20 20 28 28 73 74 6f 72 65 64 w. ((stored
13ec0 29 0a 20 20 20 20 20 20 20 28 28 65 76 61 6c 20 ). ((eval
13ed0 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
13ee0 28 63 6f 6e 63 20 22 70 61 67 65 73 3a 22 20 70 (conc "pages:" p
13ef0 61 67 65 29 29 29 20 0a 09 73 65 6c 66 20 20 20 age))) ..self
13f00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13f10 20 20 20 20 20 20 3b 3b 20 74 68 65 20 73 65 73 ;; the ses
13f20 73 69 6f 6e 0a 09 28 73 64 61 74 2d 63 6f 6e 6e sion..(sdat-conn
13f30 20 73 65 6c 66 29 20 20 20 20 20 20 20 20 20 3b self) ;
13f40 3b 20 74 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 ; the db connect
13f50 69 6f 6e 0a 09 28 73 64 61 74 2d 73 68 61 72 65 ion..(sdat-share
13f60 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b d-hash self) ;;
13f70 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 74 a shared hash t
13f80 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 able for passing
13f90 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 data to/from pa
13fa0 67 65 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 20 ge calls..)).
13fb0 20 20 20 28 28 66 6c 61 74 29 20 20 20 0a 20 20 ((flat) .
13fc0 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 2d (let* ((so-
13fd0 66 69 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 20 file (conc dir
13fe0 70 61 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 20 page ".so"))..
13ff0 20 20 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 63 (scm-file (c
14000 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 onc dir page ".s
14010 63 6d 22 29 29 0a 09 20 20 20 20 20 20 28 73 72 cm")).. (sr
14020 63 2d 66 69 6c 65 20 28 6f 72 20 28 66 69 6c 65 c-file (or (file
14030 2d 65 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c 65 -exists? so-file
14040 29 0a 09 09 09 20 20 20 20 28 66 69 6c 65 2d 65 ).... (file-e
14050 78 69 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 29 xists? scm-file)
14060 29 29 29 0a 09 20 28 69 66 20 73 72 63 2d 66 69 ))).. (if src-fi
14070 6c 65 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a le.. (begin.
14080 09 20 20 20 20 20 20 20 28 6c 6f 61 64 20 73 72 . (load sr
14090 63 2d 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 c-file)..
140a0 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((eval (string->
140b0 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 symbol (conc "pa
140c0 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 ges:" page))) ..
140d0 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 .self
140e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
140f0 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 28 the session...(
14100 73 64 61 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 20 sdat-conn self)
14110 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 64 ;; the d
14120 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 09 28 b connection...(
14130 73 64 61 74 2d 73 68 61 72 65 64 2d 68 61 73 68 sdat-shared-hash
14140 20 73 65 6c 66 29 20 20 3b 3b 20 61 20 73 68 61 self) ;; a sha
14150 72 65 64 20 68 61 73 68 20 74 61 62 6c 65 20 66 red hash table f
14160 6f 72 20 70 61 73 73 69 6e 67 20 64 61 74 61 20 or passing data
14170 74 6f 2f 66 72 6f 6d 20 70 61 67 65 20 63 61 6c to/from page cal
14180 6c 73 0a 09 09 29 29 0a 09 20 20 20 20 20 28 6c ls...)).. (l
14190 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 ist "<p>Page not
141a0 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 found " page "
141b0 3c 2f 70 3e 22 29 29 29 29 0a 20 20 20 20 20 20 </p>")))).
141c0 20 3b 3b 20 66 69 72 73 74 20 74 68 65 20 63 6f ;; first the co
141d0 6e 74 72 6f 6c 0a 20 20 20 20 20 20 20 3b 3b 20 ntrol. ;;
141e0 28 6c 65 74 20 28 28 63 6f 6e 74 72 6f 6c 2d 66 (let ((control-f
141f0 69 6c 65 20 28 63 6f 6e 63 20 22 70 61 67 65 73 ile (conc "pages
14200 2f 22 20 70 61 67 65 20 22 5f 63 74 72 6c 2e 73 /" page "_ctrl.s
14210 63 6d 22 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 cm")). ;;
14220 20 20 20 20 20 20 28 76 69 65 77 2d 66 69 6c 65 (view-file
14230 20 20 20 20 28 63 6f 6e 63 20 22 70 61 67 65 73 (conc "pages
14240 2f 22 20 70 61 67 65 20 22 5f 76 69 65 77 2e 73 /" page "_view.s
14250 63 6d 22 29 29 29 0a 20 20 20 20 20 20 20 3b 3b cm"))). ;;
14260 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c (if (and (fil
14270 65 2d 65 78 69 73 74 73 3f 20 63 6f 6e 74 72 6f e-exists? contro
14280 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 3b l-file). ;
14290 3b 20 20 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 ; . (not (eq?
142a0 70 61 72 74 73 20 27 76 69 65 77 29 29 29 0a 20 parts 'view))).
142b0 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
142c0 62 65 67 69 6e 0a 20 20 20 20 20 20 20 3b 3b 20 begin. ;;
142d0 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
142e0 3a 73 65 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c :set-called! sel
142f0 66 20 70 61 67 65 29 0a 20 20 20 20 20 20 20 3b f page). ;
14300 3b 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 ; (load
14310 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 29 29 0a control-file))).
14320 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 ;; (if
14330 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 76 69 (file-exists? vi
14340 65 77 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ew-file).
14350 3b 3b 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f ;; (if (no
14360 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 63 6f t (eq? parts 'co
14370 6e 74 72 6f 6c 29 29 0a 20 20 20 20 20 20 20 3b ntrol)). ;
14380 3b 20 20 09 20 28 73 65 73 73 69 6f 6e 3a 70 72 ; . (session:pr
14390 6f 63 65 73 73 2d 66 69 6c 65 20 76 69 65 77 2d ocess-file view-
143a0 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 3b 3b file)). ;;
143b0 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 (list "<p
143c0 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 >Page not found
143d0 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 " page " </p>"))
143e0 29 0a 20 20 20 20 20 20 28 28 64 69 72 29 20 22 ). ((dir) "
143f0 45 52 52 4f 52 3a 20 20 64 69 72 20 73 74 79 6c ERROR: dir styl
14400 65 20 6e 6f 74 20 79 65 74 20 72 65 2d 69 6d 70 e not yet re-imp
14410 6c 65 6d 65 6e 74 65 64 22 29 0a 20 20 20 20 20 lemented").
14420 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 28 6c (else. (l
14430 69 73 74 20 22 45 52 52 4f 52 3a 20 70 61 67 65 ist "ERROR: page
14440 2d 64 69 72 2d 73 74 79 6c 65 20 6d 75 73 74 20 -dir-style must
14450 62 65 20 73 74 6f 72 65 64 2c 20 64 69 72 20 6f be stored, dir o
14460 72 20 66 6c 61 74 2c 20 67 6f 74 20 22 20 64 69 r flat, got " di
14470 72 2d 73 74 79 6c 65 29 29 29 29 29 0a 0a 28 64 r-style)))))..(d
14480 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 efine (session:c
14490 61 6c 6c 20 73 65 6c 66 20 70 61 67 65 20 70 61 all self page pa
144a0 72 74 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a rts). (session:
144b0 63 61 6c 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 call-parts self
144c0 70 61 67 65 20 27 62 6f 74 68 29 29 0a 0a 3b 3b page 'both))..;;
144d0 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f (define (sessio
144e0 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 65 6c n:load-model sel
144f0 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 6c f model).;; (l
14500 65 74 20 28 28 6d 6f 64 65 6c 2e 73 63 6d 20 28 et ((model.scm (
14510 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
14520 64 61 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 dat-sroot self)
14530 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c "/models/" model
14540 20 22 2e 73 63 6d 22 29 29 0a 3b 3b 20 09 28 6d ".scm")).;; .(m
14550 6f 64 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 odel.so (string
14560 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 73 72 -append (sdat-sr
14570 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 oot self) "/mode
14580 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 ls/" model ".so"
14590 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 ))).;; (if (
145a0 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 file-exists? mod
145b0 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 64 el.so).;; .(load
145c0 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 model.so).;; .(
145d0 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
145e0 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 model.scm).;; .
145f0 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e (load model.
14600 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 3a scm).;; . (s:
14610 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 log "ERROR: mode
14620 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 l " model.scm "
14630 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a not found"))))).
14640 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 .;; (define (ses
14650 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 sion:model-path
14660 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 self model).;;
14670 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
14680 28 73 64 61 74 2d 73 72 6f 6f 74 20 73 65 6c 66 (sdat-sroot self
14690 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 ) "/models/" mod
146a0 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 64 65 el ".scm"))..(de
146b0 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 70 fine (session:pp
146c0 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 0a 20 -formdat self).
146d0 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 6f 72 (let ((dat (for
146e0 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e 67 mdat:all->string
146f0 73 20 28 73 64 61 74 2d 66 6f 72 6d 64 61 74 20 s (sdat-formdat
14700 73 65 6c 66 29 29 29 29 0a 20 20 20 20 28 73 74 self)))). (st
14710 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
14720 20 64 61 74 20 22 3c 62 72 3e 20 22 29 29 29 0a dat "<br> "))).
14730 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
14740 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 n:param->string
14750 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 65 72 params). ;; (er
14760 72 3a 6c 6f 67 20 22 70 61 72 61 6d 73 3d 22 20 r:log "params="
14770 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 3c params). (if (<
14780 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
14790 20 31 29 0a 20 20 20 20 20 20 22 22 0a 20 20 20 1). "".
147a0 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6b (let loop ((k
147b0 65 79 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ey (car params))
147c0 0a 09 09 20 28 76 61 6c 20 28 63 61 64 72 20 70 ... (val (cadr p
147d0 61 72 61 6d 73 29 29 0a 09 09 20 28 74 61 69 6c arams))... (tail
147e0 20 28 63 64 64 72 20 70 61 72 61 6d 73 29 29 0a (cddr params)).
147f0 09 09 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 .. (result '()))
14800 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 75 ..(let ((newresu
14810 6c 74 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 lt (cons (string
14820 2d 61 70 70 65 6e 64 20 28 73 3a 61 6e 79 2d 3e -append (s:any->
14830 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 22 20 string key) "="
14840 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 (s:any->string v
14850 61 6c 29 29 0a 09 09 09 20 20 20 20 20 20 20 72 al)).... r
14860 65 73 75 6c 74 29 29 29 0a 09 20 20 28 69 66 20 esult))).. (if
14870 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 (< (length tail)
14880 20 31 29 20 3b 3b 20 74 72 75 65 20 69 66 20 64 1) ;; true if d
14890 6f 6e 65 0a 09 20 20 20 20 20 20 28 73 74 72 69 one.. (stri
148a0 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6e ng-intersperse n
148b0 65 77 72 65 73 75 6c 74 20 22 26 22 29 0a 09 20 ewresult "&")..
148c0 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
148d0 74 61 69 6c 29 28 63 61 64 72 20 74 61 69 6c 29 tail)(cadr tail)
148e0 28 63 64 64 72 20 74 61 69 6c 29 20 6e 65 77 72 (cddr tail) newr
148f0 65 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 esult))))))..(de
14900 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 69 fine (session:li
14910 6e 6b 2d 74 6f 20 73 65 6c 66 20 70 61 67 65 20 nk-to self page
14920 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
14930 28 28 68 74 74 70 73 2d 68 6f 73 74 20 20 20 28 ((https-host (
14940 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
14950 76 61 72 69 61 62 6c 65 20 22 48 54 54 50 53 5f variable "HTTPS_
14960 48 4f 53 54 22 29 29 0a 20 20 20 20 20 20 20 20 HOST")).
14970 20 28 66 6f 72 63 65 2d 73 73 6c 20 20 20 20 28 (force-ssl (
14980 73 64 61 74 2d 66 6f 72 63 65 2d 73 73 6c 20 73 sdat-force-ssl s
14990 65 6c 66 29 29 0a 09 20 28 73 65 72 76 65 72 20 elf)).. (server
149a0 20 20 20 20 20 20 28 6f 72 20 68 74 74 70 73 2d (or https-
149b0 68 6f 73 74 20 3b 3b 20 41 73 73 75 6d 69 6e 67 host ;; Assuming
149c0 20 48 54 54 50 53 5f 48 4f 53 54 20 69 73 20 6f HTTPS_HOST is o
149d0 6e 6c 79 20 73 65 74 20 69 66 20 61 76 61 69 6c nly set if avail
149e0 61 62 6c 65 0a 09 09 09 20 20 20 28 67 65 74 2d able.... (get-
149f0 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
14a00 61 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 able "HTTP_HOST"
14a10 29 0a 09 09 09 20 20 20 28 67 65 74 2d 65 6e 76 ).... (get-env
14a20 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
14a30 65 20 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 29 e "SERVER_NAME")
14a40 0a 09 09 09 20 20 20 28 73 64 61 74 2d 64 6f 6d .... (sdat-dom
14a50 61 69 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 20 ain self))).
14a60 20 20 20 20 20 28 66 6f 72 63 65 2d 73 63 72 69 (force-scri
14a70 70 74 20 20 28 73 64 61 74 2d 73 63 72 69 70 74 pt (sdat-script
14a80 20 73 65 6c 66 29 29 0a 09 20 28 73 63 72 69 70 self)).. (scrip
14a90 74 20 20 20 20 20 20 20 20 28 6f 72 20 66 6f 72 t (or for
14aa0 63 65 2d 73 63 72 69 70 74 0a 09 09 09 20 20 20 ce-script....
14ab0 20 28 6c 65 74 20 28 28 73 63 72 69 70 74 2d 6e (let ((script-n
14ac0 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ame (string-spli
14ad0 74 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 t (get-environme
14ae0 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 nt-variable "SCR
14af0 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 29 29 IPT_NAME") "/"))
14b00 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 ).... (if (
14b10 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 69 70 74 > (length script
14b20 2d 6e 61 6d 65 29 20 31 29 0a 09 09 09 09 20 20 -name) 1).....
14b30 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 (string-append (
14b40 63 61 72 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 car script-name)
14b50 20 22 2f 22 20 28 63 61 64 72 20 73 63 72 69 70 "/" (cadr scrip
14b60 74 2d 6e 61 6d 65 29 29 0a 09 09 09 09 20 20 28 t-name))..... (
14b70 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
14b80 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 50 54 variable "SCRIPT
14b90 5f 4e 41 4d 45 22 29 29 29 29 29 20 3b 3b 20 62 _NAME"))))) ;; b
14ba0 75 69 6c 64 20 73 63 72 69 70 74 20 6e 61 6d 65 uild script name
14bb0 20 66 72 6f 6d 20 66 69 72 73 74 20 74 77 6f 20 from first two
14bc0 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 20 69 elements. This i
14bd0 73 20 61 20 68 61 6e 67 6f 76 65 72 20 66 72 6f s a hangover fro
14be0 6d 20 62 65 66 6f 72 65 20 49 20 75 73 65 64 20 m before I used
14bf0 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e 29 0a 20 ? in the URL.).
14c00 20 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e (session
14c10 2d 6b 65 79 20 20 20 28 73 64 61 74 2d 73 65 73 -key (sdat-ses
14c20 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 0a sion-key self)).
14c30 09 20 28 70 61 72 61 6d 73 74 72 20 20 20 20 20 . (paramstr
14c40 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d (session:param-
14c50 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 29 >string params))
14c60 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c ). (session:l
14c70 6f 67 20 73 65 6c 66 20 22 73 65 72 76 65 72 3d og self "server=
14c80 22 20 73 65 72 76 65 72 20 22 20 73 63 72 69 70 " server " scrip
14c90 74 3d 22 20 73 63 72 69 70 74 20 22 20 70 61 67 t=" script " pag
14ca0 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 73 e=" page). (s
14cb0 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 69 66 tring-append (if
14cc0 20 28 6f 72 20 68 74 74 70 73 2d 68 6f 73 74 20 (or https-host
14cd0 66 6f 72 63 65 2d 73 73 6c 29 0a 09 09 20 20 20 force-ssl)...
14ce0 20 20 20 22 68 74 74 70 73 3a 2f 2f 22 0a 09 09 "https://"...
14cf0 20 20 20 20 20 20 22 68 74 74 70 3a 2f 2f 22 29 "http://")
14d00 0a 09 09 20 20 20 73 65 72 76 65 72 20 22 2f 22 ... server "/"
14d10 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 67 65 script "/" page
14d20 20 22 3f 22 20 70 61 72 61 6d 73 74 72 29 29 29 "?" paramstr)))
14d30 20 3b 3b 20 22 2f 73 6e 3d 22 20 73 65 73 73 69 ;; "/sn=" sessi
14d40 6f 6e 2d 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 on-key)))..(defi
14d50 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d ne (session:cgi-
14d60 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 out self). (let
14d70 2a 20 28 28 63 6f 6e 74 65 6e 74 20 20 28 6c 69 * ((content (li
14d80 73 74 20 28 73 64 61 74 2d 63 6f 6e 74 65 6e 74 st (sdat-content
14d90 2d 74 79 70 65 20 73 65 6c 66 29 29 29 20 3b 3b -type self))) ;;
14da0 20 27 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 '("Content-type
14db0 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 : text/html; cha
14dc0 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c rset=iso-8859-1\
14dd0 6e 5c 6e 22 29 29 0a 09 20 28 68 65 61 64 65 72 n\n")).. (header
14de0 20 20 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 (let ((cookie
14df0 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 2d 63 (sdat-session-c
14e00 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 ookie self)))...
14e10 20 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a (if cookie.
14e20 09 09 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e ... (cons (strin
14e30 67 2d 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f g-append "Set-Co
14e40 6f 6b 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f okie: " (car coo
14e50 6b 69 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 kie))....
14e60 63 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e content).... con
14e70 74 65 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 tent))).. (paged
14e80 61 74 20 20 28 73 64 61 74 2d 70 61 67 65 64 61 at (sdat-pageda
14e90 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 73 t self))). (s
14ea0 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 20 20 28 :cgi-out . (
14eb0 63 6f 6e 73 20 68 65 61 64 65 72 20 70 61 67 65 cons header page
14ec0 64 61 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 dat))))..(define
14ed0 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
14ee0 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 77 69 74 lf . msg). (wit
14ef0 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
14f00 20 28 73 64 61 74 2d 6c 6f 67 2d 70 6f 72 74 20 (sdat-log-port
14f10 73 65 6c 66 29 20 3b 3b 20 28 73 64 61 74 2d 6c self) ;; (sdat-l
14f20 6f 67 70 74 20 73 65 6c 66 29 0a 20 20 20 20 28 ogpt self). (
14f30 6c 61 6d 62 64 61 20 28 29 20 0a 20 20 20 20 20 lambda () .
14f40 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 6d 73 (apply print ms
14f50 67 29 29 29 29 0a 0a 3b 3b 20 65 73 63 61 70 65 g))))..;; escape
14f60 2c 20 63 6f 6e 76 65 72 74 20 6f 72 20 72 65 74 , convert or ret
14f70 75 72 6e 20 72 61 77 20 77 68 65 6e 20 67 69 76 urn raw when giv
14f80 65 6e 20 75 73 65 72 20 69 6e 70 75 74 20 64 61 en user input da
14f90 74 61 20 74 68 61 74 20 70 6f 74 65 6e 74 69 61 ta that potentia
14fa0 6c 6c 79 0a 3b 3b 20 63 6f 75 6c 64 20 62 65 20 lly.;; could be
14fb0 6d 61 6c 69 63 69 6f 75 73 0a 3b 3b 0a 28 64 65 malicious.;;.(de
14fc0 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 70 fine (session:ap
14fd0 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 ply-type-prefere
14fe0 6e 63 65 20 72 65 73 20 70 61 72 61 6d 73 29 0a nce res params).
14ff0 20 20 28 6c 65 74 2a 20 28 28 64 74 79 70 65 20 (let* ((dtype
15000 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 (if (null? pa
15010 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 20 27 rams)... '
15020 65 73 63 61 70 65 64 0a 09 09 20 20 20 20 20 20 escaped...
15030 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 0a (car params))).
15040 09 20 28 74 61 67 73 20 20 20 20 28 69 66 20 28 . (tags (if (
15050 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 null? params)...
15060 20 20 20 20 20 20 27 28 29 0a 09 09 20 20 20 20 '()...
15070 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 (cdr params)))
15080 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 79 70 ). (case dtyp
15090 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 20 20 e. ((raw)
150a0 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 28 28 res). ((
150b0 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 73 74 number) (if (st
150c0 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 69 6e ring? res)(strin
150d0 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 23 g->number res) #
150e0 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 63 61 f)). ((esca
150f0 70 65 64 29 20 28 69 66 20 28 73 74 72 69 6e 67 ped) (if (string
15100 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 ? res)... (s
15110 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 :html-filter->st
15120 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 0a 09 ring res tags)..
15130 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 . res)).
15140 20 20 28 28 65 73 63 61 70 65 64 2d 6e 6c 29 20 ((escaped-nl)
15150 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 (if (string? res
15160 29 20 3b 3b 20 65 73 63 61 70 65 20 5c 6e 20 61 ) ;; escape \n a
15170 6e 64 20 5c 72 0a 09 09 09 28 73 74 72 69 6e 67 nd \r....(string
15180 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 -intersperse....
15190 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 0a 09 (string-split..
151a0 09 09 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 .. (string-inte
151b0 72 73 70 65 72 73 65 0a 09 09 09 20 20 20 28 73 rsperse.... (s
151c0 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 73 3a 68 tring-split (s:h
151d0 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 tml-filter->stri
151e0 6e 67 20 72 65 73 20 74 61 67 73 29 20 22 5c 6e ng res tags) "\n
151f0 22 29 0a 09 09 09 20 20 20 22 5c 5c 6e 22 29 0a ").... "\\n").
15200 09 09 09 20 20 22 5c 72 22 29 0a 09 09 09 20 22 ... "\r").... "
15210 5c 5c 72 22 29 0a 09 09 09 72 65 73 29 29 20 3b \\r")....res)) ;
15220 3b 20 73 68 6f 75 6c 64 20 72 65 74 75 72 6e 20 ; should return
15230 23 66 20 69 66 20 6e 6f 74 20 61 20 73 74 72 69 #f if not a stri
15240 6e 67 20 61 6e 64 20 63 61 6e 27 74 20 65 73 63 ng and can't esc
15250 61 70 65 20 69 74 3f 0a 20 20 20 20 20 20 28 65 ape it?. (e
15260 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 73 74 lse (if (st
15270 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 ring? res)...
15280 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 (s:html-filter
15290 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 28 29 ->string res '()
152a0 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 29 29 )... res))))
152b0 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 65 )..#;(define (se
152c0 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d ssion:get-param-
152d0 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 from params key)
152e0 0a 20 20 28 6c 65 74 20 28 28 72 31 20 28 72 65 . (let ((r1 (re
152f0 67 65 78 70 20 28 63 6f 6e 63 20 22 5e 22 20 28 gexp (conc "^" (
15300 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
15310 79 29 20 22 3d 28 2e 2a 29 24 22 29 29 29 29 0a y) "=(.*)$")))).
15320 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 (if (null? p
15330 61 72 61 6d 73 29 20 23 66 0a 20 20 20 20 20 20 arams) #f.
15340 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
15350 61 64 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ad (car params))
15360 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
15370 20 20 20 20 28 74 61 69 6c 20 28 63 64 72 20 70 (tail (cdr p
15380 61 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 arams))).
15390 20 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 (let ((match
153a0 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 (string-match r1
153b0 20 68 65 61 64 29 29 29 0a 20 20 20 20 20 20 20 head))).
153c0 20 20 20 20 20 28 69 66 20 6d 61 74 63 68 0a 20 (if match.
153d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
153e0 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 list-ref match 1
153f0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
15400 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 (if (null? tai
15410 6c 29 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 l) #f.
15420 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
15430 28 63 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 (car tail)(cdr t
15440 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b ail)))))))))..;;
15450 20 70 61 72 61 6d 73 20 61 72 65 20 73 74 6f 72 params are stor
15460 65 64 20 61 73 20 6c 69 73 74 20 6f 66 20 6b 65 ed as list of ke
15470 79 3d 76 61 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 y=val.;;.(define
15480 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
15490 72 61 6d 20 73 65 6c 66 20 6b 65 79 20 74 79 70 ram self key typ
154a0 65 2d 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 e-params). ;; (
154b0 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 session:log s:se
154c0 73 73 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 ssion "params="
154d0 28 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 (slot-ref s:sess
154e0 69 6f 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 ion 'params)).
154f0 28 6c 65 74 2a 20 28 28 70 61 72 61 6d 73 20 28 (let* ((params (
15500 73 64 61 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 sdat-params self
15510 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 73 65 )).. (res (se
15520 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d ssion:get-param-
15530 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 from params key)
15540 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
15550 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 apply-type-prefe
15560 72 65 6e 63 65 20 72 65 73 20 74 79 70 65 2d 70 rence res type-p
15570 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 68 69 arams)))..;; Thi
15580 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 s one will get t
15590 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 he first value f
155a0 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 ound regardless
155b0 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 61 6d of form.;; param
155c0 3a 20 28 64 74 79 70 65 20 5b 74 61 67 31 20 74 : (dtype [tag1 t
155d0 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 79 ag2 ...]).;; dty
155e0 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 20 20 pe:.;; 'raw
155f0 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e 76 65 : do no conve
15600 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e 75 6d rsion.;; 'num
15610 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 20 74 ber : convert t
15620 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 72 6e o number, return
15630 20 23 66 20 69 66 20 66 61 69 6c 73 0a 3b 3b 20 #f if fails.;;
15640 20 20 20 27 65 73 63 61 70 65 64 20 3a 20 75 73 'escaped : us
15650 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 74 6f e html-escape to
15660 20 70 72 6f 74 65 63 74 20 74 68 65 20 69 6e 70 protect the inp
15670 75 74 20 2d 2d 20 74 68 69 73 20 69 73 20 74 68 ut -- this is th
15680 65 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 64 65 e default.;;.(de
15690 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
156a0 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 t-input self key
156b0 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a params). (let*
156c0 20 28 28 64 74 79 70 65 20 20 20 20 28 69 66 20 ((dtype (if
156d0 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 (null? params)..
156e0 09 20 20 20 20 20 20 20 27 65 73 63 61 70 65 64 . 'escaped
156f0 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 20 70 ... (car p
15700 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 73 arams))).. (tags
15710 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 (if (null? p
15720 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 27 arams)... '
15730 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 20 ()... (cdr
15740 70 61 72 61 6d 73 29 29 29 0a 09 20 28 66 6f 72 params))).. (for
15750 6d 64 61 74 20 28 73 64 61 74 2d 66 6f 72 6d 64 mdat (sdat-formd
15760 61 74 20 73 65 6c 66 29 29 0a 09 20 28 72 65 73 at self)).. (res
15770 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 6f (if (not fo
15780 72 6d 64 61 74 29 20 23 66 0a 09 09 20 20 20 20 rmdat) #f...
15790 20 20 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e (if (or (strin
157a0 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 3f 20 g? key)(number?
157b0 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 key)(symbol? key
157c0 29 29 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 )).... (if (and
157d0 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 61 (vector? formda
157e0 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c t)(eq? (vector-l
157f0 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 20 31 ength formdat) 1
15800 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 76 )(hash-table? (v
15810 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 61 ector-ref formda
15820 74 20 30 29 29 29 0a 09 09 09 20 20 20 20 20 20 t 0)))....
15830 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 6f 72 (formdat:get for
15840 6d 64 61 74 20 6b 65 79 29 0a 09 09 09 20 20 20 mdat key)....
15850 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 73 (begin.....(s
15860 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
15870 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a "ERROR: formdat:
15880 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 " formdat " is
15890 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f not of class <fo
158a0 72 6d 64 61 74 3e 22 29 0a 09 09 09 09 23 66 29 rmdat>").....#f)
158b0 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ).... (begin...
158c0 09 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c 6f . (session:lo
158d0 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 62 g self "ERROR: b
158e0 61 64 20 6b 65 79 20 22 20 6b 65 79 29 0a 09 09 ad key " key)...
158f0 09 20 20 20 20 23 66 29 29 29 29 29 0a 20 20 20 . #f))))).
15900 20 28 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 (case dtype.
15910 20 20 20 28 28 72 61 77 29 20 20 20 20 20 72 65 ((raw) re
15920 73 29 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 s). ((numbe
15930 72 29 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f r) (if (string?
15940 20 72 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 res)(string->nu
15950 6d 62 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 mber res) #f)).
15960 20 20 20 20 20 28 28 65 73 63 61 70 65 64 29 20 ((escaped)
15970 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 (if (string? res
15980 29 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c )... (s:html
15990 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 -filter->string
159a0 72 65 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 res tags)...
159b0 20 72 65 73 29 29 0a 20 20 20 20 20 20 28 65 6c res)). (el
159c0 73 65 20 20 20 20 20 20 28 69 66 20 28 73 74 72 se (if (str
159d0 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 ing? res)...
159e0 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d (s:html-filter-
159f0 3e 73 74 72 69 6e 67 20 72 65 73 20 27 28 29 29 >string res '())
15a00 0a 09 09 20 20 20 20 20 72 65 73 29 29 29 29 29 ... res)))))
15a10 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 77 69 ..;; This one wi
15a20 6c 6c 20 67 65 74 20 74 68 65 20 66 69 72 73 74 ll get the first
15a30 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 65 67 value found reg
15a40 61 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 6d 0a ardless of form.
15a50 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
15a60 3a 67 65 74 2d 69 6e 70 75 74 2d 6b 65 79 73 20 :get-input-keys
15a70 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 self). (let* ((
15a80 66 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 66 6f formdat (sdat-fo
15a90 72 6d 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 rmdat self))).
15aa0 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 64 (if (not formd
15ab0 61 74 29 20 23 66 0a 09 28 69 66 20 28 61 6e 64 at) #f..(if (and
15ac0 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d 64 61 (vector? formda
15ad0 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c t)(eq? (vector-l
15ae0 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 20 31 ength formdat) 1
15af0 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 76 )(hash-table? (v
15b00 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d 64 61 ector-ref formda
15b10 74 20 30 29 29 29 0a 09 20 20 20 20 28 66 6f 72 t 0))).. (for
15b20 6d 64 61 74 3a 6b 65 79 73 20 66 6f 72 6d 64 61 mdat:keys formda
15b30 74 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 t).. (begin..
15b40 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 6c (session:l
15b50 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 og self "ERROR:
15b60 66 6f 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 formdat: " formd
15b70 61 74 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 at " is not of c
15b80 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 lass <formdat>")
15b90 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 29 0a .. #f))))).
15ba0 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
15bb0 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 73 65 n:run-actions se
15bc0 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 63 lf). (let* ((ac
15bd0 74 69 6f 6e 20 20 20 20 28 73 65 73 73 69 6f 6e tion (session
15be0 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 6c 66 20 :get-param self
15bf0 27 61 63 74 69 6f 6e 20 27 28 72 61 77 29 29 29 'action '(raw)))
15c00 0a 09 20 28 70 61 67 65 20 20 20 20 20 20 28 73 .. (page (s
15c10 64 61 74 2d 70 61 67 65 20 73 65 6c 66 29 29 29 dat-page self)))
15c20 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
15c30 61 63 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 action=" action
15c40 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 " page=" page).
15c50 20 20 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 (if action..(
15c60 6c 65 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 let ((action-lst
15c70 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
15c80 61 63 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 action ".")))..
15c90 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 ;; (print "acti
15ca0 6f 6e 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d on-lst=" action-
15cb0 6c 73 74 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 lst).. (if (not
15cc0 20 28 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 69 (= (length acti
15cd0 6f 6e 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 20 on-lst) 2)) ..
15ce0 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 (err:log "Ac
15cf0 74 69 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f tion should be o
15d00 66 20 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 f form: module.a
15d10 63 74 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 ction").. (
15d20 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 67 65 let* ((targ-page
15d30 20 20 20 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c (car action-l
15d40 73 74 29 29 0a 09 09 20 20 20 20 20 28 70 72 6f st))... (pro
15d50 63 2d 6e 61 6d 65 20 20 20 28 73 74 72 69 6e 67 c-name (string
15d60 2d 61 70 70 65 6e 64 20 74 61 72 67 2d 70 61 67 -append targ-pag
15d70 65 20 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 e "-action"))...
15d80 20 20 20 20 20 28 74 61 72 67 2d 61 63 74 69 6f (targ-actio
15d90 6e 20 28 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c n (cadr action-l
15da0 73 74 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a st)))...;; (err:
15db0 6c 6f 67 20 22 74 61 72 67 2d 70 61 67 65 3d 22 log "targ-page="
15dc0 20 74 61 72 67 2d 70 61 67 65 20 22 20 70 72 6f targ-page " pro
15dd0 63 2d 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 c-name=" proc-na
15de0 6d 65 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e me " targ-action
15df0 3d 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a =" targ-action).
15e00 0a 09 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 ...;; call here
15e10 6f 6e 6c 79 20 69 66 20 6e 65 76 65 72 20 63 61 only if never ca
15e20 6c 6c 65 64 20 62 65 66 6f 72 65 0a 09 09 28 69 lled before...(i
15e30 66 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 f (session:never
15e40 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 -called-page? se
15e50 6c 66 20 74 61 72 67 2d 70 61 67 65 29 0a 09 09 lf targ-page)...
15e60 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c (session:cal
15e70 6c 2d 70 61 72 74 73 20 73 65 6c 66 20 74 61 72 l-parts self tar
15e80 67 2d 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 g-page 'control)
15e90 29 0a 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 )...;;
15ea0 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 20 20 proc
15eb0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15ec0 20 20 20 20 20 20 20 61 63 74 69 6f 6e 20 20 20 action
15ed0 20 0a 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 73 ....(if #t ;; s
15ee0 65 74 20 74 6f 20 23 74 20 74 6f 20 73 65 65 20 et to #t to see
15ef0 62 65 74 74 65 72 20 65 72 72 6f 72 20 6d 65 73 better error mes
15f00 73 61 67 65 73 20 64 75 72 69 6e 67 20 64 65 62 sages during deb
15f10 75 67 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 uggin :-)...
15f20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((eval (string->
15f30 73 79 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 symbol proc-name
15f40 29 29 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 )) targ-action)
15f50 3b 3b 20 75 6e 73 61 66 65 20 65 78 65 63 75 74 ;; unsafe execut
15f60 69 6f 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 ion... (condi
15f70 74 69 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 6c tion-case ((eval
15f80 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
15f90 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 proc-name)) tar
15fa0 67 2d 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 g-action).....
15fb0 20 20 28 28 65 78 6e 20 66 69 6c 65 29 20 28 73 ((exn file) (s
15fc0 3a 6c 6f 67 20 22 66 69 6c 65 20 65 72 72 6f 72 :log "file error
15fd0 22 29 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 "))..... ((ex
15fe0 6e 20 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 n i/o) (s:log "
15ff0 69 2f 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 09 i/o error"))....
16000 09 20 20 20 20 28 28 65 78 6e 20 29 20 20 20 20 . ((exn )
16010 20 28 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 (s:log "Action
16020 6e 6f 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a not implemented:
16030 20 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 " proc-name " a
16040 63 74 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 ction: " targ-ac
16050 74 69 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 28 tion))..... (
16060 76 61 72 20 28 29 20 20 20 20 20 28 73 3a 6c 6f var () (s:lo
16070 67 20 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 g "Unknown Error
16080 22 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 "))))))))))..(de
16090 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 fine (session:ne
160a0 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f ver-called-page?
160b0 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 self page). (s
160c0 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 ession:log self
160d0 22 43 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 "Checking for pa
160e0 67 65 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e ge: " page). (n
160f0 6f 74 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 ot (member page
16100 28 73 64 61 74 2d 73 65 65 6e 2d 70 61 67 65 73 (sdat-seen-pages
16110 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 self))))..(defi
16120 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d ne (session:set-
16130 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 called! self pag
16140 65 29 0a 20 20 28 73 64 61 74 2d 73 65 65 6e 2d e). (sdat-seen-
16150 70 61 67 65 73 2d 73 65 74 21 20 73 65 6c 66 20 pages-set! self
16160 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 61 74 (cons page (sdat
16170 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 6c 66 -seen-pages self
16180 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
16190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
161a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
161b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
161c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
161d0 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 20 64 61 ; Alternative da
161e0 74 61 20 74 79 70 65 20 64 65 6c 69 76 65 72 79 ta type delivery
161f0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
16200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16220 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16230 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
16240 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d ne (session:alt-
16250 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 out self). (let
16260 20 28 28 64 61 74 20 28 73 64 61 74 2d 61 6c 74 ((dat (sdat-alt
16270 2d 70 61 67 65 2d 64 61 74 20 73 65 6c 66 29 29 -page-dat self))
16280 29 0a 20 20 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 ). ;; (s:log
16290 22 64 61 74 20 69 73 3a 20 22 20 64 61 74 29 0a "dat is: " dat).
162a0 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 48 ;; (print "H
162b0 54 54 50 2f 31 2e 31 20 32 30 30 20 4f 4b 22 29 TTP/1.1 200 OK")
162c0 0a 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 . (print "Dat
162d0 65 3a 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 e: " (time->stri
162e0 6e 67 20 28 73 65 63 6f 6e 64 73 2d 3e 75 74 63 ng (seconds->utc
162f0 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
16300 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 28 econds)))). (
16310 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 54 print "Content-T
16320 79 70 65 3a 20 22 20 28 73 64 61 74 2d 63 6f 6e ype: " (sdat-con
16330 74 65 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 tent-type self))
16340 0a 20 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 . (print "Acc
16350 65 70 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 ept-Ranges: byte
16360 73 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 s"). (print "
16370 43 6f 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 Content-Length:
16380 22 20 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 " (if (blob? dat
16390 29 0a 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 )..... (blob-si
163a0 7a 65 20 64 61 74 29 0a 09 09 09 09 20 20 30 29 ze dat)..... 0)
163b0 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 4b 65 ). (print "Ke
163c0 65 70 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 ep-Alive: timeou
163d0 74 3d 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a t=15, max=100").
163e0 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e (print "Conn
163f0 65 63 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 ection: Keep-Ali
16400 76 65 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 ve"). (print
16410 22 22 29 0a 20 20 20 20 28 77 72 69 74 65 2d 73 ""). (write-s
16420 74 72 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 tring (blob->str
16430 69 6e 67 20 64 61 74 29 20 23 66 20 28 63 75 72 ing dat) #f (cur
16440 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 rent-output-port
16450 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
16460 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16470 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16480 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16490 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
164a0 3b 20 4f 72 70 68 61 6e 65 64 20 66 75 6e 63 74 ; Orphaned funct
164b0 69 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ions.;;=========
164c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
164d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
164e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
164f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
16500 3b 20 77 61 73 20 69 6e 20 73 65 74 75 70 0a 3b ; was in setup.;
16510 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 6c 6f 67 ;.(define (s:log
16520 20 2e 20 6d 73 67 29 0a 20 20 28 61 70 70 6c 79 . msg). (apply
16530 20 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 session:log s:s
16540 65 73 73 69 6f 6e 20 6d 73 67 29 29 0a 0a 0a 3b ession msg))...;
16550 3b 20 55 73 61 67 65 3a 20 28 73 3a 67 65 74 2d ; Usage: (s:get-
16560 65 72 72 20 73 3a 62 69 67 29 0a 28 64 65 66 69 err s:big).(defi
16570 6e 65 20 28 73 3a 67 65 74 2d 65 72 72 20 77 72 ne (s:get-err wr
16580 61 70 70 65 72 66 75 6e 63 29 0a 20 20 28 6c 65 apperfunc). (le
16590 74 20 28 28 65 72 72 6d 73 67 20 28 73 64 61 74 t ((errmsg (sdat
165a0 2d 63 75 72 72 2d 65 72 72 20 73 3a 73 65 73 73 -curr-err s:sess
165b0 69 6f 6e 29 29 29 0a 20 20 20 20 28 69 66 20 65 ion))). (if e
165c0 72 72 6d 73 67 20 28 28 69 66 20 77 72 61 70 70 rrmsg ((if wrapp
165d0 65 72 66 75 6e 63 0a 20 20 20 20 20 20 20 20 20 erfunc.
165e0 20 20 20 20 20 20 20 20 20 20 20 77 72 61 70 70 wrapp
165f0 65 72 66 75 6e 63 0a 20 20 20 20 20 20 20 20 20 erfunc.
16600 20 20 20 20 20 20 20 20 20 20 20 73 3a 73 74 72 s:str
16610 6f 6e 67 29 20 65 72 72 6d 73 67 29 20 27 28 29 ong) errmsg) '()
16620 29 29 29 0a 28 64 65 66 69 6e 65 20 28 73 74 6d ))).(define (stm
16630 6c 3a 63 67 69 2d 73 65 73 73 69 6f 6e 20 73 65 l:cgi-session se
16640 73 73 69 6f 6e 29 0a 20 20 3b 3b 20 28 73 65 73 ssion). ;; (ses
16650 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 sion:initialize
16660 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 session). (sess
16670 69 6f 6e 3a 73 65 74 75 70 20 73 65 73 73 69 6f ion:setup sessio
16680 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 n). (session:ge
16690 74 2d 76 61 72 73 20 73 65 73 73 69 6f 6e 29 0a t-vars session).
166a0 0a 20 20 28 73 64 61 74 2d 6c 6f 67 2d 70 6f 72 . (sdat-log-por
166b0 74 2d 73 65 74 21 20 73 65 73 73 69 6f 6e 20 3b t-set! session ;
166c0 3b 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 ; (current-error
166d0 2d 70 6f 72 74 29 29 0a 09 09 20 20 20 20 20 20 -port))...
166e0 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c (open-output-fil
166f0 65 20 28 73 64 61 74 2d 6c 6f 67 66 69 6c 65 20 e (sdat-logfile
16700 73 65 73 73 69 6f 6e 29 20 23 3a 61 70 70 65 6e session) #:appen
16710 64 29 29 0a 20 20 28 73 3a 76 61 6c 69 64 61 74 d)). (s:validat
16720 65 2d 69 6e 70 75 74 73 29 0a 20 20 28 73 65 73 e-inputs). (ses
16730 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 sion:run-actions
16740 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 64 61 session). (sda
16750 74 2d 70 61 67 65 64 61 74 2d 73 65 74 21 20 73 t-pagedat-set! s
16760 65 73 73 69 6f 6e 0a 09 09 20 20 20 20 20 28 61 ession... (a
16770 70 70 65 6e 64 20 28 73 64 61 74 2d 70 61 67 65 ppend (sdat-page
16780 64 61 74 20 73 65 73 73 69 6f 6e 29 0a 09 09 09 dat session)....
16790 20 20 20 20 20 28 73 3a 63 61 6c 6c 20 28 73 64 (s:call (sd
167a0 61 74 2d 74 6f 70 70 61 67 65 20 73 65 73 73 69 at-toppage sessi
167b0 6f 6e 29 29 29 29 0a 20 20 28 69 66 20 28 65 71 on)))). (if (eq
167c0 3f 20 28 73 64 61 74 2d 70 61 67 65 2d 74 79 70 ? (sdat-page-typ
167d0 65 20 73 65 73 73 69 6f 6e 29 20 27 68 74 6d 6c e session) 'html
167e0 29 20 3b 3b 20 64 65 66 61 75 6c 74 20 69 73 20 ) ;; default is
167f0 68 74 6d 6c 2e 20 0a 20 20 20 20 20 20 28 73 65 html. . (se
16800 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 ssion:cgi-out se
16810 73 73 69 6f 6e 29 0a 20 20 20 20 20 20 28 73 65 ssion). (se
16820 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 ssion:alt-out se
16830 73 73 69 6f 6e 29 29 0a 20 20 28 73 65 73 73 69 ssion)). (sessi
16840 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 73 on:save-vars ses
16850 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e sion). (session
16860 3a 63 6c 6f 73 65 20 73 65 73 73 69 6f 6e 29 29 :close session))
16870 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 76 61 ...(define (s:va
16880 6c 69 64 61 74 65 2d 69 6e 70 75 74 73 29 0a 20 lidate-inputs).
16890 20 28 69 66 20 28 6e 6f 74 20 28 73 3a 76 61 6c (if (not (s:val
168a0 69 64 61 74 65 2d 75 72 69 29 29 0a 20 20 20 20 idate-uri)).
168b0 20 20 28 62 65 67 69 6e 20 28 73 3a 65 72 72 6f (begin (s:erro
168c0 72 2d 70 61 67 65 20 22 42 61 64 20 55 52 49 22 r-page "Bad URI"
168d0 20 28 6c 65 74 20 28 28 72 65 66 20 28 67 65 74 (let ((ref (get
168e0 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
168f0 69 61 62 6c 65 20 22 48 54 54 50 5f 52 45 46 45 iable "HTTP_REFE
16900 52 45 52 22 29 29 29 0a 09 09 09 09 20 20 20 20 RER"))).....
16910 20 20 20 28 69 66 20 72 65 66 0a 09 09 09 09 09 (if ref......
16920 20 20 20 28 6c 69 73 74 20 22 72 65 66 65 72 72 (list "referr
16930 65 64 20 66 72 6f 6d 22 20 72 65 66 29 0a 09 09 ed from" ref)...
16940 09 09 09 20 20 20 22 22 29 29 29 0a 09 20 20 20 ... "")))..
16950 20 20 28 65 78 69 74 29 29 29 29 0a 0a 28 64 65 (exit))))..(de
16960 66 69 6e 65 20 28 73 3a 65 72 72 6f 72 2d 70 61 fine (s:error-pa
16970 67 65 20 2e 20 65 72 72 29 0a 20 20 28 73 3a 63 ge . err). (s:c
16980 67 69 2d 6f 75 74 20 28 63 6f 6e 73 20 22 43 6f gi-out (cons "Co
16990 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 ntent-type: text
169a0 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 /html; charset=i
169b0 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 0a 09 so-8859-1\n\n"..
169c0 09 20 20 20 28 73 3a 68 74 6d 6c 20 28 73 3a 68 . (s:html (s:h
169d0 65 61 64 20 0a 09 09 09 20 20 20 20 28 73 3a 74 ead .... (s:t
169e0 69 74 6c 65 20 65 72 72 29 0a 09 09 09 20 20 20 itle err)....
169f0 20 28 73 3a 62 6f 64 79 0a 09 09 09 20 20 20 20 (s:body....
16a00 20 28 73 3a 68 31 20 22 45 52 52 4f 52 22 29 0a (s:h1 "ERROR").
16a10 09 09 09 20 20 20 20 20 28 73 3a 70 20 65 72 72 ... (s:p err
16a20 29 29 29 29 29 29 29 20 20 20 20 20 20 20 20 20 )))))))
16a30 20 20 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 ...(define (st
16a40 6d 6c 3a 6d 61 69 6e 20 70 72 6f 63 29 0a 20 20 ml:main proc).
16a50 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
16a60 6e 73 0a 20 20 20 65 78 6e 20 20 20 0a 20 20 20 ns. exn .
16a70 28 69 66 20 28 73 64 61 74 2d 64 65 62 75 67 2d (if (sdat-debug-
16a80 6d 6f 64 65 20 73 3a 73 65 73 73 69 6f 6e 29 0a mode s:session).
16a90 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 (begin..
16aa0 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d (print "Content-
16ab0 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 22 type: text/html"
16ac0 29 0a 09 20 28 70 72 69 6e 74 20 22 22 29 0a 09 ).. (print "")..
16ad0 20 28 70 72 69 6e 74 20 22 3c 68 74 6d 6c 3e 20 (print "<html>
16ae0 3c 68 65 61 64 3e 20 3c 74 69 74 6c 65 3e 45 58 <head> <title>EX
16af0 43 45 50 54 49 4f 4e 3c 2f 74 69 74 6c 65 3e 20 CEPTION</title>
16b00 3c 2f 68 65 61 64 3e 20 3c 62 6f 64 79 3e 22 29 </head> <body>")
16b10 0a 09 20 28 70 72 69 6e 74 20 22 20 20 20 51 55 .. (print " QU
16b20 45 52 59 5f 53 54 52 49 4e 47 20 69 73 3a 20 3c ERY_STRING is: <
16b30 62 3e 20 22 20 28 67 65 74 2d 65 6e 76 69 72 6f b> " (get-enviro
16b40 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
16b50 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 20 22 QUERY_STRING") "
16b60 20 3c 2f 62 3e 20 3c 62 72 3e 22 29 0a 09 20 28 </b> <br>").. (
16b70 70 72 69 6e 74 20 22 3c 70 72 65 3e 22 29 0a 09 print "<pre>")..
16b80 20 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 20 45 ;; (print " E
16b90 58 43 45 50 54 49 4f 4e 3a 20 22 20 28 28 63 6f XCEPTION: " ((co
16ba0 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
16bb0 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
16bc0 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 message) exn))..
16bd0 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 (print-error-me
16be0 73 73 61 67 65 20 65 78 6e 29 0a 09 20 28 70 72 ssage exn).. (pr
16bf0 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a int-call-chain).
16c00 09 20 28 70 72 69 6e 74 20 22 3c 2f 70 72 65 3e . (print "</pre>
16c10 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 74 61 ").. (print "<ta
16c20 62 6c 65 3e 22 29 0a 09 20 28 66 6f 72 2d 65 61 ble>").. (for-ea
16c30 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 29 ch (lambda (var)
16c40 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ... (print "
16c50 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 76 <tr><td>" (car v
16c60 61 72 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 ar) "</td><td>"
16c70 28 63 64 72 20 76 61 72 29 20 22 3c 2f 74 64 3e (cdr var) "</td>
16c80 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 20 28 67 </tr>"))... (g
16c90 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
16ca0 61 72 69 61 62 6c 65 73 29 29 0a 09 20 28 70 72 ariables)).. (pr
16cb0 69 6e 74 20 22 3c 2f 74 61 62 6c 65 3e 22 29 0a int "</table>").
16cc0 09 20 28 70 72 69 6e 74 20 22 3c 2f 62 6f 64 79 . (print "</body
16cd0 3e 3c 2f 68 74 6d 6c 3e 22 29 29 0a 20 20 20 20 ></html>")).
16ce0 20 20 20 28 62 65 67 69 6e 0a 09 20 28 77 69 74 (begin.. (wit
16cf0 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
16d00 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 73 74 6d (conc "/tmp/stm
16d10 6c 2d 63 72 61 73 68 2d 22 20 28 63 75 72 72 65 l-crash-" (curre
16d20 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 nt-process-id) "
16d30 2e 6c 6f 67 22 29 0a 09 20 20 20 28 6c 61 6d 62 .log").. (lamb
16d40 64 61 20 28 29 0a 09 20 20 20 20 20 28 70 72 69 da ().. (pri
16d50 6e 74 20 22 45 58 43 45 50 54 49 4f 4e 22 29 0a nt "EXCEPTION").
16d60 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 20 20 . (print "
16d70 20 51 55 45 52 59 5f 53 54 52 49 4e 47 20 69 73 QUERY_STRING is
16d80 3a 20 22 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e : " (get-environ
16d90 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 51 ment-variable "Q
16da0 55 45 52 59 5f 53 54 52 49 4e 47 22 29 20 29 0a UERY_STRING") ).
16db0 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 . (print "")
16dc0 0a 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 .. ;; (print
16dd0 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 20 " EXCEPTION:
16de0 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
16df0 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
16e00 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
16e10 78 6e 29 29 0a 09 20 20 20 20 20 28 70 72 69 6e xn)).. (prin
16e20 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 t-error-message
16e30 65 78 6e 29 0a 09 20 20 20 20 20 28 70 72 69 6e exn).. (prin
16e40 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 09 20 t-call-chain)..
16e50 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 09 (print "")..
16e60 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
16e70 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 09 09 lambda (var)....
16e80 20 28 70 72 69 6e 74 20 28 63 61 72 20 76 61 72 (print (car var
16e90 29 20 22 5c 74 22 20 28 63 64 72 20 76 61 72 29 ) "\t" (cdr var)
16ea0 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 65 74 ))... (get
16eb0 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
16ec0 69 61 62 6c 65 73 29 29 29 29 0a 09 20 3b 3b 20 iables)))).. ;;
16ed0 72 65 74 75 72 6e 20 73 6f 6d 65 74 68 69 6e 67 return something
16ee0 20 75 73 65 66 75 6c 20 74 6f 20 74 68 65 20 75 useful to the u
16ef0 73 65 72 0a 09 20 28 70 72 69 6e 74 20 22 43 6f ser.. (print "Co
16f00 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 ntent-type: text
16f10 2f 68 74 6d 6c 22 29 0a 09 20 28 70 72 69 6e 74 /html").. (print
16f20 20 22 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c "").. (print "<
16f30 68 74 6d 6c 3e 20 3c 68 65 61 64 3e 20 3c 74 69 html> <head> <ti
16f40 74 6c 65 3e 45 58 43 45 50 54 49 4f 4e 3c 2f 74 tle>EXCEPTION</t
16f50 69 74 6c 65 3e 20 3c 2f 68 65 61 64 3e 20 3c 62 itle> </head> <b
16f60 6f 64 79 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 ody>").. (print
16f70 22 3c 68 31 3e 43 52 41 53 48 21 3c 2f 68 31 3e "<h1>CRASH!</h1>
16f80 22 29 0a 09 20 28 70 72 69 6e 74 20 22 20 20 20 ").. (print "
16f90 50 6c 65 61 73 65 20 6e 6f 74 69 66 79 20 73 75 Please notify su
16fa0 70 70 6f 72 74 20 61 74 20 22 20 28 73 64 61 74 pport at " (sdat
16fb0 2d 64 6f 6d 61 69 6e 20 73 3a 73 65 73 73 69 6f -domain s:sessio
16fc0 6e 29 20 22 20 74 68 61 74 20 74 68 65 20 65 72 n) " that the er
16fd0 72 6f 72 20 6c 6f 67 20 69 73 20 73 74 6d 6c 2d ror log is stml-
16fe0 63 72 61 73 68 2d 22 20 28 63 75 72 72 65 6e 74 crash-" (current
16ff0 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2e 6c -process-id) ".l
17000 6f 67 3c 2f 62 3e 20 3c 62 72 3e 22 29 0a 09 20 og</b> <br>")..
17010 3b 3b 20 28 70 72 69 6e 74 20 22 3c 70 72 65 3e ;; (print "<pre>
17020 22 29 0a 09 20 3b 3b 20 3b 3b 20 28 70 72 69 6e ").. ;; ;; (prin
17030 74 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e 3a t " EXCEPTION:
17040 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
17050 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
17060 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
17070 65 78 6e 29 29 0a 09 20 3b 3b 20 3b 3b 20 28 70 exn)).. ;; ;; (p
17080 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 rint-error-messa
17090 67 65 20 65 78 6e 29 0a 09 20 3b 3b 20 3b 3b 20 ge exn).. ;; ;;
170a0 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
170b0 6e 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 n).. ;; (print "
170c0 3c 2f 70 72 65 3e 22 29 0a 09 20 3b 3b 20 28 70 </pre>").. ;; (p
170d0 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 22 29 0a rint "<table>").
170e0 09 20 3b 3b 20 28 66 6f 72 2d 65 61 63 68 20 28 . ;; (for-each (
170f0 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 20 3b lambda (var).. ;
17100 3b 20 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ; . (print "
17110 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 76 <tr><td>" (car v
17120 61 72 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 ar) "</td><td>"
17130 28 63 64 72 20 76 61 72 29 20 22 3c 2f 74 64 3e (cdr var) "</td>
17140 3c 2f 74 72 3e 22 29 29 0a 09 20 3b 3b 20 09 20 </tr>")).. ;; .
17150 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
17160 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 09 nt-variables))..
17170 20 3b 3b 20 28 70 72 69 6e 74 20 22 3c 2f 74 61 ;; (print "</ta
17180 62 6c 65 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 ble>").. (print
17190 22 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 "</body></html>"
171a0 29 29 29 0a 20 20 20 28 69 66 20 70 72 6f 63 20 ))). (if proc
171b0 28 70 72 6f 63 20 73 3a 73 65 73 73 69 6f 6e 29 (proc s:session)
171c0 20 28 73 74 6d 6c 3a 63 67 69 2d 73 65 73 73 69 (stml:cgi-sessi
171d0 6f 6e 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a 20 on s:session)).
171e0 3b 3b 20 28 72 61 69 73 65 2d 65 72 72 6f 72 29 ;; (raise-error)
171f0 0a 20 3b 3b 20 28 65 78 69 74 29 0a 20 20 20 29 . ;; (exit). )
17200 29 0a 0a 3b 3b 20 66 69 6e 64 20 6f 75 74 20 69 )..;; find out i
17210 66 20 77 65 20 61 72 65 20 69 6e 20 64 65 62 75 f we are in debu
17220 67 6d 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 73 gmode.(define (s
17230 3a 64 65 62 75 67 2d 6d 6f 64 65 3f 29 0a 20 20 :debug-mode?).
17240 28 73 64 61 74 2d 64 65 62 75 67 2d 6d 6f 64 65 (sdat-debug-mode
17250 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a 0a 28 64 s:session))..(d
17260 65 66 69 6e 65 20 28 73 3a 6e 65 76 65 72 2d 63 efine (s:never-c
17270 61 6c 6c 65 64 2d 70 61 67 65 3f 20 70 61 67 65 alled-page? page
17280 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 ). (session:nev
17290 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 er-called-page?
172a0 73 3a 73 65 73 73 69 6f 6e 20 70 61 67 65 29 29 s:session page))
172b0 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 65 74 ..(define (s:set
172c0 2d 65 72 72 20 2e 20 61 72 67 73 29 0a 20 20 28 -err . args). (
172d0 73 64 61 74 2d 63 75 72 72 2d 65 72 72 2d 73 65 sdat-curr-err-se
172e0 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 61 72 67 t! s:session arg
172f0 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a s))..(define (s:
17300 63 75 72 72 65 6e 74 2d 70 61 67 65 29 0a 20 20 current-page).
17310 28 73 64 61 74 2d 70 61 67 65 20 73 3a 73 65 73 (sdat-page s:ses
17320 73 69 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 sion))..(define
17330 28 73 3a 64 65 6c 65 74 65 2d 73 65 73 73 69 6f (s:delete-sessio
17340 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 64 65 n). (session:de
17350 6c 65 74 65 2d 73 65 73 73 69 6f 6e 20 73 3a 73 lete-session s:s
17360 65 73 73 69 6f 6e 20 28 73 64 61 74 2d 73 65 73 ession (sdat-ses
17370 73 69 6f 6e 2d 6b 65 79 20 73 3a 73 65 73 73 69 sion-key s:sessi
17380 6f 6e 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 on)))..(define (
17390 73 3a 63 61 6c 6c 20 70 61 67 65 20 2e 20 70 61 s:call page . pa
173a0 72 74 73 6c 29 0a 20 20 28 69 66 20 28 6e 75 6c rtsl). (if (nul
173b0 6c 3f 20 70 61 72 74 73 6c 29 0a 20 20 20 20 20 l? partsl).
173c0 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 (session:call s
173d0 3a 73 65 73 73 69 6f 6e 20 70 61 67 65 20 23 66 :session page #f
173e0 29 0a 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e ). (session
173f0 3a 63 61 6c 6c 20 73 3a 73 65 73 73 69 6f 6e 20 :call s:session
17400 70 61 67 65 20 28 63 61 72 20 70 61 72 74 73 6c page (car partsl
17410 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
17420 3a 6c 69 6e 6b 2d 74 6f 20 70 61 67 65 20 2e 20 :link-to page .
17430 70 61 72 61 6d 73 29 0a 20 20 28 73 65 73 73 69 params). (sessi
17440 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 3a 73 65 73 on:link-to s:ses
17450 73 69 6f 6e 20 70 61 67 65 20 70 61 72 61 6d 73 sion page params
17460 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 ))..(define (s:g
17470 65 74 2d 70 61 72 61 6d 20 6b 65 79 20 2e 20 74 et-param key . t
17480 79 70 65 2d 70 61 72 61 6d 73 29 0a 20 20 28 73 ype-params). (s
17490 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d ession:get-param
174a0 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 20 74 s:session key t
174b0 79 70 65 2d 70 61 72 61 6d 73 29 29 0a 0a 3b 3b ype-params))..;;
174c0 20 74 68 65 73 65 20 61 72 65 20 70 61 67 65 20 these are page
174d0 6c 6f 63 61 6c 0a 28 64 65 66 69 6e 65 20 28 73 local.(define (s
174e0 3a 67 65 74 20 6b 65 79 29 20 0a 20 20 28 73 65 :get key) . (se
174f0 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 ssion:page-get s
17500 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 0a 0a :session key))..
17510 28 64 65 66 69 6e 65 20 28 73 3a 73 65 74 21 20 (define (s:set!
17520 6b 65 79 20 76 61 6c 29 0a 20 20 28 73 65 73 73 key val). (sess
17530 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 65 ion:curr-page-se
17540 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 t! s:session key
17550 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 val))..(define
17560 28 73 3a 64 65 6c 21 20 6b 65 79 29 0a 20 20 28 (s:del! key). (
17570 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 76 61 72 session:page-var
17580 2d 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 -del! s:session
17590 6b 65 79 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 key))..#;(define
175a0 20 28 73 3a 67 65 74 2d 6e 2d 64 65 6c 21 20 6b (s:get-n-del! k
175b0 65 79 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c ey). (let ((val
175c0 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 (session:page-g
175d0 65 74 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 et s:session key
175e0 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
175f0 3a 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 :del! s:session
17600 76 61 6c 20 6b 65 79 29 0a 20 20 20 20 76 61 6c val key). val
17610 29 29 0a 0a 3b 3b 20 74 68 65 73 65 20 61 72 65 ))..;; these are
17620 20 73 65 73 73 69 6f 6e 20 77 69 64 65 0a 28 64 session wide.(d
17630 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e efine (s:session
17640 2d 76 61 72 2d 67 65 74 20 6b 65 79 20 2e 20 70 -var-get key . p
17650 61 72 61 6d 73 29 20 0a 20 20 28 73 65 73 73 69 arams) . (sessi
17660 6f 6e 3a 67 65 74 20 73 3a 73 65 73 73 69 6f 6e on:get s:session
17670 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
17680 20 6b 65 79 20 70 61 72 61 6d 73 29 29 0a 0a 28 key params))..(
17690 64 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f define (s:sessio
176a0 6e 2d 76 61 72 2d 73 65 74 21 20 6b 65 79 20 76 n-var-set! key v
176b0 61 6c 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 al). (session:s
176c0 65 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 22 2a et! s:session "*
176d0 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6b 65 sessionvars*" ke
176e0 79 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 y val))..(define
176f0 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d (s:session-var-
17700 67 65 74 2d 6e 2d 64 65 6c 21 20 6b 65 79 29 0a get-n-del! key).
17710 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 73 65 (let ((val (se
17720 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 ssion:page-get s
17730 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 29 0a :session key))).
17740 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 64 65 (session:de
17750 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 22 2a 73 l! s:session "*s
17760 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6b 65 79 essionvars*" key
17770 29 0a 20 20 20 20 20 76 61 6c 29 29 0a 0a 28 64 ). val))..(d
17780 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e efine (s:session
17790 2d 76 61 72 2d 64 65 6c 21 20 6b 65 79 29 0a 20 -var-del! key).
177a0 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 73 (session:del! s
177b0 3a 73 65 73 73 69 6f 6e 20 22 2a 73 65 73 73 69 :session "*sessi
177c0 6f 6e 76 61 72 73 2a 22 20 6b 65 79 29 29 0a 0a onvars*" key))..
177d0 28 64 65 66 69 6e 65 20 73 3a 73 65 73 73 69 6f (define s:sessio
177e0 6e 2d 76 61 72 2d 64 65 6c 65 74 65 21 20 73 3a n-var-delete! s:
177f0 73 65 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c 21 session-var-del!
17800 29 0a 0a 3b 3b 20 75 74 69 6c 69 74 79 20 74 6f )..;; utility to
17810 20 67 65 74 20 61 6c 6c 20 76 61 72 73 20 61 73 get all vars as
17820 20 68 61 73 68 20 74 61 62 6c 65 0a 28 64 65 66 hash table.(def
17830 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e 2d 67 ine (s:session-g
17840 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 29 0a et-sessionvars).
17850 20 20 28 73 64 61 74 2d 73 65 73 73 69 6f 6e 76 (sdat-sessionv
17860 61 72 73 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a ars s:session)).
17870 0a 29 0a .).