Artifact
1fd229ce93d40b5ce04d10a2ed6d3d5214eaba71
File
keys.scm
— part of check-in
[c5b61052dd]
at
2011-10-12 23:26:10
on branch trunk
— Added -reqtarg and -target for easier launching
(user:
matt
size: 4916)
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 20 0a 3b 3b 3d 3d PURPOSE.. .;;==
0150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0190: 3d 3d 3d 3d 0a 3b 3b 20 52 75 6e 20 6b 65 79 73 ====.;; Run keys
01a0: 2c 20 74 68 65 73 65 20 61 72 65 20 75 73 65 64 , these are used
01b0: 20 74 6f 20 68 69 65 72 61 72 63 68 69 61 6c 6c to hierarchiall
01c0: 79 20 6f 72 67 61 6e 69 73 65 20 74 65 73 74 73 y organise tests
01d0: 20 61 6e 64 20 72 75 6e 20 61 72 65 61 73 0a 3b and run areas.;
01e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 73 71 =======..(use sq
0230: 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 lite3 srfi-1 pos
0240: 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 ix regex regex-c
0250: 61 73 65 20 73 72 66 69 2d 36 39 29 0a 28 69 6d ase srfi-69).(im
0260: 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c port (prefix sql
0270: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a ite3 sqlite3:)).
0280: 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 .(declare (unit
0290: 6b 65 79 73 29 29 0a 28 64 65 63 6c 61 72 65 20 keys)).(declare
02a0: 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 0a (uses common))..
02b0: 28 69 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 (include "key_re
02c0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
02d0: 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 lude "common_rec
02e0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 ords.scm")..(def
02f0: 69 6e 65 20 28 67 65 74 2d 6b 65 79 73 20 64 62 ine (get-keys db
0300: 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 ). (let ((keys
0310: 27 28 29 29 29 20 3b 3b 20 6b 65 79 73 20 61 72 '())) ;; keys ar
0320: 65 20 76 65 63 74 6f 72 73 20 3c 66 69 65 6c 64 e vectors <field
0330: 6e 61 6d 65 2c 74 79 70 65 3e 0a 20 20 20 20 28 name,type>. (
0340: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
0350: 2d 72 6f 77 20 28 6c 61 6d 62 64 61 20 28 66 69 -row (lambda (fi
0360: 65 6c 64 6e 61 6d 65 20 66 69 65 6c 64 74 79 70 eldname fieldtyp
0370: 65 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 e).... (set!
0380: 6b 65 79 73 20 28 63 6f 6e 73 20 28 76 65 63 74 keys (cons (vect
0390: 6f 72 20 66 69 65 6c 64 6e 61 6d 65 20 66 69 65 or fieldname fie
03a0: 6c 64 74 79 70 65 29 20 6b 65 79 73 29 29 29 0a ldtype) keys))).
03b0: 09 09 09 20 20 64 62 0a 09 09 09 20 20 22 53 45 ... db.... "SE
03c0: 4c 45 43 54 20 66 69 65 6c 64 6e 61 6d 65 2c 66 LECT fieldname,f
03d0: 69 65 6c 64 74 79 70 65 20 46 52 4f 4d 20 6b 65 ieldtype FROM ke
03e0: 79 73 20 4f 52 44 45 52 20 42 59 20 69 64 20 41 ys ORDER BY id A
03f0: 53 43 3b 22 29 0a 20 20 20 20 28 72 65 76 65 72 SC;"). (rever
0400: 73 65 20 6b 65 79 73 29 29 29 20 3b 3b 20 63 6f se keys))) ;; co
0410: 75 6c 64 20 6a 75 73 74 20 73 6f 72 74 20 64 65 uld just sort de
0420: 73 63 3f 0a 0a 3b 3b 20 67 65 74 20 6b 65 79 20 sc?..;; get key
0430: 76 61 6c 73 20 66 6f 72 20 61 20 67 69 76 65 6e vals for a given
0440: 20 72 75 6e 2d 69 64 0a 28 64 65 66 69 6e 65 20 run-id.(define
0450: 28 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 64 62 (get-key-vals db
0460: 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a run-id). (let*
0470: 20 28 28 6b 65 79 73 20 28 67 65 74 2d 6b 65 79 ((keys (get-key
0480: 73 20 64 62 29 29 0a 09 20 28 72 65 73 20 20 27 s db)).. (res '
0490: 28 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a ())). (debug:
04a0: 70 72 69 6e 74 20 36 20 22 6b 65 79 73 3a 20 22 print 6 "keys: "
04b0: 20 6b 65 79 73 20 22 20 72 75 6e 2d 69 64 3a 20 keys " run-id:
04c0: 22 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 28 66 " run-id). (f
04d0: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
04e0: 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 20 ambda (key).
04f0: 20 20 20 28 6c 65 74 20 28 28 71 72 79 20 28 63 (let ((qry (c
0500: 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 20 28 6b onc "SELECT " (k
0510: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
0520: 20 6b 65 79 29 20 22 20 46 52 4f 4d 20 72 75 6e key) " FROM run
0530: 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 29 29 s WHERE id=?;"))
0540: 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ).. ;; (debug:pr
0550: 69 6e 74 20 30 20 22 71 72 79 3a 20 22 20 71 72 int 0 "qry: " qr
0560: 79 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 66 6f y).. (sqlite3:fo
0570: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 20 28 r-each-row .. (
0580: 6c 61 6d 62 64 61 20 28 6b 65 79 2d 76 61 6c 29 lambda (key-val)
0590: 0a 09 20 20 20 20 28 73 65 74 21 20 72 65 73 20 .. (set! res
05a0: 28 63 6f 6e 73 20 6b 65 79 2d 76 61 6c 20 72 65 (cons key-val re
05b0: 73 29 29 29 0a 09 20 20 64 62 20 71 72 79 20 72 s))).. db qry r
05c0: 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 20 6b 65 un-id))). ke
05d0: 79 73 29 0a 20 20 20 20 28 72 65 76 65 72 73 65 ys). (reverse
05e0: 20 72 65 73 29 29 29 0a 0a 3b 3b 20 67 65 74 20 res)))..;; get
05f0: 6b 65 79 20 76 61 6c 20 70 61 69 72 73 20 66 6f key val pairs fo
0600: 72 20 61 20 67 69 76 65 6e 20 72 75 6e 2d 69 64 r a given run-id
0610: 0a 3b 3b 20 28 20 28 46 49 45 4c 44 4e 41 4d 45 .;; ( (FIELDNAME
0620: 31 20 6b 65 79 76 61 6c 31 29 20 28 46 49 45 4c 1 keyval1) (FIEL
0630: 44 4e 41 4d 45 32 20 6b 65 79 76 61 6c 32 29 20 DNAME2 keyval2)
0640: 2e 2e 2e 20 29 0a 28 64 65 66 69 6e 65 20 28 6b ... ).(define (k
0650: 65 79 73 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d eys:get-key-val-
0660: 70 61 69 72 73 20 64 62 20 72 75 6e 2d 69 64 29 pairs db run-id)
0670: 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 . (let* ((keys
0680: 28 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 (get-keys db))..
0690: 20 28 72 65 73 20 20 27 28 29 29 29 0a 20 20 20 (res '())).
06a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 (debug:print 6
06b0: 22 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 "keys: " keys "
06c0: 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 run-id: " run-id
06d0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
06e0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b . (lambda (k
06f0: 65 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 ey). (let
0700: 28 28 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c ((qry (conc "SEL
0710: 45 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 ECT " (key:get-f
0720: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
0730: 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 FROM runs WHERE
0740: 69 64 3d 3f 3b 22 29 29 29 0a 09 20 3b 3b 20 28 id=?;"))).. ;; (
0750: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 71 debug:print 0 "q
0760: 72 79 3a 20 22 20 71 72 79 29 0a 09 20 28 73 71 ry: " qry).. (sq
0770: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
0780: 6f 77 20 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 ow .. (lambda (
0790: 6b 65 79 2d 76 61 6c 29 0a 09 20 20 20 20 28 73 key-val).. (s
07a0: 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c et! res (cons (l
07b0: 69 73 74 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 ist (key:get-fie
07c0: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 6b 65 79 2d ldname key) key-
07d0: 76 61 6c 29 20 72 65 73 29 29 29 0a 09 20 20 64 val) res))).. d
07e0: 62 20 71 72 79 20 72 75 6e 2d 69 64 29 29 29 0a b qry run-id))).
07f0: 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 20 28 keys). (
0800: 72 65 76 65 72 73 65 20 72 65 73 29 29 29 0a 0a reverse res)))..
0810: 28 64 65 66 69 6e 65 20 28 6b 65 79 73 2d 3e 6b (define (keys->k
0820: 65 79 73 74 72 20 6b 65 79 73 29 20 3b 3b 20 3d eystr keys) ;; =
0830: 3e 20 6b 65 79 31 2c 6b 65 79 32 2c 6b 65 79 33 > key1,key2,key3
0840: 2c 61 64 64 69 74 69 6f 6e 61 31 2c 20 2e 2e 2e ,additiona1, ...
0850: 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
0860: 73 70 65 72 73 65 20 28 6d 61 70 20 6b 65 79 3a sperse (map key:
0870: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0880: 79 73 29 20 22 2c 22 29 29 0a 0a 28 64 65 66 69 ys) ","))..(defi
0890: 6e 65 20 28 61 72 67 73 3a 75 73 61 67 65 20 2e ne (args:usage .
08a0: 20 61 29 20 23 66 29 0a 0a 3b 3b 20 6b 65 79 73 a) #f)..;; keys
08b0: 2d 3e 76 61 6c 6c 69 73 74 20 69 73 20 63 61 6c ->vallist is cal
08c0: 6c 65 64 20 73 65 76 65 72 61 6c 20 74 69 6d 65 led several time
08d0: 73 20 28 71 75 69 74 65 20 75 6e 6e 65 63 65 73 s (quite unneces
08e0: 73 61 72 69 6c 79 29 2c 20 75 73 65 20 74 68 69 sarily), use thi
08f0: 73 20 68 61 73 68 20 74 6f 20 73 75 70 70 72 65 s hash to suppre
0900: 73 73 20 6d 75 6c 74 69 70 6c 65 0a 3b 3b 20 72 ss multiple.;; r
0910: 65 70 6f 72 74 69 6e 67 20 6f 66 20 6d 69 73 73 eporting of miss
0920: 69 6e 67 20 6b 65 79 73 20 6f 6e 20 74 68 65 20 ing keys on the
0930: 63 6f 6d 6d 61 6e 64 20 6c 69 6e 65 2e 0a 28 64 command line..(d
0940: 65 66 69 6e 65 20 6b 65 79 73 3a 77 61 72 6e 69 efine keys:warni
0950: 6e 67 2d 73 75 70 70 72 65 73 73 2d 68 61 73 68 ng-suppress-hash
0960: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0970: 65 29 29 0a 0a 3b 3b 20 74 68 69 73 20 6e 6f 77 e))..;; this now
0980: 20 69 6e 76 61 6c 69 64 61 74 65 73 20 75 73 69 invalidates usi
0990: 6e 67 20 22 2f 22 20 69 6e 20 69 74 65 6d 20 6e ng "/" in item n
09a0: 61 6d 65 73 0a 28 64 65 66 69 6e 65 20 28 6b 65 ames.(define (ke
09b0: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
09c0: 67 73 20 6b 65 79 73 20 74 61 72 67 65 74 20 68 gs keys target h
09d0: 74 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 73 t). (let ((vals
09e0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
09f0: 61 72 67 65 74 20 22 2f 22 29 29 29 0a 20 20 20 arget "/"))).
0a00: 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 (if (eq? (lengt
0a10: 68 20 76 61 6c 73 29 28 6c 65 6e 67 74 68 20 6b h vals)(length k
0a20: 65 79 73 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 eys))..(for-each
0a30: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 (lambda (key va
0a40: 6c 29 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 l)... (hash-t
0a50: 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 63 6f able-set! ht (co
0a60: 6e 63 20 22 3a 22 20 28 76 65 63 74 6f 72 2d 72 nc ":" (vector-r
0a70: 65 66 20 6b 65 79 20 30 29 29 20 76 61 6c 29 29 ef key 0)) val))
0a80: 0a 09 09 20 20 6b 65 79 73 0a 09 09 20 20 76 61 ... keys... va
0a90: 6c 73 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e ls)..(debug:prin
0aa0: 74 20 30 20 22 45 52 52 4f 52 3a 20 77 72 6f 6e t 0 "ERROR: wron
0ab0: 67 20 6e 75 6d 62 65 72 20 6f 66 20 76 61 6c 75 g number of valu
0ac0: 65 73 20 69 6e 20 22 20 74 61 72 67 65 74 20 22 es in " target "
0ad0: 2c 20 73 68 6f 75 6c 64 20 6d 61 74 63 68 20 22 , should match "
0ae0: 20 6b 65 79 73 29 29 0a 20 20 20 20 76 61 6c 73 keys)). vals
0af0: 29 29 0a 0a 3b 3b 20 55 73 69 6e 67 20 74 68 65 ))..;; Using the
0b00: 20 6b 65 79 73 20 70 75 6c 6c 65 64 20 66 72 6f keys pulled fro
0b10: 6d 20 74 68 65 20 64 61 74 61 62 61 73 65 20 28 m the database (
0b20: 69 6e 69 74 69 61 6c 6c 79 20 73 65 74 20 66 72 initially set fr
0b30: 6f 6d 20 74 68 65 20 6d 65 67 61 74 65 73 74 2e om the megatest.
0b40: 63 6f 6e 66 69 67 20 66 69 6c 65 29 0a 3b 3b 20 config file).;;
0b50: 6c 6f 6f 6b 20 66 6f 72 20 74 68 65 20 65 71 75 look for the equ
0b60: 69 76 61 6c 65 6e 74 20 76 61 6c 75 65 20 6f 6e ivalent value on
0b70: 20 74 68 65 20 63 6f 6d 6d 61 6e 64 20 6c 69 6e the command lin
0b80: 65 20 61 6e 64 20 61 64 64 20 69 74 20 74 6f 20 e and add it to
0b90: 61 20 6c 69 73 74 2c 20 6f 72 20 23 66 20 69 66 a list, or #f if
0ba0: 20 6e 6f 74 20 66 6f 75 6e 64 2e 0a 3b 3b 20 64 not found..;; d
0bb0: 65 66 61 75 6c 74 20 3d 3e 20 28 76 61 6c 31 20 efault => (val1
0bc0: 76 61 6c 32 20 76 61 6c 33 20 2e 2e 2e 29 0a 3b val2 val3 ...).;
0bd0: 3b 20 77 69 74 68 6b 65 79 20 3d 3e 20 28 3a 6b ; withkey => (:k
0be0: 65 79 31 20 76 61 6c 31 20 3a 6b 65 79 32 20 76 ey1 val1 :key2 v
0bf0: 61 6c 32 20 3a 6b 65 79 33 20 76 61 6c 33 20 2e al2 :key3 val3 .
0c00: 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b 65 79 ..).(define (key
0c10: 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 s->vallist keys
0c20: 2e 20 77 69 74 68 6b 65 79 29 20 3b 3b 20 4f 52 . withkey) ;; OR
0c30: 44 45 52 49 4e 47 20 49 53 20 56 45 52 59 20 49 DERING IS VERY I
0c40: 4d 50 4f 52 54 41 4e 54 2c 20 4b 45 45 50 20 50 MPORTANT, KEEP P
0c50: 52 4f 50 45 52 20 4f 52 44 45 52 20 48 45 52 45 ROPER ORDER HERE
0c60: 21 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e !. (let* ((keyn
0c70: 61 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 3a ames (map key:
0c80: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0c90: 79 73 29 29 0a 09 20 28 61 72 67 6b 65 79 73 20 ys)).. (argkeys
0ca0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
0cb0: 28 6b 29 28 63 6f 6e 63 20 22 3a 22 20 6b 29 29 (k)(conc ":" k))
0cc0: 20 6b 65 79 6e 61 6d 65 73 29 29 0a 09 20 28 77 keynames)).. (w
0cd0: 69 74 68 6b 65 79 20 20 20 20 28 6e 6f 74 20 28 ithkey (not (
0ce0: 6e 75 6c 6c 3f 20 77 69 74 68 6b 65 79 29 29 29 null? withkey)))
0cf0: 0a 09 20 28 6e 65 77 72 65 6d 61 72 67 73 20 28 .. (newremargs (
0d00: 61 72 67 73 3a 67 65 74 2d 61 72 67 73 20 28 63 args:get-args (c
0d10: 6f 6e 73 20 22 62 6c 61 68 22 20 72 65 6d 61 72 ons "blah" remar
0d20: 67 73 29 20 61 72 67 6b 65 79 73 20 27 28 29 20 gs) argkeys '()
0d30: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 20 30 29 args:arg-hash 0)
0d40: 29 29 20 3b 3b 20 74 68 65 20 63 6f 6e 73 20 62 )) ;; the cons b
0d50: 6c 61 68 20 77 6f 72 6b 73 20 61 72 6f 75 6e 64 lah works around
0d60: 20 61 20 62 75 67 20 69 6e 20 61 72 67 73 20 5b a bug in args [
0d70: 61 72 67 73 20 61 73 73 75 6d 65 73 20 28 22 63 args assumes ("c
0d80: 61 6c 6c 69 6e 67 2d 70 72 6f 67 2d 6e 61 6d 65 alling-prog-name
0d90: 22 20 2e 2e 2e 2e 20 29 20 5d 0a 20 20 20 20 3b " .... ) ]. ;
0da0: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 ;(debug:print 0
0db0: 22 72 65 6d 61 72 67 73 3a 20 22 20 72 65 6d 61 "remargs: " rema
0dc0: 72 67 73 20 22 20 6e 65 77 72 65 6d 61 72 67 73 rgs " newremargs
0dd0: 3a 20 22 20 6e 65 77 72 65 6d 61 72 67 73 29 0a : " newremargs).
0de0: 20 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e (apply appen
0df0: 64 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 d (map (lambda (
0e00: 78 29 0a 09 09 09 20 28 6c 65 74 20 28 28 76 61 x).... (let ((va
0e10: 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 l (args:get-arg
0e20: 78 29 29 29 0a 09 09 09 20 20 20 3b 3b 20 28 64 x))).... ;; (d
0e30: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 78 3a ebug:print 0 "x:
0e40: 20 22 20 78 20 22 20 76 61 6c 3a 20 22 20 76 61 " x " val: " va
0e50: 6c 29 0a 09 09 09 20 20 20 28 69 66 20 28 6e 6f l).... (if (no
0e60: 74 20 76 61 6c 29 0a 09 09 09 20 20 20 20 20 20 t val)....
0e70: 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 69 66 (begin..... (if
0e80: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
0e90: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6b 65 e-ref/default ke
0ea0: 79 73 3a 77 61 72 6e 69 6e 67 2d 73 75 70 70 72 ys:warning-suppr
0eb0: 65 73 73 2d 68 61 73 68 20 78 20 23 66 29 29 0a ess-hash x #f)).
0ec0: 09 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a .... (begin.
0ed0: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
0ee0: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
0ef0: 4e 47 3a 20 6d 69 73 73 69 6e 67 20 6b 65 79 20 NG: missing key
0f00: 22 20 78 20 22 2e 20 53 70 65 63 69 66 69 65 64 " x ". Specified
0f10: 20 69 6e 20 64 61 74 61 62 61 73 65 20 62 75 74 in database but
0f20: 20 6e 6f 74 20 6f 6e 20 63 6f 6d 6d 61 6e 64 20 not on command
0f30: 6c 69 6e 65 2c 20 75 73 69 6e 67 20 5c 22 75 6e line, using \"un
0f40: 6b 5c 22 22 29 0a 09 09 09 09 20 20 20 20 20 20 k\"").....
0f50: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
0f60: 21 20 6b 65 79 73 3a 77 61 72 6e 69 6e 67 2d 73 ! keys:warning-s
0f70: 75 70 70 72 65 73 73 2d 68 61 73 68 20 78 20 23 uppress-hash x #
0f80: 74 29 29 29 0a 09 09 09 09 20 28 73 65 74 21 20 t)))..... (set!
0f90: 76 61 6c 20 22 64 65 66 61 75 6c 74 22 29 29 29 val "default")))
0fa0: 0a 09 09 09 20 20 20 28 69 66 20 77 69 74 68 6b .... (if withk
0fb0: 65 79 20 28 6c 69 73 74 20 78 20 76 61 6c 29 20 ey (list x val)
0fc0: 28 6c 69 73 74 20 76 61 6c 29 29 29 29 0a 09 09 (list val))))...
0fd0: 20 20 20 20 20 20 20 61 72 67 6b 65 79 73 29 29 argkeys))
0fe0: 29 29 0a 20 20 0a 3b 3b 20 47 69 76 65 6e 20 61 )). .;; Given a
0ff0: 20 6c 69 73 74 20 6f 66 20 6b 65 79 73 20 28 6c list of keys (l
1000: 69 73 74 20 6f 66 20 76 65 63 74 6f 72 73 29 20 ist of vectors)
1010: 72 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 return an alist
1020: 28 28 6b 65 79 20 61 72 67 76 61 6c 29 20 2e 2e ((key argval) ..
1030: 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b 65 79 73 .).(define (keys
1040: 2d 3e 61 6c 69 73 74 20 6b 65 79 73 20 64 65 66 ->alist keys def
1050: 61 75 6c 74 76 61 6c 29 0a 20 20 28 6c 65 74 2a aultval). (let*
1060: 20 28 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d ((keynames (m
1070: 61 70 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 ap key:get-field
1080: 6e 61 6d 65 20 6b 65 79 73 29 29 0a 09 20 28 6e name keys)).. (n
1090: 65 77 72 65 6d 61 72 67 73 20 28 61 72 67 73 3a ewremargs (args:
10a0: 67 65 74 2d 61 72 67 73 20 28 63 6f 6e 73 20 22 get-args (cons "
10b0: 62 6c 61 68 22 20 72 65 6d 61 72 67 73 29 20 28 blah" remargs) (
10c0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 map (lambda (k)(
10d0: 63 6f 6e 63 20 22 3a 22 20 6b 29 29 20 6b 65 79 conc ":" k)) key
10e0: 6e 61 6d 65 73 29 20 27 28 29 20 61 72 67 73 3a names) '() args:
10f0: 61 72 67 2d 68 61 73 68 20 30 29 29 29 20 3b 3b arg-hash 0))) ;;
1100: 20 74 68 65 20 63 6f 6e 73 20 62 6c 61 68 20 77 the cons blah w
1110: 6f 72 6b 73 20 61 72 6f 75 6e 64 20 61 20 62 75 orks around a bu
1120: 67 20 69 6e 20 61 72 67 73 0a 20 20 20 20 28 6d g in args. (m
1130: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 ap (lambda (key)
1140: 0a 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 .. (let ((val
1150: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 28 63 (args:get-arg (c
1160: 6f 6e 63 20 22 3a 22 20 6b 65 79 29 29 29 29 0a onc ":" key)))).
1170: 09 20 20 20 20 20 28 6c 69 73 74 20 6b 65 79 20 . (list key
1180: 28 69 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 (if val val defa
1190: 75 6c 74 76 61 6c 29 29 29 29 0a 09 20 6b 65 79 ultval)))).. key
11a0: 6e 61 6d 65 73 29 29 29 0a 0a 28 64 65 66 69 6e names)))..(defin
11b0: 65 20 28 6b 65 79 73 74 72 69 6e 67 2d 3e 6b 65 e (keystring->ke
11c0: 79 73 20 6b 65 79 73 74 72 69 6e 67 29 0a 20 20 ys keystring).
11d0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
11e0: 0a 09 20 28 6c 65 74 20 28 28 78 6c 73 74 20 28 .. (let ((xlst (
11f0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 78 20 22 string-split x "
1200: 3a 22 29 29 29 0a 09 20 20 20 28 6c 69 73 74 2d :"))).. (list-
1210: 3e 76 65 63 74 6f 72 20 28 69 66 20 28 3e 20 28 >vector (if (> (
1220: 6c 65 6e 67 74 68 20 78 6c 73 74 29 20 31 29 20 length xlst) 1)
1230: 78 6c 73 74 20 28 61 70 70 65 6e 64 20 28 63 61 xlst (append (ca
1240: 72 20 78 6c 73 74 29 28 6c 69 73 74 20 22 54 45 r xlst)(list "TE
1250: 58 54 22 29 29 29 29 29 29 0a 20 20 20 20 20 20 XT")))))).
1260: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
1270: 74 65 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 tes (string-spli
1280: 74 20 6b 65 79 73 74 72 69 6e 67 20 22 2c 22 29 t keystring ",")
1290: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
12a0: 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 nfig-get-fields
12b0: 63 6f 6e 66 64 61 74 29 0a 20 20 28 6c 65 74 20 confdat). (let
12c0: 28 28 66 69 65 6c 64 73 20 28 68 61 73 68 2d 74 ((fields (hash-t
12d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
12e0: 20 63 6f 6e 66 64 61 74 20 22 66 69 65 6c 64 73 confdat "fields
12f0: 22 20 27 28 29 29 29 29 0a 20 20 20 20 28 6d 61 " '()))). (ma
1300: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 76 65 p (lambda (x)(ve
1310: 63 74 6f 72 20 28 63 61 72 20 78 29 28 63 61 64 ctor (car x)(cad
1320: 72 20 78 29 29 29 0a 09 20 66 69 65 6c 64 73 29 r x))).. fields)
1330: 29 29 0a 0a ))..