Artifact
0b7d0d8b1eb547d45fc4a2a1bccfe40b953d3799
File
tests/tests.scm
— part of check-in
[ae6dbecf17]
at
2011-05-01 23:05:22
on branch trunk
— Importing 1.0.1 version of megatest, (nb// work in progress, please wait for next release)
(user:
matt
size: 2919)
0000: 28 75 73 65 20 74 65 73 74 29 0a 3b 3b 20 28 72 (use test).;; (r
0010: 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 61 equire-library a
0020: 72 67 73 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 rgs)..(include "
0030: 2e 2e 2f 63 6f 6d 6d 6f 6e 2e 73 63 6d 22 29 0a ../common.scm").
0040: 28 69 6e 63 6c 75 64 65 20 22 2e 2e 2f 6b 65 79 (include "../key
0050: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
0060: 20 22 2e 2e 2f 64 62 2e 73 63 6d 22 29 0a 28 69 "../db.scm").(i
0070: 6e 63 6c 75 64 65 20 22 2e 2e 2f 63 6f 6e 66 69 nclude "../confi
0080: 67 66 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 gf.scm").(includ
0090: 65 20 22 2e 2e 2f 70 72 6f 63 65 73 73 2e 73 63 e "../process.sc
00a0: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 2e 2e m").(include "..
00b0: 2f 6c 61 75 6e 63 68 2e 73 63 6d 22 29 0a 28 69 /launch.scm").(i
00c0: 6e 63 6c 75 64 65 20 22 2e 2e 2f 69 74 65 6d 73 nclude "../items
00d0: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
00e0: 22 2e 2e 2f 72 75 6e 73 2e 73 63 6d 22 29 0a 0a "../runs.scm")..
00f0: 28 64 65 66 69 6e 65 20 63 6f 6e 66 66 69 6c 65 (define conffile
0100: 20 23 66 29 0a 28 74 65 73 74 20 22 52 65 61 64 #f).(test "Read
0110: 20 61 20 63 6f 6e 66 69 67 22 20 23 74 20 28 68 a config" #t (h
0120: 61 73 68 2d 74 61 62 6c 65 3f 20 28 72 65 61 64 ash-table? (read
0130: 2d 63 6f 6e 66 69 67 20 22 74 65 73 74 2e 63 6f -config "test.co
0140: 6e 66 69 67 22 29 29 29 0a 28 74 65 73 74 20 22 nfig"))).(test "
0150: 52 65 61 64 20 61 20 63 6f 6e 66 69 67 20 74 68 Read a config th
0160: 61 74 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 at doesn't exist
0170: 22 20 23 74 20 28 68 61 73 68 2d 74 61 62 6c 65 " #t (hash-table
0180: 3f 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 ? (read-config "
0190: 6e 61 64 61 2e 63 6f 6e 66 69 67 22 29 29 29 0a nada.config"))).
01a0: 0a 28 73 65 74 21 20 63 6f 6e 66 66 69 6c 65 20 .(set! conffile
01b0: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 74 65 (read-config "te
01c0: 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 28 74 65 st.config")).(te
01d0: 73 74 20 22 47 65 74 20 61 76 61 69 6c 61 62 6c st "Get availabl
01e0: 65 20 64 69 73 6b 73 70 61 63 65 22 20 23 74 20 e diskspace" #t
01f0: 28 6e 75 6d 62 65 72 3f 20 28 67 65 74 2d 64 66 (number? (get-df
0200: 20 22 2e 2f 22 29 29 29 0a 28 74 65 73 74 20 22 "./"))).(test "
0210: 47 65 74 20 62 65 73 74 20 64 69 72 22 20 23 74 Get best dir" #t
0220: 20 28 6c 65 74 20 28 28 62 65 73 74 64 69 72 20 (let ((bestdir
0230: 28 67 65 74 2d 62 65 73 74 2d 64 69 73 6b 20 63 (get-best-disk c
0240: 6f 6e 66 66 69 6c 65 29 29 29 0a 09 09 09 20 20 onffile)))....
0250: 20 20 20 20 28 6f 72 20 28 65 71 75 61 6c 3f 20 (or (equal?
0260: 22 2e 2f 22 20 20 20 62 65 73 74 64 69 72 29 0a "./" bestdir).
0270: 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 22 2f .... (equal? "/
0280: 74 6d 70 22 20 62 65 73 74 64 69 72 29 29 29 29 tmp" bestdir))))
0290: 0a 0a 3b 3b 20 64 62 0a 28 64 65 66 69 6e 65 20 ..;; db.(define
02a0: 72 6f 77 20 20 20 20 28 76 65 63 74 6f 72 20 22 row (vector "
02b0: 61 22 20 22 62 22 20 22 63 22 20 22 62 6c 61 68 a" "b" "c" "blah
02c0: 22 29 29 0a 28 64 65 66 69 6e 65 20 68 65 61 64 ")).(define head
02d0: 65 72 20 28 6c 69 73 74 20 22 63 6f 6c 31 22 20 er (list "col1"
02e0: 22 63 6f 6c 32 22 20 22 63 6f 6c 33 22 20 22 63 "col2" "col3" "c
02f0: 6f 6c 34 22 29 29 0a 28 74 65 73 74 20 22 47 65 ol4")).(test "Ge
0300: 74 20 72 6f 77 20 62 79 20 68 65 61 64 65 72 22 t row by header"
0310: 20 22 62 6c 61 68 22 20 28 64 62 2d 67 65 74 2d "blah" (db-get-
0320: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
0330: 72 6f 77 20 68 65 61 64 65 72 20 22 63 6f 6c 34 row header "col4
0340: 22 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 "))..;; (define
0350: 2a 74 6f 70 70 61 74 68 2a 20 22 74 65 73 74 73 *toppath* "tests
0360: 22 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2a 20 ").(define *db*
0370: 23 66 29 0a 28 74 65 73 74 20 22 73 65 74 75 70 #f).(test "setup
0380: 20 66 6f 72 20 72 75 6e 22 20 23 74 20 28 62 65 for run" #t (be
0390: 67 69 6e 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 gin (setup-for-r
03a0: 75 6e 29 0a 09 09 09 09 28 73 74 72 69 6e 67 3f un).....(string?
03b0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (getenv "MT_RUN
03c0: 5f 41 52 45 41 5f 48 4f 4d 45 22 29 29 29 29 0a _AREA_HOME")))).
03d0: 28 74 65 73 74 20 22 6f 70 65 6e 2d 64 62 22 20 (test "open-db"
03e0: 23 74 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 #t (begin...
03f0: 20 28 73 65 74 21 20 2a 64 62 2a 20 28 6f 70 65 (set! *db* (ope
0400: 6e 2d 64 62 29 29 0a 09 09 20 20 20 20 20 28 69 n-db))... (i
0410: 66 20 2a 64 62 2a 20 23 74 20 23 66 29 29 29 0a f *db* #t #f))).
0420: 0a 28 74 65 73 74 20 22 67 65 74 20 63 70 75 20 .(test "get cpu
0430: 6c 6f 61 64 22 20 23 74 20 28 6e 75 6d 62 65 72 load" #t (number
0440: 3f 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 ? (get-cpu-load)
0450: 29 29 0a 28 74 65 73 74 20 22 67 65 74 20 75 6e )).(test "get un
0460: 61 6d 65 22 20 20 20 20 23 74 20 28 73 74 72 69 ame" #t (stri
0470: 6e 67 3f 20 28 67 65 74 2d 75 6e 61 6d 65 29 29 ng? (get-uname))
0480: 29 0a 0a 28 74 65 73 74 20 22 67 65 74 20 76 61 )..(test "get va
0490: 6c 69 64 76 61 6c 75 65 73 20 61 73 20 6c 69 73 lidvalues as lis
04a0: 74 22 20 28 6c 69 73 74 20 22 73 74 61 72 74 22 t" (list "start"
04b0: 20 22 65 6e 64 22 20 22 63 6f 6d 70 6c 65 74 65 "end" "complete
04c0: 64 22 29 0a 20 20 20 20 20 20 28 73 74 72 69 6e d"). (strin
04d0: 67 2d 73 70 6c 69 74 20 28 63 6f 6e 66 69 67 2d g-split (config-
04e0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
04f0: 74 2a 20 22 76 61 6c 69 64 76 61 6c 75 65 73 22 t* "validvalues"
0500: 20 22 73 74 61 74 65 22 29 29 29 0a 0a 28 66 6f "state")))..(fo
0510: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
0520: 69 74 65 6d 29 0a 09 20 20 20 20 28 74 65 73 74 item).. (test
0530: 20 28 63 6f 6e 63 20 22 67 65 74 20 76 61 6c 69 (conc "get vali
0540: 64 20 69 74 65 6d 73 20 28 22 20 69 74 65 6d 20 d items (" item
0550: 22 29 22 29 0a 09 09 20 20 69 74 65 6d 20 28 63 ")")... item (c
0560: 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 heck-valid-items
0570: 20 22 73 74 61 74 65 22 20 69 74 65 6d 29 29 29 "state" item)))
0580: 0a 09 20 20 28 6c 69 73 74 20 22 73 74 61 72 74 .. (list "start
0590: 22 20 22 65 6e 64 22 20 22 63 6f 6d 70 6c 65 74 " "end" "complet
05a0: 65 64 22 29 29 0a 0a 28 66 6f 72 2d 65 61 63 68 ed"))..(for-each
05b0: 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a (lambda (item).
05c0: 09 20 20 20 20 28 74 65 73 74 20 28 63 6f 6e 63 . (test (conc
05d0: 20 22 67 65 74 20 76 61 6c 69 64 20 69 74 65 6d "get valid item
05e0: 73 20 28 22 20 69 74 65 6d 20 22 29 22 29 0a 09 s (" item ")")..
05f0: 09 20 20 69 74 65 6d 20 28 63 68 65 63 6b 2d 76 . item (check-v
0600: 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 alid-items "stat
0610: 75 73 22 20 69 74 65 6d 29 29 29 0a 09 20 20 28 us" item))).. (
0620: 6c 69 73 74 20 22 70 61 73 73 22 20 22 66 61 69 list "pass" "fai
0630: 6c 22 20 22 6e 2f 61 22 29 29 0a 0a 28 74 65 73 l" "n/a"))..(tes
0640: 74 20 22 77 72 69 74 65 20 65 6e 76 20 66 69 6c t "write env fil
0650: 65 73 22 20 22 6e 61 64 61 2e 63 73 68 22 20 28 es" "nada.csh" (
0660: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
0670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0680: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 76 (sav
0690: 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 e-environment-as
06a0: 2d 66 69 6c 65 73 20 22 6e 61 64 61 22 29 0a 20 -files "nada").
06b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06d0: 20 20 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d (and (file-
06e0: 65 78 69 73 74 73 3f 20 22 6e 61 64 61 2e 73 68 exists? "nada.sh
06f0: 22 29 0a 20 20 20 20 09 09 09 20 20 20 20 20 20 "). ...
0700: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 (file
0710: 2d 65 78 69 73 74 73 3f 20 22 6e 61 64 61 2e 63 -exists? "nada.c
0720: 73 68 22 29 29 29 29 0a 0a 28 74 65 73 74 20 22 sh"))))..(test "
0730: 67 65 74 20 61 6c 6c 20 6c 65 67 61 6c 20 74 65 get all legal te
0740: 73 74 73 22 20 28 6c 69 73 74 20 22 72 75 6e 66 sts" (list "runf
0750: 69 72 73 74 22 20 22 73 71 6c 69 74 65 73 70 65 irst" "sqlitespe
0760: 65 64 22 29 20 28 73 6f 72 74 20 28 67 65 74 2d ed") (sort (get-
0770: 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 73 29 all-legal-tests)
0780: 20 73 74 72 69 6e 67 3c 3d 3f 29 29 0a 0a 28 74 string<=?))..(t
0790: 65 73 74 20 22 72 65 67 69 73 74 65 72 2d 74 65 est "register-te
07a0: 73 74 2c 20 74 65 73 74 20 69 6e 66 6f 22 20 22 st, test info" "
07b0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 0a 20 20 20 NOT_STARTED".
07c0: 20 20 20 28 62 65 67 69 6e 0a 09 28 72 65 67 69 (begin..(regi
07d0: 73 74 65 72 2d 74 65 73 74 20 2a 64 62 2a 20 31 ster-test *db* 1
07e0: 20 22 6e 61 64 61 22 20 22 22 29 0a 09 28 74 65 "nada" "")..(te
07f0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 28 72 75 st:get-state (ru
0800: 6e 73 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f ns:get-test-info
0810: 20 2a 64 62 2a 20 31 20 22 6e 61 64 61 22 20 22 *db* 1 "nada" "
0820: 22 29 29 29 29 0a 0a 28 74 65 73 74 20 22 67 65 "))))..(test "ge
0830: 74 2d 6b 65 79 73 22 20 22 73 79 73 6e 61 6d 65 t-keys" "sysname
0840: 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 " (key:get-field
0850: 6e 61 6d 65 20 28 63 61 72 20 28 73 6f 72 74 20 name (car (sort
0860: 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 2a 64 62 (db-get-keys *db
0870: 2a 29 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 *)(lambda (a b)(
0880: 73 74 72 69 6e 67 3e 3d 3f 20 28 76 65 63 74 6f string>=? (vecto
0890: 72 2d 72 65 66 20 61 20 30 29 28 76 65 63 74 6f r-ref a 0)(vecto
08a0: 72 2d 72 65 66 20 62 20 30 29 29 29 29 29 29 29 r-ref b 0)))))))
08b0: 0a 0a 28 64 65 66 69 6e 65 20 72 65 6d 61 72 67 ..(define remarg
08c0: 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 73 s (args:get-args
08d0: 0a 09 09 20 27 28 22 62 61 72 22 20 22 66 6f 6f ... '("bar" "foo
08e0: 22 20 22 3a 72 75 6e 6e 61 6d 65 22 20 22 62 6f " ":runname" "bo
08f0: 62 22 20 22 3a 73 79 73 6e 61 6d 65 22 20 22 75 b" ":sysname" "u
0900: 62 75 6e 74 75 22 20 22 3a 66 73 6e 61 6d 65 22 buntu" ":fsname"
0910: 20 22 6e 66 73 22 20 22 3a 64 61 74 61 70 61 74 "nfs" ":datapat
0920: 68 22 20 22 62 6c 61 68 2f 66 6f 6f 22 20 22 6e h" "blah/foo" "n
0930: 61 64 61 22 29 0a 09 09 20 28 6c 69 73 74 20 22 ada")... (list "
0940: 3a 72 75 6e 6e 61 6d 65 22 20 22 3a 73 74 61 74 :runname" ":stat
0950: 65 22 20 22 3a 73 74 61 74 75 73 22 29 0a 09 09 e" ":status")...
0960: 20 28 6c 69 73 74 20 22 2d 68 22 29 0a 09 09 20 (list "-h")...
0970: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 0a 09 09 args:arg-hash...
0980: 20 30 29 29 0a 0a 28 74 65 73 74 20 22 72 65 67 0))..(test "reg
0990: 69 73 74 65 72 2d 72 75 6e 22 20 23 74 20 28 6e ister-run" #t (n
09a0: 75 6d 62 65 72 3f 20 28 72 65 67 69 73 74 65 72 umber? (register
09b0: 2d 72 75 6e 20 2a 64 62 2a 20 28 64 62 2d 67 65 -run *db* (db-ge
09c0: 74 2d 6b 65 79 73 20 2a 64 62 2a 29 29 29 29 0a t-keys *db*)))).
09d0: 0a 3b 3b 28 74 65 73 74 20 22 75 70 64 61 74 65 .;;(test "update
09e0: 2d 74 65 73 74 2d 69 6e 66 6f 22 20 23 74 20 28 -test-info" #t (
09f0: 74 65 73 74 2d 75 70 64 61 74 65 2d 6d 65 74 61 test-update-meta
0a00: 2d 69 6e 66 6f 20 2a 64 62 2a 20 31 20 22 6e 61 -info *db* 1 "na
0a10: 64 61 22 20 0a 28 73 65 74 65 6e 76 20 22 42 4c da" .(setenv "BL
0a20: 41 48 46 4f 4f 22 20 22 31 32 33 34 22 29 0a 28 AHFOO" "1234").(
0a30: 75 6e 73 65 74 65 6e 76 20 22 4e 41 44 41 46 4f unsetenv "NADAFO
0a40: 4f 22 29 0a 28 74 65 73 74 20 22 65 6e 76 20 74 O").(test "env t
0a50: 65 6d 70 20 6f 76 65 72 72 69 64 65 73 22 20 22 emp overrides" "
0a60: 78 79 7a 22 20 28 6c 65 74 20 28 28 70 72 65 76 xyz" (let ((prev
0a70: 76 61 6c 73 20 28 61 6c 69 73 74 2d 3e 65 6e 76 vals (alist->env
0a80: 2d 76 61 72 73 20 27 28 28 22 42 4c 41 48 46 4f -vars '(("BLAHFO
0a90: 4f 22 20 34 33 32 31 29 28 22 4e 41 44 41 46 4f O" 4321)("NADAFO
0aa0: 4f 22 20 78 79 7a 29 29 29 29 0a 09 09 09 09 20 O" xyz)))).....
0ab0: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 20 (result
0ac0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
0ad0: 2d 76 61 72 69 61 62 6c 65 20 22 4e 41 44 41 46 -variable "NADAF
0ae0: 4f 4f 22 29 29 29 0a 09 09 09 09 20 20 20 20 28 OO")))..... (
0af0: 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 alist->env-vars
0b00: 70 72 65 76 76 61 6c 73 29 0a 09 09 09 09 20 20 prevvals).....
0b10: 20 20 72 65 73 75 6c 74 29 29 0a 0a 28 74 65 73 result))..(tes
0b20: 74 20 22 65 6e 76 20 72 65 73 74 6f 72 65 64 22 t "env restored"
0b30: 20 22 31 32 33 34 22 20 28 67 65 74 2d 65 6e 76 "1234" (get-env
0b40: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
0b50: 65 20 22 42 4c 41 48 46 4f 4f 22 29 29 0a 0a 09 e "BLAHFOO"))...
0b60: 09 09 09 20 20 20 20 ...