Artifact
556fae5e9678708ab417958c3264687d0902596a:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 30 38 2c 20 4d 61 74 74 68 65 77 20 7-2008, 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 69 6e 63 6c 75 PURPOSE...(inclu
0150: 64 65 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 de "requirements
0160: 2e 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 .scm")..(define
0170: 66 6f 72 6d 64 61 74 3a 2a 64 65 62 75 67 2a 20 formdat:*debug*
0180: 23 66 29 0a 0a 3b 3b 20 4f 6c 64 20 64 61 74 61 #f)..;; Old data
0190: 20 66 6f 72 6d 61 74 20 77 61 73 20 73 6f 6d 65 format was some
01a0: 74 68 69 6e 67 20 6c 69 6b 65 20 74 68 69 73 2e thing like this.
01b0: 20 42 55 54 21 20 0a 3b 3b 20 46 6f 72 6d 73 20 BUT! .;; Forms
01c0: 64 6f 20 6e 6f 74 20 68 61 76 65 20 6e 61 6d 65 do not have name
01d0: 73 20 73 6f 20 74 68 65 20 68 69 65 72 61 72 63 s so the hierarc
01e0: 79 20 69 73 0a 3b 3b 20 75 6e 6e 65 63 65 73 73 y is.;; unnecess
01f0: 61 72 79 20 28 49 20 74 68 69 6e 6b 29 0a 3b 3b ary (I think).;;
0200: 0a 3b 3b 20 68 61 73 68 74 61 62 6c 65 0a 3b 3b .;; hashtable.;;
0210: 20 20 20 7c 2d 66 6f 72 6d 6e 61 6d 65 20 2d 2d |-formname --
0220: 3e 20 3c 66 6f 72 6d 64 61 74 3e 20 27 66 6f 72 > <formdat> 'for
0230: 6d 2d 6e 61 6d 65 3d 66 6f 72 6d 6e 61 6d 65 0a m-name=formname.
0240: 3b 3b 20 20 20 7c 20 20 20 20 20 20 20 20 20 20 ;; |
0250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 66 'f
0260: 6f 72 6d 2d 64 61 74 61 3d 68 61 73 68 74 61 62 orm-data=hashtab
0270: 6c 65 0a 3b 3b 20 20 20 7c 20 20 20 20 20 20 20 le.;; |
0280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
02a0: 7c 20 6e 61 6d 65 20 3d 3e 20 76 61 6c 75 65 0a | name => value.
02b0: 3b 3b 0a 3b 3b 20 4e 65 77 20 64 61 74 61 20 66 ;;.;; New data f
02c0: 6f 72 6d 61 74 20 69 73 20 6f 6e 6c 79 20 74 68 ormat is only th
02d0: 65 20 3c 66 6f 72 6d 64 61 74 3e 20 70 6f 72 74 e <formdat> port
02e0: 69 6f 6e 20 66 72 6f 6d 20 61 62 6f 76 65 0a 0a ion from above..
02f0: 28 64 65 66 69 6e 65 2d 63 6c 61 73 73 20 3c 66 (define-class <f
0300: 6f 72 6d 64 61 74 3e 20 28 29 0a 20 20 20 28 66 ormdat> (). (f
0310: 6f 72 6d 2d 64 61 74 61 0a 20 20 20 29 29 0a 0a orm-data. ))..
0320: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
0330: 69 6e 69 74 69 61 6c 69 7a 65 20 28 73 65 6c 66 initialize (self
0340: 20 3c 66 6f 72 6d 64 61 74 3e 29 20 69 6e 69 74 <formdat>) init
0350: 61 72 67 73 29 0a 20 20 28 63 61 6c 6c 2d 6e 65 args). (call-ne
0360: 78 74 2d 6d 65 74 68 6f 64 29 0a 20 20 28 73 6c xt-method). (sl
0370: 6f 74 2d 73 65 74 21 20 73 65 6c 66 20 27 66 6f ot-set! self 'fo
0380: 72 6d 2d 64 61 74 61 20 28 6d 61 6b 65 2d 68 61 rm-data (make-ha
0390: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 69 6e sh-table)). (in
03a0: 69 74 69 61 6c 69 7a 65 2d 73 6c 6f 74 73 20 73 itialize-slots s
03b0: 65 6c 66 20 69 6e 69 74 61 72 67 73 29 29 0a 0a elf initargs))..
03c0: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
03d0: 66 6f 72 6d 64 61 74 3a 67 65 74 20 28 73 65 6c formdat:get (sel
03e0: 66 20 3c 66 6f 72 6d 64 61 74 3e 29 20 6b 65 79 f <formdat>) key
03f0: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
0400: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 73 6c 6f ref/default (slo
0410: 74 2d 72 65 66 20 73 65 6c 66 20 27 66 6f 72 6d t-ref self 'form
0420: 2d 64 61 74 61 29 20 6b 65 79 20 23 66 29 29 0a -data) key #f)).
0430: 0a 3b 3b 20 63 68 61 6e 67 65 20 74 6f 20 63 6f .;; change to co
0440: 6e 76 65 72 74 20 64 61 74 61 20 74 6f 20 6c 69 nvert data to li
0450: 73 74 20 61 6e 64 20 61 70 70 65 6e 64 20 76 61 st and append va
0460: 6c 20 69 66 20 61 6c 72 65 61 64 79 20 65 78 69 l if already exi
0470: 73 74 73 0a 3b 3b 20 6f 72 20 69 73 20 61 20 6c sts.;; or is a l
0480: 69 73 74 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 ist.(define-meth
0490: 6f 64 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 21 od (formdat:set!
04a0: 20 28 73 65 6c 66 20 3c 66 6f 72 6d 64 61 74 3e (self <formdat>
04b0: 29 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 6c 65 ) key val). (le
04c0: 74 20 28 28 70 72 65 76 2d 76 61 6c 20 28 66 6f t ((prev-val (fo
04d0: 72 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 20 6b rmdat:get self k
04e0: 65 79 29 29 0a 20 20 20 20 20 20 20 20 28 68 74 ey)). (ht
04f0: 20 20 20 20 20 20 20 28 73 6c 6f 74 2d 72 65 66 (slot-ref
0500: 20 73 65 6c 66 20 27 66 6f 72 6d 2d 64 61 74 61 self 'form-data
0510: 29 29 29 0a 20 20 20 20 28 69 66 20 70 72 65 76 ))). (if prev
0520: 2d 76 61 6c 0a 20 20 20 20 20 20 20 20 28 69 66 -val. (if
0530: 20 28 6c 69 73 74 3f 20 70 72 65 76 2d 76 61 6c (list? prev-val
0540: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 ). (h
0550: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
0560: 74 20 6b 65 79 20 28 63 6f 6e 73 20 76 61 6c 20 t key (cons val
0570: 70 72 65 76 2d 76 61 6c 29 29 0a 20 20 20 20 20 prev-val)).
0580: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
0590: 6c 65 2d 73 65 74 21 20 68 74 20 6b 65 79 20 28 le-set! ht key (
05a0: 6c 69 73 74 20 76 61 6c 20 70 72 65 76 2d 76 61 list val prev-va
05b0: 6c 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 l))). (ha
05c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
05d0: 20 6b 65 79 20 76 61 6c 29 29 0a 20 20 20 20 73 key val)). s
05e0: 65 6c 66 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d elf))..(define-m
05f0: 65 74 68 6f 64 20 28 66 6f 72 6d 64 61 74 3a 6b ethod (formdat:k
0600: 65 79 73 20 28 73 65 6c 66 20 3c 66 6f 72 6d 64 eys (self <formd
0610: 61 74 3e 29 29 0a 20 20 28 68 61 73 68 2d 74 61 at>)). (hash-ta
0620: 62 6c 65 2d 6b 65 79 73 20 28 73 6c 6f 74 2d 72 ble-keys (slot-r
0630: 65 66 20 73 65 6c 66 20 27 66 6f 72 6d 2d 64 61 ef self 'form-da
0640: 74 61 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 6d ta)))..(define-m
0650: 65 74 68 6f 64 20 28 66 6f 72 6d 64 61 74 3a 70 ethod (formdat:p
0660: 72 69 6e 74 61 6c 6c 20 28 73 65 6c 66 20 3c 66 rintall (self <f
0670: 6f 72 6d 64 61 74 3e 29 20 70 72 69 6e 74 70 72 ormdat>) printpr
0680: 6f 63 29 0a 20 20 28 70 72 69 6e 74 70 72 6f 63 oc). (printproc
0690: 20 22 66 6f 72 6d 64 61 74 3a 70 72 69 6e 74 61 "formdat:printa
06a0: 6c 6c 20 22 20 28 66 6f 72 6d 64 61 74 3a 6b 65 ll " (formdat:ke
06b0: 79 73 20 73 65 6c 66 29 29 0a 20 20 28 66 6f 72 ys self)). (for
06c0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
06d0: 29 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 70 ).. (printp
06e0: 72 6f 63 20 6b 20 22 20 3d 3e 20 22 20 28 66 6f roc k " => " (fo
06f0: 72 6d 64 61 74 3a 67 65 74 20 73 65 6c 66 20 6b rmdat:get self k
0700: 29 29 29 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 ))).. (formda
0710: 74 3a 6b 65 79 73 20 73 65 6c 66 29 29 29 0a 0a t:keys self)))..
0720: 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 28 (define-method (
0730: 66 6f 72 6d 64 61 74 3a 61 6c 6c 2d 3e 73 74 72 formdat:all->str
0740: 69 6e 67 73 20 28 73 65 6c 66 20 3c 66 6f 72 6d ings (self <form
0750: 64 61 74 3e 29 29 0a 20 20 28 6c 65 74 20 28 28 dat>)). (let ((
0760: 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 66 res '())). (f
0770: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
0780: 28 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 (k).
0790: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 (set! res (
07a0: 63 6f 6e 73 20 28 63 6f 6e 63 20 6b 20 22 3d 3e cons (conc k "=>
07b0: 22 20 28 66 6f 72 6d 64 61 74 3a 67 65 74 20 73 " (formdat:get s
07c0: 65 6c 66 20 6b 29 29 20 72 65 73 29 29 29 0a 20 elf k)) res))).
07d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f (fo
07e0: 72 6d 64 61 74 3a 6b 65 79 73 20 73 65 6c 66 29 rmdat:keys self)
07f0: 29 0a 20 20 20 20 20 20 20 20 72 65 73 29 29 0a ). res)).
0800: 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 68 20 2a 6f .;; call with *o
0810: 6e 65 2a 20 6f 66 20 74 68 65 20 6c 69 73 74 73 ne* of the lists
0820: 20 69 6e 20 74 68 65 20 6c 69 73 74 20 6f 66 20 in the list of
0830: 6c 69 73 74 73 20 63 72 65 61 74 65 64 20 62 79 lists created by
0840: 20 43 47 49 3a 75 72 6c 2d 75 6e 71 75 6f 74 65 CGI:url-unquote
0850: 0a 28 64 65 66 69 6e 65 2d 6d 65 74 68 6f 64 20 .(define-method
0860: 28 66 6f 72 6d 64 61 74 3a 6c 6f 61 64 20 28 73 (formdat:load (s
0870: 65 6c 66 20 3c 66 6f 72 6d 64 61 74 3e 29 20 66 elf <formdat>) f
0880: 6f 72 6d 6c 69 73 74 29 0a 20 20 28 6c 65 74 20 ormlist). (let
0890: 28 28 68 74 20 20 20 20 20 20 20 20 20 20 20 20 ((ht
08a0: 20 28 73 6c 6f 74 2d 72 65 66 20 73 65 6c 66 20 (slot-ref self
08b0: 27 66 6f 72 6d 2d 64 61 74 61 29 29 29 0a 20 20 'form-data))).
08c0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 6f 72 (if (null? for
08d0: 6d 6c 69 73 74 29 20 73 65 6c 66 20 3b 3b 20 6e mlist) self ;; n
08e0: 6f 20 76 61 6c 75 65 73 20 70 72 6f 76 69 64 65 o values provide
08f0: 64 2c 20 72 65 74 75 72 6e 20 73 65 6c 66 20 66 d, return self f
0900: 6f 72 20 6e 6f 20 67 6f 6f 64 20 72 65 61 73 6f or no good reaso
0910: 6e 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c n. (let l
0920: 6f 6f 70 20 28 28 68 65 61 64 20 28 63 61 72 20 oop ((head (car
0930: 66 6f 72 6d 6c 69 73 74 29 29 0a 20 20 20 20 20 formlist)).
0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
0950: 61 69 6c 20 28 63 64 72 20 66 6f 72 6d 6c 69 73 ail (cdr formlis
0960: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 t))). (
0970: 6c 65 74 20 28 28 6b 65 79 20 28 63 61 72 20 68 let ((key (car h
0980: 65 61 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 ead)).
0990: 20 20 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 (val (cdr
09a0: 68 65 61 64 29 29 29 0a 20 20 20 20 20 20 20 20 head))).
09b0: 20 20 20 20 3b 3b 20 28 65 72 72 3a 6c 6f 67 20 ;; (err:log
09c0: 22 6b 65 79 3d 22 20 6b 65 79 20 22 20 76 61 6c "key=" key " val
09d0: 3d 22 20 76 61 6c 29 0a 09 20 20 20 20 28 69 66 =" val).. (if
09e0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 76 61 6c 29 (> (length val)
09f0: 20 31 29 0a 09 09 28 66 6f 72 6d 64 61 74 3a 73 1)...(formdat:s
0a00: 65 74 21 20 73 65 6c 66 20 6b 65 79 20 76 61 6c et! self key val
0a10: 29 0a 09 09 28 66 6f 72 6d 64 61 74 3a 73 65 74 )...(formdat:set
0a20: 21 20 73 65 6c 66 20 6b 65 79 20 28 63 61 72 20 ! self key (car
0a30: 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 20 20 val))).
0a40: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
0a50: 69 6c 29 20 73 65 6c 66 20 20 20 3b 3b 20 77 65 il) self ;; we
0a60: 20 61 72 65 20 64 6f 6e 65 0a 20 20 20 20 20 20 are done.
0a70: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
0a80: 28 63 61 72 20 74 61 69 6c 29 28 63 64 72 20 74 (car tail)(cdr t
0a90: 61 69 6c 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 ail))))))))..;;
0aa0: 67 65 74 20 74 68 65 20 68 65 61 64 65 72 20 66 get the header f
0ab0: 72 6f 6d 20 64 61 74 73 74 72 0a 28 64 65 66 69 rom datstr.(defi
0ac0: 6e 65 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 ne (formdat:read
0ad0: 2d 68 65 61 64 65 72 20 64 61 74 73 74 72 29 20 -header datstr)
0ae0: 3b 3b 20 64 61 74 73 74 72 20 69 73 20 61 6e 20 ;; datstr is an
0af0: 69 6e 70 75 74 20 73 74 72 69 6e 67 20 70 6f 72 input string por
0b00: 74 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 t. (let loop ((
0b10: 68 73 20 28 72 65 61 64 2d 6c 69 6e 65 20 64 61 hs (read-line da
0b20: 74 73 74 72 29 29 0a 09 20 20 20 20 20 28 68 65 tstr)).. (he
0b30: 61 64 65 72 20 27 28 29 29 29 0a 20 20 20 20 28 ader '())). (
0b40: 69 66 20 28 6f 72 20 28 65 6f 66 2d 6f 62 6a 65 if (or (eof-obje
0b50: 63 74 3f 20 68 73 29 0a 09 20 20 20 20 28 73 74 ct? hs).. (st
0b60: 72 69 6e 67 3d 3f 20 68 73 20 22 22 29 29 0a 09 ring=? hs ""))..
0b70: 68 65 61 64 65 72 0a 09 28 6c 6f 6f 70 20 28 72 header..(loop (r
0b80: 65 61 64 2d 6c 69 6e 65 20 64 61 74 73 74 72 29 ead-line datstr)
0b90: 28 61 70 70 65 6e 64 20 68 65 61 64 65 72 20 28 (append header (
0ba0: 6c 69 73 74 20 68 73 29 29 29 29 29 29 0a 0a 3b list hs))))))..;
0bb0: 3b 20 67 65 74 20 74 68 65 20 64 61 74 61 20 75 ; get the data u
0bc0: 70 20 74 6f 20 74 68 65 20 6e 65 78 74 20 6b 65 p to the next ke
0bd0: 79 2e 20 69 66 20 74 68 65 72 65 20 69 73 20 6e y. if there is n
0be0: 6f 20 6b 65 79 20 74 68 65 6e 20 72 65 74 75 72 o key then retur
0bf0: 6e 20 23 66 0a 3b 3b 20 72 65 74 75 72 6e 20 28 n #f.;; return (
0c00: 64 61 74 20 72 65 6d 64 61 74 29 0a 28 64 65 66 dat remdat).(def
0c10: 69 6e 65 20 28 66 6f 72 6d 64 61 74 3a 72 65 61 ine (formdat:rea
0c20: 64 2d 64 61 74 20 64 61 74 20 6b 65 79 29 0a 20 d-dat dat key).
0c30: 20 28 6c 65 74 20 28 28 69 6e 64 65 78 20 28 73 (let ((index (s
0c40: 74 72 69 6e 67 2d 73 65 61 72 63 68 2d 70 6f 73 tring-search-pos
0c50: 69 74 69 6f 6e 73 20 6b 65 79 20 64 61 74 29 29 itions key dat))
0c60: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e ). (if (or (n
0c70: 6f 74 20 69 6e 64 65 78 29 0a 09 20 20 20 20 28 ot index).. (
0c80: 6e 75 6c 6c 3f 20 69 6e 64 65 78 29 29 20 3b 3b null? index)) ;;
0c90: 20 74 68 65 20 6b 65 79 20 77 61 73 20 6e 6f 74 the key was not
0ca0: 20 66 6f 75 6e 64 0a 09 23 66 0a 09 28 6c 65 74 found..#f..(let
0cb0: 2a 20 28 28 64 61 74 73 74 72 20 28 6f 70 65 6e * ((datstr (open
0cc0: 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 64 61 -input-string da
0cd0: 74 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 t)).. (res
0ce0: 75 6c 74 20 28 72 65 61 64 2d 73 74 72 69 6e 67 ult (read-string
0cf0: 20 28 63 61 61 72 20 69 6e 64 65 78 29 20 64 61 (caar index) da
0d00: 74 73 74 72 29 29 0a 09 20 20 20 20 20 20 20 28 tstr)).. (
0d10: 72 65 6d 64 61 74 20 28 72 65 61 64 2d 73 74 72 remdat (read-str
0d20: 69 6e 67 20 23 66 20 64 61 74 73 74 72 29 29 29 ing #f datstr)))
0d30: 0a 09 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 .. (close-input
0d40: 2d 70 6f 72 74 20 64 61 74 73 74 72 29 0a 09 20 -port datstr)..
0d50: 20 28 6c 69 73 74 20 72 65 73 75 6c 74 20 72 65 (list result re
0d60: 6d 64 61 74 29 29 29 29 29 0a 0a 20 3b 3b 20 69 mdat))))).. ;; i
0d70: 6e 70 20 69 73 20 70 6f 72 74 20 74 6f 20 72 65 np is port to re
0d80: 61 64 20 64 61 74 61 20 66 72 6f 6d 2c 20 6d 61 ad data from, ma
0d90: 78 73 69 7a 65 20 69 73 20 6d 61 78 20 64 61 74 xsize is max dat
0da0: 61 20 61 6c 6c 6f 77 65 64 20 74 6f 20 72 65 61 a allowed to rea
0db0: 64 20 28 74 6f 74 61 6c 29 0a 28 64 65 66 69 6e d (total).(defin
0dc0: 65 20 28 66 6f 72 6d 64 61 74 3a 64 61 74 2d 3e e (formdat:dat->
0dd0: 6c 69 73 74 20 69 6e 70 20 6d 61 78 73 69 7a 65 list inp maxsize
0de0: 29 0a 20 20 3b 3b 20 72 65 61 64 20 31 4d 65 67 ). ;; read 1Meg
0df0: 20 63 68 75 6e 6b 73 20 66 72 6f 6d 20 74 68 65 chunks from the
0e00: 20 69 6e 70 75 74 20 70 6f 72 74 2e 20 49 66 20 input port. If
0e10: 61 20 62 6c 6f 63 6b 20 69 73 20 6e 6f 74 20 63 a block is not c
0e20: 6f 6d 70 6c 65 74 65 0a 20 20 3b 3b 20 74 61 63 omplete. ;; tac
0e30: 6b 20 6f 6e 20 74 68 65 20 6e 65 78 74 20 31 4d k on the next 1M
0e40: 65 67 20 63 68 75 6e 6b 20 61 73 20 6e 65 65 64 eg chunk as need
0e50: 65 64 2e 20 53 65 74 20 75 70 20 73 6f 20 74 68 ed. Set up so th
0e60: 65 20 68 65 61 64 65 72 20 69 73 20 61 6c 77 61 e header is alwa
0e70: 79 73 0a 20 20 3b 3b 20 61 74 20 74 68 65 20 62 ys. ;; at the b
0e80: 65 67 69 6e 6e 69 6e 67 20 6f 66 20 74 68 65 20 eginning of the
0e90: 63 68 75 6e 6b 0a 20 20 3b 3b 2d 2d 2d 2d 2d 2d chunk. ;;------
0ea0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0eb0: 2d 2d 2d 2d 2d 2d 2d 32 39 39 33 32 30 32 34 34 -------299320244
0ec0: 31 31 35 30 32 33 32 33 33 33 32 31 33 36 32 31 1150232333213621
0ed0: 34 39 37 33 0a 20 20 3b 3b 43 6f 6e 74 65 6e 74 4973. ;;Content
0ee0: 2d 44 69 73 70 6f 73 69 74 69 6f 6e 3a 20 66 6f -Disposition: fo
0ef0: 72 6d 2d 64 61 74 61 3b 20 6e 61 6d 65 3d 22 69 rm-data; name="i
0f00: 6e 70 75 74 2d 70 69 63 74 75 72 65 22 3b 20 66 nput-picture"; f
0f10: 69 6c 65 6e 61 6d 65 3d 22 62 72 65 61 64 66 72 ilename="breadfr
0f20: 75 69 74 2e 6a 70 67 22 0a 20 20 3b 3b 43 6f 6e uit.jpg". ;;Con
0f30: 74 65 6e 74 2d 54 79 70 65 3a 20 69 6d 61 67 65 tent-Type: image
0f40: 2f 6a 70 65 67 0a 20 20 28 6c 65 74 20 6c 6f 6f /jpeg. (let loo
0f50: 70 20 28 28 64 61 74 20 28 72 65 61 64 2d 73 74 p ((dat (read-st
0f60: 72 69 6e 67 20 31 30 30 30 30 30 30 20 69 6e 70 ring 1000000 inp
0f70: 29 29 0a 09 20 20 20 20 20 28 72 65 73 20 27 28 )).. (res '(
0f80: 29 29 0a 09 20 20 20 20 20 28 73 69 7a 20 30 29 )).. (siz 0)
0f90: 29 0a 20 20 20 20 28 69 66 20 28 3e 20 73 69 7a ). (if (> siz
0fa0: 20 6d 61 78 73 69 7a 65 29 0a 09 28 62 65 67 69 maxsize)..(begi
0fb0: 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 44 41 54 n.. (print "DAT
0fc0: 41 20 54 4f 4f 20 42 49 47 22 29 0a 09 20 20 72 A TOO BIG").. r
0fd0: 65 73 29 0a 09 28 6c 65 74 2a 20 28 28 64 61 74 es)..(let* ((dat
0fe0: 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d str (open-input-
0ff0: 73 74 72 69 6e 67 20 64 61 74 29 29 0a 09 20 20 string dat))..
1000: 20 20 20 20 20 28 68 65 61 64 65 72 20 28 66 6f (header (fo
1010: 72 6d 64 61 74 3a 72 65 61 64 2d 68 65 61 64 65 rmdat:read-heade
1020: 72 20 64 61 74 73 74 72 29 29 0a 09 20 20 20 20 r datstr))..
1030: 20 20 20 28 6b 65 79 20 20 20 20 28 69 66 20 28 (key (if (
1040: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 68 65 61 64 65 not (null? heade
1050: 72 29 29 28 63 61 72 20 68 65 61 64 65 72 29 20 r))(car header)
1060: 23 66 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 #f)).. (re
1070: 6d 64 61 74 20 28 72 65 61 64 2d 73 74 72 69 6e mdat (read-strin
1080: 67 20 23 66 20 64 61 74 73 74 72 29 29 20 20 20 g #f datstr))
1090: 20 20 20 20 20 20 20 3b 3b 20 75 73 65 64 20 69 ;; used i
10a0: 6e 20 6e 65 78 74 20 6c 69 6e 65 2c 20 64 69 73 n next line, dis
10b0: 63 61 72 64 20 69 66 20 67 6f 74 20 64 61 74 61 card if got data
10c0: 2c 20 65 6c 73 65 20 72 65 76 65 72 74 20 74 6f , else revert to
10d0: 0a 09 20 20 20 20 20 20 20 28 61 6c 6c 64 61 74 .. (alldat
10e0: 20 28 69 66 20 6b 65 79 20 28 66 6f 72 6d 64 61 (if key (formda
10f0: 74 3a 72 65 61 64 2d 64 61 74 20 72 65 6d 64 61 t:read-dat remda
1100: 74 20 6b 65 79 29 20 23 66 29 29 20 20 20 20 3b t key) #f)) ;
1110: 3b 20 74 72 79 20 74 6f 20 65 78 74 72 61 63 74 ; try to extract
1120: 20 74 68 65 20 64 61 74 61 0a 09 20 20 20 20 20 the data..
1130: 20 20 28 74 68 73 64 61 74 20 28 69 66 20 61 6c (thsdat (if al
1140: 6c 64 61 74 20 28 63 61 72 20 61 6c 6c 64 61 74 ldat (car alldat
1150: 29 20 20 23 66 29 29 20 20 20 20 20 3b 3b 20 74 ) #f)) ;; t
1160: 68 65 20 64 61 74 61 0a 09 20 20 20 20 20 20 20 he data..
1170: 28 6e 65 77 64 61 74 20 28 69 66 20 61 6c 6c 64 (newdat (if alld
1180: 61 74 20 28 63 61 64 72 20 61 6c 6c 64 61 74 29 at (cadr alldat)
1190: 20 23 66 29 29 20 20 20 20 20 3b 3b 20 6c 65 66 #f)) ;; lef
11a0: 74 20 6f 76 65 72 20 64 61 74 61 2c 20 6d 75 73 t over data, mus
11b0: 74 20 70 72 6f 63 65 73 73 20 2e 2e 2e 0a 09 20 t process .....
11c0: 20 20 20 20 20 20 28 74 68 73 72 65 73 20 28 6c (thsres (l
11d0: 69 73 74 20 68 65 61 64 65 72 20 74 68 73 64 61 ist header thsda
11e0: 74 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 t))
11f0: 3b 3b 20 73 70 65 63 75 6c 61 74 69 76 65 6c 79 ;; speculatively
1200: 20 63 6f 6e 73 74 72 75 63 74 20 72 65 73 75 6c construct resul
1210: 74 73 0a 09 20 20 20 20 20 20 20 28 6e 65 77 72 ts.. (newr
1220: 65 73 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 es (append res (
1230: 6c 69 73 74 20 74 68 73 72 65 73 29 29 29 29 20 list thsres))))
1240: 20 20 20 20 20 3b 3b 20 73 70 65 63 75 6c 61 74 ;; speculat
1250: 69 76 65 6c 79 20 63 6f 6e 73 74 72 75 63 74 20 ively construct
1260: 72 65 73 75 6c 74 73 0a 09 20 20 28 63 6c 6f 73 results.. (clos
1270: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 64 61 74 e-input-port dat
1280: 73 74 72 29 0a 09 20 20 28 63 6f 6e 64 0a 09 20 str).. (cond..
1290: 20 20 3b 3b 20 65 69 74 68 65 72 20 6e 6f 20 68 ;; either no h
12a0: 65 61 64 65 72 20 6f 72 20 73 69 6e 67 6c 65 20 eader or single
12b0: 69 6e 70 75 74 0a 09 20 20 20 28 28 61 6e 64 20 input.. ((and
12c0: 28 6e 6f 74 20 61 6c 6c 64 61 74 29 0a 09 09 20 (not alldat)...
12d0: 28 6f 72 20 28 6e 75 6c 6c 3f 20 68 65 61 64 65 (or (null? heade
12e0: 72 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 20 28 r)... (not (
12f0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 string-match for
1300: 6d 64 61 74 3a 64 65 6c 69 6d 2d 70 61 74 74 2d mdat:delim-patt-
1310: 72 65 78 20 28 63 61 72 20 68 65 61 64 65 72 29 rex (car header)
1320: 29 29 29 29 0a 09 20 20 20 20 3b 3b 20 28 70 72 )))).. ;; (pr
1330: 69 6e 74 20 22 47 6f 74 20 68 65 72 65 22 29 0a int "Got here").
1340: 09 20 20 20 20 28 63 6f 6e 73 20 28 6c 69 73 74 . (cons (list
1350: 20 68 65 61 64 65 72 20 22 22 29 20 72 65 73 29 header "") res)
1360: 29 20 3b 3b 20 6e 6f 74 65 20 75 73 65 20 68 65 ) ;; note use he
1370: 61 64 65 72 20 61 73 20 64 61 74 20 61 6e 64 20 ader as dat and
1380: 75 73 65 20 22 22 20 61 73 20 68 65 61 64 65 72 use "" as header
1390: 3f 3f 3f 3f 0a 09 20 20 20 3b 3b 20 64 69 64 6e ????.. ;; didn
13a0: 27 74 20 66 69 6e 64 20 65 6e 64 20 6b 65 79 20 't find end key
13b0: 69 6e 20 74 68 69 73 20 62 6c 6f 63 6b 0a 09 20 in this block..
13c0: 20 20 28 28 6e 6f 74 20 61 6c 6c 64 61 74 29 0a ((not alldat).
13d0: 09 20 20 20 20 28 6c 65 74 20 28 28 6d 6f 72 64 . (let ((mord
13e0: 61 74 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 at (read-string
13f0: 31 30 30 30 30 30 30 20 69 6e 70 29 29 29 0a 09 1000000 inp)))..
1400: 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
1410: 67 3d 3f 20 6d 6f 72 64 61 74 20 22 22 29 20 3b g=? mordat "") ;
1420: 3b 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 6f ; there is no mo
1430: 72 65 20 64 61 74 61 2c 20 64 69 73 63 61 72 64 re data, discard
1440: 20 72 65 73 75 6c 74 73 20 61 6e 64 20 75 73 65 results and use
1450: 20 72 65 6d 64 61 74 20 61 73 20 64 61 74 61 2c remdat as data,
1460: 20 74 68 69 73 20 69 6e 70 75 74 20 69 73 20 62 this input is b
1470: 72 6f 6b 65 6e 0a 09 09 20 20 28 63 6f 6e 73 20 roken... (cons
1480: 28 6c 69 73 74 20 68 65 61 64 65 72 20 72 65 6d (list header rem
1490: 64 61 74 29 20 72 65 73 29 0a 09 09 20 20 28 6c dat) res)... (l
14a0: 6f 6f 70 20 28 73 74 72 69 6e 67 2d 61 70 70 65 oop (string-appe
14b0: 6e 64 20 64 61 74 20 6d 6f 72 64 61 74 29 20 72 nd dat mordat) r
14c0: 65 73 20 28 2b 20 73 69 7a 20 32 30 30 30 30 30 es (+ siz 200000
14d0: 30 29 29 29 29 29 20 3b 3b 20 61 64 64 20 74 68 0))))) ;; add th
14e0: 65 20 65 78 74 72 61 20 31 30 30 30 30 30 30 0a e extra 1000000.
14f0: 09 20 20 20 28 61 6c 6c 64 61 74 20 3b 3b 20 67 . (alldat ;; g
1500: 6f 74 20 64 61 74 61 2c 20 64 6f 6e 27 74 20 61 ot data, don't a
1510: 74 74 65 6d 70 74 20 74 6f 20 63 68 65 63 6b 20 ttempt to check
1520: 69 66 20 74 68 65 72 65 20 69 73 20 6d 6f 72 65 if there is more
1530: 2c 20 6a 75 73 74 20 6c 6f 6f 70 20 61 6e 64 20 , just loop and
1540: 72 65 6c 79 20 6f 6e 20 28 6e 6f 74 20 61 6c 6c rely on (not all
1550: 64 61 74 29 20 74 6f 20 67 65 74 20 6d 6f 72 65 dat) to get more
1560: 20 64 61 74 61 0a 09 20 20 20 20 28 6c 6f 6f 70 data.. (loop
1570: 20 6e 65 77 64 61 74 20 6e 65 77 72 65 73 20 28 newdat newres (
1580: 2b 20 73 69 7a 20 31 30 30 30 30 30 30 29 29 29 + siz 1000000)))
1590: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 66 )))))..(define f
15a0: 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 61 74 61 2d ormdat:bin-data-
15b0: 64 69 73 70 2d 72 65 78 20 28 72 65 67 65 78 70 disp-rex (regexp
15c0: 20 22 5e 43 6f 6e 74 65 6e 74 2d 44 69 73 70 6f "^Content-Dispo
15d0: 73 69 74 69 6f 6e 3a 5c 5c 73 2b 66 6f 72 6d 2d sition:\\s+form-
15e0: 64 61 74 61 3b 22 29 29 0a 28 64 65 66 69 6e 65 data;")).(define
15f0: 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d 64 61 74 formdat:bin-dat
1600: 61 2d 6e 61 6d 65 2d 72 65 78 20 28 72 65 67 65 a-name-rex (rege
1610: 78 70 20 22 5c 5c 57 6e 61 6d 65 3d 5c 22 28 5b xp "\\Wname=\"([
1620: 5e 5c 22 5d 2b 29 5c 22 22 29 29 0a 28 64 65 66 ^\"]+)\"")).(def
1630: 69 6e 65 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d ine formdat:bin-
1640: 66 69 6c 65 2d 6e 61 6d 65 2d 72 65 78 20 28 72 file-name-rex (r
1650: 65 67 65 78 70 20 22 5c 5c 57 66 69 6c 65 6e 61 egexp "\\Wfilena
1660: 6d 65 3d 5c 22 28 5b 5e 5c 22 5d 2b 29 5c 22 22 me=\"([^\"]+)\""
1670: 29 29 0a 28 64 65 66 69 6e 65 20 66 6f 72 6d 64 )).(define formd
1680: 61 74 3a 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 at:bin-file-type
1690: 2d 72 65 78 20 28 72 65 67 65 78 70 20 22 43 6f -rex (regexp "Co
16a0: 6e 74 65 6e 74 2d 54 79 70 65 3a 5c 5c 73 2b 28 ntent-Type:\\s+(
16b0: 5b 5e 5c 5c 73 5d 2b 29 22 29 29 0a 28 64 65 66 [^\\s]+)")).(def
16c0: 69 6e 65 20 66 6f 72 6d 64 61 74 3a 64 65 6c 69 ine formdat:deli
16d0: 6d 2d 70 61 74 74 2d 72 65 78 20 20 20 20 28 72 m-patt-rex (r
16e0: 65 67 65 78 70 20 22 5e 5c 5c 2d 2b 5b 30 2d 39 egexp "^\\-+[0-9
16f0: 5d 2b 5c 5c 2d 2a 24 22 29 29 0a 0a 3b 3b 20 72 ]+\\-*$"))..;; r
1700: 65 74 75 72 6e 73 20 61 20 68 61 73 68 20 77 69 eturns a hash wi
1710: 74 68 20 65 6e 74 72 69 65 73 20 66 6f 72 20 61 th entries for a
1720: 6c 6c 20 66 6f 72 6d 73 20 2d 20 63 6f 75 6c 64 ll forms - could
1730: 20 77 65 6c 6c 20 75 73 65 20 61 20 70 72 6f 70 well use a prop
1740: 6c 69 73 74 3f 0a 28 64 65 66 69 6e 65 20 28 66 list?.(define (f
1750: 6f 72 6d 64 61 74 3a 6c 6f 61 64 2d 61 6c 6c 29 ormdat:load-all)
1760: 0a 20 20 28 6c 65 74 20 28 28 72 65 71 75 65 73 . (let ((reques
1770: 74 2d 6d 65 74 68 6f 64 20 28 67 65 74 65 6e 76 t-method (getenv
1780: 20 22 52 45 51 55 45 53 54 5f 4d 45 54 48 4f 44 "REQUEST_METHOD
1790: 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e "))). (if (an
17a0: 64 20 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 d request-method
17b0: 0a 09 20 20 20 20 20 28 73 74 72 69 6e 67 3d 3f .. (string=?
17c0: 20 72 65 71 75 65 73 74 2d 6d 65 74 68 6f 64 20 request-method
17d0: 22 50 4f 53 54 22 29 29 0a 09 28 66 6f 72 6d 64 "POST"))..(formd
17e0: 61 74 3a 6c 6f 61 64 2d 61 6c 6c 2d 70 6f 72 74 at:load-all-port
17f0: 20 28 63 75 72 72 65 6e 74 2d 69 6e 70 75 74 2d (current-input-
1800: 70 6f 72 74 29 29 29 29 29 0a 0a 3b 3b 20 28 73 port)))))..;; (s
1810: 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d 69 6e 70 :process-cgi-inp
1820: 75 74 20 28 63 61 61 61 72 20 64 61 74 29 29 0a ut (caaar dat)).
1830: 28 64 65 66 69 6e 65 20 28 66 6f 72 6d 64 61 74 (define (formdat
1840: 3a 6c 6f 61 64 2d 61 6c 6c 2d 70 6f 72 74 20 69 :load-all-port i
1850: 6e 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f np). (let* ((fo
1860: 72 6d 64 61 74 20 20 20 20 20 20 20 20 28 6d 61 rmdat (ma
1870: 6b 65 20 3c 66 6f 72 6d 64 61 74 3e 29 29 29 0a ke <formdat>))).
1880: 3b 3b 09 20 28 64 65 62 75 67 70 20 20 20 20 20 ;;. (debugp
1890: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
18a0: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 28 73 6c 6f -file (conc (slo
18b0: 74 2d 72 65 66 20 73 3a 73 65 73 73 69 6f 6e 20 t-ref s:session
18c0: 27 73 72 6f 6f 74 29 20 22 2f 64 65 6c 6d 65 2d 'sroot) "/delme-
18d0: 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d " (current-user-
18e0: 69 64 29 20 22 2e 6c 6f 67 22 29 29 29 29 0a 20 id) ".log")))).
18f0: 20 20 20 3b 3b 20 28 77 72 69 74 65 2d 73 74 72 ;; (write-str
1900: 69 6e 67 20 28 72 65 61 64 2d 73 74 72 69 6e 67 ing (read-string
1910: 20 23 66 20 69 6e 70 29 20 23 66 20 64 65 62 75 #f inp) #f debu
1920: 67 70 29 0a 20 20 20 20 28 6c 65 74 20 28 28 61 gp). (let ((a
1930: 6c 6c 64 61 74 73 20 28 66 6f 72 6d 64 61 74 3a lldats (formdat:
1940: 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 20 31 30 dat->list inp 10
1950: 65 36 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 e6))). .
1960: 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 64 65 ;; (format de
1970: 62 75 67 70 20 22 66 6f 72 6d 64 61 74 20 3a 20 bugp "formdat :
1980: 61 6c 6c 64 61 74 73 3a 20 7e 41 5c 6e 22 20 61 alldats: ~A\n" a
1990: 6c 6c 64 61 74 73 29 0a 20 20 20 20 20 20 28 6c lldats). (l
19a0: 65 74 20 28 28 66 69 72 73 74 69 74 65 6d 20 20 et ((firstitem
19b0: 20 28 63 61 72 20 61 6c 6c 64 61 74 73 29 29 0a (car alldats)).
19c0: 09 20 20 20 20 28 6d 75 6c 74 69 70 61 73 73 20 . (multipass
19d0: 23 66 29 29 20 0a 09 28 69 66 20 28 6e 6f 74 20 #f)) ..(if (not
19e0: 28 6e 75 6c 6c 3f 20 66 69 72 73 74 69 74 65 6d (null? firstitem
19f0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 73 74 72 )).. (if (str
1a00: 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 ing-match formda
1a10: 74 3a 64 65 6c 69 6d 2d 70 61 74 74 2d 72 65 78 t:delim-patt-rex
1a20: 20 28 63 61 61 72 20 66 69 72 73 74 69 74 65 6d (caar firstitem
1a30: 29 29 0a 09 09 28 73 65 74 21 20 6d 75 6c 74 69 ))...(set! multi
1a40: 70 61 73 73 20 23 74 29 29 29 0a 09 28 69 66 20 pass #t)))..(if
1a50: 6d 75 6c 74 69 70 61 73 73 0a 09 20 20 20 20 3b multipass.. ;
1a60: 3b 20 68 61 6e 64 6c 65 20 6d 75 6c 74 69 2d 70 ; handle multi-p
1a70: 61 72 74 20 66 6f 72 6d 0a 09 20 20 20 20 28 66 art form.. (f
1a80: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
1a90: 28 64 61 74 6c 73 74 29 0a 09 09 09 28 6c 65 74 (datlst)....(let
1aa0: 2a 20 28 28 68 65 61 64 65 72 20 28 66 6f 72 6d * ((header (form
1ab0: 64 61 74 3a 65 78 74 72 61 63 74 2d 68 65 61 64 dat:extract-head
1ac0: 65 72 2d 69 6e 66 6f 20 28 63 61 72 20 64 61 74 er-info (car dat
1ad0: 6c 73 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 lst)))....
1ae0: 20 28 6e 61 6d 65 20 20 20 28 69 66 20 28 61 73 (name (if (as
1af0: 73 6f 63 20 27 6e 61 6d 65 20 68 65 61 64 65 72 soc 'name header
1b00: 29 0a 09 09 09 09 09 20 20 20 28 73 74 72 69 6e )...... (strin
1b10: 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 61 64 72 20 g->symbol (cadr
1b20: 28 61 73 73 6f 63 20 27 6e 61 6d 65 20 68 65 61 (assoc 'name hea
1b30: 64 65 72 29 29 29 0a 09 09 09 09 09 20 20 20 22 der)))...... "
1b40: 22 29 29 20 3b 3b 20 67 72 75 6d 62 6c 65 0a 09 ")) ;; grumble..
1b50: 09 09 20 20 20 20 20 20 20 28 66 6e 61 6d 65 6c .. (fnamel
1b60: 20 20 28 61 73 73 6f 63 20 27 66 69 6c 65 6e 61 (assoc 'filena
1b70: 6d 65 20 68 65 61 64 65 72 29 29 0a 09 09 09 20 me header))....
1b80: 20 20 20 20 20 20 28 63 6f 6e 74 65 6e 74 20 28 (content (
1b90: 61 73 73 6f 63 20 27 63 6f 6e 74 65 6e 74 20 68 assoc 'content h
1ba0: 65 61 64 65 72 29 29 0a 09 09 09 20 20 20 20 20 eader))....
1bb0: 20 20 28 64 61 74 20 20 20 20 28 63 61 64 72 20 (dat (cadr
1bc0: 64 61 74 6c 73 74 29 29 29 0a 09 09 09 20 20 3b datlst))).... ;
1bd0: 3b 20 28 70 72 69 6e 74 20 22 68 65 61 64 65 72 ; (print "header
1be0: 3a 20 22 20 68 65 61 64 65 72 20 22 20 6e 61 6d : " header " nam
1bf0: 65 3a 20 22 20 6e 61 6d 65 20 22 20 66 6e 61 6d e: " name " fnam
1c00: 65 6c 3a 20 22 20 66 6e 61 6d 65 6c 20 22 20 63 el: " fnamel " c
1c10: 6f 6e 74 65 6e 74 3a 20 22 20 63 6f 6e 74 65 6e ontent: " conten
1c20: 74 29 20 3b 3b 20 20 22 20 64 61 74 3a 20 22 20 t) ;; " dat: "
1c30: 28 64 61 74 29 0a 09 09 09 20 20 28 66 6f 72 6d (dat).... (form
1c40: 64 61 74 3a 73 65 74 21 20 66 6f 72 6d 64 61 74 dat:set! formdat
1c50: 20 0a 09 09 09 09 09 6e 61 6d 65 0a 09 09 09 09 ......name.....
1c60: 09 28 69 66 20 66 6e 61 6d 65 6c 20 0a 09 09 09 .(if fnamel ....
1c70: 09 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 64 .. (list (cad
1c80: 72 20 66 6e 61 6d 65 6c 29 0a 09 09 09 09 09 09 r fnamel).......
1c90: 20 20 28 69 66 20 63 6f 6e 74 65 6e 74 0a 09 09 (if content...
1ca0: 09 09 09 09 20 20 20 20 20 20 28 63 61 64 72 20 .... (cadr
1cb0: 63 6f 6e 74 65 6e 74 29 0a 09 09 09 09 09 09 20 content).......
1cc0: 20 20 20 20 20 22 75 6e 6b 6e 6f 77 6e 22 29 0a "unknown").
1cd0: 09 09 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d ...... (string-
1ce0: 3e 62 6c 6f 62 20 64 61 74 29 29 0a 09 09 09 09 >blob dat)).....
1cf0: 09 20 20 20 20 64 61 74 29 29 29 29 0a 09 09 20 . dat))))...
1d00: 20 20 20 20 20 61 6c 6c 64 61 74 73 29 0a 09 20 alldats)..
1d10: 20 20 20 3b 3b 20 68 61 6e 64 6c 65 20 73 69 6e ;; handle sin
1d20: 67 6c 65 20 70 61 72 74 20 66 6f 72 6d 0a 09 20 gle part form..
1d30: 20 20 20 3b 3b 20 09 28 69 66 20 28 61 6e 64 20 ;; .(if (and
1d40: 28 73 74 72 69 6e 67 3f 20 6e 61 6d 65 29 0a 09 (string? name)..
1d50: 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 28 73 ;; .. (s
1d60: 74 72 69 6e 67 3d 3f 20 6e 61 6d 65 20 22 22 29 tring=? name "")
1d70: 29 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 ) ;; this is the
1d80: 20 73 68 6f 72 74 20 66 6f 72 6d 20 69 6e 70 75 short form inpu
1d90: 74 20 49 20 67 75 65 73 73 0a 09 20 20 20 20 3b t I guess.. ;
1da0: 3b 20 09 09 28 6c 65 74 2a 20 28 28 64 61 74 73 ; ..(let* ((dats
1db0: 74 72 20 28 63 61 61 72 20 64 61 74 6c 73 74 29 tr (caar datlst)
1dc0: 29 0a 09 20 20 20 20 3b 3b 20 09 09 20 20 20 20 ).. ;; ..
1dd0: 20 20 20 28 6d 75 6e 67 65 64 20 28 73 3a 70 72 (munged (s:pr
1de0: 6f 63 65 73 73 2d 63 67 69 2d 69 6e 70 75 74 20 ocess-cgi-input
1df0: 64 61 74 73 74 72 29 29 29 0a 09 20 20 20 20 3b datstr))).. ;
1e00: 3b 20 09 09 20 20 28 70 72 69 6e 74 20 22 64 61 ; .. (print "da
1e10: 74 73 74 72 3a 20 22 20 64 61 74 73 74 72 20 22 tstr: " datstr "
1e20: 20 6d 75 6e 67 65 64 3a 20 22 20 6d 75 6e 67 65 munged: " munge
1e30: 64 29 0a 09 20 20 20 20 28 66 6f 72 6d 64 61 74 d).. (formdat
1e40: 3a 6c 6f 61 64 20 66 6f 72 6d 64 61 74 20 20 28 :load formdat (
1e50: 73 3a 70 72 6f 63 65 73 73 2d 63 67 69 2d 69 6e s:process-cgi-in
1e60: 70 75 74 20 28 63 61 61 61 72 20 61 6c 6c 64 61 put (caaar allda
1e70: 74 73 29 29 29 29 20 3b 3b 20 6d 75 6e 67 65 64 ts)))) ;; munged
1e80: 29 29 0a 09 3b 3b 09 09 20 20 20 20 28 66 6f 72 ))..;;.. (for
1e90: 6d 61 74 20 64 65 62 75 67 70 20 22 66 6f 72 6d mat debugp "form
1ea0: 64 61 74 20 3a 20 6e 61 6d 65 3a 20 7e 41 20 63 dat : name: ~A c
1eb0: 6f 6e 74 65 6e 74 3a 20 7e 41 5c 6e 22 20 6e 61 ontent: ~A\n" na
1ec0: 6d 65 20 63 6f 6e 74 65 6e 74 29 0a 09 3b 3b 20 me content)..;;
1ed0: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
1ee0: 72 74 20 64 65 62 75 67 70 29 0a 09 66 6f 72 6d rt debugp)..form
1ef0: 64 61 74 29 29 29 29 0a 09 09 0a 23 7c 0a 28 64 dat))))....#|.(d
1f00: 65 66 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d efine inp (open-
1f10: 69 6e 70 75 74 2d 66 69 6c 65 20 22 74 65 73 74 input-file "test
1f20: 73 2f 65 78 61 6d 70 6c 65 2e 70 6f 73 74 2e 69 s/example.post.i
1f30: 6e 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 n")).(define dat
1f40: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 (read-string #f
1f50: 20 69 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 inp)).(define d
1f60: 61 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 atstr (open-inpu
1f70: 74 2d 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a t-string dat))..
1f80: 3b 3b 20 6f 72 0a 0a 28 64 65 66 69 6e 65 20 69 ;; or..(define i
1f90: 6e 70 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 np (open-input-f
1fa0: 69 6c 65 20 22 74 65 73 74 73 2f 65 78 61 6d 70 ile "tests/examp
1fb0: 6c 65 2e 70 6f 73 74 2e 62 69 6e 61 72 79 2e 69 le.post.binary.i
1fc0: 6e 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 n")).(define dat
1fd0: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 (read-string #f
1fe0: 20 69 6e 70 29 29 0a 28 64 65 66 69 6e 65 20 64 inp)).(define d
1ff0: 61 74 73 74 72 20 28 6f 70 65 6e 2d 69 6e 70 75 atstr (open-inpu
2000: 74 2d 73 74 72 69 6e 67 20 64 61 74 29 29 0a 0a t-string dat))..
2010: 28 66 6f 72 6d 64 61 74 3a 72 65 61 64 2d 68 65 (formdat:read-he
2020: 61 64 65 72 20 64 61 74 73 74 72 29 0a 0a 28 64 ader datstr)..(d
2030: 65 66 69 6e 65 20 64 61 74 20 28 66 6f 72 6d 64 efine dat (formd
2040: 61 74 3a 64 61 74 2d 3e 6c 69 73 74 20 69 6e 70 at:dat->list inp
2050: 20 31 30 65 36 29 29 0a 28 63 6c 6f 73 65 2d 69 10e6)).(close-i
2060: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c nput-port inp).|
2070: 23 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 66 6f #. .(define (fo
2080: 72 6d 64 61 74 3a 65 78 74 72 61 63 74 2d 68 65 rmdat:extract-he
2090: 61 64 65 72 2d 69 6e 66 6f 20 68 65 61 64 65 72 ader-info header
20a0: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 68 ). (if (null? h
20b0: 65 61 64 65 72 29 0a 20 20 20 20 20 20 27 28 29 eader). '()
20c0: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
20d0: 20 28 28 68 65 64 20 28 63 61 72 20 68 65 61 64 ((hed (car head
20e0: 65 72 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 er))... (tal (cd
20f0: 72 20 68 65 61 64 65 72 29 29 0a 09 09 20 28 72 r header))... (r
2100: 65 73 20 27 28 29 29 29 0a 09 28 69 66 20 28 73 es '()))..(if (s
2110: 74 72 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d tring-match form
2120: 64 61 74 3a 62 69 6e 2d 64 61 74 61 2d 64 69 73 dat:bin-data-dis
2130: 70 2d 72 65 78 20 68 65 64 29 20 3b 3b 20 0a 09 p-rex hed) ;; ..
2140: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 61 (let* ((data
2150: 2d 6e 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d -namem (string-m
2160: 61 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e atch formdat:bin
2170: 2d 64 61 74 61 2d 6e 61 6d 65 2d 72 65 78 20 68 -data-name-rex h
2180: 65 64 29 29 0a 09 09 20 20 20 28 66 69 6c 65 2d ed))... (file-
2190: 6e 61 6d 65 6d 20 28 73 74 72 69 6e 67 2d 6d 61 namem (string-ma
21a0: 74 63 68 20 66 6f 72 6d 64 61 74 3a 62 69 6e 2d tch formdat:bin-
21b0: 66 69 6c 65 2d 6e 61 6d 65 2d 72 65 78 20 68 65 file-name-rex he
21c0: 64 29 29 0a 09 09 20 20 20 28 64 61 74 61 2d 6e d))... (data-n
21d0: 61 6d 65 20 20 28 69 66 20 64 61 74 61 2d 6e 61 ame (if data-na
21e0: 6d 65 6d 20 28 63 61 64 72 20 64 61 74 61 2d 6e mem (cadr data-n
21f0: 61 6d 65 6d 29 20 23 66 29 29 0a 09 09 20 20 20 amem) #f))...
2200: 28 74 68 69 73 20 20 20 20 20 20 20 28 69 66 20 (this (if
2210: 66 69 6c 65 2d 6e 61 6d 65 6d 0a 09 09 09 09 20 file-namem.....
2220: 20 20 28 6c 69 73 74 20 28 6c 69 73 74 20 27 6e (list (list 'n
2230: 61 6d 65 20 64 61 74 61 2d 6e 61 6d 65 29 28 6c ame data-name)(l
2240: 69 73 74 20 27 66 69 6c 65 6e 61 6d 65 20 28 63 ist 'filename (c
2250: 61 64 72 20 66 69 6c 65 2d 6e 61 6d 65 6d 29 29 adr file-namem))
2260: 29 0a 09 09 09 09 20 20 20 28 6c 69 73 74 20 28 )..... (list (
2270: 6c 69 73 74 20 27 6e 61 6d 65 20 64 61 74 61 2d list 'name data-
2280: 6e 61 6d 65 29 29 29 29 29 0a 09 20 20 20 20 20 name)))))..
2290: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
22a0: 0a 09 09 20 20 28 61 70 70 65 6e 64 20 72 65 73 ... (append res
22b0: 20 74 68 69 73 29 0a 09 09 20 20 28 6c 6f 6f 70 this)... (loop
22c0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
22d0: 61 6c 29 28 61 70 70 65 6e 64 20 72 65 73 20 74 al)(append res t
22e0: 68 69 73 29 29 29 29 0a 09 20 20 20 20 28 6c 65 his)))).. (le
22f0: 74 20 28 28 63 6f 6e 74 65 6e 74 20 28 73 74 72 t ((content (str
2300: 69 6e 67 2d 6d 61 74 63 68 20 66 6f 72 6d 64 61 ing-match formda
2310: 74 3a 62 69 6e 2d 66 69 6c 65 2d 74 79 70 65 2d t:bin-file-type-
2320: 72 65 78 20 68 65 64 29 29 29 20 3b 3b 20 74 68 rex hed))) ;; th
2330: 69 73 20 69 73 20 74 68 65 20 73 74 61 6e 7a 61 is is the stanza
2340: 20 66 6f 72 20 74 68 65 20 63 6f 6e 74 65 6e 74 for the content
2350: 20 74 79 70 65 0a 09 20 20 20 20 20 20 28 69 66 type.. (if
2360: 20 63 6f 6e 74 65 6e 74 0a 09 09 20 20 28 6c 65 content... (le
2370: 74 20 28 28 6e 65 77 72 65 73 20 28 63 6f 6e 73 t ((newres (cons
2380: 20 28 6c 69 73 74 20 27 63 6f 6e 74 65 6e 74 20 (list 'content
2390: 28 63 61 64 72 20 63 6f 6e 74 65 6e 74 29 29 20 (cadr content))
23a0: 72 65 73 29 29 29 0a 09 09 20 20 20 20 28 69 66 res)))... (if
23b0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 (null? tal)....
23c0: 6e 65 77 72 65 73 0a 09 09 09 28 6c 6f 6f 70 20 newres....(loop
23d0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
23e0: 6c 29 20 6e 65 77 72 65 73 29 29 29 0a 09 09 20 l) newres)))...
23f0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
2400: 0a 09 09 20 20 20 20 20 20 72 65 73 0a 09 09 20 ... res...
2410: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
2420: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
2430: 73 29 0a 09 09 20 20 20 20 20 20 29 29 29 29 29 s)... )))))
2440: 29 29 0a 0a 3b 3b 09 20 20 20 20 20 20 28 6c 65 ))..;;. (le
2450: 74 20 6c 6f 6f 70 20 28 28 6c 20 20 20 20 20 20 t loop ((l
2460: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 20 3b 3b (read-line)) ;;
2470: 20 28 69 66 20 28 65 71 3f 20 6d 6f 64 65 20 27 (if (eq? mode '
2480: 6e 6f 72 6d 29 28 72 65 61 64 2d 6c 69 6e 65 29 norm)(read-line)
2490: 28 72 65 61 64 2d 63 68 61 72 29 29 29 0a 3b 3b (read-char))).;;
24a0: 09 09 09 20 28 65 6e 64 6c 69 6e 65 20 23 66 29 ... (endline #f)
24b0: 0a 3b 3b 09 09 09 20 28 6e 75 6d 20 20 20 20 20 .;;... (num
24c0: 30 29 29 0a 3b 3b 09 09 3b 3b 20 28 66 6f 72 6d 0)).;;..;; (form
24d0: 61 74 20 64 65 62 75 67 70 20 22 7e 41 5c 6e 22 at debugp "~A\n"
24e0: 20 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 l).;;
24f0: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
2500: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 (eof-object? l)
2510: 29 0a 3b 3b 09 09 20 20 20 20 20 20 28 6e 6f 74 ).;;.. (not
2520: 20 28 61 6e 64 20 28 65 71 3f 20 6d 6f 64 65 20 (and (eq? mode
2530: 27 62 69 6e 29 0a 3b 3b 09 09 09 09 28 73 74 72 'bin).;;....(str
2540: 69 6e 67 3d 3f 20 6c 20 22 22 29 29 29 29 20 3b ing=? l "")))) ;
2550: 3b 20 69 66 20 69 6e 20 62 69 6e 20 6d 6f 64 65 ; if in bin mode
2560: 20 65 6d 70 74 79 20 73 74 72 69 6e 67 20 69 73 empty string is
2570: 20 65 6e 64 20 6f 66 20 66 69 6c 65 0a 3b 3b 09 end of file.;;.
2580: 09 20 20 28 63 61 73 65 20 6d 6f 64 65 0a 3b 3b . (case mode.;;
2590: 09 09 20 20 20 20 28 28 73 74 61 72 74 29 0a 3b .. ((start).;
25a0: 3b 09 09 20 20 20 20 20 28 73 65 74 21 20 6d 6f ;.. (set! mo
25b0: 64 65 20 27 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 de 'norm).;;..
25c0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d (if (string-m
25d0: 61 74 63 68 20 64 65 6c 69 6d 2d 70 61 74 74 2d atch delim-patt-
25e0: 72 65 78 20 6c 29 0a 3b 3b 09 09 09 20 28 62 65 rex l).;;... (be
25f0: 67 69 6e 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 gin.;;... (set
2600: 21 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 20 6c ! delim-string l
2610: 29 0a 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 ).;;... (set!
2620: 64 65 6c 69 6d 2d 6c 65 6e 20 20 20 20 28 73 74 delim-len (st
2630: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6c 29 29 0a ring-length l)).
2640: 3b 3b 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 ;;... (loop (r
2650: 65 61 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 ead-line) #f 0))
2660: 0a 3b 3b 09 09 09 20 28 6c 6f 6f 70 20 6c 20 23 .;;... (loop l #
2670: 66 20 30 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 f 0))).;;.. (
2680: 28 6e 6f 72 6d 29 0a 3b 3b 09 09 20 20 20 20 20 (norm).;;..
2690: 3b 3b 20 49 20 64 6f 6e 27 74 20 6c 69 6b 65 20 ;; I don't like
26a0: 68 6f 77 20 74 68 69 73 20 67 65 74 73 20 63 68 how this gets ch
26b0: 65 63 6b 65 64 20 6f 6e 20 65 76 65 72 79 20 73 ecked on every s
26c0: 69 6e 67 6c 65 20 69 6e 70 75 74 2e 20 4d 75 73 ingle input. Mus
26d0: 74 20 62 65 20 61 20 62 65 74 74 65 72 20 77 61 t be a better wa
26e0: 79 2e 20 46 49 58 4d 45 0a 3b 3b 09 09 20 20 20 y. FIXME.;;..
26f0: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
2700: 6e 67 2d 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 ng-match bin-dat
2710: 61 2d 64 69 73 70 2d 72 65 78 20 6c 29 0a 3b 3b a-disp-rex l).;;
2720: 09 09 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 ... (string
2730: 2d 6d 61 74 63 68 20 62 69 6e 2d 64 61 74 61 2d -match bin-data-
2740: 6e 61 6d 65 2d 72 65 78 20 6c 29 0a 3b 3b 09 09 name-rex l).;;..
2750: 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d . (string-m
2760: 61 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 6e 61 atch bin-file-na
2770: 6d 65 2d 72 65 78 20 6c 29 29 0a 3b 3b 09 09 09 me-rex l)).;;...
2780: 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 20 (begin.;;...
2790: 28 73 65 74 21 20 64 61 74 61 2d 6e 61 6d 65 20 (set! data-name
27a0: 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d 61 (cadr (string-ma
27b0: 74 63 68 20 62 69 6e 2d 64 61 74 61 2d 6e 61 6d tch bin-data-nam
27c0: 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 09 e-rex l))).;;...
27d0: 20 20 20 28 73 65 74 21 20 66 69 6c 65 2d 6e 61 (set! file-na
27e0: 6d 65 20 28 63 61 64 72 20 28 73 74 72 69 6e 67 me (cadr (string
27f0: 2d 6d 61 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d -match bin-file-
2800: 6e 61 6d 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b name-rex l))).;;
2810: 09 09 09 20 20 20 28 73 65 74 21 20 6d 6f 64 65 ... (set! mode
2820: 20 27 63 6f 6e 74 65 6e 74 29 0a 3b 3b 09 09 09 'content).;;...
2830: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
2840: 69 6e 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b ine) #f num))).;
2850: 3b 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ;.. (let* ((
2860: 64 61 74 20 20 28 73 3a 70 72 6f 63 65 73 73 2d dat (s:process-
2870: 63 67 69 2d 69 6e 70 75 74 20 6c 29 29 29 20 3b cgi-input l))) ;
2880: 3b 20 28 43 47 49 3a 75 72 6c 2d 75 6e 71 75 6f ; (CGI:url-unquo
2890: 74 65 20 6c 29 29 0a 3b 3b 09 09 20 20 20 20 20 te l)).;;..
28a0: 20 20 28 66 6f 72 6d 61 74 20 64 65 62 75 67 70 (format debugp
28b0: 20 22 50 52 4f 43 45 53 53 2d 43 47 49 2d 49 4e "PROCESS-CGI-IN
28c0: 50 55 54 3a 20 7e 41 5c 6e 22 20 28 69 6e 74 65 PUT: ~A\n" (inte
28d0: 72 73 70 65 72 73 65 20 64 61 74 20 22 2c 22 29 rsperse dat ",")
28e0: 29 0a 3b 3b 09 09 20 20 20 20 20 20 20 28 66 6f ).;;.. (fo
28f0: 72 6d 64 61 74 3a 6c 6f 61 64 20 66 6f 72 6d 64 rmdat:load formd
2900: 61 74 20 64 61 74 29 0a 3b 3b 09 09 20 20 20 20 at dat).;;..
2910: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
2920: 69 6e 65 29 20 23 66 20 6e 75 6d 29 29 29 0a 3b ine) #f num))).;
2930: 3b 09 09 20 20 20 20 28 28 63 6f 6e 74 65 6e 74 ;.. ((content
2940: 29 0a 3b 3b 09 09 20 20 20 20 20 28 69 66 20 28 ).;;.. (if (
2950: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 62 69 6e string-match bin
2960: 2d 66 69 6c 65 2d 74 79 70 65 2d 72 65 78 20 6c -file-type-rex l
2970: 29 0a 3b 3b 09 09 09 20 28 62 65 67 69 6e 20 0a ).;;... (begin .
2980: 3b 3b 09 09 09 20 20 20 28 73 65 74 21 20 6d 6f ;;... (set! mo
2990: 64 65 20 27 62 69 6e 29 0a 3b 3b 09 09 09 20 20 de 'bin).;;...
29a0: 20 28 73 65 74 21 20 64 61 74 61 2d 74 79 70 65 (set! data-type
29b0: 20 28 63 61 64 72 20 28 73 74 72 69 6e 67 2d 6d (cadr (string-m
29c0: 61 74 63 68 20 62 69 6e 2d 66 69 6c 65 2d 74 79 atch bin-file-ty
29d0: 70 65 2d 72 65 78 20 6c 29 29 29 0a 3b 3b 09 09 pe-rex l))).;;..
29e0: 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d . (loop (read-
29f0: 73 74 72 69 6e 67 20 31 29 20 23 66 20 6e 75 6d string 1) #f num
2a00: 29 29 29 29 0a 3b 3b 09 09 20 20 20 20 28 28 62 )))).;;.. ((b
2a10: 69 6e 29 0a 3b 3b 09 09 20 20 20 20 20 3b 3b 20 in).;;.. ;;
2a20: 64 65 6c 69 6d 2d 73 74 72 69 6e 67 3a 20 5c 6e delim-string: \n
2a30: 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "---------------
2a40: 31 32 33 34 35 22 0a 3b 3b 09 09 20 20 20 20 20 12345".;;..
2a50: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2a60: 20 20 20 20 30 31 32 33 34 35 36 37 38 39 30 31 012345678901
2a70: 32 33 34 35 36 37 38 39 30 0a 3b 3b 09 09 20 20 234567890.;;..
2a80: 20 20 20 3b 3b 20 65 6e 64 6c 69 6e 65 3a 20 20 ;; endline:
2a90: 20 20 20 20 20 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d "---------
2aa0: 2d 2d 2d 2d 2d 2d 31 32 22 0a 3b 3b 09 09 20 20 ------12".;;..
2ab0: 20 20 20 3b 3b 20 6c 20 3d 20 22 33 22 0a 3b 3b ;; l = "3".;;
2ac0: 09 09 20 20 20 20 20 3b 3b 20 64 65 6c 69 6d 2d .. ;; delim-
2ad0: 6c 65 6e 20 3d 20 32 30 0a 3b 3b 09 09 20 20 20 len = 20.;;..
2ae0: 20 20 3b 3b 20 28 73 75 62 73 74 72 69 6e 67 20 ;; (substring
2af0: 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "--------------
2b00: 2d 31 32 33 34 35 22 20 31 37 20 31 38 29 20 3d -12345" 17 18) =
2b10: 3e 20 22 33 22 0a 3b 3b 09 09 20 20 20 20 20 3b > "3".;;.. ;
2b20: 3b 0a 3b 3b 09 09 20 20 20 20 20 28 63 6f 6e 64 ;.;;.. (cond
2b30: 0a 3b 3b 09 09 20 20 20 20 20 20 20 3b 3b 20 68 .;;.. ;; h
2b40: 61 76 65 6e 27 74 20 66 6f 75 6e 64 20 74 68 65 aven't found the
2b50: 20 73 74 61 72 74 20 6f 66 20 61 6e 20 65 6e 64 start of an end
2b60: 6c 69 6e 65 2c 20 69 73 20 74 68 65 20 6e 65 78 line, is the nex
2b70: 74 20 63 68 61 72 20 61 20 6e 65 77 6c 69 6e 65 t char a newline
2b80: 3f 0a 3b 3b 09 09 20 20 20 20 20 20 28 28 61 6e ?.;;.. ((an
2b90: 64 20 28 6e 6f 74 20 65 6e 64 6c 69 6e 65 29 0a d (not endline).
2ba0: 3b 3b 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 ;;... (string
2bb0: 3d 3f 20 6c 20 22 5c 6e 22 29 29 20 3b 3b 20 72 =? l "\n")) ;; r
2bc0: 65 71 75 69 72 65 64 20 66 69 72 73 74 20 63 68 equired first ch
2bd0: 61 72 61 63 74 65 72 20 0a 3b 3b 09 09 20 20 20 aracter .;;..
2be0: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 65 6e (let ((newen
2bf0: 64 6c 69 6e 65 20 28 6f 70 65 6e 2d 6f 75 74 70 dline (open-outp
2c00: 75 74 2d 73 74 72 69 6e 67 29 29 29 0a 3b 3b 09 ut-string))).;;.
2c10: 09 09 20 3b 3b 20 28 77 72 69 74 65 2d 6c 69 6e .. ;; (write-lin
2c20: 65 20 6c 20 6e 65 77 65 6e 64 6c 69 6e 65 29 20 e l newendline)
2c30: 3b 3b 20 64 69 73 63 61 72 64 20 74 68 65 20 6e ;; discard the n
2c40: 65 77 6c 69 6e 65 2e 20 61 64 64 20 69 74 20 62 ewline. add it b
2c50: 61 63 6b 20 69 66 20 64 6f 6e 27 74 20 68 61 76 ack if don't hav
2c60: 65 20 61 20 6c 6f 63 6b 20 6f 6e 20 64 65 6c 69 e a lock on deli
2c70: 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 28 m-string.;;... (
2c80: 6c 6f 6f 70 20 28 72 65 61 64 2d 73 74 72 69 6e loop (read-strin
2c90: 67 20 31 29 20 6e 65 77 65 6e 64 6c 69 6e 65 20 g 1) newendline
2ca0: 28 2b 20 6e 75 6d 20 31 29 29 29 29 0a 3b 3b 09 (+ num 1)))).;;.
2cb0: 09 20 20 20 20 20 20 28 28 6e 6f 74 20 65 6e 64 . ((not end
2cc0: 6c 69 6e 65 29 0a 3b 3b 09 09 20 20 20 20 20 20 line).;;..
2cd0: 20 28 77 72 69 74 65 2d 73 74 72 69 6e 67 20 6c (write-string l
2ce0: 20 23 66 20 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 #f bin-dat).;;.
2cf0: 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 . (loop (r
2d00: 65 61 64 2d 73 74 72 69 6e 67 20 31 29 20 23 66 ead-string 1) #f
2d10: 20 28 2b 20 6e 75 6d 20 31 29 29 29 0a 3b 3b 09 (+ num 1))).;;.
2d20: 09 20 20 20 20 20 20 3b 3b 20 73 74 72 69 6e 67 . ;; string
2d30: 20 73 6f 20 66 61 72 20 6d 61 74 63 68 65 73 20 so far matches
2d40: 64 65 6c 69 6d 2d 73 74 72 69 6e 67 0a 3b 3b 09 delim-string.;;.
2d50: 09 20 20 20 20 20 20 28 65 6e 64 6c 69 6e 65 0a . (endline.
2d60: 3b 3b 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a ;;.. (let*
2d70: 20 28 28 65 6e 64 73 74 72 20 28 67 65 74 2d 6f ((endstr (get-o
2d80: 75 74 70 75 74 2d 73 74 72 69 6e 67 20 65 6e 64 utput-string end
2d90: 6c 69 6e 65 29 29 0a 3b 3b 09 09 09 20 20 20 20 line)).;;...
2da0: 20 20 28 65 6e 64 6c 65 6e 20 28 73 74 72 69 6e (endlen (strin
2db0: 67 2d 6c 65 6e 67 74 68 20 65 6e 64 73 74 72 29 g-length endstr)
2dc0: 29 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 3e 20 )).;;... (if (>
2dd0: 65 6e 64 6c 65 6e 20 30 29 0a 3b 3b 09 09 09 20 endlen 0).;;...
2de0: 20 20 20 20 28 66 6f 72 6d 61 74 20 64 65 62 75 (format debu
2df0: 67 70 20 22 20 64 65 6c 69 6d 3a 20 7e 41 5c 6e gp " delim: ~A\n
2e00: 65 6e 64 73 74 72 3a 20 7e 41 5c 6e 22 20 64 65 endstr: ~A\n" de
2e10: 6c 69 6d 2d 73 74 72 69 6e 67 20 65 6e 64 73 74 lim-string endst
2e20: 72 29 29 0a 3b 3b 09 09 09 20 28 69 66 20 28 61 r)).;;... (if (a
2e30: 6e 64 20 28 3e 20 64 65 6c 69 6d 2d 6c 65 6e 20 nd (> delim-len
2e40: 65 6e 64 6c 65 6e 29 0a 3b 3b 09 09 09 09 20 20 endlen).;;....
2e50: 28 73 74 72 69 6e 67 3d 3f 20 6c 20 28 73 75 62 (string=? l (sub
2e60: 73 74 72 69 6e 67 20 64 65 6c 69 6d 2d 73 74 72 string delim-str
2e70: 69 6e 67 20 65 6e 64 6c 65 6e 20 28 2b 20 65 6e ing endlen (+ en
2e80: 64 6c 65 6e 20 31 29 29 29 29 0a 3b 3b 09 09 09 dlen 1)))).;;...
2e90: 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 ;; yes, thi
2ea0: 73 20 63 68 61 72 61 63 74 65 72 20 6d 61 74 63 s character matc
2eb0: 68 65 73 20 74 68 65 20 6e 65 78 74 20 69 6e 20 hes the next in
2ec0: 74 68 65 20 64 65 6c 69 6d 2d 73 74 72 69 6e 67 the delim-string
2ed0: 0a 3b 3b 09 09 09 20 20 20 20 20 28 69 66 20 28 .;;... (if (
2ee0: 65 71 3f 20 64 65 6c 69 6d 2d 6c 65 6e 20 65 6e eq? delim-len en
2ef0: 64 6c 65 6e 29 20 3b 3b 20 68 61 76 65 20 61 20 dlen) ;; have a
2f00: 6d 61 74 63 68 21 20 49 67 6e 6f 72 65 20 74 68 match! Ignore th
2f10: 61 74 20 61 20 6e 65 77 6c 69 6e 65 20 69 73 20 at a newline is
2f20: 72 65 71 75 69 72 65 64 2e 20 4c 61 7a 79 20 62 required. Lazy b
2f30: 75 67 67 65 72 2e 0a 3b 3b 09 09 09 09 20 28 6c ugger..;;.... (l
2f40: 65 74 2a 20 28 28 66 6e 20 20 20 20 20 20 28 73 et* ((fn (s
2f50: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 64 61 tring->symbol da
2f60: 74 61 2d 6e 61 6d 65 29 29 29 0a 3b 3b 09 09 09 ta-name))).;;...
2f70: 09 20 20 20 28 66 6f 72 6d 64 61 74 3a 73 65 74 . (formdat:set
2f80: 21 20 66 6f 72 6d 64 61 74 20 66 6e 20 28 6c 69 ! formdat fn (li
2f90: 73 74 20 66 69 6c 65 2d 6e 61 6d 65 20 64 61 74 st file-name dat
2fa0: 61 2d 74 79 70 65 20 28 73 74 72 69 6e 67 2d 3e a-type (string->
2fb0: 62 6c 6f 62 20 28 67 65 74 2d 6f 75 74 70 75 74 blob (get-output
2fc0: 2d 73 74 72 69 6e 67 20 62 69 6e 2d 64 61 74 29 -string bin-dat)
2fd0: 29 29 29 0a 3b 3b 09 09 09 09 20 20 20 28 73 65 ))).;;.... (se
2fe0: 74 21 20 6d 6f 64 65 20 27 6e 6f 72 6d 29 0a 3b t! mode 'norm).;
2ff0: 3b 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 72 ;.... (loop (r
3000: 65 61 64 2d 6c 69 6e 65 29 20 23 66 20 30 29 29 ead-line) #f 0))
3010: 0a 3b 3b 09 09 09 09 20 28 62 65 67 69 6e 0a 3b .;;.... (begin.;
3020: 3b 09 09 09 09 20 20 20 28 77 72 69 74 65 2d 73 ;.... (write-s
3030: 74 72 69 6e 67 20 6c 20 23 66 20 65 6e 64 6c 69 tring l #f endli
3040: 6e 65 29 0a 3b 3b 09 09 09 09 20 20 20 28 6c 6f ne).;;.... (lo
3050: 6f 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 op (read-string
3060: 31 29 20 65 6e 64 6c 69 6e 65 20 28 2b 20 6e 75 1) endline (+ nu
3070: 6d 20 31 29 29 29 29 0a 3b 3b 09 09 09 20 20 20 m 1)))).;;...
3080: 20 20 3b 3b 20 6e 6f 2c 20 74 68 69 73 20 63 68 ;; no, this ch
3090: 61 72 61 63 74 65 72 20 64 6f 65 73 20 4e 4f 54 aracter does NOT
30a0: 20 6d 61 74 63 68 20 74 68 65 20 6e 65 78 74 20 match the next
30b0: 69 6e 20 6c 69 6e 65 20 69 6e 20 64 65 6c 69 6d in line in delim
30c0: 2d 73 74 72 69 6e 67 0a 3b 3b 09 09 09 20 20 20 -string.;;...
30d0: 20 20 28 62 65 67 69 6e 0a 3b 3b 09 09 09 20 20 (begin.;;...
30e0: 20 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 (write-stri
30f0: 6e 67 20 22 5c 6e 22 20 23 66 20 62 69 6e 2d 64 ng "\n" #f bin-d
3100: 61 74 29 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 at) ;; don't for
3110: 67 65 74 20 74 68 61 74 20 6e 65 77 6c 69 6e 65 get that newline
3120: 20 77 65 20 64 72 6f 70 70 65 64 0a 3b 3b 09 09 we dropped.;;..
3130: 09 20 20 20 20 20 20 20 28 77 72 69 74 65 2d 73 . (write-s
3140: 74 72 69 6e 67 20 65 6e 64 73 74 72 20 23 66 20 tring endstr #f
3150: 62 69 6e 2d 64 61 74 29 0a 3b 3b 09 09 09 20 20 bin-dat).;;...
3160: 20 20 20 20 20 28 77 72 69 74 65 2d 73 74 72 69 (write-stri
3170: 6e 67 20 6c 20 23 66 20 62 69 6e 2d 64 61 74 29 ng l #f bin-dat)
3180: 0a 3b 3b 09 09 09 20 20 20 20 20 20 20 28 6c 6f .;;... (lo
3190: 6f 70 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 op (read-string
31a0: 31 29 20 23 66 20 28 2b 20 6e 75 6d 20 31 29 29 1) #f (+ num 1))
31b0: 29 29 29 29 29 29 0a 3b 3b 09 09 20 20 20 20 29 )))))).;;.. )
31c0: 29 29 29 29 0a 0a 3b 3b 20 20 20 20 28 66 6f 72 ))))..;; (for
31d0: 6d 64 61 74 3a 70 72 69 6e 74 61 6c 6c 20 66 6f mdat:printall fo
31e0: 72 6d 64 61 74 20 28 6c 61 6d 62 64 61 20 28 78 rmdat (lambda (x
31f0: 29 28 77 72 69 74 65 2d 6c 69 6e 65 20 78 20 64 )(write-line x d
3200: 65 62 75 67 70 29 29 29 0a 0a 23 7c 0a 28 64 65 ebugp)))..#|.(de
3210: 66 69 6e 65 20 69 6e 70 20 28 6f 70 65 6e 2d 69 fine inp (open-i
3220: 6e 70 75 74 2d 66 69 6c 65 20 22 2f 74 6d 70 2f nput-file "/tmp/
3230: 73 74 6d 6c 72 75 6e 2f 64 65 6c 6d 65 2d 33 33 stmlrun/delme-33
3240: 2e 6c 6f 67 2e 6b 65 65 70 2d 66 6f 72 2d 72 65 .log.keep-for-re
3250: 66 22 29 29 0a 28 64 65 66 69 6e 65 20 64 61 74 f")).(define dat
3260: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 23 66 (read-string #f
3270: 20 69 6e 70 29 29 0a 28 63 6c 6f 73 65 2d 69 6e inp)).(close-in
3280: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 7c 23 put-port inp).|#
3290: 0a .