Artifact
24de706a4e4c42fb00d6207f4345911bdc6a32c4:
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 28 66 6f -ref/default (fo
04b0: 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 rmdat:formdat-ge
04c0: 74 2d 64 61 74 61 20 73 65 6c 66 29 20 6b 65 79 t-data self) key
04d0: 20 23 66 29 29 0a 0a 3b 3b 20 63 68 61 6e 67 65 #f))..;; change
04e0: 20 74 6f 20 63 6f 6e 76 65 72 74 20 64 61 74 61 to convert data
04f0: 20 74 6f 20 6c 69 73 74 20 61 6e 64 20 61 70 70 to list and app
0500: 65 6e 64 20 76 61 6c 20 69 66 20 61 6c 72 65 61 end val if alrea
0510: 64 79 20 65 78 69 73 74 73 0a 3b 3b 20 6f 72 20 dy exists.;; or
0520: 69 73 20 61 20 6c 69 73 74 0a 28 64 65 66 69 6e is a list.(defin
0530: 65 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 e (formdat:set!
0540: 73 65 6c 66 20 6b 65 79 20 76 61 6c 29 0a 20 20 self key val).
0550: 28 6c 65 74 20 28 28 70 72 65 76 2d 76 61 6c 20 (let ((prev-val
0560: 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 73 65 6c (formdat:get sel
0570: 66 20 6b 65 79 29 29 0a 20 20 20 20 20 20 20 20 f key)).
0580: 28 68 74 20 20 20 20 20 20 20 28 66 6f 72 6d 64 (ht (formd
0590: 61 74 3a 66 6f 72 6d 64 61 74 2d 67 65 74 2d 64 at:formdat-get-d
05a0: 61 74 61 20 73 65 6c 66 29 29 29 0a 20 20 20 20 ata self))).
05b0: 28 69 66 20 70 72 65 76 2d 76 61 6c 0a 20 20 20 (if prev-val.
05c0: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
05d0: 70 72 65 76 2d 76 61 6c 29 0a 20 20 20 20 20 20 prev-val).
05e0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
05f0: 65 2d 73 65 74 21 20 68 74 20 6b 65 79 20 28 63 e-set! ht key (c
0600: 6f 6e 73 20 76 61 6c 20 70 72 65 76 2d 76 61 6c ons val prev-val
0610: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
0620: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
0630: 68 74 20 6b 65 79 20 28 6c 69 73 74 20 76 61 6c ht key (list val
0640: 20 70 72 65 76 2d 76 61 6c 29 29 29 0a 20 20 20 prev-val))).
0650: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
0660: 2d 73 65 74 21 20 68 74 20 6b 65 79 20 76 61 6c -set! ht key val
0670: 29 29 0a 20 20 20 20 73 65 6c 66 29 29 0a 0a 28 )). self))..(
0680: 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a define (formdat:
0690: 6b 65 79 73 20 73 65 6c 66 29 0a 20 20 28 68 61 keys self). (ha
06a0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 28 66 sh-table-keys (f
06b0: 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 61 74 2d 67 ormdat:formdat-g
06c0: 65 74 2d 64 61 74 61 20 73 65 6c 66 29 29 29 0a et-data self))).
06d0: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
06e0: 74 3a 70 72 69 6e 74 61 6c 6c 20 73 65 6c 66 20 t:printall self
06f0: 70 72 69 6e 74 70 72 6f 63 29 0a 20 20 28 70 72 printproc). (pr
0700: 69 6e 74 70 72 6f 63 20 22 66 6f 72 6d 64 61 74 intproc "formdat
0710: 3a 70 72 69 6e 74 61 6c 6c 20 22 20 28 66 6f 72 :printall " (for
0720: 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c 66 29 29 mdat:keys self))
0730: 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 . (for-each (la
0740: 6d 62 64 61 20 28 6b 29 0a 09 20 20 20 20 20 20 mbda (k)..
0750: 28 70 72 69 6e 74 70 72 6f 63 20 6b 20 22 20 3d (printproc k " =
0760: 3e 20 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 > " (formdat:get
0770: 20 73 65 6c 66 20 6b 29 29 29 0a 09 20 20 20 20 self k)))..
0780: 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 (formdat:keys se
0790: 6c 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 lf)))..(define (
07a0: 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 formdat:all->str
07b0: 69 6e 67 73 20 73 65 6c 66 29 0a 20 20 28 6c 65 ings self). (le
07c0: 74 20 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 t ((res '())).
07d0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
07e0: 62 64 61 20 28 6b 29 0a 20 20 20 20 20 20 20 20 bda (k).
07f0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 (set! r
0800: 65 73 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 6b es (cons (conc k
0810: 20 22 3d 3e 22 20 28 66 6f 72 6d 64 61 74 3a 67 "=>" (formdat:g
0820: 65 74 20 73 65 6c 66 20 6b 29 29 20 72 65 73 29 et self k)) res)
0830: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0840: 20 28 66 6f 72 6d 64 61 74 3a 6b 65 79 73 20 73 (formdat:keys s
0850: 65 6c 66 29 29 0a 20 20 20 20 20 20 20 20 72 65 elf)). re
0860: 73 29 29 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 s))..;; call wit
0870: 68 20 2a 6f 6e 65 2a 20 6f 66 20 74 68 65 20 6c h *one* of the l
0880: 69 73 74 73 20 69 6e 20 74 68 65 20 6c 69 73 74 ists in the list
0890: 20 6f 66 20 6c 69 73 74 73 20 63 72 65 61 74 65 of lists create
08a0: 64 20 62 79 20 43 47 49 3a 75 72 6c 2d 75 6e 71 d by CGI:url-unq
08b0: 75 6f 74 65 0a 28 64 65 66 69 6e 65 20 28 66 6f uote.(define (fo
08c0: 72 6d 64 61 74 3a 6c 6f 61 64 20 73 65 6c 66 20 rmdat:load self
08d0: 66 6f 72 6d 6c 69 73 74 29 0a 20 20 28 6c 65 74 formlist). (let
08e0: 20 28 28 68 74 20 20 20 20 20 20 20 20 20 20 20 ((ht
08f0: 20 20 28 66 6f 72 6d 64 61 74 3a 66 6f 72 6d 64 (formdat:formd
0900: 61 74 2d 67 65 74 2d 64 61 74 61 20 73 65 6c 66 at-get-data self
0910: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
0920: 6c 3f 20 66 6f 72 6d 6c 69 73 74 29 20 73 65 6c l? formlist) sel
0930: 66 20 3b 3b 20 6e 6f 20 76 61 6c 75 65 73 20 70 f ;; no values p
0940: 72 6f 76 69 64 65 64 2c 20 72 65 74 75 72 6e 20 rovided, return
0950: 73 65 6c 66 20 66 6f 72 20 6e 6f 20 67 6f 6f 64 self for no good
0960: 20 72 65 61 73 6f 6e 0a 20 20 20 20 20 20 20 20 reason.
0970: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 61 64 (let loop ((head
0980: 20 28 63 61 72 20 66 6f 72 6d 6c 69 73 74 29 29 (car formlist))
0990: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
09a0: 20 20 20 20 28 74 61 69 6c 20 28 63 64 72 20 66 (tail (cdr f
09b0: 6f 72 6d 6c 69 73 74 29 29 29 0a 20 20 20 20 20 ormlist))).
09c0: 20 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 20 (let ((key
09d0: 28 63 61 72 20 68 65 61 64 29 29 0a 20 20 20 20 (car head)).
09e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 61 6c (val
09f0: 20 28 63 64 72 20 68 65 61 64 29 29 29 0a 20 20 (cdr head))).
0a00: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 65 72 ;; (er
0a10: 72 3a 6c 6f 67 20 22 6b 65 79 3d 22 20 6b 65 79 r:log "key=" key
0a20: 20 22 20 76 61 6c 3d 22 20 76 61 6c 29 0a 09 20 " val=" val)..
0a30: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
0a40: 68 20 76 61 6c 29 20 31 29 0a 09 09 28 66 6f 72 h val) 1)...(for
0a50: 6d 64 61 74 3a 73 65 74 21 20 73 65 6c 66 20 6b mdat:set! self k
0a60: 65 79 20 76 61 6c 29 0a 09 09 28 66 6f 72 6d 64 ey val)...(formd
0a70: 61 74 3a 73 65 74 21 20 73 65 6c 66 20 6b 65 79 at:set! self key
0a80: 20 28 63 61 72 20 76 61 6c 29 29 29 0a 20 20 20 (car val))).
0a90: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
0aa0: 6c 6c 3f 20 74 61 69 6c 29 20 73 65 6c 66 20 20 ll? tail) self
0ab0: 20 3b 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a ;; we are done.
0ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ad0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
0ae0: 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 29 29 (cdr tail)))))))
0af0: 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 68 65 )..;; get the he
0b00: 61 64 65 72 20 66 72 6f 6d 20 64 61 74 73 74 72 ader from datstr
0b10: 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 .(define (formda
0b20: 74 3a 72 65 61 64 2d 68 65 61 64 65 72 20 64 61 t:read-header da
0b30: 74 73 74 72 29 20 3b 3b 20 64 61 74 73 74 72 20 tstr) ;; datstr
0b40: 69 73 20 61 6e 20 69 6e 70 75 74 20 73 74 72 69 is an input stri
0b50: 6e 67 20 70 6f 72 74 0a 20 20 28 6c 65 74 20 6c ng port. (let l
0b60: 6f 6f 70 20 28 28 68 73 20 28 72 65 61 64 2d 6c oop ((hs (read-l
0b70: 69 6e 65 20 64 61 74 73 74 72 29 29 0a 09 20 20 ine datstr))..
0b80: 20 20 20 28 68 65 61 64 65 72 20 27 28 29 29 29 (header '()))
0b90: 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 6f . (if (or (eo
0ba0: 66 2d 6f 62 6a 65 63 74 3f 20 68 73 29 0a 09 20 f-object? hs)..
0bb0: 20 20 20 28 73 74 72 69 6e 67 3d 3f 20 68 73 20 (string=? hs
0bc0: 22 22 29 29 0a 09 68 65 61 64 65 72 0a 09 28 6c ""))..header..(l
0bd0: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 64 oop (read-line d
0be0: 61 74 73 74 72 29 28 61 70 70 65 6e 64 20 68 65 atstr)(append he
0bf0: 61 64 65 72 20 28 6c 69 73 74 20 68 73 29 29 29 ader (list hs)))
0c00: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 )))..;; get the
0c10: 64 61 74 61 20 75 70 20 74 6f 20 74 68 65 20 6e data up to the n
0c20: 65 78 74 20 6b 65 79 2e 20 69 66 20 74 68 65 72 ext key. if ther
0c30: 65 20 69 73 20 6e 6f 20 6b 65 79 20 74 68 65 6e e is no key then
0c40: 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b 20 72 65 return #f.;; re
0c50: 74 75 72 6e 20 28 64 61 74 20 72 65 6d 64 61 74 turn (dat remdat
0c60: 29 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 ).(define (formd
0c70: 61 74 3a 72 65 61 64 2d 64 61 74 20 64 61 74 20 at:read-dat dat
0c80: 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 69 6e key). (let ((in
0c90: 64 65 78 20 28 73 74 72 69 6e 67 2d 73 65 61 72 dex (string-sear
0ca0: 63 68 2d 70 6f 73 69 74 69 6f 6e 73 20 6b 65 79 ch-positions key
0cb0: 20 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 dat))). (if
0cc0: 28 6f 72 20 28 6e 6f 74 20 69 6e 64 65 78 29 0a (or (not index).
0cd0: 09 20 20 20 20 28 6e 75 6c 6c 3f 20 69 6e 64 65 . (null? inde
0ce0: 78 29 29 20 3b 3b 20 74 68 65 20 6b 65 79 20 77 x)) ;; the key w
0cf0: 61 73 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 23 66 as not found..#f
0d00: 0a 09 28 6c 65 74 2a 20 28 28 64 61 74 73 74 72 ..(let* ((datstr
0d10: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 (open-input-str
0d20: 69 6e 67 20 64 61 74 29 29 0a 09 20 20 20 20 20 ing dat))..
0d30: 20 20 28 72 65 73 75 6c 74 20 28 72 65 61 64 2d (result (read-
0d40: 73 74 72 69 6e 67 20 28 63 61 61 72 20 69 6e 64 string (caar ind
0d50: 65 78 29 20 64 61 74 73 74 72 29 29 0a 09 20 20 ex) datstr))..
0d60: 20 20 20 20 20 28 72 65 6d 64 61 74 20 28 72 65 (remdat (re
0d70: 61 64 2d 73 74 72 69 6e 67 20 23 66 20 64 61 74 ad-string #f dat
0d80: 73 74 72 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 str))).. (close
0d90: 2d 69 6e 70 75 74 2d 70 6f 72 74 20 64 61 74 73 -input-port dats
0da0: 74 72 29 0a 09 20 20 28 6c 69 73 74 20 72 65 73 tr).. (list res
0db0: 75 6c 74 20 72 65 6d 64 61 74 29 29 29 29 29 0a ult remdat))))).
0dc0: 0a 20 3b 3b 20 69 6e 70 20 69 73 20 70 6f 72 74 . ;; inp is port
0dd0: 20 74 6f 20 72 65 61 64 20 64 61 74 61 20 66 72 to read data fr
0de0: 6f 6d 2c 20 6d 61 78 73 69 7a 65 20 69 73 20 6d om, maxsize is m
0df0: 61 78 20 64 61 74 61 20 61 6c 6c 6f 77 65 64 20 ax data allowed
0e00: 74 6f 20 72 65 61 64 20 28 74 6f 74 61 6c 29 0a to read (total).
0e10: 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 (define (formdat
0e20: 3a 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 6d :dat->list inp m
0e30: 61 78 73 69 7a 65 29 0a 20 20 3b 3b 20 72 65 61 axsize). ;; rea
0e40: 64 20 31 4d 65 67 20 63 68 75 6e 6b 73 20 66 72 d 1Meg chunks fr
0e50: 6f 6d 20 74 68 65 20 69 6e 70 75 74 20 70 6f 72 om the input por
0e60: 74 2e 20 49 66 20 61 20 62 6c 6f 63 6b 20 69 73 t. If a block is
0e70: 20 6e 6f 74 20 63 6f 6d 70 6c 65 74 65 0a 20 20 not complete.
0e80: 3b 3b 20 74 61 63 6b 20 6f 6e 20 74 68 65 20 6e ;; tack on the n
0e90: 65 78 74 20 31 4d 65 67 20 63 68 75 6e 6b 20 61 ext 1Meg chunk a
0ea0: 73 20 6e 65 65 64 65 64 2e 20 53 65 74 20 75 70 s needed. Set up
0eb0: 20 73 6f 20 74 68 65 20 68 65 61 64 65 72 20 69 so the header i
0ec0: 73 20 61 6c 77 61 79 73 0a 20 20 3b 3b 20 61 74 s always. ;; at
0ed0: 20 74 68 65 20 62 65 67 69 6e 6e 69 6e 67 20 6f the beginning o
0ee0: 66 20 74 68 65 20 63 68 75 6e 6b 0a 20 20 3b 3b f the chunk. ;;
0ef0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0f00: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 32 39 39 -------------299
0f10: 33 32 30 32 34 34 31 31 35 30 32 33 32 33 33 33 3202441150232333
0f20: 32 31 33 36 32 31 34 39 37 33 0a 20 20 3b 3b 43 2136214973. ;;C
0f30: 6f 6e 74 65 6e 74 2d 44 69 73 70 6f 73 69 74 69 ontent-Dispositi
0f40: 6f 6e 3a 20 66 6f 72 6d 2d 64 61 74 61 3b 20 6e on: form-data; n
0f50: 61 6d 65 3d 22 69 6e 70 75 74 2d 70 69 63 74 75 ame="input-pictu
0f60: 72 65 22 3b 20 66 69 6c 65 6e 61 6d 65 3d 22 62 re"; filename="b
0f70: 72 65 61 64 66 72 75 69 74 2e 6a 70 67 22 0a 20 readfruit.jpg".
0f80: 20 3b 3b 43 6f 6e 74 65 6e 74 2d 54 79 70 65 3a ;;Content-Type:
0f90: 20 69 6d 61 67 65 2f 6a 70 65 67 0a 20 20 28 6c image/jpeg. (l
0fa0: 65 74 20 6c 6f 6f 70 20 28 28 64 61 74 20 28 72 et loop ((dat (r
0fb0: 65 61 64 2d 73 74 72 69 6e 67 20 31 30 30 30 30 ead-string 10000
0fc0: 30 30 20 69 6e 70 29 29 0a 09 20 20 20 20 20 28 00 inp)).. (
0fd0: 72 65 73 20 27 28 29 29 0a 09 20 20 20 20 20 28 res '()).. (
0fe0: 73 69 7a 20 30 29 29 0a 20 20 20 20 28 69 66 20 siz 0)). (if
0ff0: 28 3e 20 73 69 7a 20 6d 61 78 73 69 7a 65 29 0a (> siz maxsize).
1000: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e .(begin.. (prin
1010: 74 20 22 44 41 54 41 20 54 4f 4f 20 42 49 47 22 t "DATA TOO BIG"
1020: 29 0a 09 20 20 72 65 73 29 0a 09 28 6c 65 74 2a ).. res)..(let*
1030: 20 28 28 64 61 74 73 74 72 20 28 6f 70 65 6e 2d ((datstr (open-
1040: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 64 61 74 input-string dat
1050: 29 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 )).. (head
1060: 65 72 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 er (formdat:read
1070: 2d 68 65 61 64 65 72 20 64 61 74 73 74 72 29 29 -header datstr))
1080: 0a 09 20 20 20 20 20 20 20 28 6b 65 79 20 20 20 .. (key
1090: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
10a0: 20 68 65 61 64 65 72 29 29 28 63 61 72 20 68 65 header))(car he
10b0: 61 64 65 72 29 20 23 66 29 29 0a 09 20 20 20 20 ader) #f))..
10c0: 20 20 20 28 72 65 6d 64 61 74 20 28 72 65 61 64 (remdat (read
10d0: 2d 73 74 72 69 6e 67 20 23 66 20 64 61 74 73 74 -string #f datst
10e0: 72 29 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 r)) ;;
10f0: 75 73 65 64 20 69 6e 20 6e 65 78 74 20 6c 69 6e used in next lin
1100: 65 2c 20 64 69 73 63 61 72 64 20 69 66 20 67 6f e, discard if go
1110: 74 20 64 61 74 61 2c 20 65 6c 73 65 20 72 65 76 t data, else rev
1120: 65 72 74 20 74 6f 0a 09 20 20 20 20 20 20 20 28 ert to.. (
1130: 61 6c 6c 64 61 74 20 28 69 66 20 6b 65 79 20 28 alldat (if key (
1140: 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 64 61 74 formdat:read-dat
1150: 20 72 65 6d 64 61 74 20 6b 65 79 29 20 23 66 29 remdat key) #f)
1160: 29 20 20 20 20 3b 3b 20 74 72 79 20 74 6f 20 65 ) ;; try to e
1170: 78 74 72 61 63 74 20 74 68 65 20 64 61 74 61 0a xtract the data.
1180: 09 20 20 20 20 20 20 20 28 74 68 73 64 61 74 20 . (thsdat
1190: 28 69 66 20 61 6c 6c 64 61 74 20 28 63 61 72 20 (if alldat (car
11a0: 61 6c 6c 64 61 74 29 20 20 23 66 29 29 20 20 20 alldat) #f))
11b0: 20 20 3b 3b 20 74 68 65 20 64 61 74 61 0a 09 20 ;; the data..
11c0: 20 20 20 20 20 20 28 6e 65 77 64 61 74 20 28 69 (newdat (i
11d0: 66 20 61 6c 6c 64 61 74 20 28 63 61 64 72 20 61 f alldat (cadr a
11e0: 6c 6c 64 61 74 29 20 23 66 29 29 20 20 20 20 20 lldat) #f))
11f0: 3b 3b 20 6c 65 66 74 20 6f 76 65 72 20 64 61 74 ;; left over dat
1200: 61 2c 20 6d 75 73 74 20 70 72 6f 63 65 73 73 20 a, must process
1210: 2e 2e 2e 0a 09 20 20 20 20 20 20 20 28 74 68 73 ..... (ths
1220: 72 65 73 20 28 6c 69 73 74 20 68 65 61 64 65 72 res (list header
1230: 20 74 68 73 64 61 74 29 29 20 20 20 20 20 20 20 thsdat))
1240: 20 20 20 20 20 20 3b 3b 20 73 70 65 63 75 6c 61 ;; specula
1250: 74 69 76 65 6c 79 20 63 6f 6e 73 74 72 75 63 74 tively construct
1260: 20 72 65 73 75 6c 74 73 0a 09 20 20 20 20 20 20 results..
1270: 20 28 6e 65 77 72 65 73 20 28 61 70 70 65 6e 64 (newres (append
1280: 20 72 65 73 20 28 6c 69 73 74 20 74 68 73 72 65 res (list thsre
1290: 73 29 29 29 29 20 20 20 20 20 20 3b 3b 20 73 70 s)))) ;; sp
12a0: 65 63 75 6c 61 74 69 76 65 6c 79 20 63 6f 6e 73 eculatively cons
12b0: 74 72 75 63 74 20 72 65 73 75 6c 74 73 0a 09 20 truct results..
12c0: 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
12d0: 72 74 20 64 61 74 73 74 72 29 0a 09 20 20 28 63 rt datstr).. (c
12e0: 6f 6e 64 0a 09 20 20 20 3b 3b 20 65 69 74 68 65 ond.. ;; eithe
12f0: 72 20 6e 6f 20 68 65 61 64 65 72 20 6f 72 20 73 r no header or s
1300: 69 6e 67 6c 65 20 69 6e 70 75 74 0a 09 20 20 20 ingle input..
1310: 28 28 61 6e 64 20 28 6e 6f 74 20 61 6c 6c 64 61 ((and (not allda
1320: 74 29 0a 09 09 20 28 6f 72 20 28 6e 75 6c 6c 3f t)... (or (null?
1330: 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 20 header)...
1340: 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d 6d 61 74 (not (string-mat
1350: 63 68 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 6d ch formdat:delim
1360: 2d 70 61 74 74 2d 72 65 78 20 28 63 61 72 20 68 -patt-rex (car h
1370: 65 61 64 65 72 29 29 29 29 29 0a 09 20 20 20 20 eader)))))..
1380: 3b 3b 20 28 70 72 69 6e 74 20 22 47 6f 74 20 68 ;; (print "Got h
1390: 65 72 65 22 29 0a 09 20 20 20 20 28 63 6f 6e 73 ere").. (cons
13a0: 20 28 6c 69 73 74 20 68 65 61 64 65 72 20 22 22 (list header ""
13b0: 29 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 65 20 ) res)) ;; note
13c0: 75 73 65 20 68 65 61 64 65 72 20 61 73 20 64 61 use header as da
13d0: 74 20 61 6e 64 20 75 73 65 20 22 22 20 61 73 20 t and use "" as
13e0: 68 65 61 64 65 72 3f 3f 3f 3f 0a 09 20 20 20 3b header????.. ;
13f0: 3b 20 64 69 64 6e 27 74 20 66 69 6e 64 20 65 6e ; didn't find en
1400: 64 20 6b 65 79 20 69 6e 20 74 68 69 73 20 62 6c d key in this bl
1410: 6f 63 6b 0a 09 20 20 20 28 28 6e 6f 74 20 61 6c ock.. ((not al
1420: 6c 64 61 74 29 0a 09 20 20 20 20 28 6c 65 74 20 ldat).. (let
1430: 28 28 6d 6f 72 64 61 74 20 28 72 65 61 64 2d 73 ((mordat (read-s
1440: 74 72 69 6e 67 20 31 30 30 30 30 30 30 20 69 6e tring 1000000 in
1450: 70 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 p))).. (if
1460: 28 73 74 72 69 6e 67 3d 3f 20 6d 6f 72 64 61 74 (string=? mordat
1470: 20 22 22 29 20 3b 3b 20 74 68 65 72 65 20 69 73 "") ;; there is
1480: 20 6e 6f 20 6d 6f 72 65 20 64 61 74 61 2c 20 64 no more data, d
1490: 69 73 63 61 72 64 20 72 65 73 75 6c 74 73 20 61 iscard results a
14a0: 6e 64 20 75 73 65 20 72 65 6d 64 61 74 20 61 73 nd use remdat as
14b0: 20 64 61 74 61 2c 20 74 68 69 73 20 69 6e 70 75 data, this inpu
14c0: 74 20 69 73 20 62 72 6f 6b 65 6e 0a 09 09 20 20 t is broken...
14d0: 28 63 6f 6e 73 20 28 6c 69 73 74 20 68 65 61 64 (cons (list head
14e0: 65 72 20 72 65 6d 64 61 74 29 20 72 65 73 29 0a er remdat) res).
14f0: 09 09 20 20 28 6c 6f 6f 70 20 28 73 74 72 69 6e .. (loop (strin
1500: 67 2d 61 70 70 65 6e 64 20 64 61 74 20 6d 6f 72 g-append dat mor
1510: 64 61 74 29 20 72 65 73 20 28 2b 20 73 69 7a 20 dat) res (+ siz
1520: 32 30 30 30 30 30 30 29 29 29 29 29 20 3b 3b 20 2000000))))) ;;
1530: 61 64 64 20 74 68 65 20 65 78 74 72 61 20 31 30 add the extra 10
1540: 30 30 30 30 30 0a 09 20 20 20 28 61 6c 6c 64 61 00000.. (allda
1550: 74 20 3b 3b 20 67 6f 74 20 64 61 74 61 2c 20 64 t ;; got data, d
1560: 6f 6e 27 74 20 61 74 74 65 6d 70 74 20 74 6f 20 on't attempt to
1570: 63 68 65 63 6b 20 69 66 20 74 68 65 72 65 20 69 check if there i
1580: 73 20 6d 6f 72 65 2c 20 6a 75 73 74 20 6c 6f 6f s more, just loo
1590: 70 20 61 6e 64 20 72 65 6c 79 20 6f 6e 20 28 6e p and rely on (n
15a0: 6f 74 20 61 6c 6c 64 61 74 29 20 74 6f 20 67 65 ot alldat) to ge
15b0: 74 20 6d 6f 72 65 20 64 61 74 61 0a 09 20 20 20 t more data..
15c0: 20 28 6c 6f 6f 70 20 6e 65 77 64 61 74 20 6e 65 (loop newdat ne
15d0: 77 72 65 73 20 28 2b 20 73 69 7a 20 31 30 30 30 wres (+ siz 1000
15e0: 30 30 30 29 29 29 29 29 29 29 29 0a 0a 28 64 65 000))))))))..(de
15f0: 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e fine formdat:bin
1600: 2d 64 61 74 61 2d 64 69 73 70 2d 72 65 78 20 28 -data-disp-rex (
1610: 72 65 67 65 78 70 20 22 5e 43 6f 6e 74 65 6e 74 regexp "^Content
1620: 2d 44 69 73 70 6f 73 69 74 69 6f 6e 3a 5c 5c 73 -Disposition:\\s
1630: 2b 66 6f 72 6d 2d 64 61 74 61 3b 22 29 29 0a 28 +form-data;")).(
1640: 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 define formdat:b
1650: 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 in-data-name-rex
1660: 20 28 72 65 67 65 78 70 20 22 5c 5c 57 6e 61 6d (regexp "\\Wnam
1670: 65 3d 5c 22 28 5b 5e 5c 22 5d 2b 29 5c 22 22 29 e=\"([^\"]+)\"")
1680: 29 0a 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 ).(define formda
1690: 74 3a 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 2d t:bin-file-name-
16a0: 72 65 78 20 28 72 65 67 65 78 70 20 22 5c 5c 57 rex (regexp "\\W
16b0: 66 69 6c 65 6e 61 6d 65 3d 5c 22 28 5b 5e 5c 22 filename=\"([^\"
16c0: 5d 2b 29 5c 22 22 29 29 0a 28 64 65 66 69 6e 65 ]+)\"")).(define
16d0: 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 6c formdat:bin-fil
16e0: 65 2d 74 79 70 65 2d 72 65 78 20 28 72 65 67 65 e-type-rex (rege
16f0: 78 70 20 22 43 6f 6e 74 65 6e 74 2d 54 79 70 65 xp "Content-Type
1700: 3a 5c 5c 73 2b 28 5b 5e 5c 5c 73 5d 2b 29 22 29 :\\s+([^\\s]+)")
1710: 29 0a 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 61 ).(define formda
1720: 74 3a 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 t:delim-patt-rex
1730: 20 20 20 20 28 72 65 67 65 78 70 20 22 5e 5c 5c (regexp "^\\
1740: 2d 2b 5b 30 2d 39 5d 2b 5c 5c 2d 2a 24 22 29 29 -+[0-9]+\\-*$"))
1750: 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 61 20 68 ..;; returns a h
1760: 61 73 68 20 77 69 74 68 20 65 6e 74 72 69 65 73 ash with entries
1770: 20 66 6f 72 20 61 6c 6c 20 66 6f 72 6d 73 20 2d for all forms -
1780: 20 63 6f 75 6c 64 20 77 65 6c 6c 20 75 73 65 20 could well use
1790: 61 20 70 72 6f 70 6c 69 73 74 3f 0a 28 64 65 66 a proplist?.(def
17a0: 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 ine (formdat:loa
17b0: 64 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 20 28 28 d-all). (let ((
17c0: 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 28 request-method (
17d0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
17e0: 76 61 72 69 61 62 6c 65 20 22 52 45 51 55 45 53 variable "REQUES
17f0: 54 5f 4d 45 54 48 4f 44 22 29 29 29 0a 20 20 20 T_METHOD"))).
1800: 20 28 69 66 20 28 61 6e 64 20 72 65 71 75 65 73 (if (and reques
1810: 74 2d 6d 65 74 68 6f 64 0a 09 20 20 20 20 20 28 t-method.. (
1820: 73 74 72 69 6e 67 3d 3f 20 72 65 71 75 65 73 74 string=? request
1830: 2d 6d 65 74 68 6f 64 20 22 50 4f 53 54 22 29 29 -method "POST"))
1840: 0a 09 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d ..(formdat:load-
1850: 61 6c 6c 2d 70 6f 72 74 20 28 63 75 72 72 65 6e all-port (curren
1860: 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 29 t-input-port))))
1870: 29 0a 0a 3b 3b 20 28 73 3a 70 72 6f 63 65 73 73 )..;; (s:process
1880: 2d 63 67 69 2d 69 6e 70 75 74 20 28 63 61 61 61 -cgi-input (caaa
1890: 72 20 64 61 74 29 29 0a 28 64 65 66 69 6e 65 20 r dat)).(define
18a0: 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c (formdat:load-al
18b0: 6c 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 28 6c l-port inp). (l
18c0: 65 74 2a 20 28 28 66 6f 72 6d 64 61 74 20 20 20 et* ((formdat
18d0: 20 20 20 20 20 28 6d 61 6b 65 2d 66 6f 72 6d 64 (make-formd
18e0: 61 74 3a 66 6f 72 6d 64 61 74 29 29 29 0a 3b 3b at:formdat))).;;
18f0: 09 20 28 64 65 62 75 67 70 20 20 20 20 20 20 20 . (debugp
1900: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
1910: 69 6c 65 20 28 63 6f 6e 63 20 28 73 6c 6f 74 2d ile (conc (slot-
1920: 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 27 73 ref s:session 's
1930: 72 6f 6f 74 29 20 22 2f 64 65 6c 6d 65 2d 22 20 root) "/delme-"
1940: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
1950: 29 20 22 2e 6c 6f 67 22 29 29 29 29 0a 20 20 20 ) ".log")))).
1960: 20 3b 3b 20 28 77 72 69 74 65 2d 73 74 72 69 6e ;; (write-strin
1970: 67 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 g (read-string #
1980: 66 20 69 6e 70 29 20 23 66 20 64 65 62 75 67 70 f inp) #f debugp
1990: 29 0a 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 69 ). (formdat:i
19a0: 6e 69 74 69 61 6c 69 7a 65 20 66 6f 72 6d 64 61 nitialize formda
19b0: 74 29 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6c t). (let ((al
19c0: 6c 64 61 74 73 20 28 66 6f 72 6d 64 61 74 3a 64 ldats (formdat:d
19d0: 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 30 65 at->list inp 10e
19e0: 36 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 6))). .
19f0: 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 64 65 62 ;; (format deb
1a00: 75 67 70 20 22 66 6f 72 6d 64 61 74 20 3a 20 61 ugp "formdat : a
1a10: 6c 6c 64 61 74 73 3a 20 7e 41 5c 6e 22 20 61 6c lldats: ~A\n" al
1a20: 6c 64 61 74 73 29 0a 20 20 20 20 20 20 28 6c 65 ldats). (le
1a30: 74 20 28 28 66 69 72 73 74 69 74 65 6d 20 20 20 t ((firstitem
1a40: 28 63 61 72 20 61 6c 6c 64 61 74 73 29 29 0a 09 (car alldats))..
1a50: 20 20 20 20 28 6d 75 6c 74 69 70 61 73 73 20 23 (multipass #
1a60: 66 29 29 20 0a 09 28 69 66 20 28 6e 6f 74 20 28 f)) ..(if (not (
1a70: 6e 75 6c 6c 3f 20 66 69 72 73 74 69 74 65 6d 29 null? firstitem)
1a80: 29 0a 09 20 20 20 20 28 69 66 20 28 73 74 72 69 ).. (if (stri
1a90: 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 ng-match formdat
1aa0: 3a 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 :delim-patt-rex
1ab0: 28 63 61 61 72 20 66 69 72 73 74 69 74 65 6d 29 (caar firstitem)
1ac0: 29 0a 09 09 28 73 65 74 21 20 6d 75 6c 74 69 70 )...(set! multip
1ad0: 61 73 73 20 23 74 29 29 29 0a 09 28 69 66 20 6d ass #t)))..(if m
1ae0: 75 6c 74 69 70 61 73 73 0a 09 20 20 20 20 3b 3b ultipass.. ;;
1af0: 20 68 61 6e 64 6c 65 20 6d 75 6c 74 69 2d 70 61 handle multi-pa
1b00: 72 74 20 66 6f 72 6d 0a 09 20 20 20 20 28 66 6f rt form.. (fo
1b10: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
1b20: 64 61 74 6c 73 74 29 0a 09 09 09 28 6c 65 74 2a datlst)....(let*
1b30: 20 28 28 68 65 61 64 65 72 20 28 66 6f 72 6d 64 ((header (formd
1b40: 61 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 65 at:extract-heade
1b50: 72 2d 69 6e 66 6f 20 28 63 61 72 20 64 61 74 6c r-info (car datl
1b60: 73 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 st)))....
1b70: 28 6e 61 6d 65 20 20 20 28 69 66 20 28 61 73 73 (name (if (ass
1b80: 6f 63 20 27 6e 61 6d 65 20 68 65 61 64 65 72 29 oc 'name header)
1b90: 0a 09 09 09 09 09 20 20 20 28 73 74 72 69 6e 67 ...... (string
1ba0: 2d 3e 73 79 6d 62 6f 6c 20 28 63 61 64 72 20 28 ->symbol (cadr (
1bb0: 61 73 73 6f 63 20 27 6e 61 6d 65 20 68 65 61 64 assoc 'name head
1bc0: 65 72 29 29 29 0a 09 09 09 09 09 20 20 20 22 22 er)))...... ""
1bd0: 29 29 20 3b 3b 20 67 72 75 6d 62 6c 65 0a 09 09 )) ;; grumble...
1be0: 09 20 20 20 20 20 20 20 28 66 6e 61 6d 65 6c 20 . (fnamel
1bf0: 20 28 61 73 73 6f 63 20 27 66 69 6c 65 6e 61 6d (assoc 'filenam
1c00: 65 20 68 65 61 64 65 72 29 29 0a 09 09 09 20 20 e header))....
1c10: 20 20 20 20 20 28 63 6f 6e 74 65 6e 74 20 28 61 (content (a
1c20: 73 73 6f 63 20 27 63 6f 6e 74 65 6e 74 20 68 65 ssoc 'content he
1c30: 61 64 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 ader))....
1c40: 20 28 64 61 74 20 20 20 20 28 63 61 64 72 20 64 (dat (cadr d
1c50: 61 74 6c 73 74 29 29 29 0a 09 09 09 20 20 3b 3b atlst))).... ;;
1c60: 20 28 70 72 69 6e 74 20 22 68 65 61 64 65 72 3a (print "header:
1c70: 20 22 20 68 65 61 64 65 72 20 22 20 6e 61 6d 65 " header " name
1c80: 3a 20 22 20 6e 61 6d 65 20 22 20 66 6e 61 6d 65 : " name " fname
1c90: 6c 3a 20 22 20 66 6e 61 6d 65 6c 20 22 20 63 6f l: " fnamel " co
1ca0: 6e 74 65 6e 74 3a 20 22 20 63 6f 6e 74 65 6e 74 ntent: " content
1cb0: 29 20 3b 3b 20 20 22 20 64 61 74 3a 20 22 20 28 ) ;; " dat: " (
1cc0: 64 61 74 29 0a 09 09 09 20 20 28 66 6f 72 6d 64 dat).... (formd
1cd0: 61 74 3a 73 65 74 21 20 66 6f 72 6d 64 61 74 20 at:set! formdat
1ce0: 0a 09 09 09 09 09 6e 61 6d 65 0a 09 09 09 09 09 ......name......
1cf0: 28 69 66 20 66 6e 61 6d 65 6c 20 0a 09 09 09 09 (if fnamel .....
1d00: 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 64 72 . (list (cadr
1d10: 20 66 6e 61 6d 65 6c 29 0a 09 09 09 09 09 09 20 fnamel).......
1d20: 20 28 69 66 20 63 6f 6e 74 65 6e 74 0a 09 09 09 (if content....
1d30: 09 09 09 20 20 20 20 20 20 28 63 61 64 72 20 63 ... (cadr c
1d40: 6f 6e 74 65 6e 74 29 0a 09 09 09 09 09 09 20 20 ontent).......
1d50: 20 20 20 20 22 75 6e 6b 6e 6f 77 6e 22 29 0a 09 "unknown")..
1d60: 09 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d 3e ..... (string->
1d70: 62 6c 6f 62 20 64 61 74 29 29 0a 09 09 09 09 09 blob dat))......
1d80: 20 20 20 20 64 61 74 29 29 29 29 0a 09 09 20 20 dat))))...
1d90: 20 20 20 20 61 6c 6c 64 61 74 73 29 0a 09 20 20 alldats)..
1da0: 20 20 3b 3b 20 68 61 6e 64 6c 65 20 73 69 6e 67 ;; handle sing
1db0: 6c 65 20 70 61 72 74 20 66 6f 72 6d 0a 09 20 20 le part form..
1dc0: 20 20 3b 3b 20 09 28 69 66 20 28 61 6e 64 20 28 ;; .(if (and (
1dd0: 73 74 72 69 6e 67 3f 20 6e 61 6d 65 29 0a 09 20 string? name)..
1de0: 20 20 20 3b 3b 20 09 09 20 20 20 20 20 28 73 74 ;; .. (st
1df0: 72 69 6e 67 3d 3f 20 6e 61 6d 65 20 22 22 29 29 ring=? name ""))
1e00: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
1e10: 73 68 6f 72 74 20 66 6f 72 6d 20 69 6e 70 75 74 short form input
1e20: 20 49 20 67 75 65 73 73 0a 09 20 20 20 20 3b 3b I guess.. ;;
1e30: 20 09 09 28 6c 65 74 2a 20 28 28 64 61 74 73 74 ..(let* ((datst
1e40: 72 20 28 63 61 61 72 20 64 61 74 6c 73 74 29 29 r (caar datlst))
1e50: 0a 09 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 .. ;; ..
1e60: 20 20 28 6d 75 6e 67 65 64 20 28 73 3a 70 72 6f (munged (s:pro
1e70: 63 65 73 73 2d 63 67 69 2d 69 6e 70 75 74 20 64 cess-cgi-input d
1e80: 61 74 73 74 72 29 29 29 0a 09 20 20 20 20 3b 3b atstr))).. ;;
1e90: 20 09 09 20 20 28 70 72 69 6e 74 20 22 64 61 74 .. (print "dat
1ea0: 73 74 72 3a 20 22 20 64 61 74 73 74 72 20 22 20 str: " datstr "
1eb0: 6d 75 6e 67 65 64 3a 20 22 20 6d 75 6e 67 65 64 munged: " munged
1ec0: 29 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 3a ).. (formdat:
1ed0: 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 20 28 73 load formdat (s
1ee0: 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d 69 6e 70 :process-cgi-inp
1ef0: 75 74 20 28 63 61 61 61 72 20 61 6c 6c 64 61 74 ut (caaar alldat
1f00: 73 29 29 29 29 20 3b 3b 20 6d 75 6e 67 65 64 29 s)))) ;; munged)
1f10: 29 0a 09 3b 3b 09 09 20 20 20 20 28 66 6f 72 6d )..;;.. (form
1f20: 61 74 20 64 65 62 75 67 70 20 22 66 6f 72 6d 64 at debugp "formd
1f30: 61 74 20 3a 20 6e 61 6d 65 3a 20 7e 41 20 63 6f at : name: ~A co
1f40: 6e 74 65 6e 74 3a 20 7e 41 5c 6e 22 20 6e 61 6d ntent: ~A\n" nam
1f50: 65 20 63 6f 6e 74 65 6e 74 29 0a 09 3b 3b 20 28 e content)..;; (
1f60: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
1f70: 74 20 64 65 62 75 67 70 29 0a 09 66 6f 72 6d 64 t debugp)..formd
1f80: 61 74 29 29 29 29 0a 09 09 0a 23 7c 0a 28 64 65 at))))....#|.(de
1f90: 66 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 fine inp (open-i
1fa0: 6e 70 75 74 2d 66 69 6c 65 20 22 74 65 73 74 73 nput-file "tests
1fb0: 2f 65 78 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 6e /example.post.in
1fc0: 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 ")).(define dat
1fd0: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 (read-string #f
1fe0: 69 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 61 inp)).(define da
1ff0: 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 tstr (open-input
2000: 2d 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a 3b -string dat))..;
2010: 3b 20 6f 72 0a 0a 28 64 65 66 69 6e 65 20 69 6e ; or..(define in
2020: 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 p (open-input-fi
2030: 6c 65 20 22 74 65 73 74 73 2f 65 78 61 6d 70 6c le "tests/exampl
2040: 65 2e 70 6f 73 74 2e 62 69 6e 61 72 79 2e 69 6e e.post.binary.in
2050: 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 ")).(define dat
2060: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 (read-string #f
2070: 69 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 61 inp)).(define da
2080: 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 tstr (open-input
2090: 2d 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a 28 -string dat))..(
20a0: 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 formdat:read-hea
20b0: 64 65 72 20 64 61 74 73 74 72 29 0a 0a 28 64 65 der datstr)..(de
20c0: 66 69 6e 65 20 64 61 74 20 28 66 6f 72 6d 64 61 fine dat (formda
20d0: 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 t:dat->list inp
20e0: 31 30 65 36 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 10e6)).(close-in
20f0: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 put-port inp).|#
2100: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 . .(define (for
2110: 6d 64 61 74 3a 65 78 74 72 61 63 74 2d 68 65 61 mdat:extract-hea
2120: 64 65 72 2d 69 6e 66 6f 20 68 65 61 64 65 72 29 der-info header)
2130: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 68 65 . (if (null? he
2140: 61 64 65 72 29 0a 20 20 20 20 20 20 27 28 29 0a ader). '().
2150: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
2160: 28 28 68 65 64 20 28 63 61 72 20 68 65 61 64 65 ((hed (car heade
2170: 72 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 r))... (tal (cdr
2180: 20 68 65 61 64 65 72 29 29 0a 09 09 20 28 72 65 header))... (re
2190: 73 20 27 28 29 29 29 0a 09 28 69 66 20 28 73 74 s '()))..(if (st
21a0: 72 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 ring-match formd
21b0: 61 74 3a 62 69 6e 2d 64 61 74 61 2d 64 69 73 70 at:bin-data-disp
21c0: 2d 72 65 78 20 68 65 64 29 20 3b 3b 20 0a 09 20 -rex hed) ;; ..
21d0: 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 61 2d (let* ((data-
21e0: 6e 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 namem (string-ma
21f0: 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d tch formdat:bin-
2200: 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 68 65 data-name-rex he
2210: 64 29 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 6e d))... (file-n
2220: 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 amem (string-mat
2230: 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 ch formdat:bin-f
2240: 69 6c 65 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 ile-name-rex hed
2250: 29 29 0a 09 09 20 20 20 28 64 61 74 61 2d 6e 61 ))... (data-na
2260: 6d 65 20 20 28 69 66 20 64 61 74 61 2d 6e 61 6d me (if data-nam
2270: 65 6d 20 28 63 61 64 72 20 64 61 74 61 2d 6e 61 em (cadr data-na
2280: 6d 65 6d 29 20 23 66 29 29 0a 09 09 20 20 20 28 mem) #f))... (
2290: 74 68 69 73 20 20 20 20 20 20 20 28 69 66 20 66 this (if f
22a0: 69 6c 65 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 20 ile-namem.....
22b0: 20 28 6c 69 73 74 20 28 6c 69 73 74 20 27 6e 61 (list (list 'na
22c0: 6d 65 20 64 61 74 61 2d 6e 61 6d 65 29 28 6c 69 me data-name)(li
22d0: 73 74 20 27 66 69 6c 65 6e 61 6d 65 20 28 63 61 st 'filename (ca
22e0: 64 72 20 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 29 dr file-namem)))
22f0: 0a 09 09 09 09 20 20 20 28 6c 69 73 74 20 28 6c ..... (list (l
2300: 69 73 74 20 27 6e 61 6d 65 20 64 61 74 61 2d 6e ist 'name data-n
2310: 61 6d 65 29 29 29 29 29 0a 09 20 20 20 20 20 20 ame)))))..
2320: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
2330: 09 09 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 .. (append res
2340: 74 68 69 73 29 0a 09 09 20 20 28 6c 6f 6f 70 20 this)... (loop
2350: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
2360: 6c 29 28 61 70 70 65 6e 64 20 72 65 73 20 74 68 l)(append res th
2370: 69 73 29 29 29 29 0a 09 20 20 20 20 28 6c 65 74 is)))).. (let
2380: 20 28 28 63 6f 6e 74 65 6e 74 20 28 73 74 72 69 ((content (stri
2390: 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 ng-match formdat
23a0: 3a 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 :bin-file-type-r
23b0: 65 78 20 68 65 64 29 29 29 20 3b 3b 20 74 68 69 ex hed))) ;; thi
23c0: 73 20 69 73 20 74 68 65 20 73 74 61 6e 7a 61 20 s is the stanza
23d0: 66 6f 72 20 74 68 65 20 63 6f 6e 74 65 6e 74 20 for the content
23e0: 74 79 70 65 0a 09 20 20 20 20 20 20 28 69 66 20 type.. (if
23f0: 63 6f 6e 74 65 6e 74 0a 09 09 20 20 28 6c 65 74 content... (let
2400: 20 28 28 6e 65 77 72 65 73 20 28 63 6f 6e 73 20 ((newres (cons
2410: 28 6c 69 73 74 20 27 63 6f 6e 74 65 6e 74 20 28 (list 'content (
2420: 63 61 64 72 20 63 6f 6e 74 65 6e 74 29 29 20 72 cadr content)) r
2430: 65 73 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 es)))... (if
2440: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 6e (null? tal)....n
2450: 65 77 72 65 73 0a 09 09 09 28 6c 6f 6f 70 20 28 ewres....(loop (
2460: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
2470: 29 20 6e 65 77 72 65 73 29 29 29 0a 09 09 20 20 ) newres)))...
2480: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
2490: 09 09 20 20 20 20 20 20 72 65 73 0a 09 09 20 20 .. res...
24a0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
24b0: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 73 al)(cdr tal) res
24c0: 29 0a 09 09 20 20 20 20 20 20 29 29 29 29 29 29 )... ))))))
24d0: 29 0a 0a 3b 3b 09 20 20 20 20 20 20 28 6c 65 74 )..;;. (let
24e0: 20 6c 6f 6f 70 20 28 28 6c 20 20 20 20 20 20 20 loop ((l
24f0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 20 3b 3b 20 (read-line)) ;;
2500: 28 69 66 20 28 65 71 3f 20 6d 6f 64 65 20 27 6e (if (eq? mode 'n
2510: 6f 72 6d 29 28 72 65 61 64 2d 6c 69 6e 65 29 28 orm)(read-line)(
2520: 72 65 61 64 2d 63 68 61 72 29 29 29 0a 3b 3b 09 read-char))).;;.
2530: 09 09 20 28 65 6e 64 6c 69 6e 65 20 23 66 29 0a .. (endline #f).
2540: 3b 3b 09 09 09 20 28 6e 75 6d 20 20 20 20 20 30 ;;... (num 0
2550: 29 29 0a 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 61 )).;;..;; (forma
2560: 74 20 64 65 62 75 67 70 20 22 7e 41 5c 6e 22 20 t debugp "~A\n"
2570: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
2580: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
2590: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 29 (eof-object? l))
25a0: 0a 3b 3b 09 09 20 20 20 20 20 20 28 6e 6f 74 20 .;;.. (not
25b0: 28 61 6e 64 20 28 65 71 3f 20 6d 6f 64 65 20 27 (and (eq? mode '
25c0: 62 69 6e 29 0a 3b 3b 09 09 09 09 28 73 74 72 69 bin).;;....(stri
25d0: 6e 67 3d 3f 20 6c 20 22 22 29 29 29 29 20 3b 3b ng=? l "")))) ;;
25e0: 20 69 66 20 69 6e 20 62 69 6e 20 6d 6f 64 65 20 if in bin mode
25f0: 65 6d 70 74 79 20 73 74 72 69 6e 67 20 69 73 20 empty string is
2600: 65 6e 64 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 09 end of file.;;..
2610: 20 20 28 63 61 73 65 20 6d 6f 64 65 0a 3b 3b 09 (case mode.;;.
2620: 09 20 20 20 20 28 28 73 74 61 72 74 29 0a 3b 3b . ((start).;;
2630: 09 09 20 20 20 20 20 28 73 65 74 21 20 6d 6f 64 .. (set! mod
2640: 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 e 'norm).;;..
2650: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
2660: 74 63 68 20 64 65 6c 69 6d 2d 70 61 74 74 2d 72 tch delim-patt-r
2670: 65 78 20 6c 29 0a 3b 3b 09 09 09 20 28 62 65 67 ex l).;;... (beg
2680: 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 21 in.;;... (set!
2690: 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 6c 29 delim-string l)
26a0: 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 64 .;;... (set! d
26b0: 65 6c 69 6d 2d 6c 65 6e 20 20 20 20 28 73 74 72 elim-len (str
26c0: 69 6e 67 2d 6c 65 6e 67 74 68 20 6c 29 29 0a 3b ing-length l)).;
26d0: 3b 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 ;... (loop (re
26e0: 61 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 0a ad-line) #f 0)).
26f0: 3b 3b 09 09 09 20 28 6c 6f 6f 70 20 6c 20 23 66 ;;... (loop l #f
2700: 20 30 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 0))).;;.. ((
2710: 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 3b norm).;;.. ;
2720: 3b 20 49 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 ; I don't like h
2730: 6f 77 20 74 68 69 73 20 67 65 74 73 20 63 68 65 ow this gets che
2740: 63 6b 65 64 20 6f 6e 20 65 76 65 72 79 20 73 69 cked on every si
2750: 6e 67 6c 65 20 69 6e 70 75 74 2e 20 4d 75 73 74 ngle input. Must
2760: 20 62 65 20 61 20 62 65 74 74 65 72 20 77 61 79 be a better way
2770: 2e 20 46 49 58 4d 45 0a 3b 3b 09 09 20 20 20 20 . FIXME.;;..
2780: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
2790: 67 2d 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 61 g-match bin-data
27a0: 2d 64 69 73 70 2d 72 65 78 20 6c 29 0a 3b 3b 09 -disp-rex l).;;.
27b0: 09 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
27c0: 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e match bin-data-n
27d0: 61 6d 65 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 ame-rex l).;;...
27e0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 (string-ma
27f0: 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d tch bin-file-nam
2800: 65 2d 72 65 78 20 6c 29 29 0a 3b 3b 09 09 09 20 e-rex l)).;;...
2810: 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 (begin.;;... (
2820: 73 65 74 21 20 64 61 74 61 2d 6e 61 6d 65 20 28 set! data-name (
2830: 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 cadr (string-mat
2840: 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 ch bin-data-name
2850: 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 -rex l))).;;...
2860: 20 20 28 73 65 74 21 20 66 69 6c 65 2d 6e 61 6d (set! file-nam
2870: 65 20 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d e (cadr (string-
2880: 6d 61 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e match bin-file-n
2890: 61 6d 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 ame-rex l))).;;.
28a0: 09 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 .. (set! mode
28b0: 27 63 6f 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 20 'content).;;...
28c0: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
28d0: 6e 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b ne) #f num))).;;
28e0: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 .. (let* ((d
28f0: 61 74 20 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 at (s:process-c
2900: 67 69 2d 69 6e 70 75 74 20 6c 29 29 29 20 3b 3b gi-input l))) ;;
2910: 20 28 43 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 (CGI:url-unquot
2920: 65 20 6c 29 29 0a 3b 3b 09 09 20 20 20 20 20 20 e l)).;;..
2930: 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 (format debugp
2940: 22 50 52 4f 43 45 53 53 2d 43 47 49 2d 49 4e 50 "PROCESS-CGI-INP
2950: 55 54 3a 20 7e 41 5c 6e 22 20 28 69 6e 74 65 72 UT: ~A\n" (inter
2960: 73 70 65 72 73 65 20 64 61 74 20 22 2c 22 29 29 sperse dat ","))
2970: 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 66 6f 72 .;;.. (for
2980: 6d 64 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 mdat:load formda
2990: 74 20 64 61 74 29 0a 3b 3b 09 09 20 20 20 20 20 t dat).;;..
29a0: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
29b0: 6e 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b ne) #f num))).;;
29c0: 09 09 20 20 20 20 28 28 63 6f 6e 74 65 6e 74 29 .. ((content)
29d0: 0a 3b 3b 09 09 20 20 20 20 20 28 69 66 20 28 73 .;;.. (if (s
29e0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d tring-match bin-
29f0: 66 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 6c 29 file-type-rex l)
2a00: 0a 3b 3b 09 09 09 20 28 62 65 67 69 6e 20 0a 3b .;;... (begin .;
2a10: 3b 09 09 09 20 20 20 28 73 65 74 21 20 6d 6f 64 ;... (set! mod
2a20: 65 20 27 62 69 6e 29 0a 3b 3b 09 09 09 20 20 20 e 'bin).;;...
2a30: 28 73 65 74 21 20 64 61 74 61 2d 74 79 70 65 20 (set! data-type
2a40: 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 (cadr (string-ma
2a50: 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 74 79 70 tch bin-file-typ
2a60: 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 e-rex l))).;;...
2a70: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 73 (loop (read-s
2a80: 74 72 69 6e 67 20 31 29 20 23 66 20 6e 75 6d 29 tring 1) #f num)
2a90: 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 62 69 ))).;;.. ((bi
2aa0: 6e 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 64 n).;;.. ;; d
2ab0: 65 6c 69 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e 22 elim-string: \n"
2ac0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 ---------------1
2ad0: 32 33 34 35 22 0a 3b 3b 09 09 20 20 20 20 20 3b 2345".;;.. ;
2ae0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
2af0: 20 20 20 30 31 32 33 34 35 36 37 38 39 30 31 32 0123456789012
2b00: 33 34 35 36 37 38 39 30 0a 3b 3b 09 09 20 20 20 34567890.;;..
2b10: 20 20 3b 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 20 ;; endline:
2b20: 20 20 20 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "----------
2b30: 2d 2d 2d 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 20 -----12".;;..
2b40: 20 20 3b 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b 09 ;; l = "3".;;.
2b50: 09 20 20 20 20 20 3b 3b 20 64 65 6c 69 6d 2d 6c . ;; delim-l
2b60: 65 6e 20 3d 20 32 30 0a 3b 3b 09 09 20 20 20 20 en = 20.;;..
2b70: 20 3b 3b 20 28 73 75 62 73 74 72 69 6e 67 20 20 ;; (substring
2b80: 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "---------------
2b90: 31 32 33 34 35 22 20 31 37 20 31 38 29 20 3d 3e 12345" 17 18) =>
2ba0: 20 22 33 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b "3".;;.. ;;
2bb0: 0a 3b 3b 09 09 20 20 20 20 20 28 63 6f 6e 64 0a .;;.. (cond.
2bc0: 3b 3b 09 09 20 20 20 20 20 20 20 3b 3b 20 68 61 ;;.. ;; ha
2bd0: 76 65 6e 27 74 20 66 6f 75 6e 64 20 74 68 65 20 ven't found the
2be0: 73 74 61 72 74 20 6f 66 20 61 6e 20 65 6e 64 6c start of an endl
2bf0: 69 6e 65 2c 20 69 73 20 74 68 65 20 6e 65 78 74 ine, is the next
2c00: 20 63 68 61 72 20 61 20 6e 65 77 6c 69 6e 65 3f char a newline?
2c10: 0a 3b 3b 09 09 20 20 20 20 20 20 28 28 61 6e 64 .;;.. ((and
2c20: 20 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 29 0a 3b (not endline).;
2c30: 3b 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 3d ;... (string=
2c40: 3f 20 6c 20 22 5c 6e 22 29 29 20 3b 3b 20 72 65 ? l "\n")) ;; re
2c50: 71 75 69 72 65 64 20 66 69 72 73 74 20 63 68 61 quired first cha
2c60: 72 61 63 74 65 72 20 0a 3b 3b 09 09 20 20 20 20 racter .;;..
2c70: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 65 6e 64 (let ((newend
2c80: 6c 69 6e 65 20 28 6f 70 65 6e 2d 6f 75 74 70 75 line (open-outpu
2c90: 74 2d 73 74 72 69 6e 67 29 29 29 0a 3b 3b 09 09 t-string))).;;..
2ca0: 09 20 3b 3b 20 28 77 72 69 74 65 2d 6c 69 6e 65 . ;; (write-line
2cb0: 20 6c 20 6e 65 77 65 6e 64 6c 69 6e 65 29 20 3b l newendline) ;
2cc0: 3b 20 64 69 73 63 61 72 64 20 74 68 65 20 6e 65 ; discard the ne
2cd0: 77 6c 69 6e 65 2e 20 61 64 64 20 69 74 20 62 61 wline. add it ba
2ce0: 63 6b 20 69 66 20 64 6f 6e 27 74 20 68 61 76 65 ck if don't have
2cf0: 20 61 20 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 6d a lock on delim
2d00: 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 28 6c -string.;;... (l
2d10: 6f 6f 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 oop (read-string
2d20: 20 31 29 20 6e 65 77 65 6e 64 6c 69 6e 65 20 28 1) newendline (
2d30: 2b 20 6e 75 6d 20 31 29 29 29 29 0a 3b 3b 09 09 + num 1)))).;;..
2d40: 20 20 20 20 20 20 28 28 6e 6f 74 20 65 6e 64 6c ((not endl
2d50: 69 6e 65 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 ine).;;..
2d60: 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c 20 (write-string l
2d70: 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 #f bin-dat).;;..
2d80: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 (loop (re
2d90: 61 64 2d 73 74 72 69 6e 67 20 31 29 20 23 66 20 ad-string 1) #f
2da0: 28 2b 20 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 09 (+ num 1))).;;..
2db0: 20 20 20 20 20 20 3b 3b 20 73 74 72 69 6e 67 20 ;; string
2dc0: 73 6f 20 66 61 72 20 6d 61 74 63 68 65 73 20 64 so far matches d
2dd0: 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 elim-string.;;..
2de0: 20 20 20 20 20 20 28 65 6e 64 6c 69 6e 65 0a 3b (endline.;
2df0: 3b 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ;.. (let*
2e00: 28 28 65 6e 64 73 74 72 20 28 67 65 74 2d 6f 75 ((endstr (get-ou
2e10: 74 70 75 74 2d 73 74 72 69 6e 67 20 65 6e 64 6c tput-string endl
2e20: 69 6e 65 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 ine)).;;...
2e30: 20 28 65 6e 64 6c 65 6e 20 28 73 74 72 69 6e 67 (endlen (string
2e40: 2d 6c 65 6e 67 74 68 20 65 6e 64 73 74 72 29 29 -length endstr))
2e50: 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 3e 20 65 ).;;... (if (> e
2e60: 6e 64 6c 65 6e 20 30 29 0a 3b 3b 09 09 09 20 20 ndlen 0).;;...
2e70: 20 20 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 (format debug
2e80: 70 20 22 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e 65 p " delim: ~A\ne
2e90: 6e 64 73 74 72 3a 20 7e 41 5c 6e 22 20 64 65 6c ndstr: ~A\n" del
2ea0: 69 6d 2d 73 74 72 69 6e 67 20 65 6e 64 73 74 72 im-string endstr
2eb0: 29 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 61 6e )).;;... (if (an
2ec0: 64 20 28 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 d (> delim-len e
2ed0: 6e 64 6c 65 6e 29 0a 3b 3b 09 09 09 09 20 20 28 ndlen).;;.... (
2ee0: 73 74 72 69 6e 67 3d 3f 20 6c 20 28 73 75 62 73 string=? l (subs
2ef0: 74 72 69 6e 67 20 64 65 6c 69 6d 2d 73 74 72 69 tring delim-stri
2f00: 6e 67 20 65 6e 64 6c 65 6e 20 28 2b 20 65 6e 64 ng endlen (+ end
2f10: 6c 65 6e 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 len 1)))).;;...
2f20: 20 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 ;; yes, this
2f30: 20 63 68 61 72 61 63 74 65 72 20 6d 61 74 63 68 character match
2f40: 65 73 20 74 68 65 20 6e 65 78 74 20 69 6e 20 74 es the next in t
2f50: 68 65 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a he delim-string.
2f60: 3b 3b 09 09 09 20 20 20 20 20 28 69 66 20 28 65 ;;... (if (e
2f70: 71 3f 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 q? delim-len end
2f80: 6c 65 6e 29 20 3b 3b 20 68 61 76 65 20 61 20 6d len) ;; have a m
2f90: 61 74 63 68 21 20 49 67 6e 6f 72 65 20 74 68 61 atch! Ignore tha
2fa0: 74 20 61 20 6e 65 77 6c 69 6e 65 20 69 73 20 72 t a newline is r
2fb0: 65 71 75 69 72 65 64 2e 20 4c 61 7a 79 20 62 75 equired. Lazy bu
2fc0: 67 67 65 72 2e 0a 3b 3b 09 09 09 09 20 28 6c 65 gger..;;.... (le
2fd0: 74 2a 20 28 28 66 6e 20 20 20 20 20 20 28 73 74 t* ((fn (st
2fe0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 74 ring->symbol dat
2ff0: 61 2d 6e 61 6d 65 29 29 29 0a 3b 3b 09 09 09 09 a-name))).;;....
3000: 20 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 (formdat:set!
3010: 20 66 6f 72 6d 64 61 74 20 66 6e 20 28 6c 69 73 formdat fn (lis
3020: 74 20 66 69 6c 65 2d 6e 61 6d 65 20 64 61 74 61 t file-name data
3030: 2d 74 79 70 65 20 28 73 74 72 69 6e 67 2d 3e 62 -type (string->b
3040: 6c 6f 62 20 28 67 65 74 2d 6f 75 74 70 75 74 2d lob (get-output-
3050: 73 74 72 69 6e 67 20 62 69 6e 2d 64 61 74 29 29 string bin-dat))
3060: 29 29 0a 3b 3b 09 09 09 09 20 20 20 28 73 65 74 )).;;.... (set
3070: 21 20 6d 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b ! mode 'norm).;;
3080: 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 .... (loop (re
3090: 61 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 0a ad-line) #f 0)).
30a0: 3b 3b 09 09 09 09 20 28 62 65 67 69 6e 0a 3b 3b ;;.... (begin.;;
30b0: 09 09 09 09 20 20 20 28 77 72 69 74 65 2d 73 74 .... (write-st
30c0: 72 69 6e 67 20 6c 20 23 66 20 65 6e 64 6c 69 6e ring l #f endlin
30d0: 65 29 0a 3b 3b 09 09 09 09 20 20 20 28 6c 6f 6f e).;;.... (loo
30e0: 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 p (read-string 1
30f0: 29 20 65 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 6d ) endline (+ num
3100: 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 1)))).;;...
3110: 20 3b 3b 20 6e 6f 2c 20 74 68 69 73 20 63 68 61 ;; no, this cha
3120: 72 61 63 74 65 72 20 64 6f 65 73 20 4e 4f 54 20 racter does NOT
3130: 6d 61 74 63 68 20 74 68 65 20 6e 65 78 74 20 69 match the next i
3140: 6e 20 6c 69 6e 65 20 69 6e 20 64 65 6c 69 6d 2d n line in delim-
3150: 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 20 20 20 string.;;...
3160: 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 (begin.;;...
3170: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
3180: 67 20 22 5c 6e 22 20 23 66 20 62 69 6e 2d 64 61 g "\n" #f bin-da
3190: 74 29 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 67 t) ;; don't forg
31a0: 65 74 20 74 68 61 74 20 6e 65 77 6c 69 6e 65 20 et that newline
31b0: 77 65 20 64 72 6f 70 70 65 64 0a 3b 3b 09 09 09 we dropped.;;...
31c0: 20 20 20 20 20 20 20 28 77 72 69 74 65 2d 73 74 (write-st
31d0: 72 69 6e 67 20 65 6e 64 73 74 72 20 23 66 20 62 ring endstr #f b
31e0: 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 09 20 20 20 in-dat).;;...
31f0: 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e (write-strin
3200: 67 20 6c 20 23 66 20 62 69 6e 2d 64 61 74 29 0a g l #f bin-dat).
3210: 3b 3b 09 09 09 20 20 20 20 20 20 20 28 6c 6f 6f ;;... (loo
3220: 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 p (read-string 1
3230: 29 20 23 66 20 28 2b 20 6e 75 6d 20 31 29 29 29 ) #f (+ num 1)))
3240: 29 29 29 29 29 0a 3b 3b 09 09 20 20 20 20 29 29 ))))).;;.. ))
3250: 29 29 29 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 6d )))..;; (form
3260: 64 61 74 3a 70 72 69 6e 74 61 6c 6c 20 66 6f 72 dat:printall for
3270: 6d 64 61 74 20 28 6c 61 6d 62 64 61 20 28 78 29 mdat (lambda (x)
3280: 28 77 72 69 74 65 2d 6c 69 6e 65 20 78 20 64 65 (write-line x de
3290: 62 75 67 70 29 29 29 0a 0a 23 7c 0a 28 64 65 66 bugp)))..#|.(def
32a0: 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e ine inp (open-in
32b0: 70 75 74 2d 66 69 6c 65 20 22 2f 74 6d 70 2f 73 put-file "/tmp/s
32c0: 74 6d 6c 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 2e tmlrun/delme-33.
32d0: 6c 6f 67 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 66 log.keep-for-ref
32e0: 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 ")).(define dat
32f0: 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 (read-string #f
3300: 69 6e 70 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 inp)).(close-inp
3310: 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a ut-port inp).|#.