Artifact
1a4eccad682235a356b6d07256203baf539dba28:
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 3d 3d 3d 3d PURPOSE...;;====
0150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0190: 3d 3d 0a 3b 3b 20 64 75 6d 62 6f 62 6a 20 68 65 ==.;; dumbobj he
01a0: 6c 70 65 72 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d lpers.;;========
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
01f0: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 6d (declare (unit m
0200: 69 73 63 2d 73 74 6d 6c 29 29 0a 28 75 73 65 20 isc-stml)).(use
0210: 72 65 67 65 78 29 0a 28 75 73 65 20 64 62 69 29 regex).(use dbi)
0220: 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 .(import (prefix
0230: 20 64 62 69 20 64 62 69 3a 29 29 0a 0a 3b 3b 20 dbi dbi:))..;;
0240: 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f 66 20 given a list of
0250: 73 79 6d 62 6f 6c 73 20 67 69 76 65 20 74 68 65 symbols give the
0260: 20 63 6f 75 6e 74 20 6f 66 20 74 68 65 20 6d 61 count of the ma
0270: 74 63 68 69 6e 67 20 73 79 6d 62 6f 6c 0a 3b 3b tching symbol.;;
0280: 20 6c 20 3d 3e 20 27 28 61 20 62 20 63 29 20 20 l => '(a b c)
0290: 28 64 75 6d 6f 62 6a 3a 69 6e 64 78 20 61 20 27 (dumobj:indx a '
02a0: 62 29 20 3d 3e 20 31 0a 28 64 65 66 69 6e 65 20 b) => 1.(define
02b0: 28 73 3a 67 65 74 2d 66 69 65 6c 64 6e 75 6d 20 (s:get-fieldnum
02c0: 6c 73 74 20 66 69 65 6c 64 2d 6e 61 6d 65 29 0a lst field-name).
02d0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
02e0: 61 64 20 28 63 61 72 20 6c 73 74 29 29 0a 20 20 ad (car lst)).
02f0: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 69 6c (tail
0300: 20 28 63 64 72 20 6c 73 74 29 29 0a 20 20 20 20 (cdr lst)).
0310: 20 20 20 20 20 20 20 20 20 28 66 6e 75 6d 20 30 (fnum 0
0320: 29 29 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 )). (if (eq?
0330: 68 65 61 64 20 66 69 65 6c 64 2d 6e 61 6d 65 29 head field-name)
0340: 20 66 6e 75 6d 0a 20 20 20 20 20 20 20 20 28 69 fnum. (i
0350: 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 23 f (null? tail) #
0360: 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c f. (l
0370: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 oop (car tail)(c
0380: 64 72 20 74 61 69 6c 29 28 2b 20 66 6e 75 6d 20 dr tail)(+ fnum
0390: 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 1))))))..(define
03a0: 20 28 73 3a 66 69 65 6c 64 73 2d 3e 73 74 72 69 (s:fields->stri
03b0: 6e 67 20 6c 73 74 29 0a 20 20 28 73 74 72 69 6e ng lst). (strin
03c0: 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 79 6d 62 g-join (map symb
03d0: 6f 6c 2d 3e 73 74 72 69 6e 67 20 6c 73 74 29 20 ol->string lst)
03e0: 22 2c 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ","))..(define (
03f0: 73 3a 76 65 63 74 6f 72 2d 67 65 74 2d 66 69 65 s:vector-get-fie
0400: 6c 64 20 76 65 63 20 66 69 65 6c 64 20 66 69 65 ld vec field fie
0410: 6c 64 2d 6c 69 73 74 29 0a 20 20 28 76 65 63 74 ld-list). (vect
0420: 6f 72 2d 72 65 66 20 76 65 63 20 28 73 3a 67 65 or-ref vec (s:ge
0430: 74 2d 66 69 65 6c 64 6e 75 6d 20 66 69 65 6c 64 t-fieldnum field
0440: 2d 6c 69 73 74 20 66 69 65 6c 64 29 29 29 0a 0a -list field)))..
0450: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 3d 3d ========.;;.;;==
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 65 ====..(define (e
04f0: 72 72 3a 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 20 rr:log . msg).
0500: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
0510: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 port (current-er
0520: 72 6f 72 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c ror-port) ;; (sl
0530: 6f 74 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 ot-ref self 'log
0540: 70 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 pt). (lambda
0550: 28 29 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 () . (apply
0560: 20 70 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a print msg))))..
0570: 28 64 65 66 69 6e 65 20 28 73 3a 74 69 64 79 2d (define (s:tidy-
0580: 75 72 6c 20 75 72 6c 29 0a 20 20 28 69 66 20 75 url url). (if u
0590: 72 6c 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 rl. (let ((
05a0: 72 31 20 28 72 65 67 65 78 70 20 22 5e 68 74 74 r1 (regexp "^htt
05b0: 70 3a 5c 5c 2f 5c 5c 2f 22 29 29 0a 20 20 20 20 p:\\/\\/")).
05c0: 20 20 20 20 20 20 20 20 28 72 32 20 28 72 65 67 (r2 (reg
05d0: 65 78 70 20 22 5e 5b 20 5c 5c 74 5d 2a 24 22 29 exp "^[ \\t]*$")
05e0: 29 29 20 3b 3b 20 62 6c 61 6e 6b 0a 20 20 20 20 )) ;; blank.
05f0: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d (if (string-
0600: 6d 61 74 63 68 20 72 31 20 75 72 6c 29 20 75 72 match r1 url) ur
0610: 6c 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 l. (i
0620: 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 f (string-match
0630: 72 32 20 75 72 6c 29 20 23 66 20 3b 3b 20 63 6f r2 url) #f ;; co
0640: 6e 76 65 72 74 20 61 20 62 6c 61 6e 6b 20 74 6f nvert a blank to
0650: 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
0660: 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a (conc "http:
0670: 2f 2f 22 20 75 72 6c 29 29 29 29 0a 20 20 20 20 //" url)))).
0680: 20 20 75 72 6c 29 29 0a 0a 28 64 65 66 69 6e 65 url))..(define
0690: 20 28 73 3a 6c 61 7a 79 2d 3e 6e 75 6d 20 6e 75 (s:lazy->num nu
06a0: 6d 29 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 m). (if (number
06b0: 3f 20 6e 75 6d 29 20 6e 75 6d 0a 20 20 20 20 20 ? num) num.
06c0: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (if (string->nu
06d0: 6d 62 65 72 20 6e 75 6d 29 20 28 73 74 72 69 6e mber num) (strin
06e0: 67 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a 09 g->number num)..
06f0: 20 20 20 20 28 69 66 20 6e 75 6d 20 31 20 30 29 (if num 1 0)
0700: 29 29 29 20 3b 3b 20 77 69 65 72 64 20 65 68 21 ))) ;; wierd eh!
0710: 20 79 65 70 2c 20 23 66 3d 3e 30 20 23 74 3d 3e yep, #f=>0 #t=>
0720: 31 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 1 ..;;==========
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
0770: 44 20 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d D B.;;==========
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
07c0: 20 63 6f 6e 76 65 72 74 20 76 61 6c 75 65 73 20 convert values
07d0: 74 6f 20 61 70 70 72 6f 70 72 69 61 74 65 20 73 to appropriate s
07e0: 74 72 69 6e 67 73 0a 3b 3b 0a 28 64 65 66 69 6e trings.;;.(defin
07f0: 65 20 28 73 3a 73 71 6c 70 61 72 61 6d 2d 76 61 e (s:sqlparam-va
0800: 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 l->string val).
0810: 20 28 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 (cond. ((list
0820: 3f 20 20 20 76 61 6c 29 28 73 74 72 69 6e 67 2d ? val)(string-
0830: 6a 6f 69 6e 20 28 6d 61 70 20 73 79 6d 62 6f 6c join (map symbol
0840: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 20 22 2c ->string val) ",
0850: 22 29 29 20 3b 3b 20 28 61 20 62 20 63 29 20 3d ")) ;; (a b c) =
0860: 3e 20 61 2c 62 2c 63 0a 20 20 20 28 28 73 74 72 > a,b,c. ((str
0870: 69 6e 67 3f 20 76 61 6c 29 28 63 6f 6e 63 20 22 ing? val)(conc "
0880: 27 22 20 28 64 62 69 3a 65 73 63 61 70 65 2d 73 '" (dbi:escape-s
0890: 74 72 69 6e 67 20 76 61 6c 29 20 22 27 22 29 29 tring val) "'"))
08a0: 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 . ((number? va
08b0: 6c 29 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e l)(number->strin
08c0: 67 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d g val)). ((sym
08d0: 62 6f 6c 3f 20 76 61 6c 29 28 64 62 69 3a 65 73 bol? val)(dbi:es
08e0: 63 61 70 65 2d 73 74 72 69 6e 67 20 28 73 79 6d cape-string (sym
08f0: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
0900: 29 29 0a 20 20 20 28 28 62 6f 6f 6c 65 61 6e 3f )). ((boolean?
0910: 20 76 61 6c 29 0a 20 20 20 20 28 69 66 20 76 61 val). (if va
0920: 6c 20 22 54 52 55 45 22 20 22 46 41 4c 53 45 22 l "TRUE" "FALSE"
0930: 29 29 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 )) ;; should th
0940: 69 73 20 62 65 20 22 54 52 55 45 22 20 6f 72 20 is be "TRUE" or
0950: 31 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1?.
0960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0970: 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 ;; should this
0980: 62 65 20 22 46 41 4c 53 45 22 20 6f 72 20 30 20 be "FALSE" or 0
0990: 6f 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 or NULL?. (els
09a0: 65 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 e. (err:log "
09b0: 73 71 6c 70 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 sqlparam: unknow
09c0: 6e 20 74 79 70 65 20 66 6f 72 20 76 61 6c 75 65 n type for value
09d0: 3a 20 22 20 76 61 6c 29 0a 20 20 20 20 22 22 29 : " val). "")
09e0: 29 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 72 61 6d ))..;; (sqlparam
09f0: 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 66 6f "INSERT INTO fo
0a00: 6f 28 6e 61 6d 65 2c 61 67 65 29 20 56 41 4c 55 o(name,age) VALU
0a10: 45 53 28 3f 2c 3f 29 3b 22 20 22 62 6f 62 22 20 ES(?,?);" "bob"
0a20: 32 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 20).;; NB// 1. v
0a30: 61 6c 75 65 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b alues only!! .;;
0a40: 20 20 20 20 20 20 32 2e 20 74 65 72 6d 69 6e 61 2. termina
0a50: 74 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 ting semicolon r
0a60: 65 71 75 69 72 65 64 20 28 75 73 65 64 20 61 73 equired (used as
0a70: 20 70 61 72 74 20 6f 66 20 6c 6f 67 69 63 29 0a part of logic).
0a80: 3b 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 6e 75 6d ;;.;; a=? 1 (num
0a90: 62 65 72 29 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 ber) => a=1.;; a
0aa0: 3d 3f 20 31 20 28 73 74 72 69 6e 67 29 20 3d 3e =? 1 (string) =>
0ab0: 20 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 a='1'.;; a=? #f
0ac0: 20 20 20 20 20 20 20 20 20 3d 3e 20 61 3d 46 41 => a=FA
0ad0: 4c 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 LSE .;; a=? a (s
0ae0: 79 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b ymbol) => a=a .;
0af0: 3b 0a 28 64 65 66 69 6e 65 20 28 73 3a 73 71 6c ;.(define (s:sql
0b00: 70 61 72 61 6d 20 71 75 65 72 79 20 2e 20 61 72 param query . ar
0b10: 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 71 75 gs). (let* ((qu
0b20: 65 72 79 2d 70 61 72 74 73 20 28 73 74 72 69 6e ery-parts (strin
0b30: 67 2d 73 70 6c 69 74 20 71 75 65 72 79 20 22 3f g-split query "?
0b40: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 ")). (nu
0b50: 6d 2d 70 61 72 74 73 20 20 20 20 28 6c 65 6e 67 m-parts (leng
0b60: 74 68 20 71 75 65 72 79 2d 70 61 72 74 73 29 29 th query-parts))
0b70: 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 2d 61 . (num-a
0b80: 72 67 73 20 20 20 20 28 6c 65 6e 67 74 68 20 61 rgs (length a
0b90: 72 67 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 rgs))). (if (
0ba0: 6e 6f 74 20 28 3d 20 28 2b 20 6e 75 6d 2d 61 72 not (= (+ num-ar
0bb0: 67 73 20 31 29 20 6e 75 6d 2d 70 61 72 74 73 29 gs 1) num-parts)
0bc0: 29 0a 20 20 20 20 20 20 20 20 28 65 72 72 3a 6c ). (err:l
0bd0: 6f 67 20 22 45 52 52 4f 52 2c 20 73 71 6c 70 61 og "ERROR, sqlpa
0be0: 72 61 6d 3a 20 77 72 6f 6e 67 20 6e 75 6d 62 65 ram: wrong numbe
0bf0: 72 20 6f 66 20 61 72 67 75 6d 65 6e 74 73 20 6f r of arguments o
0c00: 72 20 6d 69 73 73 69 6e 67 20 73 65 6d 69 63 6f r missing semico
0c10: 6c 6f 6e 2c 20 22 20 6e 75 6d 2d 61 72 67 73 20 lon, " num-args
0c20: 22 20 66 6f 72 20 71 75 65 72 79 20 22 20 71 75 " for query " qu
0c30: 65 72 79 29 0a 20 20 20 20 20 20 20 20 28 69 66 ery). (if
0c40: 20 28 3d 20 6e 75 6d 2d 61 72 67 73 20 30 29 20 (= num-args 0)
0c50: 71 75 65 72 79 0a 20 20 20 20 20 20 20 20 20 20 query.
0c60: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 (let loop ((se
0c70: 63 74 69 6f 6e 20 28 63 61 72 20 71 75 65 72 79 ction (car query
0c80: 2d 70 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 -parts)).
0c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ca0: 28 74 61 69 6c 20 20 20 20 28 63 64 72 20 71 75 (tail (cdr qu
0cb0: 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 20 ery-parts)).
0cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0cd0: 20 20 20 28 72 65 73 75 6c 74 20 20 22 22 29 0a (result "").
0ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0cf0: 20 20 20 20 20 20 20 28 61 72 67 20 20 20 20 20 (arg
0d00: 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 20 20 (car args)).
0d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d20: 20 20 20 28 61 72 67 74 61 69 6c 20 28 63 64 72 (argtail (cdr
0d30: 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 20 20 args))).
0d40: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 76 (let* ((v
0d50: 61 6c 73 74 72 20 20 20 20 28 73 3a 73 71 6c 70 alstr (s:sqlp
0d60: 61 72 61 6d 2d 76 61 6c 2d 3e 73 74 72 69 6e 67 aram-val->string
0d70: 20 61 72 67 29 29 0a 20 20 20 20 20 20 20 20 20 arg)).
0d80: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new
0d90: 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 72 65 73 result (conc res
0da0: 75 6c 74 20 73 65 63 74 69 6f 6e 20 76 61 6c 73 ult section vals
0db0: 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 tr))).
0dc0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
0dd0: 20 61 72 67 74 61 69 6c 29 20 3b 3b 20 77 65 20 argtail) ;; we
0de0: 61 72 65 20 64 6f 6e 65 0a 20 20 20 20 20 20 20 are done.
0df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
0e00: 6e 63 20 6e 65 77 72 65 73 75 6c 74 20 28 63 61 nc newresult (ca
0e10: 72 20 74 61 69 6c 29 29 0a 20 20 20 20 20 20 20 r tail)).
0e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
0e30: 6f 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 op.
0e40: 20 20 20 20 20 20 20 20 28 63 61 72 20 74 61 69 (car tai
0e50: 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 l).
0e60: 20 20 20 20 20 20 20 20 28 63 64 72 20 74 61 69 (cdr tai
0e70: 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 l).
0e80: 20 20 20 20 20 20 20 20 6e 65 77 72 65 73 75 6c newresul
0e90: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
0ea0: 20 20 20 20 20 20 20 28 63 61 72 20 61 72 67 74 (car argt
0eb0: 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ail).
0ec0: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 61 (cdr a
0ed0: 72 67 74 61 69 6c 29 29 29 29 29 29 29 29 29 0a rgtail))))))))).
0ee0: 0a 3b 3b 20 72 61 6e 64 6f 6d 20 73 74 72 69 6e .;; random strin
0ef0: 67 20 73 74 75 66 66 0a 28 64 65 66 69 6e 65 20 g stuff.(define
0f00: 28 73 3a 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 (s:string-downca
0f10: 73 65 20 73 74 72 29 0a 20 20 28 69 66 20 28 73 se str). (if (s
0f20: 74 72 69 6e 67 3f 20 73 74 72 29 0a 20 20 20 20 tring? str).
0f30: 20 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c (string-transl
0f40: 61 74 65 20 73 74 72 20 22 41 42 43 44 45 46 47 ate str "ABCDEFG
0f50: 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 HIJKLMNOPQRSTUVW
0f60: 58 59 5a 22 20 22 61 62 63 64 65 66 67 68 69 6a XYZ" "abcdefghij
0f70: 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a klmnopqrstuvwxyz
0f80: 22 29 0a 20 20 20 20 20 20 73 74 72 29 29 20 0a "). str)) .
0f90: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 73 65 73 73 .;; (define sess
0fa0: 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 ion:valid-chars
0fb0: 22 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f "abcdefghijklmno
0fc0: 70 71 72 73 74 75 76 77 78 79 7a 41 42 43 44 45 pqrstuvwxyzABCDE
0fd0: 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 FGHIJKLMNOPQRSTU
0fe0: 56 57 58 59 5a 30 31 32 33 34 35 36 37 38 39 22 VWXYZ0123456789"
0ff0: 29 0a 28 64 65 66 69 6e 65 20 73 65 73 73 69 6f ).(define sessio
1000: 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 20 22 61 n:valid-chars "a
1010: 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 bcdefghijklmnopq
1020: 72 73 74 75 76 77 78 79 7a 30 31 32 33 34 35 36 rstuvwxyz0123456
1030: 37 38 39 22 29 20 3b 3b 20 63 6f 6f 6b 69 65 73 789") ;; cookies
1040: 20 61 72 65 20 63 61 73 65 20 69 6e 73 65 6e 73 are case insens
1050: 69 74 69 76 65 2e 0a 28 64 65 66 69 6e 65 20 73 itive..(define s
1060: 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 ession:num-valid
1070: 2d 63 68 61 72 73 20 28 73 74 72 69 6e 67 2d 6c -chars (string-l
1080: 65 6e 67 74 68 20 73 65 73 73 69 6f 6e 3a 76 61 ength session:va
1090: 6c 69 64 2d 63 68 61 72 73 29 29 0a 0a 28 64 65 lid-chars))..(de
10a0: 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 fine (session:ge
10b0: 74 2d 6e 74 68 2d 63 68 61 72 20 6e 74 68 29 0a t-nth-char nth).
10c0: 20 20 28 73 75 62 73 74 72 69 6e 67 20 73 65 73 (substring ses
10d0: 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 sion:valid-chars
10e0: 20 6e 74 68 20 20 28 2b 20 6e 74 68 20 31 29 29 nth (+ nth 1))
10f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 73 73 )..(define (sess
1100: 69 6f 6e 3a 67 65 74 2d 72 61 6e 64 2d 63 68 61 ion:get-rand-cha
1110: 72 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 67 65 r). (session:ge
1120: 74 2d 6e 74 68 2d 63 68 61 72 20 28 72 61 6e 64 t-nth-char (rand
1130: 6f 6d 20 73 65 73 73 69 6f 6e 3a 6e 75 6d 2d 76 om session:num-v
1140: 61 6c 69 64 2d 63 68 61 72 73 29 29 29 0a 0a 28 alid-chars)))..(
1150: 64 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a define (session:
1160: 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 make-rand-string
1170: 20 6c 65 6e 29 0a 20 20 28 6c 65 74 20 6c 6f 6f len). (let loo
1180: 70 20 28 28 72 65 73 20 22 22 29 0a 20 20 20 20 p ((res "").
1190: 20 20 20 20 20 20 20 20 20 28 6e 20 20 20 31 29 (n 1)
11a0: 29 0a 20 20 20 20 28 69 66 20 28 3e 20 6e 20 6c ). (if (> n l
11b0: 65 6e 29 20 72 65 73 0a 20 20 20 20 20 20 20 20 en) res.
11c0: 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 (loop (string-ap
11d0: 70 65 6e 64 20 72 65 73 20 28 73 65 73 73 69 6f pend res (sessio
11e0: 6e 3a 67 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 n:get-rand-char)
11f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1200: 28 2b 20 6e 20 31 29 29 29 29 29 0a 0a 3b 3b 20 (+ n 1)))))..;;
1210: 6f 70 65 6e 73 73 6c 20 70 61 73 73 77 64 20 2d openssl passwd -
1220: 63 72 79 70 74 20 2d 73 61 6c 74 20 78 78 20 70 crypt -salt xx p
1230: 61 73 73 77 6f 72 64 0a 3b 3b 0a 28 64 65 66 69 assword.;;.(defi
1240: 6e 65 20 28 73 3a 63 72 79 70 74 2d 70 61 73 73 ne (s:crypt-pass
1250: 77 64 20 70 77 20 73 29 0a 20 20 28 6c 65 74 2a wd pw s). (let*
1260: 20 28 28 73 61 6c 74 20 28 69 66 20 73 20 73 20 ((salt (if s s
1270: 28 73 65 73 73 69 6f 6e 3a 6d 61 6b 65 2d 72 61 (session:make-ra
1280: 6e 64 2d 73 74 72 69 6e 67 20 32 29 29 29 0a 09 nd-string 2)))..
1290: 20 28 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 (inp (open-inpu
12a0: 74 2d 70 69 70 65 20 0a 20 20 20 20 20 20 20 20 t-pipe .
12b0: 20 20 20 20 20 20 20 3b 3b 28 73 74 72 69 6e 67 ;;(string
12c0: 2d 61 70 70 65 6e 64 20 22 65 63 68 6f 20 22 20 -append "echo "
12d0: 70 77 20 22 20 7c 20 6d 6b 70 61 73 73 77 64 20 pw " | mkpasswd
12e0: 2d 53 20 22 20 73 61 6c 74 20 22 20 2d 73 22 29 -S " salt " -s")
12f0: 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 28 63 )).. ;; (c
1300: 6f 6e 63 20 22 6d 6b 70 61 73 73 77 64 20 22 20 onc "mkpasswd "
1310: 70 77 20 22 20 22 20 73 61 6c 74 29 0a 09 20 20 pw " " salt)..
1320: 20 20 20 20 20 28 63 6f 6e 63 20 22 6f 70 65 6e (conc "open
1330: 73 73 6c 20 70 61 73 73 77 64 20 2d 63 72 79 70 ssl passwd -cryp
1340: 74 20 2d 73 61 6c 74 20 22 20 73 61 6c 74 20 22 t -salt " salt "
1350: 20 22 20 70 77 29 0a 20 20 20 20 20 20 20 20 20 " pw).
1360: 20 20 20 20 20 20 29 29 0a 20 20 20 20 20 20 20 )).
1370: 20 20 28 72 65 73 20 28 72 65 61 64 2d 6c 69 6e (res (read-lin
1380: 65 20 69 6e 70 29 29 29 0a 20 20 20 20 28 63 6c e inp))). (cl
1390: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 ose-input-port i
13a0: 6e 70 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 np). res))..(
13b0: 64 65 66 69 6e 65 20 28 73 3a 70 61 73 73 77 6f define (s:passwo
13c0: 72 64 2d 6d 61 74 63 68 3f 20 70 61 73 73 77 6f rd-match? passwo
13d0: 72 64 20 63 72 79 70 74 65 64 29 0a 20 20 28 6c rd crypted). (l
13e0: 65 74 2a 20 28 28 73 61 6c 74 20 28 73 75 62 73 et* ((salt (subs
13f0: 74 72 69 6e 67 20 63 72 79 70 74 65 64 20 30 20 tring crypted 0
1400: 32 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 63 2)). (pc
1410: 72 79 70 74 65 64 20 28 73 3a 63 72 79 70 74 2d rypted (s:crypt-
1420: 70 61 73 73 77 64 20 70 61 73 73 77 6f 72 64 20 passwd password
1430: 73 61 6c 74 29 29 29 0a 20 20 20 20 28 73 3a 6c salt))). (s:l
1440: 6f 67 20 22 49 4e 46 4f 3a 20 70 63 72 79 70 74 og "INFO: pcrypt
1450: 65 64 3d 22 20 70 63 72 79 70 74 65 64 20 22 20 ed=" pcrypted "
1460: 63 72 79 70 74 65 64 3d 22 20 63 72 79 70 74 65 crypted=" crypte
1470: 64 29 0a 20 20 20 20 28 61 6e 64 20 28 73 74 72 d). (and (str
1480: 69 6e 67 3f 20 70 61 73 73 77 6f 72 64 29 0a 20 ing? password).
1490: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3f (string?
14a0: 20 70 63 72 79 70 74 65 64 29 0a 20 20 20 20 20 pcrypted).
14b0: 20 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 70 63 (string=? pc
14c0: 72 79 70 74 65 64 20 63 72 79 70 74 65 64 29 29 rypted crypted))
14d0: 29 29 0a 0a 3b 3b 20 28 72 65 61 64 2d 6c 69 6e ))..;; (read-lin
14e0: 65 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 e (open-input-pi
14f0: 70 65 20 22 65 63 68 6f 20 66 6f 6f 20 7c 20 6d pe "echo foo | m
1500: 6b 70 61 73 73 77 64 20 2d 53 20 61 62 20 2d 73 kpasswd -S ab -s
1510: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a "))..(define (s:
1520: 65 72 72 6f 72 2d 70 61 67 65 20 2e 20 65 72 72 error-page . err
1530: 29 0a 20 20 28 73 3a 63 67 69 2d 6f 75 74 20 28 ). (s:cgi-out (
1540: 63 6f 6e 73 20 22 43 6f 6e 74 65 6e 74 2d 74 79 cons "Content-ty
1550: 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 3b 20 63 pe: text/html; c
1560: 68 61 72 73 65 74 3d 69 73 6f 2d 38 38 35 39 2d harset=iso-8859-
1570: 31 5c 6e 5c 6e 22 0a 09 09 20 20 20 28 73 3a 68 1\n\n"... (s:h
1580: 74 6d 6c 20 28 73 3a 68 65 61 64 20 0a 09 09 09 tml (s:head ....
1590: 20 20 20 20 28 73 3a 74 69 74 6c 65 20 65 72 72 (s:title err
15a0: 29 0a 09 09 09 20 20 20 20 28 73 3a 62 6f 64 79 ).... (s:body
15b0: 0a 09 09 09 20 20 20 20 20 28 73 3a 68 31 20 22 .... (s:h1 "
15c0: 45 52 52 4f 52 22 29 0a 09 09 09 20 20 20 20 20 ERROR")....
15d0: 28 73 3a 70 20 65 72 72 29 29 29 29 29 29 29 0a (s:p err))))))).
15e0: 0a 28 64 65 66 69 6e 65 20 28 73 3a 76 61 6c 69 .(define (s:vali
15f0: 64 61 74 65 2d 75 72 69 29 0a 20 20 28 6c 65 74 date-uri). (let
1600: 20 28 28 75 72 69 20 28 67 65 74 2d 65 6e 76 69 ((uri (get-envi
1610: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
1620: 20 22 52 45 51 55 45 53 54 5f 55 52 49 22 29 29 "REQUEST_URI"))
1630: 0a 09 28 71 72 73 20 28 67 65 74 2d 65 6e 76 69 ..(qrs (get-envi
1640: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
1650: 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 22 29 "QUERY_STRING")
1660: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
1670: 75 72 69 29 0a 09 28 73 65 74 21 20 75 72 69 20 uri)..(set! uri
1680: 71 72 73 29 29 0a 20 20 20 20 28 69 66 20 75 72 qrs)). (if ur
1690: 69 0a 09 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 i..(string-match
16a0: 20 0a 09 20 28 72 65 67 65 78 70 20 22 5e 28 2f .. (regexp "^(/
16b0: 5b 61 2d 7a 5c 5c 2d 5c 5c 2e 5f 3a 30 2d 39 5d [a-z\\-\\._:0-9]
16c0: 2a 29 2a 28 7c 5c 5c 3f 28 5b 41 2d 5a 61 2d 7a *)*(|\\?([A-Za-z
16d0: 30 2d 39 5f 5c 5c 2d 5c 5c 2b 5d 2b 3d 5b 41 2d 0-9_\\-\\+]+=[A-
16e0: 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d 5c 5c 2e 5c 5c Za-z0-9_\\-\\.\\
16f0: 2b 5d 2a 26 7b 30 2c 31 7d 29 2a 29 24 22 29 20 +]*&{0,1})*)$")
1700: 75 72 69 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 uri)..(begin..
1710: 28 73 3a 6c 6f 67 20 22 52 45 51 55 45 53 54 20 (s:log "REQUEST
1720: 55 52 49 20 4e 4f 54 20 41 56 41 49 4c 41 42 4c URI NOT AVAILABL
1730: 45 21 22 29 0a 09 20 20 28 6c 65 74 20 28 28 70 E!").. (let ((p
1740: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 (open-input-pip
1750: 65 20 22 65 6e 76 22 29 29 29 0a 09 20 20 20 20 e "env")))..
1760: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 20 28 72 (let loop ((l (r
1770: 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 09 20 ead-line p))...
1780: 20 20 20 20 20 20 28 72 65 73 20 27 28 29 29 29 (res '()))
1790: 0a 09 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 .. (if (eof
17a0: 2d 6f 62 6a 65 63 74 3f 20 6c 29 0a 09 09 20 20 -object? l)...
17b0: 28 73 3a 6c 6f 67 20 72 65 73 29 0a 09 09 20 20 (s:log res)...
17c0: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
17d0: 20 70 29 28 63 6f 6e 73 20 28 6c 69 73 74 20 6c p)(cons (list l
17e0: 20 22 3c 42 52 3e 22 29 20 72 65 73 29 29 29 29 "<BR>") res))))
17f0: 29 0a 09 20 20 23 74 29 29 29 29 0a 0a 28 64 65 ).. #t))))..(de
1800: 66 69 6e 65 20 28 73 3a 76 61 6c 69 64 61 74 65 fine (s:validate
1810: 2d 69 6e 70 75 74 73 29 0a 20 20 28 69 66 20 28 -inputs). (if (
1820: 6e 6f 74 20 28 73 3a 76 61 6c 69 64 61 74 65 2d not (s:validate-
1830: 75 72 69 29 29 0a 20 20 20 20 20 20 28 62 65 67 uri)). (beg
1840: 69 6e 20 28 73 3a 65 72 72 6f 72 2d 70 61 67 65 in (s:error-page
1850: 20 22 42 61 64 20 55 52 49 22 20 28 6c 65 74 20 "Bad URI" (let
1860: 28 28 72 65 66 20 28 67 65 74 2d 65 6e 76 69 72 ((ref (get-envir
1870: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
1880: 22 48 54 54 50 5f 52 45 46 45 52 45 52 22 29 29 "HTTP_REFERER"))
1890: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 69 66 )..... (if
18a0: 20 72 65 66 0a 09 09 09 09 09 20 20 20 28 6c 69 ref...... (li
18b0: 73 74 20 22 72 65 66 65 72 72 65 64 20 66 72 6f st "referred fro
18c0: 6d 22 20 72 65 66 29 0a 09 09 09 09 09 20 20 20 m" ref)......
18d0: 22 22 29 29 29 0a 09 20 20 20 20 20 28 65 78 69 ""))).. (exi
18e0: 74 29 29 29 29 0a 0a 3b 3b 20 61 6e 79 74 68 69 t))))..;; anythi
18f0: 6e 67 20 65 78 63 65 70 74 20 61 20 6c 69 73 74 ng except a list
1900: 20 69 73 20 63 6f 6e 76 65 72 74 65 64 20 74 6f is converted to
1910: 20 61 20 73 74 72 69 6e 67 21 21 21 0a 28 64 65 a string!!!.(de
1920: 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 73 74 72 fine (s:any->str
1930: 69 6e 67 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 ing val). (cond
1940: 0a 20 20 20 28 28 73 74 72 69 6e 67 3f 20 76 61 . ((string? va
1950: 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 6e 75 6d l) val). ((num
1960: 62 65 72 3f 20 76 61 6c 29 20 28 6e 75 6d 62 65 ber? val) (numbe
1970: 72 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 0a r->string val)).
1980: 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c ((symbol? val
1990: 29 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e ) (symbol->strin
19a0: 67 20 76 61 6c 29 29 0a 20 20 20 28 28 65 71 3f g val)). ((eq?
19b0: 20 76 61 6c 20 23 66 29 20 22 22 29 0a 20 20 20 val #f) "").
19c0: 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 54 ((eq? val #t) "T
19d0: 52 55 45 22 29 0a 20 20 20 28 28 6c 69 73 74 3f RUE"). ((list?
19e0: 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 65 val) val). (e
19f0: 6c 73 65 20 0a 20 20 20 20 28 6c 65 74 20 28 28 lse . (let ((
1a00: 6f 73 74 72 20 28 6f 70 65 6e 2d 6f 75 74 70 75 ostr (open-outpu
1a10: 74 2d 73 74 72 69 6e 67 29 29 29 0a 20 20 20 20 t-string))).
1a20: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
1a30: 6f 2d 70 6f 72 74 20 6f 73 74 72 0a 09 28 6c 61 o-port ostr..(la
1a40: 6d 62 64 61 20 28 29 0a 09 20 20 28 64 69 73 70 mbda ().. (disp
1a50: 6c 61 79 20 76 61 6c 29 29 29 0a 20 20 20 20 20 lay val))).
1a60: 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 (get-output-str
1a70: 69 6e 67 20 6f 73 74 72 29 29 29 29 29 0a 0a 28 ing ostr)))))..(
1a80: 64 65 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 6e define (s:any->n
1a90: 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f umber val). (co
1aa0: 6e 64 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 nd. ((number?
1ab0: 76 61 6c 29 20 20 76 61 6c 29 0a 20 20 20 28 28 val) val). ((
1ac0: 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 20 28 73 string? val) (s
1ad0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 tring->number va
1ae0: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
1af0: 20 76 61 6c 29 20 20 28 73 74 72 69 6e 67 2d 3e val) (string->
1b00: 6e 75 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e number (symbol->
1b10: 73 74 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 string val))).
1b20: 20 28 65 6c 73 65 20 20 20 20 20 23 66 29 29 29 (else #f)))
1b30: 0a 0a 3b 3b 20 4e 42 2f 2f 20 74 68 69 73 20 69 ..;; NB// this i
1b40: 73 20 2a 69 6c 6c 65 67 61 6c 2a 20 70 67 69 6e s *illegal* pgin
1b50: 74 0a 28 64 65 66 69 6e 65 20 28 73 3a 69 6c 6c t.(define (s:ill
1b60: 65 67 61 6c 2d 70 67 69 6e 74 20 76 61 6c 29 0a egal-pgint val).
1b70: 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 3e 20 76 (cond. ((> v
1b80: 61 6c 20 32 31 34 37 34 38 33 36 34 37 29 20 31 al 2147483647) 1
1b90: 29 0a 20 20 20 28 28 3c 20 76 61 6c 20 2d 32 31 ). ((< val -21
1ba0: 34 37 34 38 33 36 34 38 29 20 2d 31 29 0a 20 20 47483648) -1).
1bb0: 20 28 65 6c 73 65 20 23 66 29 29 29 0a 0a 28 64 (else #f)))..(d
1bc0: 65 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 70 67 efine (s:any->pg
1bd0: 69 6e 74 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 int val). (let
1be0: 28 28 6e 20 28 73 3a 61 6e 79 2d 3e 6e 75 6d 62 ((n (s:any->numb
1bf0: 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 er val))). (i
1c00: 66 20 6e 0a 09 28 69 66 20 28 73 3a 69 6c 6c 65 f n..(if (s:ille
1c10: 67 61 6c 2d 70 67 69 6e 74 20 6e 29 0a 09 20 20 gal-pgint n)..
1c20: 20 20 23 66 0a 09 20 20 20 20 6e 29 0a 09 6e 29 #f.. n)..n)
1c30: 29 29 0a 0a 3b 3b 20 73 74 72 69 6e 67 20 69 73 ))..;; string is
1c40: 20 61 20 73 74 72 69 6e 67 20 61 6e 64 20 6e 6f a string and no
1c50: 6e 2d 7a 65 72 6f 20 6c 65 6e 67 74 68 0a 28 64 n-zero length.(d
1c60: 65 66 69 6e 65 20 28 6d 69 73 63 3a 6e 6f 6e 2d efine (misc:non-
1c70: 7a 65 72 6f 2d 73 74 72 69 6e 67 20 73 74 72 29 zero-string str)
1c80: 0a 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 . (if (and (str
1c90: 69 6e 67 3f 20 73 74 72 29 0a 20 20 20 20 20 20 ing? str).
1ca0: 20 20 20 20 20 28 3e 20 28 73 74 72 69 6e 67 2d (> (string-
1cb0: 6c 65 6e 67 74 68 20 73 74 72 29 20 30 29 29 0a length str) 0)).
1cc0: 20 20 20 20 20 20 73 74 72 0a 20 20 20 20 20 20 str.
1cd0: 23 66 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d #f))..;;========
1ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
1d20: 3b 20 50 20 41 20 52 20 41 20 4d 20 53 0a 3b 3b ; P A R A M S.;;
1d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d70: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 6e 70 75 74 ======..;; input
1d80: 3a 20 27 61 20 28 27 61 20 22 76 61 6c 20 61 22 : 'a ('a "val a"
1d90: 20 27 62 20 22 76 61 6c 20 62 22 29 20 3d 3e 20 'b "val b") =>
1da0: 22 76 61 6c 20 61 22 0a 28 64 65 66 69 6e 65 20 "val a".(define
1db0: 28 73 3a 66 69 6e 64 2d 70 61 72 61 6d 20 6b 65 (s:find-param ke
1dc0: 79 20 70 61 72 61 6d 2d 6c 73 74 29 0a 20 20 28 y param-lst). (
1dd0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
1de0: 28 63 61 72 20 70 61 72 61 6d 2d 6c 73 74 29 29 (car param-lst))
1df0: 0a 09 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 .. (tail (cd
1e00: 72 20 70 61 72 61 6d 2d 6c 73 74 29 29 29 0a 20 r param-lst))).
1e10: 20 20 20 28 69 66 20 28 65 71 3f 20 68 65 61 64 (if (eq? head
1e20: 20 6b 65 79 29 0a 09 28 63 61 72 20 74 61 69 6c key)..(car tail
1e30: 29 0a 09 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 )..(if (< (lengt
1e40: 68 20 74 61 69 6c 29 20 32 29 20 23 66 0a 09 20 h tail) 2) #f..
1e50: 20 20 20 28 6c 6f 6f 70 20 28 63 61 64 72 20 74 (loop (cadr t
1e60: 61 69 6c 29 28 63 64 64 72 20 74 61 69 6c 29 29 ail)(cddr tail))
1e70: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
1e80: 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 20 70 :param->string p
1e90: 61 72 61 6d 29 0a 20 20 28 63 6f 6e 63 20 28 73 aram). (conc (s
1ea0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 28 63 ymbol->string (c
1eb0: 61 72 20 70 61 72 61 6d 29 29 20 22 3d 22 20 22 ar param)) "=" "
1ec0: 5c 22 22 20 28 63 61 64 72 20 70 61 72 61 6d 29 \"" (cadr param)
1ed0: 20 22 5c 22 22 29 29 0a 0a 3b 3b 20 72 65 6d 6f "\""))..;; remo
1ee0: 76 65 20 27 66 6f 6f 20 22 62 61 72 22 20 66 72 ve 'foo "bar" fr
1ef0: 6f 6d 20 28 27 66 6f 6f 20 22 62 61 72 22 20 27 om ('foo "bar" '
1f00: 62 61 72 20 22 66 6f 6f 22 29 0a 28 64 65 66 69 bar "foo").(defi
1f10: 6e 65 20 28 73 3a 72 65 6d 6f 76 65 2d 70 61 72 ne (s:remove-par
1f20: 61 6d 2d 6d 61 74 63 68 69 6e 67 20 70 61 72 61 am-matching para
1f30: 6d 73 20 6b 65 79 29 0a 20 20 28 69 66 20 28 3d ms key). (if (=
1f40: 20 28 6c 65 6e 67 74 68 20 70 61 72 61 6d 73 29 (length params)
1f50: 20 30 29 27 28 29 20 3b 3b 20 20 70 72 6f 70 65 0)'() ;; prope
1f60: 72 20 70 61 72 61 6d 73 20 6c 69 73 74 20 3e 3d r params list >=
1f70: 20 32 20 69 74 65 6d 73 0a 20 20 20 20 20 20 28 2 items. (
1f80: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 let loop ((head
1f90: 20 20 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 (car params)
1fa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1fb0: 20 20 20 28 74 61 69 6c 20 20 20 20 20 28 63 64 (tail (cd
1fc0: 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 r params)).
1fd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 (res
1fe0: 75 6c 74 20 20 20 27 28 29 29 29 0a 20 20 20 20 ult '())).
1ff0: 20 20 20 20 28 69 66 20 28 73 79 6d 62 6f 6c 3f (if (symbol?
2000: 20 68 65 61 64 29 20 3b 3b 20 73 79 6d 62 6f 6c head) ;; symbol
2010: 73 20 68 61 76 65 20 70 61 72 61 6d 73 0a 20 20 s have params.
2020: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
2030: 28 76 61 6c 20 20 20 20 20 28 63 61 72 20 74 61 (val (car ta
2040: 69 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 il)).
2050: 20 20 20 20 20 20 20 28 6e 65 77 74 61 69 6c 20 (newtail
2060: 28 63 64 72 20 74 61 69 6c 29 29 29 0a 20 20 20 (cdr tail))).
2070: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
2080: 65 71 3f 20 68 65 61 64 20 6b 65 79 29 20 20 3b eq? head key) ;
2090: 3b 20 67 65 74 20 72 69 64 20 6f 66 20 74 68 69 ; get rid of thi
20a0: 73 20 6f 6e 65 0a 20 20 20 20 20 20 20 20 20 20 s one.
20b0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
20c0: 6c 3f 20 6e 65 77 74 61 69 6c 29 20 72 65 73 75 l? newtail) resu
20d0: 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 lt.
20e0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
20f0: 63 61 72 20 6e 65 77 74 61 69 6c 29 28 63 64 72 car newtail)(cdr
2100: 20 6e 65 77 74 61 69 6c 29 20 72 65 73 75 6c 74 newtail) result
2110: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2120: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 72 (let ((newr
2130: 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 esult (append re
2140: 73 75 6c 74 20 28 6c 69 73 74 20 68 65 61 64 20 sult (list head
2150: 76 61 6c 29 29 29 29 0a 20 20 20 20 20 20 20 20 val)))).
2160: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
2170: 28 6e 75 6c 6c 3f 20 6e 65 77 74 61 69 6c 29 20 (null? newtail)
2180: 6e 65 77 72 65 73 75 6c 74 0a 20 20 20 20 20 20 newresult.
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21a0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
21b0: 74 61 69 6c 29 28 63 64 72 20 6e 65 77 74 61 69 tail)(cdr newtai
21c0: 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 l) newresult))))
21d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ). (l
21e0: 65 74 20 28 28 6e 65 77 72 65 73 75 6c 74 20 28 et ((newresult (
21f0: 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 28 6c append result (l
2200: 69 73 74 20 68 65 61 64 29 29 29 29 0a 20 20 20 ist head)))).
2210: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
2220: 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 6e 65 77 72 null? tail) newr
2230: 65 73 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 esult.
2240: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 (loop (c
2250: 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 69 ar tail)(cdr tai
2260: 6c 29 20 6e 65 77 72 65 73 75 6c 74 29 29 29 29 l) newresult))))
2270: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
2280: 73 73 69 6f 6e 3a 67 65 74 2d 70 61 72 61 6d 2d ssion:get-param-
2290: 66 72 6f 6d 20 70 61 72 61 6d 73 20 6b 65 79 29 from params key)
22a0: 0a 20 20 28 6c 65 74 20 28 28 72 31 20 28 72 65 . (let ((r1 (re
22b0: 67 65 78 70 20 28 63 6f 6e 63 20 22 5e 22 20 28 gexp (conc "^" (
22c0: 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 20 6b 65 s:any->string ke
22d0: 79 29 20 22 3d 28 2e 2a 29 24 22 29 29 29 29 0a y) "=(.*)$")))).
22e0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 (if (null? p
22f0: 61 72 61 6d 73 29 20 23 66 0a 20 20 20 20 20 20 arams) #f.
2300: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
2310: 61 64 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 ad (car params))
2320: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2330: 20 20 20 20 28 74 61 69 6c 20 28 63 64 72 20 70 (tail (cdr p
2340: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 arams))).
2350: 20 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 (let ((match
2360: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 31 (string-match r1
2370: 20 68 65 61 64 29 29 29 0a 20 20 20 20 20 20 20 head))).
2380: 20 20 20 20 20 28 69 66 20 6d 61 74 63 68 0a 20 (if match.
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
23a0: 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 20 31 list-ref match 1
23b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
23c0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 (if (null? tai
23d0: 6c 29 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 l) #f.
23e0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
23f0: 28 63 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 (car tail)(cdr t
2400: 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 ail)))))))))..(d
2410: 65 66 69 6e 65 20 28 73 3a 70 72 6f 63 65 73 73 efine (s:process
2420: 2d 70 61 72 61 6d 73 20 70 61 72 61 6d 73 29 0a -params params).
2430: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 (if (null? par
2440: 61 6d 73 29 20 22 22 0a 20 20 20 20 20 20 28 6c ams) "". (l
2450: 65 74 20 6c 6f 6f 70 20 28 28 72 65 73 20 22 22 et loop ((res ""
2460: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2470: 20 20 20 28 68 65 61 64 20 28 63 61 72 20 70 61 (head (car pa
2480: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
2490: 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 (tail (c
24a0: 64 72 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 dr params))).
24b0: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
24c0: 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 tail).
24d0: 20 20 28 63 6f 6e 63 20 72 65 73 20 22 20 22 20 (conc res " "
24e0: 28 73 3a 70 61 72 61 6d 2d 3e 73 74 72 69 6e 67 (s:param->string
24f0: 20 68 65 61 64 29 29 0a 20 20 20 20 20 20 20 20 head)).
2500: 20 20 20 20 28 6c 6f 6f 70 0a 20 20 20 20 20 20 (loop.
2510: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 65 73 (conc res
2520: 20 22 20 22 20 28 73 3a 70 61 72 61 6d 2d 3e 73 " " (s:param->s
2530: 74 72 69 6e 67 20 68 65 61 64 29 29 0a 20 20 20 tring head)).
2540: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 74 (car t
2550: 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ail).
2560: 20 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 (cdr tail)))))
2570: 29 0a 0a 3b 3b 20 72 65 6d 6f 76 65 20 6b 65 79 )..;; remove key
2580: 3d 76 61 72 20 66 72 6f 6d 20 28 6b 65 79 3d 76 =var from (key=v
2590: 61 72 20 6b 65 79 31 3d 76 61 72 31 20 6b 65 79 ar key1=var1 key
25a0: 32 3d 76 61 72 32 20 2e 2e 2e 29 0a 28 64 65 66 2=var2 ...).(def
25b0: 69 6e 65 20 28 6b 3d 76 2d 70 61 72 61 6d 73 3a ine (k=v-params:
25c0: 72 65 6d 6f 76 65 2d 6d 61 74 63 68 69 6e 67 20 remove-matching
25d0: 70 61 72 61 6d 73 20 6b 65 79 29 0a 20 20 28 69 params key). (i
25e0: 66 20 28 3d 20 28 6c 65 6e 67 74 68 20 70 61 72 f (= (length par
25f0: 61 6d 73 29 20 30 29 20 70 61 72 61 6d 73 0a 20 ams) 0) params.
2600: 20 20 20 20 20 28 6c 65 74 20 28 28 72 31 20 28 (let ((r1 (
2610: 72 65 67 65 78 70 20 28 63 6f 6e 63 20 22 5e 22 regexp (conc "^"
2620: 20 6b 65 79 20 22 3d 22 29 29 29 29 0a 20 20 20 key "=")))).
2630: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
2640: 28 68 65 61 64 20 28 63 61 72 20 70 61 72 61 6d (head (car param
2650: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
2660: 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 (tail (cd
2670: 72 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 r params)).
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
2690: 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 20 20 esult '())).
26a0: 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
26b0: 67 2d 6d 61 74 63 68 20 72 31 20 68 65 61 64 29 g-match r1 head)
26c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
26d0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 if (null? tail)
26e0: 72 65 73 75 6c 74 0a 20 20 20 20 20 20 20 20 20 result.
26f0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
2700: 63 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 61 car tail)(cdr ta
2710: 69 6c 29 20 72 65 73 75 6c 74 29 29 0a 20 20 20 il) result)).
2720: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
2730: 28 28 6e 65 77 6c 73 74 20 28 63 6f 6e 73 20 68 ((newlst (cons h
2740: 65 61 64 20 72 65 73 75 6c 74 29 29 29 0a 20 20 ead result))).
2750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
2760: 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 6e f (null? tail) n
2770: 65 77 6c 73 74 0a 20 20 20 20 20 20 20 20 20 20 ewlst.
2780: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
2790: 28 63 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 (car tail)(cdr t
27a0: 61 69 6c 29 20 6e 65 77 6c 73 74 29 29 29 29 29 ail) newlst)))))
27b0: 29 29 29 0a 0a )))..