Artifact
40942140f1482588175aa379971b36d14d279304:
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 28 72 65 PURPOSE...;; (re
0150: 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 quire-extension
0160: 73 79 6e 74 61 78 2d 63 61 73 65 29 0a 3b 3b 20 syntax-case).;;
0170: 28 64 65 63 6c 61 72 65 20 28 72 75 6e 2d 74 69 (declare (run-ti
0180: 6d 65 2d 6d 61 63 72 6f 73 29 29 0a 0a 28 6d 6f me-macros))..(mo
0190: 64 75 6c 65 20 73 74 6d 6c 63 6f 6d 6d 6f 6e 0a dule stmlcommon.
01a0: 20 20 20 20 2a 0a 0a 28 69 6d 70 6f 72 74 20 20 *..(import
01b0: 63 68 69 63 6b 65 6e 20 73 63 68 65 6d 65 20 64 chicken scheme d
01c0: 61 74 61 2d 73 74 72 75 63 74 75 72 65 73 20 65 ata-structures e
01d0: 78 74 72 61 73 20 73 72 66 69 2d 31 33 20 70 6f xtras srfi-13 po
01e0: 72 74 73 20 29 0a 0a 28 75 73 65 20 63 6f 6f 6b rts )..(use cook
01f0: 69 65 20 6d 69 73 63 2d 73 74 6d 6c 20 66 6f 72 ie misc-stml for
0200: 6d 64 61 74 20 73 65 73 73 69 6f 6e 20 73 71 6c mdat session sql
0210: 74 62 6c 20 6b 65 79 73 74 6f 72 65 29 0a 0a 28 tbl keystore)..(
0220: 69 6e 63 6c 75 64 65 20 22 72 65 71 75 69 72 65 include "require
0230: 6d 65 6e 74 73 2e 73 63 6d 22 29 0a 0a 3b 3b 28 ments.scm")..;;(
0240: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co
0250: 6f 6b 69 65 29 29 0a 3b 3b 28 64 65 63 6c 61 72 okie)).;;(declar
0260: 65 20 28 75 73 65 73 20 68 74 6d 6c 2d 66 69 6c e (uses html-fil
0270: 74 65 72 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 ter)).;;(declare
0280: 20 28 75 73 65 73 20 6d 69 73 63 2d 73 74 6d 6c (uses misc-stml
0290: 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 )).;;(declare (u
02a0: 73 65 73 20 66 6f 72 6d 64 61 74 29 29 0a 3b 3b ses formdat)).;;
02b0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 (declare (uses s
02c0: 74 6d 6c 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 tml)).;;(declare
02d0: 20 28 75 73 65 73 20 73 65 73 73 69 6f 6e 29 29 (uses session))
02e0: 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 .;;(declare (use
02f0: 73 20 73 65 74 75 70 29 29 20 3b 3b 20 73 3a 73 s setup)) ;; s:s
0300: 65 73 73 69 6f 6e 20 67 65 74 73 20 63 72 65 61 ession gets crea
0310: 74 65 64 20 68 65 72 65 0a 3b 3b 28 64 65 63 6c ted here.;;(decl
0320: 61 72 65 20 28 75 73 65 73 20 73 71 6c 74 62 6c are (uses sqltbl
0330: 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 )).;;(declare (u
0340: 73 65 73 20 6b 65 79 73 74 6f 72 65 29 29 0a 0a ses keystore))..
0350: 28 64 65 66 69 6e 65 20 28 73 74 6d 6c 3a 63 67 (define (stml:cg
0360: 69 2d 73 65 73 73 69 6f 6e 20 73 65 73 73 69 6f i-session sessio
0370: 6e 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 69 6e n). (session:in
0380: 69 74 69 61 6c 69 7a 65 20 73 65 73 73 69 6f 6e itialize session
0390: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 65 74 ). (session:set
03a0: 75 70 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 up session). (s
03b0: 65 73 73 69 6f 6e 3a 67 65 74 2d 76 61 72 73 20 ession:get-vars
03c0: 73 65 73 73 69 6f 6e 29 0a 0a 20 20 28 73 64 61 session).. (sda
03d0: 74 2d 73 65 74 2d 6c 6f 67 2d 70 6f 72 74 21 20 t-set-log-port!
03e0: 73 65 73 73 69 6f 6e 20 3b 3b 20 28 63 75 72 72 session ;; (curr
03f0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
0400: 0a 09 09 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f ... (open-o
0410: 75 74 70 75 74 2d 66 69 6c 65 20 28 73 64 61 74 utput-file (sdat
0420: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 65 73 -get-logfile ses
0430: 73 69 6f 6e 29 20 23 3a 61 70 70 65 6e 64 29 29 sion) #:append))
0440: 0a 20 20 28 73 3a 76 61 6c 69 64 61 74 65 2d 69 . (s:validate-i
0450: 6e 70 75 74 73 29 0a 20 20 28 73 65 73 73 69 6f nputs). (sessio
0460: 6e 3a 72 75 6e 2d 61 63 74 69 6f 6e 73 20 73 65 n:run-actions se
0470: 73 73 69 6f 6e 29 0a 20 20 28 73 64 61 74 2d 73 ssion). (sdat-s
0480: 65 74 2d 70 61 67 65 64 61 74 21 20 73 65 73 73 et-pagedat! sess
0490: 69 6f 6e 0a 09 09 20 20 20 20 20 28 61 70 70 65 ion... (appe
04a0: 6e 64 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 nd (sdat-get-pag
04b0: 65 64 61 74 20 73 65 73 73 69 6f 6e 29 0a 09 09 edat session)...
04c0: 09 20 20 20 20 20 28 73 3a 63 61 6c 6c 20 28 73 . (s:call (s
04d0: 64 61 74 2d 67 65 74 2d 74 6f 70 70 61 67 65 20 dat-get-toppage
04e0: 73 65 73 73 69 6f 6e 29 29 29 29 0a 20 20 28 69 session)))). (i
04f0: 66 20 28 65 71 3f 20 28 73 64 61 74 2d 67 65 74 f (eq? (sdat-get
0500: 2d 70 61 67 65 2d 74 79 70 65 20 73 65 73 73 69 -page-type sessi
0510: 6f 6e 29 20 27 68 74 6d 6c 29 20 3b 3b 20 64 65 on) 'html) ;; de
0520: 66 61 75 6c 74 20 69 73 20 68 74 6d 6c 2e 20 0a fault is html. .
0530: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 63 (session:c
0540: 67 69 2d 6f 75 74 20 73 65 73 73 69 6f 6e 29 0a gi-out session).
0550: 20 20 20 20 20 20 28 73 65 73 73 69 6f 6e 3a 61 (session:a
0560: 6c 74 2d 6f 75 74 20 73 65 73 73 69 6f 6e 29 29 lt-out session))
0570: 0a 20 20 28 73 65 73 73 69 6f 6e 3a 73 61 76 65 . (session:save
0580: 2d 76 61 72 73 20 73 65 73 73 69 6f 6e 29 0a 20 -vars session).
0590: 20 28 73 65 73 73 69 6f 6e 3a 63 6c 6f 73 65 20 (session:close
05a0: 73 65 73 73 69 6f 6e 29 29 0a 0a 28 64 65 66 69 session))..(defi
05b0: 6e 65 20 28 73 74 6d 6c 3a 6d 61 69 6e 20 70 72 ne (stml:main pr
05c0: 6f 63 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 oc). (handle-ex
05d0: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 20 ceptions. exn
05e0: 20 20 0a 20 20 20 28 69 66 20 28 73 64 61 74 2d . (if (sdat-
05f0: 67 65 74 2d 64 65 62 75 67 6d 6f 64 65 20 73 3a get-debugmode s:
0600: 73 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 20 20 session).
0610: 28 62 65 67 69 6e 0a 09 20 28 70 72 69 6e 74 20 (begin.. (print
0620: 22 43 6f 6e 74 65 6e 74 2d 74 79 70 65 3a 20 74 "Content-type: t
0630: 65 78 74 2f 68 74 6d 6c 22 29 0a 09 20 28 70 72 ext/html").. (pr
0640: 69 6e 74 20 22 22 29 0a 09 20 28 70 72 69 6e 74 int "").. (print
0650: 20 22 3c 68 74 6d 6c 3e 20 3c 68 65 61 64 3e 20 "<html> <head>
0660: 3c 74 69 74 6c 65 3e 45 58 43 45 50 54 49 4f 4e <title>EXCEPTION
0670: 3c 2f 74 69 74 6c 65 3e 20 3c 2f 68 65 61 64 3e </title> </head>
0680: 20 3c 62 6f 64 79 3e 22 29 0a 09 20 28 70 72 69 <body>").. (pri
0690: 6e 74 20 22 20 20 20 51 55 45 52 59 5f 53 54 52 nt " QUERY_STR
06a0: 49 4e 47 20 69 73 3a 20 3c 62 3e 20 22 20 28 67 ING is: <b> " (g
06b0: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
06c0: 61 72 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 ariable "QUERY_S
06d0: 54 52 49 4e 47 22 29 20 22 20 3c 2f 62 3e 20 3c TRING") " </b> <
06e0: 62 72 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 br>").. (print "
06f0: 3c 70 72 65 3e 22 29 0a 09 20 3b 3b 20 28 70 72 <pre>").. ;; (pr
0700: 69 6e 74 20 22 20 20 20 45 58 43 45 50 54 49 4f int " EXCEPTIO
0710: 4e 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e N: " ((condition
0720: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
0730: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
0740: 29 20 65 78 6e 29 29 0a 09 20 28 70 72 69 6e 74 ) exn)).. (print
0750: 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 65 -error-message e
0760: 78 6e 29 0a 09 20 28 70 72 69 6e 74 2d 63 61 6c xn).. (print-cal
0770: 6c 2d 63 68 61 69 6e 29 0a 09 20 28 70 72 69 6e l-chain).. (prin
0780: 74 20 22 3c 2f 70 72 65 3e 22 29 0a 09 20 28 70 t "</pre>").. (p
0790: 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 22 29 0a rint "<table>").
07a0: 09 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d . (for-each (lam
07b0: 62 64 61 20 28 76 61 72 29 0a 09 09 20 20 20 20 bda (var)...
07c0: 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 (print "<tr><td
07d0: 3e 22 20 28 63 61 72 20 76 61 72 29 20 22 3c 2f >" (car var) "</
07e0: 74 64 3e 3c 74 64 3e 22 20 28 63 64 72 20 76 61 td><td>" (cdr va
07f0: 72 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 r) "</td></tr>")
0800: 29 0a 09 09 20 20 20 28 67 65 74 2d 65 6e 76 69 )... (get-envi
0810: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
0820: 73 29 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f s)).. (print "</
0830: 74 61 62 6c 65 3e 22 29 0a 09 20 28 70 72 69 6e table>").. (prin
0840: 74 20 22 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c t "</body></html
0850: 3e 22 29 29 0a 20 20 20 20 20 20 20 28 62 65 67 >")). (beg
0860: 69 6e 0a 09 20 28 77 69 74 68 2d 6f 75 74 70 75 in.. (with-outpu
0870: 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 t-to-file (conc
0880: 22 2f 74 6d 70 2f 73 74 6d 6c 2d 63 72 61 73 68 "/tmp/stml-crash
0890: 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 -" (current-proc
08a0: 65 73 73 2d 69 64 29 20 22 2e 6c 6f 67 22 29 0a ess-id) ".log").
08b0: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 . (lambda ()..
08c0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 58 43 (print "EXC
08d0: 45 50 54 49 4f 4e 22 29 0a 09 20 20 20 20 20 28 EPTION").. (
08e0: 70 72 69 6e 74 20 22 20 20 20 51 55 45 52 59 5f print " QUERY_
08f0: 53 54 52 49 4e 47 20 69 73 3a 20 22 20 28 67 65 STRING is: " (ge
0900: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
0910: 72 69 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 riable "QUERY_ST
0920: 52 49 4e 47 22 29 20 29 0a 09 20 20 20 20 20 28 RING") ).. (
0930: 70 72 69 6e 74 20 22 22 29 0a 09 20 20 20 20 20 print "")..
0940: 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 20 45 58 ;; (print " EX
0950: 43 45 50 54 49 4f 4e 3a 20 22 20 28 28 63 6f 6e CEPTION: " ((con
0960: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
0970: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
0980: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 essage) exn))..
0990: 20 20 20 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 (print-error
09a0: 2d 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 09 20 -message exn)..
09b0: 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d (print-call-
09c0: 63 68 61 69 6e 29 0a 09 20 20 20 20 20 28 70 72 chain).. (pr
09d0: 69 6e 74 20 22 22 29 0a 09 20 20 20 20 20 28 66 int "").. (f
09e0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
09f0: 28 76 61 72 29 0a 09 09 09 20 28 70 72 69 6e 74 (var).... (print
0a00: 20 28 63 61 72 20 76 61 72 29 20 22 5c 74 22 20 (car var) "\t"
0a10: 28 63 64 72 20 76 61 72 29 29 29 0a 09 09 20 20 (cdr var)))...
0a20: 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
0a30: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 nment-variables)
0a40: 29 29 29 0a 09 20 3b 3b 20 72 65 74 75 72 6e 20 ))).. ;; return
0a50: 73 6f 6d 65 74 68 69 6e 67 20 75 73 65 66 75 6c something useful
0a60: 20 74 6f 20 74 68 65 20 75 73 65 72 0a 09 20 28 to the user.. (
0a70: 70 72 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 74 print "Content-t
0a80: 79 70 65 3a 20 74 65 78 74 2f 68 74 6d 6c 22 29 ype: text/html")
0a90: 0a 09 20 28 70 72 69 6e 74 20 22 22 29 0a 09 20 .. (print "")..
0aa0: 28 70 72 69 6e 74 20 22 3c 68 74 6d 6c 3e 20 3c (print "<html> <
0ab0: 68 65 61 64 3e 20 3c 74 69 74 6c 65 3e 45 58 43 head> <title>EXC
0ac0: 45 50 54 49 4f 4e 3c 2f 74 69 74 6c 65 3e 20 3c EPTION</title> <
0ad0: 2f 68 65 61 64 3e 20 3c 62 6f 64 79 3e 22 29 0a /head> <body>").
0ae0: 09 20 28 70 72 69 6e 74 20 22 3c 68 31 3e 43 52 . (print "<h1>CR
0af0: 41 53 48 21 3c 2f 68 31 3e 22 29 0a 09 20 28 70 ASH!</h1>").. (p
0b00: 72 69 6e 74 20 22 20 20 20 50 6c 65 61 73 65 20 rint " Please
0b10: 6e 6f 74 69 66 79 20 73 75 70 70 6f 72 74 20 61 notify support a
0b20: 74 20 22 20 28 73 64 61 74 2d 67 65 74 2d 64 6f t " (sdat-get-do
0b30: 6d 61 69 6e 20 73 3a 73 65 73 73 69 6f 6e 29 20 main s:session)
0b40: 22 20 74 68 61 74 20 74 68 65 20 65 72 72 6f 72 " that the error
0b50: 20 6c 6f 67 20 69 73 20 73 74 6d 6c 2d 63 72 61 log is stml-cra
0b60: 73 68 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 sh-" (current-pr
0b70: 6f 63 65 73 73 2d 69 64 29 20 22 2e 6c 6f 67 3c ocess-id) ".log<
0b80: 2f 62 3e 20 3c 62 72 3e 22 29 0a 09 20 3b 3b 20 /b> <br>").. ;;
0b90: 28 70 72 69 6e 74 20 22 3c 70 72 65 3e 22 29 0a (print "<pre>").
0ba0: 09 20 3b 3b 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; ;; (print "
0bb0: 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 20 22 20 EXCEPTION: "
0bc0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
0bd0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
0be0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
0bf0: 29 29 0a 09 20 3b 3b 20 3b 3b 20 28 70 72 69 6e )).. ;; ;; (prin
0c00: 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 t-error-message
0c10: 65 78 6e 29 0a 09 20 3b 3b 20 3b 3b 20 28 70 72 exn).. ;; ;; (pr
0c20: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a int-call-chain).
0c30: 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 3c 2f 70 . ;; (print "</p
0c40: 72 65 3e 22 29 0a 09 20 3b 3b 20 28 70 72 69 6e re>").. ;; (prin
0c50: 74 20 22 3c 74 61 62 6c 65 3e 22 29 0a 09 20 3b t "<table>").. ;
0c60: 3b 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ; (for-each (lam
0c70: 62 64 61 20 28 76 61 72 29 0a 09 20 3b 3b 20 09 bda (var).. ;; .
0c80: 20 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 (print "<tr
0c90: 3e 3c 74 64 3e 22 20 28 63 61 72 20 76 61 72 29 ><td>" (car var)
0ca0: 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 63 64 "</td><td>" (cd
0cb0: 72 20 76 61 72 29 20 22 3c 2f 74 64 3e 3c 2f 74 r var) "</td></t
0cc0: 72 3e 22 29 29 0a 09 20 3b 3b 20 09 20 20 20 28 r>")).. ;; . (
0cd0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
0ce0: 76 61 72 69 61 62 6c 65 73 29 29 0a 09 20 3b 3b variables)).. ;;
0cf0: 20 28 70 72 69 6e 74 20 22 3c 2f 74 61 62 6c 65 (print "</table
0d00: 3e 22 29 0a 09 20 28 70 72 69 6e 74 20 22 3c 2f >").. (print "</
0d10: 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 29 29 body></html>")))
0d20: 0a 20 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 . (if proc (pr
0d30: 6f 63 20 73 3a 73 65 73 73 69 6f 6e 29 20 28 73 oc s:session) (s
0d40: 74 6d 6c 3a 63 67 69 2d 73 65 73 73 69 6f 6e 20 tml:cgi-session
0d50: 73 3a 73 65 73 73 69 6f 6e 29 29 0a 20 3b 3b 20 s:session)). ;;
0d60: 28 72 61 69 73 65 2d 65 72 72 6f 72 29 0a 20 3b (raise-error). ;
0d70: 3b 20 28 65 78 69 74 29 0a 20 20 20 29 29 0a 0a ; (exit). ))..
0d80: 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 ;; given a list
0d90: 6f 66 20 73 79 6d 62 6f 6c 73 20 67 69 76 65 20 of symbols give
0da0: 74 68 65 20 63 6f 75 6e 74 20 6f 66 20 74 68 65 the count of the
0db0: 20 6d 61 74 63 68 69 6e 67 20 73 79 6d 62 6f 6c matching symbol
0dc0: 0a 3b 3b 20 6c 20 3d 3e 20 27 28 61 20 62 20 63 .;; l => '(a b c
0dd0: 29 20 20 28 64 75 6d 6f 62 6a 3a 69 6e 64 78 20 ) (dumobj:indx
0de0: 61 20 27 62 29 20 3d 3e 20 31 0a 28 64 65 66 69 a 'b) => 1.(defi
0df0: 6e 65 20 28 73 3a 67 65 74 2d 66 69 65 6c 64 6e ne (s:get-fieldn
0e00: 75 6d 20 6c 73 74 20 66 69 65 6c 64 2d 6e 61 6d um lst field-nam
0e10: 65 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 e). (let loop (
0e20: 28 68 65 61 64 20 28 63 61 72 20 6c 73 74 29 29 (head (car lst))
0e30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 . (t
0e40: 61 69 6c 20 28 63 64 72 20 6c 73 74 29 29 0a 20 ail (cdr lst)).
0e50: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 75 (fnu
0e60: 6d 20 30 29 29 0a 20 20 20 20 28 69 66 20 28 65 m 0)). (if (e
0e70: 71 3f 20 68 65 61 64 20 66 69 65 6c 64 2d 6e 61 q? head field-na
0e80: 6d 65 29 20 66 6e 75 6d 0a 20 20 20 20 20 20 20 me) fnum.
0e90: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c (if (null? tail
0ea0: 29 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 ) #f.
0eb0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
0ec0: 29 28 63 64 72 20 74 61 69 6c 29 28 2b 20 66 6e )(cdr tail)(+ fn
0ed0: 75 6d 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 um 1))))))..(def
0ee0: 69 6e 65 20 28 73 3a 66 69 65 6c 64 73 2d 3e 73 ine (s:fields->s
0ef0: 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 73 74 tring lst). (st
0f00: 72 69 6e 67 2d 6a 6f 69 6e 20 28 6d 61 70 20 73 ring-join (map s
0f10: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6c 73 ymbol->string ls
0f20: 74 29 20 22 2c 22 29 29 0a 0a 28 64 65 66 69 6e t) ","))..(defin
0f30: 65 20 28 73 3a 76 65 63 74 6f 72 2d 67 65 74 2d e (s:vector-get-
0f40: 66 69 65 6c 64 20 76 65 63 20 66 69 65 6c 64 20 field vec field
0f50: 66 69 65 6c 64 2d 6c 69 73 74 29 0a 20 20 28 76 field-list). (v
0f60: 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 28 73 ector-ref vec (s
0f70: 3a 67 65 74 2d 66 69 65 6c 64 6e 75 6d 20 66 69 :get-fieldnum fi
0f80: 65 6c 64 2d 6c 69 73 74 20 66 69 65 6c 64 29 29 eld-list field))
0f90: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
0fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b ===========.;;.;
0fe0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1020: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6d 6f 76 65 =======..;; move
1030: 64 20 74 6f 20 6d 69 73 63 2d 73 74 6d 6c 0a 3b d to misc-stml.;
1040: 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 65 72 72 ;.#;(define (err
1050: 3a 6c 6f 67 20 2e 20 6d 73 67 29 0a 20 20 28 77 :log . msg). (w
1060: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
1070: 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f rt (current-erro
1080: 72 2d 70 6f 72 74 29 20 3b 3b 20 28 73 6c 6f 74 r-port) ;; (slot
1090: 2d 72 65 66 20 73 65 6c 66 20 27 6c 6f 67 70 74 -ref self 'logpt
10a0: 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 ). (lambda ()
10b0: 20 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 . (apply p
10c0: 72 69 6e 74 20 6d 73 67 29 29 29 29 0a 0a 28 64 rint msg))))..(d
10d0: 65 66 69 6e 65 20 28 73 3a 74 69 64 79 2d 75 72 efine (s:tidy-ur
10e0: 6c 20 75 72 6c 29 0a 20 20 28 69 66 20 75 72 6c l url). (if url
10f0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 31 . (let ((r1
1100: 20 28 72 65 67 65 78 70 20 22 5e 68 74 74 70 3a (regexp "^http:
1110: 5c 5c 2f 5c 5c 2f 22 29 29 0a 20 20 20 20 20 20 \\/\\/")).
1120: 20 20 20 20 20 20 28 72 32 20 28 72 65 67 65 78 (r2 (regex
1130: 70 20 22 5e 5b 20 5c 5c 74 5d 2a 24 22 29 29 29 p "^[ \\t]*$")))
1140: 20 3b 3b 20 62 6c 61 6e 6b 0a 20 20 20 20 20 20 ;; blank.
1150: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
1160: 74 63 68 20 72 31 20 75 72 6c 29 20 75 72 6c 0a tch r1 url) url.
1170: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
1180: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 32 (string-match r2
1190: 20 75 72 6c 29 20 23 66 20 3b 3b 20 63 6f 6e 76 url) #f ;; conv
11a0: 65 72 74 20 61 20 62 6c 61 6e 6b 20 74 6f 20 23 ert a blank to #
11b0: 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f.
11c0: 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f (conc "http://
11d0: 22 20 75 72 6c 29 29 29 29 0a 20 20 20 20 20 20 " url)))).
11e0: 75 72 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 url))..(define (
11f0: 73 3a 6c 61 7a 79 2d 3e 6e 75 6d 20 6e 75 6d 29 s:lazy->num num)
1200: 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 . (if (number?
1210: 6e 75 6d 29 20 6e 75 6d 0a 20 20 20 20 20 20 28 num) num. (
1220: 69 66 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 if (string->numb
1230: 65 72 20 6e 75 6d 29 20 28 73 74 72 69 6e 67 2d er num) (string-
1240: 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 0a 09 20 20 >number num)..
1250: 20 20 28 69 66 20 6e 75 6d 20 31 20 30 29 29 29 (if num 1 0)))
1260: 29 20 3b 3b 20 77 69 65 72 64 20 65 68 21 20 79 ) ;; wierd eh! y
1270: 65 70 2c 20 23 66 3d 3e 30 20 23 74 3d 3e 31 20 ep, #f=>0 #t=>1
1280: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 ==========.;; D
12d0: 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d B.;;============
12e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 ==========..;; c
1320: 6f 6e 76 65 72 74 20 76 61 6c 75 65 73 20 74 6f onvert values to
1330: 20 61 70 70 72 6f 70 72 69 61 74 65 20 73 74 72 appropriate str
1340: 69 6e 67 73 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e ings.;;.#;(defin
1350: 65 20 28 73 3a 73 71 6c 70 61 72 61 6d 2d 76 61 e (s:sqlparam-va
1360: 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 0a 20 l->string val).
1370: 20 28 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 (cond. ((list
1380: 3f 20 20 20 76 61 6c 29 28 73 74 72 69 6e 67 2d ? val)(string-
1390: 6a 6f 69 6e 20 28 6d 61 70 20 73 79 6d 62 6f 6c join (map symbol
13a0: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 20 22 2c ->string val) ",
13b0: 22 29 29 20 3b 3b 20 28 61 20 62 20 63 29 20 3d ")) ;; (a b c) =
13c0: 3e 20 61 2c 62 2c 63 0a 20 20 20 28 28 73 74 72 > a,b,c. ((str
13d0: 69 6e 67 3f 20 76 61 6c 29 28 63 6f 6e 63 20 22 ing? val)(conc "
13e0: 27 22 20 28 64 62 69 3a 65 73 63 61 70 65 2d 73 '" (dbi:escape-s
13f0: 74 72 69 6e 67 20 76 61 6c 29 20 22 27 22 29 29 tring val) "'"))
1400: 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 . ((number? va
1410: 6c 29 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e l)(number->strin
1420: 67 20 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d g val)). ((sym
1430: 62 6f 6c 3f 20 76 61 6c 29 28 64 62 69 3a 65 73 bol? val)(dbi:es
1440: 63 61 70 65 2d 73 74 72 69 6e 67 20 28 73 79 6d cape-string (sym
1450: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
1460: 29 29 0a 20 20 20 28 28 62 6f 6f 6c 65 61 6e 3f )). ((boolean?
1470: 20 76 61 6c 29 0a 20 20 20 20 28 69 66 20 76 61 val). (if va
1480: 6c 20 22 54 52 55 45 22 20 22 46 41 4c 53 45 22 l "TRUE" "FALSE"
1490: 29 29 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 )) ;; should th
14a0: 69 73 20 62 65 20 22 54 52 55 45 22 20 6f 72 20 is be "TRUE" or
14b0: 31 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1?.
14c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14d0: 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 ;; should this
14e0: 62 65 20 22 46 41 4c 53 45 22 20 6f 72 20 30 20 be "FALSE" or 0
14f0: 6f 72 20 4e 55 4c 4c 3f 0a 20 20 20 28 65 6c 73 or NULL?. (els
1500: 65 0a 20 20 20 20 28 65 72 72 3a 6c 6f 67 20 22 e. (err:log "
1510: 73 71 6c 70 61 72 61 6d 3a 20 75 6e 6b 6e 6f 77 sqlparam: unknow
1520: 6e 20 74 79 70 65 20 66 6f 72 20 76 61 6c 75 65 n type for value
1530: 3a 20 22 20 76 61 6c 29 0a 20 20 20 20 22 22 29 : " val). "")
1540: 29 29 0a 0a 3b 3b 20 28 73 71 6c 70 61 72 61 6d ))..;; (sqlparam
1550: 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 66 6f "INSERT INTO fo
1560: 6f 28 6e 61 6d 65 2c 61 67 65 29 20 56 41 4c 55 o(name,age) VALU
1570: 45 53 28 3f 2c 3f 29 3b 22 20 22 62 6f 62 22 20 ES(?,?);" "bob"
1580: 32 30 29 0a 3b 3b 20 4e 42 2f 2f 20 31 2e 20 76 20).;; NB// 1. v
1590: 61 6c 75 65 73 20 6f 6e 6c 79 21 21 20 0a 3b 3b alues only!! .;;
15a0: 20 20 20 20 20 20 32 2e 20 74 65 72 6d 69 6e 61 2. termina
15b0: 74 69 6e 67 20 73 65 6d 69 63 6f 6c 6f 6e 20 72 ting semicolon r
15c0: 65 71 75 69 72 65 64 20 28 75 73 65 64 20 61 73 equired (used as
15d0: 20 70 61 72 74 20 6f 66 20 6c 6f 67 69 63 29 0a part of logic).
15e0: 3b 3b 0a 3b 3b 20 61 3d 3f 20 31 20 28 6e 75 6d ;;.;; a=? 1 (num
15f0: 62 65 72 29 20 3d 3e 20 61 3d 31 0a 3b 3b 20 61 ber) => a=1.;; a
1600: 3d 3f 20 31 20 28 73 74 72 69 6e 67 29 20 3d 3e =? 1 (string) =>
1610: 20 61 3d 27 31 27 0a 3b 3b 20 61 3d 3f 20 23 66 a='1'.;; a=? #f
1620: 20 20 20 20 20 20 20 20 20 3d 3e 20 61 3d 46 41 => a=FA
1630: 4c 53 45 20 0a 3b 3b 20 61 3d 3f 20 61 20 28 73 LSE .;; a=? a (s
1640: 79 6d 62 6f 6c 29 20 3d 3e 20 61 3d 61 20 0a 3b ymbol) => a=a .;
1650: 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 3a 73 ;.#;(define (s:s
1660: 71 6c 70 61 72 61 6d 20 71 75 65 72 79 20 2e 20 qlparam query .
1670: 61 72 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 args). (let* ((
1680: 71 75 65 72 79 2d 70 61 72 74 73 20 28 73 74 72 query-parts (str
1690: 69 6e 67 2d 73 70 6c 69 74 20 71 75 65 72 79 20 ing-split query
16a0: 22 3f 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "?")). (
16b0: 6e 75 6d 2d 70 61 72 74 73 20 20 20 20 28 6c 65 num-parts (le
16c0: 6e 67 74 68 20 71 75 65 72 79 2d 70 61 72 74 73 ngth query-parts
16d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d )). (num
16e0: 2d 61 72 67 73 20 20 20 20 28 6c 65 6e 67 74 68 -args (length
16f0: 20 61 72 67 73 29 29 29 0a 20 20 20 20 28 69 66 args))). (if
1700: 20 28 6e 6f 74 20 28 3d 20 28 2b 20 6e 75 6d 2d (not (= (+ num-
1710: 61 72 67 73 20 31 29 20 6e 75 6d 2d 70 61 72 74 args 1) num-part
1720: 73 29 29 0a 20 20 20 20 20 20 20 20 28 65 72 72 s)). (err
1730: 3a 6c 6f 67 20 22 45 52 52 4f 52 2c 20 73 71 6c :log "ERROR, sql
1740: 70 61 72 61 6d 3a 20 77 72 6f 6e 67 20 6e 75 6d param: wrong num
1750: 62 65 72 20 6f 66 20 61 72 67 75 6d 65 6e 74 73 ber of arguments
1760: 20 6f 72 20 6d 69 73 73 69 6e 67 20 73 65 6d 69 or missing semi
1770: 63 6f 6c 6f 6e 2c 20 22 20 6e 75 6d 2d 61 72 67 colon, " num-arg
1780: 73 20 22 20 66 6f 72 20 71 75 65 72 79 20 22 20 s " for query "
1790: 71 75 65 72 79 29 0a 20 20 20 20 20 20 20 20 28 query). (
17a0: 69 66 20 28 3d 20 6e 75 6d 2d 61 72 67 73 20 30 if (= num-args 0
17b0: 29 20 71 75 65 72 79 0a 20 20 20 20 20 20 20 20 ) query.
17c0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
17d0: 73 65 63 74 69 6f 6e 20 28 63 61 72 20 71 75 65 section (car que
17e0: 72 79 2d 70 61 72 74 73 29 29 0a 20 20 20 20 20 ry-parts)).
17f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1800: 20 20 28 74 61 69 6c 20 20 20 20 28 63 64 72 20 (tail (cdr
1810: 71 75 65 72 79 2d 70 61 72 74 73 29 29 0a 20 20 query-parts)).
1820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1830: 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 22 22 (result ""
1840: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1850: 20 20 20 20 20 20 20 20 20 28 61 72 67 20 20 20 (arg
1860: 20 20 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 (car args)).
1870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1880: 20 20 20 20 20 28 61 72 67 74 61 69 6c 20 28 63 (argtail (c
1890: 64 72 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 dr args))).
18a0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
18b0: 28 76 61 6c 73 74 72 20 20 20 20 28 73 3a 73 71 (valstr (s:sq
18c0: 6c 70 61 72 61 6d 2d 76 61 6c 2d 3e 73 74 72 69 lparam-val->stri
18d0: 6e 67 20 61 72 67 29 29 0a 20 20 20 20 20 20 20 ng arg)).
18e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
18f0: 65 77 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 72 ewresult (conc r
1900: 65 73 75 6c 74 20 73 65 63 74 69 6f 6e 20 76 61 esult section va
1910: 6c 73 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 lstr))).
1920: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
1930: 6c 3f 20 61 72 67 74 61 69 6c 29 20 3b 3b 20 77 l? argtail) ;; w
1940: 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 20 20 20 e are done.
1950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1960: 63 6f 6e 63 20 6e 65 77 72 65 73 75 6c 74 20 28 conc newresult (
1970: 63 61 72 20 74 61 69 6c 29 29 0a 20 20 20 20 20 car tail)).
1980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1990: 6c 6f 6f 70 0a 20 20 20 20 20 20 20 20 20 20 20 loop.
19a0: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 74 (car t
19b0: 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ail).
19c0: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 (cdr t
19d0: 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ail).
19e0: 20 20 20 20 20 20 20 20 20 20 6e 65 77 72 65 73 newres
19f0: 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ult.
1a00: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 61 72 (car ar
1a10: 67 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 20 gtail).
1a20: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 72 (cdr
1a30: 20 61 72 67 74 61 69 6c 29 29 29 29 29 29 29 29 argtail))))))))
1a40: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d ===========.;; M
1a90: 20 49 20 53 20 43 20 20 20 53 20 54 20 52 20 49 I S C S T R I
1aa0: 20 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 46 N G S T U F F
1ab0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
1b00: 6e 65 20 28 73 3a 73 74 72 69 6e 67 2d 64 6f 77 ne (s:string-dow
1b10: 6e 63 61 73 65 20 73 74 72 29 0a 20 20 28 69 66 ncase str). (if
1b20: 20 28 73 74 72 69 6e 67 3f 20 73 74 72 29 0a 20 (string? str).
1b30: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 (string-tra
1b40: 6e 73 6c 61 74 65 20 73 74 72 20 22 41 42 43 44 nslate str "ABCD
1b50: 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 EFGHIJKLMNOPQRST
1b60: 55 56 57 58 59 5a 22 20 22 61 62 63 64 65 66 67 UVWXYZ" "abcdefg
1b70: 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 hijklmnopqrstuvw
1b80: 78 79 7a 22 29 0a 20 20 20 20 20 20 73 74 72 29 xyz"). str)
1b90: 29 20 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 73 ) ..;; (define s
1ba0: 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 ession:valid-cha
1bb0: 72 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c rs "abcdefghijkl
1bc0: 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 41 42 mnopqrstuvwxyzAB
1bd0: 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 CDEFGHIJKLMNOPQR
1be0: 53 54 55 56 57 58 59 5a 30 31 32 33 34 35 36 37 STUVWXYZ01234567
1bf0: 38 39 22 29 0a 23 3b 28 64 65 66 69 6e 65 20 73 89").#;(define s
1c00: 65 73 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 ession:valid-cha
1c10: 72 73 20 22 61 62 63 64 65 66 67 68 69 6a 6b 6c rs "abcdefghijkl
1c20: 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 30 31 mnopqrstuvwxyz01
1c30: 32 33 34 35 36 37 38 39 22 29 20 3b 3b 20 63 6f 23456789") ;; co
1c40: 6f 6b 69 65 73 20 61 72 65 20 63 61 73 65 20 69 okies are case i
1c50: 6e 73 65 6e 73 69 74 69 76 65 2e 0a 23 3b 28 64 nsensitive..#;(d
1c60: 65 66 69 6e 65 20 73 65 73 73 69 6f 6e 3a 6e 75 efine session:nu
1c70: 6d 2d 76 61 6c 69 64 2d 63 68 61 72 73 20 28 73 m-valid-chars (s
1c80: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 65 73 tring-length ses
1c90: 73 69 6f 6e 3a 76 61 6c 69 64 2d 63 68 61 72 73 sion:valid-chars
1ca0: 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 ))..#;(define (s
1cb0: 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 68 2d 63 ession:get-nth-c
1cc0: 68 61 72 20 6e 74 68 29 0a 20 20 28 73 75 62 73 har nth). (subs
1cd0: 74 72 69 6e 67 20 73 65 73 73 69 6f 6e 3a 76 61 tring session:va
1ce0: 6c 69 64 2d 63 68 61 72 73 20 6e 74 68 20 20 28 lid-chars nth (
1cf0: 2b 20 6e 74 68 20 31 29 29 29 0a 0a 23 3b 28 64 + nth 1)))..#;(d
1d00: 65 66 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 67 efine (session:g
1d10: 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 0a 20 20 et-rand-char).
1d20: 28 73 65 73 73 69 6f 6e 3a 67 65 74 2d 6e 74 68 (session:get-nth
1d30: 2d 63 68 61 72 20 28 72 61 6e 64 6f 6d 20 73 65 -char (random se
1d40: 73 73 69 6f 6e 3a 6e 75 6d 2d 76 61 6c 69 64 2d ssion:num-valid-
1d50: 63 68 61 72 73 29 29 29 0a 0a 23 3b 28 64 65 66 chars)))..#;(def
1d60: 69 6e 65 20 28 73 65 73 73 69 6f 6e 3a 6d 61 6b ine (session:mak
1d70: 65 2d 72 61 6e 64 2d 73 74 72 69 6e 67 20 6c 65 e-rand-string le
1d80: 6e 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 n). (let loop (
1d90: 28 72 65 73 20 22 22 29 0a 20 20 20 20 20 20 20 (res "").
1da0: 20 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 (n 1)).
1db0: 20 20 20 28 69 66 20 28 3e 20 6e 20 6c 65 6e 29 (if (> n len)
1dc0: 20 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c 6f res. (lo
1dd0: 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e op (string-appen
1de0: 64 20 72 65 73 20 28 73 65 73 73 69 6f 6e 3a 67 d res (session:g
1df0: 65 74 2d 72 61 6e 64 2d 63 68 61 72 29 29 0a 20 et-rand-char)).
1e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 (+
1e10: 6e 20 31 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 79 n 1)))))..;; may
1e20: 62 65 20 72 65 70 6c 61 63 65 20 61 62 6f 76 65 be replace above
1e30: 20 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 69 6e make-rand-strin
1e40: 67 20 77 69 74 68 20 74 68 69 73 20 73 6f 6d 65 g with this some
1e50: 64 61 79 3f 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e day?.;;.#;(defin
1e60: 65 20 28 73 65 73 73 69 6f 6e 3a 67 65 6e 65 72 e (session:gener
1e70: 69 63 2d 6d 61 6b 65 2d 72 61 6e 64 2d 73 74 72 ic-make-rand-str
1e80: 69 6e 67 20 6c 65 6e 20 73 65 65 64 2d 73 74 72 ing len seed-str
1e90: 69 6e 67 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 ing). (let ((nu
1ea0: 6d 2d 63 68 61 72 73 20 28 73 74 72 69 6e 67 2d m-chars (string-
1eb0: 6c 65 6e 67 74 68 20 73 65 65 64 2d 73 74 72 69 length seed-stri
1ec0: 6e 67 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c ng))). (let l
1ed0: 6f 6f 70 20 28 28 72 65 73 20 22 22 29 0a 09 20 oop ((res "")..
1ee0: 20 20 20 20 20 20 28 6e 20 20 20 31 29 29 0a 20 (n 1)).
1ef0: 20 20 20 20 20 28 6c 65 74 20 28 28 63 68 61 72 (let ((char
1f00: 2d 6e 75 6d 20 28 72 61 6e 64 6f 6d 20 6e 75 6d -num (random num
1f10: 2d 63 68 61 72 73 29 29 29 0a 09 28 69 66 20 28 -chars)))..(if (
1f20: 3e 20 6e 20 6c 65 6e 29 20 72 65 73 0a 09 20 20 > n len) res..
1f30: 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d (loop (string-
1f40: 61 70 70 65 6e 64 20 72 65 73 20 28 73 75 62 73 append res (subs
1f50: 74 72 69 6e 67 20 73 65 65 64 2d 73 74 72 69 6e tring seed-strin
1f60: 67 20 63 68 61 72 2d 6e 75 6d 20 28 2b 20 63 68 g char-num (+ ch
1f70: 61 72 2d 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 ar-num 1)))...
1f80: 28 2b 20 6e 20 31 29 29 29 29 29 29 29 0a 0a 3b (+ n 1)))))))..;
1f90: 3b 20 52 65 6c 79 20 6f 6e 20 63 72 79 70 74 20 ; Rely on crypt
1fa0: 65 67 67 27 73 20 64 65 66 61 75 6c 74 20 73 65 egg's default se
1fb0: 74 74 69 6e 67 73 20 62 65 69 6e 67 20 73 65 63 ttings being sec
1fc0: 75 72 65 20 65 6e 6f 75 67 68 2c 20 61 63 63 65 ure enough, acce
1fd0: 70 74 0a 3b 3b 20 62 61 63 6b 77 61 72 64 73 2d pt.;; backwards-
1fe0: 63 6f 6d 70 61 74 69 62 6c 65 20 4f 70 65 6e 53 compatible OpenS
1ff0: 53 4c 20 63 72 79 70 74 20 70 61 73 73 77 6f 72 SL crypt passwor
2000: 64 73 20 74 6f 6f 2e 0a 3b 3b 0a 28 64 65 66 69 ds too..;;.(defi
2010: 6e 65 20 28 73 3a 63 72 79 70 74 2d 70 61 73 73 ne (s:crypt-pass
2020: 77 64 20 70 77 20 73 29 0a 20 20 28 63 3a 63 72 wd pw s). (c:cr
2030: 79 70 74 20 70 77 20 28 6f 72 20 73 20 28 63 3a ypt pw (or s (c:
2040: 63 72 79 70 74 2d 67 65 6e 73 61 6c 74 29 29 29 crypt-gensalt)))
2050: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 3a 70 61 )..(define (s:pa
2060: 73 73 77 6f 72 64 2d 6d 61 74 63 68 3f 20 70 61 ssword-match? pa
2070: 73 73 77 6f 72 64 20 63 72 79 70 74 65 64 29 0a ssword crypted).
2080: 20 20 28 6c 65 74 2a 20 28 28 73 61 6c 74 20 28 (let* ((salt (
2090: 73 75 62 73 74 72 69 6e 67 20 63 72 79 70 74 65 substring crypte
20a0: 64 20 30 20 32 29 29 0a 20 20 20 20 20 20 20 20 d 0 2)).
20b0: 20 28 70 63 72 79 70 74 65 64 20 28 73 3a 63 72 (pcrypted (s:cr
20c0: 79 70 74 2d 70 61 73 73 77 64 20 70 61 73 73 77 ypt-passwd passw
20d0: 6f 72 64 20 73 61 6c 74 29 29 29 0a 20 20 20 20 ord salt))).
20e0: 3b 3b 20 28 73 3a 6c 6f 67 20 22 49 4e 46 4f 3a ;; (s:log "INFO:
20f0: 20 70 63 72 79 70 74 65 64 3d 22 20 70 63 72 79 pcrypted=" pcry
2100: 70 74 65 64 20 22 20 63 72 79 70 74 65 64 3d 22 pted " crypted="
2110: 20 63 72 79 70 74 65 64 29 0a 20 20 20 20 28 61 crypted). (a
2120: 6e 64 20 28 73 74 72 69 6e 67 3f 20 70 61 73 73 nd (string? pass
2130: 77 6f 72 64 29 0a 20 20 20 20 20 20 20 20 20 28 word). (
2140: 73 74 72 69 6e 67 3f 20 70 63 72 79 70 74 65 64 string? pcrypted
2150: 29 0a 20 20 20 20 20 20 20 20 20 28 73 74 72 69 ). (stri
2160: 6e 67 3d 3f 20 70 63 72 79 70 74 65 64 20 63 72 ng=? pcrypted cr
2170: 79 70 74 65 64 29 29 29 29 0a 0a 3b 3b 20 28 72 ypted))))..;; (r
2180: 65 61 64 2d 6c 69 6e 65 20 28 6f 70 65 6e 2d 69 ead-line (open-i
2190: 6e 70 75 74 2d 70 69 70 65 20 22 65 63 68 6f 20 nput-pipe "echo
21a0: 66 6f 6f 20 7c 20 6d 6b 70 61 73 73 77 64 20 2d foo | mkpasswd -
21b0: 53 20 61 62 20 2d 73 22 29 29 0a 0a 28 64 65 66 S ab -s"))..(def
21c0: 69 6e 65 20 28 73 3a 65 72 72 6f 72 2d 70 61 67 ine (s:error-pag
21d0: 65 20 2e 20 65 72 72 29 0a 20 20 28 73 3a 63 67 e . err). (s:cg
21e0: 69 2d 6f 75 74 20 28 63 6f 6e 73 20 22 43 6f 6e i-out (cons "Con
21f0: 74 65 6e 74 2d 74 79 70 65 3a 20 74 65 78 74 2f tent-type: text/
2200: 68 74 6d 6c 3b 20 63 68 61 72 73 65 74 3d 69 73 html; charset=is
2210: 6f 2d 38 38 35 39 2d 31 5c 6e 5c 6e 22 0a 09 09 o-8859-1\n\n"...
2220: 20 20 20 28 73 3a 68 74 6d 6c 20 28 73 3a 68 65 (s:html (s:he
2230: 61 64 20 0a 09 09 09 20 20 20 20 28 73 3a 74 69 ad .... (s:ti
2240: 74 6c 65 20 65 72 72 29 0a 09 09 09 20 20 20 20 tle err)....
2250: 28 73 3a 62 6f 64 79 0a 09 09 09 20 20 20 20 20 (s:body....
2260: 28 73 3a 68 31 20 22 45 52 52 4f 52 22 29 0a 09 (s:h1 "ERROR")..
2270: 09 09 20 20 20 20 20 28 73 3a 70 20 65 72 72 29 .. (s:p err)
2280: 29 29 29 29 29 29 0a 0a 3b 3b 20 42 55 47 3a 20 ))))))..;; BUG:
2290: 54 68 65 20 72 65 67 65 78 20 69 6d 70 6c 65 6d The regex implem
22a0: 65 6e 74 73 20 61 20 72 75 6c 65 2c 20 62 75 74 ents a rule, but
22b0: 20 77 68 61 74 20 72 75 6c 65 3f 20 41 48 21 20 what rule? AH!
22c0: 75 73 61 7a 74 65 6d 70 65 2c 20 67 65 74 20 72 usaztempe, get r
22d0: 69 64 20 6f 66 20 74 68 69 73 3f 20 4e 6f 2c 20 id of this? No,
22e0: 74 68 69 73 20 61 6c 73 6f 20 6c 6f 6f 6b 73 20 this also looks
22f0: 66 6f 72 20 26 6b 65 79 3d 76 61 6c 75 65 20 2e for &key=value .
2300: 2e 2e 0a 28 64 65 66 69 6e 65 20 28 73 3a 76 61 ...(define (s:va
2310: 6c 69 64 61 74 65 2d 75 72 69 29 0a 20 20 28 6c lidate-uri). (l
2320: 65 74 20 28 28 75 72 69 20 28 67 65 74 2d 65 6e et ((uri (get-en
2330: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
2340: 6c 65 20 22 52 45 51 55 45 53 54 5f 55 52 49 22 le "REQUEST_URI"
2350: 29 29 0a 09 28 71 72 73 20 28 67 65 74 2d 65 6e ))..(qrs (get-en
2360: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
2370: 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 4e 47 le "QUERY_STRING
2380: 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f "))). (if (no
2390: 74 20 75 72 69 29 0a 09 28 73 65 74 21 20 75 72 t uri)..(set! ur
23a0: 69 20 71 72 73 29 29 0a 20 20 20 20 28 69 66 20 i qrs)). (if
23b0: 75 72 69 0a 09 28 73 74 72 69 6e 67 2d 6d 61 74 uri..(string-mat
23c0: 63 68 20 0a 09 20 28 72 65 67 65 78 70 20 22 5e ch .. (regexp "^
23d0: 28 2f 5b 61 2d 7a 5c 5c 2d 5c 5c 2e 5f 3a 30 2d (/[a-z\\-\\._:0-
23e0: 39 5d 2a 29 2a 28 7c 5c 5c 3f 28 5b 41 2d 5a 61 9]*)*(|\\?([A-Za
23f0: 2d 7a 30 2d 39 5f 5c 5c 2d 5c 5c 2b 5d 2b 3d 5b -z0-9_\\-\\+]+=[
2400: 41 2d 5a 61 2d 7a 30 2d 39 5f 5c 5c 2d 5c 5c 2e A-Za-z0-9_\\-\\.
2410: 5c 5c 2b 5d 2a 26 7b 30 2c 31 7d 29 2a 29 24 22 \\+]*&{0,1})*)$"
2420: 29 20 75 72 69 29 0a 09 28 62 65 67 69 6e 0a 09 ) uri)..(begin..
2430: 20 20 28 73 3a 6c 6f 67 20 22 52 45 51 55 45 53 (s:log "REQUES
2440: 54 20 55 52 49 20 4e 4f 54 20 41 56 41 49 4c 41 T URI NOT AVAILA
2450: 42 4c 45 21 22 29 0a 09 20 20 28 6c 65 74 20 28 BLE!").. (let (
2460: 28 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 (p (open-input-p
2470: 69 70 65 20 22 65 6e 76 22 29 29 29 0a 09 20 20 ipe "env")))..
2480: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 20 (let loop ((l
2490: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 09 (read-line p))..
24a0: 09 20 20 20 20 20 20 20 28 72 65 73 20 27 28 29 . (res '()
24b0: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 65 )).. (if (e
24c0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 0a 09 09 of-object? l)...
24d0: 20 20 28 73 3a 6c 6f 67 20 72 65 73 29 0a 09 09 (s:log res)...
24e0: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
24f0: 6e 65 20 70 29 28 63 6f 6e 73 20 28 6c 69 73 74 ne p)(cons (list
2500: 20 6c 20 22 3c 42 52 3e 22 29 20 72 65 73 29 29 l "<BR>") res))
2510: 29 29 29 0a 09 20 20 23 74 29 29 29 29 0a 0a 28 ))).. #t))))..(
2520: 64 65 66 69 6e 65 20 28 73 3a 76 61 6c 69 64 61 define (s:valida
2530: 74 65 2d 69 6e 70 75 74 73 29 0a 20 20 28 69 66 te-inputs). (if
2540: 20 28 6e 6f 74 20 28 73 3a 76 61 6c 69 64 61 74 (not (s:validat
2550: 65 2d 75 72 69 29 29 0a 20 20 20 20 20 20 28 62 e-uri)). (b
2560: 65 67 69 6e 20 28 73 3a 65 72 72 6f 72 2d 70 61 egin (s:error-pa
2570: 67 65 20 22 42 61 64 20 55 52 49 22 20 28 6c 65 ge "Bad URI" (le
2580: 74 20 28 28 72 65 66 20 28 67 65 74 2d 65 6e 76 t ((ref (get-env
2590: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
25a0: 65 20 22 48 54 54 50 5f 52 45 46 45 52 45 52 22 e "HTTP_REFERER"
25b0: 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 )))..... (
25c0: 69 66 20 72 65 66 0a 09 09 09 09 09 20 20 20 28 if ref...... (
25d0: 6c 69 73 74 20 22 72 65 66 65 72 72 65 64 20 66 list "referred f
25e0: 72 6f 6d 22 20 72 65 66 29 0a 09 09 09 09 09 20 rom" ref)......
25f0: 20 20 22 22 29 29 29 0a 09 20 20 20 20 20 28 65 ""))).. (e
2600: 78 69 74 29 29 29 29 0a 0a 3b 3b 20 6d 6f 76 65 xit))))..;; move
2610: 64 20 74 6f 20 6d 69 73 63 2d 73 74 6d 6c 0a 3b d to misc-stml.;
2620: 3b 0a 3b 3b 20 61 6e 79 74 68 69 6e 67 20 65 78 ;.;; anything ex
2630: 63 65 70 74 20 61 20 6c 69 73 74 20 69 73 20 63 cept a list is c
2640: 6f 6e 76 65 72 74 65 64 20 74 6f 20 61 20 73 74 onverted to a st
2650: 72 69 6e 67 21 21 21 0a 23 3b 28 64 65 66 69 6e ring!!!.#;(defin
2660: 65 20 28 73 3a 61 6e 79 2d 3e 73 74 72 69 6e 67 e (s:any->string
2670: 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 0a 20 20 val). (cond.
2680: 20 28 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 ((string? val)
2690: 76 61 6c 29 0a 20 20 20 28 28 6e 75 6d 62 65 72 val). ((number
26a0: 3f 20 76 61 6c 29 20 28 6e 75 6d 62 65 72 2d 3e ? val) (number->
26b0: 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 20 20 20 string val)).
26c0: 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 28 ((symbol? val) (
26d0: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 symbol->string v
26e0: 61 6c 29 29 0a 20 20 20 28 28 65 71 3f 20 76 61 al)). ((eq? va
26f0: 6c 20 23 66 29 20 22 22 29 0a 20 20 20 28 28 65 l #f) ""). ((e
2700: 71 3f 20 76 61 6c 20 23 74 29 20 22 54 52 55 45 q? val #t) "TRUE
2710: 22 29 0a 20 20 20 28 28 6c 69 73 74 3f 20 76 61 "). ((list? va
2720: 6c 29 20 76 61 6c 29 0a 20 20 20 28 65 6c 73 65 l) val). (else
2730: 20 0a 20 20 20 20 28 6c 65 74 20 28 28 6f 73 74 . (let ((ost
2740: 72 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 r (open-output-s
2750: 74 72 69 6e 67 29 29 29 0a 20 20 20 20 20 20 28 tring))). (
2760: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 with-output-to-p
2770: 6f 72 74 20 6f 73 74 72 0a 09 28 6c 61 6d 62 64 ort ostr..(lambd
2780: 61 20 28 29 0a 09 20 20 28 64 69 73 70 6c 61 79 a ().. (display
2790: 20 76 61 6c 29 29 29 0a 20 20 20 20 20 20 28 67 val))). (g
27a0: 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 et-output-string
27b0: 20 6f 73 74 72 29 29 29 29 29 0a 0a 23 3b 28 64 ostr)))))..#;(d
27c0: 65 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 6e 75 efine (s:any->nu
27d0: 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e mber val). (con
27e0: 64 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 d. ((number? v
27f0: 61 6c 29 20 20 76 61 6c 29 0a 20 20 20 28 28 73 al) val). ((s
2800: 74 72 69 6e 67 3f 20 76 61 6c 29 20 20 28 73 74 tring? val) (st
2810: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c ring->number val
2820: 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 )). ((symbol?
2830: 76 61 6c 29 20 20 28 73 74 72 69 6e 67 2d 3e 6e val) (string->n
2840: 75 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 umber (symbol->s
2850: 74 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 tring val))).
2860: 28 65 6c 73 65 20 20 20 20 20 23 66 29 29 29 0a (else #f))).
2870: 0a 3b 3b 20 4e 42 2f 2f 20 74 68 69 73 20 69 73 .;; NB// this is
2880: 20 2a 69 6c 6c 65 67 61 6c 2a 20 70 67 69 6e 74 *illegal* pgint
2890: 0a 28 64 65 66 69 6e 65 20 28 73 3a 69 6c 6c 65 .(define (s:ille
28a0: 67 61 6c 2d 70 67 69 6e 74 20 76 61 6c 29 0a 20 gal-pgint val).
28b0: 20 28 63 6f 6e 64 0a 20 20 20 28 28 3e 20 76 61 (cond. ((> va
28c0: 6c 20 32 31 34 37 34 38 33 36 34 37 29 20 31 29 l 2147483647) 1)
28d0: 0a 20 20 20 28 28 3c 20 76 61 6c 20 2d 32 31 34 . ((< val -214
28e0: 37 34 38 33 36 34 38 29 20 2d 31 29 0a 20 20 20 7483648) -1).
28f0: 28 65 6c 73 65 20 23 66 29 29 29 0a 0a 28 64 65 (else #f)))..(de
2900: 66 69 6e 65 20 28 73 3a 61 6e 79 2d 3e 70 67 69 fine (s:any->pgi
2910: 6e 74 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 nt val). (let (
2920: 28 6e 20 28 73 3a 61 6e 79 2d 3e 6e 75 6d 62 65 (n (s:any->numbe
2930: 72 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 66 r val))). (if
2940: 20 6e 0a 09 28 69 66 20 28 73 3a 69 6c 6c 65 67 n..(if (s:illeg
2950: 61 6c 2d 70 67 69 6e 74 20 6e 29 0a 09 20 20 20 al-pgint n)..
2960: 20 23 66 0a 09 20 20 20 20 6e 29 0a 09 6e 29 29 #f.. n)..n))
2970: 29 0a 0a 3b 3b 20 73 74 72 69 6e 67 20 69 73 20 )..;; string is
2980: 61 20 73 74 72 69 6e 67 20 61 6e 64 20 6e 6f 6e a string and non
2990: 2d 7a 65 72 6f 20 6c 65 6e 67 74 68 0a 28 64 65 -zero length.(de
29a0: 66 69 6e 65 20 28 6d 69 73 63 3a 6e 6f 6e 2d 7a fine (misc:non-z
29b0: 65 72 6f 2d 73 74 72 69 6e 67 20 73 74 72 29 0a ero-string str).
29c0: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
29d0: 6e 67 3f 20 73 74 72 29 0a 20 20 20 20 20 20 20 ng? str).
29e0: 20 20 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c (> (string-l
29f0: 65 6e 67 74 68 20 73 74 72 29 20 30 29 29 0a 20 ength str) 0)).
2a00: 20 20 20 20 20 73 74 72 0a 20 20 20 20 20 20 23 str. #
2a10: 66 29 29 0a 0a 0a 29 0a f))...).