Artifact
05ad5e414c1c63289a6bdfee8e7ed792f12081af:
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 6c 65 74 20 28 28 61 6c 6c ). (let ((all
19a0: 64 61 74 73 20 28 66 6f 72 6d 64 61 74 3a 64 61 dats (formdat:da
19b0: 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 30 65 36 t->list inp 10e6
19c0: 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 ))). .
19d0: 20 3b 3b 20 28 66 6f 72 6d 61 74 20 64 65 62 75 ;; (format debu
19e0: 67 70 20 22 66 6f 72 6d 64 61 74 20 3a 20 61 6c gp "formdat : al
19f0: 6c 64 61 74 73 3a 20 7e 41 5c 6e 22 20 61 6c 6c ldats: ~A\n" all
1a00: 64 61 74 73 29 0a 20 20 20 20 20 20 28 6c 65 74 dats). (let
1a10: 20 28 28 66 69 72 73 74 69 74 65 6d 20 20 20 28 ((firstitem (
1a20: 63 61 72 20 61 6c 6c 64 61 74 73 29 29 0a 09 20 car alldats))..
1a30: 20 20 20 28 6d 75 6c 74 69 70 61 73 73 20 23 66 (multipass #f
1a40: 29 29 20 0a 09 28 69 66 20 28 6e 6f 74 20 28 6e )) ..(if (not (n
1a50: 75 6c 6c 3f 20 66 69 72 73 74 69 74 65 6d 29 29 ull? firstitem))
1a60: 0a 09 20 20 20 20 28 69 66 20 28 73 74 72 69 6e .. (if (strin
1a70: 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a g-match formdat:
1a80: 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 20 28 delim-patt-rex (
1a90: 63 61 61 72 20 66 69 72 73 74 69 74 65 6d 29 29 caar firstitem))
1aa0: 0a 09 09 28 73 65 74 21 20 6d 75 6c 74 69 70 61 ...(set! multipa
1ab0: 73 73 20 23 74 29 29 29 0a 09 28 69 66 20 6d 75 ss #t)))..(if mu
1ac0: 6c 74 69 70 61 73 73 0a 09 20 20 20 20 3b 3b 20 ltipass.. ;;
1ad0: 68 61 6e 64 6c 65 20 6d 75 6c 74 69 2d 70 61 72 handle multi-par
1ae0: 74 20 66 6f 72 6d 0a 09 20 20 20 20 28 66 6f 72 t form.. (for
1af0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 64 -each (lambda (d
1b00: 61 74 6c 73 74 29 0a 09 09 09 28 6c 65 74 2a 20 atlst)....(let*
1b10: 28 28 68 65 61 64 65 72 20 28 66 6f 72 6d 64 61 ((header (formda
1b20: 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 65 72 t:extract-header
1b30: 2d 69 6e 66 6f 20 28 63 61 72 20 64 61 74 6c 73 -info (car datls
1b40: 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 t))).... (
1b50: 6e 61 6d 65 20 20 20 28 69 66 20 28 61 73 73 6f name (if (asso
1b60: 63 20 27 6e 61 6d 65 20 68 65 61 64 65 72 29 0a c 'name header).
1b70: 09 09 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d ..... (string-
1b80: 3e 73 79 6d 62 6f 6c 20 28 63 61 64 72 20 28 61 >symbol (cadr (a
1b90: 73 73 6f 63 20 27 6e 61 6d 65 20 68 65 61 64 65 ssoc 'name heade
1ba0: 72 29 29 29 0a 09 09 09 09 09 20 20 20 22 22 29 r)))...... "")
1bb0: 29 20 3b 3b 20 67 72 75 6d 62 6c 65 0a 09 09 09 ) ;; grumble....
1bc0: 20 20 20 20 20 20 20 28 66 6e 61 6d 65 6c 20 20 (fnamel
1bd0: 28 61 73 73 6f 63 20 27 66 69 6c 65 6e 61 6d 65 (assoc 'filename
1be0: 20 68 65 61 64 65 72 29 29 0a 09 09 09 20 20 20 header))....
1bf0: 20 20 20 20 28 63 6f 6e 74 65 6e 74 20 28 61 73 (content (as
1c00: 73 6f 63 20 27 63 6f 6e 74 65 6e 74 20 68 65 61 soc 'content hea
1c10: 64 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 20 der))....
1c20: 28 64 61 74 20 20 20 20 28 63 61 64 72 20 64 61 (dat (cadr da
1c30: 74 6c 73 74 29 29 29 0a 09 09 09 20 20 3b 3b 20 tlst))).... ;;
1c40: 28 70 72 69 6e 74 20 22 68 65 61 64 65 72 3a 20 (print "header:
1c50: 22 20 68 65 61 64 65 72 20 22 20 6e 61 6d 65 3a " header " name:
1c60: 20 22 20 6e 61 6d 65 20 22 20 66 6e 61 6d 65 6c " name " fnamel
1c70: 3a 20 22 20 66 6e 61 6d 65 6c 20 22 20 63 6f 6e : " fnamel " con
1c80: 74 65 6e 74 3a 20 22 20 63 6f 6e 74 65 6e 74 29 tent: " content)
1c90: 20 3b 3b 20 20 22 20 64 61 74 3a 20 22 20 28 64 ;; " dat: " (d
1ca0: 61 74 29 0a 09 09 09 20 20 28 66 6f 72 6d 64 61 at).... (formda
1cb0: 74 3a 73 65 74 21 20 66 6f 72 6d 64 61 74 20 0a t:set! formdat .
1cc0: 09 09 09 09 09 6e 61 6d 65 0a 09 09 09 09 09 28 .....name......(
1cd0: 69 66 20 66 6e 61 6d 65 6c 20 0a 09 09 09 09 09 if fnamel ......
1ce0: 20 20 20 20 28 6c 69 73 74 20 28 63 61 64 72 20 (list (cadr
1cf0: 66 6e 61 6d 65 6c 29 0a 09 09 09 09 09 09 20 20 fnamel).......
1d00: 28 69 66 20 63 6f 6e 74 65 6e 74 0a 09 09 09 09 (if content.....
1d10: 09 09 20 20 20 20 20 20 28 63 61 64 72 20 63 6f .. (cadr co
1d20: 6e 74 65 6e 74 29 0a 09 09 09 09 09 09 20 20 20 ntent).......
1d30: 20 20 20 22 75 6e 6b 6e 6f 77 6e 22 29 0a 09 09 "unknown")...
1d40: 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d 3e 62 .... (string->b
1d50: 6c 6f 62 20 64 61 74 29 29 0a 09 09 09 09 09 20 lob dat))......
1d60: 20 20 20 64 61 74 29 29 29 29 0a 09 09 20 20 20 dat))))...
1d70: 20 20 20 61 6c 6c 64 61 74 73 29 0a 09 20 20 20 alldats)..
1d80: 20 3b 3b 20 68 61 6e 64 6c 65 20 73 69 6e 67 6c ;; handle singl
1d90: 65 20 70 61 72 74 20 66 6f 72 6d 0a 09 20 20 20 e part form..
1da0: 20 3b 3b 20 09 28 69 66 20 28 61 6e 64 20 28 73 ;; .(if (and (s
1db0: 74 72 69 6e 67 3f 20 6e 61 6d 65 29 0a 09 20 20 tring? name)..
1dc0: 20 20 3b 3b 20 09 09 20 20 20 20 20 28 73 74 72 ;; .. (str
1dd0: 69 6e 67 3d 3f 20 6e 61 6d 65 20 22 22 29 29 20 ing=? name ""))
1de0: 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 73 ;; this is the s
1df0: 68 6f 72 74 20 66 6f 72 6d 20 69 6e 70 75 74 20 hort form input
1e00: 49 20 67 75 65 73 73 0a 09 20 20 20 20 3b 3b 20 I guess.. ;;
1e10: 09 09 28 6c 65 74 2a 20 28 28 64 61 74 73 74 72 ..(let* ((datstr
1e20: 20 28 63 61 61 72 20 64 61 74 6c 73 74 29 29 0a (caar datlst)).
1e30: 09 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 20 . ;; ..
1e40: 20 28 6d 75 6e 67 65 64 20 28 73 3a 70 72 6f 63 (munged (s:proc
1e50: 65 73 73 2d 63 67 69 2d 69 6e 70 75 74 20 64 61 ess-cgi-input da
1e60: 74 73 74 72 29 29 29 0a 09 20 20 20 20 3b 3b 20 tstr))).. ;;
1e70: 09 09 20 20 28 70 72 69 6e 74 20 22 64 61 74 73 .. (print "dats
1e80: 74 72 3a 20 22 20 64 61 74 73 74 72 20 22 20 6d tr: " datstr " m
1e90: 75 6e 67 65 64 3a 20 22 20 6d 75 6e 67 65 64 29 unged: " munged)
1ea0: 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 3a 6c .. (formdat:l
1eb0: 6f 61 64 20 66 6f 72 6d 64 61 74 20 20 28 73 3a oad formdat (s:
1ec0: 70 72 6f 63 65 73 73 2d 63 67 69 2d 69 6e 70 75 process-cgi-inpu
1ed0: 74 20 28 63 61 61 61 72 20 61 6c 6c 64 61 74 73 t (caaar alldats
1ee0: 29 29 29 29 20 3b 3b 20 6d 75 6e 67 65 64 29 29 )))) ;; munged))
1ef0: 0a 09 3b 3b 09 09 20 20 20 20 28 66 6f 72 6d 61 ..;;.. (forma
1f00: 74 20 64 65 62 75 67 70 20 22 66 6f 72 6d 64 61 t debugp "formda
1f10: 74 20 3a 20 6e 61 6d 65 3a 20 7e 41 20 63 6f 6e t : name: ~A con
1f20: 74 65 6e 74 3a 20 7e 41 5c 6e 22 20 6e 61 6d 65 tent: ~A\n" name
1f30: 20 63 6f 6e 74 65 6e 74 29 0a 09 3b 3b 20 28 63 content)..;; (c
1f40: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
1f50: 20 64 65 62 75 67 70 29 0a 09 66 6f 72 6d 64 61 debugp)..formda
1f60: 74 29 29 29 29 0a 09 09 0a 23 7c 0a 28 64 65 66 t))))....#|.(def
1f70: 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e ine inp (open-in
1f80: 70 75 74 2d 66 69 6c 65 20 22 74 65 73 74 73 2f put-file "tests/
1f90: 65 78 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 6e 22 example.post.in"
1fa0: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 )).(define dat (
1fb0: 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 read-string #f i
1fc0: 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 np)).(define dat
1fd0: 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d str (open-input-
1fe0: 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a 3b 3b string dat))..;;
1ff0: 20 6f 72 0a 0a 28 64 65 66 69 6e 65 20 69 6e 70 or..(define inp
2000: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c (open-input-fil
2010: 65 20 22 74 65 73 74 73 2f 65 78 61 6d 70 6c 65 e "tests/example
2020: 2e 70 6f 73 74 2e 62 69 6e 61 72 79 2e 69 6e 22 .post.binary.in"
2030: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 )).(define dat (
2040: 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 read-string #f i
2050: 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 np)).(define dat
2060: 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d str (open-input-
2070: 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a 28 66 string dat))..(f
2080: 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 64 ormdat:read-head
2090: 65 72 20 64 61 74 73 74 72 29 0a 0a 28 64 65 66 er datstr)..(def
20a0: 69 6e 65 20 64 61 74 20 28 66 6f 72 6d 64 61 74 ine dat (formdat
20b0: 3a 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 :dat->list inp 1
20c0: 30 65 36 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 0e6)).(close-inp
20d0: 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a ut-port inp).|#.
20e0: 20 20 0a 28 64 65 66 69 6e 65 20 28 66 6f 72 6d .(define (form
20f0: 64 61 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 dat:extract-head
2100: 65 72 2d 69 6e 66 6f 20 68 65 61 64 65 72 29 0a er-info header).
2110: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 68 65 61 (if (null? hea
2120: 64 65 72 29 0a 20 20 20 20 20 20 27 28 29 0a 20 der). '().
2130: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
2140: 28 68 65 64 20 28 63 61 72 20 68 65 61 64 65 72 (hed (car header
2150: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
2160: 68 65 61 64 65 72 29 29 0a 09 09 20 28 72 65 73 header))... (res
2170: 20 27 28 29 29 29 0a 09 28 69 66 20 28 73 74 72 '()))..(if (str
2180: 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 ing-match formda
2190: 74 3a 62 69 6e 2d 64 61 74 61 2d 64 69 73 70 2d t:bin-data-disp-
21a0: 72 65 78 20 68 65 64 29 20 3b 3b 20 0a 09 20 20 rex hed) ;; ..
21b0: 20 20 28 6c 65 74 2a 20 28 28 64 61 74 61 2d 6e (let* ((data-n
21c0: 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 amem (string-mat
21d0: 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 ch formdat:bin-d
21e0: 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 ata-name-rex hed
21f0: 29 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 6e 61 ))... (file-na
2200: 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 mem (string-matc
2210: 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 66 69 h formdat:bin-fi
2220: 6c 65 2d 6e 61 6d 65 2d 72 65 78 20 68 65 64 29 le-name-rex hed)
2230: 29 0a 09 09 20 20 20 28 64 61 74 61 2d 6e 61 6d )... (data-nam
2240: 65 20 20 28 69 66 20 64 61 74 61 2d 6e 61 6d 65 e (if data-name
2250: 6d 20 28 63 61 64 72 20 64 61 74 61 2d 6e 61 6d m (cadr data-nam
2260: 65 6d 29 20 23 66 29 29 0a 09 09 20 20 20 28 74 em) #f))... (t
2270: 68 69 73 20 20 20 20 20 20 20 28 69 66 20 66 69 his (if fi
2280: 6c 65 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 20 20 le-namem.....
2290: 28 6c 69 73 74 20 28 6c 69 73 74 20 27 6e 61 6d (list (list 'nam
22a0: 65 20 64 61 74 61 2d 6e 61 6d 65 29 28 6c 69 73 e data-name)(lis
22b0: 74 20 27 66 69 6c 65 6e 61 6d 65 20 28 63 61 64 t 'filename (cad
22c0: 72 20 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 29 0a r file-namem))).
22d0: 09 09 09 09 20 20 20 28 6c 69 73 74 20 28 6c 69 .... (list (li
22e0: 73 74 20 27 6e 61 6d 65 20 64 61 74 61 2d 6e 61 st 'name data-na
22f0: 6d 65 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 me))))).. (
2300: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
2310: 09 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 . (append res t
2320: 68 69 73 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 his)... (loop (
2330: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
2340: 29 28 61 70 70 65 6e 64 20 72 65 73 20 74 68 69 )(append res thi
2350: 73 29 29 29 29 0a 09 20 20 20 20 28 6c 65 74 20 s)))).. (let
2360: 28 28 63 6f 6e 74 65 6e 74 20 28 73 74 72 69 6e ((content (strin
2370: 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 74 3a g-match formdat:
2380: 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d 72 65 bin-file-type-re
2390: 78 20 68 65 64 29 29 29 20 3b 3b 20 74 68 69 73 x hed))) ;; this
23a0: 20 69 73 20 74 68 65 20 73 74 61 6e 7a 61 20 66 is the stanza f
23b0: 6f 72 20 74 68 65 20 63 6f 6e 74 65 6e 74 20 74 or the content t
23c0: 79 70 65 0a 09 20 20 20 20 20 20 28 69 66 20 63 ype.. (if c
23d0: 6f 6e 74 65 6e 74 0a 09 09 20 20 28 6c 65 74 20 ontent... (let
23e0: 28 28 6e 65 77 72 65 73 20 28 63 6f 6e 73 20 28 ((newres (cons (
23f0: 6c 69 73 74 20 27 63 6f 6e 74 65 6e 74 20 28 63 list 'content (c
2400: 61 64 72 20 63 6f 6e 74 65 6e 74 29 29 20 72 65 adr content)) re
2410: 73 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 s)))... (if (
2420: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 6e 65 null? tal)....ne
2430: 77 72 65 73 0a 09 09 09 28 6c 6f 6f 70 20 28 63 wres....(loop (c
2440: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
2450: 20 6e 65 77 72 65 73 29 29 29 0a 09 09 20 20 28 newres)))... (
2460: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
2470: 09 20 20 20 20 20 20 72 65 73 0a 09 09 20 20 20 . res...
2480: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
2490: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 73 29 l)(cdr tal) res)
24a0: 0a 09 09 20 20 20 20 20 20 29 29 29 29 29 29 29 ... )))))))
24b0: 0a 0a 3b 3b 09 20 20 20 20 20 20 28 6c 65 74 20 ..;;. (let
24c0: 6c 6f 6f 70 20 28 28 6c 20 20 20 20 20 20 20 28 loop ((l (
24d0: 72 65 61 64 2d 6c 69 6e 65 29 29 20 3b 3b 20 28 read-line)) ;; (
24e0: 69 66 20 28 65 71 3f 20 6d 6f 64 65 20 27 6e 6f if (eq? mode 'no
24f0: 72 6d 29 28 72 65 61 64 2d 6c 69 6e 65 29 28 72 rm)(read-line)(r
2500: 65 61 64 2d 63 68 61 72 29 29 29 0a 3b 3b 09 09 ead-char))).;;..
2510: 09 20 28 65 6e 64 6c 69 6e 65 20 23 66 29 0a 3b . (endline #f).;
2520: 3b 09 09 09 20 28 6e 75 6d 20 20 20 20 20 30 29 ;... (num 0)
2530: 29 0a 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 61 74 ).;;..;; (format
2540: 20 64 65 62 75 67 70 20 22 7e 41 5c 6e 22 20 6c debugp "~A\n" l
2550: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
2560: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
2570: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 29 0a eof-object? l)).
2580: 3b 3b 09 09 20 20 20 20 20 20 28 6e 6f 74 20 28 ;;.. (not (
2590: 61 6e 64 20 28 65 71 3f 20 6d 6f 64 65 20 27 62 and (eq? mode 'b
25a0: 69 6e 29 0a 3b 3b 09 09 09 09 28 73 74 72 69 6e in).;;....(strin
25b0: 67 3d 3f 20 6c 20 22 22 29 29 29 29 20 3b 3b 20 g=? l "")))) ;;
25c0: 69 66 20 69 6e 20 62 69 6e 20 6d 6f 64 65 20 65 if in bin mode e
25d0: 6d 70 74 79 20 73 74 72 69 6e 67 20 69 73 20 65 mpty string is e
25e0: 6e 64 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 09 20 nd of file.;;..
25f0: 20 28 63 61 73 65 20 6d 6f 64 65 0a 3b 3b 09 09 (case mode.;;..
2600: 20 20 20 20 28 28 73 74 61 72 74 29 0a 3b 3b 09 ((start).;;.
2610: 09 20 20 20 20 20 28 73 65 74 21 20 6d 6f 64 65 . (set! mode
2620: 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 'norm).;;..
2630: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
2640: 63 68 20 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 ch delim-patt-re
2650: 78 20 6c 29 0a 3b 3b 09 09 09 20 28 62 65 67 69 x l).;;... (begi
2660: 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 n.;;... (set!
2670: 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 6c 29 0a delim-string l).
2680: 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 64 65 ;;... (set! de
2690: 6c 69 6d 2d 6c 65 6e 20 20 20 20 28 73 74 72 69 lim-len (stri
26a0: 6e 67 2d 6c 65 6e 67 74 68 20 6c 29 29 0a 3b 3b ng-length l)).;;
26b0: 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 ... (loop (rea
26c0: 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b d-line) #f 0)).;
26d0: 3b 09 09 09 20 28 6c 6f 6f 70 20 6c 20 23 66 20 ;... (loop l #f
26e0: 30 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 6e 0))).;;.. ((n
26f0: 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b orm).;;.. ;;
2700: 20 49 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 6f I don't like ho
2710: 77 20 74 68 69 73 20 67 65 74 73 20 63 68 65 63 w this gets chec
2720: 6b 65 64 20 6f 6e 20 65 76 65 72 79 20 73 69 6e ked on every sin
2730: 67 6c 65 20 69 6e 70 75 74 2e 20 4d 75 73 74 20 gle input. Must
2740: 62 65 20 61 20 62 65 74 74 65 72 20 77 61 79 2e be a better way.
2750: 20 46 49 58 4d 45 0a 3b 3b 09 09 20 20 20 20 20 FIXME.;;..
2760: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
2770: 2d 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d -match bin-data-
2780: 64 69 73 70 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 disp-rex l).;;..
2790: 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d . (string-m
27a0: 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 atch bin-data-na
27b0: 6d 65 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 me-rex l).;;...
27c0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
27d0: 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 6d 65 ch bin-file-name
27e0: 2d 72 65 78 20 6c 29 29 0a 3b 3b 09 09 09 20 28 -rex l)).;;... (
27f0: 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 begin.;;... (s
2800: 65 74 21 20 64 61 74 61 2d 6e 61 6d 65 20 28 63 et! data-name (c
2810: 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 adr (string-matc
2820: 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d 65 2d h bin-data-name-
2830: 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 20 rex l))).;;...
2840: 20 28 73 65 74 21 20 66 69 6c 65 2d 6e 61 6d 65 (set! file-name
2850: 20 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d (cadr (string-m
2860: 61 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 atch bin-file-na
2870: 6d 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 me-rex l))).;;..
2880: 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 20 27 . (set! mode '
2890: 63 6f 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 20 20 content).;;...
28a0: 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e (loop (read-lin
28b0: 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 e) #f num))).;;.
28c0: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 . (let* ((da
28d0: 74 20 20 28 73 3a 70 72 6f 63 65 73 73 2d 63 67 t (s:process-cg
28e0: 69 2d 69 6e 70 75 74 20 6c 29 29 29 20 3b 3b 20 i-input l))) ;;
28f0: 28 43 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 65 (CGI:url-unquote
2900: 20 6c 29 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 l)).;;..
2910: 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 20 22 (format debugp "
2920: 50 52 4f 43 45 53 53 2d 43 47 49 2d 49 4e 50 55 PROCESS-CGI-INPU
2930: 54 3a 20 7e 41 5c 6e 22 20 28 69 6e 74 65 72 73 T: ~A\n" (inters
2940: 70 65 72 73 65 20 64 61 74 20 22 2c 22 29 29 0a perse dat ",")).
2950: 3b 3b 09 09 20 20 20 20 20 20 20 28 66 6f 72 6d ;;.. (form
2960: 64 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 dat:load formdat
2970: 20 64 61 74 29 0a 3b 3b 09 09 20 20 20 20 20 20 dat).;;..
2980: 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e (loop (read-lin
2990: 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b 3b 09 e) #f num))).;;.
29a0: 09 20 20 20 20 28 28 63 6f 6e 74 65 6e 74 29 0a . ((content).
29b0: 3b 3b 09 09 20 20 20 20 20 28 69 66 20 28 73 74 ;;.. (if (st
29c0: 72 69 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d 66 ring-match bin-f
29d0: 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 6c 29 0a ile-type-rex l).
29e0: 3b 3b 09 09 09 20 28 62 65 67 69 6e 20 0a 3b 3b ;;... (begin .;;
29f0: 09 09 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 ... (set! mode
2a00: 20 27 62 69 6e 29 0a 3b 3b 09 09 09 20 20 20 28 'bin).;;... (
2a10: 73 65 74 21 20 64 61 74 61 2d 74 79 70 65 20 28 set! data-type (
2a20: 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 cadr (string-mat
2a30: 63 68 20 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 ch bin-file-type
2a40: 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 20 -rex l))).;;...
2a50: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 73 74 (loop (read-st
2a60: 72 69 6e 67 20 31 29 20 23 66 20 6e 75 6d 29 29 ring 1) #f num))
2a70: 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 62 69 6e )).;;.. ((bin
2a80: 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 64 65 ).;;.. ;; de
2a90: 6c 69 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e 22 2d lim-string: \n"-
2aa0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 32 --------------12
2ab0: 33 34 35 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 345".;;.. ;;
2ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ad0: 20 20 30 31 32 33 34 35 36 37 38 39 30 31 32 33 01234567890123
2ae0: 34 35 36 37 38 39 30 0a 3b 3b 09 09 20 20 20 20 4567890.;;..
2af0: 20 3b 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 20 20 ;; endline:
2b00: 20 20 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "-----------
2b10: 2d 2d 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 20 20 ----12".;;..
2b20: 20 3b 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b 09 09 ;; l = "3".;;..
2b30: 20 20 20 20 20 3b 3b 20 64 65 6c 69 6d 2d 6c 65 ;; delim-le
2b40: 6e 20 3d 20 32 30 0a 3b 3b 09 09 20 20 20 20 20 n = 20.;;..
2b50: 3b 3b 20 28 73 75 62 73 74 72 69 6e 67 20 20 22 ;; (substring "
2b60: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 31 ---------------1
2b70: 32 33 34 35 22 20 31 37 20 31 38 29 20 3d 3e 20 2345" 17 18) =>
2b80: 22 33 22 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 0a "3".;;.. ;;.
2b90: 3b 3b 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 3b ;;.. (cond.;
2ba0: 3b 09 09 20 20 20 20 20 20 20 3b 3b 20 68 61 76 ;.. ;; hav
2bb0: 65 6e 27 74 20 66 6f 75 6e 64 20 74 68 65 20 73 en't found the s
2bc0: 74 61 72 74 20 6f 66 20 61 6e 20 65 6e 64 6c 69 tart of an endli
2bd0: 6e 65 2c 20 69 73 20 74 68 65 20 6e 65 78 74 20 ne, is the next
2be0: 63 68 61 72 20 61 20 6e 65 77 6c 69 6e 65 3f 0a char a newline?.
2bf0: 3b 3b 09 09 20 20 20 20 20 20 28 28 61 6e 64 20 ;;.. ((and
2c00: 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 29 0a 3b 3b (not endline).;;
2c10: 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 3d 3f ... (string=?
2c20: 20 6c 20 22 5c 6e 22 29 29 20 3b 3b 20 72 65 71 l "\n")) ;; req
2c30: 75 69 72 65 64 20 66 69 72 73 74 20 63 68 61 72 uired first char
2c40: 61 63 74 65 72 20 0a 3b 3b 09 09 20 20 20 20 20 acter .;;..
2c50: 20 20 28 6c 65 74 20 28 28 6e 65 77 65 6e 64 6c (let ((newendl
2c60: 69 6e 65 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 ine (open-output
2c70: 2d 73 74 72 69 6e 67 29 29 29 0a 3b 3b 09 09 09 -string))).;;...
2c80: 20 3b 3b 20 28 77 72 69 74 65 2d 6c 69 6e 65 20 ;; (write-line
2c90: 6c 20 6e 65 77 65 6e 64 6c 69 6e 65 29 20 3b 3b l newendline) ;;
2ca0: 20 64 69 73 63 61 72 64 20 74 68 65 20 6e 65 77 discard the new
2cb0: 6c 69 6e 65 2e 20 61 64 64 20 69 74 20 62 61 63 line. add it bac
2cc0: 6b 20 69 66 20 64 6f 6e 27 74 20 68 61 76 65 20 k if don't have
2cd0: 61 20 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 6d 2d a lock on delim-
2ce0: 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 28 6c 6f string.;;... (lo
2cf0: 6f 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 op (read-string
2d00: 31 29 20 6e 65 77 65 6e 64 6c 69 6e 65 20 28 2b 1) newendline (+
2d10: 20 6e 75 6d 20 31 29 29 29 29 0a 3b 3b 09 09 20 num 1)))).;;..
2d20: 20 20 20 20 20 28 28 6e 6f 74 20 65 6e 64 6c 69 ((not endli
2d30: 6e 65 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 ne).;;.. (
2d40: 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c 20 23 write-string l #
2d50: 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 20 f bin-dat).;;..
2d60: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 (loop (rea
2d70: 64 2d 73 74 72 69 6e 67 20 31 29 20 23 66 20 28 d-string 1) #f (
2d80: 2b 20 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 09 20 + num 1))).;;..
2d90: 20 20 20 20 20 3b 3b 20 73 74 72 69 6e 67 20 73 ;; string s
2da0: 6f 20 66 61 72 20 6d 61 74 63 68 65 73 20 64 65 o far matches de
2db0: 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 20 lim-string.;;..
2dc0: 20 20 20 20 20 28 65 6e 64 6c 69 6e 65 0a 3b 3b (endline.;;
2dd0: 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 .. (let* (
2de0: 28 65 6e 64 73 74 72 20 28 67 65 74 2d 6f 75 74 (endstr (get-out
2df0: 70 75 74 2d 73 74 72 69 6e 67 20 65 6e 64 6c 69 put-string endli
2e00: 6e 65 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 20 ne)).;;...
2e10: 28 65 6e 64 6c 65 6e 20 28 73 74 72 69 6e 67 2d (endlen (string-
2e20: 6c 65 6e 67 74 68 20 65 6e 64 73 74 72 29 29 29 length endstr)))
2e30: 0a 3b 3b 09 09 09 20 28 69 66 20 28 3e 20 65 6e .;;... (if (> en
2e40: 64 6c 65 6e 20 30 29 0a 3b 3b 09 09 09 20 20 20 dlen 0).;;...
2e50: 20 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 (format debugp
2e60: 20 22 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e 65 6e " delim: ~A\nen
2e70: 64 73 74 72 3a 20 7e 41 5c 6e 22 20 64 65 6c 69 dstr: ~A\n" deli
2e80: 6d 2d 73 74 72 69 6e 67 20 65 6e 64 73 74 72 29 m-string endstr)
2e90: 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 61 6e 64 ).;;... (if (and
2ea0: 20 28 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e (> delim-len en
2eb0: 64 6c 65 6e 29 0a 3b 3b 09 09 09 09 20 20 28 73 dlen).;;.... (s
2ec0: 74 72 69 6e 67 3d 3f 20 6c 20 28 73 75 62 73 74 tring=? l (subst
2ed0: 72 69 6e 67 20 64 65 6c 69 6d 2d 73 74 72 69 6e ring delim-strin
2ee0: 67 20 65 6e 64 6c 65 6e 20 28 2b 20 65 6e 64 6c g endlen (+ endl
2ef0: 65 6e 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 en 1)))).;;...
2f00: 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 ;; yes, this
2f10: 63 68 61 72 61 63 74 65 72 20 6d 61 74 63 68 65 character matche
2f20: 73 20 74 68 65 20 6e 65 78 74 20 69 6e 20 74 68 s the next in th
2f30: 65 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b e delim-string.;
2f40: 3b 09 09 09 20 20 20 20 20 28 69 66 20 28 65 71 ;... (if (eq
2f50: 3f 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e 64 6c ? delim-len endl
2f60: 65 6e 29 20 3b 3b 20 68 61 76 65 20 61 20 6d 61 en) ;; have a ma
2f70: 74 63 68 21 20 49 67 6e 6f 72 65 20 74 68 61 74 tch! Ignore that
2f80: 20 61 20 6e 65 77 6c 69 6e 65 20 69 73 20 72 65 a newline is re
2f90: 71 75 69 72 65 64 2e 20 4c 61 7a 79 20 62 75 67 quired. Lazy bug
2fa0: 67 65 72 2e 0a 3b 3b 09 09 09 09 20 28 6c 65 74 ger..;;.... (let
2fb0: 2a 20 28 28 66 6e 20 20 20 20 20 20 28 73 74 72 * ((fn (str
2fc0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 74 61 ing->symbol data
2fd0: 2d 6e 61 6d 65 29 29 29 0a 3b 3b 09 09 09 09 20 -name))).;;....
2fe0: 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 20 (formdat:set!
2ff0: 66 6f 72 6d 64 61 74 20 66 6e 20 28 6c 69 73 74 formdat fn (list
3000: 20 66 69 6c 65 2d 6e 61 6d 65 20 64 61 74 61 2d file-name data-
3010: 74 79 70 65 20 28 73 74 72 69 6e 67 2d 3e 62 6c type (string->bl
3020: 6f 62 20 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 ob (get-output-s
3030: 74 72 69 6e 67 20 62 69 6e 2d 64 61 74 29 29 29 tring bin-dat)))
3040: 29 0a 3b 3b 09 09 09 09 20 20 20 28 73 65 74 21 ).;;.... (set!
3050: 20 6d 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 mode 'norm).;;.
3060: 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 ... (loop (rea
3070: 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 0a 3b d-line) #f 0)).;
3080: 3b 09 09 09 09 20 28 62 65 67 69 6e 0a 3b 3b 09 ;.... (begin.;;.
3090: 09 09 09 20 20 20 28 77 72 69 74 65 2d 73 74 72 ... (write-str
30a0: 69 6e 67 20 6c 20 23 66 20 65 6e 64 6c 69 6e 65 ing l #f endline
30b0: 29 0a 3b 3b 09 09 09 09 20 20 20 28 6c 6f 6f 70 ).;;.... (loop
30c0: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 (read-string 1)
30d0: 20 65 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 6d 20 endline (+ num
30e0: 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 20 20 1)))).;;...
30f0: 3b 3b 20 6e 6f 2c 20 74 68 69 73 20 63 68 61 72 ;; no, this char
3100: 61 63 74 65 72 20 64 6f 65 73 20 4e 4f 54 20 6d acter does NOT m
3110: 61 74 63 68 20 74 68 65 20 6e 65 78 74 20 69 6e atch the next in
3120: 20 6c 69 6e 65 20 69 6e 20 64 65 6c 69 6d 2d 73 line in delim-s
3130: 74 72 69 6e 67 0a 3b 3b 09 09 09 20 20 20 20 20 tring.;;...
3140: 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 20 (begin.;;...
3150: 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 (write-string
3160: 20 22 5c 6e 22 20 23 66 20 62 69 6e 2d 64 61 74 "\n" #f bin-dat
3170: 29 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 67 65 ) ;; don't forge
3180: 74 20 74 68 61 74 20 6e 65 77 6c 69 6e 65 20 77 t that newline w
3190: 65 20 64 72 6f 70 70 65 64 0a 3b 3b 09 09 09 20 e dropped.;;...
31a0: 20 20 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 (write-str
31b0: 69 6e 67 20 65 6e 64 73 74 72 20 23 66 20 62 69 ing endstr #f bi
31c0: 6e 2d 64 61 74 29 0a 3b 3b 09 09 09 20 20 20 20 n-dat).;;...
31d0: 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 (write-string
31e0: 20 6c 20 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b l #f bin-dat).;
31f0: 3b 09 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 ;... (loop
3200: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 31 29 (read-string 1)
3210: 20 23 66 20 28 2b 20 6e 75 6d 20 31 29 29 29 29 #f (+ num 1))))
3220: 29 29 29 29 0a 3b 3b 09 09 20 20 20 20 29 29 29 )))).;;.. )))
3230: 29 29 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 6d 64 ))..;; (formd
3240: 61 74 3a 70 72 69 6e 74 61 6c 6c 20 66 6f 72 6d at:printall form
3250: 64 61 74 20 28 6c 61 6d 62 64 61 20 28 78 29 28 dat (lambda (x)(
3260: 77 72 69 74 65 2d 6c 69 6e 65 20 78 20 64 65 62 write-line x deb
3270: 75 67 70 29 29 29 0a 0a 23 7c 0a 28 64 65 66 69 ugp)))..#|.(defi
3280: 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 ne inp (open-inp
3290: 75 74 2d 66 69 6c 65 20 22 2f 74 6d 70 2f 73 74 ut-file "/tmp/st
32a0: 6d 6c 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 2e 6c mlrun/delme-33.l
32b0: 6f 67 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 66 22 og.keep-for-ref"
32c0: 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 20 28 )).(define dat (
32d0: 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 20 69 read-string #f i
32e0: 6e 70 29 29 0a 28 63 6c 6f 73 65 2d 69 6e 70 75 np)).(close-inpu
32f0: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 0a t-port inp).|#.