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 60 tag "OPTGROUP" `
2200: 28 27 6c 61 62 65 6c 20 2c 6c 61 62 65 6c 29 29 ('label ,label))
2210: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
2220: 64 20 28 63 61 72 20 72 65 6d 29 29 0a 09 09 20 d (car rem))...
2230: 20 20 28 74 61 6c 20 28 63 64 72 20 72 65 6d 29 (tal (cdr rem)
2240: 29 0a 09 09 20 20 20 28 72 65 73 20 28 6c 69 73 )... (res (lis
2250: 74 20 28 63 6f 6e 63 20 22 3c 4f 50 54 47 52 4f t (conc "<OPTGRO
2260: 55 50 20 6c 61 62 65 6c 3d 22 20 6c 61 62 65 6c UP label=" label
2270: 29 29 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e )))).. ;; (prin
2280: 74 20 22 68 65 64 3a 20 22 20 68 65 64 20 22 20 t "hed: " hed "
2290: 74 61 6c 3a 20 22 20 74 61 6c 20 22 20 72 65 73 tal: " tal " res
22a0: 3a 20 22 20 72 65 73 29 0a 09 20 20 28 6c 65 74 : " res).. (let
22b0: 20 28 28 6e 65 77 20 28 61 70 70 65 6e 64 20 72 ((new (append r
22c0: 65 73 20 28 6c 69 73 74 20 28 69 66 20 28 6c 69 es (list (if (li
22d0: 73 74 3f 20 28 63 61 64 72 20 68 65 64 29 29 0a st? (cadr hed)).
22e0: 09 09 09 09 09 20 20 20 28 73 3a 6f 70 74 67 72 ..... (s:optgr
22f0: 6f 75 70 20 68 65 64 29 0a 09 09 09 09 09 20 20 oup hed)......
2300: 20 28 73 3a 6f 70 74 69 6f 6e 20 68 65 64 29 29 (s:option hed))
2310: 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e )))).. (if (n
2320: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 28 61 70 70 ull? tal)...(app
2330: 65 6e 64 20 6e 65 77 20 28 6c 69 73 74 20 22 3c end new (list "<
2340: 2f 4f 50 54 47 52 4f 55 50 3e 22 29 29 0a 09 09 /OPTGROUP>"))...
2350: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
2360: 63 64 72 20 74 61 6c 29 20 6e 65 77 29 29 29 29 cdr tal) new))))
2370: 29 29 29 0a 20 20 20 20 0a 3b 3b 20 69 74 65 6d ))). .;; item
2380: 73 20 69 73 20 61 20 68 69 65 72 61 72 63 68 69 s is a hierarchi
2390: 61 6c 20 61 6c 69 73 74 0a 3b 3b 20 28 20 28 6c al alist.;; ( (l
23a0: 61 62 65 6c 31 20 76 61 6c 75 65 31 20 64 69 73 abel1 value1 dis
23b0: 70 76 61 6c 31 20 23 74 29 20 3b 3b 20 3c 3d 3d pval1 #t) ;; <==
23c0: 20 74 68 69 73 20 6f 6e 65 20 69 73 20 73 65 6c this one is sel
23d0: 65 63 74 65 64 0a 3b 3b 20 20 20 28 6c 61 62 65 ected.;; (labe
23e0: 6c 32 20 28 6c 61 62 65 6c 33 20 76 61 6c 75 65 l2 (label3 value
23f0: 32 20 64 69 73 70 76 61 6c 32 29 0a 3b 3b 20 20 2 dispval2).;;
2400: 20 20 20 20 20 20 20 20 20 28 6c 61 62 65 6c 34 (label4
2410: 20 76 61 6c 75 65 33 20 64 69 73 70 76 61 6c 33 value3 dispval3
2420: 29 29 29 0a 3b 3b 20 20 20 20 20 0a 3b 3b 20 20 ))).;; .;;
2430: 72 65 71 75 69 72 65 64 20 61 72 67 20 69 73 20 required arg is
2440: 27 6e 61 6d 65 0a 28 64 65 66 69 6e 65 20 28 73 'name.(define (s
2450: 3a 73 65 6c 65 63 74 20 69 74 65 6d 73 20 2e 20 :select items .
2460: 61 72 67 73 29 0a 20 20 28 69 66 20 28 6e 75 6c args). (if (nul
2470: 6c 3f 20 69 74 65 6d 73 29 0a 20 20 20 20 20 20 l? items).
2480: 28 73 3a 63 6f 6d 6d 6f 6e 2d 74 61 67 20 22 53 (s:common-tag "S
2490: 45 4c 45 43 54 22 20 61 72 67 73 29 0a 20 20 20 ELECT" args).
24a0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
24b0: 65 64 20 28 63 61 72 20 69 74 65 6d 73 29 29 0a ed (car items)).
24c0: 09 09 20 28 74 61 6c 20 28 63 64 72 20 69 74 65 .. (tal (cdr ite
24d0: 6d 73 29 29 0a 09 09 20 28 72 65 73 20 27 28 29 ms))... (res '()
24e0: 29 29 0a 09 3b 3b 20 28 70 72 69 6e 74 20 22 68 ))..;; (print "h
24f0: 65 64 3a 20 22 20 68 65 64 20 22 20 74 61 6c 3a ed: " hed " tal:
2500: 20 22 20 74 61 6c 20 22 20 72 65 73 3a 20 22 20 " tal " res: "
2510: 72 65 73 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 res)..(let ((new
2520: 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 (append res (li
2530: 73 74 20 28 69 66 20 28 61 6e 64 20 28 3e 20 28 st (if (and (> (
2540: 6c 65 6e 67 74 68 20 68 65 64 29 20 31 29 0a 09 length hed) 1)..
2550: 09 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 3f .... (list?
2560: 20 28 63 61 64 72 20 68 65 64 29 29 29 0a 09 09 (cadr hed)))...
2570: 09 09 09 20 28 73 3a 6f 70 74 67 72 6f 75 70 20 ... (s:optgroup
2580: 68 65 64 29 0a 09 09 09 09 09 20 28 73 3a 6f 70 hed)...... (s:op
2590: 74 69 6f 6e 20 68 65 64 29 29 29 29 29 29 0a 09 tion hed))))))..
25a0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
25b0: 29 0a 09 20 20 20 20 20 20 28 73 3a 63 6f 6d 6d ).. (s:comm
25c0: 6f 6e 2d 74 61 67 20 22 53 45 4c 45 43 54 22 20 on-tag "SELECT"
25d0: 28 63 6f 6e 73 20 6e 65 77 20 61 72 67 73 29 29 (cons new args))
25e0: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
25f0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
2600: 20 6e 65 77 29 29 29 29 29 29 0a 0a 28 64 65 66 new))))))..(def
2610: 69 6e 65 20 28 73 3a 63 6f 6c 6f 72 20 20 2e 20 ine (s:color .
2620: 61 72 67 73 29 0a 20 20 22 23 30 30 66 66 30 30 args). "#00ff00
2630: 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 ")..(define (s:p
2640: 72 69 6e 74 20 69 6e 64 65 6e 74 20 69 6e 6c 73 rint indent inls
2650: 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 t). (map (lambd
2660: 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 28 a (x). (
2670: 63 6f 6e 64 20 0a 20 20 20 20 20 20 20 20 20 20 cond .
2680: 28 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 78 29 ((or (string? x)
2690: 28 73 79 6d 62 6f 6c 3f 20 78 29 29 0a 20 20 20 (symbol? x)).
26a0: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 28 (print (
26b0: 63 6f 6e 63 20 28 6d 61 6b 65 2d 73 74 72 69 6e conc (make-strin
26c0: 67 20 28 2a 20 69 6e 64 65 6e 74 20 32 29 20 23 g (* indent 2) #
26d0: 5c 20 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 \ ) (s:any->stri
26e0: 6e 67 20 78 29 29 29 29 0a 20 20 20 20 20 20 20 ng x)))).
26f0: 20 20 20 28 28 6c 69 73 74 3f 20 78 29 0a 20 20 ((list? x).
2700: 20 20 20 20 20 20 20 20 20 28 73 3a 70 72 69 6e (s:prin
2710: 74 20 28 2b 20 69 6e 64 65 6e 74 20 31 29 20 78 t (+ indent 1) x
2720: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 6c )). (el
2730: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 3b 3b se. ;;
2740: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
2750: 42 61 64 20 69 6e 70 75 74 20 30 31 22 29 20 3b Bad input 01") ;
2760: 3b 20 77 68 79 20 64 6f 20 61 6e 79 74 68 69 6e ; why do anythin
2770: 67 20 77 69 74 68 20 6a 75 6e 6b 3f 0a 20 20 20 g with junk?.
2780: 20 20 20 20 20 20 20 20 29 29 29 0a 20 20 20 20 ))).
2790: 20 20 20 69 6e 6c 73 74 29 29 0a 0a 3b 3b 20 4d inlst))..;; M
27a0: 6f 76 65 64 20 74 6f 20 6d 69 73 63 2d 73 74 6d oved to misc-stm
27b0: 6c 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 l.;;.#;(define (
27c0: 73 3a 63 67 69 2d 6f 75 74 20 69 6e 6c 73 74 29 s:cgi-out inlst)
27d0: 0a 20 20 28 73 3a 6f 75 74 70 75 74 20 28 63 75 . (s:output (cu
27e0: 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 rrent-output-por
27f0: 74 29 20 69 6e 6c 73 74 29 29 0a 0a 23 3b 28 64 t) inlst))..#;(d
2800: 65 66 69 6e 65 20 28 73 3a 6f 75 74 70 75 74 20 efine (s:output
2810: 70 6f 72 74 20 69 6e 6c 73 74 29 0a 20 20 28 6d port inlst). (m
2820: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 ap (lambda (x)..
2830: 20 28 63 6f 6e 64 20 0a 09 20 20 28 28 73 74 72 (cond .. ((str
2840: 69 6e 67 3f 20 78 29 20 28 70 72 69 6e 74 20 78 ing? x) (print x
2850: 29 29 20 3b 3b 20 28 70 72 69 6e 74 20 78 29 29 )) ;; (print x))
2860: 0a 09 20 20 28 28 73 79 6d 62 6f 6c 3f 20 78 29 .. ((symbol? x)
2870: 20 28 70 72 69 6e 74 20 78 29 29 20 3b 3b 20 28 (print x)) ;; (
2880: 70 72 69 6e 74 20 78 29 29 0a 09 20 20 28 28 6c print x)).. ((l
2890: 69 73 74 3f 20 78 29 20 20 20 28 73 3a 6f 75 74 ist? x) (s:out
28a0: 70 75 74 20 70 6f 72 74 20 78 29 29 0a 09 20 20 put port x))..
28b0: 28 65 6c 73 65 20 22 22 0a 09 20 20 20 3b 3b 20 (else "".. ;;
28c0: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 42 (print "ERROR: B
28d0: 61 64 20 69 6e 70 75 74 20 30 32 22 29 20 3b 3b ad input 02") ;;
28e0: 20 77 68 79 20 64 6f 20 61 6e 79 74 68 69 6e 67 why do anything
28f0: 3f 20 64 6f 6e 27 74 20 6f 75 74 70 75 74 20 6a ? don't output j
2900: 75 6e 6b 2e 0a 09 20 20 20 29 29 29 0a 20 20 20 unk... ))).
2910: 20 20 20 20 69 6e 6c 73 74 29 29 0a 3b 20 20 28 inlst)).; (
2920: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 69 6e if (> (length in
2930: 6c 73 74 29 20 32 29 0a 3b 20 20 20 20 20 20 28 lst) 2).; (
2940: 70 72 69 6e 74 29 29 29 0a 0a 23 3b 28 64 65 66 print)))..#;(def
2950: 69 6e 65 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 ine (s:output-ne
2960: 77 20 70 6f 72 74 20 69 6e 6c 73 74 29 0a 20 20 w port inlst).
2970: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
2980: 70 6f 72 74 20 70 6f 72 74 0a 20 20 20 20 20 20 port port.
2990: 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 6d 61 70 (lambda ()..(map
29a0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 20 (lambda (x)..
29b0: 20 20 20 20 20 28 63 6f 6e 64 20 0a 09 09 28 28 (cond ...((
29c0: 73 74 72 69 6e 67 3f 20 78 29 20 28 70 72 69 6e string? x) (prin
29d0: 74 20 78 29 29 0a 09 09 28 28 73 79 6d 62 6f 6c t x))...((symbol
29e0: 3f 20 78 29 20 28 70 72 69 6e 74 20 78 29 29 0a ? x) (print x)).
29f0: 09 09 28 28 6c 69 73 74 3f 20 78 29 20 20 20 28 ..((list? x) (
2a00: 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 20 78 29 s:output port x)
2a10: 29 0a 09 09 28 65 6c 73 65 0a 09 09 20 3b 3b 20 )...(else... ;;
2a20: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 42 (print "ERROR: B
2a30: 61 64 20 69 6e 70 75 74 20 30 33 22 29 0a 20 20 ad input 03").
2a40: 20 20 20 29 29 29 0a 09 20 20 20 20 20 69 6e 6c ))).. inl
2a50: 73 74 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d st))))..;;======
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 3d 3d 3d 3d ================
2aa0: 0a 3b 3b 20 4e 6f 74 20 73 75 72 65 20 77 68 65 .;; Not sure whe
2ab0: 72 65 20 74 68 65 73 65 20 73 68 6f 75 6c 64 20 re these should
2ac0: 67 6f 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d go.;;===========
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 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
2b10: 28 69 6e 63 6c 75 64 65 20 22 72 65 71 75 69 72 (include "requir
2b20: 65 6d 65 6e 74 73 2e 73 63 6d 22 29 2c 20 64 62 ements.scm"), db
2b30: 69 20 68 61 73 20 61 75 74 6f 6c 6f 61 64 2c 20 i has autoload,
2b40: 73 68 6f 75 6c 64 20 6e 6f 74 20 6e 65 65 64 20 should not need
2b50: 74 68 69 73 20 61 6e 79 20 6d 6f 72 65 2e 0a 0a this any more...
2b60: 3b 3b 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 3d 3d 3d 3d 0a 3b 3b 20 73 65 74 75 ========.;; setu
2bb0: 70 20 2d 20 63 6f 6e 76 69 65 6e 63 65 20 63 61 p - convience ca
2bc0: 6c 6c 73 20 74 6f 20 66 75 6e 63 74 69 6f 6e 73 lls to functions
2bd0: 20 77 72 61 70 70 65 64 20 77 69 74 68 20 61 20 wrapped with a
2be0: 67 6c 6f 62 61 6c 20 73 3a 73 65 73 73 69 6f 6e global s:session
2bf0: 0a 3b 3b 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 3d 3d 3d 3d 0a 0a 3b 3b 20 6d 61 =========..;; ma
2c40: 63 72 6f 73 20 69 6e 20 73 75 67 61 72 20 64 6f cros in sugar do
2c50: 6e 27 74 20 77 6f 72 6b 2c 20 68 61 76 65 20 74 n't work, have t
2c60: 6f 20 6c 6f 61 64 20 69 6e 20 61 6c 6c 20 66 69 o load in all fi
2c70: 6c 65 73 20 6f 72 20 75 73 65 20 63 6f 6d 70 69 les or use compi
2c80: 6c 65 64 20 6d 6f 64 65 3f 0a 3b 3b 0a 3b 3b 20 led mode?.;;.;;
2c90: 28 69 6e 63 6c 75 64 65 20 22 73 75 67 61 72 2e (include "sugar.
2ca0: 73 63 6d 22 29 0a 0a 3b 3b 20 75 73 65 20 74 68 scm")..;; use th
2cb0: 69 73 20 66 6f 72 20 67 65 74 74 69 6e 67 20 64 is for getting d
2cc0: 61 74 61 20 66 72 6f 6d 20 70 61 67 65 20 74 6f ata from page to
2cd0: 20 70 61 67 65 20 77 68 65 6e 20 73 63 6f 70 65 page when scope
2ce0: 20 61 6e 64 20 65 76 61 6c 73 0a 3b 3b 20 67 65 and evals.;; ge
2cf0: 74 20 69 6e 20 74 68 65 20 77 61 79 0a 3b 3b 20 t in the way.;;
2d00: 73 61 76 65 20 64 61 74 61 20 66 6f 72 20 75 73 save data for us
2d10: 65 20 69 6e 20 74 68 65 20 70 61 67 65 20 67 65 e in the page ge
2d20: 6e 65 72 61 74 69 6f 6e 20 68 65 72 65 2e 20 44 neration here. D
2d30: 6f 65 73 20 4e 4f 54 20 70 65 72 73 69 73 74 20 oes NOT persist
2d40: 61 63 72 6f 73 73 20 70 61 67 65 20 72 65 61 64 across page read
2d50: 73 2e 0a 0a 28 64 65 66 69 6e 65 20 2a 70 61 67 s...(define *pag
2d60: 65 2d 64 61 74 61 2a 20 28 6d 61 6b 65 2d 68 61 e-data* (make-ha
2d70: 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 sh-table))..(def
2d80: 69 6e 65 20 28 73 3a 6c 73 65 74 21 20 76 61 72 ine (s:lset! var
2d90: 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d 74 61 val). (hash-ta
2da0: 62 6c 65 2d 73 65 74 21 20 2a 70 61 67 65 2d 64 ble-set! *page-d
2db0: 61 74 61 2a 20 76 61 72 20 76 61 6c 29 29 0a 28 ata* var val)).(
2dc0: 64 65 66 69 6e 65 20 28 73 3a 6c 67 65 74 20 76 define (s:lget v
2dd0: 61 72 20 2e 20 64 65 66 61 75 6c 74 29 0a 20 20 ar . default).
2de0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2df0: 64 65 66 61 75 6c 74 20 2a 70 61 67 65 2d 64 61 default *page-da
2e00: 74 61 2a 20 76 61 72 20 28 69 66 20 28 6e 75 6c ta* var (if (nul
2e10: 6c 3f 20 64 65 66 61 75 6c 74 29 0a 09 09 09 09 l? default).....
2e20: 09 20 20 20 20 20 20 23 66 0a 09 09 09 09 09 20 . #f......
2e30: 20 20 20 20 20 28 63 61 72 20 64 65 66 61 75 6c (car defaul
2e40: 74 29 29 29 29 0a 0a 3b 3b 20 74 6f 20 6f 62 73 t))))..;; to obs
2e50: 63 75 72 65 20 61 6e 64 20 69 6e 64 69 72 65 63 cure and indirec
2e60: 74 20 64 61 74 61 62 61 73 65 20 69 64 73 20 75 t database ids u
2e70: 73 65 20 6f 6e 65 20 74 69 6d 65 20 6b 65 79 73 se one time keys
2e80: 0a 3b 3b 0a 3b 3b 20 20 28 73 3a 67 65 74 2d 6b .;;.;; (s:get-k
2e90: 65 79 20 27 6e 20 31 29 20 20 20 20 20 3d 3e 20 ey 'n 1) =>
2ea0: 22 6e 39 39 65 31 38 38 32 22 20 6e 3d 6e 75 6d "n99e1882" n=num
2eb0: 62 65 72 20 39 39 65 20 69 73 20 74 68 65 20 77 ber 99e is the w
2ec0: 65 65 6b 20 6e 75 6d 62 65 72 20 73 69 6e 63 65 eek number since
2ed0: 20 31 39 37 30 2c 20 72 65 6d 61 69 6e 64 65 72 1970, remainder
2ee0: 20 69 73 20 72 61 6e 64 6f 6d 0a 3b 3b 20 20 28 is random.;; (
2ef0: 73 3a 6b 65 79 2d 3e 76 61 6c 20 22 6e 31 38 38 s:key->val "n188
2f00: 32 22 29 20 3d 3e 20 31 0a 3b 3b 0a 3b 3b 20 20 2") => 1.;;.;;
2f10: 66 69 72 73 74 20 6c 65 74 74 65 72 20 69 73 20 first letter is
2f20: 61 20 74 79 70 65 3a 20 6e 3d 6e 75 6d 62 65 72 a type: n=number
2f30: 2c 20 73 3d 73 74 72 69 6e 67 2c 20 62 3d 62 6f , s=string, b=bo
2f40: 6f 6c 65 61 6e 0a 28 64 65 66 69 6e 65 20 28 73 olean.(define (s
2f50: 3a 67 65 74 2d 6b 65 79 20 6b 65 79 2d 74 79 70 :get-key key-typ
2f60: 65 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 28 e val). (let ((
2f70: 6d 6b 72 61 6e 64 73 74 72 20 28 6c 61 6d 62 64 mkrandstr (lambd
2f80: 61 20 28 69 6e 6e 75 6d 29 28 6e 75 6d 62 65 72 a (innum)(number
2f90: 2d 3e 73 74 72 69 6e 67 20 28 72 61 6e 64 6f 6d ->string (random
2fa0: 20 69 6e 6e 75 6d 29 20 31 36 29 29 29 0a 09 28 innum) 16)))..(
2fb0: 77 65 65 6b 20 20 20 20 20 20 28 6e 75 6d 62 65 week (numbe
2fc0: 72 2d 3e 73 74 72 69 6e 67 20 28 71 75 6f 74 69 r->string (quoti
2fd0: 65 6e 74 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ent (current-sec
2fe0: 6f 6e 64 73 29 20 28 2a 20 37 20 32 34 20 36 30 onds) (* 7 24 60
2ff0: 20 36 30 29 29 20 31 36 29 29 29 0a 20 20 20 20 60)) 16))).
3000: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 69 7a 20 (let loop ((siz
3010: 31 30 30 30 29 0a 09 20 20 20 20 20 20 20 28 6b 1000).. (k
3020: 65 79 20 28 63 6f 6e 63 20 6b 65 79 2d 74 79 70 ey (conc key-typ
3030: 65 20 77 65 65 6b 20 28 6d 6b 72 61 6e 64 73 74 e week (mkrandst
3040: 72 20 31 30 30 29 29 29 0a 09 20 20 20 20 20 20 r 100)))..
3050: 20 28 6e 75 6d 20 30 29 29 0a 20 20 20 20 20 20 (num 0)).
3060: 28 69 66 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 (if (s:session-v
3070: 61 72 2d 67 65 74 20 6b 65 79 29 20 3b 3b 20 68 ar-get key) ;; h
3080: 61 76 65 20 61 20 63 6f 6c 6c 69 73 69 6f 6e 0a ave a collision.
3090: 09 20 20 28 6c 6f 6f 70 20 28 63 6f 6e 64 20 20 . (loop (cond
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
30b0: 3b 20 69 6e 20 74 68 65 20 75 6e 6c 69 6b 65 79 ; in the unlikey
30c0: 20 65 76 65 6e 74 20 77 65 20 68 61 76 65 20 74 event we have t
30d0: 72 6f 75 62 6c 65 20 67 65 74 74 69 6e 67 20 61 rouble getting a
30e0: 20 6e 65 77 20 76 61 72 2c 20 6b 65 65 70 20 69 new var, keep i
30f0: 6e 63 72 65 61 73 69 6e 67 20 74 68 65 20 73 69 ncreasing the si
3100: 7a 65 20 6f 66 20 74 68 65 20 6e 75 6d 62 65 72 ze of the number
3110: 0a 09 09 20 28 28 3c 20 6e 75 6d 20 35 30 29 20 ... ((< num 50)
3120: 20 31 30 30 29 0a 09 09 20 28 28 3c 20 6e 75 6d 100)... ((< num
3130: 20 31 30 30 29 20 31 30 30 30 29 0a 09 09 20 28 100) 1000)... (
3140: 28 3c 20 6e 75 6d 20 32 30 30 29 20 31 30 30 30 (< num 200) 1000
3150: 30 29 0a 09 09 20 28 28 3c 20 6e 75 6d 20 33 30 0)... ((< num 30
3160: 30 29 20 31 30 30 30 30 30 29 0a 09 09 20 28 28 0) 100000)... ((
3170: 3c 20 6e 75 6d 20 34 30 30 29 20 31 30 30 30 30 < num 400) 10000
3180: 30 30 29 20 3b 3b 20 63 61 6e 27 74 20 69 6d 61 00) ;; can't ima
3190: 67 69 6e 65 20 6e 65 65 64 69 6e 67 20 74 6f 20 gine needing to
31a0: 67 65 74 20 68 65 72 65 2e 20 72 65 6d 65 6d 62 get here. rememb
31b0: 65 72 20 74 68 61 74 20 74 68 69 73 20 69 73 20 er that this is
31c0: 66 6f 72 20 61 20 73 69 6e 67 6c 65 20 75 73 65 for a single use
31d0: 72 0a 09 09 20 28 65 6c 73 65 20 31 30 30 30 30 r... (else 10000
31e0: 30 30 30 30 29 29 0a 09 09 28 63 6f 6e 63 20 6b 0000))...(conc k
31f0: 65 79 2d 74 79 70 65 20 28 6d 6b 72 61 6e 64 73 ey-type (mkrands
3200: 74 72 20 73 69 7a 29 29 0a 09 09 28 2b 20 6e 75 tr siz))...(+ nu
3210: 6d 20 31 29 29 0a 09 20 20 28 62 65 67 69 6e 0a m 1)).. (begin.
3220: 09 20 20 20 20 28 73 3a 73 65 73 73 69 6f 6e 2d . (s:session-
3230: 76 61 72 2d 73 65 74 21 20 6b 65 79 20 76 61 6c var-set! key val
3240: 29 0a 09 20 20 20 20 6b 65 79 29 29 29 29 29 0a ).. key))))).
3250: 0a 3b 3b 20 67 69 76 65 6e 20 61 20 6b 65 79 20 .;; given a key
3260: 58 6e 6e 6e 6e 2c 20 6c 6f 6f 6b 20 75 70 20 74 Xnnnn, look up t
3270: 68 65 20 73 74 6f 72 65 64 20 76 61 6c 75 65 20 he stored value
3280: 61 6e 64 20 63 6f 6e 76 65 72 74 20 69 74 20 61 and convert it a
3290: 70 70 72 6f 70 72 69 61 74 65 6c 79 2c 20 74 68 ppropriately, th
32a0: 65 6e 0a 3b 3b 20 64 65 73 74 72 6f 79 20 74 68 en.;; destroy th
32b0: 65 20 73 74 6f 72 65 64 20 73 65 73 73 69 6f 6e e stored session
32c0: 20 76 61 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 var.;;.(define
32d0: 28 73 3a 6b 65 79 2d 3e 76 61 6c 20 6b 65 79 29 (s:key->val key)
32e0: 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 73 . (let ((val (s
32f0: 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d 67 65 74 :session-var-get
3300: 20 6b 65 79 29 29 0a 09 28 74 79 70 20 28 73 74 key))..(typ (st
3310: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 75 ring->symbol (su
3320: 62 73 74 72 69 6e 67 20 6b 65 79 20 30 20 31 29 bstring key 0 1)
3330: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 0a ))). (if val.
3340: 09 28 62 65 67 69 6e 0a 09 20 20 28 73 3a 73 65 .(begin.. (s:se
3350: 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c 21 20 6b ssion-var-del! k
3360: 65 79 29 0a 09 20 20 3b 3b 20 77 65 20 74 61 6b ey).. ;; we tak
3370: 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 e this opportuni
3380: 74 79 20 74 6f 20 63 6c 65 61 6e 20 75 70 20 6f ty to clean up o
3390: 6c 64 20 6b 65 79 65 64 20 73 65 73 73 69 6f 6e ld keyed session
33a0: 20 76 61 72 73 0a 09 20 20 3b 3b 20 69 66 20 6d vars.. ;; if m
33b0: 6f 72 65 20 74 68 61 6e 20 31 30 30 20 76 61 72 ore than 100 var
33c0: 73 2c 20 72 65 6d 6f 76 65 20 61 6c 6c 20 74 68 s, remove all th
33d0: 61 74 20 61 72 65 20 6f 76 65 72 20 31 2d 32 20 at are over 1-2
33e0: 77 65 65 6b 73 20 6f 6c 64 0a 09 09 09 09 09 3b weeks old......;
33f0: 28 73 3a 63 6c 65 61 6e 75 70 2d 73 65 73 73 69 (s:cleanup-sessi
3400: 6f 6e 2d 76 61 72 73 29 0a 09 20 20 28 63 61 73 on-vars).. (cas
3410: 65 20 74 79 70 0a 09 20 20 20 20 28 28 6e 29 28 e typ.. ((n)(
3420: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 string->number v
3430: 61 6c 29 29 0a 09 20 20 20 20 28 28 73 29 20 76 al)).. ((s) v
3440: 61 6c 29 0a 09 20 20 20 20 28 65 6c 73 65 20 76 al).. (else v
3450: 61 6c 29 29 29 0a 09 76 61 6c 29 29 29 0a 20 20 al)))..val))).
3460: 0a 3b 3b 20 63 6c 65 61 6e 20 75 70 20 73 65 73 .;; clean up ses
3470: 73 69 6f 6e 20 76 61 72 73 0a 3b 3b 0a 28 64 65 sion vars.;;.(de
3480: 66 69 6e 65 20 28 73 3a 63 6c 65 61 6e 75 70 2d fine (s:cleanup-
3490: 73 65 73 73 69 6f 6e 2d 76 61 72 73 29 0a 20 20 session-vars).
34a0: 28 6c 65 74 2a 20 28 28 73 65 73 73 69 6f 6e 2d (let* ((session-
34b0: 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 6c 65 vars (hash-table
34c0: 2d 6b 65 79 73 20 28 73 3a 73 65 73 73 69 6f 6e -keys (s:session
34d0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 -get-sessionvars
34e0: 29 29 29 0a 09 20 28 77 65 65 6b 2d 6e 75 6d 20 ))).. (week-num
34f0: 20 20 20 20 28 71 75 6f 74 69 65 6e 74 20 28 63 (quotient (c
3500: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3510: 28 2a 20 37 20 32 34 20 36 30 20 36 30 29 29 29 (* 7 24 60 60)))
3520: 0a 09 20 28 77 65 65 6b 20 20 20 20 20 20 20 20 .. (week
3530: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
3540: 20 77 65 65 6b 2d 6e 75 6d 20 20 31 36 29 29 29 week-num 16)))
3550: 0a 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e . (if (> (len
3560: 67 74 68 20 73 65 73 73 69 6f 6e 2d 76 61 72 73 gth session-vars
3570: 29 20 31 30 30 29 0a 09 28 66 6f 72 2d 65 61 63 ) 100)..(for-eac
3580: 68 0a 09 20 28 6c 61 6d 62 64 61 20 28 76 61 72 h.. (lambda (var
3590: 29 0a 09 20 20 20 28 69 66 20 28 3e 20 28 73 74 ).. (if (> (st
35a0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 76 61 72 29 ring-length var)
35b0: 20 35 29 20 3b 3b 20 63 61 6e 27 74 20 68 61 76 5) ;; can't hav
35c0: 65 20 6b 65 79 65 64 20 76 61 6c 75 65 73 20 77 e keyed values w
35d0: 69 74 68 20 6b 65 79 73 20 6c 65 73 73 20 74 68 ith keys less th
35e0: 61 6e 20 35 20 63 68 61 72 61 63 74 65 72 73 20 an 5 characters
35f0: 6c 6f 6e 67 0a 09 20 20 20 20 20 20 20 28 6c 65 long.. (le
3600: 74 20 28 28 76 61 72 2d 77 65 65 6b 20 28 73 74 t ((var-week (st
3610: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 73 75 ring->number (su
3620: 62 73 74 72 69 6e 67 20 76 61 72 20 31 20 34 29 bstring var 1 4)
3630: 20 31 36 29 29 29 0a 09 09 20 28 69 66 20 28 61 16)))... (if (a
3640: 6e 64 20 76 61 72 2d 77 65 65 6b 0a 09 09 09 20 nd var-week....
3650: 20 28 3e 3d 20 28 2d 20 77 65 65 6b 2d 6e 75 6d (>= (- week-num
3660: 20 76 61 72 2d 77 65 65 6b 29 20 32 29 29 0a 09 var-week) 2))..
3670: 09 20 20 20 20 20 28 73 3a 73 65 73 73 69 6f 6e . (s:session
3680: 2d 76 61 72 2d 64 65 6c 21 20 76 61 72 29 29 29 -var-del! var)))
3690: 29 29 0a 09 20 73 65 73 73 69 6f 6e 2d 76 61 72 )).. session-var
36a0: 73 29 29 29 29 0a 0a 3b 3b 20 69 6e 70 75 74 73 s))))..;; inputs
36b0: 0a 3b 3b 0a 3b 3b 20 70 61 72 61 6d 3a 20 28 64 .;;.;; param: (d
36c0: 74 79 70 65 20 5b 74 61 67 31 20 74 61 67 32 20 type [tag1 tag2
36d0: 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 79 70 65 3a 0a ...]).;; dtype:.
36e0: 3b 3b 20 20 20 20 27 72 61 77 20 20 20 20 20 3a ;; 'raw :
36f0: 20 64 6f 20 6e 6f 20 63 6f 6e 76 65 72 73 69 6f do no conversio
3700: 6e 0a 3b 3b 20 20 20 20 27 6e 75 6d 62 65 72 20 n.;; 'number
3710: 20 3a 20 63 6f 6e 76 65 72 74 20 74 6f 20 6e 75 : convert to nu
3720: 6d 62 65 72 2c 20 72 65 74 75 72 6e 20 23 66 20 mber, return #f
3730: 69 66 20 66 61 69 6c 73 0a 3b 3b 20 20 20 20 27 if fails.;; '
3740: 65 73 63 61 70 65 64 20 3a 20 75 73 65 20 68 74 escaped : use ht
3750: 6d 6c 2d 65 73 63 61 70 65 20 74 6f 20 70 72 6f ml-escape to pro
3760: 74 65 63 74 20 74 68 65 20 69 6e 70 75 74 0a 3b tect the input.;
3770: 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 74 ;.(define (s:get
3780: 2d 69 6e 70 75 74 20 6b 65 79 20 2e 20 70 61 72 -input key . par
3790: 61 6d 73 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a ams). (session:
37a0: 67 65 74 2d 69 6e 70 75 74 20 73 3a 73 65 73 73 get-input s:sess
37b0: 69 6f 6e 20 6b 65 79 20 70 61 72 61 6d 73 29 29 ion key params))
37c0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 74 ..(define (s:get
37d0: 2d 69 6e 70 75 74 2d 6b 65 79 73 29 0a 20 20 28 -input-keys). (
37e0: 73 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 session:get-inpu
37f0: 74 2d 6b 65 79 73 20 73 3a 73 65 73 73 69 6f 6e t-keys s:session
3800: 29 29 0a 0a 3b 3b 20 67 65 74 2d 69 6e 70 75 74 ))..;; get-input
3810: 20 65 6c 73 65 2c 20 67 65 74 2d 70 61 72 61 6d else, get-param
3820: 20 65 6c 73 65 20 23 66 0a 3b 3b 0a 28 64 65 66 else #f.;;.(def
3830: 69 6e 65 20 28 73 3a 67 65 74 2d 69 6e 70 20 6b ine (s:get-inp k
3840: 65 79 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 ey . params). (
3850: 6f 72 20 28 61 70 70 6c 79 20 73 3a 67 65 74 2d or (apply s:get-
3860: 69 6e 70 75 74 20 6b 65 79 20 70 61 72 61 6d 73 input key params
3870: 29 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 73 ). (apply s
3880: 3a 67 65 74 2d 70 61 72 61 6d 20 6b 65 79 20 70 :get-param key p
3890: 61 72 61 6d 73 29 29 29 0a 0a 23 3b 28 64 65 66 arams)))..#;(def
38a0: 69 6e 65 20 28 73 3a 6c 6f 61 64 2d 6d 6f 64 65 ine (s:load-mode
38b0: 6c 20 6d 6f 64 65 6c 29 0a 20 20 28 73 65 73 73 l model). (sess
38c0: 69 6f 6e 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 73 ion:load-model s
38d0: 3a 73 65 73 73 69 6f 6e 20 6d 6f 64 65 6c 29 29 :session model))
38e0: 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 6d ..#;(define (s:m
38f0: 6f 64 65 6c 2d 70 61 74 68 20 6d 6f 64 65 6c 29 odel-path model)
3900: 0a 20 20 28 73 65 73 73 69 6f 6e 3a 6d 6f 64 65 . (session:mode
3910: 6c 2d 70 61 74 68 20 73 3a 73 65 73 73 69 6f 6e l-path s:session
3920: 20 6d 6f 64 65 6c 29 29 0a 0a 3b 3b 20 73 68 61 model))..;; sha
3930: 72 65 20 64 61 74 61 20 62 65 74 77 65 65 6e 20 re data between
3940: 70 61 67 65 73 20 63 61 6c 6c 73 2e 20 4e 4f 54 pages calls. NOT
3950: 45 3a 20 54 68 69 73 20 69 73 20 6e 6f 74 20 70 E: This is not p
3960: 65 72 73 69 73 74 65 6e 74 0a 3b 3b 20 62 65 74 ersistent.;; bet
3970: 77 65 65 6e 20 63 67 69 20 63 61 6c 6c 73 2e 20 ween cgi calls.
3980: 55 73 65 20 73 65 73 73 69 6f 6e 76 61 72 73 20 Use sessionvars
3990: 66 6f 72 20 74 68 61 74 2e 0a 3b 3b 0a 28 64 65 for that..;;.(de
39a0: 66 69 6e 65 20 28 73 3a 73 68 61 72 65 64 2d 68 fine (s:shared-h
39b0: 61 73 68 29 0a 20 20 28 73 64 61 74 2d 67 65 74 ash). (sdat-get
39c0: 2d 73 68 61 72 65 64 2d 68 61 73 68 20 73 3a 73 -shared-hash s:s
39d0: 65 73 73 69 6f 6e 29 29 0a 0a 28 64 65 66 69 6e ession))..(defin
39e0: 65 20 28 73 3a 73 68 61 72 65 64 2d 73 65 74 21 e (s:shared-set!
39f0: 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 68 61 73 key val). (has
3a00: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 h-table-set! (sd
3a10: 61 74 2d 67 65 74 2d 73 68 61 72 65 64 2d 68 61 at-get-shared-ha
3a20: 73 68 20 73 3a 73 65 73 73 69 6f 6e 29 20 6b 65 sh s:session) ke
3a30: 79 20 76 61 6c 29 29 0a 0a 3b 3b 20 57 68 61 74 y val))..;; What
3a40: 20 74 6f 20 72 65 74 75 72 6e 20 77 68 65 6e 20 to return when
3a50: 6e 6f 20 76 61 6c 75 65 20 66 6f 72 20 6b 65 79 no value for key
3a60: 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a ?.;;.(define (s:
3a70: 73 68 61 72 65 64 2d 67 65 74 20 6b 65 79 29 0a shared-get key).
3a80: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
3a90: 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d f/default (sdat-
3aa0: 67 65 74 2d 73 68 61 72 65 64 2d 68 61 73 68 20 get-shared-hash
3ab0: 73 3a 73 65 73 73 69 6f 6e 29 20 6b 65 79 20 23 s:session) key #
3ac0: 66 29 29 0a 0a 3b 3b 20 68 74 74 70 3a 2f 2f 66 f))..;; http://f
3ad0: 6f 6f 2e 62 61 72 2e 63 6f 6d 2f 70 61 67 65 6e oo.bar.com/pagen
3ae0: 61 6d 65 2f 70 31 2f 70 32 20 3d 3e 20 27 28 22 ame/p1/p2 => '("
3af0: 70 31 22 20 22 70 32 22 29 0a 3b 3b 20 20 23 23 p1" "p2").;; ##
3b00: 23 23 20 44 45 50 52 45 43 41 54 45 44 20 23 23 ## DEPRECATED ##
3b10: 23 23 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 65 ##.(define (s:ge
3b20: 74 2d 70 61 67 65 2d 70 61 72 61 6d 73 29 0a 20 t-page-params).
3b30: 20 28 73 64 61 74 2d 67 65 74 2d 70 61 74 68 2d (sdat-get-path-
3b40: 70 61 72 61 6d 73 20 73 3a 73 65 73 73 69 6f 6e params s:session
3b50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 ))..(define (s:g
3b60: 65 74 2d 70 61 74 68 2d 70 61 72 61 6d 73 29 0a et-path-params).
3b70: 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 74 68 (sdat-get-path
3b80: 2d 70 61 72 61 6d 73 20 73 3a 73 65 73 73 69 6f -params s:sessio
3b90: 6e 29 29 0a 09 0a 0a 28 64 65 66 69 6e 65 20 28 n))....(define (
3ba0: 73 3a 64 62 29 0a 20 20 28 73 64 61 74 2d 67 65 s:db). (sdat-ge
3bb0: 74 2d 63 6f 6e 6e 20 73 3a 73 65 73 73 69 6f 6e t-conn s:session
3bc0: 29 29 0a 0a 3b 3b 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 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
3c10: 63 67 69 20 61 6e 64 20 73 65 73 73 69 6f 6e 20 cgi and session
3c20: 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d stuff.;;========
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 3d 3d 3d 3d 0a 0a ==============..
3c70: 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ;;(declare (uses
3c80: 20 63 6f 6f 6b 69 65 29 29 0a 3b 3b 28 64 65 63 cookie)).;;(dec
3c90: 6c 61 72 65 20 28 75 73 65 73 20 68 74 6d 6c 2d lare (uses html-
3ca0: 66 69 6c 74 65 72 29 29 0a 3b 3b 28 64 65 63 6c filter)).;;(decl
3cb0: 61 72 65 20 28 75 73 65 73 20 6d 69 73 63 2d 73 are (uses misc-s
3cc0: 74 6d 6c 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 tml)).;;(declare
3cd0: 20 28 75 73 65 73 20 66 6f 72 6d 64 61 74 29 29 (uses formdat))
3ce0: 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 .;;(declare (use
3cf0: 73 20 73 74 6d 6c 29 29 0a 3b 3b 28 64 65 63 6c s stml)).;;(decl
3d00: 61 72 65 20 28 75 73 65 73 20 73 65 73 73 69 6f are (uses sessio
3d10: 6e 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 n)).;;(declare (
3d20: 75 73 65 73 20 73 65 74 75 70 29 29 20 3b 3b 20 uses setup)) ;;
3d30: 73 3a 73 65 73 73 69 6f 6e 20 67 65 74 73 20 63 s:session gets c
3d40: 72 65 61 74 65 64 20 68 65 72 65 0a 3b 3b 28 64 reated here.;;(d
3d50: 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 71 6c eclare (uses sql
3d60: 74 62 6c 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 tbl)).;;(declare
3d70: 20 28 75 73 65 73 20 6b 65 79 73 74 6f 72 65 29 (uses keystore)
3d80: 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 )..;; given a li
3d90: 73 74 20 6f 66 20 73 79 6d 62 6f 6c 73 20 67 69 st of symbols gi
3da0: 76 65 20 74 68 65 20 63 6f 75 6e 74 20 6f 66 20 ve the count of
3db0: 74 68 65 20 6d 61 74 63 68 69 6e 67 20 73 79 6d the matching sym
3dc0: 62 6f 6c 0a 3b 3b 20 6c 20 3d 3e 20 27 28 61 20 bol.;; l => '(a
3dd0: 62 20 63 29 20 20 28 64 75 6d 6f 62 6a 3a 69 6e b c) (dumobj:in
3de0: 64 78 20 61 20 27 62 29 20 3d 3e 20 31 0a 28 64 dx a 'b) => 1.(d
3df0: 65 66 69 6e 65 20 28 73 3a 67 65 74 2d 66 69 65 efine (s:get-fie
3e00: 6c 64 6e 75 6d 20 6c 73 74 20 66 69 65 6c 64 2d ldnum lst field-
3e10: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 6c 6f 6f name). (let loo
3e20: 70 20 28 28 68 65 61 64 20 28 63 61 72 20 6c 73 p ((head (car ls
3e30: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
3e40: 20 28 74 61 69 6c 20 28 63 64 72 20 6c 73 74 29 (tail (cdr lst)
3e50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
3e60: 66 6e 75 6d 20 30 29 29 0a 20 20 20 20 28 69 66 fnum 0)). (if
3e70: 20 28 65 71 3f 20 68 65 61 64 20 66 69 65 6c 64 (eq? head field
3e80: 2d 6e 61 6d 65 29 20 66 6e 75 6d 0a 20 20 20 20 -name) fnum.
3e90: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
3ea0: 61 69 6c 29 20 23 66 0a 20 20 20 20 20 20 20 20 ail) #f.
3eb0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
3ec0: 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 28 2b ail)(cdr tail)(+
3ed0: 20 66 6e 75 6d 20 31 29 29 29 29 29 29 0a 0a 28 fnum 1))))))..(
3ee0: 64 65 66 69 6e 65 20 28 73 3a 66 69 65 6c 64 73 define (s:fields
3ef0: 2d 3e 73 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 ->string lst).
3f00: 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 6d 61 (string-join (ma
3f10: 70 20 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 p symbol->string
3f20: 20 6c 73 74 29 20 22 2c 22 29 29 0a 0a 28 64 65 lst) ","))..(de
3f30: 66 69 6e 65 20 28 73 3a 76 65 63 74 6f 72 2d 67 fine (s:vector-g
3f40: 65 74 2d 66 69 65 6c 64 20 76 65 63 20 66 69 65 et-field vec fie
3f50: 6c 64 20 66 69 65 6c 64 2d 6c 69 73 74 29 0a 20 ld field-list).
3f60: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 (vector-ref vec
3f70: 20 28 73 3a 67 65 74 2d 66 69 65 6c 64 6e 75 6d (s:get-fieldnum
3f80: 20 66 69 65 6c 64 2d 6c 69 73 74 20 66 69 65 6c field-list fiel
3f90: 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d d)))..;;========
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 3d 3d 3d 3d 0a 3b ==============.;
3fe0: 3b 0a 3b 3b 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 3d 3d 3d 3d 0a 0a 3b 3b 20 6d ==========..;; m
4030: 6f 76 65 64 20 74 6f 20 6d 69 73 63 2d 73 74 6d oved to misc-stm
4040: 6c 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 l.;;.#;(define (
4050: 65 72 72 3a 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 err:log . msg).
4060: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
4070: 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 -port (current-e
4080: 72 72 6f 72 2d 70 6f 72 74 29 20 3b 3b 20 28 73 rror-port) ;; (s
4090: 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f lot-ref self 'lo
40a0: 67 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 gpt). (lambda
40b0: 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c () . (appl
40c0: 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a y print msg)))).
40d0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 74 69 64 79 .(define (s:tidy
40e0: 2d 75 72 6c 20 75 72 6c 29 0a 20 20 28 69 66 20 -url url). (if
40f0: 75 72 6c 0a 20 20 20 20 20 20 28 6c 65 74 20 28 url. (let (
4100: 28 72 31 20 28 72 65 67 65 78 70 20 22 5e 68 74 (r1 (regexp "^ht
4110: 74 70 3a 5c 5c 2f 5c 5c 2f 22 29 29 0a 20 20 20 tp:\\/\\/")).
4120: 20 20 20 20 20 20 20 20 20 28 72 32 20 28 72 65 (r2 (re
4130: 67 65 78 70 20 22 5e 5b 20 5c 5c 74 5d 2a 24 22 gexp "^[ \\t]*$"
4140: 29 29 29 20 3b 3b 20 62 6c 61 6e 6b 0a 20 20 20 ))) ;; blank.
4150: 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
4160: 2d 6d 61 74 63 68 20 72 31 20 75 72 6c 29 20 75 -match r1 url) u
4170: 72 6c 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 rl. (
4180: 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 if (string-match
4190: 20 72 32 20 75 72 6c 29 20 23 66 20 3b 3b 20 63 r2 url) #f ;; c
41a0: 6f 6e 76 65 72 74 20 61 20 62 6c 61 6e 6b 20 74 onvert a blank t
41b0: 6f 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 o #f.
41c0: 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 (conc "http
41d0: 3a 2f 2f 22 20 75 72 6c 29 29 29 29 0a 20 20 20 ://" url)))).
41e0: 20 20 20 75 72 6c 29 29 0a 0a 28 64 65 66 69 6e url))..(defin
41f0: 65 20 28 73 3a 6c 61 7a 79 2d 3e 6e 75 6d 20 6e e (s:lazy->num n
4200: 75 6d 29 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 um). (if (numbe
4210: 72 3f 20 6e 75 6d 29 20 6e 75 6d 0a 20 20 20 20 r? num) num.
4220: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 3e 6e (if (string->n
4230: 75 6d 62 65 72 20 6e 75 6d 29 20 28 73 74 72 69 umber num) (stri
4240: 6e 67 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a ng->number num).
4250: 09 20 20 20 20 28 69 66 20 6e 75 6d 20 31 20 30 . (if num 1 0
4260: 29 29 29 29 20 3b 3b 20 77 69 65 72 64 20 65 68 )))) ;; wierd eh
4270: 21 20 79 65 70 2c 20 23 66 3d 3e 30 20 23 74 3d ! yep, #f=>0 #t=
4280: 3e 31 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d >1 ..;;=========
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 3d 3d 3d 3d 0a 3b 3b =============.;;
42d0: 20 44 20 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d D B.;;=========
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 3d 3d 3d 3d 0a 0a 3b =============..;
4320: 3b 20 63 6f 6e 76 65 72 74 20 76 61 6c 75 65 73 ; convert values
4330: 20 74 6f 20 61 70 70 72 6f 70 72 69 61 74 65 20 to appropriate
4340: 73 74 72 69 6e 67 73 0a 3b 3b 0a 23 3b 28 64 65 strings.;;.#;(de
4350: 66 69 6e 65 20 28 73 3a 73 71 6c 70 61 72 61 6d fine (s:sqlparam
4360: 2d 76 61 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c -val->string val
4370: 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 6c ). (cond. ((l
4380: 69 73 74 3f 20 20 20 76 61 6c 29 28 73 74 72 69 ist? val)(stri
4390: 6e 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 79 6d ng-join (map sym
43a0: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
43b0: 20 22 2c 22 29 29 20 3b 3b 20 28 61 20 62 20 63 ",")) ;; (a b c
43c0: 29 20 3d 3e 20 61 2c 62 2c 63 0a 20 20 20 28 28 ) => a,b,c. ((
43d0: 73 74 72 69 6e 67 3f 20 76 61 6c 29 28 63 6f 6e string? val)(con
43e0: 63 20 22 27 22 20 28 64 62 69 3a 65 73 63 61 70 c "'" (dbi:escap
43f0: 65 2d 73 74 72 69 6e 67 20 76 61 6c 29 20 22 27 e-string val) "'
4400: 22 29 29 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f ")). ((number?
4410: 20 76 61 6c 29 28 6e 75 6d 62 65 72 2d 3e 73 74 val)(number->st
4420: 72 69 6e 67 20 76 61 6c 29 29 0a 20 20 20 28 28 ring val)). ((
4430: 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 28 64 62 69 symbol? val)(dbi
4440: 3a 65 73 63 61 70 65 2d 73 74 72 69 6e 67 20 28 :escape-string (
4450: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 symbol->string v
4460: 61 6c 29 29 29 0a 20 20 20 28 28 62 6f 6f 6c 65 al))). ((boole
4470: 61 6e 3f 20 76 61 6c 29 0a 20 20 20 20 28 69 66 an? val). (if
4480: 20 76 61 6c 20 22 54 52 55 45 22 20 22 46 41 4c val "TRUE" "FAL
4490: 53 45 22 29 29 20 20 3b 3b 20 73 68 6f 75 6c 64 SE")) ;; should
44a0: 20 74 68 69 73 20 62 65 20 22 54 52 55 45 22 20 this be "TRUE"
44b0: 6f 72 20 31 3f 0a 20 20 20 20 20 20 20 20 20 20 or 1?.
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44d0: 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 ;; should th
44e0: 69 73 20 62 65 20 22 46 41 4c 53 45 22 20 6f 72 is be "FALSE" or
44f0: 20 30 20 6f 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 0 or NULL?. (
4500: 65 6c 73 65 0a 20 20 20 20 28 65 72 72 3a 6c 6f else. (err:lo
4510: 67 20 22 73 71 6c 70 61 72 61 6d 3a 20 75 6e 6b g "sqlparam: unk
4520: 6e 6f 77 6e 20 74 79 70 65 20 66 6f 72 20 76 61 nown type for va
4530: 6c 75 65 3a 20 22 20 76 61 6c 29 0a 20 20 20 20 lue: " val).
4540: 22 22 29 29 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 "")))..;; (sqlpa
4550: 72 61 6d 20 22 49 4e 53 45 52 54 20 49 4e 54 4f ram "INSERT INTO
4560: 20 66 6f 6f 28 6e 61 6d 65 2c 61 67 65 29 20 56 foo(name,age) V
4570: 41 4c 55 45 53 28 3f 2c 3f 29 3b 22 20 22 62 6f ALUES(?,?);" "bo
4580: 62 22 20 32 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 b" 20).;; NB// 1
4590: 2e 20 76 61 6c 75 65 73 20 6f 6e 6c 79 21 21 20 . values only!!
45a0: 0a 3b 3b 20 20 20 20 20 20 32 2e 20 74 65 72 6d .;; 2. term
45b0: 69 6e 61 74 69 6e 67 20 73 65 6d 69 63 6f 6c 6f inating semicolo
45c0: 6e 20 72 65 71 75 69 72 65 64 20 28 75 73 65 64 n required (used
45d0: 20 61 73 20 70 61 72 74 20 6f 66 20 6c 6f 67 69 as part of logi
45e0: 63 29 0a 3b 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 c).;;.;; a=? 1 (
45f0: 6e 75 6d 62 65 72 29 20 3d 3e 20 61 3d 31 0a 3b number) => a=1.;
4600: 3b 20 61 3d 3f 20 31 20 28 73 74 72 69 6e 67 29 ; a=? 1 (string)
4610: 20 3d 3e 20 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f => a='1'.;; a=?
4620: 20 23 66 20 20 20 20 20 20 20 20 20 3d 3e 20 61 #f => a
4630: 3d 46 41 4c 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 =FALSE .;; a=? a
4640: 20 28 73 79 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 (symbol) => a=a
4650: 20 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 .;;.#;(define (
4660: 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
4670: 20 2e 20 61 72 67 73 29 0a 20 20 28 6c 65 74 2a . args). (let*
4680: 20 28 28 71 75 65 72 79 2d 70 61 72 74 73 20 28 ((query-parts (
4690: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 string-split que
46a0: 72 79 20 22 3f 22 29 29 0a 20 20 20 20 20 20 20 ry "?")).
46b0: 20 20 28 6e 75 6d 2d 70 61 72 74 73 20 20 20 20 (num-parts
46c0: 28 6c 65 6e 67 74 68 20 71 75 65 72 79 2d 70 61 (length query-pa
46d0: 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 rts)). (
46e0: 6e 75 6d 2d 61 72 67 73 20 20 20 20 28 6c 65 6e num-args (len
46f0: 67 74 68 20 61 72 67 73 29 29 29 0a 20 20 20 20 gth args))).
4700: 28 69 66 20 28 6e 6f 74 20 28 3d 20 28 2b 20 6e (if (not (= (+ n
4710: 75 6d 2d 61 72 67 73 20 31 29 20 6e 75 6d 2d 70 um-args 1) num-p
4720: 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 28 arts)). (
4730: 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 2c 20 err:log "ERROR,
4740: 73 71 6c 70 61 72 61 6d 3a 20 77 72 6f 6e 67 20 sqlparam: wrong
4750: 6e 75 6d 62 65 72 20 6f 66 20 61 72 67 75 6d 65 number of argume
4760: 6e 74 73 20 6f 72 20 6d 69 73 73 69 6e 67 20 73 nts or missing s
4770: 65 6d 69 63 6f 6c 6f 6e 2c 20 22 20 6e 75 6d 2d emicolon, " num-
4780: 61 72 67 73 20 22 20 66 6f 72 20 71 75 65 72 79 args " for query
4790: 20 22 20 71 75 65 72 79 29 0a 20 20 20 20 20 20 " query).
47a0: 20 20 28 69 66 20 28 3d 20 6e 75 6d 2d 61 72 67 (if (= num-arg
47b0: 73 20 30 29 20 71 75 65 72 79 0a 20 20 20 20 20 s 0) query.
47c0: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
47d0: 20 28 28 73 65 63 74 69 6f 6e 20 28 63 61 72 20 ((section (car
47e0: 71 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 query-parts)).
47f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4800: 20 20 20 20 20 28 74 61 69 6c 20 20 20 20 28 63 (tail (c
4810: 64 72 20 71 75 65 72 79 2d 70 61 72 74 73 29 29 dr query-parts))
4820: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4830: 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 (result
4840: 20 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 "").
4850: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 (arg
4860: 20 20 20 20 20 28 63 61 72 20 61 72 67 73 29 29 (car args))
4870: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4880: 20 20 20 20 20 20 20 20 28 61 72 67 74 61 69 6c (argtail
4890: 20 28 63 64 72 20 61 72 67 73 29 29 29 0a 20 20 (cdr args))).
48a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
48b0: 2a 20 28 28 76 61 6c 73 74 72 20 20 20 20 28 73 * ((valstr (s
48c0: 3a 73 71 6c 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 :sqlparam-val->s
48d0: 74 72 69 6e 67 20 61 72 67 29 29 0a 20 20 20 20 tring arg)).
48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48f0: 20 28 6e 65 77 72 65 73 75 6c 74 20 28 63 6f 6e (newresult (con
4900: 63 20 72 65 73 75 6c 74 20 73 65 63 74 69 6f 6e c result section
4910: 20 76 61 6c 73 74 72 29 29 29 0a 20 20 20 20 20 valstr))).
4920: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4930: 6e 75 6c 6c 3f 20 61 72 67 74 61 69 6c 29 20 3b null? argtail) ;
4940: 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 ; we are done.
4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4960: 20 20 28 63 6f 6e 63 20 6e 65 77 72 65 73 75 6c (conc newresul
4970: 74 20 28 63 61 72 20 74 61 69 6c 29 29 0a 20 20 t (car tail)).
4980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4990: 20 20 28 6c 6f 6f 70 0a 20 20 20 20 20 20 20 20 (loop.
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
49b0: 72 20 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 r tail).
49c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 (cd
49d0: 72 20 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 r tail).
49e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 77 new
49f0: 72 65 73 75 6c 74 0a 20 20 20 20 20 20 20 20 20 result.
4a00: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 (car
4a10: 20 61 72 67 74 61 69 6c 29 0a 20 20 20 20 20 20 argtail).
4a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4a30: 63 64 72 20 61 72 67 74 61 69 6c 29 29 29 29 29 cdr argtail)))))
4a40: 29 29 29 29 0a 0a 3b 3b 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 3d 3d 3d 3d 0a 3b ==============.;
4a90: 3b 20 4d 20 49 20 53 20 43 20 20 20 53 20 54 20 ; M I S C S T
4aa0: 52 20 49 20 4e 20 47 20 20 20 53 20 54 20 55 20 R I N G S T U
4ab0: 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F F.;;==========
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 3d 3d 3d 3d 0a 0a 28 64 ============..(d
4b00: 65 66 69 6e 65 20 28 73 3a 73 74 72 69 6e 67 2d efine (s:string-
4b10: 64 6f 77 6e 63 61 73 65 20 73 74 72 29 0a 20 20 downcase str).
4b20: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 73 74 72 (if (string? str
4b30: 29 0a 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d ). (string-
4b40: 74 72 61 6e 73 6c 61 74 65 20 73 74 72 20 22 41 translate str "A
4b50: 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 BCDEFGHIJKLMNOPQ
4b60: 52 53 54 55 56 57 58 59 5a 22 20 22 61 62 63 64 RSTUVWXYZ" "abcd
4b70: 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 efghijklmnopqrst
4b80: 75 76 77 78 79 7a 22 29 0a 20 20 20 20 20 20 73 uvwxyz"). s
4b90: 74 72 29 29 20 0a 0a 3b 3b 20 28 64 65 66 69 6e tr)) ..;; (defin
4ba0: 65 20 73 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d e session:valid-
4bb0: 63 68 61 72 73 20 22 61 62 63 64 65 66 67 68 69 chars "abcdefghi
4bc0: 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 jklmnopqrstuvwxy
4bd0: 7a 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f zABCDEFGHIJKLMNO
4be0: 50 51 52 53 54 55 56 57 58 59 5a 30 31 32 33 34 PQRSTUVWXYZ01234
4bf0: 35 36 37 38 39 22 29 0a 23 3b 28 64 65 66 69 6e 56789").#;(defin
4c00: 65 20 73 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d e session:valid-
4c10: 63 68 61 72 73 20 22 61 62 63 64 65 66 67 68 69 chars "abcdefghi
4c20: 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 jklmnopqrstuvwxy
4c30: 7a 30 31 32 33 34 35 36 37 38 39 22 29 20 3b 3b z0123456789") ;;
4c40: 20 63 6f 6f 6b 69 65 73 20 61 72 65 20 63 61 73 cookies are cas
4c50: 65 20 69 6e 73 65 6e 73 69 74 69 76 65 2e 0a 23 e insensitive..#
4c60: 3b 28 64 65 66 69 6e 65 20 73 65 73 73 69 6f 6e ;(define session
4c70: 3a 6e 75 6d 2d 76 61 6c 69 64 2d 63 68 61 72 73 :num-valid-chars
4c80: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
4c90: 73 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 session:valid-ch
4ca0: 61 72 73 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 ars))..#;(define
4cb0: 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 (session:get-nt
4cc0: 68 2d 63 68 61 72 20 6e 74 68 29 0a 20 20 28 73 h-char nth). (s
4cd0: 75 62 73 74 72 69 6e 67 20 73 65 73 73 69 6f 6e ubstring session
4ce0: 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 6e 74 68 :valid-chars nth
4cf0: 20 20 28 2b 20 6e 74 68 20 31 29 29 29 0a 0a 23 (+ nth 1)))..#
4d00: 3b 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f ;(define (sessio
4d10: 6e 3a 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 n:get-rand-char)
4d20: 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d . (session:get-
4d30: 6e 74 68 2d 63 68 61 72 20 28 72 61 6e 64 6f 6d nth-char (random
4d40: 20 73 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c session:num-val
4d50: 69 64 2d 63 68 61 72 73 29 29 29 0a 0a 23 3b 28 id-chars)))..#;(
4d60: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
4d70: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
4d80: 20 6c 65 6e 29 0a 20 20 28 6c 65 74 20 6c 6f 6f len). (let loo
4d90: 70 20 28 28 72 65 73 20 22 22 29 0a 20 20 20 20 p ((res "").
4da0: 20 20 20 20 20 20 20 20 20 28 6e 20 20 20 31 29 (n 1)
4db0: 29 0a 20 20 20 20 28 69 66 20 28 3e 20 6e 20 6c ). (if (> n l
4dc0: 65 6e 29 20 72 65 73 0a 20 20 20 20 20 20 20 20 en) res.
4dd0: 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 (loop (string-ap
4de0: 70 65 6e 64 20 72 65 73 20 28 73 65 73 73 69 6f pend res (sessio
4df0: 6e 3a 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 n:get-rand-char)
4e00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4e10: 28 2b 20 6e 20 31 29 29 29 29 29 0a 0a 3b 3b 20 (+ n 1)))))..;;
4e20: 6d 61 79 62 65 20 72 65 70 6c 61 63 65 20 61 62 maybe replace ab
4e30: 6f 76 65 20 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 ove make-rand-st
4e40: 72 69 6e 67 20 77 69 74 68 20 74 68 69 73 20 73 ring with this s
4e50: 6f 6d 65 64 61 79 3f 0a 3b 3b 0a 23 3b 28 64 65 omeday?.;;.#;(de
4e60: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
4e70: 6e 65 72 69 63 2d 6d 61 6b 65 2d 72 61 6e 64 2d neric-make-rand-
4e80: 73 74 72 69 6e 67 20 6c 65 6e 20 73 65 65 64 2d string len seed-
4e90: 73 74 72 69 6e 67 29 0a 20 20 28 6c 65 74 20 28 string). (let (
4ea0: 28 6e 75 6d 2d 63 68 61 72 73 20 28 73 74 72 69 (num-chars (stri
4eb0: 6e 67 2d 6c 65 6e 67 74 68 20 73 65 65 64 2d 73 ng-length seed-s
4ec0: 74 72 69 6e 67 29 29 29 0a 20 20 20 20 28 6c 65 tring))). (le
4ed0: 74 20 6c 6f 6f 70 20 28 28 72 65 73 20 22 22 29 t loop ((res "")
4ee0: 0a 09 20 20 20 20 20 20 20 28 6e 20 20 20 31 29 .. (n 1)
4ef0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 ). (let ((c
4f00: 68 61 72 2d 6e 75 6d 20 28 72 61 6e 64 6f 6d 20 har-num (random
4f10: 6e 75 6d 2d 63 68 61 72 73 29 29 29 0a 09 28 69 num-chars)))..(i
4f20: 66 20 28 3e 20 6e 20 6c 65 6e 29 20 72 65 73 0a f (> n len) res.
4f30: 09 20 20 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 . (loop (stri
4f40: 6e 67 2d 61 70 70 65 6e 64 20 72 65 73 20 28 73 ng-append res (s
4f50: 75 62 73 74 72 69 6e 67 20 73 65 65 64 2d 73 74 ubstring seed-st
4f60: 72 69 6e 67 20 63 68 61 72 2d 6e 75 6d 20 28 2b ring char-num (+
4f70: 20 63 68 61 72 2d 6e 75 6d 20 31 29 29 29 0a 09 char-num 1)))..
4f80: 09 20 20 28 2b 20 6e 20 31 29 29 29 29 29 29 29 . (+ n 1)))))))
4f90: 0a 0a 3b 3b 20 52 65 6c 79 20 6f 6e 20 63 72 79 ..;; Rely on cry
4fa0: 70 74 20 65 67 67 27 73 20 64 65 66 61 75 6c 74 pt egg's default
4fb0: 20 73 65 74 74 69 6e 67 73 20 62 65 69 6e 67 20 settings being
4fc0: 73 65 63 75 72 65 20 65 6e 6f 75 67 68 2c 20 61 secure enough, a
4fd0: 63 63 65 70 74 0a 3b 3b 20 62 61 63 6b 77 61 72 ccept.;; backwar
4fe0: 64 73 2d 63 6f 6d 70 61 74 69 62 6c 65 20 4f 70 ds-compatible Op
4ff0: 65 6e 53 53 4c 20 63 72 79 70 74 20 70 61 73 73 enSSL crypt pass
5000: 77 6f 72 64 73 20 74 6f 6f 2e 0a 3b 3b 0a 28 64 words too..;;.(d
5010: 65 66 69 6e 65 20 28 73 3a 63 72 79 70 74 2d 70 efine (s:crypt-p
5020: 61 73 73 77 64 20 70 77 20 73 29 0a 20 20 28 63 asswd pw s). (c
5030: 3a 63 72 79 70 74 20 70 77 20 28 6f 72 20 73 20 :crypt pw (or s
5040: 28 63 3a 63 72 79 70 74 2d 67 65 6e 73 61 6c 74 (c:crypt-gensalt
5050: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
5060: 3a 70 61 73 73 77 6f 72 64 2d 6d 61 74 63 68 3f :password-match?
5070: 20 70 61 73 73 77 6f 72 64 20 63 72 79 70 74 65 password crypte
5080: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 61 6c d). (let* ((sal
5090: 74 20 28 73 75 62 73 74 72 69 6e 67 20 63 72 79 t (substring cry
50a0: 70 74 65 64 20 30 20 32 29 29 0a 20 20 20 20 20 pted 0 2)).
50b0: 20 20 20 20 28 70 63 72 79 70 74 65 64 20 28 73 (pcrypted (s
50c0: 3a 63 72 79 70 74 2d 70 61 73 73 77 64 20 70 61 :crypt-passwd pa
50d0: 73 73 77 6f 72 64 20 73 61 6c 74 29 29 29 0a 20 ssword salt))).
50e0: 20 20 20 3b 3b 20 28 73 3a 6c 6f 67 20 22 49 4e ;; (s:log "IN
50f0: 46 4f 3a 20 70 63 72 79 70 74 65 64 3d 22 20 70 FO: pcrypted=" p
5100: 63 72 79 70 74 65 64 20 22 20 63 72 79 70 74 65 crypted " crypte
5110: 64 3d 22 20 63 72 79 70 74 65 64 29 0a 20 20 20 d=" crypted).
5120: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 70 (and (string? p
5130: 61 73 73 77 6f 72 64 29 0a 20 20 20 20 20 20 20 assword).
5140: 20 20 28 73 74 72 69 6e 67 3f 20 70 63 72 79 70 (string? pcryp
5150: 74 65 64 29 0a 20 20 20 20 20 20 20 20 20 28 73 ted). (s
5160: 74 72 69 6e 67 3d 3f 20 70 63 72 79 70 74 65 64 tring=? pcrypted
5170: 20 63 72 79 70 74 65 64 29 29 29 29 0a 0a 3b 3b crypted))))..;;
5180: 20 28 72 65 61 64 2d 6c 69 6e 65 20 28 6f 70 65 (read-line (ope
5190: 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 22 65 63 n-input-pipe "ec
51a0: 68 6f 20 66 6f 6f 20 7c 20 6d 6b 70 61 73 73 77 ho foo | mkpassw
51b0: 64 20 2d 53 20 61 62 20 2d 73 22 29 29 0a 0a 3b d -S ab -s"))..;
51c0: 3b 20 42 55 47 3a 20 54 68 65 20 72 65 67 65 78 ; BUG: The regex
51d0: 20 69 6d 70 6c 65 6d 65 6e 74 73 20 61 20 72 75 implements a ru
51e0: 6c 65 2c 20 62 75 74 20 77 68 61 74 20 72 75 6c le, but what rul
51f0: 65 3f 20 41 48 21 20 75 73 61 7a 74 65 6d 70 65 e? AH! usaztempe
5200: 2c 20 67 65 74 20 72 69 64 20 6f 66 20 74 68 69 , get rid of thi
5210: 73 3f 20 4e 6f 2c 20 74 68 69 73 20 61 6c 73 6f s? No, this also
5220: 20 6c 6f 6f 6b 73 20 66 6f 72 20 26 6b 65 79 3d looks for &key=
5230: 76 61 6c 75 65 20 2e 2e 2e 0a 28 64 65 66 69 6e value ....(defin
5240: 65 20 28 73 3a 76 61 6c 69 64 61 74 65 2d 75 72 e (s:validate-ur
5250: 69 29 0a 20 20 28 6c 65 74 20 28 28 75 72 69 20 i). (let ((uri
5260: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
5270: 2d 76 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 -variable "REQUE
5280: 53 54 5f 55 52 49 22 29 29 0a 09 28 71 72 73 20 ST_URI"))..(qrs
5290: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
52a0: 2d 76 61 72 69 61 62 6c 65 20 22 51 55 45 52 59 -variable "QUERY
52b0: 5f 53 54 52 49 4e 47 22 29 29 29 0a 20 20 20 20 _STRING"))).
52c0: 28 69 66 20 28 6e 6f 74 20 75 72 69 29 0a 09 28 (if (not uri)..(
52d0: 73 65 74 21 20 75 72 69 20 71 72 73 29 29 0a 20 set! uri qrs)).
52e0: 20 20 20 28 69 66 20 75 72 69 0a 09 28 73 74 72 (if uri..(str
52f0: 69 6e 67 2d 6d 61 74 63 68 20 0a 09 20 28 72 65 ing-match .. (re
5300: 67 65 78 70 20 22 5e 28 2f 5b 61 2d 7a 5c 5c 2d gexp "^(/[a-z\\-
5310: 5c 5c 2e 5f 3a 30 2d 39 5d 2a 29 2a 28 7c 5c 5c \\._:0-9]*)*(|\\
5320: 3f 28 5b 41 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d ?([A-Za-z0-9_\\-
5330: 5c 5c 2b 5d 2b 3d 5b 41 2d 5a 61 2d 7a 30 2d 39 \\+]+=[A-Za-z0-9
5340: 5f 5c 5c 2d 5c 5c 2e 5c 5c 2b 5d 2a 26 7b 30 2c _\\-\\.\\+]*&{0,
5350: 31 7d 29 2a 29 24 22 29 20 75 72 69 29 0a 09 28 1})*)$") uri)..(
5360: 62 65 67 69 6e 0a 09 20 20 22 52 45 51 55 45 53 begin.. "REQUES
5370: 54 20 55 52 49 20 4e 4f 54 20 41 56 41 49 4c 41 T URI NOT AVAILA
5380: 42 4c 45 21 22 0a 09 20 20 28 6c 65 74 20 28 28 BLE!".. (let ((
5390: 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 p (open-input-pi
53a0: 70 65 20 22 65 6e 76 22 29 29 29 0a 09 20 20 20 pe "env")))..
53b0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 20 28 (let loop ((l (
53c0: 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 09 read-line p))...
53d0: 20 20 20 20 20 20 20 28 72 65 73 20 27 28 29 29 (res '())
53e0: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 65 6f ).. (if (eo
53f0: 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 0a 09 09 20 f-object? l)...
5400: 20 72 65 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 res... (loop (
5410: 72 65 61 64 2d 6c 69 6e 65 20 70 29 28 63 6f 6e read-line p)(con
5420: 73 20 28 6c 69 73 74 20 6c 20 22 3c 42 52 3e 22 s (list l "<BR>"
5430: 29 20 72 65 73 29 29 29 29 29 0a 09 20 20 23 74 ) res))))).. #t
5440: 29 29 29 29 0a 0a 3b 3b 20 6d 6f 76 65 64 20 74 ))))..;; moved t
5450: 6f 20 6d 69 73 63 2d 73 74 6d 6c 0a 3b 3b 0a 3b o misc-stml.;;.;
5460: 3b 20 61 6e 79 74 68 69 6e 67 20 65 78 63 65 70 ; anything excep
5470: 74 20 61 20 6c 69 73 74 20 69 73 20 63 6f 6e 76 t a list is conv
5480: 65 72 74 65 64 20 74 6f 20 61 20 73 74 72 69 6e erted to a strin
5490: 67 21 21 21 0a 23 3b 28 64 65 66 69 6e 65 20 28 g!!!.#;(define (
54a0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
54b0: 6c 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 l). (cond. ((
54c0: 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 76 61 6c string? val) val
54d0: 29 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 ). ((number? v
54e0: 61 6c 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 al) (number->str
54f0: 69 6e 67 20 76 61 6c 29 29 0a 20 20 20 28 28 73 ing val)). ((s
5500: 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 28 73 79 6d ymbol? val) (sym
5510: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
5520: 29 0a 20 20 20 28 28 65 71 3f 20 76 61 6c 20 23 ). ((eq? val #
5530: 66 29 20 22 22 29 0a 20 20 20 28 28 65 71 3f 20 f) ""). ((eq?
5540: 76 61 6c 20 23 74 29 20 22 54 52 55 45 22 29 0a val #t) "TRUE").
5550: 20 20 20 28 28 6c 69 73 74 3f 20 76 61 6c 29 20 ((list? val)
5560: 76 61 6c 29 0a 20 20 20 28 65 6c 73 65 20 0a 20 val). (else .
5570: 20 20 20 28 6c 65 74 20 28 28 6f 73 74 72 20 28 (let ((ostr (
5580: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 open-output-stri
5590: 6e 67 29 29 29 0a 20 20 20 20 20 20 28 77 69 74 ng))). (wit
55a0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
55b0: 20 6f 73 74 72 0a 09 28 6c 61 6d 62 64 61 20 28 ostr..(lambda (
55c0: 29 0a 09 20 20 28 64 69 73 70 6c 61 79 20 76 61 ).. (display va
55d0: 6c 29 29 29 0a 20 20 20 20 20 20 28 67 65 74 2d l))). (get-
55e0: 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 20 6f 73 output-string os
55f0: 74 72 29 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 tr)))))..#;(defi
5600: 6e 65 20 28 73 3a 61 6e 79 2d 3e 6e 75 6d 62 65 ne (s:any->numbe
5610: 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 0a 20 r val). (cond.
5620: 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 ((number? val)
5630: 20 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 val). ((stri
5640: 6e 67 3f 20 76 61 6c 29 20 20 28 73 74 72 69 6e ng? val) (strin
5650: 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a g->number val)).
5660: 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c ((symbol? val
5670: 29 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ) (string->numb
5680: 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 er (symbol->stri
5690: 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 65 6c ng val))). (el
56a0: 73 65 20 20 20 20 20 23 66 29 29 29 0a 0a 3b 3b se #f)))..;;
56b0: 20 4e 42 2f 2f 20 74 68 69 73 20 69 73 20 2a 69 NB// this is *i
56c0: 6c 6c 65 67 61 6c 2a 20 70 67 69 6e 74 0a 28 64 llegal* pgint.(d
56d0: 65 66 69 6e 65 20 28 73 3a 69 6c 6c 65 67 61 6c efine (s:illegal
56e0: 2d 70 67 69 6e 74 20 76 61 6c 29 0a 20 20 28 63 -pgint val). (c
56f0: 6f 6e 64 0a 20 20 20 28 28 3e 20 76 61 6c 20 32 ond. ((> val 2
5700: 31 34 37 34 38 33 36 34 37 29 20 31 29 0a 20 20 147483647) 1).
5710: 20 28 28 3c 20 76 61 6c 20 2d 32 31 34 37 34 38 ((< val -214748
5720: 33 36 34 38 29 20 2d 31 29 0a 20 20 20 28 65 6c 3648) -1). (el
5730: 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e se #f)))..(defin
5740: 65 20 28 73 3a 61 6e 79 2d 3e 70 67 69 6e 74 20 e (s:any->pgint
5750: 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 28 6e 20 val). (let ((n
5760: 28 73 3a 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 (s:any->number v
5770: 61 6c 29 29 29 0a 20 20 20 20 28 69 66 20 6e 0a al))). (if n.
5780: 09 28 69 66 20 28 73 3a 69 6c 6c 65 67 61 6c 2d .(if (s:illegal-
5790: 70 67 69 6e 74 20 6e 29 0a 09 20 20 20 20 23 66 pgint n).. #f
57a0: 0a 09 20 20 20 20 6e 29 0a 09 6e 29 29 29 0a 0a .. n)..n)))..
57b0: 3b 3b 20 73 74 72 69 6e 67 20 69 73 20 61 20 73 ;; string is a s
57c0: 74 72 69 6e 67 20 61 6e 64 20 6e 6f 6e 2d 7a 65 tring and non-ze
57d0: 72 6f 20 6c 65 6e 67 74 68 0a 28 64 65 66 69 6e ro length.(defin
57e0: 65 20 28 6d 69 73 63 3a 6e 6f 6e 2d 7a 65 72 6f e (misc:non-zero
57f0: 2d 73 74 72 69 6e 67 20 73 74 72 29 0a 20 20 28 -string str). (
5800: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
5810: 20 73 74 72 29 0a 20 20 20 20 20 20 20 20 20 20 str).
5820: 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
5830: 74 68 20 73 74 72 29 20 30 29 29 0a 20 20 20 20 th str) 0)).
5840: 20 20 73 74 72 0a 20 20 20 20 20 20 23 66 29 29 str. #f))
5850: 0a 0a 3b 3b 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 3d 3d 3d 3d 0a 3b 3b 20 68 74 ==========.;; ht
58a0: 6d 6c 2d 66 69 6c 74 65 72 0a 3b 3b 3d 3d 3d 3d ml-filter.;;====
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 3d 3d ================
58f0: 3d 3d 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 70 ==.(define (s:sp
5900: 6c 69 74 2d 73 74 72 69 6e 67 20 73 74 72 6e 67 lit-string strng
5910: 20 64 65 6c 69 6d 29 0a 20 20 28 69 66 20 28 65 delim). (if (e
5920: 71 3f 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 q? (string-lengt
5930: 68 20 73 74 72 6e 67 29 20 30 29 20 28 6c 69 73 h strng) 0) (lis
5940: 74 20 73 74 72 6e 67 29 0a 20 20 20 20 20 20 28 t strng). (
5950: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
5960: 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 31 20 28 (make-string 1 (
5970: 63 61 72 20 28 73 74 72 69 6e 67 2d 3e 6c 69 73 car (string->lis
5980: 74 20 73 74 72 6e 67 29 29 29 29 0a 09 09 20 28 t strng))))... (
5990: 74 61 69 6c 20 28 63 64 72 20 28 73 74 72 69 6e tail (cdr (strin
59a0: 67 2d 3e 6c 69 73 74 20 73 74 72 6e 67 29 29 29 g->list strng)))
59b0: 0a 09 09 20 28 64 65 73 74 20 27 28 29 29 0a 09 ... (dest '())..
59c0: 09 20 28 74 65 6d 70 20 22 22 29 29 0a 09 28 63 . (temp ""))..(c
59d0: 6f 6e 64 20 28 28 65 71 75 61 6c 3f 20 68 65 61 ond ((equal? hea
59e0: 64 20 64 65 6c 69 6d 29 0a 09 20 20 20 20 20 20 d delim)..
59f0: 20 28 73 65 74 21 20 64 65 73 74 20 28 61 70 70 (set! dest (app
5a00: 65 6e 64 20 64 65 73 74 20 28 6c 69 73 74 20 74 end dest (list t
5a10: 65 6d 70 29 29 29 0a 09 20 20 20 20 20 20 20 28 emp))).. (
5a20: 73 65 74 21 20 74 65 6d 70 20 22 22 29 29 0a 09 set! temp ""))..
5a30: 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 68 65 ((null? he
5a40: 61 64 29 20 0a 09 20 20 20 20 20 20 20 28 73 65 ad) .. (se
5a50: 74 21 20 64 65 73 74 20 28 61 70 70 65 6e 64 20 t! dest (append
5a60: 64 65 73 74 20 28 6c 69 73 74 20 74 65 6d 70 29 dest (list temp)
5a70: 29 29 29 0a 09 20 20 20 20 20 20 28 65 6c 73 65 ))).. (else
5a80: 20 28 73 65 74 21 20 74 65 6d 70 20 28 73 74 72 (set! temp (str
5a90: 69 6e 67 2d 61 70 70 65 6e 64 20 74 65 6d 70 20 ing-append temp
5aa0: 68 65 61 64 29 29 29 29 20 3b 3b 20 65 6e 64 20 head)))) ;; end
5ab0: 69 66 0a 09 28 63 6f 6e 64 20 28 28 6e 75 6c 6c if..(cond ((null
5ac0: 3f 20 74 61 69 6c 29 0a 09 20 20 20 20 20 20 20 ? tail)..
5ad0: 28 73 65 74 21 20 64 65 73 74 20 28 61 70 70 65 (set! dest (appe
5ae0: 6e 64 20 64 65 73 74 20 28 6c 69 73 74 20 74 65 nd dest (list te
5af0: 6d 70 29 29 29 20 64 65 73 74 29 0a 09 20 20 20 mp))) dest)..
5b00: 20 20 20 28 65 6c 73 65 20 28 6c 6f 6f 70 20 28 (else (loop (
5b10: 6d 61 6b 65 2d 73 74 72 69 6e 67 20 31 20 28 63 make-string 1 (c
5b20: 61 72 20 74 61 69 6c 29 29 20 28 63 64 72 20 74 ar tail)) (cdr t
5b30: 61 69 6c 29 20 64 65 73 74 20 74 65 6d 70 29 29 ail) dest temp))
5b40: 29 29 29 29 0a 0a 3b 3b 20 61 6c 6c 6f 77 65 64 ))))..;; allowed
5b50: 2d 74 61 67 73 20 69 73 20 61 20 6c 69 73 74 20 -tags is a list
5b60: 6f 66 20 74 61 67 73 20 61 73 20 73 79 6d 62 6f of tags as symbo
5b70: 6c 73 3a 0a 3b 3b 20 20 20 27 28 61 20 62 20 63 ls:.;; '(a b c
5b80: 65 6e 74 65 72 20 70 20 61 29 0a 3b 3b 20 70 61 enter p a).;; pa
5b90: 72 73 69 6e 67 20 69 73 20 73 69 6d 70 6c 69 73 rsing is simplis
5ba0: 74 69 63 20 61 6e 64 20 74 68 65 20 72 65 73 70 tic and the resp
5bb0: 6f 6e 73 65 20 63 6f 6e 73 65 72 76 61 74 69 76 onse conservativ
5bc0: 65 0a 3b 3b 20 69 66 20 61 20 3c 20 69 73 20 66 e.;; if a < is f
5bd0: 6f 75 6e 64 20 77 69 74 68 6f 75 74 20 74 68 65 ound without the
5be0: 20 74 61 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 tag and closing
5bf0: 20 3e 20 74 68 65 6e 0a 3b 3b 20 74 68 65 20 3c > then.;; the <
5c00: 20 6f 72 20 3e 20 69 73 20 72 65 70 6c 61 63 65 or > is replace
5c10: 64 20 77 69 74 68 20 26 6c 74 3b 20 6f 72 20 26 d with < or &
5c20: 67 74 3b 20 77 69 74 68 6f 75 74 20 0a 3b 3b 20 gt; without .;;
5c30: 65 76 65 6e 20 74 72 79 69 6e 67 20 68 61 72 64 even trying hard
5c40: 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 69 to figure out i
5c50: 66 20 74 68 65 72 65 20 69 73 20 61 20 6c 65 67 f there is a leg
5c60: 69 74 20 74 61 67 20 0a 3b 3b 20 62 75 72 69 65 it tag .;; burie
5c70: 64 20 69 6e 20 74 68 65 20 74 65 78 74 20 73 6f d in the text so
5c80: 6d 65 77 68 65 72 65 2e 0a 3b 3b 20 61 20 6c 69 mewhere..;; a li
5c90: 73 74 20 6f 66 20 73 74 72 69 6e 67 73 20 69 73 st of strings is
5ca0: 20 72 65 74 75 72 6e 65 64 2e 0a 3b 3b 0a 3b 3b returned..;;.;;
5cb0: 20 4e 4f 54 45 53 0a 3b 3b 20 31 2e 20 63 61 73 NOTES.;; 1. cas
5cc0: 65 20 69 73 20 69 6d 70 6f 72 74 61 6e 74 20 69 e is important i
5cd0: 6e 20 74 68 65 20 61 6c 6c 6f 77 65 64 2d 74 61 n the allowed-ta
5ce0: 67 73 20 6c 69 73 74 21 0a 3b 3b 20 32 2e 20 6f gs list!.;; 2. o
5cf0: 6e 6c 79 20 22 73 6f 6c 69 64 22 20 74 61 67 73 nly "solid" tags
5d00: 20 61 72 65 20 73 75 70 70 6f 72 74 65 64 20 69 are supported i
5d10: 2e 65 2e 20 3c 61 20 68 72 65 66 3d 22 66 6f 6f .e. <a href="foo
5d20: 22 3e 20 77 69 6c 6c 20 6e 6f 74 20 77 6f 72 6b "> will not work
5d30: 3f 0a 3b 3b 0a 0a 3b 3b 20 28 73 3a 63 67 69 2d ?.;;..;; (s:cgi-
5d40: 6f 75 74 20 28 65 76 61 6c 20 28 73 3a 6f 75 74 out (eval (s:out
5d50: 70 75 74 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 put (s:html-filt
5d60: 65 72 20 22 68 65 6c 6c 6f 3c 62 3e 67 6f 6f 64 er "hello<b>good
5d70: 62 79 65 3c 2f 62 3e 3c 62 3e 20 65 68 22 20 27 bye</b><b> eh" '
5d80: 28 61 20 62 20 69 29 29 29 29 0a 0a 3b 3b 20 73 (a b i))))..;; s
5d90: 74 72 61 74 65 67 79 0a 3b 3b 20 31 2e 20 63 6f trategy.;; 1. co
5da0: 6e 76 65 72 74 20 5c 6e 20 74 6f 20 3c 6c 69 6e nvert \n to <lin
5db0: 65 66 65 65 64 3e 0a 3b 3b 20 32 2e 20 53 70 6c efeed>.;; 2. Spl
5dc0: 69 74 20 6f 6e 20 22 3c 22 0a 3b 3b 20 33 2e 20 it on "<".;; 3.
5dd0: 53 70 6c 69 74 20 6f 6e 20 22 3e 22 0a 3b 3b 20 Split on ">".;;
5de0: 34 2e 20 46 69 78 0a 28 64 65 66 69 6e 65 20 28 4. Fix.(define (
5df0: 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 20 69 6e s:html-filter in
5e00: 70 75 74 2d 74 65 78 74 20 61 6c 6c 6f 77 65 64 put-text allowed
5e10: 2d 74 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 -tags). (let* (
5e20: 28 74 6f 6b 73 20 20 20 28 73 3a 73 74 72 2d 3e (toks (s:str->
5e30: 74 6f 6b 73 20 69 6e 70 75 74 2d 74 65 78 74 29 toks input-text)
5e40: 29 0a 09 20 28 74 6d 70 20 20 20 20 28 73 3a 74 ).. (tmp (s:t
5e50: 6f 6b 73 2d 3e 73 74 6d 6c 20 27 28 73 3a 6e 75 oks->stml '(s:nu
5e60: 6c 6c 29 20 23 66 20 74 6f 6b 73 20 61 6c 6c 6f ll) #f toks allo
5e70: 77 65 64 2d 74 61 67 73 29 29 0a 09 20 28 72 65 wed-tags)).. (re
5e80: 73 20 20 20 20 28 63 61 72 20 74 6d 70 29 29 0a s (car tmp)).
5e90: 09 20 28 6e 78 74 74 61 67 20 28 63 61 64 72 20 . (nxttag (cadr
5ea0: 74 6d 70 29 29 0a 09 20 28 72 65 6d 20 20 20 20 tmp)).. (rem
5eb0: 28 63 61 64 64 72 20 74 6d 70 29 29 29 0a 20 20 (caddr tmp))).
5ec0: 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 res))..(define
5ed0: 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d (s:html-filter-
5ee0: 3e 73 74 72 69 6e 67 20 69 6e 70 75 74 2d 74 65 >string input-te
5ef0: 78 74 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 xt allowed-tags)
5f00: 0a 20 20 28 6c 65 74 20 28 28 6f 73 74 72 20 28 . (let ((ostr (
5f10: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 open-output-stri
5f20: 6e 67 29 29 29 0a 20 20 20 20 3b 3b 3b 20 28 73 ng))). ;;; (s
5f30: 3a 6f 75 74 70 75 74 2d 6e 65 77 20 6f 73 74 72 :output-new ostr
5f40: 20 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 20 (s:html-filter
5f50: 69 6e 70 75 74 2d 74 65 78 74 20 61 6c 6c 6f 77 input-text allow
5f60: 65 64 2d 74 61 67 73 29 29 0a 20 20 20 20 28 73 ed-tags)). (s
5f70: 3a 6f 75 74 70 75 74 2d 6e 65 77 20 6f 73 74 72 :output-new ostr
5f80: 20 28 63 61 72 20 28 65 76 61 6c 20 28 73 3a 68 (car (eval (s:h
5f90: 74 6d 6c 2d 66 69 6c 74 65 72 20 69 6e 70 75 74 tml-filter input
5fa0: 2d 74 65 78 74 20 61 6c 6c 6f 77 65 64 2d 74 61 -text allowed-ta
5fb0: 67 73 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 gs)))). (stri
5fc0: 6e 67 2d 63 68 6f 6d 70 20 28 67 65 74 2d 6f 75 ng-chomp (get-ou
5fd0: 74 70 75 74 2d 73 74 72 69 6e 67 20 6f 73 74 72 tput-string ostr
5fe0: 29 29 29 29 20 3b 3b 20 64 6f 6e 27 74 20 6e 65 )))) ;; don't ne
5ff0: 65 64 20 74 68 65 20 6c 69 6e 65 66 65 65 64 2c ed the linefeed,
6000: 20 63 6f 75 6c 64 20 73 74 6f 70 20 61 64 64 69 could stop addi
6010: 6e 67 20 69 74 20 2e 2e 2e 0a 09 0a 3b 3b 20 20 ng it ......;;
6020: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 (if (null? re
6030: 6d 29 0a 3b 3b 20 09 72 65 73 20 27 28 29 29 0a m).;; .res '()).
6040: 3b 3b 20 09 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d ;; .(s:toks->stm
6050: 6c 20 28 69 66 20 28 6c 69 73 74 3f 20 72 65 73 l (if (list? res
6060: 29 20 72 65 73 20 27 28 29 29 20 23 66 20 72 65 ) res '()) #f re
6070: 6d 20 61 6c 6c 6f 77 65 64 2d 74 61 67 73 29 29 m allowed-tags))
6080: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 ))..(define (s:s
6090: 74 72 2d 3e 74 6f 6b 73 20 73 74 72 29 0a 20 20 tr->toks str).
60a0: 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d (apply append (m
60b0: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 6f 6b 29 ap (lambda (tok)
60c0: 0a 09 09 20 20 20 20 20 20 20 28 69 6e 74 65 72 ... (inter
60d0: 73 70 65 72 73 65 20 28 73 3a 73 70 6c 69 74 2d sperse (s:split-
60e0: 73 74 72 69 6e 67 20 74 6f 6b 20 22 3e 22 29 20 string tok ">")
60f0: 22 3e 22 29 29 20 0a 09 09 20 20 20 20 20 28 69 ">")) ... (i
6100: 6e 74 65 72 73 70 65 72 73 65 20 28 73 3a 73 70 ntersperse (s:sp
6110: 6c 69 74 2d 73 74 72 69 6e 67 20 73 74 72 20 22 lit-string str "
6120: 3c 22 29 20 22 3c 22 29 29 29 29 0a 0a 28 64 65 <") "<"))))..(de
6130: 66 69 6e 65 20 28 73 3a 74 61 67 2d 3e 73 74 6d fine (s:tag->stm
6140: 6c 20 74 61 67 29 0a 20 20 28 73 74 72 69 6e 67 l tag). (string
6150: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
6160: 2d 61 70 70 65 6e 64 20 22 73 3a 22 20 28 73 79 -append "s:" (sy
6170: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 74 61 67 mbol->string tag
6180: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
6190: 73 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 72 65 73 s:toks->stml res
61a0: 20 74 61 67 20 72 65 6d 20 61 6c 6c 6f 77 65 64 tag rem allowed
61b0: 29 0a 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 ). ;; (print "t
61c0: 61 67 3a 20 22 20 74 61 67 20 22 20 72 65 6d 3a ag: " tag " rem:
61d0: 20 22 20 72 65 6d 29 0a 20 20 28 69 66 20 28 6e " rem). (if (n
61e0: 75 6c 6c 3f 20 72 65 6d 29 0a 20 20 20 20 20 20 ull? rem).
61f0: 28 6c 69 73 74 20 28 61 70 70 65 6e 64 20 72 65 (list (append re
6200: 73 20 28 69 66 20 74 61 67 0a 09 09 09 20 20 20 s (if tag....
6210: 20 28 6c 69 73 74 20 28 73 3a 74 61 67 2d 3e 73 (list (s:tag->s
6220: 74 6d 6c 20 74 61 67 29 29 0a 09 09 09 09 27 28 tml tag)).....'(
6230: 29 29 29 20 23 66 20 27 28 29 20 61 6c 6c 6f 77 ))) #f '() allow
6240: 65 64 29 20 3b 3b 20 74 68 65 20 63 61 73 65 20 ed) ;; the case
6250: 6f 66 20 61 20 6c 6f 6e 65 20 74 61 67 20 0a 20 of a lone tag .
6260: 20 20 20 20 20 3b 3b 20 68 61 6e 64 6c 65 20 61 ;; handle a
6270: 20 73 74 61 72 74 69 6e 67 20 74 61 67 0a 20 20 starting tag.
6280: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 6d 70 20 (let* ((tmp
6290: 20 20 20 20 20 20 28 73 3a 75 70 74 6f 2d 74 61 (s:upto-ta
62a0: 67 20 72 65 6d 20 61 6c 6c 6f 77 65 64 29 29 0a g rem allowed)).
62b0: 09 20 20 20 20 20 28 74 78 74 20 20 20 20 20 20 . (txt
62c0: 20 28 63 61 72 20 74 6d 70 29 29 20 20 20 20 20 (car tmp))
62d0: 20 3b 3b 20 74 68 69 73 20 74 78 74 20 67 6f 65 ;; this txt goe
62e0: 73 20 77 69 74 68 20 74 61 67 21 21 21 0a 09 20 s with tag!!!..
62f0: 20 20 20 20 28 6e 65 78 74 74 61 67 20 20 20 28 (nexttag (
6300: 63 61 64 72 20 74 6d 70 29 29 20 20 20 20 20 3b cadr tmp)) ;
6310: 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 4e 45 ; this is the NE
6320: 58 54 20 44 41 4d 4e 20 74 61 67 21 0a 09 20 20 XT DAMN tag!..
6330: 20 20 20 28 62 65 67 69 6e 2d 74 61 67 20 28 63 (begin-tag (c
6340: 61 64 64 72 20 74 6d 70 29 29 0a 09 20 20 20 20 addr tmp))..
6350: 20 28 6e 65 77 72 65 6d 20 20 20 20 28 63 61 64 (newrem (cad
6360: 64 64 72 20 74 6d 70 29 29 29 0a 09 3b 3b 20 28 ddr tmp)))..;; (
6370: 70 72 69 6e 74 20 22 74 78 74 3a 20 20 20 20 20 print "txt:
6380: 20 20 20 22 20 74 78 74 20 22 5c 6e 6e 65 78 74 " txt "\nnext
6390: 74 61 67 3a 20 20 20 20 22 20 6e 65 78 74 74 61 tag: " nextta
63a0: 67 20 22 5c 6e 62 65 67 69 6e 2d 74 61 67 3a 20 g "\nbegin-tag:
63b0: 20 22 20 62 65 67 69 6e 2d 74 61 67 20 22 5c 6e " begin-tag "\n
63c0: 6e 65 77 72 65 6d 3a 20 20 20 20 20 22 20 6e 65 newrem: " ne
63d0: 77 72 65 6d 20 22 5c 6e 72 65 73 3a 20 20 20 20 wrem "\nres:
63e0: 20 20 20 20 22 20 72 65 73 20 22 5c 6e 22 29 0a " res "\n").
63f0: 09 28 69 66 20 62 65 67 69 6e 2d 74 61 67 20 3b .(if begin-tag ;
6400: 3b 20 6e 65 73 74 20 74 68 65 20 66 6f 6c 6c 6f ; nest the follo
6410: 77 69 6e 67 20 73 74 75 66 66 0a 09 20 20 20 20 wing stuff..
6420: 28 6c 65 74 2a 20 28 28 63 68 69 6c 64 64 61 74 (let* ((childdat
6430: 20 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d 6c 20 27 (s:toks->stml '
6440: 28 29 20 6e 65 78 74 74 61 67 20 6e 65 77 72 65 () nexttag newre
6450: 6d 20 61 6c 6c 6f 77 65 64 29 29 0a 09 09 20 20 m allowed))...
6460: 20 28 63 68 69 6c 64 20 20 20 20 28 63 61 72 20 (child (car
6470: 63 68 69 6c 64 64 61 74 29 29 0a 09 09 20 20 20 childdat))...
6480: 28 6e 65 77 74 61 67 20 20 20 28 63 61 64 72 20 (newtag (cadr
6490: 63 68 69 6c 64 64 61 74 29 29 0a 09 09 20 20 20 childdat))...
64a0: 28 6e 65 77 72 65 6d 32 20 20 28 63 61 64 64 72 (newrem2 (caddr
64b0: 20 63 68 69 6c 64 64 61 74 29 29 0a 09 09 20 20 childdat))...
64c0: 20 28 61 6c 6c 6f 77 65 64 20 20 28 63 61 64 64 (allowed (cadd
64d0: 64 72 20 63 68 69 6c 64 64 61 74 29 29 29 20 3b dr childdat))) ;
64e0: 3b 20 79 61 2c 20 69 74 20 73 68 6f 75 6c 64 6e ; ya, it shouldn
64f0: 27 74 20 68 61 76 65 20 63 68 61 6e 67 65 64 0a 't have changed.
6500: 09 20 20 20 20 20 20 28 69 66 20 74 61 67 20 0a . (if tag .
6510: 09 09 20 20 28 73 3a 74 6f 6b 73 2d 3e 73 74 6d .. (s:toks->stm
6520: 6c 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c l (append res (l
6530: 69 73 74 20 28 61 70 70 65 6e 64 20 28 6c 69 73 ist (append (lis
6540: 74 20 28 73 3a 74 61 67 2d 3e 73 74 6d 6c 20 74 t (s:tag->stml t
6550: 61 67 29 29 20 63 68 69 6c 64 20 28 6c 69 73 74 ag)) child (list
6560: 20 74 78 74 29 29 29 29 0a 09 09 09 09 6e 65 77 txt)))).....new
6570: 74 61 67 20 6e 65 77 72 65 6d 32 20 61 6c 6c 6f tag newrem2 allo
6580: 77 65 64 29 0a 09 09 20 20 28 73 3a 74 6f 6b 73 wed)... (s:toks
6590: 2d 3e 73 74 6d 6c 20 28 61 70 70 65 6e 64 20 72 ->stml (append r
65a0: 65 73 20 28 6c 69 73 74 20 74 78 74 29 20 63 68 es (list txt) ch
65b0: 69 6c 64 29 0a 09 09 09 09 6e 65 77 74 61 67 20 ild).....newtag
65c0: 6e 65 77 72 65 6d 32 20 61 6c 6c 6f 77 65 64 29 newrem2 allowed)
65d0: 29 29 0a 09 20 20 20 20 3b 3b 20 69 74 20 6d 75 )).. ;; it mu
65e0: 73 74 20 68 61 76 65 20 62 65 65 6e 20 61 6e 20 st have been an
65f0: 65 6e 64 20 74 61 67 0a 09 20 20 20 20 28 6c 69 end tag.. (li
6600: 73 74 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 st (append res (
6610: 6c 69 73 74 20 0a 09 09 09 20 20 20 20 20 20 20 list ....
6620: 28 69 66 20 74 61 67 0a 09 09 09 09 20 20 20 28 (if tag..... (
6630: 6c 69 73 74 20 28 73 3a 74 61 67 2d 3e 73 74 6d list (s:tag->stm
6640: 6c 20 74 61 67 29 20 74 78 74 29 0a 09 09 09 09 l tag) txt).....
6650: 20 20 20 74 78 74 29 29 29 0a 09 09 20 20 23 66 txt)))... #f
6660: 0a 09 09 20 20 6e 65 77 72 65 6d 0a 09 09 20 20 ... newrem...
6670: 61 6c 6c 6f 77 65 64 29 29 29 29 29 0a 0a 0a 3b allowed)))))...;
6680: 3b 20 22 3c 22 20 22 62 22 20 22 3e 22 20 20 3d ; "<" "b" ">" =
6690: 3e 20 22 3c 62 3e 22 0a 3b 3b 20 22 3c 22 0a 3b > "<b>".;; "<".;
66a0: 3b 20 28 64 65 66 69 6e 65 20 28 73 3a 72 65 62 ; (define (s:reb
66b0: 75 69 6c 64 2d 74 61 67 73 20 69 6e 70 75 74 2d uild-tags input-
66c0: 6c 69 73 74 29 0a 0a 3b 3b 20 28 22 62 6c 61 68 list)..;; ("blah
66d0: 20 62 6c 61 68 22 20 22 3c 22 20 22 62 22 20 22 blah" "<" "b" "
66e0: 3e 22 20 22 6d 6f 72 65 20 73 74 75 66 66 22 20 >" "more stuff"
66f0: 22 3c 22 20 22 69 22 20 22 3e 22 20 29 20 0a 3b "<" "i" ">" ) .;
6700: 3b 20 20 20 20 20 3d 3e 20 28 22 62 6c 61 68 20 ; => ("blah
6710: 62 6c 61 68 22 20 62 20 23 74 20 28 20 22 6d 6f blah" b #t ( "mo
6720: 72 65 20 73 74 75 66 66 22 20 22 3c 22 20 22 69 re stuff" "<" "i
6730: 22 20 22 3e 22 20 29 29 0a 3b 3b 20 28 22 62 6c " ">" )).;; ("bl
6740: 61 68 20 62 6c 61 68 22 20 22 3c 22 20 22 2f 62 ah blah" "<" "/b
6750: 22 20 22 3e 22 20 22 6d 6f 72 65 20 73 74 75 66 " ">" "more stuf
6760: 66 22 20 22 3c 22 20 22 69 22 20 22 3e 22 20 29 f" "<" "i" ">" )
6770: 20 0a 3b 3b 20 20 20 20 20 3d 3e 20 28 22 62 6c .;; => ("bl
6780: 61 68 20 62 6c 61 68 22 20 62 20 23 66 20 28 20 ah blah" b #f (
6790: 22 6d 6f 72 65 20 73 74 75 66 66 22 20 22 3c 22 "more stuff" "<"
67a0: 20 22 69 22 20 22 3e 22 20 29 29 0a 28 64 65 66 "i" ">" )).(def
67b0: 69 6e 65 20 28 73 3a 75 70 74 6f 2d 74 61 67 20 ine (s:upto-tag
67c0: 69 6e 6c 73 74 20 61 6c 6c 6f 77 65 64 2d 74 61 inlst allowed-ta
67d0: 67 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f gs). (if (null?
67e0: 20 69 6e 6c 73 74 29 20 69 6e 6c 73 74 0a 20 20 inlst) inlst.
67f0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
6800: 74 6f 6b 20 20 28 63 61 72 20 69 6e 6c 73 74 29 tok (car inlst)
6810: 29 0a 09 09 20 28 74 61 69 6c 20 28 63 64 72 20 )... (tail (cdr
6820: 69 6e 6c 73 74 29 29 0a 09 09 20 28 70 72 65 6c inlst))... (prel
6830: 20 22 22 29 29 20 3b 3b 20 63 72 65 61 74 65 20 "")) ;; create
6840: 61 20 73 74 72 69 6e 67 20 6f 72 20 61 20 6c 69 a string or a li
6850: 73 74 20 6f 66 20 73 74 72 69 6e 67 20 70 61 72 st of string par
6860: 74 73 3f 0a 09 28 69 66 20 28 73 74 72 69 6e 67 ts?..(if (string
6870: 3d 3f 20 74 6f 6b 20 22 3c 22 29 20 3b 3b 20 6d =? tok "<") ;; m
6880: 69 67 68 74 20 68 61 76 65 20 61 20 74 61 67 0a ight have a tag.
6890: 09 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e . (if (> (len
68a0: 67 74 68 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 gth tail) 1) ;;
68b0: 74 6f 20 62 65 20 61 20 74 61 67 2c 20 6e 65 65 to be a tag, nee
68c0: 64 20 74 61 67 20 61 6e 64 20 63 6c 6f 73 69 6e d tag and closin
68d0: 67 20 22 3e 22 0a 09 09 28 6c 65 74 20 28 28 74 g ">"...(let ((t
68e0: 61 67 20 28 63 61 72 20 74 61 69 6c 29 29 0a 09 ag (car tail))..
68f0: 09 20 20 20 20 20 20 28 65 6e 64 20 28 63 61 64 . (end (cad
6900: 72 20 74 61 69 6c 29 29 0a 09 09 20 20 20 20 20 r tail))...
6910: 20 28 72 65 6d 20 28 63 64 64 72 20 74 61 69 6c (rem (cddr tail
6920: 29 29 29 20 0a 09 09 20 20 28 69 66 20 28 73 74 ))) ... (if (st
6930: 72 69 6e 67 3d 3f 20 65 6e 64 20 22 3e 22 29 20 ring=? end ">")
6940: 3b 3b 20 79 65 70 2c 20 69 74 20 69 73 20 70 72 ;; yep, it is pr
6950: 6f 62 61 62 6c 79 20 61 20 74 61 67 0a 09 09 20 obably a tag...
6960: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 72 69 (let* ((tri
6970: 6d 2d 74 61 67 20 28 69 66 20 20 28 73 74 72 69 m-tag (if (stri
6980: 6e 67 3d 3f 20 22 2f 22 20 28 73 75 62 73 74 72 ng=? "/" (substr
6990: 69 6e 67 20 74 61 67 20 30 20 31 29 29 0a 09 09 ing tag 0 1))...
69a0: 09 09 09 20 20 20 20 28 73 75 62 73 74 72 69 6e ... (substrin
69b0: 67 20 74 61 67 20 31 20 28 73 74 72 69 6e 67 2d g tag 1 (string-
69c0: 6c 65 6e 67 74 68 20 74 61 67 29 29 20 23 66 29 length tag)) #f)
69d0: 29 0a 09 09 09 20 20 20 20 20 28 74 61 67 2d 73 ).... (tag-s
69e0: 79 6d 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ym (string->sym
69f0: 62 6f 6c 20 28 69 66 20 74 72 69 6d 2d 74 61 67 bol (if trim-tag
6a00: 20 74 72 69 6d 2d 74 61 67 20 74 61 67 29 29 29 trim-tag tag)))
6a10: 29 0a 09 09 09 28 69 66 20 28 6d 65 6d 62 65 72 )....(if (member
6a20: 20 74 61 67 2d 73 79 6d 20 61 6c 6c 6f 77 65 64 tag-sym allowed
6a30: 2d 74 61 67 73 29 0a 09 09 09 20 20 20 20 3b 3b -tags).... ;;
6a40: 20 68 61 76 65 20 61 20 76 61 6c 69 64 20 74 61 have a valid ta
6a50: 67 2c 20 72 65 62 75 69 6c 64 20 69 74 20 61 6e g, rebuild it an
6a60: 64 20 72 65 74 75 72 6e 20 74 68 65 20 72 65 73 d return the res
6a70: 75 6c 74 0a 09 09 09 20 20 20 20 28 6c 69 73 74 ult.... (list
6a80: 20 70 72 65 6c 20 74 61 67 2d 73 79 6d 20 28 69 prel tag-sym (i
6a90: 66 20 74 72 69 6d 2d 74 61 67 20 23 66 20 23 74 f trim-tag #f #t
6aa0: 29 20 72 65 6d 29 0a 09 09 09 20 20 20 20 3b 3b ) rem).... ;;
6ab0: 20 6e 6f 74 20 61 20 76 61 6c 69 64 20 74 61 67 not a valid tag
6ac0: 2c 20 63 6f 6e 76 65 72 74 20 22 3c 22 20 61 6e , convert "<" an
6ad0: 64 20 22 3e 22 20 61 6e 64 20 61 64 64 20 61 6c d ">" and add al
6ae0: 6c 20 74 6f 20 70 72 65 6c 0a 09 09 09 20 20 20 l to prel....
6af0: 20 28 6c 65 74 20 28 28 6e 65 77 70 72 65 6c 20 (let ((newprel
6b00: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 70 (string-append p
6b10: 72 65 6c 20 22 26 6c 74 3b 22 20 74 61 67 20 22 rel "<" tag "
6b20: 26 67 74 3b 22 29 29 29 0a 09 09 09 20 20 20 20 >")))....
6b30: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d (if (null? rem
6b40: 29 28 6c 69 73 74 20 6e 65 77 70 72 65 6c 20 23 )(list newprel #
6b50: 66 20 23 66 20 27 28 29 29 20 3b 3b 20 72 65 74 f #f '()) ;; ret
6b60: 75 72 6e 20 6e 65 77 70 72 65 6c 20 2d 20 61 64 urn newprel - ad
6b70: 64 20 23 66 20 23 66 20 3f 3f 3f 0a 09 09 09 09 d #f #f ???.....
6b80: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d (loop (car rem
6b90: 29 28 63 64 72 20 72 65 6d 29 20 6e 65 77 70 72 )(cdr rem) newpr
6ba0: 65 6c 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 el)))))...
6bb0: 3b 3b 20 73 6f 2c 20 69 74 20 77 61 73 6e 27 74 ;; so, it wasn't
6bc0: 20 61 20 74 61 67 0a 09 09 20 20 20 20 20 20 28 a tag... (
6bd0: 6c 65 74 20 28 28 6e 65 77 70 72 65 6c 20 28 73 let ((newprel (s
6be0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 70 72 65 tring-append pre
6bf0: 6c 20 22 26 6c 74 3b 22 20 74 61 67 29 29 29 0a l "<" tag))).
6c00: 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
6c10: 69 6c 29 0a 09 09 09 20 20 20 20 28 6c 69 73 74 il).... (list
6c20: 20 6e 65 77 70 72 65 6c 20 23 66 20 23 66 20 27 newprel #f #f '
6c30: 28 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 ()).... (loop
6c40: 20 28 63 61 72 20 72 65 6d 29 28 63 64 72 20 72 (car rem)(cdr r
6c50: 65 6d 29 20 6e 65 77 70 72 65 6c 29 29 29 29 29 em) newprel)))))
6c60: 0a 09 09 3b 3b 20 74 6f 6f 20 73 68 6f 72 74 20 ...;; too short
6c70: 74 6f 20 62 65 20 61 20 74 61 67 0a 09 09 28 6c to be a tag...(l
6c80: 69 73 74 20 28 61 70 70 6c 79 20 73 74 72 69 6e ist (apply strin
6c90: 67 2d 61 70 70 65 6e 64 20 70 72 65 6c 20 22 26 g-append prel "&
6ca0: 6c 74 3b 22 20 74 61 69 6c 29 20 23 66 20 23 66 lt;" tail) #f #f
6cb0: 20 27 28 29 29 29 0a 09 20 20 20 20 28 69 66 20 '())).. (if
6cc0: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 0a 09 09 (null? tail) ...
6cd0: 3b 3b 20 77 65 27 72 65 20 64 6f 6e 65 0a 09 09 ;; we're done...
6ce0: 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 61 70 (list (string-ap
6cf0: 70 65 6e 64 20 70 72 65 6c 20 74 6f 6b 29 20 23 pend prel tok) #
6d00: 66 20 23 66 20 27 28 29 29 0a 09 09 28 6c 6f 6f f #f '())...(loo
6d10: 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 64 72 p (car tail)(cdr
6d20: 20 74 61 69 6c 29 28 73 74 72 69 6e 67 2d 61 70 tail)(string-ap
6d30: 70 65 6e 64 20 70 72 65 6c 20 74 6f 6b 29 29 29 pend prel tok)))
6d40: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
6d50: 73 3a 64 69 76 79 2d 75 70 2d 63 67 69 2d 73 74 s:divy-up-cgi-st
6d60: 72 20 69 6e 73 74 72 29 0a 20 20 28 6d 61 70 20 r instr). (map
6d70: 28 6c 61 6d 62 64 61 20 28 78 29 20 28 73 74 72 (lambda (x) (str
6d80: 69 6e 67 2d 73 70 6c 69 74 20 78 20 22 3d 22 29 ing-split x "=")
6d90: 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 ) (string-split
6da0: 69 6e 73 74 72 20 22 26 22 29 29 29 0a 0a 28 64 instr "&")))..(d
6db0: 65 66 69 6e 65 20 28 73 3a 64 65 63 6f 64 65 2d efine (s:decode-
6dc0: 73 74 72 20 69 6e 73 74 72 29 0a 20 20 28 6c 65 str instr). (le
6dd0: 74 2a 20 28 28 61 62 63 20 28 73 74 72 69 6e 67 t* ((abc (string
6de0: 2d 73 75 62 73 74 69 74 75 74 65 20 22 5c 5c 2b -substitute "\\+
6df0: 22 20 22 20 22 20 69 6e 73 74 72 20 23 74 29 29 " " " instr #t))
6e00: 0a 09 20 28 74 6f 6b 73 20 28 73 3a 73 70 6c 69 .. (toks (s:spli
6e10: 74 2d 73 74 72 69 6e 67 20 61 62 63 20 22 25 22 t-string abc "%"
6e20: 29 29 29 0a 20 20 20 20 28 69 66 20 28 3c 20 28 ))). (if (< (
6e30: 6c 65 6e 67 74 68 20 74 6f 6b 73 29 20 32 29 20 length toks) 2)
6e40: 61 62 63 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 abc..(let loop (
6e50: 28 68 65 61 64 20 28 63 61 64 72 20 74 6f 6b 73 (head (cadr toks
6e60: 29 29 0a 09 09 20 20 20 28 74 61 69 6c 20 28 63 ))... (tail (c
6e70: 64 64 72 20 74 6f 6b 73 29 29 0a 09 09 20 20 20 ddr toks))...
6e80: 28 72 65 73 75 6c 74 20 28 63 61 72 20 74 6f 6b (result (car tok
6e90: 73 29 29 29 0a 09 20 20 28 69 66 20 28 73 74 72 s))).. (if (str
6ea0: 69 6e 67 3d 3f 20 68 65 61 64 20 22 22 29 0a 09 ing=? head "")..
6eb0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
6ec0: 20 74 61 69 6c 29 0a 09 09 20 20 72 65 73 75 6c tail)... resul
6ed0: 74 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 t... (loop (car
6ee0: 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 tail)(cdr tail)
6ef0: 20 72 65 73 75 6c 74 29 29 0a 09 20 20 20 20 20 result))..
6f00: 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 28 73 75 (let* ((key (su
6f10: 62 73 74 72 69 6e 67 20 68 65 61 64 20 30 20 32 bstring head 0 2
6f20: 29 29 0a 09 09 20 20 20 20 20 28 72 65 6d 20 28 ))... (rem (
6f30: 73 75 62 73 74 72 69 6e 67 20 68 65 61 64 20 32 substring head 2
6f40: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
6f50: 68 65 61 64 29 29 29 0a 09 09 20 20 20 20 20 28 head)))... (
6f60: 6e 75 6d 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d num (string->num
6f70: 62 65 72 20 6b 65 79 20 31 36 29 29 0a 09 09 20 ber key 16))...
6f80: 20 20 20 20 28 63 68 20 20 28 69 66 20 28 61 6e (ch (if (an
6f90: 64 20 28 6e 75 6d 62 65 72 3f 20 6e 75 6d 29 0a d (number? 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 20
6fc0: 20 20 20 28 65 78 61 63 74 3f 20 6e 75 6d 29 29 (exact? num))
6fd0: 0a 09 09 09 20 20 20 20 20 20 28 69 6e 74 65 67 .... (integ
6fe0: 65 72 2d 3e 63 68 61 72 20 6e 75 6d 29 0a 09 09 er->char num)...
6ff0: 09 20 20 20 20 20 20 23 66 29 29 20 3b 3b 20 74 . #f)) ;; t
7000: 68 69 73 20 69 73 20 61 6e 20 65 72 72 6f 72 2e his is an error.
7010: 20 49 20 77 69 6c 6c 20 70 72 6f 62 61 62 6c 79 I will probably
7020: 20 72 65 67 72 65 74 20 74 68 69 73 20 73 6f 6d regret this som
7030: 65 20 64 61 79 0a 09 09 20 20 20 20 20 28 63 68 e day... (ch
7040: 73 74 72 20 20 28 69 66 20 63 68 20 28 6d 61 6b str (if ch (mak
7050: 65 2d 73 74 72 69 6e 67 20 31 20 63 68 29 20 22 e-string 1 ch) "
7060: 22 29 29 0a 09 09 20 20 20 20 20 28 6e 65 77 72 "))... (newr
7070: 65 73 20 28 69 66 20 63 68 0a 09 09 09 09 20 28 es (if ch..... (
7080: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 72 65 string-append re
7090: 73 75 6c 74 20 63 68 73 74 72 20 72 65 6d 29 0a sult chstr rem).
70a0: 09 09 09 09 20 28 73 74 72 69 6e 67 2d 61 70 70 .... (string-app
70b0: 65 6e 64 20 72 65 73 75 6c 74 20 68 65 61 64 29 end result head)
70c0: 29 29 29 0a 09 09 3b 3b 20 28 70 72 69 6e 74 20 )))...;; (print
70d0: 22 68 65 61 64 3a 20 22 20 68 65 61 64 20 22 20 "head: " head "
70e0: 6e 75 6d 3a 20 22 20 6e 75 6d 20 22 20 63 68 3a num: " num " ch:
70f0: 20 7c 22 20 63 68 20 22 7c 20 63 68 73 74 72 3a |" ch "| chstr:
7100: 20 22 20 63 68 73 74 72 29 0a 09 09 28 69 66 20 " chstr)...(if
7110: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 09 20 (null? tail)...
7120: 20 20 20 6e 65 77 72 65 73 0a 09 09 20 20 20 20 newres...
7130: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
7140: 28 63 64 72 20 74 61 69 6c 29 20 6e 65 77 72 65 (cdr tail) newre
7150: 73 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 70 72 s))))))))..;; pr
7160: 6f 62 61 62 6c 79 20 61 20 62 75 67 3a 0a 3b 3b obably a bug:.;;
7170: 0a 3b 3b 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 .;; (s:process-c
7180: 67 69 2d 69 6e 70 75 74 20 22 3d 62 61 72 22 29 gi-input "=bar")
7190: 0a 3b 3b 20 3d 3e 20 28 28 62 61 72 20 22 22 29 .;; => ((bar "")
71a0: 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a ).;;.(define (s:
71b0: 70 72 6f 63 65 73 73 2d 63 67 69 2d 69 6e 70 75 process-cgi-inpu
71c0: 74 20 69 6e 73 74 72 29 0a 20 20 28 6d 61 70 20 t instr). (map
71d0: 28 6c 61 6d 62 64 61 20 28 78 79 29 0a 20 20 20 (lambda (xy).
71e0: 20 20 20 20 20 20 28 6c 69 73 74 20 28 73 74 72 (list (str
71f0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 3a 64 ing->symbol (s:d
7200: 65 63 6f 64 65 2d 73 74 72 20 28 63 61 72 20 78 ecode-str (car x
7210: 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 y))).
7220: 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 6c 65 (if (eq? (le
7230: 6e 67 74 68 20 78 79 29 20 31 29 20 0a 20 20 20 ngth xy) 1) .
7240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7250: 22 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 "".
7260: 20 20 20 20 20 20 28 73 3a 64 65 63 6f 64 65 2d (s:decode-
7270: 73 74 72 20 28 63 61 64 72 20 78 79 29 29 29 29 str (cadr xy))))
7280: 29 0a 20 20 20 20 20 20 20 20 20 28 73 3a 64 69 ). (s:di
7290: 76 79 2d 75 70 2d 63 67 69 2d 73 74 72 20 69 6e vy-up-cgi-str in
72a0: 73 74 72 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 74 str)))..;; for t
72b0: 65 73 74 69 6e 67 20 2d 2d 20 64 65 6c 65 74 6d esting -- deletm
72c0: 65 0a 3b 3b 20 28 64 65 66 69 6e 65 20 62 6c 61 e.;; (define bla
72d0: 68 20 22 70 6f 73 74 5f 74 69 74 6c 65 3d 25 32 h "post_title=%2
72e0: 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 B%2B%2B%2B%2B%2B
72f0: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 68 %2B%2B%2B%2B%2Bh
7300: 65 6c 6c 6f 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ello------------
7310: 2d 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 -+++++++++++%26%
7320: 32 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 26%26%26%26%26%2
7330: 36 25 32 36 25 32 36 25 34 30 25 34 30 25 34 30 6%26%26%40%40%40
7340: 25 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 %40%40%40%40%40%
7350: 34 30 26 70 6f 73 74 5f 62 6f 64 79 3d 25 32 42 40&post_body=%2B
7360: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 %2B%2B%2B%2B%2B%
7370: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 68 65 2B%2B%2B%2B%2Bhe
7380: 6c 6c 6f 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d llo-------------
7390: 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 +++++++++++%26%2
73a0: 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 6%26%26%26%26%26
73b0: 25 32 36 25 32 36 25 34 30 25 34 30 25 34 30 25 %26%26%40%40%40%
73c0: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 34 40%40%40%40%40%4
73d0: 30 25 30 44 25 30 41 25 30 44 25 30 41 25 32 42 0%0D%0A%0D%0A%2B
73e0: 25 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 %2B%2B%2B%2B%2B%
73f0: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 68 65 2B%2B%2B%2B%2Bhe
7400: 6c 6c 6f 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d llo-------------
7410: 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b 25 32 36 25 32 +++++++++++%26%2
7420: 36 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 6%26%26%26%26%26
7430: 25 32 36 25 32 36 25 34 30 25 34 30 25 34 30 25 %26%26%40%40%40%
7440: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 34 40%40%40%40%40%4
7450: 30 25 30 44 25 30 41 25 30 44 25 30 41 25 30 44 0%0D%0A%0D%0A%0D
7460: 25 30 41 25 32 42 25 32 42 25 32 42 25 32 42 25 %0A%2B%2B%2B%2B%
7470: 32 42 25 32 42 25 32 42 25 32 42 25 32 42 25 32 2B%2B%2B%2B%2B%2
7480: 42 25 32 42 68 65 6c 6c 6f 2d 2d 2d 2d 2d 2d 2d B%2Bhello-------
7490: 2d 2d 2d 2d 2d 2d 2b 2b 2b 2b 2b 2b 2b 2b 2b 2b ------++++++++++
74a0: 2b 25 32 36 25 32 36 25 32 36 25 32 36 25 32 36 +%26%26%26%26%26
74b0: 25 32 36 25 32 36 25 32 36 25 32 36 25 34 30 25 %26%26%26%26%40%
74c0: 34 30 25 34 30 25 34 30 25 34 30 25 34 30 25 34 40%40%40%40%40%4
74d0: 30 25 34 30 25 34 30 26 6e 65 77 5f 70 6f 73 74 0%40%40&new_post
74e0: 3d 53 75 62 6d 69 74 22 29 0a 3b 3b 20 28 64 65 =Submit").;; (de
74f0: 66 69 6e 65 20 62 6c 61 68 32 20 22 70 6f 73 74 fine blah2 "post
7500: 5f 74 69 74 6c 65 3d 35 25 32 35 26 70 6f 73 74 _title=5%25&post
7510: 5f 62 6f 64 79 3d 61 6e 64 2b 31 30 25 32 35 26 _body=and+10%25&
7520: 6e 65 77 5f 70 6f 73 74 3d 53 75 62 6d 69 74 22 new_post=Submit"
7530: 29 0a 0a 3b 3b 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 3d 3d 3d 3d 0a 3b 3b 20 66 ===========.;; f
7580: 6f 72 6d 64 61 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ormdat.;;=======
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 3d 3d 3d 3d 0a ===============.
75d0: 0a 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 .(define formdat
75e0: 3a 2a 64 65 62 75 67 2a 20 23 66 29 0a 0a 3b 3b :*debug* #f)..;;
75f0: 20 4f 6c 64 20 64 61 74 61 20 66 6f 72 6d 61 74 Old data format
7600: 20 77 61 73 20 73 6f 6d 65 74 68 69 6e 67 20 6c was something l
7610: 69 6b 65 20 74 68 69 73 2e 20 42 55 54 21 20 0a ike this. BUT! .
7620: 3b 3b 20 46 6f 72 6d 73 20 64 6f 20 6e 6f 74 20 ;; Forms do not
7630: 68 61 76 65 20 6e 61 6d 65 73 20 73 6f 20 74 68 have names so th
7640: 65 20 68 69 65 72 61 72 63 79 20 69 73 0a 3b 3b e hierarcy is.;;
7650: 20 75 6e 6e 65 63 65 73 73 61 72 79 20 28 49 20 unnecessary (I
7660: 74 68 69 6e 6b 29 0a 3b 3b 0a 3b 3b 20 68 61 73 think).;;.;; has
7670: 68 74 61 62 6c 65 0a 3b 3b 20 20 20 7c 2d 66 6f htable.;; |-fo
7680: 72 6d 6e 61 6d 65 20 2d 2d 3e 20 3c 66 6f 72 6d rmname --> <form
7690: 64 61 74 3e 20 27 66 6f 72 6d 2d 6e 61 6d 65 3d dat> 'form-name=
76a0: 66 6f 72 6d 6e 61 6d 65 0a 3b 3b 20 20 20 7c 20 formname.;; |
76b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76c0: 20 20 20 20 20 20 20 27 66 6f 72 6d 2d 64 61 74 'form-dat
76d0: 61 3d 68 61 73 68 74 61 62 6c 65 0a 3b 3b 20 20 a=hashtable.;;
76e0: 20 7c 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 20 20 20 20 7c 20 6e 61 6d 65 20 | name
7710: 3d 3e 20 76 61 6c 75 65 0a 3b 3b 0a 3b 3b 20 4e => value.;;.;; N
7720: 65 77 20 64 61 74 61 20 66 6f 72 6d 61 74 20 69 ew data format i
7730: 73 20 6f 6e 6c 79 20 74 68 65 20 3c 66 6f 72 6d s only the <form
7740: 64 61 74 3e 20 70 6f 72 74 69 6f 6e 20 66 72 6f dat> portion fro
7750: 6d 20 61 62 6f 76 65 0a 0a 3b 3b 20 28 64 65 66 m above..;; (def
7760: 69 6e 65 2d 63 6c 61 73 73 20 3c 66 6f 72 6d 64 ine-class <formd
7770: 61 74 3e 20 28 29 0a 3b 3b 20 20 20 20 28 66 6f at> ().;; (fo
7780: 72 6d 2d 64 61 74 61 0a 3b 3b 20 20 20 20 29 29 rm-data.;; ))
7790: 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 66 .(define (make-f
77a0: 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 29 28 ormdat:formdat)(
77b0: 76 65 63 74 6f 72 20 28 6d 61 6b 65 2d 68 61 73 vector (make-has
77c0: 68 2d 74 61 62 6c 65 29 29 29 0a 28 64 65 66 69 h-table))).(defi
77d0: 6e 65 2d 69 6e 6c 69 6e 65 20 28 66 6f 72 6d 64 ne-inline (formd
77e0: 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 74 2d 64 at:formdat-get-d
77f0: 61 74 61 20 20 20 76 65 63 29 20 20 20 20 28 76 ata vec) (v
7800: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 30 ector-ref vec 0
7810: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
7820: 65 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 e (formdat:formd
7830: 61 74 2d 73 65 74 2d 64 61 74 61 21 20 20 76 65 at-set-data! ve
7840: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
7850: 74 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a 0a t! vec 0 val))..
7860: 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 (define (formdat
7870: 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c 66 :initialize self
7880: 29 0a 20 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 ). (formdat:for
7890: 6d 64 61 74 2d 73 65 74 2d 64 61 74 61 21 20 73 mdat-set-data! s
78a0: 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 elf (make-hash-t
78b0: 61 62 6c 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 able)))..(define
78c0: 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 73 65 (formdat:get se
78d0: 6c 66 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d lf key). (hash-
78e0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
78f0: 74 20 0a 20 20 20 28 66 6f 72 6d 64 61 74 3a 66 t . (formdat:f
7900: 6f 72 6d 64 61 74 2d 67 65 74 2d 64 61 74 61 20 ormdat-get-data
7910: 73 65 6c 66 29 0a 20 20 20 28 63 6f 6e 64 20 0a self). (cond .
7920: 20 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 6b 65 ((symbol? ke
7930: 79 29 20 6b 65 79 29 0a 20 20 20 20 28 28 73 74 y) key). ((st
7940: 72 69 6e 67 3f 20 6b 65 79 29 20 28 73 74 72 69 ring? key) (stri
7950: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6b 65 79 29 29 ng->symbol key))
7960: 0a 20 20 20 20 28 65 6c 73 65 20 6b 65 79 29 29 . (else key))
7970: 0a 20 20 20 23 66 29 29 0a 0a 3b 3b 20 63 68 61 . #f))..;; cha
7980: 6e 67 65 20 74 6f 20 63 6f 6e 76 65 72 74 20 64 nge to convert d
7990: 61 74 61 20 74 6f 20 6c 69 73 74 20 61 6e 64 20 ata to list and
79a0: 61 70 70 65 6e 64 20 76 61 6c 20 69 66 20 61 6c append val if al
79b0: 72 65 61 64 79 20 65 78 69 73 74 73 0a 3b 3b 20 ready exists.;;
79c0: 6f 72 20 69 73 20 61 20 6c 69 73 74 0a 28 64 65 or is a list.(de
79d0: 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 73 65 fine (formdat:se
79e0: 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c 29 t! self key val)
79f0: 0a 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d 76 . (let ((prev-v
7a00: 61 6c 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 al (formdat:get
7a10: 73 65 6c 66 20 6b 65 79 29 29 0a 20 20 20 20 20 self key)).
7a20: 20 20 20 28 68 74 20 20 20 20 20 20 20 28 66 6f (ht (fo
7a30: 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 rmdat:formdat-ge
7a40: 74 2d 64 61 74 61 20 73 65 6c 66 29 29 29 0a 20 t-data self))).
7a50: 20 20 20 28 69 66 20 70 72 65 76 2d 76 61 6c 0a (if prev-val.
7a60: 20 20 20 20 20 20 20 20 28 69 66 20 28 6c 69 73 (if (lis
7a70: 74 3f 20 70 72 65 76 2d 76 61 6c 29 0a 20 20 20 t? prev-val).
7a80: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
7a90: 61 62 6c 65 2d 73 65 74 21 20 68 74 20 6b 65 79 able-set! ht key
7aa0: 20 28 63 6f 6e 73 20 76 61 6c 20 70 72 65 76 2d (cons val prev-
7ab0: 76 61 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 val)).
7ac0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
7ad0: 74 21 20 68 74 20 6b 65 79 20 28 6c 69 73 74 20 t! ht key (list
7ae0: 76 61 6c 20 70 72 65 76 2d 76 61 6c 29 29 29 0a val prev-val))).
7af0: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
7b00: 62 6c 65 2d 73 65 74 21 20 68 74 20 6b 65 79 20 ble-set! ht key
7b10: 76 61 6c 29 29 0a 20 20 20 20 73 65 6c 66 29 29 val)). self))
7b20: 0a 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 ..(define (formd
7b30: 61 74 3a 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 at:keys self).
7b40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
7b50: 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 (formdat:formda
7b60: 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 29 t-get-data self)
7b70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 ))..(define (for
7b80: 6d 64 61 74 3a 70 72 69 6e 74 61 6c 6c 20 73 65 mdat:printall se
7b90: 6c 66 20 70 72 69 6e 74 70 72 6f 63 29 0a 20 20 lf printproc).
7ba0: 28 70 72 69 6e 74 70 72 6f 63 20 22 66 6f 72 6d (printproc "form
7bb0: 64 61 74 3a 70 72 69 6e 74 61 6c 6c 20 22 20 28 dat:printall " (
7bc0: 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c formdat:keys sel
7bd0: 66 29 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 f)). (for-each
7be0: 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 20 20 20 (lambda (k)..
7bf0: 20 20 20 28 70 72 69 6e 74 70 72 6f 63 20 6b 20 (printproc k
7c00: 22 20 3d 3e 20 22 20 28 66 6f 72 6d 64 61 74 3a " => " (formdat:
7c10: 67 65 74 20 73 65 6c 66 20 6b 29 29 29 0a 09 20 get self k)))..
7c20: 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 (formdat:keys
7c30: 20 73 65 6c 66 29 29 29 0a 0a 28 64 65 66 69 6e self)))..(defin
7c40: 65 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e e (formdat:all->
7c50: 73 74 72 69 6e 67 73 20 73 65 6c 66 29 0a 20 20 strings self).
7c60: 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 29 (let ((res '()))
7c70: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
7c80: 6c 61 6d 62 64 61 20 28 6b 29 0a 20 20 20 20 20 lambda (k).
7c90: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
7ca0: 21 20 72 65 73 20 28 63 6f 6e 73 20 28 63 6f 6e ! res (cons (con
7cb0: 63 20 6b 20 22 3d 3e 22 20 28 66 6f 72 6d 64 61 c k "=>" (formda
7cc0: 74 3a 67 65 74 20 73 65 6c 66 20 6b 29 29 20 72 t:get self k)) r
7cd0: 65 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 es))).
7ce0: 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 (formdat:key
7cf0: 73 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 20 s self)).
7d00: 20 72 65 73 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 res))..;; call
7d10: 77 69 74 68 20 2a 6f 6e 65 2a 20 6f 66 20 74 68 with *one* of th
7d20: 65 20 6c 69 73 74 73 20 69 6e 20 74 68 65 20 6c e lists in the l
7d30: 69 73 74 20 6f 66 20 6c 69 73 74 73 20 63 72 65 ist of lists cre
7d40: 61 74 65 64 20 62 79 20 43 47 49 3a 75 72 6c 2d ated by CGI:url-
7d50: 75 6e 71 75 6f 74 65 0a 28 64 65 66 69 6e 65 20 unquote.(define
7d60: 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 20 73 65 (formdat:load se
7d70: 6c 66 20 66 6f 72 6d 6c 69 73 74 29 0a 20 20 28 lf formlist). (
7d80: 6c 65 74 20 28 28 68 74 20 20 20 20 20 20 20 20 let ((ht
7d90: 20 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 66 6f (formdat:fo
7da0: 72 6d 64 61 74 2d 67 65 74 2d 64 61 74 61 20 73 rmdat-get-data s
7db0: 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
7dc0: 6e 75 6c 6c 3f 20 66 6f 72 6d 6c 69 73 74 29 20 null? formlist)
7dd0: 73 65 6c 66 20 3b 3b 20 6e 6f 20 76 61 6c 75 65 self ;; no value
7de0: 73 20 70 72 6f 76 69 64 65 64 2c 20 72 65 74 75 s provided, retu
7df0: 72 6e 20 73 65 6c 66 20 66 6f 72 20 6e 6f 20 67 rn self for no g
7e00: 6f 6f 64 20 72 65 61 73 6f 6e 0a 20 20 20 20 20 ood reason.
7e10: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
7e20: 65 61 64 20 28 63 61 72 20 66 6f 72 6d 6c 69 73 ead (car formlis
7e30: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
7e40: 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 (tail (cd
7e50: 72 20 66 6f 72 6d 6c 69 73 74 29 29 29 0a 20 20 r formlist))).
7e60: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b (let ((k
7e70: 65 79 20 28 63 61 72 20 68 65 61 64 29 29 0a 20 ey (car head)).
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7e90: 76 61 6c 20 28 63 64 72 20 68 65 61 64 29 29 29 val (cdr head)))
7ea0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 . ;;
7eb0: 28 65 72 72 3a 6c 6f 67 20 22 6b 65 79 3d 22 20 (err:log "key="
7ec0: 6b 65 79 20 22 20 76 61 6c 3d 22 20 76 61 6c 29 key " val=" val)
7ed0: 0a 09 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 .. (if (> (le
7ee0: 6e 67 74 68 20 76 61 6c 29 20 31 29 0a 09 09 28 ngth val) 1)...(
7ef0: 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 73 65 6c formdat:set! sel
7f00: 66 20 6b 65 79 20 76 61 6c 29 0a 09 09 28 66 6f f key val)...(fo
7f10: 72 6d 64 61 74 3a 73 65 74 21 20 73 65 6c 66 20 rmdat:set! self
7f20: 6b 65 79 20 28 63 61 72 20 76 61 6c 29 29 29 0a key (car val))).
7f30: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
7f40: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 73 65 6c (null? tail) sel
7f50: 66 20 20 20 3b 3b 20 77 65 20 61 72 65 20 64 6f f ;; we are do
7f60: 6e 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ne.
7f70: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
7f80: 69 6c 29 28 63 64 72 20 74 61 69 6c 29 29 29 29 il)(cdr tail))))
7f90: 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 ))))..;; get the
7fa0: 20 68 65 61 64 65 72 20 66 72 6f 6d 20 64 61 74 header from dat
7fb0: 73 74 72 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 str.(define (for
7fc0: 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 64 65 72 mdat:read-header
7fd0: 20 64 61 74 73 74 72 29 20 3b 3b 20 64 61 74 73 datstr) ;; dats
7fe0: 74 72 20 69 73 20 61 6e 20 69 6e 70 75 74 20 73 tr is an input s
7ff0: 74 72 69 6e 67 20 70 6f 72 74 0a 20 20 28 6c 65 tring port. (le
8000: 74 20 6c 6f 6f 70 20 28 28 68 73 20 28 72 65 61 t loop ((hs (rea
8010: 64 2d 6c 69 6e 65 20 64 61 74 73 74 72 29 29 0a d-line datstr)).
8020: 09 20 20 20 20 20 28 68 65 61 64 65 72 20 27 28 . (header '(
8030: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ))). (if (or
8040: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 68 73 29 (eof-object? hs)
8050: 0a 09 20 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 .. (string=?
8060: 68 73 20 22 22 29 29 0a 09 68 65 61 64 65 72 0a hs ""))..header.
8070: 09 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e .(loop (read-lin
8080: 65 20 64 61 74 73 74 72 29 28 61 70 70 65 6e 64 e datstr)(append
8090: 20 68 65 61 64 65 72 20 28 6c 69 73 74 20 68 73 header (list hs
80a0: 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 ))))))..;; get t
80b0: 68 65 20 64 61 74 61 20 75 70 20 74 6f 20 74 68 he data up to th
80c0: 65 20 6e 65 78 74 20 6b 65 79 2e 20 69 66 20 74 e next key. if t
80d0: 68 65 72 65 20 69 73 20 6e 6f 20 6b 65 79 20 74 here is no key t
80e0: 68 65 6e 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b hen return #f.;;
80f0: 20 72 65 74 75 72 6e 20 28 64 61 74 20 72 65 6d return (dat rem
8100: 64 61 74 29 0a 28 64 65 66 69 6e 65 20 28 66 6f dat).(define (fo
8110: 72 6d 64 61 74 3a 72 65 61 64 2d 64 61 74 20 64 rmdat:read-dat d
8120: 61 74 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 at key). (let (
8130: 28 69 6e 64 65 78 20 28 73 75 62 73 74 72 69 6e (index (substrin
8140: 67 2d 69 6e 64 65 78 20 6b 65 79 20 64 61 74 29 g-index key dat)
8150: 29 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d 73 65 )) ;; (string-se
8160: 61 72 63 68 2d 70 6f 73 69 74 69 6f 6e 73 20 6b arch-positions k
8170: 65 79 20 64 61 74 29 29 29 0a 20 20 20 20 28 69 ey dat))). (i
8180: 66 20 28 6f 72 20 28 6e 6f 74 20 69 6e 64 65 78 f (or (not index
8190: 29 0a 09 20 20 20 20 28 6e 75 6c 6c 3f 20 69 6e ).. (null? in
81a0: 64 65 78 29 29 20 3b 3b 20 74 68 65 20 6b 65 79 dex)) ;; the key
81b0: 20 77 61 73 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 was not found..
81c0: 23 66 0a 09 28 6c 65 74 2a 20 28 28 64 61 74 73 #f..(let* ((dats
81d0: 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 tr (open-input-s
81e0: 74 72 69 6e 67 20 64 61 74 29 29 0a 09 20 20 20 tring dat))..
81f0: 20 20 20 20 3b 3b 20 28 72 65 73 75 6c 74 20 28 ;; (result (
8200: 72 65 61 64 2d 73 74 72 69 6e 67 20 28 63 61 61 read-string (caa
8210: 72 20 69 6e 64 65 78 29 20 64 61 74 73 74 72 29 r index) datstr)
8220: 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 75 6c ).. (resul
8230: 74 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 69 t (read-string i
8240: 6e 64 65 78 20 64 61 74 73 74 72 29 29 0a 09 20 ndex datstr))..
8250: 20 20 20 20 20 20 28 72 65 6d 64 61 74 20 28 72 (remdat (r
8260: 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 64 61 ead-string #f da
8270: 74 73 74 72 29 29 29 0a 09 20 20 28 63 6c 6f 73 tstr))).. (clos
8280: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 64 61 74 e-input-port dat
8290: 73 74 72 29 0a 09 20 20 28 6c 69 73 74 20 72 65 str).. (list re
82a0: 73 75 6c 74 20 72 65 6d 64 61 74 29 29 29 29 29 sult remdat)))))
82b0: 0a 0a 20 3b 3b 20 69 6e 70 20 69 73 20 70 6f 72 .. ;; inp is por
82c0: 74 20 74 6f 20 72 65 61 64 20 64 61 74 61 20 66 t to read data f
82d0: 72 6f 6d 2c 20 6d 61 78 73 69 7a 65 20 69 73 20 rom, maxsize is
82e0: 6d 61 78 20 64 61 74 61 20 61 6c 6c 6f 77 65 64 max data allowed
82f0: 20 74 6f 20 72 65 61 64 20 28 74 6f 74 61 6c 29 to read (total)
8300: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
8310: 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 t:dat->list inp
8320: 6d 61 78 73 69 7a 65 20 23 21 6b 65 79 20 28 64 maxsize #!key (d
8330: 65 62 75 67 2d 70 6f 72 74 20 23 66 29 29 0a 20 ebug-port #f)).
8340: 20 3b 3b 20 72 65 61 64 20 31 4d 65 67 20 63 68 ;; read 1Meg ch
8350: 75 6e 6b 73 20 66 72 6f 6d 20 74 68 65 20 69 6e unks from the in
8360: 70 75 74 20 70 6f 72 74 2e 20 49 66 20 61 20 62 put port. If a b
8370: 6c 6f 63 6b 20 69 73 20 6e 6f 74 20 63 6f 6d 70 lock is not comp
8380: 6c 65 74 65 0a 20 20 3b 3b 20 74 61 63 6b 20 6f lete. ;; tack o
8390: 6e 20 74 68 65 20 6e 65 78 74 20 31 4d 65 67 20 n the next 1Meg
83a0: 63 68 75 6e 6b 20 61 73 20 6e 65 65 64 65 64 2e chunk as needed.
83b0: 20 53 65 74 20 75 70 20 73 6f 20 74 68 65 20 68 Set up so the h
83c0: 65 61 64 65 72 20 69 73 20 61 6c 77 61 79 73 0a eader is always.
83d0: 20 20 3b 3b 20 61 74 20 74 68 65 20 62 65 67 69 ;; at the begi
83e0: 6e 6e 69 6e 67 20 6f 66 20 74 68 65 20 63 68 75 nning of the chu
83f0: 6e 6b 0a 20 20 3b 3b 2d 2d 2d 2d 2d 2d 2d 2d 2d nk. ;;---------
8400: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
8410: 2d 2d 2d 2d 32 39 39 33 32 30 32 34 34 31 31 35 ----299320244115
8420: 30 32 33 32 33 33 33 32 31 33 36 32 31 34 39 37 0232333213621497
8430: 33 0a 20 20 3b 3b 43 6f 6e 74 65 6e 74 2d 44 69 3. ;;Content-Di
8440: 73 70 6f 73 69 74 69 6f 6e 3a 20 66 6f 72 6d 2d sposition: form-
8450: 64 61 74 61 3b 20 6e 61 6d 65 3d 22 69 6e 70 75 data; name="inpu
8460: 74 2d 70 69 63 74 75 72 65 22 3b 20 66 69 6c 65 t-picture"; file
8470: 6e 61 6d 65 3d 22 62 72 65 61 64 66 72 75 69 74 name="breadfruit
8480: 2e 6a 70 67 22 0a 20 20 3b 3b 43 6f 6e 74 65 6e .jpg". ;;Conten
8490: 74 2d 54 79 70 65 3a 20 69 6d 61 67 65 2f 6a 70 t-Type: image/jp
84a0: 65 67 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 eg. (let loop (
84b0: 28 64 61 74 20 28 72 65 61 64 2d 73 74 72 69 6e (dat (read-strin
84c0: 67 20 31 30 30 30 30 30 30 20 69 6e 70 29 29 0a g 1000000 inp)).
84d0: 09 20 20 20 20 20 28 72 65 73 20 27 28 29 29 0a . (res '()).
84e0: 09 20 20 20 20 20 28 73 69 7a 20 30 29 29 0a 20 . (siz 0)).
84f0: 20 20 20 28 69 66 20 64 65 62 75 67 2d 70 6f 72 (if debug-por
8500: 74 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 2d t (format debug-
8510: 70 6f 72 74 20 22 64 61 74 3a 20 7e 41 5c 6e 22 port "dat: ~A\n"
8520: 20 64 61 74 29 29 0a 20 20 20 20 28 69 66 20 64 dat)). (if d
8530: 65 62 75 67 2d 70 6f 72 74 20 28 66 6f 72 6d 61 ebug-port (forma
8540: 74 20 64 65 62 75 67 2d 70 6f 72 74 20 22 65 6f t debug-port "eo
8550: 66 3a 20 7e 41 5c 6e 22 20 28 65 6f 66 2d 6f 62 f: ~A\n" (eof-ob
8560: 6a 65 63 74 3f 20 28 72 65 61 64 20 69 6e 70 29 ject? (read inp)
8570: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 28 69 66 ))). . (if
8580: 20 28 3e 20 73 69 7a 20 6d 61 78 73 69 7a 65 29 (> siz maxsize)
8590: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 ..(begin.. (pri
85a0: 6e 74 20 22 44 41 54 41 20 54 4f 4f 20 42 49 47 nt "DATA TOO BIG
85b0: 22 29 0a 09 20 20 72 65 73 29 0a 09 28 6c 65 74 ").. res)..(let
85c0: 2a 20 28 28 64 61 74 73 74 72 20 28 6f 70 65 6e * ((datstr (open
85d0: 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 64 61 -input-string da
85e0: 74 29 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 t)).. (hea
85f0: 64 65 72 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 der (formdat:rea
8600: 64 2d 68 65 61 64 65 72 20 64 61 74 73 74 72 29 d-header datstr)
8610: 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 20 20 ).. (key
8620: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
8630: 3f 20 68 65 61 64 65 72 29 29 28 63 61 72 20 68 ? header))(car h
8640: 65 61 64 65 72 29 20 23 66 29 29 0a 09 20 20 20 eader) #f))..
8650: 20 20 20 20 28 72 65 6d 64 61 74 20 28 72 65 61 (remdat (rea
8660: 64 2d 73 74 72 69 6e 67 20 23 66 20 64 61 74 73 d-string #f dats
8670: 74 72 29 29 20 20 20 20 20 20 20 20 20 20 3b 3b tr)) ;;
8680: 20 75 73 65 64 20 69 6e 20 6e 65 78 74 20 6c 69 used in next li
8690: 6e 65 2c 20 64 69 73 63 61 72 64 20 69 66 20 67 ne, discard if g
86a0: 6f 74 20 64 61 74 61 2c 20 65 6c 73 65 20 72 65 ot data, else re
86b0: 76 65 72 74 20 74 6f 0a 09 20 20 20 20 20 20 20 vert to..
86c0: 28 61 6c 6c 64 61 74 20 28 69 66 20 6b 65 79 20 (alldat (if key
86d0: 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 64 61 (formdat:read-da
86e0: 74 20 72 65 6d 64 61 74 20 6b 65 79 29 20 23 66 t remdat key) #f
86f0: 29 29 20 20 20 20 3b 3b 20 74 72 79 20 74 6f 20 )) ;; try to
8700: 65 78 74 72 61 63 74 20 74 68 65 20 64 61 74 61 extract the data
8710: 0a 09 20 20 20 20 20 20 20 28 74 68 73 64 61 74 .. (thsdat
8720: 20 28 69 66 20 61 6c 6c 64 61 74 20 28 63 61 72 (if alldat (car
8730: 20 61 6c 6c 64 61 74 29 20 20 23 66 29 29 20 20 alldat) #f))
8740: 20 20 20 3b 3b 20 74 68 65 20 64 61 74 61 0a 09 ;; the data..
8750: 20 20 20 20 20 20 20 28 6e 65 77 64 61 74 20 28 (newdat (
8760: 69 66 20 61 6c 6c 64 61 74 20 28 63 61 64 72 20 if alldat (cadr
8770: 61 6c 6c 64 61 74 29 20 23 66 29 29 20 20 20 20 alldat) #f))
8780: 20 3b 3b 20 6c 65 66 74 20 6f 76 65 72 20 64 61 ;; left over da
8790: 74 61 2c 20 6d 75 73 74 20 70 72 6f 63 65 73 73 ta, must process
87a0: 20 2e 2e 2e 0a 09 20 20 20 20 20 20 20 28 74 68 ..... (th
87b0: 73 72 65 73 20 28 6c 69 73 74 20 68 65 61 64 65 sres (list heade
87c0: 72 20 74 68 73 64 61 74 29 29 20 20 20 20 20 20 r thsdat))
87d0: 20 20 20 20 20 20 20 3b 3b 20 73 70 65 63 75 6c ;; specul
87e0: 61 74 69 76 65 6c 79 20 63 6f 6e 73 74 72 75 63 atively construc
87f0: 74 20 72 65 73 75 6c 74 73 0a 09 20 20 20 20 20 t results..
8800: 20 20 28 6e 65 77 72 65 73 20 28 61 70 70 65 6e (newres (appen
8810: 64 20 72 65 73 20 28 6c 69 73 74 20 74 68 73 72 d res (list thsr
8820: 65 73 29 29 29 29 20 20 20 20 20 20 3b 3b 20 73 es)))) ;; s
8830: 70 65 63 75 6c 61 74 69 76 65 6c 79 20 63 6f 6e peculatively con
8840: 73 74 72 75 63 74 20 72 65 73 75 6c 74 73 0a 09 struct results..
8850: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
8860: 6f 72 74 20 64 61 74 73 74 72 29 0a 09 20 20 28 ort datstr).. (
8870: 63 6f 6e 64 0a 09 20 20 20 3b 3b 20 65 69 74 68 cond.. ;; eith
8880: 65 72 20 6e 6f 20 68 65 61 64 65 72 20 6f 72 20 er no header or
8890: 73 69 6e 67 6c 65 20 69 6e 70 75 74 0a 09 20 20 single input..
88a0: 20 28 28 61 6e 64 20 28 6e 6f 74 20 61 6c 6c 64 ((and (not alld
88b0: 61 74 29 0a 09 09 20 28 6f 72 20 28 6e 75 6c 6c at)... (or (null
88c0: 3f 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 ? header)...
88d0: 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 (not (string-ma
88e0: 74 63 68 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 tch formdat:deli
88f0: 6d 2d 70 61 74 74 2d 72 65 78 20 28 63 61 72 20 m-patt-rex (car
8900: 68 65 61 64 65 72 29 29 29 29 29 0a 09 20 20 20 header)))))..
8910: 20 3b 3b 20 28 70 72 69 6e 74 20 22 47 6f 74 20 ;; (print "Got
8920: 68 65 72 65 22 29 0a 09 20 20 20 20 28 63 6f 6e here").. (con
8930: 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 20 22 s (list header "
8940: 22 29 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 65 ") res)) ;; note
8950: 20 75 73 65 20 68 65 61 64 65 72 20 61 73 20 64 use header as d
8960: 61 74 20 61 6e 64 20 75 73 65 20 22 22 20 61 73 at and use "" as
8970: 20 68 65 61 64 65 72 3f 3f 3f 3f 0a 09 20 20 20 header????..
8980: 3b 3b 20 64 69 64 6e 27 74 20 66 69 6e 64 20 65 ;; didn't find e
8990: 6e 64 20 6b 65 79 20 69 6e 20 74 68 69 73 20 62 nd key in this b
89a0: 6c 6f 63 6b 0a 09 20 20 20 28 28 6e 6f 74 20 61 lock.. ((not a
89b0: 6c 6c 64 61 74 29 0a 09 20 20 20 20 28 6c 65 74 lldat).. (let
89c0: 20 28 28 6d 6f 72 64 61 74 20 28 72 65 61 64 2d ((mordat (read-
89d0: 73 74 72 69 6e 67 20 31 30 30 30 30 30 30 20 69 string 1000000 i
89e0: 6e 70 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 np))).. (if
89f0: 20 28 73 74 72 69 6e 67 3d 3f 20 6d 6f 72 64 61 (string=? morda
8a00: 74 20 22 22 29 20 3b 3b 20 74 68 65 72 65 20 69 t "") ;; there i
8a10: 73 20 6e 6f 20 6d 6f 72 65 20 64 61 74 61 2c 20 s no more data,
8a20: 64 69 73 63 61 72 64 20 72 65 73 75 6c 74 73 20 discard results
8a30: 61 6e 64 20 75 73 65 20 72 65 6d 64 61 74 20 61 and use remdat a
8a40: 73 20 64 61 74 61 2c 20 74 68 69 73 20 69 6e 70 s data, this inp
8a50: 75 74 20 69 73 20 62 72 6f 6b 65 6e 0a 09 09 20 ut is broken...
8a60: 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 68 65 61 (cons (list hea
8a70: 64 65 72 20 72 65 6d 64 61 74 29 20 72 65 73 29 der remdat) res)
8a80: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 ... (loop (stri
8a90: 6e 67 2d 61 70 70 65 6e 64 20 64 61 74 20 6d 6f ng-append dat mo
8aa0: 72 64 61 74 29 20 72 65 73 20 28 2b 20 73 69 7a rdat) res (+ siz
8ab0: 20 32 30 30 30 30 30 30 29 29 29 29 29 20 3b 3b 2000000))))) ;;
8ac0: 20 61 64 64 20 74 68 65 20 65 78 74 72 61 20 31 add the extra 1
8ad0: 30 30 30 30 30 30 0a 09 20 20 20 28 61 6c 6c 64 000000.. (alld
8ae0: 61 74 20 3b 3b 20 67 6f 74 20 64 61 74 61 2c 20 at ;; got data,
8af0: 64 6f 6e 27 74 20 61 74 74 65 6d 70 74 20 74 6f don't attempt to
8b00: 20 63 68 65 63 6b 20 69 66 20 74 68 65 72 65 20 check if there
8b10: 69 73 20 6d 6f 72 65 2c 20 6a 75 73 74 20 6c 6f is more, just lo
8b20: 6f 70 20 61 6e 64 20 72 65 6c 79 20 6f 6e 20 28 op and rely on (
8b30: 6e 6f 74 20 61 6c 6c 64 61 74 29 20 74 6f 20 67 not alldat) to g
8b40: 65 74 20 6d 6f 72 65 20 64 61 74 61 0a 09 20 20 et more data..
8b50: 20 20 28 6c 6f 6f 70 20 6e 65 77 64 61 74 20 6e (loop newdat n
8b60: 65 77 72 65 73 20 28 2b 20 73 69 7a 20 31 30 30 ewres (+ siz 100
8b70: 30 30 30 30 29 29 29 29 29 29 29 29 0a 0a 28 64 0000))))))))..(d
8b80: 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 efine formdat:bi
8b90: 6e 2d 64 61 74 61 2d 64 69 73 70 2d 72 65 78 20 n-data-disp-rex
8ba0: 28 72 65 67 65 78 70 20 22 5e 43 6f 6e 74 65 6e (regexp "^Conten
8bb0: 74 2d 44 69 73 70 6f 73 69 74 69 6f 6e 3a 5c 5c t-Disposition:\\
8bc0: 73 2b 66 6f 72 6d 2d 64 61 74 61 3b 22 29 29 0a s+form-data;")).
8bd0: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
8be0: 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 bin-data-name-re
8bf0: 78 20 28 72 65 67 65 78 70 20 22 5c 5c 57 6e 61 x (regexp "\\Wna
8c00: 6d 65 3d 5c 22 28 5b 5e 5c 22 5d 2b 29 5c 22 22 me=\"([^\"]+)\""
8c10: 29 29 0a 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 )).(define formd
8c20: 61 74 3a 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 at:bin-file-name
8c30: 2d 72 65 78 20 28 72 65 67 65 78 70 20 22 5c 5c -rex (regexp "\\
8c40: 57 66 69 6c 65 6e 61 6d 65 3d 5c 22 28 5b 5e 5c Wfilename=\"([^\
8c50: 22 5d 2b 29 5c 22 22 29 29 0a 28 64 65 66 69 6e "]+)\"")).(defin
8c60: 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 e formdat:bin-fi
8c70: 6c 65 2d 74 79 70 65 2d 72 65 78 20 28 72 65 67 le-type-rex (reg
8c80: 65 78 70 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 exp "Content-Typ
8c90: 65 3a 5c 5c 73 2b 28 5b 5e 5c 5c 73 5d 2b 29 22 e:\\s+([^\\s]+)"
8ca0: 29 29 0a 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 )).(define formd
8cb0: 61 74 3a 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 at:delim-patt-re
8cc0: 78 20 20 20 20 28 72 65 67 65 78 70 20 22 5e 5c x (regexp "^\
8cd0: 5c 2d 2b 5b 30 2d 39 5d 2b 5c 5c 2d 2a 24 22 29 \-+[0-9]+\\-*$")
8ce0: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 61 20 )..;; returns a
8cf0: 68 61 73 68 20 77 69 74 68 20 65 6e 74 72 69 65 hash with entrie
8d00: 73 20 66 6f 72 20 61 6c 6c 20 66 6f 72 6d 73 20 s for all forms
8d10: 2d 20 63 6f 75 6c 64 20 77 65 6c 6c 20 75 73 65 - could well use
8d20: 20 61 20 70 72 6f 70 6c 69 73 74 3f 0a 28 64 65 a proplist?.(de
8d30: 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 6c 6f fine (formdat:lo
8d40: 61 64 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 20 28 ad-all). (let (
8d50: 28 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 (request-method
8d60: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
8d70: 2d 76 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 -variable "REQUE
8d80: 53 54 5f 4d 45 54 48 4f 44 22 29 29 29 0a 20 20 ST_METHOD"))).
8d90: 20 20 28 69 66 20 28 61 6e 64 20 72 65 71 75 65 (if (and reque
8da0: 73 74 2d 6d 65 74 68 6f 64 0a 09 20 20 20 20 20 st-method..
8db0: 28 73 74 72 69 6e 67 3d 3f 20 72 65 71 75 65 73 (string=? reques
8dc0: 74 2d 6d 65 74 68 6f 64 20 22 50 4f 53 54 22 29 t-method "POST")
8dd0: 29 0a 09 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 )..(formdat:load
8de0: 2d 61 6c 6c 2d 70 6f 72 74 20 28 63 75 72 72 65 -all-port (curre
8df0: 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 nt-input-port)))
8e00: 29 29 0a 0a 3b 3b 20 28 73 3a 70 72 6f 63 65 73 ))..;; (s:proces
8e10: 73 2d 63 67 69 2d 69 6e 70 75 74 20 28 63 61 61 s-cgi-input (caa
8e20: 61 72 20 64 61 74 29 29 0a 28 64 65 66 69 6e 65 ar dat)).(define
8e30: 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 (formdat:load-a
8e40: 6c 6c 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 28 ll-port inp). (
8e50: 6c 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 20 let* ((formdat
8e60: 20 20 20 20 20 20 28 6d 61 6b 65 2d 66 6f 72 6d (make-form
8e70: 64 61 74 3a 66 6f 72 6d 64 61 74 29 29 0a 09 20 dat:formdat))..
8e80: 28 64 65 62 75 67 70 20 20 20 20 20 20 20 20 20 (debugp
8e90: 23 66 29 29 0a 09 09 09 20 3b 3b 20 28 6f 70 65 #f)).... ;; (ope
8ea0: 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 63 n-output-file (c
8eb0: 6f 6e 63 20 22 2f 74 6d 70 2f 64 65 6c 6d 65 2d onc "/tmp/delme-
8ec0: 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d " (current-user-
8ed0: 69 64 29 20 22 2e 6c 6f 67 22 29 29 29 29 0a 20 id) ".log")))).
8ee0: 20 20 20 3b 3b 20 28 77 72 69 74 65 2d 73 74 72 ;; (write-str
8ef0: 69 6e 67 20 28 72 65 61 64 2d 73 74 72 69 6e 67 ing (read-string
8f00: 20 23 66 20 69 6e 70 29 20 23 66 20 64 65 62 75 #f inp) #f debu
8f10: 67 70 29 20 20 3b 3b 20 64 65 73 74 72 6f 79 73 gp) ;; destroys
8f20: 20 61 6c 6c 20 64 61 74 61 21 0a 20 20 20 20 28 all data!. (
8f30: 66 6f 72 6d 64 61 74 3a 69 6e 69 74 69 61 6c 69 formdat:initiali
8f40: 7a 65 20 66 6f 72 6d 64 61 74 29 0a 20 20 20 20 ze formdat).
8f50: 28 6c 65 74 20 28 28 61 6c 6c 64 61 74 73 20 28 (let ((alldats (
8f60: 66 6f 72 6d 64 61 74 3a 64 61 74 2d 3e 6c 69 73 formdat:dat->lis
8f70: 74 20 69 6e 70 20 31 30 65 36 20 64 65 62 75 67 t inp 10e6 debug
8f80: 2d 70 6f 72 74 3a 20 64 65 62 75 67 70 29 29 29 -port: debugp)))
8f90: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 . . (i
8fa0: 66 20 64 65 62 75 67 70 20 28 66 6f 72 6d 61 74 f debugp (format
8fb0: 20 64 65 62 75 67 70 20 22 66 6f 72 6d 64 61 74 debugp "formdat
8fc0: 20 3a 20 61 6c 6c 64 61 74 73 3a 20 7e 41 5c 6e : alldats: ~A\n
8fd0: 22 20 61 6c 6c 64 61 74 73 29 29 0a 0a 20 20 20 " alldats))..
8fe0: 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 74 69 (let ((firsti
8ff0: 74 65 6d 20 20 20 28 63 61 72 20 61 6c 6c 64 61 tem (car allda
9000: 74 73 29 29 0a 09 20 20 20 20 28 6d 75 6c 74 69 ts)).. (multi
9010: 70 61 73 73 20 23 66 29 29 20 0a 09 28 69 66 20 pass #f)) ..(if
9020: 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
9030: 20 66 69 72 73 74 69 74 65 6d 29 29 0a 09 09 20 firstitem))...
9040: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 28 63 61 72 (not (null? (car
9050: 20 66 69 72 73 74 69 74 65 6d 29 29 29 29 0a 09 firstitem))))..
9060: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d (if (string-
9070: 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a 64 65 match formdat:de
9080: 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 28 63 61 lim-patt-rex (ca
9090: 61 72 20 66 69 72 73 74 69 74 65 6d 29 29 0a 09 ar firstitem))..
90a0: 09 28 73 65 74 21 20 6d 75 6c 74 69 70 61 73 73 .(set! multipass
90b0: 20 23 74 29 29 29 0a 09 28 69 66 20 6d 75 6c 74 #t)))..(if mult
90c0: 69 70 61 73 73 0a 09 20 20 20 20 3b 3b 20 68 61 ipass.. ;; ha
90d0: 6e 64 6c 65 20 6d 75 6c 74 69 2d 70 61 72 74 20 ndle multi-part
90e0: 66 6f 72 6d 0a 09 20 20 20 20 28 66 6f 72 2d 65 form.. (for-e
90f0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 64 61 74 ach (lambda (dat
9100: 6c 73 74 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 lst)....(let* ((
9110: 68 65 61 64 65 72 20 28 66 6f 72 6d 64 61 74 3a header (formdat:
9120: 65 78 74 72 61 63 74 2d 68 65 61 64 65 72 2d 69 extract-header-i
9130: 6e 66 6f 20 28 63 61 72 20 64 61 74 6c 73 74 29 nfo (car datlst)
9140: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e 61 )).... (na
9150: 6d 65 20 20 20 28 69 66 20 28 61 73 73 6f 63 20 me (if (assoc
9160: 27 6e 61 6d 65 20 68 65 61 64 65 72 29 0a 09 09 'name header)...
9170: 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 ... (string->s
9180: 79 6d 62 6f 6c 20 28 63 61 64 72 20 28 61 73 73 ymbol (cadr (ass
9190: 6f 63 20 27 6e 61 6d 65 20 68 65 61 64 65 72 29 oc 'name header)
91a0: 29 29 0a 09 09 09 09 09 20 20 20 22 22 29 29 20 ))...... ""))
91b0: 3b 3b 20 67 72 75 6d 62 6c 65 0a 09 09 09 20 20 ;; grumble....
91c0: 20 20 20 20 20 28 66 6e 61 6d 65 6c 20 20 28 61 (fnamel (a
91d0: 73 73 6f 63 20 27 66 69 6c 65 6e 61 6d 65 20 68 ssoc 'filename h
91e0: 65 61 64 65 72 29 29 0a 09 09 09 20 20 20 20 20 eader))....
91f0: 20 20 28 63 6f 6e 74 65 6e 74 20 28 61 73 73 6f (content (asso
9200: 63 20 27 63 6f 6e 74 65 6e 74 20 68 65 61 64 65 c 'content heade
9210: 72 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 r)).... (d
9220: 61 74 20 20 20 20 28 63 61 64 72 20 64 61 74 6c at (cadr datl
9230: 73 74 29 29 29 0a 09 09 09 20 20 3b 3b 20 28 70 st))).... ;; (p
9240: 72 69 6e 74 20 22 68 65 61 64 65 72 3a 20 22 20 rint "header: "
9250: 68 65 61 64 65 72 20 22 20 6e 61 6d 65 3a 20 22 header " name: "
9260: 20 6e 61 6d 65 20 22 20 66 6e 61 6d 65 6c 3a 20 name " fnamel:
9270: 22 20 66 6e 61 6d 65 6c 20 22 20 63 6f 6e 74 65 " fnamel " conte
9280: 6e 74 3a 20 22 20 63 6f 6e 74 65 6e 74 29 20 3b nt: " content) ;
9290: 3b 20 20 22 20 64 61 74 3a 20 22 20 28 64 61 74 ; " dat: " (dat
92a0: 29 0a 09 09 09 20 20 28 66 6f 72 6d 64 61 74 3a ).... (formdat:
92b0: 73 65 74 21 20 66 6f 72 6d 64 61 74 20 0a 09 09 set! formdat ...
92c0: 09 09 09 6e 61 6d 65 0a 09 09 09 09 09 28 69 66 ...name......(if
92d0: 20 66 6e 61 6d 65 6c 20 0a 09 09 09 09 09 20 20 fnamel ......
92e0: 20 20 28 6c 69 73 74 20 28 63 61 64 72 20 66 6e (list (cadr fn
92f0: 61 6d 65 6c 29 0a 09 09 09 09 09 09 20 20 28 69 amel)....... (i
9300: 66 20 63 6f 6e 74 65 6e 74 0a 09 09 09 09 09 09 f content.......
9310: 20 20 20 20 20 20 28 63 61 64 72 20 63 6f 6e 74 (cadr cont
9320: 65 6e 74 29 0a 09 09 09 09 09 09 20 20 20 20 20 ent).......
9330: 20 22 75 6e 6b 6e 6f 77 6e 22 29 0a 09 09 09 09 "unknown").....
9340: 09 09 20 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f .. (string->blo
9350: 62 20 64 61 74 29 29 0a 09 09 09 09 09 20 20 20 b dat))......
9360: 20 64 61 74 29 29 29 29 0a 09 09 20 20 20 20 20 dat))))...
9370: 20 61 6c 6c 64 61 74 73 29 0a 09 20 20 20 20 3b alldats).. ;
9380: 3b 20 68 61 6e 64 6c 65 20 73 69 6e 67 6c 65 20 ; handle single
9390: 70 61 72 74 20 66 6f 72 6d 0a 09 20 20 20 20 3b part form.. ;
93a0: 3b 20 09 28 69 66 20 28 61 6e 64 20 28 73 74 72 ; .(if (and (str
93b0: 69 6e 67 3f 20 6e 61 6d 65 29 0a 09 20 20 20 20 ing? name)..
93c0: 3b 3b 20 09 09 20 20 20 20 20 28 73 74 72 69 6e ;; .. (strin
93d0: 67 3d 3f 20 6e 61 6d 65 20 22 22 29 29 20 3b 3b g=? name "")) ;;
93e0: 20 74 68 69 73 20 69 73 20 74 68 65 20 73 68 6f this is the sho
93f0: 72 74 20 66 6f 72 6d 20 69 6e 70 75 74 20 49 20 rt form input I
9400: 67 75 65 73 73 0a 09 20 20 20 20 3b 3b 20 09 09 guess.. ;; ..
9410: 28 6c 65 74 2a 20 28 28 64 61 74 73 74 72 20 28 (let* ((datstr (
9420: 63 61 61 72 20 64 61 74 6c 73 74 29 29 0a 09 20 caar datlst))..
9430: 20 20 20 3b 3b 20 09 09 20 20 20 20 20 20 20 28 ;; .. (
9440: 6d 75 6e 67 65 64 20 28 73 3a 70 72 6f 63 65 73 munged (s:proces
9450: 73 2d 63 67 69 2d 69 6e 70 75 74 20 64 61 74 73 s-cgi-input dats
9460: 74 72 29 29 29 0a 09 20 20 20 20 3b 3b 20 09 09 tr))).. ;; ..
9470: 20 20 28 70 72 69 6e 74 20 22 64 61 74 73 74 72 (print "datstr
9480: 3a 20 22 20 64 61 74 73 74 72 20 22 20 6d 75 6e : " datstr " mun
9490: 67 65 64 3a 20 22 20 6d 75 6e 67 65 64 29 0a 09 ged: " munged)..
94a0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f (if (and (no
94b0: 74 20 28 6e 75 6c 6c 3f 20 61 6c 6c 64 61 74 73 t (null? alldats
94c0: 29 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 28 ))... (not (
94d0: 6e 75 6c 6c 3f 20 28 63 61 72 20 61 6c 6c 64 61 null? (car allda
94e0: 74 73 29 29 29 0a 09 09 20 20 20 20 20 28 6e 6f ts)))... (no
94f0: 74 20 28 6e 75 6c 6c 3f 20 28 63 61 61 72 20 61 t (null? (caar a
9500: 6c 6c 64 61 74 73 29 29 29 29 0a 09 09 28 66 6f lldats))))...(fo
9510: 72 6d 64 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 rmdat:load formd
9520: 61 74 20 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 at (s:process-c
9530: 67 69 2d 69 6e 70 75 74 20 28 63 61 61 61 72 20 gi-input (caaar
9540: 61 6c 6c 64 61 74 73 29 29 29 29 29 20 3b 3b 20 alldats))))) ;;
9550: 6d 75 6e 67 65 64 29 29 0a 09 3b 3b 09 09 20 20 munged))..;;..
9560: 20 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 (format debugp
9570: 20 22 66 6f 72 6d 64 61 74 20 3a 20 6e 61 6d 65 "formdat : name
9580: 3a 20 7e 41 20 63 6f 6e 74 65 6e 74 3a 20 7e 41 : ~A content: ~A
9590: 5c 6e 22 20 6e 61 6d 65 20 63 6f 6e 74 65 6e 74 \n" name content
95a0: 29 0a 09 28 69 66 20 64 65 62 75 67 70 20 28 63 )..(if debugp (c
95b0: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
95c0: 20 64 65 62 75 67 70 29 29 0a 09 66 6f 72 6d 64 debugp))..formd
95d0: 61 74 29 29 29 29 0a 09 09 0a 23 7c 0a 28 64 65 at))))....#|.(de
95e0: 66 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 fine inp (open-i
95f0: 6e 70 75 74 2d 66 69 6c 65 20 22 74 65 73 74 73 nput-file "tests
9600: 2f 65 78 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 6e /example.post.in
9610: 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 ")).(define dat
9620: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 (read-string #f
9630: 69 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 61 inp)).(define da
9640: 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 tstr (open-input
9650: 2d 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a 3b -string dat))..;
9660: 3b 20 6f 72 0a 0a 28 64 65 66 69 6e 65 20 69 6e ; or..(define in
9670: 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 p (open-input-fi
9680: 6c 65 20 22 74 65 73 74 73 2f 65 78 61 6d 70 6c le "tests/exampl
9690: 65 2e 70 6f 73 74 2e 62 69 6e 61 72 79 2e 69 6e e.post.binary.in
96a0: 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 ")).(define dat
96b0: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 (read-string #f
96c0: 69 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 61 inp)).(define da
96d0: 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 tstr (open-input
96e0: 2d 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a 28 -string dat))..(
96f0: 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 formdat:read-hea
9700: 64 65 72 20 64 61 74 73 74 72 29 0a 0a 28 64 65 der datstr)..(de
9710: 66 69 6e 65 20 64 61 74 20 28 66 6f 72 6d 64 61 fine dat (formda
9720: 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 t:dat->list inp
9730: 31 30 65 36 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 10e6)).(close-in
9740: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 put-port inp).|#
9750: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 . .(define (for
9760: 6d 64 61 74 3a 65 78 74 72 61 63 74 2d 68 65 61 mdat:extract-hea
9770: 64 65 72 2d 69 6e 66 6f 20 68 65 61 64 65 72 29 der-info header)
9780: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 68 65 . (if (null? he
9790: 61 64 65 72 29 0a 20 20 20 20 20 20 27 28 29 0a ader). '().
97a0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
97b0: 28 28 68 65 64 20 28 63 61 72 20 68 65 61 64 65 ((hed (car heade
97c0: 72 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 r))... (tal (cdr
97d0: 20 68 65 61 64 65 72 29 29 0a 09 09 20 28 72 65 header))... (re
97e0: 73 20 27 28 29 29 29 0a 09 28 69 66 20 28 73 74 s '()))..(if (st
97f0: 72 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 ring-match formd
9800: 61 74 3a 62 69 6e 2d 64 61 74 61 2d 64 69 73 70 at:bin-data-disp
9810: 2d 72 65 78 20 68 65 64 29 20 3b 3b 20 0a 09 20 -rex hed) ;; ..
9820: 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 61 2d (let* ((data-
9830: 6e 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 namem (string-ma
9840: 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d tch formdat:bin-
9850: 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 68 65 data-name-rex he
9860: 64 29 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 6e d))... (file-n
9870: 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 amem (string-mat
9880: 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 ch formdat:bin-f
9890: 69 6c 65 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 ile-name-rex hed
98a0: 29 29 0a 09 09 20 20 20 28 64 61 74 61 2d 6e 61 ))... (data-na
98b0: 6d 65 20 20 28 69 66 20 64 61 74 61 2d 6e 61 6d me (if data-nam
98c0: 65 6d 20 28 63 61 64 72 20 64 61 74 61 2d 6e 61 em (cadr data-na
98d0: 6d 65 6d 29 20 23 66 29 29 0a 09 09 20 20 20 28 mem) #f))... (
98e0: 74 68 69 73 20 20 20 20 20 20 20 28 69 66 20 66 this (if f
98f0: 69 6c 65 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 20 ile-namem.....
9900: 20 28 6c 69 73 74 20 28 6c 69 73 74 20 27 6e 61 (list (list 'na
9910: 6d 65 20 64 61 74 61 2d 6e 61 6d 65 29 28 6c 69 me data-name)(li
9920: 73 74 20 27 66 69 6c 65 6e 61 6d 65 20 28 63 61 st 'filename (ca
9930: 64 72 20 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 29 dr file-namem)))
9940: 0a 09 09 09 09 20 20 20 28 6c 69 73 74 20 28 6c ..... (list (l
9950: 69 73 74 20 27 6e 61 6d 65 20 64 61 74 61 2d 6e ist 'name data-n
9960: 61 6d 65 29 29 29 29 29 0a 09 20 20 20 20 20 20 ame)))))..
9970: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
9980: 09 09 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 .. (append res
9990: 74 68 69 73 29 0a 09 09 20 20 28 6c 6f 6f 70 20 this)... (loop
99a0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
99b0: 6c 29 28 61 70 70 65 6e 64 20 72 65 73 20 74 68 l)(append res th
99c0: 69 73 29 29 29 29 0a 09 20 20 20 20 28 6c 65 74 is)))).. (let
99d0: 20 28 28 63 6f 6e 74 65 6e 74 20 28 73 74 72 69 ((content (stri
99e0: 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 ng-match formdat
99f0: 3a 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 :bin-file-type-r
9a00: 65 78 20 68 65 64 29 29 29 20 3b 3b 20 74 68 69 ex hed))) ;; thi
9a10: 73 20 69 73 20 74 68 65 20 73 74 61 6e 7a 61 20 s is the stanza
9a20: 66 6f 72 20 74 68 65 20 63 6f 6e 74 65 6e 74 20 for the content
9a30: 74 79 70 65 0a 09 20 20 20 20 20 20 28 69 66 20 type.. (if
9a40: 63 6f 6e 74 65 6e 74 0a 09 09 20 20 28 6c 65 74 content... (let
9a50: 20 28 28 6e 65 77 72 65 73 20 28 63 6f 6e 73 20 ((newres (cons
9a60: 28 6c 69 73 74 20 27 63 6f 6e 74 65 6e 74 20 28 (list 'content (
9a70: 63 61 64 72 20 63 6f 6e 74 65 6e 74 29 29 20 72 cadr content)) r
9a80: 65 73 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 es)))... (if
9a90: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 6e (null? tal)....n
9aa0: 65 77 72 65 73 0a 09 09 09 28 6c 6f 6f 70 20 28 ewres....(loop (
9ab0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
9ac0: 29 20 6e 65 77 72 65 73 29 29 29 0a 09 09 20 20 ) newres)))...
9ad0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
9ae0: 09 09 20 20 20 20 20 20 72 65 73 0a 09 09 20 20 .. res...
9af0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
9b00: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 73 al)(cdr tal) res
9b10: 29 0a 09 09 20 20 20 20 20 20 29 29 29 29 29 29 )... ))))))
9b20: 29 0a 0a 3b 3b 09 20 20 20 20 20 20 28 6c 65 74 )..;;. (let
9b30: 20 6c 6f 6f 70 20 28 28 6c 20 20 20 20 20 20 20 loop ((l
9b40: 28 72 65 61 64 2d 6c 69 6e 65 29 29 20 3b 3b 20 (read-line)) ;;
9b50: 28 69 66 20 28 65 71 3f 20 6d 6f 64 65 20 27 6e (if (eq? mode 'n
9b60: 6f 72 6d 29 28 72 65 61 64 2d 6c 69 6e 65 29 28 orm)(read-line)(
9b70: 72 65 61 64 2d 63 68 61 72 29 29 29 0a 3b 3b 09 read-char))).;;.
9b80: 09 09 20 28 65 6e 64 6c 69 6e 65 20 23 66 29 0a .. (endline #f).
9b90: 3b 3b 09 09 09 20 28 6e 75 6d 20 20 20 20 20 30 ;;... (num 0
9ba0: 29 29 0a 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 61 )).;;..;; (forma
9bb0: 74 20 64 65 62 75 67 70 20 22 7e 41 5c 6e 22 20 t debugp "~A\n"
9bc0: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
9bd0: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
9be0: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 29 (eof-object? l))
9bf0: 0a 3b 3b 09 09 20 20 20 20 20 20 28 6e 6f 74 20 .;;.. (not
9c00: 28 61 6e 64 20 28 65 71 3f 20 6d 6f 64 65 20 27 (and (eq? mode '
9c10: 62 69 6e 29 0a 3b 3b 09 09 09 09 28 73 74 72 69 bin).;;....(stri
9c20: 6e 67 3d 3f 20 6c 20 22 22 29 29 29 29 20 3b 3b ng=? l "")))) ;;
9c30: 20 69 66 20 69 6e 20 62 69 6e 20 6d 6f 64 65 20 if in bin mode
9c40: 65 6d 70 74 79 20 73 74 72 69 6e 67 20 69 73 20 empty string is
9c50: 65 6e 64 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 09 end of file.;;..
9c60: 20 20 28 63 61 73 65 20 6d 6f 64 65 0a 3b 3b 09 (case mode.;;.
9c70: 09 20 20 20 20 28 28 73 74 61 72 74 29 0a 3b 3b . ((start).;;
9c80: 09 09 20 20 20 20 20 28 73 65 74 21 20 6d 6f 64 .. (set! mod
9c90: 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 e 'norm).;;..
9ca0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
9cb0: 74 63 68 20 64 65 6c 69 6d 2d 70 61 74 74 2d 72 tch delim-patt-r
9cc0: 65 78 20 6c 29 0a 3b 3b 09 09 09 20 28 62 65 67 ex l).;;... (beg
9cd0: 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 21 in.;;... (set!
9ce0: 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 6c 29 delim-string l)
9cf0: 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 64 .;;... (set! d
9d00: 65 6c 69 6d 2d 6c 65 6e 20 20 20 20 28 73 74 72 elim-len (str
9d10: 69 6e 67 2d 6c 65 6e 67 74 68 20 6c 29 29 0a 3b ing-length l)).;
9d20: 3b 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 ;... (loop (re
9d30: 61 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 0a ad-line) #f 0)).
9d40: 3b 3b 09 09 09 20 28 6c 6f 6f 70 20 6c 20 23 66 ;;... (loop l #f
9d50: 20 30 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 0))).;;.. ((
9d60: 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 3b norm).;;.. ;
9d70: 3b 20 49 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 ; I don't like h
9d80: 6f 77 20 74 68 69 73 20 67 65 74 73 20 63 68 65 ow this gets che
9d90: 63 6b 65 64 20 6f 6e 20 65 76 65 72 79 20 73 69 cked on every si
9da0: 6e 67 6c 65 20 69 6e 70 75 74 2e 20 4d 75 73 74 ngle input. Must
9db0: 20 62 65 20 61 20 62 65 74 74 65 72 20 77 61 79 be a better way
9dc0: 2e 20 46 49 58 4d 45 0a 3b 3b 09 09 20 20 20 20 . FIXME.;;..
9dd0: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
9de0: 67 2d 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 61 g-match bin-data
9df0: 2d 64 69 73 70 2d 72 65 78 20 6c 29 0a 3b 3b 09 -disp-rex l).;;.
9e00: 09 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
9e10: 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e match bin-data-n
9e20: 61 6d 65 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 ame-rex l).;;...
9e30: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 (string-ma
9e40: 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d tch bin-file-nam
9e50: 65 2d 72 65 78 20 6c 29 29 0a 3b 3b 09 09 09 20 e-rex l)).;;...
9e60: 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 (begin.;;... (
9e70: 73 65 74 21 20 64 61 74 61 2d 6e 61 6d 65 20 28 set! data-name (
9e80: 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 cadr (string-mat
9e90: 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 ch bin-data-name
9ea0: 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 -rex l))).;;...
9eb0: 20 20 28 73 65 74 21 20 66 69 6c 65 2d 6e 61 6d (set! file-nam
9ec0: 65 20 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d e (cadr (string-
9ed0: 6d 61 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e match bin-file-n
9ee0: 61 6d 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 ame-rex l))).;;.
9ef0: 09 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 .. (set! mode
9f00: 27 63 6f 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 20 'content).;;...
9f10: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
9f20: 6e 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b ne) #f num))).;;
9f30: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 .. (let* ((d
9f40: 61 74 20 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 at (s:process-c
9f50: 67 69 2d 69 6e 70 75 74 20 6c 29 29 29 20 3b 3b gi-input l))) ;;
9f60: 20 28 43 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 (CGI:url-unquot
9f70: 65 20 6c 29 29 0a 3b 3b 09 09 20 20 20 20 20 20 e l)).;;..
9f80: 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 (format debugp
9f90: 22 50 52 4f 43 45 53 53 2d 43 47 49 2d 49 4e 50 "PROCESS-CGI-INP
9fa0: 55 54 3a 20 7e 41 5c 6e 22 20 28 69 6e 74 65 72 UT: ~A\n" (inter
9fb0: 73 70 65 72 73 65 20 64 61 74 20 22 2c 22 29 29 sperse dat ","))
9fc0: 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 66 6f 72 .;;.. (for
9fd0: 6d 64 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 mdat:load formda
9fe0: 74 20 64 61 74 29 0a 3b 3b 09 09 20 20 20 20 20 t dat).;;..
9ff0: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
a000: 6e 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b ne) #f num))).;;
a010: 09 09 20 20 20 20 28 28 63 6f 6e 74 65 6e 74 29 .. ((content)
a020: 0a 3b 3b 09 09 20 20 20 20 20 28 69 66 20 28 73 .;;.. (if (s
a030: 74 72 69 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d tring-match bin-
a040: 66 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 6c 29 file-type-rex l)
a050: 0a 3b 3b 09 09 09 20 28 62 65 67 69 6e 20 0a 3b .;;... (begin .;
a060: 3b 09 09 09 20 20 20 28 73 65 74 21 20 6d 6f 64 ;... (set! mod
a070: 65 20 27 62 69 6e 29 0a 3b 3b 09 09 09 20 20 20 e 'bin).;;...
a080: 28 73 65 74 21 20 64 61 74 61 2d 74 79 70 65 20 (set! data-type
a090: 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 (cadr (string-ma
a0a0: 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 74 79 70 tch bin-file-typ
a0b0: 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 e-rex l))).;;...
a0c0: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 73 (loop (read-s
a0d0: 74 72 69 6e 67 20 31 29 20 23 66 20 6e 75 6d 29 tring 1) #f num)
a0e0: 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 62 69 ))).;;.. ((bi
a0f0: 6e 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 64 n).;;.. ;; d
a100: 65 6c 69 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e 22 elim-string: \n"
a110: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 ---------------1
a120: 32 33 34 35 22 0a 3b 3b 09 09 20 20 20 20 20 3b 2345".;;.. ;
a130: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
a140: 20 20 20 30 31 32 33 34 35 36 37 38 39 30 31 32 0123456789012
a150: 33 34 35 36 37 38 39 30 0a 3b 3b 09 09 20 20 20 34567890.;;..
a160: 20 20 3b 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 20 ;; endline:
a170: 20 20 20 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "----------
a180: 2d 2d 2d 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 20 -----12".;;..
a190: 20 20 3b 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b 09 ;; l = "3".;;.
a1a0: 09 20 20 20 20 20 3b 3b 20 64 65 6c 69 6d 2d 6c . ;; delim-l
a1b0: 65 6e 20 3d 20 32 30 0a 3b 3b 09 09 20 20 20 20 en = 20.;;..
a1c0: 20 3b 3b 20 28 73 75 62 73 74 72 69 6e 67 20 20 ;; (substring
a1d0: 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "---------------
a1e0: 31 32 33 34 35 22 20 31 37 20 31 38 29 20 3d 3e 12345" 17 18) =>
a1f0: 20 22 33 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b "3".;;.. ;;
a200: 0a 3b 3b 09 09 20 20 20 20 20 28 63 6f 6e 64 0a .;;.. (cond.
a210: 3b 3b 09 09 20 20 20 20 20 20 20 3b 3b 20 68 61 ;;.. ;; ha
a220: 76 65 6e 27 74 20 66 6f 75 6e 64 20 74 68 65 20 ven't found the
a230: 73 74 61 72 74 20 6f 66 20 61 6e 20 65 6e 64 6c start of an endl
a240: 69 6e 65 2c 20 69 73 20 74 68 65 20 6e 65 78 74 ine, is the next
a250: 20 63 68 61 72 20 61 20 6e 65 77 6c 69 6e 65 3f char a newline?
a260: 0a 3b 3b 09 09 20 20 20 20 20 20 28 28 61 6e 64 .;;.. ((and
a270: 20 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 29 0a 3b (not endline).;
a280: 3b 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 3d ;... (string=
a290: 3f 20 6c 20 22 5c 6e 22 29 29 20 3b 3b 20 72 65 ? l "\n")) ;; re
a2a0: 71 75 69 72 65 64 20 66 69 72 73 74 20 63 68 61 quired first cha
a2b0: 72 61 63 74 65 72 20 0a 3b 3b 09 09 20 20 20 20 racter .;;..
a2c0: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 65 6e 64 (let ((newend
a2d0: 6c 69 6e 65 20 28 6f 70 65 6e 2d 6f 75 74 70 75 line (open-outpu
a2e0: 74 2d 73 74 72 69 6e 67 29 29 29 0a 3b 3b 09 09 t-string))).;;..
a2f0: 09 20 3b 3b 20 28 77 72 69 74 65 2d 6c 69 6e 65 . ;; (write-line
a300: 20 6c 20 6e 65 77 65 6e 64 6c 69 6e 65 29 20 3b l newendline) ;
a310: 3b 20 64 69 73 63 61 72 64 20 74 68 65 20 6e 65 ; discard the ne
a320: 77 6c 69 6e 65 2e 20 61 64 64 20 69 74 20 62 61 wline. add it ba
a330: 63 6b 20 69 66 20 64 6f 6e 27 74 20 68 61 76 65 ck if don't have
a340: 20 61 20 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 6d a lock on delim
a350: 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 28 6c -string.;;... (l
a360: 6f 6f 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 oop (read-string
a370: 20 31 29 20 6e 65 77 65 6e 64 6c 69 6e 65 20 28 1) newendline (
a380: 2b 20 6e 75 6d 20 31 29 29 29 29 0a 3b 3b 09 09 + num 1)))).;;..
a390: 20 20 20 20 20 20 28 28 6e 6f 74 20 65 6e 64 6c ((not endl
a3a0: 69 6e 65 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 ine).;;..
a3b0: 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c 20 (write-string l
a3c0: 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 #f bin-dat).;;..
a3d0: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 (loop (re
a3e0: 61 64 2d 73 74 72 69 6e 67 20 31 29 20 23 66 20 ad-string 1) #f
a3f0: 28 2b 20 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 09 (+ num 1))).;;..
a400: 20 20 20 20 20 20 3b 3b 20 73 74 72 69 6e 67 20 ;; string
a410: 73 6f 20 66 61 72 20 6d 61 74 63 68 65 73 20 64 so far matches d
a420: 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 elim-string.;;..
a430: 20 20 20 20 20 20 28 65 6e 64 6c 69 6e 65 0a 3b (endline.;
a440: 3b 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ;.. (let*
a450: 28 28 65 6e 64 73 74 72 20 28 67 65 74 2d 6f 75 ((endstr (get-ou
a460: 74 70 75 74 2d 73 74 72 69 6e 67 20 65 6e 64 6c tput-string endl
a470: 69 6e 65 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 ine)).;;...
a480: 20 28 65 6e 64 6c 65 6e 20 28 73 74 72 69 6e 67 (endlen (string
a490: 2d 6c 65 6e 67 74 68 20 65 6e 64 73 74 72 29 29 -length endstr))
a4a0: 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 3e 20 65 ).;;... (if (> e
a4b0: 6e 64 6c 65 6e 20 30 29 0a 3b 3b 09 09 09 20 20 ndlen 0).;;...
a4c0: 20 20 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 (format debug
a4d0: 70 20 22 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e 65 p " delim: ~A\ne
a4e0: 6e 64 73 74 72 3a 20 7e 41 5c 6e 22 20 64 65 6c ndstr: ~A\n" del
a4f0: 69 6d 2d 73 74 72 69 6e 67 20 65 6e 64 73 74 72 im-string endstr
a500: 29 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 61 6e )).;;... (if (an
a510: 64 20 28 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 d (> delim-len e
a520: 6e 64 6c 65 6e 29 0a 3b 3b 09 09 09 09 20 20 28 ndlen).;;.... (
a530: 73 74 72 69 6e 67 3d 3f 20 6c 20 28 73 75 62 73 string=? l (subs
a540: 74 72 69 6e 67 20 64 65 6c 69 6d 2d 73 74 72 69 tring delim-stri
a550: 6e 67 20 65 6e 64 6c 65 6e 20 28 2b 20 65 6e 64 ng endlen (+ end
a560: 6c 65 6e 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 len 1)))).;;...
a570: 20 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 ;; yes, this
a580: 20 63 68 61 72 61 63 74 65 72 20 6d 61 74 63 68 character match
a590: 65 73 20 74 68 65 20 6e 65 78 74 20 69 6e 20 74 es the next in t
a5a0: 68 65 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a he delim-string.
a5b0: 3b 3b 09 09 09 20 20 20 20 20 28 69 66 20 28 65 ;;... (if (e
a5c0: 71 3f 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 q? delim-len end
a5d0: 6c 65 6e 29 20 3b 3b 20 68 61 76 65 20 61 20 6d len) ;; have a m
a5e0: 61 74 63 68 21 20 49 67 6e 6f 72 65 20 74 68 61 atch! Ignore tha
a5f0: 74 20 61 20 6e 65 77 6c 69 6e 65 20 69 73 20 72 t a newline is r
a600: 65 71 75 69 72 65 64 2e 20 4c 61 7a 79 20 62 75 equired. Lazy bu
a610: 67 67 65 72 2e 0a 3b 3b 09 09 09 09 20 28 6c 65 gger..;;.... (le
a620: 74 2a 20 28 28 66 6e 20 20 20 20 20 20 28 73 74 t* ((fn (st
a630: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 74 ring->symbol dat
a640: 61 2d 6e 61 6d 65 29 29 29 0a 3b 3b 09 09 09 09 a-name))).;;....
a650: 20 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 (formdat:set!
a660: 20 66 6f 72 6d 64 61 74 20 66 6e 20 28 6c 69 73 formdat fn (lis
a670: 74 20 66 69 6c 65 2d 6e 61 6d 65 20 64 61 74 61 t file-name data
a680: 2d 74 79 70 65 20 28 73 74 72 69 6e 67 2d 3e 62 -type (string->b
a690: 6c 6f 62 20 28 67 65 74 2d 6f 75 74 70 75 74 2d lob (get-output-
a6a0: 73 74 72 69 6e 67 20 62 69 6e 2d 64 61 74 29 29 string bin-dat))
a6b0: 29 29 0a 3b 3b 09 09 09 09 20 20 20 28 73 65 74 )).;;.... (set
a6c0: 21 20 6d 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b ! mode 'norm).;;
a6d0: 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 .... (loop (re
a6e0: 61 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 0a ad-line) #f 0)).
a6f0: 3b 3b 09 09 09 09 20 28 62 65 67 69 6e 0a 3b 3b ;;.... (begin.;;
a700: 09 09 09 09 20 20 20 28 77 72 69 74 65 2d 73 74 .... (write-st
a710: 72 69 6e 67 20 6c 20 23 66 20 65 6e 64 6c 69 6e ring l #f endlin
a720: 65 29 0a 3b 3b 09 09 09 09 20 20 20 28 6c 6f 6f e).;;.... (loo
a730: 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 p (read-string 1
a740: 29 20 65 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 6d ) endline (+ num
a750: 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 1)))).;;...
a760: 20 3b 3b 20 6e 6f 2c 20 74 68 69 73 20 63 68 61 ;; no, this cha
a770: 72 61 63 74 65 72 20 64 6f 65 73 20 4e 4f 54 20 racter does NOT
a780: 6d 61 74 63 68 20 74 68 65 20 6e 65 78 74 20 69 match the next i
a790: 6e 20 6c 69 6e 65 20 69 6e 20 64 65 6c 69 6d 2d n line in delim-
a7a0: 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 20 20 20 string.;;...
a7b0: 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 (begin.;;...
a7c0: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
a7d0: 67 20 22 5c 6e 22 20 23 66 20 62 69 6e 2d 64 61 g "\n" #f bin-da
a7e0: 74 29 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 67 t) ;; don't forg
a7f0: 65 74 20 74 68 61 74 20 6e 65 77 6c 69 6e 65 20 et that newline
a800: 77 65 20 64 72 6f 70 70 65 64 0a 3b 3b 09 09 09 we dropped.;;...
a810: 20 20 20 20 20 20 20 28 77 72 69 74 65 2d 73 74 (write-st
a820: 72 69 6e 67 20 65 6e 64 73 74 72 20 23 66 20 62 ring endstr #f b
a830: 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 09 20 20 20 in-dat).;;...
a840: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
a850: 67 20 6c 20 23 66 20 62 69 6e 2d 64 61 74 29 0a g l #f bin-dat).
a860: 3b 3b 09 09 09 20 20 20 20 20 20 20 28 6c 6f 6f ;;... (loo
a870: 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 p (read-string 1
a880: 29 20 23 66 20 28 2b 20 6e 75 6d 20 31 29 29 29 ) #f (+ num 1)))
a890: 29 29 29 29 29 0a 3b 3b 09 09 20 20 20 20 29 29 ))))).;;.. ))
a8a0: 29 29 29 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 6d )))..;; (form
a8b0: 64 61 74 3a 70 72 69 6e 74 61 6c 6c 20 66 6f 72 dat:printall for
a8c0: 6d 64 61 74 20 28 6c 61 6d 62 64 61 20 28 78 29 mdat (lambda (x)
a8d0: 28 77 72 69 74 65 2d 6c 69 6e 65 20 78 20 64 65 (write-line x de
a8e0: 62 75 67 70 29 29 29 0a 0a 23 7c 0a 28 64 65 66 bugp)))..#|.(def
a8f0: 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e ine inp (open-in
a900: 70 75 74 2d 66 69 6c 65 20 22 2f 74 6d 70 2f 73 put-file "/tmp/s
a910: 74 6d 6c 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 2e tmlrun/delme-33.
a920: 6c 6f 67 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 66 log.keep-for-ref
a930: 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 ")).(define dat
a940: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 (read-string #f
a950: 69 6e 70 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 inp)).(close-inp
a960: 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a ut-port inp).|#.
a970: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 75 73 65 =========.;; use
a9c0: 20 61 20 74 61 62 6c 65 20 69 6e 20 79 6f 75 72 a table in your
a9d0: 20 64 62 20 63 61 6c 6c 65 64 20 6d 65 74 61 64 db called metad
a9e0: 61 74 20 74 6f 20 73 74 6f 72 65 20 6b 65 79 20 at to store key
a9f0: 76 61 6c 75 65 20 70 61 69 72 73 0a 3b 3b 3d 3d value pairs.;;==
aa00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa40: 3d 3d 3d 3d 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ====...(define (
aa50: 6b 65 79 73 74 6f 72 65 3a 67 65 74 20 64 62 20 keystore:get db
aa60: 6b 65 79 29 0a 20 20 28 64 62 69 3a 67 65 74 2d key). (dbi:get-
aa70: 6f 6e 65 20 64 62 20 22 53 45 4c 45 43 54 20 76 one db "SELECT v
aa80: 61 6c 75 65 20 46 52 4f 4d 20 6d 65 74 61 64 61 alue FROM metada
aa90: 74 61 20 57 48 45 52 45 20 6b 65 79 3d 3f 3b 22 ta WHERE key=?;"
aaa0: 20 6b 65 79 29 29 0a 0a 28 64 65 66 69 6e 65 20 key))..(define
aab0: 28 6b 65 79 73 74 6f 72 65 3a 73 65 74 21 20 64 (keystore:set! d
aac0: 62 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 28 b key value). (
aad0: 6c 65 74 20 28 28 63 75 72 72 2d 76 61 6c 20 28 let ((curr-val (
aae0: 6b 65 79 73 74 6f 72 65 3a 67 65 74 20 64 62 20 keystore:get db
aaf0: 6b 65 79 29 29 29 0a 20 20 20 20 28 69 66 20 63 key))). (if c
ab00: 75 72 72 2d 76 61 6c 0a 09 28 64 62 69 3a 65 78 urr-val..(dbi:ex
ab10: 65 63 20 64 62 20 22 55 50 44 41 54 45 20 6d 65 ec db "UPDATE me
ab20: 74 61 64 61 74 61 20 53 45 54 20 76 61 6c 75 65 tadata SET value
ab30: 3d 3f 20 57 48 45 52 45 20 6b 65 79 3d 3f 3b 22 =? WHERE key=?;"
ab40: 20 76 61 6c 75 65 20 6b 65 79 29 0a 09 28 64 62 value key)..(db
ab50: 69 3a 65 78 65 63 20 64 62 20 22 49 4e 53 45 52 i:exec db "INSER
ab60: 54 20 49 4e 54 4f 20 6d 65 74 61 64 61 74 61 20 T INTO metadata
ab70: 28 6b 65 79 2c 76 61 6c 75 65 29 20 56 41 4c 55 (key,value) VALU
ab80: 45 53 20 28 3f 2c 3f 29 3b 22 20 6b 65 79 20 76 ES (?,?);" key v
ab90: 61 6c 75 65 29 29 29 29 0a 0a 28 64 65 66 69 6e alue))))..(defin
aba0: 65 20 28 6b 65 79 73 74 6f 72 65 3a 64 65 6c 21 e (keystore:del!
abb0: 20 64 62 20 6b 65 79 29 0a 20 20 28 64 62 69 3a db key). (dbi:
abc0: 65 78 65 63 20 64 62 20 22 44 45 4c 45 54 45 20 exec db "DELETE
abd0: 46 52 4f 4d 20 6d 65 74 61 64 61 74 61 20 57 48 FROM metadata WH
abe0: 45 52 45 20 6b 65 79 3d 3f 3b 22 20 6b 65 79 29 ERE key=?;" key)
abf0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
ac00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 ===========.;; s
ac40: 74 75 66 66 20 66 72 6f 6d 20 6d 69 73 63 2d 73 tuff from misc-s
ac50: 74 6d 6c 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d tml.scm.;;======
ac60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aca0: 0a 0a 3b 3b 20 6d 6f 76 65 64 20 74 6f 20 73 74 ..;; moved to st
acb0: 6d 6c 63 6f 6d 6d 6f 6e 0a 3b 3b 20 28 62 75 6e mlcommon.;; (bun
acc0: 63 68 20 6f 66 20 73 74 75 66 66 29 0a 0a 3b 3b ch of stuff)..;;
acd0: 20 6d 6f 76 65 64 20 66 72 6f 6d 20 73 74 6d 6c moved from stml
ace0: 63 6f 6d 6d 6f 6e 0a 3b 3b 0a 3b 3b 20 61 6e 79 common.;;.;; any
acf0: 74 68 69 6e 67 20 65 78 63 65 70 74 20 61 20 6c thing except a l
ad00: 69 73 74 20 69 73 20 63 6f 6e 76 65 72 74 65 64 ist is converted
ad10: 20 74 6f 20 61 20 73 74 72 69 6e 67 21 21 21 0a to a string!!!.
ad20: 28 64 65 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e (define (s:any->
ad30: 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 20 28 63 string val). (c
ad40: 6f 6e 64 0a 20 20 20 28 28 73 74 72 69 6e 67 3f ond. ((string?
ad50: 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 val) val). ((
ad60: 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 28 6e 75 number? val) (nu
ad70: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 76 61 6c mber->string val
ad80: 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 )). ((symbol?
ad90: 76 61 6c 29 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 val) (symbol->st
ada0: 72 69 6e 67 20 76 61 6c 29 29 0a 20 20 20 28 28 ring val)). ((
adb0: 65 71 3f 20 76 61 6c 20 23 66 29 20 22 22 29 0a eq? val #f) "").
adc0: 20 20 20 28 28 65 71 3f 20 76 61 6c 20 23 74 29 ((eq? val #t)
add0: 20 22 54 52 55 45 22 29 0a 20 20 20 28 28 6c 69 "TRUE"). ((li
ade0: 73 74 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 st? val) val).
adf0: 20 28 65 6c 73 65 20 0a 20 20 20 20 28 6c 65 74 (else . (let
ae00: 20 28 28 6f 73 74 72 20 28 6f 70 65 6e 2d 6f 75 ((ostr (open-ou
ae10: 74 70 75 74 2d 73 74 72 69 6e 67 29 29 29 0a 20 tput-string))).
ae20: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
ae30: 74 2d 74 6f 2d 70 6f 72 74 20 6f 73 74 72 0a 09 t-to-port ostr..
ae40: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 64 (lambda ().. (d
ae50: 69 73 70 6c 61 79 20 76 61 6c 29 29 29 0a 20 20 isplay val))).
ae60: 20 20 20 20 28 67 65 74 2d 6f 75 74 70 75 74 2d (get-output-
ae70: 73 74 72 69 6e 67 20 6f 73 74 72 29 29 29 29 29 string ostr)))))
ae80: 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 61 6e 79 ..(define (s:any
ae90: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 ->number val).
aea0: 28 63 6f 6e 64 0a 20 20 20 28 28 6e 75 6d 62 65 (cond. ((numbe
aeb0: 72 3f 20 76 61 6c 29 20 20 76 61 6c 29 0a 20 20 r? val) val).
aec0: 20 28 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 ((string? val)
aed0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
aee0: 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 val)). ((symb
aef0: 6f 6c 3f 20 76 61 6c 29 20 20 28 73 74 72 69 6e ol? val) (strin
af00: 67 2d 3e 6e 75 6d 62 65 72 20 28 73 79 6d 62 6f g->number (symbo
af10: 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 29 l->string val)))
af20: 0a 20 20 20 28 65 6c 73 65 20 20 20 20 20 23 66 . (else #f
af30: 29 29 29 0a 0a 3b 3b 20 4d 6f 76 65 64 20 66 72 )))..;; Moved fr
af40: 6f 6d 20 73 74 6d 6c 63 6f 6d 6d 6f 6e 0a 3b 3b om stmlcommon.;;
af50: 0a 28 64 65 66 69 6e 65 20 28 73 3a 63 67 69 2d .(define (s:cgi-
af60: 6f 75 74 20 69 6e 6c 73 74 29 0a 20 20 28 73 3a out inlst). (s:
af70: 6f 75 74 70 75 74 20 28 63 75 72 72 65 6e 74 2d output (current-
af80: 6f 75 74 70 75 74 2d 70 6f 72 74 29 20 69 6e 6c output-port) inl
af90: 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 st))..(define (s
afa0: 3a 6f 75 74 70 75 74 20 70 6f 72 74 20 69 6e 6c :output port inl
afb0: 73 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 st). (map (lamb
afc0: 64 61 20 28 78 29 0a 09 20 28 63 6f 6e 64 20 0a da (x).. (cond .
afd0: 09 20 20 28 28 73 74 72 69 6e 67 3f 20 78 29 20 . ((string? x)
afe0: 28 70 72 69 6e 74 20 78 29 29 20 3b 3b 20 28 70 (print x)) ;; (p
aff0: 72 69 6e 74 20 78 29 29 0a 09 20 20 28 28 73 79 rint x)).. ((sy
b000: 6d 62 6f 6c 3f 20 78 29 20 28 70 72 69 6e 74 20 mbol? x) (print
b010: 78 29 29 20 3b 3b 20 28 70 72 69 6e 74 20 78 29 x)) ;; (print x)
b020: 29 0a 09 20 20 28 28 6c 69 73 74 3f 20 78 29 20 ).. ((list? x)
b030: 20 20 28 73 3a 6f 75 74 70 75 74 20 70 6f 72 74 (s:output port
b040: 20 78 29 29 0a 09 20 20 28 65 6c 73 65 20 22 22 x)).. (else ""
b050: 0a 09 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 .. ;; (print "
b060: 45 52 52 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 ERROR: Bad input
b070: 20 30 32 22 29 20 3b 3b 20 77 68 79 20 64 6f 20 02") ;; why do
b080: 61 6e 79 74 68 69 6e 67 3f 20 64 6f 6e 27 74 20 anything? don't
b090: 6f 75 74 70 75 74 20 6a 75 6e 6b 2e 0a 09 20 20 output junk...
b0a0: 20 29 29 29 0a 20 20 20 20 20 20 20 69 6e 6c 73 ))). inls
b0b0: 74 29 29 0a 3b 20 20 28 69 66 20 28 3e 20 28 6c t)).; (if (> (l
b0c0: 65 6e 67 74 68 20 69 6e 6c 73 74 29 20 32 29 0a ength inlst) 2).
b0d0: 3b 20 20 20 20 20 20 28 70 72 69 6e 74 29 29 29 ; (print)))
b0e0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 6f 75 74 ..(define (s:out
b0f0: 70 75 74 2d 6e 65 77 20 70 6f 72 74 20 69 6e 6c put-new port inl
b100: 73 74 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 st). (with-outp
b110: 75 74 2d 74 6f 2d 70 6f 72 74 20 70 6f 72 74 0a ut-to-port port.
b120: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
b130: 0a 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 ..(map (lambda (
b140: 78 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 64 x).. (cond
b150: 20 0a 09 09 28 28 73 74 72 69 6e 67 3f 20 78 29 ...((string? x)
b160: 20 28 70 72 69 6e 74 20 78 29 29 0a 09 09 28 28 (print x))...((
b170: 73 79 6d 62 6f 6c 3f 20 78 29 20 28 70 72 69 6e symbol? x) (prin
b180: 74 20 78 29 29 0a 09 09 28 28 6c 69 73 74 3f 20 t x))...((list?
b190: 78 29 20 20 20 28 73 3a 6f 75 74 70 75 74 20 70 x) (s:output p
b1a0: 6f 72 74 20 78 29 29 0a 09 09 28 65 6c 73 65 0a ort x))...(else.
b1b0: 09 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 45 52 .. ;; (print "ER
b1c0: 52 4f 52 3a 20 42 61 64 20 69 6e 70 75 74 20 30 ROR: Bad input 0
b1d0: 33 22 29 0a 20 20 20 20 20 29 29 29 0a 09 20 20 3"). )))..
b1e0: 20 20 20 69 6e 6c 73 74 29 29 29 29 0a 20 20 20 inlst)))).
b1f0: 20 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 .(define
b200: 20 28 65 72 72 3a 6c 6f 67 20 2e 20 6d 73 67 29 (err:log . msg)
b210: 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
b220: 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 to-port (current
b230: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 20 3b 3b 20 -error-port) ;;
b240: 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 (slot-ref self '
b250: 6c 6f 67 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 logpt). (lamb
b260: 64 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 70 da () . (ap
b270: 70 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 29 ply print msg)))
b280: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
b290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2a0: 3d 3d 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 0a 3b 3b 20 44 ===========.;; D
b2d0: 20 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d B.;;===========
b2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
b320: 63 6f 6e 76 65 72 74 20 76 61 6c 75 65 73 20 74 convert values t
b330: 6f 20 61 70 70 72 6f 70 72 69 61 74 65 20 73 74 o appropriate st
b340: 72 69 6e 67 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 rings.;;.(define
b350: 20 28 73 3a 73 71 6c 70 61 72 61 6d 2d 76 61 6c (s:sqlparam-val
b360: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 20 ->string val).
b370: 28 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f (cond. ((list?
b380: 20 20 20 76 61 6c 29 28 73 74 72 69 6e 67 2d 6a val)(string-j
b390: 6f 69 6e 20 28 6d 61 70 20 73 79 6d 62 6f 6c 2d oin (map symbol-
b3a0: 3e 73 74 72 69 6e 67 20 76 61 6c 29 20 22 2c 22 >string val) ","
b3b0: 29 29 20 3b 3b 20 28 61 20 62 20 63 29 20 3d 3e )) ;; (a b c) =>
b3c0: 20 61 2c 62 2c 63 0a 20 20 20 28 28 73 74 72 69 a,b,c. ((stri
b3d0: 6e 67 3f 20 76 61 6c 29 28 63 6f 6e 63 20 22 27 ng? val)(conc "'
b3e0: 22 20 28 64 62 69 3a 65 73 63 61 70 65 2d 73 74 " (dbi:escape-st
b3f0: 72 69 6e 67 20 76 61 6c 29 20 22 27 22 29 29 0a ring val) "'")).
b400: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c ((number? val
b410: 29 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 )(number->string
b420: 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 val)). ((symb
b430: 6f 6c 3f 20 76 61 6c 29 28 64 62 69 3a 65 73 63 ol? val)(dbi:esc
b440: 61 70 65 2d 73 74 72 69 6e 67 20 28 73 79 6d 62 ape-string (symb
b450: 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 ol->string val))
b460: 29 0a 20 20 20 28 28 62 6f 6f 6c 65 61 6e 3f 20 ). ((boolean?
b470: 76 61 6c 29 0a 20 20 20 20 28 69 66 20 76 61 6c val). (if val
b480: 20 22 54 52 55 45 22 20 22 46 41 4c 53 45 22 29 "TRUE" "FALSE")
b490: 29 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 ) ;; should thi
b4a0: 73 20 62 65 20 22 54 52 55 45 22 20 6f 72 20 31 s be "TRUE" or 1
b4b0: 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ?.
b4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4d0: 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 62 ;; should this b
b4e0: 65 20 22 46 41 4c 53 45 22 20 6f 72 20 30 20 6f e "FALSE" or 0 o
b4f0: 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 65 r NULL?. (else
b500: 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 73 . (err:log "s
b510: 71 6c 70 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 6e qlparam: unknown
b520: 20 74 79 70 65 20 66 6f 72 20 76 61 6c 75 65 3a type for value:
b530: 20 22 20 76 61 6c 29 0a 20 20 20 20 22 22 29 29 " val). ""))
b540: 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 72 61 6d 20 )..;; (sqlparam
b550: 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 66 6f 6f "INSERT INTO foo
b560: 28 6e 61 6d 65 2c 61 67 65 29 20 56 41 4c 55 45 (name,age) VALUE
b570: 53 28 3f 2c 3f 29 3b 22 20 22 62 6f 62 22 20 32 S(?,?);" "bob" 2
b580: 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 61 0).;; NB// 1. va
b590: 6c 75 65 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b 20 lues only!! .;;
b5a0: 20 20 20 20 20 32 2e 20 74 65 72 6d 69 6e 61 74 2. terminat
b5b0: 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 65 ing semicolon re
b5c0: 71 75 69 72 65 64 20 28 75 73 65 64 20 61 73 20 quired (used as
b5d0: 70 61 72 74 20 6f 66 20 6c 6f 67 69 63 29 0a 3b part of logic).;
b5e0: 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 6e 75 6d 62 ;.;; a=? 1 (numb
b5f0: 65 72 29 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 3d er) => a=1.;; a=
b600: 3f 20 31 20 28 73 74 72 69 6e 67 29 20 3d 3e 20 ? 1 (string) =>
b610: 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 20 a='1'.;; a=? #f
b620: 20 20 20 20 20 20 20 20 3d 3e 20 61 3d 46 41 4c => a=FAL
b630: 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 79 SE .;; a=? a (sy
b640: 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b 3b mbol) => a=a .;;
b650: 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 71 6c 70 .(define (s:sqlp
b660: 61 72 61 6d 20 71 75 65 72 79 20 2e 20 61 72 67 aram query . arg
b670: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 71 75 65 s). (let* ((que
b680: 72 79 2d 70 61 72 74 73 20 28 73 74 72 69 6e 67 ry-parts (string
b690: 2d 73 70 6c 69 74 20 71 75 65 72 79 20 22 3f 22 -split query "?"
b6a0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d )). (num
b6b0: 2d 70 61 72 74 73 20 20 20 20 28 6c 65 6e 67 74 -parts (lengt
b6c0: 68 20 71 75 65 72 79 2d 70 61 72 74 73 29 29 0a h query-parts)).
b6d0: 20 20 20 20 20 20 20 20 20 28 6e 75 6d 2d 61 72 (num-ar
b6e0: 67 73 20 20 20 20 28 6c 65 6e 67 74 68 20 61 72 gs (length ar
b6f0: 67 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e gs))). (if (n
b700: 6f 74 20 28 3d 20 28 2b 20 6e 75 6d 2d 61 72 67 ot (= (+ num-arg
b710: 73 20 31 29 20 6e 75 6d 2d 70 61 72 74 73 29 29 s 1) num-parts))
b720: 0a 20 20 20 20 20 20 20 20 28 65 72 72 3a 6c 6f . (err:lo
b730: 67 20 22 45 52 52 4f 52 2c 20 73 71 6c 70 61 72 g "ERROR, sqlpar
b740: 61 6d 3a 20 77 72 6f 6e 67 20 6e 75 6d 62 65 72 am: wrong number
b750: 20 6f 66 20 61 72 67 75 6d 65 6e 74 73 20 6f 72 of arguments or
b760: 20 6d 69 73 73 69 6e 67 20 73 65 6d 69 63 6f 6c missing semicol
b770: 6f 6e 2c 20 22 20 6e 75 6d 2d 61 72 67 73 20 22 on, " num-args "
b780: 20 66 6f 72 20 71 75 65 72 79 20 22 20 71 75 65 for query " que
b790: 72 79 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ry). (if
b7a0: 28 3d 20 6e 75 6d 2d 61 72 67 73 20 30 29 20 71 (= num-args 0) q
b7b0: 75 65 72 79 0a 20 20 20 20 20 20 20 20 20 20 20 uery.
b7c0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 63 (let loop ((sec
b7d0: 74 69 6f 6e 20 28 63 61 72 20 71 75 65 72 79 2d tion (car 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: 74 61 69 6c 20 20 20 20 28 63 64 72 20 71 75 65 tail (cdr que
b810: 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 20 20 ry-parts)).
b820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b830: 20 20 28 72 65 73 75 6c 74 20 20 22 22 29 0a 20 (result "").
b840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b850: 20 20 20 20 20 20 28 61 72 67 20 20 20 20 20 28 (arg (
b860: 63 61 72 20 61 72 67 73 29 29 0a 20 20 20 20 20 car args)).
b870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b880: 20 20 28 61 72 67 74 61 69 6c 20 28 63 64 72 20 (argtail (cdr
b890: 61 72 67 73 29 29 29 0a 20 20 20 20 20 20 20 20 args))).
b8a0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 (let* ((va
b8b0: 6c 73 74 72 20 20 20 20 28 73 3a 73 71 6c 70 61 lstr (s:sqlpa
b8c0: 72 61 6d 2d 76 61 6c 2d 3e 73 74 72 69 6e 67 20 ram-val->string
b8d0: 61 72 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 arg)).
b8e0: 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 72 (newr
b8f0: 65 73 75 6c 74 20 28 63 6f 6e 63 20 72 65 73 75 esult (conc resu
b900: 6c 74 20 73 65 63 74 69 6f 6e 20 76 61 6c 73 74 lt section valst
b910: 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 r))).
b920: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
b930: 61 72 67 74 61 69 6c 29 20 3b 3b 20 77 65 20 61 argtail) ;; we a
b940: 72 65 20 64 6f 6e 65 0a 20 20 20 20 20 20 20 20 re done.
b950: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
b960: 63 20 6e 65 77 72 65 73 75 6c 74 20 28 63 61 72 c newresult (car
b970: 20 74 61 69 6c 29 29 0a 20 20 20 20 20 20 20 20 tail)).
b980: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
b990: 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 p.
b9a0: 20 20 20 20 20 20 20 28 63 61 72 20 74 61 69 6c (car tail
b9b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b9c0: 20 20 20 20 20 20 20 28 63 64 72 20 74 61 69 6c (cdr tail
b9d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b9e0: 20 20 20 20 20 20 20 6e 65 77 72 65 73 75 6c 74 newresult
b9f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ba00: 20 20 20 20 20 20 28 63 61 72 20 61 72 67 74 61 (car argta
ba10: 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 il).
ba20: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 61 72 (cdr ar
ba30: 67 74 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a gtail)))))))))..
ba40: 3b 3b 20 28 64 65 66 69 6e 65 20 73 65 73 73 69 ;; (define sessi
ba50: 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 22 on:valid-chars "
ba60: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop
ba70: 71 72 73 74 75 76 77 78 79 7a 41 42 43 44 45 46 qrstuvwxyzABCDEF
ba80: 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 GHIJKLMNOPQRSTUV
ba90: 57 58 59 5a 30 31 32 33 34 35 36 37 38 39 22 29 WXYZ0123456789")
baa0: 0a 28 64 65 66 69 6e 65 20 73 65 73 73 69 6f 6e .(define session
bab0: 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 22 61 62 :valid-chars "ab
bac0: 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 cdefghijklmnopqr
bad0: 73 74 75 76 77 78 79 7a 30 31 32 33 34 35 36 37 stuvwxyz01234567
bae0: 38 39 22 29 20 3b 3b 20 63 6f 6f 6b 69 65 73 20 89") ;; cookies
baf0: 61 72 65 20 63 61 73 65 20 69 6e 73 65 6e 73 69 are case insensi
bb00: 74 69 76 65 2e 0a 28 64 65 66 69 6e 65 20 73 65 tive..(define se
bb10: 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 2d ssion:num-valid-
bb20: 63 68 61 72 73 20 28 73 74 72 69 6e 67 2d 6c 65 chars (string-le
bb30: 6e 67 74 68 20 73 65 73 73 69 6f 6e 3a 76 61 6c ngth session:val
bb40: 69 64 2d 63 68 61 72 73 29 29 0a 0a 28 64 65 66 id-chars))..(def
bb50: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ine (session:get
bb60: 2d 6e 74 68 2d 63 68 61 72 20 6e 74 68 29 0a 20 -nth-char nth).
bb70: 20 28 73 75 62 73 74 72 69 6e 67 20 73 65 73 73 (substring sess
bb80: 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 ion:valid-chars
bb90: 6e 74 68 20 20 28 2b 20 6e 74 68 20 31 29 29 29 nth (+ nth 1)))
bba0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
bbb0: 6f 6e 3a 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 on:get-rand-char
bbc0: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ). (session:get
bbd0: 2d 6e 74 68 2d 63 68 61 72 20 28 72 61 6e 64 6f -nth-char (rando
bbe0: 6d 20 73 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 m session:num-va
bbf0: 6c 69 64 2d 63 68 61 72 73 29 29 29 0a 0a 28 64 lid-chars)))..(d
bc00: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d efine (session:m
bc10: 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 ake-rand-string
bc20: 6c 65 6e 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 len). (let loop
bc30: 20 28 28 72 65 73 20 22 22 29 0a 20 20 20 20 20 ((res "").
bc40: 20 20 20 20 20 20 20 20 28 6e 20 20 20 31 29 29 (n 1))
bc50: 0a 20 20 20 20 28 69 66 20 28 3e 20 6e 20 6c 65 . (if (> n le
bc60: 6e 29 20 72 65 73 0a 20 20 20 20 20 20 20 20 28 n) res. (
bc70: 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 70 loop (string-app
bc80: 65 6e 64 20 72 65 73 20 28 73 65 73 73 69 6f 6e end res (session
bc90: 3a 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 29 :get-rand-char))
bca0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
bcb0: 2b 20 6e 20 31 29 29 29 29 29 0a 0a 3b 3b 20 6d + n 1)))))..;; m
bcc0: 61 79 62 65 20 72 65 70 6c 61 63 65 20 61 62 6f aybe replace abo
bcd0: 76 65 20 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 ve make-rand-str
bce0: 69 6e 67 20 77 69 74 68 20 74 68 69 73 20 73 6f ing with this so
bcf0: 6d 65 64 61 79 3f 0a 3b 3b 0a 28 64 65 66 69 6e meday?.;;.(defin
bd00: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 6e 65 72 e (session:gener
bd10: 69 63 2d 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 ic-make-rand-str
bd20: 69 6e 67 20 6c 65 6e 20 73 65 65 64 2d 73 74 72 ing len seed-str
bd30: 69 6e 67 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 ing). (let ((nu
bd40: 6d 2d 63 68 61 72 73 20 28 73 74 72 69 6e 67 2d m-chars (string-
bd50: 6c 65 6e 67 74 68 20 73 65 65 64 2d 73 74 72 69 length seed-stri
bd60: 6e 67 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c ng))). (let l
bd70: 6f 6f 70 20 28 28 72 65 73 20 22 22 29 0a 09 20 oop ((res "")..
bd80: 20 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 (n 1)).
bd90: 20 20 20 20 20 28 6c 65 74 20 28 28 63 68 61 72 (let ((char
bda0: 2d 6e 75 6d 20 28 72 61 6e 64 6f 6d 20 6e 75 6d -num (random num
bdb0: 2d 63 68 61 72 73 29 29 29 0a 09 28 69 66 20 28 -chars)))..(if (
bdc0: 3e 20 6e 20 6c 65 6e 29 20 72 65 73 0a 09 20 20 > n len) res..
bdd0: 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d (loop (string-
bde0: 61 70 70 65 6e 64 20 72 65 73 20 28 73 75 62 73 append res (subs
bdf0: 74 72 69 6e 67 20 73 65 65 64 2d 73 74 72 69 6e tring seed-strin
be00: 67 20 63 68 61 72 2d 6e 75 6d 20 28 2b 20 63 68 g char-num (+ ch
be10: 61 72 2d 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 ar-num 1)))...
be20: 28 2b 20 6e 20 31 29 29 29 29 29 29 29 0a 0a 0a (+ n 1)))))))...
be30: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
be40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 50 20 41 20 ========.;; P A
be80: 52 20 41 20 4d 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d R A M S.;;======
be90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
beb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bed0: 0a 0a 3b 3b 20 69 6e 70 75 74 3a 20 27 61 20 28 ..;; input: 'a (
bee0: 27 61 20 22 76 61 6c 20 61 22 20 27 62 20 22 76 'a "val a" 'b "v
bef0: 61 6c 20 62 22 29 20 3d 3e 20 22 76 61 6c 20 61 al b") => "val a
bf00: 22 0a 28 64 65 66 69 6e 65 20 28 73 3a 66 69 6e ".(define (s:fin
bf10: 64 2d 70 61 72 61 6d 20 6b 65 79 20 70 61 72 61 d-param key para
bf20: 6d 2d 6c 73 74 29 0a 20 20 28 6c 65 74 20 6c 6f m-lst). (let lo
bf30: 6f 70 20 28 28 68 65 61 64 20 28 63 61 72 20 70 op ((head (car p
bf40: 61 72 61 6d 2d 6c 73 74 29 29 0a 09 20 20 20 20 aram-lst))..
bf50: 20 28 74 61 69 6c 20 28 63 64 72 20 70 61 72 61 (tail (cdr para
bf60: 6d 2d 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 m-lst))). (if
bf70: 20 28 65 71 3f 20 68 65 61 64 20 6b 65 79 29 0a (eq? head key).
bf80: 09 28 63 61 72 20 74 61 69 6c 29 0a 09 28 69 66 .(car tail)..(if
bf90: 20 28 3c 20 28 6c 65 6e 67 74 68 20 74 61 69 6c (< (length tail
bfa0: 29 20 32 29 20 23 66 0a 09 20 20 20 20 28 6c 6f ) 2) #f.. (lo
bfb0: 6f 70 20 28 63 61 64 72 20 74 61 69 6c 29 28 63 op (cadr tail)(c
bfc0: 64 64 72 20 74 61 69 6c 29 29 29 29 29 29 0a 0a ddr tail))))))..
bfd0: 28 64 65 66 69 6e 65 20 28 73 3a 70 61 72 61 6d (define (s:param
bfe0: 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 29 0a ->string param).
bff0: 20 20 28 63 6f 6e 63 20 28 73 79 6d 62 6f 6c 2d (conc (symbol-
c000: 3e 73 74 72 69 6e 67 20 28 63 61 72 20 70 61 72 >string (car par
c010: 61 6d 29 29 20 22 3d 22 20 22 5c 22 22 20 28 63 am)) "=" "\"" (c
c020: 61 64 72 20 70 61 72 61 6d 29 20 22 5c 22 22 29 adr param) "\"")
c030: 29 0a 0a 3b 3b 20 72 65 6d 6f 76 65 20 27 66 6f )..;; remove 'fo
c040: 6f 20 22 62 61 72 22 20 66 72 6f 6d 20 28 27 66 o "bar" from ('f
c050: 6f 6f 20 22 62 61 72 22 20 27 62 61 72 20 22 66 oo "bar" 'bar "f
c060: 6f 6f 22 29 0a 28 64 65 66 69 6e 65 20 28 73 3a oo").(define (s:
c070: 72 65 6d 6f 76 65 2d 70 61 72 61 6d 2d 6d 61 74 remove-param-mat
c080: 63 68 69 6e 67 20 70 61 72 61 6d 73 20 6b 65 79 ching params key
c090: 29 0a 20 20 28 69 66 20 28 3d 20 28 6c 65 6e 67 ). (if (= (leng
c0a0: 74 68 20 70 61 72 61 6d 73 29 20 30 29 27 28 29 th params) 0)'()
c0b0: 20 3b 3b 20 20 70 72 6f 70 65 72 20 70 61 72 61 ;; proper para
c0c0: 6d 73 20 6c 69 73 74 20 3e 3d 20 32 20 69 74 65 ms list >= 2 ite
c0d0: 6d 73 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ms. (let lo
c0e0: 6f 70 20 28 28 68 65 61 64 20 20 20 20 20 28 63 op ((head (c
c0f0: 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ar params)).
c100: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
c110: 69 6c 20 20 20 20 20 28 63 64 72 20 70 61 72 61 il (cdr para
c120: 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ms)).
c130: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 20 (result
c140: 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 '())). (i
c150: 66 20 28 73 79 6d 62 6f 6c 3f 20 68 65 61 64 29 f (symbol? head)
c160: 20 3b 3b 20 73 79 6d 62 6f 6c 73 20 68 61 76 65 ;; symbols have
c170: 20 70 61 72 61 6d 73 0a 20 20 20 20 20 20 20 20 params.
c180: 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 20 (let ((val
c190: 20 20 20 28 63 61 72 20 74 61 69 6c 29 29 0a 20 (car tail)).
c1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1b0: 20 28 6e 65 77 74 61 69 6c 20 28 63 64 72 20 74 (newtail (cdr t
c1c0: 61 69 6c 29 29 29 0a 20 20 20 20 20 20 20 20 20 ail))).
c1d0: 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 68 65 (if (eq? he
c1e0: 61 64 20 6b 65 79 29 20 20 3b 3b 20 67 65 74 20 ad key) ;; get
c1f0: 72 69 64 20 6f 66 20 74 68 69 73 20 6f 6e 65 0a rid of this one.
c200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c210: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 (if (null? new
c220: 74 61 69 6c 29 20 72 65 73 75 6c 74 0a 20 20 20 tail) result.
c230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c240: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
c250: 77 74 61 69 6c 29 28 63 64 72 20 6e 65 77 74 61 wtail)(cdr newta
c260: 69 6c 29 20 72 65 73 75 6c 74 29 29 0a 20 20 20 il) result)).
c270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c280: 6c 65 74 20 28 28 6e 65 77 72 65 73 75 6c 74 20 let ((newresult
c290: 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 28 (append result (
c2a0: 6c 69 73 74 20 68 65 61 64 20 76 61 6c 29 29 29 list head val)))
c2b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c2c0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
c2d0: 20 6e 65 77 74 61 69 6c 29 20 6e 65 77 72 65 73 newtail) newres
c2e0: 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ult.
c2f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
c300: 70 20 28 63 61 72 20 6e 65 77 74 61 69 6c 29 28 p (car newtail)(
c310: 63 64 72 20 6e 65 77 74 61 69 6c 29 20 6e 65 77 cdr newtail) new
c320: 72 65 73 75 6c 74 29 29 29 29 29 0a 20 20 20 20 result))))).
c330: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e (let ((n
c340: 65 77 72 65 73 75 6c 74 20 28 61 70 70 65 6e 64 ewresult (append
c350: 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 68 65 result (list he
c360: 61 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 ad)))).
c370: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
c380: 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 0a tail) newresult.
c390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c3a0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 (loop (car tai
c3b0: 6c 29 28 63 64 72 20 74 61 69 6c 29 20 6e 65 77 l)(cdr tail) new
c3c0: 72 65 73 75 6c 74 29 29 29 29 29 29 29 0a 0a 28 result)))))))..(
c3d0: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
c3e0: 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f 6d 20 70 get-param-from p
c3f0: 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 6c 65 arams key). (le
c400: 74 20 28 28 72 31 20 28 72 65 67 65 78 70 20 28 t ((r1 (regexp (
c410: 63 6f 6e 63 20 22 5e 22 20 28 73 3a 61 6e 79 2d conc "^" (s:any-
c420: 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 22 3d 28 >string key) "=(
c430: 2e 2a 29 24 22 29 29 29 29 0a 20 20 20 20 28 69 .*)$")))). (i
c440: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
c450: 20 23 66 0a 20 20 20 20 20 20 20 20 28 6c 65 74 #f. (let
c460: 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 63 61 loop ((head (ca
c470: 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 r params)).
c480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
c490: 61 69 6c 20 28 63 64 72 20 70 61 72 61 6d 73 29 ail (cdr params)
c4a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 )). (le
c4b0: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
c4c0: 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 g-match r1 head)
c4d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
c4e0: 69 66 20 6d 61 74 63 68 0a 20 20 20 20 20 20 20 if match.
c4f0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
c500: 65 66 20 6d 61 74 63 68 20 31 29 0a 20 20 20 20 ef match 1).
c510: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
c520: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 23 66 0a (null? tail) #f.
c530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c540: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
c550: 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 29 29 ail)(cdr tail)))
c560: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
c570: 28 73 3a 70 72 6f 63 65 73 73 2d 70 61 72 61 6d (s:process-param
c580: 73 20 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 s params). (if
c590: 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 (null? params) "
c5a0: 22 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ". (let loo
c5b0: 70 20 28 28 72 65 73 20 22 22 29 0a 20 20 20 20 p ((res "").
c5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 65 (he
c5d0: 61 64 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ad (car params))
c5e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c5f0: 20 20 28 74 61 69 6c 20 28 63 64 72 20 70 61 72 (tail (cdr par
c600: 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 28 ams))). (
c610: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a if (null? tail).
c620: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
c630: 63 20 72 65 73 20 22 20 22 20 28 73 3a 70 61 72 c res " " (s:par
c640: 61 6d 2d 3e 73 74 72 69 6e 67 20 68 65 61 64 29 am->string head)
c650: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ). (l
c660: 6f 6f 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 oop.
c670: 20 28 63 6f 6e 63 20 72 65 73 20 22 20 22 20 28 (conc res " " (
c680: 73 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 s:param->string
c690: 68 65 61 64 29 29 0a 20 20 20 20 20 20 20 20 20 head)).
c6a0: 20 20 20 20 28 63 61 72 20 74 61 69 6c 29 0a 20 (car tail).
c6b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 72 (cdr
c6c0: 20 74 61 69 6c 29 29 29 29 29 29 0a 0a 3b 3b 20 tail))))))..;;
c6d0: 72 65 6d 6f 76 65 20 6b 65 79 3d 76 61 72 20 66 remove key=var f
c6e0: 72 6f 6d 20 28 6b 65 79 3d 76 61 72 20 6b 65 79 rom (key=var key
c6f0: 31 3d 76 61 72 31 20 6b 65 79 32 3d 76 61 72 32 1=var1 key2=var2
c700: 20 2e 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b ...).(define (k
c710: 3d 76 2d 70 61 72 61 6d 73 3a 72 65 6d 6f 76 65 =v-params:remove
c720: 2d 6d 61 74 63 68 69 6e 67 20 70 61 72 61 6d 73 -matching params
c730: 20 6b 65 79 29 0a 20 20 28 69 66 20 28 3d 20 28 key). (if (= (
c740: 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 20 30 length params) 0
c750: 29 20 70 61 72 61 6d 73 0a 20 20 20 20 20 20 28 ) params. (
c760: 6c 65 74 20 28 28 72 31 20 28 72 65 67 65 78 70 let ((r1 (regexp
c770: 20 28 63 6f 6e 63 20 22 5e 22 20 6b 65 79 20 22 (conc "^" key "
c780: 3d 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 =")))). (
c790: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
c7a0: 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 (car params)).
c7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7c0: 20 28 74 61 69 6c 20 28 63 64 72 20 70 61 72 61 (tail (cdr para
c7d0: 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ms)).
c7e0: 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 (result
c7f0: 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 '())).
c800: 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (if (string-matc
c810: 68 20 72 31 20 68 65 61 64 29 0a 20 20 20 20 20 h r1 head).
c820: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
c830: 6c 6c 3f 20 74 61 69 6c 29 20 72 65 73 75 6c 74 ll? tail) result
c840: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c850: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
c860: 69 6c 29 28 63 64 72 20 74 61 69 6c 29 20 72 65 il)(cdr tail) re
c870: 73 75 6c 74 29 29 0a 20 20 20 20 20 20 20 20 20 sult)).
c880: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 6c (let ((newl
c890: 73 74 20 28 63 6f 6e 73 20 68 65 61 64 20 72 65 st (cons head re
c8a0: 73 75 6c 74 29 29 29 0a 20 20 20 20 20 20 20 20 sult))).
c8b0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
c8c0: 6c 3f 20 74 61 69 6c 29 20 6e 65 77 6c 73 74 0a l? tail) newlst.
c8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8e0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
c8f0: 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 20 6e ail)(cdr tail) n
c900: 65 77 6c 73 74 29 29 29 29 29 29 29 29 0a 0a 3b ewlst))))))))..;
c910: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
c920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c950: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 74 75 66 66 =======.;; stuff
c960: 20 70 75 6c 6c 65 64 20 66 72 6f 6d 20 73 65 73 pulled from ses
c970: 73 69 6f 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d sion.;;=========
c980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 0a =============...
c9c0: 3b 3b 20 73 65 73 73 69 6f 6e 73 20 74 61 62 6c ;; sessions tabl
c9d0: 65 0a 3b 3b 20 69 64 20 73 65 73 73 69 6f 6e 5f e.;; id session_
c9e0: 69 64 20 73 65 73 73 69 6f 6e 5f 6b 65 79 0a 3b id session_key.;
c9f0: 3b 20 63 72 65 61 74 65 20 74 61 62 6c 65 20 73 ; create table s
ca00: 65 73 73 69 6f 6e 73 20 28 69 64 20 73 65 72 69 essions (id seri
ca10: 61 6c 20 6e 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 al not null,sess
ca20: 69 6f 6e 2d 6b 65 79 20 74 65 78 74 29 3b 0a 0a ion-key text);..
ca30: 3b 3b 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 20 ;; session_vars
ca40: 74 61 62 6c 65 0a 3b 3b 20 69 64 20 73 65 73 73 table.;; id sess
ca50: 69 6f 6e 5f 69 64 20 70 61 67 65 5f 69 64 20 6b ion_id page_id k
ca60: 65 79 20 76 61 6c 75 65 0a 3b 3b 20 63 72 65 61 ey value.;; crea
ca70: 74 65 20 74 61 62 6c 65 20 73 65 73 73 69 6f 6e te table session
ca80: 5f 76 61 72 73 20 28 69 64 20 73 65 72 69 61 6c _vars (id serial
ca90: 20 6e 6f 74 20 6e 75 6c 6c 2c 73 65 73 73 69 6f not null,sessio
caa0: 6e 5f 69 64 20 69 6e 74 65 67 65 72 2c 70 61 67 n_id integer,pag
cab0: 65 20 74 65 78 74 2c 6b 65 79 20 74 65 78 74 2c e text,key text,
cac0: 76 61 6c 75 65 20 74 65 78 74 29 3b 0a 0a 3b 3b value text);..;;
cad0: 20 54 4f 44 4f 0a 3b 3b 20 20 43 6f 6e 63 65 70 TODO.;; Concep
cae0: 74 20 6f 66 20 6f 72 64 65 72 20 6e 75 6d 20 69 t of order num i
caf0: 6e 63 72 65 6d 65 6e 74 65 64 20 77 69 74 68 20 ncremented with
cb00: 65 61 63 68 20 70 61 67 65 20 61 63 63 65 73 73 each page access
cb10: 0a 3b 3b 20 20 20 20 20 69 66 20 61 20 62 72 61 .;; if a bra
cb20: 6e 63 68 20 69 73 20 74 61 6b 65 6e 20 74 68 65 nch is taken the
cb30: 6e 20 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 n a new session
cb40: 77 6f 75 6c 64 20 6e 65 65 64 20 74 6f 20 62 65 would need to be
cb50: 20 63 72 65 61 74 65 64 0a 3b 3b 0a 0a 3b 3b 20 created.;;..;;
cb60: 6d 61 6b 65 2d 76 65 63 74 6f 72 2d 72 65 63 6f make-vector-reco
cb70: 72 64 20 73 65 73 73 69 6f 6e 20 73 65 73 73 69 rd session sessi
cb80: 6f 6e 20 64 62 74 79 70 65 20 64 62 69 6e 69 74 on dbtype dbinit
cb90: 20 63 6f 6e 6e 20 70 61 72 61 6d 73 20 70 61 74 conn params pat
cba0: 68 2d 70 61 72 61 6d 73 20 73 65 73 73 69 6f 6e h-params session
cbb0: 2d 6b 65 79 20 73 65 73 73 69 6f 6e 2d 69 64 20 -key session-id
cbc0: 64 6f 6d 61 69 6e 20 74 6f 70 70 61 67 65 20 70 domain toppage p
cbd0: 61 67 65 20 63 75 72 72 2d 70 61 67 65 20 63 6f age curr-page co
cbe0: 6e 74 65 6e 74 2d 74 79 70 65 20 70 61 67 65 2d ntent-type page-
cbf0: 74 79 70 65 20 73 72 6f 6f 74 20 74 77 69 6b 69 type sroot twiki
cc00: 64 69 72 20 70 61 67 65 64 61 74 20 61 6c 74 2d dir pagedat alt-
cc10: 70 61 67 65 2d 64 61 74 20 70 61 67 65 76 61 72 page-dat pagevar
cc20: 73 20 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 s pagevars-befor
cc30: 65 20 73 65 73 73 69 6f 6e 76 61 72 73 20 73 65 e sessionvars se
cc40: 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 ssionvars-before
cc50: 20 67 6c 6f 62 61 6c 76 61 72 73 20 67 6c 6f 62 globalvars glob
cc60: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 6c 6f alvars-before lo
cc70: 67 70 74 20 66 6f 72 6d 64 61 74 20 72 65 71 75 gpt formdat requ
cc80: 65 73 74 2d 6d 65 74 68 6f 64 20 73 65 73 73 69 est-method sessi
cc90: 6f 6e 2d 63 6f 6f 6b 69 65 20 63 75 72 72 2d 65 on-cookie curr-e
cca0: 72 72 20 6c 6f 67 2d 70 6f 72 74 20 6c 6f 67 66 rr log-port logf
ccb0: 69 6c 65 20 73 65 65 6e 2d 70 61 67 65 73 20 70 ile seen-pages p
ccc0: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 64 65 age-dir-style de
ccd0: 62 75 67 6d 6f 64 65 0a 28 64 65 66 69 6e 65 20 bugmode.(define
cce0: 28 6d 61 6b 65 2d 73 64 61 74 29 28 6d 61 6b 65 (make-sdat)(make
ccf0: 2d 76 65 63 74 6f 72 20 33 36 29 29 0a 28 64 65 -vector 36)).(de
cd00: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 fine (sdat-get-d
cd10: 62 74 79 70 65 20 20 20 20 20 20 20 20 20 20 20 btype
cd20: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
cd30: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 tor-ref vec 0))
cd40: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
cd50: 65 74 2d 64 62 69 6e 69 74 20 20 20 20 20 20 20 et-dbinit
cd60: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
cd70: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
cd80: 20 31 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 1)).(define (sd
cd90: 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 20 20 20 20 at-get-conn
cda0: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
cdb0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
cdc0: 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 vec 2)).(define
cdd0: 20 28 73 64 61 74 2d 67 65 74 2d 70 67 63 6f 6e (sdat-get-pgcon
cde0: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n
cdf0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
ce00: 72 65 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ref (vector-ref
ce10: 76 65 63 20 32 29 20 31 29 29 0a 28 64 65 66 69 vec 2) 1)).(defi
ce20: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 72 ne (sdat-get-par
ce30: 61 6d 73 20 20 20 20 20 20 20 20 20 20 20 20 20 ams
ce40: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
ce50: 72 2d 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 r-ref vec 3)).(
ce60: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
ce70: 2d 70 61 74 68 2d 70 61 72 61 6d 73 20 20 20 20 -path-params
ce80: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
ce90: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 34 ector-ref vec 4
cea0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
ceb0: 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 -get-session-key
cec0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
ced0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
cee0: 65 63 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 5)).(define (
cef0: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
cf00: 2d 69 64 20 20 20 20 20 20 20 20 20 20 20 76 65 -id ve
cf10: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
cf20: 66 20 20 76 65 63 20 36 29 29 0a 28 64 65 66 69 f vec 6)).(defi
cf30: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d ne (sdat-get-dom
cf40: 61 69 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 ain
cf50: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
cf60: 72 2d 72 65 66 20 20 76 65 63 20 37 29 29 0a 28 r-ref vec 7)).(
cf70: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
cf80: 2d 74 6f 70 70 61 67 65 20 20 20 20 20 20 20 20 -toppage
cf90: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
cfa0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 38 ector-ref vec 8
cfb0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
cfc0: 2d 67 65 74 2d 70 61 67 65 20 20 20 20 20 20 20 -get-page
cfd0: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
cfe0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
cff0: 65 63 20 39 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 9)).(define (
d000: 73 64 61 74 2d 67 65 74 2d 63 75 72 72 2d 70 61 sdat-get-curr-pa
d010: 67 65 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ge ve
d020: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
d030: 66 20 20 76 65 63 20 31 30 29 29 0a 28 64 65 66 f vec 10)).(def
d040: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f ine (sdat-get-co
d050: 6e 74 65 6e 74 2d 74 79 70 65 20 20 20 20 20 20 ntent-type
d060: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
d070: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 31 29 29 or-ref vec 11))
d080: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
d090: 65 74 2d 70 61 67 65 2d 74 79 70 65 20 20 20 20 et-page-type
d0a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
d0b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
d0c0: 20 31 32 29 29 0a 28 64 65 66 69 6e 65 20 28 73 12)).(define (s
d0d0: 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 20 20 20 dat-get-sroot
d0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
d0f0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
d100: 20 20 76 65 63 20 31 33 29 29 0a 28 64 65 66 69 vec 13)).(defi
d110: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 74 77 69 ne (sdat-get-twi
d120: 6b 69 64 69 72 20 20 20 20 20 20 20 20 20 20 20 kidir
d130: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
d140: 72 2d 72 65 66 20 20 76 65 63 20 31 34 29 29 0a r-ref vec 14)).
d150: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
d160: 74 2d 70 61 67 65 64 61 74 20 20 20 20 20 20 20 t-pagedat
d170: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
d180: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
d190: 31 35 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 15)).(define (sd
d1a0: 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d at-get-alt-page-
d1b0: 64 61 74 20 20 20 20 20 20 20 20 20 76 65 63 29 dat vec)
d1c0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
d1d0: 20 76 65 63 20 31 36 29 29 0a 28 64 65 66 69 6e vec 16)).(defin
d1e0: 65 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 e (sdat-get-page
d1f0: 76 61 72 73 20 20 20 20 20 20 20 20 20 20 20 20 vars
d200: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
d210: 2d 72 65 66 20 20 76 65 63 20 31 37 29 29 0a 28 -ref vec 17)).(
d220: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
d230: 2d 70 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 -pagevars-before
d240: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
d250: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
d260: 38 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 8)).(define (sda
d270: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 t-get-sessionvar
d280: 73 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 s vec)
d290: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
d2a0: 76 65 63 20 31 39 29 29 0a 28 64 65 66 69 6e 65 vec 19)).(define
d2b0: 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 (sdat-get-sessi
d2c0: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 20 20 onvars-before
d2d0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
d2e0: 72 65 66 20 20 76 65 63 20 32 30 29 29 0a 28 64 ref vec 20)).(d
d2f0: 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d efine (sdat-get-
d300: 67 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 globalvars
d310: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
d320: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 31 ctor-ref vec 21
d330: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
d340: 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d -get-globalvars-
d350: 62 65 66 6f 72 65 20 20 20 20 76 65 63 29 20 20 before vec)
d360: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
d370: 65 63 20 32 32 29 29 0a 28 64 65 66 69 6e 65 20 ec 22)).(define
d380: 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 (sdat-get-logpt
d390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 v
d3a0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
d3b0: 65 66 20 20 76 65 63 20 32 33 29 29 0a 28 64 65 ef vec 23)).(de
d3c0: 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 66 fine (sdat-get-f
d3d0: 6f 72 6d 64 61 74 20 20 20 20 20 20 20 20 20 20 ormdat
d3e0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
d3f0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 34 29 tor-ref vec 24)
d400: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
d410: 67 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 get-request-meth
d420: 6f 64 20 20 20 20 20 20 20 76 65 63 29 20 20 20 od vec)
d430: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
d440: 63 20 32 35 29 29 0a 28 64 65 66 69 6e 65 20 28 c 25)).(define (
d450: 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
d460: 2d 63 6f 6f 6b 69 65 20 20 20 20 20 20 20 76 65 -cookie ve
d470: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
d480: 66 20 20 76 65 63 20 32 36 29 29 0a 28 64 65 66 f vec 26)).(def
d490: 69 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 63 75 ine (sdat-get-cu
d4a0: 72 72 2d 65 72 72 20 20 20 20 20 20 20 20 20 20 rr-err
d4b0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
d4c0: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 37 29 29 or-ref vec 27))
d4d0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 .(define (sdat-g
d4e0: 65 74 2d 6c 6f 67 2d 70 6f 72 74 20 20 20 20 20 et-log-port
d4f0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
d500: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
d510: 20 32 38 29 29 0a 28 64 65 66 69 6e 65 20 28 73 28)).(define (s
d520: 64 61 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 dat-get-logfile
d530: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 vec
d540: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
d550: 20 20 76 65 63 20 32 39 29 29 0a 28 64 65 66 69 vec 29)).(defi
d560: 6e 65 20 28 73 64 61 74 2d 67 65 74 2d 73 65 65 ne (sdat-get-see
d570: 6e 2d 70 61 67 65 73 20 20 20 20 20 20 20 20 20 n-pages
d580: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
d590: 72 2d 72 65 66 20 20 76 65 63 20 33 30 29 29 0a r-ref vec 30)).
d5a0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 (define (sdat-ge
d5b0: 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 t-page-dir-style
d5c0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
d5d0: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
d5e0: 33 31 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 31)).(define (sd
d5f0: 61 74 2d 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 at-get-debugmode
d600: 20 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 vec)
d610: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
d620: 20 76 65 63 20 33 32 29 29 0a 28 64 65 66 69 6e vec 32)).(defin
d630: 65 20 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 e (sdat-get-shar
d640: 65 64 2d 68 61 73 68 20 20 20 20 20 20 20 20 20 ed-hash
d650: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
d660: 2d 72 65 66 20 20 76 65 63 20 33 33 29 29 0a 28 -ref vec 33)).(
d670: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 67 65 74 define (sdat-get
d680: 2d 73 63 72 69 70 74 20 20 20 20 20 20 20 20 20 -script
d690: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
d6a0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 ector-ref vec 3
d6b0: 34 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 4)).(define (sda
d6c0: 74 2d 67 65 74 2d 66 6f 72 63 65 2d 73 73 6c 20 t-get-force-ssl
d6d0: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 vec)
d6e0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
d6f0: 76 65 63 20 33 35 29 29 0a 0a 28 64 65 66 69 6e vec 35))..(defin
d700: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 e (session:get-s
d710: 68 61 72 65 64 20 76 65 63 20 76 61 72 6e 61 6d hared vec varnam
d720: 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 e). (hash-table
d730: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 76 65 -ref/default (ve
d740: 63 74 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 ctor-ref vec 33)
d750: 20 76 61 72 6e 61 6d 65 20 23 66 29 29 0a 0a 28 varname #f))..(
d760: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
d770: 2d 64 62 74 79 70 65 21 20 20 20 20 20 20 20 20 -dbtype!
d780: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
d790: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 30 ector-set! vec 0
d7a0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
d7b0: 73 64 61 74 2d 73 65 74 2d 64 62 69 6e 69 74 21 sdat-set-dbinit!
d7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
d7d0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
d7e0: 74 21 20 76 65 63 20 31 20 76 61 6c 29 29 0a 28 t! vec 1 val)).(
d7f0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
d800: 2d 63 6f 6e 6e 21 20 20 20 20 20 20 20 20 20 20 -conn!
d810: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
d820: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
d830: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
d840: 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 sdat-set-params!
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
d860: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
d870: 74 21 20 76 65 63 20 33 20 76 61 6c 29 29 0a 28 t! vec 3 val)).(
d880: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
d890: 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 20 20 -path-params!
d8a0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
d8b0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 34 ector-set! vec 4
d8c0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
d8d0: 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e sdat-set-session
d8e0: 2d 6b 65 79 21 20 20 20 20 20 20 20 20 20 76 65 -key! ve
d8f0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
d900: 74 21 20 76 65 63 20 35 20 76 61 6c 29 29 0a 28 t! vec 5 val)).(
d910: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
d920: 2d 73 65 73 73 69 6f 6e 2d 69 64 21 20 20 20 20 -session-id!
d930: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
d940: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 36 ector-set! vec 6
d950: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
d960: 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 sdat-set-domain!
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
d980: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
d990: 74 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a 28 t! vec 7 val)).(
d9a0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
d9b0: 2d 74 6f 70 70 61 67 65 21 20 20 20 20 20 20 20 -toppage!
d9c0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
d9d0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 38 ector-set! vec 8
d9e0: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
d9f0: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 20 sdat-set-page!
da00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
da10: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
da20: 74 21 20 76 65 63 20 39 20 76 61 6c 29 29 0a 28 t! vec 9 val)).(
da30: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
da40: 2d 63 75 72 72 2d 70 61 67 65 21 20 20 20 20 20 -curr-page!
da50: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
da60: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
da70: 30 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 0 val)).(define
da80: 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 6e (sdat-set-conten
da90: 74 2d 74 79 70 65 21 20 20 20 20 20 20 20 20 76 t-type! v
daa0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
dab0: 65 74 21 20 76 65 63 20 31 31 20 76 61 6c 29 29 et! vec 11 val))
dac0: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
dad0: 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 20 20 et-page-type!
dae0: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
daf0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
db00: 20 31 32 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 12 val)).(defin
db10: 65 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f e (sdat-set-sroo
db20: 74 21 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t!
db30: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
db40: 2d 73 65 74 21 20 76 65 63 20 31 33 20 76 61 6c -set! vec 13 val
db50: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
db60: 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 21 20 20 -set-twikidir!
db70: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
db80: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
db90: 65 63 20 31 34 20 76 61 6c 29 29 0a 28 64 65 66 ec 14 val)).(def
dba0: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
dbb0: 67 65 64 61 74 21 20 20 20 20 20 20 20 20 20 20 gedat!
dbc0: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
dbd0: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 35 20 76 or-set! vec 15 v
dbe0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
dbf0: 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 65 2d at-set-alt-page-
dc00: 64 61 74 21 20 20 20 20 20 20 20 20 76 65 63 20 dat! vec
dc10: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
dc20: 20 76 65 63 20 31 36 20 76 61 6c 29 29 0a 28 64 vec 16 val)).(d
dc30: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
dc40: 70 61 67 65 76 61 72 73 21 20 20 20 20 20 20 20 pagevars!
dc50: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
dc60: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 37 ctor-set! vec 17
dc70: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
dc80: 73 64 61 74 2d 73 65 74 2d 70 61 67 65 76 61 72 sdat-set-pagevar
dc90: 73 2d 62 65 66 6f 72 65 21 20 20 20 20 20 76 65 s-before! ve
dca0: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
dcb0: 74 21 20 76 65 63 20 31 38 20 76 61 6c 29 29 0a t! vec 18 val)).
dcc0: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
dcd0: 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 20 20 t-sessionvars!
dce0: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
dcf0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
dd00: 31 39 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 19 val)).(define
dd10: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
dd20: 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 onvars-before!
dd30: 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d vec val)(vector-
dd40: 73 65 74 21 20 76 65 63 20 32 30 20 76 61 6c 29 set! vec 20 val)
dd50: 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d ).(define (sdat-
dd60: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 set-globalvars!
dd70: 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c vec val
dd80: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
dd90: 63 20 32 31 20 76 61 6c 29 29 0a 28 64 65 66 69 c 21 val)).(defi
dda0: 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f ne (sdat-set-glo
ddb0: 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 balvars-before!
ddc0: 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f vec val)(vecto
ddd0: 72 2d 73 65 74 21 20 76 65 63 20 32 32 20 76 61 r-set! vec 22 va
dde0: 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 l)).(define (sda
ddf0: 74 2d 73 65 74 2d 6c 6f 67 70 74 21 20 20 20 20 t-set-logpt!
de00: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 vec v
de10: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
de20: 76 65 63 20 32 33 20 76 61 6c 29 29 0a 28 64 65 vec 23 val)).(de
de30: 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 66 fine (sdat-set-f
de40: 6f 72 6d 64 61 74 21 20 20 20 20 20 20 20 20 20 ormdat!
de50: 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 vec val)(vec
de60: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 34 20 tor-set! vec 24
de70: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 val)).(define (s
de80: 64 61 74 2d 73 65 74 2d 72 65 71 75 65 73 74 2d dat-set-request-
de90: 6d 65 74 68 6f 64 21 20 20 20 20 20 20 76 65 63 method! vec
dea0: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
deb0: 21 20 76 65 63 20 32 35 20 76 61 6c 29 29 0a 28 ! vec 25 val)).(
dec0: 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 define (sdat-set
ded0: 2d 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 -session-cookie!
dee0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
def0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 32 ector-set! vec 2
df00: 36 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 6 val)).(define
df10: 28 73 64 61 74 2d 73 65 74 2d 63 75 72 72 2d 65 (sdat-set-curr-e
df20: 72 72 21 20 20 20 20 20 20 20 20 20 20 20 20 76 rr! v
df30: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
df40: 65 74 21 20 76 65 63 20 32 37 20 76 61 6c 29 29 et! vec 27 val))
df50: 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 .(define (sdat-s
df60: 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 20 20 20 et-log-port!
df70: 20 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 vec val)
df80: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
df90: 20 32 38 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 28 val)).(defin
dfa0: 65 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 e (sdat-set-logf
dfb0: 69 6c 65 21 20 20 20 20 20 20 20 20 20 20 20 20 ile!
dfc0: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
dfd0: 2d 73 65 74 21 20 76 65 63 20 32 39 20 76 61 6c -set! vec 29 val
dfe0: 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 61 74 )).(define (sdat
dff0: 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 -set-seen-pages!
e000: 20 20 20 20 20 20 20 20 20 20 76 65 63 20 76 61 vec va
e010: 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 l)(vector-set! v
e020: 65 63 20 33 30 20 76 61 6c 29 29 0a 28 64 65 66 ec 30 val)).(def
e030: 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ine (sdat-set-pa
e040: 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 20 20 ge-dir-style!
e050: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
e060: 6f 72 2d 73 65 74 21 20 76 65 63 20 33 31 20 76 or-set! vec 31 v
e070: 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 73 64 al)).(define (sd
e080: 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 65 at-set-debugmode
e090: 21 20 20 20 20 20 20 20 20 20 20 20 76 65 63 20 ! vec
e0a0: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
e0b0: 20 76 65 63 20 33 32 20 76 61 6c 29 29 0a 28 64 vec 32 val)).(d
e0c0: 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 74 2d efine (sdat-set-
e0d0: 73 68 61 72 65 64 2d 68 61 73 68 21 20 20 20 20 shared-hash!
e0e0: 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 vec val)(ve
e0f0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 33 ctor-set! vec 33
e100: 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 20 28 val)).(define (
e110: 73 64 61 74 2d 73 65 74 2d 73 63 72 69 70 74 21 sdat-set-script!
e120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 65 ve
e130: 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 c val)(vector-se
e140: 74 21 20 76 65 63 20 33 34 20 76 61 6c 29 29 0a t! vec 34 val)).
e150: 28 64 65 66 69 6e 65 20 28 73 64 61 74 2d 73 65 (define (sdat-se
e160: 74 2d 66 6f 72 63 65 2d 73 73 6c 21 20 20 20 20 t-force-ssl!
e170: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
e180: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
e190: 33 35 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 35 val))..(defin
e1a0: 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 73 e (session:set-s
e1b0: 68 61 72 65 64 21 20 76 65 63 20 76 61 72 6e 61 hared! vec varna
e1c0: 6d 65 20 76 61 6c 29 0a 20 20 28 68 61 73 68 2d me val). (hash-
e1d0: 74 61 62 6c 65 2d 73 65 74 21 20 28 76 65 63 74 table-set! (vect
e1e0: 6f 72 2d 72 65 66 20 76 65 63 20 33 33 29 20 76 or-ref vec 33) v
e1f0: 61 72 6e 61 6d 65 20 76 61 6c 29 29 0a 0a 3b 3b arname val))..;;
e200: 20 54 68 65 20 67 6c 6f 62 61 6c 20 73 65 73 73 The global sess
e210: 69 6f 6e 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 ion.(define s:se
e220: 73 73 69 6f 6e 20 28 6d 61 6b 65 2d 73 64 61 74 ssion (make-sdat
e230: 29 29 0a 0a 3b 3b 20 53 50 4c 49 54 20 49 4e 54 ))..;; SPLIT INT
e240: 4f 20 53 54 52 41 49 47 48 54 20 46 4f 52 57 41 O STRAIGHT FORWA
e250: 52 44 20 49 4e 49 54 20 41 4e 44 20 43 4f 4d 50 RD INIT AND COMP
e260: 4c 45 58 20 49 4e 49 54 0a 28 64 65 66 69 6e 65 LEX INIT.(define
e270: 20 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 (session:initia
e280: 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 73 64 lize self). (sd
e290: 61 74 2d 73 65 74 2d 64 62 74 79 70 65 21 20 73 at-set-dbtype! s
e2a0: 65 6c 66 20 20 20 20 20 20 27 70 67 29 0a 20 20 elf 'pg).
e2b0: 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 21 20 (sdat-set-page!
e2c0: 73 65 6c 66 20 20 20 20 20 20 20 20 22 68 6f 6d self "hom
e2d0: 65 22 29 20 20 20 20 20 20 20 20 3b 3b 20 74 68 e") ;; th
e2e0: 65 73 65 20 61 72 65 20 64 65 66 61 75 6c 74 73 ese are defaults
e2f0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
e300: 72 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 22 r-page! self "
e310: 68 6f 6d 65 22 29 0a 20 20 28 73 64 61 74 2d 73 home"). (sdat-s
e320: 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 21 et-content-type!
e330: 20 73 65 6c 66 20 22 43 6f 6e 74 65 6e 74 2d 74 self "Content-t
e340: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 ype: text/html;
e350: 63 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 charset=iso-8859
e360: 2d 31 5c 6e 5c 6e 22 29 0a 20 20 28 73 64 61 74 -1\n\n"). (sdat
e370: 2d 73 65 74 2d 70 61 67 65 2d 74 79 70 65 21 20 -set-page-type!
e380: 73 65 6c 66 20 20 20 27 68 74 6d 6c 29 0a 20 20 self 'html).
e390: 28 73 64 61 74 2d 73 65 74 2d 74 6f 70 70 61 67 (sdat-set-toppag
e3a0: 65 21 20 73 65 6c 66 20 20 20 20 20 22 69 6e 64 e! self "ind
e3b0: 65 78 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 ex"). (sdat-set
e3c0: 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 20 20 20 -params! self
e3d0: 20 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 '())
e3e0: 20 20 3b 3b 0a 20 20 28 73 64 61 74 2d 73 65 74 ;;. (sdat-set
e3f0: 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
e400: 6c 66 20 27 28 29 29 0a 20 20 28 73 64 61 74 2d lf '()). (sdat-
e410: 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 21 set-session-key!
e420: 20 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 self #f). (sda
e430: 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 20 73 t-set-pagedat! s
e440: 65 6c 66 20 20 20 20 20 27 28 29 29 0a 20 20 28 elf '()). (
e450: 73 64 61 74 2d 73 65 74 2d 61 6c 74 2d 70 61 67 sdat-set-alt-pag
e460: 65 2d 64 61 74 21 20 73 65 6c 66 20 23 66 29 0a e-dat! self #f).
e470: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f (sdat-set-sroo
e480: 74 21 20 73 65 6c 66 20 20 20 20 20 20 20 22 2e t! self ".
e490: 2f 22 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d /"). (sdat-set-
e4a0: 73 65 73 73 69 6f 6e 2d 63 6f 6f 6b 69 65 21 20 session-cookie!
e4b0: 73 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 self #f). (sdat
e4c0: 2d 73 65 74 2d 63 75 72 72 2d 65 72 72 21 20 73 -set-curr-err! s
e4d0: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
e4e0: 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 set-log-port! se
e4f0: 6c 66 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f lf (current-erro
e500: 72 2d 70 6f 72 74 29 29 0a 20 20 28 73 64 61 74 r-port)). (sdat
e510: 2d 73 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 21 -set-seen-pages!
e520: 20 73 65 6c 66 20 27 28 29 29 0a 20 20 28 73 64 self '()). (sd
e530: 61 74 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d at-set-page-dir-
e540: 73 74 79 6c 65 21 20 73 65 6c 66 20 23 74 29 20 style! self #t)
e550: 3b 3b 20 23 74 20 3a 20 70 61 67 65 73 2f 3c 70 ;; #t : pages/<p
e560: 61 67 65 6e 61 6d 65 3e 5f 28 76 69 65 77 7c 63 agename>_(view|c
e570: 6e 74 6c 29 2e 73 63 6d 0a 20 20 20 20 20 20 20 ntl).scm.
e580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
e5a0: 3b 20 23 66 20 3a 20 70 61 67 65 73 2f 3c 70 61 ; #f : pages/<pa
e5b0: 67 65 6e 61 6d 65 3e 2f 28 76 69 65 77 7c 63 6f gename>/(view|co
e5c0: 6e 74 72 6f 6c 29 2e 73 63 6d 20 0a 20 20 28 73 ntrol).scm . (s
e5d0: 64 61 74 2d 73 65 74 2d 64 65 62 75 67 6d 6f 64 dat-set-debugmod
e5e0: 65 21 20 20 20 20 20 20 20 20 20 20 73 65 6c 66 e! self
e5f0: 20 23 66 29 0a 20 20 09 09 09 20 20 20 20 20 0a #f). ... .
e600: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
e610: 76 61 72 73 21 20 20 20 20 20 20 20 20 20 20 20 vars!
e620: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
e630: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
e640: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 21 set-sessionvars!
e650: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
e660: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
e670: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
e680: 61 6c 76 61 72 73 21 20 20 20 20 20 20 20 20 20 alvars!
e690: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
e6a0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
e6b0: 73 65 74 2d 70 61 67 65 76 61 72 73 2d 62 65 66 set-pagevars-bef
e6c0: 6f 72 65 21 20 20 20 20 73 65 6c 66 20 28 6d 61 ore! self (ma
e6d0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
e6e0: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
e6f0: 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 21 20 ionvars-before!
e700: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
e710: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
e720: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 2d 62 set-globalvars-b
e730: 65 66 6f 72 65 21 20 20 73 65 6c 66 20 28 6d 61 efore! self (ma
e740: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
e750: 20 20 28 73 64 61 74 2d 73 65 74 2d 64 6f 6d 61 (sdat-set-doma
e760: 69 6e 21 20 20 20 20 20 20 20 20 20 20 20 20 20 in!
e770: 73 65 6c 66 20 22 6c 6f 63 61 68 6f 73 74 22 29 self "locahost")
e780: 20 20 20 3b 3b 20 65 6e 64 20 6f 66 20 64 65 66 ;; end of def
e790: 61 75 6c 74 73 0a 20 20 28 73 64 61 74 2d 73 65 aults. (sdat-se
e7a0: 74 2d 73 63 72 69 70 74 21 20 20 20 20 20 20 20 t-script!
e7b0: 20 20 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 self #f).
e7c0: 20 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 (sdat-set-force
e7d0: 2d 73 73 6c 21 20 20 20 20 20 20 20 20 20 20 73 -ssl! s
e7e0: 65 6c 66 20 23 66 29 0a 20 20 28 6c 65 74 2a 20 elf #f). (let*
e7f0: 28 28 72 61 77 63 6f 6e 66 69 67 64 61 74 20 28 ((rawconfigdat (
e800: 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f 6e session:read-con
e810: 66 69 67 20 73 65 6c 66 29 29 0a 09 20 28 63 6f fig self)).. (co
e820: 6e 66 69 67 64 61 74 20 28 69 66 20 72 61 77 63 nfigdat (if rawc
e830: 6f 6e 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 onfigdat (eval r
e840: 61 77 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 awconfigdat) '()
e850: 29 29 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 )).. (sroot
e860: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 (s:find-param 's
e870: 72 6f 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 root configda
e880: 74 29 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 t)).. (logfile
e890: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
e8a0: 6c 6f 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 logfile configd
e8b0: 61 74 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 at)).. (dbtype
e8c0: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
e8d0: 27 64 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 'dbtype config
e8e0: 64 61 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 dat)).. (dbinit
e8f0: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
e900: 20 27 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 'dbinit confi
e910: 67 64 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e gdat)).. (domain
e920: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
e930: 6d 20 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 m 'domain conf
e940: 69 67 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 igdat)).. (twiki
e950: 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 dir (s:find-par
e960: 61 6d 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e am 'twikidir con
e970: 66 69 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 figdat)).. (page
e980: 2d 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 -dir (s:find-pa
e990: 72 61 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 ram 'page-dir-st
e9a0: 79 6c 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a yle configdat)).
e9b0: 09 20 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a . (debugmode (s:
e9c0: 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 find-param 'debu
e9d0: 67 6d 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 gmode configdat)
e9e0: 29 0a 20 20 20 20 20 20 20 20 20 28 73 63 72 69 ). (scri
e9f0: 70 74 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 pt (s:find-pa
ea00: 72 61 6d 20 27 73 63 72 69 70 74 20 20 20 20 63 ram 'script c
ea10: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 66 6f onfigdat)).. (fo
ea20: 72 63 65 2d 73 73 6c 20 28 73 3a 66 69 6e 64 2d rce-ssl (s:find-
ea30: 70 61 72 61 6d 20 27 66 6f 72 63 65 2d 73 73 6c param 'force-ssl
ea40: 20 63 6f 6e 66 69 67 64 61 74 29 29 29 0a 20 20 configdat))).
ea50: 20 20 28 69 66 20 73 72 6f 6f 74 20 20 20 20 28 (if sroot (
ea60: 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 sdat-set-sroot!
ea70: 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 29 29 0a self sroot)).
ea80: 20 20 20 20 28 69 66 20 6c 6f 67 66 69 6c 65 20 (if logfile
ea90: 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 (sdat-set-logfi
eaa0: 6c 65 21 20 20 73 65 6c 66 20 6c 6f 67 66 69 6c le! self logfil
eab0: 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 74 79 e)). (if dbty
eac0: 70 65 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 pe (sdat-set-d
ead0: 62 74 79 70 65 21 20 20 20 73 65 6c 66 20 64 62 btype! self db
eae0: 74 79 70 65 29 29 0a 20 20 20 20 28 69 66 20 64 type)). (if d
eaf0: 62 69 6e 69 74 20 20 20 28 73 64 61 74 2d 73 65 binit (sdat-se
eb00: 74 2d 64 62 69 6e 69 74 21 20 20 20 73 65 6c 66 t-dbinit! self
eb10: 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 dbinit)). (i
eb20: 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 64 61 74 f domain (sdat
eb30: 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 73 -set-domain! s
eb40: 65 6c 66 20 64 6f 6d 61 69 6e 29 29 0a 20 20 20 elf domain)).
eb50: 20 28 69 66 20 74 77 69 6b 69 64 69 72 20 28 73 (if twikidir (s
eb60: 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 dat-set-twikidir
eb70: 21 20 73 65 6c 66 20 74 77 69 6b 69 64 69 72 29 ! self twikidir)
eb80: 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 67 6d ). (if debugm
eb90: 6f 64 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 ode (sdat-set-de
eba0: 62 75 67 6d 6f 64 65 21 20 73 65 6c 66 20 64 65 bugmode! self de
ebb0: 62 75 67 6d 6f 64 65 29 29 0a 20 20 20 20 28 69 bugmode)). (i
ebc0: 66 20 73 63 72 69 70 74 20 20 20 20 28 73 64 61 f script (sda
ebd0: 74 2d 73 65 74 2d 73 63 72 69 70 74 21 20 20 20 t-set-script!
ebe0: 20 73 65 6c 66 20 73 63 72 69 70 74 29 29 0a 20 self script)).
ebf0: 20 20 20 28 69 66 20 66 6f 72 63 65 2d 73 73 6c (if force-ssl
ec00: 20 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 (sdat-set-force
ec10: 2d 73 73 6c 21 20 73 65 6c 66 20 66 6f 72 63 65 -ssl! self force
ec20: 2d 73 73 6c 29 29 0a 20 20 20 20 28 73 64 61 74 -ssl)). (sdat
ec30: 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -set-page-dir-st
ec40: 79 6c 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 yle! self page-d
ec50: 69 72 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e ir). ;; (prin
ec60: 74 20 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 t "configdat: ")
ec70: 28 70 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 (pp configdat).
ec80: 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 (if debugmode
ec90: 0a 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ..(session:log s
eca0: 65 6c 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 elf "sroot: " sr
ecb0: 6f 6f 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 oot " logfile: "
ecc0: 20 6c 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 logfile " dbtyp
ecd0: 65 3a 20 22 20 64 62 74 79 70 65 20 0a 09 09 20 e: " dbtype ...
ece0: 20 20 20 20 22 20 64 62 69 6e 69 74 3a 20 22 20 " dbinit: "
ecf0: 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a dbinit " domain:
ed00: 20 22 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 " domain " page
ed10: 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 -dir-style: " pa
ed20: 67 65 2d 64 69 72 29 29 0a 20 20 20 20 29 0a 20 ge-dir)). ).
ed30: 20 28 73 64 61 74 2d 73 65 74 2d 73 68 61 72 65 (sdat-set-share
ed40: 64 2d 68 61 73 68 21 20 73 65 6c 66 20 28 6d 61 d-hash! self (ma
ed50: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
ed60: 20 20 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 )..;; Used for
ed70: 20 74 68 65 20 73 74 72 61 6e 67 65 6c 79 20 69 the strangely i
ed80: 6e 63 6f 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 nconsistent hand
ed90: 6c 69 6e 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 ling of the conf
eda0: 69 67 20 66 69 6c 65 2e 20 41 20 62 65 74 74 65 ig file. A bette
edb0: 72 20 77 61 79 20 69 73 20 6e 65 65 64 65 64 2e r way is needed.
edc0: 0a 3b 3b 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 .;;.;; (let ((
edd0: 64 62 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 dbtype (sdat-get
ede0: 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a -dbtype self))).
edf0: 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 ;; (print "d
ee00: 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 btype: " dbtype)
ee10: 0a 3b 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 .;; (sdat-se
ee20: 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 t-dbtype! self (
ee30: 65 76 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a eval dbtype)))).
ee40: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
ee50: 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 n:setup self).
ee60: 28 6c 65 74 20 28 28 64 62 74 79 70 65 20 20 20 (let ((dbtype
ee70: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 (sdat-get-dbtyp
ee80: 65 20 73 65 6c 66 29 29 0a 09 28 64 65 62 75 67 e self))..(debug
ee90: 6d 6f 64 65 20 28 73 64 61 74 2d 67 65 74 2d 64 mode (sdat-get-d
eea0: 65 62 75 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a ebugmode self)).
eeb0: 09 28 64 62 69 6e 69 74 20 20 20 20 28 65 76 61 .(dbinit (eva
eec0: 6c 20 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e l (sdat-get-dbin
eed0: 69 74 20 73 65 6c 66 29 29 29 0a 09 28 64 62 65 it self)))..(dbe
eee0: 78 69 73 74 73 20 20 23 66 29 29 0a 20 20 20 20 xists #f)).
eef0: 28 6c 65 74 20 28 28 64 62 66 6e 61 6d 65 20 28 (let ((dbfname (
ef00: 61 6c 69 73 74 2d 72 65 66 20 27 64 62 6e 61 6d alist-ref 'dbnam
ef10: 65 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 e dbinit))).
ef20: 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 (if debugmode
ef30: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
ef40: 66 20 22 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 f "session:setup
ef50: 20 64 62 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 dbfname=" dbfna
ef60: 6d 65 20 22 2c 20 64 62 74 79 70 65 3d 22 20 64 me ", dbtype=" d
ef70: 62 74 79 70 65 20 22 2c 20 64 62 69 6e 69 74 3d btype ", dbinit=
ef80: 22 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 20 " dbinit)).
ef90: 20 28 69 66 20 28 65 71 3f 20 64 62 74 79 70 65 (if (eq? dbtype
efa0: 20 27 73 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 'sqlite3).. ;;
efb0: 20 54 68 65 20 27 61 75 74 6f 20 6d 65 74 68 6f The 'auto metho
efc0: 64 20 77 69 6c 6c 20 64 69 73 74 72 69 62 75 74 d will distribut
efd0: 65 20 64 62 73 20 61 63 72 6f 73 73 20 74 68 65 e dbs across the
efe0: 20 64 69 73 6b 20 75 73 69 6e 67 20 68 61 73 68 disk using hash
eff0: 0a 09 20 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 .. ;; of user h
f000: 6f 73 74 20 61 6e 64 20 75 73 65 72 2e 20 54 4f ost and user. TO
f010: 44 4f 0a 09 20 20 3b 3b 20 28 69 66 20 28 65 71 DO.. ;; (if (eq
f020: 3f 20 64 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 ? dbfname 'auto)
f030: 20 3b 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 ;; This is the
f040: 61 75 74 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 auto assignment
f050: 6f 66 20 61 20 64 62 20 62 61 73 65 64 20 6f 6e of a db based on
f060: 20 68 61 73 68 20 6f 66 20 49 50 0a 09 20 20 28 hash of IP.. (
f070: 6c 65 74 20 28 28 64 62 70 61 74 68 20 28 70 61 let ((dbpath (pa
f080: 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 thname-directory
f090: 20 64 62 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 dbfname))) ;;
f0a0: 64 6f 20 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 do a couple sani
f0b0: 74 79 20 63 68 65 63 6b 73 20 68 65 72 65 20 74 ty checks here t
f0c0: 6f 20 6d 61 6b 65 20 73 65 74 74 69 6e 67 20 75 o make setting u
f0d0: 70 20 65 61 73 69 65 72 0a 09 20 20 20 20 28 69 p easier.. (i
f0e0: 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 f debugmode (ses
f0f0: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 sion:log self "I
f100: 4e 46 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 NFO: setting up
f110: 66 6f 72 20 73 71 6c 69 74 65 33 20 64 62 20 61 for sqlite3 db a
f120: 63 63 65 73 73 20 74 6f 20 22 20 64 62 66 6e 61 ccess to " dbfna
f130: 6d 65 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e me)).. (if (n
f140: 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ot (file-write-a
f150: 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 29 0a ccess? dbpath)).
f160: 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ..(session:log s
f170: 65 6c 66 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 elf "WARNING: Ca
f180: 6e 6e 6f 74 20 77 72 69 74 65 20 74 6f 20 22 20 nnot write to "
f190: 64 62 70 61 74 68 29 0a 09 09 28 69 66 20 64 65 dbpath)...(if de
f1a0: 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e bugmode (session
f1b0: 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a :log self "INFO:
f1c0: 20 22 20 64 62 70 61 74 68 20 22 20 69 73 20 77 " dbpath " is w
f1d0: 72 69 74 65 61 62 6c 65 22 29 29 29 0a 09 20 20 riteable")))..
f1e0: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
f1f0: 74 73 3f 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 ts? dbfname)...(
f200: 62 65 67 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 begin... ;; (se
f210: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
f220: 73 65 74 74 69 6e 67 20 64 62 65 78 69 73 74 73 setting dbexists
f230: 20 74 6f 20 23 74 22 29 0a 09 09 20 20 28 73 65 to #t")... (se
f240: 74 21 20 64 62 65 78 69 73 74 73 20 23 74 29 29 t! dbexists #t))
f250: 29 29 0a 09 20 20 28 69 66 20 64 65 62 75 67 6d )).. (if debugm
f260: 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ode (session:log
f270: 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 self "INFO: set
f280: 74 69 6e 67 20 75 70 20 66 6f 72 20 70 67 20 64 ting up for pg d
f290: 62 20 61 63 63 65 73 73 20 74 6f 20 61 63 63 6f b access to acco
f2a0: 75 6e 74 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 unt info " dbini
f2b0: 74 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 t))). (if d
f2c0: 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f ebugmode (sessio
f2d0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 79 n:log self "dbty
f2e0: 70 65 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 pe: " dbtype " d
f2f0: 62 66 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d bfname: " dbfnam
f300: 65 20 22 20 64 62 65 78 69 73 74 73 3a 20 22 20 e " dbexists: "
f310: 64 62 65 78 69 73 74 73 29 29 29 0a 20 20 20 20 dbexists))).
f320: 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 (sdat-set-conn!
f330: 73 65 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 self (dbi:open d
f340: 62 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 btype dbinit)).
f350: 20 20 20 28 73 65 74 21 20 2a 64 62 2a 20 28 73 (set! *db* (s
f360: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
f370: 66 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 f)). (if (and
f380: 20 28 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 (not dbexists)(
f390: 65 71 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 eq? dbtype 'sqli
f3a0: 74 65 33 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 te3)). .(begin..
f3b0: 20 20 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e (print "WARNIN
f3c0: 47 3a 20 53 65 74 74 69 6e 67 20 75 70 20 73 65 G: Setting up se
f3d0: 73 73 69 6f 6e 20 64 62 20 77 69 74 68 20 73 71 ssion db with sq
f3e0: 6c 69 74 65 33 22 29 0a 09 20 20 28 73 65 73 73 lite3").. (sess
f3f0: 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c ion:setup-db sel
f400: 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f f))). (sessio
f410: 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 n:process-url-pa
f420: 74 68 20 73 65 6c 66 29 0a 20 20 20 20 28 73 65 th self). (se
f430: 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 ssion:setup-sess
f440: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 ion-key self).
f450: 20 20 3b 3b 20 63 61 70 74 75 72 65 20 73 74 64 ;; capture std
f460: 69 6e 20 69 66 20 74 68 69 73 20 69 73 20 61 20 in if this is a
f470: 50 4f 53 54 0a 20 20 20 20 28 73 64 61 74 2d 73 POST. (sdat-s
f480: 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f et-request-metho
f490: 64 21 20 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 d! self (get-env
f4a0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
f4b0: 65 20 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f e "REQUEST_METHO
f4c0: 44 22 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 D")). (sdat-s
f4d0: 65 74 2d 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 et-formdat! self
f4e0: 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 (formdat:load-a
f4f0: 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 ll))))..;; setup
f500: 20 74 68 65 20 64 62 20 77 69 74 68 20 73 65 73 the db with ses
f510: 73 69 6f 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 sion tables, wor
f520: 6b 73 20 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e ks for sqlite on
f530: 6c 79 20 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 ly right now.(de
f540: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
f550: 74 75 70 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 tup-db self). (
f560: 6c 65 74 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 let ((conn (sdat
f570: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
f580: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
f590: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 . (lambda (s
f5a0: 74 6d 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 tmt). (dbi
f5b0: 3a 65 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 :exec conn stmt)
f5c0: 29 0a 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 ). (list "CR
f5d0: 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 EATE TABLE sessi
f5e0: 6f 6e 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 on_vars (id INTE
f5f0: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
f600: 73 65 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 session_id INTEG
f610: 45 52 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 ER,page TEXT,key
f620: 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 TEXT,value TEXT
f630: 29 3b 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 );".. "CREATE
f640: 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 TABLE sessions (
f650: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
f660: 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b RY KEY,session_k
f670: 65 79 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 ey TEXT,last_use
f680: 64 20 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 d TIMESTAMP);".
f690: 20 20 20 20 20 20 20 20 20 20 22 43 52 45 41 54 "CREAT
f6a0: 45 20 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 E TABLE metadata
f6b0: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
f6c0: 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 MARY KEY,key TEX
f6d0: 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 T,value TEXT);")
f6e0: 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 ))).;; ;; if we
f6f0: 20 68 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f have a session_
f700: 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 key look up the
f710: 73 65 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 session-id and s
f720: 74 6f 72 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 tore it.;; (sda
f730: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-set-session-id
f740: 21 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a ! self (session:
f750: 67 65 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a get-id self)))..
f760: 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 ;; only set sess
f770: 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 ion-cookie when
f780: 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 a new session is
f790: 20 63 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 created.(define
f7a0: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
f7b0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
f7c0: 29 20 20 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b ) . (let* ((sk
f7d0: 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 (session:extra
f7e0: 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 ct-session-key s
f7f0: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 elf)). (
f800: 73 69 64 20 28 69 66 20 73 6b 20 28 73 65 73 73 sid (if sk (sess
f810: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 ion:get-id self
f820: 73 6b 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 sk) #f))). (i
f830: 66 20 28 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e f (not sid) ;; n
f840: 65 65 64 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 eed a new key.
f850: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 (let* ((ne
f860: 77 2d 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 w-key (session:g
f870: 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 et-new-key self)
f880: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
f890: 20 28 6e 65 77 2d 73 69 64 20 28 73 65 73 73 69 (new-sid (sessi
f8a0: 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 6e on:get-id self n
f8b0: 65 77 2d 6b 65 79 29 29 29 0a 20 20 20 20 20 20 ew-key))).
f8c0: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 (sdat-set-se
f8d0: 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 ssion-key! self
f8e0: 6e 65 77 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 new-key).
f8f0: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 (sdat-set-ses
f900: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 sion-id! self ne
f910: 77 2d 73 69 64 29 0a 20 20 20 20 20 20 20 20 20 w-sid).
f920: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
f930: 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 on-cookie! self
f940: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f (session:make-co
f950: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 20 20 20 okie self))).
f960: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 (sdat-set-s
f970: 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 ession-id! self
f980: 73 69 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 sid))))..(define
f990: 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 (session:make-c
f9a0: 6f 6f 6b 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b ookie self). ;;
f9b0: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 73 65 (list (conc "se
f9c0: 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 ssion_key=" (sda
f9d0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
f9e0: 79 20 73 65 6c 66 29 20 22 3b 20 50 61 74 68 3d y self) "; Path=
f9f0: 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 /; Domain=." (sd
fa00: 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 at-get-domain se
fa10: 6c 66 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 lf) "; Max-Age="
fa20: 20 28 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b (* 86400 14) ";
fa30: 20 56 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a Version=1"))) .
fa40: 20 20 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 ;; According t
fa50: 6f 20 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a o . ;; http:
fa60: 2f 2f 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c //www.codemarvel
fa70: 73 2e 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 s.com/2010/11/ap
fa80: 61 63 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 ache-rewriterule
fa90: 2d 73 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e -set-a-cookie-on
faa0: 2d 6c 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b -localhost/.. ;
fab0: 3b 20 20 48 65 72 65 20 61 72 65 20 74 68 65 20 ; Here are the
fac0: 32 20 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 2 (often left ou
fad0: 74 29 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 t) requirements
fae0: 74 6f 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 to set a cookie
faf0: 75 73 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 using. ;; http
fb00: 64 1b 2d 46 ef bf bd 73 20 72 65 77 72 69 74 65 d.-F�s rewrite
fb10: 20 72 75 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 rule (mod_rewri
fb20: 74 65 29 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 te), while worki
fb30: 6e 67 20 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a ng on localhost:
fb40: 1b 2d 41 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 .-A. ;;. ;; U
fb50: 73 65 20 74 68 65 20 49 50 20 31 32 37 2e 30 2e se the IP 127.0.
fb60: 30 2e 31 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 0.1 instead of l
fb70: 6f 63 61 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 ocalhost/machine
fb80: 2d 6e 61 6d 65 20 61 73 20 74 68 65 0a 20 20 3b -name as the. ;
fb90: 3b 20 20 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 ; domain; e.g.
fba0: 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 [CO=someCookie:s
fbb0: 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 omeValue:127.0.0
fbc0: 2e 31 3a 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 .1:2:/], which s
fbd0: 61 79 73 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 ays. ;; create
fbe0: 20 61 20 63 6f 6f 6b 69 65 20 1b 2d 59 ef bf bd a cookie .-Y�
fbf0: 73 6f 6d 65 43 6f 6f 6b 69 65 ef bf bd 20 77 69 someCookie� wi
fc00: 74 68 20 76 61 6c 75 65 20 ef bf bd 73 6f 6d 65 th value �some
fc10: 56 61 6c 75 65 ef bf bd 20 66 6f 72 20 74 68 65 Value� for the
fc20: 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 20 ef bf . ;; domain ï¿
fc30: bd 31 32 37 2e 30 2e 30 2e 31 1b 24 42 21 6d 1b ½127.0.0.1.$B!m.
fc40: 28 42 20 68 61 76 69 6e 67 20 61 20 6c 69 66 65 (B having a life
fc50: 20 74 69 6d 65 20 6f 66 20 32 20 6d 69 6e 73 2c time of 2 mins,
fc60: 20 66 6f 72 20 61 6e 79 20 70 61 74 68 20 69 6e for any path in
fc70: 0a 20 20 3b 3b 20 20 74 68 65 20 64 6f 6d 61 69 . ;; the domai
fc80: 6e 20 28 70 61 74 68 3d 2f 29 2e 20 28 4f 62 76 n (path=/). (Obv
fc90: 69 6f 75 73 6c 79 20 79 6f 75 20 77 69 6c 6c 20 iously you will
fca0: 68 61 76 65 20 74 6f 20 72 75 6e 20 74 68 65 0a have to run the.
fcb0: 20 20 3b 3b 20 20 61 70 70 6c 69 63 61 74 69 6f ;; applicatio
fcc0: 6e 20 77 69 74 68 20 74 68 69 73 20 76 61 6c 75 n with this valu
fcd0: 65 20 69 6e 20 74 68 65 20 55 52 4c 29 0a 20 20 e in the URL).
fce0: 3b 3b 0a 20 20 3b 3b 20 20 54 6f 20 6d 61 6b 65 ;;. ;; To make
fcf0: 20 61 20 73 65 73 73 69 6f 6e 20 63 6f 6f 6b 69 a session cooki
fd00: 65 2c 20 6c 69 6d 69 74 20 74 68 65 20 66 6c 61 e, limit the fla
fd10: 67 20 73 74 61 74 65 6d 65 6e 74 20 74 6f 20 6a g statement to j
fd20: 75 73 74 20 74 68 72 65 65 0a 20 20 3b 3b 20 20 ust three. ;;
fd30: 61 74 74 72 69 62 75 74 65 73 3a 20 6e 61 6d 65 attributes: name
fd40: 2c 20 76 61 6c 75 65 20 61 6e 64 20 64 6f 6d 61 , value and doma
fd50: 69 6e 2e 20 65 2e 67 0a 20 20 3b 3b 20 20 5b 43 in. e.g. ;; [C
fd60: 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d O=someCookie:som
fd70: 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 eValue:127.0.0.1
fd80: 5d 20 1b 25 47 e2 80 93 1b 25 40 20 41 6e 79 20 ] .%G–.%@ Any
fd90: 66 75 72 74 68 65 72 0a 20 20 3b 3b 20 20 73 65 further. ;; se
fda0: 74 74 69 6e 67 73 2c 20 61 70 61 63 68 65 20 77 ttings, apache w
fdb0: 72 69 74 65 73 20 61 6e ef bf bd 20 65 78 70 69 rites an� expi
fdc0: 72 65 73 ef bf bd 20 61 74 74 72 69 62 75 74 65 res� attribute
fdd0: 20 66 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f for the set-coo
fde0: 6b 69 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 kie. ;; header
fdf0: 2c 20 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 , which makes th
fe00: 65 20 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 e cookie a persi
fe10: 73 74 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 stent one (not r
fe20: 65 61 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 eally. ;; pers
fe30: 69 73 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 istent, as the e
fe40: 78 70 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 xpires value set
fe50: 20 69 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 is the current
fe60: 73 65 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b server time. ;;
fe70: 20 20 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 .%G–.%@ so y
fe80: 6f 75 20 64 6f 6e 1b 2d 46 1b 2d 46 ef bf bd 74 ou don.-F.-F�t
fe90: 20 65 76 65 6e 20 67 65 74 20 74 6f 20 73 65 65 even get to see
fea0: 20 79 6f 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d your cookie!).-
feb0: 41 0a 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e A. (list (strin
fec0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 20 g-substitute ..
fed0: 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 61 72 ";" "; " .. (car
fee0: 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b (construct-cook
fef0: 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 20 ie-string ..
ff00: 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d ;; warning! m
ff10: 65 73 73 69 6e 67 20 75 70 20 74 68 69 73 20 69 essing up this i
ff20: 74 74 79 20 62 69 74 74 79 20 62 69 74 20 6f 66 tty bitty bit of
ff30: 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 code will cost
ff40: 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 20 20 20 much time!..
ff50: 20 20 20 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b `(("session_k
ff60: 65 79 22 20 2c 28 73 64 61 74 2d 67 65 74 2d 73 ey" ,(sdat-get-s
ff70: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
ff80: 0a 09 09 20 20 65 78 70 69 72 65 73 3a 20 2c 28 ... expires: ,(
ff90: 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e + (current-secon
ffa0: 64 73 29 20 28 2a 20 31 34 20 38 36 34 30 30 29 ds) (* 14 86400)
ffb0: 29 20 0a 09 09 20 20 3b 3b 20 6d 61 78 2d 61 67 ) ... ;; max-ag
ffc0: 65 3a 20 28 2a 20 31 34 20 38 36 34 30 30 29 0a e: (* 14 86400).
ffd0: 09 09 20 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b .. path: "/" ;;
ffe0: 20 0a 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 ... domain: ,(
fff0: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e string-append ".
10000 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 " (sdat-get-doma
10010 69 6e 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 in self))... ve
10020 72 73 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 rsion: 1)) 0))))
10030 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 )..;; look up a
10040 67 69 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 given session ke
10050 79 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 y and return the
10060 20 69 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 id if found, #f
10070 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 if not found.(d
10080 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
10090 65 74 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 et-id self sessi
100a0 6f 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 on-key). ;; (le
100b0 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 t ((session-key
100c0 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
100d0 6e 2d 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 20 n-key self))).
100e0 28 69 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a (if session-key.
100f0 20 20 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 (let ((que
10100 72 79 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ry (string-appen
10110 64 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f d "SELECT id FRO
10120 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 M sessions WHERE
10130 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 session_key='"
10140 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 session-key "'")
10150 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ). (c
10160 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f onn (sdat-get-co
10170 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 nn self)).
10180 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 (result #f
10190 29 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 ))..(dbi:for-eac
101a0 68 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 h-row .. (lambda
101b0 20 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 (tuple).. (se
101c0 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f t! result (vecto
101d0 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
101e0 0a 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 .. conn query)..
101f0 28 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a (if result (dbi:
10200 65 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 exec conn (conc
10210 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 "UPDATE sessions
10220 20 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 SET last_used="
10230 20 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 (dbi:now conn)
10240 22 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f " WHERE session_
10250 6b 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e key=?;") session
10260 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 -key)). r
10270 65 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 esult). #f)
10280 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 )..;; .(define (
10290 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
102a0 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 url-path self).
102b0 20 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 (let ((path-inf
102c0 6f 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f o (get-enviro
102d0 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
102e0 50 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 PATH_INFO"))..(q
102f0 75 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 uery-string (get
10300 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
10310 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 iable "QUERY_STR
10320 49 4e 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 ING"))). ;; (
10330 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
10340 20 22 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 "path-info=" pa
10350 74 68 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d th-info " query-
10360 73 74 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 string=" query-s
10370 74 72 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 tring). (if p
10380 61 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 ath-info..(let*
10390 28 28 70 61 72 74 73 20 20 20 20 28 73 74 72 69 ((parts (stri
103a0 6e 67 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e ng-split path-in
103b0 66 6f 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 fo "/"))..
103c0 20 28 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 (numparts (leng
103d0 74 68 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 th parts))).. (
103e0 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 if (> numparts 0
103f0 29 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 ).. (sdat-s
10400 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 28 63 et-page! self (c
10410 61 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b ar parts))).. ;
10420 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
10430 65 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 elf "url-path="
10440 75 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 url-path " parts
10450 3d 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 =" parts).. (if
10460 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a (> numparts 1).
10470 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 . (sdat-set
10480 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
10490 6c 66 20 28 63 64 72 20 70 61 72 74 73 29 29 29 lf (cdr parts)))
104a0 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 71 . (if q
104b0 75 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 uery-string.
104c0 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
104d0 73 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 set-params! self
104e0 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 (string-split q
104f0 75 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 uery-string "&")
10500 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 ))))))..;; BUGGY
10510 21 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 !.(define (sessi
10520 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 on:get-new-key s
10530 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f elf). (let ((co
10540 6e 6e 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 nn (sdat-get-c
10550 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 onn self)).
10560 20 20 20 28 74 6d 70 6b 65 79 20 28 73 65 73 73 (tmpkey (sess
10570 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 ion:make-rand-st
10580 72 69 6e 67 20 32 30 29 29 0a 20 20 20 20 20 20 ring 20)).
10590 20 20 28 73 74 61 74 75 73 20 23 66 29 29 0a 20 (status #f)).
105a0 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
105b0 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
105c0 70 6c 65 29 0a 09 09 09 28 73 65 74 21 20 73 74 ple)....(set! st
105d0 61 74 75 73 20 23 74 29 29 0a 09 09 20 20 20 20 atus #t))...
105e0 20 20 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 conn (string-a
105f0 70 70 65 6e 64 20 22 49 4e 53 45 52 54 20 49 4e ppend "INSERT IN
10600 54 4f 20 73 65 73 73 69 6f 6e 73 20 28 73 65 73 TO sessions (ses
10610 73 69 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 sion_key) VALUES
10620 20 28 27 22 20 74 6d 70 6b 65 79 20 22 27 29 22 ('" tmpkey "')"
10630 29 29 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 0a )). tmpkey)).
10640 0a 3b 3b 20 72 65 74 75 72 6e 73 20 73 65 73 73 .;; returns sess
10650 69 6f 6e 20 6b 65 79 20 49 46 46 20 69 74 20 69 ion key IFF it i
10660 73 20 69 6e 20 74 68 65 20 48 54 54 50 5f 43 4f s in the HTTP_CO
10670 4f 4b 49 45 20 0a 28 64 65 66 69 6e 65 20 28 73 OKIE .(define (s
10680 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 ession:extract-s
10690 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
106a0 0a 20 20 28 6c 65 74 20 28 28 68 74 74 70 2d 63 . (let ((http-c
106b0 6f 6f 6b 69 65 20 28 67 65 74 2d 65 6e 76 69 72 ookie (get-envir
106c0 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
106d0 22 48 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 "HTTP_COOKIE")))
106e0 0a 20 20 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 . ;; (err:log
106f0 20 22 68 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 "http-cookie: "
10700 20 68 74 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 http-cookie).
10710 20 20 28 69 66 20 68 74 74 70 2d 63 6f 6f 6b 69 (if http-cooki
10720 65 0a 20 20 20 20 20 20 20 20 28 73 65 73 73 69 e. (sessi
10730 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 on:extract-key-f
10740 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 rom-param self (
10750 73 74 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 string-split-fie
10760 6c 64 73 20 20 22 3b 5c 5c 73 2b 22 20 68 74 74 lds ";\\s+" htt
10770 70 2d 63 6f 6f 6b 69 65 20 69 6e 66 69 78 3a 29 p-cookie infix:)
10780 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a "session_key").
10790 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 #f)))..(
107a0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
107b0 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
107c0 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 elf session-key)
107d0 0a 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 . (let ((query
107e0 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
107f0 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 sessions WHERE s
10800 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a ession_key=?;").
10810 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 (result
10820 23 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 #f)). ;;
10830 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 (pg:query-for-ea
10840 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ch (lambda (tupl
10850 65 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 e). ;;
10860 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10870 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
10880 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
10890 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f e 0))) ;; (vecto
108a0 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
108b0 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
108c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
108d0 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
108e0 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 session-key).
108f0 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
10900 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 (sda
10910 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
10920 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
10930 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10940 63 6f 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 conn). (dbi:f
10950 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
10960 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 bda (tuple)....(
10970 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 set! result (vec
10980 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
10990 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 )) ;; (vector-re
109a0 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 f tuple 0)))...
109b0 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 (sdat-get-c
109c0 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 20 onn self)...
109d0 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
109e0 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 ery session-key)
109f0 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a ). result))..
10a00 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 ;; delete all re
10a10 63 6f 72 64 73 20 66 6f 72 20 61 20 73 65 73 73 cords for a sess
10a20 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 ion.;; .;; NEEDS
10a30 20 54 4f 20 42 45 20 54 52 41 4e 53 41 43 54 49 TO BE TRANSACTI
10a40 4f 4e 49 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 69 ONIZED!.;;.(defi
10a50 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 ne (session:dele
10a60 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 te-session self
10a70 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 session-key). (
10a80 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 let ((session-id
10a90 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
10aa0 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
10ab0 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 ssion-key)).
10ac0 20 20 20 20 28 71 72 79 31 20 20 20 20 20 20 20 (qry1
10ad0 20 3b 3b 20 28 63 6f 6e 63 20 22 42 45 47 49 4e ;; (conc "BEGIN
10ae0 3b 22 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 ;".... "DELETE
10af0 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
10b00 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
10b10 69 64 3d 3f 3b 22 29 0a 09 28 71 72 79 32 20 20 id=?;")..(qry2
10b20 20 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 "DELE
10b30 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 TE FROM sessions
10b40 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 WHERE id=?;")..
10b50 09 20 20 20 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 . ;; "COMMI
10b60 54 3b 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 T;")). (c
10b70 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
10b80 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
10b90 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
10ba0 73 65 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 session-id.
10bb0 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
10bc0 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f (dbi:exec co
10bd0 6e 6e 20 71 72 79 31 20 73 65 73 73 69 6f 6e 2d nn qry1 session-
10be0 69 64 29 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 id) ;; session-i
10bf0 64 29 0a 09 20 20 28 64 62 69 3a 65 78 65 63 20 d).. (dbi:exec
10c00 63 6f 6e 6e 20 71 72 79 32 20 73 65 73 73 69 6f conn qry2 sessio
10c10 6e 2d 69 64 29 0a 09 20 20 28 73 65 73 73 69 6f n-id).. (sessio
10c20 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c n:initialize sel
10c30 66 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 f).. (session:s
10c40 65 74 75 70 20 73 65 6c 66 29 29 29 0a 20 20 20 etup self))).
10c50 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 (not (session:g
10c60 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
10c70 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
10c80 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
10c90 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 session:delete-s
10ca0 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 ession self sess
10cb0 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c ion-key).;; (l
10cc0 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 et ((session-id
10cd0 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 (session:get-ses
10ce0 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 sion-id self ses
10cf0 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 sion-key)).;;
10d00 20 20 20 20 20 20 28 71 75 65 72 69 65 73 20 20 (queries
10d10 20 20 28 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 (list "BEGIN;"
10d20 0a 3b 3b 20 09 09 09 20 20 22 44 45 4c 45 54 45 .;; ... "DELETE
10d30 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 FROM session_va
10d40 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e rs WHERE session
10d50 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 _id=?;".;;
10d60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10d70 20 20 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f "DELETE FRO
10d80 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 M sessions WHERE
10d90 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 id=?;".;; ...
10da0 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 "COMMIT;")).;;
10db0 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 (conn
10dc0 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
10dd0 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 get-conn self)))
10de0 0a 3b 3b 20 20 20 20 20 28 69 66 20 73 65 73 73 .;; (if sess
10df0 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 ion-id.;;
10e00 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 (begin.;;
10e10 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a (for-each.
10e20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ;; (l
10e30 61 6d 62 64 61 20 28 71 75 65 72 79 29 0a 3b 3b ambda (query).;;
10e40 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
10e50 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 bi:exec conn que
10e60 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a ry session-id)).
10e70 3b 3b 20 09 20 20 20 71 75 65 72 69 65 73 29 0a ;; . queries).
10e80 3b 3b 20 09 20 20 28 69 6e 69 74 69 61 6c 69 7a ;; . (initializ
10e90 65 20 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 e self '()).;; .
10ea0 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
10eb0 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 self))).;;
10ec0 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 (not (session:ge
10ed0 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
10ee0 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 f session-key)))
10ef0 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
10f00 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 ion:extract-key
10f10 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 self key). (let
10f20 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d ((params (sdat-
10f30 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 get-params self)
10f40 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
10f50 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
10f60 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 -param self para
10f70 6d 73 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 ms key)))..(defi
10f80 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 ne (session:extr
10f90 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 act-key-from-par
10fa0 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b am self params k
10fb0 65 79 29 0a 20 20 28 6c 65 74 20 28 28 72 31 20 ey). (let ((r1
10fc0 20 20 20 20 28 72 65 67 65 78 70 20 28 73 74 72 (regexp (str
10fd0 69 6e 67 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b ing-append "^" k
10fe0 65 79 20 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 ey "=([^=]+)$"))
10ff0 29 29 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 )). (err:log
11000 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 "INFO: Looking f
11010 6f 72 20 22 20 6b 65 79 20 22 20 69 6e 20 22 20 or " key " in "
11020 70 61 72 61 6d 73 29 0a 20 20 20 20 28 69 66 20 params). (if
11030 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d (< (length param
11040 73 29 20 31 29 20 23 66 0a 09 28 6c 65 74 20 6c s) 1) #f..(let l
11050 6f 6f 70 20 28 28 68 65 61 64 20 20 20 28 63 61 oop ((head (ca
11060 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 r params))...
11070 28 74 61 69 6c 20 20 20 28 63 64 72 20 70 61 72 (tail (cdr par
11080 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 74 20 28 ams))).. (let (
11090 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
110a0 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 0a atch r1 head))).
110b0 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 . (cond..
110c0 20 28 6d 61 74 63 68 0a 09 20 20 20 20 20 20 28 (match.. (
110d0 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 let ((session-ke
110e0 79 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 y (list-ref matc
110f0 68 20 31 29 29 29 0a 09 09 28 65 72 72 3a 6c 6f h 1)))...(err:lo
11100 67 20 22 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 g "INFO: Found s
11110 65 73 73 69 6f 6e 20 6b 65 79 3d 22 20 73 65 73 ession key=" ses
11120 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 28 73 64 61 sion-key)...(sda
11130 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
11140 79 21 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 y! self (list-re
11150 66 20 6d 61 74 63 68 20 31 29 29 0a 09 09 73 65 f match 1))...se
11160 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 ssion-key))..
11170 20 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a ((null? tail).
11180 09 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 . #f)..
11190 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 6c (else.. (l
111a0 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 0a 09 oop (car tail)..
111b0 09 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 29 . (cdr tail))
111c0 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
111d0 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 (session:set-pa
111e0 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 ge! self page_na
111f0 6d 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d me). (sdat-set-
11200 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f page! self page_
11210 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 name))..(define
11220 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 (session:close s
11230 65 6c 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 elf). (dbi:clos
11240 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e e (sdat-get-conn
11250 20 73 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f self))).;; (clo
11260 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 se-output-port (
11270 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 sdat-get-logpt s
11280 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 elf))..(define (
11290 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 session:err-msg
112a0 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 73 self msg). (has
112b0 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 h-table-set! (sd
112c0 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
112d0 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f rs self) "ERROR_
112e0 4d 53 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e MSG"... (strin
112f0 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
11300 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ap s:any->string
11310 20 6d 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 msg) " ")))..(d
11320 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
11330 72 65 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 rev-err self).
11340 28 6c 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 (let ((prev-err
11350 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
11360 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
11370 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
11380 66 6f 72 65 20 73 65 6c 66 29 20 22 45 52 52 4f fore self) "ERRO
11390 52 5f 4d 53 47 22 20 23 66 29 29 0a 09 28 63 75 R_MSG" #f))..(cu
113a0 72 72 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 rr-err (hash-tab
113b0 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
113c0 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
113d0 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f vars self) "ERRO
113e0 52 5f 4d 53 47 22 20 23 66 29 29 29 0a 20 20 20 R_MSG" #f))).
113f0 20 28 69 66 20 70 72 65 76 2d 65 72 72 20 70 72 (if prev-err pr
11400 65 76 2d 65 72 72 0a 09 28 69 66 20 63 75 72 72 ev-err..(if curr
11410 2d 65 72 72 20 63 75 72 72 2d 65 72 72 20 23 66 -err curr-err #f
11420 29 29 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e ))))..;; session
11430 20 76 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 vars.;; 1. keys
11440 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 are always a st
11450 72 69 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f ring NOT a symbo
11460 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 l.;; 2. values a
11470 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 re always a stri
11480 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 ng conversion is
11490 20 74 68 65 20 72 65 73 70 6f 6e 73 69 62 69 6c the responsibil
114a0 69 74 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 ity of the .;;
114b0 20 20 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 consuming func
114c0 74 69 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 66 tion (at least f
114d0 6f 72 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 or now, I'd like
114e0 20 74 6f 20 63 68 61 6e 67 65 20 74 68 69 73 29 to change this)
114f0 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 ..;; set a sessi
11500 6f 6e 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 on var for the c
11510 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
11520 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
11530 63 75 72 72 2d 70 61 67 65 2d 73 65 74 21 20 73 curr-page-set! s
11540 65 6c 66 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 elf key value).
11550 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
11560 21 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ! (sdat-get-page
11570 76 61 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e vars self) (s:an
11580 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 y->string key) (
11590 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
115a0 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 lue)))..;; del a
115b0 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 var for the cur
115c0 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
115d0 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 fine (session:pa
115e0 67 65 2d 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 ge-var-del! self
115f0 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 key). (hash-ta
11600 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 73 64 61 ble-delete! (sda
11610 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 t-get-pagevars s
11620 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 elf) (s:any->str
11630 69 6e 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 ing key)))..;; g
11640 65 74 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 et the appropria
11650 74 65 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 te hash given a
11660 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 page "*sessionva
11670 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 rs*, *globalvars
11680 2a 20 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 * or page.;;.(de
11690 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
116a0 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 t-page-hash self
116b0 20 70 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 page). (if (st
116c0 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 ring=? page "*se
116d0 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 ssionvars*").
116e0 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 (sdat-get-ses
116f0 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 sionvars self).
11700 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
11710 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c =? page "*global
11720 76 61 72 73 2a 22 29 0a 09 20 20 28 73 64 61 74 vars*").. (sdat
11730 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 -get-globalvars
11740 73 65 6c 66 29 0a 09 20 20 28 73 64 61 74 2d 67 self).. (sdat-g
11750 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
11760 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 ))))..;; set a s
11770 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
11780 20 67 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 given page.;;.(
11790 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
117a0 73 65 74 21 20 73 65 6c 66 20 70 61 67 65 20 6b set! self page k
117b0 65 79 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 ey value). (let
117c0 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 ((ht (session:g
117d0 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
117e0 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 f page))). (h
117f0 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
11800 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 t (s:any->string
11810 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 key) (s:any->st
11820 72 69 6e 67 20 76 61 6c 75 65 29 29 29 29 0a 0a ring value))))..
11830 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 ;; get session v
11840 61 72 73 20 66 6f 72 20 74 68 65 20 63 75 72 72 ars for the curr
11850 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ent page.;;.(def
11860 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 ine (session:pag
11870 65 2d 67 65 74 20 73 65 6c 66 20 6b 65 79 29 0a e-get self key).
11880 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
11890 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d f/default (sdat-
118a0 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
118b0 66 29 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 f) key #f))..;;
118c0 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 get session vars
118d0 20 66 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 for a specified
118e0 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
118f0 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 (session:get se
11900 6c 66 20 70 61 67 65 20 6b 65 79 20 70 61 72 61 lf page key para
11910 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 ms). (let* ((ht
11920 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
11930 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
11940 67 65 29 29 0a 09 20 28 72 65 73 20 28 68 61 73 ge)).. (res (has
11950 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
11960 75 6c 74 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 ult ht (s:any->s
11970 74 72 69 6e 67 20 6b 65 79 29 20 23 66 29 29 29 tring key) #f)))
11980 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 . (session:ap
11990 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 ply-type-prefere
119a0 6e 63 65 20 72 65 73 20 70 61 72 61 6d 73 29 29 nce res params))
119b0 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 )..;; delete a s
119c0 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
119d0 20 73 70 65 63 69 66 69 65 64 20 70 61 67 65 0a specified page.
119e0 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
119f0 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 ion:del! self pa
11a00 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ge key). (let (
11a10 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
11a20 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
11a30 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
11a40 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
11a50 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e ht (s:any->strin
11a60 67 20 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 g key))))..;; ge
11a70 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 t ALL keys for t
11a80 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f his page and sto
11a90 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f re in the sessio
11aa0 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 68 0a n pagevars hash.
11ab0 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
11ac0 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c ion:get-vars sel
11ad0 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
11ae0 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
11af0 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
11b00 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
11b10 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
11b20 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
11b30 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
11b40 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
11b50 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
11b60 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 s")..(let* ((res
11b70 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ult
11b80 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e #f).. (con
11b90 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n
11ba0 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
11bb0 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
11bc0 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 agevars-before
11bd0 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
11be0 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
11bf0 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 )).. (sess
11c00 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 28 ionvars-before (
11c10 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
11c20 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
11c30 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
11c40 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 alvars-before (
11c50 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
11c60 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
11c70 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 76 ).. (pagev
11c80 61 72 73 20 20 20 20 20 20 20 20 20 20 20 28 73 ars (s
11c90 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
11ca0 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
11cb0 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 (sessionvars
11cc0 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
11cd0 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 ssionvars self))
11ce0 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c .. (global
11cf0 76 61 72 73 20 20 20 20 20 20 20 20 20 28 73 64 vars (sd
11d00 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
11d10 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
11d20 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 (page-name
11d30 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
11d40 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 age self))..
11d50 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 (session-key
11d60 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
11d70 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
11d80 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 75 65 f)).. (que
11d90 72 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ry
11da0 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 (string-append..
11db0 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 20 6b ... "SELECT k
11dc0 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 ey,value FROM se
11dd0 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 ssion_vars INNER
11de0 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f JOIN sessions O
11df0 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 N session_vars.s
11e00 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f ession_id=sessio
11e10 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 20 20 ns.id ".....
11e20 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b "WHERE session_k
11e30 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b ey=? AND page=?;
11e40 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 "))).. ;; first
11e50 20 74 68 65 20 70 61 67 65 20 73 70 65 63 69 66 the page specif
11e60 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
11e70 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
11e80 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
11e90 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
11ea0 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
11eb0 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
11ec0 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
11ed0 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
11ee0 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 -table-set! page
11ef0 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
11f00 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
11f10 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 20 20 -set! pagevars
11f20 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 k v)))....
11f30 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 conn....
11f40 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
11f50 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 y session-key pa
11f60 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 ge-name)).. ;;
11f70 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 6f 6e then the session
11f80 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
11f90 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
11fa0 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
11fb0 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
11fc0 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
11fd0 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
11fe0 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
11ff0 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
12000 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
12010 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 t! sessionvars-b
12020 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
12030 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
12040 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
12050 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
12060 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
12070 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
12080 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 ession-key "*ses
12090 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 sionvars*"))..
120a0 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 ;; and finally t
120b0 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 he global vars..
120c0 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
120d0 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
120e0 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
120f0 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
12100 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
12110 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
12120 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
12130 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
12140 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 t! globalvars-be
12150 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
12160 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
12170 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 lobalvars
12180 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 k v))).... c
12190 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 onn.... (s:sq
121a0 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
121b0 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 sion-key "*globa
121c0 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 29 29 lvars")).. ))))
121d0 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
121e0 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 6c on:save-vars sel
121f0 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
12200 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
12210 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
12220 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
12230 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
12240 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
12250 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
12260 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
12270 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
12280 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 s")..(let* ((sta
12290 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 tus #f)..
122a0 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
122b0 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
122c0 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
122d0 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 (page-name (sd
122e0 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
122f0 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c 2d )).. (del-
12300 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 45 20 query "DELETE
12310 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
12320 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
12330 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 id=? AND page=?
12340 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 AND key=?;")..
12350 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 79 20 (ins-query
12360 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 "INSERT INTO s
12370 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 ession_vars (ses
12380 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 sion_id,page,key
12390 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 28 3f ,value) VALUES(?
123a0 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 ,?,?,?);")..
123b0 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 20 20 (upd-query
123c0 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 5f "UPDATE session_
123d0 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 3d 3f vars set value=?
123e0 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 WHERE key=? AND
123f0 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
12400 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 D page=?;")..
12410 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 (changed-cou
12420 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 nt 0)).. ;; sav
12430 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 e the delta only
12440 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
12450 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 29 (lambda (page)
12460 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 2a 67 ;; page is: "*g
12470 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 lobalvars*" "*se
12480 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f ssionvars*" or o
12490 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 20 20 therstring..
124a0 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 65 2d (let* ((before-
124b0 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 after-ht (cond..
124c0 09 09 09 20 20 20 20 20 20 28 28 73 74 72 69 6e ... ((strin
124d0 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
124e0 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 20 20 onvars*").....
124f0 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 73 64 (vector (sd
12500 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
12510 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 20 20 rs self)......
12520 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 (sdat-get-s
12530 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
12540 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 e self))).....
12550 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
12560 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
12570 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 74 6f s*")......(vecto
12580 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 r (sdat-get-glob
12590 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 alvars self)....
125a0 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f ...(sdat-get-glo
125b0 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 balvars-before s
125c0 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
125d0 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 28 76 (else ......(v
125e0 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d ector (sdat-get-
125f0 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 0a 09 pagevars self)..
12600 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 70 .....(sdat-get-p
12610 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 agevars-before s
12620 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 20 28 elf)))))... (
12630 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 65 63 master-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 30 29 29 0a 09 09 20 20 fter-ht 0))...
12660 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 20 28 (before-ht (
12670 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 vector-ref befor
12680 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 0a 09 e-after-ht 1))..
12690 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 . (master-key
126a0 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
126b0 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 ys master-ht))..
126c0 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 . (before-key
126d0 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
126e0 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 ys before-ht))..
126f0 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 . (all-keys (
12700 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
12710 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 72 s (append master
12720 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 -keys before-key
12730 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 66 s)))).. (f
12740 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 or-each ...(lamb
12750 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 da (key)... (le
12760 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 t ((master-value
12770 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
12780 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 2d /default master-
12790 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 28 ht key #f))....(
127a0 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 before-value (ha
127b0 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
127c0 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 6b ault before-ht k
127d0 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 28 ey #f)))... (
127e0 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 cond... ;; b
127f0 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
12800 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 20 exist and value
12810 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e unchanged - do n
12820 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 28 othing... ((
12830 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 and master-value
12840 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 before-value (e
12850 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c qual? master-val
12860 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 ue before-value)
12870 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 ))... ;; bef
12880 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 ore and after ex
12890 69 73 74 20 62 75 74 20 61 72 65 20 63 68 61 6e ist but are chan
128a0 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ged... ((and
128b0 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
128c0 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 fore-value)...
128d0 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
128e0 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
128f0 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
12900 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
12910 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
12920 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
12930 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
12940 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 74 m upd-query mast
12950 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 73 er-value key ses
12960 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 0a sion-id page))).
12970 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 .. ;; master
12980 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 -value no longer
12990 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 66 exists (i.e. #f
129a0 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a ) - remove item.
129b0 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 .. ((not mas
129c0 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 ter-value)...
129d0 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
129e0 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
129f0 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 ple)...... (set
12a00 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 ! changed-count
12a10 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 (+ changed-count
12a20 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 1)))......conn.
12a30 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d .....(s:sqlparam
12a40 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 del-query sessi
12a50 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 29 on-id page key))
12a60 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f )... ;; befo
12a70 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 re-value doesn't
12a80 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 20 exist - insert
12a90 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 20 a new value...
12aa0 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d ((not before-
12ab0 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 value)... (
12ac0 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
12ad0 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
12ae0 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 ...... (set! ch
12af0 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 anged-count (+ c
12b00 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 hanged-count 1))
12b10 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 )......conn.....
12b20 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 .(s:sqlparam ins
12b30 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
12b40 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 65 d page key maste
12b50 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 r-value)))...
12b60 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 (else (err:log
12b70 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 "Shouldn't get
12b80 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c 6c here")))))...all
12b90 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 -keys))) ;; proc
12ba0 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 ess all keys..
12bb0 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f 6e (list "*session
12bc0 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 vars*" "*globalv
12bd0 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 ars*" page-name)
12be0 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 )))))..;; (pg:sq
12bf0 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 l-null-object? e
12c00 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 lement).(define
12c10 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f (session:read-co
12c20 6e 66 69 67 20 73 65 6c 66 29 0a 20 20 28 6c 65 nfig self). (le
12c30 74 2a 20 28 28 63 67 69 2d 70 61 74 68 20 28 70 t* ((cgi-path (p
12c40 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
12c50 79 20 28 63 61 72 20 28 61 72 67 76 29 29 29 29 y (car (argv))))
12c60 0a 20 20 20 20 20 20 20 20 20 28 6e 61 6d 65 20 . (name
12c70 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 (string-appe
12c80 6e 64 20 28 69 66 20 63 67 69 2d 70 61 74 68 20 nd (if cgi-path
12c90 28 63 6f 6e 63 20 63 67 69 2d 70 61 74 68 20 22 (conc cgi-path "
12ca0 2f 22 29 20 22 22 29 20 22 2e 22 20 28 70 61 74 /") "") "." (pat
12cb0 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 hname-file (car
12cc0 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 (argv))) ".confi
12cd0 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e g"))). (if (n
12ce0 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ot (file-exists?
12cf0 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e 74 20 name))..(print
12d00 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 name " not found
12d10 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 2d 64 at " (current-d
12d20 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c 65 74 irectory))..(let
12d30 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 6e 70 * ((fp (open-inp
12d40 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 0a 09 ut-file name))..
12d50 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 67 73 (initargs
12d60 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 20 20 (read fp)))..
12d70 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
12d80 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 72 67 t fp).. initarg
12d90 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 74 s))))..;; call t
12da0 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 66 he controller if
12db0 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 0a 3b it exists.;; .;
12dc0 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 69 73 ; WARNING - this
12dd0 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 64 65 code needs a de
12de0 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 65 63 fence agains rec
12df0 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 21 21 ursive calling!!
12e00 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 75 !!!.;;.;; I su
12e10 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 6f 66 ggest a limit of
12e20 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c 65 6e 100 calls. Plen
12e30 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 20 ty for allowing
12e40 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 6e 63 multiple instanc
12e50 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 61 67 es.;; of a pag
12e60 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 65 72 e inside another
12e70 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 61 page. .;;.;; pa
12e80 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 27 63 rts = 'both | 'c
12e90 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 0a 3b ontrol | 'view.;
12ea0 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c 65 ;..(define (file
12eb0 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 2e s-read->string .
12ec0 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 69 6e files). (strin
12ed0 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 g-intersperse .
12ee0 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 (apply append
12ef0 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 2d 3e (map file-read->
12f00 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 20 22 string files)) "
12f10 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 \n"))..(define (
12f20 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 6e file-read->strin
12f30 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 28 70 g f) . (let ((p
12f40 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c (open-input-fil
12f50 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 74 20 e f))). (let
12f60 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 61 64 loop ((hed (read
12f70 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 20 20 -line p))..
12f80 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 (res '())).
12f90 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
12fa0 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 73 0a ct? hed).. res.
12fb0 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c . (loop (read-l
12fc0 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 72 65 ine p)(append re
12fd0 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 29 s (list hed)))))
12fe0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f ))..(define (pro
12ff0 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 20 28 cess-port p). (
13000 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 61 63 let ((e (interac
13010 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 tion-environment
13020 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a 20 20 ))). (map .
13030 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 (lambda (x).
13040 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 28 6c (cond..((l
13050 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 73 74 ist? x) x)..((st
13060 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 65 6c ring? x) x)..(el
13070 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 28 se '()))). (
13080 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 64 61 port-map (lambda
13090 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 73 20 (s)... (eval s
130a0 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d e)).. (lam
130b0 62 64 61 20 28 29 28 72 65 61 64 20 70 29 29 29 bda ()(read p)))
130c0 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
130d0 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 69 ssion:process-fi
130e0 6c 65 20 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 le f). (let* ((
130f0 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 p (open-input
13100 2d 66 69 6c 65 20 66 29 29 0a 09 20 28 64 61 74 -file f)).. (dat
13110 20 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 20 (process-port
13120 70 29 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d p))). (close-
13130 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 20 20 input-port p).
13140 20 20 64 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 20 dat))..;; May
13150 32 30 31 31 2c 20 70 75 74 74 69 6e 67 20 61 6c 2011, putting al
13160 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e 65 l pages into one
13170 20 64 69 72 65 63 74 6f 72 79 20 66 6f 72 20 74 directory for t
13180 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 61 he following rea
13190 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 61 sons:.;; 1. wa
131a0 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 72 nt filename to r
131b0 65 66 6c 65 63 74 20 70 61 67 65 20 6e 61 6d 65 eflect page name
131c0 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 69 (emacs limitati
131d0 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 74 on).;; 2. that
131e0 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 20 's it! no other
131f0 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d 61 reason. could ma
13200 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 72 61 62 ke it configurab
13210 6c 65 20 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d 64 le ....;; page-d
13220 69 72 2d 73 74 79 6c 65 20 69 73 3a 0a 3b 3b 20 ir-style is:.;;
13230 20 27 73 74 6f 72 65 64 20 20 20 3d 3e 20 73 74 'stored => st
13240 6f 72 65 64 20 69 6e 20 65 78 65 63 75 74 61 62 ored in executab
13250 6c 65 0a 3b 3b 20 20 27 66 6c 61 74 20 20 20 20 le.;; 'flat
13260 20 3d 3e 20 70 61 67 65 73 20 66 6c 61 74 20 64 => pages flat d
13270 69 72 65 63 74 6f 72 79 0a 3b 3b 20 20 27 64 69 irectory.;; 'di
13280 72 20 20 20 20 20 20 3d 3e 20 64 69 72 65 63 74 r => direct
13290 6f 72 79 20 74 72 65 65 20 70 61 67 65 73 2f 3c ory tree pages/<
132a0 70 61 67 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 2c pagename>/{view,
132b0 63 6f 6e 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b 20 control}.scm.;;
132c0 70 61 72 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 68 parts:.;; 'both
132d0 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e => load con
132e0 74 72 6f 6c 20 61 6e 64 20 76 69 65 77 20 28 61 trol and view (a
132f0 6e 79 74 68 69 6e 67 20 6f 74 68 65 72 20 74 68 nything other th
13300 61 6e 20 76 69 65 77 20 6f 72 20 63 6f 6e 74 72 an view or contr
13310 6f 6c 20 61 6e 64 20 74 68 65 20 64 65 66 61 75 ol and the defau
13320 6c 74 29 0a 3b 3b 20 20 27 76 69 65 77 20 20 20 lt).;; 'view
13330 20 20 3d 3e 20 6c 6f 61 64 20 76 69 65 77 20 6f => load view o
13340 6e 6c 79 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f 6c nly.;; 'control
13350 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 6f => load contro
13360 6c 20 6f 6e 6c 79 0a 28 64 65 66 69 6e 65 20 28 l only.(define (
13370 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 72 session:call-par
13380 74 73 20 73 65 6c 66 20 70 61 67 65 20 23 21 6b ts self page #!k
13390 65 79 20 28 70 61 72 74 73 20 27 62 6f 74 68 29 ey (parts 'both)
133a0 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 ). (sdat-set-cu
133b0 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 61 rr-page! self pa
133c0 67 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 ge). (let* ((di
133d0 72 2d 73 74 79 6c 65 20 20 20 20 28 73 64 61 74 r-style (sdat
133e0 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -get-page-dir-st
133f0 79 6c 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 71 yle self));; (eq
13400 75 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 ual? (sdat-get-p
13410 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 65 age-dir-style se
13420 6c 66 29 20 22 6f 6e 65 64 69 72 22 29 29 20 3b lf) "onedir")) ;
13430 3b 20 66 6c 61 67 20 23 74 20 66 6f 72 20 6f 6e ; flag #t for on
13440 65 64 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c 64 edir, #f for old
13450 20 73 74 79 6c 65 0a 09 20 28 64 69 72 20 20 20 style.. (dir
13460 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
13470 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
13480 73 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 09 sroot self) ....
13490 09 20 20 20 20 20 20 28 69 66 20 64 69 72 2d 73 . (if dir-s
134a0 74 79 6c 65 20 0a 09 09 09 09 09 20 20 28 63 6f tyle ...... (co
134b0 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 09 nc "/pages/")...
134c0 09 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 67 ... (conc "/pag
134d0 65 73 2f 22 20 70 61 67 65 29 29 29 29 29 0a 20 es/" page))))).
134e0 20 20 20 28 63 61 73 65 20 64 69 72 2d 73 74 79 (case dir-sty
134f0 6c 65 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f le. ;; NB//
13500 20 53 74 6f 72 65 64 20 61 6c 77 61 79 73 20 6c Stored always l
13510 6f 61 64 73 20 62 6f 74 68 20 63 6f 6e 74 72 6f oads both contro
13520 6c 20 61 6e 64 20 76 69 65 77 0a 20 20 20 20 20 l and view.
13530 20 28 28 73 74 6f 72 65 64 29 0a 20 20 20 20 20 ((stored).
13540 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 ((eval (string
13550 2d 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 ->symbol (conc "
13560 70 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 pages:" page)))
13570 0a 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 ..self
13580 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
13590 3b 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 28 ; the session..(
135a0 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 sdat-get-conn se
135b0 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 74 lf) ;; t
135c0 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f 6e he db connection
135d0 0a 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 72 ..(sdat-get-shar
135e0 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 3b ed-hash self) ;
135f0 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 68 20 ; a shared hash
13600 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 6e table for passin
13610 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 70 g data to/from p
13620 61 67 65 20 63 61 6c 6c 73 0a 09 29 29 0a 20 20 age calls..)).
13630 20 20 20 20 28 28 66 6c 61 74 29 20 20 20 0a 20 ((flat) .
13640 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f (let* ((so
13650 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 64 69 72 -file (conc dir
13660 20 70 61 67 65 20 22 2e 73 6f 22 29 29 0a 09 20 page ".so"))..
13670 20 20 20 20 20 28 73 63 6d 2d 66 69 6c 65 20 28 (scm-file (
13680 63 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 2e conc dir page ".
13690 73 63 6d 22 29 29 0a 09 20 20 20 20 20 20 28 73 scm")).. (s
136a0 72 63 2d 66 69 6c 65 20 28 6f 72 20 28 66 69 6c rc-file (or (fil
136b0 65 2d 65 78 69 73 74 73 3f 20 73 6f 2d 66 69 6c e-exists? so-fil
136c0 65 29 0a 09 09 09 20 20 20 20 28 66 69 6c 65 2d e).... (file-
136d0 65 78 69 73 74 73 3f 20 73 63 6d 2d 66 69 6c 65 exists? scm-file
136e0 29 29 29 29 0a 09 20 28 69 66 20 73 72 63 2d 66 )))).. (if src-f
136f0 69 6c 65 0a 09 20 20 20 20 20 28 62 65 67 69 6e ile.. (begin
13700 0a 09 20 20 20 20 20 20 20 28 6c 6f 61 64 20 73 .. (load s
13710 72 63 2d 66 69 6c 65 29 0a 09 20 20 20 20 20 20 rc-file)..
13720 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d ((eval (string-
13730 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 70 >symbol (conc "p
13740 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 0a ages:" page))) .
13750 09 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 20 ..self
13760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
13770 3b 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 09 ; the session...
13780 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
13790 65 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 elf) ;;
137a0 74 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f the db connectio
137b0 6e 0a 09 09 28 73 64 61 74 2d 67 65 74 2d 73 68 n...(sdat-get-sh
137c0 61 72 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 ared-hash self)
137d0 20 3b 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 ;; a shared has
137e0 68 20 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 h table for pass
137f0 69 6e 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d ing data to/from
13800 20 70 61 67 65 20 63 61 6c 6c 73 0a 09 09 29 29 page calls...))
13810 0a 09 20 20 20 20 20 28 6c 69 73 74 20 22 3c 70 .. (list "<p
13820 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 20 >Page not found
13830 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 29 " page " </p>"))
13840 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 72 )). ;; fir
13850 73 74 20 74 68 65 20 63 6f 6e 74 72 6f 6c 0a 20 st the control.
13860 20 20 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 ;; (let ((
13870 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 20 28 63 6f control-file (co
13880 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 nc "pages/" page
13890 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 29 0a 20 "_ctrl.scm")).
138a0 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 ;; (
138b0 76 69 65 77 2d 66 69 6c 65 20 20 20 20 28 63 6f view-file (co
138c0 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 65 nc "pages/" page
138d0 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 29 29 0a "_view.scm"))).
138e0 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 20 ;; (if
138f0 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
13900 73 3f 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 29 s? control-file)
13910 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 20 28 . ;; . (
13920 6e 6f 74 20 28 65 71 3f 20 70 61 72 74 73 20 27 not (eq? parts '
13930 76 69 65 77 29 29 29 0a 20 20 20 20 20 20 20 3b view))). ;
13940 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ; (begin.
13950 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
13960 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 61 (session:set-ca
13970 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 29 lled! self page)
13980 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
13990 20 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f 6c (load control
139a0 2d 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 -file))).
139b0 3b 3b 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 ;; (if (file-e
139c0 78 69 73 74 73 3f 20 76 69 65 77 2d 66 69 6c 65 xists? view-file
139d0 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ). ;;
139e0 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
139f0 70 61 72 74 73 20 27 63 6f 6e 74 72 6f 6c 29 29 parts 'control))
13a00 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 28 73 . ;; . (s
13a10 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 ession:process-f
13a20 69 6c 65 20 76 69 65 77 2d 66 69 6c 65 29 29 0a ile view-file)).
13a30 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
13a40 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 6e (list "<p>Page n
13a50 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 20 ot found " page
13a60 22 20 3c 2f 70 3e 22 29 29 29 0a 20 20 20 20 20 " </p>"))).
13a70 20 28 28 64 69 72 29 20 22 45 52 52 4f 52 3a 20 ((dir) "ERROR:
13a80 20 64 69 72 20 73 74 79 6c 65 20 6e 6f 74 20 79 dir style not y
13a90 65 74 20 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 65 et re-implemente
13aa0 64 22 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a d"). (else.
13ab0 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 45 52 (list "ER
13ac0 52 4f 52 3a 20 70 61 67 65 2d 64 69 72 2d 73 74 ROR: page-dir-st
13ad0 79 6c 65 20 6d 75 73 74 20 62 65 20 73 74 6f 72 yle must be stor
13ae0 65 64 2c 20 64 69 72 20 6f 72 20 66 6c 61 74 2c ed, dir or flat,
13af0 20 67 6f 74 20 22 20 64 69 72 2d 73 74 79 6c 65 got " dir-style
13b00 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
13b10 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 6c session:call sel
13b20 66 20 70 61 67 65 20 70 61 72 74 73 29 0a 20 20 f page parts).
13b30 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
13b40 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 62 rts self page 'b
13b50 6f 74 68 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e oth))..;; (defin
13b60 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 2d e (session:load-
13b70 6d 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 6c model self model
13b80 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6d 6f ).;; (let ((mo
13b90 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 2d del.scm (string-
13ba0 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 append (sdat-get
13bb0 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d -sroot self) "/m
13bc0 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e odels/" model ".
13bd0 73 63 6d 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 65 scm")).;; .(mode
13be0 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 70 l.so (string-ap
13bf0 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 73 pend (sdat-get-s
13c00 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 root self) "/mod
13c10 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 6f els/" model ".so
13c20 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 "))).;; (if
13c30 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 6f (file-exists? mo
13c40 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f 61 del.so).;; .(loa
13c50 64 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 d model.so).;; .
13c60 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
13c70 3f 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b 20 ? model.scm).;;
13c80 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 6c . (load model
13c90 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 73 .scm).;; . (s
13ca0 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f 64 :log "ERROR: mod
13cb0 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 22 el " model.scm "
13cc0 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 29 not found")))))
13cd0 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ..;; (define (se
13ce0 73 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 68 ssion:model-path
13cf0 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b 20 self model).;;
13d00 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
13d10 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f 74 (sdat-get-sroot
13d20 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 2f self) "/models/
13d30 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 29 " model ".scm"))
13d40 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
13d50 6f 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 65 on:pp-formdat se
13d60 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 lf). (let ((dat
13d70 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 (formdat:all->s
13d80 74 72 69 6e 67 73 20 28 73 64 61 74 2d 67 65 74 trings (sdat-get
13d90 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 29 -formdat self)))
13da0 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e ). (string-in
13db0 74 65 72 73 70 65 72 73 65 20 64 61 74 20 22 3c tersperse dat "<
13dc0 62 72 3e 20 22 29 29 29 0a 0a 28 64 65 66 69 6e br> ")))..(defin
13dd0 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 6d e (session:param
13de0 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 29 ->string params)
13df0 0a 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 22 . ;; (err:log "
13e00 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 params=" params)
13e10 0a 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 . (if (< (lengt
13e20 68 20 70 61 72 61 6d 73 29 20 31 29 0a 20 20 20 h params) 1).
13e30 20 20 20 22 22 0a 20 20 20 20 20 20 28 6c 65 74 "". (let
13e40 20 6c 6f 6f 70 20 28 28 6b 65 79 20 28 63 61 72 loop ((key (car
13e50 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 76 61 params))... (va
13e60 6c 20 28 63 61 64 72 20 70 61 72 61 6d 73 29 29 l (cadr params))
13e70 0a 09 09 20 28 74 61 69 6c 20 28 63 64 64 72 20 ... (tail (cddr
13e80 70 61 72 61 6d 73 29 29 0a 09 09 20 28 72 65 73 params))... (res
13e90 75 6c 74 20 27 28 29 29 29 0a 09 28 6c 65 74 20 ult '()))..(let
13ea0 28 28 6e 65 77 72 65 73 75 6c 74 20 28 63 6f 6e ((newresult (con
13eb0 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 s (string-append
13ec0 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 (s:any->string
13ed0 6b 65 79 29 20 22 3d 22 20 28 73 3a 61 6e 79 2d key) "=" (s:any-
13ee0 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 >string val))...
13ef0 09 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 . result))
13f00 29 0a 09 20 20 28 69 66 20 28 3c 20 28 6c 65 6e ).. (if (< (len
13f10 67 74 68 20 74 61 69 6c 29 20 31 29 20 3b 3b 20 gth tail) 1) ;;
13f20 74 72 75 65 20 69 66 20 64 6f 6e 65 0a 09 20 20 true if done..
13f30 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
13f40 72 73 70 65 72 73 65 20 6e 65 77 72 65 73 75 6c rsperse newresul
13f50 74 20 22 26 22 29 0a 09 20 20 20 20 20 20 28 6c t "&").. (l
13f60 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 oop (car tail)(c
13f70 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 20 74 adr tail)(cddr t
13f80 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 29 ail) newresult))
13f90 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
13fa0 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 ession:link-to s
13fb0 65 6c 66 20 70 61 67 65 20 70 61 72 61 6d 73 29 elf page params)
13fc0 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 74 70 73 . (let* ((https
13fd0 2d 68 6f 73 74 20 20 20 28 67 65 74 2d 65 6e 76 -host (get-env
13fe0 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
13ff0 65 20 22 48 54 54 50 53 5f 48 4f 53 54 22 29 29 e "HTTPS_HOST"))
14000 0a 20 20 20 20 20 20 20 20 20 28 66 6f 72 63 65 . (force
14010 2d 73 73 6c 20 20 20 20 28 73 64 61 74 2d 67 65 -ssl (sdat-ge
14020 74 2d 66 6f 72 63 65 2d 73 73 6c 20 73 65 6c 66 t-force-ssl self
14030 29 29 0a 09 20 28 73 65 72 76 65 72 20 20 20 20 )).. (server
14040 20 20 20 28 6f 72 20 68 74 74 70 73 2d 68 6f 73 (or https-hos
14050 74 20 3b 3b 20 41 73 73 75 6d 69 6e 67 20 48 54 t ;; Assuming HT
14060 54 50 53 5f 48 4f 53 54 20 69 73 20 6f 6e 6c 79 TPS_HOST is only
14070 20 73 65 74 20 69 66 20 61 76 61 69 6c 61 62 6c set if availabl
14080 65 0a 09 09 09 20 20 20 28 67 65 74 2d 65 6e 76 e.... (get-env
14090 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
140a0 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a 09 e "HTTP_HOST")..
140b0 09 09 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f .. (get-enviro
140c0 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
140d0 53 45 52 56 45 52 5f 4e 41 4d 45 22 29 0a 09 09 SERVER_NAME")...
140e0 09 20 20 20 28 73 64 61 74 2d 67 65 74 2d 64 6f . (sdat-get-do
140f0 6d 61 69 6e 20 73 65 6c 66 29 29 29 0a 20 20 20 main self))).
14100 20 20 20 20 20 20 28 66 6f 72 63 65 2d 73 63 72 (force-scr
14110 69 70 74 20 20 28 73 64 61 74 2d 67 65 74 2d 73 ipt (sdat-get-s
14120 63 72 69 70 74 20 73 65 6c 66 29 29 0a 09 20 28 cript self)).. (
14130 73 63 72 69 70 74 20 20 20 20 20 20 20 20 28 6f script (o
14140 72 20 66 6f 72 63 65 2d 73 63 72 69 70 74 0a 09 r force-script..
14150 09 09 20 20 20 20 28 6c 65 74 20 28 28 73 63 72 .. (let ((scr
14160 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e 67 ipt-name (string
14170 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 6e 76 69 -split (get-envi
14180 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
14190 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 20 "SCRIPT_NAME")
141a0 22 2f 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 "/")))....
141b0 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 73 (if (> (length s
141c0 63 72 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a 09 cript-name) 1)..
141d0 09 09 09 20 20 28 73 74 72 69 6e 67 2d 61 70 70 ... (string-app
141e0 65 6e 64 20 28 63 61 72 20 73 63 72 69 70 74 2d end (car script-
141f0 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 64 72 20 name) "/" (cadr
14200 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 09 script-name))...
14210 09 09 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e .. (get-environ
14220 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 ment-variable "S
14230 43 52 49 50 54 5f 4e 41 4d 45 22 29 29 29 29 29 CRIPT_NAME")))))
14240 20 3b 3b 20 62 75 69 6c 64 20 73 63 72 69 70 74 ;; build script
14250 20 6e 61 6d 65 20 66 72 6f 6d 20 66 69 72 73 74 name from first
14260 20 74 77 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 54 two elements. T
14270 68 69 73 20 69 73 20 61 20 68 61 6e 67 6f 76 65 his is a hangove
14280 72 20 66 72 6f 6d 20 62 65 66 6f 72 65 20 49 20 r from before I
14290 75 73 65 64 20 3f 20 69 6e 20 74 68 65 20 55 52 used ? in the UR
142a0 4c 2e 29 0a 20 20 20 20 20 20 20 20 20 28 73 65 L.). (se
142b0 73 73 69 6f 6e 2d 6b 65 79 20 20 20 28 73 64 61 ssion-key (sda
142c0 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
142d0 79 20 73 65 6c 66 29 29 0a 09 20 28 70 61 72 61 y self)).. (para
142e0 6d 73 74 72 20 20 20 20 20 20 28 73 65 73 73 69 mstr (sessi
142f0 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 on:param->string
14300 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 28 params))). (
14310 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
14320 20 22 73 65 72 76 65 72 3d 22 20 73 65 72 76 65 "server=" serve
14330 72 20 22 20 73 63 72 69 70 74 3d 22 20 73 63 72 r " script=" scr
14340 69 70 74 20 22 20 70 61 67 65 3d 22 20 70 61 67 ipt " page=" pag
14350 65 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 61 e). (string-a
14360 70 70 65 6e 64 20 28 69 66 20 28 6f 72 20 68 74 ppend (if (or ht
14370 74 70 73 2d 68 6f 73 74 20 66 6f 72 63 65 2d 73 tps-host force-s
14380 73 6c 29 0a 09 09 20 20 20 20 20 20 22 68 74 74 sl)... "htt
14390 70 73 3a 2f 2f 22 0a 09 09 20 20 20 20 20 20 22 ps://"... "
143a0 68 74 74 70 3a 2f 2f 22 29 0a 09 09 20 20 20 73 http://")... s
143b0 65 72 76 65 72 20 22 2f 22 20 73 63 72 69 70 74 erver "/" script
143c0 20 22 2f 22 20 70 61 67 65 20 22 3f 22 20 70 61 "/" page "?" pa
143d0 72 61 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f 73 ramstr))) ;; "/s
143e0 6e 3d 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 n=" session-key)
143f0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 ))..(define (ses
14400 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 6c sion:cgi-out sel
14410 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e f). (let* ((con
14420 74 65 6e 74 20 20 28 6c 69 73 74 20 28 73 64 61 tent (list (sda
14430 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 79 t-get-content-ty
14440 70 65 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 28 pe self))) ;; '(
14450 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 "Content-type: t
14460 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 ext/html; charse
14470 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e t=iso-8859-1\n\n
14480 22 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 ")).. (header
14490 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 73 (let ((cookie (s
144a0 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d dat-get-session-
144b0 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 09 cookie self)))..
144c0 09 20 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 65 . (if cookie
144d0 0a 09 09 09 20 28 63 6f 6e 73 20 28 73 74 72 69 .... (cons (stri
144e0 6e 67 2d 61 70 70 65 6e 64 20 22 53 65 74 2d 43 ng-append "Set-C
144f0 6f 6f 6b 69 65 3a 20 22 20 28 63 61 72 20 63 6f ookie: " (car co
14500 6f 6b 69 65 29 29 0a 09 09 09 20 20 20 20 20 20 okie))....
14510 20 63 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 6f content).... co
14520 6e 74 65 6e 74 29 29 29 0a 09 20 28 70 61 67 65 ntent))).. (page
14530 64 61 74 20 20 28 73 64 61 74 2d 67 65 74 2d 70 dat (sdat-get-p
14540 61 67 65 64 61 74 20 73 65 6c 66 29 29 29 0a 20 agedat self))).
14550 20 20 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a 20 (s:cgi-out .
14560 20 20 20 20 28 63 6f 6e 73 20 68 65 61 64 65 72 (cons header
14570 20 70 61 67 65 64 61 74 29 29 29 29 0a 0a 28 64 pagedat))))..(d
14580 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c efine (session:l
14590 6f 67 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a 20 og self . msg).
145a0 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
145b0 2d 70 6f 72 74 20 28 73 64 61 74 2d 67 65 74 2d -port (sdat-get-
145c0 6c 6f 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 3b log-port self) ;
145d0 3b 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 ; (sdat-get-logp
145e0 74 20 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 6d t self). (lam
145f0 62 64 61 20 28 29 20 0a 20 20 20 20 20 20 28 61 bda () . (a
14600 70 70 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 29 pply print msg))
14610 29 29 0a 0a 3b 3b 20 65 73 63 61 70 65 2c 20 63 ))..;; escape, c
14620 6f 6e 76 65 72 74 20 6f 72 20 72 65 74 75 72 6e onvert or return
14630 20 72 61 77 20 77 68 65 6e 20 67 69 76 65 6e 20 raw when given
14640 75 73 65 72 20 69 6e 70 75 74 20 64 61 74 61 20 user input data
14650 74 68 61 74 20 70 6f 74 65 6e 74 69 61 6c 6c 79 that potentially
14660 0a 3b 3b 20 63 6f 75 6c 64 20 62 65 20 6d 61 6c .;; could be mal
14670 69 63 69 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 6e icious.;;.(defin
14680 65 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c 79 e (session:apply
14690 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 65 -type-preference
146a0 20 72 65 73 20 70 61 72 61 6d 73 29 0a 20 20 28 res params). (
146b0 6c 65 74 2a 20 28 28 64 74 79 70 65 20 20 20 20 let* ((dtype
146c0 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
146d0 73 29 0a 09 09 20 20 20 20 20 20 20 27 65 73 63 s)... 'esc
146e0 61 70 65 64 0a 09 09 20 20 20 20 20 20 20 28 63 aped... (c
146f0 61 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 ar params))).. (
14700 74 61 67 73 20 20 20 20 28 69 66 20 28 6e 75 6c tags (if (nul
14710 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 l? params)...
14720 20 20 20 27 28 29 0a 09 09 20 20 20 20 20 20 28 '()... (
14730 63 64 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 cdr params)))).
14740 20 20 20 28 63 61 73 65 20 64 74 79 70 65 0a 20 (case dtype.
14750 20 20 20 20 20 28 28 72 61 77 29 20 20 20 20 20 ((raw)
14760 72 65 73 29 0a 20 20 20 20 20 20 28 28 6e 75 6d res). ((num
14770 62 65 72 29 20 20 28 69 66 20 28 73 74 72 69 6e ber) (if (strin
14780 67 3f 20 72 65 73 29 28 73 74 72 69 6e 67 2d 3e g? res)(string->
14790 6e 75 6d 62 65 72 20 72 65 73 29 20 23 66 29 29 number res) #f))
147a0 0a 20 20 20 20 20 20 28 28 65 73 63 61 70 65 64 . ((escaped
147b0 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 ) (if (string? r
147c0 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 74 es)... (s:ht
147d0 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e ml-filter->strin
147e0 67 20 72 65 73 20 74 61 67 73 29 0a 09 09 20 20 g res tags)...
147f0 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 28 res)). (
14800 28 65 73 63 61 70 65 64 2d 6e 6c 29 20 28 69 66 (escaped-nl) (if
14810 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 20 3b (string? res) ;
14820 3b 20 65 73 63 61 70 65 20 5c 6e 20 61 6e 64 20 ; escape \n and
14830 5c 72 0a 09 09 09 28 73 74 72 69 6e 67 2d 69 6e \r....(string-in
14840 74 65 72 73 70 65 72 73 65 0a 09 09 09 20 28 73 tersperse.... (s
14850 74 72 69 6e 67 2d 73 70 6c 69 74 0a 09 09 09 20 tring-split....
14860 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
14870 65 72 73 65 0a 09 09 09 20 20 20 28 73 74 72 69 erse.... (stri
14880 6e 67 2d 73 70 6c 69 74 20 28 73 3a 68 74 6d 6c ng-split (s:html
14890 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 -filter->string
148a0 72 65 73 20 74 61 67 73 29 20 22 5c 6e 22 29 0a res tags) "\n").
148b0 09 09 09 20 20 20 22 5c 5c 6e 22 29 0a 09 09 09 ... "\\n")....
148c0 20 20 22 5c 72 22 29 0a 09 09 09 20 22 5c 5c 72 "\r").... "\\r
148d0 22 29 0a 09 09 09 72 65 73 29 29 20 3b 3b 20 73 ")....res)) ;; s
148e0 68 6f 75 6c 64 20 72 65 74 75 72 6e 20 23 66 20 hould return #f
148f0 69 66 20 6e 6f 74 20 61 20 73 74 72 69 6e 67 20 if not a string
14900 61 6e 64 20 63 61 6e 27 74 20 65 73 63 61 70 65 and can't escape
14910 20 69 74 3f 0a 20 20 20 20 20 20 28 65 6c 73 65 it?. (else
14920 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
14930 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 g? res)... (
14940 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 s:html-filter->s
14950 74 72 69 6e 67 20 72 65 73 20 27 28 29 29 0a 09 tring res '())..
14960 09 20 20 20 20 20 72 65 73 29 29 29 29 29 0a 0a . res)))))..
14970 23 3b 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 #;(define (sessi
14980 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 6f on:get-param-fro
14990 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 m params key).
149a0 28 6c 65 74 20 28 28 72 31 20 28 72 65 67 65 78 (let ((r1 (regex
149b0 70 20 28 63 6f 6e 63 20 22 5e 22 20 28 73 3a 61 p (conc "^" (s:a
149c0 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 ny->string key)
149d0 22 3d 28 2e 2a 29 24 22 29 29 29 29 0a 20 20 20 "=(.*)$")))).
149e0 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 (if (null? para
149f0 6d 73 29 20 23 66 0a 20 20 20 20 20 20 20 20 28 ms) #f. (
14a00 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
14a10 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 (car params)).
14a20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14a30 20 28 74 61 69 6c 20 28 63 64 72 20 70 61 72 61 (tail (cdr para
14a40 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ms))).
14a50 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 (let ((match (st
14a60 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 65 ring-match r1 he
14a70 61 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ad))).
14a80 20 20 28 69 66 20 6d 61 74 63 68 0a 20 20 20 20 (if match.
14a90 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
14aa0 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 0a 20 t-ref match 1).
14ab0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
14ac0 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 if (null? tail)
14ad0 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 #f.
14ae0 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 (loop (ca
14af0 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 6c r tail)(cdr tail
14b00 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 70 61 )))))))))..;; pa
14b10 72 61 6d 73 20 61 72 65 20 73 74 6f 72 65 64 20 rams are stored
14b20 61 73 20 6c 69 73 74 20 6f 66 20 6b 65 79 3d 76 as list of key=v
14b30 61 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 al.;;.(define (s
14b40 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d ession:get-param
14b50 20 73 65 6c 66 20 6b 65 79 20 74 79 70 65 2d 70 self key type-p
14b60 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 73 65 73 arams). ;; (ses
14b70 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 69 sion:log s:sessi
14b80 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 6c on "params=" (sl
14b90 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e ot-ref s:session
14ba0 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c 65 'params)). (le
14bb0 74 2a 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 t* ((params (sda
14bc0 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c t-get-params sel
14bd0 66 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 73 f)).. (res (s
14be0 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d ession:get-param
14bf0 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 -from params key
14c00 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
14c10 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 :apply-type-pref
14c20 65 72 65 6e 63 65 20 72 65 73 20 74 79 70 65 2d erence res type-
14c30 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 68 params)))..;; Th
14c40 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 is one will get
14c50 74 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 20 the first value
14c60 66 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 73 found regardless
14c70 20 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 61 of form.;; para
14c80 6d 3a 20 28 64 74 79 70 65 20 5b 74 61 67 31 20 m: (dtype [tag1
14c90 74 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 74 tag2 ...]).;; dt
14ca0 79 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 20 ype:.;; 'raw
14cb0 20 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e 76 : do no conv
14cc0 65 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e 75 ersion.;; 'nu
14cd0 6d 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 20 mber : convert
14ce0 74 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 72 to number, retur
14cf0 6e 20 23 66 20 69 66 20 66 61 69 6c 73 0a 3b 3b n #f if fails.;;
14d00 20 20 20 20 27 65 73 63 61 70 65 64 20 3a 20 75 'escaped : u
14d10 73 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 74 se html-escape t
14d20 6f 20 70 72 6f 74 65 63 74 20 74 68 65 20 69 6e o protect the in
14d30 70 75 74 20 2d 2d 20 74 68 69 73 20 69 73 20 74 put -- this is t
14d40 68 65 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 64 he default.;;.(d
14d50 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
14d60 65 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b 65 et-input self ke
14d70 79 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 y params). (let
14d80 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 66 * ((dtype (if
14d90 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a (null? params).
14da0 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 65 .. 'escape
14db0 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 20 d... (car
14dc0 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 67 params))).. (tag
14dd0 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s (if (null?
14de0 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 20 params)...
14df0 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 '()... (cdr
14e00 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 66 6f params))).. (fo
14e10 72 6d 64 61 74 20 28 73 64 61 74 2d 67 65 74 2d rmdat (sdat-get-
14e20 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 0a 09 formdat self))..
14e30 20 28 72 65 73 20 20 20 20 20 28 69 66 20 28 6e (res (if (n
14e40 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a 09 ot formdat) #f..
14e50 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 . (if (or (
14e60 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 6d string? key)(num
14e70 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f 6c ber? key)(symbol
14e80 3f 20 6b 65 79 29 29 0a 09 09 09 20 20 28 69 66 ? key)).... (if
14e90 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 66 (and (vector? f
14ea0 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 63 ormdat)(eq? (vec
14eb0 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d 64 tor-length formd
14ec0 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 6c at) 1)(hash-tabl
14ed0 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 e? (vector-ref f
14ee0 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 09 09 20 ormdat 0)))....
14ef0 20 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 67 65 (formdat:ge
14f00 74 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 0a 09 t formdat key)..
14f10 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
14f20 09 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 ...(session:log
14f30 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 self "ERROR: for
14f40 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 mdat: " formdat
14f50 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 " is not of clas
14f60 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 09 s <formdat>")...
14f70 09 09 23 66 29 29 0a 09 09 09 20 20 28 62 65 67 ..#f)).... (beg
14f80 69 6e 0a 09 09 09 20 20 20 20 28 73 65 73 73 69 in.... (sessi
14f90 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 52 on:log self "ERR
14fa0 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b 65 OR: bad key " ke
14fb0 79 29 0a 09 09 09 20 20 20 20 23 66 29 29 29 29 y).... #f))))
14fc0 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 79 70 ). (case dtyp
14fd0 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 20 20 e. ((raw)
14fe0 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 28 28 res). ((
14ff0 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 73 74 number) (if (st
15000 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 69 6e ring? res)(strin
15010 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 23 g->number res) #
15020 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 63 61 f)). ((esca
15030 70 65 64 29 20 28 69 66 20 28 73 74 72 69 6e 67 ped) (if (string
15040 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 ? res)... (s
15050 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 :html-filter->st
15060 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 0a 09 ring res tags)..
15070 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 . res)).
15080 20 20 28 65 6c 73 65 20 20 20 20 20 20 28 69 66 (else (if
15090 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 (string? res)..
150a0 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 69 . (s:html-fi
150b0 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 73 lter->string res
150c0 20 27 28 29 29 0a 09 09 20 20 20 20 20 72 65 73 '())... res
150d0 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6f )))))..;; This o
150e0 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 65 20 ne will get the
150f0 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f 75 6e first value foun
15100 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f 66 20 d regardless of
15110 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 73 65 form.(define (se
15120 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 2d ssion:get-input-
15130 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 keys self). (le
15140 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 73 64 t* ((formdat (sd
15150 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 73 at-get-formdat s
15160 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 elf))). (if (
15170 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a not formdat) #f.
15180 09 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f .(if (and (vecto
15190 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 r? formdat)(eq?
151a0 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 (vector-length f
151b0 6f 72 6d 64 61 74 29 20 31 29 28 68 61 73 68 2d ormdat) 1)(hash-
151c0 74 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 table? (vector-r
151d0 65 66 20 66 6f 72 6d 64 61 74 20 30 29 29 29 0a ef formdat 0))).
151e0 09 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b 65 . (formdat:ke
151f0 79 73 20 66 6f 72 6d 64 61 74 29 0a 09 20 20 20 ys formdat)..
15200 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
15210 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
15220 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 74 "ERROR: formdat
15230 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 73 : " formdat " is
15240 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c 66 not of class <f
15250 6f 72 6d 64 61 74 3e 22 29 0a 09 20 20 20 20 20 ormdat>")..
15260 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e #f)))))..(defin
15270 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 e (session:run-a
15280 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 28 ctions self). (
15290 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 20 let* ((action
152a0 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 (session:get-pa
152b0 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 6f 6e ram self 'action
152c0 20 27 28 72 61 77 29 29 29 0a 09 20 28 70 61 67 '(raw))).. (pag
152d0 65 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 e (sdat-get
152e0 2d 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 20 -page self))).
152f0 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 74 ;; (print "act
15300 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 70 ion=" action " p
15310 61 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 20 age=" page).
15320 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 74 (if action..(let
15330 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 28 ((action-lst (
15340 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 74 string-split act
15350 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b 3b ion "."))).. ;;
15360 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e 2d (print "action-
15370 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 74 lst=" action-lst
15380 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 3d ).. (if (not (=
15390 20 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e 2d (length action-
153a0 6c 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 20 lst) 2)) ..
153b0 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 6f (err:log "Actio
153c0 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 66 n should be of f
153d0 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 69 orm: module.acti
153e0 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 74 on").. (let
153f0 2a 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 20 * ((targ-page
15400 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 (car action-lst)
15410 29 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d 6e )... (proc-n
15420 61 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 70 ame (string-ap
15430 70 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 22 pend targ-page "
15440 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 20 -action"))...
15450 20 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 28 (targ-action (
15460 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 29 cadr action-lst)
15470 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f 67 ))...;; (err:log
15480 20 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 61 "targ-page=" ta
15490 72 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d 6e rg-page " proc-n
154a0 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 20 ame=" proc-name
154b0 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 20 " targ-action="
154c0 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 09 targ-action)....
154d0 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e 6c ;; call here onl
154e0 79 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c 65 y if never calle
154f0 64 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 28 d before...(if (
15500 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 session:never-ca
15510 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 20 lled-page? self
15520 74 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 20 targ-page)...
15530 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
15540 61 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d 70 arts self targ-p
15550 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a 09 age 'control))..
15560 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
15570 20 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 20 proc
15580 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15590 20 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a 0a action ..
155a0 09 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 20 ..(if #t ;; set
155b0 74 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 74 to #t to see bet
155c0 74 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 67 ter error messag
155d0 65 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 67 es during debugg
155e0 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 65 in :-)... ((e
155f0 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d val (string->sym
15600 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 20 bol proc-name))
15610 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b 20 targ-action) ;;
15620 75 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f 6e unsafe execution
15630 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f ... (conditio
15640 6e 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 73 n-case ((eval (s
15650 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 tring->symbol pr
15660 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d 61 oc-name)) targ-a
15670 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 28 ction)..... (
15680 28 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c 6f (exn file) (s:lo
15690 67 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 29 g "file error"))
156a0 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 69 ..... ((exn i
156b0 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f 6f /o) (s:log "i/o
156c0 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 20 error")).....
156d0 20 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 73 ((exn ) (s
156e0 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f 74 :log "Action not
156f0 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 20 implemented: "
15700 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 69 proc-name " acti
15710 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 6f on: " targ-actio
15720 6e 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 72 n))..... (var
15730 20 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 () (s:log "
15740 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 29 Unknown Error"))
15750 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
15760 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 e (session:never
15770 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 -called-page? se
15780 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 73 lf page). (sess
15790 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 68 ion:log self "Ch
157a0 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 3a ecking for page:
157b0 20 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 20 " page). (not
157c0 28 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 64 (member page (sd
157d0 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-get-seen-page
157e0 73 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 66 s self))))..(def
157f0 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ine (session:set
15800 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 -called! self pa
15810 67 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d ge). (sdat-set-
15820 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 seen-pages! self
15830 20 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 61 (cons page (sda
15840 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 73 t-get-seen-pages
15850 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d self))))..;;===
15860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15870 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15880 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15890 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158a0 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 69 ===.;; Alternati
158b0 76 65 20 64 61 74 61 20 74 79 70 65 20 64 65 6c ve data type del
158c0 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ivery.;;========
158d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15900 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
15910 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e (define (session
15920 3a 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a 20 :alt-out self).
15930 20 28 6c 65 74 20 28 28 64 61 74 20 28 73 64 61 (let ((dat (sda
15940 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d 64 t-get-alt-page-d
15950 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 3b at self))). ;
15960 3b 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 73 ; (s:log "dat is
15970 3a 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b 20 : " dat). ;;
15980 28 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e 31 (print "HTTP/1.1
15990 20 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 70 200 OK"). (p
159a0 72 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 74 rint "Date: " (t
159b0 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 ime->string (sec
159c0 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 28 onds->utc-time (
159d0 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
159e0 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 ))). (print "
159f0 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 20 Content-Type: "
15a00 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e (sdat-get-conten
15a10 74 2d 74 79 70 65 20 73 65 6c 66 29 29 0a 20 20 t-type self)).
15a20 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 70 74 (print "Accept
15a30 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 73 22 29 -Ranges: bytes")
15a40 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e . (print "Con
15a50 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 28 tent-Length: " (
15a60 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a 09 if (blob? dat)..
15a70 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 20 ... (blob-size
15a80 64 61 74 29 0a 09 09 09 09 20 20 30 29 29 0a 20 dat)..... 0)).
15a90 20 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 2d (print "Keep-
15aa0 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d 31 Alive: timeout=1
15ab0 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 20 5, max=100").
15ac0 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 (print "Connect
15ad0 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 22 ion: Keep-Alive"
15ae0 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 ). (print "")
15af0 0a 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 . (write-stri
15b00 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e 67 ng (blob->string
15b10 20 64 61 74 29 20 23 66 20 28 63 75 72 72 65 6e dat) #f (curren
15b20 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 29 t-output-port)))
15b30 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
15b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b60 3d 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 0a 3b 3b 20 4f ===========.;; O
15b80 72 70 68 61 6e 65 64 20 66 75 6e 63 74 69 6f 6e rphaned function
15b90 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
15ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15bc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15bd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 77 ==========..;; w
15be0 61 73 20 69 6e 20 73 65 74 75 70 0a 3b 3b 0a 28 as in setup.;;.(
15bf0 64 65 66 69 6e 65 20 28 73 3a 6c 6f 67 20 2e 20 define (s:log .
15c00 6d 73 67 29 0a 20 20 28 61 70 70 6c 79 20 73 65 msg). (apply se
15c10 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 ssion:log s:sess
15c20 69 6f 6e 20 6d 73 67 29 29 0a 0a 0a 3b 3b 20 55 ion msg))...;; U
15c30 73 61 67 65 3a 20 28 73 3a 67 65 74 2d 65 72 72 sage: (s:get-err
15c40 20 73 3a 62 69 67 29 0a 28 64 65 66 69 6e 65 20 s:big).(define
15c50 28 73 3a 67 65 74 2d 65 72 72 20 77 72 61 70 70 (s:get-err wrapp
15c60 65 72 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 erfunc). (let (
15c70 28 65 72 72 6d 73 67 20 28 73 64 61 74 2d 67 65 (errmsg (sdat-ge
15c80 74 2d 63 75 72 72 2d 65 72 72 20 73 3a 73 65 73 t-curr-err s:ses
15c90 73 69 6f 6e 29 29 29 0a 20 20 20 20 28 69 66 20 sion))). (if
15ca0 65 72 72 6d 73 67 20 28 28 69 66 20 77 72 61 70 errmsg ((if wrap
15cb0 70 65 72 66 75 6e 63 0a 20 20 20 20 20 20 20 20 perfunc.
15cc0 20 20 20 20 20 20 20 20 20 20 20 20 77 72 61 70 wrap
15cd0 70 65 72 66 75 6e 63 0a 20 20 20 20 20 20 20 20 perfunc.
15ce0 20 20 20 20 20 20 20 20 20 20 20 20 73 3a 73 74 s:st
15cf0 72 6f 6e 67 29 20 65 72 72 6d 73 67 29 20 27 28 rong) errmsg) '(
15d00 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 73 74 )))).(define (st
15d10 6d 6c 3a 63 67 69 2d 73 65 73 73 69 6f 6e 20 73 ml:cgi-session s
15d20 65 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 ession). (sessi
15d30 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 on:initialize se
15d40 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f ssion). (sessio
15d50 6e 3a 73 65 74 75 70 20 73 65 73 73 69 6f 6e 29 n:setup session)
15d60 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d . (session:get-
15d70 76 61 72 73 20 73 65 73 73 69 6f 6e 29 0a 0a 20 vars session)..
15d80 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d 70 (sdat-set-log-p
15d90 6f 72 74 21 20 73 65 73 73 69 6f 6e 20 3b 3b 20 ort! session ;;
15da0 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
15db0 6f 72 74 29 29 0a 09 09 20 20 20 20 20 20 28 6f ort))... (o
15dc0 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 pen-output-file
15dd0 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 66 69 6c (sdat-get-logfil
15de0 65 20 73 65 73 73 69 6f 6e 29 20 23 3a 61 70 70 e session) #:app
15df0 65 6e 64 29 29 0a 20 20 28 73 3a 76 61 6c 69 64 end)). (s:valid
15e00 61 74 65 2d 69 6e 70 75 74 73 29 0a 20 20 28 73 ate-inputs). (s
15e10 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 6f ession:run-actio
15e20 6e 73 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 ns session). (s
15e30 64 61 74 2d 73 65 74 2d 70 61 67 65 64 61 74 21 dat-set-pagedat!
15e40 20 73 65 73 73 69 6f 6e 0a 09 09 20 20 20 20 20 session...
15e50 28 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 (append (sdat-ge
15e60 74 2d 70 61 67 65 64 61 74 20 73 65 73 73 69 6f t-pagedat sessio
15e70 6e 29 0a 09 09 09 20 20 20 20 20 28 73 3a 63 61 n).... (s:ca
15e80 6c 6c 20 28 73 64 61 74 2d 67 65 74 2d 74 6f 70 ll (sdat-get-top
15e90 70 61 67 65 20 73 65 73 73 69 6f 6e 29 29 29 29 page session))))
15ea0 0a 20 20 28 69 66 20 28 65 71 3f 20 28 73 64 61 . (if (eq? (sda
15eb0 74 2d 67 65 74 2d 70 61 67 65 2d 74 79 70 65 20 t-get-page-type
15ec0 73 65 73 73 69 6f 6e 29 20 27 68 74 6d 6c 29 20 session) 'html)
15ed0 3b 3b 20 64 65 66 61 75 6c 74 20 69 73 20 68 74 ;; default is ht
15ee0 6d 6c 2e 20 0a 20 20 20 20 20 20 28 73 65 73 73 ml. . (sess
15ef0 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 73 73 ion:cgi-out sess
15f00 69 6f 6e 29 0a 20 20 20 20 20 20 28 73 65 73 73 ion). (sess
15f10 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 73 73 ion:alt-out sess
15f20 69 6f 6e 29 29 0a 20 20 28 73 65 73 73 69 6f 6e ion)). (session
15f30 3a 73 61 76 65 2d 76 61 72 73 20 73 65 73 73 69 :save-vars sessi
15f40 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 63 on). (session:c
15f50 6c 6f 73 65 20 73 65 73 73 69 6f 6e 29 29 0a 0a lose session))..
15f60 0a 28 64 65 66 69 6e 65 20 28 73 3a 76 61 6c 69 .(define (s:vali
15f70 64 61 74 65 2d 69 6e 70 75 74 73 29 0a 20 20 28 date-inputs). (
15f80 69 66 20 28 6e 6f 74 20 28 73 3a 76 61 6c 69 64 if (not (s:valid
15f90 61 74 65 2d 75 72 69 29 29 0a 20 20 20 20 20 20 ate-uri)).
15fa0 28 62 65 67 69 6e 20 28 73 3a 65 72 72 6f 72 2d (begin (s:error-
15fb0 70 61 67 65 20 22 42 61 64 20 55 52 49 22 20 28 page "Bad URI" (
15fc0 6c 65 74 20 28 28 72 65 66 20 28 67 65 74 2d 65 let ((ref (get-e
15fd0 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
15fe0 62 6c 65 20 22 48 54 54 50 5f 52 45 46 45 52 45 ble "HTTP_REFERE
15ff0 52 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 R"))).....
16000 20 28 69 66 20 72 65 66 0a 09 09 09 09 09 20 20 (if ref......
16010 20 28 6c 69 73 74 20 22 72 65 66 65 72 72 65 64 (list "referred
16020 20 66 72 6f 6d 22 20 72 65 66 29 0a 09 09 09 09 from" ref).....
16030 09 20 20 20 22 22 29 29 29 0a 09 20 20 20 20 20 . "")))..
16040 28 65 78 69 74 29 29 29 29 0a 0a 28 64 65 66 69 (exit))))..(defi
16050 6e 65 20 28 73 3a 65 72 72 6f 72 2d 70 61 67 65 ne (s:error-page
16060 20 2e 20 65 72 72 29 0a 20 20 28 73 3a 63 67 69 . err). (s:cgi
16070 2d 6f 75 74 20 28 63 6f 6e 73 20 22 43 6f 6e 74 -out (cons "Cont
16080 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 ent-type: text/h
16090 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 6f tml; charset=iso
160a0 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 0a 09 09 20 -8859-1\n\n"...
160b0 20 20 28 73 3a 68 74 6d 6c 20 28 73 3a 68 65 61 (s:html (s:hea
160c0 64 20 0a 09 09 09 20 20 20 20 28 73 3a 74 69 74 d .... (s:tit
160d0 6c 65 20 65 72 72 29 0a 09 09 09 20 20 20 20 28 le err).... (
160e0 73 3a 62 6f 64 79 0a 09 09 09 20 20 20 20 20 28 s:body.... (
160f0 73 3a 68 31 20 22 45 52 52 4f 52 22 29 0a 09 09 s:h1 "ERROR")...
16100 09 20 20 20 20 20 28 73 3a 70 20 65 72 72 29 29 . (s:p err))
16110 29 29 29 29 29 20 20 20 20 20 20 20 20 20 20 20 )))))
16120 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 6d 6c ...(define (stml
16130 3a 6d 61 69 6e 20 70 72 6f 63 29 0a 20 20 28 68 :main proc). (h
16140 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
16150 0a 20 20 20 65 78 6e 20 20 20 0a 20 20 20 28 69 . exn . (i
16160 66 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 75 f (sdat-get-debu
16170 67 6d 6f 64 65 20 73 3a 73 65 73 73 69 6f 6e 29 gmode s:session)
16180 0a 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
16190 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 (print "Content
161a0 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c -type: text/html
161b0 22 29 0a 09 20 28 70 72 69 6e 74 20 22 22 29 0a ").. (print "").
161c0 09 20 28 70 72 69 6e 74 20 22 3c 68 74 6d 6c 3e . (print "<html>
161d0 20 3c 68 65 61 64 3e 20 3c 74 69 74 6c 65 3e 45 <head> <title>E
161e0 58 43 45 50 54 49 4f 4e 3c 2f 74 69 74 6c 65 3e XCEPTION</title>
161f0 20 3c 2f 68 65 61 64 3e 20 3c 62 6f 64 79 3e 22 </head> <body>"
16200 29 0a 09 20 28 70 72 69 6e 74 20 22 20 20 20 51 ).. (print " Q
16210 55 45 52 59 5f 53 54 52 49 4e 47 20 69 73 3a 20 UERY_STRING is:
16220 3c 62 3e 20 22 20 28 67 65 74 2d 65 6e 76 69 72 <b> " (get-envir
16230 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
16240 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 20 "QUERY_STRING")
16250 22 20 3c 2f 62 3e 20 3c 62 72 3e 22 29 0a 09 20 " </b> <br>")..
16260 28 70 72 69 6e 74 20 22 3c 70 72 65 3e 22 29 0a (print "<pre>").
16270 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 20 . ;; (print "
16280 45 58 43 45 50 54 49 4f 4e 3a 20 22 20 28 28 63 EXCEPTION: " ((c
16290 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
162a0 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
162b0 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
162c0 09 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d . (print-error-m
162d0 65 73 73 61 67 65 20 65 78 6e 29 0a 09 20 28 70 essage exn).. (p
162e0 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 rint-call-chain)
162f0 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f 70 72 65 .. (print "</pre
16300 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 74 >").. (print "<t
16310 61 62 6c 65 3e 22 29 0a 09 20 28 66 6f 72 2d 65 able>").. (for-e
16320 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 ach (lambda (var
16330 29 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 )... (print
16340 22 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 "<tr><td>" (car
16350 76 61 72 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 var) "</td><td>"
16360 20 28 63 64 72 20 76 61 72 29 20 22 3c 2f 74 64 (cdr var) "</td
16370 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 20 28 ></tr>"))... (
16380 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
16390 76 61 72 69 61 62 6c 65 73 29 29 0a 09 20 28 70 variables)).. (p
163a0 72 69 6e 74 20 22 3c 2f 74 61 62 6c 65 3e 22 29 rint "</table>")
163b0 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f 62 6f 64 .. (print "</bod
163c0 79 3e 3c 2f 68 74 6d 6c 3e 22 29 29 0a 20 20 20 y></html>")).
163d0 20 20 20 20 28 62 65 67 69 6e 0a 09 20 28 77 69 (begin.. (wi
163e0 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
163f0 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 73 74 e (conc "/tmp/st
16400 6d 6c 2d 63 72 61 73 68 2d 22 20 28 63 75 72 72 ml-crash-" (curr
16410 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 ent-process-id)
16420 22 2e 6c 6f 67 22 29 0a 09 20 20 20 28 6c 61 6d ".log").. (lam
16430 62 64 61 20 28 29 0a 09 20 20 20 20 20 28 70 72 bda ().. (pr
16440 69 6e 74 20 22 45 58 43 45 50 54 49 4f 4e 22 29 int "EXCEPTION")
16450 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 20 .. (print "
16460 20 20 51 55 45 52 59 5f 53 54 52 49 4e 47 20 69 QUERY_STRING i
16470 73 3a 20 22 20 28 67 65 74 2d 65 6e 76 69 72 6f s: " (get-enviro
16480 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
16490 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 20 29 QUERY_STRING") )
164a0 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 22 .. (print ""
164b0 29 0a 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e ).. ;; (prin
164c0 74 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e 3a t " EXCEPTION:
164d0 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
164e0 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
164f0 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
16500 65 78 6e 29 29 0a 09 20 20 20 20 20 28 70 72 69 exn)).. (pri
16510 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 nt-error-message
16520 20 65 78 6e 29 0a 09 20 20 20 20 20 28 70 72 69 exn).. (pri
16530 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 09 nt-call-chain)..
16540 20 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a (print "").
16550 09 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 . (for-each
16560 28 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 09 (lambda (var)...
16570 09 20 28 70 72 69 6e 74 20 28 63 61 72 20 76 61 . (print (car va
16580 72 29 20 22 5c 74 22 20 28 63 64 72 20 76 61 72 r) "\t" (cdr var
16590 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 65 )))... (ge
165a0 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
165b0 72 69 61 62 6c 65 73 29 29 29 29 0a 09 20 3b 3b riables)))).. ;;
165c0 20 72 65 74 75 72 6e 20 73 6f 6d 65 74 68 69 6e return somethin
165d0 67 20 75 73 65 66 75 6c 20 74 6f 20 74 68 65 20 g useful to the
165e0 75 73 65 72 0a 09 20 28 70 72 69 6e 74 20 22 43 user.. (print "C
165f0 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
16600 74 2f 68 74 6d 6c 22 29 0a 09 20 28 70 72 69 6e t/html").. (prin
16610 74 20 22 22 29 0a 09 20 28 70 72 69 6e 74 20 22 t "").. (print "
16620 3c 68 74 6d 6c 3e 20 3c 68 65 61 64 3e 20 3c 74 <html> <head> <t
16630 69 74 6c 65 3e 45 58 43 45 50 54 49 4f 4e 3c 2f itle>EXCEPTION</
16640 74 69 74 6c 65 3e 20 3c 2f 68 65 61 64 3e 20 3c title> </head> <
16650 62 6f 64 79 3e 22 29 0a 09 20 28 70 72 69 6e 74 body>").. (print
16660 20 22 3c 68 31 3e 43 52 41 53 48 21 3c 2f 68 31 "<h1>CRASH!</h1
16670 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 20 20 >").. (print "
16680 20 50 6c 65 61 73 65 20 6e 6f 74 69 66 79 20 73 Please notify s
16690 75 70 70 6f 72 74 20 61 74 20 22 20 28 73 64 61 upport at " (sda
166a0 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 3a 73 t-get-domain s:s
166b0 65 73 73 69 6f 6e 29 20 22 20 74 68 61 74 20 74 ession) " that t
166c0 68 65 20 65 72 72 6f 72 20 6c 6f 67 20 69 73 20 he error log is
166d0 73 74 6d 6c 2d 63 72 61 73 68 2d 22 20 28 63 75 stml-crash-" (cu
166e0 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
166f0 29 20 22 2e 6c 6f 67 3c 2f 62 3e 20 3c 62 72 3e ) ".log</b> <br>
16700 22 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 ").. ;; (print "
16710 3c 70 72 65 3e 22 29 0a 09 20 3b 3b 20 3b 3b 20 <pre>").. ;; ;;
16720 28 70 72 69 6e 74 20 22 20 20 20 45 58 43 45 50 (print " EXCEP
16730 54 49 4f 4e 3a 20 22 20 28 28 63 6f 6e 64 69 74 TION: " ((condit
16740 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
16750 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
16760 61 67 65 29 20 65 78 6e 29 29 0a 09 20 3b 3b 20 age) exn)).. ;;
16770 3b 3b 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d ;; (print-error-
16780 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 09 20 3b message exn).. ;
16790 3b 20 3b 3b 20 28 70 72 69 6e 74 2d 63 61 6c 6c ; ;; (print-call
167a0 2d 63 68 61 69 6e 29 0a 09 20 3b 3b 20 28 70 72 -chain).. ;; (pr
167b0 69 6e 74 20 22 3c 2f 70 72 65 3e 22 29 0a 09 20 int "</pre>")..
167c0 3b 3b 20 28 70 72 69 6e 74 20 22 3c 74 61 62 6c ;; (print "<tabl
167d0 65 3e 22 29 0a 09 20 3b 3b 20 28 66 6f 72 2d 65 e>").. ;; (for-e
167e0 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 ach (lambda (var
167f0 29 0a 09 20 3b 3b 20 09 20 20 20 20 20 28 70 72 ).. ;; . (pr
16800 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 28 int "<tr><td>" (
16810 63 61 72 20 76 61 72 29 20 22 3c 2f 74 64 3e 3c car var) "</td><
16820 74 64 3e 22 20 28 63 64 72 20 76 61 72 29 20 22 td>" (cdr var) "
16830 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 20 </td></tr>"))..
16840 3b 3b 20 09 20 20 20 28 67 65 74 2d 65 6e 76 69 ;; . (get-envi
16850 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
16860 73 29 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 s)).. ;; (print
16870 22 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 20 28 70 "</table>").. (p
16880 72 69 6e 74 20 22 3c 2f 62 6f 64 79 3e 3c 2f 68 rint "</body></h
16890 74 6d 6c 3e 22 29 29 29 0a 20 20 20 28 69 66 20 tml>"))). (if
168a0 70 72 6f 63 20 28 70 72 6f 63 20 73 3a 73 65 73 proc (proc s:ses
168b0 73 69 6f 6e 29 20 28 73 74 6d 6c 3a 63 67 69 2d sion) (stml:cgi-
168c0 73 65 73 73 69 6f 6e 20 73 3a 73 65 73 73 69 6f session s:sessio
168d0 6e 29 29 0a 20 3b 3b 20 28 72 61 69 73 65 2d 65 n)). ;; (raise-e
168e0 72 72 6f 72 29 0a 20 3b 3b 20 28 65 78 69 74 29 rror). ;; (exit)
168f0 0a 20 20 20 29 29 0a 0a 3b 3b 20 66 69 6e 64 20 . ))..;; find
16900 6f 75 74 20 69 66 20 77 65 20 61 72 65 20 69 6e out if we are in
16910 20 64 65 62 75 67 6d 6f 64 65 0a 28 64 65 66 69 debugmode.(defi
16920 6e 65 20 28 73 3a 64 65 62 75 67 2d 6d 6f 64 65 ne (s:debug-mode
16930 3f 29 0a 20 20 28 73 64 61 74 2d 67 65 74 2d 64 ?). (sdat-get-d
16940 65 62 75 67 6d 6f 64 65 20 73 3a 73 65 73 73 69 ebugmode s:sessi
16950 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 on))..(define (s
16960 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 61 :never-called-pa
16970 67 65 3f 20 70 61 67 65 29 0a 20 20 28 73 65 73 ge? page). (ses
16980 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 sion:never-calle
16990 64 2d 70 61 67 65 3f 20 73 3a 73 65 73 73 69 6f d-page? s:sessio
169a0 6e 20 70 61 67 65 29 29 0a 0a 28 64 65 66 69 6e n page))..(defin
169b0 65 20 28 73 3a 73 65 74 2d 65 72 72 20 2e 20 61 e (s:set-err . a
169c0 72 67 73 29 0a 20 20 28 73 64 61 74 2d 73 65 74 rgs). (sdat-set
169d0 2d 63 75 72 72 2d 65 72 72 21 20 73 3a 73 65 73 -curr-err! s:ses
169e0 73 69 6f 6e 20 61 72 67 73 29 29 0a 0a 28 64 65 sion args))..(de
169f0 66 69 6e 65 20 28 73 3a 63 75 72 72 65 6e 74 2d fine (s:current-
16a00 70 61 67 65 29 0a 20 20 28 73 64 61 74 2d 67 65 page). (sdat-ge
16a10 74 2d 70 61 67 65 20 73 3a 73 65 73 73 69 6f 6e t-page s:session
16a20 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 64 ))..(define (s:d
16a30 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 29 0a 20 elete-session).
16a40 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 (session:delete
16a50 2d 73 65 73 73 69 6f 6e 20 73 3a 73 65 73 73 69 -session s:sessi
16a60 6f 6e 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 on (sdat-get-ses
16a70 73 69 6f 6e 2d 6b 65 79 20 73 3a 73 65 73 73 69 sion-key s:sessi
16a80 6f 6e 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 on)))..(define (
16a90 73 3a 63 61 6c 6c 20 70 61 67 65 20 2e 20 70 61 s:call page . pa
16aa0 72 74 73 6c 29 0a 20 20 28 69 66 20 28 6e 75 6c rtsl). (if (nul
16ab0 6c 3f 20 70 61 72 74 73 6c 29 0a 20 20 20 20 20 l? partsl).
16ac0 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 (session:call s
16ad0 3a 73 65 73 73 69 6f 6e 20 70 61 67 65 20 23 66 :session page #f
16ae0 29 0a 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e ). (session
16af0 3a 63 61 6c 6c 20 73 3a 73 65 73 73 69 6f 6e 20 :call s:session
16b00 70 61 67 65 20 28 63 61 72 20 70 61 72 74 73 6c page (car partsl
16b10 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
16b20 3a 6c 69 6e 6b 2d 74 6f 20 70 61 67 65 20 2e 20 :link-to page .
16b30 70 61 72 61 6d 73 29 0a 20 20 28 73 65 73 73 69 params). (sessi
16b40 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 3a 73 65 73 on:link-to s:ses
16b50 73 69 6f 6e 20 70 61 67 65 20 70 61 72 61 6d 73 sion page params
16b60 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 67 ))..(define (s:g
16b70 65 74 2d 70 61 72 61 6d 20 6b 65 79 20 2e 20 74 et-param key . t
16b80 79 70 65 2d 70 61 72 61 6d 73 29 0a 20 20 28 73 ype-params). (s
16b90 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d ession:get-param
16ba0 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 20 74 s:session key t
16bb0 79 70 65 2d 70 61 72 61 6d 73 29 29 0a 0a 3b 3b ype-params))..;;
16bc0 20 74 68 65 73 65 20 61 72 65 20 70 61 67 65 20 these are page
16bd0 6c 6f 63 61 6c 0a 28 64 65 66 69 6e 65 20 28 73 local.(define (s
16be0 3a 67 65 74 20 6b 65 79 29 20 0a 20 20 28 73 65 :get key) . (se
16bf0 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 ssion:page-get s
16c00 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 0a 0a :session key))..
16c10 28 64 65 66 69 6e 65 20 28 73 3a 73 65 74 21 20 (define (s:set!
16c20 6b 65 79 20 76 61 6c 29 0a 20 20 28 73 65 73 73 key val). (sess
16c30 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 65 ion:curr-page-se
16c40 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 t! s:session key
16c50 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 val))..(define
16c60 28 73 3a 64 65 6c 21 20 6b 65 79 29 0a 20 20 28 (s:del! key). (
16c70 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 76 61 72 session:page-var
16c80 2d 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 -del! s:session
16c90 6b 65 79 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 key))..#;(define
16ca0 20 28 73 3a 67 65 74 2d 6e 2d 64 65 6c 21 20 6b (s:get-n-del! k
16cb0 65 79 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c ey). (let ((val
16cc0 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 (session:page-g
16cd0 65 74 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 et s:session key
16ce0 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e ))). (session
16cf0 3a 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 :del! s:session
16d00 76 61 6c 20 6b 65 79 29 0a 20 20 20 20 76 61 6c val key). val
16d10 29 29 0a 0a 3b 3b 20 74 68 65 73 65 20 61 72 65 ))..;; these are
16d20 20 73 65 73 73 69 6f 6e 20 77 69 64 65 0a 28 64 session wide.(d
16d30 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e efine (s:session
16d40 2d 76 61 72 2d 67 65 74 20 6b 65 79 20 2e 20 70 -var-get key . p
16d50 61 72 61 6d 73 29 20 0a 20 20 28 73 65 73 73 69 arams) . (sessi
16d60 6f 6e 3a 67 65 74 20 73 3a 73 65 73 73 69 6f 6e on:get s:session
16d70 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 "*sessionvars*"
16d80 20 6b 65 79 20 70 61 72 61 6d 73 29 29 0a 0a 28 key params))..(
16d90 64 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f define (s:sessio
16da0 6e 2d 76 61 72 2d 73 65 74 21 20 6b 65 79 20 76 n-var-set! key v
16db0 61 6c 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 al). (session:s
16dc0 65 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 22 2a et! s:session "*
16dd0 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6b 65 sessionvars*" ke
16de0 79 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 y val))..(define
16df0 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d (s:session-var-
16e00 67 65 74 2d 6e 2d 64 65 6c 21 20 6b 65 79 29 0a get-n-del! key).
16e10 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 73 65 (let ((val (se
16e20 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 73 ssion:page-get s
16e30 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 29 0a :session key))).
16e40 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 64 65 (session:de
16e50 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 22 2a 73 l! s:session "*s
16e60 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6b 65 79 essionvars*" key
16e70 29 0a 20 20 20 20 20 76 61 6c 29 29 0a 0a 28 64 ). val))..(d
16e80 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e efine (s:session
16e90 2d 76 61 72 2d 64 65 6c 21 20 6b 65 79 29 0a 20 -var-del! key).
16ea0 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 73 (session:del! s
16eb0 3a 73 65 73 73 69 6f 6e 20 22 2a 73 65 73 73 69 :session "*sessi
16ec0 6f 6e 76 61 72 73 2a 22 20 6b 65 79 29 29 0a 0a onvars*" key))..
16ed0 28 64 65 66 69 6e 65 20 73 3a 73 65 73 73 69 6f (define s:sessio
16ee0 6e 2d 76 61 72 2d 64 65 6c 65 74 65 21 20 73 3a n-var-delete! s:
16ef0 73 65 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c 21 session-var-del!
16f00 29 0a 0a 3b 3b 20 75 74 69 6c 69 74 79 20 74 6f )..;; utility to
16f10 20 67 65 74 20 61 6c 6c 20 76 61 72 73 20 61 73 get all vars as
16f20 20 68 61 73 68 20 74 61 62 6c 65 0a 28 64 65 66 hash table.(def
16f30 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e 2d 67 ine (s:session-g
16f40 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 29 0a et-sessionvars).
16f50 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 (sdat-get-sess
16f60 69 6f 6e 76 61 72 73 20 73 3a 73 65 73 73 69 6f ionvars s:sessio
16f70 6e 29 29 0a 0a 0a 0a 29 0a n))....).