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 29 0a 0a 3b 3b 20 28 64 65 63 6c t c:))..;; (decl
0230: 61 72 65 20 28 75 73 65 73 20 6d 69 73 63 2d 73 are (uses misc-s
0240: 74 6d 6c 29 29 0a 28 75 73 65 20 72 65 67 65 78 tml)).(use regex
0250: 29 0a 0a 3b 3b 20 65 78 74 72 61 63 74 20 76 61 )..;; extract va
0260: 72 69 6f 75 73 20 74 6f 6b 65 6e 73 20 66 72 6f rious tokens fro
0270: 6d 20 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 m the parameter
0280: 6c 69 73 74 0a 3b 3b 20 20 20 27 6b 65 79 20 76 list.;; 'key v
0290: 61 6c 20 3d 3e 20 70 75 74 20 69 6e 20 74 68 65 al => put in the
02a0: 20 70 61 72 61 6d 73 20 6c 69 73 74 0a 3b 3b 20 params list.;;
02b0: 20 20 73 74 72 69 6e 67 73 20 20 3d 3e 20 6d 61 strings => ma
02c0: 69 6e 74 61 69 6e 20 6f 72 64 65 72 20 61 6e 64 intain order and
02d0: 20 61 64 64 20 74 6f 20 74 68 65 20 64 61 74 61 add to the data
02e0: 6c 69 73 74 20 3c 3c 3d 3d 20 49 4d 50 4f 52 54 list <<== IMPORT
02f0: 41 4e 54 0a 28 64 65 66 69 6e 65 20 28 73 3a 65 ANT.(define (s:e
0300: 78 74 72 61 63 74 20 69 6e 6c 73 74 29 0a 20 20 xtract inlst).
0310: 28 69 66 20 28 6e 75 6c 6c 3f 20 69 6e 6c 73 74 (if (null? inlst
0320: 29 20 69 6e 6c 73 74 0a 20 20 20 20 20 20 28 6c ) inlst. (l
0330: 65 74 20 6c 6f 6f 70 20 28 28 64 61 74 61 20 27 et loop ((data '
0340: 28 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ()).
0350: 20 20 20 20 20 28 70 61 72 61 6d 73 20 27 28 29 (params '()
0360: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0370: 20 20 20 28 68 65 61 64 20 28 63 61 72 20 69 6e (head (car in
0380: 6c 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 lst)).
0390: 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 (tail (cd
03a0: 72 20 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 20 r inlst))).
03b0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 68 65 ;; (print "he
03c0: 61 64 3d 22 20 68 65 61 64 20 22 20 74 61 69 6c ad=" head " tail
03d0: 3d 22 20 74 61 69 6c 29 0a 20 20 20 20 20 20 20 =" tail).
03e0: 20 28 63 6f 6e 64 20 0a 20 20 20 20 20 20 20 20 (cond .
03f0: 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 ((null? tail).
0400: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 73 79 (if (sy
0410: 6d 62 6f 6c 3f 20 68 65 61 64 29 20 3b 3b 20 74 mbol? head) ;; t
0420: 68 65 20 6c 61 73 74 20 69 74 65 6d 20 69 73 20 he last item is
0430: 61 20 70 61 72 61 6d 20 2d 20 62 6f 72 6b 65 64 a param - borked
0440: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
0450: 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 70 61 s:log "ERROR: pa
0460: 72 61 6d 20 77 69 74 68 20 6e 6f 20 76 61 6c 75 ram with no valu
0470: 65 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 e")). (
0480: 6c 69 73 74 20 28 61 70 70 65 6e 64 20 64 61 74 list (append dat
0490: 61 20 28 6c 69 73 74 20 28 73 3a 61 6e 79 2d 3e a (list (s:any->
04a0: 73 74 72 69 6e 67 20 68 65 61 64 29 29 29 20 70 string head))) p
04b0: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
04c0: 20 28 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 68 ((or (string? h
04d0: 65 61 64 29 28 6c 69 73 74 3f 20 68 65 61 64 29 ead)(list? head)
04e0: 28 6e 75 6d 62 65 72 3f 20 68 65 61 64 29 29 0a (number? head)).
04f0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
0500: 28 61 70 70 65 6e 64 20 64 61 74 61 20 28 6c 69 (append data (li
0510: 73 74 20 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 st (s:any->stri
0520: 6e 67 20 68 65 61 64 29 29 29 20 70 61 72 61 6d ng head))) param
0530: 73 20 28 63 61 72 20 74 61 69 6c 29 20 20 20 28 s (car tail) (
0540: 63 64 72 20 74 61 69 6c 29 29 29 0a 20 20 20 20 cdr tail))).
0550: 20 20 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 68 ((symbol? h
0560: 65 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 ead). (
0570: 6c 65 74 20 28 28 6e 65 77 2d 70 61 72 61 6d 73 let ((new-params
0580: 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 68 65 61 (cons (list hea
0590: 64 20 28 63 61 72 20 74 61 69 6c 29 29 20 70 61 d (car tail)) pa
05a0: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
05b0: 20 20 20 20 20 20 20 28 6e 65 77 2d 74 61 69 6c (new-tail
05c0: 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 0a 20 (cdr tail))).
05d0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
05e0: 6e 75 6c 6c 3f 20 6e 65 77 2d 74 61 69 6c 29 20 null? new-tail)
05f0: 3b 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 2c 20 ;; we are done,
0600: 6e 6f 20 6d 6f 72 65 20 70 61 72 61 6d 73 20 65 no more params e
0610: 74 63 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 tc..
0620: 20 20 20 20 28 6c 69 73 74 20 64 61 74 61 20 6e (list data n
0630: 65 77 2d 70 61 72 61 6d 73 29 0a 20 20 20 20 20 ew-params).
0640: 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 (loop
0650: 20 64 61 74 61 20 6e 65 77 2d 70 61 72 61 6d 73 data new-params
0660: 20 28 63 61 72 20 6e 65 77 2d 74 61 69 6c 29 28 (car new-tail)(
0670: 63 64 72 20 6e 65 77 2d 74 61 69 6c 29 29 29 29 cdr new-tail))))
0680: 29 0a 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 ). (else
0690: 0a 20 20 20 20 20 20 20 20 20 20 28 73 3a 6c 6f . (s:lo
06a0: 67 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 6c 66 g "WARNING: Malf
06b0: 6f 72 6d 65 64 20 69 6e 70 75 74 2c 20 79 6f 75 ormed input, you
06c0: 20 68 61 76 65 20 62 72 6f 6b 65 6e 20 73 74 6d have broken stm
06d0: 6c 2c 20 72 65 6d 65 6d 62 65 72 20 74 68 61 74 l, remember that
06e0: 20 61 6c 6c 20 73 74 6d 6c 20 63 61 6c 6c 73 20 all stml calls
06f0: 73 68 6f 75 6c 64 20 72 65 74 75 72 6e 20 61 20 should return a
0700: 72 65 73 75 6c 74 20 28 6e 75 6c 6c 20 6c 69 73 result (null lis
0710: 74 20 6f 72 20 65 6d 70 74 79 20 73 74 72 69 6e t or empty strin
0720: 67 20 69 73 20 6f 6b 29 3a 5c 6e 20 20 68 65 61 g is ok):\n hea
0730: 64 3d 22 20 68 65 61 64 20 0a 09 20 20 20 20 20 d=" head ..
0740: 20 20 20 20 20 22 5c 6e 20 20 74 61 69 6c 3d 22 "\n tail="
0750: 20 74 61 69 6c 20 0a 20 20 20 20 20 20 20 20 20 tail .
0760: 20 20 20 20 20 20 20 20 20 22 5c 6e 20 20 69 6e "\n in
0770: 6c 73 74 3d 22 20 69 6e 6c 73 74 20 0a 20 20 20 lst=" inlst .
0780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
0790: 5c 6e 20 20 70 61 72 61 6d 73 3d 22 20 70 61 72 \n params=" par
07a0: 61 6d 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c ams).. (if (nul
07b0: 6c 3f 20 74 61 69 6c 29 0a 09 20 20 20 20 20 20 l? tail)..
07c0: 28 6c 69 73 74 20 64 61 74 61 20 70 61 72 61 6d (list data param
07d0: 73 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 s).. (loop
07e0: 64 61 74 61 20 70 61 72 61 6d 73 20 28 63 61 72 data params (car
07f0: 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 tail)(cdr tail)
0800: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 6f 73 74 )))))))..;; most
0810: 20 74 61 67 73 20 63 61 6e 20 62 65 20 68 61 6e tags can be han
0820: 64 6c 65 64 20 62 79 20 74 68 69 73 20 72 6f 75 dled by this rou
0830: 74 69 6e 65 0a 28 64 65 66 69 6e 65 20 28 73 3a tine.(define (s:
0840: 63 6f 6d 6d 6f 6e 2d 74 61 67 20 74 61 67 6e 61 common-tag tagna
0850: 6d 65 20 61 72 67 73 29 0a 20 20 28 6c 65 74 2a me args). (let*
0860: 20 28 28 69 6e 70 75 74 73 20 28 73 3a 65 78 74 ((inputs (s:ext
0870: 72 61 63 74 20 61 72 67 73 29 29 0a 20 20 20 20 ract args)).
0880: 20 20 20 20 20 28 64 61 74 61 20 20 20 28 63 61 (data (ca
0890: 72 20 69 6e 70 75 74 73 29 29 0a 20 20 20 20 20 r inputs)).
08a0: 20 20 20 20 28 70 61 72 61 6d 73 20 28 73 3a 70 (params (s:p
08b0: 72 6f 63 65 73 73 2d 70 61 72 61 6d 73 20 28 63 rocess-params (c
08c0: 61 64 72 20 69 6e 70 75 74 73 29 29 29 29 0a 20 adr inputs)))).
08d0: 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 (list (conc "
08e0: 3c 22 20 74 61 67 6e 61 6d 65 20 70 61 72 61 6d <" tagname param
08f0: 73 20 22 3e 22 29 0a 20 20 20 20 20 20 20 20 20 s ">").
0900: 20 64 61 74 61 0a 20 20 20 20 20 20 20 20 20 20 data.
0910: 28 63 6f 6e 63 20 22 3c 2f 22 20 74 61 67 6e 61 (conc "</" tagna
0920: 6d 65 20 22 3e 22 29 29 29 29 0a 0a 3b 3b 20 53 me ">"))))..;; S
0930: 75 67 67 65 73 74 69 6f 6e 3a 20 6f 72 64 65 72 uggestion: order
0940: 20 74 68 65 73 65 20 61 6c 70 68 61 62 65 74 69 these alphabeti
0950: 63 61 6c 6c 79 0a 28 64 65 66 69 6e 65 20 28 73 cally.(define (s
0960: 3a 61 20 20 20 20 20 20 2e 20 61 72 67 73 29 20 :a . args)
0970: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 41 (s:common-tag "A
0980: 22 20 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 " args)).(d
0990: 65 66 69 6e 65 20 28 73 3a 62 20 20 20 20 20 20 efine (s:b
09a0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
09b0: 6e 2d 74 61 67 20 22 42 22 20 20 20 20 20 20 61 n-tag "B" a
09c0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
09d0: 3a 75 20 20 20 20 20 20 2e 20 61 72 67 73 29 20 :u . args)
09e0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 55 (s:common-tag "U
09f0: 22 20 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 " args)).(d
0a00: 65 66 69 6e 65 20 28 73 3a 62 69 67 20 20 20 20 efine (s:big
0a10: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0a20: 6e 2d 74 61 67 20 22 42 49 47 22 20 20 20 20 61 n-tag "BIG" a
0a30: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0a40: 3a 62 6f 64 79 20 20 20 2e 20 61 72 67 73 29 20 :body . args)
0a50: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 42 (s:common-tag "B
0a60: 4f 44 59 22 20 20 20 61 72 67 73 29 29 0a 28 64 ODY" args)).(d
0a70: 65 66 69 6e 65 20 28 73 3a 62 75 74 74 6f 6e 20 efine (s:button
0a80: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0a90: 6e 2d 74 61 67 20 22 42 55 54 54 4f 4e 22 20 61 n-tag "BUTTON" a
0aa0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0ab0: 3a 63 65 6e 74 65 72 20 2e 20 61 72 67 73 29 20 :center . args)
0ac0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 43 (s:common-tag "C
0ad0: 45 4e 54 45 52 22 20 61 72 67 73 29 29 0a 28 64 ENTER" args)).(d
0ae0: 65 66 69 6e 65 20 28 73 3a 63 6f 64 65 20 20 20 efine (s:code
0af0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0b00: 6e 2d 74 61 67 20 22 43 4f 44 45 22 20 20 20 61 n-tag "CODE" a
0b10: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0b20: 3a 64 69 76 20 20 20 20 2e 20 61 72 67 73 29 20 :div . args)
0b30: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 44 (s:common-tag "D
0b40: 49 56 22 20 20 20 20 61 72 67 73 29 29 0a 28 64 IV" args)).(d
0b50: 65 66 69 6e 65 20 28 73 3a 68 31 20 20 20 20 20 efine (s:h1
0b60: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0b70: 6e 2d 74 61 67 20 22 48 31 22 20 20 20 20 20 61 n-tag "H1" a
0b80: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0b90: 3a 68 32 20 20 20 20 20 2e 20 61 72 67 73 29 20 :h2 . args)
0ba0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 48 (s:common-tag "H
0bb0: 32 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 2" args)).(d
0bc0: 65 66 69 6e 65 20 28 73 3a 68 33 20 20 20 20 20 efine (s:h3
0bd0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0be0: 6e 2d 74 61 67 20 22 48 33 22 20 20 20 20 20 61 n-tag "H3" a
0bf0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0c00: 3a 68 34 20 20 20 20 20 2e 20 61 72 67 73 29 20 :h4 . args)
0c10: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 48 (s:common-tag "H
0c20: 34 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 4" args)).(d
0c30: 65 66 69 6e 65 20 28 73 3a 68 35 20 20 20 20 20 efine (s:h5
0c40: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0c50: 6e 2d 74 61 67 20 22 48 35 22 20 20 20 20 20 61 n-tag "H5" a
0c60: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0c70: 3a 68 65 61 64 20 20 20 2e 20 61 72 67 73 29 20 :head . args)
0c80: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 48 (s:common-tag "H
0c90: 45 41 44 22 20 20 20 61 72 67 73 29 29 0a 28 64 EAD" args)).(d
0ca0: 65 66 69 6e 65 20 28 73 3a 68 74 6d 6c 20 20 20 efine (s:html
0cb0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0cc0: 6e 2d 74 61 67 20 22 48 54 4d 4c 22 20 20 20 61 n-tag "HTML" a
0cd0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0ce0: 3a 69 20 20 20 20 20 20 2e 20 61 72 67 73 29 20 :i . args)
0cf0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 49 (s:common-tag "I
0d00: 22 20 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 " args)).(d
0d10: 65 66 69 6e 65 20 28 73 3a 69 6d 67 20 20 20 20 efine (s:img
0d20: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0d30: 6e 2d 74 61 67 20 22 49 4d 47 22 20 20 20 20 61 n-tag "IMG" a
0d40: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0d50: 3a 69 6e 70 75 74 20 20 2e 20 61 72 67 73 29 20 :input . args)
0d60: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 49 (s:common-tag "I
0d70: 4e 50 55 54 22 20 20 61 72 67 73 29 29 0a 28 64 NPUT" args)).(d
0d80: 65 66 69 6e 65 20 28 73 3a 6c 69 6e 6b 20 20 20 efine (s:link
0d90: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0da0: 6e 2d 74 61 67 20 22 4c 49 4e 4b 22 20 20 20 61 n-tag "LINK" a
0db0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0dc0: 3a 70 20 20 20 20 20 20 2e 20 61 72 67 73 29 20 :p . args)
0dd0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 50 (s:common-tag "P
0de0: 22 20 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 " args)).(d
0df0: 65 66 69 6e 65 20 28 73 3a 73 74 72 6f 6e 67 20 efine (s:strong
0e00: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0e10: 6e 2d 74 61 67 20 22 53 54 52 4f 4e 47 22 20 61 n-tag "STRONG" a
0e20: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0e30: 3a 74 61 62 6c 65 20 20 2e 20 61 72 67 73 29 20 :table . args)
0e40: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 54 (s:common-tag "T
0e50: 41 42 4c 45 22 20 20 61 72 67 73 29 29 0a 28 64 ABLE" args)).(d
0e60: 65 66 69 6e 65 20 28 73 3a 74 62 6f 64 79 20 20 efine (s:tbody
0e70: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0e80: 6e 2d 74 61 67 20 22 54 42 4f 44 59 22 20 20 61 n-tag "TBODY" a
0e90: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0ea0: 3a 74 68 65 61 64 20 20 2e 20 61 72 67 73 29 20 :thead . args)
0eb0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 54 (s:common-tag "T
0ec0: 48 45 41 44 22 20 20 61 72 67 73 29 29 0a 28 64 HEAD" args)).(d
0ed0: 65 66 69 6e 65 20 28 73 3a 74 68 20 20 20 20 20 efine (s:th
0ee0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0ef0: 6e 2d 74 61 67 20 22 54 48 22 20 20 20 20 20 61 n-tag "TH" a
0f00: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0f10: 3a 74 64 20 20 20 20 20 2e 20 61 72 67 73 29 20 :td . args)
0f20: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 54 (s:common-tag "T
0f30: 44 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 D" args)).(d
0f40: 65 66 69 6e 65 20 28 73 3a 74 69 74 6c 65 20 20 efine (s:title
0f50: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0f60: 6e 2d 74 61 67 20 22 54 49 54 4c 45 22 20 20 61 n-tag "TITLE" a
0f70: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0f80: 3a 74 72 20 20 20 20 20 2e 20 61 72 67 73 29 20 :tr . args)
0f90: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 54 (s:common-tag "T
0fa0: 52 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 R" args)).(d
0fb0: 65 66 69 6e 65 20 28 73 3a 73 6d 61 6c 6c 20 20 efine (s:small
0fc0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
0fd0: 6e 2d 74 61 67 20 22 53 4d 41 4c 4c 22 20 20 61 n-tag "SMALL" a
0fe0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
0ff0: 3a 71 75 6f 74 65 20 20 2e 20 61 72 67 73 29 20 :quote . args)
1000: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 51 (s:common-tag "Q
1010: 55 4f 54 45 22 20 20 61 72 67 73 29 29 0a 28 64 UOTE" args)).(d
1020: 65 66 69 6e 65 20 28 73 3a 68 72 20 20 20 20 20 efine (s:hr
1030: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
1040: 6e 2d 74 61 67 20 22 48 52 22 20 20 20 20 20 61 n-tag "HR" a
1050: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
1060: 3a 6c 69 20 20 20 20 20 2e 20 61 72 67 73 29 20 :li . args)
1070: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 4c (s:common-tag "L
1080: 49 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 I" args)).(d
1090: 65 66 69 6e 65 20 28 73 3a 75 6c 20 20 20 20 20 efine (s:ul
10a0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
10b0: 6e 2d 74 61 67 20 22 55 4c 22 20 20 20 20 20 61 n-tag "UL" a
10c0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
10d0: 3a 6f 6c 20 20 20 20 20 2e 20 61 72 67 73 29 20 :ol . args)
10e0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 4f (s:common-tag "O
10f0: 4c 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 L" args)).(d
1100: 65 66 69 6e 65 20 28 73 3a 64 6c 20 20 20 20 20 efine (s:dl
1110: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
1120: 6e 2d 74 61 67 20 22 44 4c 22 20 20 20 20 20 61 n-tag "DL" a
1130: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
1140: 3a 64 74 20 20 20 20 20 2e 20 61 72 67 73 29 20 :dt . args)
1150: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 44 (s:common-tag "D
1160: 54 22 20 20 20 20 20 61 72 67 73 29 29 0a 28 64 T" args)).(d
1170: 65 66 69 6e 65 20 28 73 3a 64 64 20 20 20 20 20 efine (s:dd
1180: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
1190: 6e 2d 74 61 67 20 22 44 44 22 20 20 20 20 20 61 n-tag "DD" a
11a0: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
11b0: 3a 70 72 65 20 20 20 20 2e 20 61 72 67 73 29 20 :pre . args)
11c0: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 50 (s:common-tag "P
11d0: 52 45 22 20 20 20 20 61 72 67 73 29 29 0a 28 64 RE" args)).(d
11e0: 65 66 69 6e 65 20 28 73 3a 73 70 61 6e 20 20 20 efine (s:span
11f0: 2e 20 61 72 67 73 29 20 28 73 3a 63 6f 6d 6d 6f . args) (s:commo
1200: 6e 2d 74 61 67 20 22 53 50 41 4e 22 20 20 20 61 n-tag "SPAN" a
1210: 72 67 73 29 29 0a 28 64 65 66 69 6e 65 20 28 73 rgs)).(define (s
1220: 3a 6c 61 62 65 6c 20 20 2e 20 61 72 67 73 29 20 :label . args)
1230: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 4c (s:common-tag "L
1240: 41 42 45 4c 22 20 20 61 72 67 73 29 29 0a 0a 28 ABEL" args))..(
1250: 64 65 66 69 6e 65 20 28 73 3a 64 62 6c 71 75 6f define (s:dblquo
1260: 74 65 20 20 2e 20 61 72 67 73 29 0a 20 20 28 6c te . args). (l
1270: 65 74 2a 20 28 28 69 6e 70 75 74 73 20 28 73 3a et* ((inputs (s:
1280: 65 78 74 72 61 63 74 20 61 72 67 73 29 29 0a 20 extract args)).
1290: 20 20 20 20 20 20 20 20 28 64 61 74 61 20 20 20 (data
12a0: 28 63 61 61 72 20 69 6e 70 75 74 73 29 29 0a 20 (caar inputs)).
12b0: 20 20 20 20 20 20 20 20 28 70 61 72 61 6d 73 20 (params
12c0: 28 73 3a 70 72 6f 63 65 73 73 2d 70 61 72 61 6d (s:process-param
12d0: 73 20 28 63 61 64 72 20 69 6e 70 75 74 73 29 29 s (cadr inputs))
12e0: 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 26 71 )). (conc "&q
12f0: 75 6f 74 3b 22 20 64 61 74 61 20 22 26 71 75 6f uot;" data "&quo
1300: 74 3b 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 t;")))..(define
1310: 28 73 3a 62 72 20 20 20 20 20 2e 20 61 72 67 73 (s:br . args
1320: 29 20 22 3c 42 52 3e 22 29 20 3b 3b 20 20 54 48 ) "<BR>") ;; TH
1330: 49 53 20 4d 41 59 20 4e 4f 54 20 57 4f 52 4b 21 IS MAY NOT WORK!
1340: 21 21 21 20 42 52 20 43 41 4e 20 28 4d 49 53 54 !!! BR CAN (MIST
1350: 41 4b 45 4e 4c 59 29 20 47 45 54 20 50 41 52 41 AKENLY) GET PARA
1360: 4d 20 54 45 58 54 0a 3b 3b 20 28 64 65 66 69 6e M TEXT.;; (defin
1370: 65 20 28 73 3a 62 72 20 20 20 20 20 2e 20 61 72 e (s:br . ar
1380: 67 73 29 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 gs) (s:common-ta
1390: 67 20 22 42 52 22 20 20 20 20 20 61 72 67 73 29 g "BR" args)
13a0: 29 0a 28 64 65 66 69 6e 65 20 28 73 3a 66 6f 6e ).(define (s:fon
13b0: 74 20 20 20 2e 20 61 72 67 73 29 20 28 73 3a 63 t . args) (s:c
13c0: 6f 6d 6d 6f 6e 2d 74 61 67 20 22 46 4f 4e 54 22 ommon-tag "FONT"
13d0: 20 20 20 61 72 67 73 29 29 0a 28 64 65 66 69 6e args)).(defin
13e0: 65 20 28 73 3a 65 72 72 2d 66 6f 6e 74 20 2e 20 e (s:err-font .
13f0: 61 72 67 73 29 0a 20 20 28 73 3a 62 20 28 73 3a args). (s:b (s:
1400: 66 6f 6e 74 20 27 63 6f 6c 6f 72 20 22 72 65 64 font 'color "red
1410: 22 20 61 72 67 73 29 29 29 0a 0a 28 64 65 66 69 " args)))..(defi
1420: 6e 65 20 28 73 3a 63 6f 6d 6d 65 6e 74 20 2e 20 ne (s:comment .
1430: 61 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 args). (let* ((
1440: 69 6e 70 75 74 73 20 28 73 3a 65 78 74 72 61 63 inputs (s:extrac
1450: 74 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 t args)).
1460: 20 20 28 64 61 74 61 20 20 20 28 63 61 72 20 69 (data (car i
1470: 6e 70 75 74 73 29 29 0a 20 20 20 20 20 20 20 20 nputs)).
1480: 20 28 70 61 72 61 6d 73 20 28 73 3a 70 72 6f 63 (params (s:proc
1490: 65 73 73 2d 70 61 72 61 6d 73 20 28 63 61 64 72 ess-params (cadr
14a0: 20 69 6e 70 75 74 73 29 29 29 29 0a 20 20 20 20 inputs)))).
14b0: 28 6c 69 73 74 20 22 3c 21 2d 2d 22 20 64 61 74 (list "<!--" dat
14c0: 61 20 22 2d 2d 3e 22 29 29 29 0a 0a 28 64 65 66 a "-->")))..(def
14d0: 69 6e 65 20 28 73 3a 6e 75 6c 6c 20 20 20 2e 20 ine (s:null .
14e0: 61 72 67 73 29 20 3b 3b 20 6e 6f 70 0a 20 20 28 args) ;; nop. (
14f0: 6c 65 74 2a 20 28 28 69 6e 70 75 74 73 20 28 73 let* ((inputs (s
1500: 3a 65 78 74 72 61 63 74 20 61 72 67 73 29 29 0a :extract args)).
1510: 20 20 20 20 20 20 20 20 20 28 64 61 74 61 20 20 (data
1520: 20 28 63 61 72 20 69 6e 70 75 74 73 29 29 0a 20 (car inputs)).
1530: 20 20 20 20 20 20 20 20 28 70 61 72 61 6d 73 20 (params
1540: 28 73 3a 70 72 6f 63 65 73 73 2d 70 61 72 61 6d (s:process-param
1550: 73 20 28 63 61 64 72 20 69 6e 70 75 74 73 29 29 s (cadr inputs))
1560: 29 29 0a 20 20 20 20 28 6c 69 73 74 20 64 61 74 )). (list dat
1570: 61 29 29 29 0a 0a 3b 3b 20 70 75 74 73 20 61 20 a)))..;; puts a
1580: 6e 69 63 65 20 62 6f 78 20 61 72 6f 75 6e 64 20 nice box around
1590: 61 20 63 68 75 6e 6b 20 6f 66 20 73 74 75 66 66 a chunk of stuff
15a0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 66 69 65 6c .(define (s:fiel
15b0: 64 73 65 74 20 6c 65 67 65 6e 64 20 2e 20 61 72 dset legend . ar
15c0: 67 73 29 0a 20 20 28 6c 69 73 74 20 22 3c 46 49 gs). (list "<FI
15d0: 45 4c 44 53 45 54 3e 3c 4c 45 47 45 4e 44 3e 22 ELDSET><LEGEND>"
15e0: 20 6c 65 67 65 6e 64 20 22 3c 2f 4c 45 47 45 4e legend "</LEGEN
15f0: 44 3e 22 20 61 72 67 73 20 22 3c 2f 46 49 45 4c D>" args "</FIEL
1600: 44 53 45 54 3e 22 29 29 0a 0a 3b 3b 20 67 69 76 DSET>"))..;; giv
1610: 65 6e 20 61 20 73 74 72 69 6e 67 20 72 65 74 75 en a string retu
1620: 72 6e 20 74 68 65 20 73 74 72 69 6e 67 20 69 66 rn the string if
1630: 20 69 74 20 69 73 20 6e 6f 6e 2d 77 68 69 74 65 it is non-white
1640: 20 73 70 61 63 65 20 6f 72 20 26 6e 62 73 70 3b space or
1650: 20 6f 74 68 65 72 77 69 73 65 0a 28 64 65 66 69 otherwise.(defi
1660: 6e 65 20 28 73 3a 6e 62 73 70 20 73 74 72 29 0a ne (s:nbsp str).
1670: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
1680: 74 63 68 20 22 5e 5c 5c 73 2a 24 22 20 73 74 72 tch "^\\s*$" str
1690: 29 0a 20 20 20 20 20 20 22 26 6e 62 73 70 3b 22 ). " "
16a0: 0a 20 20 20 20 20 20 73 74 72 29 29 0a 0a 3b 3b . str))..;;
16b0: 20 55 53 45 20 27 70 61 67 65 5f 6f 76 65 72 72 USE 'page_overr
16c0: 69 64 65 20 74 6f 20 6f 76 65 72 72 69 64 65 20 ide to override
16d0: 61 20 6c 69 6e 6b 74 6f 20 70 61 67 65 20 66 72 a linkto page fr
16e0: 6f 6d 20 61 20 62 75 74 74 6f 6e 0a 28 64 65 66 om a button.(def
16f0: 69 6e 65 20 28 73 3a 66 6f 72 6d 20 20 20 2e 20 ine (s:form .
1700: 61 72 67 73 29 0a 20 20 3b 3b 20 63 72 65 61 74 args). ;; creat
1710: 65 20 61 20 6c 69 6e 6b 20 66 6f 72 20 63 61 6c e a link for cal
1720: 6c 69 6e 67 20 62 61 63 6b 20 69 6e 74 6f 20 74 ling back into t
1730: 68 65 20 63 75 72 72 65 6e 74 20 70 61 67 65 20 he current page
1740: 61 6e 64 20 63 61 6c 6c 69 6e 67 20 61 20 73 70 and calling a sp
1750: 65 63 69 66 69 65 64 20 0a 20 20 3b 3b 20 66 75 ecified . ;; fu
1760: 6e 63 74 69 6f 6e 0a 20 20 28 6c 65 74 2a 20 28 nction. (let* (
1770: 28 61 63 74 69 6f 6e 20 20 20 20 20 28 6c 65 74 (action (let
1780: 20 28 28 76 20 28 73 3a 66 69 6e 64 2d 70 61 72 ((v (s:find-par
1790: 61 6d 20 27 61 63 74 69 6f 6e 20 61 72 67 73 29 am 'action args)
17a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
17b0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 76 20 (if v
17c0: 76 20 22 64 65 66 61 75 6c 74 22 29 29 29 0a 09 v "default")))..
17d0: 20 28 69 64 20 20 20 20 20 20 20 20 20 28 6c 65 (id (le
17e0: 74 20 28 28 69 20 28 73 3a 66 69 6e 64 2d 70 61 t ((i (s:find-pa
17f0: 72 61 6d 20 27 69 64 20 61 72 67 73 29 29 29 0a ram 'id args))).
1800: 09 09 20 20 20 20 20 20 20 28 69 66 20 69 20 69 .. (if i i
1810: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
1820: 28 70 61 67 65 20 20 20 20 20 20 20 28 6c 65 74 (page (let
1830: 20 28 28 70 20 28 73 64 61 74 2d 67 65 74 2d 70 ((p (sdat-get-p
1840: 61 67 65 20 73 3a 73 65 73 73 69 6f 6e 29 29 29 age s:session)))
1850: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1860: 20 20 20 20 20 20 20 20 28 69 66 20 70 20 70 20 (if p p
1870: 22 68 6f 6d 65 22 29 29 29 0a 09 20 3b 3b 20 28 "home"))).. ;; (
1880: 6c 69 6e 6b 20 20 20 20 20 20 20 28 73 65 73 73 link (sess
1890: 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 3a 73 65 ion:link-to s:se
18a0: 73 73 69 6f 6e 20 70 61 67 65 20 28 69 66 20 69 ssion page (if i
18b0: 64 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 d. ;;
18c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
18f0: 69 73 74 20 27 61 63 74 69 6f 6e 20 61 63 74 69 ist 'action acti
1900: 6f 6e 20 27 69 64 20 69 64 29 0a 20 20 20 20 20 on 'id id).
1910: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
1920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1940: 20 20 20 20 20 20 20 28 6c 69 73 74 20 27 61 63 (list 'ac
1950: 74 69 6f 6e 20 61 63 74 69 6f 6e 29 29 29 29 29 tion action)))))
1960: 0a 09 20 28 6c 69 6e 6b 20 20 20 20 20 20 20 28 .. (link (
1970: 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 28 73 75 if (string=? (su
1980: 62 73 74 72 69 6e 67 20 61 63 74 69 6f 6e 20 30 bstring action 0
1990: 20 35 29 20 22 68 74 74 70 3a 22 29 20 3b 3b 20 5) "http:") ;;
19a0: 69 66 20 66 69 72 73 74 20 70 61 72 74 20 6f 66 if first part of
19b0: 20 73 74 72 69 6e 67 20 69 73 20 68 74 74 70 3a string is http:
19c0: 0a 09 20 20 20 20 20 20 20 20 09 20 61 63 74 69 .. . acti
19d0: 6f 6e 0a 09 20 20 20 20 20 20 20 20 09 20 28 73 on.. . (s
19e0: 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 ession:link-to s
19f0: 3a 73 65 73 73 69 6f 6e 20 0a 09 20 20 20 20 20 :session ..
1a00: 20 20 20 09 09 09 20 20 70 61 67 65 20 0a 09 20 ... page ..
1a10: 20 20 20 20 20 20 20 09 09 09 20 20 28 69 66 20 ... (if
1a20: 69 64 0a 09 20 20 20 20 20 20 20 20 09 09 09 20 id.. ...
1a30: 20 20 20 20 20 28 6c 69 73 74 20 27 61 63 74 69 (list 'acti
1a40: 6f 6e 20 61 63 74 69 6f 6e 20 27 69 64 20 69 64 on action 'id id
1a50: 29 0a 09 20 20 20 20 20 20 20 20 09 09 09 20 20 ).. ...
1a60: 20 20 20 20 28 6c 69 73 74 20 27 61 63 74 69 6f (list 'actio
1a70: 6e 20 61 63 74 69 6f 6e 29 29 29 29 29 29 0a 20 n action)))))).
1a80: 20 20 20 3b 3b 20 28 73 63 72 69 70 74 20 20 20 ;; (script
1a90: 20 20 28 73 6c 6f 74 2d 72 65 66 20 73 3a 73 65 (slot-ref s:se
1aa0: 73 73 69 6f 6e 20 27 73 63 72 69 70 74 29 29 0a ssion 'script)).
1ab0: 20 20 20 20 3b 3b 20 28 61 63 74 69 6f 6e 2d 73 ;; (action-s
1ac0: 74 72 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e tr (string-appen
1ad0: 64 20 73 63 72 69 70 74 20 22 2f 22 20 70 61 67 d script "/" pag
1ae0: 65 20 22 3f 61 63 74 69 6f 6e 3d 22 20 61 63 74 e "?action=" act
1af0: 69 6f 6e 29 29 29 0a 20 20 20 20 28 73 3a 63 6f ion))). (s:co
1b00: 6d 6d 6f 6e 2d 74 61 67 20 22 46 4f 52 4d 22 20 mmon-tag "FORM"
1b10: 28 61 70 70 65 6e 64 20 28 73 3a 72 65 6d 6f 76 (append (s:remov
1b20: 65 2d 70 61 72 61 6d 2d 6d 61 74 63 68 69 6e 67 e-param-matching
1b30: 20 28 73 3a 72 65 6d 6f 76 65 2d 70 61 72 61 6d (s:remove-param
1b40: 2d 6d 61 74 63 68 69 6e 67 20 61 72 67 73 20 27 -matching args '
1b50: 61 63 74 69 6f 6e 29 20 27 69 64 29 0a 20 20 20 action) 'id).
1b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
1b80: 69 73 74 20 27 61 63 74 69 6f 6e 20 6c 69 6e 6b ist 'action link
1b90: 29 29 29 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 )))))..;; look u
1ba0: 70 20 74 68 65 20 76 61 72 69 61 62 6c 65 20 6e p the variable n
1bb0: 61 6d 65 20 28 76 69 61 20 74 68 65 20 27 6e 61 ame (via the 'na
1bc0: 6d 65 20 74 61 67 29 20 74 68 65 6e 20 69 6e 6a me tag) then inj
1bd0: 65 63 74 20 74 68 65 20 76 61 6c 75 65 20 66 72 ect the value fr
1be0: 6f 6d 20 74 68 65 20 73 65 73 73 69 6f 6e 20 76 om the session v
1bf0: 61 72 0a 3b 3b 20 72 65 70 6c 61 63 69 6e 67 20 ar.;; replacing
1c00: 74 68 65 20 27 76 61 6c 75 65 20 76 61 6c 75 65 the 'value value
1c10: 20 69 66 20 69 74 20 69 73 20 61 6c 72 65 61 64 if it is alread
1c20: 79 20 74 68 65 72 65 2c 20 61 64 64 69 6e 67 20 y there, adding
1c30: 69 74 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e it if it is not.
1c40: 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 72 65 73 .(define (s:pres
1c50: 65 72 76 65 20 74 61 67 20 61 72 67 73 29 0a 20 erve tag args).
1c60: 20 28 6c 65 74 2a 20 28 28 76 61 72 2d 6e 61 6d (let* ((var-nam
1c70: 65 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 e (s:find-param
1c80: 27 6e 61 6d 65 20 61 72 67 73 29 29 20 3b 3b 20 'name args)) ;;
1c90: 6e 61 6d 65 3d 27 76 61 72 6e 61 6d 65 27 0a 09 name='varname'..
1ca0: 20 28 76 61 6c 75 65 20 20 20 20 28 6c 65 74 20 (value (let
1cb0: 28 28 76 20 28 73 3a 67 65 74 20 76 61 72 2d 6e ((v (s:get var-n
1cc0: 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 28 69 ame)))... (i
1cd0: 66 20 76 20 76 20 23 66 29 29 29 0a 09 20 28 6e f v v #f))).. (n
1ce0: 65 77 61 72 67 73 20 20 28 61 70 70 65 6e 64 20 ewargs (append
1cf0: 28 73 3a 72 65 6d 6f 76 65 2d 70 61 72 61 6d 2d (s:remove-param-
1d00: 6d 61 74 63 68 69 6e 67 20 61 72 67 73 20 27 76 matching args 'v
1d10: 61 6c 75 65 29 20 28 69 66 20 76 61 6c 75 65 20 alue) (if value
1d20: 28 6c 69 73 74 20 27 76 61 6c 75 65 20 76 61 6c (list 'value val
1d30: 75 65 29 20 27 28 29 29 29 29 29 0a 20 20 20 20 ue) '())))).
1d40: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 74 61 (s:common-tag ta
1d50: 67 20 6e 65 77 61 72 67 73 29 29 29 0a 0a 28 64 g newargs)))..(d
1d60: 65 66 69 6e 65 20 28 73 3a 69 6e 70 75 74 2d 70 efine (s:input-p
1d70: 72 65 73 65 72 76 65 20 20 2e 20 61 72 67 73 29 reserve . args)
1d80: 0a 20 20 28 73 3a 70 72 65 73 65 72 76 65 20 22 . (s:preserve "
1d90: 49 4e 50 55 54 22 20 61 72 67 73 29 29 0a 0a 3b INPUT" args))..;
1da0: 3b 20 74 65 78 74 20 61 72 65 61 73 20 61 72 65 ; text areas are
1db0: 20 64 6f 6e 65 20 61 20 6c 69 74 74 6c 65 20 64 done a little d
1dc0: 69 66 66 65 72 65 6e 74 6c 79 2e 20 54 68 65 20 ifferently. The
1dd0: 76 61 6c 75 65 20 69 73 20 73 74 6f 72 65 64 20 value is stored
1de0: 62 65 74 77 65 65 6e 20 74 68 65 20 74 61 67 73 between the tags
1df0: 20 3c 74 65 78 74 61 72 65 61 20 2e 2e 2e 3e 74 <textarea ...>t
1e00: 68 65 20 76 61 6c 75 65 20 67 6f 65 73 20 68 65 he value goes he
1e10: 72 65 3c 2f 74 65 78 74 61 72 65 61 3e 0a 28 64 re</textarea>.(d
1e20: 65 66 69 6e 65 20 28 73 3a 74 65 78 74 61 72 65 efine (s:textare
1e30: 61 2d 70 72 65 73 65 72 76 65 20 2e 20 61 72 67 a-preserve . arg
1e40: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 76 61 72 s). (let* ((var
1e50: 2d 6e 61 6d 65 20 28 73 3a 66 69 6e 64 2d 70 61 -name (s:find-pa
1e60: 72 61 6d 20 27 6e 61 6d 65 20 61 72 67 73 29 29 ram 'name args))
1e70: 0a 09 20 28 76 61 6c 75 65 20 20 20 20 28 6c 65 .. (value (le
1e80: 74 20 28 28 76 20 28 73 3a 67 65 74 20 76 61 72 t ((v (s:get var
1e90: 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 -name)))...
1ea0: 28 69 66 20 76 20 76 20 23 66 29 29 29 29 0a 20 (if v v #f)))).
1eb0: 20 20 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 (s:common-tag
1ec0: 20 22 54 45 58 54 41 52 45 41 22 20 28 69 66 20 "TEXTAREA" (if
1ed0: 76 61 6c 75 65 20 28 63 6f 6e 73 20 76 61 6c 75 value (cons valu
1ee0: 65 20 61 72 67 73 29 20 61 72 67 73 29 29 29 29 e args) args))))
1ef0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 6f 70 74 ..(define (s:opt
1f00: 69 6f 6e 20 64 61 74 29 0a 20 20 28 6c 65 74 20 ion dat). (let
1f10: 28 28 6c 65 6e 20 20 20 20 20 20 28 6c 65 6e 67 ((len (leng
1f20: 74 68 20 64 61 74 29 29 29 0a 20 20 20 20 28 63 th dat))). (c
1f30: 6f 6e 64 0a 20 20 20 20 20 28 28 65 71 3f 20 6c ond. ((eq? l
1f40: 65 6e 20 31 29 0a 20 20 20 20 20 20 28 6c 65 74 en 1). (let
1f50: 20 28 28 69 74 65 6d 20 28 63 61 72 20 64 61 74 ((item (car dat
1f60: 29 29 29 0a 09 28 73 3a 6f 70 74 69 6f 6e 20 28 )))..(s:option (
1f70: 6c 69 73 74 20 69 74 65 6d 20 69 74 65 6d 20 69 list item item i
1f80: 74 65 6d 29 29 29 29 0a 20 20 20 20 20 28 28 65 tem)))). ((e
1f90: 71 3f 20 6c 65 6e 20 32 29 0a 20 20 20 20 20 20 q? len 2).
1fa0: 28 73 3a 6f 70 74 69 6f 6e 20 28 61 70 70 65 6e (s:option (appen
1fb0: 64 20 64 61 74 20 28 6c 69 73 74 20 28 63 61 72 d dat (list (car
1fc0: 20 64 61 74 29 29 29 29 29 0a 20 20 20 20 20 28 dat))))). (
1fd0: 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 else. (let
1fe0: 28 28 6c 61 62 65 6c 20 20 20 20 28 63 61 72 20 ((label (car
1ff0: 64 61 74 29 29 0a 09 20 20 20 20 28 76 61 6c 75 dat)).. (valu
2000: 65 20 20 20 20 28 63 61 64 72 20 64 61 74 29 29 e (cadr dat))
2010: 0a 09 20 20 20 20 28 64 69 73 70 76 61 6c 20 20 .. (dispval
2020: 28 63 61 64 64 72 20 64 61 74 29 29 0a 09 20 20 (caddr dat))..
2030: 20 20 28 73 65 6c 65 63 74 65 64 20 28 69 66 20 (selected (if
2040: 28 3e 20 6c 65 6e 20 33 29 28 63 61 64 64 64 72 (> len 3)(cadddr
2050: 20 64 61 74 29 20 23 66 29 29 29 0a 09 28 6c 69 dat) #f)))..(li
2060: 73 74 20 28 63 6f 6e 63 20 22 3c 4f 50 54 49 4f st (conc "<OPTIO
2070: 4e 20 22 20 0a 09 09 20 20 20 20 28 69 66 20 73 N " ... (if s
2080: 65 6c 65 63 74 65 64 20 22 20 73 65 6c 65 63 74 elected " select
2090: 65 64 20 22 20 22 22 29 0a 09 09 20 20 20 20 22 ed " "")... "
20a0: 6c 61 62 65 6c 3d 5c 22 22 20 6c 61 62 65 6c 0a label=\"" label.
20b0: 09 09 20 20 20 20 22 5c 22 20 76 61 6c 75 65 3d .. "\" value=
20c0: 5c 22 22 20 76 61 6c 75 65 0a 09 09 20 20 20 20 \"" value...
20d0: 22 5c 22 3e 22 20 64 69 73 70 76 61 6c 20 22 3c "\">" dispval "<
20e0: 2f 4f 50 54 49 4f 4e 3e 22 29 29 29 29 29 29 29 /OPTION>")))))))
20f0: 0a 0a 3b 3b 20 63 61 6c 6c 20 6f 6e 6c 79 20 77 ..;; call only w
2100: 69 74 68 20 28 6c 61 62 65 6c 20 28 6c 61 62 65 ith (label (labe
2110: 6c 20 76 61 6c 75 65 20 64 69 73 70 76 61 6c 20 l value dispval
2120: 5b 23 74 5d 29 20 2e 2e 2e 29 0a 3b 3b 20 4e 42 [#t]) ...).;; NB
2130: 2f 2f 20 73 61 64 6c 79 20 74 68 69 73 20 62 6c // sadly this bl
2140: 6f 63 6b 20 69 73 20 72 65 64 75 6e 64 61 6e 74 ock is redundant
2150: 6c 79 20 61 6c 6d 6f 73 74 20 69 64 65 6e 74 69 ly almost identi
2160: 63 61 6c 20 74 6f 20 74 68 65 20 73 3a 73 65 6c cal to the s:sel
2170: 65 63 74 0a 3b 3b 20 66 69 78 20 74 68 61 74 20 ect.;; fix that
2180: 6c 61 74 65 72 20 2e 2e 2e 0a 28 64 65 66 69 6e later ....(defin
2190: 65 20 28 73 3a 6f 70 74 67 72 6f 75 70 20 64 61 e (s:optgroup da
21a0: 74 29 0a 20 20 28 6c 65 74 20 28 28 6c 61 62 65 t). (let ((labe
21b0: 6c 20 28 63 61 72 20 64 61 74 29 29 0a 09 28 72 l (car dat))..(r
21c0: 65 6d 20 20 20 28 63 64 72 20 64 61 74 29 29 29 em (cdr dat)))
21d0: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
21e0: 72 65 6d 29 0a 09 28 73 3a 63 6f 6d 6d 6f 6e 2d rem)..(s:common-
21f0: 74 61 67 20 22 4f 50 54 47 52 4f 55 50 22 20 27 tag "OPTGROUP" '
2200: 6c 61 62 65 6c 20 6c 61 62 65 6c 29 0a 09 28 6c label label)..(l
2210: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
2220: 61 72 20 72 65 6d 29 29 0a 09 09 20 20 20 28 74 ar rem))... (t
2230: 61 6c 20 28 63 64 72 20 72 65 6d 29 29 0a 09 09 al (cdr rem))...
2240: 20 20 20 28 72 65 73 20 28 6c 69 73 74 20 28 63 (res (list (c
2250: 6f 6e 63 20 22 3c 4f 50 54 47 52 4f 55 50 20 6c onc "<OPTGROUP l
2260: 61 62 65 6c 3d 22 20 6c 61 62 65 6c 29 29 29 29 abel=" label))))
2270: 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 68 .. ;; (print "h
2280: 65 64 3a 20 22 20 68 65 64 20 22 20 74 61 6c 3a ed: " hed " tal:
2290: 20 22 20 74 61 6c 20 22 20 72 65 73 3a 20 22 20 " tal " res: "
22a0: 72 65 73 29 0a 09 20 20 28 6c 65 74 20 28 28 6e res).. (let ((n
22b0: 65 77 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 ew (append res (
22c0: 6c 69 73 74 20 28 69 66 20 28 6c 69 73 74 3f 20 list (if (list?
22d0: 28 63 61 64 72 20 68 65 64 29 29 0a 09 09 09 09 (cadr hed)).....
22e0: 09 20 20 20 28 73 3a 6f 70 74 67 72 6f 75 70 20 . (s:optgroup
22f0: 68 65 64 29 0a 09 09 09 09 09 20 20 20 28 73 3a hed)...... (s:
2300: 6f 70 74 69 6f 6e 20 68 65 64 29 29 29 29 29 29 option hed))))))
2310: 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f .. (if (null?
2320: 20 74 61 6c 29 0a 09 09 28 61 70 70 65 6e 64 20 tal)...(append
2330: 6e 65 77 20 28 6c 69 73 74 20 22 3c 2f 4f 50 54 new (list "</OPT
2340: 47 52 4f 55 50 3e 22 29 29 0a 09 09 28 6c 6f 6f GROUP>"))...(loo
2350: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
2360: 74 61 6c 29 20 6e 65 77 29 29 29 29 29 29 29 0a tal) new))))))).
2370: 20 20 20 20 0a 3b 3b 20 69 74 65 6d 73 20 69 73 .;; items is
2380: 20 61 20 68 69 65 72 61 72 63 68 69 61 6c 20 61 a hierarchial a
2390: 6c 69 73 74 0a 3b 3b 20 28 20 28 6c 61 62 65 6c list.;; ( (label
23a0: 31 20 76 61 6c 75 65 31 20 64 69 73 70 76 61 6c 1 value1 dispval
23b0: 31 20 23 74 29 20 3b 3b 20 3c 3d 3d 20 74 68 69 1 #t) ;; <== thi
23c0: 73 20 6f 6e 65 20 69 73 20 73 65 6c 65 63 74 65 s one is selecte
23d0: 64 0a 3b 3b 20 20 20 28 6c 61 62 65 6c 32 20 28 d.;; (label2 (
23e0: 6c 61 62 65 6c 33 20 76 61 6c 75 65 32 20 64 69 label3 value2 di
23f0: 73 70 76 61 6c 32 29 0a 3b 3b 20 20 20 20 20 20 spval2).;;
2400: 20 20 20 20 20 28 6c 61 62 65 6c 34 20 76 61 6c (label4 val
2410: 75 65 33 20 64 69 73 70 76 61 6c 33 29 29 29 0a ue3 dispval3))).
2420: 3b 3b 20 20 20 20 20 0a 3b 3b 20 20 72 65 71 75 ;; .;; requ
2430: 69 72 65 64 20 61 72 67 20 69 73 20 27 6e 61 6d ired arg is 'nam
2440: 65 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 65 6c e.(define (s:sel
2450: 65 63 74 20 69 74 65 6d 73 20 2e 20 61 72 67 73 ect items . args
2460: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 69 ). (if (null? i
2470: 74 65 6d 73 29 0a 20 20 20 20 20 20 28 73 3a 63 tems). (s:c
2480: 6f 6d 6d 6f 6e 2d 74 61 67 20 22 53 45 4c 45 43 ommon-tag "SELEC
2490: 54 22 20 61 72 67 73 29 0a 20 20 20 20 20 20 28 T" args). (
24a0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
24b0: 63 61 72 20 69 74 65 6d 73 29 29 0a 09 09 20 28 car items))... (
24c0: 74 61 6c 20 28 63 64 72 20 69 74 65 6d 73 29 29 tal (cdr items))
24d0: 0a 09 09 20 28 72 65 73 20 27 28 29 29 29 0a 09 ... (res '()))..
24e0: 3b 3b 20 28 70 72 69 6e 74 20 22 68 65 64 3a 20 ;; (print "hed:
24f0: 22 20 68 65 64 20 22 20 74 61 6c 3a 20 22 20 74 " hed " tal: " t
2500: 61 6c 20 22 20 72 65 73 3a 20 22 20 72 65 73 29 al " res: " res)
2510: 0a 09 28 6c 65 74 20 28 28 6e 65 77 20 28 61 70 ..(let ((new (ap
2520: 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 28 pend res (list (
2530: 69 66 20 28 61 6e 64 20 28 3e 20 28 6c 65 6e 67 if (and (> (leng
2540: 74 68 20 68 65 64 29 20 31 29 0a 09 09 09 09 09 th hed) 1)......
2550: 20 20 20 20 20 20 28 6c 69 73 74 3f 20 28 63 61 (list? (ca
2560: 64 72 20 68 65 64 29 29 29 0a 09 09 09 09 09 20 dr hed)))......
2570: 28 73 3a 6f 70 74 67 72 6f 75 70 20 68 65 64 29 (s:optgroup hed)
2580: 0a 09 09 09 09 09 20 28 73 3a 6f 70 74 69 6f 6e ...... (s:option
2590: 20 68 65 64 29 29 29 29 29 29 0a 09 20 20 28 69 hed)))))).. (i
25a0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 f (null? tal)..
25b0: 20 20 20 20 20 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 (s:common-t
25c0: 61 67 20 22 53 45 4c 45 43 54 22 20 28 63 6f 6e ag "SELECT" (con
25d0: 73 20 6e 65 77 20 61 72 67 73 29 29 0a 09 20 20 s new args))..
25e0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
25f0: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 al)(cdr tal) new
2600: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
2610: 28 73 3a 63 6f 6c 6f 72 20 20 2e 20 61 72 67 73 (s:color . args
2620: 29 0a 20 20 22 23 30 30 66 66 30 30 22 29 0a 0a ). "#00ff00")..
2630: 28 64 65 66 69 6e 65 20 28 73 3a 70 72 69 6e 74 (define (s:print
2640: 20 69 6e 64 65 6e 74 20 69 6e 6c 73 74 29 0a 20 indent inlst).
2650: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
2660: 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 ). (cond
2670: 20 0a 20 20 20 20 20 20 20 20 20 20 28 28 6f 72 . ((or
2680: 20 28 73 74 72 69 6e 67 3f 20 78 29 28 73 79 6d (string? x)(sym
2690: 62 6f 6c 3f 20 78 29 29 0a 20 20 20 20 20 20 20 bol? x)).
26a0: 20 20 20 20 28 70 72 69 6e 74 20 28 63 6f 6e 63 (print (conc
26b0: 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 28 2a (make-string (*
26c0: 20 69 6e 64 65 6e 74 20 32 29 20 23 5c 20 29 20 indent 2) #\ )
26d0: 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 78 (s:any->string x
26e0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 )))). (
26f0: 28 6c 69 73 74 3f 20 78 29 0a 20 20 20 20 20 20 (list? x).
2700: 20 20 20 20 20 28 73 3a 70 72 69 6e 74 20 28 2b (s:print (+
2710: 20 69 6e 64 65 6e 74 20 31 29 20 78 29 29 0a 20 indent 1) x)).
2720: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 (else.
2730: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
2740: 69 6e 74 20 22 45 52 52 4f 52 3a 20 42 61 64 20 int "ERROR: Bad
2750: 69 6e 70 75 74 20 30 31 22 29 20 3b 3b 20 77 68 input 01") ;; wh
2760: 79 20 64 6f 20 61 6e 79 74 68 69 6e 67 20 77 69 y do anything wi
2770: 74 68 20 6a 75 6e 6b 3f 0a 20 20 20 20 20 20 20 th junk?.
2780: 20 20 20 20 29 29 29 0a 20 20 20 20 20 20 20 69 ))). i
2790: 6e 6c 73 74 29 29 0a 0a 3b 3b 20 4d 6f 76 65 64 nlst))..;; Moved
27a0: 20 74 6f 20 6d 69 73 63 2d 73 74 6d 6c 0a 3b 3b to misc-stml.;;
27b0: 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 63 67 .#;(define (s:cg
27c0: 69 2d 6f 75 74 20 69 6e 6c 73 74 29 0a 20 20 28 i-out inlst). (
27d0: 73 3a 6f 75 74 70 75 74 20 28 63 75 72 72 65 6e s:output (curren
27e0: 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 20 69 t-output-port) i
27f0: 6e 6c 73 74 29 29 0a 0a 23 3b 28 64 65 66 69 6e nlst))..#;(defin
2800: 65 20 28 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 e (s:output port
2810: 20 69 6e 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 inlst). (map (
2820: 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 28 63 6f lambda (x).. (co
2830: 6e 64 20 0a 09 20 20 28 28 73 74 72 69 6e 67 3f nd .. ((string?
2840: 20 78 29 20 28 70 72 69 6e 74 20 78 29 29 20 3b x) (print x)) ;
2850: 3b 20 28 70 72 69 6e 74 20 78 29 29 0a 09 20 20 ; (print x))..
2860: 28 28 73 79 6d 62 6f 6c 3f 20 78 29 20 28 70 72 ((symbol? x) (pr
2870: 69 6e 74 20 78 29 29 20 3b 3b 20 28 70 72 69 6e int x)) ;; (prin
2880: 74 20 78 29 29 0a 09 20 20 28 28 6c 69 73 74 3f t x)).. ((list?
2890: 20 78 29 20 20 20 28 73 3a 6f 75 74 70 75 74 20 x) (s:output
28a0: 70 6f 72 74 20 78 29 29 0a 09 20 20 28 65 6c 73 port x)).. (els
28b0: 65 20 22 22 0a 09 20 20 20 3b 3b 20 28 70 72 69 e "".. ;; (pri
28c0: 6e 74 20 22 45 52 52 4f 52 3a 20 42 61 64 20 69 nt "ERROR: Bad i
28d0: 6e 70 75 74 20 30 32 22 29 20 3b 3b 20 77 68 79 nput 02") ;; why
28e0: 20 64 6f 20 61 6e 79 74 68 69 6e 67 3f 20 64 6f do anything? do
28f0: 6e 27 74 20 6f 75 74 70 75 74 20 6a 75 6e 6b 2e n't output junk.
2900: 0a 09 20 20 20 29 29 29 0a 20 20 20 20 20 20 20 .. ))).
2910: 69 6e 6c 73 74 29 29 0a 3b 20 20 28 69 66 20 28 inlst)).; (if (
2920: 3e 20 28 6c 65 6e 67 74 68 20 69 6e 6c 73 74 29 > (length inlst)
2930: 20 32 29 0a 3b 20 20 20 20 20 20 28 70 72 69 6e 2).; (prin
2940: 74 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 t)))..#;(define
2950: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 20 70 6f (s:output-new po
2960: 72 74 20 69 6e 6c 73 74 29 0a 20 20 28 77 69 74 rt inlst). (wit
2970: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
2980: 20 70 6f 72 74 0a 20 20 20 20 20 20 28 6c 61 6d port. (lam
2990: 62 64 61 20 28 29 0a 09 28 6d 61 70 20 28 6c 61 bda ()..(map (la
29a0: 6d 62 64 61 20 28 78 29 0a 09 20 20 20 20 20 20 mbda (x)..
29b0: 20 28 63 6f 6e 64 20 0a 09 09 28 28 73 74 72 69 (cond ...((stri
29c0: 6e 67 3f 20 78 29 20 28 70 72 69 6e 74 20 78 29 ng? x) (print x)
29d0: 29 0a 09 09 28 28 73 79 6d 62 6f 6c 3f 20 78 29 )...((symbol? x)
29e0: 20 28 70 72 69 6e 74 20 78 29 29 0a 09 09 28 28 (print x))...((
29f0: 6c 69 73 74 3f 20 78 29 20 20 20 28 73 3a 6f 75 list? x) (s:ou
2a00: 74 70 75 74 20 70 6f 72 74 20 78 29 29 0a 09 09 tput port x))...
2a10: 28 65 6c 73 65 0a 09 09 20 3b 3b 20 28 70 72 69 (else... ;; (pri
2a20: 6e 74 20 22 45 52 52 4f 52 3a 20 42 61 64 20 69 nt "ERROR: Bad i
2a30: 6e 70 75 74 20 30 33 22 29 0a 20 20 20 20 20 29 nput 03"). )
2a40: 29 29 0a 09 20 20 20 20 20 69 6e 6c 73 74 29 29 )).. inlst))
2a50: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
2a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
2aa0: 4e 6f 74 20 73 75 72 65 20 77 68 65 72 65 20 74 Not sure where t
2ab0: 68 65 73 65 20 73 68 6f 75 6c 64 20 67 6f 0a 3b hese should go.;
2ac0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
2ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b00: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 69 6e 63 =======..;; (inc
2b10: 6c 75 64 65 20 22 72 65 71 75 69 72 65 6d 65 6e lude "requiremen
2b20: 74 73 2e 73 63 6d 22 29 2c 20 64 62 69 20 68 61 ts.scm"), dbi ha
2b30: 73 20 61 75 74 6f 6c 6f 61 64 2c 20 73 68 6f 75 s autoload, shou
2b40: 6c 64 20 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 ld not need this
2b50: 20 61 6e 79 20 6d 6f 72 65 2e 0a 0a 3b 3b 3d 3d any more...;;==
2b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ba0: 3d 3d 3d 3d 0a 3b 3b 20 73 65 74 75 70 20 2d 20 ====.;; setup -
2bb0: 63 6f 6e 76 69 65 6e 63 65 20 63 61 6c 6c 73 20 convience calls
2bc0: 74 6f 20 66 75 6e 63 74 69 6f 6e 73 20 77 72 61 to functions wra
2bd0: 70 70 65 64 20 77 69 74 68 20 61 20 67 6c 6f 62 pped with a glob
2be0: 61 6c 20 73 3a 73 65 73 73 69 6f 6e 0a 3b 3b 3d al s:session.;;=
2bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c30: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6d 61 63 72 6f 73 =====..;; macros
2c40: 20 69 6e 20 73 75 67 61 72 20 64 6f 6e 27 74 20 in sugar don't
2c50: 77 6f 72 6b 2c 20 68 61 76 65 20 74 6f 20 6c 6f work, have to lo
2c60: 61 64 20 69 6e 20 61 6c 6c 20 66 69 6c 65 73 20 ad in all files
2c70: 6f 72 20 75 73 65 20 63 6f 6d 70 69 6c 65 64 20 or use compiled
2c80: 6d 6f 64 65 3f 0a 3b 3b 0a 3b 3b 20 28 69 6e 63 mode?.;;.;; (inc
2c90: 6c 75 64 65 20 22 73 75 67 61 72 2e 73 63 6d 22 lude "sugar.scm"
2ca0: 29 0a 0a 3b 3b 20 75 73 65 20 74 68 69 73 20 66 )..;; use this f
2cb0: 6f 72 20 67 65 74 74 69 6e 67 20 64 61 74 61 20 or getting data
2cc0: 66 72 6f 6d 20 70 61 67 65 20 74 6f 20 70 61 67 from page to pag
2cd0: 65 20 77 68 65 6e 20 73 63 6f 70 65 20 61 6e 64 e when scope and
2ce0: 20 65 76 61 6c 73 0a 3b 3b 20 67 65 74 20 69 6e evals.;; get in
2cf0: 20 74 68 65 20 77 61 79 0a 3b 3b 20 73 61 76 65 the way.;; save
2d00: 20 64 61 74 61 20 66 6f 72 20 75 73 65 20 69 6e data for use in
2d10: 20 74 68 65 20 70 61 67 65 20 67 65 6e 65 72 61 the page genera
2d20: 74 69 6f 6e 20 68 65 72 65 2e 20 44 6f 65 73 20 tion here. Does
2d30: 4e 4f 54 20 70 65 72 73 69 73 74 20 61 63 72 6f NOT persist acro
2d40: 73 73 20 70 61 67 65 20 72 65 61 64 73 2e 0a 0a ss page reads...
2d50: 28 64 65 66 69 6e 65 20 2a 70 61 67 65 2d 64 61 (define *page-da
2d60: 74 61 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ta* (make-hash-t
2d70: 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 able))..(define
2d80: 28 73 3a 6c 73 65 74 21 20 76 61 72 20 76 61 6c (s:lset! var val
2d90: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
2da0: 73 65 74 21 20 2a 70 61 67 65 2d 64 61 74 61 2a set! *page-data*
2db0: 20 76 61 72 20 76 61 6c 29 29 0a 28 64 65 66 69 var val)).(defi
2dc0: 6e 65 20 28 73 3a 6c 67 65 74 20 76 61 72 20 2e ne (s:lget var .
2dd0: 20 64 65 66 61 75 6c 74 29 0a 20 20 28 68 61 73 default). (has
2de0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2df0: 75 6c 74 20 2a 70 61 67 65 2d 64 61 74 61 2a 20 ult *page-data*
2e00: 76 61 72 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 var (if (null? d
2e10: 65 66 61 75 6c 74 29 0a 09 09 09 09 09 20 20 20 efault)......
2e20: 20 20 20 23 66 0a 09 09 09 09 09 20 20 20 20 20 #f......
2e30: 20 28 63 61 72 20 64 65 66 61 75 6c 74 29 29 29 (car default)))
2e40: 29 0a 0a 3b 3b 20 74 6f 20 6f 62 73 63 75 72 65 )..;; to obscure
2e50: 20 61 6e 64 20 69 6e 64 69 72 65 63 74 20 64 61 and indirect da
2e60: 74 61 62 61 73 65 20 69 64 73 20 75 73 65 20 6f tabase ids use o
2e70: 6e 65 20 74 69 6d 65 20 6b 65 79 73 0a 3b 3b 0a ne time keys.;;.
2e80: 3b 3b 20 20 28 73 3a 67 65 74 2d 6b 65 79 20 27 ;; (s:get-key '
2e90: 6e 20 31 29 20 20 20 20 20 3d 3e 20 22 6e 39 39 n 1) => "n99
2ea0: 65 31 38 38 32 22 20 6e 3d 6e 75 6d 62 65 72 20 e1882" n=number
2eb0: 39 39 65 20 69 73 20 74 68 65 20 77 65 65 6b 20 99e is the week
2ec0: 6e 75 6d 62 65 72 20 73 69 6e 63 65 20 31 39 37 number since 197
2ed0: 30 2c 20 72 65 6d 61 69 6e 64 65 72 20 69 73 20 0, remainder is
2ee0: 72 61 6e 64 6f 6d 0a 3b 3b 20 20 28 73 3a 6b 65 random.;; (s:ke
2ef0: 79 2d 3e 76 61 6c 20 22 6e 31 38 38 32 22 29 20 y->val "n1882")
2f00: 3d 3e 20 31 0a 3b 3b 0a 3b 3b 20 20 66 69 72 73 => 1.;;.;; firs
2f10: 74 20 6c 65 74 74 65 72 20 69 73 20 61 20 74 79 t letter is a ty
2f20: 70 65 3a 20 6e 3d 6e 75 6d 62 65 72 2c 20 73 3d pe: n=number, s=
2f30: 73 74 72 69 6e 67 2c 20 62 3d 62 6f 6f 6c 65 61 string, b=boolea
2f40: 6e 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 74 n.(define (s:get
2f50: 2d 6b 65 79 20 6b 65 79 2d 74 79 70 65 20 76 61 -key key-type va
2f60: 6c 29 0a 20 20 28 6c 65 74 20 28 28 6d 6b 72 61 l). (let ((mkra
2f70: 6e 64 73 74 72 20 28 6c 61 6d 62 64 61 20 28 69 ndstr (lambda (i
2f80: 6e 6e 75 6d 29 28 6e 75 6d 62 65 72 2d 3e 73 74 nnum)(number->st
2f90: 72 69 6e 67 20 28 72 61 6e 64 6f 6d 20 69 6e 6e ring (random inn
2fa0: 75 6d 29 20 31 36 29 29 29 0a 09 28 77 65 65 6b um) 16)))..(week
2fb0: 20 20 20 20 20 20 28 6e 75 6d 62 65 72 2d 3e 73 (number->s
2fc0: 74 72 69 6e 67 20 28 71 75 6f 74 69 65 6e 74 20 tring (quotient
2fd0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2fe0: 29 20 28 2a 20 37 20 32 34 20 36 30 20 36 30 29 ) (* 7 24 60 60)
2ff0: 29 20 31 36 29 29 29 0a 20 20 20 20 28 6c 65 74 ) 16))). (let
3000: 20 6c 6f 6f 70 20 28 28 73 69 7a 20 31 30 30 30 loop ((siz 1000
3010: 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 20 28 ).. (key (
3020: 63 6f 6e 63 20 6b 65 79 2d 74 79 70 65 20 77 65 conc key-type we
3030: 65 6b 20 28 6d 6b 72 61 6e 64 73 74 72 20 31 30 ek (mkrandstr 10
3040: 30 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 0))).. (nu
3050: 6d 20 30 29 29 0a 20 20 20 20 20 20 28 69 66 20 m 0)). (if
3060: 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d 67 (s:session-var-g
3070: 65 74 20 6b 65 79 29 20 3b 3b 20 68 61 76 65 20 et key) ;; have
3080: 61 20 63 6f 6c 6c 69 73 69 6f 6e 0a 09 20 20 28 a collision.. (
3090: 6c 6f 6f 70 20 28 63 6f 6e 64 20 20 20 20 20 20 loop (cond
30a0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 6e ;; in
30b0: 20 74 68 65 20 75 6e 6c 69 6b 65 79 20 65 76 65 the unlikey eve
30c0: 6e 74 20 77 65 20 68 61 76 65 20 74 72 6f 75 62 nt we have troub
30d0: 6c 65 20 67 65 74 74 69 6e 67 20 61 20 6e 65 77 le getting a new
30e0: 20 76 61 72 2c 20 6b 65 65 70 20 69 6e 63 72 65 var, keep incre
30f0: 61 73 69 6e 67 20 74 68 65 20 73 69 7a 65 20 6f asing the size o
3100: 66 20 74 68 65 20 6e 75 6d 62 65 72 0a 09 09 20 f the number...
3110: 28 28 3c 20 6e 75 6d 20 35 30 29 20 20 31 30 30 ((< num 50) 100
3120: 29 0a 09 09 20 28 28 3c 20 6e 75 6d 20 31 30 30 )... ((< num 100
3130: 29 20 31 30 30 30 29 0a 09 09 20 28 28 3c 20 6e ) 1000)... ((< n
3140: 75 6d 20 32 30 30 29 20 31 30 30 30 30 29 0a 09 um 200) 10000)..
3150: 09 20 28 28 3c 20 6e 75 6d 20 33 30 30 29 20 31 . ((< num 300) 1
3160: 30 30 30 30 30 29 0a 09 09 20 28 28 3c 20 6e 75 00000)... ((< nu
3170: 6d 20 34 30 30 29 20 31 30 30 30 30 30 30 29 20 m 400) 1000000)
3180: 3b 3b 20 63 61 6e 27 74 20 69 6d 61 67 69 6e 65 ;; can't imagine
3190: 20 6e 65 65 64 69 6e 67 20 74 6f 20 67 65 74 20 needing to get
31a0: 68 65 72 65 2e 20 72 65 6d 65 6d 62 65 72 20 74 here. remember t
31b0: 68 61 74 20 74 68 69 73 20 69 73 20 66 6f 72 20 hat this is for
31c0: 61 20 73 69 6e 67 6c 65 20 75 73 65 72 0a 09 09 a single user...
31d0: 20 28 65 6c 73 65 20 31 30 30 30 30 30 30 30 30 (else 100000000
31e0: 29 29 0a 09 09 28 63 6f 6e 63 20 6b 65 79 2d 74 ))...(conc key-t
31f0: 79 70 65 20 28 6d 6b 72 61 6e 64 73 74 72 20 73 ype (mkrandstr s
3200: 69 7a 29 29 0a 09 09 28 2b 20 6e 75 6d 20 31 29 iz))...(+ num 1)
3210: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
3220: 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d (s:session-var-
3230: 73 65 74 21 20 6b 65 79 20 76 61 6c 29 0a 09 20 set! key val)..
3240: 20 20 20 6b 65 79 29 29 29 29 29 0a 0a 3b 3b 20 key)))))..;;
3250: 67 69 76 65 6e 20 61 20 6b 65 79 20 58 6e 6e 6e given a key Xnnn
3260: 6e 2c 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 n, look up the s
3270: 74 6f 72 65 64 20 76 61 6c 75 65 20 61 6e 64 20 tored value and
3280: 63 6f 6e 76 65 72 74 20 69 74 20 61 70 70 72 6f convert it appro
3290: 70 72 69 61 74 65 6c 79 2c 20 74 68 65 6e 0a 3b priately, then.;
32a0: 3b 20 64 65 73 74 72 6f 79 20 74 68 65 20 73 74 ; destroy the st
32b0: 6f 72 65 64 20 73 65 73 73 69 6f 6e 20 76 61 72 ored session var
32c0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 6b .;;.(define (s:k
32d0: 65 79 2d 3e 76 61 6c 20 6b 65 79 29 0a 20 20 28 ey->val key). (
32e0: 6c 65 74 20 28 28 76 61 6c 20 28 73 3a 73 65 73 let ((val (s:ses
32f0: 73 69 6f 6e 2d 76 61 72 2d 67 65 74 20 6b 65 79 sion-var-get key
3300: 29 29 0a 09 28 74 79 70 20 28 73 74 72 69 6e 67 ))..(typ (string
3310: 2d 3e 73 79 6d 62 6f 6c 20 28 73 75 62 73 74 72 ->symbol (substr
3320: 69 6e 67 20 6b 65 79 20 30 20 31 29 29 29 29 0a ing key 0 1)))).
3330: 20 20 20 20 28 69 66 20 76 61 6c 0a 09 28 62 65 (if val..(be
3340: 67 69 6e 0a 09 20 20 28 73 3a 73 65 73 73 69 6f gin.. (s:sessio
3350: 6e 2d 76 61 72 2d 64 65 6c 21 20 6b 65 79 29 0a n-var-del! key).
3360: 09 20 20 3b 3b 20 77 65 20 74 61 6b 65 20 74 68 . ;; we take th
3370: 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 is opportunity t
3380: 6f 20 63 6c 65 61 6e 20 75 70 20 6f 6c 64 20 6b o clean up old k
3390: 65 79 65 64 20 73 65 73 73 69 6f 6e 20 76 61 72 eyed session var
33a0: 73 0a 09 20 20 3b 3b 20 69 66 20 6d 6f 72 65 20 s.. ;; if more
33b0: 74 68 61 6e 20 31 30 30 20 76 61 72 73 2c 20 72 than 100 vars, r
33c0: 65 6d 6f 76 65 20 61 6c 6c 20 74 68 61 74 20 61 emove all that a
33d0: 72 65 20 6f 76 65 72 20 31 2d 32 20 77 65 65 6b re over 1-2 week
33e0: 73 20 6f 6c 64 0a 09 09 09 09 09 3b 28 73 3a 63 s old......;(s:c
33f0: 6c 65 61 6e 75 70 2d 73 65 73 73 69 6f 6e 2d 76 leanup-session-v
3400: 61 72 73 29 0a 09 20 20 28 63 61 73 65 20 74 79 ars).. (case ty
3410: 70 0a 09 20 20 20 20 28 28 6e 29 28 73 74 72 69 p.. ((n)(stri
3420: 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 ng->number val))
3430: 0a 09 20 20 20 20 28 28 73 29 20 76 61 6c 29 0a .. ((s) val).
3440: 09 20 20 20 20 28 65 6c 73 65 20 76 61 6c 29 29 . (else val))
3450: 29 0a 09 76 61 6c 29 29 29 0a 20 20 0a 3b 3b 20 )..val))). .;;
3460: 63 6c 65 61 6e 20 75 70 20 73 65 73 73 69 6f 6e clean up session
3470: 20 76 61 72 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 vars.;;.(define
3480: 20 28 73 3a 63 6c 65 61 6e 75 70 2d 73 65 73 73 (s:cleanup-sess
3490: 69 6f 6e 2d 76 61 72 73 29 0a 20 20 28 6c 65 74 ion-vars). (let
34a0: 2a 20 28 28 73 65 73 73 69 6f 6e 2d 76 61 72 73 * ((session-vars
34b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
34c0: 73 20 28 73 3a 73 65 73 73 69 6f 6e 2d 67 65 74 s (s:session-get
34d0: 2d 73 65 73 73 69 6f 6e 76 61 72 73 29 29 29 0a -sessionvars))).
34e0: 09 20 28 77 65 65 6b 2d 6e 75 6d 20 20 20 20 20 . (week-num
34f0: 28 71 75 6f 74 69 65 6e 74 20 28 63 75 72 72 65 (quotient (curre
3500: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 2a 20 37 nt-seconds) (* 7
3510: 20 32 34 20 36 30 20 36 30 29 29 29 0a 09 20 28 24 60 60))).. (
3520: 77 65 65 6b 20 20 20 20 20 20 20 20 20 28 6e 75 week (nu
3530: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 77 65 65 mber->string wee
3540: 6b 2d 6e 75 6d 20 20 31 36 29 29 29 0a 20 20 20 k-num 16))).
3550: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
3560: 73 65 73 73 69 6f 6e 2d 76 61 72 73 29 20 31 30 session-vars) 10
3570: 30 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 0)..(for-each..
3580: 28 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 20 (lambda (var)..
3590: 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 (if (> (string
35a0: 2d 6c 65 6e 67 74 68 20 76 61 72 29 20 35 29 20 -length var) 5)
35b0: 3b 3b 20 63 61 6e 27 74 20 68 61 76 65 20 6b 65 ;; can't have ke
35c0: 79 65 64 20 76 61 6c 75 65 73 20 77 69 74 68 20 yed values with
35d0: 6b 65 79 73 20 6c 65 73 73 20 74 68 61 6e 20 35 keys less than 5
35e0: 20 63 68 61 72 61 63 74 65 72 73 20 6c 6f 6e 67 characters long
35f0: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
3600: 76 61 72 2d 77 65 65 6b 20 28 73 74 72 69 6e 67 var-week (string
3610: 2d 3e 6e 75 6d 62 65 72 20 28 73 75 62 73 74 72 ->number (substr
3620: 69 6e 67 20 76 61 72 20 31 20 34 29 20 31 36 29 ing var 1 4) 16)
3630: 29 29 0a 09 09 20 28 69 66 20 28 61 6e 64 20 76 ))... (if (and v
3640: 61 72 2d 77 65 65 6b 0a 09 09 09 20 20 28 3e 3d ar-week.... (>=
3650: 20 28 2d 20 77 65 65 6b 2d 6e 75 6d 20 76 61 72 (- week-num var
3660: 2d 77 65 65 6b 29 20 32 29 29 0a 09 09 20 20 20 -week) 2))...
3670: 20 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 (s:session-var
3680: 2d 64 65 6c 21 20 76 61 72 29 29 29 29 29 0a 09 -del! var)))))..
3690: 20 73 65 73 73 69 6f 6e 2d 76 61 72 73 29 29 29 session-vars)))
36a0: 29 0a 0a 3b 3b 20 69 6e 70 75 74 73 0a 3b 3b 0a )..;; inputs.;;.
36b0: 3b 3b 20 70 61 72 61 6d 3a 20 28 64 74 79 70 65 ;; param: (dtype
36c0: 20 5b 74 61 67 31 20 74 61 67 32 20 2e 2e 2e 5d [tag1 tag2 ...]
36d0: 29 0a 3b 3b 20 64 74 79 70 65 3a 0a 3b 3b 20 20 ).;; dtype:.;;
36e0: 20 20 27 72 61 77 20 20 20 20 20 3a 20 64 6f 20 'raw : do
36f0: 6e 6f 20 63 6f 6e 76 65 72 73 69 6f 6e 0a 3b 3b no conversion.;;
3700: 20 20 20 20 27 6e 75 6d 62 65 72 20 20 3a 20 63 'number : c
3710: 6f 6e 76 65 72 74 20 74 6f 20 6e 75 6d 62 65 72 onvert to number
3720: 2c 20 72 65 74 75 72 6e 20 23 66 20 69 66 20 66 , return #f if f
3730: 61 69 6c 73 0a 3b 3b 20 20 20 20 27 65 73 63 61 ails.;; 'esca
3740: 70 65 64 20 3a 20 75 73 65 20 68 74 6d 6c 2d 65 ped : use html-e
3750: 73 63 61 70 65 20 74 6f 20 70 72 6f 74 65 63 74 scape to protect
3760: 20 74 68 65 20 69 6e 70 75 74 0a 3b 3b 0a 28 64 the input.;;.(d
3770: 65 66 69 6e 65 20 28 73 3a 67 65 74 2d 69 6e 70 efine (s:get-inp
3780: 75 74 20 6b 65 79 20 2e 20 70 61 72 61 6d 73 29 ut key . params)
3790: 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d . (session:get-
37a0: 69 6e 70 75 74 20 73 3a 73 65 73 73 69 6f 6e 20 input s:session
37b0: 6b 65 79 20 70 61 72 61 6d 73 29 29 0a 0a 28 64 key params))..(d
37c0: 65 66 69 6e 65 20 28 73 3a 67 65 74 2d 69 6e 70 efine (s:get-inp
37d0: 75 74 2d 6b 65 79 73 29 0a 20 20 28 73 65 73 73 ut-keys). (sess
37e0: 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 2d 6b 65 ion:get-input-ke
37f0: 79 73 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a 0a ys s:session))..
3800: 3b 3b 20 67 65 74 2d 69 6e 70 75 74 20 65 6c 73 ;; get-input els
3810: 65 2c 20 67 65 74 2d 70 61 72 61 6d 20 65 6c 73 e, get-param els
3820: 65 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 e #f.;;.(define
3830: 28 73 3a 67 65 74 2d 69 6e 70 20 6b 65 79 20 2e (s:get-inp key .
3840: 20 70 61 72 61 6d 73 29 0a 20 20 28 6f 72 20 28 params). (or (
3850: 61 70 70 6c 79 20 73 3a 67 65 74 2d 69 6e 70 75 apply s:get-inpu
3860: 74 20 6b 65 79 20 70 61 72 61 6d 73 29 0a 20 20 t key params).
3870: 20 20 20 20 28 61 70 70 6c 79 20 73 3a 67 65 74 (apply s:get
3880: 2d 70 61 72 61 6d 20 6b 65 79 20 70 61 72 61 6d -param key param
3890: 73 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 s)))..#;(define
38a0: 28 73 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 6d 6f (s:load-model mo
38b0: 64 65 6c 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a del). (session:
38c0: 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 3a 73 65 73 load-model s:ses
38d0: 73 69 6f 6e 20 6d 6f 64 65 6c 29 29 0a 0a 23 3b sion model))..#;
38e0: 28 64 65 66 69 6e 65 20 28 73 3a 6d 6f 64 65 6c (define (s:model
38f0: 2d 70 61 74 68 20 6d 6f 64 65 6c 29 0a 20 20 28 -path model). (
3900: 73 65 73 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 session:model-pa
3910: 74 68 20 73 3a 73 65 73 73 69 6f 6e 20 6d 6f 64 th s:session mod
3920: 65 6c 29 29 0a 0a 3b 3b 20 73 68 61 72 65 20 64 el))..;; share d
3930: 61 74 61 20 62 65 74 77 65 65 6e 20 70 61 67 65 ata between page
3940: 73 20 63 61 6c 6c 73 2e 20 4e 4f 54 45 3a 20 54 s calls. NOTE: T
3950: 68 69 73 20 69 73 20 6e 6f 74 20 70 65 72 73 69 his is not persi
3960: 73 74 65 6e 74 0a 3b 3b 20 62 65 74 77 65 65 6e stent.;; between
3970: 20 63 67 69 20 63 61 6c 6c 73 2e 20 55 73 65 20 cgi calls. Use
3980: 73 65 73 73 69 6f 6e 76 61 72 73 20 66 6f 72 20 sessionvars for
3990: 74 68 61 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 that..;;.(define
39a0: 20 28 73 3a 73 68 61 72 65 64 2d 68 61 73 68 29 (s:shared-hash)
39b0: 0a 20 20 28 73 64 61 74 2d 67 65 74 2d 73 68 61 . (sdat-get-sha
39c0: 72 65 64 2d 68 61 73 68 20 73 3a 73 65 73 73 69 red-hash s:sessi
39d0: 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 on))..(define (s
39e0: 3a 73 68 61 72 65 64 2d 73 65 74 21 20 6b 65 79 :shared-set! key
39f0: 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d 74 61 val). (hash-ta
3a00: 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d 67 ble-set! (sdat-g
3a10: 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 et-shared-hash s
3a20: 3a 73 65 73 73 69 6f 6e 29 20 6b 65 79 20 76 61 :session) key va
3a30: 6c 29 29 0a 0a 3b 3b 20 57 68 61 74 20 74 6f 20 l))..;; What to
3a40: 72 65 74 75 72 6e 20 77 68 65 6e 20 6e 6f 20 76 return when no v
3a50: 61 6c 75 65 20 66 6f 72 20 6b 65 79 3f 0a 3b 3b alue for key?.;;
3a60: 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 68 61 72 .(define (s:shar
3a70: 65 64 2d 67 65 74 20 6b 65 79 29 0a 20 20 28 68 ed-get key). (h
3a80: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3a90: 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d fault (sdat-get-
3aa0: 73 68 61 72 65 64 2d 68 61 73 68 20 73 3a 73 65 shared-hash s:se
3ab0: 73 73 69 6f 6e 29 20 6b 65 79 20 23 66 29 29 0a ssion) key #f)).
3ac0: 0a 3b 3b 20 68 74 74 70 3a 2f 2f 66 6f 6f 2e 62 .;; http://foo.b
3ad0: 61 72 2e 63 6f 6d 2f 70 61 67 65 6e 61 6d 65 2f ar.com/pagename/
3ae0: 70 31 2f 70 32 20 3d 3e 20 27 28 22 70 31 22 20 p1/p2 => '("p1"
3af0: 22 70 32 22 29 0a 3b 3b 20 20 23 23 23 23 20 44 "p2").;; #### D
3b00: 45 50 52 45 43 41 54 45 44 20 23 23 23 23 0a 28 EPRECATED ####.(
3b10: 64 65 66 69 6e 65 20 28 73 3a 67 65 74 2d 70 61 define (s:get-pa
3b20: 67 65 2d 70 61 72 61 6d 73 29 0a 20 20 28 73 64 ge-params). (sd
3b30: 61 74 2d 67 65 74 2d 70 61 74 68 2d 70 61 72 61 at-get-path-para
3b40: 6d 73 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a 0a ms s:session))..
3b50: 28 64 65 66 69 6e 65 20 28 73 3a 67 65 74 2d 70 (define (s:get-p
3b60: 61 74 68 2d 70 61 72 61 6d 73 29 0a 20 20 28 73 ath-params). (s
3b70: 64 61 74 2d 67 65 74 2d 70 61 74 68 2d 70 61 72 dat-get-path-par
3b80: 61 6d 73 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a ams s:session)).
3b90: 09 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 64 62 ...(define (s:db
3ba0: 29 0a 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f ). (sdat-get-co
3bb0: 6e 6e 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a 0a nn s:session))..
3bc0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
3bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c00: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 63 67 69 20 ========.;; cgi
3c10: 61 6e 64 20 73 65 73 73 69 6f 6e 20 73 74 75 66 and session stuf
3c20: 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d f.;;============
3c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 28 64 ==========..;;(d
3c70: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6f eclare (uses coo
3c80: 6b 69 65 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 kie)).;;(declare
3c90: 20 28 75 73 65 73 20 68 74 6d 6c 2d 66 69 6c 74 (uses html-filt
3ca0: 65 72 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 er)).;;(declare
3cb0: 28 75 73 65 73 20 6d 69 73 63 2d 73 74 6d 6c 29 (uses misc-stml)
3cc0: 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 ).;;(declare (us
3cd0: 65 73 20 66 6f 72 6d 64 61 74 29 29 0a 3b 3b 28 es formdat)).;;(
3ce0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 74 declare (uses st
3cf0: 6d 6c 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 ml)).;;(declare
3d00: 28 75 73 65 73 20 73 65 73 73 69 6f 6e 29 29 0a (uses session)).
3d10: 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ;;(declare (uses
3d20: 20 73 65 74 75 70 29 29 20 3b 3b 20 73 3a 73 65 setup)) ;; s:se
3d30: 73 73 69 6f 6e 20 67 65 74 73 20 63 72 65 61 74 ssion gets creat
3d40: 65 64 20 68 65 72 65 0a 3b 3b 28 64 65 63 6c 61 ed here.;;(decla
3d50: 72 65 20 28 75 73 65 73 20 73 71 6c 74 62 6c 29 re (uses sqltbl)
3d60: 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 ).;;(declare (us
3d70: 65 73 20 6b 65 79 73 74 6f 72 65 29 29 0a 0a 3b es keystore))..;
3d80: 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f ; given a list o
3d90: 66 20 73 79 6d 62 6f 6c 73 20 67 69 76 65 20 74 f symbols give t
3da0: 68 65 20 63 6f 75 6e 74 20 6f 66 20 74 68 65 20 he count of the
3db0: 6d 61 74 63 68 69 6e 67 20 73 79 6d 62 6f 6c 0a matching symbol.
3dc0: 3b 3b 20 6c 20 3d 3e 20 27 28 61 20 62 20 63 29 ;; l => '(a b c)
3dd0: 20 20 28 64 75 6d 6f 62 6a 3a 69 6e 64 78 20 61 (dumobj:indx a
3de0: 20 27 62 29 20 3d 3e 20 31 0a 28 64 65 66 69 6e 'b) => 1.(defin
3df0: 65 20 28 73 3a 67 65 74 2d 66 69 65 6c 64 6e 75 e (s:get-fieldnu
3e00: 6d 20 6c 73 74 20 66 69 65 6c 64 2d 6e 61 6d 65 m lst field-name
3e10: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
3e20: 68 65 61 64 20 28 63 61 72 20 6c 73 74 29 29 0a head (car lst)).
3e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
3e40: 69 6c 20 28 63 64 72 20 6c 73 74 29 29 0a 20 20 il (cdr lst)).
3e50: 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 75 6d (fnum
3e60: 20 30 29 29 0a 20 20 20 20 28 69 66 20 28 65 71 0)). (if (eq
3e70: 3f 20 68 65 61 64 20 66 69 65 6c 64 2d 6e 61 6d ? head field-nam
3e80: 65 29 20 66 6e 75 6d 0a 20 20 20 20 20 20 20 20 e) fnum.
3e90: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 (if (null? tail)
3ea0: 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
3eb0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
3ec0: 28 63 64 72 20 74 61 69 6c 29 28 2b 20 66 6e 75 (cdr tail)(+ fnu
3ed0: 6d 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 m 1))))))..(defi
3ee0: 6e 65 20 28 73 3a 66 69 65 6c 64 73 2d 3e 73 74 ne (s:fields->st
3ef0: 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 73 74 72 ring lst). (str
3f00: 69 6e 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 79 ing-join (map sy
3f10: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6c 73 74 mbol->string lst
3f20: 29 20 22 2c 22 29 29 0a 0a 28 64 65 66 69 6e 65 ) ","))..(define
3f30: 20 28 73 3a 76 65 63 74 6f 72 2d 67 65 74 2d 66 (s:vector-get-f
3f40: 69 65 6c 64 20 76 65 63 20 66 69 65 6c 64 20 66 ield vec field f
3f50: 69 65 6c 64 2d 6c 69 73 74 29 0a 20 20 28 76 65 ield-list). (ve
3f60: 63 74 6f 72 2d 72 65 66 20 76 65 63 20 28 73 3a ctor-ref vec (s:
3f70: 67 65 74 2d 66 69 65 6c 64 6e 75 6d 20 66 69 65 get-fieldnum fie
3f80: 6c 64 2d 6c 69 73 74 20 66 69 65 6c 64 29 29 29 ld-list field)))
3f90: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
3fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b ==========.;;.;;
3fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4020: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6d 6f 76 65 64 ======..;; moved
4030: 20 74 6f 20 6d 69 73 63 2d 73 74 6d 6c 0a 3b 3b to misc-stml.;;
4040: 0a 23 3b 28 64 65 66 69 6e 65 20 28 65 72 72 3a .#;(define (err:
4050: 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 20 28 77 69 log . msg). (wi
4060: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
4070: 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 t (current-error
4080: 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c 6f 74 2d -port) ;; (slot-
4090: 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 70 74 29 ref self 'logpt)
40a0: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 . (lambda ()
40b0: 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 . (apply pr
40c0: 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 65 int msg))))..(de
40d0: 66 69 6e 65 20 28 73 3a 74 69 64 79 2d 75 72 6c fine (s:tidy-url
40e0: 20 75 72 6c 29 0a 20 20 28 69 66 20 75 72 6c 0a url). (if url.
40f0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 31 20 (let ((r1
4100: 28 72 65 67 65 78 70 20 22 5e 68 74 74 70 3a 5c (regexp "^http:\
4110: 5c 2f 5c 5c 2f 22 29 29 0a 20 20 20 20 20 20 20 \/\\/")).
4120: 20 20 20 20 20 28 72 32 20 28 72 65 67 65 78 70 (r2 (regexp
4130: 20 22 5e 5b 20 5c 5c 74 5d 2a 24 22 29 29 29 20 "^[ \\t]*$")))
4140: 3b 3b 20 62 6c 61 6e 6b 0a 20 20 20 20 20 20 20 ;; blank.
4150: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
4160: 63 68 20 72 31 20 75 72 6c 29 20 75 72 6c 0a 20 ch r1 url) url.
4170: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4180: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 32 20 string-match r2
4190: 75 72 6c 29 20 23 66 20 3b 3b 20 63 6f 6e 76 65 url) #f ;; conve
41a0: 72 74 20 61 20 62 6c 61 6e 6b 20 74 6f 20 23 66 rt a blank to #f
41b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
41c0: 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 (conc "http://"
41d0: 20 75 72 6c 29 29 29 29 0a 20 20 20 20 20 20 75 url)))). u
41e0: 72 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 rl))..(define (s
41f0: 3a 6c 61 7a 79 2d 3e 6e 75 6d 20 6e 75 6d 29 0a :lazy->num num).
4200: 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e (if (number? n
4210: 75 6d 29 20 6e 75 6d 0a 20 20 20 20 20 20 28 69 um) num. (i
4220: 66 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 f (string->numbe
4230: 72 20 6e 75 6d 29 20 28 73 74 72 69 6e 67 2d 3e r num) (string->
4240: 6e 75 6d 62 65 72 20 6e 75 6d 29 0a 09 20 20 20 number num)..
4250: 20 28 69 66 20 6e 75 6d 20 31 20 30 29 29 29 29 (if num 1 0))))
4260: 20 3b 3b 20 77 69 65 72 64 20 65 68 21 20 79 65 ;; wierd eh! ye
4270: 70 2c 20 23 66 3d 3e 30 20 23 74 3d 3e 31 20 0a p, #f=>0 #t=>1 .
4280: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 42 =========.;; D B
42d0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
42e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f =========..;; co
4320: 6e 76 65 72 74 20 76 61 6c 75 65 73 20 74 6f 20 nvert values to
4330: 61 70 70 72 6f 70 72 69 61 74 65 20 73 74 72 69 appropriate stri
4340: 6e 67 73 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 ngs.;;.#;(define
4350: 20 28 73 3a 73 71 6c 70 61 72 61 6d 2d 76 61 6c (s:sqlparam-val
4360: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 20 ->string val).
4370: 28 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f (cond. ((list?
4380: 20 20 20 76 61 6c 29 28 73 74 72 69 6e 67 2d 6a val)(string-j
4390: 6f 69 6e 20 28 6d 61 70 20 73 79 6d 62 6f 6c 2d oin (map symbol-
43a0: 3e 73 74 72 69 6e 67 20 76 61 6c 29 20 22 2c 22 >string val) ","
43b0: 29 29 20 3b 3b 20 28 61 20 62 20 63 29 20 3d 3e )) ;; (a b c) =>
43c0: 20 61 2c 62 2c 63 0a 20 20 20 28 28 73 74 72 69 a,b,c. ((stri
43d0: 6e 67 3f 20 76 61 6c 29 28 63 6f 6e 63 20 22 27 ng? val)(conc "'
43e0: 22 20 28 64 62 69 3a 65 73 63 61 70 65 2d 73 74 " (dbi:escape-st
43f0: 72 69 6e 67 20 76 61 6c 29 20 22 27 22 29 29 0a ring val) "'")).
4400: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c ((number? val
4410: 29 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 )(number->string
4420: 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 val)). ((symb
4430: 6f 6c 3f 20 76 61 6c 29 28 64 62 69 3a 65 73 63 ol? val)(dbi:esc
4440: 61 70 65 2d 73 74 72 69 6e 67 20 28 73 79 6d 62 ape-string (symb
4450: 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 ol->string val))
4460: 29 0a 20 20 20 28 28 62 6f 6f 6c 65 61 6e 3f 20 ). ((boolean?
4470: 76 61 6c 29 0a 20 20 20 20 28 69 66 20 76 61 6c val). (if val
4480: 20 22 54 52 55 45 22 20 22 46 41 4c 53 45 22 29 "TRUE" "FALSE")
4490: 29 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 ) ;; should thi
44a0: 73 20 62 65 20 22 54 52 55 45 22 20 6f 72 20 31 s be "TRUE" or 1
44b0: 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ?.
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44d0: 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 62 ;; should this b
44e0: 65 20 22 46 41 4c 53 45 22 20 6f 72 20 30 20 6f e "FALSE" or 0 o
44f0: 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 65 r NULL?. (else
4500: 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 73 . (err:log "s
4510: 71 6c 70 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 6e qlparam: unknown
4520: 20 74 79 70 65 20 66 6f 72 20 76 61 6c 75 65 3a type for value:
4530: 20 22 20 76 61 6c 29 0a 20 20 20 20 22 22 29 29 " val). ""))
4540: 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 72 61 6d 20 )..;; (sqlparam
4550: 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 66 6f 6f "INSERT INTO foo
4560: 28 6e 61 6d 65 2c 61 67 65 29 20 56 41 4c 55 45 (name,age) VALUE
4570: 53 28 3f 2c 3f 29 3b 22 20 22 62 6f 62 22 20 32 S(?,?);" "bob" 2
4580: 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 61 0).;; NB// 1. va
4590: 6c 75 65 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b 20 lues only!! .;;
45a0: 20 20 20 20 20 32 2e 20 74 65 72 6d 69 6e 61 74 2. terminat
45b0: 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 65 ing semicolon re
45c0: 71 75 69 72 65 64 20 28 75 73 65 64 20 61 73 20 quired (used as
45d0: 70 61 72 74 20 6f 66 20 6c 6f 67 69 63 29 0a 3b part of logic).;
45e0: 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 6e 75 6d 62 ;.;; a=? 1 (numb
45f0: 65 72 29 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 3d er) => a=1.;; a=
4600: 3f 20 31 20 28 73 74 72 69 6e 67 29 20 3d 3e 20 ? 1 (string) =>
4610: 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 20 a='1'.;; a=? #f
4620: 20 20 20 20 20 20 20 20 3d 3e 20 61 3d 46 41 4c => a=FAL
4630: 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 79 SE .;; a=? a (sy
4640: 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b 3b mbol) => a=a .;;
4650: 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 73 71 .#;(define (s:sq
4660: 6c 70 61 72 61 6d 20 71 75 65 72 79 20 2e 20 61 lparam query . a
4670: 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 71 rgs). (let* ((q
4680: 75 65 72 79 2d 70 61 72 74 73 20 28 73 74 72 69 uery-parts (stri
4690: 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 79 20 22 ng-split query "
46a0: 3f 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e ?")). (n
46b0: 75 6d 2d 70 61 72 74 73 20 20 20 20 28 6c 65 6e um-parts (len
46c0: 67 74 68 20 71 75 65 72 79 2d 70 61 72 74 73 29 gth query-parts)
46d0: 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 2d ). (num-
46e0: 61 72 67 73 20 20 20 20 28 6c 65 6e 67 74 68 20 args (length
46f0: 61 72 67 73 29 29 29 0a 20 20 20 20 28 69 66 20 args))). (if
4700: 28 6e 6f 74 20 28 3d 20 28 2b 20 6e 75 6d 2d 61 (not (= (+ num-a
4710: 72 67 73 20 31 29 20 6e 75 6d 2d 70 61 72 74 73 rgs 1) num-parts
4720: 29 29 0a 20 20 20 20 20 20 20 20 28 65 72 72 3a )). (err:
4730: 6c 6f 67 20 22 45 52 52 4f 52 2c 20 73 71 6c 70 log "ERROR, sqlp
4740: 61 72 61 6d 3a 20 77 72 6f 6e 67 20 6e 75 6d 62 aram: wrong numb
4750: 65 72 20 6f 66 20 61 72 67 75 6d 65 6e 74 73 20 er of arguments
4760: 6f 72 20 6d 69 73 73 69 6e 67 20 73 65 6d 69 63 or missing semic
4770: 6f 6c 6f 6e 2c 20 22 20 6e 75 6d 2d 61 72 67 73 olon, " num-args
4780: 20 22 20 66 6f 72 20 71 75 65 72 79 20 22 20 71 " for query " q
4790: 75 65 72 79 29 0a 20 20 20 20 20 20 20 20 28 69 uery). (i
47a0: 66 20 28 3d 20 6e 75 6d 2d 61 72 67 73 20 30 29 f (= num-args 0)
47b0: 20 71 75 65 72 79 0a 20 20 20 20 20 20 20 20 20 query.
47c0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 (let loop ((s
47d0: 65 63 74 69 6f 6e 20 28 63 61 72 20 71 75 65 72 ection (car quer
47e0: 79 2d 70 61 72 74 73 29 29 0a 20 20 20 20 20 20 y-parts)).
47f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4800: 20 28 74 61 69 6c 20 20 20 20 28 63 64 72 20 71 (tail (cdr q
4810: 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 uery-parts)).
4820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4830: 20 20 20 20 28 72 65 73 75 6c 74 20 20 22 22 29 (result "")
4840: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4850: 20 20 20 20 20 20 20 20 28 61 72 67 20 20 20 20 (arg
4860: 20 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 20 (car args)).
4870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4880: 20 20 20 20 28 61 72 67 74 61 69 6c 20 28 63 64 (argtail (cd
4890: 72 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 20 r args))).
48a0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
48b0: 76 61 6c 73 74 72 20 20 20 20 28 73 3a 73 71 6c valstr (s:sql
48c0: 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 74 72 69 6e param-val->strin
48d0: 67 20 61 72 67 29 29 0a 20 20 20 20 20 20 20 20 g arg)).
48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 (ne
48f0: 77 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 72 65 wresult (conc re
4900: 73 75 6c 74 20 73 65 63 74 69 6f 6e 20 76 61 6c sult section val
4910: 73 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 str))).
4920: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
4930: 3f 20 61 72 67 74 61 69 6c 29 20 3b 3b 20 77 65 ? argtail) ;; we
4940: 20 61 72 65 20 64 6f 6e 65 0a 20 20 20 20 20 20 are done.
4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
4960: 6f 6e 63 20 6e 65 77 72 65 73 75 6c 74 20 28 63 onc newresult (c
4970: 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 20 20 ar tail)).
4980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
4990: 6f 6f 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 oop.
49a0: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 74 61 (car ta
49b0: 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 il).
49c0: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 61 (cdr ta
49d0: 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 il).
49e0: 20 20 20 20 20 20 20 20 20 6e 65 77 72 65 73 75 newresu
49f0: 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 lt.
4a00: 20 20 20 20 20 20 20 20 28 63 61 72 20 61 72 67 (car arg
4a10: 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 tail).
4a20: 20 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 (cdr
4a30: 61 72 67 74 61 69 6c 29 29 29 29 29 29 29 29 29 argtail)))))))))
4a40: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
4a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 ==========.;; M
4a90: 49 20 53 20 43 20 20 20 53 20 54 20 52 20 49 20 I S C S T R I
4aa0: 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 46 0a N G S T U F F.
4ab0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
4ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4af0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
4b00: 65 20 28 73 3a 73 74 72 69 6e 67 2d 64 6f 77 6e e (s:string-down
4b10: 63 61 73 65 20 73 74 72 29 0a 20 20 28 69 66 20 case str). (if
4b20: 28 73 74 72 69 6e 67 3f 20 73 74 72 29 0a 20 20 (string? str).
4b30: 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 6e (string-tran
4b40: 73 6c 61 74 65 20 73 74 72 20 22 41 42 43 44 45 slate str "ABCDE
4b50: 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 FGHIJKLMNOPQRSTU
4b60: 56 57 58 59 5a 22 20 22 61 62 63 64 65 66 67 68 VWXYZ" "abcdefgh
4b70: 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 ijklmnopqrstuvwx
4b80: 79 7a 22 29 0a 20 20 20 20 20 20 73 74 72 29 29 yz"). str))
4b90: 20 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 73 65 ..;; (define se
4ba0: 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 ssion:valid-char
4bb0: 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d s "abcdefghijklm
4bc0: 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 41 42 43 nopqrstuvwxyzABC
4bd0: 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 DEFGHIJKLMNOPQRS
4be0: 54 55 56 57 58 59 5a 30 31 32 33 34 35 36 37 38 TUVWXYZ012345678
4bf0: 39 22 29 0a 23 3b 28 64 65 66 69 6e 65 20 73 65 9").#;(define se
4c00: 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 ssion:valid-char
4c10: 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d s "abcdefghijklm
4c20: 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 30 31 32 nopqrstuvwxyz012
4c30: 33 34 35 36 37 38 39 22 29 20 3b 3b 20 63 6f 6f 3456789") ;; coo
4c40: 6b 69 65 73 20 61 72 65 20 63 61 73 65 20 69 6e kies are case in
4c50: 73 65 6e 73 69 74 69 76 65 2e 0a 23 3b 28 64 65 sensitive..#;(de
4c60: 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a 6e 75 6d fine session:num
4c70: 2d 76 61 6c 69 64 2d 63 68 61 72 73 20 28 73 74 -valid-chars (st
4c80: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 65 73 73 ring-length sess
4c90: 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 29 ion:valid-chars)
4ca0: 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 65 )..#;(define (se
4cb0: 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 68 2d 63 68 ssion:get-nth-ch
4cc0: 61 72 20 6e 74 68 29 0a 20 20 28 73 75 62 73 74 ar nth). (subst
4cd0: 72 69 6e 67 20 73 65 73 73 69 6f 6e 3a 76 61 6c ring session:val
4ce0: 69 64 2d 63 68 61 72 73 20 6e 74 68 20 20 28 2b id-chars nth (+
4cf0: 20 6e 74 68 20 31 29 29 29 0a 0a 23 3b 28 64 65 nth 1)))..#;(de
4d00: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
4d10: 74 2d 72 61 6e 64 2d 63 68 61 72 29 0a 20 20 28 t-rand-char). (
4d20: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 68 2d session:get-nth-
4d30: 63 68 61 72 20 28 72 61 6e 64 6f 6d 20 73 65 73 char (random ses
4d40: 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 2d 63 sion:num-valid-c
4d50: 68 61 72 73 29 29 29 0a 0a 23 3b 28 64 65 66 69 hars)))..#;(defi
4d60: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 ne (session:make
4d70: 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 6c 65 6e -rand-string len
4d80: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
4d90: 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 20 res "").
4da0: 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 20 (n 1)).
4db0: 20 20 28 69 66 20 28 3e 20 6e 20 6c 65 6e 29 20 (if (> n len)
4dc0: 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c 6f 6f res. (loo
4dd0: 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 p (string-append
4de0: 20 72 65 73 20 28 73 65 73 73 69 6f 6e 3a 67 65 res (session:ge
4df0: 74 2d 72 61 6e 64 2d 63 68 61 72 29 29 0a 20 20 t-rand-char)).
4e00: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 6e (+ n
4e10: 20 31 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 79 62 1)))))..;; mayb
4e20: 65 20 72 65 70 6c 61 63 65 20 61 62 6f 76 65 20 e replace above
4e30: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
4e40: 20 77 69 74 68 20 74 68 69 73 20 73 6f 6d 65 64 with this somed
4e50: 61 79 3f 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 ay?.;;.#;(define
4e60: 20 28 73 65 73 73 69 6f 6e 3a 67 65 6e 65 72 69 (session:generi
4e70: 63 2d 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 c-make-rand-stri
4e80: 6e 67 20 6c 65 6e 20 73 65 65 64 2d 73 74 72 69 ng len seed-stri
4e90: 6e 67 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d ng). (let ((num
4ea0: 2d 63 68 61 72 73 20 28 73 74 72 69 6e 67 2d 6c -chars (string-l
4eb0: 65 6e 67 74 68 20 73 65 65 64 2d 73 74 72 69 6e ength seed-strin
4ec0: 67 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f g))). (let lo
4ed0: 6f 70 20 28 28 72 65 73 20 22 22 29 0a 09 20 20 op ((res "")..
4ee0: 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 20 (n 1)).
4ef0: 20 20 20 20 28 6c 65 74 20 28 28 63 68 61 72 2d (let ((char-
4f00: 6e 75 6d 20 28 72 61 6e 64 6f 6d 20 6e 75 6d 2d num (random num-
4f10: 63 68 61 72 73 29 29 29 0a 09 28 69 66 20 28 3e chars)))..(if (>
4f20: 20 6e 20 6c 65 6e 29 20 72 65 73 0a 09 20 20 20 n len) res..
4f30: 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 (loop (string-a
4f40: 70 70 65 6e 64 20 72 65 73 20 28 73 75 62 73 74 ppend res (subst
4f50: 72 69 6e 67 20 73 65 65 64 2d 73 74 72 69 6e 67 ring seed-string
4f60: 20 63 68 61 72 2d 6e 75 6d 20 28 2b 20 63 68 61 char-num (+ cha
4f70: 72 2d 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 28 r-num 1)))... (
4f80: 2b 20 6e 20 31 29 29 29 29 29 29 29 0a 0a 3b 3b + n 1)))))))..;;
4f90: 20 52 65 6c 79 20 6f 6e 20 63 72 79 70 74 20 65 Rely on crypt e
4fa0: 67 67 27 73 20 64 65 66 61 75 6c 74 20 73 65 74 gg's default set
4fb0: 74 69 6e 67 73 20 62 65 69 6e 67 20 73 65 63 75 tings being secu
4fc0: 72 65 20 65 6e 6f 75 67 68 2c 20 61 63 63 65 70 re enough, accep
4fd0: 74 0a 3b 3b 20 62 61 63 6b 77 61 72 64 73 2d 63 t.;; backwards-c
4fe0: 6f 6d 70 61 74 69 62 6c 65 20 4f 70 65 6e 53 53 ompatible OpenSS
4ff0: 4c 20 63 72 79 70 74 20 70 61 73 73 77 6f 72 64 L crypt password
5000: 73 20 74 6f 6f 2e 0a 3b 3b 0a 28 64 65 66 69 6e s too..;;.(defin
5010: 65 20 28 73 3a 63 72 79 70 74 2d 70 61 73 73 77 e (s:crypt-passw
5020: 64 20 70 77 20 73 29 0a 20 20 28 63 3a 63 72 79 d pw s). (c:cry
5030: 70 74 20 70 77 20 28 6f 72 20 73 20 28 63 3a 63 pt pw (or s (c:c
5040: 72 79 70 74 2d 67 65 6e 73 61 6c 74 29 29 29 29 rypt-gensalt))))
5050: 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 61 73 ..(define (s:pas
5060: 73 77 6f 72 64 2d 6d 61 74 63 68 3f 20 70 61 73 sword-match? pas
5070: 73 77 6f 72 64 20 63 72 79 70 74 65 64 29 0a 20 sword crypted).
5080: 20 28 6c 65 74 2a 20 28 28 73 61 6c 74 20 28 73 (let* ((salt (s
5090: 75 62 73 74 72 69 6e 67 20 63 72 79 70 74 65 64 ubstring crypted
50a0: 20 30 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 0 2)).
50b0: 28 70 63 72 79 70 74 65 64 20 28 73 3a 63 72 79 (pcrypted (s:cry
50c0: 70 74 2d 70 61 73 73 77 64 20 70 61 73 73 77 6f pt-passwd passwo
50d0: 72 64 20 73 61 6c 74 29 29 29 0a 20 20 20 20 3b rd salt))). ;
50e0: 3b 20 28 73 3a 6c 6f 67 20 22 49 4e 46 4f 3a 20 ; (s:log "INFO:
50f0: 70 63 72 79 70 74 65 64 3d 22 20 70 63 72 79 70 pcrypted=" pcryp
5100: 74 65 64 20 22 20 63 72 79 70 74 65 64 3d 22 20 ted " crypted="
5110: 63 72 79 70 74 65 64 29 0a 20 20 20 20 28 61 6e crypted). (an
5120: 64 20 28 73 74 72 69 6e 67 3f 20 70 61 73 73 77 d (string? passw
5130: 6f 72 64 29 0a 20 20 20 20 20 20 20 20 20 28 73 ord). (s
5140: 74 72 69 6e 67 3f 20 70 63 72 79 70 74 65 64 29 tring? pcrypted)
5150: 0a 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e . (strin
5160: 67 3d 3f 20 70 63 72 79 70 74 65 64 20 63 72 79 g=? pcrypted cry
5170: 70 74 65 64 29 29 29 29 0a 0a 3b 3b 20 28 72 65 pted))))..;; (re
5180: 61 64 2d 6c 69 6e 65 20 28 6f 70 65 6e 2d 69 6e ad-line (open-in
5190: 70 75 74 2d 70 69 70 65 20 22 65 63 68 6f 20 66 put-pipe "echo f
51a0: 6f 6f 20 7c 20 6d 6b 70 61 73 73 77 64 20 2d 53 oo | mkpasswd -S
51b0: 20 61 62 20 2d 73 22 29 29 0a 0a 3b 3b 20 42 55 ab -s"))..;; BU
51c0: 47 3a 20 54 68 65 20 72 65 67 65 78 20 69 6d 70 G: The regex imp
51d0: 6c 65 6d 65 6e 74 73 20 61 20 72 75 6c 65 2c 20 lements a rule,
51e0: 62 75 74 20 77 68 61 74 20 72 75 6c 65 3f 20 41 but what rule? A
51f0: 48 21 20 75 73 61 7a 74 65 6d 70 65 2c 20 67 65 H! usaztempe, ge
5200: 74 20 72 69 64 20 6f 66 20 74 68 69 73 3f 20 4e t rid of this? N
5210: 6f 2c 20 74 68 69 73 20 61 6c 73 6f 20 6c 6f 6f o, this also loo
5220: 6b 73 20 66 6f 72 20 26 6b 65 79 3d 76 61 6c 75 ks for &key=valu
5230: 65 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 73 e ....(define (s
5240: 3a 76 61 6c 69 64 61 74 65 2d 75 72 69 29 0a 20 :validate-uri).
5250: 20 28 6c 65 74 20 28 28 75 72 69 20 28 67 65 74 (let ((uri (get
5260: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
5270: 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f 55 iable "REQUEST_U
5280: 52 49 22 29 29 0a 09 28 71 72 73 20 28 67 65 74 RI"))..(qrs (get
5290: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
52a0: 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 iable "QUERY_STR
52b0: 49 4e 47 22 29 29 29 0a 20 20 20 20 28 69 66 20 ING"))). (if
52c0: 28 6e 6f 74 20 75 72 69 29 0a 09 28 73 65 74 21 (not uri)..(set!
52d0: 20 75 72 69 20 71 72 73 29 29 0a 20 20 20 20 28 uri qrs)). (
52e0: 69 66 20 75 72 69 0a 09 28 73 74 72 69 6e 67 2d if uri..(string-
52f0: 6d 61 74 63 68 20 0a 09 20 28 72 65 67 65 78 70 match .. (regexp
5300: 20 22 5e 28 2f 5b 61 2d 7a 5c 5c 2d 5c 5c 2e 5f "^(/[a-z\\-\\._
5310: 3a 30 2d 39 5d 2a 29 2a 28 7c 5c 5c 3f 28 5b 41 :0-9]*)*(|\\?([A
5320: 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d 5c 5c 2b 5d -Za-z0-9_\\-\\+]
5330: 2b 3d 5b 41 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d +=[A-Za-z0-9_\\-
5340: 5c 5c 2e 5c 5c 2b 5d 2a 26 7b 30 2c 31 7d 29 2a \\.\\+]*&{0,1})*
5350: 29 24 22 29 20 75 72 69 29 0a 09 28 62 65 67 69 )$") uri)..(begi
5360: 6e 0a 09 20 20 22 52 45 51 55 45 53 54 20 55 52 n.. "REQUEST UR
5370: 49 20 4e 4f 54 20 41 56 41 49 4c 41 42 4c 45 21 I NOT AVAILABLE!
5380: 22 0a 09 20 20 28 6c 65 74 20 28 28 70 20 28 6f ".. (let ((p (o
5390: 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 22 pen-input-pipe "
53a0: 65 6e 76 22 29 29 29 0a 09 20 20 20 20 28 6c 65 env"))).. (le
53b0: 74 20 6c 6f 6f 70 20 28 28 6c 20 28 72 65 61 64 t loop ((l (read
53c0: 2d 6c 69 6e 65 20 70 29 29 0a 09 09 20 20 20 20 -line p))...
53d0: 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 09 20 (res '()))..
53e0: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
53f0: 6a 65 63 74 3f 20 6c 29 0a 09 09 20 20 72 65 73 ject? l)... res
5400: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 ... (loop (read
5410: 2d 6c 69 6e 65 20 70 29 28 63 6f 6e 73 20 28 6c -line p)(cons (l
5420: 69 73 74 20 6c 20 22 3c 42 52 3e 22 29 20 72 65 ist l "<BR>") re
5430: 73 29 29 29 29 29 0a 09 20 20 23 74 29 29 29 29 s))))).. #t))))
5440: 0a 0a 3b 3b 20 6d 6f 76 65 64 20 74 6f 20 6d 69 ..;; moved to mi
5450: 73 63 2d 73 74 6d 6c 0a 3b 3b 0a 3b 3b 20 61 6e sc-stml.;;.;; an
5460: 79 74 68 69 6e 67 20 65 78 63 65 70 74 20 61 20 ything except a
5470: 6c 69 73 74 20 69 73 20 63 6f 6e 76 65 72 74 65 list is converte
5480: 64 20 74 6f 20 61 20 73 74 72 69 6e 67 21 21 21 d to a string!!!
5490: 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 61 6e .#;(define (s:an
54a0: 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 y->string val).
54b0: 20 28 63 6f 6e 64 0a 20 20 20 28 28 73 74 72 69 (cond. ((stri
54c0: 6e 67 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 ng? val) val).
54d0: 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 ((number? val)
54e0: 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
54f0: 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f val)). ((symbo
5500: 6c 3f 20 76 61 6c 29 20 28 73 79 6d 62 6f 6c 2d l? val) (symbol-
5510: 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 20 20 >string val)).
5520: 20 28 28 65 71 3f 20 76 61 6c 20 23 66 29 20 22 ((eq? val #f) "
5530: 22 29 0a 20 20 20 28 28 65 71 3f 20 76 61 6c 20 "). ((eq? val
5540: 23 74 29 20 22 54 52 55 45 22 29 0a 20 20 20 28 #t) "TRUE"). (
5550: 28 6c 69 73 74 3f 20 76 61 6c 29 20 76 61 6c 29 (list? val) val)
5560: 0a 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 28 . (else . (
5570: 6c 65 74 20 28 28 6f 73 74 72 20 28 6f 70 65 6e let ((ostr (open
5580: 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 29 -output-string))
5590: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 ). (with-ou
55a0: 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 6f 73 74 tput-to-port ost
55b0: 72 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 r..(lambda ()..
55c0: 20 28 64 69 73 70 6c 61 79 20 76 61 6c 29 29 29 (display val)))
55d0: 0a 20 20 20 20 20 20 28 67 65 74 2d 6f 75 74 70 . (get-outp
55e0: 75 74 2d 73 74 72 69 6e 67 20 6f 73 74 72 29 29 ut-string ostr))
55f0: 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 )))..#;(define (
5600: 73 3a 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 s:any->number va
5610: 6c 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 l). (cond. ((
5620: 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 20 76 61 number? val) va
5630: 6c 29 0a 20 20 20 28 28 73 74 72 69 6e 67 3f 20 l). ((string?
5640: 76 61 6c 29 20 20 28 73 74 72 69 6e 67 2d 3e 6e val) (string->n
5650: 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 20 20 28 umber val)). (
5660: 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 20 28 (symbol? val) (
5670: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
5680: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 symbol->string v
5690: 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 20 al))). (else
56a0: 20 20 20 23 66 29 29 29 0a 0a 3b 3b 20 4e 42 2f #f)))..;; NB/
56b0: 2f 20 74 68 69 73 20 69 73 20 2a 69 6c 6c 65 67 / this is *illeg
56c0: 61 6c 2a 20 70 67 69 6e 74 0a 28 64 65 66 69 6e al* pgint.(defin
56d0: 65 20 28 73 3a 69 6c 6c 65 67 61 6c 2d 70 67 69 e (s:illegal-pgi
56e0: 6e 74 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 0a nt val). (cond.
56f0: 20 20 20 28 28 3e 20 76 61 6c 20 32 31 34 37 34 ((> val 21474
5700: 38 33 36 34 37 29 20 31 29 0a 20 20 20 28 28 3c 83647) 1). ((<
5710: 20 76 61 6c 20 2d 32 31 34 37 34 38 33 36 34 38 val -2147483648
5720: 29 20 2d 31 29 0a 20 20 20 28 65 6c 73 65 20 23 ) -1). (else #
5730: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
5740: 3a 61 6e 79 2d 3e 70 67 69 6e 74 20 76 61 6c 29 :any->pgint val)
5750: 0a 20 20 28 6c 65 74 20 28 28 6e 20 28 73 3a 61 . (let ((n (s:a
5760: 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 ny->number val))
5770: 29 0a 20 20 20 20 28 69 66 20 6e 0a 09 28 69 66 ). (if n..(if
5780: 20 28 73 3a 69 6c 6c 65 67 61 6c 2d 70 67 69 6e (s:illegal-pgin
5790: 74 20 6e 29 0a 09 20 20 20 20 23 66 0a 09 20 20 t n).. #f..
57a0: 20 20 6e 29 0a 09 6e 29 29 29 0a 0a 3b 3b 20 73 n)..n)))..;; s
57b0: 74 72 69 6e 67 20 69 73 20 61 20 73 74 72 69 6e tring is a strin
57c0: 67 20 61 6e 64 20 6e 6f 6e 2d 7a 65 72 6f 20 6c g and non-zero l
57d0: 65 6e 67 74 68 0a 28 64 65 66 69 6e 65 20 28 6d ength.(define (m
57e0: 69 73 63 3a 6e 6f 6e 2d 7a 65 72 6f 2d 73 74 72 isc:non-zero-str
57f0: 69 6e 67 20 73 74 72 29 0a 20 20 28 69 66 20 28 ing str). (if (
5800: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 73 74 72 and (string? str
5810: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 3e 20 ). (>
5820: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s
5830: 74 72 29 20 30 29 29 0a 20 20 20 20 20 20 73 74 tr) 0)). st
5840: 72 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b r. #f))..;;
5850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5890: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 74 6d 6c 2d 66 ======.;; html-f
58a0: 69 6c 74 65 72 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ilter.;;========
58b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 28 ==============.(
58f0: 64 65 66 69 6e 65 20 28 73 3a 73 70 6c 69 74 2d define (s:split-
5900: 73 74 72 69 6e 67 20 73 74 72 6e 67 20 64 65 6c string strng del
5910: 69 6d 29 0a 20 20 28 69 66 20 28 65 71 3f 20 28 im). (if (eq? (
5920: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 string-length st
5930: 72 6e 67 29 20 30 29 20 28 6c 69 73 74 20 73 74 rng) 0) (list st
5940: 72 6e 67 29 0a 20 20 20 20 20 20 28 6c 65 74 20 rng). (let
5950: 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 6d 61 6b loop ((head (mak
5960: 65 2d 73 74 72 69 6e 67 20 31 20 28 63 61 72 20 e-string 1 (car
5970: 28 73 74 72 69 6e 67 2d 3e 6c 69 73 74 20 73 74 (string->list st
5980: 72 6e 67 29 29 29 29 0a 09 09 20 28 74 61 69 6c rng))))... (tail
5990: 20 28 63 64 72 20 28 73 74 72 69 6e 67 2d 3e 6c (cdr (string->l
59a0: 69 73 74 20 73 74 72 6e 67 29 29 29 0a 09 09 20 ist strng)))...
59b0: 28 64 65 73 74 20 27 28 29 29 0a 09 09 20 28 74 (dest '())... (t
59c0: 65 6d 70 20 22 22 29 29 0a 09 28 63 6f 6e 64 20 emp ""))..(cond
59d0: 28 28 65 71 75 61 6c 3f 20 68 65 61 64 20 64 65 ((equal? head de
59e0: 6c 69 6d 29 0a 09 20 20 20 20 20 20 20 28 73 65 lim).. (se
59f0: 74 21 20 64 65 73 74 20 28 61 70 70 65 6e 64 20 t! dest (append
5a00: 64 65 73 74 20 28 6c 69 73 74 20 74 65 6d 70 29 dest (list temp)
5a10: 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 )).. (set!
5a20: 20 74 65 6d 70 20 22 22 29 29 0a 09 20 20 20 20 temp ""))..
5a30: 20 20 28 28 6e 75 6c 6c 3f 20 68 65 61 64 29 20 ((null? head)
5a40: 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 20 64 .. (set! d
5a50: 65 73 74 20 28 61 70 70 65 6e 64 20 64 65 73 74 est (append dest
5a60: 20 28 6c 69 73 74 20 74 65 6d 70 29 29 29 29 0a (list temp)))).
5a70: 09 20 20 20 20 20 20 28 65 6c 73 65 20 28 73 65 . (else (se
5a80: 74 21 20 74 65 6d 70 20 28 73 74 72 69 6e 67 2d t! temp (string-
5a90: 61 70 70 65 6e 64 20 74 65 6d 70 20 68 65 61 64 append temp head
5aa0: 29 29 29 29 20 3b 3b 20 65 6e 64 20 69 66 0a 09 )))) ;; end if..
5ab0: 28 63 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 74 61 (cond ((null? ta
5ac0: 69 6c 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 il).. (set
5ad0: 21 20 64 65 73 74 20 28 61 70 70 65 6e 64 20 64 ! dest (append d
5ae0: 65 73 74 20 28 6c 69 73 74 20 74 65 6d 70 29 29 est (list temp))
5af0: 29 20 64 65 73 74 29 0a 09 20 20 20 20 20 20 28 ) dest).. (
5b00: 65 6c 73 65 20 28 6c 6f 6f 70 20 28 6d 61 6b 65 else (loop (make
5b10: 2d 73 74 72 69 6e 67 20 31 20 28 63 61 72 20 74 -string 1 (car t
5b20: 61 69 6c 29 29 20 28 63 64 72 20 74 61 69 6c 29 ail)) (cdr tail)
5b30: 20 64 65 73 74 20 74 65 6d 70 29 29 29 29 29 29 dest temp))))))
5b40: 0a 0a 3b 3b 20 61 6c 6c 6f 77 65 64 2d 74 61 67 ..;; allowed-tag
5b50: 73 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 s is a list of t
5b60: 61 67 73 20 61 73 20 73 79 6d 62 6f 6c 73 3a 0a ags as symbols:.
5b70: 3b 3b 20 20 20 27 28 61 20 62 20 63 65 6e 74 65 ;; '(a b cente
5b80: 72 20 70 20 61 29 0a 3b 3b 20 70 61 72 73 69 6e r p a).;; parsin
5b90: 67 20 69 73 20 73 69 6d 70 6c 69 73 74 69 63 20 g is simplistic
5ba0: 61 6e 64 20 74 68 65 20 72 65 73 70 6f 6e 73 65 and the response
5bb0: 20 63 6f 6e 73 65 72 76 61 74 69 76 65 0a 3b 3b conservative.;;
5bc0: 20 69 66 20 61 20 3c 20 69 73 20 66 6f 75 6e 64 if a < is found
5bd0: 20 77 69 74 68 6f 75 74 20 74 68 65 20 74 61 67 without the tag
5be0: 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 3e 20 74 and closing > t
5bf0: 68 65 6e 0a 3b 3b 20 74 68 65 20 3c 20 6f 72 20 hen.;; the < or
5c00: 3e 20 69 73 20 72 65 70 6c 61 63 65 64 20 77 69 > is replaced wi
5c10: 74 68 20 26 6c 74 3b 20 6f 72 20 26 67 74 3b 20 th < or >
5c20: 77 69 74 68 6f 75 74 20 0a 3b 3b 20 65 76 65 6e without .;; even
5c30: 20 74 72 79 69 6e 67 20 68 61 72 64 20 74 6f 20 trying hard to
5c40: 66 69 67 75 72 65 20 6f 75 74 20 69 66 20 74 68 figure out if th
5c50: 65 72 65 20 69 73 20 61 20 6c 65 67 69 74 20 74 ere is a legit t
5c60: 61 67 20 0a 3b 3b 20 62 75 72 69 65 64 20 69 6e ag .;; buried in
5c70: 20 74 68 65 20 74 65 78 74 20 73 6f 6d 65 77 68 the text somewh
5c80: 65 72 65 2e 0a 3b 3b 20 61 20 6c 69 73 74 20 6f ere..;; a list o
5c90: 66 20 73 74 72 69 6e 67 73 20 69 73 20 72 65 74 f strings is ret
5ca0: 75 72 6e 65 64 2e 0a 3b 3b 0a 3b 3b 20 4e 4f 54 urned..;;.;; NOT
5cb0: 45 53 0a 3b 3b 20 31 2e 20 63 61 73 65 20 69 73 ES.;; 1. case is
5cc0: 20 69 6d 70 6f 72 74 61 6e 74 20 69 6e 20 74 68 important in th
5cd0: 65 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 20 6c e allowed-tags l
5ce0: 69 73 74 21 0a 3b 3b 20 32 2e 20 6f 6e 6c 79 20 ist!.;; 2. only
5cf0: 22 73 6f 6c 69 64 22 20 74 61 67 73 20 61 72 65 "solid" tags are
5d00: 20 73 75 70 70 6f 72 74 65 64 20 69 2e 65 2e 20 supported i.e.
5d10: 3c 61 20 68 72 65 66 3d 22 66 6f 6f 22 3e 20 77 <a href="foo"> w
5d20: 69 6c 6c 20 6e 6f 74 20 77 6f 72 6b 3f 0a 3b 3b ill not work?.;;
5d30: 0a 0a 3b 3b 20 28 73 3a 63 67 69 2d 6f 75 74 20 ..;; (s:cgi-out
5d40: 28 65 76 61 6c 20 28 73 3a 6f 75 74 70 75 74 20 (eval (s:output
5d50: 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 20 22 (s:html-filter "
5d60: 68 65 6c 6c 6f 3c 62 3e 67 6f 6f 64 62 79 65 3c hello<b>goodbye<
5d70: 2f 62 3e 3c 62 3e 20 65 68 22 20 27 28 61 20 62 /b><b> eh" '(a b
5d80: 20 69 29 29 29 29 0a 0a 3b 3b 20 73 74 72 61 74 i))))..;; strat
5d90: 65 67 79 0a 3b 3b 20 31 2e 20 63 6f 6e 76 65 72 egy.;; 1. conver
5da0: 74 20 5c 6e 20 74 6f 20 3c 6c 69 6e 65 66 65 65 t \n to <linefee
5db0: 64 3e 0a 3b 3b 20 32 2e 20 53 70 6c 69 74 20 6f d>.;; 2. Split o
5dc0: 6e 20 22 3c 22 0a 3b 3b 20 33 2e 20 53 70 6c 69 n "<".;; 3. Spli
5dd0: 74 20 6f 6e 20 22 3e 22 0a 3b 3b 20 34 2e 20 46 t on ">".;; 4. F
5de0: 69 78 0a 28 64 65 66 69 6e 65 20 28 73 3a 68 74 ix.(define (s:ht
5df0: 6d 6c 2d 66 69 6c 74 65 72 20 69 6e 70 75 74 2d ml-filter input-
5e00: 74 65 78 74 20 61 6c 6c 6f 77 65 64 2d 74 61 67 text allowed-tag
5e10: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 6f 6b s). (let* ((tok
5e20: 73 20 20 20 28 73 3a 73 74 72 2d 3e 74 6f 6b 73 s (s:str->toks
5e30: 20 69 6e 70 75 74 2d 74 65 78 74 29 29 0a 09 20 input-text))..
5e40: 28 74 6d 70 20 20 20 20 28 73 3a 74 6f 6b 73 2d (tmp (s:toks-
5e50: 3e 73 74 6d 6c 20 27 28 73 3a 6e 75 6c 6c 29 20 >stml '(s:null)
5e60: 23 66 20 74 6f 6b 73 20 61 6c 6c 6f 77 65 64 2d #f toks allowed-
5e70: 74 61 67 73 29 29 0a 09 20 28 72 65 73 20 20 20 tags)).. (res
5e80: 20 28 63 61 72 20 74 6d 70 29 29 0a 09 20 28 6e (car tmp)).. (n
5e90: 78 74 74 61 67 20 28 63 61 64 72 20 74 6d 70 29 xttag (cadr tmp)
5ea0: 29 0a 09 20 28 72 65 6d 20 20 20 20 28 63 61 64 ).. (rem (cad
5eb0: 64 72 20 74 6d 70 29 29 29 0a 20 20 20 20 72 65 dr tmp))). re
5ec0: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a s))..(define (s:
5ed0: 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 html-filter->str
5ee0: 69 6e 67 20 69 6e 70 75 74 2d 74 65 78 74 20 61 ing input-text a
5ef0: 6c 6c 6f 77 65 64 2d 74 61 67 73 29 0a 20 20 28 llowed-tags). (
5f00: 6c 65 74 20 28 28 6f 73 74 72 20 28 6f 70 65 6e let ((ostr (open
5f10: 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 29 -output-string))
5f20: 29 0a 20 20 20 20 3b 3b 3b 20 28 73 3a 6f 75 74 ). ;;; (s:out
5f30: 70 75 74 2d 6e 65 77 20 6f 73 74 72 20 28 73 3a put-new ostr (s:
5f40: 68 74 6d 6c 2d 66 69 6c 74 65 72 20 69 6e 70 75 html-filter inpu
5f50: 74 2d 74 65 78 74 20 61 6c 6c 6f 77 65 64 2d 74 t-text allowed-t
5f60: 61 67 73 29 29 0a 20 20 20 20 28 73 3a 6f 75 74 ags)). (s:out
5f70: 70 75 74 2d 6e 65 77 20 6f 73 74 72 20 28 63 61 put-new ostr (ca
5f80: 72 20 28 65 76 61 6c 20 28 73 3a 68 74 6d 6c 2d r (eval (s:html-
5f90: 66 69 6c 74 65 72 20 69 6e 70 75 74 2d 74 65 78 filter input-tex
5fa0: 74 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 29 t allowed-tags))
5fb0: 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 63 )). (string-c
5fc0: 68 6f 6d 70 20 28 67 65 74 2d 6f 75 74 70 75 74 homp (get-output
5fd0: 2d 73 74 72 69 6e 67 20 6f 73 74 72 29 29 29 29 -string ostr))))
5fe0: 20 3b 3b 20 64 6f 6e 27 74 20 6e 65 65 64 20 74 ;; don't need t
5ff0: 68 65 20 6c 69 6e 65 66 65 65 64 2c 20 63 6f 75 he linefeed, cou
6000: 6c 64 20 73 74 6f 70 20 61 64 64 69 6e 67 20 69 ld stop adding i
6010: 74 20 2e 2e 2e 0a 09 0a 3b 3b 20 20 20 20 20 28 t ......;; (
6020: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 29 0a 3b if (null? rem).;
6030: 3b 20 09 72 65 73 20 27 28 29 29 0a 3b 3b 20 09 ; .res '()).;; .
6040: 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 28 69 (s:toks->stml (i
6050: 66 20 28 6c 69 73 74 3f 20 72 65 73 29 20 72 65 f (list? res) re
6060: 73 20 27 28 29 29 20 23 66 20 72 65 6d 20 61 6c s '()) #f rem al
6070: 6c 6f 77 65 64 2d 74 61 67 73 29 29 29 29 0a 0a lowed-tags))))..
6080: 28 64 65 66 69 6e 65 20 28 73 3a 73 74 72 2d 3e (define (s:str->
6090: 74 6f 6b 73 20 73 74 72 29 0a 20 20 28 61 70 70 toks str). (app
60a0: 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 70 20 28 ly append (map (
60b0: 6c 61 6d 62 64 61 20 28 74 6f 6b 29 0a 09 09 20 lambda (tok)...
60c0: 20 20 20 20 20 20 28 69 6e 74 65 72 73 70 65 72 (intersper
60d0: 73 65 20 28 73 3a 73 70 6c 69 74 2d 73 74 72 69 se (s:split-stri
60e0: 6e 67 20 74 6f 6b 20 22 3e 22 29 20 22 3e 22 29 ng tok ">") ">")
60f0: 29 20 0a 09 09 20 20 20 20 20 28 69 6e 74 65 72 ) ... (inter
6100: 73 70 65 72 73 65 20 28 73 3a 73 70 6c 69 74 2d sperse (s:split-
6110: 73 74 72 69 6e 67 20 73 74 72 20 22 3c 22 29 20 string str "<")
6120: 22 3c 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 "<"))))..(define
6130: 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 61 (s:tag->stml ta
6140: 67 29 0a 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 g). (string->sy
6150: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 61 70 70 mbol (string-app
6160: 65 6e 64 20 22 73 3a 22 20 28 73 79 6d 62 6f 6c end "s:" (symbol
6170: 2d 3e 73 74 72 69 6e 67 20 74 61 67 29 29 29 29 ->string tag))))
6180: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 74 6f ...(define (s:to
6190: 6b 73 2d 3e 73 74 6d 6c 20 72 65 73 20 74 61 67 ks->stml res tag
61a0: 20 72 65 6d 20 61 6c 6c 6f 77 65 64 29 0a 20 20 rem allowed).
61b0: 3b 3b 20 28 70 72 69 6e 74 20 22 74 61 67 3a 20 ;; (print "tag:
61c0: 22 20 74 61 67 20 22 20 72 65 6d 3a 20 22 20 72 " tag " rem: " r
61d0: 65 6d 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f em). (if (null?
61e0: 20 72 65 6d 29 0a 20 20 20 20 20 20 28 6c 69 73 rem). (lis
61f0: 74 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 69 t (append res (i
6200: 66 20 74 61 67 0a 09 09 09 20 20 20 20 28 6c 69 f tag.... (li
6210: 73 74 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 st (s:tag->stml
6220: 74 61 67 29 29 0a 09 09 09 09 27 28 29 29 29 20 tag)).....'()))
6230: 23 66 20 27 28 29 20 61 6c 6c 6f 77 65 64 29 20 #f '() allowed)
6240: 3b 3b 20 74 68 65 20 63 61 73 65 20 6f 66 20 61 ;; the case of a
6250: 20 6c 6f 6e 65 20 74 61 67 20 0a 20 20 20 20 20 lone tag .
6260: 20 3b 3b 20 68 61 6e 64 6c 65 20 61 20 73 74 61 ;; handle a sta
6270: 72 74 69 6e 67 20 74 61 67 0a 20 20 20 20 20 20 rting tag.
6280: 28 6c 65 74 2a 20 28 28 74 6d 70 20 20 20 20 20 (let* ((tmp
6290: 20 20 28 73 3a 75 70 74 6f 2d 74 61 67 20 72 65 (s:upto-tag re
62a0: 6d 20 61 6c 6c 6f 77 65 64 29 29 0a 09 20 20 20 m allowed))..
62b0: 20 20 28 74 78 74 20 20 20 20 20 20 20 28 63 61 (txt (ca
62c0: 72 20 74 6d 70 29 29 20 20 20 20 20 20 3b 3b 20 r tmp)) ;;
62d0: 74 68 69 73 20 74 78 74 20 67 6f 65 73 20 77 69 this txt goes wi
62e0: 74 68 20 74 61 67 21 21 21 0a 09 20 20 20 20 20 th tag!!!..
62f0: 28 6e 65 78 74 74 61 67 20 20 20 28 63 61 64 72 (nexttag (cadr
6300: 20 74 6d 70 29 29 20 20 20 20 20 3b 3b 20 74 68 tmp)) ;; th
6310: 69 73 20 69 73 20 74 68 65 20 4e 45 58 54 20 44 is is the NEXT D
6320: 41 4d 4e 20 74 61 67 21 0a 09 20 20 20 20 20 28 AMN tag!.. (
6330: 62 65 67 69 6e 2d 74 61 67 20 28 63 61 64 64 72 begin-tag (caddr
6340: 20 74 6d 70 29 29 0a 09 20 20 20 20 20 28 6e 65 tmp)).. (ne
6350: 77 72 65 6d 20 20 20 20 28 63 61 64 64 64 72 20 wrem (cadddr
6360: 74 6d 70 29 29 29 0a 09 3b 3b 20 28 70 72 69 6e tmp)))..;; (prin
6370: 74 20 22 74 78 74 3a 20 20 20 20 20 20 20 20 22 t "txt: "
6380: 20 74 78 74 20 22 5c 6e 6e 65 78 74 74 61 67 3a txt "\nnexttag:
6390: 20 20 20 20 22 20 6e 65 78 74 74 61 67 20 22 5c " nexttag "\
63a0: 6e 62 65 67 69 6e 2d 74 61 67 3a 20 20 22 20 62 nbegin-tag: " b
63b0: 65 67 69 6e 2d 74 61 67 20 22 5c 6e 6e 65 77 72 egin-tag "\nnewr
63c0: 65 6d 3a 20 20 20 20 20 22 20 6e 65 77 72 65 6d em: " newrem
63d0: 20 22 5c 6e 72 65 73 3a 20 20 20 20 20 20 20 20 "\nres:
63e0: 22 20 72 65 73 20 22 5c 6e 22 29 0a 09 28 69 66 " res "\n")..(if
63f0: 20 62 65 67 69 6e 2d 74 61 67 20 3b 3b 20 6e 65 begin-tag ;; ne
6400: 73 74 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 st the following
6410: 20 73 74 75 66 66 0a 09 20 20 20 20 28 6c 65 74 stuff.. (let
6420: 2a 20 28 28 63 68 69 6c 64 64 61 74 20 28 73 3a * ((childdat (s:
6430: 74 6f 6b 73 2d 3e 73 74 6d 6c 20 27 28 29 20 6e toks->stml '() n
6440: 65 78 74 74 61 67 20 6e 65 77 72 65 6d 20 61 6c exttag newrem al
6450: 6c 6f 77 65 64 29 29 0a 09 09 20 20 20 28 63 68 lowed))... (ch
6460: 69 6c 64 20 20 20 20 28 63 61 72 20 63 68 69 6c ild (car chil
6470: 64 64 61 74 29 29 0a 09 09 20 20 20 28 6e 65 77 ddat))... (new
6480: 74 61 67 20 20 20 28 63 61 64 72 20 63 68 69 6c tag (cadr chil
6490: 64 64 61 74 29 29 0a 09 09 20 20 20 28 6e 65 77 ddat))... (new
64a0: 72 65 6d 32 20 20 28 63 61 64 64 72 20 63 68 69 rem2 (caddr chi
64b0: 6c 64 64 61 74 29 29 0a 09 09 20 20 20 28 61 6c lddat))... (al
64c0: 6c 6f 77 65 64 20 20 28 63 61 64 64 64 72 20 63 lowed (cadddr c
64d0: 68 69 6c 64 64 61 74 29 29 29 20 3b 3b 20 79 61 hilddat))) ;; ya
64e0: 2c 20 69 74 20 73 68 6f 75 6c 64 6e 27 74 20 68 , it shouldn't h
64f0: 61 76 65 20 63 68 61 6e 67 65 64 0a 09 20 20 20 ave changed..
6500: 20 20 20 28 69 66 20 74 61 67 20 0a 09 09 20 20 (if tag ...
6510: 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 28 61 (s:toks->stml (a
6520: 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 ppend res (list
6530: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 28 73 (append (list (s
6540: 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 61 67 29 29 :tag->stml tag))
6550: 20 63 68 69 6c 64 20 28 6c 69 73 74 20 74 78 74 child (list txt
6560: 29 29 29 29 0a 09 09 09 09 6e 65 77 74 61 67 20 )))).....newtag
6570: 6e 65 77 72 65 6d 32 20 61 6c 6c 6f 77 65 64 29 newrem2 allowed)
6580: 0a 09 09 20 20 28 73 3a 74 6f 6b 73 2d 3e 73 74 ... (s:toks->st
6590: 6d 6c 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 ml (append res (
65a0: 6c 69 73 74 20 74 78 74 29 20 63 68 69 6c 64 29 list txt) child)
65b0: 0a 09 09 09 09 6e 65 77 74 61 67 20 6e 65 77 72 .....newtag newr
65c0: 65 6d 32 20 61 6c 6c 6f 77 65 64 29 29 29 0a 09 em2 allowed)))..
65d0: 20 20 20 20 3b 3b 20 69 74 20 6d 75 73 74 20 68 ;; it must h
65e0: 61 76 65 20 62 65 65 6e 20 61 6e 20 65 6e 64 20 ave been an end
65f0: 74 61 67 0a 09 20 20 20 20 28 6c 69 73 74 20 28 tag.. (list (
6600: 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 append res (list
6610: 20 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 .... (if
6620: 74 61 67 0a 09 09 09 09 20 20 20 28 6c 69 73 74 tag..... (list
6630: 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 61 (s:tag->stml ta
6640: 67 29 20 74 78 74 29 0a 09 09 09 09 20 20 20 74 g) txt)..... t
6650: 78 74 29 29 29 0a 09 09 20 20 23 66 0a 09 09 20 xt)))... #f...
6660: 20 6e 65 77 72 65 6d 0a 09 09 20 20 61 6c 6c 6f newrem... allo
6670: 77 65 64 29 29 29 29 29 0a 0a 0a 3b 3b 20 22 3c wed)))))...;; "<
6680: 22 20 22 62 22 20 22 3e 22 20 20 3d 3e 20 22 3c " "b" ">" => "<
6690: 62 3e 22 0a 3b 3b 20 22 3c 22 0a 3b 3b 20 28 64 b>".;; "<".;; (d
66a0: 65 66 69 6e 65 20 28 73 3a 72 65 62 75 69 6c 64 efine (s:rebuild
66b0: 2d 74 61 67 73 20 69 6e 70 75 74 2d 6c 69 73 74 -tags input-list
66c0: 29 0a 0a 3b 3b 20 28 22 62 6c 61 68 20 62 6c 61 )..;; ("blah bla
66d0: 68 22 20 22 3c 22 20 22 62 22 20 22 3e 22 20 22 h" "<" "b" ">" "
66e0: 6d 6f 72 65 20 73 74 75 66 66 22 20 22 3c 22 20 more stuff" "<"
66f0: 22 69 22 20 22 3e 22 20 29 20 0a 3b 3b 20 20 20 "i" ">" ) .;;
6700: 20 20 3d 3e 20 28 22 62 6c 61 68 20 62 6c 61 68 => ("blah blah
6710: 22 20 62 20 23 74 20 28 20 22 6d 6f 72 65 20 73 " b #t ( "more s
6720: 74 75 66 66 22 20 22 3c 22 20 22 69 22 20 22 3e tuff" "<" "i" ">
6730: 22 20 29 29 0a 3b 3b 20 28 22 62 6c 61 68 20 62 " )).;; ("blah b
6740: 6c 61 68 22 20 22 3c 22 20 22 2f 62 22 20 22 3e lah" "<" "/b" ">
6750: 22 20 22 6d 6f 72 65 20 73 74 75 66 66 22 20 22 " "more stuff" "
6760: 3c 22 20 22 69 22 20 22 3e 22 20 29 20 0a 3b 3b <" "i" ">" ) .;;
6770: 20 20 20 20 20 3d 3e 20 28 22 62 6c 61 68 20 62 => ("blah b
6780: 6c 61 68 22 20 62 20 23 66 20 28 20 22 6d 6f 72 lah" b #f ( "mor
6790: 65 20 73 74 75 66 66 22 20 22 3c 22 20 22 69 22 e stuff" "<" "i"
67a0: 20 22 3e 22 20 29 29 0a 28 64 65 66 69 6e 65 20 ">" )).(define
67b0: 28 73 3a 75 70 74 6f 2d 74 61 67 20 69 6e 6c 73 (s:upto-tag inls
67c0: 74 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 0a t allowed-tags).
67d0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 69 6e 6c (if (null? inl
67e0: 73 74 29 20 69 6e 6c 73 74 0a 20 20 20 20 20 20 st) inlst.
67f0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 6f 6b 20 (let loop ((tok
6800: 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 09 (car inlst))...
6810: 20 28 74 61 69 6c 20 28 63 64 72 20 69 6e 6c 73 (tail (cdr inls
6820: 74 29 29 0a 09 09 20 28 70 72 65 6c 20 22 22 29 t))... (prel "")
6830: 29 20 3b 3b 20 63 72 65 61 74 65 20 61 20 73 74 ) ;; create a st
6840: 72 69 6e 67 20 6f 72 20 61 20 6c 69 73 74 20 6f ring or a list o
6850: 66 20 73 74 72 69 6e 67 20 70 61 72 74 73 3f 0a f string parts?.
6860: 09 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 74 .(if (string=? t
6870: 6f 6b 20 22 3c 22 29 20 3b 3b 20 6d 69 67 68 74 ok "<") ;; might
6880: 20 68 61 76 65 20 61 20 74 61 67 0a 09 20 20 20 have a tag..
6890: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
68a0: 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 6f 20 62 tail) 1) ;; to b
68b0: 65 20 61 20 74 61 67 2c 20 6e 65 65 64 20 74 61 e a tag, need ta
68c0: 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 22 3e g and closing ">
68d0: 22 0a 09 09 28 6c 65 74 20 28 28 74 61 67 20 28 "...(let ((tag (
68e0: 63 61 72 20 74 61 69 6c 29 29 0a 09 09 20 20 20 car tail))...
68f0: 20 20 20 28 65 6e 64 20 28 63 61 64 72 20 74 61 (end (cadr ta
6900: 69 6c 29 29 0a 09 09 20 20 20 20 20 20 28 72 65 il))... (re
6910: 6d 20 28 63 64 64 72 20 74 61 69 6c 29 29 29 20 m (cddr tail)))
6920: 0a 09 09 20 20 28 69 66 20 28 73 74 72 69 6e 67 ... (if (string
6930: 3d 3f 20 65 6e 64 20 22 3e 22 29 20 3b 3b 20 79 =? end ">") ;; y
6940: 65 70 2c 20 69 74 20 69 73 20 70 72 6f 62 61 62 ep, it is probab
6950: 6c 79 20 61 20 74 61 67 0a 09 09 20 20 20 20 20 ly a tag...
6960: 20 28 6c 65 74 2a 20 28 28 74 72 69 6d 2d 74 61 (let* ((trim-ta
6970: 67 20 28 69 66 20 20 28 73 74 72 69 6e 67 3d 3f g (if (string=?
6980: 20 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 20 "/" (substring
6990: 74 61 67 20 30 20 31 29 29 0a 09 09 09 09 09 20 tag 0 1))......
69a0: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 74 61 (substring ta
69b0: 67 20 31 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 g 1 (string-leng
69c0: 74 68 20 74 61 67 29 29 20 23 66 29 29 0a 09 09 th tag)) #f))...
69d0: 09 20 20 20 20 20 28 74 61 67 2d 73 79 6d 20 20 . (tag-sym
69e0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
69f0: 28 69 66 20 74 72 69 6d 2d 74 61 67 20 74 72 69 (if trim-tag tri
6a00: 6d 2d 74 61 67 20 74 61 67 29 29 29 29 0a 09 09 m-tag tag))))...
6a10: 09 28 69 66 20 28 6d 65 6d 62 65 72 20 74 61 67 .(if (member tag
6a20: 2d 73 79 6d 20 61 6c 6c 6f 77 65 64 2d 74 61 67 -sym allowed-tag
6a30: 73 29 0a 09 09 09 20 20 20 20 3b 3b 20 68 61 76 s).... ;; hav
6a40: 65 20 61 20 76 61 6c 69 64 20 74 61 67 2c 20 72 e a valid tag, r
6a50: 65 62 75 69 6c 64 20 69 74 20 61 6e 64 20 72 65 ebuild it and re
6a60: 74 75 72 6e 20 74 68 65 20 72 65 73 75 6c 74 0a turn the result.
6a70: 09 09 09 20 20 20 20 28 6c 69 73 74 20 70 72 65 ... (list pre
6a80: 6c 20 74 61 67 2d 73 79 6d 20 28 69 66 20 74 72 l tag-sym (if tr
6a90: 69 6d 2d 74 61 67 20 23 66 20 23 74 29 20 72 65 im-tag #f #t) re
6aa0: 6d 29 0a 09 09 09 20 20 20 20 3b 3b 20 6e 6f 74 m).... ;; not
6ab0: 20 61 20 76 61 6c 69 64 20 74 61 67 2c 20 63 6f a valid tag, co
6ac0: 6e 76 65 72 74 20 22 3c 22 20 61 6e 64 20 22 3e nvert "<" and ">
6ad0: 22 20 61 6e 64 20 61 64 64 20 61 6c 6c 20 74 6f " and add all to
6ae0: 20 70 72 65 6c 0a 09 09 09 20 20 20 20 28 6c 65 prel.... (le
6af0: 74 20 28 28 6e 65 77 70 72 65 6c 20 28 73 74 72 t ((newprel (str
6b00: 69 6e 67 2d 61 70 70 65 6e 64 20 70 72 65 6c 20 ing-append prel
6b10: 22 26 6c 74 3b 22 20 74 61 67 20 22 26 67 74 3b "<" tag ">
6b20: 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 "))).... (i
6b30: 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 29 28 6c 69 f (null? rem)(li
6b40: 73 74 20 6e 65 77 70 72 65 6c 20 23 66 20 23 66 st newprel #f #f
6b50: 20 27 28 29 29 20 3b 3b 20 72 65 74 75 72 6e 20 '()) ;; return
6b60: 6e 65 77 70 72 65 6c 20 2d 20 61 64 64 20 23 66 newprel - add #f
6b70: 20 23 66 20 3f 3f 3f 0a 09 09 09 09 20 20 28 6c #f ???..... (l
6b80: 6f 6f 70 20 28 63 61 72 20 72 65 6d 29 28 63 64 oop (car rem)(cd
6b90: 72 20 72 65 6d 29 20 6e 65 77 70 72 65 6c 29 29 r rem) newprel))
6ba0: 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 73 )))... ;; s
6bb0: 6f 2c 20 69 74 20 77 61 73 6e 27 74 20 61 20 74 o, it wasn't a t
6bc0: 61 67 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 ag... (let
6bd0: 28 28 6e 65 77 70 72 65 6c 20 28 73 74 72 69 6e ((newprel (strin
6be0: 67 2d 61 70 70 65 6e 64 20 70 72 65 6c 20 22 26 g-append prel "&
6bf0: 6c 74 3b 22 20 74 61 67 29 29 29 0a 09 09 09 28 lt;" tag)))....(
6c00: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a if (null? tail).
6c10: 09 09 09 20 20 20 20 28 6c 69 73 74 20 6e 65 77 ... (list new
6c20: 70 72 65 6c 20 23 66 20 23 66 20 27 28 29 29 0a prel #f #f '()).
6c30: 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
6c40: 72 20 72 65 6d 29 28 63 64 72 20 72 65 6d 29 20 r rem)(cdr rem)
6c50: 6e 65 77 70 72 65 6c 29 29 29 29 29 0a 09 09 3b newprel)))))...;
6c60: 3b 20 74 6f 6f 20 73 68 6f 72 74 20 74 6f 20 62 ; too short to b
6c70: 65 20 61 20 74 61 67 0a 09 09 28 6c 69 73 74 20 e a tag...(list
6c80: 28 61 70 70 6c 79 20 73 74 72 69 6e 67 2d 61 70 (apply string-ap
6c90: 70 65 6e 64 20 70 72 65 6c 20 22 26 6c 74 3b 22 pend prel "<"
6ca0: 20 74 61 69 6c 29 20 23 66 20 23 66 20 27 28 29 tail) #f #f '()
6cb0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c )).. (if (nul
6cc0: 6c 3f 20 74 61 69 6c 29 20 0a 09 09 3b 3b 20 77 l? tail) ...;; w
6cd0: 65 27 72 65 20 64 6f 6e 65 0a 09 09 28 6c 69 73 e're done...(lis
6ce0: 74 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 t (string-append
6cf0: 20 70 72 65 6c 20 74 6f 6b 29 20 23 66 20 23 66 prel tok) #f #f
6d00: 20 27 28 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 '())...(loop (c
6d10: 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 ar tail)(cdr tai
6d20: 6c 29 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 l)(string-append
6d30: 20 70 72 65 6c 20 74 6f 6b 29 29 29 29 29 29 29 prel tok)))))))
6d40: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 64 69 ...(define (s:di
6d50: 76 79 2d 75 70 2d 63 67 69 2d 73 74 72 20 69 6e vy-up-cgi-str in
6d60: 73 74 72 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d str). (map (lam
6d70: 62 64 61 20 28 78 29 20 28 73 74 72 69 6e 67 2d bda (x) (string-
6d80: 73 70 6c 69 74 20 78 20 22 3d 22 29 29 20 28 73 split x "=")) (s
6d90: 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e 73 74 tring-split inst
6da0: 72 20 22 26 22 29 29 29 0a 0a 28 64 65 66 69 6e r "&")))..(defin
6db0: 65 20 28 73 3a 64 65 63 6f 64 65 2d 73 74 72 20 e (s:decode-str
6dc0: 69 6e 73 74 72 29 0a 20 20 28 6c 65 74 2a 20 28 instr). (let* (
6dd0: 28 61 62 63 20 28 73 74 72 69 6e 67 2d 73 75 62 (abc (string-sub
6de0: 73 74 69 74 75 74 65 20 22 5c 5c 2b 22 20 22 20 stitute "\\+" "
6df0: 22 20 69 6e 73 74 72 20 23 74 29 29 0a 09 20 28 " instr #t)).. (
6e00: 74 6f 6b 73 20 28 73 3a 73 70 6c 69 74 2d 73 74 toks (s:split-st
6e10: 72 69 6e 67 20 61 62 63 20 22 25 22 29 29 29 0a ring abc "%"))).
6e20: 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 (if (< (leng
6e30: 74 68 20 74 6f 6b 73 29 20 32 29 20 61 62 63 0a th toks) 2) abc.
6e40: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 .(let loop ((hea
6e50: 64 20 28 63 61 64 72 20 74 6f 6b 73 29 29 0a 09 d (cadr toks))..
6e60: 09 20 20 20 28 74 61 69 6c 20 28 63 64 64 72 20 . (tail (cddr
6e70: 74 6f 6b 73 29 29 0a 09 09 20 20 20 28 72 65 73 toks))... (res
6e80: 75 6c 74 20 28 63 61 72 20 74 6f 6b 73 29 29 29 ult (car toks)))
6e90: 0a 09 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d .. (if (string=
6ea0: 3f 20 68 65 61 64 20 22 22 29 0a 09 20 20 20 20 ? head "")..
6eb0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 (if (null? tai
6ec0: 6c 29 0a 09 09 20 20 72 65 73 75 6c 74 0a 09 09 l)... result...
6ed0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 (loop (car tai
6ee0: 6c 29 28 63 64 72 20 74 61 69 6c 29 20 72 65 73 l)(cdr tail) res
6ef0: 75 6c 74 29 29 0a 09 20 20 20 20 20 20 28 6c 65 ult)).. (le
6f00: 74 2a 20 28 28 6b 65 79 20 28 73 75 62 73 74 72 t* ((key (substr
6f10: 69 6e 67 20 68 65 61 64 20 30 20 32 29 29 0a 09 ing head 0 2))..
6f20: 09 20 20 20 20 20 28 72 65 6d 20 28 73 75 62 73 . (rem (subs
6f30: 74 72 69 6e 67 20 68 65 61 64 20 32 20 28 73 74 tring head 2 (st
6f40: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 68 65 61 64 ring-length head
6f50: 29 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d 20 )))... (num
6f60: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
6f70: 6b 65 79 20 31 36 29 29 0a 09 09 20 20 20 20 20 key 16))...
6f80: 28 63 68 20 20 28 69 66 20 28 61 6e 64 20 28 6e (ch (if (and (n
6f90: 75 6d 62 65 72 3f 20 6e 75 6d 29 0a 20 20 20 20 umber? num).
6fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6fc0: 65 78 61 63 74 3f 20 6e 75 6d 29 29 0a 09 09 09 exact? num))....
6fd0: 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d 3e (integer->
6fe0: 63 68 61 72 20 6e 75 6d 29 0a 09 09 09 20 20 20 char num)....
6ff0: 20 20 20 23 66 29 29 20 3b 3b 20 74 68 69 73 20 #f)) ;; this
7000: 69 73 20 61 6e 20 65 72 72 6f 72 2e 20 49 20 77 is an error. I w
7010: 69 6c 6c 20 70 72 6f 62 61 62 6c 79 20 72 65 67 ill probably reg
7020: 72 65 74 20 74 68 69 73 20 73 6f 6d 65 20 64 61 ret this some da
7030: 79 0a 09 09 20 20 20 20 20 28 63 68 73 74 72 20 y... (chstr
7040: 20 28 69 66 20 63 68 20 28 6d 61 6b 65 2d 73 74 (if ch (make-st
7050: 72 69 6e 67 20 31 20 63 68 29 20 22 22 29 29 0a ring 1 ch) "")).
7060: 09 09 20 20 20 20 20 28 6e 65 77 72 65 73 20 28 .. (newres (
7070: 69 66 20 63 68 0a 09 09 09 09 20 28 73 74 72 69 if ch..... (stri
7080: 6e 67 2d 61 70 70 65 6e 64 20 72 65 73 75 6c 74 ng-append result
7090: 20 63 68 73 74 72 20 72 65 6d 29 0a 09 09 09 09 chstr rem).....
70a0: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
70b0: 72 65 73 75 6c 74 20 68 65 61 64 29 29 29 29 0a result head)))).
70c0: 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 68 65 61 ..;; (print "hea
70d0: 64 3a 20 22 20 68 65 61 64 20 22 20 6e 75 6d 3a d: " head " num:
70e0: 20 22 20 6e 75 6d 20 22 20 63 68 3a 20 7c 22 20 " num " ch: |"
70f0: 63 68 20 22 7c 20 63 68 73 74 72 3a 20 22 20 63 ch "| chstr: " c
7100: 68 73 74 72 29 0a 09 09 28 69 66 20 28 6e 75 6c hstr)...(if (nul
7110: 6c 3f 20 74 61 69 6c 29 0a 09 09 20 20 20 20 6e l? tail)... n
7120: 65 77 72 65 73 0a 09 09 20 20 20 20 28 6c 6f 6f ewres... (loo
7130: 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 64 72 p (car tail)(cdr
7140: 20 74 61 69 6c 29 20 6e 65 77 72 65 73 29 29 29 tail) newres)))
7150: 29 29 29 29 29 0a 0a 3b 3b 20 70 72 6f 62 61 62 )))))..;; probab
7160: 6c 79 20 61 20 62 75 67 3a 0a 3b 3b 0a 3b 3b 20 ly a bug:.;;.;;
7170: 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d 69 (s:process-cgi-i
7180: 6e 70 75 74 20 22 3d 62 61 72 22 29 0a 3b 3b 20 nput "=bar").;;
7190: 3d 3e 20 28 28 62 61 72 20 22 22 29 29 0a 3b 3b => ((bar "")).;;
71a0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 72 6f 63 .(define (s:proc
71b0: 65 73 73 2d 63 67 69 2d 69 6e 70 75 74 20 69 6e ess-cgi-input in
71c0: 73 74 72 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d str). (map (lam
71d0: 62 64 61 20 28 78 79 29 0a 20 20 20 20 20 20 20 bda (xy).
71e0: 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d (list (string-
71f0: 3e 73 79 6d 62 6f 6c 20 28 73 3a 64 65 63 6f 64 >symbol (s:decod
7200: 65 2d 73 74 72 20 28 63 61 72 20 78 79 29 29 29 e-str (car xy)))
7210: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7220: 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 (if (eq? (length
7230: 20 78 79 29 20 31 29 20 0a 20 20 20 20 20 20 20 xy) 1) .
7240: 20 20 20 20 20 20 20 20 20 20 20 20 22 22 0a 20 "".
7250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7260: 20 20 28 73 3a 64 65 63 6f 64 65 2d 73 74 72 20 (s:decode-str
7270: 28 63 61 64 72 20 78 79 29 29 29 29 29 0a 20 20 (cadr xy))))).
7280: 20 20 20 20 20 20 20 28 73 3a 64 69 76 79 2d 75 (s:divy-u
7290: 70 2d 63 67 69 2d 73 74 72 20 69 6e 73 74 72 29 p-cgi-str instr)
72a0: 29 29 0a 0a 3b 3b 20 66 6f 72 20 74 65 73 74 69 ))..;; for testi
72b0: 6e 67 20 2d 2d 20 64 65 6c 65 74 6d 65 0a 3b 3b ng -- deletme.;;
72c0: 20 28 64 65 66 69 6e 65 20 62 6c 61 68 20 22 70 (define blah "p
72d0: 6f 73 74 5f 74 69 74 6c 65 3d 25 32 42 25 32 42 ost_title=%2B%2B
72e0: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 %2B%2B%2B%2B%2B%
72f0: 32 42 25 32 42 25 32 42 25 32 42 68 65 6c 6c 6f 2B%2B%2B%2Bhello
7300: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2b 2b 2b -------------+++
7310: 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 36 25 32 ++++++++%26%26%2
7320: 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 6%26%26%26%26%26
7330: 25 32 36 25 34 30 25 34 30 25 34 30 25 34 30 25 %26%40%40%40%40%
7340: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 26 70 40%40%40%40%40&p
7350: 6f 73 74 5f 62 6f 64 79 3d 25 32 42 25 32 42 25 ost_body=%2B%2B%
7360: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 2B%2B%2B%2B%2B%2
7370: 42 25 32 42 25 32 42 25 32 42 68 65 6c 6c 6f 2d B%2B%2B%2Bhello-
7380: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2b 2b 2b 2b ------------++++
7390: 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 36 25 32 36 +++++++%26%26%26
73a0: 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 25 %26%26%26%26%26%
73b0: 32 36 25 34 30 25 34 30 25 34 30 25 34 30 25 34 26%40%40%40%40%4
73c0: 30 25 34 30 25 34 30 25 34 30 25 34 30 25 30 44 0%40%40%40%40%0D
73d0: 25 30 41 25 30 44 25 30 41 25 32 42 25 32 42 25 %0A%0D%0A%2B%2B%
73e0: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 2B%2B%2B%2B%2B%2
73f0: 42 25 32 42 25 32 42 25 32 42 68 65 6c 6c 6f 2d B%2B%2B%2Bhello-
7400: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2b 2b 2b 2b ------------++++
7410: 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 36 25 32 36 +++++++%26%26%26
7420: 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 25 %26%26%26%26%26%
7430: 32 36 25 34 30 25 34 30 25 34 30 25 34 30 25 34 26%40%40%40%40%4
7440: 30 25 34 30 25 34 30 25 34 30 25 34 30 25 30 44 0%40%40%40%40%0D
7450: 25 30 41 25 30 44 25 30 41 25 30 44 25 30 41 25 %0A%0D%0A%0D%0A%
7460: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 2B%2B%2B%2B%2B%2
7470: 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 B%2B%2B%2B%2B%2B
7480: 68 65 6c 6c 6f 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d hello-----------
7490: 2d 2d 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 --+++++++++++%26
74a0: 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 25 %26%26%26%26%26%
74b0: 32 36 25 32 36 25 32 36 25 34 30 25 34 30 25 34 26%26%26%40%40%4
74c0: 30 25 34 30 25 34 30 25 34 30 25 34 30 25 34 30 0%40%40%40%40%40
74d0: 25 34 30 26 6e 65 77 5f 70 6f 73 74 3d 53 75 62 %40&new_post=Sub
74e0: 6d 69 74 22 29 0a 3b 3b 20 28 64 65 66 69 6e 65 mit").;; (define
74f0: 20 62 6c 61 68 32 20 22 70 6f 73 74 5f 74 69 74 blah2 "post_tit
7500: 6c 65 3d 35 25 32 35 26 70 6f 73 74 5f 62 6f 64 le=5%25&post_bod
7510: 79 3d 61 6e 64 2b 31 30 25 32 35 26 6e 65 77 5f y=and+10%25&new_
7520: 70 6f 73 74 3d 53 75 62 6d 69 74 22 29 0a 0a 3b post=Submit")..;
7530: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7570: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 66 6f 72 6d 64 =======.;; formd
7580: 61 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d at.;;===========
7590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
75d0: 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 2a 64 65 fine formdat:*de
75e0: 62 75 67 2a 20 23 66 29 0a 0a 3b 3b 20 4f 6c 64 bug* #f)..;; Old
75f0: 20 64 61 74 61 20 66 6f 72 6d 61 74 20 77 61 73 data format was
7600: 20 73 6f 6d 65 74 68 69 6e 67 20 6c 69 6b 65 20 something like
7610: 74 68 69 73 2e 20 42 55 54 21 20 0a 3b 3b 20 46 this. BUT! .;; F
7620: 6f 72 6d 73 20 64 6f 20 6e 6f 74 20 68 61 76 65 orms do not have
7630: 20 6e 61 6d 65 73 20 73 6f 20 74 68 65 20 68 69 names so the hi
7640: 65 72 61 72 63 79 20 69 73 0a 3b 3b 20 75 6e 6e erarcy is.;; unn
7650: 65 63 65 73 73 61 72 79 20 28 49 20 74 68 69 6e ecessary (I thin
7660: 6b 29 0a 3b 3b 0a 3b 3b 20 68 61 73 68 74 61 62 k).;;.;; hashtab
7670: 6c 65 0a 3b 3b 20 20 20 7c 2d 66 6f 72 6d 6e 61 le.;; |-formna
7680: 6d 65 20 2d 2d 3e 20 3c 66 6f 72 6d 64 61 74 3e me --> <formdat>
7690: 20 27 66 6f 72 6d 2d 6e 61 6d 65 3d 66 6f 72 6d 'form-name=form
76a0: 6e 61 6d 65 0a 3b 3b 20 20 20 7c 20 20 20 20 20 name.;; |
76b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76c0: 20 20 20 27 66 6f 72 6d 2d 64 61 74 61 3d 68 61 'form-data=ha
76d0: 73 68 74 61 62 6c 65 0a 3b 3b 20 20 20 7c 20 20 shtable.;; |
76e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7700: 20 20 20 20 20 7c 20 6e 61 6d 65 20 3d 3e 20 76 | name => v
7710: 61 6c 75 65 0a 3b 3b 0a 3b 3b 20 4e 65 77 20 64 alue.;;.;; New d
7720: 61 74 61 20 66 6f 72 6d 61 74 20 69 73 20 6f 6e ata format is on
7730: 6c 79 20 74 68 65 20 3c 66 6f 72 6d 64 61 74 3e ly the <formdat>
7740: 20 70 6f 72 74 69 6f 6e 20 66 72 6f 6d 20 61 62 portion from ab
7750: 6f 76 65 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 2d ove..;; (define-
7760: 63 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 20 class <formdat>
7770: 28 29 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 2d 64 ().;; (form-d
7780: 61 74 61 0a 3b 3b 20 20 20 20 29 29 0a 28 64 65 ata.;; )).(de
7790: 66 69 6e 65 20 28 6d 61 6b 65 2d 66 6f 72 6d 64 fine (make-formd
77a0: 61 74 3a 66 6f 72 6d 64 61 74 29 28 76 65 63 74 at:formdat)(vect
77b0: 6f 72 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 or (make-hash-ta
77c0: 62 6c 65 29 29 29 0a 28 64 65 66 69 6e 65 2d 69 ble))).(define-i
77d0: 6e 6c 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 66 nline (formdat:f
77e0: 6f 72 6d 64 61 74 2d 67 65 74 2d 64 61 74 61 20 ormdat-get-data
77f0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
7800: 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 r-ref vec 0)).(
7810: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 66 define-inline (f
7820: 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 73 ormdat:formdat-s
7830: 65 74 2d 64 61 74 61 21 20 20 76 65 63 20 76 61 et-data! vec va
7840: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
7850: 65 63 20 30 20 76 61 6c 29 29 0a 0a 28 64 65 66 ec 0 val))..(def
7860: 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 69 6e 69 ine (formdat:ini
7870: 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 tialize self).
7880: 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 (formdat:formdat
7890: 2d 73 65 74 2d 64 61 74 61 21 20 73 65 6c 66 20 -set-data! self
78a0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
78b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6f )))..(define (fo
78c0: 72 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 20 6b rmdat:get self k
78d0: 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ey). (hash-tabl
78e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 20 e-ref/default .
78f0: 20 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 (formdat:formd
7900: 61 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 at-get-data self
7910: 29 0a 20 20 20 28 63 6f 6e 64 20 0a 20 20 20 20 ). (cond .
7920: 28 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 20 6b ((symbol? key) k
7930: 65 79 29 0a 20 20 20 20 28 28 73 74 72 69 6e 67 ey). ((string
7940: 3f 20 6b 65 79 29 20 28 73 74 72 69 6e 67 2d 3e ? key) (string->
7950: 73 79 6d 62 6f 6c 20 6b 65 79 29 29 0a 20 20 20 symbol key)).
7960: 20 28 65 6c 73 65 20 6b 65 79 29 29 0a 20 20 20 (else key)).
7970: 23 66 29 29 0a 0a 3b 3b 20 63 68 61 6e 67 65 20 #f))..;; change
7980: 74 6f 20 63 6f 6e 76 65 72 74 20 64 61 74 61 20 to convert data
7990: 74 6f 20 6c 69 73 74 20 61 6e 64 20 61 70 70 65 to list and appe
79a0: 6e 64 20 76 61 6c 20 69 66 20 61 6c 72 65 61 64 nd val if alread
79b0: 79 20 65 78 69 73 74 73 0a 3b 3b 20 6f 72 20 69 y exists.;; or i
79c0: 73 20 61 20 6c 69 73 74 0a 28 64 65 66 69 6e 65 s a list.(define
79d0: 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 73 (formdat:set! s
79e0: 65 6c 66 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 elf key val). (
79f0: 6c 65 74 20 28 28 70 72 65 76 2d 76 61 6c 20 28 let ((prev-val (
7a00: 66 6f 72 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 formdat:get self
7a10: 20 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 28 key)). (
7a20: 68 74 20 20 20 20 20 20 20 28 66 6f 72 6d 64 61 ht (formda
7a30: 74 3a 66 6f 72 6d 64 61 74 2d 67 65 74 2d 64 61 t:formdat-get-da
7a40: 74 61 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 ta self))). (
7a50: 69 66 20 70 72 65 76 2d 76 61 6c 0a 20 20 20 20 if prev-val.
7a60: 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 70 (if (list? p
7a70: 72 65 76 2d 76 61 6c 29 0a 20 20 20 20 20 20 20 rev-val).
7a80: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
7a90: 2d 73 65 74 21 20 68 74 20 6b 65 79 20 28 63 6f -set! ht key (co
7aa0: 6e 73 20 76 61 6c 20 70 72 65 76 2d 76 61 6c 29 ns val prev-val)
7ab0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 ). (h
7ac0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
7ad0: 74 20 6b 65 79 20 28 6c 69 73 74 20 76 61 6c 20 t key (list val
7ae0: 70 72 65 76 2d 76 61 6c 29 29 29 0a 20 20 20 20 prev-val))).
7af0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
7b00: 73 65 74 21 20 68 74 20 6b 65 79 20 76 61 6c 29 set! ht key val)
7b10: 29 0a 20 20 20 20 73 65 6c 66 29 29 0a 0a 28 64 ). self))..(d
7b20: 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 6b efine (formdat:k
7b30: 65 79 73 20 73 65 6c 66 29 0a 20 20 28 68 61 73 eys self). (has
7b40: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 66 6f h-table-keys (fo
7b50: 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 rmdat:formdat-ge
7b60: 74 2d 64 61 74 61 20 73 65 6c 66 29 29 29 0a 0a t-data self)))..
7b70: 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 (define (formdat
7b80: 3a 70 72 69 6e 74 61 6c 6c 20 73 65 6c 66 20 70 :printall self p
7b90: 72 69 6e 74 70 72 6f 63 29 0a 20 20 28 70 72 69 rintproc). (pri
7ba0: 6e 74 70 72 6f 63 20 22 66 6f 72 6d 64 61 74 3a ntproc "formdat:
7bb0: 70 72 69 6e 74 61 6c 6c 20 22 20 28 66 6f 72 6d printall " (form
7bc0: 64 61 74 3a 6b 65 79 73 20 73 65 6c 66 29 29 0a dat:keys self)).
7bd0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
7be0: 62 64 61 20 28 6b 29 0a 09 20 20 20 20 20 20 28 bda (k).. (
7bf0: 70 72 69 6e 74 70 72 6f 63 20 6b 20 22 20 3d 3e printproc k " =>
7c00: 20 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 " (formdat:get
7c10: 73 65 6c 66 20 6b 29 29 29 0a 09 20 20 20 20 28 self k))).. (
7c20: 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c formdat:keys sel
7c30: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 f)))..(define (f
7c40: 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 ormdat:all->stri
7c50: 6e 67 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ngs self). (let
7c60: 20 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 ((res '())).
7c70: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
7c80: 64 61 20 28 6b 29 0a 20 20 20 20 20 20 20 20 20 da (k).
7c90: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 (set! re
7ca0: 73 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 6b 20 s (cons (conc k
7cb0: 22 3d 3e 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 "=>" (formdat:ge
7cc0: 74 20 73 65 6c 66 20 6b 29 29 20 72 65 73 29 29 t self k)) res))
7cd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7ce0: 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 (formdat:keys se
7cf0: 6c 66 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 lf)). res
7d00: 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 68 ))..;; call with
7d10: 20 2a 6f 6e 65 2a 20 6f 66 20 74 68 65 20 6c 69 *one* of the li
7d20: 73 74 73 20 69 6e 20 74 68 65 20 6c 69 73 74 20 sts in the list
7d30: 6f 66 20 6c 69 73 74 73 20 63 72 65 61 74 65 64 of lists created
7d40: 20 62 79 20 43 47 49 3a 75 72 6c 2d 75 6e 71 75 by CGI:url-unqu
7d50: 6f 74 65 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 ote.(define (for
7d60: 6d 64 61 74 3a 6c 6f 61 64 20 73 65 6c 66 20 66 mdat:load self f
7d70: 6f 72 6d 6c 69 73 74 29 0a 20 20 28 6c 65 74 20 ormlist). (let
7d80: 28 28 68 74 20 20 20 20 20 20 20 20 20 20 20 20 ((ht
7d90: 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 (formdat:formda
7da0: 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 29 t-get-data self)
7db0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null
7dc0: 3f 20 66 6f 72 6d 6c 69 73 74 29 20 73 65 6c 66 ? formlist) self
7dd0: 20 3b 3b 20 6e 6f 20 76 61 6c 75 65 73 20 70 72 ;; no values pr
7de0: 6f 76 69 64 65 64 2c 20 72 65 74 75 72 6e 20 73 ovided, return s
7df0: 65 6c 66 20 66 6f 72 20 6e 6f 20 67 6f 6f 64 20 elf for no good
7e00: 72 65 61 73 6f 6e 0a 20 20 20 20 20 20 20 20 28 reason. (
7e10: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
7e20: 28 63 61 72 20 66 6f 72 6d 6c 69 73 74 29 29 0a (car formlist)).
7e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e40: 20 20 20 28 74 61 69 6c 20 28 63 64 72 20 66 6f (tail (cdr fo
7e50: 72 6d 6c 69 73 74 29 29 29 0a 20 20 20 20 20 20 rmlist))).
7e60: 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 20 28 (let ((key (
7e70: 63 61 72 20 68 65 61 64 29 29 0a 20 20 20 20 20 car head)).
7e80: 20 20 20 20 20 20 20 20 20 20 20 28 76 61 6c 20 (val
7e90: 28 63 64 72 20 68 65 61 64 29 29 29 0a 20 20 20 (cdr head))).
7ea0: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 65 72 72 ;; (err
7eb0: 3a 6c 6f 67 20 22 6b 65 79 3d 22 20 6b 65 79 20 :log "key=" key
7ec0: 22 20 76 61 6c 3d 22 20 76 61 6c 29 0a 09 20 20 " val=" val)..
7ed0: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
7ee0: 20 76 61 6c 29 20 31 29 0a 09 09 28 66 6f 72 6d val) 1)...(form
7ef0: 64 61 74 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 dat:set! self ke
7f00: 79 20 76 61 6c 29 0a 09 09 28 66 6f 72 6d 64 61 y val)...(formda
7f10: 74 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 79 20 t:set! self key
7f20: 28 63 61 72 20 76 61 6c 29 29 29 0a 20 20 20 20 (car val))).
7f30: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
7f40: 6c 3f 20 74 61 69 6c 29 20 73 65 6c 66 20 20 20 l? tail) self
7f50: 3b 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 20 ;; we are done.
7f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7f70: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
7f80: 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 29 cdr tail))))))))
7f90: 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 68 65 61 ..;; get the hea
7fa0: 64 65 72 20 66 72 6f 6d 20 64 61 74 73 74 72 0a der from datstr.
7fb0: 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 (define (formdat
7fc0: 3a 72 65 61 64 2d 68 65 61 64 65 72 20 64 61 74 :read-header dat
7fd0: 73 74 72 29 20 3b 3b 20 64 61 74 73 74 72 20 69 str) ;; datstr i
7fe0: 73 20 61 6e 20 69 6e 70 75 74 20 73 74 72 69 6e s an input strin
7ff0: 67 20 70 6f 72 74 0a 20 20 28 6c 65 74 20 6c 6f g port. (let lo
8000: 6f 70 20 28 28 68 73 20 28 72 65 61 64 2d 6c 69 op ((hs (read-li
8010: 6e 65 20 64 61 74 73 74 72 29 29 0a 09 20 20 20 ne datstr))..
8020: 20 20 28 68 65 61 64 65 72 20 27 28 29 29 29 0a (header '())).
8030: 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 6f 66 (if (or (eof
8040: 2d 6f 62 6a 65 63 74 3f 20 68 73 29 0a 09 20 20 -object? hs)..
8050: 20 20 28 73 74 72 69 6e 67 3d 3f 20 68 73 20 22 (string=? hs "
8060: 22 29 29 0a 09 68 65 61 64 65 72 0a 09 28 6c 6f "))..header..(lo
8070: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 64 61 op (read-line da
8080: 74 73 74 72 29 28 61 70 70 65 6e 64 20 68 65 61 tstr)(append hea
8090: 64 65 72 20 28 6c 69 73 74 20 68 73 29 29 29 29 der (list hs))))
80a0: 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 64 ))..;; get the d
80b0: 61 74 61 20 75 70 20 74 6f 20 74 68 65 20 6e 65 ata up to the ne
80c0: 78 74 20 6b 65 79 2e 20 69 66 20 74 68 65 72 65 xt key. if there
80d0: 20 69 73 20 6e 6f 20 6b 65 79 20 74 68 65 6e 20 is no key then
80e0: 72 65 74 75 72 6e 20 23 66 0a 3b 3b 20 72 65 74 return #f.;; ret
80f0: 75 72 6e 20 28 64 61 74 20 72 65 6d 64 61 74 29 urn (dat remdat)
8100: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
8110: 74 3a 72 65 61 64 2d 64 61 74 20 64 61 74 20 6b t:read-dat dat k
8120: 65 79 29 0a 20 20 28 6c 65 74 20 28 28 69 6e 64 ey). (let ((ind
8130: 65 78 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e ex (substring-in
8140: 64 65 78 20 6b 65 79 20 64 61 74 29 29 29 20 3b dex key dat))) ;
8150: 3b 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 ; (string-search
8160: 2d 70 6f 73 69 74 69 6f 6e 73 20 6b 65 79 20 64 -positions key d
8170: 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f at))). (if (o
8180: 72 20 28 6e 6f 74 20 69 6e 64 65 78 29 0a 09 20 r (not index)..
8190: 20 20 20 28 6e 75 6c 6c 3f 20 69 6e 64 65 78 29 (null? index)
81a0: 29 20 3b 3b 20 74 68 65 20 6b 65 79 20 77 61 73 ) ;; the key was
81b0: 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 23 66 0a 09 not found..#f..
81c0: 28 6c 65 74 2a 20 28 28 64 61 74 73 74 72 20 28 (let* ((datstr (
81d0: 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e open-input-strin
81e0: 67 20 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 g dat))..
81f0: 28 72 65 73 75 6c 74 20 28 72 65 61 64 2d 73 74 (result (read-st
8200: 72 69 6e 67 20 28 63 61 61 72 20 69 6e 64 65 78 ring (caar index
8210: 29 20 64 61 74 73 74 72 29 29 0a 09 20 20 20 20 ) datstr))..
8220: 20 20 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 (remdat (read
8230: 2d 73 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 -string #f datst
8240: 72 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 r))).. (close-i
8250: 6e 70 75 74 2d 70 6f 72 74 20 64 61 74 73 74 72 nput-port datstr
8260: 29 0a 09 20 20 28 6c 69 73 74 20 72 65 73 75 6c ).. (list resul
8270: 74 20 72 65 6d 64 61 74 29 29 29 29 29 0a 0a 20 t remdat)))))..
8280: 3b 3b 20 69 6e 70 20 69 73 20 70 6f 72 74 20 74 ;; inp is port t
8290: 6f 20 72 65 61 64 20 64 61 74 61 20 66 72 6f 6d o read data from
82a0: 2c 20 6d 61 78 73 69 7a 65 20 69 73 20 6d 61 78 , maxsize is max
82b0: 20 64 61 74 61 20 61 6c 6c 6f 77 65 64 20 74 6f data allowed to
82c0: 20 72 65 61 64 20 28 74 6f 74 61 6c 29 0a 28 64 read (total).(d
82d0: 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 64 efine (formdat:d
82e0: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 6d 61 78 at->list inp max
82f0: 73 69 7a 65 20 23 21 6b 65 79 20 28 64 65 62 75 size #!key (debu
8300: 67 2d 70 6f 72 74 20 23 66 29 29 0a 20 20 3b 3b g-port #f)). ;;
8310: 20 72 65 61 64 20 31 4d 65 67 20 63 68 75 6e 6b read 1Meg chunk
8320: 73 20 66 72 6f 6d 20 74 68 65 20 69 6e 70 75 74 s from the input
8330: 20 70 6f 72 74 2e 20 49 66 20 61 20 62 6c 6f 63 port. If a bloc
8340: 6b 20 69 73 20 6e 6f 74 20 63 6f 6d 70 6c 65 74 k is not complet
8350: 65 0a 20 20 3b 3b 20 74 61 63 6b 20 6f 6e 20 74 e. ;; tack on t
8360: 68 65 20 6e 65 78 74 20 31 4d 65 67 20 63 68 75 he next 1Meg chu
8370: 6e 6b 20 61 73 20 6e 65 65 64 65 64 2e 20 53 65 nk as needed. Se
8380: 74 20 75 70 20 73 6f 20 74 68 65 20 68 65 61 64 t up so the head
8390: 65 72 20 69 73 20 61 6c 77 61 79 73 0a 20 20 3b er is always. ;
83a0: 3b 20 61 74 20 74 68 65 20 62 65 67 69 6e 6e 69 ; at the beginni
83b0: 6e 67 20 6f 66 20 74 68 65 20 63 68 75 6e 6b 0a ng of the chunk.
83c0: 20 20 3b 3b 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ;;------------
83d0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
83e0: 2d 32 39 39 33 32 30 32 34 34 31 31 35 30 32 33 -299320244115023
83f0: 32 33 33 33 32 31 33 36 32 31 34 39 37 33 0a 20 23332136214973.
8400: 20 3b 3b 43 6f 6e 74 65 6e 74 2d 44 69 73 70 6f ;;Content-Dispo
8410: 73 69 74 69 6f 6e 3a 20 66 6f 72 6d 2d 64 61 74 sition: form-dat
8420: 61 3b 20 6e 61 6d 65 3d 22 69 6e 70 75 74 2d 70 a; name="input-p
8430: 69 63 74 75 72 65 22 3b 20 66 69 6c 65 6e 61 6d icture"; filenam
8440: 65 3d 22 62 72 65 61 64 66 72 75 69 74 2e 6a 70 e="breadfruit.jp
8450: 67 22 0a 20 20 3b 3b 43 6f 6e 74 65 6e 74 2d 54 g". ;;Content-T
8460: 79 70 65 3a 20 69 6d 61 67 65 2f 6a 70 65 67 0a ype: image/jpeg.
8470: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 64 61 (let loop ((da
8480: 74 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 t (read-string 1
8490: 30 30 30 30 30 30 20 69 6e 70 29 29 0a 09 20 20 000000 inp))..
84a0: 20 20 20 28 72 65 73 20 27 28 29 29 0a 09 20 20 (res '())..
84b0: 20 20 20 28 73 69 7a 20 30 29 29 0a 20 20 20 20 (siz 0)).
84c0: 28 69 66 20 64 65 62 75 67 2d 70 6f 72 74 20 28 (if debug-port (
84d0: 66 6f 72 6d 61 74 20 64 65 62 75 67 2d 70 6f 72 format debug-por
84e0: 74 20 22 64 61 74 3a 20 7e 41 5c 6e 22 20 64 61 t "dat: ~A\n" da
84f0: 74 29 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 t)). (if debu
8500: 67 2d 70 6f 72 74 20 28 66 6f 72 6d 61 74 20 64 g-port (format d
8510: 65 62 75 67 2d 70 6f 72 74 20 22 65 6f 66 3a 20 ebug-port "eof:
8520: 7e 41 5c 6e 22 20 28 65 6f 66 2d 6f 62 6a 65 63 ~A\n" (eof-objec
8530: 74 3f 20 28 72 65 61 64 20 69 6e 70 29 29 29 29 t? (read inp))))
8540: 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 28 3e . . (if (>
8550: 20 73 69 7a 20 6d 61 78 73 69 7a 65 29 0a 09 28 siz maxsize)..(
8560: 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 begin.. (print
8570: 22 44 41 54 41 20 54 4f 4f 20 42 49 47 22 29 0a "DATA TOO BIG").
8580: 09 20 20 72 65 73 29 0a 09 28 6c 65 74 2a 20 28 . res)..(let* (
8590: 28 64 61 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e (datstr (open-in
85a0: 70 75 74 2d 73 74 72 69 6e 67 20 64 61 74 29 29 put-string dat))
85b0: 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 72 .. (header
85c0: 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 (formdat:read-h
85d0: 65 61 64 65 72 20 64 61 74 73 74 72 29 29 0a 09 eader datstr))..
85e0: 20 20 20 20 20 20 20 28 6b 65 79 20 20 20 20 28 (key (
85f0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 68 if (not (null? h
8600: 65 61 64 65 72 29 29 28 63 61 72 20 68 65 61 64 eader))(car head
8610: 65 72 29 20 23 66 29 29 0a 09 20 20 20 20 20 20 er) #f))..
8620: 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 2d 73 (remdat (read-s
8630: 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 72 29 tring #f datstr)
8640: 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 75 73 ) ;; us
8650: 65 64 20 69 6e 20 6e 65 78 74 20 6c 69 6e 65 2c ed in next line,
8660: 20 64 69 73 63 61 72 64 20 69 66 20 67 6f 74 20 discard if got
8670: 64 61 74 61 2c 20 65 6c 73 65 20 72 65 76 65 72 data, else rever
8680: 74 20 74 6f 0a 09 20 20 20 20 20 20 20 28 61 6c t to.. (al
8690: 6c 64 61 74 20 28 69 66 20 6b 65 79 20 28 66 6f ldat (if key (fo
86a0: 72 6d 64 61 74 3a 72 65 61 64 2d 64 61 74 20 72 rmdat:read-dat r
86b0: 65 6d 64 61 74 20 6b 65 79 29 20 23 66 29 29 20 emdat key) #f))
86c0: 20 20 20 3b 3b 20 74 72 79 20 74 6f 20 65 78 74 ;; try to ext
86d0: 72 61 63 74 20 74 68 65 20 64 61 74 61 0a 09 20 ract the data..
86e0: 20 20 20 20 20 20 28 74 68 73 64 61 74 20 28 69 (thsdat (i
86f0: 66 20 61 6c 6c 64 61 74 20 28 63 61 72 20 61 6c f alldat (car al
8700: 6c 64 61 74 29 20 20 23 66 29 29 20 20 20 20 20 ldat) #f))
8710: 3b 3b 20 74 68 65 20 64 61 74 61 0a 09 20 20 20 ;; the data..
8720: 20 20 20 20 28 6e 65 77 64 61 74 20 28 69 66 20 (newdat (if
8730: 61 6c 6c 64 61 74 20 28 63 61 64 72 20 61 6c 6c alldat (cadr all
8740: 64 61 74 29 20 23 66 29 29 20 20 20 20 20 3b 3b dat) #f)) ;;
8750: 20 6c 65 66 74 20 6f 76 65 72 20 64 61 74 61 2c left over data,
8760: 20 6d 75 73 74 20 70 72 6f 63 65 73 73 20 2e 2e must process ..
8770: 2e 0a 09 20 20 20 20 20 20 20 28 74 68 73 72 65 ... (thsre
8780: 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 20 74 s (list header t
8790: 68 73 64 61 74 29 29 20 20 20 20 20 20 20 20 20 hsdat))
87a0: 20 20 20 20 3b 3b 20 73 70 65 63 75 6c 61 74 69 ;; speculati
87b0: 76 65 6c 79 20 63 6f 6e 73 74 72 75 63 74 20 72 vely construct r
87c0: 65 73 75 6c 74 73 0a 09 20 20 20 20 20 20 20 28 esults.. (
87d0: 6e 65 77 72 65 73 20 28 61 70 70 65 6e 64 20 72 newres (append r
87e0: 65 73 20 28 6c 69 73 74 20 74 68 73 72 65 73 29 es (list thsres)
87f0: 29 29 29 20 20 20 20 20 20 3b 3b 20 73 70 65 63 ))) ;; spec
8800: 75 6c 61 74 69 76 65 6c 79 20 63 6f 6e 73 74 72 ulatively constr
8810: 75 63 74 20 72 65 73 75 6c 74 73 0a 09 20 20 28 uct results.. (
8820: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
8830: 20 64 61 74 73 74 72 29 0a 09 20 20 28 63 6f 6e datstr).. (con
8840: 64 0a 09 20 20 20 3b 3b 20 65 69 74 68 65 72 20 d.. ;; either
8850: 6e 6f 20 68 65 61 64 65 72 20 6f 72 20 73 69 6e no header or sin
8860: 67 6c 65 20 69 6e 70 75 74 0a 09 20 20 20 28 28 gle input.. ((
8870: 61 6e 64 20 28 6e 6f 74 20 61 6c 6c 64 61 74 29 and (not alldat)
8880: 0a 09 09 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 68 ... (or (null? h
8890: 65 61 64 65 72 29 0a 09 09 20 20 20 20 20 28 6e eader)... (n
88a0: 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ot (string-match
88b0: 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d 2d 70 formdat:delim-p
88c0: 61 74 74 2d 72 65 78 20 28 63 61 72 20 68 65 61 att-rex (car hea
88d0: 64 65 72 29 29 29 29 29 0a 09 20 20 20 20 3b 3b der))))).. ;;
88e0: 20 28 70 72 69 6e 74 20 22 47 6f 74 20 68 65 72 (print "Got her
88f0: 65 22 29 0a 09 20 20 20 20 28 63 6f 6e 73 20 28 e").. (cons (
8900: 6c 69 73 74 20 68 65 61 64 65 72 20 22 22 29 20 list header "")
8910: 72 65 73 29 29 20 3b 3b 20 6e 6f 74 65 20 75 73 res)) ;; note us
8920: 65 20 68 65 61 64 65 72 20 61 73 20 64 61 74 20 e header as dat
8930: 61 6e 64 20 75 73 65 20 22 22 20 61 73 20 68 65 and use "" as he
8940: 61 64 65 72 3f 3f 3f 3f 0a 09 20 20 20 3b 3b 20 ader????.. ;;
8950: 64 69 64 6e 27 74 20 66 69 6e 64 20 65 6e 64 20 didn't find end
8960: 6b 65 79 20 69 6e 20 74 68 69 73 20 62 6c 6f 63 key in this bloc
8970: 6b 0a 09 20 20 20 28 28 6e 6f 74 20 61 6c 6c 64 k.. ((not alld
8980: 61 74 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 at).. (let ((
8990: 6d 6f 72 64 61 74 20 28 72 65 61 64 2d 73 74 72 mordat (read-str
89a0: 69 6e 67 20 31 30 30 30 30 30 30 20 69 6e 70 29 ing 1000000 inp)
89b0: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 )).. (if (s
89c0: 74 72 69 6e 67 3d 3f 20 6d 6f 72 64 61 74 20 22 tring=? mordat "
89d0: 22 29 20 3b 3b 20 74 68 65 72 65 20 69 73 20 6e ") ;; there is n
89e0: 6f 20 6d 6f 72 65 20 64 61 74 61 2c 20 64 69 73 o more data, dis
89f0: 63 61 72 64 20 72 65 73 75 6c 74 73 20 61 6e 64 card results and
8a00: 20 75 73 65 20 72 65 6d 64 61 74 20 61 73 20 64 use remdat as d
8a10: 61 74 61 2c 20 74 68 69 73 20 69 6e 70 75 74 20 ata, this input
8a20: 69 73 20 62 72 6f 6b 65 6e 0a 09 09 20 20 28 63 is broken... (c
8a30: 6f 6e 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 ons (list header
8a40: 20 72 65 6d 64 61 74 29 20 72 65 73 29 0a 09 09 remdat) res)...
8a50: 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d (loop (string-
8a60: 61 70 70 65 6e 64 20 64 61 74 20 6d 6f 72 64 61 append dat morda
8a70: 74 29 20 72 65 73 20 28 2b 20 73 69 7a 20 32 30 t) res (+ siz 20
8a80: 30 30 30 30 30 29 29 29 29 29 20 3b 3b 20 61 64 00000))))) ;; ad
8a90: 64 20 74 68 65 20 65 78 74 72 61 20 31 30 30 30 d the extra 1000
8aa0: 30 30 30 0a 09 20 20 20 28 61 6c 6c 64 61 74 20 000.. (alldat
8ab0: 3b 3b 20 67 6f 74 20 64 61 74 61 2c 20 64 6f 6e ;; got data, don
8ac0: 27 74 20 61 74 74 65 6d 70 74 20 74 6f 20 63 68 't attempt to ch
8ad0: 65 63 6b 20 69 66 20 74 68 65 72 65 20 69 73 20 eck if there is
8ae0: 6d 6f 72 65 2c 20 6a 75 73 74 20 6c 6f 6f 70 20 more, just loop
8af0: 61 6e 64 20 72 65 6c 79 20 6f 6e 20 28 6e 6f 74 and rely on (not
8b00: 20 61 6c 6c 64 61 74 29 20 74 6f 20 67 65 74 20 alldat) to get
8b10: 6d 6f 72 65 20 64 61 74 61 0a 09 20 20 20 20 28 more data.. (
8b20: 6c 6f 6f 70 20 6e 65 77 64 61 74 20 6e 65 77 72 loop newdat newr
8b30: 65 73 20 28 2b 20 73 69 7a 20 31 30 30 30 30 30 es (+ siz 100000
8b40: 30 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 0))))))))..(defi
8b50: 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 ne formdat:bin-d
8b60: 61 74 61 2d 64 69 73 70 2d 72 65 78 20 28 72 65 ata-disp-rex (re
8b70: 67 65 78 70 20 22 5e 43 6f 6e 74 65 6e 74 2d 44 gexp "^Content-D
8b80: 69 73 70 6f 73 69 74 69 6f 6e 3a 5c 5c 73 2b 66 isposition:\\s+f
8b90: 6f 72 6d 2d 64 61 74 61 3b 22 29 29 0a 28 64 65 orm-data;")).(de
8ba0: 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e fine formdat:bin
8bb0: 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 28 -data-name-rex (
8bc0: 72 65 67 65 78 70 20 22 5c 5c 57 6e 61 6d 65 3d regexp "\\Wname=
8bd0: 5c 22 28 5b 5e 5c 22 5d 2b 29 5c 22 22 29 29 0a \"([^\"]+)\"")).
8be0: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
8bf0: 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d 72 65 bin-file-name-re
8c00: 78 20 28 72 65 67 65 78 70 20 22 5c 5c 57 66 69 x (regexp "\\Wfi
8c10: 6c 65 6e 61 6d 65 3d 5c 22 28 5b 5e 5c 22 5d 2b lename=\"([^\"]+
8c20: 29 5c 22 22 29 29 0a 28 64 65 66 69 6e 65 20 66 )\"")).(define f
8c30: 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c 65 2d ormdat:bin-file-
8c40: 74 79 70 65 2d 72 65 78 20 28 72 65 67 65 78 70 type-rex (regexp
8c50: 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 5c "Content-Type:\
8c60: 5c 73 2b 28 5b 5e 5c 5c 73 5d 2b 29 22 29 29 0a \s+([^\\s]+)")).
8c70: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
8c80: 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 20 delim-patt-rex
8c90: 20 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 2d 2b (regexp "^\\-+
8ca0: 5b 30 2d 39 5d 2b 5c 5c 2d 2a 24 22 29 29 0a 0a [0-9]+\\-*$"))..
8cb0: 3b 3b 20 72 65 74 75 72 6e 73 20 61 20 68 61 73 ;; returns a has
8cc0: 68 20 77 69 74 68 20 65 6e 74 72 69 65 73 20 66 h with entries f
8cd0: 6f 72 20 61 6c 6c 20 66 6f 72 6d 73 20 2d 20 63 or all forms - c
8ce0: 6f 75 6c 64 20 77 65 6c 6c 20 75 73 65 20 61 20 ould well use a
8cf0: 70 72 6f 70 6c 69 73 74 3f 0a 28 64 65 66 69 6e proplist?.(defin
8d00: 65 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d e (formdat:load-
8d10: 61 6c 6c 29 0a 20 20 28 6c 65 74 20 28 28 72 65 all). (let ((re
8d20: 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 28 67 65 quest-method (ge
8d30: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
8d40: 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f riable "REQUEST_
8d50: 4d 45 54 48 4f 44 22 29 29 29 0a 20 20 20 20 28 METHOD"))). (
8d60: 69 66 20 28 61 6e 64 20 72 65 71 75 65 73 74 2d if (and request-
8d70: 6d 65 74 68 6f 64 0a 09 20 20 20 20 20 28 73 74 method.. (st
8d80: 72 69 6e 67 3d 3f 20 72 65 71 75 65 73 74 2d 6d ring=? request-m
8d90: 65 74 68 6f 64 20 22 50 4f 53 54 22 29 29 0a 09 ethod "POST"))..
8da0: 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c (formdat:load-al
8db0: 6c 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d l-port (current-
8dc0: 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 29 29 0a input-port))))).
8dd0: 0a 3b 3b 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 .;; (s:process-c
8de0: 67 69 2d 69 6e 70 75 74 20 28 63 61 61 61 72 20 gi-input (caaar
8df0: 64 61 74 29 29 0a 28 64 65 66 69 6e 65 20 28 66 dat)).(define (f
8e00: 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 2d ormdat:load-all-
8e10: 70 6f 72 74 20 69 6e 70 29 0a 20 20 28 6c 65 74 port inp). (let
8e20: 2a 20 28 28 66 6f 72 6d 64 61 74 20 20 20 20 20 * ((formdat
8e30: 20 20 20 28 6d 61 6b 65 2d 66 6f 72 6d 64 61 74 (make-formdat
8e40: 3a 66 6f 72 6d 64 61 74 29 29 0a 09 20 28 64 65 :formdat)).. (de
8e50: 62 75 67 70 20 20 20 20 20 20 20 20 20 23 66 29 bugp #f)
8e60: 29 0a 09 09 09 20 3b 3b 20 28 6f 70 65 6e 2d 6f ).... ;; (open-o
8e70: 75 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 utput-file (conc
8e80: 20 22 2f 74 6d 70 2f 64 65 6c 6d 65 2d 22 20 28 "/tmp/delme-" (
8e90: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
8ea0: 20 22 2e 6c 6f 67 22 29 29 29 29 0a 20 20 20 20 ".log")))).
8eb0: 3b 3b 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 ;; (write-string
8ec0: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 (read-string #f
8ed0: 20 69 6e 70 29 20 23 66 20 64 65 62 75 67 70 29 inp) #f debugp)
8ee0: 20 20 3b 3b 20 64 65 73 74 72 6f 79 73 20 61 6c ;; destroys al
8ef0: 6c 20 64 61 74 61 21 0a 20 20 20 20 28 66 6f 72 l data!. (for
8f00: 6d 64 61 74 3a 69 6e 69 74 69 61 6c 69 7a 65 20 mdat:initialize
8f10: 66 6f 72 6d 64 61 74 29 0a 20 20 20 20 28 6c 65 formdat). (le
8f20: 74 20 28 28 61 6c 6c 64 61 74 73 20 28 66 6f 72 t ((alldats (for
8f30: 6d 64 61 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 mdat:dat->list i
8f40: 6e 70 20 31 30 65 36 20 64 65 62 75 67 2d 70 6f np 10e6 debug-po
8f50: 72 74 3a 20 64 65 62 75 67 70 29 29 29 0a 20 20 rt: debugp))).
8f60: 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 64 . (if d
8f70: 65 62 75 67 70 20 28 66 6f 72 6d 61 74 20 64 65 ebugp (format de
8f80: 62 75 67 70 20 22 66 6f 72 6d 64 61 74 20 3a 20 bugp "formdat :
8f90: 61 6c 6c 64 61 74 73 3a 20 7e 41 5c 6e 22 20 61 alldats: ~A\n" a
8fa0: 6c 6c 64 61 74 73 29 29 0a 0a 20 20 20 20 20 20 lldats))..
8fb0: 28 6c 65 74 20 28 28 66 69 72 73 74 69 74 65 6d (let ((firstitem
8fc0: 20 20 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 (car alldats)
8fd0: 29 0a 09 20 20 20 20 28 6d 75 6c 74 69 70 61 73 ).. (multipas
8fe0: 73 20 23 66 29 29 20 0a 09 28 69 66 20 28 61 6e s #f)) ..(if (an
8ff0: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 69 d (not (null? fi
9000: 72 73 74 69 74 65 6d 29 29 0a 09 09 20 28 6e 6f rstitem))... (no
9010: 74 20 28 6e 75 6c 6c 3f 20 28 63 61 72 20 66 69 t (null? (car fi
9020: 72 73 74 69 74 65 6d 29 29 29 29 0a 09 20 20 20 rstitem))))..
9030: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
9040: 63 68 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d ch formdat:delim
9050: 2d 70 61 74 74 2d 72 65 78 20 28 63 61 61 72 20 -patt-rex (caar
9060: 66 69 72 73 74 69 74 65 6d 29 29 0a 09 09 28 73 firstitem))...(s
9070: 65 74 21 20 6d 75 6c 74 69 70 61 73 73 20 23 74 et! multipass #t
9080: 29 29 29 0a 09 28 69 66 20 6d 75 6c 74 69 70 61 )))..(if multipa
9090: 73 73 0a 09 20 20 20 20 3b 3b 20 68 61 6e 64 6c ss.. ;; handl
90a0: 65 20 6d 75 6c 74 69 2d 70 61 72 74 20 66 6f 72 e multi-part for
90b0: 6d 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 m.. (for-each
90c0: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 6c 73 74 (lambda (datlst
90d0: 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 68 65 61 )....(let* ((hea
90e0: 64 65 72 20 28 66 6f 72 6d 64 61 74 3a 65 78 74 der (formdat:ext
90f0: 72 61 63 74 2d 68 65 61 64 65 72 2d 69 6e 66 6f ract-header-info
9100: 20 28 63 61 72 20 64 61 74 6c 73 74 29 29 29 0a (car datlst))).
9110: 09 09 09 20 20 20 20 20 20 20 28 6e 61 6d 65 20 ... (name
9120: 20 20 28 69 66 20 28 61 73 73 6f 63 20 27 6e 61 (if (assoc 'na
9130: 6d 65 20 68 65 61 64 65 72 29 0a 09 09 09 09 09 me header)......
9140: 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 (string->symb
9150: 6f 6c 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 ol (cadr (assoc
9160: 27 6e 61 6d 65 20 68 65 61 64 65 72 29 29 29 0a 'name header))).
9170: 09 09 09 09 09 20 20 20 22 22 29 29 20 3b 3b 20 ..... "")) ;;
9180: 67 72 75 6d 62 6c 65 0a 09 09 09 20 20 20 20 20 grumble....
9190: 20 20 28 66 6e 61 6d 65 6c 20 20 28 61 73 73 6f (fnamel (asso
91a0: 63 20 27 66 69 6c 65 6e 61 6d 65 20 68 65 61 64 c 'filename head
91b0: 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 er)).... (
91c0: 63 6f 6e 74 65 6e 74 20 28 61 73 73 6f 63 20 27 content (assoc '
91d0: 63 6f 6e 74 65 6e 74 20 68 65 61 64 65 72 29 29 content header))
91e0: 0a 09 09 09 20 20 20 20 20 20 20 28 64 61 74 20 .... (dat
91f0: 20 20 20 28 63 61 64 72 20 64 61 74 6c 73 74 29 (cadr datlst)
9200: 29 29 0a 09 09 09 20 20 3b 3b 20 28 70 72 69 6e )).... ;; (prin
9210: 74 20 22 68 65 61 64 65 72 3a 20 22 20 68 65 61 t "header: " hea
9220: 64 65 72 20 22 20 6e 61 6d 65 3a 20 22 20 6e 61 der " name: " na
9230: 6d 65 20 22 20 66 6e 61 6d 65 6c 3a 20 22 20 66 me " fnamel: " f
9240: 6e 61 6d 65 6c 20 22 20 63 6f 6e 74 65 6e 74 3a namel " content:
9250: 20 22 20 63 6f 6e 74 65 6e 74 29 20 3b 3b 20 20 " content) ;;
9260: 22 20 64 61 74 3a 20 22 20 28 64 61 74 29 0a 09 " dat: " (dat)..
9270: 09 09 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 .. (formdat:set
9280: 21 20 66 6f 72 6d 64 61 74 20 0a 09 09 09 09 09 ! formdat ......
9290: 6e 61 6d 65 0a 09 09 09 09 09 28 69 66 20 66 6e name......(if fn
92a0: 61 6d 65 6c 20 0a 09 09 09 09 09 20 20 20 20 28 amel ...... (
92b0: 6c 69 73 74 20 28 63 61 64 72 20 66 6e 61 6d 65 list (cadr fname
92c0: 6c 29 0a 09 09 09 09 09 09 20 20 28 69 66 20 63 l)....... (if c
92d0: 6f 6e 74 65 6e 74 0a 09 09 09 09 09 09 20 20 20 ontent.......
92e0: 20 20 20 28 63 61 64 72 20 63 6f 6e 74 65 6e 74 (cadr content
92f0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 22 75 )....... "u
9300: 6e 6b 6e 6f 77 6e 22 29 0a 09 09 09 09 09 09 20 nknown").......
9310: 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f 62 20 64 (string->blob d
9320: 61 74 29 29 0a 09 09 09 09 09 20 20 20 20 64 61 at))...... da
9330: 74 29 29 29 29 0a 09 09 20 20 20 20 20 20 61 6c t))))... al
9340: 6c 64 61 74 73 29 0a 09 20 20 20 20 3b 3b 20 68 ldats).. ;; h
9350: 61 6e 64 6c 65 20 73 69 6e 67 6c 65 20 70 61 72 andle single par
9360: 74 20 66 6f 72 6d 0a 09 20 20 20 20 3b 3b 20 09 t form.. ;; .
9370: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
9380: 3f 20 6e 61 6d 65 29 0a 09 20 20 20 20 3b 3b 20 ? name).. ;;
9390: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 3d 3f .. (string=?
93a0: 20 6e 61 6d 65 20 22 22 29 29 20 3b 3b 20 74 68 name "")) ;; th
93b0: 69 73 20 69 73 20 74 68 65 20 73 68 6f 72 74 20 is is the short
93c0: 66 6f 72 6d 20 69 6e 70 75 74 20 49 20 67 75 65 form input I gue
93d0: 73 73 0a 09 20 20 20 20 3b 3b 20 09 09 28 6c 65 ss.. ;; ..(le
93e0: 74 2a 20 28 28 64 61 74 73 74 72 20 28 63 61 61 t* ((datstr (caa
93f0: 72 20 64 61 74 6c 73 74 29 29 0a 09 20 20 20 20 r datlst))..
9400: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 6d 75 6e ;; .. (mun
9410: 67 65 64 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 ged (s:process-c
9420: 67 69 2d 69 6e 70 75 74 20 64 61 74 73 74 72 29 gi-input datstr)
9430: 29 29 0a 09 20 20 20 20 3b 3b 20 09 09 20 20 28 )).. ;; .. (
9440: 70 72 69 6e 74 20 22 64 61 74 73 74 72 3a 20 22 print "datstr: "
9450: 20 64 61 74 73 74 72 20 22 20 6d 75 6e 67 65 64 datstr " munged
9460: 3a 20 22 20 6d 75 6e 67 65 64 29 0a 09 20 20 20 : " munged)..
9470: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
9480: 6e 75 6c 6c 3f 20 61 6c 6c 64 61 74 73 29 29 0a null? alldats)).
9490: 09 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c .. (not (nul
94a0: 6c 3f 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 l? (car alldats)
94b0: 29 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 28 ))... (not (
94c0: 6e 75 6c 6c 3f 20 28 63 61 61 72 20 61 6c 6c 64 null? (caar alld
94d0: 61 74 73 29 29 29 29 0a 09 09 28 66 6f 72 6d 64 ats))))...(formd
94e0: 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 at:load formdat
94f0: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
9500: 69 6e 70 75 74 20 28 63 61 61 61 72 20 61 6c 6c input (caaar all
9510: 64 61 74 73 29 29 29 29 29 20 3b 3b 20 6d 75 6e dats))))) ;; mun
9520: 67 65 64 29 29 0a 09 3b 3b 09 09 20 20 20 20 28 ged))..;;.. (
9530: 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 66 format debugp "f
9540: 6f 72 6d 64 61 74 20 3a 20 6e 61 6d 65 3a 20 7e ormdat : name: ~
9550: 41 20 63 6f 6e 74 65 6e 74 3a 20 7e 41 5c 6e 22 A content: ~A\n"
9560: 20 6e 61 6d 65 20 63 6f 6e 74 65 6e 74 29 0a 09 name content)..
9570: 28 69 66 20 64 65 62 75 67 70 20 28 63 6c 6f 73 (if debugp (clos
9580: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 64 65 e-output-port de
9590: 62 75 67 70 29 29 0a 09 66 6f 72 6d 64 61 74 29 bugp))..formdat)
95a0: 29 29 29 0a 09 09 0a 23 7c 0a 28 64 65 66 69 6e )))....#|.(defin
95b0: 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 e inp (open-inpu
95c0: 74 2d 66 69 6c 65 20 22 74 65 73 74 73 2f 65 78 t-file "tests/ex
95d0: 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 6e 22 29 29 ample.post.in"))
95e0: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
95f0: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
9600: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 73 74 )).(define datst
9610: 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 r (open-input-st
9620: 72 69 6e 67 20 64 61 74 29 29 0a 0a 3b 3b 20 6f ring dat))..;; o
9630: 72 0a 0a 28 64 65 66 69 6e 65 20 69 6e 70 20 28 r..(define inp (
9640: 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 open-input-file
9650: 22 74 65 73 74 73 2f 65 78 61 6d 70 6c 65 2e 70 "tests/example.p
9660: 6f 73 74 2e 62 69 6e 61 72 79 2e 69 6e 22 29 29 ost.binary.in"))
9670: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
9680: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
9690: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 73 74 )).(define datst
96a0: 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 r (open-input-st
96b0: 72 69 6e 67 20 64 61 74 29 29 0a 0a 28 66 6f 72 ring dat))..(for
96c0: 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 64 65 72 mdat:read-header
96d0: 20 64 61 74 73 74 72 29 0a 0a 28 64 65 66 69 6e datstr)..(defin
96e0: 65 20 64 61 74 20 28 66 6f 72 6d 64 61 74 3a 64 e dat (formdat:d
96f0: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 30 65 at->list inp 10e
9700: 36 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 74 6)).(close-input
9710: 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a 20 20 -port inp).|#.
9720: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
9730: 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 65 72 t:extract-header
9740: 2d 69 6e 66 6f 20 68 65 61 64 65 72 29 0a 20 20 -info header).
9750: 28 69 66 20 28 6e 75 6c 6c 3f 20 68 65 61 64 65 (if (null? heade
9760: 72 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 r). '().
9770: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
9780: 65 64 20 28 63 61 72 20 68 65 61 64 65 72 29 29 ed (car header))
9790: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 68 65 ... (tal (cdr he
97a0: 61 64 65 72 29 29 0a 09 09 20 28 72 65 73 20 27 ader))... (res '
97b0: 28 29 29 29 0a 09 28 69 66 20 28 73 74 72 69 6e ()))..(if (strin
97c0: 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a g-match formdat:
97d0: 62 69 6e 2d 64 61 74 61 2d 64 69 73 70 2d 72 65 bin-data-disp-re
97e0: 78 20 68 65 64 29 20 3b 3b 20 0a 09 20 20 20 20 x hed) ;; ..
97f0: 28 6c 65 74 2a 20 28 28 64 61 74 61 2d 6e 61 6d (let* ((data-nam
9800: 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 em (string-match
9810: 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 61 74 formdat:bin-dat
9820: 61 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 29 a-name-rex hed))
9830: 0a 09 09 20 20 20 28 66 69 6c 65 2d 6e 61 6d 65 ... (file-name
9840: 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 m (string-match
9850: 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c 65 formdat:bin-file
9860: 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 29 0a -name-rex hed)).
9870: 09 09 20 20 20 28 64 61 74 61 2d 6e 61 6d 65 20 .. (data-name
9880: 20 28 69 66 20 64 61 74 61 2d 6e 61 6d 65 6d 20 (if data-namem
9890: 28 63 61 64 72 20 64 61 74 61 2d 6e 61 6d 65 6d (cadr data-namem
98a0: 29 20 23 66 29 29 0a 09 09 20 20 20 28 74 68 69 ) #f))... (thi
98b0: 73 20 20 20 20 20 20 20 28 69 66 20 66 69 6c 65 s (if file
98c0: 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 20 20 28 6c -namem..... (l
98d0: 69 73 74 20 28 6c 69 73 74 20 27 6e 61 6d 65 20 ist (list 'name
98e0: 64 61 74 61 2d 6e 61 6d 65 29 28 6c 69 73 74 20 data-name)(list
98f0: 27 66 69 6c 65 6e 61 6d 65 20 28 63 61 64 72 20 'filename (cadr
9900: 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 29 0a 09 09 file-namem)))...
9910: 09 09 20 20 20 28 6c 69 73 74 20 28 6c 69 73 74 .. (list (list
9920: 20 27 6e 61 6d 65 20 64 61 74 61 2d 6e 61 6d 65 'name data-name
9930: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 ))))).. (if
9940: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
9950: 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 (append res thi
9960: 73 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 s)... (loop (ca
9970: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
9980: 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 73 29 append res this)
9990: 29 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 ))).. (let ((
99a0: 63 6f 6e 74 65 6e 74 20 28 73 74 72 69 6e 67 2d content (string-
99b0: 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 match formdat:bi
99c0: 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 n-file-type-rex
99d0: 68 65 64 29 29 29 20 3b 3b 20 74 68 69 73 20 69 hed))) ;; this i
99e0: 73 20 74 68 65 20 73 74 61 6e 7a 61 20 66 6f 72 s the stanza for
99f0: 20 74 68 65 20 63 6f 6e 74 65 6e 74 20 74 79 70 the content typ
9a00: 65 0a 09 20 20 20 20 20 20 28 69 66 20 63 6f 6e e.. (if con
9a10: 74 65 6e 74 0a 09 09 20 20 28 6c 65 74 20 28 28 tent... (let ((
9a20: 6e 65 77 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 newres (cons (li
9a30: 73 74 20 27 63 6f 6e 74 65 6e 74 20 28 63 61 64 st 'content (cad
9a40: 72 20 63 6f 6e 74 65 6e 74 29 29 20 72 65 73 29 r content)) res)
9a50: 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 ))... (if (nu
9a60: 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 6e 65 77 72 ll? tal)....newr
9a70: 65 73 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 es....(loop (car
9a80: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e tal)(cdr tal) n
9a90: 65 77 72 65 73 29 29 29 0a 09 09 20 20 28 69 66 ewres)))... (if
9aa0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
9ab0: 20 20 20 20 20 72 65 73 0a 09 09 20 20 20 20 20 res...
9ac0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
9ad0: 28 63 64 72 20 74 61 6c 29 20 72 65 73 29 0a 09 (cdr tal) res)..
9ae0: 09 20 20 20 20 20 20 29 29 29 29 29 29 29 0a 0a . )))))))..
9af0: 3b 3b 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ;;. (let lo
9b00: 6f 70 20 28 28 6c 20 20 20 20 20 20 20 28 72 65 op ((l (re
9b10: 61 64 2d 6c 69 6e 65 29 29 20 3b 3b 20 28 69 66 ad-line)) ;; (if
9b20: 20 28 65 71 3f 20 6d 6f 64 65 20 27 6e 6f 72 6d (eq? mode 'norm
9b30: 29 28 72 65 61 64 2d 6c 69 6e 65 29 28 72 65 61 )(read-line)(rea
9b40: 64 2d 63 68 61 72 29 29 29 0a 3b 3b 09 09 09 20 d-char))).;;...
9b50: 28 65 6e 64 6c 69 6e 65 20 23 66 29 0a 3b 3b 09 (endline #f).;;.
9b60: 09 09 20 28 6e 75 6d 20 20 20 20 20 30 29 29 0a .. (num 0)).
9b70: 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 61 74 20 64 ;;..;; (format d
9b80: 65 62 75 67 70 20 22 7e 41 5c 6e 22 20 6c 29 0a ebugp "~A\n" l).
9b90: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
9ba0: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 65 6f (if (or (not (eo
9bb0: 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 29 0a 3b 3b f-object? l)).;;
9bc0: 09 09 20 20 20 20 20 20 28 6e 6f 74 20 28 61 6e .. (not (an
9bd0: 64 20 28 65 71 3f 20 6d 6f 64 65 20 27 62 69 6e d (eq? mode 'bin
9be0: 29 0a 3b 3b 09 09 09 09 28 73 74 72 69 6e 67 3d ).;;....(string=
9bf0: 3f 20 6c 20 22 22 29 29 29 29 20 3b 3b 20 69 66 ? l "")))) ;; if
9c00: 20 69 6e 20 62 69 6e 20 6d 6f 64 65 20 65 6d 70 in bin mode emp
9c10: 74 79 20 73 74 72 69 6e 67 20 69 73 20 65 6e 64 ty string is end
9c20: 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 09 20 20 28 of file.;;.. (
9c30: 63 61 73 65 20 6d 6f 64 65 0a 3b 3b 09 09 20 20 case mode.;;..
9c40: 20 20 28 28 73 74 61 72 74 29 0a 3b 3b 09 09 20 ((start).;;..
9c50: 20 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 (set! mode '
9c60: 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 28 norm).;;.. (
9c70: 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 if (string-match
9c80: 20 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 delim-patt-rex
9c90: 6c 29 0a 3b 3b 09 09 09 20 28 62 65 67 69 6e 0a l).;;... (begin.
9ca0: 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 64 65 ;;... (set! de
9cb0: 6c 69 6d 2d 73 74 72 69 6e 67 20 6c 29 0a 3b 3b lim-string l).;;
9cc0: 09 09 09 20 20 20 28 73 65 74 21 20 64 65 6c 69 ... (set! deli
9cd0: 6d 2d 6c 65 6e 20 20 20 20 28 73 74 72 69 6e 67 m-len (string
9ce0: 2d 6c 65 6e 67 74 68 20 6c 29 29 0a 3b 3b 09 09 -length l)).;;..
9cf0: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
9d00: 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b 3b 09 line) #f 0)).;;.
9d10: 09 09 20 28 6c 6f 6f 70 20 6c 20 23 66 20 30 29 .. (loop l #f 0)
9d20: 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 6e 6f 72 )).;;.. ((nor
9d30: 6d 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 49 m).;;.. ;; I
9d40: 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 6f 77 20 don't like how
9d50: 74 68 69 73 20 67 65 74 73 20 63 68 65 63 6b 65 this gets checke
9d60: 64 20 6f 6e 20 65 76 65 72 79 20 73 69 6e 67 6c d on every singl
9d70: 65 20 69 6e 70 75 74 2e 20 4d 75 73 74 20 62 65 e input. Must be
9d80: 20 61 20 62 65 74 74 65 72 20 77 61 79 2e 20 46 a better way. F
9d90: 49 58 4d 45 0a 3b 3b 09 09 20 20 20 20 20 28 69 IXME.;;.. (i
9da0: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d f (and (string-m
9db0: 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 64 69 atch bin-data-di
9dc0: 73 70 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 sp-rex l).;;...
9dd0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
9de0: 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 ch bin-data-name
9df0: 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 20 20 -rex l).;;...
9e00: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
9e10: 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d 72 bin-file-name-r
9e20: 65 78 20 6c 29 29 0a 3b 3b 09 09 09 20 28 62 65 ex l)).;;... (be
9e30: 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 gin.;;... (set
9e40: 21 20 64 61 74 61 2d 6e 61 6d 65 20 28 63 61 64 ! data-name (cad
9e50: 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 r (string-match
9e60: 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 bin-data-name-re
9e70: 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 20 28 x l))).;;... (
9e80: 73 65 74 21 20 66 69 6c 65 2d 6e 61 6d 65 20 28 set! file-name (
9e90: 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 cadr (string-mat
9ea0: 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 ch bin-file-name
9eb0: 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 -rex l))).;;...
9ec0: 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 63 6f (set! mode 'co
9ed0: 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 20 20 20 28 ntent).;;... (
9ee0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
9ef0: 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 09 20 #f num))).;;..
9f00: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 20 (let* ((dat
9f10: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
9f20: 69 6e 70 75 74 20 6c 29 29 29 20 3b 3b 20 28 43 input l))) ;; (C
9f30: 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 65 20 6c GI:url-unquote l
9f40: 29 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 66 )).;;.. (f
9f50: 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 50 52 ormat debugp "PR
9f60: 4f 43 45 53 53 2d 43 47 49 2d 49 4e 50 55 54 3a OCESS-CGI-INPUT:
9f70: 20 7e 41 5c 6e 22 20 28 69 6e 74 65 72 73 70 65 ~A\n" (interspe
9f80: 72 73 65 20 64 61 74 20 22 2c 22 29 29 0a 3b 3b rse dat ",")).;;
9f90: 09 09 20 20 20 20 20 20 20 28 66 6f 72 6d 64 61 .. (formda
9fa0: 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 64 t:load formdat d
9fb0: 61 74 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 at).;;.. (
9fc0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
9fd0: 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 09 20 #f num))).;;..
9fe0: 20 20 20 28 28 63 6f 6e 74 65 6e 74 29 0a 3b 3b ((content).;;
9ff0: 09 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 .. (if (stri
a000: 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d 66 69 6c ng-match bin-fil
a010: 65 2d 74 79 70 65 2d 72 65 78 20 6c 29 0a 3b 3b e-type-rex l).;;
a020: 09 09 09 20 28 62 65 67 69 6e 20 0a 3b 3b 09 09 ... (begin .;;..
a030: 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 . (set! mode '
a040: 62 69 6e 29 0a 3b 3b 09 09 09 20 20 20 28 73 65 bin).;;... (se
a050: 74 21 20 64 61 74 61 2d 74 79 70 65 20 28 63 61 t! data-type (ca
a060: 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 dr (string-match
a070: 20 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 bin-file-type-r
a080: 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 20 ex l))).;;...
a090: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 73 74 72 69 (loop (read-stri
a0a0: 6e 67 20 31 29 20 23 66 20 6e 75 6d 29 29 29 29 ng 1) #f num))))
a0b0: 0a 3b 3b 09 09 20 20 20 20 28 28 62 69 6e 29 0a .;;.. ((bin).
a0c0: 3b 3b 09 09 20 20 20 20 20 3b 3b 20 64 65 6c 69 ;;.. ;; deli
a0d0: 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e 22 2d 2d 2d m-string: \n"---
a0e0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 33 34 ------------1234
a0f0: 35 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 20 5".;;.. ;;
a100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a110: 30 31 32 33 34 35 36 37 38 39 30 31 32 33 34 35 0123456789012345
a120: 36 37 38 39 30 0a 3b 3b 09 09 20 20 20 20 20 3b 67890.;;.. ;
a130: 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 20 20 20 20 ; endline:
a140: 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "-------------
a150: 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 20 20 20 3b --12".;;.. ;
a160: 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b 09 09 20 20 ; l = "3".;;..
a170: 20 20 20 3b 3b 20 64 65 6c 69 6d 2d 6c 65 6e 20 ;; delim-len
a180: 3d 20 32 30 0a 3b 3b 09 09 20 20 20 20 20 3b 3b = 20.;;.. ;;
a190: 20 28 73 75 62 73 74 72 69 6e 67 20 20 22 2d 2d (substring "--
a1a0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 33 -------------123
a1b0: 34 35 22 20 31 37 20 31 38 29 20 3d 3e 20 22 33 45" 17 18) => "3
a1c0: 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 0a 3b 3b ".;;.. ;;.;;
a1d0: 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 09 .. (cond.;;.
a1e0: 09 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 6e . ;; haven
a1f0: 27 74 20 66 6f 75 6e 64 20 74 68 65 20 73 74 61 't found the sta
a200: 72 74 20 6f 66 20 61 6e 20 65 6e 64 6c 69 6e 65 rt of an endline
a210: 2c 20 69 73 20 74 68 65 20 6e 65 78 74 20 63 68 , is the next ch
a220: 61 72 20 61 20 6e 65 77 6c 69 6e 65 3f 0a 3b 3b ar a newline?.;;
a230: 09 09 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e .. ((and (n
a240: 6f 74 20 65 6e 64 6c 69 6e 65 29 0a 3b 3b 09 09 ot endline).;;..
a250: 09 20 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 6c . (string=? l
a260: 20 22 5c 6e 22 29 29 20 3b 3b 20 72 65 71 75 69 "\n")) ;; requi
a270: 72 65 64 20 66 69 72 73 74 20 63 68 61 72 61 63 red first charac
a280: 74 65 72 20 0a 3b 3b 09 09 20 20 20 20 20 20 20 ter .;;..
a290: 28 6c 65 74 20 28 28 6e 65 77 65 6e 64 6c 69 6e (let ((newendlin
a2a0: 65 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 e (open-output-s
a2b0: 74 72 69 6e 67 29 29 29 0a 3b 3b 09 09 09 20 3b tring))).;;... ;
a2c0: 3b 20 28 77 72 69 74 65 2d 6c 69 6e 65 20 6c 20 ; (write-line l
a2d0: 6e 65 77 65 6e 64 6c 69 6e 65 29 20 3b 3b 20 64 newendline) ;; d
a2e0: 69 73 63 61 72 64 20 74 68 65 20 6e 65 77 6c 69 iscard the newli
a2f0: 6e 65 2e 20 61 64 64 20 69 74 20 62 61 63 6b 20 ne. add it back
a300: 69 66 20 64 6f 6e 27 74 20 68 61 76 65 20 61 20 if don't have a
a310: 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 6d 2d 73 74 lock on delim-st
a320: 72 69 6e 67 0a 3b 3b 09 09 09 20 28 6c 6f 6f 70 ring.;;... (loop
a330: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 (read-string 1)
a340: 20 6e 65 77 65 6e 64 6c 69 6e 65 20 28 2b 20 6e newendline (+ n
a350: 75 6d 20 31 29 29 29 29 0a 3b 3b 09 09 20 20 20 um 1)))).;;..
a360: 20 20 20 28 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 ((not endline
a370: 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 77 72 ).;;.. (wr
a380: 69 74 65 2d 73 74 72 69 6e 67 20 6c 20 23 66 20 ite-string l #f
a390: 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 20 20 20 bin-dat).;;..
a3a0: 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d (loop (read-
a3b0: 73 74 72 69 6e 67 20 31 29 20 23 66 20 28 2b 20 string 1) #f (+
a3c0: 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 09 20 20 20 num 1))).;;..
a3d0: 20 20 20 3b 3b 20 73 74 72 69 6e 67 20 73 6f 20 ;; string so
a3e0: 66 61 72 20 6d 61 74 63 68 65 73 20 64 65 6c 69 far matches deli
a3f0: 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 20 20 20 m-string.;;..
a400: 20 20 20 28 65 6e 64 6c 69 6e 65 0a 3b 3b 09 09 (endline.;;..
a410: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
a420: 6e 64 73 74 72 20 28 67 65 74 2d 6f 75 74 70 75 ndstr (get-outpu
a430: 74 2d 73 74 72 69 6e 67 20 65 6e 64 6c 69 6e 65 t-string endline
a440: 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 28 65 )).;;... (e
a450: 6e 64 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 ndlen (string-le
a460: 6e 67 74 68 20 65 6e 64 73 74 72 29 29 29 0a 3b ngth endstr))).;
a470: 3b 09 09 09 20 28 69 66 20 28 3e 20 65 6e 64 6c ;... (if (> endl
a480: 65 6e 20 30 29 0a 3b 3b 09 09 09 20 20 20 20 20 en 0).;;...
a490: 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 (format debugp "
a4a0: 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e 65 6e 64 73 delim: ~A\nends
a4b0: 74 72 3a 20 7e 41 5c 6e 22 20 64 65 6c 69 6d 2d tr: ~A\n" delim-
a4c0: 73 74 72 69 6e 67 20 65 6e 64 73 74 72 29 29 0a string endstr)).
a4d0: 3b 3b 09 09 09 20 28 69 66 20 28 61 6e 64 20 28 ;;... (if (and (
a4e0: 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c > delim-len endl
a4f0: 65 6e 29 0a 3b 3b 09 09 09 09 20 20 28 73 74 72 en).;;.... (str
a500: 69 6e 67 3d 3f 20 6c 20 28 73 75 62 73 74 72 69 ing=? l (substri
a510: 6e 67 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 ng delim-string
a520: 65 6e 64 6c 65 6e 20 28 2b 20 65 6e 64 6c 65 6e endlen (+ endlen
a530: 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 1)))).;;...
a540: 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 63 68 ;; yes, this ch
a550: 61 72 61 63 74 65 72 20 6d 61 74 63 68 65 73 20 aracter matches
a560: 74 68 65 20 6e 65 78 74 20 69 6e 20 74 68 65 20 the next in the
a570: 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 delim-string.;;.
a580: 09 09 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 .. (if (eq?
a590: 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c 65 6e delim-len endlen
a5a0: 29 20 3b 3b 20 68 61 76 65 20 61 20 6d 61 74 63 ) ;; have a matc
a5b0: 68 21 20 49 67 6e 6f 72 65 20 74 68 61 74 20 61 h! Ignore that a
a5c0: 20 6e 65 77 6c 69 6e 65 20 69 73 20 72 65 71 75 newline is requ
a5d0: 69 72 65 64 2e 20 4c 61 7a 79 20 62 75 67 67 65 ired. Lazy bugge
a5e0: 72 2e 0a 3b 3b 09 09 09 09 20 28 6c 65 74 2a 20 r..;;.... (let*
a5f0: 28 28 66 6e 20 20 20 20 20 20 28 73 74 72 69 6e ((fn (strin
a600: 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 74 61 2d 6e g->symbol data-n
a610: 61 6d 65 29 29 29 0a 3b 3b 09 09 09 09 20 20 20 ame))).;;....
a620: 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 66 6f (formdat:set! fo
a630: 72 6d 64 61 74 20 66 6e 20 28 6c 69 73 74 20 66 rmdat fn (list f
a640: 69 6c 65 2d 6e 61 6d 65 20 64 61 74 61 2d 74 79 ile-name data-ty
a650: 70 65 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f 62 pe (string->blob
a660: 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 (get-output-str
a670: 69 6e 67 20 62 69 6e 2d 64 61 74 29 29 29 29 0a ing bin-dat)))).
a680: 3b 3b 09 09 09 09 20 20 20 28 73 65 74 21 20 6d ;;.... (set! m
a690: 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 09 ode 'norm).;;...
a6a0: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
a6b0: 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b 3b 09 line) #f 0)).;;.
a6c0: 09 09 09 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 ... (begin.;;...
a6d0: 09 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e . (write-strin
a6e0: 67 20 6c 20 23 66 20 65 6e 64 6c 69 6e 65 29 0a g l #f endline).
a6f0: 3b 3b 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 ;;.... (loop (
a700: 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 65 read-string 1) e
a710: 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 6d 20 31 29 ndline (+ num 1)
a720: 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 3b 3b ))).;;... ;;
a730: 20 6e 6f 2c 20 74 68 69 73 20 63 68 61 72 61 63 no, this charac
a740: 74 65 72 20 64 6f 65 73 20 4e 4f 54 20 6d 61 74 ter does NOT mat
a750: 63 68 20 74 68 65 20 6e 65 78 74 20 69 6e 20 6c ch the next in l
a760: 69 6e 65 20 69 6e 20 64 65 6c 69 6d 2d 73 74 72 ine in delim-str
a770: 69 6e 67 0a 3b 3b 09 09 09 20 20 20 20 20 28 62 ing.;;... (b
a780: 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 20 20 20 egin.;;...
a790: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 22 (write-string "
a7a0: 5c 6e 22 20 23 66 20 62 69 6e 2d 64 61 74 29 20 \n" #f bin-dat)
a7b0: 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 67 65 74 20 ;; don't forget
a7c0: 74 68 61 74 20 6e 65 77 6c 69 6e 65 20 77 65 20 that newline we
a7d0: 64 72 6f 70 70 65 64 0a 3b 3b 09 09 09 20 20 20 dropped.;;...
a7e0: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
a7f0: 67 20 65 6e 64 73 74 72 20 23 66 20 62 69 6e 2d g endstr #f bin-
a800: 64 61 74 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 dat).;;...
a810: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c (write-string l
a820: 20 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 #f bin-dat).;;.
a830: 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 .. (loop (
a840: 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 23 read-string 1) #
a850: 66 20 28 2b 20 6e 75 6d 20 31 29 29 29 29 29 29 f (+ num 1))))))
a860: 29 29 0a 3b 3b 09 09 20 20 20 20 29 29 29 29 29 )).;;.. )))))
a870: 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 64 61 74 ..;; (formdat
a880: 3a 70 72 69 6e 74 61 6c 6c 20 66 6f 72 6d 64 61 :printall formda
a890: 74 20 28 6c 61 6d 62 64 61 20 28 78 29 28 77 72 t (lambda (x)(wr
a8a0: 69 74 65 2d 6c 69 6e 65 20 78 20 64 65 62 75 67 ite-line x debug
a8b0: 70 29 29 29 0a 0a 23 7c 0a 28 64 65 66 69 6e 65 p)))..#|.(define
a8c0: 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 inp (open-input
a8d0: 2d 66 69 6c 65 20 22 2f 74 6d 70 2f 73 74 6d 6c -file "/tmp/stml
a8e0: 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 2e 6c 6f 67 run/delme-33.log
a8f0: 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 66 22 29 29 .keep-for-ref"))
a900: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
a910: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
a920: 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d )).(close-input-
a930: 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a 0a 3b 3b port inp).|#..;;
a940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a980: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 73 65 20 61 20 ======.;; use a
a990: 74 61 62 6c 65 20 69 6e 20 79 6f 75 72 20 64 62 table in your db
a9a0: 20 63 61 6c 6c 65 64 20 6d 65 74 61 64 61 74 20 called metadat
a9b0: 74 6f 20 73 74 6f 72 65 20 6b 65 79 20 76 61 6c to store key val
a9c0: 75 65 20 70 61 69 72 73 0a 3b 3b 3d 3d 3d 3d 3d ue pairs.;;=====
a9d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa10: 3d 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6b 65 79 =...(define (key
aa20: 73 74 6f 72 65 3a 67 65 74 20 64 62 20 6b 65 79 store:get db key
aa30: 29 0a 20 20 28 64 62 69 3a 67 65 74 2d 6f 6e 65 ). (dbi:get-one
aa40: 20 64 62 20 22 53 45 4c 45 43 54 20 76 61 6c 75 db "SELECT valu
aa50: 65 20 46 52 4f 4d 20 6d 65 74 61 64 61 74 61 20 e FROM metadata
aa60: 57 48 45 52 45 20 6b 65 79 3d 3f 3b 22 20 6b 65 WHERE key=?;" ke
aa70: 79 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6b 65 y))..(define (ke
aa80: 79 73 74 6f 72 65 3a 73 65 74 21 20 64 62 20 6b ystore:set! db k
aa90: 65 79 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 ey value). (let
aaa0: 20 28 28 63 75 72 72 2d 76 61 6c 20 28 6b 65 79 ((curr-val (key
aab0: 73 74 6f 72 65 3a 67 65 74 20 64 62 20 6b 65 79 store:get db key
aac0: 29 29 29 0a 20 20 20 20 28 69 66 20 63 75 72 72 ))). (if curr
aad0: 2d 76 61 6c 0a 09 28 64 62 69 3a 65 78 65 63 20 -val..(dbi:exec
aae0: 64 62 20 22 55 50 44 41 54 45 20 6d 65 74 61 64 db "UPDATE metad
aaf0: 61 74 61 20 53 45 54 20 76 61 6c 75 65 3d 3f 20 ata SET value=?
ab00: 57 48 45 52 45 20 6b 65 79 3d 3f 3b 22 20 76 61 WHERE key=?;" va
ab10: 6c 75 65 20 6b 65 79 29 0a 09 28 64 62 69 3a 65 lue key)..(dbi:e
ab20: 78 65 63 20 64 62 20 22 49 4e 53 45 52 54 20 49 xec db "INSERT I
ab30: 4e 54 4f 20 6d 65 74 61 64 61 74 61 20 28 6b 65 NTO metadata (ke
ab40: 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 20 y,value) VALUES
ab50: 28 3f 2c 3f 29 3b 22 20 6b 65 79 20 76 61 6c 75 (?,?);" key valu
ab60: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 e))))..(define (
ab70: 6b 65 79 73 74 6f 72 65 3a 64 65 6c 21 20 64 62 keystore:del! db
ab80: 20 6b 65 79 29 0a 20 20 28 64 62 69 3a 65 78 65 key). (dbi:exe
ab90: 63 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 4f c db "DELETE FRO
aba0: 4d 20 6d 65 74 61 64 61 74 61 20 57 48 45 52 45 M metadata WHERE
abb0: 20 6b 65 79 3d 3f 3b 22 20 6b 65 79 29 29 0a 0a key=?;" key))..
abc0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
abd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac00: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 74 75 66 ========.;; stuf
ac10: 66 20 66 72 6f 6d 20 6d 69 73 63 2d 73 74 6d 6c f from misc-stml
ac20: 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .scm.;;=========
ac30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
ac70: 3b 20 6d 6f 76 65 64 20 74 6f 20 73 74 6d 6c 63 ; moved to stmlc
ac80: 6f 6d 6d 6f 6e 0a 3b 3b 20 28 62 75 6e 63 68 20 ommon.;; (bunch
ac90: 6f 66 20 73 74 75 66 66 29 0a 0a 3b 3b 20 6d 6f of stuff)..;; mo
aca0: 76 65 64 20 66 72 6f 6d 20 73 74 6d 6c 63 6f 6d ved from stmlcom
acb0: 6d 6f 6e 0a 3b 3b 0a 3b 3b 20 61 6e 79 74 68 69 mon.;;.;; anythi
acc0: 6e 67 20 65 78 63 65 70 74 20 61 20 6c 69 73 74 ng except a list
acd0: 20 69 73 20 63 6f 6e 76 65 72 74 65 64 20 74 6f is converted to
ace0: 20 61 20 73 74 72 69 6e 67 21 21 21 0a 28 64 65 a string!!!.(de
acf0: 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 73 74 72 fine (s:any->str
ad00: 69 6e 67 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 ing val). (cond
ad10: 0a 20 20 20 28 28 73 74 72 69 6e 67 3f 20 76 61 . ((string? va
ad20: 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 6e 75 6d l) val). ((num
ad30: 62 65 72 3f 20 76 61 6c 29 20 28 6e 75 6d 62 65 ber? val) (numbe
ad40: 72 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a r->string val)).
ad50: 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c ((symbol? val
ad60: 29 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e ) (symbol->strin
ad70: 67 20 76 61 6c 29 29 0a 20 20 20 28 28 65 71 3f g val)). ((eq?
ad80: 20 76 61 6c 20 23 66 29 20 22 22 29 0a 20 20 20 val #f) "").
ad90: 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 54 ((eq? val #t) "T
ada0: 52 55 45 22 29 0a 20 20 20 28 28 6c 69 73 74 3f RUE"). ((list?
adb0: 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 65 val) val). (e
adc0: 6c 73 65 20 0a 20 20 20 20 28 6c 65 74 20 28 28 lse . (let ((
add0: 6f 73 74 72 20 28 6f 70 65 6e 2d 6f 75 74 70 75 ostr (open-outpu
ade0: 74 2d 73 74 72 69 6e 67 29 29 29 0a 20 20 20 20 t-string))).
adf0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
ae00: 6f 2d 70 6f 72 74 20 6f 73 74 72 0a 09 28 6c 61 o-port ostr..(la
ae10: 6d 62 64 61 20 28 29 0a 09 20 20 28 64 69 73 70 mbda ().. (disp
ae20: 6c 61 79 20 76 61 6c 29 29 29 0a 20 20 20 20 20 lay val))).
ae30: 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 (get-output-str
ae40: 69 6e 67 20 6f 73 74 72 29 29 29 29 29 0a 0a 28 ing ostr)))))..(
ae50: 64 65 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 6e define (s:any->n
ae60: 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f umber val). (co
ae70: 6e 64 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 nd. ((number?
ae80: 76 61 6c 29 20 20 76 61 6c 29 0a 20 20 20 28 28 val) val). ((
ae90: 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 20 28 73 string? val) (s
aea0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 tring->number va
aeb0: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
aec0: 20 76 61 6c 29 20 20 28 73 74 72 69 6e 67 2d 3e val) (string->
aed0: 6e 75 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e number (symbol->
aee0: 73 74 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 string val))).
aef0: 20 28 65 6c 73 65 20 20 20 20 20 23 66 29 29 29 (else #f)))
af00: 0a 0a 3b 3b 20 4d 6f 76 65 64 20 66 72 6f 6d 20 ..;; Moved from
af10: 73 74 6d 6c 63 6f 6d 6d 6f 6e 0a 3b 3b 0a 28 64 stmlcommon.;;.(d
af20: 65 66 69 6e 65 20 28 73 3a 63 67 69 2d 6f 75 74 efine (s:cgi-out
af30: 20 69 6e 6c 73 74 29 0a 20 20 28 73 3a 6f 75 74 inlst). (s:out
af40: 70 75 74 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 put (current-out
af50: 70 75 74 2d 70 6f 72 74 29 20 69 6e 6c 73 74 29 put-port) inlst)
af60: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 6f 75 )..(define (s:ou
af70: 74 70 75 74 20 70 6f 72 74 20 69 6e 6c 73 74 29 tput port inlst)
af80: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
af90: 28 78 29 0a 09 20 28 63 6f 6e 64 20 0a 09 20 20 (x).. (cond ..
afa0: 28 28 73 74 72 69 6e 67 3f 20 78 29 20 28 70 72 ((string? x) (pr
afb0: 69 6e 74 20 78 29 29 20 3b 3b 20 28 70 72 69 6e int x)) ;; (prin
afc0: 74 20 78 29 29 0a 09 20 20 28 28 73 79 6d 62 6f t x)).. ((symbo
afd0: 6c 3f 20 78 29 20 28 70 72 69 6e 74 20 78 29 29 l? x) (print x))
afe0: 20 3b 3b 20 28 70 72 69 6e 74 20 78 29 29 0a 09 ;; (print x))..
aff0: 20 20 28 28 6c 69 73 74 3f 20 78 29 20 20 20 28 ((list? x) (
b000: 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 20 78 29 s:output port x)
b010: 29 0a 09 20 20 28 65 6c 73 65 20 22 22 0a 09 20 ).. (else ""..
b020: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 52 ;; (print "ERR
b030: 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 20 30 32 OR: Bad input 02
b040: 22 29 20 3b 3b 20 77 68 79 20 64 6f 20 61 6e 79 ") ;; why do any
b050: 74 68 69 6e 67 3f 20 64 6f 6e 27 74 20 6f 75 74 thing? don't out
b060: 70 75 74 20 6a 75 6e 6b 2e 0a 09 20 20 20 29 29 put junk... ))
b070: 29 0a 20 20 20 20 20 20 20 69 6e 6c 73 74 29 29 ). inlst))
b080: 0a 3b 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 .; (if (> (leng
b090: 74 68 20 69 6e 6c 73 74 29 20 32 29 0a 3b 20 20 th inlst) 2).;
b0a0: 20 20 20 20 28 70 72 69 6e 74 29 29 29 0a 0a 28 (print)))..(
b0b0: 64 65 66 69 6e 65 20 28 73 3a 6f 75 74 70 75 74 define (s:output
b0c0: 2d 6e 65 77 20 70 6f 72 74 20 69 6e 6c 73 74 29 -new port inlst)
b0d0: 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
b0e0: 74 6f 2d 70 6f 72 74 20 70 6f 72 74 0a 20 20 20 to-port port.
b0f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
b100: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
b110: 09 20 20 20 20 20 20 20 28 63 6f 6e 64 20 0a 09 . (cond ..
b120: 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 28 70 .((string? x) (p
b130: 72 69 6e 74 20 78 29 29 0a 09 09 28 28 73 79 6d rint x))...((sym
b140: 62 6f 6c 3f 20 78 29 20 28 70 72 69 6e 74 20 78 bol? x) (print x
b150: 29 29 0a 09 09 28 28 6c 69 73 74 3f 20 78 29 20 ))...((list? x)
b160: 20 20 28 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 (s:output port
b170: 20 78 29 29 0a 09 09 28 65 6c 73 65 0a 09 09 20 x))...(else...
b180: 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 ;; (print "ERROR
b190: 3a 20 42 61 64 20 69 6e 70 75 74 20 30 33 22 29 : Bad input 03")
b1a0: 0a 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 20 . )))..
b1b0: 69 6e 6c 73 74 29 29 29 29 0a 20 20 20 20 20 20 inlst)))).
b1c0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 65 .(define (e
b1d0: 72 72 3a 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 20 rr:log . msg).
b1e0: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
b1f0: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 port (current-er
b200: 72 6f 72 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c ror-port) ;; (sl
b210: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 ot-ref self 'log
b220: 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 pt). (lambda
b230: 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 () . (apply
b240: 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a print msg))))..
b250: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b290: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 42 0a ========.;; D B.
b2a0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b2b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2e0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e ========..;; con
b2f0: 76 65 72 74 20 76 61 6c 75 65 73 20 74 6f 20 61 vert values to a
b300: 70 70 72 6f 70 72 69 61 74 65 20 73 74 72 69 6e ppropriate strin
b310: 67 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 gs.;;.(define (s
b320: 3a 73 71 6c 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 :sqlparam-val->s
b330: 74 72 69 6e 67 20 76 61 6c 29 0a 20 20 28 63 6f tring val). (co
b340: 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 20 20 nd. ((list?
b350: 76 61 6c 29 28 73 74 72 69 6e 67 2d 6a 6f 69 6e val)(string-join
b360: 20 28 6d 61 70 20 73 79 6d 62 6f 6c 2d 3e 73 74 (map symbol->st
b370: 72 69 6e 67 20 76 61 6c 29 20 22 2c 22 29 29 20 ring val) ","))
b380: 3b 3b 20 28 61 20 62 20 63 29 20 3d 3e 20 61 2c ;; (a b c) => a,
b390: 62 2c 63 0a 20 20 20 28 28 73 74 72 69 6e 67 3f b,c. ((string?
b3a0: 20 76 61 6c 29 28 63 6f 6e 63 20 22 27 22 20 28 val)(conc "'" (
b3b0: 64 62 69 3a 65 73 63 61 70 65 2d 73 74 72 69 6e dbi:escape-strin
b3c0: 67 20 76 61 6c 29 20 22 27 22 29 29 0a 20 20 20 g val) "'")).
b3d0: 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 28 6e ((number? val)(n
b3e0: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 76 61 umber->string va
b3f0: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
b400: 20 76 61 6c 29 28 64 62 69 3a 65 73 63 61 70 65 val)(dbi:escape
b410: 2d 73 74 72 69 6e 67 20 28 73 79 6d 62 6f 6c 2d -string (symbol-
b420: 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 >string val))).
b430: 20 20 28 28 62 6f 6f 6c 65 61 6e 3f 20 76 61 6c ((boolean? val
b440: 29 0a 20 20 20 20 28 69 66 20 76 61 6c 20 22 54 ). (if val "T
b450: 52 55 45 22 20 22 46 41 4c 53 45 22 29 29 20 20 RUE" "FALSE"))
b460: 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 62 ;; should this b
b470: 65 20 22 54 52 55 45 22 20 6f 72 20 31 3f 0a 20 e "TRUE" or 1?.
b480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b490: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
b4a0: 73 68 6f 75 6c 64 20 74 68 69 73 20 62 65 20 22 should this be "
b4b0: 46 41 4c 53 45 22 20 6f 72 20 30 20 6f 72 20 4e FALSE" or 0 or N
b4c0: 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 65 0a 20 20 ULL?. (else.
b4d0: 20 20 28 65 72 72 3a 6c 6f 67 20 22 73 71 6c 70 (err:log "sqlp
b4e0: 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 6e 20 74 79 aram: unknown ty
b4f0: 70 65 20 66 6f 72 20 76 61 6c 75 65 3a 20 22 20 pe for value: "
b500: 76 61 6c 29 0a 20 20 20 20 22 22 29 29 29 0a 0a val). "")))..
b510: 3b 3b 20 28 73 71 6c 70 61 72 61 6d 20 22 49 4e ;; (sqlparam "IN
b520: 53 45 52 54 20 49 4e 54 4f 20 66 6f 6f 28 6e 61 SERT INTO foo(na
b530: 6d 65 2c 61 67 65 29 20 56 41 4c 55 45 53 28 3f me,age) VALUES(?
b540: 2c 3f 29 3b 22 20 22 62 6f 62 22 20 32 30 29 0a ,?);" "bob" 20).
b550: 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 61 6c 75 65 ;; NB// 1. value
b560: 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b 20 20 20 20 s only!! .;;
b570: 20 20 32 2e 20 74 65 72 6d 69 6e 61 74 69 6e 67 2. terminating
b580: 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 65 71 75 69 semicolon requi
b590: 72 65 64 20 28 75 73 65 64 20 61 73 20 70 61 72 red (used as par
b5a0: 74 20 6f 66 20 6c 6f 67 69 63 29 0a 3b 3b 0a 3b t of logic).;;.;
b5b0: 3b 20 61 3d 3f 20 31 20 28 6e 75 6d 62 65 72 29 ; a=? 1 (number)
b5c0: 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 3d 3f 20 31 => a=1.;; a=? 1
b5d0: 20 28 73 74 72 69 6e 67 29 20 3d 3e 20 61 3d 27 (string) => a='
b5e0: 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 20 20 20 20 1'.;; a=? #f
b5f0: 20 20 20 20 20 3d 3e 20 61 3d 46 41 4c 53 45 20 => a=FALSE
b600: 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 79 6d 62 6f .;; a=? a (symbo
b610: 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b 3b 0a 28 64 l) => a=a .;;.(d
b620: 65 66 69 6e 65 20 28 73 3a 73 71 6c 70 61 72 61 efine (s:sqlpara
b630: 6d 20 71 75 65 72 79 20 2e 20 61 72 67 73 29 0a m query . args).
b640: 20 20 28 6c 65 74 2a 20 28 28 71 75 65 72 79 2d (let* ((query-
b650: 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 73 70 parts (string-sp
b660: 6c 69 74 20 71 75 65 72 79 20 22 3f 22 29 29 0a lit query "?")).
b670: 20 20 20 20 20 20 20 20 20 28 6e 75 6d 2d 70 61 (num-pa
b680: 72 74 73 20 20 20 20 28 6c 65 6e 67 74 68 20 71 rts (length q
b690: 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 uery-parts)).
b6a0: 20 20 20 20 20 20 28 6e 75 6d 2d 61 72 67 73 20 (num-args
b6b0: 20 20 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 (length args)
b6c0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
b6d0: 28 3d 20 28 2b 20 6e 75 6d 2d 61 72 67 73 20 31 (= (+ num-args 1
b6e0: 29 20 6e 75 6d 2d 70 61 72 74 73 29 29 0a 20 20 ) num-parts)).
b6f0: 20 20 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 (err:log "
b700: 45 52 52 4f 52 2c 20 73 71 6c 70 61 72 61 6d 3a ERROR, sqlparam:
b710: 20 77 72 6f 6e 67 20 6e 75 6d 62 65 72 20 6f 66 wrong number of
b720: 20 61 72 67 75 6d 65 6e 74 73 20 6f 72 20 6d 69 arguments or mi
b730: 73 73 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 2c ssing semicolon,
b740: 20 22 20 6e 75 6d 2d 61 72 67 73 20 22 20 66 6f " num-args " fo
b750: 72 20 71 75 65 72 79 20 22 20 71 75 65 72 79 29 r query " query)
b760: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 3d 20 . (if (=
b770: 6e 75 6d 2d 61 72 67 73 20 30 29 20 71 75 65 72 num-args 0) quer
b780: 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c y. (l
b790: 65 74 20 6c 6f 6f 70 20 28 28 73 65 63 74 69 6f et loop ((sectio
b7a0: 6e 20 28 63 61 72 20 71 75 65 72 79 2d 70 61 72 n (car query-par
b7b0: 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ts)).
b7c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 69 (tai
b7d0: 6c 20 20 20 20 28 63 64 72 20 71 75 65 72 79 2d l (cdr query-
b7e0: 70 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 parts)).
b7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b800: 72 65 73 75 6c 74 20 20 22 22 29 0a 20 20 20 20 result "").
b810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b820: 20 20 20 28 61 72 67 20 20 20 20 20 28 63 61 72 (arg (car
b830: 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 args)).
b840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b850: 61 72 67 74 61 69 6c 20 28 63 64 72 20 61 72 67 argtail (cdr arg
b860: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s))).
b870: 20 20 20 28 6c 65 74 2a 20 28 28 76 61 6c 73 74 (let* ((valst
b880: 72 20 20 20 20 28 73 3a 73 71 6c 70 61 72 61 6d r (s:sqlparam
b890: 2d 76 61 6c 2d 3e 73 74 72 69 6e 67 20 61 72 67 -val->string arg
b8a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b8b0: 20 20 20 20 20 20 20 20 28 6e 65 77 72 65 73 75 (newresu
b8c0: 6c 74 20 28 63 6f 6e 63 20 72 65 73 75 6c 74 20 lt (conc result
b8d0: 73 65 63 74 69 6f 6e 20 76 61 6c 73 74 72 29 29 section valstr))
b8e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b8f0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 67 (if (null? arg
b900: 74 61 69 6c 29 20 3b 3b 20 77 65 20 61 72 65 20 tail) ;; we are
b910: 64 6f 6e 65 0a 20 20 20 20 20 20 20 20 20 20 20 done.
b920: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 6e (conc n
b930: 65 77 72 65 73 75 6c 74 20 28 63 61 72 20 74 61 ewresult (car ta
b940: 69 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 il)).
b950: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 0a 20 (loop.
b960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b970: 20 20 20 20 28 63 61 72 20 74 61 69 6c 29 0a 20 (car tail).
b980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b990: 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 0a 20 (cdr tail).
b9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9b0: 20 20 20 20 6e 65 77 72 65 73 75 6c 74 0a 20 20 newresult.
b9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9d0: 20 20 20 28 63 61 72 20 61 72 67 74 61 69 6c 29 (car argtail)
b9e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b9f0: 20 20 20 20 20 20 28 63 64 72 20 61 72 67 74 61 (cdr argta
ba00: 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 il)))))))))..;;
ba10: 28 64 65 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a (define session:
ba20: 76 61 6c 69 64 2d 63 68 61 72 73 20 22 61 62 63 valid-chars "abc
ba30: 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 defghijklmnopqrs
ba40: 74 75 76 77 78 79 7a 41 42 43 44 45 46 47 48 49 tuvwxyzABCDEFGHI
ba50: 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 JKLMNOPQRSTUVWXY
ba60: 5a 30 31 32 33 34 35 36 37 38 39 22 29 0a 28 64 Z0123456789").(d
ba70: 65 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a 76 61 efine session:va
ba80: 6c 69 64 2d 63 68 61 72 73 20 22 61 62 63 64 65 lid-chars "abcde
ba90: 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 fghijklmnopqrstu
baa0: 76 77 78 79 7a 30 31 32 33 34 35 36 37 38 39 22 vwxyz0123456789"
bab0: 29 20 3b 3b 20 63 6f 6f 6b 69 65 73 20 61 72 65 ) ;; cookies are
bac0: 20 63 61 73 65 20 69 6e 73 65 6e 73 69 74 69 76 case insensitiv
bad0: 65 2e 0a 28 64 65 66 69 6e 65 20 73 65 73 73 69 e..(define sessi
bae0: 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 2d 63 68 61 on:num-valid-cha
baf0: 72 73 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 rs (string-lengt
bb00: 68 20 73 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d h session:valid-
bb10: 63 68 61 72 73 29 29 0a 0a 28 64 65 66 69 6e 65 chars))..(define
bb20: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 (session:get-nt
bb30: 68 2d 63 68 61 72 20 6e 74 68 29 0a 20 20 28 73 h-char nth). (s
bb40: 75 62 73 74 72 69 6e 67 20 73 65 73 73 69 6f 6e ubstring session
bb50: 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 6e 74 68 :valid-chars nth
bb60: 20 20 28 2b 20 6e 74 68 20 31 29 29 29 0a 0a 28 (+ nth 1)))..(
bb70: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
bb80: 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 0a 20 get-rand-char).
bb90: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 (session:get-nt
bba0: 68 2d 63 68 61 72 20 28 72 61 6e 64 6f 6d 20 73 h-char (random s
bbb0: 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 ession:num-valid
bbc0: 2d 63 68 61 72 73 29 29 29 0a 0a 28 64 65 66 69 -chars)))..(defi
bbd0: 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 ne (session:make
bbe0: 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 6c 65 6e -rand-string len
bbf0: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
bc00: 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 20 res "").
bc10: 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 20 (n 1)).
bc20: 20 20 28 69 66 20 28 3e 20 6e 20 6c 65 6e 29 20 (if (> n len)
bc30: 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c 6f 6f res. (loo
bc40: 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 p (string-append
bc50: 20 72 65 73 20 28 73 65 73 73 69 6f 6e 3a 67 65 res (session:ge
bc60: 74 2d 72 61 6e 64 2d 63 68 61 72 29 29 0a 20 20 t-rand-char)).
bc70: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 6e (+ n
bc80: 20 31 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 79 62 1)))))..;; mayb
bc90: 65 20 72 65 70 6c 61 63 65 20 61 62 6f 76 65 20 e replace above
bca0: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
bcb0: 20 77 69 74 68 20 74 68 69 73 20 73 6f 6d 65 64 with this somed
bcc0: 61 79 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ay?.;;.(define (
bcd0: 73 65 73 73 69 6f 6e 3a 67 65 6e 65 72 69 63 2d session:generic-
bce0: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
bcf0: 20 6c 65 6e 20 73 65 65 64 2d 73 74 72 69 6e 67 len seed-string
bd00: 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 63 ). (let ((num-c
bd10: 68 61 72 73 20 28 73 74 72 69 6e 67 2d 6c 65 6e hars (string-len
bd20: 67 74 68 20 73 65 65 64 2d 73 74 72 69 6e 67 29 gth seed-string)
bd30: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
bd40: 20 28 28 72 65 73 20 22 22 29 0a 09 20 20 20 20 ((res "")..
bd50: 20 20 20 28 6e 20 20 20 31 29 29 0a 20 20 20 20 (n 1)).
bd60: 20 20 28 6c 65 74 20 28 28 63 68 61 72 2d 6e 75 (let ((char-nu
bd70: 6d 20 28 72 61 6e 64 6f 6d 20 6e 75 6d 2d 63 68 m (random num-ch
bd80: 61 72 73 29 29 29 0a 09 28 69 66 20 28 3e 20 6e ars)))..(if (> n
bd90: 20 6c 65 6e 29 20 72 65 73 0a 09 20 20 20 20 28 len) res.. (
bda0: 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 70 loop (string-app
bdb0: 65 6e 64 20 72 65 73 20 28 73 75 62 73 74 72 69 end res (substri
bdc0: 6e 67 20 73 65 65 64 2d 73 74 72 69 6e 67 20 63 ng seed-string c
bdd0: 68 61 72 2d 6e 75 6d 20 28 2b 20 63 68 61 72 2d har-num (+ char-
bde0: 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 28 2b 20 num 1)))... (+
bdf0: 6e 20 31 29 29 29 29 29 29 29 0a 0a 0a 3b 3b 3d n 1)))))))...;;=
be00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be40: 3d 3d 3d 3d 3d 0a 3b 3b 20 50 20 41 20 52 20 41 =====.;; P A R A
be50: 20 4d 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d M S.;;=========
be60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
bea0: 3b 20 69 6e 70 75 74 3a 20 27 61 20 28 27 61 20 ; input: 'a ('a
beb0: 22 76 61 6c 20 61 22 20 27 62 20 22 76 61 6c 20 "val a" 'b "val
bec0: 62 22 29 20 3d 3e 20 22 76 61 6c 20 61 22 0a 28 b") => "val a".(
bed0: 64 65 66 69 6e 65 20 28 73 3a 66 69 6e 64 2d 70 define (s:find-p
bee0: 61 72 61 6d 20 6b 65 79 20 70 61 72 61 6d 2d 6c aram key param-l
bef0: 73 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 st). (let loop
bf00: 28 28 68 65 61 64 20 28 63 61 72 20 70 61 72 61 ((head (car para
bf10: 6d 2d 6c 73 74 29 29 0a 09 20 20 20 20 20 28 74 m-lst)).. (t
bf20: 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 2d 6c ail (cdr param-l
bf30: 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 65 st))). (if (e
bf40: 71 3f 20 68 65 61 64 20 6b 65 79 29 0a 09 28 63 q? head key)..(c
bf50: 61 72 20 74 61 69 6c 29 0a 09 28 69 66 20 28 3c ar tail)..(if (<
bf60: 20 28 6c 65 6e 67 74 68 20 74 61 69 6c 29 20 32 (length tail) 2
bf70: 29 20 23 66 0a 09 20 20 20 20 28 6c 6f 6f 70 20 ) #f.. (loop
bf80: 28 63 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 (cadr tail)(cddr
bf90: 20 74 61 69 6c 29 29 29 29 29 29 0a 0a 28 64 65 tail))))))..(de
bfa0: 66 69 6e 65 20 28 73 3a 70 61 72 61 6d 2d 3e 73 fine (s:param->s
bfb0: 74 72 69 6e 67 20 70 61 72 61 6d 29 0a 20 20 28 tring param). (
bfc0: 63 6f 6e 63 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 conc (symbol->st
bfd0: 72 69 6e 67 20 28 63 61 72 20 70 61 72 61 6d 29 ring (car param)
bfe0: 29 20 22 3d 22 20 22 5c 22 22 20 28 63 61 64 72 ) "=" "\"" (cadr
bff0: 20 70 61 72 61 6d 29 20 22 5c 22 22 29 29 0a 0a param) "\""))..
c000: 3b 3b 20 72 65 6d 6f 76 65 20 27 66 6f 6f 20 22 ;; remove 'foo "
c010: 62 61 72 22 20 66 72 6f 6d 20 28 27 66 6f 6f 20 bar" from ('foo
c020: 22 62 61 72 22 20 27 62 61 72 20 22 66 6f 6f 22 "bar" 'bar "foo"
c030: 29 0a 28 64 65 66 69 6e 65 20 28 73 3a 72 65 6d ).(define (s:rem
c040: 6f 76 65 2d 70 61 72 61 6d 2d 6d 61 74 63 68 69 ove-param-matchi
c050: 6e 67 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 ng params key).
c060: 20 28 69 66 20 28 3d 20 28 6c 65 6e 67 74 68 20 (if (= (length
c070: 70 61 72 61 6d 73 29 20 30 29 27 28 29 20 3b 3b params) 0)'() ;;
c080: 20 20 70 72 6f 70 65 72 20 70 61 72 61 6d 73 20 proper params
c090: 6c 69 73 74 20 3e 3d 20 32 20 69 74 65 6d 73 0a list >= 2 items.
c0a0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
c0b0: 28 28 68 65 61 64 20 20 20 20 20 28 63 61 72 20 ((head (car
c0c0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 params)).
c0d0: 20 20 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 (tail
c0e0: 20 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 29 (cdr params)
c0f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c100: 20 20 20 28 72 65 73 75 6c 74 20 20 20 27 28 29 (result '()
c110: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
c120: 73 79 6d 62 6f 6c 3f 20 68 65 61 64 29 20 3b 3b symbol? head) ;;
c130: 20 73 79 6d 62 6f 6c 73 20 68 61 76 65 20 70 61 symbols have pa
c140: 72 61 6d 73 0a 20 20 20 20 20 20 20 20 20 20 20 rams.
c150: 20 28 6c 65 74 20 28 28 76 61 6c 20 20 20 20 20 (let ((val
c160: 28 63 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 (car tail)).
c170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
c180: 65 77 74 61 69 6c 20 28 63 64 72 20 74 61 69 6c ewtail (cdr tail
c190: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
c1a0: 20 20 28 69 66 20 28 65 71 3f 20 68 65 61 64 20 (if (eq? head
c1b0: 6b 65 79 29 20 20 3b 3b 20 67 65 74 20 72 69 64 key) ;; get rid
c1c0: 20 6f 66 20 74 68 69 73 20 6f 6e 65 0a 20 20 20 of this one.
c1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c1e0: 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 61 69 if (null? newtai
c1f0: 6c 29 20 72 65 73 75 6c 74 0a 20 20 20 20 20 20 l) result.
c200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c210: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
c220: 69 6c 29 28 63 64 72 20 6e 65 77 74 61 69 6c 29 il)(cdr newtail)
c230: 20 72 65 73 75 6c 74 29 29 0a 20 20 20 20 20 20 result)).
c240: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
c250: 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 61 70 ((newresult (ap
c260: 70 65 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 73 pend result (lis
c270: 74 20 68 65 61 64 20 76 61 6c 29 29 29 29 0a 20 t head val)))).
c280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c290: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 (if (null? ne
c2a0: 77 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 wtail) newresult
c2b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c2c0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
c2d0: 63 61 72 20 6e 65 77 74 61 69 6c 29 28 63 64 72 car newtail)(cdr
c2e0: 20 6e 65 77 74 61 69 6c 29 20 6e 65 77 72 65 73 newtail) newres
c2f0: 75 6c 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 ult))))).
c300: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 72 (let ((newr
c310: 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 esult (append re
c320: 73 75 6c 74 20 28 6c 69 73 74 20 68 65 61 64 29 sult (list head)
c330: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
c340: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 (if (null? tai
c350: 6c 29 20 6e 65 77 72 65 73 75 6c 74 0a 20 20 20 l) newresult.
c360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c370: 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
c380: 63 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 73 cdr tail) newres
c390: 75 6c 74 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ult)))))))..(def
c3a0: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
c3b0: 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 61 72 61 -param-from para
c3c0: 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ms key). (let (
c3d0: 28 72 31 20 28 72 65 67 65 78 70 20 28 63 6f 6e (r1 (regexp (con
c3e0: 63 20 22 5e 22 20 28 73 3a 61 6e 79 2d 3e 73 74 c "^" (s:any->st
c3f0: 72 69 6e 67 20 6b 65 79 29 20 22 3d 28 2e 2a 29 ring key) "=(.*)
c400: 24 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 $")))). (if (
c410: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 23 66 null? params) #f
c420: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f . (let lo
c430: 6f 70 20 28 28 68 65 61 64 20 28 63 61 72 20 70 op ((head (car p
c440: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
c450: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 69 6c (tail
c460: 20 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 0a (cdr params))).
c470: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
c480: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
c490: 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 0a atch r1 head))).
c4a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
c4b0: 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 20 match.
c4c0: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
c4d0: 6d 61 74 63 68 20 31 29 0a 20 20 20 20 20 20 20 match 1).
c4e0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
c4f0: 6c 6c 3f 20 74 61 69 6c 29 20 23 66 0a 20 20 20 ll? tail) #f.
c500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c510: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
c520: 29 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 )(cdr tail))))))
c530: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a )))..(define (s:
c540: 70 72 6f 63 65 73 73 2d 70 61 72 61 6d 73 20 70 process-params p
c550: 61 72 61 6d 73 29 0a 20 20 28 69 66 20 28 6e 75 arams). (if (nu
c560: 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 22 0a 20 ll? params) "".
c570: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
c580: 28 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 (res "").
c590: 20 20 20 20 20 20 20 20 20 20 28 68 65 61 64 20 (head
c5a0: 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 (car params)).
c5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c5c0: 74 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 tail (cdr params
c5d0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ))). (if
c5e0: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 20 (null? tail).
c5f0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 (conc r
c600: 65 73 20 22 20 22 20 28 73 3a 70 61 72 61 6d 2d es " " (s:param-
c610: 3e 73 74 72 69 6e 67 20 68 65 61 64 29 29 0a 20 >string head)).
c620: 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 (loop
c630: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 . (c
c640: 6f 6e 63 20 72 65 73 20 22 20 22 20 28 73 3a 70 onc res " " (s:p
c650: 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 68 65 61 aram->string hea
c660: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
c670: 20 28 63 61 72 20 74 61 69 6c 29 0a 20 20 20 20 (car tail).
c680: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 61 (cdr ta
c690: 69 6c 29 29 29 29 29 29 0a 0a 3b 3b 20 72 65 6d il))))))..;; rem
c6a0: 6f 76 65 20 6b 65 79 3d 76 61 72 20 66 72 6f 6d ove key=var from
c6b0: 20 28 6b 65 79 3d 76 61 72 20 6b 65 79 31 3d 76 (key=var key1=v
c6c0: 61 72 31 20 6b 65 79 32 3d 76 61 72 32 20 2e 2e ar1 key2=var2 ..
c6d0: 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b 3d 76 2d .).(define (k=v-
c6e0: 70 61 72 61 6d 73 3a 72 65 6d 6f 76 65 2d 6d 61 params:remove-ma
c6f0: 74 63 68 69 6e 67 20 70 61 72 61 6d 73 20 6b 65 tching params ke
c700: 79 29 0a 20 20 28 69 66 20 28 3d 20 28 6c 65 6e y). (if (= (len
c710: 67 74 68 20 70 61 72 61 6d 73 29 20 30 29 20 70 gth params) 0) p
c720: 61 72 61 6d 73 0a 20 20 20 20 20 20 28 6c 65 74 arams. (let
c730: 20 28 28 72 31 20 28 72 65 67 65 78 70 20 28 63 ((r1 (regexp (c
c740: 6f 6e 63 20 22 5e 22 20 6b 65 79 20 22 3d 22 29 onc "^" key "=")
c750: 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 ))). (let
c760: 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 63 61 loop ((head (ca
c770: 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 r params)).
c780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
c790: 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 29 ail (cdr params)
c7a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c7b0: 20 20 20 20 20 28 72 65 73 75 6c 74 20 27 28 29 (result '()
c7c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
c7d0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 (string-match r
c7e0: 31 20 68 65 61 64 29 0a 20 20 20 20 20 20 20 20 1 head).
c7f0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
c800: 20 74 61 69 6c 29 20 72 65 73 75 6c 74 0a 20 20 tail) result.
c810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c820: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
c830: 28 63 64 72 20 74 61 69 6c 29 20 72 65 73 75 6c (cdr tail) resul
c840: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
c850: 20 20 28 6c 65 74 20 28 28 6e 65 77 6c 73 74 20 (let ((newlst
c860: 28 63 6f 6e 73 20 68 65 61 64 20 72 65 73 75 6c (cons head resul
c870: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
c880: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
c890: 74 61 69 6c 29 20 6e 65 77 6c 73 74 0a 20 20 20 tail) newlst.
c8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8b0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
c8c0: 29 28 63 64 72 20 74 61 69 6c 29 20 6e 65 77 6c )(cdr tail) newl
c8d0: 73 74 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d st))))))))..;;==
c8e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c8f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c920: 3d 3d 3d 3d 0a 3b 3b 20 73 74 75 66 66 20 70 75 ====.;; stuff pu
c930: 6c 6c 65 64 20 66 72 6f 6d 20 73 65 73 73 69 6f lled from sessio
c940: 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d n.;;============
c950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 0a 3b 3b 20 ==========...;;
c990: 73 65 73 73 69 6f 6e 73 20 74 61 62 6c 65 0a 3b sessions table.;
c9a0: 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f 69 64 20 ; id session_id
c9b0: 73 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b 3b 20 63 session_key.;; c
c9c0: 72 65 61 74 65 20 74 61 62 6c 65 20 73 65 73 73 reate table sess
c9d0: 69 6f 6e 73 20 28 69 64 20 73 65 72 69 61 6c 20 ions (id serial
c9e0: 6e 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e not null,session
c9f0: 2d 6b 65 79 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 -key text);..;;
ca00: 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 74 61 62 session_vars tab
ca10: 6c 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e le.;; id session
ca20: 5f 69 64 20 70 61 67 65 5f 69 64 20 6b 65 79 20 _id page_id key
ca30: 76 61 6c 75 65 0a 3b 3b 20 63 72 65 61 74 65 20 value.;; create
ca40: 74 61 62 6c 65 20 73 65 73 73 69 6f 6e 5f 76 61 table session_va
ca50: 72 73 20 28 69 64 20 73 65 72 69 61 6c 20 6e 6f rs (id serial no
ca60: 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f 6e 5f 69 t null,session_i
ca70: 64 20 69 6e 74 65 67 65 72 2c 70 61 67 65 20 74 d integer,page t
ca80: 65 78 74 2c 6b 65 79 20 74 65 78 74 2c 76 61 6c ext,key text,val
ca90: 75 65 20 74 65 78 74 29 3b 0a 0a 3b 3b 20 54 4f ue text);..;; TO
caa0: 44 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 74 20 6f DO.;; Concept o
cab0: 66 20 6f 72 64 65 72 20 6e 75 6d 20 69 6e 63 72 f order num incr
cac0: 65 6d 65 6e 74 65 64 20 77 69 74 68 20 65 61 63 emented with eac
cad0: 68 20 70 61 67 65 20 61 63 63 65 73 73 0a 3b 3b h page access.;;
cae0: 20 20 20 20 20 69 66 20 61 20 62 72 61 6e 63 68 if a branch
caf0: 20 69 73 20 74 61 6b 65 6e 20 74 68 65 6e 20 61 is taken then a
cb00: 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 77 6f 75 new session wou
cb10: 6c 64 20 6e 65 65 64 20 74 6f 20 62 65 20 63 72 ld need to be cr
cb20: 65 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 6d 61 6b eated.;;..;; mak
cb30: 65 2d 76 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 e-vector-record
cb40: 73 65 73 73 69 6f 6e 20 73 65 73 73 69 6f 6e 20 session session
cb50: 64 62 74 79 70 65 20 64 62 69 6e 69 74 20 63 6f dbtype dbinit co
cb60: 6e 6e 20 70 61 72 61 6d 73 20 70 61 74 68 2d 70 nn params path-p
cb70: 61 72 61 6d 73 20 73 65 73 73 69 6f 6e 2d 6b 65 arams session-ke
cb80: 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 64 6f 6d y session-id dom
cb90: 61 69 6e 20 74 6f 70 70 61 67 65 20 70 61 67 65 ain toppage page
cba0: 20 63 75 72 72 2d 70 61 67 65 20 63 6f 6e 74 65 curr-page conte
cbb0: 6e 74 2d 74 79 70 65 20 70 61 67 65 2d 74 79 70 nt-type page-typ
cbc0: 65 20 73 72 6f 6f 74 20 74 77 69 6b 69 64 69 72 e sroot twikidir
cbd0: 20 70 61 67 65 64 61 74 20 61 6c 74 2d 70 61 67 pagedat alt-pag
cbe0: 65 2d 64 61 74 20 70 61 67 65 76 61 72 73 20 70 e-dat pagevars p
cbf0: 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 agevars-before s
cc00: 65 73 73 69 6f 6e 76 61 72 73 20 73 65 73 73 69 essionvars sessi
cc10: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 67 6c onvars-before gl
cc20: 6f 62 61 6c 76 61 72 73 20 67 6c 6f 62 61 6c 76 obalvars globalv
cc30: 61 72 73 2d 62 65 66 6f 72 65 20 6c 6f 67 70 74 ars-before logpt
cc40: 20 66 6f 72 6d 64 61 74 20 72 65 71 75 65 73 74 formdat request
cc50: 2d 6d 65 74 68 6f 64 20 73 65 73 73 69 6f 6e 2d -method session-
cc60: 63 6f 6f 6b 69 65 20 63 75 72 72 2d 65 72 72 20 cookie curr-err
cc70: 6c 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 69 6c 65 log-port logfile
cc80: 20 73 65 65 6e 2d 70 61 67 65 73 20 70 61 67 65 seen-pages page
cc90: 2d 64 69 72 2d 73 74 79 6c 65 20 64 65 62 75 67 -dir-style debug
cca0: 6d 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 6d 61 mode.(define (ma
ccb0: 6b 65 2d 73 64 61 74 29 28 6d 61 6b 65 2d 76 65 ke-sdat)(make-ve
ccc0: 63 74 6f 72 20 33 36 29 29 0a 28 64 65 66 69 6e ctor 36)).(defin
ccd0: 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 e (sdat-get-dbty
cce0: 70 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 pe
ccf0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
cd00: 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 -ref vec 0)).(d
cd10: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
cd20: 64 62 69 6e 69 74 20 20 20 20 20 20 20 20 20 20 dbinit
cd30: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
cd40: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 ctor-ref vec 1)
cd50: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
cd60: 67 65 74 2d 63 6f 6e 6e 20 20 20 20 20 20 20 20 get-conn
cd70: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
cd80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
cd90: 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 c 2)).(define (s
cda0: 64 61 74 2d 67 65 74 2d 70 67 63 6f 6e 6e 20 20 dat-get-pgconn
cdb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
cdc0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
cdd0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 (vector-ref vec
cde0: 20 32 29 20 31 29 29 0a 28 64 65 66 69 6e 65 20 2) 1)).(define
cdf0: 28 73 64 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 (sdat-get-params
ce00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
ce10: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
ce20: 65 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 ef vec 3)).(def
ce30: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
ce40: 74 68 2d 70 61 72 61 6d 73 20 20 20 20 20 20 20 th-params
ce50: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
ce60: 6f 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a or-ref vec 4)).
ce70: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
ce80: 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 t-session-key
ce90: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
cea0: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
ceb0: 35 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 5)).(define (sda
cec0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-get-session-id
ced0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
cee0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
cef0: 76 65 63 20 36 29 29 0a 28 64 65 66 69 6e 65 20 vec 6)).(define
cf00: 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e (sdat-get-domain
cf10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
cf20: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
cf30: 65 66 20 20 76 65 63 20 37 29 29 0a 28 64 65 66 ef vec 7)).(def
cf40: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 74 6f ine (sdat-get-to
cf50: 70 70 61 67 65 20 20 20 20 20 20 20 20 20 20 20 ppage
cf60: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
cf70: 6f 72 2d 72 65 66 20 20 76 65 63 20 38 29 29 0a or-ref vec 8)).
cf80: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
cf90: 74 2d 70 61 67 65 20 20 20 20 20 20 20 20 20 20 t-page
cfa0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
cfb0: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
cfc0: 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 9)).(define (sda
cfd0: 74 2d 67 65 74 2d 63 75 72 72 2d 70 61 67 65 20 t-get-curr-page
cfe0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
cff0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
d000: 76 65 63 20 31 30 29 29 0a 28 64 65 66 69 6e 65 vec 10)).(define
d010: 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 (sdat-get-conte
d020: 6e 74 2d 74 79 70 65 20 20 20 20 20 20 20 20 20 nt-type
d030: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
d040: 72 65 66 20 20 76 65 63 20 31 31 29 29 0a 28 64 ref vec 11)).(d
d050: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
d060: 70 61 67 65 2d 74 79 70 65 20 20 20 20 20 20 20 page-type
d070: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
d080: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 32 ctor-ref vec 12
d090: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
d0a0: 2d 67 65 74 2d 73 72 6f 6f 74 20 20 20 20 20 20 -get-sroot
d0b0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
d0c0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
d0d0: 65 63 20 31 33 29 29 0a 28 64 65 66 69 6e 65 20 ec 13)).(define
d0e0: 28 73 64 61 74 2d 67 65 74 2d 74 77 69 6b 69 64 (sdat-get-twikid
d0f0: 69 72 20 20 20 20 20 20 20 20 20 20 20 20 20 76 ir v
d100: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
d110: 65 66 20 20 76 65 63 20 31 34 29 29 0a 28 64 65 ef vec 14)).(de
d120: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
d130: 61 67 65 64 61 74 20 20 20 20 20 20 20 20 20 20 agedat
d140: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
d150: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 35 29 tor-ref vec 15)
d160: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
d170: 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 get-alt-page-dat
d180: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
d190: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
d1a0: 63 20 31 36 29 29 0a 28 64 65 66 69 6e 65 20 28 c 16)).(define (
d1b0: 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
d1c0: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 s ve
d1d0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
d1e0: 66 20 20 76 65 63 20 31 37 29 29 0a 28 64 65 66 f vec 17)).(def
d1f0: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 ine (sdat-get-pa
d200: 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 gevars-before
d210: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
d220: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 38 29 29 or-ref vec 18))
d230: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
d240: 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 20 et-sessionvars
d250: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
d260: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
d270: 20 31 39 29 29 0a 28 64 65 66 69 6e 65 20 28 73 19)).(define (s
d280: 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 dat-get-sessionv
d290: 61 72 73 2d 62 65 66 6f 72 65 20 20 20 76 65 63 ars-before vec
d2a0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
d2b0: 20 20 76 65 63 20 32 30 29 29 0a 28 64 65 66 69 vec 20)).(defi
d2c0: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f ne (sdat-get-glo
d2d0: 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 20 balvars
d2e0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
d2f0: 72 2d 72 65 66 20 20 76 65 63 20 32 31 29 29 0a r-ref vec 21)).
d300: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
d310: 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 t-globalvars-bef
d320: 6f 72 65 20 20 20 20 76 65 63 29 20 20 20 20 28 ore vec) (
d330: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
d340: 32 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 22)).(define (sd
d350: 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 20 20 20 at-get-logpt
d360: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
d370: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
d380: 20 76 65 63 20 32 33 29 29 0a 28 64 65 66 69 6e vec 23)).(defin
d390: 65 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 6d e (sdat-get-form
d3a0: 64 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 dat
d3b0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
d3c0: 2d 72 65 66 20 20 76 65 63 20 32 34 29 29 0a 28 -ref vec 24)).(
d3d0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
d3e0: 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 -request-method
d3f0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
d400: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
d410: 35 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 5)).(define (sda
d420: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f t-get-session-co
d430: 6f 6b 69 65 20 20 20 20 20 20 20 76 65 63 29 20 okie vec)
d440: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
d450: 76 65 63 20 32 36 29 29 0a 28 64 65 66 69 6e 65 vec 26)).(define
d460: 20 28 73 64 61 74 2d 67 65 74 2d 63 75 72 72 2d (sdat-get-curr-
d470: 65 72 72 20 20 20 20 20 20 20 20 20 20 20 20 20 err
d480: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
d490: 72 65 66 20 20 76 65 63 20 32 37 29 29 0a 28 64 ref vec 27)).(d
d4a0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
d4b0: 6c 6f 67 2d 70 6f 72 74 20 20 20 20 20 20 20 20 log-port
d4c0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
d4d0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 38 ctor-ref vec 28
d4e0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
d4f0: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 20 20 20 -get-logfile
d500: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
d510: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
d520: 65 63 20 32 39 29 29 0a 28 64 65 66 69 6e 65 20 ec 29)).(define
d530: 28 73 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 (sdat-get-seen-p
d540: 61 67 65 73 20 20 20 20 20 20 20 20 20 20 20 76 ages v
d550: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
d560: 65 66 20 20 76 65 63 20 33 30 29 29 0a 28 64 65 ef vec 30)).(de
d570: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 fine (sdat-get-p
d580: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 20 20 age-dir-style
d590: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
d5a0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 31 29 tor-ref vec 31)
d5b0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
d5c0: 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 20 20 get-debugmode
d5d0: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
d5e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
d5f0: 63 20 33 32 29 29 0a 28 64 65 66 69 6e 65 20 28 c 32)).(define (
d600: 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d sdat-get-shared-
d610: 68 61 73 68 20 20 20 20 20 20 20 20 20 20 76 65 hash ve
d620: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
d630: 66 20 20 76 65 63 20 33 33 29 29 0a 28 64 65 66 f vec 33)).(def
d640: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 63 ine (sdat-get-sc
d650: 72 69 70 74 20 20 20 20 20 20 20 20 20 20 20 20 ript
d660: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
d670: 6f 72 2d 72 65 66 20 20 76 65 63 20 33 34 29 29 or-ref vec 34))
d680: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
d690: 65 74 2d 66 6f 72 63 65 2d 73 73 6c 20 20 20 20 et-force-ssl
d6a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
d6b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
d6c0: 20 33 35 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 35))..(define (
d6d0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 68 61 72 session:get-shar
d6e0: 65 64 20 76 65 63 20 76 61 72 6e 61 6d 65 29 0a ed vec varname).
d6f0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
d700: 66 2f 64 65 66 61 75 6c 74 20 28 76 65 63 74 6f f/default (vecto
d710: 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 61 r-ref vec 33) va
d720: 72 6e 61 6d 65 20 23 66 29 29 0a 0a 28 64 65 66 rname #f))..(def
d730: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 64 62 ine (sdat-set-db
d740: 74 79 70 65 21 20 20 20 20 20 20 20 20 20 20 20 type!
d750: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
d760: 6f 72 2d 73 65 74 21 20 76 65 63 20 30 20 76 61 or-set! vec 0 va
d770: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
d780: 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 20 20 20 t-set-dbinit!
d790: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
d7a0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
d7b0: 76 65 63 20 31 20 76 61 6c 29 29 0a 28 64 65 66 vec 1 val)).(def
d7c0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 63 6f ine (sdat-set-co
d7d0: 6e 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 nn!
d7e0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
d7f0: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 20 76 61 or-set! vec 2 va
d800: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
d810: 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 20 20 20 t-set-params!
d820: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
d830: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
d840: 76 65 63 20 33 20 76 61 6c 29 29 0a 28 64 65 66 vec 3 val)).(def
d850: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
d860: 74 68 2d 70 61 72 61 6d 73 21 20 20 20 20 20 20 th-params!
d870: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
d880: 6f 72 2d 73 65 74 21 20 76 65 63 20 34 20 76 61 or-set! vec 4 va
d890: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
d8a0: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
d8b0: 79 21 20 20 20 20 20 20 20 20 20 76 65 63 20 76 y! vec v
d8c0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
d8d0: 76 65 63 20 35 20 76 61 6c 29 29 0a 28 64 65 66 vec 5 val)).(def
d8e0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ine (sdat-set-se
d8f0: 73 73 69 6f 6e 2d 69 64 21 20 20 20 20 20 20 20 ssion-id!
d900: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
d910: 6f 72 2d 73 65 74 21 20 76 65 63 20 36 20 76 61 or-set! vec 6 va
d920: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
d930: 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 t-set-domain!
d940: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
d950: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
d960: 76 65 63 20 37 20 76 61 6c 29 29 0a 28 64 65 66 vec 7 val)).(def
d970: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 74 6f ine (sdat-set-to
d980: 70 70 61 67 65 21 20 20 20 20 20 20 20 20 20 20 ppage!
d990: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
d9a0: 6f 72 2d 73 65 74 21 20 76 65 63 20 38 20 76 61 or-set! vec 8 va
d9b0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
d9c0: 74 2d 73 65 74 2d 70 61 67 65 21 20 20 20 20 20 t-set-page!
d9d0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
d9e0: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
d9f0: 76 65 63 20 39 20 76 61 6c 29 29 0a 28 64 65 66 vec 9 val)).(def
da00: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 63 75 ine (sdat-set-cu
da10: 72 72 2d 70 61 67 65 21 20 20 20 20 20 20 20 20 rr-page!
da20: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
da30: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 30 20 76 or-set! vec 10 v
da40: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
da50: 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 at-set-content-t
da60: 79 70 65 21 20 20 20 20 20 20 20 20 76 65 63 20 ype! vec
da70: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
da80: 20 76 65 63 20 31 31 20 76 61 6c 29 29 0a 28 64 vec 11 val)).(d
da90: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
daa0: 70 61 67 65 2d 74 79 70 65 21 20 20 20 20 20 20 page-type!
dab0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
dac0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 32 ctor-set! vec 12
dad0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
dae0: 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 sdat-set-sroot!
daf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
db00: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
db10: 74 21 20 76 65 63 20 31 33 20 76 61 6c 29 29 0a t! vec 13 val)).
db20: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
db30: 74 2d 74 77 69 6b 69 64 69 72 21 20 20 20 20 20 t-twikidir!
db40: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
db50: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
db60: 31 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 14 val)).(define
db70: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 64 (sdat-set-paged
db80: 61 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 at!
db90: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
dba0: 73 65 74 21 20 76 65 63 20 31 35 20 76 61 6c 29 set! vec 15 val)
dbb0: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
dbc0: 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 set-alt-page-dat
dbd0: 21 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c ! vec val
dbe0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
dbf0: 63 20 31 36 20 76 61 6c 29 29 0a 28 64 65 66 69 c 16 val)).(defi
dc00: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 ne (sdat-set-pag
dc10: 65 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 evars!
dc20: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
dc30: 72 2d 73 65 74 21 20 76 65 63 20 31 37 20 76 61 r-set! vec 17 va
dc40: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
dc50: 74 2d 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 t-set-pagevars-b
dc60: 65 66 6f 72 65 21 20 20 20 20 20 76 65 63 20 76 efore! vec v
dc70: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
dc80: 76 65 63 20 31 38 20 76 61 6c 29 29 0a 28 64 65 vec 18 val)).(de
dc90: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 fine (sdat-set-s
dca0: 65 73 73 69 6f 6e 76 61 72 73 21 20 20 20 20 20 essionvars!
dcb0: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
dcc0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 39 20 tor-set! vec 19
dcd0: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
dce0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 76 dat-set-sessionv
dcf0: 61 72 73 2d 62 65 66 6f 72 65 21 20 20 76 65 63 ars-before! vec
dd00: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
dd10: 21 20 76 65 63 20 32 30 20 76 61 6c 29 29 0a 28 ! vec 20 val)).(
dd20: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
dd30: 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 20 20 20 -globalvars!
dd40: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
dd50: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
dd60: 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 1 val)).(define
dd70: 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c (sdat-set-global
dd80: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 76 vars-before! v
dd90: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
dda0: 65 74 21 20 76 65 63 20 32 32 20 76 61 6c 29 29 et! vec 22 val))
ddb0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
ddc0: 65 74 2d 6c 6f 67 70 74 21 20 20 20 20 20 20 20 et-logpt!
ddd0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
dde0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
ddf0: 20 32 33 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 23 val)).(defin
de00: 65 20 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 6d e (sdat-set-form
de10: 64 61 74 21 20 20 20 20 20 20 20 20 20 20 20 20 dat!
de20: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
de30: 2d 73 65 74 21 20 76 65 63 20 32 34 20 76 61 6c -set! vec 24 val
de40: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
de50: 2d 73 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 -set-request-met
de60: 68 6f 64 21 20 20 20 20 20 20 76 65 63 20 76 61 hod! vec va
de70: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
de80: 65 63 20 32 35 20 76 61 6c 29 29 0a 28 64 65 66 ec 25 val)).(def
de90: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 65 ine (sdat-set-se
dea0: 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 20 20 ssion-cookie!
deb0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
dec0: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 36 20 76 or-set! vec 26 v
ded0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
dee0: 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 at-set-curr-err!
def0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 vec
df00: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
df10: 20 76 65 63 20 32 37 20 76 61 6c 29 29 0a 28 64 vec 27 val)).(d
df20: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
df30: 6c 6f 67 2d 70 6f 72 74 21 20 20 20 20 20 20 20 log-port!
df40: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
df50: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 38 ctor-set! vec 28
df60: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
df70: 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 sdat-set-logfile
df80: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ! ve
df90: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
dfa0: 74 21 20 76 65 63 20 32 39 20 76 61 6c 29 29 0a t! vec 29 val)).
dfb0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
dfc0: 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 20 20 t-seen-pages!
dfd0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
dfe0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
dff0: 33 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 30 val)).(define
e000: 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 2d (sdat-set-page-
e010: 64 69 72 2d 73 74 79 6c 65 21 20 20 20 20 20 20 dir-style!
e020: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
e030: 73 65 74 21 20 76 65 63 20 33 31 20 76 61 6c 29 set! vec 31 val)
e040: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
e050: 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 20 set-debugmode!
e060: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
e070: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
e080: 63 20 33 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 32 val)).(defi
e090: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 73 68 61 ne (sdat-set-sha
e0a0: 72 65 64 2d 68 61 73 68 21 20 20 20 20 20 20 20 red-hash!
e0b0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
e0c0: 72 2d 73 65 74 21 20 76 65 63 20 33 33 20 76 61 r-set! vec 33 va
e0d0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
e0e0: 74 2d 73 65 74 2d 73 63 72 69 70 74 21 20 20 20 t-set-script!
e0f0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
e100: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
e110: 76 65 63 20 33 34 20 76 61 6c 29 29 0a 28 64 65 vec 34 val)).(de
e120: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 66 fine (sdat-set-f
e130: 6f 72 63 65 2d 73 73 6c 21 20 20 20 20 20 20 20 orce-ssl!
e140: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
e150: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 35 20 tor-set! vec 35
e160: 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 val))..(define (
e170: 73 65 73 73 69 6f 6e 3a 73 65 74 2d 73 68 61 72 session:set-shar
e180: 65 64 21 20 76 65 63 20 76 61 72 6e 61 6d 65 20 ed! vec varname
e190: 76 61 6c 29 0a 20 20 28 68 61 73 68 2d 74 61 62 val). (hash-tab
e1a0: 6c 65 2d 73 65 74 21 20 28 76 65 63 74 6f 72 2d le-set! (vector-
e1b0: 72 65 66 20 76 65 63 20 33 33 29 20 76 61 72 6e ref vec 33) varn
e1c0: 61 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b 20 54 68 ame val))..;; Th
e1d0: 65 20 67 6c 6f 62 61 6c 20 73 65 73 73 69 6f 6e e global session
e1e0: 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 73 73 69 .(define s:sessi
e1f0: 6f 6e 20 28 6d 61 6b 65 2d 73 64 61 74 29 29 0a on (make-sdat)).
e200: 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 4f 20 53 .;; SPLIT INTO S
e210: 54 52 41 49 47 48 54 20 46 4f 52 57 41 52 44 20 TRAIGHT FORWARD
e220: 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 4c 45 58 INIT AND COMPLEX
e230: 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 20 28 73 INIT.(define (s
e240: 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a ession:initializ
e250: 65 20 73 65 6c 66 29 0a 20 20 28 73 64 61 74 2d e self). (sdat-
e260: 73 65 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 set-dbtype! self
e270: 20 20 20 20 20 20 27 70 67 29 0a 20 20 28 73 64 'pg). (sd
e280: 61 74 2d 73 65 74 2d 70 61 67 65 21 20 73 65 6c at-set-page! sel
e290: 66 20 20 20 20 20 20 20 20 22 68 6f 6d 65 22 29 f "home")
e2a0: 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 73 65 ;; these
e2b0: 20 61 72 65 20 64 65 66 61 75 6c 74 73 0a 20 20 are defaults.
e2c0: 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 70 (sdat-set-curr-p
e2d0: 61 67 65 21 20 73 65 6c 66 20 20 20 22 68 6f 6d age! self "hom
e2e0: 65 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d e"). (sdat-set-
e2f0: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 20 73 65 content-type! se
e300: 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 lf "Content-type
e310: 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 : text/html; cha
e320: 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c rset=iso-8859-1\
e330: 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 2d 73 65 n\n"). (sdat-se
e340: 74 2d 70 61 67 65 2d 74 79 70 65 21 20 73 65 6c t-page-type! sel
e350: 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 28 73 64 f 'html). (sd
e360: 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 65 21 20 at-set-toppage!
e370: 73 65 6c 66 20 20 20 20 20 22 69 6e 64 65 78 22 self "index"
e380: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
e390: 72 61 6d 73 21 20 73 65 6c 66 20 20 20 20 20 20 rams! self
e3a0: 27 28 29 29 20 20 20 20 20 20 20 20 20 20 20 3b '()) ;
e3b0: 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ;. (sdat-set-pa
e3c0: 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 th-params! self
e3d0: 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 '()). (sdat-set
e3e0: 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 -session-key! se
e3f0: 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 lf #f). (sdat-s
e400: 65 74 2d 70 61 67 65 64 61 74 21 20 73 65 6c 66 et-pagedat! self
e410: 20 20 20 20 20 27 28 29 29 0a 20 20 28 73 64 61 '()). (sda
e420: 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 t-set-alt-page-d
e430: 61 74 21 20 73 65 6c 66 20 23 66 29 0a 20 20 28 at! self #f). (
e440: 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 sdat-set-sroot!
e450: 73 65 6c 66 20 20 20 20 20 20 20 22 2e 2f 22 29 self "./")
e460: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 . (sdat-set-ses
e470: 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 6c sion-cookie! sel
e480: 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 f #f). (sdat-se
e490: 74 2d 63 75 72 72 2d 65 72 72 21 20 73 65 6c 66 t-curr-err! self
e4a0: 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 65 74 #f). (sdat-set
e4b0: 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 6c 66 20 -log-port! self
e4c0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
e4d0: 6f 72 74 29 29 0a 20 20 28 73 64 61 74 2d 73 65 ort)). (sdat-se
e4e0: 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 t-seen-pages! se
e4f0: 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d lf '()). (sdat-
e500: 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 set-page-dir-sty
e510: 6c 65 21 20 73 65 6c 66 20 23 74 29 20 3b 3b 20 le! self #t) ;;
e520: 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 #t : pages/<page
e530: 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 6e 74 6c name>_(view|cntl
e540: 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 20 20 20 ).scm.
e550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e560: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 23 ;; #
e570: 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 67 65 6e f : pages/<pagen
e580: 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f 6e 74 72 ame>/(view|contr
e590: 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 64 61 74 ol).scm . (sdat
e5a0: 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 21 20 -set-debugmode!
e5b0: 20 20 20 20 20 20 20 20 20 73 65 6c 66 20 23 66 self #f
e5c0: 29 0a 20 20 09 09 09 20 20 20 20 20 0a 20 20 28 ). ... . (
e5d0: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 sdat-set-pagevar
e5e0: 73 21 20 20 20 20 20 20 20 20 20 20 20 73 65 6c s! sel
e5f0: 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 f (make-hash-tab
e600: 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 le)). (sdat-set
e610: 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 20 -sessionvars!
e620: 20 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d self (make-
e630: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
e640: 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 61 6c 76 sdat-set-globalv
e650: 61 72 73 21 20 20 20 20 20 20 20 20 20 73 65 6c ars! sel
e660: 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 f (make-hash-tab
e670: 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 le)). (sdat-set
e680: 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
e690: 21 20 20 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d ! self (make-
e6a0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
e6b0: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
e6c0: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 73 65 6c vars-before! sel
e6d0: 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 f (make-hash-tab
e6e0: 6c 65 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 le)). (sdat-set
e6f0: 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f -globalvars-befo
e700: 72 65 21 20 20 73 65 6c 66 20 28 6d 61 6b 65 2d re! self (make-
e710: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
e720: 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 sdat-set-domain!
e730: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 65 6c sel
e740: 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 20 20 20 f "locahost")
e750: 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 61 75 6c ;; end of defaul
e760: 74 73 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 ts. (sdat-set-s
e770: 63 72 69 70 74 21 20 20 20 20 20 20 20 20 20 20 cript!
e780: 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 self #f). (s
e790: 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 2d 73 73 dat-set-force-ss
e7a0: 6c 21 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 l! self
e7b0: 20 23 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 #f). (let* ((r
e7c0: 61 77 63 6f 6e 66 69 67 64 61 74 20 28 73 65 73 awconfigdat (ses
e7d0: 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 67 sion:read-config
e7e0: 20 73 65 6c 66 29 29 0a 09 20 28 63 6f 6e 66 69 self)).. (confi
e7f0: 67 64 61 74 20 28 69 66 20 72 61 77 63 6f 6e 66 gdat (if rawconf
e800: 69 67 64 61 74 20 28 65 76 61 6c 20 72 61 77 63 igdat (eval rawc
e810: 6f 6e 66 69 67 64 61 74 29 20 27 28 29 29 29 0a onfigdat) '())).
e820: 09 20 28 73 72 6f 6f 74 20 20 20 20 20 28 73 3a . (sroot (s:
e830: 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 72 6f 6f find-param 'sroo
e840: 74 20 20 20 20 63 6f 6e 66 69 67 64 61 74 29 29 t configdat))
e850: 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 20 28 73 .. (logfile (s
e860: 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 6c 6f 67 :find-param 'log
e870: 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 61 74 29 file configdat)
e880: 29 0a 09 20 28 64 62 74 79 70 65 20 20 20 20 28 ).. (dbtype (
e890: 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 62 s:find-param 'db
e8a0: 74 79 70 65 20 20 20 63 6f 6e 66 69 67 64 61 74 type configdat
e8b0: 29 29 0a 09 20 28 64 62 69 6e 69 74 20 20 20 20 )).. (dbinit
e8c0: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 (s:find-param 'd
e8d0: 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 67 64 61 binit configda
e8e0: 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e 20 20 20 t)).. (domain
e8f0: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
e900: 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 69 67 64 domain configd
e910: 61 74 29 29 0a 09 20 28 74 77 69 6b 69 64 69 72 at)).. (twikidir
e920: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
e930: 27 74 77 69 6b 69 64 69 72 20 63 6f 6e 66 69 67 'twikidir config
e940: 64 61 74 29 29 0a 09 20 28 70 61 67 65 2d 64 69 dat)).. (page-di
e950: 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d r (s:find-param
e960: 20 27 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 'page-dir-style
e970: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 configdat)).. (
e980: 64 65 62 75 67 6d 6f 64 65 20 28 73 3a 66 69 6e debugmode (s:fin
e990: 64 2d 70 61 72 61 6d 20 27 64 65 62 75 67 6d 6f d-param 'debugmo
e9a0: 64 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 20 de configdat)).
e9b0: 20 20 20 20 20 20 20 20 28 73 63 72 69 70 74 20 (script
e9c0: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
e9d0: 20 27 73 63 72 69 70 74 20 20 20 20 63 6f 6e 66 'script conf
e9e0: 69 67 64 61 74 29 29 0a 09 20 28 66 6f 72 63 65 igdat)).. (force
e9f0: 2d 73 73 6c 20 28 73 3a 66 69 6e 64 2d 70 61 72 -ssl (s:find-par
ea00: 61 6d 20 27 66 6f 72 63 65 2d 73 73 6c 20 63 6f am 'force-ssl co
ea10: 6e 66 69 67 64 61 74 29 29 29 0a 20 20 20 20 28 nfigdat))). (
ea20: 69 66 20 73 72 6f 6f 74 20 20 20 20 28 73 64 61 if sroot (sda
ea30: 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 20 20 20 t-set-sroot!
ea40: 73 65 6c 66 20 73 72 6f 6f 74 29 29 0a 20 20 20 self sroot)).
ea50: 20 28 69 66 20 6c 6f 67 66 69 6c 65 20 20 28 73 (if logfile (s
ea60: 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 6c 65 21 dat-set-logfile!
ea70: 20 20 73 65 6c 66 20 6c 6f 67 66 69 6c 65 29 29 self logfile))
ea80: 0a 20 20 20 20 28 69 66 20 64 62 74 79 70 65 20 . (if dbtype
ea90: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 62 74 79 (sdat-set-dbty
eaa0: 70 65 21 20 20 20 73 65 6c 66 20 64 62 74 79 70 pe! self dbtyp
eab0: 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 69 6e e)). (if dbin
eac0: 69 74 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 it (sdat-set-d
ead0: 62 69 6e 69 74 21 20 20 20 73 65 6c 66 20 64 62 binit! self db
eae0: 69 6e 69 74 29 29 0a 20 20 20 20 28 69 66 20 64 init)). (if d
eaf0: 6f 6d 61 69 6e 20 20 20 28 73 64 61 74 2d 73 65 omain (sdat-se
eb00: 74 2d 64 6f 6d 61 69 6e 21 20 20 20 73 65 6c 66 t-domain! self
eb10: 20 64 6f 6d 61 69 6e 29 29 0a 20 20 20 20 28 69 domain)). (i
eb20: 66 20 74 77 69 6b 69 64 69 72 20 28 73 64 61 74 f twikidir (sdat
eb30: 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 20 73 -set-twikidir! s
eb40: 65 6c 66 20 74 77 69 6b 69 64 69 72 29 29 0a 20 elf twikidir)).
eb50: 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 (if debugmode
eb60: 20 28 73 64 61 74 2d 73 65 74 2d 64 65 62 75 67 (sdat-set-debug
eb70: 6d 6f 64 65 21 20 73 65 6c 66 20 64 65 62 75 67 mode! self debug
eb80: 6d 6f 64 65 29 29 0a 20 20 20 20 28 69 66 20 73 mode)). (if s
eb90: 63 72 69 70 74 20 20 20 20 28 73 64 61 74 2d 73 cript (sdat-s
eba0: 65 74 2d 73 63 72 69 70 74 21 20 20 20 20 73 65 et-script! se
ebb0: 6c 66 20 73 63 72 69 70 74 29 29 0a 20 20 20 20 lf script)).
ebc0: 28 69 66 20 66 6f 72 63 65 2d 73 73 6c 20 28 73 (if force-ssl (s
ebd0: 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 2d 73 73 dat-set-force-ss
ebe0: 6c 21 20 73 65 6c 66 20 66 6f 72 63 65 2d 73 73 l! self force-ss
ebf0: 6c 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 l)). (sdat-se
ec00: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
ec10: 21 20 73 65 6c 66 20 70 61 67 65 2d 64 69 72 29 ! self page-dir)
ec20: 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
ec30: 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 28 70 70 configdat: ")(pp
ec40: 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 20 20 configdat).
ec50: 28 69 66 20 64 65 62 75 67 6d 6f 64 65 0a 09 28 (if debugmode..(
ec60: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
ec70: 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 6f 6f 74 "sroot: " sroot
ec80: 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 20 6c 6f " logfile: " lo
ec90: 67 66 69 6c 65 20 22 20 64 62 74 79 70 65 3a 20 gfile " dbtype:
eca0: 22 20 64 62 74 79 70 65 20 0a 09 09 20 20 20 20 " dbtype ...
ecb0: 20 22 20 64 62 69 6e 69 74 3a 20 22 20 64 62 69 " dbinit: " dbi
ecc0: 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a 20 22 20 nit " domain: "
ecd0: 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 2d 64 69 domain " page-di
ece0: 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 67 65 2d r-style: " page-
ecf0: 64 69 72 29 29 0a 20 20 20 20 29 0a 20 20 28 73 dir)). ). (s
ed00: 64 61 74 2d 73 65 74 2d 73 68 61 72 65 64 2d 68 dat-set-shared-h
ed10: 61 73 68 21 20 73 65 6c 66 20 28 6d 61 6b 65 2d ash! self (make-
ed20: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 29 hash-table)). )
ed30: 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 20 74 68 ..;; Used for th
ed40: 65 20 73 74 72 61 6e 67 65 6c 79 20 69 6e 63 6f e strangely inco
ed50: 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 6c 69 6e nsistent handlin
ed60: 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 69 67 20 g of the config
ed70: 66 69 6c 65 2e 20 41 20 62 65 74 74 65 72 20 77 file. A better w
ed80: 61 79 20 69 73 20 6e 65 65 64 65 64 2e 0a 3b 3b ay is needed..;;
ed90: 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 64 62 74 .;; (let ((dbt
eda0: 79 70 65 20 28 73 64 61 74 2d 67 65 74 2d 64 62 ype (sdat-get-db
edb0: 74 79 70 65 20 73 65 6c 66 29 29 29 0a 3b 3b 20 type self))).;;
edc0: 20 20 20 20 28 70 72 69 6e 74 20 22 64 62 74 79 (print "dbty
edd0: 70 65 3a 20 22 20 64 62 74 79 70 65 29 0a 3b 3b pe: " dbtype).;;
ede0: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 (sdat-set-d
edf0: 62 74 79 70 65 21 20 73 65 6c 66 20 28 65 76 61 btype! self (eva
ee00: 6c 20 64 62 74 79 70 65 29 29 29 29 0a 0a 28 64 l dbtype))))..(d
ee10: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 efine (session:s
ee20: 65 74 75 70 20 73 65 6c 66 29 0a 20 20 28 6c 65 etup self). (le
ee30: 74 20 28 28 64 62 74 79 70 65 20 20 20 20 28 73 t ((dbtype (s
ee40: 64 61 74 2d 67 65 74 2d 64 62 74 79 70 65 20 73 dat-get-dbtype s
ee50: 65 6c 66 29 29 0a 09 28 64 65 62 75 67 6d 6f 64 elf))..(debugmod
ee60: 65 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 75 e (sdat-get-debu
ee70: 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a 09 28 64 gmode self))..(d
ee80: 62 69 6e 69 74 20 20 20 20 28 65 76 61 6c 20 28 binit (eval (
ee90: 73 64 61 74 2d 67 65 74 2d 64 62 69 6e 69 74 20 sdat-get-dbinit
eea0: 73 65 6c 66 29 29 29 0a 09 28 64 62 65 78 69 73 self)))..(dbexis
eeb0: 74 73 20 20 23 66 29 29 0a 20 20 20 20 28 6c 65 ts #f)). (le
eec0: 74 20 28 28 64 62 66 6e 61 6d 65 20 28 61 6c 69 t ((dbfname (ali
eed0: 73 74 2d 72 65 66 20 27 64 62 6e 61 6d 65 20 64 st-ref 'dbname d
eee0: 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 28 binit))). (
eef0: 69 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 if debugmode (se
ef00: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
ef10: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 64 62 session:setup db
ef20: 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 6d 65 20 fname=" dbfname
ef30: 22 2c 20 64 62 74 79 70 65 3d 22 20 64 62 74 79 ", dbtype=" dbty
ef40: 70 65 20 22 2c 20 64 62 69 6e 69 74 3d 22 20 64 pe ", dbinit=" d
ef50: 62 69 6e 69 74 29 29 0a 20 20 20 20 20 20 28 69 binit)). (i
ef60: 66 20 28 65 71 3f 20 64 62 74 79 70 65 20 27 73 f (eq? dbtype 's
ef70: 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 20 54 68 qlite3).. ;; Th
ef80: 65 20 27 61 75 74 6f 20 6d 65 74 68 6f 64 20 77 e 'auto method w
ef90: 69 6c 6c 20 64 69 73 74 72 69 62 75 74 65 20 64 ill distribute d
efa0: 62 73 20 61 63 72 6f 73 73 20 74 68 65 20 64 69 bs across the di
efb0: 73 6b 20 75 73 69 6e 67 20 68 61 73 68 0a 09 20 sk using hash..
efc0: 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 6f 73 74 ;; of user host
efd0: 20 61 6e 64 20 75 73 65 72 2e 20 54 4f 44 4f 0a and user. TODO.
efe0: 09 20 20 3b 3b 20 28 69 66 20 28 65 71 3f 20 64 . ;; (if (eq? d
eff0: 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 20 3b 3b bfname 'auto) ;;
f000: 20 54 68 69 73 20 69 73 20 74 68 65 20 61 75 74 This is the aut
f010: 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 6f 66 20 o assignment of
f020: 61 20 64 62 20 62 61 73 65 64 20 6f 6e 20 68 61 a db based on ha
f030: 73 68 20 6f 66 20 49 50 0a 09 20 20 28 6c 65 74 sh of IP.. (let
f040: 20 28 28 64 62 70 61 74 68 20 28 70 61 74 68 6e ((dbpath (pathn
f050: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 62 ame-directory db
f060: 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 64 6f 20 fname))) ;; do
f070: 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 74 79 20 a couple sanity
f080: 63 68 65 63 6b 73 20 68 65 72 65 20 74 6f 20 6d checks here to m
f090: 61 6b 65 20 73 65 74 74 69 6e 67 20 75 70 20 65 ake setting up e
f0a0: 61 73 69 65 72 0a 09 20 20 20 20 28 69 66 20 64 asier.. (if d
f0b0: 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f ebugmode (sessio
f0c0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f n:log self "INFO
f0d0: 3a 20 73 65 74 74 69 6e 67 20 75 70 20 66 6f 72 : setting up for
f0e0: 20 73 71 6c 69 74 65 33 20 64 62 20 61 63 63 65 sqlite3 db acce
f0f0: 73 73 20 74 6f 20 22 20 64 62 66 6e 61 6d 65 29 ss to " dbfname)
f100: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
f110: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
f120: 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 09 28 ss? dbpath))...(
f130: 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
f140: 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e 6f "WARNING: Canno
f150: 74 20 77 72 69 74 65 20 74 6f 20 22 20 64 62 70 t write to " dbp
f160: 61 74 68 29 0a 09 09 28 69 66 20 64 65 62 75 67 ath)...(if debug
f170: 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f mode (session:lo
f180: 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 22 20 g self "INFO: "
f190: 64 62 70 61 74 68 20 22 20 69 73 20 77 72 69 74 dbpath " is writ
f1a0: 65 61 62 6c 65 22 29 29 29 0a 09 20 20 20 20 28 eable"))).. (
f1b0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
f1c0: 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 62 65 67 dbfname)...(beg
f1d0: 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 73 73 69 in... ;; (sessi
f1e0: 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 65 74 on:log self "set
f1f0: 74 69 6e 67 20 64 62 65 78 69 73 74 73 20 74 6f ting dbexists to
f200: 20 23 74 22 29 0a 09 09 20 20 28 73 65 74 21 20 #t")... (set!
f210: 64 62 65 78 69 73 74 73 20 23 74 29 29 29 29 0a dbexists #t)))).
f220: 09 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 . (if debugmode
f230: 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 (session:log se
f240: 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 74 69 6e lf "INFO: settin
f250: 67 20 75 70 20 66 6f 72 20 70 67 20 64 62 20 61 g up for pg db a
f260: 63 63 65 73 73 20 74 6f 20 61 63 63 6f 75 6e 74 ccess to account
f270: 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 74 29 29 info " dbinit))
f280: 29 0a 20 20 20 20 20 20 28 69 66 20 64 65 62 75 ). (if debu
f290: 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c gmode (session:l
f2a0: 6f 67 20 73 65 6c 66 20 22 64 62 74 79 70 65 3a og self "dbtype:
f2b0: 20 22 20 64 62 74 79 70 65 20 22 20 64 62 66 6e " dbtype " dbfn
f2c0: 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d 65 20 22 ame: " dbfname "
f2d0: 20 64 62 65 78 69 73 74 73 3a 20 22 20 64 62 65 dbexists: " dbe
f2e0: 78 69 73 74 73 29 29 29 0a 20 20 20 20 28 73 64 xists))). (sd
f2f0: 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 73 65 6c at-set-conn! sel
f300: 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 62 74 79 f (dbi:open dbty
f310: 70 65 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 pe dbinit)).
f320: 28 73 65 74 21 20 2a 64 62 2a 20 28 73 64 61 74 (set! *db* (sdat
f330: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
f340: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e . (if (and (n
f350: 6f 74 20 64 62 65 78 69 73 74 73 29 28 65 71 3f ot dbexists)(eq?
f360: 20 64 62 74 79 70 65 20 27 73 71 6c 69 74 65 33 dbtype 'sqlite3
f370: 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 20 20 28 )). .(begin.. (
f380: 70 72 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 print "WARNING:
f390: 53 65 74 74 69 6e 67 20 75 70 20 73 65 73 73 69 Setting up sessi
f3a0: 6f 6e 20 64 62 20 77 69 74 68 20 73 71 6c 69 74 on db with sqlit
f3b0: 65 33 22 29 0a 09 20 20 28 73 65 73 73 69 6f 6e e3").. (session
f3c0: 3a 73 65 74 75 70 2d 64 62 20 73 65 6c 66 29 29 :setup-db self))
f3d0: 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 70 ). (session:p
f3e0: 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 74 68 20 rocess-url-path
f3f0: 73 65 6c 66 29 0a 20 20 20 20 28 73 65 73 73 69 self). (sessi
f400: 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 69 6f 6e on:setup-session
f410: 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 20 20 3b -key self). ;
f420: 3b 20 63 61 70 74 75 72 65 20 73 74 64 69 6e 20 ; capture stdin
f430: 69 66 20 74 68 69 73 20 69 73 20 61 20 50 4f 53 if this is a POS
f440: 54 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d T. (sdat-set-
f450: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 21 20 request-method!
f460: 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 69 72 6f self (get-enviro
f470: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
f480: 52 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 22 29 REQUEST_METHOD")
f490: 29 0a 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d ). (sdat-set-
f4a0: 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 20 28 66 formdat! self (f
f4b0: 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 ormdat:load-all)
f4c0: 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 20 74 68 )))..;; setup th
f4d0: 65 20 64 62 20 77 69 74 68 20 73 65 73 73 69 6f e db with sessio
f4e0: 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 6b 73 20 n tables, works
f4f0: 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e 6c 79 20 for sqlite only
f500: 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 66 69 6e right now.(defin
f510: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 e (session:setup
f520: 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 -db self). (let
f530: 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 2d 67 65 ((conn (sdat-ge
f540: 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 20 t-conn self))).
f550: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
f560: 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 6d 74 (lambda (stmt
f570: 29 0a 20 20 20 20 20 20 20 28 64 62 69 3a 65 78 ). (dbi:ex
f580: 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 29 0a 20 ec conn stmt)).
f590: 20 20 20 20 28 6c 69 73 74 20 22 43 52 45 41 54 (list "CREAT
f5a0: 45 20 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 5f E TABLE session_
f5b0: 76 61 72 73 20 28 69 64 20 49 4e 54 45 47 45 52 vars (id INTEGER
f5c0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 73 65 73 PRIMARY KEY,ses
f5d0: 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 45 52 2c sion_id INTEGER,
f5e0: 70 61 67 65 20 54 45 58 54 2c 6b 65 79 20 54 45 page TEXT,key TE
f5f0: 58 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 XT,value TEXT);"
f600: 0a 09 20 20 20 22 43 52 45 41 54 45 20 54 41 42 .. "CREATE TAB
f610: 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 69 64 20 LE sessions (id
f620: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
f630: 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b 65 79 20 KEY,session_key
f640: 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 64 20 54 TEXT,last_used T
f650: 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 20 20 20 IMESTAMP);".
f660: 20 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 "CREATE T
f670: 41 42 4c 45 20 6d 65 74 61 64 61 74 61 20 28 69 ABLE metadata (i
f680: 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 d INTEGER PRIMAR
f690: 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 76 Y KEY,key TEXT,v
f6a0: 61 6c 75 65 20 54 45 58 54 29 3b 22 29 29 29 29 alue TEXT);"))))
f6b0: 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 20 68 61 .;; ;; if we ha
f6c0: 76 65 20 61 20 73 65 73 73 69 6f 6e 5f 6b 65 79 ve a session_key
f6d0: 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 73 65 73 look up the ses
f6e0: 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 74 6f 72 sion-id and stor
f6f0: 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 74 2d 73 e it.;; (sdat-s
f700: 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 73 et-session-id! s
f710: 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 elf (session:get
f720: 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a 3b 3b 20 -id self)))..;;
f730: 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 69 6f 6e only set session
f740: 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 61 20 6e -cookie when a n
f750: 65 77 20 73 65 73 73 69 6f 6e 20 69 73 20 63 72 ew session is cr
f760: 65 61 74 65 64 0a 28 64 65 66 69 6e 65 20 28 73 eated.(define (s
f770: 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 ession:setup-ses
f780: 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 20 20 sion-key self)
f790: 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b 20 20 28 . (let* ((sk (
f7a0: 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d session:extract-
f7b0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
f7c0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 69 64 )). (sid
f7d0: 20 28 69 66 20 73 6b 20 28 73 65 73 73 69 6f 6e (if sk (session
f7e0: 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 73 6b 29 :get-id self sk)
f7f0: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 #f))). (if (
f800: 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e 65 65 64 not sid) ;; need
f810: 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 20 20 20 a new key.
f820: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 6b (let* ((new-k
f830: 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ey (session:get-
f840: 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 29 0a 20 new-key self)).
f850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
f860: 65 77 2d 73 69 64 20 28 73 65 73 73 69 6f 6e 3a ew-sid (session:
f870: 67 65 74 2d 69 64 20 73 65 6c 66 20 6e 65 77 2d get-id self new-
f880: 6b 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 key))).
f890: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
f8a0: 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 6e 65 77 on-key! self new
f8b0: 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 -key).
f8c0: 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f (sdat-set-sessio
f8d0: 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 77 2d 73 n-id! self new-s
f8e0: 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 id). (s
f8f0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
f900: 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 28 73 65 cookie! self (se
f910: 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b 69 ssion:make-cooki
f920: 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 20 e self))).
f930: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
f940: 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 73 69 64 ion-id! self sid
f950: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
f960: 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f 6f 6b ession:make-cook
f970: 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b 20 28 6c ie self). ;; (l
f980: 69 73 74 20 28 63 6f 6e 63 20 22 73 65 73 73 69 ist (conc "sessi
f990: 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 74 2d 67 on_key=" (sdat-g
f9a0: 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
f9b0: 65 6c 66 29 20 22 3b 20 50 61 74 68 3d 2f 3b 20 elf) "; Path=/;
f9c0: 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 61 74 2d Domain=." (sdat-
f9d0: 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 6c 66 29 get-domain self)
f9e0: 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 20 28 2a "; Max-Age=" (*
f9f0: 20 38 36 34 30 30 20 31 34 29 20 22 3b 20 56 65 86400 14) "; Ve
fa00: 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a 20 20 3b rsion=1"))) . ;
fa10: 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 6f 20 0a ; According to .
fa20: 20 20 3b 3b 20 20 20 20 68 74 74 70 3a 2f 2f 77 ;; http://w
fa30: 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c 73 2e 63 ww.codemarvels.c
fa40: 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 61 63 68 om/2010/11/apach
fa50: 65 2d 72 65 77 72 69 74 65 72 75 6c 65 2d 73 65 e-rewriterule-se
fa60: 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e 2d 6c 6f t-a-cookie-on-lo
fa70: 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b 3b 20 20 calhost/.. ;;
fa80: 48 65 72 65 20 61 72 65 20 74 68 65 20 32 20 28 Here are the 2 (
fa90: 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 74 29 20 often left out)
faa0: 72 65 71 75 69 72 65 6d 65 6e 74 73 20 74 6f 20 requirements to
fab0: 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 75 73 69 set a cookie usi
fac0: 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 64 1b 2d ng. ;; httpd.-
fad0: 46 ef bf bd 73 20 72 65 77 72 69 74 65 20 72 75 F�s rewrite ru
fae0: 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 74 65 29 le (mod_rewrite)
faf0: 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 6e 67 20 , while working
fb00: 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a 1b 2d 41 on localhost:.-A
fb10: 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 73 65 20 . ;;. ;; Use
fb20: 74 68 65 20 49 50 20 31 32 37 2e 30 2e 30 2e 31 the IP 127.0.0.1
fb30: 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 6f 63 61 instead of loca
fb40: 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 2d 6e 61 lhost/machine-na
fb50: 6d 65 20 61 73 20 74 68 65 0a 20 20 3b 3b 20 20 me as the. ;;
fb60: 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 5b 43 4f domain; e.g. [CO
fb70: 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 =someCookie:some
fb80: 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 3a Value:127.0.0.1:
fb90: 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 61 79 73 2:/], which says
fba0: 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 20 61 20 . ;; create a
fbb0: 63 6f 6f 6b 69 65 20 1b 2d 59 ef bf bd 73 6f 6d cookie .-Y�som
fbc0: 65 43 6f 6f 6b 69 65 ef bf bd 20 77 69 74 68 20 eCookie� with
fbd0: 76 61 6c 75 65 20 ef bf bd 73 6f 6d 65 56 61 6c value �someVal
fbe0: 75 65 ef bf bd 20 66 6f 72 20 74 68 65 0a 20 20 ue� for the.
fbf0: 3b 3b 20 20 64 6f 6d 61 69 6e 20 ef bf bd 31 32 ;; domain �12
fc00: 37 2e 30 2e 30 2e 31 1b 24 42 21 6d 1b 28 42 20 7.0.0.1.$B!m.(B
fc10: 68 61 76 69 6e 67 20 61 20 6c 69 66 65 20 74 69 having a life ti
fc20: 6d 65 20 6f 66 20 32 20 6d 69 6e 73 2c 20 66 6f me of 2 mins, fo
fc30: 72 20 61 6e 79 20 70 61 74 68 20 69 6e 0a 20 20 r any path in.
fc40: 3b 3b 20 20 74 68 65 20 64 6f 6d 61 69 6e 20 28 ;; the domain (
fc50: 70 61 74 68 3d 2f 29 2e 20 28 4f 62 76 69 6f 75 path=/). (Obviou
fc60: 73 6c 79 20 79 6f 75 20 77 69 6c 6c 20 68 61 76 sly you will hav
fc70: 65 20 74 6f 20 72 75 6e 20 74 68 65 0a 20 20 3b e to run the. ;
fc80: 3b 20 20 61 70 70 6c 69 63 61 74 69 6f 6e 20 77 ; application w
fc90: 69 74 68 20 74 68 69 73 20 76 61 6c 75 65 20 69 ith this value i
fca0: 6e 20 74 68 65 20 55 52 4c 29 0a 20 20 3b 3b 0a n the URL). ;;.
fcb0: 20 20 3b 3b 20 20 54 6f 20 6d 61 6b 65 20 61 20 ;; To make a
fcc0: 73 65 73 73 69 6f 6e 20 63 6f 6f 6b 69 65 2c 20 session cookie,
fcd0: 6c 69 6d 69 74 20 74 68 65 20 66 6c 61 67 20 73 limit the flag s
fce0: 74 61 74 65 6d 65 6e 74 20 74 6f 20 6a 75 73 74 tatement to just
fcf0: 20 74 68 72 65 65 0a 20 20 3b 3b 20 20 61 74 74 three. ;; att
fd00: 72 69 62 75 74 65 73 3a 20 6e 61 6d 65 2c 20 76 ributes: name, v
fd10: 61 6c 75 65 20 61 6e 64 20 64 6f 6d 61 69 6e 2e alue and domain.
fd20: 20 65 2e 67 0a 20 20 3b 3b 20 20 5b 43 4f 3d 73 e.g. ;; [CO=s
fd30: 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d 65 56 61 omeCookie:someVa
fd40: 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 5d 20 1b lue:127.0.0.1] .
fd50: 25 47 e2 80 93 1b 25 40 20 41 6e 79 20 66 75 72 %G–.%@ Any fur
fd60: 74 68 65 72 0a 20 20 3b 3b 20 20 73 65 74 74 69 ther. ;; setti
fd70: 6e 67 73 2c 20 61 70 61 63 68 65 20 77 72 69 74 ngs, apache writ
fd80: 65 73 20 61 6e ef bf bd 20 65 78 70 69 72 65 73 es an� expires
fd90: ef bf bd 20 61 74 74 72 69 62 75 74 65 20 66 6f � attribute fo
fda0: 72 20 74 68 65 20 73 65 74 2d 63 6f 6f 6b 69 65 r the set-cookie
fdb0: 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 2c 20 77 . ;; header, w
fdc0: 68 69 63 68 20 6d 61 6b 65 73 20 74 68 65 20 63 hich makes the c
fdd0: 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 73 74 65 ookie a persiste
fde0: 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 65 61 6c nt one (not real
fdf0: 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 69 73 74 ly. ;; persist
fe00: 65 6e 74 2c 20 61 73 20 74 68 65 20 65 78 70 69 ent, as the expi
fe10: 72 65 73 20 76 61 6c 75 65 20 73 65 74 20 69 73 res value set is
fe20: 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 65 72 the current ser
fe30: 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b 20 20 1b ver time. ;; .
fe40: 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 6f 75 20 %G–.%@ so you
fe50: 64 6f 6e 1b 2d 46 1b 2d 46 ef bf bd 74 20 65 76 don.-F.-F�t ev
fe60: 65 6e 20 67 65 74 20 74 6f 20 73 65 65 20 79 6f en get to see yo
fe70: 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d 41 0a 20 ur cookie!).-A.
fe80: 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 (list (string-s
fe90: 75 62 73 74 69 74 75 74 65 20 0a 09 20 22 3b 22 ubstitute .. ";"
fea0: 20 22 3b 20 22 20 0a 09 20 28 63 61 72 20 28 63 "; " .. (car (c
feb0: 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b 69 65 2d onstruct-cookie-
fec0: 73 74 72 69 6e 67 20 0a 09 20 20 20 20 20 20 20 string ..
fed0: 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d 65 73 73 ;; warning! mess
fee0: 69 6e 67 20 75 70 20 74 68 69 73 20 69 74 74 79 ing up this itty
fef0: 20 62 69 74 74 79 20 62 69 74 20 6f 66 20 63 6f bitty bit of co
ff00: 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 6d 75 63 de will cost muc
ff10: 68 20 74 69 6d 65 21 0a 09 20 20 20 20 20 20 20 h time!..
ff20: 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 `(("session_key"
ff30: 20 2c 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 ,(sdat-get-sess
ff40: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 09 09 ion-key self)...
ff50: 20 20 65 78 70 69 72 65 73 3a 20 2c 28 2b 20 28 expires: ,(+ (
ff60: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
ff70: 20 28 2a 20 31 34 20 38 36 34 30 30 29 29 20 0a (* 14 86400)) .
ff80: 09 09 20 20 3b 3b 20 6d 61 78 2d 61 67 65 3a 20 .. ;; max-age:
ff90: 28 2a 20 31 34 20 38 36 34 30 30 29 0a 09 09 20 (* 14 86400)...
ffa0: 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b 20 0a 09 path: "/" ;; ..
ffb0: 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 73 74 72 . domain: ,(str
ffc0: 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e 22 20 28 ing-append "." (
ffd0: 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 sdat-get-domain
ffe0: 73 65 6c 66 29 29 0a 09 09 20 20 76 65 72 73 69 self))... versi
fff0: 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 29 0a 0a on: 1)) 0)))))..
10000 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 67 69 76 ;; look up a giv
10010 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 79 20 61 en session key a
10020 6e 64 20 72 65 74 75 72 6e 20 74 68 65 20 69 64 nd return the id
10030 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 20 69 66 if found, #f if
10040 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 65 66 69 not found.(defi
10050 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
10060 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f 6e 2d id self session-
10070 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 key). ;; (let (
10080 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 73 64 (session-key (sd
10090 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b at-get-session-k
100a0 65 79 20 73 65 6c 66 29 29 29 0a 20 20 28 69 66 ey self))). (if
100b0 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a 20 20 20 session-key.
100c0 20 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 (let ((query
100d0 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
100e0 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 SELECT id FROM s
100f0 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 essions WHERE se
10100 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 73 65 73 ssion_key='" ses
10110 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 29 0a 20 sion-key "'")).
10120 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 6e (conn
10130 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
10140 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 self)).
10150 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 29 0a (result #f)).
10160 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 .(dbi:for-each-r
10170 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 ow .. (lambda (t
10180 75 70 6c 65 29 0a 09 20 20 20 28 73 65 74 21 20 uple).. (set!
10190 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 result (vector-r
101a0 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 20 ef tuple 0)))..
101b0 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 28 69 66 conn query)..(if
101c0 20 72 65 73 75 6c 74 20 28 64 62 69 3a 65 78 65 result (dbi:exe
101d0 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 22 55 50 c conn (conc "UP
101e0 44 41 54 45 20 73 65 73 73 69 6f 6e 73 20 53 45 DATE sessions SE
101f0 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 20 28 64 T last_used=" (d
10200 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 22 20 57 bi:now conn) " W
10210 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 HERE session_key
10220 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e 2d 6b 65 =?;") session-ke
10230 79 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 75 y)). resu
10240 6c 74 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a lt). #f))..
10250 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ;; .(define (ses
10260 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c sion:process-url
10270 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 20 28 6c -path self). (l
10280 65 74 20 28 28 70 61 74 68 2d 69 6e 66 6f 20 20 et ((path-info
10290 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
102a0 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 nt-variable "PAT
102b0 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 75 65 72 H_INFO"))..(quer
102c0 79 2d 73 74 72 69 6e 67 20 28 67 65 74 2d 65 6e y-string (get-en
102d0 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
102e0 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 le "QUERY_STRING
102f0 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 73 "))). ;; (ses
10300 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 70 sion:log self "p
10310 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 74 68 2d ath-info=" path-
10320 69 6e 66 6f 20 22 20 71 75 65 72 79 2d 73 74 72 info " query-str
10330 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 74 72 69 ing=" query-stri
10340 6e 67 29 0a 20 20 20 20 28 69 66 20 70 61 74 68 ng). (if path
10350 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 70 -info..(let* ((p
10360 61 72 74 73 20 20 20 20 28 73 74 72 69 6e 67 2d arts (string-
10370 73 70 6c 69 74 20 70 61 74 68 2d 69 6e 66 6f 20 split path-info
10380 22 2f 22 29 29 0a 09 20 20 20 20 20 20 20 28 6e "/")).. (n
10390 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 74 68 20 umparts (length
103a0 70 61 72 74 73 29 29 29 0a 09 20 20 28 69 66 20 parts))).. (if
103b0 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 29 0a 09 (> numparts 0)..
103c0 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d (sdat-set-
103d0 70 61 67 65 21 20 73 65 6c 66 20 28 63 61 72 20 page! self (car
103e0 70 61 72 74 73 29 29 29 0a 09 20 20 3b 3b 20 28 parts))).. ;; (
103f0 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
10400 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 75 72 6c "url-path=" url
10410 2d 70 61 74 68 20 22 20 70 61 72 74 73 3d 22 20 -path " parts="
10420 70 61 72 74 73 29 0a 09 20 20 28 69 66 20 28 3e parts).. (if (>
10430 20 6e 75 6d 70 61 72 74 73 20 31 29 0a 09 20 20 numparts 1)..
10440 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 (sdat-set-pa
10450 74 68 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 th-params! self
10460 28 63 64 72 20 70 61 72 74 73 29 29 29 0a 20 20 (cdr parts))).
10470 20 20 20 20 20 20 20 20 28 69 66 20 71 75 65 72 (if quer
10480 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 y-string.
10490 20 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 (sdat-set
104a0 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 28 73 -params! self (s
104b0 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 tring-split quer
104c0 79 2d 73 74 72 69 6e 67 20 22 26 22 29 29 29 29 y-string "&"))))
104d0 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 21 0a 28 )))..;; BUGGY!.(
104e0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
104f0 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 get-new-key self
10500 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 6e 20 ). (let ((conn
10510 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
10520 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 self)).
10530 28 74 6d 70 6b 65 79 20 28 73 65 73 73 69 6f 6e (tmpkey (session
10540 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e :make-rand-strin
10550 67 20 32 30 29 29 0a 20 20 20 20 20 20 20 20 28 g 20)). (
10560 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 20 status #f)).
10570 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
10580 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
10590 29 0a 09 09 09 28 73 65 74 21 20 73 74 61 74 75 )....(set! statu
105a0 73 20 23 74 29 29 0a 09 09 20 20 20 20 20 20 63 s #t))... c
105b0 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 70 70 65 onn (string-appe
105c0 6e 64 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 nd "INSERT INTO
105d0 73 65 73 73 69 6f 6e 73 20 28 73 65 73 73 69 6f sessions (sessio
105e0 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 20 28 27 n_key) VALUES ('
105f0 22 20 74 6d 70 6b 65 79 20 22 27 29 22 29 29 0a " tmpkey "')")).
10600 20 20 20 20 74 6d 70 6b 65 79 29 29 0a 0a 3b 3b tmpkey))..;;
10610 20 72 65 74 75 72 6e 73 20 73 65 73 73 69 6f 6e returns session
10620 20 6b 65 79 20 49 46 46 20 69 74 20 69 73 20 69 key IFF it is i
10630 6e 20 74 68 65 20 48 54 54 50 5f 43 4f 4f 4b 49 n the HTTP_COOKI
10640 45 20 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 E .(define (sess
10650 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 65 73 73 ion:extract-sess
10660 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 ion-key self).
10670 28 6c 65 74 20 28 28 68 74 74 70 2d 63 6f 6f 6b (let ((http-cook
10680 69 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ie (get-environm
10690 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 54 ent-variable "HT
106a0 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 0a 20 20 TP_COOKIE"))).
106b0 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 68 ;; (err:log "h
106c0 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 20 68 74 ttp-cookie: " ht
106d0 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 20 20 28 tp-cookie). (
106e0 69 66 20 68 74 74 70 2d 63 6f 6f 6b 69 65 0a 20 if http-cookie.
106f0 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a (session:
10700 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
10710 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 73 74 72 -param self (str
10720 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 73 ing-split-fields
10730 20 20 22 3b 5c 5c 73 2b 22 20 68 74 74 70 2d 63 ";\\s+" http-c
10740 6f 6f 6b 69 65 20 69 6e 66 69 78 3a 29 20 22 73 ookie infix:) "s
10750 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a 20 20 20 ession_key").
10760 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 66 #f)))..(def
10770 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
10780 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 -session-id self
10790 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 session-key).
107a0 28 6c 65 74 20 28 28 71 75 65 72 79 20 22 53 45 (let ((query "SE
107b0 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 73 65 73 LECT id FROM ses
107c0 73 69 6f 6e 73 20 57 48 45 52 45 20 73 65 73 73 sions WHERE sess
107d0 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a 20 20 20 ion_key=?;").
107e0 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 29 (result #f)
107f0 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 70 67 ). ;; (pg
10800 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 63 68 20 :query-for-each
10810 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a (lambda (tuple).
10820 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
10830 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10840 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 (set! result (ve
10850 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 ctor-ref tuple 0
10860 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 ))) ;; (vector-r
10870 65 66 20 74 75 70 6c 65 20 30 29 29 29 0a 20 20 ef tuple 0))).
10880 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
10890 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 73 (s:s
108a0 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 qlparam query se
108b0 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 20 20 3b ssion-key). ;
108c0 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
108d0 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 (sdat-g
108e0 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 et-conn self)).
108f0 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
10900 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6e con
10910 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 6f 72 2d n). (dbi:for-
10920 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 each-row (lambda
10930 20 28 74 75 70 6c 65 29 0a 09 09 09 28 73 65 74 (tuple)....(set
10940 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f 72 ! result (vector
10950 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 20 -ref tuple 0)))
10960 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 ;; (vector-ref t
10970 75 70 6c 65 20 30 29 29 29 0a 09 09 20 20 20 20 uple 0)))...
10980 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
10990 20 73 65 6c 66 29 0a 09 09 20 20 20 20 20 20 28 self)... (
109a0 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
109b0 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 session-key)).
109c0 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 result))..;;
109d0 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 63 6f 72 delete all recor
109e0 64 73 20 66 6f 72 20 61 20 73 65 73 73 69 6f 6e ds for a session
109f0 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 20 54 4f .;; .;; NEEDS TO
10a00 20 42 45 20 54 52 41 4e 53 41 43 54 49 4f 4e 49 BE TRANSACTIONI
10a10 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ZED!.;;.(define
10a20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d (session:delete-
10a30 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 session self ses
10a40 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 6c 65 74 sion-key). (let
10a50 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 ((session-id (s
10a60 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 ession:get-sessi
10a70 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 on-id self sessi
10a80 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 on-key)).
10a90 20 28 71 72 79 31 20 20 20 20 20 20 20 20 3b 3b (qry1 ;;
10aa0 20 28 63 6f 6e 63 20 22 42 45 47 49 4e 3b 22 0a (conc "BEGIN;".
10ab0 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 4f ... "DELETE FRO
10ac0 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
10ad0 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
10ae0 3f 3b 22 29 0a 09 28 71 72 79 32 20 20 20 20 20 ?;")..(qry2
10af0 20 20 20 20 20 20 20 20 22 44 45 4c 45 54 45 20 "DELETE
10b00 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 FROM sessions WH
10b10 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 20 ERE id=?;")...
10b20 20 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 54 3b 22 ;; "COMMIT;"
10b30 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 6e )). (conn
10b40 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
10b50 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
10b60 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 65 73 f))). (if ses
10b70 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 sion-id.
10b80 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
10b90 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 (dbi:exec conn
10ba0 71 72 79 31 20 73 65 73 73 69 6f 6e 2d 69 64 29 qry1 session-id)
10bb0 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a ;; session-id).
10bc0 09 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f 6e . (dbi:exec con
10bd0 6e 20 71 72 79 32 20 73 65 73 73 69 6f 6e 2d 69 n qry2 session-i
10be0 64 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 69 d).. (session:i
10bf0 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a nitialize self).
10c00 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 . (session:setu
10c10 70 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 6e p self))). (n
10c20 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ot (session:get-
10c30 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 session-id self
10c40 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a session-key)))).
10c50 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 .;; (define (ses
10c60 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 73 73 sion:delete-sess
10c70 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 69 6f 6e ion self session
10c80 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c 65 74 20 -key).;; (let
10c90 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 28 73 65 ((session-id (se
10ca0 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 73 69 6f ssion:get-sessio
10cb0 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 6f n-id self sessio
10cc0 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 20 20 20 n-key)).;;
10cd0 20 20 20 28 71 75 65 72 69 65 73 20 20 20 20 28 (queries (
10ce0 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 0a 3b 3b list "BEGIN;".;;
10cf0 20 09 09 09 20 20 22 44 45 4c 45 54 45 20 46 52 ... "DELETE FR
10d00 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 OM session_vars
10d10 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 WHERE session_id
10d20 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 20 20 20 =?;".;;
10d30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10d40 20 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 73 "DELETE FROM s
10d50 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 69 64 essions WHERE id
10d60 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 22 43 4f =?;".;; ... "CO
10d70 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 20 20 20 MMIT;")).;;
10d80 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 (conn
10d90 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
10da0 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 0a 3b 3b -conn self))).;;
10db0 20 20 20 20 20 28 69 66 20 73 65 73 73 69 6f 6e (if session
10dc0 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 -id.;; (
10dd0 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 begin.;;
10de0 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 (for-each.;;
10df0 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
10e00 64 61 20 28 71 75 65 72 79 29 0a 3b 3b 20 20 20 da (query).;;
10e10 20 20 20 20 20 20 20 20 20 20 20 28 64 62 69 3a (dbi:
10e20 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 72 79 20 exec conn query
10e30 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a 3b 3b 20 session-id)).;;
10e40 09 20 20 20 71 75 65 72 69 65 73 29 0a 3b 3b 20 . queries).;;
10e50 09 20 20 28 69 6e 69 74 69 61 6c 69 7a 65 20 73 . (initialize s
10e60 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 20 20 28 elf '()).;; . (
10e70 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
10e80 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6e 6f lf))).;; (no
10e90 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 t (session:get-s
10ea0 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 ession-id self s
10eb0 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 29 0a 0a ession-key))))..
10ec0 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
10ed0 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 73 65 6c :extract-key sel
10ee0 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 f key). (let ((
10ef0 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 65 74 params (sdat-get
10f00 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 29 0a -params self))).
10f10 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 (session:ext
10f20 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 ract-key-from-pa
10f30 72 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 ram self params
10f40 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 key)))..(define
10f50 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 (session:extract
10f60 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 61 6d 20 -key-from-param
10f70 73 65 6c 66 20 70 61 72 61 6d 73 20 6b 65 79 29 self params key)
10f80 0a 20 20 28 6c 65 74 20 28 28 72 31 20 20 20 20 . (let ((r1
10f90 20 28 72 65 67 65 78 70 20 28 73 74 72 69 6e 67 (regexp (string
10fa0 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b 65 79 20 -append "^" key
10fb0 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 29 29 0a "=([^=]+)$")))).
10fc0 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 49 4e (err:log "IN
10fd0 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 6f 72 20 FO: Looking for
10fe0 22 20 6b 65 79 20 22 20 69 6e 20 22 20 70 61 72 " key " in " par
10ff0 61 6d 73 29 0a 20 20 20 20 28 69 66 20 28 3c 20 ams). (if (<
11000 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 (length params)
11010 31 29 20 23 66 0a 09 28 6c 65 74 20 6c 6f 6f 70 1) #f..(let loop
11020 20 28 28 68 65 61 64 20 20 20 28 63 61 72 20 70 ((head (car p
11030 61 72 61 6d 73 29 29 0a 09 09 20 20 20 28 74 61 arams))... (ta
11040 69 6c 20 20 20 28 63 64 72 20 70 61 72 61 6d 73 il (cdr params
11050 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6d 61 ))).. (let ((ma
11060 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 tch (string-matc
11070 68 20 72 31 20 68 65 61 64 29 29 29 0a 09 20 20 h r1 head)))..
11080 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 6d (cond.. (m
11090 61 74 63 68 0a 09 20 20 20 20 20 20 28 6c 65 74 atch.. (let
110a0 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 28 ((session-key (
110b0 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 list-ref match 1
110c0 29 29 29 0a 09 09 28 65 72 72 3a 6c 6f 67 20 22 )))...(err:log "
110d0 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 65 73 73 INFO: Found sess
110e0 69 6f 6e 20 6b 65 79 3d 22 20 73 65 73 73 69 6f ion key=" sessio
110f0 6e 2d 6b 65 79 29 0a 09 09 28 73 64 61 74 2d 73 n-key)...(sdat-s
11100 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 20 et-session-key!
11110 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 66 20 6d self (list-ref m
11120 61 74 63 68 20 31 29 29 0a 09 09 73 65 73 73 69 atch 1))...sessi
11130 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 20 20 28 on-key)).. (
11140 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 20 20 (null? tail)..
11150 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 28 65 #f).. (e
11160 6c 73 65 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 lse.. (loop
11170 20 28 63 61 72 20 74 61 69 6c 29 0a 09 09 20 20 (car tail)...
11180 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 (cdr tail)))))
11190 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
111a0 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 67 65 21 ession:set-page!
111b0 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d 65 29 self page_name)
111c0 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
111d0 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 6d e! self page_nam
111e0 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 e))..(define (se
111f0 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 6c 66 ssion:close self
11200 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 28 ). (dbi:close (
11210 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
11220 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f 73 65 2d lf))).;; (close-
11230 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 73 64 61 output-port (sda
11240 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 65 6c 66 t-get-logpt self
11250 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
11260 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 73 65 6c sion:err-msg sel
11270 66 20 6d 73 67 29 0a 20 20 28 68 61 73 68 2d 74 f msg). (hash-t
11280 61 62 6c 65 2d 73 65 74 21 20 28 73 64 61 74 2d able-set! (sdat-
11290 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
112a0 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d 53 47 self) "ERROR_MSG
112b0 22 0a 09 09 20 20 20 28 73 74 72 69 6e 67 2d 69 "... (string-i
112c0 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
112d0 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6d 73 s:any->string ms
112e0 67 29 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 g) " ")))..(defi
112f0 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 72 65 76 ne (session:prev
11300 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 28 6c 65 -err self). (le
11310 74 20 28 28 70 72 65 76 2d 65 72 72 20 28 68 61 t ((prev-err (ha
11320 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
11330 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 2d 73 ault (sdat-get-s
11340 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
11350 65 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d e self) "ERROR_M
11360 53 47 22 20 23 66 29 29 0a 09 28 63 75 72 72 2d SG" #f))..(curr-
11370 65 72 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d err (hash-table-
11380 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 ref/default (sda
11390 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
113a0 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f 4d s self) "ERROR_M
113b0 53 47 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 SG" #f))). (i
113c0 66 20 70 72 65 76 2d 65 72 72 20 70 72 65 76 2d f prev-err prev-
113d0 65 72 72 0a 09 28 69 66 20 63 75 72 72 2d 65 72 err..(if curr-er
113e0 72 20 63 75 72 72 2d 65 72 72 20 23 66 29 29 29 r curr-err #f)))
113f0 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e 20 76 61 )..;; session va
11400 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 20 61 72 rs.;; 1. keys ar
11410 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e e always a strin
11420 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f 6c 0a 3b g NOT a symbol.;
11430 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 72 65 20 ; 2. values are
11440 61 6c 77 61 79 73 20 61 20 73 74 72 69 6e 67 20 always a string
11450 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 20 74 68 conversion is th
11460 65 20 72 65 73 70 6f 6e 73 69 62 69 6c 69 74 79 e responsibility
11470 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 20 20 63 of the .;; c
11480 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 74 69 6f onsuming functio
11490 6e 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 n (at least for
114a0 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 20 74 6f now, I'd like to
114b0 20 63 68 61 6e 67 65 20 74 68 69 73 29 0a 0a 3b change this)..;
114c0 3b 20 73 65 74 20 61 20 73 65 73 73 69 6f 6e 20 ; set a session
114d0 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 var for the curr
114e0 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ent page.;;.(def
114f0 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 63 75 72 ine (session:cur
11500 72 2d 70 61 67 65 2d 73 65 74 21 20 73 65 6c 66 r-page-set! self
11510 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 68 key value). (h
11520 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
11530 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
11540 73 20 73 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e s self) (s:any->
11550 73 74 72 69 6e 67 20 6b 65 79 29 20 28 73 3a 61 string key) (s:a
11560 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 ny->string value
11570 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 20 76 61 )))..;; del a va
11580 72 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e r for the curren
11590 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e t page.;;.(defin
115a0 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d e (session:page-
115b0 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 20 6b 65 var-del! self ke
115c0 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 y). (hash-table
115d0 2d 64 65 6c 65 74 65 21 20 28 73 64 61 74 2d 67 -delete! (sdat-g
115e0 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
115f0 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ) (s:any->string
11600 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 65 74 20 key)))..;; get
11610 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 20 the appropriate
11620 68 61 73 68 20 67 69 76 65 6e 20 61 20 70 61 67 hash given a pag
11630 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a e "*sessionvars*
11640 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 20 6f , *globalvars* o
11650 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e r page.;;.(defin
11660 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 e (session:get-p
11670 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
11680 67 65 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e ge). (if (strin
11690 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
116a0 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 20 20 20 onvars*").
116b0 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
116c0 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 20 20 20 nvars self).
116d0 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 (if (string=?
116e0 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
116f0 73 2a 22 29 0a 09 20 20 28 73 64 61 74 2d 67 65 s*").. (sdat-ge
11700 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 65 6c t-globalvars sel
11710 66 29 0a 09 20 20 28 73 64 61 74 2d 67 65 74 2d f).. (sdat-get-
11720 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 29 29 pagevars self)))
11730 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 )..;; set a sess
11740 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 67 69 ion var for a gi
11750 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ven page.;;.(def
11760 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
11770 21 20 73 65 6c 66 20 70 61 67 65 20 6b 65 79 20 ! self page key
11780 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 20 28 28 value). (let ((
11790 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ht (session:get-
117a0 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 page-hash self p
117b0 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 age))). (hash
117c0 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 -table-set! ht (
117d0 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
117e0 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e y) (s:any->strin
117f0 67 20 76 61 6c 75 65 29 29 29 29 0a 0a 3b 3b 20 g value))))..;;
11800 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 get session vars
11810 20 66 6f 72 20 74 68 65 20 63 75 72 72 65 6e 74 for the current
11820 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
11830 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 (session:page-g
11840 65 74 20 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 et self key). (
11850 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
11860 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 74 efault (sdat-get
11870 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 20 -pagevars self)
11880 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 67 65 74 key #f))..;; get
11890 20 73 65 73 73 69 6f 6e 20 76 61 72 73 20 66 6f session vars fo
118a0 72 20 61 20 73 70 65 63 69 66 69 65 64 20 70 61 r a specified pa
118b0 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 ge.;;.(define (s
118c0 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 6c 66 20 ession:get self
118d0 70 61 67 65 20 6b 65 79 20 70 61 72 61 6d 73 29 page key params)
118e0 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 20 20 28 . (let* ((ht (
118f0 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 67 65 session:get-page
11900 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 65 29 -hash self page)
11910 29 0a 09 20 28 72 65 73 20 28 68 61 73 68 2d 74 ).. (res (hash-t
11920 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
11930 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 ht (s:any->stri
11940 6e 67 20 6b 65 79 29 20 23 66 29 29 29 0a 20 20 ng key) #f))).
11950 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 (session:apply
11960 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 -type-preference
11970 20 72 65 73 20 70 61 72 61 6d 73 29 29 29 0a 0a res params)))..
11980 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 65 73 73 ;; delete a sess
11990 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 20 73 70 ion var for a sp
119a0 65 63 69 66 69 65 64 20 70 61 67 65 0a 3b 3b 0a ecified page.;;.
119b0 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
119c0 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 67 65 20 :del! self page
119d0 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 68 74 key). (let ((ht
119e0 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
119f0 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 67 ge-hash self pag
11a00 65 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 e))). (hash-t
11a10 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 able-delete! ht
11a20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b (s:any->string k
11a30 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 41 ey))))..;; get A
11a40 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 68 69 73 LL keys for this
11a50 20 70 61 67 65 20 61 6e 64 20 73 74 6f 72 65 20 page and store
11a60 69 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 70 in the session p
11a70 61 67 65 76 61 72 73 20 68 61 73 68 0a 3b 3b 0a agevars hash.;;.
11a80 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
11a90 3a 67 65 74 2d 76 61 72 73 20 73 65 6c 66 29 0a :get-vars self).
11aa0 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
11ab0 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 -id (sdat-get-s
11ac0 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 ession-id self))
11ad0 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
11ae0 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 ession-id)..(err
11af0 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 :log "ERROR: No
11b00 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 session id in se
11b10 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 ssion object! se
11b20 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 ssion:get-vars")
11b30 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 ..(let* ((result
11b40 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
11b50 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 .. (conn
11b60 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 (sd
11b70 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
11b80 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 )).. (page
11b90 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 20 28 vars-before (
11ba0 73 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 sdat-get-pagevar
11bb0 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
11bc0 09 20 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
11bd0 76 61 72 73 2d 62 65 66 6f 72 65 20 28 73 64 61 vars-before (sda
11be0 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
11bf0 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a s-before self)).
11c00 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 . (globalv
11c10 61 72 73 2d 62 65 66 6f 72 65 20 20 28 73 64 61 ars-before (sda
11c20 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 t-get-globalvars
11c30 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 29 0a 09 -before self))..
11c40 20 20 20 20 20 20 20 28 70 61 67 65 76 61 72 73 (pagevars
11c50 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 (sdat
11c60 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 -get-pagevars se
11c70 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 lf)).. (se
11c80 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 ssionvars
11c90 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
11ca0 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 0a 09 20 onvars self))..
11cb0 20 20 20 20 20 20 28 67 6c 6f 62 61 6c 76 61 72 (globalvar
11cc0 73 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d s (sdat-
11cd0 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 73 get-globalvars s
11ce0 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
11cf0 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 age-name
11d00 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
11d10 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
11d20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 20 (session-key
11d30 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
11d40 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 29 ssion-key self))
11d50 0a 09 20 20 20 20 20 20 20 28 71 75 65 72 79 20 .. (query
11d60 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
11d70 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 ring-append.....
11d80 20 20 20 20 22 53 45 4c 45 43 54 20 6b 65 79 2c "SELECT key,
11d90 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 73 73 69 value FROM sessi
11da0 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 20 4a 4f on_vars INNER JO
11db0 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f 4e 20 73 IN sessions ON s
11dc0 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 65 73 73 ession_vars.sess
11dd0 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f 6e 73 2e ion_id=sessions.
11de0 69 64 20 22 0a 09 09 09 09 20 20 20 20 22 57 48 id "..... "WH
11df0 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d ERE session_key=
11e00 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b 22 29 29 ? AND page=?;"))
11e10 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 20 74 68 ).. ;; first th
11e20 65 20 70 61 67 65 20 73 70 65 63 69 66 69 63 20 e page specific
11e30 76 61 72 73 0a 09 20 20 28 64 62 69 3a 66 6f 72 vars.. (dbi:for
11e40 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d 62 64 -each-row (lambd
11e50 61 20 28 74 75 70 6c 65 29 0a 09 09 09 20 20 20 a (tuple)....
11e60 20 20 20 28 6c 65 74 20 28 28 6b 20 28 76 65 63 (let ((k (vec
11e70 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
11e80 29 0a 09 09 09 09 20 20 20 20 28 76 20 28 76 65 )..... (v (ve
11e90 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 31 ctor-ref tuple 1
11ea0 29 29 29 0a 09 09 09 09 28 68 61 73 68 2d 74 61 ))).....(hash-ta
11eb0 62 6c 65 2d 73 65 74 21 20 70 61 67 65 76 61 72 ble-set! pagevar
11ec0 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 s-before k v)...
11ed0 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
11ee0 74 21 20 70 61 67 65 76 61 72 73 20 20 20 20 20 t! pagevars
11ef0 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
11f00 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
11f10 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
11f20 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 67 65 2d ession-key page-
11f30 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 74 68 65 name)).. ;; the
11f40 6e 20 74 68 65 20 73 65 73 73 69 6f 6e 20 73 70 n the session sp
11f50 65 63 69 66 69 63 20 76 61 72 73 0a 09 20 20 28 ecific vars.. (
11f60 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
11f70 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
11f80 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
11f90 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (k (vector-ref t
11fa0 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 uple 0)).....
11fb0 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (v (vector-ref
11fc0 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 tuple 1))).....(
11fd0 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
11fe0 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f sessionvars-befo
11ff0 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 re k v).....(has
12000 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 65 73 h-table-set! ses
12010 73 69 6f 6e 76 61 72 73 20 20 20 20 20 20 20 20 sionvars
12020 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f k v))).... co
12030 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c nn.... (s:sql
12040 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 param query sess
12050 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 73 69 6f ion-key "*sessio
12060 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 3b 3b 20 nvars*")).. ;;
12070 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 68 65 20 and finally the
12080 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 20 20 28 global vars.. (
12090 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
120a0 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
120b0 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
120c0 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (k (vector-ref t
120d0 75 70 6c 65 20 30 29 29 0a 09 09 09 09 20 20 20 uple 0)).....
120e0 20 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (v (vector-ref
120f0 74 75 70 6c 65 20 31 29 29 29 0a 09 09 09 09 28 tuple 1))).....(
12100 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
12110 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 globalvars-befor
12120 65 20 6b 20 76 29 0a 09 09 09 09 28 68 61 73 68 e k v).....(hash
12130 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 6c 6f 62 -table-set! glob
12140 61 6c 76 61 72 73 20 20 20 20 20 20 20 20 6b 20 alvars k
12150 76 29 29 29 0a 09 09 09 20 20 20 20 63 6f 6e 6e v))).... conn
12160 0a 09 09 09 20 20 20 20 28 73 3a 73 71 6c 70 61 .... (s:sqlpa
12170 72 61 6d 20 71 75 65 72 79 20 73 65 73 73 69 6f ram query sessio
12180 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 6c 76 61 n-key "*globalva
12190 72 73 22 29 29 0a 09 20 20 29 29 29 29 0a 0a 28 rs")).. ))))..(
121a0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
121b0 73 61 76 65 2d 76 61 72 73 20 73 65 6c 66 29 0a save-vars self).
121c0 20 20 28 6c 65 74 20 28 28 73 65 73 73 69 6f 6e (let ((session
121d0 2d 69 64 20 20 28 73 64 61 74 2d 67 65 74 2d 73 -id (sdat-get-s
121e0 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 29 29 ession-id self))
121f0 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
12200 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 65 72 72 ession-id)..(err
12210 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 4e 6f 20 :log "ERROR: No
12220 73 65 73 73 69 6f 6e 20 69 64 20 69 6e 20 73 65 session id in se
12230 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 20 73 65 ssion object! se
12240 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 22 29 ssion:get-vars")
12250 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 74 75 73 ..(let* ((status
12260 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 20 #f)..
12270 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 20 20 28 (conn (
12280 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
12290 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 lf)).. (pa
122a0 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 61 74 2d ge-name (sdat-
122b0 67 65 74 2d 70 61 67 65 20 73 65 6c 66 29 29 0a get-page self)).
122c0 09 20 20 20 20 20 20 20 28 64 65 6c 2d 71 75 65 . (del-que
122d0 72 79 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f ry "DELETE FRO
122e0 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 57 M session_vars W
122f0 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 69 64 3d HERE session_id=
12300 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 41 4e 44 ? AND page=? AND
12310 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 20 20 20 key=?;")..
12320 20 20 28 69 6e 73 2d 71 75 65 72 79 20 20 20 22 (ins-query "
12330 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 65 73 73 INSERT INTO sess
12340 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 73 69 6f ion_vars (sessio
12350 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 2c 76 61 n_id,page,key,va
12360 6c 75 65 29 20 56 41 4c 55 45 53 28 3f 2c 3f 2c lue) VALUES(?,?,
12370 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 20 20 20 ?,?);")..
12380 28 75 70 64 2d 71 75 65 72 79 20 20 20 22 55 50 (upd-query "UP
12390 44 41 54 45 20 73 65 73 73 69 6f 6e 5f 76 61 72 DATE session_var
123a0 73 20 73 65 74 20 76 61 6c 75 65 3d 3f 20 57 48 s set value=? WH
123b0 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 20 73 65 ERE key=? AND se
123c0 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e 44 20 70 ssion_id=? AND p
123d0 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 age=?;")..
123e0 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 (changed-count
123f0 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 65 20 74 0)).. ;; save t
12400 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 0a 09 20 he delta only..
12410 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 (for-each.. (
12420 6c 61 6d 62 64 61 20 28 70 61 67 65 29 20 3b 3b lambda (page) ;;
12430 20 70 61 67 65 20 69 73 3a 20 22 2a 67 6c 6f 62 page is: "*glob
12440 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 73 73 69 alvars*" "*sessi
12450 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f 74 68 65 onvars*" or othe
12460 72 73 74 72 69 6e 67 0a 09 20 20 20 20 20 28 6c rstring.. (l
12470 65 74 2a 20 28 28 62 65 66 6f 72 65 2d 61 66 74 et* ((before-aft
12480 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 09 09 09 er-ht (cond.....
12490 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f ((string=?
124a0 20 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 page "*sessionv
124b0 61 72 73 2a 22 29 0a 09 09 09 09 20 20 20 20 20 ars*").....
124c0 20 20 28 76 65 63 74 6f 72 20 28 73 64 61 74 2d (vector (sdat-
124d0 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 get-sessionvars
124e0 73 65 6c 66 29 0a 09 09 09 09 09 20 20 20 20 20 self)......
124f0 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 (sdat-get-sess
12500 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 73 ionvars-before s
12510 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
12520 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 70 61 67 ((string=? pag
12530 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 2a 22 e "*globalvars*"
12540 29 0a 09 09 09 09 09 28 76 65 63 74 6f 72 20 28 )......(vector (
12550 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
12560 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 09 ars self).......
12570 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c (sdat-get-global
12580 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
12590 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 )))..... (
125a0 65 6c 73 65 20 0a 09 09 09 09 09 28 76 65 63 74 else ......(vect
125b0 6f 72 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 or (sdat-get-pag
125c0 65 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 09 evars self).....
125d0 09 09 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ..(sdat-get-page
125e0 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
125f0 29 29 29 29 29 0a 09 09 20 20 20 20 28 6d 61 73 )))))... (mas
12600 74 65 72 2d 68 74 20 20 20 28 76 65 63 74 6f 72 ter-ht (vector
12610 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 66 74 65 -ref before-afte
12620 72 2d 68 74 20 30 29 29 0a 09 09 20 20 20 20 28 r-ht 0))... (
12630 62 65 66 6f 72 65 2d 68 74 20 20 20 28 76 65 63 before-ht (vec
12640 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 tor-ref before-a
12650 66 74 65 72 2d 68 74 20 31 29 29 0a 09 09 20 20 fter-ht 1))...
12660 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 73 20 28 (master-keys (
12670 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
12680 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 09 20 20 master-ht))...
12690 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 73 20 28 (before-keys (
126a0 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
126b0 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 09 20 20 before-ht))...
126c0 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 64 65 6c (all-keys (del
126d0 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
126e0 61 70 70 65 6e 64 20 6d 61 73 74 65 72 2d 6b 65 append master-ke
126f0 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 73 29 29 ys before-keys))
12700 29 29 0a 09 20 20 20 20 20 20 20 28 66 6f 72 2d )).. (for-
12710 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 64 61 20 each ...(lambda
12720 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 74 20 28 (key)... (let (
12730 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 28 68 (master-value (h
12740 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
12750 66 61 75 6c 74 20 6d 61 73 74 65 72 2d 68 74 20 fault master-ht
12760 6b 65 79 20 23 66 29 29 0a 09 09 09 28 62 65 66 key #f))....(bef
12770 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 73 68 2d ore-value (hash-
12780 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
12790 74 20 62 65 66 6f 72 65 2d 68 74 20 6b 65 79 20 t before-ht key
127a0 23 66 29 29 29 0a 09 09 20 20 20 20 28 63 6f 6e #f)))... (con
127b0 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f d... ;; befo
127c0 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 re and after exi
127d0 73 74 20 61 6e 64 20 76 61 6c 75 65 20 75 6e 63 st and value unc
127e0 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e 6f 74 68 hanged - do noth
127f0 69 6e 67 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ing... ((and
12800 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
12810 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 71 75 61 fore-value (equa
12820 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 l? master-value
12830 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 29 29 0a before-value))).
12840 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 .. ;; before
12850 20 61 6e 64 20 61 66 74 65 72 20 65 78 69 73 74 and after exist
12860 20 62 75 74 20 61 72 65 20 63 68 61 6e 67 65 64 but are changed
12870 0a 09 09 20 20 20 20 20 28 28 61 6e 64 20 6d 61 ... ((and ma
12880 73 74 65 72 2d 76 61 6c 75 65 20 62 65 66 6f 72 ster-value befor
12890 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 e-value)...
128a0 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 (dbi:for-each-r
128b0 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ow (lambda (tupl
128c0 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 e)...... (set!
128d0 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b changed-count (+
128e0 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 changed-count 1
128f0 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 )))......conn...
12900 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 75 ...(s:sqlparam u
12910 70 64 2d 71 75 65 72 79 20 6d 61 73 74 65 72 2d pd-query master-
12920 76 61 6c 75 65 20 6b 65 79 20 73 65 73 73 69 6f value key sessio
12930 6e 2d 69 64 20 70 61 67 65 29 29 29 0a 09 09 20 n-id page)))...
12940 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 2d 76 61 ;; master-va
12950 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 20 65 78 lue no longer ex
12960 69 73 74 73 20 28 69 2e 65 2e 20 23 66 29 20 2d ists (i.e. #f) -
12970 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a 09 09 20 remove item...
12980 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 74 65 72 ((not master
12990 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 -value)...
129a0 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f (dbi:for-each-ro
129b0 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 w (lambda (tuple
129c0 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 )...... (set! c
129d0 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 hanged-count (+
129e0 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 changed-count 1)
129f0 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 ))......conn....
12a00 09 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 64 65 ..(s:sqlparam de
12a10 6c 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d l-query session-
12a20 69 64 20 70 61 67 65 20 6b 65 79 29 29 29 0a 09 id page key)))..
12a30 09 20 20 20 20 20 3b 3b 20 62 65 66 6f 72 65 2d . ;; before-
12a40 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 20 65 78 value doesn't ex
12a50 69 73 74 20 2d 20 69 6e 73 65 72 74 20 61 20 6e ist - insert a n
12a60 65 77 20 76 61 6c 75 65 0a 09 09 20 20 20 20 20 ew value...
12a70 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d 76 61 6c ((not before-val
12a80 75 65 29 0a 09 09 20 20 20 20 20 20 28 64 62 69 ue)... (dbi
12a90 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c :for-each-row (l
12aa0 61 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 ambda (tuple)...
12ab0 09 09 09 20 20 28 73 65 74 21 20 63 68 61 6e 67 ... (set! chang
12ac0 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 68 61 6e ed-count (+ chan
12ad0 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 29 0a 09 ged-count 1)))..
12ae0 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 09 28 73 ....conn......(s
12af0 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 2d 71 75 :sqlparam ins-qu
12b00 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 70 ery session-id p
12b10 61 67 65 20 6b 65 79 20 6d 61 73 74 65 72 2d 76 age key master-v
12b20 61 6c 75 65 29 29 29 0a 09 09 20 20 20 20 20 28 alue)))... (
12b30 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 20 22 53 else (err:log "S
12b40 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 houldn't get her
12b50 65 22 29 29 29 29 29 0a 09 09 61 6c 6c 2d 6b 65 e")))))...all-ke
12b60 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 65 73 73 ys))) ;; process
12b70 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 20 28 6c all keys.. (l
12b80 69 73 74 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 ist "*sessionvar
12b90 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 61 72 73 s*" "*globalvars
12ba0 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 29 29 29 *" page-name))))
12bb0 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 6c 2d 6e ))..;; (pg:sql-n
12bc0 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 6c 65 6d ull-object? elem
12bd0 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 28 73 65 ent).(define (se
12be0 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e 66 69 ssion:read-confi
12bf0 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 g self). (let*
12c00 28 28 63 67 69 2d 70 61 74 68 20 28 70 61 74 68 ((cgi-path (path
12c10 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 28 name-directory (
12c20 63 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 car (argv)))).
12c30 20 20 20 20 20 20 20 28 6e 61 6d 65 20 20 20 20 (name
12c40 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
12c50 28 69 66 20 63 67 69 2d 70 61 74 68 20 28 63 6f (if cgi-path (co
12c60 6e 63 20 63 67 69 2d 70 61 74 68 20 22 2f 22 29 nc cgi-path "/")
12c70 20 22 22 29 20 22 2e 22 20 28 70 61 74 68 6e 61 "") "." (pathna
12c80 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 me-file (car (ar
12c90 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 67 22 29 gv))) ".config")
12ca0 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
12cb0 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6e 61 (file-exists? na
12cc0 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 6e 61 6d me))..(print nam
12cd0 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 61 74 e " not found at
12ce0 20 22 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 " (current-dire
12cf0 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 2a 20 28 ctory))..(let* (
12d00 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d (fp (open-input-
12d10 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 20 20 20 file name))..
12d20 20 20 20 20 28 69 6e 69 74 61 72 67 73 20 28 72 (initargs (r
12d30 65 61 64 20 66 70 29 29 29 0a 09 20 20 28 63 6c ead fp))).. (cl
12d40 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 ose-input-port f
12d50 70 29 0a 09 20 20 69 6e 69 74 61 72 67 73 29 29 p).. initargs))
12d60 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 68 65 20 ))..;; call the
12d70 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 20 69 74 controller if it
12d80 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b 3b 20 57 exists.;; .;; W
12d90 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 20 63 6f ARNING - this co
12da0 64 65 20 6e 65 65 64 73 20 61 20 64 65 66 65 6e de needs a defen
12db0 63 65 20 61 67 61 69 6e 73 20 72 65 63 75 72 73 ce agains recurs
12dc0 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 21 21 21 ive calling!!!!!
12dd0 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 67 67 65 .;;.;; I sugge
12de0 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 20 31 30 st a limit of 10
12df0 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 74 79 20 0 calls. Plenty
12e00 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 6d 75 6c for allowing mul
12e10 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 65 73 0a tiple instances.
12e20 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 65 20 69 ;; of a page i
12e30 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 20 70 61 nside another pa
12e40 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 72 74 73 ge. .;;.;; parts
12e50 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 6f 6e 74 = 'both | 'cont
12e60 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b 3b 0a 0a rol | 'view.;;..
12e70 28 64 65 66 69 6e 65 20 28 66 69 6c 65 73 2d 72 (define (files-r
12e80 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e 20 66 69 ead->string . fi
12e90 6c 65 73 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 les). (string-i
12ea0 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 ntersperse . (
12eb0 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 apply append (ma
12ec0 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 p file-read->str
12ed0 69 6e 67 20 66 69 6c 65 73 29 29 20 22 5c 6e 22 ing files)) "\n"
12ee0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c ))..(define (fil
12ef0 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 66 e-read->string f
12f00 29 20 0a 20 20 28 6c 65 74 20 28 28 70 20 28 6f ) . (let ((p (o
12f10 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 pen-input-file f
12f20 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f ))). (let loo
12f30 70 20 28 28 68 65 64 20 28 72 65 61 64 2d 6c 69 p ((hed (read-li
12f40 6e 65 20 70 29 29 0a 09 20 20 20 20 20 20 20 28 ne p)).. (
12f50 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 res '())).
12f60 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
12f70 20 68 65 64 29 0a 09 20 20 72 65 73 0a 09 20 20 hed).. res..
12f80 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
12f90 20 70 29 28 61 70 70 65 6e 64 20 72 65 73 20 28 p)(append res (
12fa0 6c 69 73 74 20 68 65 64 29 29 29 29 29 29 29 0a list hed))))))).
12fb0 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 .(define (proces
12fc0 73 2d 70 6f 72 74 20 70 29 0a 20 20 28 6c 65 74 s-port p). (let
12fd0 20 28 28 65 20 28 69 6e 74 65 72 61 63 74 69 6f ((e (interactio
12fe0 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 29 n-environment)))
12ff0 0a 20 20 20 20 28 6d 61 70 20 0a 20 20 20 20 20 . (map .
13000 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 (lambda (x).
13010 20 20 20 28 63 6f 6e 64 0a 09 28 28 6c 69 73 74 (cond..((list
13020 3f 20 78 29 20 78 29 0a 09 28 28 73 74 72 69 6e ? x) x)..((strin
13030 67 3f 20 78 29 20 78 29 0a 09 28 65 6c 73 65 20 g? x) x)..(else
13040 27 28 29 29 29 29 0a 20 20 20 20 20 28 70 6f 72 '()))). (por
13050 74 2d 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 t-map (lambda (s
13060 29 0a 09 09 20 28 65 76 61 6c 20 73 20 65 29 29 )... (eval s e))
13070 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
13080 20 28 29 28 72 65 61 64 20 70 29 29 29 29 29 29 ()(read p))))))
13090 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
130a0 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 20 on:process-file
130b0 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 20 20 f). (let* ((p
130c0 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 (open-input-fi
130d0 6c 65 20 66 29 29 0a 09 20 28 64 61 74 20 20 28 le f)).. (dat (
130e0 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 29 process-port p))
130f0 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 ). (close-inp
13100 75 74 2d 70 6f 72 74 20 70 29 0a 20 20 20 20 64 ut-port p). d
13110 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 20 32 30 31 at))..;; May 201
13120 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 6c 20 70 1, putting all p
13130 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 20 64 69 ages into one di
13140 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 rectory for the
13150 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 73 6f 6e following reason
13160 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 6e 74 20 s:.;; 1. want
13170 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 65 66 6c filename to refl
13180 65 63 74 20 70 61 67 65 20 6e 61 6d 65 20 28 65 ect page name (e
13190 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 6f 6e 29 macs limitation)
131a0 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 27 73 20 .;; 2. that's
131b0 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 72 65 61 it! no other rea
131c0 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 6b 65 20 son. could make
131d0 69 74 20 63 6f 6e 66 69 67 75 72 61 62 6c 65 20 it configurable
131e0 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d 64 69 72 2d ....;; page-dir-
131f0 73 74 79 6c 65 20 69 73 3a 0a 3b 3b 20 20 27 73 style is:.;; 's
13200 74 6f 72 65 64 20 20 20 3d 3e 20 73 74 6f 72 65 tored => store
13210 64 20 69 6e 20 65 78 65 63 75 74 61 62 6c 65 0a d in executable.
13220 3b 3b 20 20 27 66 6c 61 74 20 20 20 20 20 3d 3e ;; 'flat =>
13230 20 70 61 67 65 73 20 66 6c 61 74 20 64 69 72 65 pages flat dire
13240 63 74 6f 72 79 0a 3b 3b 20 20 27 64 69 72 20 20 ctory.;; 'dir
13250 20 20 20 20 3d 3e 20 64 69 72 65 63 74 6f 72 79 => directory
13260 20 74 72 65 65 20 70 61 67 65 73 2f 3c 70 61 67 tree pages/<pag
13270 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 2c 63 6f 6e ename>/{view,con
13280 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b 20 70 61 72 trol}.scm.;; par
13290 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 68 20 20 20 ts:.;; 'both
132a0 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f => load contro
132b0 6c 20 61 6e 64 20 76 69 65 77 20 28 61 6e 79 74 l and view (anyt
132c0 68 69 6e 67 20 6f 74 68 65 72 20 74 68 61 6e 20 hing other than
132d0 76 69 65 77 20 6f 72 20 63 6f 6e 74 72 6f 6c 20 view or control
132e0 61 6e 64 20 74 68 65 20 64 65 66 61 75 6c 74 29 and the default)
132f0 0a 3b 3b 20 20 27 76 69 65 77 20 20 20 20 20 3d .;; 'view =
13300 3e 20 6c 6f 61 64 20 76 69 65 77 20 6f 6e 6c 79 > load view only
13310 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f 6c 20 20 3d .;; 'control =
13320 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 20 6f > load control o
13330 6e 6c 79 0a 28 64 65 66 69 6e 65 20 28 73 65 73 nly.(define (ses
13340 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 20 sion:call-parts
13350 73 65 6c 66 20 70 61 67 65 20 23 21 6b 65 79 20 self page #!key
13360 28 70 61 72 74 73 20 27 62 6f 74 68 29 29 0a 20 (parts 'both)).
13370 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d (sdat-set-curr-
13380 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 29 page! self page)
13390 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 72 2d 73 . (let* ((dir-s
133a0 74 79 6c 65 20 20 20 20 28 73 64 61 74 2d 67 65 tyle (sdat-ge
133b0 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
133c0 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 75 61 6c self));; (equal
133d0 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ? (sdat-get-page
133e0 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 6c 66 29 -dir-style self)
133f0 20 22 6f 6e 65 64 69 72 22 29 29 20 3b 3b 20 66 "onedir")) ;; f
13400 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e 65 64 69 lag #t for onedi
13410 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 20 73 74 r, #f for old st
13420 79 6c 65 0a 09 20 28 64 69 72 20 20 20 20 20 20 yle.. (dir
13430 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
13440 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f nd (sdat-get-sro
13450 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 09 20 20 ot self) .....
13460 20 20 20 20 28 69 66 20 64 69 72 2d 73 74 79 6c (if dir-styl
13470 65 20 0a 09 09 09 09 09 20 20 28 63 6f 6e 63 20 e ...... (conc
13480 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 09 09 09 "/pages/")......
13490 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 65 73 2f (conc "/pages/
134a0 22 20 70 61 67 65 29 29 29 29 29 0a 20 20 20 20 " page))))).
134b0 28 63 61 73 65 20 64 69 72 2d 73 74 79 6c 65 0a (case dir-style.
134c0 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 74 ;; NB// St
134d0 6f 72 65 64 20 61 6c 77 61 79 73 20 6c 6f 61 64 ored always load
134e0 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f 6c 20 61 s both control a
134f0 6e 64 20 76 69 65 77 0a 20 20 20 20 20 20 28 28 nd view. ((
13500 73 74 6f 72 65 64 29 0a 20 20 20 20 20 20 20 28 stored). (
13510 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
13520 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 ymbol (conc "pag
13530 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 73 es:" page))) ..s
13540 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 20 elf
13550 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
13560 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 73 64 61 he session..(sda
13570 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
13580 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;; the
13590 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 28 db connection..(
135a0 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d sdat-get-shared-
135b0 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b 20 61 hash self) ;; a
135c0 20 73 68 61 72 65 64 20 68 61 73 68 20 74 61 62 shared hash tab
135d0 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 20 64 le for passing d
135e0 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 67 65 ata to/from page
135f0 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 20 20 20 calls..)).
13600 20 28 28 66 6c 61 74 29 20 20 20 0a 20 20 20 20 ((flat) .
13610 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 2d 66 69 (let* ((so-fi
13620 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 20 70 61 le (conc dir pa
13630 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 20 20 20 ge ".so"))..
13640 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 63 6f 6e (scm-file (con
13650 63 20 64 69 72 20 70 61 67 65 20 22 2e 73 63 6d c dir page ".scm
13660 22 29 29 0a 09 20 20 20 20 20 20 28 73 72 63 2d ")).. (src-
13670 66 69 6c 65 20 28 6f 72 20 28 66 69 6c 65 2d 65 file (or (file-e
13680 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c 65 29 0a xists? so-file).
13690 09 09 09 20 20 20 20 28 66 69 6c 65 2d 65 78 69 ... (file-exi
136a0 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 29 29 29 sts? scm-file)))
136b0 29 0a 09 20 28 69 66 20 73 72 63 2d 66 69 6c 65 ).. (if src-file
136c0 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
136d0 20 20 20 20 20 20 28 6c 6f 61 64 20 73 72 63 2d (load src-
136e0 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 28 28 file).. ((
136f0 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
13700 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 61 67 65 mbol (conc "page
13710 73 3a 22 20 70 61 67 65 29 29 29 20 0a 09 09 73 s:" page))) ...s
13720 65 6c 66 20 20 20 20 20 20 20 20 20 20 20 20 20 elf
13730 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
13740 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 28 73 64 he session...(sd
13750 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 at-get-conn self
13760 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 ) ;; the
13770 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 db connection..
13780 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 65 .(sdat-get-share
13790 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b 3b d-hash self) ;;
137a0 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 74 a shared hash t
137b0 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e 67 able for passing
137c0 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 61 data to/from pa
137d0 67 65 20 63 61 6c 6c 73 0a 09 09 29 29 0a 09 20 ge calls...))..
137e0 20 20 20 20 28 6c 69 73 74 20 22 3c 70 3e 50 61 (list "<p>Pa
137f0 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 ge not found " p
13800 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 29 29 0a age " </p>")))).
13810 20 20 20 20 20 20 20 3b 3b 20 66 69 72 73 74 20 ;; first
13820 74 68 65 20 63 6f 6e 74 72 6f 6c 0a 20 20 20 20 the control.
13830 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 63 6f 6e ;; (let ((con
13840 74 72 6f 6c 2d 66 69 6c 65 20 28 63 6f 6e 63 20 trol-file (conc
13850 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 22 5f "pages/" page "_
13860 63 74 72 6c 2e 73 63 6d 22 29 29 0a 20 20 20 20 ctrl.scm")).
13870 20 20 20 3b 3b 20 20 20 20 20 20 20 28 76 69 65 ;; (vie
13880 77 2d 66 69 6c 65 20 20 20 20 28 63 6f 6e 63 20 w-file (conc
13890 22 70 61 67 65 73 2f 22 20 70 61 67 65 20 22 5f "pages/" page "_
138a0 76 69 65 77 2e 73 63 6d 22 29 29 29 0a 20 20 20 view.scm"))).
138b0 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 61 6e ;; (if (an
138c0 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
138d0 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 0a 20 20 control-file).
138e0 20 20 20 20 20 3b 3b 20 20 09 20 20 28 6e 6f 74 ;; . (not
138f0 20 28 65 71 3f 20 70 61 72 74 73 20 27 76 69 65 (eq? parts 'vie
13900 77 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 w))). ;;
13910 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
13920 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 73 ;; (s
13930 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 6c 6c 65 ession:set-calle
13940 64 21 20 73 65 6c 66 20 70 61 67 65 29 0a 20 20 d! self page).
13950 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
13960 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c 2d 66 69 (load control-fi
13970 6c 65 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 le))). ;;
13980 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
13990 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 29 0a 20 ts? view-file).
139a0 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
139b0 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 72 if (not (eq? par
139c0 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 20 20 ts 'control)).
139d0 20 20 20 20 20 3b 3b 20 20 09 20 28 73 65 73 73 ;; . (sess
139e0 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 6c 65 ion:process-file
139f0 20 76 69 65 77 2d 66 69 6c 65 29 29 0a 20 20 20 view-file)).
13a00 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 6c 69 ;; (li
13a10 73 74 20 22 3c 70 3e 50 61 67 65 20 6e 6f 74 20 st "<p>Page not
13a20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 22 20 3c found " page " <
13a30 2f 70 3e 22 29 29 29 0a 20 20 20 20 20 20 28 28 /p>"))). ((
13a40 64 69 72 29 20 22 45 52 52 4f 52 3a 20 20 64 69 dir) "ERROR: di
13a50 72 20 73 74 79 6c 65 20 6e 6f 74 20 79 65 74 20 r style not yet
13a60 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 65 64 22 29 re-implemented")
13a70 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 . (else.
13a80 20 20 20 20 28 6c 69 73 74 20 22 45 52 52 4f 52 (list "ERROR
13a90 3a 20 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 : page-dir-style
13aa0 20 6d 75 73 74 20 62 65 20 73 74 6f 72 65 64 2c must be stored,
13ab0 20 64 69 72 20 6f 72 20 66 6c 61 74 2c 20 67 6f dir or flat, go
13ac0 74 20 22 20 64 69 72 2d 73 74 79 6c 65 29 29 29 t " dir-style)))
13ad0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
13ae0 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c 66 20 70 sion:call self p
13af0 61 67 65 20 70 61 72 74 73 29 0a 20 20 28 73 65 age parts). (se
13b00 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 73 ssion:call-parts
13b10 20 73 65 6c 66 20 70 61 67 65 20 27 62 6f 74 68 self page 'both
13b20 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
13b30 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f 64 session:load-mod
13b40 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b el self model).;
13b50 3b 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 65 6c ; (let ((model
13b60 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d 61 70 70 .scm (string-app
13b70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 end (sdat-get-sr
13b80 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 oot self) "/mode
13b90 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d ls/" model ".scm
13ba0 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 65 6c 2e 73 ")).;; .(model.s
13bb0 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e o (string-appen
13bc0 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
13bd0 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
13be0 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f 22 29 29 /" model ".so"))
13bf0 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 66 69 ).;; (if (fi
13c00 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f 64 65 6c le-exists? model
13c10 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 64 20 6d .so).;; .(load m
13c20 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 69 66 odel.so).;; .(if
13c30 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d (file-exists? m
13c40 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 odel.scm).;; .
13c50 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c 2e 73 63 (load model.sc
13c60 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 3a 6c 6f m).;; . (s:lo
13c70 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 65 6c 20 g "ERROR: model
13c80 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 20 6e 6f " model.scm " no
13c90 74 20 66 6f 75 6e 64 22 29 29 29 29 29 0a 0a 3b t found")))))..;
13ca0 3b 20 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ; (define (sessi
13cb0 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 20 73 65 on:model-path se
13cc0 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 20 20 28 lf model).;; (
13cd0 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
13ce0 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 73 65 dat-get-sroot se
13cf0 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f 22 20 6d lf) "/models/" m
13d00 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 0a 0a 28 odel ".scm"))..(
13d10 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
13d20 70 70 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 pp-formdat self)
13d30 0a 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 66 . (let ((dat (f
13d40 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 ormdat:all->stri
13d50 6e 67 73 20 28 73 64 61 74 2d 67 65 74 2d 66 6f ngs (sdat-get-fo
13d60 72 6d 64 61 74 20 73 65 6c 66 29 29 29 29 0a 20 rmdat self)))).
13d70 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
13d80 73 70 65 72 73 65 20 64 61 74 20 22 3c 62 72 3e sperse dat "<br>
13d90 20 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ")))..(define (
13da0 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 session:param->s
13db0 74 72 69 6e 67 20 70 61 72 61 6d 73 29 0a 20 20 tring params).
13dc0 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 70 61 72 ;; (err:log "par
13dd0 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 ams=" params).
13de0 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 70 (if (< (length p
13df0 61 72 61 6d 73 29 20 31 29 0a 20 20 20 20 20 20 arams) 1).
13e00 22 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f "". (let lo
13e10 6f 70 20 28 28 6b 65 79 20 28 63 61 72 20 70 61 op ((key (car pa
13e20 72 61 6d 73 29 29 0a 09 09 20 28 76 61 6c 20 28 rams))... (val (
13e30 63 61 64 72 20 70 61 72 61 6d 73 29 29 0a 09 09 cadr params))...
13e40 20 28 74 61 69 6c 20 28 63 64 64 72 20 70 61 72 (tail (cddr par
13e50 61 6d 73 29 29 0a 09 09 20 28 72 65 73 75 6c 74 ams))... (result
13e60 20 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e '()))..(let ((n
13e70 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 73 20 28 ewresult (cons (
13e80 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 73 string-append (s
13e90 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 :any->string key
13ea0 29 20 22 3d 22 20 28 73 3a 61 6e 79 2d 3e 73 74 ) "=" (s:any->st
13eb0 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 ring val))....
13ec0 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a 09 result)))..
13ed0 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
13ee0 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 74 72 75 tail) 1) ;; tru
13ef0 65 20 69 66 20 64 6f 6e 65 0a 09 20 20 20 20 20 e if done..
13f00 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
13f10 65 72 73 65 20 6e 65 77 72 65 73 75 6c 74 20 22 erse newresult "
13f20 26 22 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 &").. (loop
13f30 20 28 63 61 72 20 74 61 69 6c 29 28 63 61 64 72 (car tail)(cadr
13f40 20 74 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c tail)(cddr tail
13f50 29 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 29 ) newresult)))))
13f60 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
13f70 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 65 6c 66 ion:link-to self
13f80 20 70 61 67 65 20 70 61 72 61 6d 73 29 0a 20 20 page params).
13f90 28 6c 65 74 2a 20 28 28 68 74 74 70 73 2d 68 6f (let* ((https-ho
13fa0 73 74 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f st (get-enviro
13fb0 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
13fc0 48 54 54 50 53 5f 48 4f 53 54 22 29 29 0a 20 20 HTTPS_HOST")).
13fd0 20 20 20 20 20 20 20 28 66 6f 72 63 65 2d 73 73 (force-ss
13fe0 6c 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 66 l (sdat-get-f
13ff0 6f 72 63 65 2d 73 73 6c 20 73 65 6c 66 29 29 0a orce-ssl self)).
14000 09 20 28 73 65 72 76 65 72 20 20 20 20 20 20 20 . (server
14010 28 6f 72 20 68 74 74 70 73 2d 68 6f 73 74 20 3b (or https-host ;
14020 3b 20 41 73 73 75 6d 69 6e 67 20 48 54 54 50 53 ; Assuming HTTPS
14030 5f 48 4f 53 54 20 69 73 20 6f 6e 6c 79 20 73 65 _HOST is only se
14040 74 20 69 66 20 61 76 61 69 6c 61 62 6c 65 0a 09 t if available..
14050 09 09 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f .. (get-enviro
14060 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
14070 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 09 09 20 HTTP_HOST")....
14080 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
14090 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 45 52 nt-variable "SER
140a0 56 45 52 5f 4e 41 4d 45 22 29 0a 09 09 09 20 20 VER_NAME")....
140b0 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 69 (sdat-get-domai
140c0 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 20 20 20 n self))).
140d0 20 20 20 28 66 6f 72 63 65 2d 73 63 72 69 70 74 (force-script
140e0 20 20 28 73 64 61 74 2d 67 65 74 2d 73 63 72 69 (sdat-get-scri
140f0 70 74 20 73 65 6c 66 29 29 0a 09 20 28 73 63 72 pt self)).. (scr
14100 69 70 74 20 20 20 20 20 20 20 20 28 6f 72 20 66 ipt (or f
14110 6f 72 63 65 2d 73 63 72 69 70 74 0a 09 09 09 20 orce-script....
14120 20 20 20 28 6c 65 74 20 28 28 73 63 72 69 70 74 (let ((script
14130 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 2d 73 70 -name (string-sp
14140 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e lit (get-environ
14150 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 ment-variable "S
14160 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 22 2f 22 CRIPT_NAME") "/"
14170 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 ))).... (if
14180 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 63 72 69 (> (length scri
14190 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 09 09 09 pt-name) 1).....
141a0 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
141b0 20 28 63 61 72 20 73 63 72 69 70 74 2d 6e 61 6d (car script-nam
141c0 65 29 20 22 2f 22 20 28 63 61 64 72 20 73 63 72 e) "/" (cadr scr
141d0 69 70 74 2d 6e 61 6d 65 29 29 0a 09 09 09 09 20 ipt-name)).....
141e0 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
141f0 74 2d 76 61 72 69 61 62 6c 65 20 22 53 43 52 49 t-variable "SCRI
14200 50 54 5f 4e 41 4d 45 22 29 29 29 29 29 20 3b 3b PT_NAME"))))) ;;
14210 20 62 75 69 6c 64 20 73 63 72 69 70 74 20 6e 61 build script na
14220 6d 65 20 66 72 6f 6d 20 66 69 72 73 74 20 74 77 me from first tw
14230 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 54 68 69 73 o elements. This
14240 20 69 73 20 61 20 68 61 6e 67 6f 76 65 72 20 66 is a hangover f
14250 72 6f 6d 20 62 65 66 6f 72 65 20 49 20 75 73 65 rom before I use
14260 64 20 3f 20 69 6e 20 74 68 65 20 55 52 4c 2e 29 d ? in the URL.)
14270 0a 20 20 20 20 20 20 20 20 20 28 73 65 73 73 69 . (sessi
14280 6f 6e 2d 6b 65 79 20 20 20 28 73 64 61 74 2d 67 on-key (sdat-g
14290 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 et-session-key s
142a0 65 6c 66 29 29 0a 09 20 28 70 61 72 61 6d 73 74 elf)).. (paramst
142b0 72 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a r (session:
142c0 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 61 param->string pa
142d0 72 61 6d 73 29 29 29 0a 20 20 20 20 28 73 65 73 rams))). (ses
142e0 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 73 sion:log self "s
142f0 65 72 76 65 72 3d 22 20 73 65 72 76 65 72 20 22 erver=" server "
14300 20 73 63 72 69 70 74 3d 22 20 73 63 72 69 70 74 script=" script
14310 20 22 20 70 61 67 65 3d 22 20 70 61 67 65 29 0a " page=" page).
14320 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
14330 6e 64 20 28 69 66 20 28 6f 72 20 68 74 74 70 73 nd (if (or https
14340 2d 68 6f 73 74 20 66 6f 72 63 65 2d 73 73 6c 29 -host force-ssl)
14350 0a 09 09 20 20 20 20 20 20 22 68 74 74 70 73 3a ... "https:
14360 2f 2f 22 0a 09 09 20 20 20 20 20 20 22 68 74 74 //"... "htt
14370 70 3a 2f 2f 22 29 0a 09 09 20 20 20 73 65 72 76 p://")... serv
14380 65 72 20 22 2f 22 20 73 63 72 69 70 74 20 22 2f er "/" script "/
14390 22 20 70 61 67 65 20 22 3f 22 20 70 61 72 61 6d " page "?" param
143a0 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 6e 3d 22 str))) ;; "/sn="
143b0 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 0a session-key))).
143c0 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
143d0 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c 66 29 0a n:cgi-out self).
143e0 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 74 65 6e (let* ((conten
143f0 74 20 20 28 6c 69 73 74 20 28 73 64 61 74 2d 67 t (list (sdat-g
14400 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 et-content-type
14410 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 22 43 6f self))) ;; '("Co
14420 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 ntent-type: text
14430 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 /html; charset=i
14440 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 29 so-8859-1\n\n"))
14450 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 6c 65 .. (header (le
14460 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 64 61 74 t ((cookie (sdat
14470 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f -get-session-coo
14480 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 09 20 20 kie self)))...
14490 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 0a 09 09 (if cookie...
144a0 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d . (cons (string-
144b0 61 70 70 65 6e 64 20 22 53 65 74 2d 43 6f 6f 6b append "Set-Cook
144c0 69 65 3a 20 22 20 28 63 61 72 20 63 6f 6f 6b 69 ie: " (car cooki
144d0 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 63 6f e)).... co
144e0 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f 6e 74 65 ntent).... conte
144f0 6e 74 29 29 29 0a 09 20 28 70 61 67 65 64 61 74 nt))).. (pagedat
14500 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
14510 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
14520 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 20 20 20 (s:cgi-out .
14530 20 28 63 6f 6e 73 20 68 65 61 64 65 72 20 70 61 (cons header pa
14540 67 65 64 61 74 29 29 29 29 0a 0a 28 64 65 66 69 gedat))))..(defi
14550 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ne (session:log
14560 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 20 28 77 self . msg). (w
14570 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
14580 72 74 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 rt (sdat-get-log
14590 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b 3b 20 28 -port self) ;; (
145a0 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 sdat-get-logpt s
145b0 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 elf). (lambda
145c0 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c () . (appl
145d0 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a y print msg)))).
145e0 0a 3b 3b 20 65 73 63 61 70 65 2c 20 63 6f 6e 76 .;; escape, conv
145f0 65 72 74 20 6f 72 20 72 65 74 75 72 6e 20 72 61 ert or return ra
14600 77 20 77 68 65 6e 20 67 69 76 65 6e 20 75 73 65 w when given use
14610 72 20 69 6e 70 75 74 20 64 61 74 61 20 74 68 61 r input data tha
14620 74 20 70 6f 74 65 6e 74 69 61 6c 6c 79 0a 3b 3b t potentially.;;
14630 20 63 6f 75 6c 64 20 62 65 20 6d 61 6c 69 63 69 could be malici
14640 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ous.;;.(define (
14650 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 2d 74 79 session:apply-ty
14660 70 65 2d 70 72 65 66 65 72 65 6e 63 65 20 72 65 pe-preference re
14670 73 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 s params). (let
14680 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 66 * ((dtype (if
14690 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a (null? params).
146a0 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 65 .. 'escape
146b0 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 20 d... (car
146c0 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 params))).. (tag
146d0 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s (if (null?
146e0 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 params)...
146f0 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 '()... (cdr
14700 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 params)))).
14710 28 63 61 73 65 20 64 74 79 70 65 0a 20 20 20 20 (case dtype.
14720 20 20 28 28 72 61 77 29 20 20 20 20 20 72 65 73 ((raw) res
14730 29 0a 20 20 20 20 20 20 28 28 6e 75 6d 62 65 72 ). ((number
14740 29 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 ) (if (string?
14750 72 65 73 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d res)(string->num
14760 62 65 72 20 72 65 73 29 20 23 66 29 29 0a 20 20 ber res) #f)).
14770 20 20 20 20 28 28 65 73 63 61 70 65 64 29 20 28 ((escaped) (
14780 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 if (string? res)
14790 0a 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d ... (s:html-
147a0 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 filter->string r
147b0 65 73 20 74 61 67 73 29 0a 09 09 20 20 20 20 20 es tags)...
147c0 72 65 73 29 29 0a 20 20 20 20 20 20 28 28 65 73 res)). ((es
147d0 63 61 70 65 64 2d 6e 6c 29 20 28 69 66 20 28 73 caped-nl) (if (s
147e0 74 72 69 6e 67 3f 20 72 65 73 29 20 3b 3b 20 65 tring? res) ;; e
147f0 73 63 61 70 65 20 5c 6e 20 61 6e 64 20 5c 72 0a scape \n and \r.
14800 09 09 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ...(string-inter
14810 73 70 65 72 73 65 0a 09 09 09 20 28 73 74 72 69 sperse.... (stri
14820 6e 67 2d 73 70 6c 69 74 0a 09 09 09 20 20 28 73 ng-split.... (s
14830 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
14840 65 0a 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d e.... (string-
14850 73 70 6c 69 74 20 28 73 3a 68 74 6d 6c 2d 66 69 split (s:html-fi
14860 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 lter->string res
14870 20 74 61 67 73 29 20 22 5c 6e 22 29 0a 09 09 09 tags) "\n")....
14880 20 20 20 22 5c 5c 6e 22 29 0a 09 09 09 20 20 22 "\\n").... "
14890 5c 72 22 29 0a 09 09 09 20 22 5c 5c 72 22 29 0a \r").... "\\r").
148a0 09 09 09 72 65 73 29 29 20 3b 3b 20 73 68 6f 75 ...res)) ;; shou
148b0 6c 64 20 72 65 74 75 72 6e 20 23 66 20 69 66 20 ld return #f if
148c0 6e 6f 74 20 61 20 73 74 72 69 6e 67 20 61 6e 64 not a string and
148d0 20 63 61 6e 27 74 20 65 73 63 61 70 65 20 69 74 can't escape it
148e0 3f 0a 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 ?. (else
148f0 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (if (string?
14900 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 res)... (s:h
14910 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 tml-filter->stri
14920 6e 67 20 72 65 73 20 27 28 29 29 0a 09 09 20 20 ng res '())...
14930 20 20 20 72 65 73 29 29 29 29 29 0a 0a 23 3b 28 res)))))..#;(
14940 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
14950 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 get-param-from p
14960 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 arams key). (le
14970 74 20 28 28 72 31 20 28 72 65 67 65 78 70 20 28 t ((r1 (regexp (
14980 63 6f 6e 63 20 22 5e 22 20 28 73 3a 61 6e 79 2d conc "^" (s:any-
14990 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 28 >string key) "=(
149a0 2e 2a 29 24 22 29 29 29 29 0a 20 20 20 20 28 69 .*)$")))). (i
149b0 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
149c0 20 23 66 0a 20 20 20 20 20 20 20 20 28 6c 65 74 #f. (let
149d0 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 63 61 loop ((head (ca
149e0 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 r params)).
149f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
14a00 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 29 ail (cdr params)
14a10 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 )). (le
14a20 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
14a30 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 g-match r1 head)
14a40 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
14a50 69 66 20 6d 61 74 63 68 0a 20 20 20 20 20 20 20 if match.
14a60 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
14a70 65 66 20 6d 61 74 63 68 20 31 29 0a 20 20 20 20 ef match 1).
14a80 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
14a90 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 23 66 0a (null? tail) #f.
14aa0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14ab0 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
14ac0 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 29 29 ail)(cdr tail)))
14ad0 29 29 29 29 29 29 0a 0a 3b 3b 20 70 61 72 61 6d ))))))..;; param
14ae0 73 20 61 72 65 20 73 74 6f 72 65 64 20 61 73 20 s are stored as
14af0 6c 69 73 74 20 6f 66 20 6b 65 79 3d 76 61 6c 0a list of key=val.
14b00 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
14b10 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 65 ion:get-param se
14b20 6c 66 20 6b 65 79 20 74 79 70 65 2d 70 61 72 61 lf key type-para
14b30 6d 73 29 0a 20 20 3b 3b 20 28 73 65 73 73 69 6f ms). ;; (sessio
14b40 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f 6e 20 n:log s:session
14b50 22 70 61 72 61 6d 73 3d 22 20 28 73 6c 6f 74 2d "params=" (slot-
14b60 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 27 70 ref s:session 'p
14b70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 74 2a 20 arams)). (let*
14b80 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d 67 ((params (sdat-g
14b90 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 29 et-params self))
14ba0 0a 09 20 28 72 65 73 20 20 20 20 28 73 65 73 73 .. (res (sess
14bb0 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 ion:get-param-fr
14bc0 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 29 29 om params key)))
14bd0 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 . (session:ap
14be0 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 ply-type-prefere
14bf0 6e 63 65 20 72 65 73 20 74 79 70 65 2d 70 61 72 nce res type-par
14c00 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 ams)))..;; This
14c10 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 65 one will get the
14c20 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f 75 first value fou
14c30 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f 66 nd regardless of
14c40 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 61 6d 3a 20 form.;; param:
14c50 28 64 74 79 70 65 20 5b 74 61 67 31 20 74 61 67 (dtype [tag1 tag
14c60 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 79 70 65 2 ...]).;; dtype
14c70 3a 0a 3b 3b 20 20 20 20 27 72 61 77 20 20 20 20 :.;; 'raw
14c80 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e 76 65 72 73 : do no convers
14c90 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e 75 6d 62 65 ion.;; 'numbe
14ca0 72 20 20 3a 20 63 6f 6e 76 65 72 74 20 74 6f 20 r : convert to
14cb0 6e 75 6d 62 65 72 2c 20 72 65 74 75 72 6e 20 23 number, return #
14cc0 66 20 69 66 20 66 61 69 6c 73 0a 3b 3b 20 20 20 f if fails.;;
14cd0 20 27 65 73 63 61 70 65 64 20 3a 20 75 73 65 20 'escaped : use
14ce0 68 74 6d 6c 2d 65 73 63 61 70 65 20 74 6f 20 70 html-escape to p
14cf0 72 6f 74 65 63 74 20 74 68 65 20 69 6e 70 75 74 rotect the input
14d00 20 2d 2d 20 74 68 69 73 20 69 73 20 74 68 65 20 -- this is the
14d10 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 default.;;.(defi
14d20 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d ne (session:get-
14d30 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 79 20 70 input self key p
14d40 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
14d50 28 64 74 79 70 65 20 20 20 20 28 69 66 20 28 6e (dtype (if (n
14d60 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 ull? params)...
14d70 20 20 20 20 20 20 27 65 73 63 61 70 65 64 0a 09 'escaped..
14d80 09 20 20 20 20 20 20 20 28 63 61 72 20 70 61 72 . (car par
14d90 61 6d 73 29 29 29 0a 09 20 28 74 61 67 73 20 20 ams))).. (tags
14da0 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 (if (null? par
14db0 61 6d 73 29 0a 09 09 20 20 20 20 20 20 27 28 29 ams)... '()
14dc0 0a 09 09 20 20 20 20 20 20 28 63 64 72 20 70 61 ... (cdr pa
14dd0 72 61 6d 73 29 29 29 0a 09 20 28 66 6f 72 6d 64 rams))).. (formd
14de0 61 74 20 28 73 64 61 74 2d 67 65 74 2d 66 6f 72 at (sdat-get-for
14df0 6d 64 61 74 20 73 65 6c 66 29 29 0a 09 20 28 72 mdat self)).. (r
14e00 65 73 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 es (if (not
14e10 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 09 20 20 formdat) #f...
14e20 20 20 20 20 28 69 66 20 28 6f 72 20 28 73 74 72 (if (or (str
14e30 69 6e 67 3f 20 6b 65 79 29 28 6e 75 6d 62 65 72 ing? key)(number
14e40 3f 20 6b 65 79 29 28 73 79 6d 62 6f 6c 3f 20 6b ? key)(symbol? k
14e50 65 79 29 29 0a 09 09 09 20 20 28 69 66 20 28 61 ey)).... (if (a
14e60 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 6f 72 6d nd (vector? form
14e70 64 61 74 29 28 65 71 3f 20 28 76 65 63 74 6f 72 dat)(eq? (vector
14e80 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 61 74 29 -length formdat)
14e90 20 31 29 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 1)(hash-table?
14ea0 28 76 65 63 74 6f 72 2d 72 65 66 20 66 6f 72 6d (vector-ref form
14eb0 64 61 74 20 30 29 29 29 0a 09 09 09 20 20 20 20 dat 0)))....
14ec0 20 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 66 (formdat:get f
14ed0 6f 72 6d 64 61 74 20 6b 65 79 29 0a 09 09 09 20 ormdat key)....
14ee0 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
14ef0 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
14f00 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 f "ERROR: formda
14f10 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 t: " formdat " i
14f20 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c s not of class <
14f30 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 09 09 23 formdat>").....#
14f40 66 29 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a f)).... (begin.
14f50 09 09 09 20 20 20 20 28 73 65 73 73 69 6f 6e 3a ... (session:
14f60 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 4f 52 3a log self "ERROR:
14f70 20 62 61 64 20 6b 65 79 20 22 20 6b 65 79 29 0a bad key " key).
14f80 09 09 09 20 20 20 20 23 66 29 29 29 29 29 0a 20 ... #f))))).
14f90 20 20 20 28 63 61 73 65 20 64 74 79 70 65 0a 20 (case dtype.
14fa0 20 20 20 20 20 28 28 72 61 77 29 20 20 20 20 20 ((raw)
14fb0 72 65 73 29 0a 20 20 20 20 20 20 28 28 6e 75 6d res). ((num
14fc0 62 65 72 29 20 20 28 69 66 20 28 73 74 72 69 6e ber) (if (strin
14fd0 67 3f 20 72 65 73 29 28 73 74 72 69 6e 67 2d 3e g? res)(string->
14fe0 6e 75 6d 62 65 72 20 72 65 73 29 20 23 66 29 29 number res) #f))
14ff0 0a 20 20 20 20 20 20 28 28 65 73 63 61 70 65 64 . ((escaped
15000 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 ) (if (string? r
15010 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 74 es)... (s:ht
15020 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e ml-filter->strin
15030 67 20 72 65 73 20 74 61 67 73 29 0a 09 09 20 20 g res tags)...
15040 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 28 res)). (
15050 65 6c 73 65 20 20 20 20 20 20 28 69 66 20 28 73 else (if (s
15060 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 tring? res)...
15070 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 (s:html-filte
15080 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 20 27 28 r->string res '(
15090 29 29 0a 09 09 20 20 20 20 20 72 65 73 29 29 29 ))... res)))
150a0 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 ))..;; This one
150b0 77 69 6c 6c 20 67 65 74 20 74 68 65 20 66 69 72 will get the fir
150c0 73 74 20 76 61 6c 75 65 20 66 6f 75 6e 64 20 72 st value found r
150d0 65 67 61 72 64 6c 65 73 73 20 6f 66 20 66 6f 72 egardless of for
150e0 6d 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 m.(define (sessi
150f0 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 2d 6b 65 79 on:get-input-key
15100 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 2a 20 s self). (let*
15110 28 28 66 6f 72 6d 64 61 74 20 28 73 64 61 74 2d ((formdat (sdat-
15120 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 get-formdat self
15130 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
15140 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 28 69 formdat) #f..(i
15150 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
15160 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 formdat)(eq? (ve
15170 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d ctor-length form
15180 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 dat) 1)(hash-tab
15190 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 le? (vector-ref
151a0 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 20 20 formdat 0)))..
151b0 20 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 (formdat:keys
151c0 66 6f 72 6d 64 61 74 29 0a 09 20 20 20 20 28 62 formdat).. (b
151d0 65 67 69 6e 0a 09 20 20 20 20 20 20 28 73 65 73 egin.. (ses
151e0 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 sion:log self "E
151f0 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 3a 20 22 RROR: formdat: "
15200 20 66 6f 72 6d 64 61 74 20 22 20 69 73 20 6e 6f formdat " is no
15210 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 6f 72 6d t of class <form
15220 64 61 74 3e 22 29 0a 09 20 20 20 20 20 20 23 66 dat>").. #f
15230 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
15240 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 session:run-acti
15250 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 ons self). (let
15260 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 20 28 73 * ((action (s
15270 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d ession:get-param
15280 20 73 65 6c 66 20 27 61 63 74 69 6f 6e 20 27 28 self 'action '(
15290 72 61 77 29 29 29 0a 09 20 28 70 61 67 65 20 20 raw))).. (page
152a0 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 (sdat-get-pa
152b0 67 65 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b ge self))). ;
152c0 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e ; (print "action
152d0 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 61 67 65 =" action " page
152e0 3d 22 20 70 61 67 65 29 0a 20 20 20 20 28 69 66 =" page). (if
152f0 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 20 28 28 action..(let ((
15300 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 73 74 72 action-lst (str
15310 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 69 6f 6e ing-split action
15320 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b 20 28 70 "."))).. ;; (p
15330 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d 6c 73 74 rint "action-lst
15340 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 29 0a 09 =" action-lst)..
15350 20 20 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 6c (if (not (= (l
15360 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d 6c 73 74 ength action-lst
15370 29 20 32 29 29 20 0a 09 20 20 20 20 20 20 28 65 ) 2)) .. (e
15380 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 73 rr:log "Action s
15390 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 6f 72 6d hould be of form
153a0 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 6f 6e 22 : module.action"
153b0 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ).. (let* (
153c0 28 74 61 72 67 2d 70 61 67 65 20 20 20 28 63 61 (targ-page (ca
153d0 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 0a 09 r action-lst))..
153e0 09 20 20 20 20 20 28 70 72 6f 63 2d 6e 61 6d 65 . (proc-name
153f0 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
15400 64 20 74 61 72 67 2d 70 61 67 65 20 22 2d 61 63 d targ-page "-ac
15410 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 20 20 28 tion"))... (
15420 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 63 61 64 targ-action (cad
15430 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 29 29 0a r action-lst))).
15440 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 74 ..;; (err:log "t
15450 61 72 67 2d 70 61 67 65 3d 22 20 74 61 72 67 2d arg-page=" targ-
15460 70 61 67 65 20 22 20 70 72 6f 63 2d 6e 61 6d 65 page " proc-name
15470 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 74 =" proc-name " t
15480 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 74 61 72 arg-action=" tar
15490 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 3b 3b 20 g-action)....;;
154a0 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c 79 20 69 call here only i
154b0 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 64 20 62 f never called b
154c0 65 66 6f 72 65 0a 09 09 28 69 66 20 28 73 65 73 efore...(if (ses
154d0 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 sion:never-calle
154e0 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 74 61 72 d-page? self tar
154f0 67 2d 70 61 67 65 29 0a 09 09 20 20 20 20 28 73 g-page)... (s
15500 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 74 ession:call-part
15510 73 20 73 65 6c 66 20 74 61 72 67 2d 70 61 67 65 s self targ-page
15520 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 09 3b 3b 'control))...;;
15530 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15540 20 20 20 20 70 72 6f 63 20 20 20 20 20 20 20 20 proc
15550 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15560 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a 09 09 28 action ....(
15570 69 66 20 23 74 20 3b 3b 20 73 65 74 20 74 6f 20 if #t ;; set to
15580 23 74 20 74 6f 20 73 65 65 20 62 65 74 74 65 72 #t to see better
15590 20 65 72 72 6f 72 20 6d 65 73 73 61 67 65 73 20 error messages
155a0 64 75 72 69 6e 67 20 64 65 62 75 67 67 69 6e 20 during debuggin
155b0 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 76 61 6c :-)... ((eval
155c0 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
155d0 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 proc-name)) tar
155e0 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 75 6e 73 g-action) ;; uns
155f0 61 66 65 20 65 78 65 63 75 74 69 6f 6e 0a 09 09 afe execution...
15600 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 (condition-c
15610 61 73 65 20 28 28 65 76 61 6c 20 28 73 74 72 69 ase ((eval (stri
15620 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 2d ng->symbol proc-
15630 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 63 74 69 name)) targ-acti
15640 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 on)..... ((ex
15650 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f 67 20 22 n file) (s:log "
15660 66 69 6c 65 20 65 72 72 6f 72 22 29 29 0a 09 09 file error"))...
15670 09 09 20 20 20 20 28 28 65 78 6e 20 69 2f 6f 29 .. ((exn i/o)
15680 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f 20 65 72 (s:log "i/o er
15690 72 6f 72 22 29 29 0a 09 09 09 09 20 20 20 20 28 ror"))..... (
156a0 28 65 78 6e 20 29 20 20 20 20 20 28 73 3a 6c 6f (exn ) (s:lo
156b0 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 20 69 6d g "Action not im
156c0 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 70 72 6f plemented: " pro
156d0 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 6f 6e 3a c-name " action:
156e0 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 29 " targ-action))
156f0 0a 09 09 09 09 20 20 20 20 28 76 61 72 20 28 29 ..... (var ()
15700 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 55 6e 6b (s:log "Unk
15710 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 29 29 29 nown Error")))))
15720 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
15730 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 session:never-ca
15740 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 lled-page? self
15750 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f 6e page). (session
15760 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 65 63 6b :log self "Check
15770 69 6e 67 20 66 6f 72 20 70 61 67 65 3a 20 22 20 ing for page: "
15780 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 28 6d 65 page). (not (me
15790 6d 62 65 72 20 70 61 67 65 20 28 73 64 61 74 2d mber page (sdat-
157a0 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 get-seen-pages s
157b0 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 elf))))..(define
157c0 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 (session:set-ca
157d0 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 lled! self page)
157e0 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 . (sdat-set-see
157f0 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 28 63 n-pages! self (c
15800 6f 6e 73 20 70 61 67 65 20 28 73 64 61 74 2d 67 ons page (sdat-g
15810 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 20 73 65 et-seen-pages se
15820 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d lf))))..;;======
15830 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15840 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15850 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15870 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 20 .;; Alternative
15880 64 61 74 61 20 74 79 70 65 20 64 65 6c 69 76 65 data type delive
15890 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ry.;;===========
158a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
158e0 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 6c fine (session:al
158f0 74 2d 6f 75 74 20 73 65 6c 66 29 0a 20 20 28 6c t-out self). (l
15900 65 74 20 28 28 64 61 74 20 28 73 64 61 74 2d 67 et ((dat (sdat-g
15910 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 20 et-alt-page-dat
15920 73 65 6c 66 29 29 29 0a 20 20 20 20 3b 3b 20 28 self))). ;; (
15930 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 3a 20 22 s:log "dat is: "
15940 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 28 70 72 dat). ;; (pr
15950 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 20 32 30 int "HTTP/1.1 20
15960 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 72 69 6e 0 OK"). (prin
15970 74 20 22 44 61 74 65 3a 20 22 20 28 74 69 6d 65 t "Date: " (time
15980 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 ->string (second
15990 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 63 75 72 s->utc-time (cur
159a0 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 rent-seconds))))
159b0 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e . (print "Con
159c0 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 28 73 64 tent-Type: " (sd
159d0 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 at-get-content-t
159e0 79 70 65 20 73 65 6c 66 29 29 0a 20 20 20 20 28 ype self)). (
159f0 70 72 69 6e 74 20 22 41 63 63 65 70 74 2d 52 61 print "Accept-Ra
15a00 6e 67 65 73 3a 20 62 79 74 65 73 22 29 0a 20 20 nges: bytes").
15a10 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e (print "Conten
15a20 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 69 66 20 t-Length: " (if
15a30 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 09 09 09 (blob? dat).....
15a40 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 64 61 74 (blob-size dat
15a50 29 0a 09 09 09 09 20 20 30 29 29 0a 20 20 20 20 )..... 0)).
15a60 28 70 72 69 6e 74 20 22 4b 65 65 70 2d 41 6c 69 (print "Keep-Ali
15a70 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 35 2c 20 ve: timeout=15,
15a80 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 20 28 70 max=100"). (p
15a90 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e rint "Connection
15aa0 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 29 0a 20 : Keep-Alive").
15ab0 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 20 (print "").
15ac0 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 (write-string
15ad0 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 20 64 61 (blob->string da
15ae0 74 29 20 23 66 20 28 63 75 72 72 65 6e 74 2d 6f t) #f (current-o
15af0 75 74 70 75 74 2d 70 6f 72 74 29 29 29 29 0a 0a utput-port))))..
15b00 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
15b10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b40 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4f 72 70 68 ========.;; Orph
15b50 61 6e 65 64 20 66 75 6e 63 74 69 6f 6e 73 0a 3b aned functions.;
15b60 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
15b70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ba0 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 77 61 73 20 =======..;; was
15bb0 69 6e 20 73 65 74 75 70 0a 3b 3b 0a 28 64 65 66 in setup.;;.(def
15bc0 69 6e 65 20 28 73 3a 6c 6f 67 20 2e 20 6d 73 67 ine (s:log . msg
15bd0 29 0a 20 20 28 61 70 70 6c 79 20 73 65 73 73 69 ). (apply sessi
15be0 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 6f 6e on:log s:session
15bf0 20 6d 73 67 29 29 0a 0a 0a 3b 3b 20 55 73 61 67 msg))...;; Usag
15c00 65 3a 20 28 73 3a 67 65 74 2d 65 72 72 20 73 3a e: (s:get-err s:
15c10 62 69 67 29 0a 28 64 65 66 69 6e 65 20 28 73 3a big).(define (s:
15c20 67 65 74 2d 65 72 72 20 77 72 61 70 70 65 72 66 get-err wrapperf
15c30 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 65 72 unc). (let ((er
15c40 72 6d 73 67 20 28 73 64 61 74 2d 67 65 74 2d 63 rmsg (sdat-get-c
15c50 75 72 72 2d 65 72 72 20 73 3a 73 65 73 73 69 6f urr-err s:sessio
15c60 6e 29 29 29 0a 20 20 20 20 28 69 66 20 65 72 72 n))). (if err
15c70 6d 73 67 20 28 28 69 66 20 77 72 61 70 70 65 72 msg ((if wrapper
15c80 66 75 6e 63 0a 20 20 20 20 20 20 20 20 20 20 20 func.
15c90 20 20 20 20 20 20 20 20 20 77 72 61 70 70 65 72 wrapper
15ca0 66 75 6e 63 0a 20 20 20 20 20 20 20 20 20 20 20 func.
15cb0 20 20 20 20 20 20 20 20 20 73 3a 73 74 72 6f 6e s:stron
15cc0 67 29 20 65 72 72 6d 73 67 29 20 27 28 29 29 29 g) errmsg) '()))
15cd0 29 0a 28 64 65 66 69 6e 65 20 28 73 74 6d 6c 3a ).(define (stml:
15ce0 63 67 69 2d 73 65 73 73 69 6f 6e 20 73 65 73 73 cgi-session sess
15cf0 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a ion). (session:
15d00 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 73 73 69 initialize sessi
15d10 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 on). (session:s
15d20 65 74 75 70 20 73 65 73 73 69 6f 6e 29 0a 20 20 etup session).
15d30 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 (session:get-var
15d40 73 20 73 65 73 73 69 6f 6e 29 0a 0a 20 20 28 73 s session).. (s
15d50 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 dat-set-log-port
15d60 21 20 73 65 73 73 69 6f 6e 20 3b 3b 20 28 63 75 ! session ;; (cu
15d70 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
15d80 29 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 6e ))... (open
15d90 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 73 64 -output-file (sd
15da0 61 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 at-get-logfile s
15db0 65 73 73 69 6f 6e 29 20 23 3a 61 70 70 65 6e 64 ession) #:append
15dc0 29 29 0a 20 20 28 73 3a 76 61 6c 69 64 61 74 65 )). (s:validate
15dd0 2d 69 6e 70 75 74 73 29 0a 20 20 28 73 65 73 73 -inputs). (sess
15de0 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 ion:run-actions
15df0 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 64 61 74 session). (sdat
15e00 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 65 -set-pagedat! se
15e10 73 73 69 6f 6e 0a 09 09 20 20 20 20 20 28 61 70 ssion... (ap
15e20 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 70 pend (sdat-get-p
15e30 61 67 65 64 61 74 20 73 65 73 73 69 6f 6e 29 0a agedat session).
15e40 09 09 09 20 20 20 20 20 28 73 3a 63 61 6c 6c 20 ... (s:call
15e50 28 73 64 61 74 2d 67 65 74 2d 74 6f 70 70 61 67 (sdat-get-toppag
15e60 65 20 73 65 73 73 69 6f 6e 29 29 29 29 0a 20 20 e session)))).
15e70 28 69 66 20 28 65 71 3f 20 28 73 64 61 74 2d 67 (if (eq? (sdat-g
15e80 65 74 2d 70 61 67 65 2d 74 79 70 65 20 73 65 73 et-page-type ses
15e90 73 69 6f 6e 29 20 27 68 74 6d 6c 29 20 3b 3b 20 sion) 'html) ;;
15ea0 64 65 66 61 75 6c 74 20 69 73 20 68 74 6d 6c 2e default is html.
15eb0 20 0a 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e . (session
15ec0 3a 63 67 69 2d 6f 75 74 20 73 65 73 73 69 6f 6e :cgi-out session
15ed0 29 0a 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e ). (session
15ee0 3a 61 6c 74 2d 6f 75 74 20 73 65 73 73 69 6f 6e :alt-out session
15ef0 29 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 61 )). (session:sa
15f00 76 65 2d 76 61 72 73 20 73 65 73 73 69 6f 6e 29 ve-vars session)
15f10 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 . (session:clos
15f20 65 20 73 65 73 73 69 6f 6e 29 29 0a 0a 0a 28 64 e session))...(d
15f30 65 66 69 6e 65 20 28 73 3a 76 61 6c 69 64 61 74 efine (s:validat
15f40 65 2d 69 6e 70 75 74 73 29 0a 20 20 28 69 66 20 e-inputs). (if
15f50 28 6e 6f 74 20 28 73 3a 76 61 6c 69 64 61 74 65 (not (s:validate
15f60 2d 75 72 69 29 29 0a 20 20 20 20 20 20 28 62 65 -uri)). (be
15f70 67 69 6e 20 28 73 3a 65 72 72 6f 72 2d 70 61 67 gin (s:error-pag
15f80 65 20 22 42 61 64 20 55 52 49 22 20 28 6c 65 74 e "Bad URI" (let
15f90 20 28 28 72 65 66 20 28 67 65 74 2d 65 6e 76 69 ((ref (get-envi
15fa0 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
15fb0 20 22 48 54 54 50 5f 52 45 46 45 52 45 52 22 29 "HTTP_REFERER")
15fc0 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 69 ))..... (i
15fd0 66 20 72 65 66 0a 09 09 09 09 09 20 20 20 28 6c f ref...... (l
15fe0 69 73 74 20 22 72 65 66 65 72 72 65 64 20 66 72 ist "referred fr
15ff0 6f 6d 22 20 72 65 66 29 0a 09 09 09 09 09 20 20 om" ref)......
16000 20 22 22 29 29 29 0a 09 20 20 20 20 20 28 65 78 ""))).. (ex
16010 69 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 it))))..(define
16020 28 73 3a 65 72 72 6f 72 2d 70 61 67 65 20 2e 20 (s:error-page .
16030 65 72 72 29 0a 20 20 28 73 3a 63 67 69 2d 6f 75 err). (s:cgi-ou
16040 74 20 28 63 6f 6e 73 20 22 43 6f 6e 74 65 6e 74 t (cons "Content
16050 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c -type: text/html
16060 3b 20 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 ; charset=iso-88
16070 35 39 2d 31 5c 6e 5c 6e 22 0a 09 09 20 20 20 28 59-1\n\n"... (
16080 73 3a 68 74 6d 6c 20 28 73 3a 68 65 61 64 20 0a s:html (s:head .
16090 09 09 09 20 20 20 20 28 73 3a 74 69 74 6c 65 20 ... (s:title
160a0 65 72 72 29 0a 09 09 09 20 20 20 20 28 73 3a 62 err).... (s:b
160b0 6f 64 79 0a 09 09 09 20 20 20 20 20 28 73 3a 68 ody.... (s:h
160c0 31 20 22 45 52 52 4f 52 22 29 0a 09 09 09 20 20 1 "ERROR")....
160d0 20 20 20 28 73 3a 70 20 65 72 72 29 29 29 29 29 (s:p err)))))
160e0 29 29 20 20 20 20 20 20 20 20 20 20 20 0a 0a 0a )) ...
160f0 28 64 65 66 69 6e 65 20 28 73 74 6d 6c 3a 6d 61 (define (stml:ma
16100 69 6e 20 70 72 6f 63 29 0a 20 20 28 68 61 6e 64 in proc). (hand
16110 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
16120 20 65 78 6e 20 20 20 0a 20 20 20 28 69 66 20 28 exn . (if (
16130 73 64 61 74 2d 67 65 74 2d 64 65 62 75 67 6d 6f sdat-get-debugmo
16140 64 65 20 73 3a 73 65 73 73 69 6f 6e 29 0a 20 20 de s:session).
16150 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 28 70 (begin.. (p
16160 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 74 79 rint "Content-ty
16170 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 22 29 0a pe: text/html").
16180 09 20 28 70 72 69 6e 74 20 22 22 29 0a 09 20 28 . (print "").. (
16190 70 72 69 6e 74 20 22 3c 68 74 6d 6c 3e 20 3c 68 print "<html> <h
161a0 65 61 64 3e 20 3c 74 69 74 6c 65 3e 45 58 43 45 ead> <title>EXCE
161b0 50 54 49 4f 4e 3c 2f 74 69 74 6c 65 3e 20 3c 2f PTION</title> </
161c0 68 65 61 64 3e 20 3c 62 6f 64 79 3e 22 29 0a 09 head> <body>")..
161d0 20 28 70 72 69 6e 74 20 22 20 20 20 51 55 45 52 (print " QUER
161e0 59 5f 53 54 52 49 4e 47 20 69 73 3a 20 3c 62 3e Y_STRING is: <b>
161f0 20 22 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d " (get-environm
16200 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 ent-variable "QU
16210 45 52 59 5f 53 54 52 49 4e 47 22 29 20 22 20 3c ERY_STRING") " <
16220 2f 62 3e 20 3c 62 72 3e 22 29 0a 09 20 28 70 72 /b> <br>").. (pr
16230 69 6e 74 20 22 3c 70 72 65 3e 22 29 0a 09 20 3b int "<pre>").. ;
16240 3b 20 28 70 72 69 6e 74 20 22 20 20 20 45 58 43 ; (print " EXC
16250 45 50 54 49 4f 4e 3a 20 22 20 28 28 63 6f 6e 64 EPTION: " ((cond
16260 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
16270 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
16280 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 28 ssage) exn)).. (
16290 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 print-error-mess
162a0 61 67 65 20 65 78 6e 29 0a 09 20 28 70 72 69 6e age exn).. (prin
162b0 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 09 20 t-call-chain)..
162c0 28 70 72 69 6e 74 20 22 3c 2f 70 72 65 3e 22 29 (print "</pre>")
162d0 0a 09 20 28 70 72 69 6e 74 20 22 3c 74 61 62 6c .. (print "<tabl
162e0 65 3e 22 29 0a 09 20 28 66 6f 72 2d 65 61 63 68 e>").. (for-each
162f0 20 28 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 (lambda (var)..
16300 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 . (print "<t
16310 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 76 61 72 r><td>" (car var
16320 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 63 ) "</td><td>" (c
16330 64 72 20 76 61 72 29 20 22 3c 2f 74 64 3e 3c 2f dr var) "</td></
16340 74 72 3e 22 29 29 0a 09 09 20 20 20 28 67 65 74 tr>"))... (get
16350 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
16360 69 61 62 6c 65 73 29 29 0a 09 20 28 70 72 69 6e iables)).. (prin
16370 74 20 22 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 20 t "</table>")..
16380 28 70 72 69 6e 74 20 22 3c 2f 62 6f 64 79 3e 3c (print "</body><
16390 2f 68 74 6d 6c 3e 22 29 29 0a 20 20 20 20 20 20 /html>")).
163a0 20 28 62 65 67 69 6e 0a 09 20 28 77 69 74 68 2d (begin.. (with-
163b0 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 output-to-file (
163c0 63 6f 6e 63 20 22 2f 74 6d 70 2f 73 74 6d 6c 2d conc "/tmp/stml-
163d0 63 72 61 73 68 2d 22 20 28 63 75 72 72 65 6e 74 crash-" (current
163e0 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2e 6c -process-id) ".l
163f0 6f 67 22 29 0a 09 20 20 20 28 6c 61 6d 62 64 61 og").. (lambda
16400 20 28 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 ().. (print
16410 20 22 45 58 43 45 50 54 49 4f 4e 22 29 0a 09 20 "EXCEPTION")..
16420 20 20 20 20 28 70 72 69 6e 74 20 22 20 20 20 51 (print " Q
16430 55 45 52 59 5f 53 54 52 49 4e 47 20 69 73 3a 20 UERY_STRING is:
16440 22 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 " (get-environme
16450 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 51 55 45 nt-variable "QUE
16460 52 59 5f 53 54 52 49 4e 47 22 29 20 29 0a 09 20 RY_STRING") )..
16470 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 09 (print "")..
16480 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
16490 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 20 22 20 EXCEPTION: "
164a0 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
164b0 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
164c0 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
164d0 29 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 2d )).. (print-
164e0 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 65 78 error-message ex
164f0 6e 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 2d n).. (print-
16500 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 09 20 20 20 call-chain)..
16510 20 20 28 70 72 69 6e 74 20 22 22 29 0a 09 20 20 (print "")..
16520 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
16530 6d 62 64 61 20 28 76 61 72 29 0a 09 09 09 20 28 mbda (var).... (
16540 70 72 69 6e 74 20 28 63 61 72 20 76 61 72 29 20 print (car var)
16550 22 5c 74 22 20 28 63 64 72 20 76 61 72 29 29 29 "\t" (cdr var)))
16560 0a 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 65 ... (get-e
16570 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
16580 62 6c 65 73 29 29 29 29 0a 09 20 3b 3b 20 72 65 bles)))).. ;; re
16590 74 75 72 6e 20 73 6f 6d 65 74 68 69 6e 67 20 75 turn something u
165a0 73 65 66 75 6c 20 74 6f 20 74 68 65 20 75 73 65 seful to the use
165b0 72 0a 09 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 r.. (print "Cont
165c0 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 ent-type: text/h
165d0 74 6d 6c 22 29 0a 09 20 28 70 72 69 6e 74 20 22 tml").. (print "
165e0 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 68 74 ").. (print "<ht
165f0 6d 6c 3e 20 3c 68 65 61 64 3e 20 3c 74 69 74 6c ml> <head> <titl
16600 65 3e 45 58 43 45 50 54 49 4f 4e 3c 2f 74 69 74 e>EXCEPTION</tit
16610 6c 65 3e 20 3c 2f 68 65 61 64 3e 20 3c 62 6f 64 le> </head> <bod
16620 79 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c y>").. (print "<
16630 68 31 3e 43 52 41 53 48 21 3c 2f 68 31 3e 22 29 h1>CRASH!</h1>")
16640 0a 09 20 28 70 72 69 6e 74 20 22 20 20 20 50 6c .. (print " Pl
16650 65 61 73 65 20 6e 6f 74 69 66 79 20 73 75 70 70 ease notify supp
16660 6f 72 74 20 61 74 20 22 20 28 73 64 61 74 2d 67 ort at " (sdat-g
16670 65 74 2d 64 6f 6d 61 69 6e 20 73 3a 73 65 73 73 et-domain s:sess
16680 69 6f 6e 29 20 22 20 74 68 61 74 20 74 68 65 20 ion) " that the
16690 65 72 72 6f 72 20 6c 6f 67 20 69 73 20 73 74 6d error log is stm
166a0 6c 2d 63 72 61 73 68 2d 22 20 28 63 75 72 72 65 l-crash-" (curre
166b0 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 nt-process-id) "
166c0 2e 6c 6f 67 3c 2f 62 3e 20 3c 62 72 3e 22 29 0a .log</b> <br>").
166d0 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 3c 70 72 . ;; (print "<pr
166e0 65 3e 22 29 0a 09 20 3b 3b 20 3b 3b 20 28 70 72 e>").. ;; ;; (pr
166f0 69 6e 74 20 22 20 20 20 45 58 43 45 50 54 49 4f int " EXCEPTIO
16700 4e 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e N: " ((condition
16710 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
16720 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
16730 29 20 65 78 6e 29 29 0a 09 20 3b 3b 20 3b 3b 20 ) exn)).. ;; ;;
16740 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 (print-error-mes
16750 73 61 67 65 20 65 78 6e 29 0a 09 20 3b 3b 20 3b sage exn).. ;; ;
16760 3b 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 ; (print-call-ch
16770 61 69 6e 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 ain).. ;; (print
16780 20 22 3c 2f 70 72 65 3e 22 29 0a 09 20 3b 3b 20 "</pre>").. ;;
16790 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 22 (print "<table>"
167a0 29 0a 09 20 3b 3b 20 28 66 6f 72 2d 65 61 63 68 ).. ;; (for-each
167b0 20 28 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 (lambda (var)..
167c0 20 3b 3b 20 09 20 20 20 20 20 28 70 72 69 6e 74 ;; . (print
167d0 20 22 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 "<tr><td>" (car
167e0 20 76 61 72 29 20 22 3c 2f 74 64 3e 3c 74 64 3e var) "</td><td>
167f0 22 20 28 63 64 72 20 76 61 72 29 20 22 3c 2f 74 " (cdr var) "</t
16800 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 20 3b 3b 20 d></tr>")).. ;;
16810 09 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e . (get-environ
16820 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 ment-variables))
16830 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 3c 2f .. ;; (print "</
16840 74 61 62 6c 65 3e 22 29 0a 09 20 28 70 72 69 6e table>").. (prin
16850 74 20 22 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c t "</body></html
16860 3e 22 29 29 29 0a 20 20 20 28 69 66 20 70 72 6f >"))). (if pro
16870 63 20 28 70 72 6f 63 20 73 3a 73 65 73 73 69 6f c (proc s:sessio
16880 6e 29 20 28 73 74 6d 6c 3a 63 67 69 2d 73 65 73 n) (stml:cgi-ses
16890 73 69 6f 6e 20 73 3a 73 65 73 73 69 6f 6e 29 29 sion s:session))
168a0 0a 20 3b 3b 20 28 72 61 69 73 65 2d 65 72 72 6f . ;; (raise-erro
168b0 72 29 0a 20 3b 3b 20 28 65 78 69 74 29 0a 20 20 r). ;; (exit).
168c0 20 29 29 0a 0a 3b 3b 20 66 69 6e 64 20 6f 75 74 ))..;; find out
168d0 20 69 66 20 77 65 20 61 72 65 20 69 6e 20 64 65 if we are in de
168e0 62 75 67 6d 6f 64 65 0a 28 64 65 66 69 6e 65 20 bugmode.(define
168f0 28 73 3a 64 65 62 75 67 2d 6d 6f 64 65 3f 29 0a (s:debug-mode?).
16900 20 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 75 (sdat-get-debu
16910 67 6d 6f 64 65 20 73 3a 73 65 73 73 69 6f 6e 29 gmode s:session)
16920 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 6e 65 )..(define (s:ne
16930 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f ver-called-page?
16940 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 69 6f page). (sessio
16950 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 n:never-called-p
16960 61 67 65 3f 20 73 3a 73 65 73 73 69 6f 6e 20 70 age? s:session p
16970 61 67 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 age))..(define (
16980 73 3a 73 65 74 2d 65 72 72 20 2e 20 61 72 67 73 s:set-err . args
16990 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 ). (sdat-set-cu
169a0 72 72 2d 65 72 72 21 20 73 3a 73 65 73 73 69 6f rr-err! s:sessio
169b0 6e 20 61 72 67 73 29 29 0a 0a 28 64 65 66 69 6e n args))..(defin
169c0 65 20 28 73 3a 63 75 72 72 65 6e 74 2d 70 61 67 e (s:current-pag
169d0 65 29 0a 20 20 28 73 64 61 74 2d 67 65 74 2d 70 e). (sdat-get-p
169e0 61 67 65 20 73 3a 73 65 73 73 69 6f 6e 29 29 0a age s:session)).
169f0 0a 28 64 65 66 69 6e 65 20 28 73 3a 64 65 6c 65 .(define (s:dele
16a00 74 65 2d 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 te-session). (s
16a10 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 65 ession:delete-se
16a20 73 73 69 6f 6e 20 73 3a 73 65 73 73 69 6f 6e 20 ssion s:session
16a30 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
16a40 6e 2d 6b 65 79 20 73 3a 73 65 73 73 69 6f 6e 29 n-key s:session)
16a50 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 63 ))..(define (s:c
16a60 61 6c 6c 20 70 61 67 65 20 2e 20 70 61 72 74 73 all page . parts
16a70 6c 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 l). (if (null?
16a80 70 61 72 74 73 6c 29 0a 20 20 20 20 20 20 28 73 partsl). (s
16a90 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 3a 73 65 ession:call s:se
16aa0 73 73 69 6f 6e 20 70 61 67 65 20 23 66 29 0a 20 ssion page #f).
16ab0 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 (session:ca
16ac0 6c 6c 20 73 3a 73 65 73 73 69 6f 6e 20 70 61 67 ll s:session pag
16ad0 65 20 28 63 61 72 20 70 61 72 74 73 6c 29 29 29 e (car partsl)))
16ae0 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 6c 69 )..(define (s:li
16af0 6e 6b 2d 74 6f 20 70 61 67 65 20 2e 20 70 61 72 nk-to page . par
16b00 61 6d 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a ams). (session:
16b10 6c 69 6e 6b 2d 74 6f 20 73 3a 73 65 73 73 69 6f link-to s:sessio
16b20 6e 20 70 61 67 65 20 70 61 72 61 6d 73 29 29 0a n page params)).
16b30 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 74 2d .(define (s:get-
16b40 70 61 72 61 6d 20 6b 65 79 20 2e 20 74 79 70 65 param key . type
16b50 2d 70 61 72 61 6d 73 29 0a 20 20 28 73 65 73 73 -params). (sess
16b60 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 20 73 3a ion:get-param s:
16b70 73 65 73 73 69 6f 6e 20 6b 65 79 20 74 79 70 65 session key type
16b80 2d 70 61 72 61 6d 73 29 29 0a 0a 3b 3b 20 74 68 -params))..;; th
16b90 65 73 65 20 61 72 65 20 70 61 67 65 20 6c 6f 63 ese are page loc
16ba0 61 6c 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 al.(define (s:ge
16bb0 74 20 6b 65 79 29 20 0a 20 20 28 73 65 73 73 69 t key) . (sessi
16bc0 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 3a 73 65 on:page-get s:se
16bd0 73 73 69 6f 6e 20 6b 65 79 29 29 0a 0a 28 64 65 ssion key))..(de
16be0 66 69 6e 65 20 28 73 3a 73 65 74 21 20 6b 65 79 fine (s:set! key
16bf0 20 76 61 6c 29 0a 20 20 28 73 65 73 73 69 6f 6e val). (session
16c00 3a 63 75 72 72 2d 70 61 67 65 2d 73 65 74 21 20 :curr-page-set!
16c10 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 20 76 61 s:session key va
16c20 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a l))..(define (s:
16c30 64 65 6c 21 20 6b 65 79 29 0a 20 20 28 73 65 73 del! key). (ses
16c40 73 69 6f 6e 3a 70 61 67 65 2d 76 61 72 2d 64 65 sion:page-var-de
16c50 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 l! s:session key
16c60 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 ))..(define (s:g
16c70 65 74 2d 6e 2d 64 65 6c 21 20 6b 65 79 29 0a 20 et-n-del! key).
16c80 20 28 6c 65 74 20 28 28 76 61 6c 20 28 73 65 73 (let ((val (ses
16c90 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 3a sion:page-get s:
16ca0 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 29 0a 20 session key))).
16cb0 20 20 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 (session:del!
16cc0 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 0a s:session key).
16cd0 20 20 20 20 76 61 6c 29 29 0a 0a 3b 3b 20 74 68 val))..;; th
16ce0 65 73 65 20 61 72 65 20 73 65 73 73 69 6f 6e 20 ese are session
16cf0 77 69 64 65 0a 28 64 65 66 69 6e 65 20 28 73 3a wide.(define (s:
16d00 73 65 73 73 69 6f 6e 2d 76 61 72 2d 67 65 74 20 session-var-get
16d10 6b 65 79 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 key . params) .
16d20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 3a (session:get s:
16d30 73 65 73 73 69 6f 6e 20 22 2a 73 65 73 73 69 6f session "*sessio
16d40 6e 76 61 72 73 2a 22 20 6b 65 79 20 70 61 72 61 nvars*" key para
16d50 6d 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ms))..(define (s
16d60 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d 73 65 74 :session-var-set
16d70 21 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 73 65 ! key val). (se
16d80 73 73 69 6f 6e 3a 73 65 74 21 20 73 3a 73 65 73 ssion:set! s:ses
16d90 73 69 6f 6e 20 22 2a 73 65 73 73 69 6f 6e 76 61 sion "*sessionva
16da0 72 73 2a 22 20 6b 65 79 20 76 61 6c 29 29 0a 0a rs*" key val))..
16db0 28 64 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 (define (s:sessi
16dc0 6f 6e 2d 76 61 72 2d 67 65 74 2d 6e 2d 64 65 6c on-var-get-n-del
16dd0 21 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 ! key). (let ((
16de0 76 61 6c 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 val (session:pag
16df0 65 2d 67 65 74 20 73 3a 73 65 73 73 69 6f 6e 20 e-get s:session
16e00 6b 65 79 29 29 29 0a 20 20 20 20 20 28 73 65 73 key))). (ses
16e10 73 69 6f 6e 3a 64 65 6c 21 20 73 3a 73 65 73 73 sion:del! s:sess
16e20 69 6f 6e 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 ion "*sessionvar
16e30 73 2a 22 20 6b 65 79 29 0a 20 20 20 20 20 76 61 s*" key). va
16e40 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a l))..(define (s:
16e50 73 65 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c 21 session-var-del!
16e60 20 6b 65 79 29 0a 20 20 28 73 65 73 73 69 6f 6e key). (session
16e70 3a 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 :del! s:session
16e80 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 "*sessionvars*"
16e90 6b 65 79 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 key))..(define s
16ea0 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c :session-var-del
16eb0 65 74 65 21 20 73 3a 73 65 73 73 69 6f 6e 2d 76 ete! s:session-v
16ec0 61 72 2d 64 65 6c 21 29 0a 0a 3b 3b 20 75 74 69 ar-del!)..;; uti
16ed0 6c 69 74 79 20 74 6f 20 67 65 74 20 61 6c 6c 20 lity to get all
16ee0 76 61 72 73 20 61 73 20 68 61 73 68 20 74 61 62 vars as hash tab
16ef0 6c 65 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 65 le.(define (s:se
16f00 73 73 69 6f 6e 2d 67 65 74 2d 73 65 73 73 69 6f ssion-get-sessio
16f10 6e 76 61 72 73 29 0a 20 20 28 73 64 61 74 2d 67 nvars). (sdat-g
16f20 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 20 73 et-sessionvars s
16f30 3a 73 65 73 73 69 6f 6e 29 29 0a 0a 0a 0a 29 0a :session))....).