Artifact
722378235d068fb39bc86cb11044575f3cd8f8be:
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 69 6e me-macros))..(in
0190: 63 6c 75 64 65 20 22 72 65 71 75 69 72 65 6d 65 clude "requireme
01a0: 6e 74 73 2e 73 63 6d 22 29 0a 28 64 65 63 6c 61 nts.scm").(decla
01b0: 72 65 20 28 75 73 65 73 20 63 6f 6f 6b 69 65 29 re (uses cookie)
01c0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
01d0: 20 68 74 6d 6c 2d 66 69 6c 74 65 72 29 29 0a 28 html-filter)).(
01e0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 69 declare (uses mi
01f0: 73 63 2d 73 74 6d 6c 29 29 0a 28 64 65 63 6c 61 sc-stml)).(decla
0200: 72 65 20 28 75 73 65 73 20 66 6f 72 6d 64 61 74 re (uses formdat
0210: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0220: 73 20 73 74 6d 6c 29 29 0a 28 64 65 63 6c 61 72 s stml)).(declar
0230: 65 20 28 75 73 65 73 20 73 65 73 73 69 6f 6e 29 e (uses session)
0240: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0250: 20 73 65 74 75 70 29 29 20 3b 3b 20 73 3a 73 65 setup)) ;; s:se
0260: 73 73 69 6f 6e 20 67 65 74 73 20 63 72 65 61 74 ssion gets creat
0270: 65 64 20 68 65 72 65 0a 28 64 65 63 6c 61 72 65 ed here.(declare
0280: 20 28 75 73 65 73 20 73 71 6c 74 62 6c 29 29 0a (uses sqltbl)).
0290: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6b (declare (uses k
02a0: 65 79 73 74 6f 72 65 29 29 0a 0a 28 64 65 66 69 eystore))..(defi
02b0: 6e 65 20 28 73 74 6d 6c 3a 63 67 69 2d 73 65 73 ne (stml:cgi-ses
02c0: 73 69 6f 6e 20 73 65 73 73 69 6f 6e 29 0a 20 20 sion session).
02d0: 28 73 65 73 73 69 6f 6e 3a 69 6e 69 74 69 61 6c (session:initial
02e0: 69 7a 65 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 ize session). (
02f0: 73 65 73 73 69 6f 6e 3a 73 65 74 75 70 20 73 65 session:setup se
0300: 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 73 69 6f ssion). (sessio
0310: 6e 3a 67 65 74 2d 76 61 72 73 20 73 65 73 73 69 n:get-vars sessi
0320: 6f 6e 29 0a 0a 20 20 28 73 64 61 74 2d 73 65 74 on).. (sdat-set
0330: 2d 6c 6f 67 2d 70 6f 72 74 21 20 73 65 73 73 69 -log-port! sessi
0340: 6f 6e 20 3b 3b 20 28 63 75 72 72 65 6e 74 2d 65 on ;; (current-e
0350: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 20 20 rror-port))...
0360: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
0370: 2d 66 69 6c 65 20 28 73 64 61 74 2d 67 65 74 2d -file (sdat-get-
0380: 6c 6f 67 66 69 6c 65 20 73 65 73 73 69 6f 6e 29 logfile session)
0390: 20 23 3a 61 70 70 65 6e 64 29 29 0a 20 20 28 73 #:append)). (s
03a0: 3a 76 61 6c 69 64 61 74 65 2d 69 6e 70 75 74 73 :validate-inputs
03b0: 29 0a 20 20 28 73 65 73 73 69 6f 6e 3a 72 75 6e ). (session:run
03c0: 2d 61 63 74 69 6f 6e 73 20 73 65 73 73 69 6f 6e -actions session
03d0: 29 0a 20 20 28 73 64 61 74 2d 73 65 74 2d 70 61 ). (sdat-set-pa
03e0: 67 65 64 61 74 21 20 73 65 73 73 69 6f 6e 0a 09 gedat! session..
03f0: 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 73 . (append (s
0400: 64 61 74 2d 67 65 74 2d 70 61 67 65 64 61 74 20 dat-get-pagedat
0410: 73 65 73 73 69 6f 6e 29 0a 09 09 09 20 20 20 20 session)....
0420: 20 28 73 3a 63 61 6c 6c 20 28 73 64 61 74 2d 67 (s:call (sdat-g
0430: 65 74 2d 74 6f 70 70 61 67 65 20 73 65 73 73 69 et-toppage sessi
0440: 6f 6e 29 29 29 29 0a 20 20 28 69 66 20 28 65 71 on)))). (if (eq
0450: 3f 20 28 73 64 61 74 2d 67 65 74 2d 70 61 67 65 ? (sdat-get-page
0460: 2d 74 79 70 65 20 73 65 73 73 69 6f 6e 29 20 27 -type session) '
0470: 68 74 6d 6c 29 20 3b 3b 20 64 65 66 61 75 6c 74 html) ;; default
0480: 20 69 73 20 68 74 6d 6c 2e 20 0a 20 20 20 20 20 is html. .
0490: 20 28 73 65 73 73 69 6f 6e 3a 63 67 69 2d 6f 75 (session:cgi-ou
04a0: 74 20 73 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 t session).
04b0: 20 28 73 65 73 73 69 6f 6e 3a 61 6c 74 2d 6f 75 (session:alt-ou
04c0: 74 20 73 65 73 73 69 6f 6e 29 29 0a 20 20 28 73 t session)). (s
04d0: 65 73 73 69 6f 6e 3a 73 61 76 65 2d 76 61 72 73 ession:save-vars
04e0: 20 73 65 73 73 69 6f 6e 29 0a 20 20 28 73 65 73 session). (ses
04f0: 73 69 6f 6e 3a 63 6c 6f 73 65 20 73 65 73 73 69 sion:close sessi
0500: 6f 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 on))..(define (s
0510: 74 6d 6c 3a 6d 61 69 6e 20 70 72 6f 63 29 0a 20 tml:main proc).
0520: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
0530: 6f 6e 73 0a 20 20 20 65 78 6e 20 20 20 0a 20 20 ons. exn .
0540: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 70 72 (begin. (pr
0550: 69 6e 74 20 22 43 6f 6e 74 65 6e 74 2d 74 79 70 int "Content-typ
0560: 65 3a 20 74 65 78 74 2f 68 74 6d 6c 22 29 0a 20 e: text/html").
0570: 20 20 20 20 28 70 72 69 6e 74 20 22 22 29 0a 20 (print "").
0580: 20 20 20 20 28 70 72 69 6e 74 20 22 3c 68 74 6d (print "<htm
0590: 6c 3e 20 3c 68 65 61 64 3e 20 3c 74 69 74 6c 65 l> <head> <title
05a0: 3e 45 58 43 45 50 54 49 4f 4e 3c 2f 74 69 74 6c >EXCEPTION</titl
05b0: 65 3e 20 3c 2f 68 65 61 64 3e 20 3c 62 6f 64 79 e> </head> <body
05c0: 3e 22 29 0a 20 20 20 20 20 28 70 72 69 6e 74 20 >"). (print
05d0: 22 20 20 20 51 55 45 52 59 5f 53 54 52 49 4e 47 " QUERY_STRING
05e0: 20 69 73 3a 20 3c 62 3e 20 22 20 28 67 65 74 2d is: <b> " (get-
05f0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
0600: 61 62 6c 65 20 22 51 55 45 52 59 5f 53 54 52 49 able "QUERY_STRI
0610: 4e 47 22 29 20 22 20 3c 2f 62 3e 20 3c 62 72 3e NG") " </b> <br>
0620: 22 29 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 "). (print "
0630: 3c 70 72 65 3e 22 29 0a 20 20 20 20 20 3b 3b 20 <pre>"). ;;
0640: 28 70 72 69 6e 74 20 22 20 20 20 45 58 43 45 50 (print " EXCEP
0650: 54 49 4f 4e 3a 20 22 20 28 28 63 6f 6e 64 69 74 TION: " ((condit
0660: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
0670: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
0680: 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 age) exn)).
0690: 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 (print-error-mes
06a0: 73 61 67 65 20 65 78 6e 29 0a 20 20 20 20 20 28 sage exn). (
06b0: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
06c0: 29 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 3c ). (print "<
06d0: 2f 70 72 65 3e 22 29 0a 20 20 20 20 20 28 70 72 /pre>"). (pr
06e0: 69 6e 74 20 22 3c 74 61 62 6c 65 3e 22 29 0a 20 int "<table>").
06f0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
0700: 61 6d 62 64 61 20 28 76 61 72 29 0a 09 09 20 28 ambda (var)... (
0710: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 print "<tr><td>"
0720: 20 28 63 61 72 20 76 61 72 29 20 22 3c 2f 74 64 (car var) "</td
0730: 3e 3c 74 64 3e 22 20 28 63 64 72 20 76 61 72 29 ><td>" (cdr var)
0740: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a "</td></tr>")).
0750: 09 20 20 20 20 20 20 20 28 67 65 74 2d 65 6e 76 . (get-env
0760: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
0770: 65 73 29 29 0a 20 20 20 20 20 28 70 72 69 6e 74 es)). (print
0780: 20 22 3c 2f 74 61 62 6c 65 3e 22 29 0a 20 20 20 "</table>").
0790: 20 20 28 70 72 69 6e 74 20 22 3c 2f 62 6f 64 79 (print "</body
07a0: 3e 3c 2f 68 74 6d 6c 3e 22 29 29 0a 20 20 20 0a ></html>")). .
07b0: 20 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f (if proc (pro
07c0: 63 20 73 3a 73 65 73 73 69 6f 6e 29 20 28 73 74 c s:session) (st
07d0: 6d 6c 3a 63 67 69 2d 73 65 73 73 69 6f 6e 20 73 ml:cgi-session s
07e0: 3a 73 65 73 73 69 6f 6e 29 29 0a 20 3b 3b 20 28 :session)). ;; (
07f0: 72 61 69 73 65 2d 65 72 72 6f 72 29 0a 20 3b 3b raise-error). ;;
0800: 20 28 65 78 69 74 29 0a 20 20 20 29 29 0a (exit). )).