Artifact
e9ddc4ee152fb3b56dc6782f13897be6cecc9673:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 73 72 66 69 2d 36 39 20 70 6f 73 69 78 29 0a srfi-69 posix).
01f0: 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 .(declare (unit
0200: 61 70 69 29 29 0a 28 64 65 63 6c 61 72 65 20 28 api)).(declare (
0210: 75 73 65 73 20 72 6d 74 29 29 0a 28 64 65 63 6c uses rmt)).(decl
0220: 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 are (uses db)).(
0230: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 61 declare (uses ta
0240: 73 6b 73 29 29 0a 0a 3b 3b 20 61 6c 6c 6f 77 20 sks))..;; allow
0250: 74 68 65 73 65 20 71 75 65 72 69 65 73 20 74 68 these queries th
0260: 72 6f 75 67 68 20 77 69 74 68 6f 75 74 20 73 74 rough without st
0270: 61 72 74 69 6e 67 20 61 20 73 65 72 76 65 72 0a arting a server.
0280: 3b 3b 0a 28 64 65 66 69 6e 65 20 61 70 69 3a 72 ;;.(define api:r
0290: 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 ead-only-queries
02a0: 0a 20 20 27 28 67 65 74 2d 6b 65 79 2d 76 61 6c . '(get-key-val
02b0: 2d 70 61 69 72 73 0a 20 20 20 20 67 65 74 2d 76 -pairs. get-v
02c0: 61 72 0a 20 20 20 20 67 65 74 2d 6b 65 79 73 0a ar. get-keys.
02d0: 20 20 20 20 67 65 74 2d 6b 65 79 2d 76 61 6c 73 get-key-vals
02e0: 0a 20 20 20 20 74 65 73 74 2d 74 6f 70 6c 65 76 . test-toplev
02f0: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 0a 20 20 20 el-num-items.
0300: 20 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 get-test-info-b
0310: 79 2d 69 64 0a 20 20 20 20 74 65 73 74 2d 67 65 y-id. test-ge
0320: 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 t-rundir-from-te
0330: 73 74 2d 69 64 0a 20 20 20 20 67 65 74 2d 63 6f st-id. get-co
0340: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
0350: 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d 65 0a 20 g-for-testname.
0360: 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 get-count-tes
0370: 74 73 2d 72 75 6e 6e 69 6e 67 0a 20 20 20 20 67 ts-running. g
0380: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
0390: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
03a0: 75 70 0a 20 20 20 20 67 65 74 2d 70 72 65 76 69 up. get-previ
03b0: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
03c0: 6f 72 64 0a 20 20 20 20 67 65 74 2d 6d 61 74 63 ord. get-matc
03d0: 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 hing-previous-te
03e0: 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 0a 20 st-run-records.
03f0: 20 20 20 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 test-get-logf
0400: 69 6c 65 2d 69 6e 66 6f 0a 20 20 20 20 74 65 73 ile-info. tes
0410: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
0420: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 0a 20 20 20 r-index-file.
0430: 20 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 get-testinfo-st
0440: 61 74 65 2d 73 74 61 74 75 73 0a 20 20 20 20 74 ate-status. t
0450: 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 est-get-top-proc
0460: 65 73 73 2d 70 69 64 0a 20 20 20 20 74 65 73 74 ess-pid. test
0470: 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 -get-paths-match
0480: 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 ing-keynames-tar
0490: 67 65 74 2d 6e 65 77 0a 20 20 20 20 67 65 74 2d get-new. get-
04a0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 0a prereqs-not-met.
04b0: 20 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 get-count-te
04c0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
04d0: 72 75 6e 2d 69 64 0a 20 20 20 20 67 65 74 2d 72 run-id. get-r
04e0: 75 6e 2d 69 6e 66 6f 0a 20 20 20 20 67 65 74 2d un-info. get-
04f0: 72 75 6e 2d 73 74 61 74 75 73 0a 20 20 20 20 67 run-status. g
0500: 65 74 2d 72 75 6e 2d 73 74 61 74 73 0a 20 20 20 et-run-stats.
0510: 20 67 65 74 2d 74 61 72 67 65 74 73 0a 20 20 20 get-targets.
0520: 20 67 65 74 2d 74 61 72 67 65 74 0a 20 20 20 20 get-target.
0530: 3b 3b 20 72 65 67 69 73 74 65 72 2d 72 75 6e 0a ;; register-run.
0540: 20 20 20 20 67 65 74 2d 74 65 73 74 73 2d 74 61 get-tests-ta
0550: 67 73 0a 20 20 20 20 67 65 74 2d 74 65 73 74 73 gs. get-tests
0560: 2d 66 6f 72 2d 72 75 6e 0a 20 20 20 20 67 65 74 -for-run. get
0570: 2d 74 65 73 74 2d 69 64 0a 20 20 20 20 67 65 74 -test-id. get
0580: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d -tests-for-runs-
0590: 6d 69 6e 64 61 74 61 0a 20 20 20 20 67 65 74 2d mindata. get-
05a0: 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 run-name-from-id
05b0: 0a 20 20 20 20 67 65 74 2d 72 75 6e 73 0a 20 20 . get-runs.
05c0: 20 20 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 0a 20 get-num-runs.
05d0: 20 20 20 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 get-all-run-i
05e0: 64 73 0a 20 20 20 20 67 65 74 2d 70 72 65 76 2d ds. get-prev-
05f0: 72 75 6e 2d 69 64 73 0a 20 20 20 20 67 65 74 2d run-ids. get-
0600: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
0610: 2d 74 61 72 67 65 74 0a 20 20 20 20 67 65 74 2d -target. get-
0620: 72 75 6e 73 2d 62 79 2d 70 61 74 74 0a 20 20 20 runs-by-patt.
0630: 20 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 0a get-steps-data.
0640: 20 20 20 20 67 65 74 2d 73 74 65 70 73 2d 66 6f get-steps-fo
0650: 72 2d 74 65 73 74 0a 20 20 20 20 72 65 61 64 2d r-test. read-
0660: 74 65 73 74 2d 64 61 74 61 0a 20 20 20 20 72 65 test-data. re
0670: 61 64 2d 74 65 73 74 2d 64 61 74 61 2a 0a 20 20 ad-test-data*.
0680: 20 20 6c 6f 67 69 6e 0a 20 20 20 20 74 61 73 6b login. task
0690: 73 2d 67 65 74 2d 6c 61 73 74 0a 20 20 20 20 74 s-get-last. t
06a0: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
06b0: 72 64 0a 20 20 20 20 68 61 76 65 2d 69 6e 63 6f rd. have-inco
06c0: 6d 70 6c 65 74 65 73 3f 0a 20 20 20 20 73 79 6e mpletes?. syn
06d0: 63 68 61 73 68 2d 67 65 74 0a 20 20 20 20 29 29 chash-get. ))
06e0: 0a 0a 28 64 65 66 69 6e 65 20 61 70 69 3a 77 72 ..(define api:wr
06f0: 69 74 65 2d 71 75 65 72 69 65 73 0a 20 20 27 28 ite-queries. '(
0700: 0a 20 20 20 20 67 65 74 2d 6b 65 79 73 2d 77 72 . get-keys-wr
0710: 69 74 65 20 3b 3b 20 64 75 6d 6d 79 20 22 77 72 ite ;; dummy "wr
0720: 69 74 65 22 20 71 75 65 72 79 20 74 6f 20 66 6f ite" query to fo
0730: 72 63 65 20 73 65 72 76 65 72 20 73 74 61 72 74 rce server start
0740: 0a 0a 20 20 20 20 3b 3b 20 53 45 52 56 45 52 53 .. ;; SERVERS
0750: 0a 20 20 20 20 73 74 61 72 74 2d 73 65 72 76 65 . start-serve
0760: 72 0a 20 20 20 20 6b 69 6c 6c 2d 73 65 72 76 65 r. kill-serve
0770: 72 0a 0a 20 20 20 20 3b 3b 20 54 45 53 54 53 0a r.. ;; TESTS.
0780: 20 20 20 20 74 65 73 74 2d 73 65 74 2d 73 74 61 test-set-sta
0790: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 0a te-status-by-id.
07a0: 20 20 20 20 64 65 6c 65 74 65 2d 74 65 73 74 2d delete-test-
07b0: 72 65 63 6f 72 64 73 0a 20 20 20 20 64 65 6c 65 records. dele
07c0: 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 te-old-deleted-t
07d0: 65 73 74 2d 72 65 63 6f 72 64 73 0a 20 20 20 20 est-records.
07e0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
07f0: 74 61 74 75 73 0a 20 20 20 20 74 65 73 74 2d 73 tatus. test-s
0800: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
0810: 69 64 0a 20 20 20 20 73 65 74 2d 73 74 61 74 65 id. set-state
0820: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
0830: 2d 75 70 2d 69 74 65 6d 73 0a 20 20 20 20 75 70 -up-items. up
0840: 64 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 date-pass-fail-c
0850: 6f 75 6e 74 73 0a 20 20 20 20 74 6f 70 2d 74 65 ounts. top-te
0860: 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f st-set-per-pf-co
0870: 75 6e 74 73 20 3b 3b 20 28 64 62 3a 74 6f 70 2d unts ;; (db:top-
0880: 74 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d test-set-per-pf-
0890: 63 6f 75 6e 74 73 20 28 64 62 3a 67 65 74 2d 64 counts (db:get-d
08a0: 62 20 2a 64 62 2a 20 35 29 20 35 20 22 72 75 6e b *db* 5) 5 "run
08b0: 66 69 72 73 74 22 29 0a 0a 20 20 20 20 3b 3b 20 first").. ;;
08c0: 52 55 4e 53 0a 20 20 20 20 72 65 67 69 73 74 65 RUNS. registe
08d0: 72 2d 72 75 6e 0a 20 20 20 20 73 65 74 2d 74 65 r-run. set-te
08e0: 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 sts-state-status
08f0: 0a 20 20 20 20 64 65 6c 65 74 65 2d 72 75 6e 0a . delete-run.
0900: 20 20 20 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d lock/unlock-
0910: 72 75 6e 0a 20 20 20 20 75 70 64 61 74 65 2d 72 run. update-r
0920: 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 0a 20 20 un-event_time.
0930: 20 20 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 mark-incomplet
0940: 65 0a 0a 20 20 20 20 3b 3b 20 53 54 45 50 53 0a e.. ;; STEPS.
0950: 20 20 20 20 74 65 73 74 73 74 65 70 2d 73 65 74 teststep-set
0960: 2d 73 74 61 74 75 73 21 0a 0a 20 20 20 20 3b 3b -status!.. ;;
0970: 20 54 45 53 54 20 44 41 54 41 0a 20 20 20 20 74 TEST DATA. t
0980: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 0a est-data-rollup.
0990: 20 20 20 20 63 73 76 2d 3e 74 65 73 74 2d 64 61 csv->test-da
09a0: 74 61 0a 0a 20 20 20 20 3b 3b 20 4d 49 53 43 0a ta.. ;; MISC.
09b0: 20 20 20 20 73 79 6e 63 2d 69 6e 6d 65 6d 2d 3e sync-inmem->
09c0: 64 62 0a 0a 20 20 20 20 3b 3b 20 54 45 53 54 4d db.. ;; TESTM
09d0: 45 54 41 0a 20 20 20 20 74 65 73 74 6d 65 74 61 ETA. testmeta
09e0: 2d 61 64 64 2d 72 65 63 6f 72 64 0a 20 20 20 20 -add-record.
09f0: 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d testmeta-update-
0a00: 66 69 65 6c 64 0a 0a 20 20 20 20 3b 3b 20 54 41 field.. ;; TA
0a10: 53 4b 53 0a 20 20 20 20 74 61 73 6b 73 2d 61 64 SKS. tasks-ad
0a20: 64 0a 20 20 20 20 74 61 73 6b 73 2d 73 65 74 2d d. tasks-set-
0a30: 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 state-given-para
0a40: 6d 2d 6b 65 79 0a 20 20 20 20 29 29 0a 0a 3b 3b m-key. ))..;;
0a50: 20 54 68 65 73 65 20 61 72 65 20 63 61 6c 6c 65 These are calle
0a60: 64 20 62 79 20 74 68 65 20 73 65 72 76 65 72 20 d by the server
0a70: 6f 6e 20 72 65 63 69 70 74 20 6f 66 20 2f 61 70 on recipt of /ap
0a80: 69 20 63 61 6c 6c 73 0a 3b 3b 20 20 20 20 2d 20 i calls.;; -
0a90: 6b 65 65 70 20 69 74 20 73 69 6d 70 6c 65 2c 20 keep it simple,
0aa0: 6f 6e 6c 79 20 72 65 74 75 72 6e 20 74 68 65 20 only return the
0ab0: 61 63 74 75 61 6c 20 72 65 73 75 6c 74 20 6f 66 actual result of
0ac0: 20 74 68 65 20 63 61 6c 6c 2c 20 69 2e 65 2e 20 the call, i.e.
0ad0: 6e 6f 20 6d 65 74 61 20 69 6e 66 6f 20 68 65 72 no meta info her
0ae0: 65 0a 3b 3b 0a 3b 3b 20 20 20 20 2d 20 72 65 74 e.;;.;; - ret
0af0: 75 72 6e 73 20 23 28 20 66 6c 61 67 20 72 65 73 urns #( flag res
0b00: 75 6c 74 20 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 ult ).;;.(define
0b10: 20 28 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 (api:execute-re
0b20: 71 75 65 73 74 73 20 64 62 73 74 72 75 63 74 20 quests dbstruct
0b30: 64 61 74 20 71 75 65 75 65 73 29 0a 20 20 28 68 dat queues). (h
0b40: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
0b50: 0a 20 20 20 65 78 6e 0a 20 20 20 28 6c 65 74 20 . exn. (let
0b60: 28 28 63 61 6c 6c 2d 63 68 61 69 6e 20 28 67 65 ((call-chain (ge
0b70: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 29 0a t-call-chain))).
0b80: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0b90: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
0ba0: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
0bb0: 20 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 api:execute-req
0bc0: 75 65 73 74 73 20 72 65 63 65 69 76 65 64 20 61 uests received a
0bd0: 6e 20 65 78 63 65 70 74 69 6f 6e 20 66 72 6f 6d n exception from
0be0: 20 70 65 65 72 2c 20 64 61 74 3d 22 20 64 61 74 peer, dat=" dat
0bf0: 29 0a 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 ). (print-ca
0c00: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
0c10: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
0c20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0c30: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0c40: 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a port* " message:
0c50: 20 22 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d " ((condition-
0c60: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
0c70: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
0c80: 20 65 78 6e 29 29 20 20 20 20 20 20 20 0a 20 20 exn)) .
0c90: 20 20 20 28 76 65 63 74 6f 72 20 23 66 20 28 76 (vector #f (v
0ca0: 65 63 74 6f 72 20 65 78 6e 20 63 61 6c 6c 2d 63 ector exn call-c
0cb0: 68 61 69 6e 20 64 61 74 29 29 29 20 3b 3b 20 72 hain dat))) ;; r
0cc0: 65 74 75 72 6e 20 73 6f 6d 65 20 73 74 75 66 66 eturn some stuff
0cd0: 20 66 6f 72 20 64 65 62 75 67 20 69 66 20 61 6e for debug if an
0ce0: 20 65 78 63 65 70 74 69 6f 6e 20 68 61 70 70 65 exception happe
0cf0: 6e 73 0a 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ns. (cond.
0d00: 28 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 64 ((not (vector? d
0d10: 61 74 29 29 20 20 20 20 20 20 20 20 20 20 20 20 at))
0d20: 20 20 20 20 20 20 20 20 3b 3b 20 69 74 20 69 73 ;; it is
0d30: 20 61 6e 20 65 72 72 6f 72 20 74 6f 20 6e 6f 74 an error to not
0d40: 20 72 65 63 65 69 76 65 20 61 20 76 65 63 74 6f receive a vecto
0d50: 72 0a 20 20 20 20 20 28 76 65 63 74 6f 72 20 23 r. (vector #
0d60: 66 20 28 76 65 63 74 6f 72 20 23 66 20 22 72 65 f (vector #f "re
0d70: 6d 6f 74 65 20 6d 75 73 74 20 62 65 20 63 61 6c mote must be cal
0d80: 6c 65 64 20 77 69 74 68 20 61 20 76 65 63 74 6f led with a vecto
0d90: 72 22 29 29 29 0a 20 20 20 20 28 28 3e 20 2a 61 r"))). ((> *a
0da0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
0db0: 73 74 2d 63 6f 75 6e 74 2a 20 32 30 29 20 3b 3b st-count* 20) ;;
0dc0: 20 32 30 29 0a 20 20 20 20 20 28 64 65 62 75 67 20). (debug
0dd0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
0de0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
0df0: 4e 49 4e 47 3a 20 61 70 69 3a 65 78 65 63 75 74 NING: api:execut
0e00: 65 2d 72 65 71 75 65 73 74 73 20 72 65 63 65 69 e-requests recei
0e10: 76 65 64 20 61 6e 20 6f 76 65 72 6c 6f 61 64 65 ved an overloade
0e20: 64 20 6d 65 73 73 61 67 65 2e 22 29 0a 20 20 20 d message.").
0e30: 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d (set! *server-
0e40: 6f 76 65 72 6c 6f 61 64 65 64 2a 20 23 74 29 0a overloaded* #t).
0e50: 20 20 20 20 20 28 76 65 63 74 6f 72 20 23 66 20 (vector #f
0e60: 28 76 65 63 74 6f 72 20 23 66 20 27 6f 76 65 72 (vector #f 'over
0e70: 6c 6f 61 64 65 64 29 29 29 20 3b 3b 20 74 68 65 loaded))) ;; the
0e80: 20 69 6e 6e 65 72 20 76 65 63 74 6f 72 20 69 73 inner vector is
0e90: 20 77 68 61 74 20 67 65 74 73 20 72 65 74 75 72 what gets retur
0ea0: 6e 65 64 2e 20 6e 6f 70 65 2c 20 64 6f 6e 27 74 ned. nope, don't
0eb0: 20 6b 6e 6f 77 20 77 68 79 2e 20 70 6c 65 61 73 know why. pleas
0ec0: 65 20 72 65 66 61 63 74 6f 72 21 0a 20 20 20 20 e refactor!.
0ed0: 28 65 6c 73 65 20 20 0a 20 20 20 20 20 28 6c 65 (else . (le
0ee0: 74 2a 20 28 28 63 6d 64 2d 69 6e 20 20 20 20 20 t* ((cmd-in
0ef0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
0f00: 65 66 20 64 61 74 20 30 29 29 0a 20 20 20 20 20 ef dat 0)).
0f10: 20 20 20 20 20 20 20 28 63 6d 64 20 20 20 20 20 (cmd
0f20: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 73 (if (s
0f30: 79 6d 62 6f 6c 3f 20 63 6d 64 2d 69 6e 29 0a 09 ymbol? cmd-in)..
0f40: 09 09 09 20 20 20 63 6d 64 2d 69 6e 0a 09 09 09 ... cmd-in....
0f50: 09 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d . (string->sym
0f60: 62 6f 6c 20 63 6d 64 2d 69 6e 29 29 29 0a 20 20 bol cmd-in))).
0f70: 20 20 20 20 20 20 20 20 20 20 28 70 61 72 61 6d (param
0f80: 73 20 20 20 20 20 20 20 20 20 20 20 20 28 76 65 s (ve
0f90: 63 74 6f 72 2d 72 65 66 20 64 61 74 20 31 29 29 ctor-ref dat 1))
0fa0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 . (st
0fb0: 61 72 74 2d 74 20 20 20 20 20 20 20 20 20 20 20 art-t
0fc0: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
0fd0: 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 conds)).
0fe0: 20 20 20 20 28 72 65 61 64 6f 6e 6c 79 2d 6d 6f (readonly-mo
0ff0: 64 65 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 de (dbr:dbst
1000: 72 75 63 74 2d 72 65 61 64 2d 6f 6e 6c 79 20 64 ruct-read-only d
1010: 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 20 20 bstruct)).
1020: 20 20 20 20 20 20 28 72 65 61 64 6f 6e 6c 79 2d (readonly-
1030: 63 6f 6d 6d 61 6e 64 20 20 28 6d 65 6d 62 65 72 command (member
1040: 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e cmd api:read-on
1050: 6c 79 2d 71 75 65 72 69 65 73 29 29 0a 20 20 20 ly-queries)).
1060: 20 20 20 20 20 20 20 20 20 28 77 72 69 74 65 63 (writec
1070: 6d 64 2d 69 6e 2d 72 65 61 64 6f 6e 6c 79 2d 6d md-in-readonly-m
1080: 6f 64 65 20 28 61 6e 64 20 72 65 61 64 6f 6e 6c ode (and readonl
1090: 79 2d 6d 6f 64 65 20 28 6e 6f 74 20 72 65 61 64 y-mode (not read
10a0: 6f 6e 6c 79 2d 63 6f 6d 6d 61 6e 64 29 29 29 0a only-command))).
10b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 (res
10c0: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
10d0: 20 20 28 69 66 20 77 72 69 74 65 63 6d 64 2d 69 (if writecmd-i
10e0: 6e 2d 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 0a n-readonly-mode.
10f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1100: 20 28 63 6f 6e 63 20 22 61 74 74 65 6d 70 74 20 (conc "attempt
1110: 74 6f 20 72 75 6e 20 77 72 69 74 65 20 63 6f 6d to run write com
1120: 6d 61 6e 64 20 22 63 6d 64 22 20 6f 6e 20 61 20 mand "cmd" on a
1130: 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 read-only databa
1140: 73 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 se").
1150: 20 20 20 20 20 20 28 63 61 73 65 20 63 6d 64 0a (case cmd.
1160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1170: 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;===========
1180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11a0: 3d 3d 3d 3d 0a 20 20 20 20 20 20 20 20 20 20 20 ====.
11b0: 20 20 20 20 20 20 20 20 3b 3b 20 52 45 41 44 2f ;; READ/
11c0: 57 52 49 54 45 20 51 55 45 52 49 45 53 0a 20 20 WRITE QUERIES.
11d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11e0: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
11f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1210: 3d 3d 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 ==..
1220: 20 20 20 20 20 20 20 28 28 67 65 74 2d 6b 65 79 ((get-key
1230: 73 2d 77 72 69 74 65 29 20 20 20 20 20 20 20 20 s-write)
1240: 20 20 20 20 20 20 20 20 20 20 28 61 70 69 3a 71 (api:q
1250: 75 65 75 65 64 2d 72 65 71 75 65 73 74 20 71 75 ueued-request qu
1260: 65 75 65 73 20 27 77 72 69 74 65 20 70 61 72 61 eues 'write para
1270: 6d 73 0a 09 09 09 09 09 09 09 09 09 20 20 28 6c ms.......... (l
1280: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 09 ambda ()........
1290: 09 09 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 .. (db:get-ke
12a0: 79 73 20 64 62 73 74 72 75 63 74 29 29 29 29 20 ys dbstruct))))
12b0: 3b 3b 20 66 6f 72 63 65 20 61 20 64 75 6d 6d 79 ;; force a dummy
12c0: 20 22 77 72 69 74 65 22 20 71 75 65 72 79 20 74 "write" query t
12d0: 6f 20 66 6f 72 63 65 20 73 65 72 76 65 72 3b 20 o force server;
12e0: 66 6f 72 20 64 65 62 75 67 20 69 6e 20 2d 72 65 for debug in -re
12f0: 70 6c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 pl.
1300: 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 .
1310: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 53 45 52 ;; SER
1320: 56 45 52 53 0a 20 20 20 20 20 20 20 20 20 20 20 VERS.
1330: 20 20 20 20 20 20 20 20 28 28 73 74 61 72 74 2d ((start-
1340: 73 65 72 76 65 72 29 20 20 20 20 20 20 20 20 20 server)
1350: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
1360: 79 20 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 y server:kind-ru
1370: 6e 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 n params)).
1380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
1390: 6b 69 6c 6c 2d 73 65 72 76 65 72 29 20 20 20 20 kill-server)
13a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13b0: 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d 72 (set! *server-r
13c0: 75 6e 2a 20 23 66 29 29 0a 0a 20 20 20 20 20 20 un* #f))..
13d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
13e0: 54 45 53 54 53 0a 0a 20 20 20 20 20 20 20 20 20 TESTS..
13f0: 20 20 20 20 20 20 20 20 20 20 3b 3b 28 28 74 65 ;;((te
1400: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
1410: 74 75 73 2d 62 79 2d 69 64 29 20 20 20 20 20 28 tus-by-id) (
1420: 61 70 70 6c 79 20 6d 74 3a 74 65 73 74 2d 73 65 apply mt:test-se
1430: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
1440: 79 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 61 y-id dbstruct pa
1450: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
1460: 20 20 20 20 20 20 20 20 20 20 3b 3b 42 42 20 2d ;;BB -
1470: 20 63 6f 6d 6d 65 6e 74 65 64 20 6f 75 74 20 61 commented out a
1480: 62 6f 76 65 20 62 65 63 61 75 73 65 20 69 74 20 bove because it
1490: 77 61 73 20 63 61 6c 6c 69 6e 67 20 62 65 6c 6f was calling belo
14a0: 77 2c 20 65 76 65 6e 74 75 61 6c 6c 79 2c 20 69 w, eventually, i
14b0: 6e 63 6f 72 72 65 63 74 6c 79 20 28 64 62 73 74 ncorrectly (dbst
14c0: 72 75 63 74 20 70 61 73 73 65 64 20 74 6f 20 6d ruct passed to m
14d0: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
14e0: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 2c 20 77 -status-by-id, w
14f0: 68 69 63 68 20 70 72 65 76 69 6f 73 6c 79 20 64 hich previosly d
1500: 69 64 20 6d 6f 72 65 2c 20 62 75 74 20 6e 6f 77 id more, but now
1510: 20 6f 6e 6c 79 20 70 61 73 73 65 73 20 74 68 72 only passes thr
1520: 75 20 74 6f 20 64 62 3a 73 65 74 2d 73 74 61 74 u to db:set-stat
1530: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
1540: 6c 2d 75 70 2d 69 74 65 6d 73 2e 0a 20 20 20 20 l-up-items..
1550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1560: 28 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d (test-set-state-
1570: 73 74 61 74 75 73 2d 62 79 2d 69 64 29 0a 0a 20 status-by-id)..
1580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1590: 20 20 20 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 ;; (define (d
15a0: 62 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 b:set-state-stat
15b0: 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 us-and-roll-up-i
15c0: 74 65 6d 73 20 64 62 73 74 72 75 63 74 20 72 75 tems dbstruct ru
15d0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
15e0: 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 tem-path state s
15f0: 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 0a 20 tatus comment).
1600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1610: 20 20 20 28 64 62 3a 73 65 74 2d 73 74 61 74 65 (db:set-state
1620: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
1630: 2d 75 70 2d 69 74 65 6d 73 0a 20 20 20 20 20 20 -up-items.
1640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64 d
1650: 62 73 74 72 75 63 74 0a 20 20 20 20 20 20 20 20 bstruct.
1660: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
1670: 73 74 2d 72 65 66 20 70 61 72 61 6d 73 20 30 29 st-ref params 0)
1680: 20 3b 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 ; run-id.
1690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
16a0: 6c 69 73 74 2d 72 65 66 20 70 61 72 61 6d 73 20 list-ref params
16b0: 31 29 20 3b 20 74 65 73 74 2d 6e 61 6d 65 0a 20 1) ; test-name.
16c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16d0: 20 20 20 20 23 66 20 20 20 20 20 20 20 20 20 20 #f
16e0: 20 20 20 20 20 20 20 20 3b 20 69 74 65 6d 2d 70 ; item-p
16f0: 61 74 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 ath.
1700: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
1710: 65 66 20 70 61 72 61 6d 73 20 32 29 20 3b 20 73 ef params 2) ; s
1720: 74 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 tate.
1730: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d (list-
1740: 72 65 66 20 70 61 72 61 6d 73 20 33 29 20 3b 20 ref params 3) ;
1750: 73 74 61 74 75 73 0a 20 20 20 20 20 20 20 20 20 status.
1760: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
1770: 74 2d 72 65 66 20 70 61 72 61 6d 73 20 34 29 20 t-ref params 4)
1780: 3b 20 63 6f 6d 6d 65 6e 74 0a 20 20 20 20 20 20 ; comment.
1790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 )
17a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
17b0: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
17c0: 20 20 20 20 20 20 20 20 20 28 28 64 65 6c 65 74 ((delet
17d0: 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 29 20 e-test-records)
17e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
17f0: 6c 79 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 ly db:delete-tes
1800: 74 2d 72 65 63 6f 72 64 73 20 64 62 73 74 72 75 t-records dbstru
1810: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
1820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1830: 28 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 (delete-old-dele
1840: 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ted-test-records
1850: 29 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c 65 ) (apply db:dele
1860: 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 te-old-deleted-t
1870: 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 73 74 est-records dbst
1880: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
1890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18a0: 20 28 28 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ((test-set-stat
18b0: 65 2d 73 74 61 74 75 73 29 20 20 20 20 20 20 20 e-status)
18c0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 65 (apply db:te
18d0: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
18e0: 74 75 73 20 64 62 73 74 72 75 63 74 20 70 61 72 tus dbstruct par
18f0: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
1900: 20 20 20 20 20 20 20 20 20 28 28 74 65 73 74 2d ((test-
1910: 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d set-top-process-
1920: 70 69 64 29 20 20 20 20 20 20 20 20 28 61 70 70 pid) (app
1930: 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 74 ly db:test-set-t
1940: 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 64 op-process-pid d
1950: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
1960: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1970: 20 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d ((set-state-
1980: 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d status-and-roll-
1990: 75 70 2d 69 74 65 6d 73 29 20 28 61 70 70 6c 79 up-items) (apply
19a0: 20 64 62 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 db:set-state-st
19b0: 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 atus-and-roll-up
19c0: 2d 69 74 65 6d 73 20 64 62 73 74 72 75 63 74 20 -items dbstruct
19d0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 params)).
19e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 74 6f ((to
19f0: 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 p-test-set-per-p
1a00: 66 2d 63 6f 75 6e 74 73 29 20 20 20 20 20 20 28 f-counts) (
1a10: 61 70 70 6c 79 20 64 62 3a 74 6f 70 2d 74 65 73 apply db:top-tes
1a20: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
1a30: 6e 74 73 20 64 62 73 74 72 75 63 74 20 70 61 72 nts dbstruct par
1a40: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
1a50: 20 20 20 20 20 20 20 20 20 28 28 74 65 73 74 2d ((test-
1a60: 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 set-archive-bloc
1a70: 6b 2d 69 64 29 20 20 20 20 20 20 20 28 61 70 70 k-id) (app
1a80: 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 61 ly db:test-set-a
1a90: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 rchive-block-id
1aa0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
1ab0: 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )..
1ac0: 20 20 20 20 20 20 3b 3b 20 52 55 4e 53 0a 20 20 ;; RUNS.
1ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ae0: 20 28 28 72 65 67 69 73 74 65 72 2d 72 75 6e 29 ((register-run)
1af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b00: 20 28 61 70 70 6c 79 20 64 62 3a 72 65 67 69 73 (apply db:regis
1b10: 74 65 72 2d 72 75 6e 20 64 62 73 74 72 75 63 74 ter-run dbstruct
1b20: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
1b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
1b40: 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 et-tests-state-s
1b50: 74 61 74 75 73 29 20 20 20 20 20 20 20 28 61 70 tatus) (ap
1b60: 70 6c 79 20 64 62 3a 73 65 74 2d 74 65 73 74 73 ply db:set-tests
1b70: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 -state-status db
1b80: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
1b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ba0: 20 20 20 28 28 64 65 6c 65 74 65 2d 72 75 6e 29 ((delete-run)
1bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1bc0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c (apply db:del
1bd0: 65 74 65 2d 72 75 6e 20 64 62 73 74 72 75 63 74 ete-run dbstruct
1be0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
1bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6c ((l
1c00: 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 29 20 ock/unlock-run)
1c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
1c20: 70 6c 79 20 64 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f ply db:lock/unlo
1c30: 63 6b 2d 72 75 6e 20 64 62 73 74 72 75 63 74 20 ck-run dbstruct
1c40: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 params)).
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 75 70 ((up
1c60: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
1c70: 69 6d 65 29 20 20 20 20 20 20 20 20 28 61 70 70 ime) (app
1c80: 6c 79 20 64 62 3a 75 70 64 61 74 65 2d 72 75 6e ly db:update-run
1c90: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 73 74 -event_time dbst
1ca0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
1cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cc0: 20 28 28 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 ((update-run-st
1cd0: 61 74 73 29 20 20 20 20 20 20 20 20 20 20 20 20 ats)
1ce0: 20 28 61 70 70 6c 79 20 64 62 3a 75 70 64 61 74 (apply db:updat
1cf0: 65 2d 72 75 6e 2d 73 74 61 74 73 20 64 62 73 74 e-run-stats dbst
1d00: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d20: 20 28 28 73 65 74 2d 76 61 72 29 20 20 20 20 20 ((set-var)
1d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d40: 20 28 61 70 70 6c 79 20 64 62 3a 73 65 74 2d 76 (apply db:set-v
1d50: 61 72 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ar dbstruct para
1d60: 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ms)).
1d70: 20 20 20 20 20 20 20 20 28 28 64 65 6c 2d 76 61 ((del-va
1d80: 72 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r)
1d90: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
1da0: 62 3a 64 65 6c 2d 76 61 72 20 64 62 73 74 72 75 b:del-var dbstru
1db0: 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 ct params))..
1dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1dd0: 3b 3b 20 53 54 45 50 53 0a 20 20 20 20 20 20 20 ;; STEPS.
1de0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 74 65 ((te
1df0: 73 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 ststep-set-statu
1e00: 73 21 29 20 20 20 20 20 20 20 20 20 28 61 70 70 s!) (app
1e10: 6c 79 20 64 62 3a 74 65 73 74 73 74 65 70 2d 73 ly db:teststep-s
1e20: 65 74 2d 73 74 61 74 75 73 21 20 64 62 73 74 72 et-status! dbstr
1e30: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 uct params))..
1e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e50: 20 3b 3b 20 54 45 53 54 20 44 41 54 41 0a 20 20 ;; TEST DATA.
1e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e70: 20 28 28 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c ((test-data-rol
1e80: 6c 75 70 29 20 20 20 20 20 20 20 20 20 20 20 20 lup)
1e90: 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d (apply db:test-
1ea0: 64 61 74 61 2d 72 6f 6c 6c 75 70 20 64 62 73 74 data-rollup dbst
1eb0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
1ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ed0: 20 28 28 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 ((csv->test-dat
1ee0: 61 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a)
1ef0: 20 28 61 70 70 6c 79 20 64 62 3a 63 73 76 2d 3e (apply db:csv->
1f00: 74 65 73 74 2d 64 61 74 61 20 64 62 73 74 72 75 test-data dbstru
1f10: 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 ct params))..
1f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f30: 3b 3b 20 4d 49 53 43 0a 20 20 20 20 20 20 20 20 ;; MISC.
1f40: 20 20 20 20 20 20 20 20 20 20 20 28 28 73 79 6e ((syn
1f50: 63 2d 69 6e 6d 65 6d 2d 3e 64 62 29 20 20 20 20 c-inmem->db)
1f60: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
1f70: 28 28 72 75 6e 2d 69 64 20 28 63 61 72 20 70 61 ((run-id (car pa
1f80: 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 rams))).
1f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
1fc0: 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 :sync-touched db
1fd0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 66 6f struct run-id fo
1fe0: 72 63 65 2d 73 79 6e 63 3a 20 23 74 29 29 29 0a rce-sync: #t))).
1ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2000: 20 20 20 28 28 6d 61 72 6b 2d 69 6e 63 6f 6d 70 ((mark-incomp
2010: 6c 65 74 65 29 20 20 20 20 20 20 20 20 20 20 20 lete)
2020: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 66 69 6e (apply db:fin
2030: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
2040: 70 6c 65 74 65 20 64 62 73 74 72 75 63 74 20 70 plete dbstruct p
2050: 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 20 20 arams))..
2060: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 54 ;; T
2070: 45 53 54 4d 45 54 41 0a 20 20 20 20 20 20 20 20 ESTMETA.
2080: 20 20 20 20 20 20 20 20 20 20 20 28 28 74 65 73 ((tes
2090: 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 tmeta-add-record
20a0: 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 ) (apply d
20b0: 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 b:testmeta-add-r
20c0: 65 63 6f 72 64 20 64 62 73 74 72 75 63 74 20 70 ecord dbstruct p
20d0: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
20e0: 20 20 20 20 20 20 20 20 20 20 20 28 28 74 65 73 ((tes
20f0: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
2100: 6c 64 29 20 20 20 20 20 28 61 70 70 6c 79 20 64 ld) (apply d
2110: 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 b:testmeta-updat
2120: 65 2d 66 69 65 6c 64 20 64 62 73 74 72 75 63 74 e-field dbstruct
2130: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
2140: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 67 ((g
2150: 65 74 2d 74 65 73 74 73 2d 74 61 67 73 29 20 20 et-tests-tags)
2160: 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 (db:ge
2170: 74 2d 74 65 73 74 73 2d 74 61 67 73 20 64 62 73 t-tests-tags dbs
2180: 74 72 75 63 74 29 29 0a 0a 20 20 20 20 20 20 20 truct))..
2190: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 54 ;; T
21a0: 41 53 4b 53 0a 20 20 20 20 20 20 20 20 20 20 20 ASKS.
21b0: 20 20 20 20 20 20 20 20 28 28 74 61 73 6b 73 2d ((tasks-
21c0: 61 64 64 29 20 20 20 20 20 20 20 20 20 20 20 20 add)
21d0: 20 20 20 20 20 28 61 70 70 6c 79 20 74 61 73 6b (apply task
21e0: 73 3a 61 64 64 20 64 62 73 74 72 75 63 74 20 70 s:add dbstruct p
21f0: 61 72 61 6d 73 29 29 20 20 20 0a 20 20 20 20 20 arams)) .
2200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
2210: 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d tasks-set-state-
2220: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 29 given-param-key)
2230: 20 28 61 70 70 6c 79 20 74 61 73 6b 73 3a 73 65 (apply tasks:se
2240: 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 t-state-given-pa
2250: 72 61 6d 2d 6b 65 79 20 64 62 73 74 72 75 63 74 ram-key dbstruct
2260: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 74 ((t
2280: 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 29 20 20 asks-get-last)
2290: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
22a0: 20 74 61 73 6b 73 3a 67 65 74 2d 6c 61 73 74 20 tasks:get-last
22b0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
22c0: 29 0a 0a 09 09 20 20 20 3b 3b 20 4e 4f 20 53 59 ).... ;; NO SY
22d0: 4e 43 20 44 42 0a 09 09 20 20 20 28 28 6e 6f 2d NC DB... ((no-
22e0: 73 79 6e 63 2d 73 65 74 29 20 20 20 20 20 20 20 sync-set)
22f0: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
2300: 62 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 20 20 b:no-sync-set
2310: 20 20 20 20 20 20 2a 6e 6f 2d 73 79 6e 63 2d 64 *no-sync-d
2320: 62 2a 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 b* params))...
2330: 20 28 28 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 ((no-sync-get/d
2340: 65 66 61 75 6c 74 29 20 20 20 20 20 20 20 28 61 efault) (a
2350: 70 70 6c 79 20 64 62 3a 6e 6f 2d 73 79 6e 63 2d pply db:no-sync-
2360: 67 65 74 2f 64 65 66 61 75 6c 74 20 2a 6e 6f 2d get/default *no-
2370: 73 79 6e 63 2d 64 62 2a 20 70 61 72 61 6d 73 29 sync-db* params)
2380: 29 0a 09 09 20 20 20 28 28 6e 6f 2d 73 79 6e 63 )... ((no-sync
2390: 2d 64 65 6c 21 29 20 20 20 20 20 20 20 20 20 20 -del!)
23a0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 6e 6f (apply db:no
23b0: 2d 73 79 6e 63 2d 64 65 6c 21 20 20 20 20 20 20 -sync-del!
23c0: 20 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 70 *no-sync-db* p
23d0: 61 72 61 6d 73 29 29 0a 09 09 20 0a 20 20 20 20 arams))... .
23e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
23f0: 3b 20 41 52 43 48 49 56 45 53 0a 20 20 20 20 20 ; ARCHIVES.
2400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
2410: 20 28 28 61 72 63 68 69 76 65 2d 67 65 74 2d 61 ((archive-get-a
2420: 6c 6c 6f 63 61 74 69 6f 6e 73 29 20 20 20 0a 20 llocations) .
2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2440: 20 20 28 28 61 72 63 68 69 76 65 2d 72 65 67 69 ((archive-regi
2450: 73 74 65 72 2d 64 69 73 6b 29 20 20 20 20 20 28 ster-disk) (
2460: 61 70 70 6c 79 20 64 62 3a 61 72 63 68 69 76 65 apply db:archive
2470: 2d 72 65 67 69 73 74 65 72 2d 64 69 73 6b 20 64 -register-disk d
2480: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2490: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
24a0: 20 20 20 20 28 28 61 72 63 68 69 76 65 2d 72 65 ((archive-re
24b0: 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d gister-block-nam
24c0: 65 29 28 61 70 70 6c 79 20 64 62 3a 61 72 63 68 e)(apply db:arch
24d0: 69 76 65 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f ive-register-blo
24e0: 63 6b 2d 6e 61 6d 65 20 64 62 73 74 72 75 63 74 ck-name dbstruct
24f0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
2500: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
2510: 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 65 2d rchive-allocate-
2520: 74 65 73 74 73 75 69 74 65 2f 61 72 65 61 2d 74 testsuite/area-t
2530: 6f 2d 62 6c 6f 63 6b 29 28 61 70 70 6c 79 20 64 o-block)(apply d
2540: 62 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 b:archive-alloca
2550: 74 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 te-testsuite/are
2560: 61 2d 74 6f 2d 62 6c 6f 63 6b 20 64 62 73 74 72 a-to-block dbstr
2570: 75 63 74 20 62 6c 6f 63 6b 2d 69 64 20 74 65 73 uct block-id tes
2580: 74 73 75 69 74 65 2d 6e 61 6d 65 20 61 72 65 61 tsuite-name area
2590: 6b 65 79 29 29 0a 0a 20 20 20 20 20 20 20 20 20 key))..
25a0: 20 20 20 20 20 20 20 20 20 20 3b 3b 3d 3d 3d 3d ;;====
25b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25f0: 3d 3d 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ==.
2600: 20 20 20 20 20 20 3b 3b 20 52 45 41 44 20 4f 4e ;; READ ON
2610: 4c 59 20 51 55 45 52 49 45 53 0a 20 20 20 20 20 LY QUERIES.
2620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
2630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2670: 3d 3d 3d 3d 3d 3d 0a 0a 20 20 20 20 20 20 20 20 ======..
2680: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4b 45 ;; KE
2690: 59 53 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 YS.
26a0: 20 20 20 20 20 20 28 28 67 65 74 2d 6b 65 79 2d ((get-key-
26b0: 76 61 6c 2d 70 61 69 72 73 29 20 20 20 20 20 20 val-pairs)
26c0: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
26d0: 64 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 db:get-key-val-p
26e0: 61 69 72 73 20 64 62 73 74 72 75 63 74 20 70 61 airs dbstruct pa
26f0: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
2700: 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d ((get-
2710: 6b 65 79 73 29 20 20 20 20 20 20 20 20 20 20 20 keys)
2720: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
2730: 3a 67 65 74 2d 6b 65 79 73 20 64 62 73 74 72 75 :get-keys dbstru
2740: 63 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ct)).
2750: 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 6b 65 ((get-ke
2760: 79 2d 76 61 6c 73 29 20 20 20 20 20 20 20 20 20 y-vals)
2770: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
2780: 79 20 64 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c y db:get-key-val
2790: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
27a0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
27b0: 20 20 20 20 20 20 20 28 28 67 65 74 2d 74 61 72 ((get-tar
27c0: 67 65 74 29 20 20 20 20 20 20 20 20 20 20 20 20 get)
27d0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
27e0: 20 64 62 3a 67 65 74 2d 74 61 72 67 65 74 20 64 db:get-target d
27f0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2800: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2810: 20 20 20 20 28 28 67 65 74 2d 74 61 72 67 65 74 ((get-target
2820: 73 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s)
2830: 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 74 (db:get-t
2840: 61 72 67 65 74 73 20 64 62 73 74 72 75 63 74 29 argets dbstruct)
2850: 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )..
2860: 20 20 20 20 20 20 3b 3b 20 41 52 43 48 49 56 45 ;; ARCHIVE
2870: 53 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 S.
2880: 20 20 20 20 20 28 28 74 65 73 74 2d 67 65 74 2d ((test-get-
2890: 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e archive-block-in
28a0: 66 6f 29 20 20 20 20 20 28 61 70 70 6c 79 20 64 fo) (apply d
28b0: 62 3a 74 65 73 74 2d 67 65 74 2d 61 72 63 68 69 b:test-get-archi
28c0: 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 64 62 ve-block-info db
28d0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28f0: 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .
2900: 20 20 20 20 20 20 20 3b 3b 20 54 45 53 54 53 0a ;; TESTS.
2910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2920: 20 20 20 28 28 74 65 73 74 2d 74 6f 70 6c 65 76 ((test-toplev
2930: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 29 20 20 20 el-num-items)
2940: 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a (apply db:
2950: 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 test-toplevel-nu
2960: 6d 2d 69 74 65 6d 73 20 64 62 73 74 72 75 63 74 m-items dbstruct
2970: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 67 ((g
2990: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
29a0: 69 64 29 09 20 20 20 20 20 20 20 28 61 70 70 6c id). (appl
29b0: 79 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e y db:get-test-in
29c0: 66 6f 2d 62 79 2d 69 64 20 64 62 73 74 72 75 63 fo-by-id dbstruc
29d0: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 t params)).
29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
29f0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
2a00: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 29 20 20 20 from-test-id)
2a10: 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d (apply db:test-
2a20: 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d get-rundir-from-
2a30: 74 65 73 74 2d 69 64 20 64 62 73 74 72 75 63 74 test-id dbstruct
2a40: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
2a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 67 ((g
2a60: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
2a70: 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 6e unning-for-testn
2a80: 61 6d 65 29 20 28 61 70 70 6c 79 20 64 62 3a 67 ame) (apply db:g
2a90: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
2aa0: 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 6e unning-for-testn
2ab0: 61 6d 65 20 64 62 73 74 72 75 63 74 20 70 61 72 ame dbstruct par
2ac0: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
2ad0: 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 63 ((get-c
2ae0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
2af0: 6e 67 29 20 20 20 20 20 20 20 20 20 28 61 70 70 ng) (app
2b00: 6c 79 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d ly db:get-count-
2b10: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 62 tests-running db
2b20: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
2b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b40: 20 20 20 28 28 67 65 74 2d 63 6f 75 6e 74 2d 74 ((get-count-t
2b50: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d ests-running-in-
2b60: 6a 6f 62 67 72 6f 75 70 29 20 28 61 70 70 6c 79 jobgroup) (apply
2b70: 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 db:get-count-te
2b80: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
2b90: 6f 62 67 72 6f 75 70 20 64 62 73 74 72 75 63 74 obgroup dbstruct
2ba0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 params)).
2bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
2bc0: 28 28 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 74 ((delete-test-st
2bd0: 65 70 2d 72 65 63 6f 72 64 73 29 20 20 20 20 20 ep-records)
2be0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c (apply db:del
2bf0: 65 74 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 ete-test-step-re
2c00: 63 6f 72 64 73 20 64 62 73 74 72 75 63 74 20 70 cords dbstruct p
2c10: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
2c20: 20 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 ((get
2c30: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
2c40: 75 6e 2d 72 65 63 6f 72 64 29 20 20 20 20 28 61 un-record) (a
2c50: 70 70 6c 79 20 64 62 3a 67 65 74 2d 70 72 65 76 pply db:get-prev
2c60: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
2c70: 63 6f 72 64 20 64 62 73 74 72 75 63 74 20 70 61 cord dbstruct pa
2c80: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
2c90: 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d ((get-
2ca0: 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 matching-previou
2cb0: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
2cc0: 64 73 29 28 61 70 70 6c 79 20 64 62 3a 67 65 74 ds)(apply db:get
2cd0: 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f -matching-previo
2ce0: 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f us-test-run-reco
2cf0: 72 64 73 20 64 62 73 74 72 75 63 74 20 70 61 72 rds dbstruct par
2d00: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
2d10: 20 20 20 20 20 20 20 20 20 28 28 74 65 73 74 2d ((test-
2d20: 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f get-logfile-info
2d30: 29 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 ) (app
2d40: 6c 79 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 6c ly db:test-get-l
2d50: 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 64 62 73 74 ogfile-info dbst
2d60: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
2d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d80: 20 28 28 74 65 73 74 2d 67 65 74 2d 72 65 63 6f ((test-get-reco
2d90: 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 rds-for-index-fi
2da0: 6c 65 29 20 20 28 61 70 70 6c 79 20 64 62 3a 74 le) (apply db:t
2db0: 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d est-get-records-
2dc0: 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 64 for-index-file d
2dd0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2de0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2df0: 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 69 6e ((get-testin
2e00: 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 fo-state-status)
2e10: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
2e20: 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 :get-testinfo-st
2e30: 61 74 65 2d 73 74 61 74 75 73 20 64 62 73 74 72 ate-status dbstr
2e40: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
2e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e60: 28 28 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 ((test-get-top-p
2e70: 72 6f 63 65 73 73 2d 70 69 64 29 20 20 20 20 20 rocess-pid)
2e80: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 (apply db:tes
2e90: 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-get-top-proces
2ea0: 73 2d 70 69 64 20 64 62 73 74 72 75 63 74 20 70 s-pid dbstruct p
2eb0: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
2ec0: 20 20 20 20 20 20 20 20 20 20 20 28 28 74 65 73 ((tes
2ed0: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
2ee0: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
2ef0: 72 67 65 74 2d 6e 65 77 29 20 28 61 70 70 6c 79 rget-new) (apply
2f00: 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 db:test-get-pat
2f10: 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e hs-matching-keyn
2f20: 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 ames-target-new
2f30: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
2f40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2f50: 20 20 20 20 20 28 28 67 65 74 2d 70 72 65 72 65 ((get-prere
2f60: 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 20 20 20 20 qs-not-met)
2f70: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
2f80: 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f b:get-prereqs-no
2f90: 74 2d 6d 65 74 20 64 62 73 74 72 75 63 74 20 70 t-met dbstruct p
2fa0: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
2fb0: 20 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 ((get
2fc0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
2fd0: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 29 ning-for-run-id)
2fe0: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 63 (apply db:get-c
2ff0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
3000: 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 64 62 ng-for-run-id db
3010: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
3020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3030: 20 20 20 28 28 73 79 6e 63 68 61 73 68 2d 67 65 ((synchash-ge
3040: 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t)
3050: 20 20 20 20 20 20 28 61 70 70 6c 79 20 73 79 6e (apply syn
3060: 63 68 61 73 68 3a 73 65 72 76 65 72 2d 67 65 74 chash:server-get
3070: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
3080: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3090: 20 20 20 20 20 20 28 28 67 65 74 2d 72 61 77 2d ((get-raw-
30a0: 72 75 6e 2d 73 74 61 74 73 29 20 20 20 20 20 20 run-stats)
30b0: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
30c0: 64 62 3a 67 65 74 2d 72 61 77 2d 72 75 6e 2d 73 db:get-raw-run-s
30d0: 74 61 74 73 20 64 62 73 74 72 75 63 74 20 70 61 tats dbstruct pa
30e0: 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 20 20 20 rams))..
30f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 52 55 ;; RU
3100: 4e 53 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 NS.
3110: 20 20 20 20 20 20 28 28 67 65 74 2d 72 75 6e 2d ((get-run-
3120: 69 6e 66 6f 29 20 20 20 20 20 20 20 20 20 20 20 info)
3130: 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a (apply db:
3140: 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 64 62 73 get-run-info dbs
3150: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
3160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3170: 20 20 28 28 67 65 74 2d 72 75 6e 2d 73 74 61 74 ((get-run-stat
3180: 75 73 29 20 20 20 20 20 20 20 20 20 20 20 20 20 us)
3190: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
31a0: 72 75 6e 2d 73 74 61 74 75 73 20 64 62 73 74 72 run-status dbstr
31b0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
31c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31d0: 28 28 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 ((set-run-status
31e0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
31f0: 28 61 70 70 6c 79 20 64 62 3a 73 65 74 2d 72 75 (apply db:set-ru
3200: 6e 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 63 n-status dbstruc
3210: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 t params)).
3220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
3230: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
3240: 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 28 61 n) (a
3250: 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 73 74 pply db:get-test
3260: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 73 74 72 75 s-for-run dbstru
3270: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
3280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3290: 28 67 65 74 2d 74 65 73 74 2d 69 64 29 20 20 20 (get-test-id)
32a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
32b0: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 73 apply db:get-tes
32c0: 74 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 61 t-id dbstruct pa
32d0: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
32e0: 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d ((get-
32f0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 tests-for-run-mi
3300: 6e 64 61 74 61 29 20 20 20 20 28 61 70 70 6c 79 ndata) (apply
3310: 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f db:get-tests-fo
3320: 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 64 62 r-run-mindata db
3330: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
3340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3350: 20 20 20 28 28 67 65 74 2d 72 75 6e 73 29 20 20 ((get-runs)
3360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3370: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
3380: 2d 72 75 6e 73 20 64 62 73 74 72 75 63 74 20 70 -runs dbstruct p
3390: 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 arams)).
33a0: 20 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 ((get
33b0: 2d 6e 75 6d 2d 72 75 6e 73 29 20 20 20 20 20 20 -num-runs)
33c0: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
33d0: 79 20 64 62 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e y db:get-num-run
33e0: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
33f0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
3400: 20 20 20 20 20 20 20 28 28 67 65 74 2d 61 6c 6c ((get-all
3410: 2d 72 75 6e 2d 69 64 73 29 20 20 20 20 20 20 20 -run-ids)
3420: 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 61 (db:get-a
3430: 6c 6c 2d 72 75 6e 2d 69 64 73 20 64 62 73 74 72 ll-run-ids dbstr
3440: 75 63 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 uct)).
3450: 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 70 ((get-p
3460: 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 20 20 20 rev-run-ids)
3470: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
3480: 64 62 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d db:get-prev-run-
3490: 69 64 73 20 64 62 73 74 72 75 63 74 20 70 61 72 ids dbstruct par
34a0: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
34b0: 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 72 ((get-r
34c0: 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d un-ids-matching-
34d0: 74 61 72 67 65 74 29 20 20 28 61 70 70 6c 79 20 target) (apply
34e0: 64 62 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d db:get-run-ids-m
34f0: 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 64 atching-target d
3500: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3510: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3520: 20 20 20 20 28 28 67 65 74 2d 72 75 6e 73 2d 62 ((get-runs-b
3530: 79 2d 70 61 74 74 29 20 20 20 20 20 20 20 20 20 y-patt)
3540: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
3550: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 t-runs-by-patt d
3560: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3570: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3580: 20 20 20 20 28 28 67 65 74 2d 72 75 6e 2d 6e 61 ((get-run-na
3590: 6d 65 2d 66 72 6f 6d 2d 69 64 29 20 20 20 20 20 me-from-id)
35a0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
35b0: 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d t-run-name-from-
35c0: 69 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 id dbstruct para
35d0: 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ms)).
35e0: 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 6d 61 ((get-ma
35f0: 69 6e 2d 72 75 6e 2d 73 74 61 74 73 29 20 20 20 in-run-stats)
3600: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
3610: 62 3a 67 65 74 2d 6d 61 69 6e 2d 72 75 6e 2d 73 b:get-main-run-s
3620: 74 61 74 73 20 64 62 73 74 72 75 63 74 20 70 61 tats dbstruct pa
3630: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
3640: 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d ((get-
3650: 76 61 72 29 20 20 20 20 20 20 20 20 20 20 20 20 var)
3660: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
3670: 20 64 62 3a 67 65 74 2d 76 61 72 20 64 62 73 74 db:get-var dbst
3680: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36a0: 20 28 28 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 ((get-run-stats
36b0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
36c0: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 (apply db:get-r
36d0: 75 6e 2d 73 74 61 74 73 20 64 62 73 74 72 75 63 un-stats dbstruc
36e0: 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 t params))..
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
3700: 3b 20 53 54 45 50 53 0a 20 20 20 20 20 20 20 20 ; STEPS.
3710: 20 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 ((get
3720: 2d 73 74 65 70 73 2d 64 61 74 61 29 20 20 20 20 -steps-data)
3730: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
3740: 79 20 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 64 y db:get-steps-d
3750: 61 74 61 20 64 62 73 74 72 75 63 74 20 70 61 72 ata dbstruct par
3760: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
3770: 20 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 73 ((get-s
3780: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 29 20 20 teps-for-test)
3790: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
37a0: 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 db:get-steps-for
37b0: 2d 74 65 73 74 20 64 62 73 74 72 75 63 74 20 70 -test dbstruct p
37c0: 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 20 20 arams))..
37d0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 54 ;; T
37e0: 45 53 54 20 44 41 54 41 0a 20 20 20 20 20 20 20 EST DATA.
37f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 65 ((re
3800: 61 64 2d 74 65 73 74 2d 64 61 74 61 29 20 20 20 ad-test-data)
3810: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
3820: 6c 79 20 64 62 3a 72 65 61 64 2d 74 65 73 74 2d ly db:read-test-
3830: 64 61 74 61 20 64 62 73 74 72 75 63 74 20 70 61 data dbstruct pa
3840: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
3850: 20 20 20 20 20 20 20 20 20 20 28 28 72 65 61 64 ((read
3860: 2d 74 65 73 74 2d 64 61 74 61 2a 29 20 20 20 20 -test-data*)
3870: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
3880: 20 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 db:read-test-da
3890: 74 61 2a 20 64 62 73 74 72 75 63 74 20 70 61 72 ta* dbstruct par
38a0: 61 6d 73 29 29 0a 0a 20 20 20 20 20 20 20 20 20 ams))..
38b0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4d 49 53 ;; MIS
38c0: 43 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 C.
38d0: 20 20 20 20 20 28 28 67 65 74 2d 6c 61 74 65 73 ((get-lates
38e0: 74 2d 68 6f 73 74 2d 6c 6f 61 64 29 20 20 20 20 t-host-load)
38f0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
3900: 65 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c et-latest-host-l
3910: 6f 61 64 20 64 62 73 74 72 75 63 74 20 70 61 72 oad dbstruct par
3920: 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ams)).
3930: 20 20 20 20 20 20 20 20 20 28 28 68 61 76 65 2d ((have-
3940: 69 6e 63 6f 6d 70 6c 65 74 65 73 3f 29 20 20 20 incompletes?)
3950: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
3960: 64 62 3a 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 db:have-incomple
3970: 74 65 73 3f 20 64 62 73 74 72 75 63 74 20 70 61 tes? dbstruct pa
3980: 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 rams)).
3990: 20 20 20 20 20 20 20 20 20 20 28 28 6c 6f 67 69 ((logi
39a0: 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n)
39b0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
39c0: 20 64 62 3a 6c 6f 67 69 6e 20 64 62 73 74 72 75 db:login dbstru
39d0: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
39e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
39f0: 28 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 29 20 20 (general-call)
3a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3a10: 6c 65 74 20 28 28 73 74 6d 74 6e 61 6d 65 20 20 let ((stmtname
3a20: 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 (car params)).
3a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a60: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 (run-id
3a70: 20 20 20 20 28 63 61 64 72 20 70 61 72 61 6d 73 (cadr params
3a80: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ab0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 61 (rea
3ac0: 6c 70 61 72 61 6d 73 20 28 63 64 64 72 20 70 61 lparams (cddr pa
3ad0: 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 rams))).
3ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
3b10: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 64 62 :general-call db
3b20: 73 74 72 75 63 74 20 73 74 6d 74 6e 61 6d 65 20 struct stmtname
3b30: 72 65 61 6c 70 61 72 61 6d 73 29 29 29 0a 20 20 realparams))).
3b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b50: 20 28 28 73 64 62 2d 71 72 79 29 20 20 20 20 20 ((sdb-qry)
3b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b70: 20 28 61 70 70 6c 79 20 73 64 62 3a 71 72 79 20 (apply sdb:qry
3b80: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 20 20 20 params)).
3b90: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 69 ((pi
3ba0: 6e 67 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ng)
3bb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur
3bc0: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
3bd0: 29 0a 09 09 20 20 20 28 28 67 65 74 2d 63 68 61 )... ((get-cha
3be0: 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 29 nged-record-ids)
3bf0: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
3c00: 3a 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 :get-changed-rec
3c10: 6f 72 64 2d 69 64 73 20 64 62 73 74 72 75 63 74 ord-ids dbstruct
3c20: 20 70 61 72 61 6d 73 29 29 0a 09 09 20 20 20 0a params))... .
3c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c40: 20 20 20 3b 3b 20 54 45 53 54 4d 45 54 41 0a 20 ;; TESTMETA.
3c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c60: 20 20 28 28 74 65 73 74 6d 65 74 61 2d 67 65 74 ((testmeta-get
3c70: 2d 72 65 63 6f 72 64 29 20 20 20 20 20 20 20 28 -record) (
3c80: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 6d 65 74 apply db:testmet
3c90: 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 73 a-get-record dbs
3ca0: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a truct params))..
3cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3cc0: 20 20 20 3b 3b 20 54 41 53 4b 53 20 0a 20 20 20 ;; TASKS .
3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ce0: 28 28 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 ((find-task-queu
3cf0: 65 2d 72 65 63 6f 72 64 73 29 20 20 20 28 61 70 e-records) (ap
3d00: 70 6c 79 20 74 61 73 6b 73 3a 66 69 6e 64 2d 74 ply tasks:find-t
3d10: 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 ask-queue-record
3d20: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
3d30: 73 29 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 s))... (else..
3d40: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3d50: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3d60: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 62 -port* "ERROR: b
3d70: 61 64 20 61 70 69 20 63 61 6c 6c 20 22 20 63 6d ad api call " cm
3d80: 64 29 0a 09 09 20 20 20 20 28 63 6f 6e 63 20 22 d)... (conc "
3d90: 45 52 52 4f 52 3a 20 42 41 44 20 61 70 69 20 63 ERROR: BAD api c
3da0: 61 6c 6c 20 22 20 63 6d 64 29 29 29 29 29 29 0a all " cmd)))))).
3db0: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 3b . ;
3dc0: 3b 20 73 61 76 65 20 61 6c 6c 20 73 74 61 74 73 ; save all stats
3dd0: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 . (let ((d
3de0: 65 6c 74 61 2d 74 20 28 2d 20 28 63 75 72 72 65 elta-t (- (curre
3df0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
3e00: 0a 09 09 09 20 73 74 61 72 74 2d 74 29 29 29 0a .... start-t))).
3e10: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
3e20: 74 21 20 2a 64 62 2d 61 70 69 2d 63 61 6c 6c 2d t! *db-api-call-
3e30: 74 69 6d 65 2a 20 63 6d 64 0a 09 09 09 20 20 28 time* cmd.... (
3e40: 63 6f 6e 73 20 64 65 6c 74 61 2d 74 20 28 68 61 cons delta-t (ha
3e50: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3e60: 61 75 6c 74 20 2a 64 62 2d 61 70 69 2d 63 61 6c ault *db-api-cal
3e70: 6c 2d 74 69 6d 65 2a 20 63 6d 64 20 27 28 29 29 l-time* cmd '())
3e80: 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 77 ))). (if w
3e90: 72 69 74 65 63 6d 64 2d 69 6e 2d 72 65 61 64 6f ritecmd-in-reado
3ea0: 6e 6c 79 2d 6d 6f 64 65 0a 09 20 20 20 28 76 65 nly-mode.. (ve
3eb0: 63 74 6f 72 20 23 66 20 72 65 73 29 0a 20 20 20 ctor #f res).
3ec0: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 (vector
3ed0: 23 74 20 72 65 73 29 29 29 29 29 29 29 0a 0a 3b #t res)))))))..;
3ee0: 3b 20 68 74 74 70 2d 73 65 72 76 65 72 20 20 73 ; http-server s
3ef0: 65 6e 64 2d 72 65 73 70 6f 6e 73 65 0a 3b 3b 20 end-response.;;
3f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f10: 61 70 69 3a 70 72 6f 63 65 73 73 2d 72 65 71 75 api:process-requ
3f20: 65 73 74 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 est.;;
3f30: 20 20 20 20 20 20 20 20 20 20 64 62 3a 2a 0a 3b db:*.;
3f40: 3b 0a 3b 3b 20 4e 42 2f 2f 20 52 75 6e 73 20 6f ;.;; NB// Runs o
3f50: 6e 20 74 68 65 20 73 65 72 76 65 72 20 61 73 20 n the server as
3f60: 70 61 72 74 20 6f 66 20 74 68 65 20 73 65 72 76 part of the serv
3f70: 65 72 20 6c 6f 6f 70 0a 3b 3b 0a 28 64 65 66 69 er loop.;;.(defi
3f80: 6e 65 20 28 61 70 69 3a 70 72 6f 63 65 73 73 2d ne (api:process-
3f90: 72 65 71 75 65 73 74 20 64 62 73 74 72 75 63 74 request dbstruct
3fa0: 20 24 29 20 3b 3b 20 74 68 65 20 24 20 69 73 20 $) ;; the $ is
3fb0: 74 68 65 20 72 65 71 75 65 73 74 20 76 61 72 73 the request vars
3fc0: 20 70 72 6f 63 0a 20 20 28 73 65 74 21 20 2a 61 proc. (set! *a
3fd0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
3fe0: 73 74 2d 63 6f 75 6e 74 2a 20 28 2b 20 2a 61 70 st-count* (+ *ap
3ff0: 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 i-process-reques
4000: 74 2d 63 6f 75 6e 74 2a 20 31 29 29 0a 20 20 28 t-count* 1)). (
4010: 6c 65 74 2a 20 28 28 63 6d 64 20 20 20 20 20 28 let* ((cmd (
4020: 24 20 27 63 6d 64 29 29 0a 09 20 28 70 61 72 61 $ 'cmd)).. (para
4030: 6d 73 6a 20 28 24 20 27 70 61 72 61 6d 73 29 29 msj ($ 'params))
4040: 0a 09 20 28 70 61 72 61 6d 73 20 20 28 64 62 3a .. (params (db:
4050: 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 70 61 72 61 string->obj para
4060: 6d 73 6a 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 msj transport: '
4070: 68 74 74 70 29 29 20 3b 3b 20 69 6e 63 6f 6d 69 http)) ;; incomi
4080: 6e 67 20 64 61 74 61 20 66 72 6f 6d 20 74 68 65 ng data from the
4090: 20 50 4f 53 54 20 28 6f 72 20 69 73 20 69 74 20 POST (or is it
40a0: 61 20 47 45 54 3f 29 0a 09 20 28 72 65 73 64 61 a GET?).. (resda
40b0: 74 20 20 28 61 70 69 3a 65 78 65 63 75 74 65 2d t (api:execute-
40c0: 72 65 71 75 65 73 74 73 20 64 62 73 74 72 75 63 requests dbstruc
40d0: 74 20 28 76 65 63 74 6f 72 20 63 6d 64 20 70 61 t (vector cmd pa
40e0: 72 61 6d 73 29 20 2a 71 75 65 75 65 73 2a 29 29 rams) *queues*))
40f0: 20 3b 3b 20 70 72 6f 63 65 73 73 20 74 68 65 20 ;; process the
4100: 72 65 71 75 65 73 74 2c 20 72 65 73 64 61 74 20 request, resdat
4110: 3d 20 23 28 20 66 6c 61 67 20 72 65 73 75 6c 74 = #( flag result
4120: 20 29 2c 20 77 65 20 72 65 73 6f 72 74 20 74 6f ), we resort to
4130: 20 61 20 67 6c 6f 62 61 6c 20 68 65 72 65 20 66 a global here f
4140: 6f 72 20 74 68 65 20 71 75 65 75 65 73 2e 0a 09 or the queues...
4150: 20 28 73 75 63 63 65 73 73 20 28 76 65 63 74 6f (success (vecto
4160: 72 2d 72 65 66 20 72 65 73 64 61 74 20 30 29 29 r-ref resdat 0))
4170: 0a 09 20 28 72 65 73 20 20 20 20 20 28 76 65 63 .. (res (vec
4180: 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 20 31 tor-ref resdat 1
4190: 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 20 66 ))) ;; (vector f
41a0: 6c 61 67 20 70 61 79 6c 6f 61 64 29 2c 20 67 65 lag payload), ge
41b0: 74 20 74 68 65 20 70 61 79 6c 6f 61 64 2c 20 69 t the payload, i
41c0: 67 6e 6f 72 65 20 74 68 65 20 66 6c 61 67 20 28 gnore the flag (
41d0: 77 68 79 3f 29 0a 20 20 20 20 28 69 66 20 28 6e why?). (if (n
41e0: 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 64 65 ot success)..(de
41f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4200: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4210: 45 52 52 4f 52 3a 20 73 75 63 63 65 73 73 20 66 ERROR: success f
4220: 6c 61 67 20 69 73 20 23 66 20 66 6f 72 20 22 20 lag is #f for "
4230: 63 6d 64 20 22 20 77 69 74 68 20 70 61 72 61 6d cmd " with param
4240: 73 20 22 20 70 61 72 61 6d 73 29 29 0a 20 20 20 s " params)).
4250: 20 28 69 66 20 28 3e 20 2a 61 70 69 2d 70 72 6f (if (> *api-pro
4260: 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 cess-request-cou
4270: 6e 74 2a 20 2a 6d 61 78 2d 61 70 69 2d 70 72 6f nt* *max-api-pro
4280: 63 65 73 73 2d 72 65 71 75 65 73 74 73 2a 29 0a cess-requests*).
4290: 09 28 73 65 74 21 20 2a 6d 61 78 2d 61 70 69 2d .(set! *max-api-
42a0: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 73 process-requests
42b0: 2a 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 * *api-process-r
42c0: 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 29 29 0a equest-count*)).
42d0: 20 20 20 20 28 73 65 74 21 20 2a 61 70 69 2d 70 (set! *api-p
42e0: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 rocess-request-c
42f0: 6f 75 6e 74 2a 20 28 2d 20 2a 61 70 69 2d 70 72 ount* (- *api-pr
4300: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f ocess-request-co
4310: 75 6e 74 2a 20 31 29 29 0a 20 20 20 20 3b 3b 20 unt* 1)). ;;
4320: 54 68 69 73 20 63 61 6e 20 62 65 20 68 65 72 65 This can be here
4330: 20 62 75 74 20 6e 65 65 64 73 20 63 6f 6e 74 72 but needs contr
4340: 6f 6c 73 20 74 6f 20 65 6e 73 75 72 65 20 69 74 ols to ensure it
4350: 20 64 6f 65 73 6e 27 74 20 72 75 6e 20 6d 6f 72 doesn't run mor
4360: 65 20 74 68 61 6e 20 65 76 65 72 79 20 34 20 73 e than every 4 s
4370: 65 63 6f 6e 64 73 0a 20 20 20 20 3b 3b 20 28 72 econds. ;; (r
4380: 6d 74 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 mt:dat->json-str
4390: 0a 20 20 20 20 3b 3b 20 20 28 69 66 20 28 6f 72 . ;; (if (or
43a0: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 20 (string? res).
43b0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 ;; (
43c0: 6c 69 73 74 3f 20 20 20 72 65 73 29 0a 20 20 20 list? res).
43d0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6e 75 ;; (nu
43e0: 6d 62 65 72 3f 20 72 65 73 29 0a 20 20 20 20 3b mber? res). ;
43f0: 3b 20 20 20 20 20 20 20 20 20 20 28 62 6f 6f 6c ; (bool
4400: 65 61 6e 3f 20 72 65 73 29 29 0a 20 20 20 20 3b ean? res)). ;
4410: 3b 20 20 20 20 20 20 72 65 73 20 0a 20 20 20 20 ; res .
4420: 3b 3b 20 20 20 20 20 20 28 6c 69 73 74 20 22 45 ;; (list "E
4430: 52 52 4f 52 2c 20 6e 6f 74 20 73 74 72 69 6e 67 RROR, not string
4440: 2c 20 6c 69 73 74 2c 20 6e 75 6d 62 65 72 20 6f , list, number o
4450: 72 20 62 6f 6f 6c 65 61 6e 22 20 31 20 63 6d 64 r boolean" 1 cmd
4460: 20 70 61 72 61 6d 73 20 72 65 73 29 29 29 29 29 params res)))))
4470: 0a 20 20 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 . (db:obj->st
4480: 72 69 6e 67 20 72 65 73 20 74 72 61 6e 73 70 6f ring res transpo
4490: 72 74 3a 20 27 68 74 74 70 29 29 29 0a 0a 28 64 rt: 'http)))..(d
44a0: 65 66 69 6e 65 20 61 70 69 3a 71 75 65 75 65 2d efine api:queue-
44b0: 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 mutex (make-mute
44c0: 78 29 29 0a 0a 3b 3b 20 61 70 69 20 71 75 65 75 x))..;; api queu
44d0: 65 64 20 72 65 71 75 65 73 74 20 68 61 6e 64 6c ed request handl
44e0: 65 72 0a 3b 3b 0a 3b 3b 20 71 72 79 2d 74 79 70 er.;;.;; qry-typ
44f0: 65 3a 20 72 65 61 64 20 77 72 69 74 65 20 74 72 e: read write tr
4500: 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 0a 28 64 65 ansaction.;;.(de
4510: 66 69 6e 65 20 28 61 70 69 3a 71 75 65 75 65 64 fine (api:queued
4520: 2d 72 65 71 75 65 73 74 20 71 75 65 75 65 73 20 -request queues
4530: 71 72 79 2d 74 79 70 65 20 70 61 72 61 6d 73 20 qry-type params
4540: 70 72 6f 63 29 0a 20 20 3b 3b 20 61 64 64 20 70 proc). ;; add p
4550: 72 6f 63 20 74 6f 20 72 65 61 64 2c 20 77 72 69 roc to read, wri
4560: 74 65 20 71 75 65 75 65 20 6f 72 20 69 66 20 74 te queue or if t
4570: 72 61 6e 73 61 63 74 69 6f 6e 20 64 6f 20 69 74 ransaction do it
4580: 20 69 6d 6d 65 64 69 61 74 65 6c 79 20 28 66 6f immediately (fo
4590: 72 20 6e 6f 77 2c 20 6e 6f 74 20 73 75 72 65 20 r now, not sure
45a0: 62 75 74 20 6d 69 67 68 74 20 6e 65 65 64 20 74 but might need t
45b0: 6f 20 70 72 6f 63 65 73 73 20 64 69 66 66 65 72 o process differ
45c0: 65 6e 74 6c 79 2e 29 0a 20 20 28 69 66 20 71 75 ently.). (if qu
45d0: 65 75 65 73 0a 20 20 20 20 20 20 28 62 65 67 69 eues. (begi
45e0: 6e 0a 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 n..(mutex-lock!
45f0: 28 61 70 69 3a 71 75 65 75 65 73 2d 6d 75 74 65 (api:queues-mute
4600: 78 20 71 75 65 75 65 73 29 29 0a 09 28 6c 65 74 x queues))..(let
4610: 20 28 28 64 61 74 20 28 76 65 63 74 6f 72 20 70 ((dat (vector p
4620: 72 6f 63 20 70 61 72 61 6d 73 20 23 66 29 29 29 roc params #f)))
4630: 20 3b 3b 20 23 66 20 69 73 20 70 6c 61 63 65 68 ;; #f is placeh
4640: 6f 6c 64 65 72 20 66 6f 72 20 74 68 65 20 72 65 older for the re
4650: 73 75 6c 74 0a 09 20 20 28 63 61 73 65 20 71 72 sult.. (case qr
4660: 79 2d 74 79 70 65 0a 09 20 20 20 20 28 28 72 65 y-type.. ((re
4670: 61 64 29 0a 09 20 20 20 20 20 28 61 70 69 3a 71 ad).. (api:q
4680: 75 65 75 65 73 2d 72 65 61 64 71 2d 73 65 74 21 ueues-readq-set!
4690: 20 20 71 75 65 75 65 73 20 28 63 6f 6e 73 20 64 queues (cons d
46a0: 61 74 20 28 61 70 69 3a 71 75 65 75 65 73 2d 72 at (api:queues-r
46b0: 65 61 64 71 20 71 75 65 75 65 73 29 29 29 0a 09 eadq queues)))..
46c0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
46d0: 63 6b 21 20 28 61 70 69 3a 71 75 65 75 65 73 2d ck! (api:queues-
46e0: 6d 75 74 65 78 20 71 75 65 75 65 73 29 28 61 70 mutex queues)(ap
46f0: 69 3a 71 75 65 75 65 73 2d 72 65 61 64 2d 63 76 i:queues-read-cv
4700: 61 72 20 71 75 65 75 65 73 29 29 20 3b 3b 20 75 ar queues)) ;; u
4710: 6e 6c 6f 63 6b 20 6d 75 74 65 78 20 61 6e 64 20 nlock mutex and
4720: 70 72 6f 63 65 65 64 20 77 68 65 6e 20 63 6f 6e proceed when con
4730: 64 69 74 69 6f 6e 20 76 61 72 20 69 73 20 74 72 dition var is tr
4740: 69 67 67 65 72 65 64 0a 09 20 20 20 20 20 28 76 iggered.. (v
4750: 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 32 29 ector-ref dat 2)
4760: 29 20 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 ) ;; return the
4770: 76 61 6c 75 65 20 66 72 6f 6d 20 74 68 65 20 71 value from the q
4780: 75 65 72 79 20 74 6f 20 74 68 65 20 63 61 6c 6c uery to the call
4790: 65 72 0a 09 20 20 20 20 28 28 77 72 69 74 65 29 er.. ((write)
47a0: 0a 09 20 20 20 20 20 28 61 70 69 3a 71 75 65 75 .. (api:queu
47b0: 65 73 2d 77 72 69 74 65 71 2d 73 65 74 21 20 71 es-writeq-set! q
47c0: 75 65 75 65 73 20 28 63 6f 6e 73 20 64 61 74 20 ueues (cons dat
47d0: 28 61 70 69 3a 71 75 65 75 65 73 2d 77 72 69 74 (api:queues-writ
47e0: 65 71 20 71 75 65 75 65 73 29 29 29 0a 09 20 20 eq queues)))..
47f0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
4800: 21 20 28 61 70 69 3a 71 75 65 75 65 73 2d 6d 75 ! (api:queues-mu
4810: 74 65 78 20 71 75 65 75 65 73 29 28 61 70 69 3a tex queues)(api:
4820: 71 75 65 75 65 73 2d 77 72 69 74 65 2d 63 76 61 queues-write-cva
4830: 72 20 71 75 65 75 65 73 29 29 20 3b 3b 20 75 6e r queues)) ;; un
4840: 6c 6f 63 6b 20 6d 75 74 65 78 20 61 6e 64 20 70 lock mutex and p
4850: 72 6f 63 65 65 64 20 77 68 65 6e 20 63 6f 6e 64 roceed when cond
4860: 69 74 69 6f 6e 20 76 61 72 20 69 73 20 74 72 69 ition var is tri
4870: 67 67 65 72 65 64 0a 09 20 20 20 20 20 28 76 65 ggered.. (ve
4880: 63 74 6f 72 2d 72 65 66 20 64 61 74 20 32 29 29 ctor-ref dat 2))
4890: 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 .. (else..
48a0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
48b0: 20 28 61 70 69 3a 71 75 65 75 65 73 2d 6d 75 74 (api:queues-mut
48c0: 65 78 20 71 75 65 75 65 73 29 29 0a 09 20 20 20 ex queues))..
48d0: 20 20 28 70 72 6f 63 29 29 29 29 29 0a 20 20 20 (proc))))).
48e0: 20 20 20 28 70 72 6f 63 29 29 29 0a 0a 3b 3b 20 (proc)))..;;
48f0: 70 72 6f 63 65 73 73 20 71 75 65 75 65 73 0a 3b process queues.;
4900: 3b 0a 28 64 65 66 69 6e 65 20 28 61 70 69 3a 70 ;.(define (api:p
4910: 72 6f 63 65 73 73 2d 71 75 65 75 65 73 20 71 75 rocess-queues qu
4920: 65 75 65 73 29 0a 20 20 28 6d 75 74 65 78 2d 6c eues). (mutex-l
4930: 6f 63 6b 20 28 61 70 69 3a 71 75 65 75 65 73 2d ock (api:queues-
4940: 6d 75 74 65 78 20 71 75 65 75 65 73 29 29 0a 20 mutex queues)).
4950: 20 28 6c 65 74 2a 20 28 28 6e 6f 77 20 20 20 20 (let* ((now
4960: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (current-mil
4970: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 64 liseconds)).. (d
4980: 75 65 20 20 20 20 20 20 20 20 28 2d 20 6e 6f 77 ue (- now
4990: 20 35 30 30 29 29 20 3b 3b 20 77 65 20 77 69 6c 500)) ;; we wil
49a0: 6c 20 70 72 6f 63 65 73 73 20 74 68 65 20 71 75 l process the qu
49b0: 65 75 65 20 69 66 20 69 74 20 68 61 73 20 6e 6f eue if it has no
49c0: 74 20 62 65 65 6e 20 70 72 6f 63 65 73 73 65 64 t been processed
49d0: 20 69 6e 20 35 30 30 20 6d 73 0a 09 20 28 72 65 in 500 ms.. (re
49e0: 61 64 73 20 20 20 20 20 20 28 61 70 69 3a 71 75 ads (api:qu
49f0: 65 75 65 73 2d 72 65 61 64 71 20 20 20 20 20 20 eues-readq
4a00: 71 75 65 75 65 73 29 29 0a 09 20 28 77 72 69 74 queues)).. (writ
4a10: 65 73 20 20 20 20 20 28 61 70 69 3a 71 75 65 75 es (api:queu
4a20: 65 73 2d 77 72 69 74 65 71 20 20 20 20 20 71 75 es-writeq qu
4a30: 65 75 65 73 29 29 0a 09 20 28 6c 61 73 74 2d 72 eues)).. (last-r
4a40: 65 61 64 20 20 28 61 70 69 3a 71 75 65 75 65 73 ead (api:queues
4a50: 2d 6c 61 73 74 2d 72 65 61 64 20 20 71 75 65 75 -last-read queu
4a60: 65 73 29 29 0a 09 20 28 6c 61 73 74 2d 77 72 69 es)).. (last-wri
4a70: 74 65 20 28 61 70 69 3a 71 75 65 75 65 73 2d 6c te (api:queues-l
4a80: 61 73 74 2d 77 72 69 74 65 20 71 75 65 75 65 73 ast-write queues
4a90: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ))). (cond.
4aa0: 20 20 20 28 28 61 6e 64 20 28 3e 3d 20 6c 61 73 ((and (>= las
4ab0: 74 2d 72 65 61 64 20 6c 61 73 74 2d 77 72 69 74 t-read last-writ
4ac0: 65 29 20 3b 3b 20 6e 75 64 67 65 20 74 68 65 20 e) ;; nudge the
4ad0: 73 79 73 74 65 6d 20 74 6f 20 74 6f 67 67 6c 65 system to toggle
4ae0: 20 62 65 74 77 65 65 6e 20 70 72 6f 63 65 73 73 between process
4af0: 69 6e 67 20 74 68 65 20 72 65 61 64 73 20 61 6e ing the reads an
4b00: 64 20 70 72 6f 63 65 73 73 69 6e 67 20 74 68 65 d processing the
4b10: 20 77 72 69 74 65 73 0a 09 20 20 20 28 6e 6f 74 writes.. (not
4b20: 20 28 6e 75 6c 6c 3f 20 72 65 61 64 73 29 29 0a (null? reads)).
4b30: 09 20 20 20 28 3e 20 64 75 65 20 6c 61 73 74 2d . (> due last-
4b40: 72 65 61 64 29 29 0a 20 20 20 20 20 20 28 64 62 read)). (db
4b50: 3a 77 69 74 68 2d 64 62 20 20 20 20 20 20 20 20 :with-db
4b60: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 70 ;; p
4b70: 72 6f 63 65 73 73 20 74 68 65 20 70 72 6f 63 73 rocess the procs
4b80: 20 69 6e 73 69 64 65 20 61 20 74 72 61 6e 73 61 inside a transa
4b90: 63 74 69 6f 6e 0a 20 20 20 20 20 20 20 28 61 70 ction. (ap
4ba0: 69 3a 71 75 65 75 65 73 2d 64 62 73 74 72 75 63 i:queues-dbstruc
4bb0: 74 20 71 75 65 75 65 73 29 0a 20 20 20 20 20 20 t queues).
4bc0: 20 23 66 0a 20 20 20 20 20 20 20 23 66 0a 20 20 #f. #f.
4bd0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 (lambda (db
4be0: 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 77 69 74 ).. (sqlite3:wit
4bf0: 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e 20 20 20 h-transaction
4c00: 3b 3b 20 74 68 65 20 74 72 61 6e 73 61 63 74 69 ;; the transacti
4c10: 6f 6e 0a 09 20 20 64 62 0a 09 20 20 28 6c 61 6d on.. db.. (lam
4c20: 62 64 61 20 28 29 0a 09 20 20 20 20 28 66 6f 72 bda ().. (for
4c30: 2d 65 61 63 68 0a 09 20 20 20 20 20 28 6c 61 6d -each.. (lam
4c40: 62 64 61 20 28 70 72 6f 63 64 61 74 29 0a 09 20 bda (procdat)..
4c50: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
4c60: 74 21 20 70 72 6f 63 64 61 74 20 32 20 28 28 76 t! procdat 2 ((v
4c70: 65 63 74 6f 72 2d 72 65 66 20 70 72 6f 63 64 61 ector-ref procda
4c80: 74 20 30 29 29 29 29 20 3b 3b 20 73 65 74 20 76 t 0)))) ;; set v
4c90: 65 63 74 6f 72 20 33 72 64 20 70 6f 73 20 74 6f ector 3rd pos to
4ca0: 20 74 68 65 20 72 65 73 75 6c 74 20 6f 66 20 63 the result of c
4cb0: 61 6c 63 75 6c 61 74 69 6e 67 20 70 72 6f 63 0a alculating proc.
4cc0: 09 20 20 20 20 20 72 65 61 64 73 29 29 29 29 29 . reads)))))
4cd0: 0a 20 20 20 20 20 20 3b 3b 20 6e 6f 77 20 72 65 . ;; now re
4ce0: 73 65 74 20 74 68 65 20 71 75 65 75 65 20 76 61 set the queue va
4cf0: 6c 75 65 73 0a 20 20 20 20 20 20 28 61 70 69 3a lues. (api:
4d00: 71 75 65 75 65 73 2d 72 65 61 64 2d 73 65 74 21 queues-read-set!
4d10: 20 20 20 20 20 20 71 75 65 75 65 73 20 27 28 29 queues '()
4d20: 29 0a 20 20 20 20 20 20 28 61 70 69 3a 71 75 65 ). (api:que
4d30: 75 65 73 2d 6c 61 73 74 2d 72 65 61 64 2d 73 65 ues-last-read-se
4d40: 74 21 20 71 75 65 75 65 73 20 6e 6f 77 29 0a 20 t! queues now).
4d50: 20 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d (condition-
4d60: 76 61 72 69 61 62 6c 65 2d 62 72 6f 61 64 63 61 variable-broadca
4d70: 73 74 21 20 28 61 70 69 3a 71 75 65 75 65 73 2d st! (api:queues-
4d80: 72 65 61 64 2d 63 76 61 72 20 71 75 65 75 65 73 read-cvar queues
4d90: 29 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 28 ))). ((and (
4da0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 77 72 69 74 65 not (null? write
4db0: 73 29 29 0a 09 20 20 20 28 3e 20 64 75 65 20 6c s)).. (> due l
4dc0: 61 73 74 2d 77 72 69 74 65 29 29 0a 20 20 20 20 ast-write)).
4dd0: 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 (db:with-db.
4de0: 20 20 20 20 20 28 61 70 69 3a 71 75 65 75 65 73 (api:queues
4df0: 2d 64 62 73 74 72 75 63 74 20 71 75 65 75 65 73 -dbstruct queues
4e00: 29 0a 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 ). #f.
4e10: 20 20 20 23 66 0a 20 20 20 20 20 20 20 28 6c 61 #f. (la
4e20: 6d 62 64 61 20 28 64 62 29 0a 09 20 28 73 71 6c mbda (db).. (sql
4e30: 69 74 65 33 3a 77 69 74 68 2d 74 72 61 6e 73 61 ite3:with-transa
4e40: 63 74 69 6f 6e 0a 09 20 20 64 62 0a 09 20 20 28 ction.. db.. (
4e50: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 28 lambda ().. (
4e60: 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 28 for-each.. (
4e70: 6c 61 6d 62 64 61 20 28 70 72 6f 63 64 61 74 29 lambda (procdat)
4e80: 0a 09 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 .. (vector
4e90: 2d 73 65 74 21 20 70 72 6f 63 64 61 74 20 32 20 -set! procdat 2
4ea0: 28 28 76 65 63 74 6f 72 2d 72 65 66 20 70 72 6f ((vector-ref pro
4eb0: 63 64 61 74 20 30 29 29 29 29 0a 09 20 20 20 20 cdat 0))))..
4ec0: 20 77 72 69 74 65 73 29 29 29 29 29 0a 20 20 20 writes))))).
4ed0: 20 20 20 3b 3b 20 6e 6f 77 20 72 65 73 65 74 20 ;; now reset
4ee0: 74 68 65 20 71 75 65 75 65 20 76 61 6c 75 65 73 the queue values
4ef0: 0a 20 20 20 20 20 20 28 61 70 69 3a 71 75 65 75 . (api:queu
4f00: 65 73 2d 77 72 69 74 65 2d 73 65 74 21 20 20 20 es-write-set!
4f10: 20 71 75 65 75 65 73 20 27 28 29 29 0a 20 20 20 queues '()).
4f20: 20 20 20 28 61 70 69 3a 71 75 65 75 65 73 2d 6c (api:queues-l
4f30: 61 73 74 2d 77 72 69 74 65 2d 73 65 74 21 20 71 ast-write-set! q
4f40: 75 65 75 65 73 20 6e 6f 77 29 0a 20 20 20 20 20 ueues now).
4f50: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 76 61 72 69 (condition-vari
4f60: 61 62 6c 65 2d 62 72 6f 61 64 63 61 73 74 21 20 able-broadcast!
4f70: 28 61 70 69 3a 71 75 65 75 65 73 2d 77 72 69 74 (api:queues-writ
4f80: 65 2d 63 76 61 72 20 71 75 65 75 65 73 29 29 29 e-cvar queues)))
4f90: 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c ). (mutex-unl
4fa0: 6f 63 6b 20 28 61 70 69 3a 71 75 65 75 65 73 2d ock (api:queues-
4fb0: 6d 75 74 65 78 20 71 75 65 75 65 73 29 29 29 29 mutex queues))))
4fc0: 0a 20 20 20 20 20 20 0a 09 20 0a . .. .