Artifact
3d742549ec555e0739a653a23ea19427b3da2fd1:
- File
keys.scm
— part of check-in
[3469edbbf7]
at
2011-10-08 20:23:24
on branch trunk
— 90% converted to using units
(user:
matt
size: 4533)
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 55 73 69 6e 67 20 74 68 e))..;; Using th
0980: 65 20 6b 65 79 73 20 70 75 6c 6c 65 64 20 66 72 e keys pulled fr
0990: 6f 6d 20 74 68 65 20 64 61 74 61 62 61 73 65 20 om the database
09a0: 28 69 6e 69 74 69 61 6c 6c 79 20 73 65 74 20 66 (initially set f
09b0: 72 6f 6d 20 74 68 65 20 6d 65 67 61 74 65 73 74 rom the megatest
09c0: 2e 63 6f 6e 66 69 67 20 66 69 6c 65 29 0a 3b 3b .config file).;;
09d0: 20 6c 6f 6f 6b 20 66 6f 72 20 74 68 65 20 65 71 look for the eq
09e0: 75 69 76 61 6c 65 6e 74 20 76 61 6c 75 65 20 6f uivalent value o
09f0: 6e 20 74 68 65 20 63 6f 6d 6d 61 6e 64 20 6c 69 n the command li
0a00: 6e 65 20 61 6e 64 20 61 64 64 20 69 74 20 74 6f ne and add it to
0a10: 20 61 20 6c 69 73 74 2c 20 6f 72 20 23 66 20 69 a list, or #f i
0a20: 66 20 6e 6f 74 20 66 6f 75 6e 64 2e 0a 3b 3b 20 f not found..;;
0a30: 64 65 66 61 75 6c 74 20 3d 3e 20 28 76 61 6c 31 default => (val1
0a40: 20 76 61 6c 32 20 76 61 6c 33 20 2e 2e 2e 29 0a val2 val3 ...).
0a50: 3b 3b 20 77 69 74 68 6b 65 79 20 3d 3e 20 28 3a ;; withkey => (:
0a60: 6b 65 79 31 20 76 61 6c 31 20 3a 6b 65 79 32 20 key1 val1 :key2
0a70: 76 61 6c 32 20 3a 6b 65 79 33 20 76 61 6c 33 20 val2 :key3 val3
0a80: 2e 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b 65 ...).(define (ke
0a90: 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 ys->vallist keys
0aa0: 20 2e 20 77 69 74 68 6b 65 79 29 20 3b 3b 20 4f . withkey) ;; O
0ab0: 52 44 45 52 49 4e 47 20 49 53 20 56 45 52 59 20 RDERING IS VERY
0ac0: 49 4d 50 4f 52 54 41 4e 54 2c 20 4b 45 45 50 20 IMPORTANT, KEEP
0ad0: 50 52 4f 50 45 52 20 4f 52 44 45 52 20 48 45 52 PROPER ORDER HER
0ae0: 45 21 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 E!. (let* ((key
0af0: 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 names (map key
0b00: 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b :get-fieldname k
0b10: 65 79 73 29 29 0a 09 20 28 61 72 67 6b 65 79 73 eys)).. (argkeys
0b20: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
0b30: 20 28 6b 29 28 63 6f 6e 63 20 22 3a 22 20 6b 29 (k)(conc ":" k)
0b40: 29 20 6b 65 79 6e 61 6d 65 73 29 29 0a 09 20 28 ) keynames)).. (
0b50: 77 69 74 68 6b 65 79 20 20 20 20 28 6e 6f 74 20 withkey (not
0b60: 28 6e 75 6c 6c 3f 20 77 69 74 68 6b 65 79 29 29 (null? withkey))
0b70: 29 0a 09 20 28 6e 65 77 72 65 6d 61 72 67 73 20 ).. (newremargs
0b80: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 73 20 28 (args:get-args (
0b90: 63 6f 6e 73 20 22 62 6c 61 68 22 20 72 65 6d 61 cons "blah" rema
0ba0: 72 67 73 29 20 61 72 67 6b 65 79 73 20 27 28 29 rgs) argkeys '()
0bb0: 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 20 30 args:arg-hash 0
0bc0: 29 29 29 20 3b 3b 20 74 68 65 20 63 6f 6e 73 20 ))) ;; the cons
0bd0: 62 6c 61 68 20 77 6f 72 6b 73 20 61 72 6f 75 6e blah works aroun
0be0: 64 20 61 20 62 75 67 20 69 6e 20 61 72 67 73 20 d a bug in args
0bf0: 5b 61 72 67 73 20 61 73 73 75 6d 65 73 20 28 22 [args assumes ("
0c00: 63 61 6c 6c 69 6e 67 2d 70 72 6f 67 2d 6e 61 6d calling-prog-nam
0c10: 65 22 20 2e 2e 2e 2e 20 29 20 5d 0a 20 20 20 20 e" .... ) ].
0c20: 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ;;(debug:print 0
0c30: 20 22 72 65 6d 61 72 67 73 3a 20 22 20 72 65 6d "remargs: " rem
0c40: 61 72 67 73 20 22 20 6e 65 77 72 65 6d 61 72 67 args " newremarg
0c50: 73 3a 20 22 20 6e 65 77 72 65 6d 61 72 67 73 29 s: " newremargs)
0c60: 0a 20 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 . (apply appe
0c70: 6e 64 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 nd (map (lambda
0c80: 28 78 29 0a 09 09 09 20 28 6c 65 74 20 28 28 76 (x).... (let ((v
0c90: 61 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 al (args:get-arg
0ca0: 20 78 29 29 29 0a 09 09 09 20 20 20 3b 3b 20 28 x))).... ;; (
0cb0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 78 debug:print 0 "x
0cc0: 3a 20 22 20 78 20 22 20 76 61 6c 3a 20 22 20 76 : " x " val: " v
0cd0: 61 6c 29 0a 09 09 09 20 20 20 28 69 66 20 28 6e al).... (if (n
0ce0: 6f 74 20 76 61 6c 29 0a 09 09 09 20 20 20 20 20 ot val)....
0cf0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 69 (begin..... (i
0d00: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
0d10: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6b le-ref/default k
0d20: 65 79 73 3a 77 61 72 6e 69 6e 67 2d 73 75 70 70 eys:warning-supp
0d30: 72 65 73 73 2d 68 61 73 68 20 78 20 23 66 29 29 ress-hash x #f))
0d40: 0a 09 09 09 09 20 20 20 20 20 28 62 65 67 69 6e ..... (begin
0d50: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ..... (deb
0d60: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
0d70: 49 4e 47 3a 20 6d 69 73 73 69 6e 67 20 6b 65 79 ING: missing key
0d80: 20 22 20 78 20 22 2e 20 53 70 65 63 69 66 69 65 " x ". Specifie
0d90: 64 20 69 6e 20 64 61 74 61 62 61 73 65 20 62 75 d in database bu
0da0: 74 20 6e 6f 74 20 6f 6e 20 63 6f 6d 6d 61 6e 64 t not on command
0db0: 20 6c 69 6e 65 2c 20 75 73 69 6e 67 20 5c 22 75 line, using \"u
0dc0: 6e 6b 5c 22 22 29 0a 09 09 09 09 20 20 20 20 20 nk\"").....
0dd0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
0de0: 74 21 20 6b 65 79 73 3a 77 61 72 6e 69 6e 67 2d t! keys:warning-
0df0: 73 75 70 70 72 65 73 73 2d 68 61 73 68 20 78 20 suppress-hash x
0e00: 23 74 29 29 29 0a 09 09 09 09 20 28 73 65 74 21 #t)))..... (set!
0e10: 20 76 61 6c 20 22 64 65 66 61 75 6c 74 22 29 29 val "default"))
0e20: 29 0a 09 09 09 20 20 20 28 69 66 20 77 69 74 68 ).... (if with
0e30: 6b 65 79 20 28 6c 69 73 74 20 78 20 76 61 6c 29 key (list x val)
0e40: 20 28 6c 69 73 74 20 76 61 6c 29 29 29 29 0a 09 (list val))))..
0e50: 09 20 20 20 20 20 20 20 61 72 67 6b 65 79 73 29 . argkeys)
0e60: 29 29 29 0a 20 20 0a 3b 3b 20 47 69 76 65 6e 20 ))). .;; Given
0e70: 61 20 6c 69 73 74 20 6f 66 20 6b 65 79 73 20 28 a list of keys (
0e80: 6c 69 73 74 20 6f 66 20 76 65 63 74 6f 72 73 29 list of vectors)
0e90: 20 72 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 return an alist
0ea0: 20 28 28 6b 65 79 20 61 72 67 76 61 6c 29 20 2e ((key argval) .
0eb0: 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 6b 65 79 ..).(define (key
0ec0: 73 2d 3e 61 6c 69 73 74 20 6b 65 79 73 20 64 65 s->alist keys de
0ed0: 66 61 75 6c 74 76 61 6c 29 0a 20 20 28 6c 65 74 faultval). (let
0ee0: 2a 20 28 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 * ((keynames (
0ef0: 6d 61 70 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c map key:get-fiel
0f00: 64 6e 61 6d 65 20 6b 65 79 73 29 29 0a 09 20 28 dname keys)).. (
0f10: 6e 65 77 72 65 6d 61 72 67 73 20 28 61 72 67 73 newremargs (args
0f20: 3a 67 65 74 2d 61 72 67 73 20 28 63 6f 6e 73 20 :get-args (cons
0f30: 22 62 6c 61 68 22 20 72 65 6d 61 72 67 73 29 20 "blah" remargs)
0f40: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
0f50: 28 63 6f 6e 63 20 22 3a 22 20 6b 29 29 20 6b 65 (conc ":" k)) ke
0f60: 79 6e 61 6d 65 73 29 20 27 28 29 20 61 72 67 73 ynames) '() args
0f70: 3a 61 72 67 2d 68 61 73 68 20 30 29 29 29 20 3b :arg-hash 0))) ;
0f80: 3b 20 74 68 65 20 63 6f 6e 73 20 62 6c 61 68 20 ; the cons blah
0f90: 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 61 20 62 works around a b
0fa0: 75 67 20 69 6e 20 61 72 67 73 0a 20 20 20 20 28 ug in args. (
0fb0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 map (lambda (key
0fc0: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c ).. (let ((val
0fd0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 28 (args:get-arg (
0fe0: 63 6f 6e 63 20 22 3a 22 20 6b 65 79 29 29 29 29 conc ":" key))))
0ff0: 0a 09 20 20 20 20 20 28 6c 69 73 74 20 6b 65 79 .. (list key
1000: 20 28 69 66 20 76 61 6c 20 76 61 6c 20 64 65 66 (if val val def
1010: 61 75 6c 74 76 61 6c 29 29 29 29 0a 09 20 6b 65 aultval)))).. ke
1020: 79 6e 61 6d 65 73 29 29 29 0a 0a 28 64 65 66 69 ynames)))..(defi
1030: 6e 65 20 28 6b 65 79 73 74 72 69 6e 67 2d 3e 6b ne (keystring->k
1040: 65 79 73 20 6b 65 79 73 74 72 69 6e 67 29 0a 20 eys keystring).
1050: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
1060: 29 0a 09 20 28 6c 65 74 20 28 28 78 6c 73 74 20 ).. (let ((xlst
1070: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 78 20 (string-split x
1080: 22 3a 22 29 29 29 0a 09 20 20 20 28 6c 69 73 74 ":"))).. (list
1090: 2d 3e 76 65 63 74 6f 72 20 28 69 66 20 28 3e 20 ->vector (if (>
10a0: 28 6c 65 6e 67 74 68 20 78 6c 73 74 29 20 31 29 (length xlst) 1)
10b0: 20 78 6c 73 74 20 28 61 70 70 65 6e 64 20 28 63 xlst (append (c
10c0: 61 72 20 78 6c 73 74 29 28 6c 69 73 74 20 22 54 ar xlst)(list "T
10d0: 45 58 54 22 29 29 29 29 29 29 0a 20 20 20 20 20 EXT")))))).
10e0: 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 (delete-duplic
10f0: 61 74 65 73 20 28 73 74 72 69 6e 67 2d 73 70 6c ates (string-spl
1100: 69 74 20 6b 65 79 73 74 72 69 6e 67 20 22 2c 22 it keystring ","
1110: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
1120: 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 onfig-get-fields
1130: 20 63 6f 6e 66 64 61 74 29 0a 20 20 28 6c 65 74 confdat). (let
1140: 20 28 28 66 69 65 6c 64 73 20 28 68 61 73 68 2d ((fields (hash-
1150: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1160: 74 20 63 6f 6e 66 64 61 74 20 22 66 69 65 6c 64 t confdat "field
1170: 73 22 20 27 28 29 29 29 29 0a 20 20 20 20 28 6d s" '()))). (m
1180: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 76 ap (lambda (x)(v
1190: 65 63 74 6f 72 20 28 63 61 72 20 78 29 28 63 61 ector (car x)(ca
11a0: 64 72 20 78 29 29 29 0a 09 20 66 69 65 6c 64 73 dr x))).. fields
11b0: 29 29 29 0a 0a )))..