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 20 23 21 6f 70 74 69 lize self #!opti
e290: 6f 6e 61 6c 20 28 63 6f 6e 66 69 67 66 20 23 66 onal (configf #f
e2a0: 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 64 )). (sdat-set-d
e2b0: 62 74 79 70 65 21 20 73 65 6c 66 20 20 20 20 20 btype! self
e2c0: 20 27 70 67 29 0a 20 20 28 73 64 61 74 2d 73 65 'pg). (sdat-se
e2d0: 74 2d 70 61 67 65 21 20 73 65 6c 66 20 20 20 20 t-page! self
e2e0: 20 20 20 20 22 68 6f 6d 65 22 29 20 20 20 20 20 "home")
e2f0: 20 20 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 ;; these are
e300: 64 65 66 61 75 6c 74 73 0a 20 20 28 73 64 61 74 defaults. (sdat
e310: 2d 73 65 74 2d 63 75 72 72 2d 70 61 67 65 21 20 -set-curr-page!
e320: 73 65 6c 66 20 20 20 22 68 6f 6d 65 22 29 0a 20 self "home").
e330: 20 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 74 65 (sdat-set-conte
e340: 6e 74 2d 74 79 70 65 21 20 73 65 6c 66 20 22 43 nt-type! self "C
e350: 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 ontent-type: tex
e360: 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d t/html; charset=
e370: 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 29 iso-8859-1\n\n")
e380: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 . (sdat-set-pag
e390: 65 2d 74 79 70 65 21 20 73 65 6c 66 20 20 20 27 e-type! self '
e3a0: 68 74 6d 6c 29 0a 20 20 28 73 64 61 74 2d 73 65 html). (sdat-se
e3b0: 74 2d 74 6f 70 70 61 67 65 21 20 73 65 6c 66 20 t-toppage! self
e3c0: 20 20 20 20 22 69 6e 64 65 78 22 29 0a 20 20 28 "index"). (
e3d0: 73 64 61 74 2d 73 65 74 2d 70 61 72 61 6d 73 21 sdat-set-params!
e3e0: 20 73 65 6c 66 20 20 20 20 20 20 27 28 29 29 20 self '())
e3f0: 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 28 ;;. (
e400: 73 64 61 74 2d 73 65 74 2d 70 61 74 68 2d 70 61 sdat-set-path-pa
e410: 72 61 6d 73 21 20 73 65 6c 66 20 27 28 29 29 0a rams! self '()).
e420: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
e430: 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 23 66 ion-key! self #f
e440: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
e450: 67 65 64 61 74 21 20 73 65 6c 66 20 20 20 20 20 gedat! self
e460: 27 28 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 '()). (sdat-set
e470: 2d 61 6c 74 2d 70 61 67 65 2d 64 61 74 21 20 73 -alt-page-dat! s
e480: 65 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d elf #f). (sdat-
e490: 73 65 74 2d 73 72 6f 6f 74 21 20 73 65 6c 66 20 set-sroot! self
e4a0: 20 20 20 20 20 20 22 2e 2f 22 29 0a 20 20 28 73 "./"). (s
e4b0: 64 61 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d dat-set-session-
e4c0: 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 23 66 29 cookie! self #f)
e4d0: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 75 72 . (sdat-set-cur
e4e0: 72 2d 65 72 72 21 20 73 65 6c 66 20 23 66 29 0a r-err! self #f).
e4f0: 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d (sdat-set-log-
e500: 70 6f 72 74 21 20 73 65 6c 66 20 28 63 75 72 72 port! self (curr
e510: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
e520: 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 65 . (sdat-set-see
e530: 6e 2d 70 61 67 65 73 21 20 73 65 6c 66 20 27 28 n-pages! self '(
e540: 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 )). (sdat-set-p
e550: 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 21 20 73 age-dir-style! s
e560: 65 6c 66 20 23 74 29 20 3b 3b 20 23 74 20 3a 20 elf #t) ;; #t :
e570: 70 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e pages/<pagename>
e580: 5f 28 76 69 65 77 7c 63 6e 74 6c 29 2e 73 63 6d _(view|cntl).scm
e590: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e5b0: 20 20 20 20 20 20 20 3b 3b 20 23 66 20 3a 20 70 ;; #f : p
e5c0: 61 67 65 73 2f 3c 70 61 67 65 6e 61 6d 65 3e 2f ages/<pagename>/
e5d0: 28 76 69 65 77 7c 63 6f 6e 74 72 6f 6c 29 2e 73 (view|control).s
e5e0: 63 6d 20 0a 20 20 28 73 64 61 74 2d 73 65 74 2d cm . (sdat-set-
e5f0: 64 65 62 75 67 6d 6f 64 65 21 20 20 20 20 20 20 debugmode!
e600: 20 20 20 20 73 65 6c 66 20 23 66 29 0a 20 20 09 self #f). .
e610: 09 09 20 20 20 20 20 0a 20 20 28 73 64 61 74 2d .. . (sdat-
e620: 73 65 74 2d 70 61 67 65 76 61 72 73 21 20 20 20 set-pagevars!
e630: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
e640: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
e650: 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 (sdat-set-sess
e660: 69 6f 6e 76 61 72 73 21 20 20 20 20 20 20 20 20 ionvars!
e670: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
e680: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
e690: 73 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 21 20 set-globalvars!
e6a0: 20 20 20 20 20 20 20 20 73 65 6c 66 20 28 6d 61 self (ma
e6b0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
e6c0: 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 67 65 (sdat-set-page
e6d0: 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 20 20 vars-before!
e6e0: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
e6f0: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
e700: 73 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d set-sessionvars-
e710: 62 65 66 6f 72 65 21 20 73 65 6c 66 20 28 6d 61 before! self (ma
e720: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
e730: 20 20 28 73 64 61 74 2d 73 65 74 2d 67 6c 6f 62 (sdat-set-glob
e740: 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 21 20 20 alvars-before!
e750: 73 65 6c 66 20 28 6d 61 6b 65 2d 68 61 73 68 2d self (make-hash-
e760: 74 61 62 6c 65 29 29 0a 20 20 28 73 64 61 74 2d table)). (sdat-
e770: 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 20 20 set-domain!
e780: 20 20 20 20 20 20 20 20 73 65 6c 66 20 22 6c 6f self "lo
e790: 63 61 68 6f 73 74 22 29 20 20 20 3b 3b 20 65 6e cahost") ;; en
e7a0: 64 20 6f 66 20 64 65 66 61 75 6c 74 73 0a 20 20 d of defaults.
e7b0: 28 73 64 61 74 2d 73 65 74 2d 73 63 72 69 70 74 (sdat-set-script
e7c0: 21 20 20 20 20 20 20 20 20 20 20 20 20 20 73 65 ! se
e7d0: 6c 66 20 23 66 29 0a 20 20 28 73 64 61 74 2d 73 lf #f). (sdat-s
e7e0: 65 74 2d 66 6f 72 63 65 2d 73 73 6c 21 20 20 20 et-force-ssl!
e7f0: 20 20 20 20 20 20 20 73 65 6c 66 20 23 66 29 0a self #f).
e800: 20 20 28 6c 65 74 2a 20 28 28 72 61 77 63 6f 6e (let* ((rawcon
e810: 66 69 67 64 61 74 20 28 73 65 73 73 69 6f 6e 3a figdat (session:
e820: 72 65 61 64 2d 63 6f 6e 66 69 67 20 73 65 6c 66 read-config self
e830: 20 63 6f 6e 66 69 67 66 29 29 0a 09 20 28 63 6f configf)).. (co
e840: 6e 66 69 67 64 61 74 20 28 69 66 20 72 61 77 63 nfigdat (if rawc
e850: 6f 6e 66 69 67 64 61 74 20 28 65 76 61 6c 20 72 onfigdat (eval r
e860: 61 77 63 6f 6e 66 69 67 64 61 74 29 20 27 28 29 awconfigdat) '()
e870: 29 29 0a 09 20 28 73 72 6f 6f 74 20 20 20 20 20 )).. (sroot
e880: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 73 (s:find-param 's
e890: 72 6f 6f 74 20 20 20 20 63 6f 6e 66 69 67 64 61 root configda
e8a0: 74 29 29 0a 09 20 28 6c 6f 67 66 69 6c 65 20 20 t)).. (logfile
e8b0: 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 27 (s:find-param '
e8c0: 6c 6f 67 66 69 6c 65 20 20 63 6f 6e 66 69 67 64 logfile configd
e8d0: 61 74 29 29 0a 09 20 28 64 62 74 79 70 65 20 20 at)).. (dbtype
e8e0: 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 (s:find-param
e8f0: 27 64 62 74 79 70 65 20 20 20 63 6f 6e 66 69 67 'dbtype config
e900: 64 61 74 29 29 0a 09 20 28 64 62 69 6e 69 74 20 dat)).. (dbinit
e910: 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d (s:find-param
e920: 20 27 64 62 69 6e 69 74 20 20 20 63 6f 6e 66 69 'dbinit confi
e930: 67 64 61 74 29 29 0a 09 20 28 64 6f 6d 61 69 6e gdat)).. (domain
e940: 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 61 (s:find-para
e950: 6d 20 27 64 6f 6d 61 69 6e 20 20 20 63 6f 6e 66 m 'domain conf
e960: 69 67 64 61 74 29 29 0a 09 20 28 74 77 69 6b 69 igdat)).. (twiki
e970: 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 72 dir (s:find-par
e980: 61 6d 20 27 74 77 69 6b 69 64 69 72 20 63 6f 6e am 'twikidir con
e990: 66 69 67 64 61 74 29 29 0a 09 20 28 70 61 67 65 figdat)).. (page
e9a0: 2d 64 69 72 20 20 28 73 3a 66 69 6e 64 2d 70 61 -dir (s:find-pa
e9b0: 72 61 6d 20 27 70 61 67 65 2d 64 69 72 2d 73 74 ram 'page-dir-st
e9c0: 79 6c 65 20 63 6f 6e 66 69 67 64 61 74 29 29 0a yle configdat)).
e9d0: 09 20 28 64 65 62 75 67 6d 6f 64 65 20 28 73 3a . (debugmode (s:
e9e0: 66 69 6e 64 2d 70 61 72 61 6d 20 27 64 65 62 75 find-param 'debu
e9f0: 67 6d 6f 64 65 20 63 6f 6e 66 69 67 64 61 74 29 gmode configdat)
ea00: 29 0a 20 20 20 20 20 20 20 20 20 28 73 63 72 69 ). (scri
ea10: 70 74 20 20 20 20 28 73 3a 66 69 6e 64 2d 70 61 pt (s:find-pa
ea20: 72 61 6d 20 27 73 63 72 69 70 74 20 20 20 20 63 ram 'script c
ea30: 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 28 66 6f onfigdat)).. (fo
ea40: 72 63 65 2d 73 73 6c 20 28 73 3a 66 69 6e 64 2d rce-ssl (s:find-
ea50: 70 61 72 61 6d 20 27 66 6f 72 63 65 2d 73 73 6c param 'force-ssl
ea60: 20 63 6f 6e 66 69 67 64 61 74 29 29 29 0a 20 20 configdat))).
ea70: 20 20 28 69 66 20 73 72 6f 6f 74 20 20 20 20 28 (if sroot (
ea80: 73 64 61 74 2d 73 65 74 2d 73 72 6f 6f 74 21 20 sdat-set-sroot!
ea90: 20 20 20 73 65 6c 66 20 73 72 6f 6f 74 29 29 0a self sroot)).
eaa0: 20 20 20 20 28 69 66 20 6c 6f 67 66 69 6c 65 20 (if logfile
eab0: 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 66 69 (sdat-set-logfi
eac0: 6c 65 21 20 20 73 65 6c 66 20 6c 6f 67 66 69 6c le! self logfil
ead0: 65 29 29 0a 20 20 20 20 28 69 66 20 64 62 74 79 e)). (if dbty
eae0: 70 65 20 20 20 28 73 64 61 74 2d 73 65 74 2d 64 pe (sdat-set-d
eaf0: 62 74 79 70 65 21 20 20 20 73 65 6c 66 20 64 62 btype! self db
eb00: 74 79 70 65 29 29 0a 20 20 20 20 28 69 66 20 64 type)). (if d
eb10: 62 69 6e 69 74 20 20 20 28 73 64 61 74 2d 73 65 binit (sdat-se
eb20: 74 2d 64 62 69 6e 69 74 21 20 20 20 73 65 6c 66 t-dbinit! self
eb30: 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 28 69 dbinit)). (i
eb40: 66 20 64 6f 6d 61 69 6e 20 20 20 28 73 64 61 74 f domain (sdat
eb50: 2d 73 65 74 2d 64 6f 6d 61 69 6e 21 20 20 20 73 -set-domain! s
eb60: 65 6c 66 20 64 6f 6d 61 69 6e 29 29 0a 20 20 20 elf domain)).
eb70: 20 28 69 66 20 74 77 69 6b 69 64 69 72 20 28 73 (if twikidir (s
eb80: 64 61 74 2d 73 65 74 2d 74 77 69 6b 69 64 69 72 dat-set-twikidir
eb90: 21 20 73 65 6c 66 20 74 77 69 6b 69 64 69 72 29 ! self twikidir)
eba0: 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 67 6d ). (if debugm
ebb0: 6f 64 65 20 28 73 64 61 74 2d 73 65 74 2d 64 65 ode (sdat-set-de
ebc0: 62 75 67 6d 6f 64 65 21 20 73 65 6c 66 20 64 65 bugmode! self de
ebd0: 62 75 67 6d 6f 64 65 29 29 0a 20 20 20 20 28 69 bugmode)). (i
ebe0: 66 20 73 63 72 69 70 74 20 20 20 20 28 73 64 61 f script (sda
ebf0: 74 2d 73 65 74 2d 73 63 72 69 70 74 21 20 20 20 t-set-script!
ec00: 20 73 65 6c 66 20 73 63 72 69 70 74 29 29 0a 20 self script)).
ec10: 20 20 20 28 69 66 20 66 6f 72 63 65 2d 73 73 6c (if force-ssl
ec20: 20 28 73 64 61 74 2d 73 65 74 2d 66 6f 72 63 65 (sdat-set-force
ec30: 2d 73 73 6c 21 20 73 65 6c 66 20 66 6f 72 63 65 -ssl! self force
ec40: 2d 73 73 6c 29 29 0a 20 20 20 20 28 73 64 61 74 -ssl)). (sdat
ec50: 2d 73 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 74 -set-page-dir-st
ec60: 79 6c 65 21 20 73 65 6c 66 20 70 61 67 65 2d 64 yle! self page-d
ec70: 69 72 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e ir). ;; (prin
ec80: 74 20 22 63 6f 6e 66 69 67 64 61 74 3a 20 22 29 t "configdat: ")
ec90: 28 70 70 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 (pp configdat).
eca0: 20 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 (if debugmode
ecb0: 0a 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ..(session:log s
ecc0: 65 6c 66 20 22 73 72 6f 6f 74 3a 20 22 20 73 72 elf "sroot: " sr
ecd0: 6f 6f 74 20 22 20 6c 6f 67 66 69 6c 65 3a 20 22 oot " logfile: "
ece0: 20 6c 6f 67 66 69 6c 65 20 22 20 64 62 74 79 70 logfile " dbtyp
ecf0: 65 3a 20 22 20 64 62 74 79 70 65 20 0a 09 09 20 e: " dbtype ...
ed00: 20 20 20 20 22 20 64 62 69 6e 69 74 3a 20 22 20 " dbinit: "
ed10: 64 62 69 6e 69 74 20 22 20 64 6f 6d 61 69 6e 3a dbinit " domain:
ed20: 20 22 20 64 6f 6d 61 69 6e 20 22 20 70 61 67 65 " domain " page
ed30: 2d 64 69 72 2d 73 74 79 6c 65 3a 20 22 20 70 61 -dir-style: " pa
ed40: 67 65 2d 64 69 72 29 29 0a 20 20 20 20 29 0a 20 ge-dir)). ).
ed50: 20 28 73 64 61 74 2d 73 65 74 2d 73 68 61 72 65 (sdat-set-share
ed60: 64 2d 68 61 73 68 21 20 73 65 6c 66 20 28 6d 61 d-hash! self (ma
ed70: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
ed80: 20 20 29 0a 0a 3b 3b 20 55 73 65 64 20 66 6f 72 )..;; Used for
ed90: 20 74 68 65 20 73 74 72 61 6e 67 65 6c 79 20 69 the strangely i
eda0: 6e 63 6f 6e 73 69 73 74 65 6e 74 20 68 61 6e 64 nconsistent hand
edb0: 6c 69 6e 67 20 6f 66 20 74 68 65 20 63 6f 6e 66 ling of the conf
edc0: 69 67 20 66 69 6c 65 2e 20 41 20 62 65 74 74 65 ig file. A bette
edd0: 72 20 77 61 79 20 69 73 20 6e 65 65 64 65 64 2e r way is needed.
ede0: 0a 3b 3b 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 .;;.;; (let ((
edf0: 64 62 74 79 70 65 20 28 73 64 61 74 2d 67 65 74 dbtype (sdat-get
ee00: 2d 64 62 74 79 70 65 20 73 65 6c 66 29 29 29 0a -dbtype self))).
ee10: 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 64 ;; (print "d
ee20: 62 74 79 70 65 3a 20 22 20 64 62 74 79 70 65 29 btype: " dbtype)
ee30: 0a 3b 3b 20 20 20 20 20 28 73 64 61 74 2d 73 65 .;; (sdat-se
ee40: 74 2d 64 62 74 79 70 65 21 20 73 65 6c 66 20 28 t-dbtype! self (
ee50: 65 76 61 6c 20 64 62 74 79 70 65 29 29 29 29 0a eval dbtype)))).
ee60: 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
ee70: 6e 3a 73 65 74 75 70 20 73 65 6c 66 29 0a 20 20 n:setup self).
ee80: 28 6c 65 74 20 28 28 64 62 74 79 70 65 20 20 20 (let ((dbtype
ee90: 20 28 73 64 61 74 2d 67 65 74 2d 64 62 74 79 70 (sdat-get-dbtyp
eea0: 65 20 73 65 6c 66 29 29 0a 09 28 64 65 62 75 67 e self))..(debug
eeb0: 6d 6f 64 65 20 28 73 64 61 74 2d 67 65 74 2d 64 mode (sdat-get-d
eec0: 65 62 75 67 6d 6f 64 65 20 73 65 6c 66 29 29 0a ebugmode self)).
eed0: 09 28 64 62 69 6e 69 74 20 20 20 20 28 65 76 61 .(dbinit (eva
eee0: 6c 20 28 73 64 61 74 2d 67 65 74 2d 64 62 69 6e l (sdat-get-dbin
eef0: 69 74 20 73 65 6c 66 29 29 29 0a 09 28 64 62 65 it self)))..(dbe
ef00: 78 69 73 74 73 20 20 23 66 29 29 0a 20 20 20 20 xists #f)).
ef10: 28 6c 65 74 20 28 28 64 62 66 6e 61 6d 65 20 28 (let ((dbfname (
ef20: 61 6c 69 73 74 2d 72 65 66 20 27 64 62 6e 61 6d alist-ref 'dbnam
ef30: 65 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 e dbinit))).
ef40: 20 20 28 69 66 20 64 65 62 75 67 6d 6f 64 65 20 (if debugmode
ef50: 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
ef60: 66 20 22 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 f "session:setup
ef70: 20 64 62 66 6e 61 6d 65 3d 22 20 64 62 66 6e 61 dbfname=" dbfna
ef80: 6d 65 20 22 2c 20 64 62 74 79 70 65 3d 22 20 64 me ", dbtype=" d
ef90: 62 74 79 70 65 20 22 2c 20 64 62 69 6e 69 74 3d btype ", dbinit=
efa0: 22 20 64 62 69 6e 69 74 29 29 0a 20 20 20 20 20 " dbinit)).
efb0: 20 28 69 66 20 28 65 71 3f 20 64 62 74 79 70 65 (if (eq? dbtype
efc0: 20 27 73 71 6c 69 74 65 33 29 0a 09 20 20 3b 3b 'sqlite3).. ;;
efd0: 20 54 68 65 20 27 61 75 74 6f 20 6d 65 74 68 6f The 'auto metho
efe0: 64 20 77 69 6c 6c 20 64 69 73 74 72 69 62 75 74 d will distribut
eff0: 65 20 64 62 73 20 61 63 72 6f 73 73 20 74 68 65 e dbs across the
f000: 20 64 69 73 6b 20 75 73 69 6e 67 20 68 61 73 68 disk using hash
f010: 0a 09 20 20 3b 3b 20 6f 66 20 75 73 65 72 20 68 .. ;; of user h
f020: 6f 73 74 20 61 6e 64 20 75 73 65 72 2e 20 54 4f ost and user. TO
f030: 44 4f 0a 09 20 20 3b 3b 20 28 69 66 20 28 65 71 DO.. ;; (if (eq
f040: 3f 20 64 62 66 6e 61 6d 65 20 27 61 75 74 6f 29 ? dbfname 'auto)
f050: 20 3b 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 ;; This is the
f060: 61 75 74 6f 20 61 73 73 69 67 6e 6d 65 6e 74 20 auto assignment
f070: 6f 66 20 61 20 64 62 20 62 61 73 65 64 20 6f 6e of a db based on
f080: 20 68 61 73 68 20 6f 66 20 49 50 0a 09 20 20 28 hash of IP.. (
f090: 6c 65 74 20 28 28 64 62 70 61 74 68 20 28 70 61 let ((dbpath (pa
f0a0: 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 thname-directory
f0b0: 20 64 62 66 6e 61 6d 65 29 29 29 20 20 3b 3b 20 dbfname))) ;;
f0c0: 64 6f 20 61 20 63 6f 75 70 6c 65 20 73 61 6e 69 do a couple sani
f0d0: 74 79 20 63 68 65 63 6b 73 20 68 65 72 65 20 74 ty checks here t
f0e0: 6f 20 6d 61 6b 65 20 73 65 74 74 69 6e 67 20 75 o make setting u
f0f0: 70 20 65 61 73 69 65 72 0a 09 20 20 20 20 28 69 p easier.. (i
f100: 66 20 64 65 62 75 67 6d 6f 64 65 20 28 73 65 73 f debugmode (ses
f110: 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 49 sion:log self "I
f120: 4e 46 4f 3a 20 73 65 74 74 69 6e 67 20 75 70 20 NFO: setting up
f130: 66 6f 72 20 73 71 6c 69 74 65 33 20 64 62 20 61 for sqlite3 db a
f140: 63 63 65 73 73 20 74 6f 20 22 20 64 62 66 6e 61 ccess to " dbfna
f150: 6d 65 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e me)).. (if (n
f160: 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ot (file-write-a
f170: 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 29 0a ccess? dbpath)).
f180: 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ..(session:log s
f190: 65 6c 66 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 elf "WARNING: Ca
f1a0: 6e 6e 6f 74 20 77 72 69 74 65 20 74 6f 20 22 20 nnot write to "
f1b0: 64 62 70 61 74 68 29 0a 09 09 28 69 66 20 64 65 dbpath)...(if de
f1c0: 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f 6e bugmode (session
f1d0: 3a 6c 6f 67 20 73 65 6c 66 20 22 49 4e 46 4f 3a :log self "INFO:
f1e0: 20 22 20 64 62 70 61 74 68 20 22 20 69 73 20 77 " dbpath " is w
f1f0: 72 69 74 65 61 62 6c 65 22 29 29 29 0a 09 20 20 riteable")))..
f200: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
f210: 74 73 3f 20 64 62 66 6e 61 6d 65 29 0a 09 09 28 ts? dbfname)...(
f220: 62 65 67 69 6e 0a 09 09 20 20 3b 3b 20 28 73 65 begin... ;; (se
f230: 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 ssion:log self "
f240: 73 65 74 74 69 6e 67 20 64 62 65 78 69 73 74 73 setting dbexists
f250: 20 74 6f 20 23 74 22 29 0a 09 09 20 20 28 73 65 to #t")... (se
f260: 74 21 20 64 62 65 78 69 73 74 73 20 23 74 29 29 t! dbexists #t))
f270: 29 29 0a 09 20 20 28 69 66 20 64 65 62 75 67 6d )).. (if debugm
f280: 6f 64 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ode (session:log
f290: 20 73 65 6c 66 20 22 49 4e 46 4f 3a 20 73 65 74 self "INFO: set
f2a0: 74 69 6e 67 20 75 70 20 66 6f 72 20 70 67 20 64 ting up for pg d
f2b0: 62 20 61 63 63 65 73 73 20 74 6f 20 61 63 63 6f b access to acco
f2c0: 75 6e 74 20 69 6e 66 6f 20 22 20 64 62 69 6e 69 unt info " dbini
f2d0: 74 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 64 t))). (if d
f2e0: 65 62 75 67 6d 6f 64 65 20 28 73 65 73 73 69 6f ebugmode (sessio
f2f0: 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 64 62 74 79 n:log self "dbty
f300: 70 65 3a 20 22 20 64 62 74 79 70 65 20 22 20 64 pe: " dbtype " d
f310: 62 66 6e 61 6d 65 3a 20 22 20 64 62 66 6e 61 6d bfname: " dbfnam
f320: 65 20 22 20 64 62 65 78 69 73 74 73 3a 20 22 20 e " dbexists: "
f330: 64 62 65 78 69 73 74 73 29 29 29 0a 20 20 20 20 dbexists))).
f340: 28 73 64 61 74 2d 73 65 74 2d 63 6f 6e 6e 21 20 (sdat-set-conn!
f350: 73 65 6c 66 20 28 64 62 69 3a 6f 70 65 6e 20 64 self (dbi:open d
f360: 62 74 79 70 65 20 64 62 69 6e 69 74 29 29 0a 20 btype dbinit)).
f370: 20 20 20 28 73 65 74 21 20 2a 64 62 2a 20 28 73 (set! *db* (s
f380: 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c dat-get-conn sel
f390: 66 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 f)). (if (and
f3a0: 20 28 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 (not dbexists)(
f3b0: 65 71 3f 20 64 62 74 79 70 65 20 27 73 71 6c 69 eq? dbtype 'sqli
f3c0: 74 65 33 29 29 0a 20 09 28 62 65 67 69 6e 0a 09 te3)). .(begin..
f3d0: 20 20 28 70 72 69 6e 74 20 22 57 41 52 4e 49 4e (print "WARNIN
f3e0: 47 3a 20 53 65 74 74 69 6e 67 20 75 70 20 73 65 G: Setting up se
f3f0: 73 73 69 6f 6e 20 64 62 20 77 69 74 68 20 73 71 ssion db with sq
f400: 6c 69 74 65 33 22 29 0a 09 20 20 28 73 65 73 73 lite3").. (sess
f410: 69 6f 6e 3a 73 65 74 75 70 2d 64 62 20 73 65 6c ion:setup-db sel
f420: 66 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f f))). (sessio
f430: 6e 3a 70 72 6f 63 65 73 73 2d 75 72 6c 2d 70 61 n:process-url-pa
f440: 74 68 20 73 65 6c 66 29 0a 20 20 20 20 28 73 65 th self). (se
f450: 73 73 69 6f 6e 3a 73 65 74 75 70 2d 73 65 73 73 ssion:setup-sess
f460: 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 0a 20 20 ion-key self).
f470: 20 20 3b 3b 20 63 61 70 74 75 72 65 20 73 74 64 ;; capture std
f480: 69 6e 20 69 66 20 74 68 69 73 20 69 73 20 61 20 in if this is a
f490: 50 4f 53 54 0a 20 20 20 20 28 73 64 61 74 2d 73 POST. (sdat-s
f4a0: 65 74 2d 72 65 71 75 65 73 74 2d 6d 65 74 68 6f et-request-metho
f4b0: 64 21 20 73 65 6c 66 20 28 67 65 74 2d 65 6e 76 d! self (get-env
f4c0: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
f4d0: 65 20 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f e "REQUEST_METHO
f4e0: 44 22 29 29 0a 20 20 20 20 28 73 64 61 74 2d 73 D")). (sdat-s
f4f0: 65 74 2d 66 6f 72 6d 64 61 74 21 20 73 65 6c 66 et-formdat! self
f500: 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 (formdat:load-a
f510: 6c 6c 29 29 29 29 0a 0a 3b 3b 20 73 65 74 75 70 ll))))..;; setup
f520: 20 74 68 65 20 64 62 20 77 69 74 68 20 73 65 73 the db with ses
f530: 73 69 6f 6e 20 74 61 62 6c 65 73 2c 20 77 6f 72 sion tables, wor
f540: 6b 73 20 66 6f 72 20 73 71 6c 69 74 65 20 6f 6e ks for sqlite on
f550: 6c 79 20 72 69 67 68 74 20 6e 6f 77 0a 28 64 65 ly right now.(de
f560: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
f570: 74 75 70 2d 64 62 20 73 65 6c 66 29 0a 20 20 28 tup-db self). (
f580: 6c 65 74 20 28 28 63 6f 6e 6e 20 28 73 64 61 74 let ((conn (sdat
f590: 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 -get-conn self))
f5a0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
f5b0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 . (lambda (s
f5c0: 74 6d 74 29 0a 20 20 20 20 20 20 20 28 64 62 69 tmt). (dbi
f5d0: 3a 65 78 65 63 20 63 6f 6e 6e 20 73 74 6d 74 29 :exec conn stmt)
f5e0: 29 0a 20 20 20 20 20 28 6c 69 73 74 20 22 43 52 ). (list "CR
f5f0: 45 41 54 45 20 54 41 42 4c 45 20 73 65 73 73 69 EATE TABLE sessi
f600: 6f 6e 5f 76 61 72 73 20 28 69 64 20 49 4e 54 45 on_vars (id INTE
f610: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
f620: 73 65 73 73 69 6f 6e 5f 69 64 20 49 4e 54 45 47 session_id INTEG
f630: 45 52 2c 70 61 67 65 20 54 45 58 54 2c 6b 65 79 ER,page TEXT,key
f640: 20 54 45 58 54 2c 76 61 6c 75 65 20 54 45 58 54 TEXT,value TEXT
f650: 29 3b 22 0a 09 20 20 20 22 43 52 45 41 54 45 20 );".. "CREATE
f660: 54 41 42 4c 45 20 73 65 73 73 69 6f 6e 73 20 28 TABLE sessions (
f670: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
f680: 52 59 20 4b 45 59 2c 73 65 73 73 69 6f 6e 5f 6b RY KEY,session_k
f690: 65 79 20 54 45 58 54 2c 6c 61 73 74 5f 75 73 65 ey TEXT,last_use
f6a0: 64 20 54 49 4d 45 53 54 41 4d 50 29 3b 22 0a 20 d TIMESTAMP);".
f6b0: 20 20 20 20 20 20 20 20 20 20 22 43 52 45 41 54 "CREAT
f6c0: 45 20 54 41 42 4c 45 20 6d 65 74 61 64 61 74 61 E TABLE metadata
f6d0: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
f6e0: 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 MARY KEY,key TEX
f6f0: 54 2c 76 61 6c 75 65 20 54 45 58 54 29 3b 22 29 T,value TEXT);")
f700: 29 29 29 0a 3b 3b 20 20 3b 3b 20 69 66 20 77 65 ))).;; ;; if we
f710: 20 68 61 76 65 20 61 20 73 65 73 73 69 6f 6e 5f have a session_
f720: 6b 65 79 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 key look up the
f730: 73 65 73 73 69 6f 6e 2d 69 64 20 61 6e 64 20 73 session-id and s
f740: 74 6f 72 65 20 69 74 0a 3b 3b 20 20 28 73 64 61 tore it.;; (sda
f750: 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 t-set-session-id
f760: 21 20 73 65 6c 66 20 28 73 65 73 73 69 6f 6e 3a ! self (session:
f770: 67 65 74 2d 69 64 20 73 65 6c 66 29 29 29 0a 0a get-id self)))..
f780: 3b 3b 20 6f 6e 6c 79 20 73 65 74 20 73 65 73 73 ;; only set sess
f790: 69 6f 6e 2d 63 6f 6f 6b 69 65 20 77 68 65 6e 20 ion-cookie when
f7a0: 61 20 6e 65 77 20 73 65 73 73 69 6f 6e 20 69 73 a new session is
f7b0: 20 63 72 65 61 74 65 64 0a 28 64 65 66 69 6e 65 created.(define
f7c0: 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 2d (session:setup-
f7d0: 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 session-key self
f7e0: 29 20 20 0a 20 20 28 6c 65 74 2a 20 28 28 73 6b ) . (let* ((sk
f7f0: 20 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 61 (session:extra
f800: 63 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 ct-session-key s
f810: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 elf)). (
f820: 73 69 64 20 28 69 66 20 73 6b 20 28 73 65 73 73 sid (if sk (sess
f830: 69 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 ion:get-id self
f840: 73 6b 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 sk) #f))). (i
f850: 66 20 28 6e 6f 74 20 73 69 64 29 20 3b 3b 20 6e f (not sid) ;; n
f860: 65 65 64 20 61 20 6e 65 77 20 6b 65 79 0a 20 20 eed a new key.
f870: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 (let* ((ne
f880: 77 2d 6b 65 79 20 28 73 65 73 73 69 6f 6e 3a 67 w-key (session:g
f890: 65 74 2d 6e 65 77 2d 6b 65 79 20 73 65 6c 66 29 et-new-key self)
f8a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
f8b0: 20 28 6e 65 77 2d 73 69 64 20 28 73 65 73 73 69 (new-sid (sessi
f8c0: 6f 6e 3a 67 65 74 2d 69 64 20 73 65 6c 66 20 6e on:get-id self n
f8d0: 65 77 2d 6b 65 79 29 29 29 0a 20 20 20 20 20 20 ew-key))).
f8e0: 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 (sdat-set-se
f8f0: 73 73 69 6f 6e 2d 6b 65 79 21 20 73 65 6c 66 20 ssion-key! self
f900: 6e 65 77 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 new-key).
f910: 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 (sdat-set-ses
f920: 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 6e 65 sion-id! self ne
f930: 77 2d 73 69 64 29 0a 20 20 20 20 20 20 20 20 20 w-sid).
f940: 20 28 73 64 61 74 2d 73 65 74 2d 73 65 73 73 69 (sdat-set-sessi
f950: 6f 6e 2d 63 6f 6f 6b 69 65 21 20 73 65 6c 66 20 on-cookie! self
f960: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 6f (session:make-co
f970: 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a 20 20 20 okie self))).
f980: 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 2d 73 (sdat-set-s
f990: 65 73 73 69 6f 6e 2d 69 64 21 20 73 65 6c 66 20 ession-id! self
f9a0: 73 69 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 sid))))..(define
f9b0: 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 63 (session:make-c
f9c0: 6f 6f 6b 69 65 20 73 65 6c 66 29 0a 20 20 3b 3b ookie self). ;;
f9d0: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 73 65 (list (conc "se
f9e0: 73 73 69 6f 6e 5f 6b 65 79 3d 22 20 28 73 64 61 ssion_key=" (sda
f9f0: 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-get-session-ke
fa00: 79 20 73 65 6c 66 29 20 22 3b 20 50 61 74 68 3d y self) "; Path=
fa10: 2f 3b 20 44 6f 6d 61 69 6e 3d 2e 22 20 28 73 64 /; Domain=." (sd
fa20: 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 65 at-get-domain se
fa30: 6c 66 29 20 22 3b 20 4d 61 78 2d 41 67 65 3d 22 lf) "; Max-Age="
fa40: 20 28 2a 20 38 36 34 30 30 20 31 34 29 20 22 3b (* 86400 14) ";
fa50: 20 56 65 72 73 69 6f 6e 3d 31 22 29 29 29 20 0a Version=1"))) .
fa60: 20 20 3b 3b 20 41 63 63 6f 72 64 69 6e 67 20 74 ;; According t
fa70: 6f 20 0a 20 20 3b 3b 20 20 20 20 68 74 74 70 3a o . ;; http:
fa80: 2f 2f 77 77 77 2e 63 6f 64 65 6d 61 72 76 65 6c //www.codemarvel
fa90: 73 2e 63 6f 6d 2f 32 30 31 30 2f 31 31 2f 61 70 s.com/2010/11/ap
faa0: 61 63 68 65 2d 72 65 77 72 69 74 65 72 75 6c 65 ache-rewriterule
fab0: 2d 73 65 74 2d 61 2d 63 6f 6f 6b 69 65 2d 6f 6e -set-a-cookie-on
fac0: 2d 6c 6f 63 61 6c 68 6f 73 74 2f 0a 0a 20 20 3b -localhost/.. ;
fad0: 3b 20 20 48 65 72 65 20 61 72 65 20 74 68 65 20 ; Here are the
fae0: 32 20 28 6f 66 74 65 6e 20 6c 65 66 74 20 6f 75 2 (often left ou
faf0: 74 29 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 t) requirements
fb00: 74 6f 20 73 65 74 20 61 20 63 6f 6f 6b 69 65 20 to set a cookie
fb10: 75 73 69 6e 67 0a 20 20 3b 3b 20 20 68 74 74 70 using. ;; http
fb20: 64 1b 2d 46 ef bf bd 73 20 72 65 77 72 69 74 65 d.-F�s rewrite
fb30: 20 72 75 6c 65 20 28 6d 6f 64 5f 72 65 77 72 69 rule (mod_rewri
fb40: 74 65 29 2c 20 77 68 69 6c 65 20 77 6f 72 6b 69 te), while worki
fb50: 6e 67 20 6f 6e 20 6c 6f 63 61 6c 68 6f 73 74 3a ng on localhost:
fb60: 1b 2d 41 0a 20 20 3b 3b 0a 20 20 3b 3b 20 20 55 .-A. ;;. ;; U
fb70: 73 65 20 74 68 65 20 49 50 20 31 32 37 2e 30 2e se the IP 127.0.
fb80: 30 2e 31 20 69 6e 73 74 65 61 64 20 6f 66 20 6c 0.1 instead of l
fb90: 6f 63 61 6c 68 6f 73 74 2f 6d 61 63 68 69 6e 65 ocalhost/machine
fba0: 2d 6e 61 6d 65 20 61 73 20 74 68 65 0a 20 20 3b -name as the. ;
fbb0: 3b 20 20 64 6f 6d 61 69 6e 3b 20 65 2e 67 2e 20 ; domain; e.g.
fbc0: 5b 43 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 [CO=someCookie:s
fbd0: 6f 6d 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 omeValue:127.0.0
fbe0: 2e 31 3a 32 3a 2f 5d 2c 20 77 68 69 63 68 20 73 .1:2:/], which s
fbf0: 61 79 73 0a 20 20 3b 3b 20 20 63 72 65 61 74 65 ays. ;; create
fc00: 20 61 20 63 6f 6f 6b 69 65 20 1b 2d 59 ef bf bd a cookie .-Y�
fc10: 73 6f 6d 65 43 6f 6f 6b 69 65 ef bf bd 20 77 69 someCookie� wi
fc20: 74 68 20 76 61 6c 75 65 20 ef bf bd 73 6f 6d 65 th value �some
fc30: 56 61 6c 75 65 ef bf bd 20 66 6f 72 20 74 68 65 Value� for the
fc40: 0a 20 20 3b 3b 20 20 64 6f 6d 61 69 6e 20 ef bf . ;; domain ï¿
fc50: bd 31 32 37 2e 30 2e 30 2e 31 1b 24 42 21 6d 1b ½127.0.0.1.$B!m.
fc60: 28 42 20 68 61 76 69 6e 67 20 61 20 6c 69 66 65 (B having a life
fc70: 20 74 69 6d 65 20 6f 66 20 32 20 6d 69 6e 73 2c time of 2 mins,
fc80: 20 66 6f 72 20 61 6e 79 20 70 61 74 68 20 69 6e for any path in
fc90: 0a 20 20 3b 3b 20 20 74 68 65 20 64 6f 6d 61 69 . ;; the domai
fca0: 6e 20 28 70 61 74 68 3d 2f 29 2e 20 28 4f 62 76 n (path=/). (Obv
fcb0: 69 6f 75 73 6c 79 20 79 6f 75 20 77 69 6c 6c 20 iously you will
fcc0: 68 61 76 65 20 74 6f 20 72 75 6e 20 74 68 65 0a have to run the.
fcd0: 20 20 3b 3b 20 20 61 70 70 6c 69 63 61 74 69 6f ;; applicatio
fce0: 6e 20 77 69 74 68 20 74 68 69 73 20 76 61 6c 75 n with this valu
fcf0: 65 20 69 6e 20 74 68 65 20 55 52 4c 29 0a 20 20 e in the URL).
fd00: 3b 3b 0a 20 20 3b 3b 20 20 54 6f 20 6d 61 6b 65 ;;. ;; To make
fd10: 20 61 20 73 65 73 73 69 6f 6e 20 63 6f 6f 6b 69 a session cooki
fd20: 65 2c 20 6c 69 6d 69 74 20 74 68 65 20 66 6c 61 e, limit the fla
fd30: 67 20 73 74 61 74 65 6d 65 6e 74 20 74 6f 20 6a g statement to j
fd40: 75 73 74 20 74 68 72 65 65 0a 20 20 3b 3b 20 20 ust three. ;;
fd50: 61 74 74 72 69 62 75 74 65 73 3a 20 6e 61 6d 65 attributes: name
fd60: 2c 20 76 61 6c 75 65 20 61 6e 64 20 64 6f 6d 61 , value and doma
fd70: 69 6e 2e 20 65 2e 67 0a 20 20 3b 3b 20 20 5b 43 in. e.g. ;; [C
fd80: 4f 3d 73 6f 6d 65 43 6f 6f 6b 69 65 3a 73 6f 6d O=someCookie:som
fd90: 65 56 61 6c 75 65 3a 31 32 37 2e 30 2e 30 2e 31 eValue:127.0.0.1
fda0: 5d 20 1b 25 47 e2 80 93 1b 25 40 20 41 6e 79 20 ] .%G–.%@ Any
fdb0: 66 75 72 74 68 65 72 0a 20 20 3b 3b 20 20 73 65 further. ;; se
fdc0: 74 74 69 6e 67 73 2c 20 61 70 61 63 68 65 20 77 ttings, apache w
fdd0: 72 69 74 65 73 20 61 6e ef bf bd 20 65 78 70 69 rites an� expi
fde0: 72 65 73 ef bf bd 20 61 74 74 72 69 62 75 74 65 res� attribute
fdf0: 20 66 6f 72 20 74 68 65 20 73 65 74 2d 63 6f 6f for the set-coo
fe00: 6b 69 65 0a 20 20 3b 3b 20 20 68 65 61 64 65 72 kie. ;; header
fe10: 2c 20 77 68 69 63 68 20 6d 61 6b 65 73 20 74 68 , which makes th
fe20: 65 20 63 6f 6f 6b 69 65 20 61 20 70 65 72 73 69 e cookie a persi
fe30: 73 74 65 6e 74 20 6f 6e 65 20 28 6e 6f 74 20 72 stent one (not r
fe40: 65 61 6c 6c 79 0a 20 20 3b 3b 20 20 70 65 72 73 eally. ;; pers
fe50: 69 73 74 65 6e 74 2c 20 61 73 20 74 68 65 20 65 istent, as the e
fe60: 78 70 69 72 65 73 20 76 61 6c 75 65 20 73 65 74 xpires value set
fe70: 20 69 73 20 74 68 65 20 63 75 72 72 65 6e 74 20 is the current
fe80: 73 65 72 76 65 72 20 74 69 6d 65 0a 20 20 3b 3b server time. ;;
fe90: 20 20 1b 25 47 e2 80 93 1b 25 40 20 73 6f 20 79 .%G–.%@ so y
fea0: 6f 75 20 64 6f 6e 1b 2d 46 1b 2d 46 ef bf bd 74 ou don.-F.-F�t
feb0: 20 65 76 65 6e 20 67 65 74 20 74 6f 20 73 65 65 even get to see
fec0: 20 79 6f 75 72 20 63 6f 6f 6b 69 65 21 29 1b 2d your cookie!).-
fed0: 41 0a 20 20 28 6c 69 73 74 20 28 73 74 72 69 6e A. (list (strin
fee0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 20 g-substitute ..
fef0: 22 3b 22 20 22 3b 20 22 20 0a 09 20 28 63 61 72 ";" "; " .. (car
ff00: 20 28 63 6f 6e 73 74 72 75 63 74 2d 63 6f 6f 6b (construct-cook
ff10: 69 65 2d 73 74 72 69 6e 67 20 0a 09 20 20 20 20 ie-string ..
ff20: 20 20 20 3b 3b 20 77 61 72 6e 69 6e 67 21 20 6d ;; warning! m
ff30: 65 73 73 69 6e 67 20 75 70 20 74 68 69 73 20 69 essing up this i
ff40: 74 74 79 20 62 69 74 74 79 20 62 69 74 20 6f 66 tty bitty bit of
ff50: 20 63 6f 64 65 20 77 69 6c 6c 20 63 6f 73 74 20 code will cost
ff60: 6d 75 63 68 20 74 69 6d 65 21 0a 09 20 20 20 20 much time!..
ff70: 20 20 20 60 28 28 22 73 65 73 73 69 6f 6e 5f 6b `(("session_k
ff80: 65 79 22 20 2c 28 73 64 61 74 2d 67 65 74 2d 73 ey" ,(sdat-get-s
ff90: 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
ffa0: 0a 09 09 20 20 65 78 70 69 72 65 73 3a 20 2c 28 ... expires: ,(
ffb0: 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e + (current-secon
ffc0: 64 73 29 20 28 2a 20 31 34 20 38 36 34 30 30 29 ds) (* 14 86400)
ffd0: 29 20 0a 09 09 20 20 3b 3b 20 6d 61 78 2d 61 67 ) ... ;; max-ag
ffe0: 65 3a 20 28 2a 20 31 34 20 38 36 34 30 30 29 0a e: (* 14 86400).
fff0: 09 09 20 20 70 61 74 68 3a 20 22 2f 22 20 3b 3b .. path: "/" ;;
10000 20 0a 09 09 20 20 64 6f 6d 61 69 6e 3a 20 2c 28 ... domain: ,(
10010 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 2e string-append ".
10020 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f 6d 61 " (sdat-get-doma
10030 69 6e 20 73 65 6c 66 29 29 0a 09 09 20 20 76 65 in self))... ve
10040 72 73 69 6f 6e 3a 20 31 29 29 20 30 29 29 29 29 rsion: 1)) 0))))
10050 29 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 20 )..;; look up a
10060 67 69 76 65 6e 20 73 65 73 73 69 6f 6e 20 6b 65 given session ke
10070 79 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 65 y and return the
10080 20 69 64 20 69 66 20 66 6f 75 6e 64 2c 20 23 66 id if found, #f
10090 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 28 64 if not found.(d
100a0 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
100b0 65 74 2d 69 64 20 73 65 6c 66 20 73 65 73 73 69 et-id self sessi
100c0 6f 6e 2d 6b 65 79 29 0a 20 20 3b 3b 20 28 6c 65 on-key). ;; (le
100d0 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 t ((session-key
100e0 28 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f (sdat-get-sessio
100f0 6e 2d 6b 65 79 20 73 65 6c 66 29 29 29 0a 20 20 n-key self))).
10100 28 69 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 0a (if session-key.
10110 20 20 20 20 20 20 28 6c 65 74 20 28 28 71 75 65 (let ((que
10120 72 79 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ry (string-appen
10130 64 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f d "SELECT id FRO
10140 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 M sessions WHERE
10150 20 73 65 73 73 69 6f 6e 5f 6b 65 79 3d 27 22 20 session_key='"
10160 73 65 73 73 69 6f 6e 2d 6b 65 79 20 22 27 22 29 session-key "'")
10170 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ). (c
10180 6f 6e 6e 20 28 73 64 61 74 2d 67 65 74 2d 63 6f onn (sdat-get-co
10190 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 20 nn self)).
101a0 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 23 66 (result #f
101b0 29 29 0a 09 28 64 62 69 3a 66 6f 72 2d 65 61 63 ))..(dbi:for-eac
101c0 68 2d 72 6f 77 20 0a 09 20 28 6c 61 6d 62 64 61 h-row .. (lambda
101d0 20 28 74 75 70 6c 65 29 0a 09 20 20 20 28 73 65 (tuple).. (se
101e0 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 74 6f t! result (vecto
101f0 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
10200 0a 09 20 63 6f 6e 6e 20 71 75 65 72 79 29 0a 09 .. conn query)..
10210 28 69 66 20 72 65 73 75 6c 74 20 28 64 62 69 3a (if result (dbi:
10220 65 78 65 63 20 63 6f 6e 6e 20 28 63 6f 6e 63 20 exec conn (conc
10230 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 73 "UPDATE sessions
10240 20 53 45 54 20 6c 61 73 74 5f 75 73 65 64 3d 22 SET last_used="
10250 20 28 64 62 69 3a 6e 6f 77 20 63 6f 6e 6e 29 20 (dbi:now conn)
10260 22 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f " WHERE session_
10270 6b 65 79 3d 3f 3b 22 29 20 73 65 73 73 69 6f 6e key=?;") session
10280 2d 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 72 -key)). r
10290 65 73 75 6c 74 29 0a 20 20 20 20 20 20 23 66 29 esult). #f)
102a0 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 )..;; .(define (
102b0 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
102c0 75 72 6c 2d 70 61 74 68 20 73 65 6c 66 29 0a 20 url-path self).
102d0 20 28 6c 65 74 20 28 28 70 61 74 68 2d 69 6e 66 (let ((path-inf
102e0 6f 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f o (get-enviro
102f0 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
10300 50 41 54 48 5f 49 4e 46 4f 22 29 29 0a 09 28 71 PATH_INFO"))..(q
10310 75 65 72 79 2d 73 74 72 69 6e 67 20 28 67 65 74 uery-string (get
10320 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
10330 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 iable "QUERY_STR
10340 49 4e 47 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 ING"))). ;; (
10350 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 session:log self
10360 20 22 70 61 74 68 2d 69 6e 66 6f 3d 22 20 70 61 "path-info=" pa
10370 74 68 2d 69 6e 66 6f 20 22 20 71 75 65 72 79 2d th-info " query-
10380 73 74 72 69 6e 67 3d 22 20 71 75 65 72 79 2d 73 string=" query-s
10390 74 72 69 6e 67 29 0a 20 20 20 20 28 69 66 20 70 tring). (if p
103a0 61 74 68 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 ath-info..(let*
103b0 28 28 70 61 72 74 73 20 20 20 20 28 73 74 72 69 ((parts (stri
103c0 6e 67 2d 73 70 6c 69 74 20 70 61 74 68 2d 69 6e ng-split path-in
103d0 66 6f 20 22 2f 22 29 29 0a 09 20 20 20 20 20 20 fo "/"))..
103e0 20 28 6e 75 6d 70 61 72 74 73 20 28 6c 65 6e 67 (numparts (leng
103f0 74 68 20 70 61 72 74 73 29 29 29 0a 09 20 20 28 th parts))).. (
10400 69 66 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 30 if (> numparts 0
10410 29 0a 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 ).. (sdat-s
10420 65 74 2d 70 61 67 65 21 20 73 65 6c 66 20 28 63 et-page! self (c
10430 61 72 20 70 61 72 74 73 29 29 29 0a 09 20 20 3b ar parts))).. ;
10440 3b 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 ; (session:log s
10450 65 6c 66 20 22 75 72 6c 2d 70 61 74 68 3d 22 20 elf "url-path="
10460 75 72 6c 2d 70 61 74 68 20 22 20 70 61 72 74 73 url-path " parts
10470 3d 22 20 70 61 72 74 73 29 0a 09 20 20 28 69 66 =" parts).. (if
10480 20 28 3e 20 6e 75 6d 70 61 72 74 73 20 31 29 0a (> numparts 1).
10490 09 20 20 20 20 20 20 28 73 64 61 74 2d 73 65 74 . (sdat-set
104a0 2d 70 61 74 68 2d 70 61 72 61 6d 73 21 20 73 65 -path-params! se
104b0 6c 66 20 28 63 64 72 20 70 61 72 74 73 29 29 29 lf (cdr parts)))
104c0 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 71 . (if q
104d0 75 65 72 79 2d 73 74 72 69 6e 67 0a 20 20 20 20 uery-string.
104e0 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
104f0 73 65 74 2d 70 61 72 61 6d 73 21 20 73 65 6c 66 set-params! self
10500 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 71 (string-split q
10510 75 65 72 79 2d 73 74 72 69 6e 67 20 22 26 22 29 uery-string "&")
10520 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 47 59 ))))))..;; BUGGY
10530 21 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 !.(define (sessi
10540 6f 6e 3a 67 65 74 2d 6e 65 77 2d 6b 65 79 20 73 on:get-new-key s
10550 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 63 6f elf). (let ((co
10560 6e 6e 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 nn (sdat-get-c
10570 6f 6e 6e 20 73 65 6c 66 29 29 0a 20 20 20 20 20 onn self)).
10580 20 20 20 28 74 6d 70 6b 65 79 20 28 73 65 73 73 (tmpkey (sess
10590 69 6f 6e 3a 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 ion:make-rand-st
105a0 72 69 6e 67 20 32 30 29 29 0a 20 20 20 20 20 20 ring 20)).
105b0 20 20 28 73 74 61 74 75 73 20 23 66 29 29 0a 20 (status #f)).
105c0 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
105d0 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
105e0 70 6c 65 29 0a 09 09 09 28 73 65 74 21 20 73 74 ple)....(set! st
105f0 61 74 75 73 20 23 74 29 29 0a 09 09 20 20 20 20 atus #t))...
10600 20 20 63 6f 6e 6e 20 28 73 74 72 69 6e 67 2d 61 conn (string-a
10610 70 70 65 6e 64 20 22 49 4e 53 45 52 54 20 49 4e ppend "INSERT IN
10620 54 4f 20 73 65 73 73 69 6f 6e 73 20 28 73 65 73 TO sessions (ses
10630 73 69 6f 6e 5f 6b 65 79 29 20 56 41 4c 55 45 53 sion_key) VALUES
10640 20 28 27 22 20 74 6d 70 6b 65 79 20 22 27 29 22 ('" tmpkey "')"
10650 29 29 0a 20 20 20 20 74 6d 70 6b 65 79 29 29 0a )). tmpkey)).
10660 0a 3b 3b 20 72 65 74 75 72 6e 73 20 73 65 73 73 .;; returns sess
10670 69 6f 6e 20 6b 65 79 20 49 46 46 20 69 74 20 69 ion key IFF it i
10680 73 20 69 6e 20 74 68 65 20 48 54 54 50 5f 43 4f s in the HTTP_CO
10690 4f 4b 49 45 20 0a 28 64 65 66 69 6e 65 20 28 73 OKIE .(define (s
106a0 65 73 73 69 6f 6e 3a 65 78 74 72 61 63 74 2d 73 ession:extract-s
106b0 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c 66 29 ession-key self)
106c0 0a 20 20 28 6c 65 74 20 28 28 68 74 74 70 2d 63 . (let ((http-c
106d0 6f 6f 6b 69 65 20 28 67 65 74 2d 65 6e 76 69 72 ookie (get-envir
106e0 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
106f0 22 48 54 54 50 5f 43 4f 4f 4b 49 45 22 29 29 29 "HTTP_COOKIE")))
10700 0a 20 20 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 . ;; (err:log
10710 20 22 68 74 74 70 2d 63 6f 6f 6b 69 65 3a 20 22 "http-cookie: "
10720 20 68 74 74 70 2d 63 6f 6f 6b 69 65 29 0a 20 20 http-cookie).
10730 20 20 28 69 66 20 68 74 74 70 2d 63 6f 6f 6b 69 (if http-cooki
10740 65 0a 20 20 20 20 20 20 20 20 28 73 65 73 73 69 e. (sessi
10750 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 on:extract-key-f
10760 72 6f 6d 2d 70 61 72 61 6d 20 73 65 6c 66 20 28 rom-param self (
10770 73 74 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 string-split-fie
10780 6c 64 73 20 20 22 3b 5c 5c 73 2b 22 20 68 74 74 lds ";\\s+" htt
10790 70 2d 63 6f 6f 6b 69 65 20 69 6e 66 69 78 3a 29 p-cookie infix:)
107a0 20 22 73 65 73 73 69 6f 6e 5f 6b 65 79 22 29 0a "session_key").
107b0 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 #f)))..(
107c0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
107d0 67 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 get-session-id s
107e0 65 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 elf session-key)
107f0 0a 20 20 28 6c 65 74 20 28 28 71 75 65 72 79 20 . (let ((query
10800 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
10810 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 20 73 sessions WHERE s
10820 65 73 73 69 6f 6e 5f 6b 65 79 3d 3f 3b 22 29 0a ession_key=?;").
10830 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 (result
10840 23 66 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 #f)). ;;
10850 28 70 67 3a 71 75 65 72 79 2d 66 6f 72 2d 65 61 (pg:query-for-ea
10860 63 68 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c ch (lambda (tupl
10870 65 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 e). ;;
10880 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10890 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
108a0 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
108b0 65 20 30 29 29 29 20 3b 3b 20 28 76 65 63 74 6f e 0))) ;; (vecto
108c0 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 29 29 r-ref tuple 0)))
108d0 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
108e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
108f0 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 s:sqlparam query
10900 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 session-key).
10910 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
10920 20 20 20 20 20 20 20 20 20 20 20 20 28 73 64 61 (sda
10930 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 t-get-conn self)
10940 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ). ;;
10950 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10960 63 6f 6e 6e 29 0a 20 20 20 20 28 64 62 69 3a 66 conn). (dbi:f
10970 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 6d or-each-row (lam
10980 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 28 bda (tuple)....(
10990 73 65 74 21 20 72 65 73 75 6c 74 20 28 76 65 63 set! result (vec
109a0 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 20 30 29 tor-ref tuple 0)
109b0 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 )) ;; (vector-re
109c0 66 20 74 75 70 6c 65 20 30 29 29 29 0a 09 09 20 f tuple 0)))...
109d0 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 63 (sdat-get-c
109e0 6f 6e 6e 20 73 65 6c 66 29 0a 09 09 20 20 20 20 onn self)...
109f0 20 20 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 (s:sqlparam qu
10a00 65 72 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 ery session-key)
10a10 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a ). result))..
10a20 3b 3b 20 64 65 6c 65 74 65 20 61 6c 6c 20 72 65 ;; delete all re
10a30 63 6f 72 64 73 20 66 6f 72 20 61 20 73 65 73 73 cords for a sess
10a40 69 6f 6e 0a 3b 3b 20 0a 3b 3b 20 4e 45 45 44 53 ion.;; .;; NEEDS
10a50 20 54 4f 20 42 45 20 54 52 41 4e 53 41 43 54 49 TO BE TRANSACTI
10a60 4f 4e 49 5a 45 44 21 0a 3b 3b 0a 28 64 65 66 69 ONIZED!.;;.(defi
10a70 6e 65 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 ne (session:dele
10a80 74 65 2d 73 65 73 73 69 6f 6e 20 73 65 6c 66 20 te-session self
10a90 73 65 73 73 69 6f 6e 2d 6b 65 79 29 0a 20 20 28 session-key). (
10aa0 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 let ((session-id
10ab0 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 (session:get-se
10ac0 73 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 ssion-id self se
10ad0 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 20 20 20 20 ssion-key)).
10ae0 20 20 20 20 28 71 72 79 31 20 20 20 20 20 20 20 (qry1
10af0 20 3b 3b 20 28 63 6f 6e 63 20 22 42 45 47 49 4e ;; (conc "BEGIN
10b00 3b 22 0a 09 09 09 20 20 22 44 45 4c 45 54 45 20 ;".... "DELETE
10b10 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
10b20 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
10b30 69 64 3d 3f 3b 22 29 0a 09 28 71 72 79 32 20 20 id=?;")..(qry2
10b40 20 20 20 20 20 20 20 20 20 20 20 22 44 45 4c 45 "DELE
10b50 54 45 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 73 TE FROM sessions
10b60 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 WHERE id=?;")..
10b70 09 20 20 20 20 20 3b 3b 20 20 22 43 4f 4d 4d 49 . ;; "COMMI
10b80 54 3b 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 T;")). (c
10b90 6f 6e 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 onn
10ba0 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 (sdat-get-conn
10bb0 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
10bc0 73 65 73 73 69 6f 6e 2d 69 64 0a 20 20 20 20 20 session-id.
10bd0 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
10be0 20 20 20 20 28 64 62 69 3a 65 78 65 63 20 63 6f (dbi:exec co
10bf0 6e 6e 20 71 72 79 31 20 73 65 73 73 69 6f 6e 2d nn qry1 session-
10c00 69 64 29 20 3b 3b 20 73 65 73 73 69 6f 6e 2d 69 id) ;; session-i
10c10 64 29 0a 09 20 20 28 64 62 69 3a 65 78 65 63 20 d).. (dbi:exec
10c20 63 6f 6e 6e 20 71 72 79 32 20 73 65 73 73 69 6f conn qry2 sessio
10c30 6e 2d 69 64 29 0a 09 20 20 28 73 65 73 73 69 6f n-id).. (sessio
10c40 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 65 6c n:initialize sel
10c50 66 29 0a 09 20 20 28 73 65 73 73 69 6f 6e 3a 73 f).. (session:s
10c60 65 74 75 70 20 73 65 6c 66 29 29 29 0a 20 20 20 etup self))).
10c70 20 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 (not (session:g
10c80 65 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 et-session-id se
10c90 6c 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 lf session-key))
10ca0 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
10cb0 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 65 2d 73 session:delete-s
10cc0 65 73 73 69 6f 6e 20 73 65 6c 66 20 73 65 73 73 ession self sess
10cd0 69 6f 6e 2d 6b 65 79 29 0a 3b 3b 20 20 20 28 6c ion-key).;; (l
10ce0 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 69 64 20 et ((session-id
10cf0 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 73 65 73 (session:get-ses
10d00 73 69 6f 6e 2d 69 64 20 73 65 6c 66 20 73 65 73 sion-id self ses
10d10 73 69 6f 6e 2d 6b 65 79 29 29 0a 3b 3b 20 20 20 sion-key)).;;
10d20 20 20 20 20 20 20 28 71 75 65 72 69 65 73 20 20 (queries
10d30 20 20 28 6c 69 73 74 20 22 42 45 47 49 4e 3b 22 (list "BEGIN;"
10d40 0a 3b 3b 20 09 09 09 20 20 22 44 45 4c 45 54 45 .;; ... "DELETE
10d50 20 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 FROM session_va
10d60 72 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e rs WHERE session
10d70 5f 69 64 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 _id=?;".;;
10d80 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10d90 20 20 20 20 20 22 44 45 4c 45 54 45 20 46 52 4f "DELETE FRO
10da0 4d 20 73 65 73 73 69 6f 6e 73 20 57 48 45 52 45 M sessions WHERE
10db0 20 69 64 3d 3f 3b 22 0a 3b 3b 20 09 09 09 20 20 id=?;".;; ...
10dc0 22 43 4f 4d 4d 49 54 3b 22 29 29 0a 3b 3b 20 20 "COMMIT;")).;;
10dd0 20 20 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 (conn
10de0 20 20 20 20 20 20 20 20 20 20 28 73 64 61 74 2d (sdat-
10df0 67 65 74 2d 63 6f 6e 6e 20 73 65 6c 66 29 29 29 get-conn self)))
10e00 0a 3b 3b 20 20 20 20 20 28 69 66 20 73 65 73 73 .;; (if sess
10e10 69 6f 6e 2d 69 64 0a 3b 3b 20 20 20 20 20 20 20 ion-id.;;
10e20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 (begin.;;
10e30 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a (for-each.
10e40 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ;; (l
10e50 61 6d 62 64 61 20 28 71 75 65 72 79 29 0a 3b 3b ambda (query).;;
10e60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
10e70 62 69 3a 65 78 65 63 20 63 6f 6e 6e 20 71 75 65 bi:exec conn que
10e80 72 79 20 73 65 73 73 69 6f 6e 2d 69 64 29 29 0a ry session-id)).
10e90 3b 3b 20 09 20 20 20 71 75 65 72 69 65 73 29 0a ;; . queries).
10ea0 3b 3b 20 09 20 20 28 69 6e 69 74 69 61 6c 69 7a ;; . (initializ
10eb0 65 20 73 65 6c 66 20 27 28 29 29 0a 3b 3b 20 09 e self '()).;; .
10ec0 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 (session:setup
10ed0 20 73 65 6c 66 29 29 29 0a 3b 3b 20 20 20 20 20 self))).;;
10ee0 28 6e 6f 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 (not (session:ge
10ef0 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
10f00 66 20 73 65 73 73 69 6f 6e 2d 6b 65 79 29 29 29 f session-key)))
10f10 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
10f20 69 6f 6e 3a 65 78 74 72 61 63 74 2d 6b 65 79 20 ion:extract-key
10f30 73 65 6c 66 20 6b 65 79 29 0a 20 20 28 6c 65 74 self key). (let
10f40 20 28 28 70 61 72 61 6d 73 20 28 73 64 61 74 2d ((params (sdat-
10f50 67 65 74 2d 70 61 72 61 6d 73 20 73 65 6c 66 29 get-params self)
10f60 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a )). (session:
10f70 65 78 74 72 61 63 74 2d 6b 65 79 2d 66 72 6f 6d extract-key-from
10f80 2d 70 61 72 61 6d 20 73 65 6c 66 20 70 61 72 61 -param self para
10f90 6d 73 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 ms key)))..(defi
10fa0 6e 65 20 28 73 65 73 73 69 6f 6e 3a 65 78 74 72 ne (session:extr
10fb0 61 63 74 2d 6b 65 79 2d 66 72 6f 6d 2d 70 61 72 act-key-from-par
10fc0 61 6d 20 73 65 6c 66 20 70 61 72 61 6d 73 20 6b am self params k
10fd0 65 79 29 0a 20 20 28 6c 65 74 20 28 28 72 31 20 ey). (let ((r1
10fe0 20 20 20 20 28 72 65 67 65 78 70 20 28 73 74 72 (regexp (str
10ff0 69 6e 67 2d 61 70 70 65 6e 64 20 22 5e 22 20 6b ing-append "^" k
11000 65 79 20 22 3d 28 5b 5e 3d 5d 2b 29 24 22 29 29 ey "=([^=]+)$"))
11010 29 29 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 )). (err:log
11020 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 66 "INFO: Looking f
11030 6f 72 20 22 20 6b 65 79 20 22 20 69 6e 20 22 20 or " key " in "
11040 70 61 72 61 6d 73 29 0a 20 20 20 20 28 69 66 20 params). (if
11050 28 3c 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d (< (length param
11060 73 29 20 31 29 20 23 66 0a 09 28 6c 65 74 20 6c s) 1) #f..(let l
11070 6f 6f 70 20 28 28 68 65 61 64 20 20 20 28 63 61 oop ((head (ca
11080 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 r params))...
11090 28 74 61 69 6c 20 20 20 28 63 64 72 20 70 61 72 (tail (cdr par
110a0 61 6d 73 29 29 29 0a 09 20 20 28 6c 65 74 20 28 ams))).. (let (
110b0 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
110c0 61 74 63 68 20 72 31 20 68 65 61 64 29 29 29 0a atch r1 head))).
110d0 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 . (cond..
110e0 20 28 6d 61 74 63 68 0a 09 20 20 20 20 20 20 28 (match.. (
110f0 6c 65 74 20 28 28 73 65 73 73 69 6f 6e 2d 6b 65 let ((session-ke
11100 79 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 y (list-ref matc
11110 68 20 31 29 29 29 0a 09 09 28 65 72 72 3a 6c 6f h 1)))...(err:lo
11120 67 20 22 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 73 g "INFO: Found s
11130 65 73 73 69 6f 6e 20 6b 65 79 3d 22 20 73 65 73 ession key=" ses
11140 73 69 6f 6e 2d 6b 65 79 29 0a 09 09 28 73 64 61 sion-key)...(sda
11150 74 2d 73 65 74 2d 73 65 73 73 69 6f 6e 2d 6b 65 t-set-session-ke
11160 79 21 20 73 65 6c 66 20 28 6c 69 73 74 2d 72 65 y! self (list-re
11170 66 20 6d 61 74 63 68 20 31 29 29 0a 09 09 73 65 f match 1))...se
11180 73 73 69 6f 6e 2d 6b 65 79 29 29 0a 09 20 20 20 ssion-key))..
11190 20 20 28 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a ((null? tail).
111a0 09 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 . #f)..
111b0 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 6c (else.. (l
111c0 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 0a 09 oop (car tail)..
111d0 09 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 29 . (cdr tail))
111e0 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
111f0 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 70 61 (session:set-pa
11200 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f 6e 61 ge! self page_na
11210 6d 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d me). (sdat-set-
11220 70 61 67 65 21 20 73 65 6c 66 20 70 61 67 65 5f page! self page_
11230 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 name))..(define
11240 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 (session:close s
11250 65 6c 66 29 0a 20 20 28 64 62 69 3a 63 6c 6f 73 elf). (dbi:clos
11260 65 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e e (sdat-get-conn
11270 20 73 65 6c 66 29 29 29 0a 3b 3b 20 28 63 6c 6f self))).;; (clo
11280 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 28 se-output-port (
11290 73 64 61 74 2d 67 65 74 2d 6c 6f 67 70 74 20 73 sdat-get-logpt s
112a0 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 elf))..(define (
112b0 73 65 73 73 69 6f 6e 3a 65 72 72 2d 6d 73 67 20 session:err-msg
112c0 73 65 6c 66 20 6d 73 67 29 0a 20 20 28 68 61 73 self msg). (has
112d0 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 73 64 h-table-set! (sd
112e0 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
112f0 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f 52 5f rs self) "ERROR_
11300 4d 53 47 22 0a 09 09 20 20 20 28 73 74 72 69 6e MSG"... (strin
11310 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
11320 61 70 20 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 ap s:any->string
11330 20 6d 73 67 29 20 22 20 22 29 29 29 0a 0a 28 64 msg) " ")))..(d
11340 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 efine (session:p
11350 72 65 76 2d 65 72 72 20 73 65 6c 66 29 0a 20 20 rev-err self).
11360 28 6c 65 74 20 28 28 70 72 65 76 2d 65 72 72 20 (let ((prev-err
11370 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
11380 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d 67 65 default (sdat-ge
11390 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 t-sessionvars-be
113a0 66 6f 72 65 20 73 65 6c 66 29 20 22 45 52 52 4f fore self) "ERRO
113b0 52 5f 4d 53 47 22 20 23 66 29 29 0a 09 28 63 75 R_MSG" #f))..(cu
113c0 72 72 2d 65 72 72 20 28 68 61 73 68 2d 74 61 62 rr-err (hash-tab
113d0 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
113e0 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
113f0 76 61 72 73 20 73 65 6c 66 29 20 22 45 52 52 4f vars self) "ERRO
11400 52 5f 4d 53 47 22 20 23 66 29 29 29 0a 20 20 20 R_MSG" #f))).
11410 20 28 69 66 20 70 72 65 76 2d 65 72 72 20 70 72 (if prev-err pr
11420 65 76 2d 65 72 72 0a 09 28 69 66 20 63 75 72 72 ev-err..(if curr
11430 2d 65 72 72 20 63 75 72 72 2d 65 72 72 20 23 66 -err curr-err #f
11440 29 29 29 29 0a 0a 3b 3b 20 73 65 73 73 69 6f 6e ))))..;; session
11450 20 76 61 72 73 0a 3b 3b 20 31 2e 20 6b 65 79 73 vars.;; 1. keys
11460 20 61 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 are always a st
11470 72 69 6e 67 20 4e 4f 54 20 61 20 73 79 6d 62 6f ring NOT a symbo
11480 6c 0a 3b 3b 20 32 2e 20 76 61 6c 75 65 73 20 61 l.;; 2. values a
11490 72 65 20 61 6c 77 61 79 73 20 61 20 73 74 72 69 re always a stri
114a0 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e 20 69 73 ng conversion is
114b0 20 74 68 65 20 72 65 73 70 6f 6e 73 69 62 69 6c the responsibil
114c0 69 74 79 20 6f 66 20 74 68 65 20 0a 3b 3b 20 20 ity of the .;;
114d0 20 20 63 6f 6e 73 75 6d 69 6e 67 20 66 75 6e 63 consuming func
114e0 74 69 6f 6e 20 28 61 74 20 6c 65 61 73 74 20 66 tion (at least f
114f0 6f 72 20 6e 6f 77 2c 20 49 27 64 20 6c 69 6b 65 or now, I'd like
11500 20 74 6f 20 63 68 61 6e 67 65 20 74 68 69 73 29 to change this)
11510 0a 0a 3b 3b 20 73 65 74 20 61 20 73 65 73 73 69 ..;; set a sessi
11520 6f 6e 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 on var for the c
11530 75 72 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 urrent page.;;.(
11540 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
11550 63 75 72 72 2d 70 61 67 65 2d 73 65 74 21 20 73 curr-page-set! s
11560 65 6c 66 20 6b 65 79 20 76 61 6c 75 65 29 0a 20 elf key value).
11570 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
11580 21 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ! (sdat-get-page
11590 76 61 72 73 20 73 65 6c 66 29 20 28 73 3a 61 6e vars self) (s:an
115a0 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 28 y->string key) (
115b0 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 76 61 s:any->string va
115c0 6c 75 65 29 29 29 0a 0a 3b 3b 20 64 65 6c 20 61 lue)))..;; del a
115d0 20 76 61 72 20 66 6f 72 20 74 68 65 20 63 75 72 var for the cur
115e0 72 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 rent page.;;.(de
115f0 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 fine (session:pa
11600 67 65 2d 76 61 72 2d 64 65 6c 21 20 73 65 6c 66 ge-var-del! self
11610 20 6b 65 79 29 0a 20 20 28 68 61 73 68 2d 74 61 key). (hash-ta
11620 62 6c 65 2d 64 65 6c 65 74 65 21 20 28 73 64 61 ble-delete! (sda
11630 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 t-get-pagevars s
11640 65 6c 66 29 20 28 73 3a 61 6e 79 2d 3e 73 74 72 elf) (s:any->str
11650 69 6e 67 20 6b 65 79 29 29 29 0a 0a 3b 3b 20 67 ing key)))..;; g
11660 65 74 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 et the appropria
11670 74 65 20 68 61 73 68 20 67 69 76 65 6e 20 61 20 te hash given a
11680 70 61 67 65 20 22 2a 73 65 73 73 69 6f 6e 76 61 page "*sessionva
11690 72 73 2a 2c 20 2a 67 6c 6f 62 61 6c 76 61 72 73 rs*, *globalvars
116a0 2a 20 6f 72 20 70 61 67 65 0a 3b 3b 0a 28 64 65 * or page.;;.(de
116b0 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
116c0 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 t-page-hash self
116d0 20 70 61 67 65 29 0a 20 20 28 69 66 20 28 73 74 page). (if (st
116e0 72 69 6e 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 ring=? page "*se
116f0 73 73 69 6f 6e 76 61 72 73 2a 22 29 0a 20 20 20 ssionvars*").
11700 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 (sdat-get-ses
11710 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 0a 20 sionvars self).
11720 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
11730 3d 3f 20 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c =? page "*global
11740 76 61 72 73 2a 22 29 0a 09 20 20 28 73 64 61 74 vars*").. (sdat
11750 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 73 20 -get-globalvars
11760 73 65 6c 66 29 0a 09 20 20 28 73 64 61 74 2d 67 self).. (sdat-g
11770 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c 66 et-pagevars self
11780 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 61 20 73 ))))..;; set a s
11790 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
117a0 20 67 69 76 65 6e 20 70 61 67 65 0a 3b 3b 0a 28 given page.;;.(
117b0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
117c0 73 65 74 21 20 73 65 6c 66 20 70 61 67 65 20 6b set! self page k
117d0 65 79 20 76 61 6c 75 65 29 0a 20 20 28 6c 65 74 ey value). (let
117e0 20 28 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 ((ht (session:g
117f0 65 74 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c et-page-hash sel
11800 66 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 f page))). (h
11810 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
11820 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 t (s:any->string
11830 20 6b 65 79 29 20 28 73 3a 61 6e 79 2d 3e 73 74 key) (s:any->st
11840 72 69 6e 67 20 76 61 6c 75 65 29 29 29 29 0a 0a ring value))))..
11850 3b 3b 20 67 65 74 20 73 65 73 73 69 6f 6e 20 76 ;; get session v
11860 61 72 73 20 66 6f 72 20 74 68 65 20 63 75 72 72 ars for the curr
11870 65 6e 74 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 ent page.;;.(def
11880 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 ine (session:pag
11890 65 2d 67 65 74 20 73 65 6c 66 20 6b 65 79 29 0a e-get self key).
118a0 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
118b0 66 2f 64 65 66 61 75 6c 74 20 28 73 64 61 74 2d f/default (sdat-
118c0 67 65 74 2d 70 61 67 65 76 61 72 73 20 73 65 6c get-pagevars sel
118d0 66 29 20 6b 65 79 20 23 66 29 29 0a 0a 3b 3b 20 f) key #f))..;;
118e0 67 65 74 20 73 65 73 73 69 6f 6e 20 76 61 72 73 get session vars
118f0 20 66 6f 72 20 61 20 73 70 65 63 69 66 69 65 64 for a specified
11900 20 70 61 67 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 page.;;.(define
11910 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 20 73 65 (session:get se
11920 6c 66 20 70 61 67 65 20 6b 65 79 20 70 61 72 61 lf page key para
11930 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 ms). (let* ((ht
11940 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
11950 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 70 61 age-hash self pa
11960 67 65 29 29 0a 09 20 28 72 65 73 20 28 68 61 73 ge)).. (res (has
11970 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
11980 75 6c 74 20 68 74 20 28 73 3a 61 6e 79 2d 3e 73 ult ht (s:any->s
11990 74 72 69 6e 67 20 6b 65 79 29 20 23 66 29 29 29 tring key) #f)))
119a0 0a 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 70 . (session:ap
119b0 70 6c 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 ply-type-prefere
119c0 6e 63 65 20 72 65 73 20 70 61 72 61 6d 73 29 29 nce res params))
119d0 29 0a 0a 3b 3b 20 64 65 6c 65 74 65 20 61 20 73 )..;; delete a s
119e0 65 73 73 69 6f 6e 20 76 61 72 20 66 6f 72 20 61 ession var for a
119f0 20 73 70 65 63 69 66 69 65 64 20 70 61 67 65 0a specified page.
11a00 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
11a10 69 6f 6e 3a 64 65 6c 21 20 73 65 6c 66 20 70 61 ion:del! self pa
11a20 67 65 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 ge key). (let (
11a30 28 68 74 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 (ht (session:get
11a40 2d 70 61 67 65 2d 68 61 73 68 20 73 65 6c 66 20 -page-hash self
11a50 70 61 67 65 29 29 29 0a 20 20 20 20 28 68 61 73 page))). (has
11a60 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
11a70 68 74 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e ht (s:any->strin
11a80 67 20 6b 65 79 29 29 29 29 0a 0a 3b 3b 20 67 65 g key))))..;; ge
11a90 74 20 41 4c 4c 20 6b 65 79 73 20 66 6f 72 20 74 t ALL keys for t
11aa0 68 69 73 20 70 61 67 65 20 61 6e 64 20 73 74 6f his page and sto
11ab0 72 65 20 69 6e 20 74 68 65 20 73 65 73 73 69 6f re in the sessio
11ac0 6e 20 70 61 67 65 76 61 72 73 20 68 61 73 68 0a n pagevars hash.
11ad0 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 ;;.(define (sess
11ae0 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 6c ion:get-vars sel
11af0 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
11b00 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
11b10 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
11b20 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
11b30 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
11b40 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
11b50 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
11b60 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
11b70 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
11b80 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 s")..(let* ((res
11b90 75 6c 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ult
11ba0 23 66 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e #f).. (con
11bb0 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n
11bc0 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
11bd0 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 28 70 elf)).. (p
11be0 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 20 agevars-before
11bf0 20 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 (sdat-get-page
11c00 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
11c10 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 73 73 )).. (sess
11c20 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 65 20 28 ionvars-before (
11c30 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
11c40 76 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 vars-before self
11c50 29 29 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 )).. (glob
11c60 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 20 28 alvars-before (
11c70 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 sdat-get-globalv
11c80 61 72 73 2d 62 65 66 6f 72 65 20 73 65 6c 66 29 ars-before self)
11c90 29 0a 09 20 20 20 20 20 20 20 28 70 61 67 65 76 ).. (pagev
11ca0 61 72 73 20 20 20 20 20 20 20 20 20 20 20 28 73 ars (s
11cb0 64 61 74 2d 67 65 74 2d 70 61 67 65 76 61 72 73 dat-get-pagevars
11cc0 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
11cd0 28 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 (sessionvars
11ce0 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 (sdat-get-se
11cf0 73 73 69 6f 6e 76 61 72 73 20 73 65 6c 66 29 29 ssionvars self))
11d00 0a 09 20 20 20 20 20 20 20 28 67 6c 6f 62 61 6c .. (global
11d10 76 61 72 73 20 20 20 20 20 20 20 20 20 28 73 64 vars (sd
11d20 61 74 2d 67 65 74 2d 67 6c 6f 62 61 6c 76 61 72 at-get-globalvar
11d30 73 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 s self))..
11d40 20 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 20 20 (page-name
11d50 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 70 (sdat-get-p
11d60 61 67 65 20 73 65 6c 66 29 29 0a 09 20 20 20 20 age self))..
11d70 20 20 20 28 73 65 73 73 69 6f 6e 2d 6b 65 79 20 (session-key
11d80 20 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 (sdat-get
11d90 2d 73 65 73 73 69 6f 6e 2d 6b 65 79 20 73 65 6c -session-key sel
11da0 66 29 29 0a 09 20 20 20 20 20 20 20 28 71 75 65 f)).. (que
11db0 72 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ry
11dc0 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 09 (string-append..
11dd0 09 09 09 20 20 20 20 22 53 45 4c 45 43 54 20 6b ... "SELECT k
11de0 65 79 2c 76 61 6c 75 65 20 46 52 4f 4d 20 73 65 ey,value FROM se
11df0 73 73 69 6f 6e 5f 76 61 72 73 20 49 4e 4e 45 52 ssion_vars INNER
11e00 20 4a 4f 49 4e 20 73 65 73 73 69 6f 6e 73 20 4f JOIN sessions O
11e10 4e 20 73 65 73 73 69 6f 6e 5f 76 61 72 73 2e 73 N session_vars.s
11e20 65 73 73 69 6f 6e 5f 69 64 3d 73 65 73 73 69 6f ession_id=sessio
11e30 6e 73 2e 69 64 20 22 0a 09 09 09 09 20 20 20 20 ns.id ".....
11e40 22 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f 6b "WHERE session_k
11e50 65 79 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 3b ey=? AND page=?;
11e60 22 29 29 29 0a 09 20 20 3b 3b 20 66 69 72 73 74 "))).. ;; first
11e70 20 74 68 65 20 70 61 67 65 20 73 70 65 63 69 66 the page specif
11e80 69 63 20 76 61 72 73 0a 09 20 20 28 64 62 69 3a ic vars.. (dbi:
11e90 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 28 6c 61 for-each-row (la
11ea0 6d 62 64 61 20 28 74 75 70 6c 65 29 0a 09 09 09 mbda (tuple)....
11eb0 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 20 28 (let ((k (
11ec0 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c 65 vector-ref tuple
11ed0 20 30 29 29 0a 09 09 09 09 20 20 20 20 28 76 20 0))..... (v
11ee0 28 76 65 63 74 6f 72 2d 72 65 66 20 74 75 70 6c (vector-ref tupl
11ef0 65 20 31 29 29 29 0a 09 09 09 09 28 68 61 73 68 e 1))).....(hash
11f00 2d 74 61 62 6c 65 2d 73 65 74 21 20 70 61 67 65 -table-set! page
11f10 76 61 72 73 2d 62 65 66 6f 72 65 20 6b 20 76 29 vars-before k v)
11f20 0a 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 .....(hash-table
11f30 2d 73 65 74 21 20 70 61 67 65 76 61 72 73 20 20 -set! pagevars
11f40 20 20 20 20 20 20 6b 20 76 29 29 29 0a 09 09 09 k v)))....
11f50 20 20 20 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 conn....
11f60 28 73 3a 73 71 6c 70 61 72 61 6d 20 71 75 65 72 (s:sqlparam quer
11f70 79 20 73 65 73 73 69 6f 6e 2d 6b 65 79 20 70 61 y session-key pa
11f80 67 65 2d 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 ge-name)).. ;;
11f90 74 68 65 6e 20 74 68 65 20 73 65 73 73 69 6f 6e then the session
11fa0 20 73 70 65 63 69 66 69 63 20 76 61 72 73 0a 09 specific vars..
11fb0 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
11fc0 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
11fd0 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
11fe0 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
11ff0 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
12000 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
12010 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
12020 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
12030 74 21 20 73 65 73 73 69 6f 6e 76 61 72 73 2d 62 t! sessionvars-b
12040 65 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 efore k v).....(
12050 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
12060 73 65 73 73 69 6f 6e 76 61 72 73 20 20 20 20 20 sessionvars
12070 20 20 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 k v)))....
12080 20 63 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a conn.... (s:
12090 73 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 sqlparam query s
120a0 65 73 73 69 6f 6e 2d 6b 65 79 20 22 2a 73 65 73 ession-key "*ses
120b0 73 69 6f 6e 76 61 72 73 2a 22 29 29 0a 09 20 20 sionvars*"))..
120c0 3b 3b 20 61 6e 64 20 66 69 6e 61 6c 6c 79 20 74 ;; and finally t
120d0 68 65 20 67 6c 6f 62 61 6c 20 76 61 72 73 0a 09 he global vars..
120e0 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d (dbi:for-each-
120f0 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 70 row (lambda (tup
12100 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 le).... (le
12110 74 20 28 28 6b 20 28 76 65 63 74 6f 72 2d 72 65 t ((k (vector-re
12120 66 20 74 75 70 6c 65 20 30 29 29 0a 09 09 09 09 f tuple 0)).....
12130 20 20 20 20 28 76 20 28 76 65 63 74 6f 72 2d 72 (v (vector-r
12140 65 66 20 74 75 70 6c 65 20 31 29 29 29 0a 09 09 ef tuple 1)))...
12150 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
12160 74 21 20 67 6c 6f 62 61 6c 76 61 72 73 2d 62 65 t! globalvars-be
12170 66 6f 72 65 20 6b 20 76 29 0a 09 09 09 09 28 68 fore k v).....(h
12180 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 67 ash-table-set! g
12190 6c 6f 62 61 6c 76 61 72 73 20 20 20 20 20 20 20 lobalvars
121a0 20 6b 20 76 29 29 29 0a 09 09 09 20 20 20 20 63 k v))).... c
121b0 6f 6e 6e 0a 09 09 09 20 20 20 20 28 73 3a 73 71 onn.... (s:sq
121c0 6c 70 61 72 61 6d 20 71 75 65 72 79 20 73 65 73 lparam query ses
121d0 73 69 6f 6e 2d 6b 65 79 20 22 2a 67 6c 6f 62 61 sion-key "*globa
121e0 6c 76 61 72 73 22 29 29 0a 09 20 20 29 29 29 29 lvars")).. ))))
121f0 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 ..(define (sessi
12200 6f 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 6c on:save-vars sel
12210 66 29 0a 20 20 28 6c 65 74 20 28 28 73 65 73 73 f). (let ((sess
12220 69 6f 6e 2d 69 64 20 20 28 73 64 61 74 2d 67 65 ion-id (sdat-ge
12230 74 2d 73 65 73 73 69 6f 6e 2d 69 64 20 73 65 6c t-session-id sel
12240 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
12250 74 20 73 65 73 73 69 6f 6e 2d 69 64 29 0a 09 28 t session-id)..(
12260 65 72 72 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 err:log "ERROR:
12270 4e 6f 20 73 65 73 73 69 6f 6e 20 69 64 20 69 6e No session id in
12280 20 73 65 73 73 69 6f 6e 20 6f 62 6a 65 63 74 21 session object!
12290 20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 session:get-var
122a0 73 22 29 0a 09 28 6c 65 74 2a 20 28 28 73 74 61 s")..(let* ((sta
122b0 74 75 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 tus #f)..
122c0 20 20 20 20 20 28 63 6f 6e 6e 20 20 20 20 20 20 (conn
122d0 20 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e (sdat-get-conn
122e0 20 73 65 6c 66 29 29 0a 09 20 20 20 20 20 20 20 self))..
122f0 28 70 61 67 65 2d 6e 61 6d 65 20 20 20 28 73 64 (page-name (sd
12300 61 74 2d 67 65 74 2d 70 61 67 65 20 73 65 6c 66 at-get-page self
12310 29 29 0a 09 20 20 20 20 20 20 20 28 64 65 6c 2d )).. (del-
12320 71 75 65 72 79 20 20 20 22 44 45 4c 45 54 45 20 query "DELETE
12330 46 52 4f 4d 20 73 65 73 73 69 6f 6e 5f 76 61 72 FROM session_var
12340 73 20 57 48 45 52 45 20 73 65 73 73 69 6f 6e 5f s WHERE session_
12350 69 64 3d 3f 20 41 4e 44 20 70 61 67 65 3d 3f 20 id=? AND page=?
12360 41 4e 44 20 6b 65 79 3d 3f 3b 22 29 0a 09 20 20 AND key=?;")..
12370 20 20 20 20 20 28 69 6e 73 2d 71 75 65 72 79 20 (ins-query
12380 20 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 73 "INSERT INTO s
12390 65 73 73 69 6f 6e 5f 76 61 72 73 20 28 73 65 73 ession_vars (ses
123a0 73 69 6f 6e 5f 69 64 2c 70 61 67 65 2c 6b 65 79 sion_id,page,key
123b0 2c 76 61 6c 75 65 29 20 56 41 4c 55 45 53 28 3f ,value) VALUES(?
123c0 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 20 ,?,?,?);")..
123d0 20 20 20 28 75 70 64 2d 71 75 65 72 79 20 20 20 (upd-query
123e0 22 55 50 44 41 54 45 20 73 65 73 73 69 6f 6e 5f "UPDATE session_
123f0 76 61 72 73 20 73 65 74 20 76 61 6c 75 65 3d 3f vars set value=?
12400 20 57 48 45 52 45 20 6b 65 79 3d 3f 20 41 4e 44 WHERE key=? AND
12410 20 73 65 73 73 69 6f 6e 5f 69 64 3d 3f 20 41 4e session_id=? AN
12420 44 20 70 61 67 65 3d 3f 3b 22 29 0a 09 20 20 20 D page=?;")..
12430 20 20 20 20 28 63 68 61 6e 67 65 64 2d 63 6f 75 (changed-cou
12440 6e 74 20 30 29 29 0a 09 20 20 3b 3b 20 73 61 76 nt 0)).. ;; sav
12450 65 20 74 68 65 20 64 65 6c 74 61 20 6f 6e 6c 79 e the delta only
12460 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
12470 20 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 29 (lambda (page)
12480 20 3b 3b 20 70 61 67 65 20 69 73 3a 20 22 2a 67 ;; page is: "*g
12490 6c 6f 62 61 6c 76 61 72 73 2a 22 20 22 2a 73 65 lobalvars*" "*se
124a0 73 73 69 6f 6e 76 61 72 73 2a 22 20 6f 72 20 6f ssionvars*" or o
124b0 74 68 65 72 73 74 72 69 6e 67 0a 09 20 20 20 20 therstring..
124c0 20 28 6c 65 74 2a 20 28 28 62 65 66 6f 72 65 2d (let* ((before-
124d0 61 66 74 65 72 2d 68 74 20 28 63 6f 6e 64 0a 09 after-ht (cond..
124e0 09 09 09 20 20 20 20 20 20 28 28 73 74 72 69 6e ... ((strin
124f0 67 3d 3f 20 70 61 67 65 20 22 2a 73 65 73 73 69 g=? page "*sessi
12500 6f 6e 76 61 72 73 2a 22 29 0a 09 09 09 09 20 20 onvars*").....
12510 20 20 20 20 20 28 76 65 63 74 6f 72 20 28 73 64 (vector (sd
12520 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 at-get-sessionva
12530 72 73 20 73 65 6c 66 29 0a 09 09 09 09 09 20 20 rs self)......
12540 20 20 20 20 20 28 73 64 61 74 2d 67 65 74 2d 73 (sdat-get-s
12550 65 73 73 69 6f 6e 76 61 72 73 2d 62 65 66 6f 72 essionvars-befor
12560 65 20 73 65 6c 66 29 29 29 0a 09 09 09 09 20 20 e self))).....
12570 20 20 20 20 20 28 28 73 74 72 69 6e 67 3d 3f 20 ((string=?
12580 70 61 67 65 20 22 2a 67 6c 6f 62 61 6c 76 61 72 page "*globalvar
12590 73 2a 22 29 0a 09 09 09 09 09 28 76 65 63 74 6f s*")......(vecto
125a0 72 20 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f 62 r (sdat-get-glob
125b0 61 6c 76 61 72 73 20 73 65 6c 66 29 0a 09 09 09 alvars self)....
125c0 09 09 09 28 73 64 61 74 2d 67 65 74 2d 67 6c 6f ...(sdat-get-glo
125d0 62 61 6c 76 61 72 73 2d 62 65 66 6f 72 65 20 73 balvars-before s
125e0 65 6c 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 elf))).....
125f0 20 20 28 65 6c 73 65 20 0a 09 09 09 09 09 28 76 (else ......(v
12600 65 63 74 6f 72 20 28 73 64 61 74 2d 67 65 74 2d ector (sdat-get-
12610 70 61 67 65 76 61 72 73 20 73 65 6c 66 29 0a 09 pagevars self)..
12620 09 09 09 09 09 28 73 64 61 74 2d 67 65 74 2d 70 .....(sdat-get-p
12630 61 67 65 76 61 72 73 2d 62 65 66 6f 72 65 20 73 agevars-before s
12640 65 6c 66 29 29 29 29 29 0a 09 09 20 20 20 20 28 elf)))))... (
12650 6d 61 73 74 65 72 2d 68 74 20 20 20 28 76 65 63 master-ht (vec
12660 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 65 2d 61 tor-ref before-a
12670 66 74 65 72 2d 68 74 20 30 29 29 0a 09 09 20 20 fter-ht 0))...
12680 20 20 28 62 65 66 6f 72 65 2d 68 74 20 20 20 28 (before-ht (
12690 76 65 63 74 6f 72 2d 72 65 66 20 62 65 66 6f 72 vector-ref befor
126a0 65 2d 61 66 74 65 72 2d 68 74 20 31 29 29 0a 09 e-after-ht 1))..
126b0 09 20 20 20 20 28 6d 61 73 74 65 72 2d 6b 65 79 . (master-key
126c0 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
126d0 79 73 20 6d 61 73 74 65 72 2d 68 74 29 29 0a 09 ys master-ht))..
126e0 09 20 20 20 20 28 62 65 66 6f 72 65 2d 6b 65 79 . (before-key
126f0 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
12700 79 73 20 62 65 66 6f 72 65 2d 68 74 29 29 0a 09 ys before-ht))..
12710 09 20 20 20 20 28 61 6c 6c 2d 6b 65 79 73 20 28 . (all-keys (
12720 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
12730 73 20 28 61 70 70 65 6e 64 20 6d 61 73 74 65 72 s (append master
12740 2d 6b 65 79 73 20 62 65 66 6f 72 65 2d 6b 65 79 -keys before-key
12750 73 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 66 s)))).. (f
12760 6f 72 2d 65 61 63 68 20 0a 09 09 28 6c 61 6d 62 or-each ...(lamb
12770 64 61 20 28 6b 65 79 29 0a 09 09 20 20 28 6c 65 da (key)... (le
12780 74 20 28 28 6d 61 73 74 65 72 2d 76 61 6c 75 65 t ((master-value
12790 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
127a0 2f 64 65 66 61 75 6c 74 20 6d 61 73 74 65 72 2d /default master-
127b0 68 74 20 6b 65 79 20 23 66 29 29 0a 09 09 09 28 ht key #f))....(
127c0 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 68 61 before-value (ha
127d0 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
127e0 61 75 6c 74 20 62 65 66 6f 72 65 2d 68 74 20 6b ault before-ht k
127f0 65 79 20 23 66 29 29 29 0a 09 09 20 20 20 20 28 ey #f)))... (
12800 63 6f 6e 64 0a 09 09 20 20 20 20 20 3b 3b 20 62 cond... ;; b
12810 65 66 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 efore and after
12820 65 78 69 73 74 20 61 6e 64 20 76 61 6c 75 65 20 exist and value
12830 75 6e 63 68 61 6e 67 65 64 20 2d 20 64 6f 20 6e unchanged - do n
12840 6f 74 68 69 6e 67 0a 09 09 20 20 20 20 20 28 28 othing... ((
12850 61 6e 64 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 and master-value
12860 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 20 28 65 before-value (e
12870 71 75 61 6c 3f 20 6d 61 73 74 65 72 2d 76 61 6c qual? master-val
12880 75 65 20 62 65 66 6f 72 65 2d 76 61 6c 75 65 29 ue before-value)
12890 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 ))... ;; bef
128a0 6f 72 65 20 61 6e 64 20 61 66 74 65 72 20 65 78 ore and after ex
128b0 69 73 74 20 62 75 74 20 61 72 65 20 63 68 61 6e ist but are chan
128c0 67 65 64 0a 09 09 20 20 20 20 20 28 28 61 6e 64 ged... ((and
128d0 20 6d 61 73 74 65 72 2d 76 61 6c 75 65 20 62 65 master-value be
128e0 66 6f 72 65 2d 76 61 6c 75 65 29 0a 09 09 20 20 fore-value)...
128f0 20 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 (dbi:for-eac
12900 68 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 h-row (lambda (t
12910 75 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 uple)...... (se
12920 74 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 t! changed-count
12930 20 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e (+ changed-coun
12940 74 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e t 1)))......conn
12950 0a 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 ......(s:sqlpara
12960 6d 20 75 70 64 2d 71 75 65 72 79 20 6d 61 73 74 m upd-query mast
12970 65 72 2d 76 61 6c 75 65 20 6b 65 79 20 73 65 73 er-value key ses
12980 73 69 6f 6e 2d 69 64 20 70 61 67 65 29 29 29 0a sion-id page))).
12990 09 09 20 20 20 20 20 3b 3b 20 6d 61 73 74 65 72 .. ;; master
129a0 2d 76 61 6c 75 65 20 6e 6f 20 6c 6f 6e 67 65 72 -value no longer
129b0 20 65 78 69 73 74 73 20 28 69 2e 65 2e 20 23 66 exists (i.e. #f
129c0 29 20 2d 20 72 65 6d 6f 76 65 20 69 74 65 6d 0a ) - remove item.
129d0 09 09 20 20 20 20 20 28 28 6e 6f 74 20 6d 61 73 .. ((not mas
129e0 74 65 72 2d 76 61 6c 75 65 29 0a 09 09 20 20 20 ter-value)...
129f0 20 20 20 28 64 62 69 3a 66 6f 72 2d 65 61 63 68 (dbi:for-each
12a00 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 74 75 -row (lambda (tu
12a10 70 6c 65 29 0a 09 09 09 09 09 20 20 28 73 65 74 ple)...... (set
12a20 21 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 ! changed-count
12a30 28 2b 20 63 68 61 6e 67 65 64 2d 63 6f 75 6e 74 (+ changed-count
12a40 20 31 29 29 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 1)))......conn.
12a50 09 09 09 09 09 28 73 3a 73 71 6c 70 61 72 61 6d .....(s:sqlparam
12a60 20 64 65 6c 2d 71 75 65 72 79 20 73 65 73 73 69 del-query sessi
12a70 6f 6e 2d 69 64 20 70 61 67 65 20 6b 65 79 29 29 on-id page key))
12a80 29 0a 09 09 20 20 20 20 20 3b 3b 20 62 65 66 6f )... ;; befo
12a90 72 65 2d 76 61 6c 75 65 20 64 6f 65 73 6e 27 74 re-value doesn't
12aa0 20 65 78 69 73 74 20 2d 20 69 6e 73 65 72 74 20 exist - insert
12ab0 61 20 6e 65 77 20 76 61 6c 75 65 0a 09 09 20 20 a new value...
12ac0 20 20 20 28 28 6e 6f 74 20 62 65 66 6f 72 65 2d ((not before-
12ad0 76 61 6c 75 65 29 0a 09 09 20 20 20 20 20 20 28 value)... (
12ae0 64 62 69 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 dbi:for-each-row
12af0 20 28 6c 61 6d 62 64 61 20 28 74 75 70 6c 65 29 (lambda (tuple)
12b00 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 63 68 ...... (set! ch
12b10 61 6e 67 65 64 2d 63 6f 75 6e 74 20 28 2b 20 63 anged-count (+ c
12b20 68 61 6e 67 65 64 2d 63 6f 75 6e 74 20 31 29 29 hanged-count 1))
12b30 29 0a 09 09 09 09 09 63 6f 6e 6e 0a 09 09 09 09 )......conn.....
12b40 09 28 73 3a 73 71 6c 70 61 72 61 6d 20 69 6e 73 .(s:sqlparam ins
12b50 2d 71 75 65 72 79 20 73 65 73 73 69 6f 6e 2d 69 -query session-i
12b60 64 20 70 61 67 65 20 6b 65 79 20 6d 61 73 74 65 d page key maste
12b70 72 2d 76 61 6c 75 65 29 29 29 0a 09 09 20 20 20 r-value)))...
12b80 20 20 28 65 6c 73 65 20 28 65 72 72 3a 6c 6f 67 (else (err:log
12b90 20 22 53 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 "Shouldn't get
12ba0 68 65 72 65 22 29 29 29 29 29 0a 09 09 61 6c 6c here")))))...all
12bb0 2d 6b 65 79 73 29 29 29 20 3b 3b 20 70 72 6f 63 -keys))) ;; proc
12bc0 65 73 73 20 61 6c 6c 20 6b 65 79 73 0a 09 20 20 ess all keys..
12bd0 20 28 6c 69 73 74 20 22 2a 73 65 73 73 69 6f 6e (list "*session
12be0 76 61 72 73 2a 22 20 22 2a 67 6c 6f 62 61 6c 76 vars*" "*globalv
12bf0 61 72 73 2a 22 20 70 61 67 65 2d 6e 61 6d 65 29 ars*" page-name)
12c00 29 29 29 29 29 0a 0a 3b 3b 20 28 70 67 3a 73 71 )))))..;; (pg:sq
12c10 6c 2d 6e 75 6c 6c 2d 6f 62 6a 65 63 74 3f 20 65 l-null-object? e
12c20 6c 65 6d 65 6e 74 29 0a 28 64 65 66 69 6e 65 20 lement).(define
12c30 28 73 65 73 73 69 6f 6e 3a 72 65 61 64 2d 63 6f (session:read-co
12c40 6e 66 69 67 20 73 65 6c 66 20 23 21 6f 70 74 69 nfig self #!opti
12c50 6f 6e 61 6c 20 28 66 6e 61 6d 65 20 23 66 29 29 onal (fname #f))
12c60 0a 20 20 28 6c 65 74 2a 20 28 28 63 67 69 2d 70 . (let* ((cgi-p
12c70 61 74 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 ath (pathname-di
12c80 72 65 63 74 6f 72 79 20 28 63 61 72 20 28 61 72 rectory (car (ar
12c90 67 76 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 gv)))).
12ca0 28 6e 61 6d 65 20 20 20 20 20 28 6f 72 20 66 6e (name (or fn
12cb0 61 6d 65 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ame (string-appe
12cc0 6e 64 20 28 69 66 20 63 67 69 2d 70 61 74 68 20 nd (if cgi-path
12cd0 28 63 6f 6e 63 20 63 67 69 2d 70 61 74 68 20 22 (conc cgi-path "
12ce0 2f 22 29 20 22 22 29 20 22 2e 22 20 28 70 61 74 /") "") "." (pat
12cf0 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 hname-file (car
12d00 28 61 72 67 76 29 29 29 20 22 2e 63 6f 6e 66 69 (argv))) ".confi
12d10 67 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 g")))). (if (
12d20 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
12d30 3f 20 6e 61 6d 65 29 29 0a 09 28 70 72 69 6e 74 ? name))..(print
12d40 20 6e 61 6d 65 20 22 20 6e 6f 74 20 66 6f 75 6e name " not foun
12d50 64 20 61 74 20 22 20 28 63 75 72 72 65 6e 74 2d d at " (current-
12d60 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c 65 directory))..(le
12d70 74 2a 20 28 28 66 70 20 28 6f 70 65 6e 2d 69 6e t* ((fp (open-in
12d80 70 75 74 2d 66 69 6c 65 20 6e 61 6d 65 29 29 0a put-file name)).
12d90 09 20 20 20 20 20 20 20 28 69 6e 69 74 61 72 67 . (initarg
12da0 73 20 28 72 65 61 64 20 66 70 29 29 29 0a 09 20 s (read fp)))..
12db0 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
12dc0 72 74 20 66 70 29 0a 09 20 20 69 6e 69 74 61 72 rt fp).. initar
12dd0 67 73 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 gs))))..;; call
12de0 74 68 65 20 63 6f 6e 74 72 6f 6c 6c 65 72 20 69 the controller i
12df0 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 20 0a f it exists.;; .
12e00 3b 3b 20 57 41 52 4e 49 4e 47 20 2d 20 74 68 69 ;; WARNING - thi
12e10 73 20 63 6f 64 65 20 6e 65 65 64 73 20 61 20 64 s code needs a d
12e20 65 66 65 6e 63 65 20 61 67 61 69 6e 73 20 72 65 efence agains re
12e30 63 75 72 73 69 76 65 20 63 61 6c 6c 69 6e 67 21 cursive calling!
12e40 21 21 21 21 0a 3b 3b 0a 3b 3b 20 20 20 49 20 73 !!!!.;;.;; I s
12e50 75 67 67 65 73 74 20 61 20 6c 69 6d 69 74 20 6f uggest a limit o
12e60 66 20 31 30 30 20 63 61 6c 6c 73 2e 20 50 6c 65 f 100 calls. Ple
12e70 6e 74 79 20 66 6f 72 20 61 6c 6c 6f 77 69 6e 67 nty for allowing
12e80 20 6d 75 6c 74 69 70 6c 65 20 69 6e 73 74 61 6e multiple instan
12e90 63 65 73 0a 3b 3b 20 20 20 6f 66 20 61 20 70 61 ces.;; of a pa
12ea0 67 65 20 69 6e 73 69 64 65 20 61 6e 6f 74 68 65 ge inside anothe
12eb0 72 20 70 61 67 65 2e 20 0a 3b 3b 0a 3b 3b 20 70 r page. .;;.;; p
12ec0 61 72 74 73 20 3d 20 27 62 6f 74 68 20 7c 20 27 arts = 'both | '
12ed0 63 6f 6e 74 72 6f 6c 20 7c 20 27 76 69 65 77 0a control | 'view.
12ee0 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 6c ;;..(define (fil
12ef0 65 73 2d 72 65 61 64 2d 3e 73 74 72 69 6e 67 20 es-read->string
12f00 2e 20 66 69 6c 65 73 29 0a 20 20 28 73 74 72 69 . files). (stri
12f10 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
12f20 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 (apply append
12f30 20 28 6d 61 70 20 66 69 6c 65 2d 72 65 61 64 2d (map file-read-
12f40 3e 73 74 72 69 6e 67 20 66 69 6c 65 73 29 29 20 >string files))
12f50 22 5c 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 "\n"))..(define
12f60 28 66 69 6c 65 2d 72 65 61 64 2d 3e 73 74 72 69 (file-read->stri
12f70 6e 67 20 66 29 20 0a 20 20 28 6c 65 74 20 28 28 ng f) . (let ((
12f80 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 p (open-input-fi
12f90 6c 65 20 66 29 29 29 0a 20 20 20 20 28 6c 65 74 le f))). (let
12fa0 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 72 65 61 loop ((hed (rea
12fb0 64 2d 6c 69 6e 65 20 70 29 29 0a 09 20 20 20 20 d-line p))..
12fc0 20 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 (res '())).
12fd0 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a (if (eof-obj
12fe0 65 63 74 3f 20 68 65 64 29 0a 09 20 20 72 65 73 ect? hed).. res
12ff0 0a 09 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d .. (loop (read-
13000 6c 69 6e 65 20 70 29 28 61 70 70 65 6e 64 20 72 line p)(append r
13010 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 es (list hed))))
13020 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 )))..(define (pr
13030 6f 63 65 73 73 2d 70 6f 72 74 20 70 29 0a 20 20 ocess-port p).
13040 28 6c 65 74 20 28 28 65 20 28 69 6e 74 65 72 61 (let ((e (intera
13050 63 74 69 6f 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e ction-environmen
13060 74 29 29 29 0a 20 20 20 20 28 6d 61 70 20 0a 20 t))). (map .
13070 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a (lambda (x).
13080 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 28 28 (cond..((
13090 6c 69 73 74 3f 20 78 29 20 78 29 0a 09 28 28 73 list? x) x)..((s
130a0 74 72 69 6e 67 3f 20 78 29 20 78 29 0a 09 28 65 tring? x) x)..(e
130b0 6c 73 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 lse '()))).
130c0 28 70 6f 72 74 2d 6d 61 70 20 28 6c 61 6d 62 64 (port-map (lambd
130d0 61 20 28 73 29 0a 09 09 20 28 65 76 61 6c 20 73 a (s)... (eval s
130e0 20 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 e)).. (la
130f0 6d 62 64 61 20 28 29 28 72 65 61 64 20 70 29 29 mbda ()(read p))
13100 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
13110 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d 66 ession:process-f
13120 69 6c 65 20 66 29 0a 20 20 28 6c 65 74 2a 20 28 ile f). (let* (
13130 28 70 20 20 20 20 28 6f 70 65 6e 2d 69 6e 70 75 (p (open-inpu
13140 74 2d 66 69 6c 65 20 66 29 29 0a 09 20 28 64 61 t-file f)).. (da
13150 74 20 20 28 70 72 6f 63 65 73 73 2d 70 6f 72 74 t (process-port
13160 20 70 29 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 p))). (close
13170 2d 69 6e 70 75 74 2d 70 6f 72 74 20 70 29 0a 20 -input-port p).
13180 20 20 20 64 61 74 29 29 0a 0a 3b 3b 20 4d 61 79 dat))..;; May
13190 20 32 30 31 31 2c 20 70 75 74 74 69 6e 67 20 61 2011, putting a
131a0 6c 6c 20 70 61 67 65 73 20 69 6e 74 6f 20 6f 6e ll pages into on
131b0 65 20 64 69 72 65 63 74 6f 72 79 20 66 6f 72 20 e directory for
131c0 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 the following re
131d0 61 73 6f 6e 73 3a 0a 3b 3b 20 20 20 31 2e 20 77 asons:.;; 1. w
131e0 61 6e 74 20 66 69 6c 65 6e 61 6d 65 20 74 6f 20 ant filename to
131f0 72 65 66 6c 65 63 74 20 70 61 67 65 20 6e 61 6d reflect page nam
13200 65 20 28 65 6d 61 63 73 20 6c 69 6d 69 74 61 74 e (emacs limitat
13210 69 6f 6e 29 0a 3b 3b 20 20 20 32 2e 20 74 68 61 ion).;; 2. tha
13220 74 27 73 20 69 74 21 20 6e 6f 20 6f 74 68 65 72 t's it! no other
13230 20 72 65 61 73 6f 6e 2e 20 63 6f 75 6c 64 20 6d reason. could m
13240 61 6b 65 20 69 74 20 63 6f 6e 66 69 67 75 72 61 ake it configura
13250 62 6c 65 20 2e 2e 2e 0a 3b 3b 20 70 61 67 65 2d ble ....;; page-
13260 64 69 72 2d 73 74 79 6c 65 20 69 73 3a 0a 3b 3b dir-style is:.;;
13270 20 20 27 73 74 6f 72 65 64 20 20 20 3d 3e 20 73 'stored => s
13280 74 6f 72 65 64 20 69 6e 20 65 78 65 63 75 74 61 tored in executa
13290 62 6c 65 0a 3b 3b 20 20 27 66 6c 61 74 20 20 20 ble.;; 'flat
132a0 20 20 3d 3e 20 70 61 67 65 73 20 66 6c 61 74 20 => pages flat
132b0 64 69 72 65 63 74 6f 72 79 0a 3b 3b 20 20 27 64 directory.;; 'd
132c0 69 72 20 20 20 20 20 20 3d 3e 20 64 69 72 65 63 ir => direc
132d0 74 6f 72 79 20 74 72 65 65 20 70 61 67 65 73 2f tory tree pages/
132e0 3c 70 61 67 65 6e 61 6d 65 3e 2f 7b 76 69 65 77 <pagename>/{view
132f0 2c 63 6f 6e 74 72 6f 6c 7d 2e 73 63 6d 0a 3b 3b ,control}.scm.;;
13300 20 70 61 72 74 73 3a 0a 3b 3b 20 20 27 62 6f 74 parts:.;; 'bot
13310 68 20 20 20 20 20 3d 3e 20 6c 6f 61 64 20 63 6f h => load co
13320 6e 74 72 6f 6c 20 61 6e 64 20 76 69 65 77 20 28 ntrol and view (
13330 61 6e 79 74 68 69 6e 67 20 6f 74 68 65 72 20 74 anything other t
13340 68 61 6e 20 76 69 65 77 20 6f 72 20 63 6f 6e 74 han view or cont
13350 72 6f 6c 20 61 6e 64 20 74 68 65 20 64 65 66 61 rol and the defa
13360 75 6c 74 29 0a 3b 3b 20 20 27 76 69 65 77 20 20 ult).;; 'view
13370 20 20 20 3d 3e 20 6c 6f 61 64 20 76 69 65 77 20 => load view
13380 6f 6e 6c 79 0a 3b 3b 20 20 27 63 6f 6e 74 72 6f only.;; 'contro
13390 6c 20 20 3d 3e 20 6c 6f 61 64 20 63 6f 6e 74 72 l => load contr
133a0 6f 6c 20 6f 6e 6c 79 0a 28 64 65 66 69 6e 65 20 ol only.(define
133b0 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 61 (session:call-pa
133c0 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 23 21 rts self page #!
133d0 6b 65 79 20 28 70 61 72 74 73 20 27 62 6f 74 68 key (parts 'both
133e0 29 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 63 )). (sdat-set-c
133f0 75 72 72 2d 70 61 67 65 21 20 73 65 6c 66 20 70 urr-page! self p
13400 61 67 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 age). (let* ((d
13410 69 72 2d 73 74 79 6c 65 20 20 20 20 28 73 64 61 ir-style (sda
13420 74 2d 67 65 74 2d 70 61 67 65 2d 64 69 72 2d 73 t-get-page-dir-s
13430 74 79 6c 65 20 73 65 6c 66 29 29 3b 3b 20 28 65 tyle self));; (e
13440 71 75 61 6c 3f 20 28 73 64 61 74 2d 67 65 74 2d qual? (sdat-get-
13450 70 61 67 65 2d 64 69 72 2d 73 74 79 6c 65 20 73 page-dir-style s
13460 65 6c 66 29 20 22 6f 6e 65 64 69 72 22 29 29 20 elf) "onedir"))
13470 3b 3b 20 66 6c 61 67 20 23 74 20 66 6f 72 20 6f ;; flag #t for o
13480 6e 65 64 69 72 2c 20 23 66 20 66 6f 72 20 6f 6c nedir, #f for ol
13490 64 20 73 74 79 6c 65 0a 09 20 28 64 69 72 20 20 d style.. (dir
134a0 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
134b0 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 append (sdat-get
134c0 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 0a 09 09 -sroot self) ...
134d0 09 09 20 20 20 20 20 20 28 69 66 20 64 69 72 2d .. (if dir-
134e0 73 74 79 6c 65 20 0a 09 09 09 09 09 20 20 28 63 style ...... (c
134f0 6f 6e 63 20 22 2f 70 61 67 65 73 2f 22 29 0a 09 onc "/pages/")..
13500 09 09 09 09 20 20 28 63 6f 6e 63 20 22 2f 70 61 .... (conc "/pa
13510 67 65 73 2f 22 20 70 61 67 65 29 29 29 29 29 0a ges/" page))))).
13520 20 20 20 20 28 63 61 73 65 20 64 69 72 2d 73 74 (case dir-st
13530 79 6c 65 0a 20 20 20 20 20 20 3b 3b 20 4e 42 2f yle. ;; NB/
13540 2f 20 53 74 6f 72 65 64 20 61 6c 77 61 79 73 20 / Stored always
13550 6c 6f 61 64 73 20 62 6f 74 68 20 63 6f 6e 74 72 loads both contr
13560 6f 6c 20 61 6e 64 20 76 69 65 77 0a 20 20 20 20 ol and view.
13570 20 20 28 28 73 74 6f 72 65 64 29 0a 20 20 20 20 ((stored).
13580 20 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e ((eval (strin
13590 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 g->symbol (conc
135a0 22 70 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 "pages:" page)))
135b0 20 0a 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 ..self
135c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
135d0 3b 3b 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 ;; the session..
135e0 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 73 (sdat-get-conn s
135f0 65 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b 20 elf) ;;
13600 74 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 6f the db connectio
13610 6e 0a 09 28 73 64 61 74 2d 67 65 74 2d 73 68 61 n..(sdat-get-sha
13620 72 65 64 2d 68 61 73 68 20 73 65 6c 66 29 20 20 red-hash self)
13630 3b 3b 20 61 20 73 68 61 72 65 64 20 68 61 73 68 ;; a shared hash
13640 20 74 61 62 6c 65 20 66 6f 72 20 70 61 73 73 69 table for passi
13650 6e 67 20 64 61 74 61 20 74 6f 2f 66 72 6f 6d 20 ng data to/from
13660 70 61 67 65 20 63 61 6c 6c 73 0a 09 29 29 0a 20 page calls..)).
13670 20 20 20 20 20 28 28 66 6c 61 74 29 20 20 20 0a ((flat) .
13680 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
13690 6f 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 64 69 o-file (conc di
136a0 72 20 70 61 67 65 20 22 2e 73 6f 22 29 29 0a 09 r page ".so"))..
136b0 20 20 20 20 20 20 28 73 63 6d 2d 66 69 6c 65 20 (scm-file
136c0 28 63 6f 6e 63 20 64 69 72 20 70 61 67 65 20 22 (conc dir page "
136d0 2e 73 63 6d 22 29 29 0a 09 20 20 20 20 20 20 28 .scm")).. (
136e0 73 72 63 2d 66 69 6c 65 20 28 6f 72 20 28 66 69 src-file (or (fi
136f0 6c 65 2d 65 78 69 73 74 73 3f 20 73 6f 2d 66 69 le-exists? so-fi
13700 6c 65 29 0a 09 09 09 20 20 20 20 28 66 69 6c 65 le).... (file
13710 2d 65 78 69 73 74 73 3f 20 73 63 6d 2d 66 69 6c -exists? scm-fil
13720 65 29 29 29 29 0a 09 20 28 69 66 20 73 72 63 2d e)))).. (if src-
13730 66 69 6c 65 0a 09 20 20 20 20 20 28 62 65 67 69 file.. (begi
13740 6e 0a 09 20 20 20 20 20 20 20 28 6c 6f 61 64 20 n.. (load
13750 73 72 63 2d 66 69 6c 65 29 0a 09 20 20 20 20 20 src-file)..
13760 20 20 28 28 65 76 61 6c 20 28 73 74 72 69 6e 67 ((eval (string
13770 2d 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 ->symbol (conc "
13780 70 61 67 65 73 3a 22 20 70 61 67 65 29 29 29 20 pages:" page)))
13790 0a 09 09 73 65 6c 66 20 20 20 20 20 20 20 20 20 ...self
137a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
137b0 3b 3b 20 74 68 65 20 73 65 73 73 69 6f 6e 0a 09 ;; the session..
137c0 09 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 6e 20 .(sdat-get-conn
137d0 73 65 6c 66 29 20 20 20 20 20 20 20 20 20 3b 3b self) ;;
137e0 20 74 68 65 20 64 62 20 63 6f 6e 6e 65 63 74 69 the db connecti
137f0 6f 6e 0a 09 09 28 73 64 61 74 2d 67 65 74 2d 73 on...(sdat-get-s
13800 68 61 72 65 64 2d 68 61 73 68 20 73 65 6c 66 29 hared-hash self)
13810 20 20 3b 3b 20 61 20 73 68 61 72 65 64 20 68 61 ;; a shared ha
13820 73 68 20 74 61 62 6c 65 20 66 6f 72 20 70 61 73 sh table for pas
13830 73 69 6e 67 20 64 61 74 61 20 74 6f 2f 66 72 6f sing data to/fro
13840 6d 20 70 61 67 65 20 63 61 6c 6c 73 0a 09 09 29 m page calls...)
13850 29 0a 09 20 20 20 20 20 28 6c 69 73 74 20 22 3c ).. (list "<
13860 70 3e 50 61 67 65 20 6e 6f 74 20 66 6f 75 6e 64 p>Page not found
13870 20 22 20 70 61 67 65 20 22 20 3c 2f 70 3e 22 29 " page " </p>")
13880 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 ))). ;; fi
13890 72 73 74 20 74 68 65 20 63 6f 6e 74 72 6f 6c 0a rst the control.
138a0 20 20 20 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 ;; (let (
138b0 28 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 20 28 63 (control-file (c
138c0 6f 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 onc "pages/" pag
138d0 65 20 22 5f 63 74 72 6c 2e 73 63 6d 22 29 29 0a e "_ctrl.scm")).
138e0 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
138f0 28 76 69 65 77 2d 66 69 6c 65 20 20 20 20 28 63 (view-file (c
13900 6f 6e 63 20 22 70 61 67 65 73 2f 22 20 70 61 67 onc "pages/" pag
13910 65 20 22 5f 76 69 65 77 2e 73 63 6d 22 29 29 29 e "_view.scm")))
13920 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 28 69 66 . ;; (if
13930 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 (and (file-exis
13940 74 73 3f 20 63 6f 6e 74 72 6f 6c 2d 66 69 6c 65 ts? control-file
13950 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 20 ). ;; .
13960 28 6e 6f 74 20 28 65 71 3f 20 70 61 72 74 73 20 (not (eq? parts
13970 27 76 69 65 77 29 29 29 0a 20 20 20 20 20 20 20 'view))).
13980 3b 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a ;; (begin.
13990 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
139a0 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 2d 63 (session:set-c
139b0 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 61 67 65 alled! self page
139c0 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ). ;;
139d0 20 20 20 20 28 6c 6f 61 64 20 63 6f 6e 74 72 6f (load contro
139e0 6c 2d 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 l-file))).
139f0 20 3b 3b 20 20 20 28 69 66 20 28 66 69 6c 65 2d ;; (if (file-
13a00 65 78 69 73 74 73 3f 20 76 69 65 77 2d 66 69 6c exists? view-fil
13a10 65 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 e). ;;
13a20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f (if (not (eq?
13a30 20 70 61 72 74 73 20 27 63 6f 6e 74 72 6f 6c 29 parts 'control)
13a40 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 20 28 ). ;; . (
13a50 73 65 73 73 69 6f 6e 3a 70 72 6f 63 65 73 73 2d session:process-
13a60 66 69 6c 65 20 76 69 65 77 2d 66 69 6c 65 29 29 file view-file))
13a70 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
13a80 20 28 6c 69 73 74 20 22 3c 70 3e 50 61 67 65 20 (list "<p>Page
13a90 6e 6f 74 20 66 6f 75 6e 64 20 22 20 70 61 67 65 not found " page
13aa0 20 22 20 3c 2f 70 3e 22 29 29 29 0a 20 20 20 20 " </p>"))).
13ab0 20 20 28 28 64 69 72 29 20 22 45 52 52 4f 52 3a ((dir) "ERROR:
13ac0 20 20 64 69 72 20 73 74 79 6c 65 20 6e 6f 74 20 dir style not
13ad0 79 65 74 20 72 65 2d 69 6d 70 6c 65 6d 65 6e 74 yet re-implement
13ae0 65 64 22 29 0a 20 20 20 20 20 20 28 65 6c 73 65 ed"). (else
13af0 0a 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 45 . (list "E
13b00 52 52 4f 52 3a 20 70 61 67 65 2d 64 69 72 2d 73 RROR: page-dir-s
13b10 74 79 6c 65 20 6d 75 73 74 20 62 65 20 73 74 6f tyle must be sto
13b20 72 65 64 2c 20 64 69 72 20 6f 72 20 66 6c 61 74 red, dir or flat
13b30 2c 20 67 6f 74 20 22 20 64 69 72 2d 73 74 79 6c , got " dir-styl
13b40 65 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 e)))))..(define
13b50 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 73 65 (session:call se
13b60 6c 66 20 70 61 67 65 20 70 61 72 74 73 29 0a 20 lf page parts).
13b70 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d 70 (session:call-p
13b80 61 72 74 73 20 73 65 6c 66 20 70 61 67 65 20 27 arts self page '
13b90 62 6f 74 68 29 29 0a 0a 3b 3b 20 28 64 65 66 69 both))..;; (defi
13ba0 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6c 6f 61 64 ne (session:load
13bb0 2d 6d 6f 64 65 6c 20 73 65 6c 66 20 6d 6f 64 65 -model self mode
13bc0 6c 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6d l).;; (let ((m
13bd0 6f 64 65 6c 2e 73 63 6d 20 28 73 74 72 69 6e 67 odel.scm (string
13be0 2d 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 -append (sdat-ge
13bf0 74 2d 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f t-sroot self) "/
13c00 6d 6f 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 models/" model "
13c10 2e 73 63 6d 22 29 29 0a 3b 3b 20 09 28 6d 6f 64 .scm")).;; .(mod
13c20 65 6c 2e 73 6f 20 20 28 73 74 72 69 6e 67 2d 61 el.so (string-a
13c30 70 70 65 6e 64 20 28 73 64 61 74 2d 67 65 74 2d ppend (sdat-get-
13c40 73 72 6f 6f 74 20 73 65 6c 66 29 20 22 2f 6d 6f sroot self) "/mo
13c50 64 65 6c 73 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 dels/" model ".s
13c60 6f 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 o"))).;; (if
13c70 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d (file-exists? m
13c80 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 09 28 6c 6f odel.so).;; .(lo
13c90 61 64 20 6d 6f 64 65 6c 2e 73 6f 29 0a 3b 3b 20 ad model.so).;;
13ca0 09 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 .(if (file-exist
13cb0 73 3f 20 6d 6f 64 65 6c 2e 73 63 6d 29 0a 3b 3b s? model.scm).;;
13cc0 20 09 20 20 20 20 28 6c 6f 61 64 20 6d 6f 64 65 . (load mode
13cd0 6c 2e 73 63 6d 29 0a 3b 3b 20 09 20 20 20 20 28 l.scm).;; . (
13ce0 73 3a 6c 6f 67 20 22 45 52 52 4f 52 3a 20 6d 6f s:log "ERROR: mo
13cf0 64 65 6c 20 22 20 6d 6f 64 65 6c 2e 73 63 6d 20 del " model.scm
13d00 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 29 " not found"))))
13d10 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 )..;; (define (s
13d20 65 73 73 69 6f 6e 3a 6d 6f 64 65 6c 2d 70 61 74 ession:model-pat
13d30 68 20 73 65 6c 66 20 6d 6f 64 65 6c 29 0a 3b 3b h self model).;;
13d40 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
13d50 64 20 28 73 64 61 74 2d 67 65 74 2d 73 72 6f 6f d (sdat-get-sroo
13d60 74 20 73 65 6c 66 29 20 22 2f 6d 6f 64 65 6c 73 t self) "/models
13d70 2f 22 20 6d 6f 64 65 6c 20 22 2e 73 63 6d 22 29 /" model ".scm")
13d80 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
13d90 69 6f 6e 3a 70 70 2d 66 6f 72 6d 64 61 74 20 73 ion:pp-formdat s
13da0 65 6c 66 29 0a 20 20 28 6c 65 74 20 28 28 64 61 elf). (let ((da
13db0 74 20 28 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e t (formdat:all->
13dc0 73 74 72 69 6e 67 73 20 28 73 64 61 74 2d 67 65 strings (sdat-ge
13dd0 74 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 t-formdat self))
13de0 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 )). (string-i
13df0 6e 74 65 72 73 70 65 72 73 65 20 64 61 74 20 22 ntersperse dat "
13e00 3c 62 72 3e 20 22 29 29 29 0a 0a 28 64 65 66 69 <br> ")))..(defi
13e10 6e 65 20 28 73 65 73 73 69 6f 6e 3a 70 61 72 61 ne (session:para
13e20 6d 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 m->string params
13e30 29 0a 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 ). ;; (err:log
13e40 22 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 "params=" params
13e50 29 0a 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 ). (if (< (leng
13e60 74 68 20 70 61 72 61 6d 73 29 20 31 29 0a 20 20 th params) 1).
13e70 20 20 20 20 22 22 0a 20 20 20 20 20 20 28 6c 65 "". (le
13e80 74 20 6c 6f 6f 70 20 28 28 6b 65 79 20 28 63 61 t loop ((key (ca
13e90 72 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 76 r params))... (v
13ea0 61 6c 20 28 63 61 64 72 20 70 61 72 61 6d 73 29 al (cadr params)
13eb0 29 0a 09 09 20 28 74 61 69 6c 20 28 63 64 64 72 )... (tail (cddr
13ec0 20 70 61 72 61 6d 73 29 29 0a 09 09 20 28 72 65 params))... (re
13ed0 73 75 6c 74 20 27 28 29 29 29 0a 09 28 6c 65 74 sult '()))..(let
13ee0 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 63 6f ((newresult (co
13ef0 6e 73 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e ns (string-appen
13f00 64 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 d (s:any->string
13f10 20 6b 65 79 29 20 22 3d 22 20 28 73 3a 61 6e 79 key) "=" (s:any
13f20 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 ->string val))..
13f30 09 09 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 .. result)
13f40 29 29 0a 09 20 20 28 69 66 20 28 3c 20 28 6c 65 )).. (if (< (le
13f50 6e 67 74 68 20 74 61 69 6c 29 20 31 29 20 3b 3b ngth tail) 1) ;;
13f60 20 74 72 75 65 20 69 66 20 64 6f 6e 65 0a 09 20 true if done..
13f70 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 (string-int
13f80 65 72 73 70 65 72 73 65 20 6e 65 77 72 65 73 75 ersperse newresu
13f90 6c 74 20 22 26 22 29 0a 09 20 20 20 20 20 20 28 lt "&").. (
13fa0 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 loop (car tail)(
13fb0 63 61 64 72 20 74 61 69 6c 29 28 63 64 64 72 20 cadr tail)(cddr
13fc0 74 61 69 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 tail) newresult)
13fd0 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
13fe0 73 65 73 73 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 session:link-to
13ff0 73 65 6c 66 20 70 61 67 65 20 70 61 72 61 6d 73 self page params
14000 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 74 74 70 ). (let* ((http
14010 73 2d 68 6f 73 74 20 20 20 28 67 65 74 2d 65 6e s-host (get-en
14020 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
14030 6c 65 20 22 48 54 54 50 53 5f 48 4f 53 54 22 29 le "HTTPS_HOST")
14040 29 0a 20 20 20 20 20 20 20 20 20 28 66 6f 72 63 ). (forc
14050 65 2d 73 73 6c 20 20 20 20 28 73 64 61 74 2d 67 e-ssl (sdat-g
14060 65 74 2d 66 6f 72 63 65 2d 73 73 6c 20 73 65 6c et-force-ssl sel
14070 66 29 29 0a 09 20 28 73 65 72 76 65 72 20 20 20 f)).. (server
14080 20 20 20 20 28 6f 72 20 68 74 74 70 73 2d 68 6f (or https-ho
14090 73 74 20 3b 3b 20 41 73 73 75 6d 69 6e 67 20 48 st ;; Assuming H
140a0 54 54 50 53 5f 48 4f 53 54 20 69 73 20 6f 6e 6c TTPS_HOST is onl
140b0 79 20 73 65 74 20 69 66 20 61 76 61 69 6c 61 62 y set if availab
140c0 6c 65 0a 09 09 09 20 20 20 28 67 65 74 2d 65 6e le.... (get-en
140d0 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
140e0 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 0a le "HTTP_HOST").
140f0 09 09 09 20 20 20 28 67 65 74 2d 65 6e 76 69 72 ... (get-envir
14100 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
14110 22 53 45 52 56 45 52 5f 4e 41 4d 45 22 29 0a 09 "SERVER_NAME")..
14120 09 09 20 20 20 28 73 64 61 74 2d 67 65 74 2d 64 .. (sdat-get-d
14130 6f 6d 61 69 6e 20 73 65 6c 66 29 29 29 0a 20 20 omain self))).
14140 20 20 20 20 20 20 20 28 66 6f 72 63 65 2d 73 63 (force-sc
14150 72 69 70 74 20 20 28 73 64 61 74 2d 67 65 74 2d ript (sdat-get-
14160 73 63 72 69 70 74 20 73 65 6c 66 29 29 0a 09 20 script self))..
14170 28 73 63 72 69 70 74 20 20 20 20 20 20 20 20 28 (script (
14180 6f 72 20 66 6f 72 63 65 2d 73 63 72 69 70 74 0a or force-script.
14190 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 73 63 ... (let ((sc
141a0 72 69 70 74 2d 6e 61 6d 65 20 28 73 74 72 69 6e ript-name (strin
141b0 67 2d 73 70 6c 69 74 20 28 67 65 74 2d 65 6e 76 g-split (get-env
141c0 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
141d0 65 20 22 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 e "SCRIPT_NAME")
141e0 20 22 2f 22 29 29 29 0a 09 09 09 20 20 20 20 20 "/")))....
141f0 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
14200 73 63 72 69 70 74 2d 6e 61 6d 65 29 20 31 29 0a script-name) 1).
14210 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d 61 70 .... (string-ap
14220 70 65 6e 64 20 28 63 61 72 20 73 63 72 69 70 74 pend (car script
14230 2d 6e 61 6d 65 29 20 22 2f 22 20 28 63 61 64 72 -name) "/" (cadr
14240 20 73 63 72 69 70 74 2d 6e 61 6d 65 29 29 0a 09 script-name))..
14250 09 09 09 20 20 28 67 65 74 2d 65 6e 76 69 72 6f ... (get-enviro
14260 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
14270 53 43 52 49 50 54 5f 4e 41 4d 45 22 29 29 29 29 SCRIPT_NAME"))))
14280 29 20 3b 3b 20 62 75 69 6c 64 20 73 63 72 69 70 ) ;; build scrip
14290 74 20 6e 61 6d 65 20 66 72 6f 6d 20 66 69 72 73 t name from firs
142a0 74 20 74 77 6f 20 65 6c 65 6d 65 6e 74 73 2e 20 t two elements.
142b0 54 68 69 73 20 69 73 20 61 20 68 61 6e 67 6f 76 This is a hangov
142c0 65 72 20 66 72 6f 6d 20 62 65 66 6f 72 65 20 49 er from before I
142d0 20 75 73 65 64 20 3f 20 69 6e 20 74 68 65 20 55 used ? in the U
142e0 52 4c 2e 29 0a 20 20 20 20 20 20 20 20 20 28 73 RL.). (s
142f0 65 73 73 69 6f 6e 2d 6b 65 79 20 20 20 28 73 64 ession-key (sd
14300 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e 2d 6b at-get-session-k
14310 65 79 20 73 65 6c 66 29 29 0a 09 20 28 70 61 72 ey self)).. (par
14320 61 6d 73 74 72 20 20 20 20 20 20 28 73 65 73 73 amstr (sess
14330 69 6f 6e 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e ion:param->strin
14340 67 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 g params))).
14350 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
14360 66 20 22 73 65 72 76 65 72 3d 22 20 73 65 72 76 f "server=" serv
14370 65 72 20 22 20 73 63 72 69 70 74 3d 22 20 73 63 er " script=" sc
14380 72 69 70 74 20 22 20 70 61 67 65 3d 22 20 70 61 ript " page=" pa
14390 67 65 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ge). (string-
143a0 61 70 70 65 6e 64 20 28 69 66 20 28 6f 72 20 68 append (if (or h
143b0 74 74 70 73 2d 68 6f 73 74 20 66 6f 72 63 65 2d ttps-host force-
143c0 73 73 6c 29 0a 09 09 20 20 20 20 20 20 22 68 74 ssl)... "ht
143d0 74 70 73 3a 2f 2f 22 0a 09 09 20 20 20 20 20 20 tps://"...
143e0 22 68 74 74 70 3a 2f 2f 22 29 0a 09 09 20 20 20 "http://")...
143f0 73 65 72 76 65 72 20 22 2f 22 20 73 63 72 69 70 server "/" scrip
14400 74 20 22 2f 22 20 70 61 67 65 20 22 3f 22 20 70 t "/" page "?" p
14410 61 72 61 6d 73 74 72 29 29 29 20 3b 3b 20 22 2f aramstr))) ;; "/
14420 73 6e 3d 22 20 73 65 73 73 69 6f 6e 2d 6b 65 79 sn=" session-key
14430 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
14440 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 ssion:cgi-out se
14450 6c 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f lf). (let* ((co
14460 6e 74 65 6e 74 20 20 28 6c 69 73 74 20 28 73 64 ntent (list (sd
14470 61 74 2d 67 65 74 2d 63 6f 6e 74 65 6e 74 2d 74 at-get-content-t
14480 79 70 65 20 73 65 6c 66 29 29 29 20 3b 3b 20 27 ype self))) ;; '
14490 28 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 ("Content-type:
144a0 74 65 78 74 2f 68 74 6d 6c 3b 20 63 68 61 72 73 text/html; chars
144b0 65 74 3d 69 73 6f 2d 38 38 35 39 2d 31 5c 6e 5c et=iso-8859-1\n\
144c0 6e 22 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 n")).. (header
144d0 20 28 6c 65 74 20 28 28 63 6f 6f 6b 69 65 20 28 (let ((cookie (
144e0 73 64 61 74 2d 67 65 74 2d 73 65 73 73 69 6f 6e sdat-get-session
144f0 2d 63 6f 6f 6b 69 65 20 73 65 6c 66 29 29 29 0a -cookie self))).
14500 09 09 20 20 20 20 20 28 69 66 20 63 6f 6f 6b 69 .. (if cooki
14510 65 0a 09 09 09 20 28 63 6f 6e 73 20 28 73 74 72 e.... (cons (str
14520 69 6e 67 2d 61 70 70 65 6e 64 20 22 53 65 74 2d ing-append "Set-
14530 43 6f 6f 6b 69 65 3a 20 22 20 28 63 61 72 20 63 Cookie: " (car c
14540 6f 6f 6b 69 65 29 29 0a 09 09 09 20 20 20 20 20 ookie))....
14550 20 20 63 6f 6e 74 65 6e 74 29 0a 09 09 09 20 63 content).... c
14560 6f 6e 74 65 6e 74 29 29 29 0a 09 20 28 70 61 67 ontent))).. (pag
14570 65 64 61 74 20 20 28 73 64 61 74 2d 67 65 74 2d edat (sdat-get-
14580 70 61 67 65 64 61 74 20 73 65 6c 66 29 29 29 0a pagedat self))).
14590 20 20 20 20 28 73 3a 63 67 69 2d 6f 75 74 20 0a (s:cgi-out .
145a0 20 20 20 20 20 28 63 6f 6e 73 20 68 65 61 64 65 (cons heade
145b0 72 20 70 61 67 65 64 61 74 29 29 29 29 0a 0a 28 r pagedat))))..(
145c0 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
145d0 6c 6f 67 20 73 65 6c 66 20 2e 20 6d 73 67 29 0a log self . msg).
145e0 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
145f0 6f 2d 70 6f 72 74 20 28 73 64 61 74 2d 67 65 74 o-port (sdat-get
14600 2d 6c 6f 67 2d 70 6f 72 74 20 73 65 6c 66 29 20 -log-port self)
14610 3b 3b 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 ;; (sdat-get-log
14620 70 74 20 73 65 6c 66 29 0a 20 20 20 20 28 6c 61 pt self). (la
14630 6d 62 64 61 20 28 29 20 0a 20 20 20 20 20 20 28 mbda () . (
14640 61 70 70 6c 79 20 70 72 69 6e 74 20 6d 73 67 29 apply print msg)
14650 29 29 29 0a 0a 3b 3b 20 65 73 63 61 70 65 2c 20 )))..;; escape,
14660 63 6f 6e 76 65 72 74 20 6f 72 20 72 65 74 75 72 convert or retur
14670 6e 20 72 61 77 20 77 68 65 6e 20 67 69 76 65 6e n raw when given
14680 20 75 73 65 72 20 69 6e 70 75 74 20 64 61 74 61 user input data
14690 20 74 68 61 74 20 70 6f 74 65 6e 74 69 61 6c 6c that potentiall
146a0 79 0a 3b 3b 20 63 6f 75 6c 64 20 62 65 20 6d 61 y.;; could be ma
146b0 6c 69 63 69 6f 75 73 0a 3b 3b 0a 28 64 65 66 69 licious.;;.(defi
146c0 6e 65 20 28 73 65 73 73 69 6f 6e 3a 61 70 70 6c ne (session:appl
146d0 79 2d 74 79 70 65 2d 70 72 65 66 65 72 65 6e 63 y-type-preferenc
146e0 65 20 72 65 73 20 70 61 72 61 6d 73 29 0a 20 20 e res params).
146f0 28 6c 65 74 2a 20 28 28 64 74 79 70 65 20 20 20 (let* ((dtype
14700 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 (if (null? para
14710 6d 73 29 0a 09 09 20 20 20 20 20 20 20 27 65 73 ms)... 'es
14720 63 61 70 65 64 0a 09 09 20 20 20 20 20 20 20 28 caped... (
14730 63 61 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 car params)))..
14740 28 74 61 67 73 20 20 20 20 28 69 66 20 28 6e 75 (tags (if (nu
14750 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 20 20 ll? params)...
14760 20 20 20 20 27 28 29 0a 09 09 20 20 20 20 20 20 '()...
14770 28 63 64 72 20 70 61 72 61 6d 73 29 29 29 29 0a (cdr params)))).
14780 20 20 20 20 28 63 61 73 65 20 64 74 79 70 65 0a (case dtype.
14790 20 20 20 20 20 20 28 28 72 61 77 29 20 20 20 20 ((raw)
147a0 20 72 65 73 29 0a 20 20 20 20 20 20 28 28 6e 75 res). ((nu
147b0 6d 62 65 72 29 20 20 28 69 66 20 28 73 74 72 69 mber) (if (stri
147c0 6e 67 3f 20 72 65 73 29 28 73 74 72 69 6e 67 2d ng? res)(string-
147d0 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 23 66 29 >number res) #f)
147e0 29 0a 20 20 20 20 20 20 28 28 65 73 63 61 70 65 ). ((escape
147f0 64 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 d) (if (string?
14800 72 65 73 29 0a 09 09 20 20 20 20 20 28 73 3a 68 res)... (s:h
14810 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 tml-filter->stri
14820 6e 67 20 72 65 73 20 74 61 67 73 29 0a 09 09 20 ng res tags)...
14830 20 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 res)).
14840 28 28 65 73 63 61 70 65 64 2d 6e 6c 29 20 28 69 ((escaped-nl) (i
14850 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 20 f (string? res)
14860 3b 3b 20 65 73 63 61 70 65 20 5c 6e 20 61 6e 64 ;; escape \n and
14870 20 5c 72 0a 09 09 09 28 73 74 72 69 6e 67 2d 69 \r....(string-i
14880 6e 74 65 72 73 70 65 72 73 65 0a 09 09 09 20 28 ntersperse.... (
14890 73 74 72 69 6e 67 2d 73 70 6c 69 74 0a 09 09 09 string-split....
148a0 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
148b0 70 65 72 73 65 0a 09 09 09 20 20 20 28 73 74 72 perse.... (str
148c0 69 6e 67 2d 73 70 6c 69 74 20 28 73 3a 68 74 6d ing-split (s:htm
148d0 6c 2d 66 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 l-filter->string
148e0 20 72 65 73 20 74 61 67 73 29 20 22 5c 6e 22 29 res tags) "\n")
148f0 0a 09 09 09 20 20 20 22 5c 5c 6e 22 29 0a 09 09 .... "\\n")...
14900 09 20 20 22 5c 72 22 29 0a 09 09 09 20 22 5c 5c . "\r").... "\\
14910 72 22 29 0a 09 09 09 72 65 73 29 29 20 3b 3b 20 r")....res)) ;;
14920 73 68 6f 75 6c 64 20 72 65 74 75 72 6e 20 23 66 should return #f
14930 20 69 66 20 6e 6f 74 20 61 20 73 74 72 69 6e 67 if not a string
14940 20 61 6e 64 20 63 61 6e 27 74 20 65 73 63 61 70 and can't escap
14950 65 20 69 74 3f 0a 20 20 20 20 20 20 28 65 6c 73 e it?. (els
14960 65 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 e (if (stri
14970 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 ng? res)...
14980 28 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e (s:html-filter->
14990 73 74 72 69 6e 67 20 72 65 73 20 27 28 29 29 0a string res '()).
149a0 09 09 20 20 20 20 20 72 65 73 29 29 29 29 29 0a .. res))))).
149b0 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 65 73 73 .#;(define (sess
149c0 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d 66 72 ion:get-param-fr
149d0 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 om params key).
149e0 20 28 6c 65 74 20 28 28 72 31 20 28 72 65 67 65 (let ((r1 (rege
149f0 78 70 20 28 63 6f 6e 63 20 22 5e 22 20 28 73 3a xp (conc "^" (s:
14a00 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 any->string key)
14a10 20 22 3d 28 2e 2a 29 24 22 29 29 29 29 0a 20 20 "=(.*)$")))).
14a20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 (if (null? par
14a30 61 6d 73 29 20 23 66 0a 20 20 20 20 20 20 20 20 ams) #f.
14a40 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 (let loop ((head
14a50 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 (car params)).
14a60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14a70 20 20 28 74 61 69 6c 20 28 63 64 72 20 70 61 72 (tail (cdr par
14a80 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 ams))).
14a90 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 (let ((match (s
14aa0 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 20 68 tring-match r1 h
14ab0 65 61 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 ead))).
14ac0 20 20 20 28 69 66 20 6d 61 74 63 68 0a 20 20 20 (if match.
14ad0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
14ae0 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 29 0a st-ref match 1).
14af0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14b00 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 (if (null? tail)
14b10 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
14b20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 (loop (c
14b30 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 ar tail)(cdr tai
14b40 6c 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 70 l)))))))))..;; p
14b50 61 72 61 6d 73 20 61 72 65 20 73 74 6f 72 65 64 arams are stored
14b60 20 61 73 20 6c 69 73 74 20 6f 66 20 6b 65 79 3d as list of key=
14b70 76 61 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 val.;;.(define (
14b80 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
14b90 6d 20 73 65 6c 66 20 6b 65 79 20 74 79 70 65 2d m self key type-
14ba0 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 73 65 params). ;; (se
14bb0 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 73 ssion:log s:sess
14bc0 69 6f 6e 20 22 70 61 72 61 6d 73 3d 22 20 28 73 ion "params=" (s
14bd0 6c 6f 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f lot-ref s:sessio
14be0 6e 20 27 70 61 72 61 6d 73 29 29 0a 20 20 28 6c n 'params)). (l
14bf0 65 74 2a 20 28 28 70 61 72 61 6d 73 20 28 73 64 et* ((params (sd
14c00 61 74 2d 67 65 74 2d 70 61 72 61 6d 73 20 73 65 at-get-params se
14c10 6c 66 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 lf)).. (res (
14c20 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
14c30 6d 2d 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 m-from params ke
14c40 79 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f y))). (sessio
14c50 6e 3a 61 70 70 6c 79 2d 74 79 70 65 2d 70 72 65 n:apply-type-pre
14c60 66 65 72 65 6e 63 65 20 72 65 73 20 74 79 70 65 ference res type
14c70 2d 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 54 -params)))..;; T
14c80 68 69 73 20 6f 6e 65 20 77 69 6c 6c 20 67 65 74 his one will get
14c90 20 74 68 65 20 66 69 72 73 74 20 76 61 6c 75 65 the first value
14ca0 20 66 6f 75 6e 64 20 72 65 67 61 72 64 6c 65 73 found regardles
14cb0 73 20 6f 66 20 66 6f 72 6d 0a 3b 3b 20 70 61 72 s of form.;; par
14cc0 61 6d 3a 20 28 64 74 79 70 65 20 5b 74 61 67 31 am: (dtype [tag1
14cd0 20 74 61 67 32 20 2e 2e 2e 5d 29 0a 3b 3b 20 64 tag2 ...]).;; d
14ce0 74 79 70 65 3a 0a 3b 3b 20 20 20 20 27 72 61 77 type:.;; 'raw
14cf0 20 20 20 20 20 3a 20 64 6f 20 6e 6f 20 63 6f 6e : do no con
14d00 76 65 72 73 69 6f 6e 0a 3b 3b 20 20 20 20 27 6e version.;; 'n
14d10 75 6d 62 65 72 20 20 3a 20 63 6f 6e 76 65 72 74 umber : convert
14d20 20 74 6f 20 6e 75 6d 62 65 72 2c 20 72 65 74 75 to number, retu
14d30 72 6e 20 23 66 20 69 66 20 66 61 69 6c 73 0a 3b rn #f if fails.;
14d40 3b 20 20 20 20 27 65 73 63 61 70 65 64 20 3a 20 ; 'escaped :
14d50 75 73 65 20 68 74 6d 6c 2d 65 73 63 61 70 65 20 use html-escape
14d60 74 6f 20 70 72 6f 74 65 63 74 20 74 68 65 20 69 to protect the i
14d70 6e 70 75 74 20 2d 2d 20 74 68 69 73 20 69 73 20 nput -- this is
14d80 74 68 65 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 the default.;;.(
14d90 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
14da0 67 65 74 2d 69 6e 70 75 74 20 73 65 6c 66 20 6b get-input self k
14db0 65 79 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 ey params). (le
14dc0 74 2a 20 28 28 64 74 79 70 65 20 20 20 20 28 69 t* ((dtype (i
14dd0 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
14de0 0a 09 09 20 20 20 20 20 20 20 27 65 73 63 61 70 ... 'escap
14df0 65 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 ed... (car
14e00 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 74 61 params))).. (ta
14e10 67 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f gs (if (null?
14e20 20 70 61 72 61 6d 73 29 0a 09 09 20 20 20 20 20 params)...
14e30 20 27 28 29 0a 09 09 20 20 20 20 20 20 28 63 64 '()... (cd
14e40 72 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 66 r params))).. (f
14e50 6f 72 6d 64 61 74 20 28 73 64 61 74 2d 67 65 74 ormdat (sdat-get
14e60 2d 66 6f 72 6d 64 61 74 20 73 65 6c 66 29 29 0a -formdat self)).
14e70 09 20 28 72 65 73 20 20 20 20 20 28 69 66 20 28 . (res (if (
14e80 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 0a not formdat) #f.
14e90 09 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 .. (if (or
14ea0 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 28 6e 75 (string? key)(nu
14eb0 6d 62 65 72 3f 20 6b 65 79 29 28 73 79 6d 62 6f mber? key)(symbo
14ec0 6c 3f 20 6b 65 79 29 29 0a 09 09 09 20 20 28 69 l? key)).... (i
14ed0 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
14ee0 66 6f 72 6d 64 61 74 29 28 65 71 3f 20 28 76 65 formdat)(eq? (ve
14ef0 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 6f 72 6d ctor-length form
14f00 64 61 74 29 20 31 29 28 68 61 73 68 2d 74 61 62 dat) 1)(hash-tab
14f10 6c 65 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 le? (vector-ref
14f20 66 6f 72 6d 64 61 74 20 30 29 29 29 0a 09 09 09 formdat 0)))....
14f30 20 20 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 67 (formdat:g
14f40 65 74 20 66 6f 72 6d 64 61 74 20 6b 65 79 29 0a et formdat key).
14f50 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
14f60 09 09 09 09 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 ....(session:log
14f70 20 73 65 6c 66 20 22 45 52 52 4f 52 3a 20 66 6f self "ERROR: fo
14f80 72 6d 64 61 74 3a 20 22 20 66 6f 72 6d 64 61 74 rmdat: " formdat
14f90 20 22 20 69 73 20 6e 6f 74 20 6f 66 20 63 6c 61 " is not of cla
14fa0 73 73 20 3c 66 6f 72 6d 64 61 74 3e 22 29 0a 09 ss <formdat>")..
14fb0 09 09 09 23 66 29 29 0a 09 09 09 20 20 28 62 65 ...#f)).... (be
14fc0 67 69 6e 0a 09 09 09 20 20 20 20 28 73 65 73 73 gin.... (sess
14fd0 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 45 52 ion:log self "ER
14fe0 52 4f 52 3a 20 62 61 64 20 6b 65 79 20 22 20 6b ROR: bad key " k
14ff0 65 79 29 0a 09 09 09 20 20 20 20 23 66 29 29 29 ey).... #f)))
15000 29 29 0a 20 20 20 20 28 63 61 73 65 20 64 74 79 )). (case dty
15010 70 65 0a 20 20 20 20 20 20 28 28 72 61 77 29 20 pe. ((raw)
15020 20 20 20 20 72 65 73 29 0a 20 20 20 20 20 20 28 res). (
15030 28 6e 75 6d 62 65 72 29 20 20 28 69 66 20 28 73 (number) (if (s
15040 74 72 69 6e 67 3f 20 72 65 73 29 28 73 74 72 69 tring? res)(stri
15050 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 20 ng->number res)
15060 23 66 29 29 0a 20 20 20 20 20 20 28 28 65 73 63 #f)). ((esc
15070 61 70 65 64 29 20 28 69 66 20 28 73 74 72 69 6e aped) (if (strin
15080 67 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 g? res)... (
15090 73 3a 68 74 6d 6c 2d 66 69 6c 74 65 72 2d 3e 73 s:html-filter->s
150a0 74 72 69 6e 67 20 72 65 73 20 74 61 67 73 29 0a tring res tags).
150b0 09 09 20 20 20 20 20 72 65 73 29 29 0a 20 20 20 .. res)).
150c0 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 28 69 (else (i
150d0 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a f (string? res).
150e0 09 09 20 20 20 20 20 28 73 3a 68 74 6d 6c 2d 66 .. (s:html-f
150f0 69 6c 74 65 72 2d 3e 73 74 72 69 6e 67 20 72 65 ilter->string re
15100 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 72 65 s '())... re
15110 73 29 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 s)))))..;; This
15120 6f 6e 65 20 77 69 6c 6c 20 67 65 74 20 74 68 65 one will get the
15130 20 66 69 72 73 74 20 76 61 6c 75 65 20 66 6f 75 first value fou
15140 6e 64 20 72 65 67 61 72 64 6c 65 73 73 20 6f 66 nd regardless of
15150 20 66 6f 72 6d 0a 28 64 65 66 69 6e 65 20 28 73 form.(define (s
15160 65 73 73 69 6f 6e 3a 67 65 74 2d 69 6e 70 75 74 ession:get-input
15170 2d 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 28 6c -keys self). (l
15180 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 28 73 et* ((formdat (s
15190 64 61 74 2d 67 65 74 2d 66 6f 72 6d 64 61 74 20 dat-get-formdat
151a0 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 66 20 self))). (if
151b0 28 6e 6f 74 20 66 6f 72 6d 64 61 74 29 20 23 66 (not formdat) #f
151c0 0a 09 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 ..(if (and (vect
151d0 6f 72 3f 20 66 6f 72 6d 64 61 74 29 28 65 71 3f or? formdat)(eq?
151e0 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 (vector-length
151f0 66 6f 72 6d 64 61 74 29 20 31 29 28 68 61 73 68 formdat) 1)(hash
15200 2d 74 61 62 6c 65 3f 20 28 76 65 63 74 6f 72 2d -table? (vector-
15210 72 65 66 20 66 6f 72 6d 64 61 74 20 30 29 29 29 ref formdat 0)))
15220 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 6b .. (formdat:k
15230 65 79 73 20 66 6f 72 6d 64 61 74 29 0a 09 20 20 eys formdat)..
15240 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
15250 28 73 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c (session:log sel
15260 66 20 22 45 52 52 4f 52 3a 20 66 6f 72 6d 64 61 f "ERROR: formda
15270 74 3a 20 22 20 66 6f 72 6d 64 61 74 20 22 20 69 t: " formdat " i
15280 73 20 6e 6f 74 20 6f 66 20 63 6c 61 73 73 20 3c s not of class <
15290 66 6f 72 6d 64 61 74 3e 22 29 0a 09 20 20 20 20 formdat>")..
152a0 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 #f)))))..(defi
152b0 6e 65 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e 2d ne (session:run-
152c0 61 63 74 69 6f 6e 73 20 73 65 6c 66 29 0a 20 20 actions self).
152d0 28 6c 65 74 2a 20 28 28 61 63 74 69 6f 6e 20 20 (let* ((action
152e0 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 (session:get-p
152f0 61 72 61 6d 20 73 65 6c 66 20 27 61 63 74 69 6f aram self 'actio
15300 6e 20 27 28 72 61 77 29 29 29 0a 09 20 28 70 61 n '(raw))).. (pa
15310 67 65 20 20 20 20 20 20 28 73 64 61 74 2d 67 65 ge (sdat-ge
15320 74 2d 70 61 67 65 20 73 65 6c 66 29 29 29 0a 20 t-page self))).
15330 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 61 63 ;; (print "ac
15340 74 69 6f 6e 3d 22 20 61 63 74 69 6f 6e 20 22 20 tion=" action "
15350 70 61 67 65 3d 22 20 70 61 67 65 29 0a 20 20 20 page=" page).
15360 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 28 6c 65 (if action..(le
15370 74 20 28 28 61 63 74 69 6f 6e 2d 6c 73 74 20 20 t ((action-lst
15380 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 61 63 (string-split ac
15390 74 69 6f 6e 20 22 2e 22 29 29 29 0a 09 20 20 3b tion "."))).. ;
153a0 3b 20 28 70 72 69 6e 74 20 22 61 63 74 69 6f 6e ; (print "action
153b0 2d 6c 73 74 3d 22 20 61 63 74 69 6f 6e 2d 6c 73 -lst=" action-ls
153c0 74 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 t).. (if (not (
153d0 3d 20 28 6c 65 6e 67 74 68 20 61 63 74 69 6f 6e = (length action
153e0 2d 6c 73 74 29 20 32 29 29 20 0a 09 20 20 20 20 -lst) 2)) ..
153f0 20 20 28 65 72 72 3a 6c 6f 67 20 22 41 63 74 69 (err:log "Acti
15400 6f 6e 20 73 68 6f 75 6c 64 20 62 65 20 6f 66 20 on should be of
15410 66 6f 72 6d 3a 20 6d 6f 64 75 6c 65 2e 61 63 74 form: module.act
15420 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 6c 65 ion").. (le
15430 74 2a 20 28 28 74 61 72 67 2d 70 61 67 65 20 20 t* ((targ-page
15440 20 28 63 61 72 20 61 63 74 69 6f 6e 2d 6c 73 74 (car action-lst
15450 29 29 0a 09 09 20 20 20 20 20 28 70 72 6f 63 2d ))... (proc-
15460 6e 61 6d 65 20 20 20 28 73 74 72 69 6e 67 2d 61 name (string-a
15470 70 70 65 6e 64 20 74 61 72 67 2d 70 61 67 65 20 ppend targ-page
15480 22 2d 61 63 74 69 6f 6e 22 29 29 0a 09 09 20 20 "-action"))...
15490 20 20 20 28 74 61 72 67 2d 61 63 74 69 6f 6e 20 (targ-action
154a0 28 63 61 64 72 20 61 63 74 69 6f 6e 2d 6c 73 74 (cadr action-lst
154b0 29 29 29 0a 09 09 3b 3b 20 28 65 72 72 3a 6c 6f )))...;; (err:lo
154c0 67 20 22 74 61 72 67 2d 70 61 67 65 3d 22 20 74 g "targ-page=" t
154d0 61 72 67 2d 70 61 67 65 20 22 20 70 72 6f 63 2d arg-page " proc-
154e0 6e 61 6d 65 3d 22 20 70 72 6f 63 2d 6e 61 6d 65 name=" proc-name
154f0 20 22 20 74 61 72 67 2d 61 63 74 69 6f 6e 3d 22 " targ-action="
15500 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 0a 0a 09 targ-action)...
15510 09 3b 3b 20 63 61 6c 6c 20 68 65 72 65 20 6f 6e .;; call here on
15520 6c 79 20 69 66 20 6e 65 76 65 72 20 63 61 6c 6c ly if never call
15530 65 64 20 62 65 66 6f 72 65 0a 09 09 28 69 66 20 ed before...(if
15540 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 (session:never-c
15550 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 65 6c 66 alled-page? self
15560 20 74 61 72 67 2d 70 61 67 65 29 0a 09 09 20 20 targ-page)...
15570 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 2d (session:call-
15580 70 61 72 74 73 20 73 65 6c 66 20 74 61 72 67 2d parts self targ-
15590 70 61 67 65 20 27 63 6f 6e 74 72 6f 6c 29 29 0a page 'control)).
155a0 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ..;;
155b0 20 20 20 20 20 20 20 20 70 72 6f 63 20 20 20 20 proc
155c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
155d0 20 20 20 20 20 61 63 74 69 6f 6e 20 20 20 20 0a action .
155e0 0a 09 09 28 69 66 20 23 74 20 3b 3b 20 73 65 74 ...(if #t ;; set
155f0 20 74 6f 20 23 74 20 74 6f 20 73 65 65 20 62 65 to #t to see be
15600 74 74 65 72 20 65 72 72 6f 72 20 6d 65 73 73 61 tter error messa
15610 67 65 73 20 64 75 72 69 6e 67 20 64 65 62 75 67 ges during debug
15620 67 69 6e 20 3a 2d 29 0a 09 09 20 20 20 20 28 28 gin :-)... ((
15630 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
15640 6d 62 6f 6c 20 70 72 6f 63 2d 6e 61 6d 65 29 29 mbol proc-name))
15650 20 74 61 72 67 2d 61 63 74 69 6f 6e 29 20 3b 3b targ-action) ;;
15660 20 75 6e 73 61 66 65 20 65 78 65 63 75 74 69 6f unsafe executio
15670 6e 0a 09 09 20 20 20 20 28 63 6f 6e 64 69 74 69 n... (conditi
15680 6f 6e 2d 63 61 73 65 20 28 28 65 76 61 6c 20 28 on-case ((eval (
15690 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 string->symbol p
156a0 72 6f 63 2d 6e 61 6d 65 29 29 20 74 61 72 67 2d roc-name)) targ-
156b0 61 63 74 69 6f 6e 29 0a 09 09 09 09 20 20 20 20 action).....
156c0 28 28 65 78 6e 20 66 69 6c 65 29 20 28 73 3a 6c ((exn file) (s:l
156d0 6f 67 20 22 66 69 6c 65 20 65 72 72 6f 72 22 29 og "file error")
156e0 29 0a 09 09 09 09 20 20 20 20 28 28 65 78 6e 20 )..... ((exn
156f0 69 2f 6f 29 20 20 28 73 3a 6c 6f 67 20 22 69 2f i/o) (s:log "i/
15700 6f 20 65 72 72 6f 72 22 29 29 0a 09 09 09 09 20 o error")).....
15710 20 20 20 28 28 65 78 6e 20 29 20 20 20 20 20 28 ((exn ) (
15720 73 3a 6c 6f 67 20 22 41 63 74 69 6f 6e 20 6e 6f s:log "Action no
15730 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 3a 20 22 t implemented: "
15740 20 70 72 6f 63 2d 6e 61 6d 65 20 22 20 61 63 74 proc-name " act
15750 69 6f 6e 3a 20 22 20 74 61 72 67 2d 61 63 74 69 ion: " targ-acti
15760 6f 6e 29 29 0a 09 09 09 09 20 20 20 20 28 76 61 on))..... (va
15770 72 20 28 29 20 20 20 20 20 28 73 3a 6c 6f 67 20 r () (s:log
15780 22 55 6e 6b 6e 6f 77 6e 20 45 72 72 6f 72 22 29 "Unknown Error")
15790 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 )))))))))..(defi
157a0 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6e 65 76 65 ne (session:neve
157b0 72 2d 63 61 6c 6c 65 64 2d 70 61 67 65 3f 20 73 r-called-page? s
157c0 65 6c 66 20 70 61 67 65 29 0a 20 20 28 73 65 73 elf page). (ses
157d0 73 69 6f 6e 3a 6c 6f 67 20 73 65 6c 66 20 22 43 sion:log self "C
157e0 68 65 63 6b 69 6e 67 20 66 6f 72 20 70 61 67 65 hecking for page
157f0 3a 20 22 20 70 61 67 65 29 0a 20 20 28 6e 6f 74 : " page). (not
15800 20 28 6d 65 6d 62 65 72 20 70 61 67 65 20 28 73 (member page (s
15810 64 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 dat-get-seen-pag
15820 65 73 20 73 65 6c 66 29 29 29 29 0a 0a 28 64 65 es self))))..(de
15830 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 73 65 fine (session:se
15840 74 2d 63 61 6c 6c 65 64 21 20 73 65 6c 66 20 70 t-called! self p
15850 61 67 65 29 0a 20 20 28 73 64 61 74 2d 73 65 74 age). (sdat-set
15860 2d 73 65 65 6e 2d 70 61 67 65 73 21 20 73 65 6c -seen-pages! sel
15870 66 20 28 63 6f 6e 73 20 70 61 67 65 20 28 73 64 f (cons page (sd
15880 61 74 2d 67 65 74 2d 73 65 65 6e 2d 70 61 67 65 at-get-seen-page
15890 73 20 73 65 6c 66 29 29 29 29 0a 0a 3b 3b 3d 3d s self))))..;;==
158a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
158e0 3d 3d 3d 3d 0a 3b 3b 20 41 6c 74 65 72 6e 61 74 ====.;; Alternat
158f0 69 76 65 20 64 61 74 61 20 74 79 70 65 20 64 65 ive data type de
15900 6c 69 76 65 72 79 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d livery.;;=======
15910 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15920 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15930 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15940 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
15950 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f .(define (sessio
15960 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 6c 66 29 0a n:alt-out self).
15970 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 73 64 (let ((dat (sd
15980 61 74 2d 67 65 74 2d 61 6c 74 2d 70 61 67 65 2d at-get-alt-page-
15990 64 61 74 20 73 65 6c 66 29 29 29 0a 20 20 20 20 dat self))).
159a0 3b 3b 20 28 73 3a 6c 6f 67 20 22 64 61 74 20 69 ;; (s:log "dat i
159b0 73 3a 20 22 20 64 61 74 29 0a 20 20 20 20 3b 3b s: " dat). ;;
159c0 20 28 70 72 69 6e 74 20 22 48 54 54 50 2f 31 2e (print "HTTP/1.
159d0 31 20 32 30 30 20 4f 4b 22 29 0a 20 20 20 20 28 1 200 OK"). (
159e0 70 72 69 6e 74 20 22 44 61 74 65 3a 20 22 20 28 print "Date: " (
159f0 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 time->string (se
15a00 63 6f 6e 64 73 2d 3e 75 74 63 2d 74 69 6d 65 20 conds->utc-time
15a10 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
15a20 29 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 )))). (print
15a30 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 20 22 "Content-Type: "
15a40 20 28 73 64 61 74 2d 67 65 74 2d 63 6f 6e 74 65 (sdat-get-conte
15a50 6e 74 2d 74 79 70 65 20 73 65 6c 66 29 29 0a 20 nt-type self)).
15a60 20 20 20 28 70 72 69 6e 74 20 22 41 63 63 65 70 (print "Accep
15a70 74 2d 52 61 6e 67 65 73 3a 20 62 79 74 65 73 22 t-Ranges: bytes"
15a80 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 43 6f ). (print "Co
15a90 6e 74 65 6e 74 2d 4c 65 6e 67 74 68 3a 20 22 20 ntent-Length: "
15aa0 28 69 66 20 28 62 6c 6f 62 3f 20 64 61 74 29 0a (if (blob? dat).
15ab0 09 09 09 09 20 20 28 62 6c 6f 62 2d 73 69 7a 65 .... (blob-size
15ac0 20 64 61 74 29 0a 09 09 09 09 20 20 30 29 29 0a dat)..... 0)).
15ad0 20 20 20 20 28 70 72 69 6e 74 20 22 4b 65 65 70 (print "Keep
15ae0 2d 41 6c 69 76 65 3a 20 74 69 6d 65 6f 75 74 3d -Alive: timeout=
15af0 31 35 2c 20 6d 61 78 3d 31 30 30 22 29 0a 20 20 15, max=100").
15b00 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 63 (print "Connec
15b10 74 69 6f 6e 3a 20 4b 65 65 70 2d 41 6c 69 76 65 tion: Keep-Alive
15b20 22 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 22 "). (print ""
15b30 29 0a 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 ). (write-str
15b40 69 6e 67 20 28 62 6c 6f 62 2d 3e 73 74 72 69 6e ing (blob->strin
15b50 67 20 64 61 74 29 20 23 66 20 28 63 75 72 72 65 g dat) #f (curre
15b60 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 nt-output-port))
15b70 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
15b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
15bc0 4f 72 70 68 61 6e 65 64 20 66 75 6e 63 74 69 6f Orphaned functio
15bd0 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
15be0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15bf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15c00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15c10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
15c20 77 61 73 20 69 6e 20 73 65 74 75 70 0a 3b 3b 0a was in setup.;;.
15c30 28 64 65 66 69 6e 65 20 28 73 3a 6c 6f 67 20 2e (define (s:log .
15c40 20 6d 73 67 29 0a 20 20 28 61 70 70 6c 79 20 73 msg). (apply s
15c50 65 73 73 69 6f 6e 3a 6c 6f 67 20 73 3a 73 65 73 ession:log s:ses
15c60 73 69 6f 6e 20 6d 73 67 29 29 0a 0a 0a 3b 3b 20 sion msg))...;;
15c70 55 73 61 67 65 3a 20 28 73 3a 67 65 74 2d 65 72 Usage: (s:get-er
15c80 72 20 73 3a 62 69 67 29 0a 28 64 65 66 69 6e 65 r s:big).(define
15c90 20 28 73 3a 67 65 74 2d 65 72 72 20 77 72 61 70 (s:get-err wrap
15ca0 70 65 72 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 perfunc). (let
15cb0 28 28 65 72 72 6d 73 67 20 28 73 64 61 74 2d 67 ((errmsg (sdat-g
15cc0 65 74 2d 63 75 72 72 2d 65 72 72 20 73 3a 73 65 et-curr-err s:se
15cd0 73 73 69 6f 6e 29 29 29 0a 20 20 20 20 28 69 66 ssion))). (if
15ce0 20 65 72 72 6d 73 67 20 28 28 69 66 20 77 72 61 errmsg ((if wra
15cf0 70 70 65 72 66 75 6e 63 0a 20 20 20 20 20 20 20 pperfunc.
15d00 20 20 20 20 20 20 20 20 20 20 20 20 20 77 72 61 wra
15d10 70 70 65 72 66 75 6e 63 0a 20 20 20 20 20 20 20 pperfunc.
15d20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 3a 73 s:s
15d30 74 72 6f 6e 67 29 20 65 72 72 6d 73 67 29 20 27 trong) errmsg) '
15d40 28 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 73 ()))).(define (s
15d50 74 6d 6c 3a 63 67 69 2d 73 65 73 73 69 6f 6e 20 tml:cgi-session
15d60 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 session). (sess
15d70 69 6f 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 ion:initialize s
15d80 65 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 ession). (sessi
15d90 6f 6e 3a 73 65 74 75 70 20 73 65 73 73 69 6f 6e on:setup session
15da0 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 74 ). (session:get
15db0 2d 76 61 72 73 20 73 65 73 73 69 6f 6e 29 0a 0a -vars session)..
15dc0 20 20 28 73 64 61 74 2d 73 65 74 2d 6c 6f 67 2d (sdat-set-log-
15dd0 70 6f 72 74 21 20 73 65 73 73 69 6f 6e 20 3b 3b port! session ;;
15de0 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
15df0 70 6f 72 74 29 29 0a 09 09 20 20 20 20 20 20 28 port))... (
15e00 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
15e10 20 28 73 64 61 74 2d 67 65 74 2d 6c 6f 67 66 69 (sdat-get-logfi
15e20 6c 65 20 73 65 73 73 69 6f 6e 29 20 23 3a 61 70 le session) #:ap
15e30 70 65 6e 64 29 29 0a 20 20 28 73 3a 76 61 6c 69 pend)). (s:vali
15e40 64 61 74 65 2d 69 6e 70 75 74 73 29 0a 20 20 28 date-inputs). (
15e50 73 65 73 73 69 6f 6e 3a 72 75 6e 2d 61 63 74 69 session:run-acti
15e60 6f 6e 73 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 ons session). (
15e70 73 64 61 74 2d 73 65 74 2d 70 61 67 65 64 61 74 sdat-set-pagedat
15e80 21 20 73 65 73 73 69 6f 6e 0a 09 09 20 20 20 20 ! session...
15e90 20 28 61 70 70 65 6e 64 20 28 73 64 61 74 2d 67 (append (sdat-g
15ea0 65 74 2d 70 61 67 65 64 61 74 20 73 65 73 73 69 et-pagedat sessi
15eb0 6f 6e 29 0a 09 09 09 20 20 20 20 20 28 73 3a 63 on).... (s:c
15ec0 61 6c 6c 20 28 73 64 61 74 2d 67 65 74 2d 74 6f all (sdat-get-to
15ed0 70 70 61 67 65 20 73 65 73 73 69 6f 6e 29 29 29 ppage session)))
15ee0 29 0a 20 20 28 69 66 20 28 65 71 3f 20 28 73 64 ). (if (eq? (sd
15ef0 61 74 2d 67 65 74 2d 70 61 67 65 2d 74 79 70 65 at-get-page-type
15f00 20 73 65 73 73 69 6f 6e 29 20 27 68 74 6d 6c 29 session) 'html)
15f10 20 3b 3b 20 64 65 66 61 75 6c 74 20 69 73 20 68 ;; default is h
15f20 74 6d 6c 2e 20 0a 20 20 20 20 20 20 28 73 65 73 tml. . (ses
15f30 73 69 6f 6e 3a 63 67 69 2d 6f 75 74 20 73 65 73 sion:cgi-out ses
15f40 73 69 6f 6e 29 0a 20 20 20 20 20 20 28 73 65 73 sion). (ses
15f50 73 69 6f 6e 3a 61 6c 74 2d 6f 75 74 20 73 65 73 sion:alt-out ses
15f60 73 69 6f 6e 29 29 0a 20 20 28 73 65 73 73 69 6f sion)). (sessio
15f70 6e 3a 73 61 76 65 2d 76 61 72 73 20 73 65 73 73 n:save-vars sess
15f80 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a ion). (session:
15f90 63 6c 6f 73 65 20 73 65 73 73 69 6f 6e 29 29 0a close session)).
15fa0 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 76 61 6c ..(define (s:val
15fb0 69 64 61 74 65 2d 69 6e 70 75 74 73 29 0a 20 20 idate-inputs).
15fc0 28 69 66 20 28 6e 6f 74 20 28 73 3a 76 61 6c 69 (if (not (s:vali
15fd0 64 61 74 65 2d 75 72 69 29 29 0a 20 20 20 20 20 date-uri)).
15fe0 20 28 62 65 67 69 6e 20 28 73 3a 65 72 72 6f 72 (begin (s:error
15ff0 2d 70 61 67 65 20 22 42 61 64 20 55 52 49 22 20 -page "Bad URI"
16000 28 6c 65 74 20 28 28 72 65 66 20 28 67 65 74 2d (let ((ref (get-
16010 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
16020 61 62 6c 65 20 22 48 54 54 50 5f 52 45 46 45 52 able "HTTP_REFER
16030 45 52 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 ER"))).....
16040 20 20 28 69 66 20 72 65 66 0a 09 09 09 09 09 20 (if ref......
16050 20 20 28 6c 69 73 74 20 22 72 65 66 65 72 72 65 (list "referre
16060 64 20 66 72 6f 6d 22 20 72 65 66 29 0a 09 09 09 d from" ref)....
16070 09 09 20 20 20 22 22 29 29 29 0a 09 20 20 20 20 .. "")))..
16080 20 28 65 78 69 74 29 29 29 29 0a 0a 28 64 65 66 (exit))))..(def
16090 69 6e 65 20 28 73 3a 65 72 72 6f 72 2d 70 61 67 ine (s:error-pag
160a0 65 20 2e 20 65 72 72 29 0a 20 20 28 73 3a 63 67 e . err). (s:cg
160b0 69 2d 6f 75 74 20 28 63 6f 6e 73 20 22 43 6f 6e i-out (cons "Con
160c0 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f tent-type: text/
160d0 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 html; charset=is
160e0 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 0a 09 09 o-8859-1\n\n"...
160f0 20 20 20 28 73 3a 68 74 6d 6c 20 28 73 3a 68 65 (s:html (s:he
16100 61 64 20 0a 09 09 09 20 20 20 20 28 73 3a 74 69 ad .... (s:ti
16110 74 6c 65 20 65 72 72 29 0a 09 09 09 20 20 20 20 tle err)....
16120 28 73 3a 62 6f 64 79 0a 09 09 09 20 20 20 20 20 (s:body....
16130 28 73 3a 68 31 20 22 45 52 52 4f 52 22 29 0a 09 (s:h1 "ERROR")..
16140 09 09 20 20 20 20 20 28 73 3a 70 20 65 72 72 29 .. (s:p err)
16150 29 29 29 29 29 29 20 20 20 20 20 20 20 20 20 20 ))))))
16160 20 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 6d ...(define (stm
16170 6c 3a 6d 61 69 6e 20 70 72 6f 63 29 0a 20 20 28 l:main proc). (
16180 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
16190 73 0a 20 20 20 65 78 6e 20 20 20 0a 20 20 20 28 s. exn . (
161a0 69 66 20 28 73 64 61 74 2d 67 65 74 2d 64 65 62 if (sdat-get-deb
161b0 75 67 6d 6f 64 65 20 73 3a 73 65 73 73 69 6f 6e ugmode s:session
161c0 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a ). (begin.
161d0 09 20 28 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e . (print "Conten
161e0 74 2d 74 79 70 65 3a 20 74 65 78 74 2f 68 74 6d t-type: text/htm
161f0 6c 22 29 0a 09 20 28 70 72 69 6e 74 20 22 22 29 l").. (print "")
16200 0a 09 20 28 70 72 69 6e 74 20 22 3c 68 74 6d 6c .. (print "<html
16210 3e 20 3c 68 65 61 64 3e 20 3c 74 69 74 6c 65 3e > <head> <title>
16220 45 58 43 45 50 54 49 4f 4e 3c 2f 74 69 74 6c 65 EXCEPTION</title
16230 3e 20 3c 2f 68 65 61 64 3e 20 3c 62 6f 64 79 3e > </head> <body>
16240 22 29 0a 09 20 28 70 72 69 6e 74 20 22 20 20 20 ").. (print "
16250 51 55 45 52 59 5f 53 54 52 49 4e 47 20 69 73 3a QUERY_STRING is:
16260 20 3c 62 3e 20 22 20 28 67 65 74 2d 65 6e 76 69 <b> " (get-envi
16270 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
16280 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 "QUERY_STRING")
16290 20 22 20 3c 2f 62 3e 20 3c 62 72 3e 22 29 0a 09 " </b> <br>")..
162a0 20 28 70 72 69 6e 74 20 22 3c 70 72 65 3e 22 29 (print "<pre>")
162b0 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 .. ;; (print "
162c0 20 45 58 43 45 50 54 49 4f 4e 3a 20 22 20 28 28 EXCEPTION: " ((
162d0 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
162e0 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
162f0 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
16300 0a 09 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d .. (print-error-
16310 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 09 20 28 message exn).. (
16320 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
16330 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f 70 72 ).. (print "</pr
16340 65 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c e>").. (print "<
16350 74 61 62 6c 65 3e 22 29 0a 09 20 28 66 6f 72 2d table>").. (for-
16360 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 each (lambda (va
16370 72 29 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 r)... (print
16380 20 22 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 "<tr><td>" (car
16390 20 76 61 72 29 20 22 3c 2f 74 64 3e 3c 74 64 3e var) "</td><td>
163a0 22 20 28 63 64 72 20 76 61 72 29 20 22 3c 2f 74 " (cdr var) "</t
163b0 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 20 d></tr>"))...
163c0 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
163d0 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 09 20 28 -variables)).. (
163e0 70 72 69 6e 74 20 22 3c 2f 74 61 62 6c 65 3e 22 print "</table>"
163f0 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f 62 6f ).. (print "</bo
16400 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 29 0a 20 20 dy></html>")).
16410 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 28 77 (begin.. (w
16420 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
16430 6c 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 73 le (conc "/tmp/s
16440 74 6d 6c 2d 63 72 61 73 68 2d 22 20 28 63 75 72 tml-crash-" (cur
16450 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
16460 20 22 2e 6c 6f 67 22 29 0a 09 20 20 20 28 6c 61 ".log").. (la
16470 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 28 70 mbda ().. (p
16480 72 69 6e 74 20 22 45 58 43 45 50 54 49 4f 4e 22 rint "EXCEPTION"
16490 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ).. (print "
164a0 20 20 20 51 55 45 52 59 5f 53 54 52 49 4e 47 20 QUERY_STRING
164b0 69 73 3a 20 22 20 28 67 65 74 2d 65 6e 76 69 72 is: " (get-envir
164c0 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
164d0 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 20 "QUERY_STRING")
164e0 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ).. (print "
164f0 22 29 0a 09 20 20 20 20 20 3b 3b 20 28 70 72 69 ").. ;; (pri
16500 6e 74 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e nt " EXCEPTION
16510 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
16520 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
16530 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
16540 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 70 72 exn)).. (pr
16550 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 int-error-messag
16560 65 20 65 78 6e 29 0a 09 20 20 20 20 20 28 70 72 e exn).. (pr
16570 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a int-call-chain).
16580 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 . (print "")
16590 0a 09 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 .. (for-each
165a0 20 28 6c 61 6d 62 64 61 20 28 76 61 72 29 0a 09 (lambda (var)..
165b0 09 09 20 28 70 72 69 6e 74 20 28 63 61 72 20 76 .. (print (car v
165c0 61 72 29 20 22 5c 74 22 20 28 63 64 72 20 76 61 ar) "\t" (cdr va
165d0 72 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 67 r)))... (g
165e0 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
165f0 61 72 69 61 62 6c 65 73 29 29 29 29 0a 09 20 3b ariables)))).. ;
16600 3b 20 72 65 74 75 72 6e 20 73 6f 6d 65 74 68 69 ; return somethi
16610 6e 67 20 75 73 65 66 75 6c 20 74 6f 20 74 68 65 ng useful to the
16620 20 75 73 65 72 0a 09 20 28 70 72 69 6e 74 20 22 user.. (print "
16630 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 Content-type: te
16640 78 74 2f 68 74 6d 6c 22 29 0a 09 20 28 70 72 69 xt/html").. (pri
16650 6e 74 20 22 22 29 0a 09 20 28 70 72 69 6e 74 20 nt "").. (print
16660 22 3c 68 74 6d 6c 3e 20 3c 68 65 61 64 3e 20 3c "<html> <head> <
16670 74 69 74 6c 65 3e 45 58 43 45 50 54 49 4f 4e 3c title>EXCEPTION<
16680 2f 74 69 74 6c 65 3e 20 3c 2f 68 65 61 64 3e 20 /title> </head>
16690 3c 62 6f 64 79 3e 22 29 0a 09 20 28 70 72 69 6e <body>").. (prin
166a0 74 20 22 3c 68 31 3e 43 52 41 53 48 21 3c 2f 68 t "<h1>CRASH!</h
166b0 31 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 20 1>").. (print "
166c0 20 20 50 6c 65 61 73 65 20 6e 6f 74 69 66 79 20 Please notify
166d0 73 75 70 70 6f 72 74 20 61 74 20 22 20 28 73 64 support at " (sd
166e0 61 74 2d 67 65 74 2d 64 6f 6d 61 69 6e 20 73 3a at-get-domain s:
166f0 73 65 73 73 69 6f 6e 29 20 22 20 74 68 61 74 20 session) " that
16700 74 68 65 20 65 72 72 6f 72 20 6c 6f 67 20 69 73 the error log is
16710 20 73 74 6d 6c 2d 63 72 61 73 68 2d 22 20 28 63 stml-crash-" (c
16720 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
16730 64 29 20 22 2e 6c 6f 67 3c 2f 62 3e 20 3c 62 72 d) ".log</b> <br
16740 3e 22 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 20 >").. ;; (print
16750 22 3c 70 72 65 3e 22 29 0a 09 20 3b 3b 20 3b 3b "<pre>").. ;; ;;
16760 20 28 70 72 69 6e 74 20 22 20 20 20 45 58 43 45 (print " EXCE
16770 50 54 49 4f 4e 3a 20 22 20 28 28 63 6f 6e 64 69 PTION: " ((condi
16780 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
16790 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
167a0 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 3b 3b sage) exn)).. ;;
167b0 20 3b 3b 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 ;; (print-error
167c0 2d 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 09 20 -message exn)..
167d0 3b 3b 20 3b 3b 20 28 70 72 69 6e 74 2d 63 61 6c ;; ;; (print-cal
167e0 6c 2d 63 68 61 69 6e 29 0a 09 20 3b 3b 20 28 70 l-chain).. ;; (p
167f0 72 69 6e 74 20 22 3c 2f 70 72 65 3e 22 29 0a 09 rint "</pre>")..
16800 20 3b 3b 20 28 70 72 69 6e 74 20 22 3c 74 61 62 ;; (print "<tab
16810 6c 65 3e 22 29 0a 09 20 3b 3b 20 28 66 6f 72 2d le>").. ;; (for-
16820 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 each (lambda (va
16830 72 29 0a 09 20 3b 3b 20 09 20 20 20 20 20 28 70 r).. ;; . (p
16840 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 rint "<tr><td>"
16850 28 63 61 72 20 76 61 72 29 20 22 3c 2f 74 64 3e (car var) "</td>
16860 3c 74 64 3e 22 20 28 63 64 72 20 76 61 72 29 20 <td>" (cdr var)
16870 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 "</td></tr>"))..
16880 20 3b 3b 20 09 20 20 20 28 67 65 74 2d 65 6e 76 ;; . (get-env
16890 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
168a0 65 73 29 29 0a 09 20 3b 3b 20 28 70 72 69 6e 74 es)).. ;; (print
168b0 20 22 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 20 28 "</table>").. (
168c0 70 72 69 6e 74 20 22 3c 2f 62 6f 64 79 3e 3c 2f print "</body></
168d0 68 74 6d 6c 3e 22 29 29 29 0a 20 20 20 28 69 66 html>"))). (if
168e0 20 70 72 6f 63 20 28 70 72 6f 63 20 73 3a 73 65 proc (proc s:se
168f0 73 73 69 6f 6e 29 20 28 73 74 6d 6c 3a 63 67 69 ssion) (stml:cgi
16900 2d 73 65 73 73 69 6f 6e 20 73 3a 73 65 73 73 69 -session s:sessi
16910 6f 6e 29 29 0a 20 3b 3b 20 28 72 61 69 73 65 2d on)). ;; (raise-
16920 65 72 72 6f 72 29 0a 20 3b 3b 20 28 65 78 69 74 error). ;; (exit
16930 29 0a 20 20 20 29 29 0a 0a 3b 3b 20 66 69 6e 64 ). ))..;; find
16940 20 6f 75 74 20 69 66 20 77 65 20 61 72 65 20 69 out if we are i
16950 6e 20 64 65 62 75 67 6d 6f 64 65 0a 28 64 65 66 n debugmode.(def
16960 69 6e 65 20 28 73 3a 64 65 62 75 67 2d 6d 6f 64 ine (s:debug-mod
16970 65 3f 29 0a 20 20 28 73 64 61 74 2d 67 65 74 2d e?). (sdat-get-
16980 64 65 62 75 67 6d 6f 64 65 20 73 3a 73 65 73 73 debugmode s:sess
16990 69 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ion))..(define (
169a0 73 3a 6e 65 76 65 72 2d 63 61 6c 6c 65 64 2d 70 s:never-called-p
169b0 61 67 65 3f 20 70 61 67 65 29 0a 20 20 28 73 65 age? page). (se
169c0 73 73 69 6f 6e 3a 6e 65 76 65 72 2d 63 61 6c 6c ssion:never-call
169d0 65 64 2d 70 61 67 65 3f 20 73 3a 73 65 73 73 69 ed-page? s:sessi
169e0 6f 6e 20 70 61 67 65 29 29 0a 0a 28 64 65 66 69 on page))..(defi
169f0 6e 65 20 28 73 3a 73 65 74 2d 65 72 72 20 2e 20 ne (s:set-err .
16a00 61 72 67 73 29 0a 20 20 28 73 64 61 74 2d 73 65 args). (sdat-se
16a10 74 2d 63 75 72 72 2d 65 72 72 21 20 73 3a 73 65 t-curr-err! s:se
16a20 73 73 69 6f 6e 20 61 72 67 73 29 29 0a 0a 28 64 ssion args))..(d
16a30 65 66 69 6e 65 20 28 73 3a 63 75 72 72 65 6e 74 efine (s:current
16a40 2d 70 61 67 65 29 0a 20 20 28 73 64 61 74 2d 67 -page). (sdat-g
16a50 65 74 2d 70 61 67 65 20 73 3a 73 65 73 73 69 6f et-page s:sessio
16a60 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a n))..(define (s:
16a70 64 65 6c 65 74 65 2d 73 65 73 73 69 6f 6e 29 0a delete-session).
16a80 20 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 65 74 (session:delet
16a90 65 2d 73 65 73 73 69 6f 6e 20 73 3a 73 65 73 73 e-session s:sess
16aa0 69 6f 6e 20 28 73 64 61 74 2d 67 65 74 2d 73 65 ion (sdat-get-se
16ab0 73 73 69 6f 6e 2d 6b 65 79 20 73 3a 73 65 73 73 ssion-key s:sess
16ac0 69 6f 6e 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ion)))..(define
16ad0 28 73 3a 63 61 6c 6c 20 70 61 67 65 20 2e 20 70 (s:call page . p
16ae0 61 72 74 73 6c 29 0a 20 20 28 69 66 20 28 6e 75 artsl). (if (nu
16af0 6c 6c 3f 20 70 61 72 74 73 6c 29 0a 20 20 20 20 ll? partsl).
16b00 20 20 28 73 65 73 73 69 6f 6e 3a 63 61 6c 6c 20 (session:call
16b10 73 3a 73 65 73 73 69 6f 6e 20 70 61 67 65 20 23 s:session page #
16b20 66 29 0a 20 20 20 20 20 20 28 73 65 73 73 69 6f f). (sessio
16b30 6e 3a 63 61 6c 6c 20 73 3a 73 65 73 73 69 6f 6e n:call s:session
16b40 20 70 61 67 65 20 28 63 61 72 20 70 61 72 74 73 page (car parts
16b50 6c 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 l))))..(define (
16b60 73 3a 6c 69 6e 6b 2d 74 6f 20 70 61 67 65 20 2e s:link-to page .
16b70 20 70 61 72 61 6d 73 29 0a 20 20 28 73 65 73 73 params). (sess
16b80 69 6f 6e 3a 6c 69 6e 6b 2d 74 6f 20 73 3a 73 65 ion:link-to s:se
16b90 73 73 69 6f 6e 20 70 61 67 65 20 70 61 72 61 6d ssion page param
16ba0 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a s))..(define (s:
16bb0 67 65 74 2d 70 61 72 61 6d 20 6b 65 79 20 2e 20 get-param key .
16bc0 74 79 70 65 2d 70 61 72 61 6d 73 29 0a 20 20 28 type-params). (
16bd0 73 65 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 session:get-para
16be0 6d 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 20 m s:session key
16bf0 74 79 70 65 2d 70 61 72 61 6d 73 29 29 0a 0a 3b type-params))..;
16c00 3b 20 74 68 65 73 65 20 61 72 65 20 70 61 67 65 ; these are page
16c10 20 6c 6f 63 61 6c 0a 28 64 65 66 69 6e 65 20 28 local.(define (
16c20 73 3a 67 65 74 20 6b 65 79 29 20 0a 20 20 28 73 s:get key) . (s
16c30 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 ession:page-get
16c40 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 0a s:session key)).
16c50 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 65 74 21 .(define (s:set!
16c60 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 73 65 73 key val). (ses
16c70 73 69 6f 6e 3a 63 75 72 72 2d 70 61 67 65 2d 73 sion:curr-page-s
16c80 65 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 et! s:session ke
16c90 79 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 y val))..(define
16ca0 20 28 73 3a 64 65 6c 21 20 6b 65 79 29 0a 20 20 (s:del! key).
16cb0 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d 76 61 (session:page-va
16cc0 72 2d 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e r-del! s:session
16cd0 20 6b 65 79 29 29 0a 0a 23 3b 28 64 65 66 69 6e key))..#;(defin
16ce0 65 20 28 73 3a 67 65 74 2d 6e 2d 64 65 6c 21 20 e (s:get-n-del!
16cf0 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 76 61 key). (let ((va
16d00 6c 20 28 73 65 73 73 69 6f 6e 3a 70 61 67 65 2d l (session:page-
16d10 67 65 74 20 73 3a 73 65 73 73 69 6f 6e 20 6b 65 get s:session ke
16d20 79 29 29 29 0a 20 20 20 20 28 73 65 73 73 69 6f y))). (sessio
16d30 6e 3a 64 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e n:del! s:session
16d40 20 76 61 6c 20 6b 65 79 29 0a 20 20 20 20 76 61 val key). va
16d50 6c 29 29 0a 0a 3b 3b 20 74 68 65 73 65 20 61 72 l))..;; these ar
16d60 65 20 73 65 73 73 69 6f 6e 20 77 69 64 65 0a 28 e session wide.(
16d70 64 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f define (s:sessio
16d80 6e 2d 76 61 72 2d 67 65 74 20 6b 65 79 20 2e 20 n-var-get key .
16d90 70 61 72 61 6d 73 29 20 0a 20 20 28 73 65 73 73 params) . (sess
16da0 69 6f 6e 3a 67 65 74 20 73 3a 73 65 73 73 69 6f ion:get s:sessio
16db0 6e 20 22 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a n "*sessionvars*
16dc0 22 20 6b 65 79 20 70 61 72 61 6d 73 29 29 0a 0a " key params))..
16dd0 28 64 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 (define (s:sessi
16de0 6f 6e 2d 76 61 72 2d 73 65 74 21 20 6b 65 79 20 on-var-set! key
16df0 76 61 6c 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a val). (session:
16e00 73 65 74 21 20 73 3a 73 65 73 73 69 6f 6e 20 22 set! s:session "
16e10 2a 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6b *sessionvars*" k
16e20 65 79 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e ey val))..(defin
16e30 65 20 28 73 3a 73 65 73 73 69 6f 6e 2d 76 61 72 e (s:session-var
16e40 2d 67 65 74 2d 6e 2d 64 65 6c 21 20 6b 65 79 29 -get-n-del! key)
16e50 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 73 . (let ((val (s
16e60 65 73 73 69 6f 6e 3a 70 61 67 65 2d 67 65 74 20 ession:page-get
16e70 73 3a 73 65 73 73 69 6f 6e 20 6b 65 79 29 29 29 s:session key)))
16e80 0a 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 64 . (session:d
16e90 65 6c 21 20 73 3a 73 65 73 73 69 6f 6e 20 22 2a el! s:session "*
16ea0 73 65 73 73 69 6f 6e 76 61 72 73 2a 22 20 6b 65 sessionvars*" ke
16eb0 79 29 0a 20 20 20 20 20 76 61 6c 29 29 0a 0a 28 y). val))..(
16ec0 64 65 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f define (s:sessio
16ed0 6e 2d 76 61 72 2d 64 65 6c 21 20 6b 65 79 29 0a n-var-del! key).
16ee0 20 20 28 73 65 73 73 69 6f 6e 3a 64 65 6c 21 20 (session:del!
16ef0 73 3a 73 65 73 73 69 6f 6e 20 22 2a 73 65 73 73 s:session "*sess
16f00 69 6f 6e 76 61 72 73 2a 22 20 6b 65 79 29 29 0a ionvars*" key)).
16f10 0a 28 64 65 66 69 6e 65 20 73 3a 73 65 73 73 69 .(define s:sessi
16f20 6f 6e 2d 76 61 72 2d 64 65 6c 65 74 65 21 20 73 on-var-delete! s
16f30 3a 73 65 73 73 69 6f 6e 2d 76 61 72 2d 64 65 6c :session-var-del
16f40 21 29 0a 0a 3b 3b 20 75 74 69 6c 69 74 79 20 74 !)..;; utility t
16f50 6f 20 67 65 74 20 61 6c 6c 20 76 61 72 73 20 61 o get all vars a
16f60 73 20 68 61 73 68 20 74 61 62 6c 65 0a 28 64 65 s hash table.(de
16f70 66 69 6e 65 20 28 73 3a 73 65 73 73 69 6f 6e 2d fine (s:session-
16f80 67 65 74 2d 73 65 73 73 69 6f 6e 76 61 72 73 29 get-sessionvars)
16f90 0a 20 20 28 73 64 61 74 2d 67 65 74 2d 73 65 73 . (sdat-get-ses
16fa0 73 69 6f 6e 76 61 72 73 20 73 3a 73 65 73 73 69 sionvars s:sessi
16fb0 6f 6e 29 29 0a 0a 0a 0a 29 0a on))....).