Artifact
9664a46cedd4fd6d6cda85a299b405a8beb30f56:
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 28 64 65 63 6c 61 PURPOSE...(decla
0150: 72 65 20 28 75 6e 69 74 20 66 6f 72 6d 64 61 74 re (unit formdat
0160: 29 29 0a 28 75 73 65 20 72 65 67 65 78 29 0a 28 )).(use regex).(
0170: 72 65 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f require-extensio
0180: 6e 20 73 72 66 69 2d 36 39 29 0a 0a 28 64 65 66 n srfi-69)..(def
0190: 69 6e 65 20 66 6f 72 6d 64 61 74 3a 2a 64 65 62 ine formdat:*deb
01a0: 75 67 2a 20 23 66 29 0a 0a 3b 3b 20 4f 6c 64 20 ug* #f)..;; Old
01b0: 64 61 74 61 20 66 6f 72 6d 61 74 20 77 61 73 20 data format was
01c0: 73 6f 6d 65 74 68 69 6e 67 20 6c 69 6b 65 20 74 something like t
01d0: 68 69 73 2e 20 42 55 54 21 20 0a 3b 3b 20 46 6f his. BUT! .;; Fo
01e0: 72 6d 73 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 rms do not have
01f0: 6e 61 6d 65 73 20 73 6f 20 74 68 65 20 68 69 65 names so the hie
0200: 72 61 72 63 79 20 69 73 0a 3b 3b 20 75 6e 6e 65 rarcy is.;; unne
0210: 63 65 73 73 61 72 79 20 28 49 20 74 68 69 6e 6b cessary (I think
0220: 29 0a 3b 3b 0a 3b 3b 20 68 61 73 68 74 61 62 6c ).;;.;; hashtabl
0230: 65 0a 3b 3b 20 20 20 7c 2d 66 6f 72 6d 6e 61 6d e.;; |-formnam
0240: 65 20 2d 2d 3e 20 3c 66 6f 72 6d 64 61 74 3e 20 e --> <formdat>
0250: 27 66 6f 72 6d 2d 6e 61 6d 65 3d 66 6f 72 6d 6e 'form-name=formn
0260: 61 6d 65 0a 3b 3b 20 20 20 7c 20 20 20 20 20 20 ame.;; |
0270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0280: 20 20 27 66 6f 72 6d 2d 64 61 74 61 3d 68 61 73 'form-data=has
0290: 68 74 61 62 6c 65 0a 3b 3b 20 20 20 7c 20 20 20 htable.;; |
02a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
02b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
02c0: 20 20 20 20 7c 20 6e 61 6d 65 20 3d 3e 20 76 61 | name => va
02d0: 6c 75 65 0a 3b 3b 0a 3b 3b 20 4e 65 77 20 64 61 lue.;;.;; New da
02e0: 74 61 20 66 6f 72 6d 61 74 20 69 73 20 6f 6e 6c ta format is onl
02f0: 79 20 74 68 65 20 3c 66 6f 72 6d 64 61 74 3e 20 y the <formdat>
0300: 70 6f 72 74 69 6f 6e 20 66 72 6f 6d 20 61 62 6f portion from abo
0310: 76 65 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 2d 63 ve..;; (define-c
0320: 6c 61 73 73 20 3c 66 6f 72 6d 64 61 74 3e 20 28 lass <formdat> (
0330: 29 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 2d 64 61 ).;; (form-da
0340: 74 61 0a 3b 3b 20 20 20 20 29 29 0a 28 64 65 66 ta.;; )).(def
0350: 69 6e 65 20 28 6d 61 6b 65 2d 66 6f 72 6d 64 61 ine (make-formda
0360: 74 3a 66 6f 72 6d 64 61 74 29 28 76 65 63 74 6f t:formdat)(vecto
0370: 72 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 r (make-hash-tab
0380: 6c 65 29 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e le))).(define-in
0390: 6c 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 66 6f line (formdat:fo
03a0: 72 6d 64 61 74 2d 67 65 74 2d 64 61 74 61 20 20 rmdat-get-data
03b0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
03c0: 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 -ref vec 0)).(d
03d0: 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 66 6f efine-inline (fo
03e0: 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 73 65 rmdat:formdat-se
03f0: 74 2d 64 61 74 61 21 20 20 76 65 63 20 76 61 6c t-data! vec val
0400: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
0410: 63 20 30 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 c 0 val))..(defi
0420: 6e 65 20 28 66 6f 72 6d 64 61 74 3a 69 6e 69 74 ne (formdat:init
0430: 69 61 6c 69 7a 65 20 73 65 6c 66 29 0a 20 20 28 ialize self). (
0440: 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d formdat:formdat-
0450: 73 65 74 2d 64 61 74 61 21 20 73 65 6c 66 20 28 set-data! self (
0460: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0470: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 ))..(define (for
0480: 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 20 6b 65 mdat:get self ke
0490: 79 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 y). (hash-table
04a0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 20 20 -ref/default .
04b0: 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 (formdat:formda
04c0: 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 29 t-get-data self)
04d0: 0a 20 20 20 28 63 6f 6e 64 20 0a 20 20 20 20 28 . (cond . (
04e0: 28 73 79 6d 62 6f 6c 3f 20 6b 65 79 29 20 6b 65 (symbol? key) ke
04f0: 79 29 0a 20 20 20 20 28 28 73 74 72 69 6e 67 3f y). ((string?
0500: 20 6b 65 79 29 20 28 73 74 72 69 6e 67 2d 3e 73 key) (string->s
0510: 79 6d 62 6f 6c 20 6b 65 79 29 29 0a 20 20 20 20 ymbol key)).
0520: 28 65 6c 73 65 20 6b 65 79 29 29 0a 20 20 20 23 (else key)). #
0530: 66 29 29 0a 0a 3b 3b 20 63 68 61 6e 67 65 20 74 f))..;; change t
0540: 6f 20 63 6f 6e 76 65 72 74 20 64 61 74 61 20 74 o convert data t
0550: 6f 20 6c 69 73 74 20 61 6e 64 20 61 70 70 65 6e o list and appen
0560: 64 20 76 61 6c 20 69 66 20 61 6c 72 65 61 64 79 d val if already
0570: 20 65 78 69 73 74 73 0a 3b 3b 20 6f 72 20 69 73 exists.;; or is
0580: 20 61 20 6c 69 73 74 0a 28 64 65 66 69 6e 65 20 a list.(define
0590: 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 73 65 (formdat:set! se
05a0: 6c 66 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 6c lf key val). (l
05b0: 65 74 20 28 28 70 72 65 76 2d 76 61 6c 20 28 66 et ((prev-val (f
05c0: 6f 72 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 20 ormdat:get self
05d0: 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 28 68 key)). (h
05e0: 74 20 20 20 20 20 20 20 28 66 6f 72 6d 64 61 74 t (formdat
05f0: 3a 66 6f 72 6d 64 61 74 2d 67 65 74 2d 64 61 74 :formdat-get-dat
0600: 61 20 73 65 6c 66 29 29 29 0a 20 20 20 20 28 69 a self))). (i
0610: 66 20 70 72 65 76 2d 76 61 6c 0a 20 20 20 20 20 f prev-val.
0620: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 70 72 (if (list? pr
0630: 65 76 2d 76 61 6c 29 0a 20 20 20 20 20 20 20 20 ev-val).
0640: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
0650: 73 65 74 21 20 68 74 20 6b 65 79 20 28 63 6f 6e set! ht key (con
0660: 73 20 76 61 6c 20 70 72 65 76 2d 76 61 6c 29 29 s val prev-val))
0670: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 . (ha
0680: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
0690: 20 6b 65 79 20 28 6c 69 73 74 20 76 61 6c 20 70 key (list val p
06a0: 72 65 76 2d 76 61 6c 29 29 29 0a 20 20 20 20 20 rev-val))).
06b0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
06c0: 65 74 21 20 68 74 20 6b 65 79 20 76 61 6c 29 29 et! ht key val))
06d0: 0a 20 20 20 20 73 65 6c 66 29 29 0a 0a 28 64 65 . self))..(de
06e0: 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 6b 65 fine (formdat:ke
06f0: 79 73 20 73 65 6c 66 29 0a 20 20 28 68 61 73 68 ys self). (hash
0700: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 66 6f 72 -table-keys (for
0710: 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 74 mdat:formdat-get
0720: 2d 64 61 74 61 20 73 65 6c 66 29 29 29 0a 0a 28 -data self)))..(
0730: 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a define (formdat:
0740: 70 72 69 6e 74 61 6c 6c 20 73 65 6c 66 20 70 72 printall self pr
0750: 69 6e 74 70 72 6f 63 29 0a 20 20 28 70 72 69 6e intproc). (prin
0760: 74 70 72 6f 63 20 22 66 6f 72 6d 64 61 74 3a 70 tproc "formdat:p
0770: 72 69 6e 74 61 6c 6c 20 22 20 28 66 6f 72 6d 64 rintall " (formd
0780: 61 74 3a 6b 65 79 73 20 73 65 6c 66 29 29 0a 20 at:keys self)).
0790: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
07a0: 64 61 20 28 6b 29 0a 09 20 20 20 20 20 20 28 70 da (k).. (p
07b0: 72 69 6e 74 70 72 6f 63 20 6b 20 22 20 3d 3e 20 rintproc k " =>
07c0: 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 73 " (formdat:get s
07d0: 65 6c 66 20 6b 29 29 29 0a 09 20 20 20 20 28 66 elf k))).. (f
07e0: 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c 66 ormdat:keys self
07f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6f )))..(define (fo
0800: 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 69 6e rmdat:all->strin
0810: 67 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 74 20 gs self). (let
0820: 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 ((res '())).
0830: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
0840: 61 20 28 6b 29 0a 20 20 20 20 20 20 20 20 20 20 a (k).
0850: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
0860: 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 6b 20 22 (cons (conc k "
0870: 3d 3e 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 =>" (formdat:get
0880: 20 73 65 6c 66 20 6b 29 29 20 72 65 73 29 29 29 self k)) res)))
0890: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
08a0: 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c formdat:keys sel
08b0: 66 29 29 0a 20 20 20 20 20 20 20 20 72 65 73 29 f)). res)
08c0: 29 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 68 20 )..;; call with
08d0: 2a 6f 6e 65 2a 20 6f 66 20 74 68 65 20 6c 69 73 *one* of the lis
08e0: 74 73 20 69 6e 20 74 68 65 20 6c 69 73 74 20 6f ts in the list o
08f0: 66 20 6c 69 73 74 73 20 63 72 65 61 74 65 64 20 f lists created
0900: 62 79 20 43 47 49 3a 75 72 6c 2d 75 6e 71 75 6f by CGI:url-unquo
0910: 74 65 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d te.(define (form
0920: 64 61 74 3a 6c 6f 61 64 20 73 65 6c 66 20 66 6f dat:load self fo
0930: 72 6d 6c 69 73 74 29 0a 20 20 28 6c 65 74 20 28 rmlist). (let (
0940: 28 68 74 20 20 20 20 20 20 20 20 20 20 20 20 20 (ht
0950: 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 (formdat:formdat
0960: 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 29 29 -get-data self))
0970: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
0980: 20 66 6f 72 6d 6c 69 73 74 29 20 73 65 6c 66 20 formlist) self
0990: 3b 3b 20 6e 6f 20 76 61 6c 75 65 73 20 70 72 6f ;; no values pro
09a0: 76 69 64 65 64 2c 20 72 65 74 75 72 6e 20 73 65 vided, return se
09b0: 6c 66 20 66 6f 72 20 6e 6f 20 67 6f 6f 64 20 72 lf for no good r
09c0: 65 61 73 6f 6e 0a 20 20 20 20 20 20 20 20 28 6c eason. (l
09d0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 20 28 et loop ((head (
09e0: 63 61 72 20 66 6f 72 6d 6c 69 73 74 29 29 0a 20 car formlist)).
09f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a00: 20 20 28 74 61 69 6c 20 28 63 64 72 20 66 6f 72 (tail (cdr for
0a10: 6d 6c 69 73 74 29 29 29 0a 20 20 20 20 20 20 20 mlist))).
0a20: 20 20 20 28 6c 65 74 20 28 28 6b 65 79 20 28 63 (let ((key (c
0a30: 61 72 20 68 65 61 64 29 29 0a 20 20 20 20 20 20 ar head)).
0a40: 20 20 20 20 20 20 20 20 20 20 28 76 61 6c 20 28 (val (
0a50: 63 64 72 20 68 65 61 64 29 29 29 0a 20 20 20 20 cdr head))).
0a60: 20 20 20 20 20 20 20 20 3b 3b 20 28 65 72 72 3a ;; (err:
0a70: 6c 6f 67 20 22 6b 65 79 3d 22 20 6b 65 79 20 22 log "key=" key "
0a80: 20 76 61 6c 3d 22 20 76 61 6c 29 0a 09 20 20 20 val=" val)..
0a90: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
0aa0: 76 61 6c 29 20 31 29 0a 09 09 28 66 6f 72 6d 64 val) 1)...(formd
0ab0: 61 74 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 79 at:set! self key
0ac0: 20 76 61 6c 29 0a 09 09 28 66 6f 72 6d 64 61 74 val)...(formdat
0ad0: 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 79 20 28 :set! self key (
0ae0: 63 61 72 20 76 61 6c 29 29 29 0a 20 20 20 20 20 car val))).
0af0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
0b00: 3f 20 74 61 69 6c 29 20 73 65 6c 66 20 20 20 3b ? tail) self ;
0b10: 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 ; we are done.
0b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
0b30: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 28 63 oop (car tail)(c
0b40: 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 29 0a dr tail)))))))).
0b50: 0a 3b 3b 20 67 65 74 20 74 68 65 20 68 65 61 64 .;; get the head
0b60: 65 72 20 66 72 6f 6d 20 64 61 74 73 74 72 0a 28 er from datstr.(
0b70: 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a define (formdat:
0b80: 72 65 61 64 2d 68 65 61 64 65 72 20 64 61 74 73 read-header dats
0b90: 74 72 29 20 3b 3b 20 64 61 74 73 74 72 20 69 73 tr) ;; datstr is
0ba0: 20 61 6e 20 69 6e 70 75 74 20 73 74 72 69 6e 67 an input string
0bb0: 20 70 6f 72 74 0a 20 20 28 6c 65 74 20 6c 6f 6f port. (let loo
0bc0: 70 20 28 28 68 73 20 28 72 65 61 64 2d 6c 69 6e p ((hs (read-lin
0bd0: 65 20 64 61 74 73 74 72 29 29 0a 09 20 20 20 20 e datstr))..
0be0: 20 28 68 65 61 64 65 72 20 27 28 29 29 29 0a 20 (header '())).
0bf0: 20 20 20 28 69 66 20 28 6f 72 20 28 65 6f 66 2d (if (or (eof-
0c00: 6f 62 6a 65 63 74 3f 20 68 73 29 0a 09 20 20 20 object? hs)..
0c10: 20 28 73 74 72 69 6e 67 3d 3f 20 68 73 20 22 22 (string=? hs ""
0c20: 29 29 0a 09 68 65 61 64 65 72 0a 09 28 6c 6f 6f ))..header..(loo
0c30: 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 64 61 74 p (read-line dat
0c40: 73 74 72 29 28 61 70 70 65 6e 64 20 68 65 61 64 str)(append head
0c50: 65 72 20 28 6c 69 73 74 20 68 73 29 29 29 29 29 er (list hs)))))
0c60: 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 64 61 )..;; get the da
0c70: 74 61 20 75 70 20 74 6f 20 74 68 65 20 6e 65 78 ta up to the nex
0c80: 74 20 6b 65 79 2e 20 69 66 20 74 68 65 72 65 20 t key. if there
0c90: 69 73 20 6e 6f 20 6b 65 79 20 74 68 65 6e 20 72 is no key then r
0ca0: 65 74 75 72 6e 20 23 66 0a 3b 3b 20 72 65 74 75 eturn #f.;; retu
0cb0: 72 6e 20 28 64 61 74 20 72 65 6d 64 61 74 29 0a rn (dat remdat).
0cc0: 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 (define (formdat
0cd0: 3a 72 65 61 64 2d 64 61 74 20 64 61 74 20 6b 65 :read-dat dat ke
0ce0: 79 29 0a 20 20 28 6c 65 74 20 28 28 69 6e 64 65 y). (let ((inde
0cf0: 78 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 x (string-search
0d00: 2d 70 6f 73 69 74 69 6f 6e 73 20 6b 65 79 20 64 -positions key d
0d10: 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f at))). (if (o
0d20: 72 20 28 6e 6f 74 20 69 6e 64 65 78 29 0a 09 20 r (not index)..
0d30: 20 20 20 28 6e 75 6c 6c 3f 20 69 6e 64 65 78 29 (null? index)
0d40: 29 20 3b 3b 20 74 68 65 20 6b 65 79 20 77 61 73 ) ;; the key was
0d50: 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 23 66 0a 09 not found..#f..
0d60: 28 6c 65 74 2a 20 28 28 64 61 74 73 74 72 20 28 (let* ((datstr (
0d70: 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e open-input-strin
0d80: 67 20 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 g dat))..
0d90: 28 72 65 73 75 6c 74 20 28 72 65 61 64 2d 73 74 (result (read-st
0da0: 72 69 6e 67 20 28 63 61 61 72 20 69 6e 64 65 78 ring (caar index
0db0: 29 20 64 61 74 73 74 72 29 29 0a 09 20 20 20 20 ) datstr))..
0dc0: 20 20 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 (remdat (read
0dd0: 2d 73 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 -string #f datst
0de0: 72 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 69 r))).. (close-i
0df0: 6e 70 75 74 2d 70 6f 72 74 20 64 61 74 73 74 72 nput-port datstr
0e00: 29 0a 09 20 20 28 6c 69 73 74 20 72 65 73 75 6c ).. (list resul
0e10: 74 20 72 65 6d 64 61 74 29 29 29 29 29 0a 0a 20 t remdat)))))..
0e20: 3b 3b 20 69 6e 70 20 69 73 20 70 6f 72 74 20 74 ;; inp is port t
0e30: 6f 20 72 65 61 64 20 64 61 74 61 20 66 72 6f 6d o read data from
0e40: 2c 20 6d 61 78 73 69 7a 65 20 69 73 20 6d 61 78 , maxsize is max
0e50: 20 64 61 74 61 20 61 6c 6c 6f 77 65 64 20 74 6f data allowed to
0e60: 20 72 65 61 64 20 28 74 6f 74 61 6c 29 0a 28 64 read (total).(d
0e70: 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 64 efine (formdat:d
0e80: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 6d 61 78 at->list inp max
0e90: 73 69 7a 65 20 23 21 6b 65 79 20 28 64 65 62 75 size #!key (debu
0ea0: 67 2d 70 6f 72 74 20 23 66 29 29 0a 20 20 3b 3b g-port #f)). ;;
0eb0: 20 72 65 61 64 20 31 4d 65 67 20 63 68 75 6e 6b read 1Meg chunk
0ec0: 73 20 66 72 6f 6d 20 74 68 65 20 69 6e 70 75 74 s from the input
0ed0: 20 70 6f 72 74 2e 20 49 66 20 61 20 62 6c 6f 63 port. If a bloc
0ee0: 6b 20 69 73 20 6e 6f 74 20 63 6f 6d 70 6c 65 74 k is not complet
0ef0: 65 0a 20 20 3b 3b 20 74 61 63 6b 20 6f 6e 20 74 e. ;; tack on t
0f00: 68 65 20 6e 65 78 74 20 31 4d 65 67 20 63 68 75 he next 1Meg chu
0f10: 6e 6b 20 61 73 20 6e 65 65 64 65 64 2e 20 53 65 nk as needed. Se
0f20: 74 20 75 70 20 73 6f 20 74 68 65 20 68 65 61 64 t up so the head
0f30: 65 72 20 69 73 20 61 6c 77 61 79 73 0a 20 20 3b er is always. ;
0f40: 3b 20 61 74 20 74 68 65 20 62 65 67 69 6e 6e 69 ; at the beginni
0f50: 6e 67 20 6f 66 20 74 68 65 20 63 68 75 6e 6b 0a ng of the chunk.
0f60: 20 20 3b 3b 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ;;------------
0f70: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0f80: 2d 32 39 39 33 32 30 32 34 34 31 31 35 30 32 33 -299320244115023
0f90: 32 33 33 33 32 31 33 36 32 31 34 39 37 33 0a 20 23332136214973.
0fa0: 20 3b 3b 43 6f 6e 74 65 6e 74 2d 44 69 73 70 6f ;;Content-Dispo
0fb0: 73 69 74 69 6f 6e 3a 20 66 6f 72 6d 2d 64 61 74 sition: form-dat
0fc0: 61 3b 20 6e 61 6d 65 3d 22 69 6e 70 75 74 2d 70 a; name="input-p
0fd0: 69 63 74 75 72 65 22 3b 20 66 69 6c 65 6e 61 6d icture"; filenam
0fe0: 65 3d 22 62 72 65 61 64 66 72 75 69 74 2e 6a 70 e="breadfruit.jp
0ff0: 67 22 0a 20 20 3b 3b 43 6f 6e 74 65 6e 74 2d 54 g". ;;Content-T
1000: 79 70 65 3a 20 69 6d 61 67 65 2f 6a 70 65 67 0a ype: image/jpeg.
1010: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 64 61 (let loop ((da
1020: 74 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 t (read-string 1
1030: 30 30 30 30 30 30 20 69 6e 70 29 29 0a 09 20 20 000000 inp))..
1040: 20 20 20 28 72 65 73 20 27 28 29 29 0a 09 20 20 (res '())..
1050: 20 20 20 28 73 69 7a 20 30 29 29 0a 20 20 20 20 (siz 0)).
1060: 28 69 66 20 64 65 62 75 67 2d 70 6f 72 74 20 28 (if debug-port (
1070: 66 6f 72 6d 61 74 20 64 65 62 75 67 2d 70 6f 72 format debug-por
1080: 74 20 22 64 61 74 3a 20 7e 41 5c 6e 22 20 64 61 t "dat: ~A\n" da
1090: 74 29 29 0a 20 20 20 20 28 69 66 20 64 65 62 75 t)). (if debu
10a0: 67 2d 70 6f 72 74 20 28 66 6f 72 6d 61 74 20 64 g-port (format d
10b0: 65 62 75 67 2d 70 6f 72 74 20 22 65 6f 66 3a 20 ebug-port "eof:
10c0: 7e 41 5c 6e 22 20 28 65 6f 66 2d 6f 62 6a 65 63 ~A\n" (eof-objec
10d0: 74 3f 20 28 72 65 61 64 20 69 6e 70 29 29 29 29 t? (read inp))))
10e0: 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 28 3e . . (if (>
10f0: 20 73 69 7a 20 6d 61 78 73 69 7a 65 29 0a 09 28 siz maxsize)..(
1100: 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 begin.. (print
1110: 22 44 41 54 41 20 54 4f 4f 20 42 49 47 22 29 0a "DATA TOO BIG").
1120: 09 20 20 72 65 73 29 0a 09 28 6c 65 74 2a 20 28 . res)..(let* (
1130: 28 64 61 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e (datstr (open-in
1140: 70 75 74 2d 73 74 72 69 6e 67 20 64 61 74 29 29 put-string dat))
1150: 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 72 .. (header
1160: 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 (formdat:read-h
1170: 65 61 64 65 72 20 64 61 74 73 74 72 29 29 0a 09 eader datstr))..
1180: 20 20 20 20 20 20 20 28 6b 65 79 20 20 20 20 28 (key (
1190: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 68 if (not (null? h
11a0: 65 61 64 65 72 29 29 28 63 61 72 20 68 65 61 64 eader))(car head
11b0: 65 72 29 20 23 66 29 29 0a 09 20 20 20 20 20 20 er) #f))..
11c0: 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 2d 73 (remdat (read-s
11d0: 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 72 29 tring #f datstr)
11e0: 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 75 73 ) ;; us
11f0: 65 64 20 69 6e 20 6e 65 78 74 20 6c 69 6e 65 2c ed in next line,
1200: 20 64 69 73 63 61 72 64 20 69 66 20 67 6f 74 20 discard if got
1210: 64 61 74 61 2c 20 65 6c 73 65 20 72 65 76 65 72 data, else rever
1220: 74 20 74 6f 0a 09 20 20 20 20 20 20 20 28 61 6c t to.. (al
1230: 6c 64 61 74 20 28 69 66 20 6b 65 79 20 28 66 6f ldat (if key (fo
1240: 72 6d 64 61 74 3a 72 65 61 64 2d 64 61 74 20 72 rmdat:read-dat r
1250: 65 6d 64 61 74 20 6b 65 79 29 20 23 66 29 29 20 emdat key) #f))
1260: 20 20 20 3b 3b 20 74 72 79 20 74 6f 20 65 78 74 ;; try to ext
1270: 72 61 63 74 20 74 68 65 20 64 61 74 61 0a 09 20 ract the data..
1280: 20 20 20 20 20 20 28 74 68 73 64 61 74 20 28 69 (thsdat (i
1290: 66 20 61 6c 6c 64 61 74 20 28 63 61 72 20 61 6c f alldat (car al
12a0: 6c 64 61 74 29 20 20 23 66 29 29 20 20 20 20 20 ldat) #f))
12b0: 3b 3b 20 74 68 65 20 64 61 74 61 0a 09 20 20 20 ;; the data..
12c0: 20 20 20 20 28 6e 65 77 64 61 74 20 28 69 66 20 (newdat (if
12d0: 61 6c 6c 64 61 74 20 28 63 61 64 72 20 61 6c 6c alldat (cadr all
12e0: 64 61 74 29 20 23 66 29 29 20 20 20 20 20 3b 3b dat) #f)) ;;
12f0: 20 6c 65 66 74 20 6f 76 65 72 20 64 61 74 61 2c left over data,
1300: 20 6d 75 73 74 20 70 72 6f 63 65 73 73 20 2e 2e must process ..
1310: 2e 0a 09 20 20 20 20 20 20 20 28 74 68 73 72 65 ... (thsre
1320: 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 20 74 s (list header t
1330: 68 73 64 61 74 29 29 20 20 20 20 20 20 20 20 20 hsdat))
1340: 20 20 20 20 3b 3b 20 73 70 65 63 75 6c 61 74 69 ;; speculati
1350: 76 65 6c 79 20 63 6f 6e 73 74 72 75 63 74 20 72 vely construct r
1360: 65 73 75 6c 74 73 0a 09 20 20 20 20 20 20 20 28 esults.. (
1370: 6e 65 77 72 65 73 20 28 61 70 70 65 6e 64 20 72 newres (append r
1380: 65 73 20 28 6c 69 73 74 20 74 68 73 72 65 73 29 es (list thsres)
1390: 29 29 29 20 20 20 20 20 20 3b 3b 20 73 70 65 63 ))) ;; spec
13a0: 75 6c 61 74 69 76 65 6c 79 20 63 6f 6e 73 74 72 ulatively constr
13b0: 75 63 74 20 72 65 73 75 6c 74 73 0a 09 20 20 28 uct results.. (
13c0: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
13d0: 20 64 61 74 73 74 72 29 0a 09 20 20 28 63 6f 6e datstr).. (con
13e0: 64 0a 09 20 20 20 3b 3b 20 65 69 74 68 65 72 20 d.. ;; either
13f0: 6e 6f 20 68 65 61 64 65 72 20 6f 72 20 73 69 6e no header or sin
1400: 67 6c 65 20 69 6e 70 75 74 0a 09 20 20 20 28 28 gle input.. ((
1410: 61 6e 64 20 28 6e 6f 74 20 61 6c 6c 64 61 74 29 and (not alldat)
1420: 0a 09 09 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 68 ... (or (null? h
1430: 65 61 64 65 72 29 0a 09 09 20 20 20 20 20 28 6e eader)... (n
1440: 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ot (string-match
1450: 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d 2d 70 formdat:delim-p
1460: 61 74 74 2d 72 65 78 20 28 63 61 72 20 68 65 61 att-rex (car hea
1470: 64 65 72 29 29 29 29 29 0a 09 20 20 20 20 3b 3b der))))).. ;;
1480: 20 28 70 72 69 6e 74 20 22 47 6f 74 20 68 65 72 (print "Got her
1490: 65 22 29 0a 09 20 20 20 20 28 63 6f 6e 73 20 28 e").. (cons (
14a0: 6c 69 73 74 20 68 65 61 64 65 72 20 22 22 29 20 list header "")
14b0: 72 65 73 29 29 20 3b 3b 20 6e 6f 74 65 20 75 73 res)) ;; note us
14c0: 65 20 68 65 61 64 65 72 20 61 73 20 64 61 74 20 e header as dat
14d0: 61 6e 64 20 75 73 65 20 22 22 20 61 73 20 68 65 and use "" as he
14e0: 61 64 65 72 3f 3f 3f 3f 0a 09 20 20 20 3b 3b 20 ader????.. ;;
14f0: 64 69 64 6e 27 74 20 66 69 6e 64 20 65 6e 64 20 didn't find end
1500: 6b 65 79 20 69 6e 20 74 68 69 73 20 62 6c 6f 63 key in this bloc
1510: 6b 0a 09 20 20 20 28 28 6e 6f 74 20 61 6c 6c 64 k.. ((not alld
1520: 61 74 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 at).. (let ((
1530: 6d 6f 72 64 61 74 20 28 72 65 61 64 2d 73 74 72 mordat (read-str
1540: 69 6e 67 20 31 30 30 30 30 30 30 20 69 6e 70 29 ing 1000000 inp)
1550: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 )).. (if (s
1560: 74 72 69 6e 67 3d 3f 20 6d 6f 72 64 61 74 20 22 tring=? mordat "
1570: 22 29 20 3b 3b 20 74 68 65 72 65 20 69 73 20 6e ") ;; there is n
1580: 6f 20 6d 6f 72 65 20 64 61 74 61 2c 20 64 69 73 o more data, dis
1590: 63 61 72 64 20 72 65 73 75 6c 74 73 20 61 6e 64 card results and
15a0: 20 75 73 65 20 72 65 6d 64 61 74 20 61 73 20 64 use remdat as d
15b0: 61 74 61 2c 20 74 68 69 73 20 69 6e 70 75 74 20 ata, this input
15c0: 69 73 20 62 72 6f 6b 65 6e 0a 09 09 20 20 28 63 is broken... (c
15d0: 6f 6e 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 ons (list header
15e0: 20 72 65 6d 64 61 74 29 20 72 65 73 29 0a 09 09 remdat) res)...
15f0: 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e 67 2d (loop (string-
1600: 61 70 70 65 6e 64 20 64 61 74 20 6d 6f 72 64 61 append dat morda
1610: 74 29 20 72 65 73 20 28 2b 20 73 69 7a 20 32 30 t) res (+ siz 20
1620: 30 30 30 30 30 29 29 29 29 29 20 3b 3b 20 61 64 00000))))) ;; ad
1630: 64 20 74 68 65 20 65 78 74 72 61 20 31 30 30 30 d the extra 1000
1640: 30 30 30 0a 09 20 20 20 28 61 6c 6c 64 61 74 20 000.. (alldat
1650: 3b 3b 20 67 6f 74 20 64 61 74 61 2c 20 64 6f 6e ;; got data, don
1660: 27 74 20 61 74 74 65 6d 70 74 20 74 6f 20 63 68 't attempt to ch
1670: 65 63 6b 20 69 66 20 74 68 65 72 65 20 69 73 20 eck if there is
1680: 6d 6f 72 65 2c 20 6a 75 73 74 20 6c 6f 6f 70 20 more, just loop
1690: 61 6e 64 20 72 65 6c 79 20 6f 6e 20 28 6e 6f 74 and rely on (not
16a0: 20 61 6c 6c 64 61 74 29 20 74 6f 20 67 65 74 20 alldat) to get
16b0: 6d 6f 72 65 20 64 61 74 61 0a 09 20 20 20 20 28 more data.. (
16c0: 6c 6f 6f 70 20 6e 65 77 64 61 74 20 6e 65 77 72 loop newdat newr
16d0: 65 73 20 28 2b 20 73 69 7a 20 31 30 30 30 30 30 es (+ siz 100000
16e0: 30 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 0))))))))..(defi
16f0: 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 ne formdat:bin-d
1700: 61 74 61 2d 64 69 73 70 2d 72 65 78 20 28 72 65 ata-disp-rex (re
1710: 67 65 78 70 20 22 5e 43 6f 6e 74 65 6e 74 2d 44 gexp "^Content-D
1720: 69 73 70 6f 73 69 74 69 6f 6e 3a 5c 5c 73 2b 66 isposition:\\s+f
1730: 6f 72 6d 2d 64 61 74 61 3b 22 29 29 0a 28 64 65 orm-data;")).(de
1740: 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e fine formdat:bin
1750: 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 28 -data-name-rex (
1760: 72 65 67 65 78 70 20 22 5c 5c 57 6e 61 6d 65 3d regexp "\\Wname=
1770: 5c 22 28 5b 5e 5c 22 5d 2b 29 5c 22 22 29 29 0a \"([^\"]+)\"")).
1780: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
1790: 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d 72 65 bin-file-name-re
17a0: 78 20 28 72 65 67 65 78 70 20 22 5c 5c 57 66 69 x (regexp "\\Wfi
17b0: 6c 65 6e 61 6d 65 3d 5c 22 28 5b 5e 5c 22 5d 2b lename=\"([^\"]+
17c0: 29 5c 22 22 29 29 0a 28 64 65 66 69 6e 65 20 66 )\"")).(define f
17d0: 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c 65 2d ormdat:bin-file-
17e0: 74 79 70 65 2d 72 65 78 20 28 72 65 67 65 78 70 type-rex (regexp
17f0: 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a 5c "Content-Type:\
1800: 5c 73 2b 28 5b 5e 5c 5c 73 5d 2b 29 22 29 29 0a \s+([^\\s]+)")).
1810: 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a (define formdat:
1820: 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 20 delim-patt-rex
1830: 20 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 2d 2b (regexp "^\\-+
1840: 5b 30 2d 39 5d 2b 5c 5c 2d 2a 24 22 29 29 0a 0a [0-9]+\\-*$"))..
1850: 3b 3b 20 72 65 74 75 72 6e 73 20 61 20 68 61 73 ;; returns a has
1860: 68 20 77 69 74 68 20 65 6e 74 72 69 65 73 20 66 h with entries f
1870: 6f 72 20 61 6c 6c 20 66 6f 72 6d 73 20 2d 20 63 or all forms - c
1880: 6f 75 6c 64 20 77 65 6c 6c 20 75 73 65 20 61 20 ould well use a
1890: 70 72 6f 70 6c 69 73 74 3f 0a 28 64 65 66 69 6e proplist?.(defin
18a0: 65 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d e (formdat:load-
18b0: 61 6c 6c 29 0a 20 20 28 6c 65 74 20 28 28 72 65 all). (let ((re
18c0: 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 28 67 65 quest-method (ge
18d0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
18e0: 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 54 5f riable "REQUEST_
18f0: 4d 45 54 48 4f 44 22 29 29 29 0a 20 20 20 20 28 METHOD"))). (
1900: 69 66 20 28 61 6e 64 20 72 65 71 75 65 73 74 2d if (and request-
1910: 6d 65 74 68 6f 64 0a 09 20 20 20 20 20 28 73 74 method.. (st
1920: 72 69 6e 67 3d 3f 20 72 65 71 75 65 73 74 2d 6d ring=? request-m
1930: 65 74 68 6f 64 20 22 50 4f 53 54 22 29 29 0a 09 ethod "POST"))..
1940: 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c (formdat:load-al
1950: 6c 2d 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d l-port (current-
1960: 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 29 29 0a input-port))))).
1970: 0a 3b 3b 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 .;; (s:process-c
1980: 67 69 2d 69 6e 70 75 74 20 28 63 61 61 61 72 20 gi-input (caaar
1990: 64 61 74 29 29 0a 28 64 65 66 69 6e 65 20 28 66 dat)).(define (f
19a0: 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 2d ormdat:load-all-
19b0: 70 6f 72 74 20 69 6e 70 29 0a 20 20 28 6c 65 74 port inp). (let
19c0: 2a 20 28 28 66 6f 72 6d 64 61 74 20 20 20 20 20 * ((formdat
19d0: 20 20 20 28 6d 61 6b 65 2d 66 6f 72 6d 64 61 74 (make-formdat
19e0: 3a 66 6f 72 6d 64 61 74 29 29 0a 09 20 28 64 65 :formdat)).. (de
19f0: 62 75 67 70 20 20 20 20 20 20 20 20 20 23 66 29 bugp #f)
1a00: 29 0a 09 09 09 20 3b 3b 20 28 6f 70 65 6e 2d 6f ).... ;; (open-o
1a10: 75 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 utput-file (conc
1a20: 20 22 2f 74 6d 70 2f 64 65 6c 6d 65 2d 22 20 28 "/tmp/delme-" (
1a30: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
1a40: 20 22 2e 6c 6f 67 22 29 29 29 29 0a 20 20 20 20 ".log")))).
1a50: 3b 3b 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 ;; (write-string
1a60: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 (read-string #f
1a70: 20 69 6e 70 29 20 23 66 20 64 65 62 75 67 70 29 inp) #f debugp)
1a80: 20 20 3b 3b 20 64 65 73 74 72 6f 79 73 20 61 6c ;; destroys al
1a90: 6c 20 64 61 74 61 21 0a 20 20 20 20 28 66 6f 72 l data!. (for
1aa0: 6d 64 61 74 3a 69 6e 69 74 69 61 6c 69 7a 65 20 mdat:initialize
1ab0: 66 6f 72 6d 64 61 74 29 0a 20 20 20 20 28 6c 65 formdat). (le
1ac0: 74 20 28 28 61 6c 6c 64 61 74 73 20 28 66 6f 72 t ((alldats (for
1ad0: 6d 64 61 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 mdat:dat->list i
1ae0: 6e 70 20 31 30 65 36 20 64 65 62 75 67 2d 70 6f np 10e6 debug-po
1af0: 72 74 3a 20 64 65 62 75 67 70 29 29 29 0a 20 20 rt: debugp))).
1b00: 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 64 . (if d
1b10: 65 62 75 67 70 20 28 66 6f 72 6d 61 74 20 64 65 ebugp (format de
1b20: 62 75 67 70 20 22 66 6f 72 6d 64 61 74 20 3a 20 bugp "formdat :
1b30: 61 6c 6c 64 61 74 73 3a 20 7e 41 5c 6e 22 20 61 alldats: ~A\n" a
1b40: 6c 6c 64 61 74 73 29 29 0a 0a 20 20 20 20 20 20 lldats))..
1b50: 28 6c 65 74 20 28 28 66 69 72 73 74 69 74 65 6d (let ((firstitem
1b60: 20 20 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 (car alldats)
1b70: 29 0a 09 20 20 20 20 28 6d 75 6c 74 69 70 61 73 ).. (multipas
1b80: 73 20 23 66 29 29 20 0a 09 28 69 66 20 28 61 6e s #f)) ..(if (an
1b90: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 69 d (not (null? fi
1ba0: 72 73 74 69 74 65 6d 29 29 0a 09 09 20 28 6e 6f rstitem))... (no
1bb0: 74 20 28 6e 75 6c 6c 3f 20 28 63 61 72 20 66 69 t (null? (car fi
1bc0: 72 73 74 69 74 65 6d 29 29 29 29 0a 09 20 20 20 rstitem))))..
1bd0: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
1be0: 63 68 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d ch formdat:delim
1bf0: 2d 70 61 74 74 2d 72 65 78 20 28 63 61 61 72 20 -patt-rex (caar
1c00: 66 69 72 73 74 69 74 65 6d 29 29 0a 09 09 28 73 firstitem))...(s
1c10: 65 74 21 20 6d 75 6c 74 69 70 61 73 73 20 23 74 et! multipass #t
1c20: 29 29 29 0a 09 28 69 66 20 6d 75 6c 74 69 70 61 )))..(if multipa
1c30: 73 73 0a 09 20 20 20 20 3b 3b 20 68 61 6e 64 6c ss.. ;; handl
1c40: 65 20 6d 75 6c 74 69 2d 70 61 72 74 20 66 6f 72 e multi-part for
1c50: 6d 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 m.. (for-each
1c60: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 6c 73 74 (lambda (datlst
1c70: 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 68 65 61 )....(let* ((hea
1c80: 64 65 72 20 28 66 6f 72 6d 64 61 74 3a 65 78 74 der (formdat:ext
1c90: 72 61 63 74 2d 68 65 61 64 65 72 2d 69 6e 66 6f ract-header-info
1ca0: 20 28 63 61 72 20 64 61 74 6c 73 74 29 29 29 0a (car datlst))).
1cb0: 09 09 09 20 20 20 20 20 20 20 28 6e 61 6d 65 20 ... (name
1cc0: 20 20 28 69 66 20 28 61 73 73 6f 63 20 27 6e 61 (if (assoc 'na
1cd0: 6d 65 20 68 65 61 64 65 72 29 0a 09 09 09 09 09 me header)......
1ce0: 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 (string->symb
1cf0: 6f 6c 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 ol (cadr (assoc
1d00: 27 6e 61 6d 65 20 68 65 61 64 65 72 29 29 29 0a 'name header))).
1d10: 09 09 09 09 09 20 20 20 22 22 29 29 20 3b 3b 20 ..... "")) ;;
1d20: 67 72 75 6d 62 6c 65 0a 09 09 09 20 20 20 20 20 grumble....
1d30: 20 20 28 66 6e 61 6d 65 6c 20 20 28 61 73 73 6f (fnamel (asso
1d40: 63 20 27 66 69 6c 65 6e 61 6d 65 20 68 65 61 64 c 'filename head
1d50: 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 er)).... (
1d60: 63 6f 6e 74 65 6e 74 20 28 61 73 73 6f 63 20 27 content (assoc '
1d70: 63 6f 6e 74 65 6e 74 20 68 65 61 64 65 72 29 29 content header))
1d80: 0a 09 09 09 20 20 20 20 20 20 20 28 64 61 74 20 .... (dat
1d90: 20 20 20 28 63 61 64 72 20 64 61 74 6c 73 74 29 (cadr datlst)
1da0: 29 29 0a 09 09 09 20 20 3b 3b 20 28 70 72 69 6e )).... ;; (prin
1db0: 74 20 22 68 65 61 64 65 72 3a 20 22 20 68 65 61 t "header: " hea
1dc0: 64 65 72 20 22 20 6e 61 6d 65 3a 20 22 20 6e 61 der " name: " na
1dd0: 6d 65 20 22 20 66 6e 61 6d 65 6c 3a 20 22 20 66 me " fnamel: " f
1de0: 6e 61 6d 65 6c 20 22 20 63 6f 6e 74 65 6e 74 3a namel " content:
1df0: 20 22 20 63 6f 6e 74 65 6e 74 29 20 3b 3b 20 20 " content) ;;
1e00: 22 20 64 61 74 3a 20 22 20 28 64 61 74 29 0a 09 " dat: " (dat)..
1e10: 09 09 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 .. (formdat:set
1e20: 21 20 66 6f 72 6d 64 61 74 20 0a 09 09 09 09 09 ! formdat ......
1e30: 6e 61 6d 65 0a 09 09 09 09 09 28 69 66 20 66 6e name......(if fn
1e40: 61 6d 65 6c 20 0a 09 09 09 09 09 20 20 20 20 28 amel ...... (
1e50: 6c 69 73 74 20 28 63 61 64 72 20 66 6e 61 6d 65 list (cadr fname
1e60: 6c 29 0a 09 09 09 09 09 09 20 20 28 69 66 20 63 l)....... (if c
1e70: 6f 6e 74 65 6e 74 0a 09 09 09 09 09 09 20 20 20 ontent.......
1e80: 20 20 20 28 63 61 64 72 20 63 6f 6e 74 65 6e 74 (cadr content
1e90: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 22 75 )....... "u
1ea0: 6e 6b 6e 6f 77 6e 22 29 0a 09 09 09 09 09 09 20 nknown").......
1eb0: 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f 62 20 64 (string->blob d
1ec0: 61 74 29 29 0a 09 09 09 09 09 20 20 20 20 64 61 at))...... da
1ed0: 74 29 29 29 29 0a 09 09 20 20 20 20 20 20 61 6c t))))... al
1ee0: 6c 64 61 74 73 29 0a 09 20 20 20 20 3b 3b 20 68 ldats).. ;; h
1ef0: 61 6e 64 6c 65 20 73 69 6e 67 6c 65 20 70 61 72 andle single par
1f00: 74 20 66 6f 72 6d 0a 09 20 20 20 20 3b 3b 20 09 t form.. ;; .
1f10: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
1f20: 3f 20 6e 61 6d 65 29 0a 09 20 20 20 20 3b 3b 20 ? name).. ;;
1f30: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 3d 3f .. (string=?
1f40: 20 6e 61 6d 65 20 22 22 29 29 20 3b 3b 20 74 68 name "")) ;; th
1f50: 69 73 20 69 73 20 74 68 65 20 73 68 6f 72 74 20 is is the short
1f60: 66 6f 72 6d 20 69 6e 70 75 74 20 49 20 67 75 65 form input I gue
1f70: 73 73 0a 09 20 20 20 20 3b 3b 20 09 09 28 6c 65 ss.. ;; ..(le
1f80: 74 2a 20 28 28 64 61 74 73 74 72 20 28 63 61 61 t* ((datstr (caa
1f90: 72 20 64 61 74 6c 73 74 29 29 0a 09 20 20 20 20 r datlst))..
1fa0: 3b 3b 20 09 09 20 20 20 20 20 20 20 28 6d 75 6e ;; .. (mun
1fb0: 67 65 64 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 ged (s:process-c
1fc0: 67 69 2d 69 6e 70 75 74 20 64 61 74 73 74 72 29 gi-input datstr)
1fd0: 29 29 0a 09 20 20 20 20 3b 3b 20 09 09 20 20 28 )).. ;; .. (
1fe0: 70 72 69 6e 74 20 22 64 61 74 73 74 72 3a 20 22 print "datstr: "
1ff0: 20 64 61 74 73 74 72 20 22 20 6d 75 6e 67 65 64 datstr " munged
2000: 3a 20 22 20 6d 75 6e 67 65 64 29 0a 09 20 20 20 : " munged)..
2010: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
2020: 6e 75 6c 6c 3f 20 61 6c 6c 64 61 74 73 29 29 0a null? alldats)).
2030: 09 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c .. (not (nul
2040: 6c 3f 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 l? (car alldats)
2050: 29 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 28 ))... (not (
2060: 6e 75 6c 6c 3f 20 28 63 61 61 72 20 61 6c 6c 64 null? (caar alld
2070: 61 74 73 29 29 29 29 0a 09 09 28 66 6f 72 6d 64 ats))))...(formd
2080: 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 at:load formdat
2090: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
20a0: 69 6e 70 75 74 20 28 63 61 61 61 72 20 61 6c 6c input (caaar all
20b0: 64 61 74 73 29 29 29 29 29 20 3b 3b 20 6d 75 6e dats))))) ;; mun
20c0: 67 65 64 29 29 0a 09 3b 3b 09 09 20 20 20 20 28 ged))..;;.. (
20d0: 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 66 format debugp "f
20e0: 6f 72 6d 64 61 74 20 3a 20 6e 61 6d 65 3a 20 7e ormdat : name: ~
20f0: 41 20 63 6f 6e 74 65 6e 74 3a 20 7e 41 5c 6e 22 A content: ~A\n"
2100: 20 6e 61 6d 65 20 63 6f 6e 74 65 6e 74 29 0a 09 name content)..
2110: 28 69 66 20 64 65 62 75 67 70 20 28 63 6c 6f 73 (if debugp (clos
2120: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 64 65 e-output-port de
2130: 62 75 67 70 29 29 0a 09 66 6f 72 6d 64 61 74 29 bugp))..formdat)
2140: 29 29 29 0a 09 09 0a 23 7c 0a 28 64 65 66 69 6e )))....#|.(defin
2150: 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 e inp (open-inpu
2160: 74 2d 66 69 6c 65 20 22 74 65 73 74 73 2f 65 78 t-file "tests/ex
2170: 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 6e 22 29 29 ample.post.in"))
2180: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
2190: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
21a0: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 73 74 )).(define datst
21b0: 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 r (open-input-st
21c0: 72 69 6e 67 20 64 61 74 29 29 0a 0a 3b 3b 20 6f ring dat))..;; o
21d0: 72 0a 0a 28 64 65 66 69 6e 65 20 69 6e 70 20 28 r..(define inp (
21e0: 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 20 open-input-file
21f0: 22 74 65 73 74 73 2f 65 78 61 6d 70 6c 65 2e 70 "tests/example.p
2200: 6f 73 74 2e 62 69 6e 61 72 79 2e 69 6e 22 29 29 ost.binary.in"))
2210: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
2220: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
2230: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 73 74 )).(define datst
2240: 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 r (open-input-st
2250: 72 69 6e 67 20 64 61 74 29 29 0a 0a 28 66 6f 72 ring dat))..(for
2260: 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 64 65 72 mdat:read-header
2270: 20 64 61 74 73 74 72 29 0a 0a 28 64 65 66 69 6e datstr)..(defin
2280: 65 20 64 61 74 20 28 66 6f 72 6d 64 61 74 3a 64 e dat (formdat:d
2290: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 30 65 at->list inp 10e
22a0: 36 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 74 6)).(close-input
22b0: 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a 20 20 -port inp).|#.
22c0: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
22d0: 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 65 72 t:extract-header
22e0: 2d 69 6e 66 6f 20 68 65 61 64 65 72 29 0a 20 20 -info header).
22f0: 28 69 66 20 28 6e 75 6c 6c 3f 20 68 65 61 64 65 (if (null? heade
2300: 72 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 r). '().
2310: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
2320: 65 64 20 28 63 61 72 20 68 65 61 64 65 72 29 29 ed (car header))
2330: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 68 65 ... (tal (cdr he
2340: 61 64 65 72 29 29 0a 09 09 20 28 72 65 73 20 27 ader))... (res '
2350: 28 29 29 29 0a 09 28 69 66 20 28 73 74 72 69 6e ()))..(if (strin
2360: 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a g-match formdat:
2370: 62 69 6e 2d 64 61 74 61 2d 64 69 73 70 2d 72 65 bin-data-disp-re
2380: 78 20 68 65 64 29 20 3b 3b 20 0a 09 20 20 20 20 x hed) ;; ..
2390: 28 6c 65 74 2a 20 28 28 64 61 74 61 2d 6e 61 6d (let* ((data-nam
23a0: 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 em (string-match
23b0: 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 61 74 formdat:bin-dat
23c0: 61 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 29 a-name-rex hed))
23d0: 0a 09 09 20 20 20 28 66 69 6c 65 2d 6e 61 6d 65 ... (file-name
23e0: 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 m (string-match
23f0: 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c 65 formdat:bin-file
2400: 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 29 0a -name-rex hed)).
2410: 09 09 20 20 20 28 64 61 74 61 2d 6e 61 6d 65 20 .. (data-name
2420: 20 28 69 66 20 64 61 74 61 2d 6e 61 6d 65 6d 20 (if data-namem
2430: 28 63 61 64 72 20 64 61 74 61 2d 6e 61 6d 65 6d (cadr data-namem
2440: 29 20 23 66 29 29 0a 09 09 20 20 20 28 74 68 69 ) #f))... (thi
2450: 73 20 20 20 20 20 20 20 28 69 66 20 66 69 6c 65 s (if file
2460: 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 20 20 28 6c -namem..... (l
2470: 69 73 74 20 28 6c 69 73 74 20 27 6e 61 6d 65 20 ist (list 'name
2480: 64 61 74 61 2d 6e 61 6d 65 29 28 6c 69 73 74 20 data-name)(list
2490: 27 66 69 6c 65 6e 61 6d 65 20 28 63 61 64 72 20 'filename (cadr
24a0: 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 29 0a 09 09 file-namem)))...
24b0: 09 09 20 20 20 28 6c 69 73 74 20 28 6c 69 73 74 .. (list (list
24c0: 20 27 6e 61 6d 65 20 64 61 74 61 2d 6e 61 6d 65 'name data-name
24d0: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 ))))).. (if
24e0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
24f0: 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 (append res thi
2500: 73 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 s)... (loop (ca
2510: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
2520: 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 73 29 append res this)
2530: 29 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 ))).. (let ((
2540: 63 6f 6e 74 65 6e 74 20 28 73 74 72 69 6e 67 2d content (string-
2550: 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 match formdat:bi
2560: 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 n-file-type-rex
2570: 68 65 64 29 29 29 20 3b 3b 20 74 68 69 73 20 69 hed))) ;; this i
2580: 73 20 74 68 65 20 73 74 61 6e 7a 61 20 66 6f 72 s the stanza for
2590: 20 74 68 65 20 63 6f 6e 74 65 6e 74 20 74 79 70 the content typ
25a0: 65 0a 09 20 20 20 20 20 20 28 69 66 20 63 6f 6e e.. (if con
25b0: 74 65 6e 74 0a 09 09 20 20 28 6c 65 74 20 28 28 tent... (let ((
25c0: 6e 65 77 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 newres (cons (li
25d0: 73 74 20 27 63 6f 6e 74 65 6e 74 20 28 63 61 64 st 'content (cad
25e0: 72 20 63 6f 6e 74 65 6e 74 29 29 20 72 65 73 29 r content)) res)
25f0: 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 ))... (if (nu
2600: 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 6e 65 77 72 ll? tal)....newr
2610: 65 73 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 es....(loop (car
2620: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e tal)(cdr tal) n
2630: 65 77 72 65 73 29 29 29 0a 09 09 20 20 28 69 66 ewres)))... (if
2640: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
2650: 20 20 20 20 20 72 65 73 0a 09 09 20 20 20 20 20 res...
2660: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
2670: 28 63 64 72 20 74 61 6c 29 20 72 65 73 29 0a 09 (cdr tal) res)..
2680: 09 20 20 20 20 20 20 29 29 29 29 29 29 29 0a 0a . )))))))..
2690: 3b 3b 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ;;. (let lo
26a0: 6f 70 20 28 28 6c 20 20 20 20 20 20 20 28 72 65 op ((l (re
26b0: 61 64 2d 6c 69 6e 65 29 29 20 3b 3b 20 28 69 66 ad-line)) ;; (if
26c0: 20 28 65 71 3f 20 6d 6f 64 65 20 27 6e 6f 72 6d (eq? mode 'norm
26d0: 29 28 72 65 61 64 2d 6c 69 6e 65 29 28 72 65 61 )(read-line)(rea
26e0: 64 2d 63 68 61 72 29 29 29 0a 3b 3b 09 09 09 20 d-char))).;;...
26f0: 28 65 6e 64 6c 69 6e 65 20 23 66 29 0a 3b 3b 09 (endline #f).;;.
2700: 09 09 20 28 6e 75 6d 20 20 20 20 20 30 29 29 0a .. (num 0)).
2710: 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 61 74 20 64 ;;..;; (format d
2720: 65 62 75 67 70 20 22 7e 41 5c 6e 22 20 6c 29 0a ebugp "~A\n" l).
2730: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2740: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 65 6f (if (or (not (eo
2750: 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 29 0a 3b 3b f-object? l)).;;
2760: 09 09 20 20 20 20 20 20 28 6e 6f 74 20 28 61 6e .. (not (an
2770: 64 20 28 65 71 3f 20 6d 6f 64 65 20 27 62 69 6e d (eq? mode 'bin
2780: 29 0a 3b 3b 09 09 09 09 28 73 74 72 69 6e 67 3d ).;;....(string=
2790: 3f 20 6c 20 22 22 29 29 29 29 20 3b 3b 20 69 66 ? l "")))) ;; if
27a0: 20 69 6e 20 62 69 6e 20 6d 6f 64 65 20 65 6d 70 in bin mode emp
27b0: 74 79 20 73 74 72 69 6e 67 20 69 73 20 65 6e 64 ty string is end
27c0: 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 09 20 20 28 of file.;;.. (
27d0: 63 61 73 65 20 6d 6f 64 65 0a 3b 3b 09 09 20 20 case mode.;;..
27e0: 20 20 28 28 73 74 61 72 74 29 0a 3b 3b 09 09 20 ((start).;;..
27f0: 20 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 (set! mode '
2800: 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 28 norm).;;.. (
2810: 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 if (string-match
2820: 20 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 delim-patt-rex
2830: 6c 29 0a 3b 3b 09 09 09 20 28 62 65 67 69 6e 0a l).;;... (begin.
2840: 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 64 65 ;;... (set! de
2850: 6c 69 6d 2d 73 74 72 69 6e 67 20 6c 29 0a 3b 3b lim-string l).;;
2860: 09 09 09 20 20 20 28 73 65 74 21 20 64 65 6c 69 ... (set! deli
2870: 6d 2d 6c 65 6e 20 20 20 20 28 73 74 72 69 6e 67 m-len (string
2880: 2d 6c 65 6e 67 74 68 20 6c 29 29 0a 3b 3b 09 09 -length l)).;;..
2890: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
28a0: 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b 3b 09 line) #f 0)).;;.
28b0: 09 09 20 28 6c 6f 6f 70 20 6c 20 23 66 20 30 29 .. (loop l #f 0)
28c0: 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 6e 6f 72 )).;;.. ((nor
28d0: 6d 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 49 m).;;.. ;; I
28e0: 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 6f 77 20 don't like how
28f0: 74 68 69 73 20 67 65 74 73 20 63 68 65 63 6b 65 this gets checke
2900: 64 20 6f 6e 20 65 76 65 72 79 20 73 69 6e 67 6c d on every singl
2910: 65 20 69 6e 70 75 74 2e 20 4d 75 73 74 20 62 65 e input. Must be
2920: 20 61 20 62 65 74 74 65 72 20 77 61 79 2e 20 46 a better way. F
2930: 49 58 4d 45 0a 3b 3b 09 09 20 20 20 20 20 28 69 IXME.;;.. (i
2940: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d f (and (string-m
2950: 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 64 69 atch bin-data-di
2960: 73 70 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 sp-rex l).;;...
2970: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
2980: 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 ch bin-data-name
2990: 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 20 20 -rex l).;;...
29a0: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
29b0: 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d 72 bin-file-name-r
29c0: 65 78 20 6c 29 29 0a 3b 3b 09 09 09 20 28 62 65 ex l)).;;... (be
29d0: 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 gin.;;... (set
29e0: 21 20 64 61 74 61 2d 6e 61 6d 65 20 28 63 61 64 ! data-name (cad
29f0: 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 r (string-match
2a00: 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 bin-data-name-re
2a10: 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 20 28 x l))).;;... (
2a20: 73 65 74 21 20 66 69 6c 65 2d 6e 61 6d 65 20 28 set! file-name (
2a30: 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 cadr (string-mat
2a40: 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 ch bin-file-name
2a50: 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 -rex l))).;;...
2a60: 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 63 6f (set! mode 'co
2a70: 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 20 20 20 28 ntent).;;... (
2a80: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
2a90: 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 09 20 #f num))).;;..
2aa0: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 20 (let* ((dat
2ab0: 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d (s:process-cgi-
2ac0: 69 6e 70 75 74 20 6c 29 29 29 20 3b 3b 20 28 43 input l))) ;; (C
2ad0: 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 65 20 6c GI:url-unquote l
2ae0: 29 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 66 )).;;.. (f
2af0: 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 50 52 ormat debugp "PR
2b00: 4f 43 45 53 53 2d 43 47 49 2d 49 4e 50 55 54 3a OCESS-CGI-INPUT:
2b10: 20 7e 41 5c 6e 22 20 28 69 6e 74 65 72 73 70 65 ~A\n" (interspe
2b20: 72 73 65 20 64 61 74 20 22 2c 22 29 29 0a 3b 3b rse dat ",")).;;
2b30: 09 09 20 20 20 20 20 20 20 28 66 6f 72 6d 64 61 .. (formda
2b40: 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 64 t:load formdat d
2b50: 61 74 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 at).;;.. (
2b60: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
2b70: 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 09 20 #f num))).;;..
2b80: 20 20 20 28 28 63 6f 6e 74 65 6e 74 29 0a 3b 3b ((content).;;
2b90: 09 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 .. (if (stri
2ba0: 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d 66 69 6c ng-match bin-fil
2bb0: 65 2d 74 79 70 65 2d 72 65 78 20 6c 29 0a 3b 3b e-type-rex l).;;
2bc0: 09 09 09 20 28 62 65 67 69 6e 20 0a 3b 3b 09 09 ... (begin .;;..
2bd0: 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 . (set! mode '
2be0: 62 69 6e 29 0a 3b 3b 09 09 09 20 20 20 28 73 65 bin).;;... (se
2bf0: 74 21 20 64 61 74 61 2d 74 79 70 65 20 28 63 61 t! data-type (ca
2c00: 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 dr (string-match
2c10: 20 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 bin-file-type-r
2c20: 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 20 ex l))).;;...
2c30: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 73 74 72 69 (loop (read-stri
2c40: 6e 67 20 31 29 20 23 66 20 6e 75 6d 29 29 29 29 ng 1) #f num))))
2c50: 0a 3b 3b 09 09 20 20 20 20 28 28 62 69 6e 29 0a .;;.. ((bin).
2c60: 3b 3b 09 09 20 20 20 20 20 3b 3b 20 64 65 6c 69 ;;.. ;; deli
2c70: 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e 22 2d 2d 2d m-string: \n"---
2c80: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 33 34 ------------1234
2c90: 35 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 20 5".;;.. ;;
2ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cb0: 30 31 32 33 34 35 36 37 38 39 30 31 32 33 34 35 0123456789012345
2cc0: 36 37 38 39 30 0a 3b 3b 09 09 20 20 20 20 20 3b 67890.;;.. ;
2cd0: 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 20 20 20 20 ; endline:
2ce0: 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "-------------
2cf0: 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 20 20 20 3b --12".;;.. ;
2d00: 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b 09 09 20 20 ; l = "3".;;..
2d10: 20 20 20 3b 3b 20 64 65 6c 69 6d 2d 6c 65 6e 20 ;; delim-len
2d20: 3d 20 32 30 0a 3b 3b 09 09 20 20 20 20 20 3b 3b = 20.;;.. ;;
2d30: 20 28 73 75 62 73 74 72 69 6e 67 20 20 22 2d 2d (substring "--
2d40: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 33 -------------123
2d50: 34 35 22 20 31 37 20 31 38 29 20 3d 3e 20 22 33 45" 17 18) => "3
2d60: 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 0a 3b 3b ".;;.. ;;.;;
2d70: 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 09 .. (cond.;;.
2d80: 09 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 6e . ;; haven
2d90: 27 74 20 66 6f 75 6e 64 20 74 68 65 20 73 74 61 't found the sta
2da0: 72 74 20 6f 66 20 61 6e 20 65 6e 64 6c 69 6e 65 rt of an endline
2db0: 2c 20 69 73 20 74 68 65 20 6e 65 78 74 20 63 68 , is the next ch
2dc0: 61 72 20 61 20 6e 65 77 6c 69 6e 65 3f 0a 3b 3b ar a newline?.;;
2dd0: 09 09 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e .. ((and (n
2de0: 6f 74 20 65 6e 64 6c 69 6e 65 29 0a 3b 3b 09 09 ot endline).;;..
2df0: 09 20 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 6c . (string=? l
2e00: 20 22 5c 6e 22 29 29 20 3b 3b 20 72 65 71 75 69 "\n")) ;; requi
2e10: 72 65 64 20 66 69 72 73 74 20 63 68 61 72 61 63 red first charac
2e20: 74 65 72 20 0a 3b 3b 09 09 20 20 20 20 20 20 20 ter .;;..
2e30: 28 6c 65 74 20 28 28 6e 65 77 65 6e 64 6c 69 6e (let ((newendlin
2e40: 65 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 e (open-output-s
2e50: 74 72 69 6e 67 29 29 29 0a 3b 3b 09 09 09 20 3b tring))).;;... ;
2e60: 3b 20 28 77 72 69 74 65 2d 6c 69 6e 65 20 6c 20 ; (write-line l
2e70: 6e 65 77 65 6e 64 6c 69 6e 65 29 20 3b 3b 20 64 newendline) ;; d
2e80: 69 73 63 61 72 64 20 74 68 65 20 6e 65 77 6c 69 iscard the newli
2e90: 6e 65 2e 20 61 64 64 20 69 74 20 62 61 63 6b 20 ne. add it back
2ea0: 69 66 20 64 6f 6e 27 74 20 68 61 76 65 20 61 20 if don't have a
2eb0: 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 6d 2d 73 74 lock on delim-st
2ec0: 72 69 6e 67 0a 3b 3b 09 09 09 20 28 6c 6f 6f 70 ring.;;... (loop
2ed0: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 (read-string 1)
2ee0: 20 6e 65 77 65 6e 64 6c 69 6e 65 20 28 2b 20 6e newendline (+ n
2ef0: 75 6d 20 31 29 29 29 29 0a 3b 3b 09 09 20 20 20 um 1)))).;;..
2f00: 20 20 20 28 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 ((not endline
2f10: 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 77 72 ).;;.. (wr
2f20: 69 74 65 2d 73 74 72 69 6e 67 20 6c 20 23 66 20 ite-string l #f
2f30: 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 20 20 20 bin-dat).;;..
2f40: 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d (loop (read-
2f50: 73 74 72 69 6e 67 20 31 29 20 23 66 20 28 2b 20 string 1) #f (+
2f60: 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 09 20 20 20 num 1))).;;..
2f70: 20 20 20 3b 3b 20 73 74 72 69 6e 67 20 73 6f 20 ;; string so
2f80: 66 61 72 20 6d 61 74 63 68 65 73 20 64 65 6c 69 far matches deli
2f90: 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 20 20 20 m-string.;;..
2fa0: 20 20 20 28 65 6e 64 6c 69 6e 65 0a 3b 3b 09 09 (endline.;;..
2fb0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
2fc0: 6e 64 73 74 72 20 28 67 65 74 2d 6f 75 74 70 75 ndstr (get-outpu
2fd0: 74 2d 73 74 72 69 6e 67 20 65 6e 64 6c 69 6e 65 t-string endline
2fe0: 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 28 65 )).;;... (e
2ff0: 6e 64 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 ndlen (string-le
3000: 6e 67 74 68 20 65 6e 64 73 74 72 29 29 29 0a 3b ngth endstr))).;
3010: 3b 09 09 09 20 28 69 66 20 28 3e 20 65 6e 64 6c ;... (if (> endl
3020: 65 6e 20 30 29 0a 3b 3b 09 09 09 20 20 20 20 20 en 0).;;...
3030: 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 (format debugp "
3040: 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e 65 6e 64 73 delim: ~A\nends
3050: 74 72 3a 20 7e 41 5c 6e 22 20 64 65 6c 69 6d 2d tr: ~A\n" delim-
3060: 73 74 72 69 6e 67 20 65 6e 64 73 74 72 29 29 0a string endstr)).
3070: 3b 3b 09 09 09 20 28 69 66 20 28 61 6e 64 20 28 ;;... (if (and (
3080: 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c > delim-len endl
3090: 65 6e 29 0a 3b 3b 09 09 09 09 20 20 28 73 74 72 en).;;.... (str
30a0: 69 6e 67 3d 3f 20 6c 20 28 73 75 62 73 74 72 69 ing=? l (substri
30b0: 6e 67 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 ng delim-string
30c0: 65 6e 64 6c 65 6e 20 28 2b 20 65 6e 64 6c 65 6e endlen (+ endlen
30d0: 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 1)))).;;...
30e0: 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 63 68 ;; yes, this ch
30f0: 61 72 61 63 74 65 72 20 6d 61 74 63 68 65 73 20 aracter matches
3100: 74 68 65 20 6e 65 78 74 20 69 6e 20 74 68 65 20 the next in the
3110: 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 delim-string.;;.
3120: 09 09 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 .. (if (eq?
3130: 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c 65 6e delim-len endlen
3140: 29 20 3b 3b 20 68 61 76 65 20 61 20 6d 61 74 63 ) ;; have a matc
3150: 68 21 20 49 67 6e 6f 72 65 20 74 68 61 74 20 61 h! Ignore that a
3160: 20 6e 65 77 6c 69 6e 65 20 69 73 20 72 65 71 75 newline is requ
3170: 69 72 65 64 2e 20 4c 61 7a 79 20 62 75 67 67 65 ired. Lazy bugge
3180: 72 2e 0a 3b 3b 09 09 09 09 20 28 6c 65 74 2a 20 r..;;.... (let*
3190: 28 28 66 6e 20 20 20 20 20 20 28 73 74 72 69 6e ((fn (strin
31a0: 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 74 61 2d 6e g->symbol data-n
31b0: 61 6d 65 29 29 29 0a 3b 3b 09 09 09 09 20 20 20 ame))).;;....
31c0: 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 66 6f (formdat:set! fo
31d0: 72 6d 64 61 74 20 66 6e 20 28 6c 69 73 74 20 66 rmdat fn (list f
31e0: 69 6c 65 2d 6e 61 6d 65 20 64 61 74 61 2d 74 79 ile-name data-ty
31f0: 70 65 20 28 73 74 72 69 6e 67 2d 3e 62 6c 6f 62 pe (string->blob
3200: 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 (get-output-str
3210: 69 6e 67 20 62 69 6e 2d 64 61 74 29 29 29 29 0a ing bin-dat)))).
3220: 3b 3b 09 09 09 09 20 20 20 28 73 65 74 21 20 6d ;;.... (set! m
3230: 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 09 ode 'norm).;;...
3240: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
3250: 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b 3b 09 line) #f 0)).;;.
3260: 09 09 09 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 ... (begin.;;...
3270: 09 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e . (write-strin
3280: 67 20 6c 20 23 66 20 65 6e 64 6c 69 6e 65 29 0a g l #f endline).
3290: 3b 3b 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 ;;.... (loop (
32a0: 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 65 read-string 1) e
32b0: 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 6d 20 31 29 ndline (+ num 1)
32c0: 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 3b 3b ))).;;... ;;
32d0: 20 6e 6f 2c 20 74 68 69 73 20 63 68 61 72 61 63 no, this charac
32e0: 74 65 72 20 64 6f 65 73 20 4e 4f 54 20 6d 61 74 ter does NOT mat
32f0: 63 68 20 74 68 65 20 6e 65 78 74 20 69 6e 20 6c ch the next in l
3300: 69 6e 65 20 69 6e 20 64 65 6c 69 6d 2d 73 74 72 ine in delim-str
3310: 69 6e 67 0a 3b 3b 09 09 09 20 20 20 20 20 28 62 ing.;;... (b
3320: 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 20 20 20 egin.;;...
3330: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 22 (write-string "
3340: 5c 6e 22 20 23 66 20 62 69 6e 2d 64 61 74 29 20 \n" #f bin-dat)
3350: 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 67 65 74 20 ;; don't forget
3360: 74 68 61 74 20 6e 65 77 6c 69 6e 65 20 77 65 20 that newline we
3370: 64 72 6f 70 70 65 64 0a 3b 3b 09 09 09 20 20 20 dropped.;;...
3380: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
3390: 67 20 65 6e 64 73 74 72 20 23 66 20 62 69 6e 2d g endstr #f bin-
33a0: 64 61 74 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 dat).;;...
33b0: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c (write-string l
33c0: 20 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 #f bin-dat).;;.
33d0: 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 .. (loop (
33e0: 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 23 read-string 1) #
33f0: 66 20 28 2b 20 6e 75 6d 20 31 29 29 29 29 29 29 f (+ num 1))))))
3400: 29 29 0a 3b 3b 09 09 20 20 20 20 29 29 29 29 29 )).;;.. )))))
3410: 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 64 61 74 ..;; (formdat
3420: 3a 70 72 69 6e 74 61 6c 6c 20 66 6f 72 6d 64 61 :printall formda
3430: 74 20 28 6c 61 6d 62 64 61 20 28 78 29 28 77 72 t (lambda (x)(wr
3440: 69 74 65 2d 6c 69 6e 65 20 78 20 64 65 62 75 67 ite-line x debug
3450: 70 29 29 29 0a 0a 23 7c 0a 28 64 65 66 69 6e 65 p)))..#|.(define
3460: 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 inp (open-input
3470: 2d 66 69 6c 65 20 22 2f 74 6d 70 2f 73 74 6d 6c -file "/tmp/stml
3480: 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 2e 6c 6f 67 run/delme-33.log
3490: 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 66 22 29 29 .keep-for-ref"))
34a0: 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 72 65 .(define dat (re
34b0: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 6e 70 ad-string #f inp
34c0: 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d )).(close-input-
34d0: 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a port inp).|#.