0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 20 6-2012, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 This file is par
0040: 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a 3b t of Megatest..;
0050: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
0060: 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 77 st is free softw
0070: 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 64 are: you can red
0080: 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e 64 istribute it and
0090: 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 20 /or modify.;;
00a0: 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 74 it under the t
00b0: 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 20 erms of the GNU
00c0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
00d0: 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 73 icense as publis
00e0: 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 68 hed by.;; th
00f0: 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 20 e Free Software
0100: 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 68 Foundation, eith
0110: 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 20 er version 3 of
0120: 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 0a the License, or.
0130: 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 20 ;; (at your
0140: 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 65 option) any late
0150: 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a 3b r version..;; .;
0160: 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 69 ; Megatest i
0170: 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 6e s distributed in
0180: 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 69 the hope that i
0190: 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 6c t will be useful
01a0: 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 54 ,.;; but WIT
01b0: 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e 54 HOUT ANY WARRANT
01c0: 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e 20 Y; without even
01d0: 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 72 the implied warr
01e0: 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 4d anty of.;; M
01f0: 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 6f ERCHANTABILITY o
0200: 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 r FITNESS FOR A
0210: 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f PARTICULAR PURPO
0220: 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b 20 SE. See the.;;
0230: 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 GNU General
0240: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 66 Public License f
0250: 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 2e or more details.
0260: 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 20 .;; .;; You
0270: 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 65 should have rece
0280: 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 74 ived a copy of t
0290: 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 he GNU General P
02a0: 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b 3b ublic License.;;
02b0: 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 20 along with
02c0: 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e 6f Megatest. If no
02d0: 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f 77 t, see <http://w
02e0: 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 6e ww.gnu.org/licen
02f0: 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 3b 3b 20 20 73 ses/>..;;..;; s
0300: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0310: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0320: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0330: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0340: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
0350: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
0360: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 66 69 dot-locking f
0370: 6f 72 6d 61 74 29 0a 28 69 6d 70 6f 72 74 20 28 ormat).(import (
0380: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0390: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
03a0: 61 72 65 20 28 75 6e 69 74 20 74 61 73 6b 73 29 are (unit tasks)
03b0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03c0: 20 64 62 66 69 6c 65 29 29 0a 28 64 65 63 6c 61 dbfile)).(decla
03d0: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
03e0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 6d 74 eclare (uses rmt
03f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0400: 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c s common)).(decl
0410: 61 72 65 20 28 75 73 65 73 20 70 67 64 62 29 29 are (uses pgdb))
0420: 0a 0a 28 69 6d 70 6f 72 74 20 64 62 66 69 6c 65 ..(import dbfile
0430: 29 0a 3b 3b 20 28 69 6d 70 6f 72 74 20 70 67 64 ).;; (import pgd
0440: 62 29 20 3b 3b 20 70 67 64 62 20 69 73 20 61 20 b) ;; pgdb is a
0450: 6d 6f 64 75 6c 65 0a 0a 28 69 6e 63 6c 75 64 65 module..(include
0460: 20 22 74 61 73 6b 5f 72 65 63 6f 72 64 73 2e 73 "task_records.s
0470: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 cm").(include "d
0480: 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a b_records.scm").
0490: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 61 73 =========.;; Tas
04e0: 6b 73 20 64 62 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ks db.;;========
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0530: 3b 3b 20 77 61 69 74 20 75 70 20 74 6f 20 61 70 ;; wait up to ap
0540: 72 6f 78 20 6e 20 73 65 63 6f 6e 64 73 20 66 6f rox n seconds fo
0550: 72 20 61 20 6a 6f 75 72 6e 61 6c 20 74 6f 20 67 r a journal to g
0560: 6f 20 61 77 61 79 0a 3b 3b 0a 28 64 65 66 69 6e o away.;;.(defin
0570: 65 20 28 74 61 73 6b 73 3a 77 61 69 74 2d 6f 6e e (tasks:wait-on
0580: 2d 6a 6f 75 72 6e 61 6c 20 70 61 74 68 20 6e 20 -journal path n
0590: 23 21 6b 65 79 20 28 72 65 6d 6f 76 65 20 23 66 #!key (remove #f
05a0: 29 28 77 61 69 74 69 6e 67 2d 6d 73 67 20 23 66 )(waiting-msg #f
05b0: 29 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 73 )). (if (not (s
05c0: 74 72 69 6e 67 3f 20 70 61 74 68 29 29 0a 20 20 tring? path)).
05d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
05e0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
05f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 61 6c t-log-port* "Cal
0600: 6c 65 64 20 74 61 73 6b 73 3a 77 61 69 74 2d 6f led tasks:wait-o
0610: 6e 2d 6a 6f 75 72 6e 61 6c 20 77 69 74 68 20 70 n-journal with p
0620: 61 74 68 3d 22 20 70 61 74 68 20 22 20 28 6e 6f ath=" path " (no
0630: 74 20 61 20 73 74 72 69 6e 67 29 22 29 0a 20 20 t a string)").
0640: 20 20 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 70 (let ((fullp
0650: 61 74 68 20 28 63 6f 6e 63 20 70 61 74 68 20 22 ath (conc path "
0660: 2d 6a 6f 75 72 6e 61 6c 22 29 29 29 0a 09 28 68 -journal")))..(h
0670: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
0680: 0a 09 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a .. exn.. (begin.
0690: 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d . (print-call-
06a0: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
06b0: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 rror-port))..
06c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
06d0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
06e0: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
06f0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
0700: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
0710: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
0720: 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
0730: 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 5 *default-lo
0740: 67 2d 70 6f 72 74 2a 20 22 20 65 78 6e 3d 22 20 g-port* " exn="
0750: 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 (condition->list
0760: 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 62 75 exn)).. (debu
0770: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
0780: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 61 lt-log-port* "ta
0790: 73 6b 73 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 sks:wait-on-jour
07a0: 6e 61 6c 20 66 61 69 6c 65 64 2e 20 43 6f 6e 74 nal failed. Cont
07b0: 69 6e 75 69 6e 67 20 6f 6e 2c 20 79 6f 75 20 63 inuing on, you c
07c0: 61 6e 20 69 67 6e 6f 72 65 20 74 68 69 73 20 63 an ignore this c
07d0: 61 6c 6c 2d 63 68 61 69 6e 22 29 0a 09 20 20 20 all-chain")..
07e0: 23 74 29 20 3b 3b 20 69 66 20 73 74 75 66 66 20 #t) ;; if stuff
07f0: 67 6f 65 73 20 77 72 6f 6e 67 20 6a 75 73 74 20 goes wrong just
0800: 61 6c 6c 6f 77 20 69 74 20 74 6f 20 6d 6f 76 65 allow it to move
0810: 20 6f 6e 0a 09 20 28 6c 65 74 20 6c 6f 6f 70 20 on.. (let loop
0820: 28 28 6a 6f 75 72 6e 61 6c 2d 65 78 69 73 74 73 ((journal-exists
0830: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
0840: 69 73 74 73 3f 20 66 75 6c 6c 70 61 74 68 29 29 ists? fullpath))
0850: 0a 09 09 20 20 20 20 28 63 6f 75 6e 74 20 20 20 ... (count
0860: 20 20 20 20 20 20 20 6e 29 29 20 3b 3b 20 77 61 n)) ;; wa
0870: 69 74 20 74 65 6e 20 74 69 6d 65 73 20 2e 2e 2e it ten times ...
0880: 0a 09 20 20 20 28 69 66 20 6a 6f 75 72 6e 61 6c .. (if journal
0890: 2d 65 78 69 73 74 73 0a 09 20 20 20 20 20 20 20 -exists..
08a0: 28 62 65 67 69 6e 0a 09 09 20 28 69 66 20 28 61 (begin... (if (a
08b0: 6e 64 20 77 61 69 74 69 6e 67 2d 6d 73 67 0a 09 nd waiting-msg..
08c0: 09 09 20 20 28 65 71 3f 20 28 6d 6f 64 75 6c 6f .. (eq? (modulo
08d0: 20 6e 20 33 30 29 20 30 29 29 0a 09 09 20 20 20 n 30) 0))...
08e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
08f0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0900: 72 74 2a 20 77 61 69 74 69 6e 67 2d 6d 73 67 29 rt* waiting-msg)
0910: 29 0a 09 09 20 28 69 66 20 28 3e 20 63 6f 75 6e )... (if (> coun
0920: 74 20 30 29 0a 09 09 20 20 20 20 20 28 62 65 67 t 0)... (beg
0930: 69 6e 0a 09 09 20 20 20 20 20 20 20 28 74 68 72 in... (thr
0940: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 ead-sleep! 1)...
0950: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f (loop (co
0960: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
0970: 3f 20 66 75 6c 6c 70 61 74 68 29 0a 09 09 09 20 ? fullpath)....
0980: 20 20 20 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 (- count 1))
0990: 29 0a 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a )... (begin.
09a0: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
09b0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
09c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
09d0: 52 3a 20 72 65 6d 6f 76 69 6e 67 20 74 68 65 20 R: removing the
09e0: 6a 6f 75 72 6e 61 6c 20 66 69 6c 65 20 22 20 66 journal file " f
09f0: 75 6c 6c 70 61 74 68 20 22 2c 20 74 68 69 73 20 ullpath ", this
0a00: 69 73 20 6e 6f 74 20 67 6f 6f 64 2e 20 4c 6f 6f is not good. Loo
0a10: 6b 20 66 6f 72 20 64 69 73 6b 20 66 75 6c 6c 2c k for disk full,
0a20: 20 77 72 69 74 65 20 61 63 63 65 73 73 20 61 6e write access an
0a30: 64 20 6f 74 68 65 72 20 69 73 73 75 65 73 2e 22 d other issues."
0a40: 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 72 )... (if r
0a50: 65 6d 6f 76 65 20 28 73 79 73 74 65 6d 20 28 63 emove (system (c
0a60: 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 66 75 onc "rm -rf " fu
0a70: 6c 6c 70 61 74 68 29 29 29 0a 09 09 20 20 20 20 llpath)))...
0a80: 20 20 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 #f)))..
0a90: 20 23 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 #t))))))..(defi
0aa0: 6e 65 20 28 74 61 73 6b 73 3a 67 65 74 2d 74 61 ne (tasks:get-ta
0ab0: 73 6b 2d 64 62 2d 70 61 74 68 29 0a 20 20 28 6c sk-db-path). (l
0ac0: 65 74 20 28 28 64 62 64 69 72 20 20 28 6f 72 20 et ((dbdir (or
0ad0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
0ae0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
0af0: 75 70 22 20 22 6d 6f 6e 69 74 6f 72 64 69 72 22 up" "monitordir"
0b00: 29 0a 09 09 20 20 20 20 28 63 6f 6e 66 69 67 66 )... (configf
0b10: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
0b20: 61 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 64 at* "setup" "dbd
0b30: 69 72 22 29 0a 09 09 20 20 20 20 28 63 6f 6e 63 ir")... (conc
0b40: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e (common:get-lin
0b50: 6b 74 72 65 65 29 20 22 2f 2e 64 62 22 29 29 29 ktree) "/.db")))
0b60: 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 ). (handle-ex
0b70: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 ceptions. ex
0b80: 6e 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 n. (begin.
0b90: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0ba0: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
0bb0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 6f lt-log-port* "Co
0bc0: 75 6c 64 6e 27 74 20 63 72 65 61 74 65 20 70 61 uldn't create pa
0bd0: 74 68 20 74 6f 20 22 20 64 62 64 69 72 20 22 2c th to " dbdir ",
0be0: 20 65 78 6e 3d 22 20 65 78 6e 29 0a 20 20 20 20 exn=" exn).
0bf0: 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 (exit 1)).
0c00: 20 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 (if (not (dire
0c10: 63 74 6f 72 79 3f 20 64 62 64 69 72 29 29 28 63 ctory? dbdir))(c
0c20: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
0c30: 64 62 64 69 72 20 23 74 29 29 29 0a 20 20 20 20 dbdir #t))).
0c40: 64 62 64 69 72 29 29 0a 0a 3b 3b 20 49 66 20 66 dbdir))..;; If f
0c50: 69 6c 65 20 65 78 69 73 74 73 20 41 4e 44 0a 3b ile exists AND.;
0c60: 3b 20 20 20 20 66 69 6c 65 20 72 65 61 64 61 62 ; file readab
0c70: 6c 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 3d 3d le.;; ==
0c80: 3e 20 6f 70 65 6e 20 69 74 0a 3b 3b 20 49 66 20 > open it.;; If
0c90: 66 69 6c 65 20 65 78 69 73 74 73 20 41 4e 44 0a file exists AND.
0ca0: 3b 3b 20 20 20 20 66 69 6c 65 20 4e 4f 54 20 72 ;; file NOT r
0cb0: 65 61 64 61 62 6c 65 0a 3b 3b 20 20 20 20 20 20 eadable.;;
0cc0: 20 20 20 3d 3d 3e 20 6f 70 65 6e 20 69 6e 2d 6d ==> open in-m
0cd0: 65 6d 20 76 65 72 73 69 6f 6e 0a 3b 3b 20 49 66 em version.;; If
0ce0: 20 66 69 6c 65 20 4e 4f 54 20 65 78 69 73 74 73 file NOT exists
0cf0: 0a 3b 3b 20 20 20 20 3d 3d 3e 20 6f 70 65 6e 20 .;; ==> open
0d00: 69 6e 2d 6d 65 6d 20 76 65 72 73 69 6f 6e 0a 3b in-mem version.;
0d10: 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ;.(define (tasks
0d20: 3a 6f 70 65 6e 2d 64 62 20 23 21 6b 65 79 20 28 :open-db #!key (
0d30: 6e 75 6d 72 65 74 72 69 65 73 20 34 29 29 0a 20 numretries 4)).
0d40: 20 28 69 66 20 2a 74 61 73 6b 2d 64 62 2a 0a 20 (if *task-db*.
0d50: 20 20 20 20 20 2a 74 61 73 6b 2d 64 62 2a 0a 20 *task-db*.
0d60: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
0d70: 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 65 eptions. e
0d80: 78 6e 0a 20 20 20 20 20 20 20 28 69 66 20 28 3e xn. (if (>
0d90: 20 6e 75 6d 72 65 74 72 69 65 73 20 30 29 0a 09 numretries 0)..
0da0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
0db0: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
0dc0: 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
0dd0: 2d 70 6f 72 74 29 29 0a 09 20 20 20 20 20 28 64 -port)).. (d
0de0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
0df0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0e00: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
0e10: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
0e20: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
0e30: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
0e40: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
0e50: 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 5 *default-lo
0e60: 67 2d 70 6f 72 74 2a 20 22 20 65 78 6e 3d 22 20 g-port* " exn="
0e70: 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 (condition->list
0e80: 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 74 68 exn)).. (th
0e90: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 read-sleep! 1)..
0ea0: 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e (tasks:open
0eb0: 2d 64 62 20 6e 75 6d 72 65 74 72 69 65 73 20 28 -db numretries (
0ec0: 2d 20 6e 75 6d 72 65 74 72 69 65 73 20 31 29 29 - numretries 1))
0ed0: 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 ).. (begin..
0ee0: 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
0ef0: 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
0f00: 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 20 ror-port))..
0f10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
0f20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0f30: 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 t* " message: "
0f40: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
0f50: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
0f60: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
0f70: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
0f80: 70 72 69 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 print 5 *default
0f90: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 65 78 6e -log-port* " exn
0fa0: 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c =" (condition->l
0fb0: 69 73 74 20 65 78 6e 29 29 29 29 0a 20 20 20 20 ist exn)))).
0fc0: 20 20 20 28 6c 65 74 2a 20 28 28 64 62 70 61 74 (let* ((dbpat
0fd0: 68 20 20 20 20 20 20 20 20 28 64 62 3a 64 62 66 h (db:dbf
0fe0: 69 6c 65 2d 70 61 74 68 20 29 29 20 3b 3b 20 28 ile-path )) ;; (
0ff0: 74 61 73 6b 73 3a 67 65 74 2d 74 61 73 6b 2d 64 tasks:get-task-d
1000: 62 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 b-path))..
1010: 28 64 62 66 69 6c 65 20 20 20 20 20 20 20 28 63 (dbfile (c
1020: 6f 6e 63 20 64 62 70 61 74 68 20 22 2f 6d 6f 6e onc dbpath "/mon
1030: 69 74 6f 72 2e 64 62 22 29 29 0a 09 20 20 20 20 itor.db"))..
1040: 20 20 28 61 76 61 69 6c 20 20 20 20 20 20 20 20 (avail
1050: 28 74 61 73 6b 73 3a 77 61 69 74 2d 6f 6e 2d 6a (tasks:wait-on-j
1060: 6f 75 72 6e 61 6c 20 64 62 70 61 74 68 20 31 30 ournal dbpath 10
1070: 29 29 20 3b 3b 20 77 61 69 74 20 75 70 20 74 6f )) ;; wait up to
1080: 20 61 62 6f 75 74 20 31 30 20 73 65 63 6f 6e 64 about 10 second
1090: 73 20 66 6f 72 20 74 68 65 20 6a 6f 75 72 6e 61 s for the journa
10a0: 6c 20 74 6f 20 67 6f 20 61 77 61 79 0a 09 20 20 l to go away..
10b0: 20 20 20 20 28 65 78 69 73 74 73 20 20 20 20 20 (exists
10c0: 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 (common:file-e
10d0: 78 69 73 74 73 3f 20 64 62 70 61 74 68 29 29 0a xists? dbpath)).
10e0: 09 20 20 20 20 20 20 28 77 72 69 74 65 2d 61 63 . (write-ac
10f0: 63 65 73 73 20 28 66 69 6c 65 2d 77 72 69 74 65 cess (file-write
1100: 2d 61 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 -access? dbpath)
1110: 29 0a 09 20 20 20 20 20 20 28 6d 64 62 20 20 20 ).. (mdb
1120: 20 20 20 20 20 20 20 28 63 6f 6e 64 20 3b 3b 20 (cond ;;
1130: 77 68 61 74 20 74 68 65 20 68 65 6b 20 69 73 20 what the hek is
1140: 2a 74 6f 70 70 61 74 68 2a 20 64 6f 69 6e 67 20 *toppath* doing
1150: 68 65 72 65 3f 0a 09 09 09 20 20 20 20 20 28 28 here?.... ((
1160: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 2a 74 6f and (string? *to
1170: 70 70 61 74 68 2a 29 28 66 69 6c 65 2d 77 72 69 ppath*)(file-wri
1180: 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 te-access? *topp
1190: 61 74 68 2a 29 29 0a 09 09 09 20 20 20 20 20 20 ath*))....
11a0: 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 (sqlite3:open-da
11b0: 74 61 62 61 73 65 20 64 62 66 69 6c 65 29 29 0a tabase dbfile)).
11c0: 09 09 09 20 20 20 20 20 28 28 66 69 6c 65 2d 72 ... ((file-r
11d0: 65 61 64 2d 61 63 63 65 73 73 3f 20 64 62 70 61 ead-access? dbpa
11e0: 74 68 29 20 20 20 20 28 73 71 6c 69 74 65 33 3a th) (sqlite3:
11f0: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 64 62 open-database db
1200: 66 69 6c 65 29 29 0a 09 09 09 20 20 20 20 20 28 file)).... (
1210: 65 6c 73 65 20 28 73 71 6c 69 74 65 33 3a 6f 70 else (sqlite3:op
1220: 65 6e 2d 64 61 74 61 62 61 73 65 20 22 3a 6d 65 en-database ":me
1230: 6d 6f 72 79 3a 22 29 29 29 29 20 3b 3b 20 28 6e mory:")))) ;; (n
1240: 65 76 65 72 2d 67 69 76 65 2d 75 70 2d 6f 70 65 ever-give-up-ope
1250: 6e 2d 64 62 20 64 62 70 61 74 68 29 29 0a 09 20 n-db dbpath))..
1260: 20 20 20 20 20 28 68 61 6e 64 6c 65 72 20 20 20 (handler
1270: 20 20 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 (sqlite3:make
1280: 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 36 -busy-timeout 36
1290: 30 30 30 29 29 29 0a 09 20 28 69 66 20 28 61 6e 000))).. (if (an
12a0: 64 20 65 78 69 73 74 73 0a 09 09 20 20 28 6e 6f d exists... (no
12b0: 74 20 77 72 69 74 65 2d 61 63 63 65 73 73 29 29 t write-access))
12c0: 0a 09 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 .. (set! *db
12d0: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 2a 20 77 -write-access* w
12e0: 72 69 74 65 2d 61 63 63 65 73 73 29 29 20 3b 3b rite-access)) ;;
12f0: 20 6f 6e 6c 79 20 75 6e 73 65 74 20 73 6f 20 6f only unset so o
1300: 74 68 65 72 20 64 62 27 73 20 61 6c 73 6f 20 63 ther db's also c
1310: 61 6e 20 75 73 65 20 74 68 69 73 20 63 6f 6e 74 an use this cont
1320: 72 6f 6c 0a 09 20 28 73 71 6c 69 74 65 33 3a 73 rol.. (sqlite3:s
1330: 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 et-busy-handler!
1340: 20 6d 64 62 20 68 61 6e 64 6c 65 72 29 0a 09 20 mdb handler)..
1350: 28 64 62 3a 73 65 74 2d 73 79 6e 63 20 6d 64 62 (db:set-sync mdb
1360: 29 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 ) ;; (sqlite3:ex
1370: 65 63 75 74 65 20 6d 64 62 20 28 63 6f 6e 63 20 ecute mdb (conc
1380: 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e "PRAGMA synchron
1390: 6f 75 73 20 3d 20 30 3b 22 29 29 0a 09 20 3b 3b ous = 0;")).. ;;
13a0: 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 (if (or (and (
13b0: 6e 6f 74 20 65 78 69 73 74 73 29 0a 09 20 3b 3b not exists).. ;;
13c0: 20 09 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 . (file-wr
13d0: 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 ite-access? *top
13e0: 70 61 74 68 2a 29 29 0a 09 20 3b 3b 20 09 20 28 path*)).. ;; . (
13f0: 6e 6f 74 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 not (file-read-a
1400: 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 29 29 ccess? dbpath)))
1410: 0a 09 20 3b 3b 20 20 20 20 20 20 28 62 65 67 69 .. ;; (begi
1420: 6e 0a 09 20 3b 3b 20 0a 09 20 3b 3b 20 54 41 53 n.. ;; .. ;; TAS
1430: 4b 53 20 51 55 45 55 45 20 4d 4f 56 45 44 20 54 KS QUEUE MOVED T
1440: 4f 20 6d 61 69 6e 2e 64 62 0a 09 20 3b 3b 0a 09 O main.db.. ;;..
1450: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ;; (sqlite3:exe
1460: 63 75 74 65 20 6d 64 62 20 22 43 52 45 41 54 45 cute mdb "CREATE
1470: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
1480: 49 53 54 53 20 74 61 73 6b 73 5f 71 75 65 75 65 ISTS tasks_queue
1490: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
14a0: 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 MARY KEY,.
14b0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
14c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 61 63 74 act
14d0: 69 6f 6e 20 54 45 58 54 20 44 45 46 41 55 4c 54 ion TEXT DEFAULT
14e0: 20 27 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b '',. ;;
14f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1500: 20 20 20 20 20 20 20 20 6f 77 6e 65 72 20 54 45 owner TE
1510: 58 54 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 XT,. ;;
1520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1530: 20 20 20 20 20 20 20 73 74 61 74 65 20 54 45 58 state TEX
1540: 54 20 44 45 46 41 55 4c 54 20 27 6e 65 77 27 2c T DEFAULT 'new',
1550: 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 . ;;
1560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1570: 20 20 20 20 74 61 72 67 65 74 20 54 45 58 54 20 target TEXT
1580: 44 45 46 41 55 4c 54 20 27 27 2c 0a 20 20 20 20 DEFAULT '',.
1590: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
15a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e n
15b0: 61 6d 65 20 54 45 58 54 20 44 45 46 41 55 4c 54 ame TEXT DEFAULT
15c0: 20 27 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b '',. ;;
15d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15e0: 20 20 20 20 20 20 20 20 74 65 73 74 70 61 74 74 testpatt
15f0: 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 TEXT DEFAULT ''
1600: 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ,. ;;
1610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1620: 20 20 20 20 20 6b 65 79 6c 6f 63 6b 20 54 45 58 keylock TEX
1630: 54 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 T,. ;;
1640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1650: 20 20 20 20 20 20 70 61 72 61 6d 73 20 54 45 58 params TEX
1660: 54 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 T,. ;;
1670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1680: 20 20 20 20 20 20 63 72 65 61 74 69 6f 6e 5f 74 creation_t
1690: 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 ime TIMESTAMP,.
16a0: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
16b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16c0: 20 20 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 execution_time
16d0: 20 54 49 4d 45 53 54 41 4d 50 29 3b 22 29 0a 09 TIMESTAMP);")..
16e0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
16f0: 65 20 6d 64 62 20 22 43 52 45 41 54 45 20 54 41 e mdb "CREATE TA
1700: 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 BLE IF NOT EXIST
1710: 53 20 6d 6f 6e 69 74 6f 72 73 20 28 69 64 20 49 S monitors (id I
1720: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
1730: 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 EY,.
1740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1750: 20 20 20 20 70 69 64 20 49 4e 54 45 47 45 52 2c pid INTEGER,
1760: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1780: 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 4d 45 start_time TIME
1790: 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 STAMP,.
17a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17b0: 20 20 20 20 20 20 20 6c 61 73 74 5f 75 70 64 61 last_upda
17c0: 74 65 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 te TIMESTAMP,.
17d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 6f ho
17f0: 73 74 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 stname TEXT,.
1800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1810: 20 20 20 20 20 20 20 20 20 20 20 20 20 75 73 65 use
1820: 72 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 rname TEXT,.
1830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1840: 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 CONST
1850: 52 41 49 4e 54 20 6d 6f 6e 69 74 6f 72 73 5f 63 RAINT monitors_c
1860: 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 onstraint UNIQUE
1870: 20 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 29 29 (pid,hostname))
1880: 3b 22 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 ;").. (sqlite3:e
1890: 78 65 63 75 74 65 20 6d 64 62 20 22 43 52 45 41 xecute mdb "CREA
18a0: 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 TE TABLE IF NOT
18b0: 45 58 49 53 54 53 20 73 65 72 76 65 72 73 20 28 EXISTS servers (
18c0: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
18d0: 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 RY KEY,.
18e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18f0: 20 20 20 20 20 20 20 20 20 20 70 69 64 20 49 4e pid IN
1900: 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 TEGER,.
1910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1920: 20 20 20 20 20 20 20 20 20 69 6e 74 65 72 66 61 interfa
1930: 63 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 ce TEXT,.
1940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1950: 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 6e hostn
1960: 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 ame TEXT,.
1970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1980: 20 20 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 port
1990: 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 INTEGER,.
19a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19b0: 20 20 20 20 20 20 20 20 20 20 20 20 70 75 62 70 pubp
19c0: 6f 72 74 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 ort INTEGER,.
19d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
19f0: 74 61 72 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 tart_time TIMEST
1a00: 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 AMP,.
1a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a20: 20 20 20 20 20 20 20 70 72 69 6f 72 69 74 79 20 priority
1a30: 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
1a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a50: 20 20 20 20 20 20 20 20 20 20 20 73 74 61 74 65 state
1a60: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
1a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a80: 20 20 20 20 20 20 20 20 20 6d 74 5f 76 65 72 73 mt_vers
1a90: 69 6f 6e 20 54 45 58 54 2c 0a 20 20 20 20 20 20 ion TEXT,.
1aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ab0: 20 20 20 20 20 20 20 20 20 20 20 20 68 65 61 72 hear
1ac0: 74 62 65 61 74 20 54 49 4d 45 53 54 41 4d 50 2c tbeat TIMESTAMP,
1ad0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1af0: 20 20 20 74 72 61 6e 73 70 6f 72 74 20 54 45 58 transport TEX
1b00: 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 T,.
1b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b20: 20 20 20 20 20 72 75 6e 5f 69 64 20 49 4e 54 45 run_id INTE
1b30: 47 45 52 29 3b 22 29 0a 09 20 3b 3b 20 20 20 20 GER);").. ;;
1b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b50: 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 CONST
1b60: 52 41 49 4e 54 20 73 65 72 76 65 72 73 5f 63 6f RAINT servers_co
1b70: 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 nstraint UNIQUE
1b80: 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 2c 70 6f (pid,hostname,po
1b90: 72 74 29 29 3b 22 29 0a 09 20 28 73 71 6c 69 74 rt));").. (sqlit
1ba0: 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 e3:execute mdb "
1bb0: 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 CREATE TABLE IF
1bc0: 4e 4f 54 20 45 58 49 53 54 53 20 63 6c 69 65 6e NOT EXISTS clien
1bd0: 74 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 ts (id INTEGER P
1be0: 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 RIMARY KEY,.
1bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 65 se
1c10: 72 76 65 72 5f 69 64 20 49 4e 54 45 47 45 52 2c rver_id INTEGER,
1c20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c40: 20 20 20 70 69 64 20 49 4e 54 45 47 45 52 2c 0a pid INTEGER,.
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c70: 20 20 68 6f 73 74 6e 61 6d 65 20 54 45 58 54 2c hostname TEXT,
1c80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ca0: 20 20 20 63 6d 64 6c 69 6e 65 20 54 45 58 54 2c cmdline TEXT,
1cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cd0: 20 20 20 6c 6f 67 69 6e 5f 74 69 6d 65 20 54 49 login_time TI
1ce0: 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 MESTAMP,.
1cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d00: 20 20 20 20 20 20 20 20 20 20 20 6c 6f 67 6f 75 logou
1d10: 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 t_time TIMESTAMP
1d20: 20 44 45 46 41 55 4c 54 20 2d 31 2c 0a 20 20 20 DEFAULT -1,.
1d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e CON
1d50: 53 54 52 41 49 4e 54 20 63 6c 69 65 6e 74 73 5f STRAINT clients_
1d60: 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 constraint UNIQU
1d70: 45 20 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 29 E (pid,hostname)
1d80: 29 3b 22 29 0a 09 20 20 20 20 20 20 20 0a 09 20 );").. ..
1d90: 20 20 20 20 20 20 3b 29 29 0a 09 20 28 73 65 74 ;)).. (set
1da0: 21 20 2a 74 61 73 6b 2d 64 62 2a 20 28 63 6f 6e ! *task-db* (con
1db0: 73 20 6d 64 62 20 64 62 70 61 74 68 29 29 0a 09 s mdb dbpath))..
1dc0: 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 29 0a 0a *task-db*))))..
1dd0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e10: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 65 72 76 ========.;; Serv
1e20: 65 72 20 61 6e 64 20 63 6c 69 65 6e 74 20 6d 61 er and client ma
1e30: 6e 61 67 65 6d 65 6e 74 0a 3b 3b 3d 3d 3d 3d 3d nagement.;;=====
1e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e80: 3d 0a 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 74 6f =..;; make-vecto
1e90: 72 2d 72 65 63 6f 72 64 20 74 61 73 6b 73 20 68 r-record tasks h
1ea0: 6f 73 74 69 6e 66 6f 20 69 64 20 69 6e 74 65 72 ostinfo id inter
1eb0: 66 61 63 65 20 70 6f 72 74 20 70 75 62 70 6f 72 face port pubpor
1ec0: 74 20 74 72 61 6e 73 70 6f 72 74 20 70 69 64 20 t transport pid
1ed0: 68 6f 73 74 6e 61 6d 65 0a 28 64 65 66 69 6e 65 hostname.(define
1ee0: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
1ef0: 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 20 -get-id
1f00: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
1f10: 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 -ref vec 0)).(d
1f20: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 efine (tasks:hos
1f30: 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 tinfo-get-interf
1f40: 61 63 65 20 20 20 76 65 63 29 20 20 20 20 28 76 ace vec) (v
1f50: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
1f60: 29 29 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )).(define (task
1f70: 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 s:hostinfo-get-p
1f80: 6f 72 74 20 20 20 20 20 20 20 20 76 65 63 29 20 ort vec)
1f90: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
1fa0: 76 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 vec 2)).(define
1fb0: 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d (tasks:hostinfo-
1fc0: 67 65 74 2d 70 75 62 70 6f 72 74 20 20 20 20 20 get-pubport
1fd0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
1fe0: 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 ref vec 3)).(de
1ff0: 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 fine (tasks:host
2000: 69 6e 66 6f 2d 67 65 74 2d 74 72 61 6e 73 70 6f info-get-transpo
2010: 72 74 20 20 20 76 65 63 29 20 20 20 20 28 76 65 rt vec) (ve
2020: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 34 29 ctor-ref vec 4)
2030: 29 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ).(define (tasks
2040: 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 69 :hostinfo-get-pi
2050: 64 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 d vec)
2060: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
2070: 65 63 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 5)).(define (
2080: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
2090: 65 74 2d 68 6f 73 74 6e 61 6d 65 20 20 20 20 76 et-hostname v
20a0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
20b0: 65 66 20 20 76 65 63 20 36 29 29 0a 0a 28 64 65 ef vec 6))..(de
20c0: 66 69 6e 65 20 28 74 61 73 6b 73 3a 6e 65 65 64 fine (tasks:need
20d0: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a -server run-id).
20e0: 20 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 (equal? (confi
20f0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
2100: 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 gdat* "server" "
2110: 72 65 71 75 69 72 65 64 22 29 20 22 79 65 73 22 required") "yes"
2120: 29 29 0a 0a 3b 3b 20 6e 6f 20 65 6c 65 67 61 6e ))..;; no elegan
2130: 63 65 20 68 65 72 65 20 2e 2e 2e 0a 3b 3b 0a 28 ce here ....;;.(
2140: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6b 69 define (tasks:ki
2150: 6c 6c 2d 73 65 72 76 65 72 20 68 6f 73 74 6e 61 ll-server hostna
2160: 6d 65 20 70 69 64 20 23 21 6b 65 79 20 28 6b 69 me pid #!key (ki
2170: 6c 6c 2d 73 77 69 74 63 68 20 22 22 29 29 0a 20 ll-switch "")).
2180: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2190: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
21a0: 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 g-port* "Attempt
21b0: 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 73 65 72 76 ing to kill serv
21c0: 65 72 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 er process " pid
21d0: 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 " on host " hos
21e0: 74 6e 61 6d 65 29 0a 20 20 28 73 65 74 65 6e 76 tname). (setenv
21f0: 20 22 54 41 52 47 45 54 48 4f 53 54 22 20 68 6f "TARGETHOST" ho
2200: 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 stname). (let*
2210: 28 28 6c 6f 67 64 69 72 20 28 69 66 20 28 64 69 ((logdir (if (di
2220: 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 rectory-exists?
2230: 22 6c 6f 67 73 22 29 0a 20 20 20 20 20 20 20 20 "logs").
2240: 20 20 20 20 20 20 20 20 20 20 20 20 22 6c 6f 67 "log
2250: 73 2f 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 s/".
2260: 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 20 20 "")).
2270: 20 20 20 20 20 20 28 6c 6f 67 66 69 6c 65 20 28 (logfile (
2280: 69 66 20 6c 6f 67 64 69 72 20 28 63 6f 6e 63 20 if logdir (conc
2290: 22 6c 6f 67 73 2f 73 65 72 76 65 72 2d 22 70 69 "logs/server-"pi
22a0: 64 22 2d 22 68 6f 73 74 6e 61 6d 65 22 2e 6c 6f d"-"hostname".lo
22b0: 67 22 29 20 23 66 29 29 0a 20 20 20 20 20 20 20 g") #f)).
22c0: 20 20 28 67 7a 66 69 6c 65 20 20 28 69 66 20 6c (gzfile (if l
22d0: 6f 67 66 69 6c 65 20 28 63 6f 6e 63 20 6c 6f 67 ogfile (conc log
22e0: 66 69 6c 65 20 22 2e 67 7a 22 29 29 29 29 0a 20 file ".gz")))).
22f0: 20 20 20 28 73 65 74 65 6e 76 20 22 54 41 52 47 (setenv "TARG
2300: 45 54 48 4f 53 54 5f 4c 4f 47 46 22 20 28 63 6f ETHOST_LOGF" (co
2310: 6e 63 20 6c 6f 67 64 69 72 20 22 73 65 72 76 65 nc logdir "serve
2320: 72 2d 6b 69 6c 6c 73 2e 6c 6f 67 22 29 29 0a 0a r-kills.log"))..
2330: 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e (system (con
2340: 63 20 22 6e 62 66 61 6b 65 20 6b 69 6c 6c 20 22 c "nbfake kill "
2350: 6b 69 6c 6c 2d 73 77 69 74 63 68 22 20 22 70 69 kill-switch" "pi
2360: 64 29 29 0a 0a 20 20 20 20 28 77 68 65 6e 20 6c d)).. (when l
2370: 6f 67 66 69 6c 65 0a 20 20 20 20 20 20 28 74 68 ogfile. (th
2380: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 read-sleep! 0.5)
2390: 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d . (if (comm
23a0: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
23b0: 67 7a 66 69 6c 65 29 20 28 64 65 6c 65 74 65 2d gzfile) (delete-
23c0: 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 0a 20 20 file gzfile)).
23d0: 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e (system (con
23e0: 63 20 22 67 7a 69 70 20 22 20 6c 6f 67 66 69 6c c "gzip " logfil
23f0: 65 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 e)). .
2400: 20 28 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 (unsetenv "TARG
2410: 45 54 48 4f 53 54 5f 4c 4f 47 46 22 29 0a 20 20 ETHOST_LOGF").
2420: 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 54 (unsetenv "T
2430: 41 52 47 45 54 48 4f 53 54 22 29 29 29 29 0a 20 ARGETHOST")))).
2440: 20 20 20 0a 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d . .;;========
2450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2490: 3b 20 4d 20 4f 20 4e 20 49 20 54 20 4f 20 52 20 ; M O N I T O R
24a0: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
24b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
24f0: 69 6e 65 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 ine (tasks:remov
2500: 65 2d 6d 6f 6e 69 74 6f 72 2d 72 65 63 6f 72 64 e-monitor-record
2510: 20 6d 64 62 29 0a 20 20 28 73 71 6c 69 74 65 33 mdb). (sqlite3
2520: 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 44 45 :execute mdb "DE
2530: 4c 45 54 45 20 46 52 4f 4d 20 6d 6f 6e 69 74 6f LETE FROM monito
2540: 72 73 20 57 48 45 52 45 20 70 69 64 3d 3f 20 41 rs WHERE pid=? A
2550: 4e 44 20 68 6f 73 74 6e 61 6d 65 3d 3f 3b 22 0a ND hostname=?;".
2560: 09 09 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 .. (current-pr
2570: 6f 63 65 73 73 2d 69 64 29 0a 09 09 20 20 20 28 ocess-id)... (
2580: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 get-host-name)))
2590: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
25a0: 3a 67 65 74 2d 6d 6f 6e 69 74 6f 72 73 20 6d 64 :get-monitors md
25b0: 62 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 b). (let ((res
25c0: 27 28 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 '())). (sqlit
25d0: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
25e0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 (lambda (a
25f0: 2e 20 72 65 6d 29 0a 20 20 20 20 20 20 20 28 73 . rem). (s
2600: 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 61 et! res (cons (a
2610: 70 70 6c 79 20 76 65 63 74 6f 72 20 61 20 72 65 pply vector a re
2620: 6d 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 6d m) res))). m
2630: 64 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 db. "SELECT
2640: 69 64 2c 70 69 64 2c 73 74 72 66 74 69 6d 65 28 id,pid,strftime(
2650: 27 25 6d 2f 25 64 2f 25 59 20 25 48 3a 25 4d 27 '%m/%d/%Y %H:%M'
2660: 2c 64 61 74 65 74 69 6d 65 28 73 74 61 72 74 5f ,datetime(start_
2670: 74 69 6d 65 2c 27 75 6e 69 78 65 70 6f 63 68 27 time,'unixepoch'
2680: 29 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 2c 73 ),'localtime'),s
2690: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
26a0: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 64 61 74 65 Y %H:%M:%S',date
26b0: 74 69 6d 65 28 6c 61 73 74 5f 75 70 64 61 74 65 time(last_update
26c0: 2c 27 75 6e 69 78 65 70 6f 63 68 27 29 2c 27 6c ,'unixepoch'),'l
26d0: 6f 63 61 6c 74 69 6d 65 27 29 2c 68 6f 73 74 6e ocaltime'),hostn
26e0: 61 6d 65 2c 75 73 65 72 6e 61 6d 65 20 46 52 4f ame,username FRO
26f0: 4d 20 6d 6f 6e 69 74 6f 72 73 20 4f 52 44 45 52 M monitors ORDER
2700: 20 42 59 20 6c 61 73 74 5f 75 70 64 61 74 65 20 BY last_update
2710: 41 53 43 3b 22 29 0a 20 20 20 20 28 72 65 76 65 ASC;"). (reve
2720: 72 73 65 20 72 65 73 29 0a 20 20 20 20 29 29 0a rse res). )).
2730: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
2740: 6d 6f 6e 69 74 6f 72 73 2d 3e 74 65 78 74 2d 74 monitors->text-t
2750: 61 62 6c 65 20 6d 6f 6e 69 74 6f 72 73 29 0a 20 able monitors).
2760: 20 28 6c 65 74 20 28 28 66 6d 74 73 74 72 20 22 (let ((fmtstr "
2770: 7e 34 61 7e 38 61 7e 32 30 61 7e 32 30 61 7e 31 ~4a~8a~20a~20a~1
2780: 30 61 7e 31 30 61 22 29 29 0a 20 20 20 20 28 63 0a~10a")). (c
2790: 6f 6e 63 20 28 66 6f 72 6d 61 74 20 23 66 20 66 onc (format #f f
27a0: 6d 74 73 74 72 20 22 69 64 22 20 22 70 69 64 22 mtstr "id" "pid"
27b0: 20 22 73 74 61 72 74 20 74 69 6d 65 22 20 22 6c "start time" "l
27c0: 61 73 74 20 75 70 64 61 74 65 22 20 22 68 6f 73 ast update" "hos
27d0: 74 6e 61 6d 65 22 20 22 75 73 65 72 22 29 20 22 tname" "user") "
27e0: 5c 6e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d 69 \n".. (string-i
27f0: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 ntersperse ..
2800: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6d 6f (map (lambda (mo
2810: 6e 69 74 6f 72 29 0a 09 09 20 20 28 66 6f 72 6d nitor)... (form
2820: 61 74 20 23 66 20 66 6d 74 73 74 72 0a 09 09 09 at #f fmtstr....
2830: 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 (tasks:monitor
2840: 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 20 -get-id
2850: 20 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 20 28 monitor).... (
2860: 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 tasks:monitor-ge
2870: 74 2d 70 69 64 20 20 20 20 20 20 20 20 20 6d 6f t-pid mo
2880: 6e 69 74 6f 72 29 0a 09 09 09 20 20 28 74 61 73 nitor).... (tas
2890: 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 73 ks:monitor-get-s
28a0: 74 61 72 74 5f 74 69 6d 65 20 20 6d 6f 6e 69 74 tart_time monit
28b0: 6f 72 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a or).... (tasks:
28c0: 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 6c 61 73 74 monitor-get-last
28d0: 5f 75 70 64 61 74 65 20 6d 6f 6e 69 74 6f 72 29 _update monitor)
28e0: 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e .... (tasks:mon
28f0: 69 74 6f 72 2d 67 65 74 2d 68 6f 73 74 6e 61 6d itor-get-hostnam
2900: 65 20 20 20 20 6d 6f 6e 69 74 6f 72 29 0a 09 09 e monitor)...
2910: 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f . (tasks:monito
2920: 72 2d 67 65 74 2d 75 73 65 72 6e 61 6d 65 20 20 r-get-username
2930: 20 20 6d 6f 6e 69 74 6f 72 29 29 29 0a 09 09 6d monitor)))...m
2940: 6f 6e 69 74 6f 72 73 29 0a 09 20 20 20 22 5c 6e onitors).. "\n
2950: 22 29 29 29 29 0a 20 20 20 0a 3b 3b 20 75 70 64 ")))). .;; upd
2960: 61 74 65 20 74 68 65 20 6c 61 73 74 5f 75 70 64 ate the last_upd
2970: 61 74 65 20 66 69 65 6c 64 20 77 69 74 68 20 74 ate field with t
2980: 68 65 20 63 75 72 72 65 6e 74 20 74 69 6d 65 20 he current time
2990: 61 6e 64 0a 3b 3b 20 69 66 20 61 6e 79 20 6d 6f and.;; if any mo
29a0: 6e 69 74 6f 72 73 20 61 70 70 65 61 72 20 64 65 nitors appear de
29b0: 61 64 2c 20 72 65 6d 6f 76 65 20 74 68 65 6d 0a ad, remove them.
29c0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6d (define (tasks:m
29d0: 6f 6e 69 74 6f 72 73 2d 75 70 64 61 74 65 20 6d onitors-update m
29e0: 64 62 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 db). (sqlite3:e
29f0: 78 65 63 75 74 65 20 6d 64 62 20 22 55 50 44 41 xecute mdb "UPDA
2a00: 54 45 20 6d 6f 6e 69 74 6f 72 73 20 53 45 54 20 TE monitors SET
2a10: 6c 61 73 74 5f 75 70 64 61 74 65 3d 73 74 72 66 last_update=strf
2a20: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
2a30: 20 57 48 45 52 45 20 70 69 64 3d 3f 20 41 4e 44 WHERE pid=? AND
2a40: 20 68 6f 73 74 6e 61 6d 65 3d 3f 3b 22 0a 09 09 hostname=?;"...
2a50: 09 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 . (current-proc
2a60: 65 73 73 2d 69 64 29 0a 09 09 09 20 20 28 67 65 ess-id).... (ge
2a70: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 20 20 t-host-name)).
2a80: 28 6c 65 74 20 28 28 64 65 61 64 6c 69 73 74 20 (let ((deadlist
2a90: 27 28 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 '())). (sqlit
2aa0: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
2ab0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 64 (lambda (id
2ac0: 20 70 69 64 20 68 6f 73 74 20 6c 61 73 74 2d 75 pid host last-u
2ad0: 70 64 61 74 65 20 64 65 6c 74 61 29 0a 20 20 20 pdate delta).
2ae0: 20 20 20 20 28 70 72 69 6e 74 20 22 47 6f 69 6e (print "Goin
2af0: 67 20 74 6f 20 64 65 6c 65 74 65 20 73 74 61 6c g to delete stal
2b00: 65 20 72 65 63 6f 72 64 20 66 6f 72 20 6d 6f 6e e record for mon
2b10: 69 74 6f 72 20 77 69 74 68 20 70 69 64 20 22 20 itor with pid "
2b20: 70 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 pid " on host "
2b30: 68 6f 73 74 20 22 20 6c 61 73 74 20 75 70 64 61 host " last upda
2b40: 74 65 64 20 22 20 64 65 6c 74 61 20 22 20 73 65 ted " delta " se
2b50: 63 6f 6e 64 73 20 61 67 6f 22 29 0a 20 20 20 20 conds ago").
2b60: 20 20 20 28 73 65 74 21 20 64 65 61 64 6c 69 73 (set! deadlis
2b70: 74 20 28 63 6f 6e 73 20 69 64 20 64 65 61 64 6c t (cons id deadl
2b80: 69 73 74 29 29 29 0a 20 20 20 20 20 6d 64 62 20 ist))). mdb
2b90: 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 69 64 . "SELECT id
2ba0: 2c 70 69 64 2c 68 6f 73 74 6e 61 6d 65 2c 6c 61 ,pid,hostname,la
2bb0: 73 74 5f 75 70 64 61 74 65 2c 73 74 72 66 74 69 st_update,strfti
2bc0: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 2d 6c me('%s','now')-l
2bd0: 61 73 74 5f 75 70 64 61 74 65 20 41 53 20 64 65 ast_update AS de
2be0: 6c 74 61 20 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 lta FROM monitor
2bf0: 73 20 57 48 45 52 45 20 64 65 6c 74 61 20 3e 20 s WHERE delta >
2c00: 37 30 30 3b 22 29 0a 20 20 20 20 28 73 71 6c 69 700;"). (sqli
2c10: 74 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 20 te3:execute mdb
2c20: 28 63 6f 6e 63 20 22 44 45 4c 45 54 45 20 46 52 (conc "DELETE FR
2c30: 4f 4d 20 6d 6f 6e 69 74 6f 72 73 20 57 48 45 52 OM monitors WHER
2c40: 45 20 69 64 20 49 4e 20 28 27 22 20 28 73 74 72 E id IN ('" (str
2c50: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
2c60: 28 6d 61 70 20 63 6f 6e 63 20 64 65 61 64 6c 69 (map conc deadli
2c70: 73 74 29 20 22 27 2c 27 22 29 20 22 27 29 3b 22 st) "','") "');"
2c80: 29 29 29 0a 20 20 29 0a 28 64 65 66 69 6e 65 20 ))). ).(define
2c90: 28 74 61 73 6b 73 3a 72 65 67 69 73 74 65 72 2d (tasks:register-
2ca0: 6d 6f 6e 69 74 6f 72 20 64 62 20 70 6f 72 74 29 monitor db port)
2cb0: 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 64 20 28 . (let* ((pid (
2cc0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
2cd0: 69 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 id)).. (hostname
2ce0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
2cf0: 29 0a 09 20 28 75 73 65 72 69 6e 66 6f 20 28 75 ).. (userinfo (u
2d00: 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 ser-information
2d10: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
2d20: 29 29 29 0a 09 20 28 75 73 65 72 6e 61 6d 65 20 ))).. (username
2d30: 28 63 61 72 20 75 73 65 72 69 6e 66 6f 29 29 29 (car userinfo)))
2d40: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 . (print "Reg
2d50: 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 ister monitor, p
2d60: 69 64 3a 20 22 20 70 69 64 20 22 2c 20 68 6f 73 id: " pid ", hos
2d70: 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d tname: " hostnam
2d80: 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 e ", port: " por
2d90: 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 t ", username: "
2da0: 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 28 username). (
2db0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
2dc0: 64 62 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 db "INSERT INTO
2dd0: 6d 6f 6e 69 74 6f 72 73 20 28 70 69 64 2c 73 74 monitors (pid,st
2de0: 61 72 74 5f 74 69 6d 65 2c 6c 61 73 74 5f 75 70 art_time,last_up
2df0: 64 61 74 65 2c 68 6f 73 74 6e 61 6d 65 2c 75 73 date,hostname,us
2e00: 65 72 6e 61 6d 65 29 20 56 41 4c 55 45 53 20 28 ername) VALUES (
2e10: 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c ?,strftime('%s',
2e20: 27 6e 6f 77 27 29 2c 73 74 72 66 74 69 6d 65 28 'now'),strftime(
2e30: 27 25 73 27 2c 27 6e 6f 77 27 29 2c 3f 2c 3f 29 '%s','now'),?,?)
2e40: 3b 22 0a 09 09 20 20 20 20 20 70 69 64 20 68 6f ;"... pid ho
2e50: 73 74 6e 61 6d 65 20 75 73 65 72 6e 61 6d 65 29 stname username)
2e60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ))..(define (tas
2e70: 6b 73 3a 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 ks:get-num-alive
2e80: 2d 6d 6f 6e 69 74 6f 72 73 20 6d 64 62 29 0a 20 -monitors mdb).
2e90: 20 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a (let ((res 0)).
2ea0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
2eb0: 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 -each-row .
2ec0: 28 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a (lambda (count).
2ed0: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
2ee0: 20 63 6f 75 6e 74 29 29 0a 20 20 20 20 20 6d 64 count)). md
2ef0: 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 63 b. "SELECT c
2f00: 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 6d 6f ount(id) FROM mo
2f10: 6e 69 74 6f 72 73 20 57 48 45 52 45 20 6c 61 73 nitors WHERE las
2f20: 74 5f 75 70 64 61 74 65 20 3c 20 28 73 74 72 66 t_update < (strf
2f30: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
2f40: 20 2d 20 33 30 30 29 20 41 4e 44 20 75 73 65 72 - 300) AND user
2f50: 6e 61 6d 65 3d 3f 3b 22 0a 20 20 20 20 20 28 63 name=?;". (c
2f60: 61 72 20 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 ar (user-informa
2f70: 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 tion (current-us
2f80: 65 72 2d 69 64 29 29 29 29 0a 20 20 20 20 72 65 er-id)))). re
2f90: 73 29 29 0a 0a 3b 3b 20 0a 23 3b 28 64 65 66 69 s))..;; .#;(defi
2fa0: 6e 65 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d ne (tasks:start-
2fb0: 6d 6f 6e 69 74 6f 72 20 64 62 20 6d 64 62 29 0a monitor db mdb).
2fc0: 20 20 28 69 66 20 28 3e 20 28 74 61 73 6b 73 3a (if (> (tasks:
2fd0: 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 2d 6d 6f get-num-alive-mo
2fe0: 6e 69 74 6f 72 73 20 6d 64 62 29 20 32 29 20 3b nitors mdb) 2) ;
2ff0: 3b 20 68 61 76 65 20 74 77 6f 20 72 75 6e 6e 69 ; have two runni
3000: 6e 67 2c 20 6e 6f 20 6e 65 65 64 20 66 6f 72 20 ng, no need for
3010: 6d 6f 72 65 0a 20 20 20 20 20 20 28 64 65 62 75 more. (debu
3020: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
3030: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3040: 2a 20 22 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 * "Not starting
3050: 6d 6f 6e 69 74 6f 72 2c 20 61 6c 72 65 61 64 79 monitor, already
3060: 20 68 61 76 65 20 6d 6f 72 65 20 74 68 61 6e 20 have more than
3070: 74 77 6f 20 72 75 6e 6e 69 6e 67 22 29 0a 20 20 two running").
3080: 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 65 67 61 (let* ((mega
3090: 74 65 73 74 64 62 20 20 20 20 20 28 63 6f 6e 63 testdb (conc
30a0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 *toppath* "/meg
30b0: 61 74 65 73 74 2e 64 62 22 29 29 0a 09 20 20 20 atest.db"))..
30c0: 20 20 28 6d 6f 6e 69 74 6f 72 64 62 66 20 20 20 (monitordbf
30d0: 20 20 28 63 6f 6e 63 20 28 64 62 3a 64 62 66 69 (conc (db:dbfi
30e0: 6c 65 2d 70 61 74 68 20 23 66 29 20 22 2f 6d 6f le-path #f) "/mo
30f0: 6e 69 74 6f 72 2e 64 62 22 29 29 0a 09 20 20 20 nitor.db"))..
3100: 20 20 28 6c 61 73 74 2d 64 62 2d 75 70 64 61 74 (last-db-updat
3110: 65 20 30 29 29 20 3b 3b 20 28 66 69 6c 65 2d 6d e 0)) ;; (file-m
3120: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
3130: 20 6d 65 67 61 74 65 73 74 64 62 29 29 29 0a 09 megatestdb)))..
3140: 28 74 61 73 6b 3a 72 65 67 69 73 74 65 72 2d 6d (task:register-m
3150: 6f 6e 69 74 6f 72 20 6d 64 62 29 0a 09 28 6c 65 onitor mdb)..(le
3160: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 t loop ((count
3170: 20 20 20 20 30 29 0a 09 09 20 20 20 28 6e 65 78 0)... (nex
3180: 74 2d 74 6f 75 63 68 20 30 29 29 20 3b 3b 20 6e t-touch 0)) ;; n
3190: 65 78 74 2d 74 6f 75 63 68 20 69 73 20 74 68 65 ext-touch is the
31a0: 20 74 69 6d 65 20 77 68 65 72 65 20 77 65 20 6e time where we n
31b0: 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 6c 61 eed to update la
31c0: 73 74 5f 75 70 64 61 74 65 0a 09 20 20 3b 3b 20 st_update.. ;;
31d0: 69 66 20 74 68 65 20 64 62 20 68 61 73 20 62 65 if the db has be
31e0: 65 6e 20 6d 6f 64 69 66 69 65 64 20 77 65 27 64 en modified we'd
31f0: 20 62 65 73 74 20 6c 6f 6f 6b 20 61 74 20 74 68 best look at th
3200: 65 20 74 61 73 6b 20 71 75 65 75 65 0a 09 20 20 e task queue..
3210: 28 6c 65 74 20 28 28 6d 6f 64 74 69 6d 65 20 28 (let ((modtime (
3220: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
3230: 6e 2d 74 69 6d 65 20 6d 65 67 61 74 65 73 74 64 n-time megatestd
3240: 62 70 61 74 68 20 29 29 29 0a 09 20 20 20 20 28 bpath ))).. (
3250: 69 66 20 28 3e 20 6d 6f 64 74 69 6d 65 20 6c 61 if (> modtime la
3260: 73 74 2d 64 62 2d 75 70 64 61 74 65 29 0a 09 09 st-db-update)...
3270: 28 74 61 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 (tasks:process-q
3280: 75 65 75 65 20 64 62 29 29 20 3b 3b 20 42 52 4f ueue db)) ;; BRO
3290: 4b 45 4e 2e 20 6d 64 62 20 6c 61 73 74 2d 64 62 KEN. mdb last-db
32a0: 2d 75 70 64 61 74 65 20 6d 65 67 61 74 65 73 74 -update megatest
32b0: 64 62 20 6e 65 78 74 2d 74 6f 75 63 68 29 29 0a db next-touch)).
32c0: 09 20 20 20 20 3b 3b 20 57 41 52 4e 49 4e 47 3a . ;; WARNING:
32d0: 20 50 6f 73 73 69 62 6c 65 20 72 61 63 65 20 63 Possible race c
32e0: 6f 6e 64 69 74 6f 6e 20 68 65 72 65 21 21 0a 09 onditon here!!..
32f0: 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 ;; should th
3300: 69 73 20 75 70 64 61 74 65 20 62 65 20 69 6d 6d is update be imm
3310: 65 64 69 61 74 65 6c 79 20 61 66 74 65 72 20 74 ediately after t
3320: 68 65 20 74 61 73 6b 2d 67 65 74 2d 61 63 74 69 he task-get-acti
3330: 6f 6e 20 63 61 6c 6c 20 61 62 6f 76 65 3f 0a 09 on call above?..
3340: 20 20 20 20 28 69 66 20 28 3e 20 28 63 75 72 72 (if (> (curr
3350: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6e 65 78 ent-seconds) nex
3360: 74 2d 74 6f 75 63 68 29 0a 09 09 28 62 65 67 69 t-touch)...(begi
3370: 6e 0a 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e n... (tasks:mon
3380: 69 74 6f 72 73 2d 75 70 64 61 74 65 20 6d 64 62 itors-update mdb
3390: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 )... (loop (+ c
33a0: 6f 75 6e 74 20 31 29 28 2b 20 28 63 75 72 72 65 ount 1)(+ (curre
33b0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 32 34 30 29 nt-seconds) 240)
33c0: 29 29 0a 09 09 28 6c 6f 6f 70 20 28 2b 20 63 6f ))...(loop (+ co
33d0: 75 6e 74 20 31 29 20 6e 65 78 74 2d 74 6f 75 63 unt 1) next-touc
33e0: 68 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a h))))))). .
33f0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
3400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3430: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 ========.;; T A
3440: 53 20 4b 20 53 20 20 20 51 20 55 20 45 20 55 20 S K S Q U E U
3450: 45 0a 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a 3a E.;;.;; NOTE::
3460: 20 54 68 65 73 65 20 6f 70 65 72 61 74 65 20 6f These operate o
3470: 6e 20 74 61 73 6b 5f 71 75 65 75 65 20 77 68 69 n task_queue whi
3480: 63 68 20 69 73 20 69 6e 20 6d 61 69 6e 2e 64 62 ch is in main.db
3490: 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;.;;==========
34a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
34e0: 20 4e 4f 54 45 3a 20 49 74 20 6d 69 67 68 74 20 NOTE: It might
34f0: 62 65 20 67 6f 6f 64 20 74 6f 20 61 64 64 20 6f be good to add o
3500: 6e 65 20 6d 6f 72 65 20 6c 61 79 65 72 20 6f 66 ne more layer of
3510: 20 63 68 65 63 6b 69 6e 67 20 74 6f 20 65 6e 73 checking to ens
3520: 75 72 65 0a 3b 3b 20 20 20 20 20 20 20 74 68 61 ure.;; tha
3530: 74 20 6e 6f 20 74 61 73 6b 20 67 65 74 73 20 72 t no task gets r
3540: 75 6e 20 69 6e 20 70 61 72 61 6c 6c 65 6c 2e 0a un in parallel..
3550: 0a 3b 3b 20 69 64 20 49 4e 54 45 47 45 52 20 50 .;; id INTEGER P
3560: 52 49 4d 41 52 59 20 4b 45 59 2c 0a 3b 3b 20 61 RIMARY KEY,.;; a
3570: 63 74 69 6f 6e 20 54 45 58 54 20 44 45 46 41 55 ction TEXT DEFAU
3580: 4c 54 20 27 27 2c 0a 3b 3b 20 6f 77 6e 65 72 20 LT '',.;; owner
3590: 54 45 58 54 2c 0a 3b 3b 20 73 74 61 74 65 20 54 TEXT,.;; state T
35a0: 45 58 54 20 44 45 46 41 55 4c 54 20 27 6e 65 77 EXT DEFAULT 'new
35b0: 27 2c 0a 3b 3b 20 74 61 72 67 65 74 20 54 45 58 ',.;; target TEX
35c0: 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a 3b 3b T DEFAULT '',.;;
35d0: 20 6e 61 6d 65 20 54 45 58 54 20 44 45 46 41 55 name TEXT DEFAU
35e0: 4c 54 20 27 27 2c 0a 3b 3b 20 74 65 73 74 70 61 LT '',.;; testpa
35f0: 74 74 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 tt TEXT DEFAULT
3600: 27 27 2c 0a 3b 3b 20 6b 65 79 6c 6f 63 6b 20 54 '',.;; keylock T
3610: 45 58 54 2c 0a 3b 3b 20 70 61 72 61 6d 73 20 54 EXT,.;; params T
3620: 45 58 54 2c 0a 3b 3b 20 63 72 65 61 74 69 6f 6e EXT,.;; creation
3630: 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 _time TIMESTAMP
3640: 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d DEFAULT (strftim
3650: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a e('%s','now')),.
3660: 3b 3b 20 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d ;; execution_tim
3670: 65 20 54 49 4d 45 53 54 41 4d 50 29 3b 0a 0a 0a e TIMESTAMP);...
3680: 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 61 ;; register a ta
3690: 73 6b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b sk.(define (task
36a0: 73 3a 61 64 64 20 64 62 73 74 72 75 63 74 20 61 s:add dbstruct a
36b0: 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 ction owner targ
36c0: 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 et runname testp
36d0: 61 74 74 20 70 61 72 61 6d 73 29 0a 20 20 28 64 att params). (d
36e0: 62 3a 77 69 74 68 2d 64 62 20 0a 20 20 20 64 62 b:with-db . db
36f0: 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 struct #f #t.
3700: 28 6c 61 6d 62 64 61 20 28 64 62 64 61 74 20 64 (lambda (dbdat d
3710: 62 29 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 b). (sqlite3
3720: 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 :execute db "INS
3730: 45 52 54 20 49 4e 54 4f 20 74 61 73 6b 73 5f 71 ERT INTO tasks_q
3740: 75 65 75 65 20 28 61 63 74 69 6f 6e 2c 6f 77 6e ueue (action,own
3750: 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c er,state,target,
3760: 6e 61 6d 65 2c 74 65 73 74 70 61 74 74 2c 70 61 name,testpatt,pa
3770: 72 61 6d 73 2c 63 72 65 61 74 69 6f 6e 5f 74 69 rams,creation_ti
3780: 6d 65 2c 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d me,execution_tim
3790: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
37a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37b0: 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 27 6e 65 77 VALUES (?,?,'new
37c0: 27 2c 3f 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 ',?,?,?,?,strfti
37d0: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 2c 30 me('%s','now'),0
37e0: 29 3b 22 20 0a 09 09 20 20 20 20 20 20 61 63 74 );" ... act
37f0: 69 6f 6e 0a 09 09 20 20 20 20 20 20 6f 77 6e 65 ion... owne
3800: 72 0a 09 09 20 20 20 20 20 20 74 61 72 67 65 74 r... target
3810: 0a 09 09 20 20 20 20 20 20 72 75 6e 6e 61 6d 65 ... runname
3820: 0a 09 09 20 20 20 20 20 20 74 65 73 74 70 61 74 ... testpat
3830: 74 0a 09 09 20 20 20 20 20 20 28 69 66 20 70 61 t... (if pa
3840: 72 61 6d 73 20 70 61 72 61 6d 73 20 22 22 29 29 rams params ""))
3850: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6b 65 )))..(define (ke
3860: 79 73 3a 6b 65 79 2d 76 61 6c 73 2d 68 61 73 68 ys:key-vals-hash
3870: 2d 3e 74 61 72 67 65 74 20 6b 65 79 73 20 6b 65 ->target keys ke
3880: 79 2d 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 y-params). (let
3890: 20 28 28 74 6d 70 20 28 68 61 73 68 2d 74 61 62 ((tmp (hash-tab
38a0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6b le-ref/default k
38b0: 65 79 2d 70 61 72 61 6d 73 20 28 76 65 63 74 6f ey-params (vecto
38c0: 72 2d 72 65 66 20 28 63 61 72 20 6b 65 79 73 29 r-ref (car keys)
38d0: 20 30 29 20 22 22 29 29 29 0a 20 20 20 20 28 69 0) ""))). (i
38e0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b 65 79 f (> (length key
38f0: 73 29 20 31 29 0a 09 28 66 6f 72 2d 65 61 63 68 s) 1)..(for-each
3900: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 (lambda (key)..
3910: 09 20 20 20 20 28 73 65 74 21 20 74 6d 70 20 28 . (set! tmp (
3920: 63 6f 6e 63 20 74 6d 70 20 22 2f 22 20 28 68 61 conc tmp "/" (ha
3930: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3940: 61 75 6c 74 20 6b 65 79 2d 70 61 72 61 6d 73 20 ault key-params
3950: 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 65 79 20 (vector-ref key
3960: 30 29 20 22 22 29 29 29 29 0a 09 09 20 20 28 63 0) ""))))... (c
3970: 64 72 20 6b 65 79 73 29 29 29 0a 20 20 20 20 74 dr keys))). t
3980: 6d 70 29 29 0a 09 09 09 09 09 09 09 09 0a 3b 3b mp))..........;;
3990: 20 66 6f 72 20 75 73 65 20 66 72 6f 6d 20 74 68 for use from th
39a0: 65 20 67 75 69 2c 20 6e 6f 74 20 70 6f 72 74 65 e gui, not porte
39b0: 64 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 d.;;.;; (define
39c0: 28 74 61 73 6b 73 3a 61 64 64 2d 66 72 6f 6d 2d (tasks:add-from-
39d0: 70 61 72 61 6d 73 20 6d 64 62 20 61 63 74 69 6f params mdb actio
39e0: 6e 20 6b 65 79 73 20 6b 65 79 2d 70 61 72 61 6d n keys key-param
39f0: 73 20 76 61 72 2d 70 61 72 61 6d 73 29 0a 3b 3b s var-params).;;
3a00: 20 20 20 28 6c 65 74 20 28 28 74 61 72 67 65 74 (let ((target
3a10: 20 20 20 20 28 6b 65 79 73 3a 6b 65 79 2d 76 61 (keys:key-va
3a20: 6c 73 2d 68 61 73 68 2d 3e 74 61 72 67 65 74 20 ls-hash->target
3a30: 6b 65 79 73 20 6b 65 79 2d 70 61 72 61 6d 73 29 keys key-params)
3a40: 29 0a 3b 3b 20 09 28 6f 77 6e 65 72 20 20 20 20 ).;; .(owner
3a50: 20 28 63 61 72 20 28 75 73 65 72 2d 69 6e 66 6f (car (user-info
3a60: 72 6d 61 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 rmation (current
3a70: 2d 75 73 65 72 2d 69 64 29 29 29 29 0a 3b 3b 20 -user-id)))).;;
3a80: 09 28 72 75 6e 6e 61 6d 65 20 20 20 28 68 61 73 .(runname (has
3a90: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3aa0: 75 6c 74 20 76 61 72 2d 70 61 72 61 6d 73 20 22 ult var-params "
3ab0: 72 75 6e 6e 61 6d 65 22 20 23 66 29 29 0a 3b 3b runname" #f)).;;
3ac0: 20 09 28 74 65 73 74 70 61 74 74 73 20 28 68 61 .(testpatts (ha
3ad0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3ae0: 61 75 6c 74 20 76 61 72 2d 70 61 72 61 6d 73 20 ault var-params
3af0: 22 74 65 73 74 70 61 74 74 73 22 20 22 25 22 29 "testpatts" "%")
3b00: 29 0a 3b 3b 20 09 28 70 61 72 61 6d 73 20 20 20 ).;; .(params
3b10: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3b20: 2f 64 65 66 61 75 6c 74 20 76 61 72 2d 70 61 72 /default var-par
3b30: 61 6d 73 20 22 70 61 72 61 6d 73 22 20 20 20 20 ams "params"
3b40: 22 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 74 61 ""))).;; (ta
3b50: 73 6b 73 3a 61 64 64 20 6d 64 62 20 61 63 74 69 sks:add mdb acti
3b60: 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 on owner target
3b70: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
3b80: 73 20 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 s params)))..;;
3b90: 72 65 74 75 72 6e 20 6f 6e 65 20 74 61 73 6b 20 return one task
3ba0: 66 72 6f 6d 20 74 68 6f 73 65 20 77 68 6f 20 61 from those who a
3bb0: 72 65 20 27 6e 65 77 27 20 4f 52 20 27 77 61 69 re 'new' OR 'wai
3bc0: 74 69 6e 67 27 20 41 4e 44 20 6d 6f 72 65 20 74 ting' AND more t
3bd0: 68 61 6e 20 31 30 73 65 63 20 6f 6c 64 0a 3b 3b han 10sec old.;;
3be0: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
3bf0: 73 6e 61 67 2d 61 2d 74 61 73 6b 20 64 62 73 74 snag-a-task dbst
3c00: 72 75 63 74 29 0a 20 20 28 6c 65 74 20 28 28 72 ruct). (let ((r
3c10: 65 73 20 20 20 20 23 66 29 0a 09 28 6b 65 79 74 es #f)..(keyt
3c20: 78 74 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e xt (conc (curren
3c30: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2d t-process-id) "-
3c40: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
3c50: 29 20 22 2d 22 20 28 63 61 72 20 28 75 73 65 72 ) "-" (car (user
3c60: 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 -information (cu
3c70: 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 29 29 rrent-user-id)))
3c80: 29 29 29 0a 20 20 20 20 28 64 62 3a 77 69 74 68 ))). (db:with
3c90: 2d 64 62 0a 20 20 20 20 20 64 62 73 74 72 75 63 -db. dbstruc
3ca0: 74 20 23 66 20 23 74 0a 20 20 20 20 20 28 6c 61 t #f #t. (la
3cb0: 6d 62 64 61 20 28 64 61 74 20 64 62 29 0a 20 20 mbda (dat db).
3cc0: 20 20 20 20 20 3b 3b 20 66 69 72 73 74 20 72 61 ;; first ra
3cd0: 6e 64 6f 6d 6c 79 20 73 65 74 20 61 20 6e 65 77 ndomly set a new
3ce0: 20 74 6f 20 70 69 64 2d 68 6f 73 74 6e 61 6d 65 to pid-hostname
3cf0: 2d 68 6f 73 74 6e 61 6d 65 0a 20 20 20 20 20 20 -hostname.
3d00: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
3d10: 65 0a 09 64 62 20 0a 09 22 55 50 44 41 54 45 20 e..db .."UPDATE
3d20: 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 tasks_queue SET
3d30: 6b 65 79 6c 6f 63 6b 3d 3f 20 57 48 45 52 45 20 keylock=? WHERE
3d40: 69 64 20 49 4e 0a 20 20 20 20 20 20 20 20 20 20 id IN.
3d50: 20 28 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d (SELECT id FROM
3d60: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 0a 20 20 tasks_queue .
3d70: 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 WHER
3d80: 45 20 73 74 61 74 65 3d 27 6e 65 77 27 20 4f 52 E state='new' OR
3d90: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3da0: 20 20 20 20 20 20 28 73 74 61 74 65 3d 27 77 61 (state='wa
3db0: 69 74 69 6e 67 27 20 41 4e 44 20 28 73 74 72 66 iting' AND (strf
3dc0: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
3dd0: 2d 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 29 -execution_time)
3de0: 20 3e 20 31 30 29 20 4f 52 0a 20 20 20 20 20 20 > 10) OR.
3df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 st
3e00: 61 74 65 3d 27 72 65 73 65 74 27 0a 20 20 20 20 ate='reset'.
3e10: 20 20 20 20 20 20 20 20 20 20 4f 52 44 45 52 20 ORDER
3e20: 42 59 20 52 41 4e 44 4f 4d 28 29 20 4c 49 4d 49 BY RANDOM() LIMI
3e30: 54 20 31 29 3b 22 20 6b 65 79 74 78 74 29 0a 0a T 1);" keytxt)..
3e40: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
3e50: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 6c for-each-row..(l
3e60: 61 6d 62 64 61 20 28 69 64 20 2e 20 72 65 6d 29 ambda (id . rem)
3e70: 0a 09 20 20 28 73 65 74 21 20 72 65 73 20 28 61 .. (set! res (a
3e80: 70 70 6c 79 20 76 65 63 74 6f 72 20 69 64 20 72 pply vector id r
3e90: 65 6d 29 29 29 0a 09 64 62 0a 09 22 53 45 4c 45 em)))..db.."SELE
3ea0: 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e CT id,action,own
3eb0: 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c er,state,target,
3ec0: 6e 61 6d 65 2c 74 65 73 74 2c 69 74 65 6d 2c 70 name,test,item,p
3ed0: 61 72 61 6d 73 2c 63 72 65 61 74 69 6f 6e 5f 74 arams,creation_t
3ee0: 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e 5f 74 69 ime,execution_ti
3ef0: 6d 65 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 75 me FROM tasks_qu
3f00: 65 75 65 20 57 48 45 52 45 20 6b 65 79 6c 6f 63 eue WHERE keyloc
3f10: 6b 3d 3f 20 4f 52 44 45 52 20 42 59 20 65 78 65 k=? ORDER BY exe
3f20: 63 75 74 69 6f 6e 5f 74 69 6d 65 20 41 53 43 20 cution_time ASC
3f30: 4c 49 4d 49 54 20 31 3b 22 20 6b 65 79 74 78 74 LIMIT 1;" keytxt
3f40: 29 0a 20 20 20 20 20 20 20 28 69 66 20 72 65 73 ). (if res
3f50: 20 3b 3b 20 79 65 70 2c 20 68 61 76 65 20 77 6f ;; yep, have wo
3f60: 72 6b 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 rk to be done..
3f70: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 (begin.. (
3f80: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
3f90: 64 62 20 22 55 50 44 41 54 45 20 74 61 73 6b 73 db "UPDATE tasks
3fa0: 5f 71 75 65 75 65 20 53 45 54 20 73 74 61 74 65 _queue SET state
3fb0: 3d 27 69 6e 70 72 6f 67 72 65 73 73 27 2c 65 78 ='inprogress',ex
3fc0: 65 63 75 74 69 6f 6e 5f 74 69 6d 65 3d 73 74 72 ecution_time=str
3fd0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
3fe0: 29 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a 09 ) WHERE id=?;"..
3ff0: 09 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a 74 .. (tasks:t
4000: 61 73 6b 2d 67 65 74 2d 69 64 20 72 65 73 29 29 ask-get-id res))
4010: 0a 09 20 20 20 20 20 72 65 73 29 0a 09 20 20 20 .. res)..
4020: 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 #f)))))..(define
4030: 20 28 74 61 73 6b 73 3a 72 65 73 65 74 2d 73 74 (tasks:reset-st
4040: 75 63 6b 2d 74 61 73 6b 73 20 64 62 73 74 72 75 uck-tasks dbstru
4050: 63 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 ct). (let ((res
4060: 20 27 28 29 29 29 0a 20 20 20 20 28 64 62 3a 77 '())). (db:w
4070: 69 74 68 2d 64 62 0a 20 20 20 20 20 64 62 73 74 ith-db. dbst
4080: 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 20 20 ruct #f #t.
4090: 28 6c 61 6d 62 64 61 20 28 64 61 74 20 64 62 29 (lambda (dat db)
40a0: 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 . (sqlite3
40b0: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 :for-each-row..(
40c0: 6c 61 6d 62 64 61 20 28 69 64 20 64 65 6c 74 61 lambda (id delta
40d0: 29 0a 09 20 20 28 73 65 74 21 20 72 65 73 20 28 ).. (set! res (
40e0: 63 6f 6e 73 20 69 64 20 72 65 73 29 29 29 0a 09 cons id res)))..
40f0: 64 62 0a 09 22 53 45 4c 45 43 54 20 69 64 2c 73 db.."SELECT id,s
4100: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
4110: 77 27 29 2d 65 78 65 63 75 74 69 6f 6e 5f 74 69 w')-execution_ti
4120: 6d 65 20 41 53 20 64 65 6c 74 61 20 46 52 4f 4d me AS delta FROM
4130: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 57 48 45 tasks_queue WHE
4140: 52 45 20 73 74 61 74 65 3d 27 69 6e 70 72 6f 67 RE state='inprog
4150: 72 65 73 73 27 20 41 4e 44 20 64 65 6c 74 61 3e ress' AND delta>
4160: 37 30 30 20 4f 52 44 45 52 20 42 59 20 64 65 6c 700 ORDER BY del
4170: 74 61 20 44 45 53 43 20 4c 49 4d 49 54 20 32 3b ta DESC LIMIT 2;
4180: 22 29 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 "). (sqlit
4190: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 64 62 20 e3:execute ..db
41a0: 0a 09 28 63 6f 6e 63 20 22 55 50 44 41 54 45 20 ..(conc "UPDATE
41b0: 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 tasks_queue SET
41c0: 73 74 61 74 65 3d 27 72 65 73 65 74 27 20 57 48 state='reset' WH
41d0: 45 52 45 20 69 64 20 49 4e 20 28 27 22 20 28 73 ERE id IN ('" (s
41e0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
41f0: 65 20 28 6d 61 70 20 63 6f 6e 63 20 72 65 73 29 e (map conc res)
4200: 20 22 27 2c 27 22 29 20 22 27 29 3b 22 29 0a 09 "','") "');")..
4210: 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e )))))..;; return
4220: 20 61 6c 6c 20 74 61 73 6b 73 20 69 6e 20 74 68 all tasks in th
4230: 65 20 74 61 73 6b 73 5f 71 75 65 75 65 20 74 61 e tasks_queue ta
4240: 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ble.;;.(define (
4250: 74 61 73 6b 73 3a 67 65 74 2d 74 61 73 6b 73 20 tasks:get-tasks
4260: 64 62 73 74 72 75 63 74 20 74 79 70 65 73 20 73 dbstruct types s
4270: 74 61 74 65 73 29 0a 20 20 28 6c 65 74 20 28 28 tates). (let ((
4280: 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 64 res '())). (d
4290: 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 20 64 b:with-db. d
42a0: 62 73 74 72 75 63 74 20 23 66 20 23 66 0a 20 20 bstruct #f #f.
42b0: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 (lambda (dbda
42c0: 74 20 64 62 29 0a 20 20 20 20 20 20 20 28 73 71 t db). (sq
42d0: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
42e0: 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 64 20 ow..(lambda (id
42f0: 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 74 21 20 . rem).. (set!
4300: 72 65 73 20 28 63 6f 6e 73 20 28 61 70 70 6c 79 res (cons (apply
4310: 20 76 65 63 74 6f 72 20 69 64 20 72 65 6d 29 20 vector id rem)
4320: 72 65 73 29 29 29 0a 09 64 62 0a 09 28 63 6f 6e res)))..db..(con
4330: 63 20 22 53 45 4c 45 43 54 20 69 64 2c 61 63 74 c "SELECT id,act
4340: 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c ion,owner,state,
4350: 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 target,name,test
4360: 2c 69 74 65 6d 2c 70 61 72 61 6d 73 2c 63 72 65 ,item,params,cre
4370: 61 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 ation_time,execu
4380: 74 69 6f 6e 5f 74 69 6d 65 20 0a 20 20 20 20 20 tion_time .
4390: 20 20 20 20 20 20 20 20 20 20 20 20 20 46 52 4f FRO
43a0: 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 22 0a M tasks_queue ".
43b0: 09 20 20 20 20 20 20 3b 3b 20 57 48 45 52 45 20 . ;; WHERE
43c0: 20 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 73 74 .. ;; st
43d0: 61 74 65 20 49 4e 20 22 20 73 74 61 74 65 73 73 ate IN " statess
43e0: 74 72 20 22 20 41 4e 44 20 0a 09 20 20 20 20 20 tr " AND ..
43f0: 20 3b 3b 20 20 20 61 63 74 69 6f 6e 20 49 4e 20 ;; action IN
4400: 22 20 61 63 74 69 6f 6e 73 73 74 72 20 0a 09 20 " actionsstr ..
4410: 20 20 20 20 20 22 20 4f 52 44 45 52 20 42 59 20 " ORDER BY
4420: 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 20 44 45 creation_time DE
4430: 53 43 3b 22 29 29 0a 20 20 20 20 20 20 20 72 65 SC;")). re
4440: 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s))))..(define (
4450: 74 61 73 6b 73 3a 67 65 74 2d 6c 61 73 74 20 64 tasks:get-last d
4460: 62 73 74 72 75 63 74 20 74 61 72 67 65 74 20 72 bstruct target r
4470: 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 unname). (let (
4480: 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 64 (res #f)). (d
4490: 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 20 64 b:with-db. d
44a0: 62 73 74 72 75 63 74 20 23 66 20 23 66 0a 20 20 bstruct #f #f.
44b0: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 (lambda (dbda
44c0: 74 20 64 62 29 0a 20 20 20 20 20 20 20 28 73 71 t db). (sq
44d0: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
44e0: 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 64 20 ow..(lambda (id
44f0: 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 74 21 20 . rem).. (set!
4500: 72 65 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f res (apply vecto
4510: 72 20 69 64 20 72 65 6d 29 29 29 0a 09 64 62 0a r id rem)))..db.
4520: 09 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 .(conc "SELECT i
4530: 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 d,action,owner,s
4540: 74 61 74 65 2c 74 61 72 67 65 74 2c 6e 61 6d 65 tate,target,name
4550: 2c 74 65 73 74 70 61 74 74 2c 6b 65 79 6c 6f 63 ,testpatt,keyloc
4560: 6b 2c 70 61 72 61 6d 73 2c 63 72 65 61 74 69 6f k,params,creatio
4570: 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e n_time,execution
4580: 5f 74 69 6d 65 20 0a 20 20 20 20 20 20 20 20 20 _time .
4590: 20 20 20 20 20 20 20 20 20 46 52 4f 4d 20 74 61 FROM ta
45a0: 73 6b 73 5f 71 75 65 75 65 20 0a 20 09 20 20 20 sks_queue . .
45b0: 20 20 20 20 57 48 45 52 45 20 20 0a 09 20 20 20 WHERE ..
45c0: 20 20 20 20 20 74 61 72 67 65 74 20 3d 20 3f 20 target = ?
45d0: 41 4e 44 20 6e 61 6d 65 20 3d 3f 0a 09 20 20 20 AND name =?..
45e0: 20 20 20 20 4f 52 44 45 52 20 42 59 20 63 72 65 ORDER BY cre
45f0: 61 74 69 6f 6e 5f 74 69 6d 65 20 44 45 53 43 20 ation_time DESC
4600: 4c 49 4d 49 54 20 31 3b 22 29 0a 09 74 61 72 67 LIMIT 1;")..targ
4610: 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 et runname).
4620: 20 20 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 72 res))))..;; r
4630: 65 6d 6f 76 65 20 74 61 73 6b 73 20 67 69 76 65 emove tasks give
4640: 6e 20 62 79 20 61 20 73 74 72 69 6e 67 20 6f 66 n by a string of
4650: 20 6e 75 6d 62 65 72 73 20 63 6f 6d 6d 61 20 73 numbers comma s
4660: 65 70 61 72 61 74 65 64 0a 28 64 65 66 69 6e 65 eparated.(define
4670: 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d 71 (tasks:remove-q
4680: 75 65 75 65 2d 65 6e 74 72 69 65 73 20 64 62 73 ueue-entries dbs
4690: 74 72 75 63 74 20 74 61 73 6b 2d 69 64 73 29 0a truct task-ids).
46a0: 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 (db:with-db.
46b0: 20 64 62 73 74 72 75 63 74 20 23 66 20 23 74 0a dbstruct #f #t.
46c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 (lambda (dbda
46d0: 74 20 64 62 29 0a 20 20 20 20 20 28 73 71 6c 69 t db). (sqli
46e0: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 te3:execute db (
46f0: 63 6f 6e 63 20 22 44 45 4c 45 54 45 20 46 52 4f conc "DELETE FRO
4700: 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 57 48 M tasks_queue WH
4710: 45 52 45 20 69 64 20 49 4e 20 28 22 20 74 61 73 ERE id IN (" tas
4720: 6b 2d 69 64 73 20 22 29 3b 22 29 29 29 29 29 0a k-ids ");"))))).
4730: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 .;; (define (tas
4740: 6b 73 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 ks:process-queue
4750: 20 64 62 73 74 72 75 63 74 29 0a 3b 3b 20 20 20 dbstruct).;;
4760: 28 6c 65 74 2a 20 28 28 74 61 73 6b 20 20 20 28 (let* ((task (
4770: 74 61 73 6b 73 3a 73 6e 61 67 2d 61 2d 74 61 73 tasks:snag-a-tas
4780: 6b 20 64 62 73 74 72 75 63 74 29 29 0a 3b 3b 20 k dbstruct)).;;
4790: 09 20 28 61 63 74 69 6f 6e 20 28 69 66 20 74 61 . (action (if ta
47a0: 73 6b 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 sk (tasks:task-g
47b0: 65 74 2d 61 63 74 69 6f 6e 20 74 61 73 6b 29 20 et-action task)
47c0: 23 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 #f))).;; (if
47d0: 20 61 63 74 69 6f 6e 20 28 70 72 69 6e 74 20 22 action (print "
47e0: 74 61 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 75 tasks:process-qu
47f0: 65 75 65 20 74 61 73 6b 3a 20 22 20 74 61 73 6b eue task: " task
4800: 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 61 63 )).;; (if ac
4810: 74 69 6f 6e 0a 3b 3b 20 09 28 63 61 73 65 20 28 tion.;; .(case (
4820: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 61 string->symbol a
4830: 63 74 69 6f 6e 29 0a 3b 3b 20 09 20 20 28 28 72 ction).;; . ((r
4840: 75 6e 29 20 20 20 20 20 20 20 28 74 61 73 6b 73 un) (tasks
4850: 3a 73 74 61 72 74 2d 72 75 6e 20 20 20 20 20 64 :start-run d
4860: 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a 3b bstruct task)).;
4870: 3b 20 09 20 20 28 28 72 65 6d 6f 76 65 29 20 20 ; . ((remove)
4880: 20 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d (tasks:remove-
4890: 72 75 6e 73 20 20 20 64 62 73 74 72 75 63 74 20 runs dbstruct
48a0: 74 61 73 6b 29 29 0a 3b 3b 20 09 20 20 28 28 6c task)).;; . ((l
48b0: 6f 63 6b 29 20 20 20 20 20 20 28 74 61 73 6b 73 ock) (tasks
48c0: 3a 6c 6f 63 6b 2d 72 75 6e 73 20 20 20 20 20 64 :lock-runs d
48d0: 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a 3b bstruct task)).;
48e0: 3b 20 09 20 20 3b 3b 20 28 28 6d 6f 6e 69 74 6f ; . ;; ((monito
48f0: 72 29 20 20 20 28 74 61 73 6b 73 3a 73 74 61 72 r) (tasks:star
4900: 74 2d 6d 6f 6e 69 74 6f 72 20 64 62 20 74 61 73 t-monitor db tas
4910: 6b 29 29 0a 3b 3b 20 09 20 20 23 3b 28 28 72 6f k)).;; . #;((ro
4920: 6c 6c 75 70 29 20 20 20 20 28 74 61 73 6b 73 3a llup) (tasks:
4930: 72 6f 6c 6c 75 70 2d 72 75 6e 73 20 20 20 64 62 rollup-runs db
4940: 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a 3b 3b struct task)).;;
4950: 20 09 20 20 28 28 75 70 64 61 74 65 6d 65 74 61 . ((updatemeta
4960: 29 28 74 61 73 6b 73 3a 75 70 64 61 74 65 2d 6d )(tasks:update-m
4970: 65 74 61 20 20 20 64 62 73 74 72 75 63 74 20 74 eta dbstruct t
4980: 61 73 6b 29 29 0a 3b 3b 20 09 20 20 23 3b 28 28 ask)).;; . #;((
4990: 6b 69 6c 6c 29 20 20 20 20 20 20 28 74 61 73 6b kill) (task
49a0: 73 3a 6b 69 6c 6c 2d 6d 6f 6e 69 74 6f 72 73 20 s:kill-monitors
49b0: 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 29 dbstruct task)))
49c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 )))..(define (ta
49d0: 73 6b 73 3a 74 61 73 6b 73 2d 3e 74 65 78 74 20 sks:tasks->text
49e0: 74 61 73 6b 73 29 0a 20 20 28 6c 65 74 20 28 28 tasks). (let ((
49f0: 66 6d 74 73 74 72 20 22 7e 31 30 61 7e 31 30 61 fmtstr "~10a~10a
4a00: 7e 31 30 61 7e 31 32 61 7e 32 30 61 7e 31 32 61 ~10a~12a~20a~12a
4a10: 7e 31 32 61 7e 31 30 61 22 29 29 0a 20 20 20 20 ~12a~10a")).
4a20: 28 63 6f 6e 63 20 28 66 6f 72 6d 61 74 20 23 66 (conc (format #f
4a30: 20 66 6d 74 73 74 72 20 22 69 64 22 20 22 61 63 fmtstr "id" "ac
4a40: 74 69 6f 6e 22 20 22 6f 77 6e 65 72 22 20 22 73 tion" "owner" "s
4a50: 74 61 74 65 22 20 22 74 61 72 67 65 74 22 20 22 tate" "target" "
4a60: 72 75 6e 6e 61 6d 65 22 20 22 74 65 73 74 70 61 runname" "testpa
4a70: 74 74 73 22 20 22 70 61 72 61 6d 73 22 29 20 22 tts" "params") "
4a80: 5c 6e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d 69 \n".. (string-i
4a90: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 ntersperse ..
4aa0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 61 (map (lambda (ta
4ab0: 73 6b 29 0a 09 09 20 20 28 66 6f 72 6d 61 74 20 sk)... (format
4ac0: 23 66 20 66 6d 74 73 74 72 0a 09 09 09 20 20 28 #f fmtstr.... (
4ad0: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 tasks:task-get-i
4ae0: 64 20 20 20 20 20 74 61 73 6b 29 0a 09 09 09 20 d task)....
4af0: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
4b00: 2d 61 63 74 69 6f 6e 20 74 61 73 6b 29 0a 09 09 -action task)...
4b10: 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 . (tasks:task-g
4b20: 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 6b 29 0a et-owner task).
4b30: 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b ... (tasks:task
4b40: 2d 67 65 74 2d 73 74 61 74 65 20 20 74 61 73 6b -get-state task
4b50: 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 ).... (tasks:ta
4b60: 73 6b 2d 67 65 74 2d 74 61 72 67 65 74 20 74 61 sk-get-target ta
4b70: 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a sk).... (tasks:
4b80: 74 61 73 6b 2d 67 65 74 2d 6e 61 6d 65 20 20 20 task-get-name
4b90: 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b task).... (task
4ba0: 73 3a 74 61 73 6b 2d 67 65 74 2d 74 65 73 74 70 s:task-get-testp
4bb0: 61 74 74 20 74 61 73 6b 29 0a 09 09 09 20 20 3b att task).... ;
4bc0: 3b 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 ; (tasks:task-ge
4bd0: 74 2d 69 74 65 6d 20 20 20 74 61 73 6b 29 0a 09 t-item task)..
4be0: 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d .. (tasks:task-
4bf0: 67 65 74 2d 70 61 72 61 6d 73 20 74 61 73 6b 29 get-params task)
4c00: 29 29 0a 09 09 74 61 73 6b 73 29 20 22 5c 6e 22 ))...tasks) "\n"
4c10: 29 29 29 29 0a 20 20 20 0a 28 64 65 66 69 6e 65 )))). .(define
4c20: 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 74 61 74 (tasks:set-stat
4c30: 65 20 64 62 73 74 72 75 63 74 20 74 61 73 6b 2d e dbstruct task-
4c40: 69 64 20 73 74 61 74 65 29 0a 20 20 28 64 62 3a id state). (db:
4c50: 77 69 74 68 2d 64 62 20 0a 20 20 20 64 62 73 74 with-db . dbst
4c60: 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 28 6c ruct #f #t. (l
4c70: 61 6d 62 64 61 20 28 64 62 64 61 74 20 64 62 29 ambda (dbdat db)
4c80: 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
4c90: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
4ca0: 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 E tasks_queue SE
4cb0: 54 20 73 74 61 74 65 3d 3f 20 57 48 45 52 45 20 T state=? WHERE
4cc0: 69 64 3d 3f 3b 22 20 0a 09 09 20 20 20 20 20 20 id=?;" ...
4cd0: 73 74 61 74 65 20 0a 09 09 20 20 20 20 20 20 74 state ... t
4ce0: 61 73 6b 2d 69 64 29 29 29 29 0a 0a 3b 3b 3d 3d ask-id))))..;;==
4cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d30: 3d 3d 3d 3d 0a 3b 3b 20 41 63 63 65 73 73 20 75 ====.;; Access u
4d40: 73 69 6e 67 20 74 61 73 6b 20 6b 65 79 20 28 73 sing task key (s
4d50: 74 6f 72 65 64 20 69 6e 20 70 61 72 61 6d 73 3b tored in params;
4d60: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
4d70: 69 73 74 20 66 6c 61 67 73 29 20 68 6f 73 74 6e ist flags) hostn
4d80: 61 6d 65 20 70 69 64 0a 3b 3b 3d 3d 3d 3d 3d 3d ame pid.;;======
4d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dd0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
4de0: 3a 70 61 72 61 6d 2d 6b 65 79 2d 3e 69 64 20 64 :param-key->id d
4df0: 62 73 74 72 75 63 74 20 74 61 73 6b 2d 70 61 72 bstruct task-par
4e00: 61 6d 73 29 0a 20 20 28 64 62 3a 77 69 74 68 2d ams). (db:with-
4e10: 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 23 db. dbstruct #
4e20: 66 20 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 f #f. (lambda
4e30: 28 64 62 64 61 74 20 64 62 29 0a 20 20 20 20 20 (dbdat db).
4e40: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
4e50: 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 ns. exn.
4e60: 20 20 20 23 66 0a 20 20 20 20 20 20 28 73 71 6c #f. (sql
4e70: 69 74 65 33 3a 66 69 72 73 74 2d 72 65 73 75 6c ite3:first-resul
4e80: 74 20 64 62 20 22 53 45 4c 45 43 54 20 69 64 20 t db "SELECT id
4e90: 46 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 FROM tasks_queue
4ea0: 20 57 48 45 52 45 20 70 61 72 61 6d 73 20 4c 49 WHERE params LI
4eb0: 4b 45 20 3f 3b 22 0a 09 09 09 20 20 20 20 74 61 KE ?;".... ta
4ec0: 73 6b 2d 70 61 72 61 6d 73 29 29 29 29 29 0a 0a sk-params)))))..
4ed0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 (define (tasks:s
4ee0: 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 et-state-given-p
4ef0: 61 72 61 6d 2d 6b 65 79 20 64 62 73 74 72 75 63 aram-key dbstruc
4f00: 74 20 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d t param-key new-
4f10: 73 74 61 74 65 29 0a 20 20 28 64 62 3a 77 69 74 state). (db:wit
4f20: 68 2d 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 h-db. dbstruct
4f30: 20 23 66 20 23 74 0a 20 20 20 28 6c 61 6d 62 64 #f #t. (lambd
4f40: 61 20 28 64 62 64 61 74 20 64 62 29 0a 20 20 20 a (dbdat db).
4f50: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
4f60: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 61 te db "UPDATE ta
4f70: 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 74 sks_queue SET st
4f80: 61 74 65 3d 3f 20 57 48 45 52 45 20 70 61 72 61 ate=? WHERE para
4f90: 6d 73 20 4c 49 4b 45 20 3f 3b 22 20 6e 65 77 2d ms LIKE ?;" new-
4fa0: 73 74 61 74 65 20 70 61 72 61 6d 2d 6b 65 79 29 state param-key)
4fb0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 )))..(define (ta
4fc0: 73 6b 73 3a 67 65 74 2d 72 65 63 6f 72 64 73 2d sks:get-records-
4fd0: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
4fe0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 2d 6b dbstruct param-k
4ff0: 65 79 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 ey state-patt ac
5000: 74 69 6f 6e 2d 70 61 74 74 20 74 65 73 74 2d 70 tion-patt test-p
5010: 61 74 74 29 0a 20 20 28 64 62 3a 77 69 74 68 2d att). (db:with-
5020: 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 23 db. dbstruct #
5030: 66 20 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 f #f. (lambda
5040: 28 64 62 64 61 74 20 64 62 29 0a 20 20 20 20 20 (dbdat db).
5050: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
5060: 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 ns. exn.
5070: 20 20 20 27 28 29 0a 20 20 20 20 20 20 28 73 71 '(). (sq
5080: 6c 69 74 65 33 3a 66 69 72 73 74 2d 72 6f 77 20 lite3:first-row
5090: 64 62 20 22 53 45 4c 45 43 54 20 69 64 2c 61 63 db "SELECT id,ac
50a0: 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 tion,owner,state
50b0: 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 ,target,name,tes
50c0: 74 70 61 74 74 2c 6b 65 79 6c 6f 63 6b 2c 70 61 tpatt,keylock,pa
50d0: 72 61 6d 73 20 57 48 45 52 45 0a 20 20 20 20 20 rams WHERE.
50e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50f0: 20 20 20 20 20 20 20 20 20 20 70 61 72 61 6d 73 params
5100: 20 4c 49 4b 45 20 3f 20 41 4e 44 20 73 74 61 74 LIKE ? AND stat
5110: 65 20 4c 49 4b 45 20 3f 20 41 4e 44 20 61 63 74 e LIKE ? AND act
5120: 69 6f 6e 20 4c 49 4b 45 20 3f 20 41 4e 44 20 74 ion LIKE ? AND t
5130: 65 73 74 70 61 74 74 20 4c 49 4b 45 20 3f 3b 22 estpatt LIKE ?;"
5140: 0a 09 09 09 20 70 61 72 61 6d 2d 6b 65 79 20 73 .... param-key s
5150: 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f 6e tate-patt action
5160: 2d 70 61 74 74 20 74 65 73 74 2d 70 61 74 74 29 -patt test-patt)
5170: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
5180: 61 73 6b 73 3a 66 69 6e 64 2d 74 61 73 6b 2d 71 asks:find-task-q
5190: 75 65 75 65 2d 72 65 63 6f 72 64 73 20 64 62 73 ueue-records dbs
51a0: 74 72 75 63 74 20 74 61 72 67 65 74 20 72 75 6e truct target run
51b0: 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 20 -name test-patt
51c0: 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f state-patt actio
51d0: 6e 2d 70 61 74 74 29 0a 20 20 28 64 62 3a 77 69 n-patt). (db:wi
51e0: 74 68 2d 64 62 0a 20 20 20 64 62 73 74 72 75 63 th-db. dbstruc
51f0: 74 0a 20 20 20 23 66 20 23 66 0a 20 20 20 28 6c t. #f #f. (l
5200: 61 6d 62 64 61 20 28 64 62 64 61 74 20 64 62 29 ambda (dbdat db)
5210: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 . (let ((res
5220: 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 28 73 '())). (s
5230: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
5240: 72 6f 77 20 0a 09 28 6c 61 6d 62 64 61 20 28 61 row ..(lambda (a
5250: 20 2e 20 62 29 0a 09 20 20 28 73 65 74 21 20 72 . b).. (set! r
5260: 65 73 20 28 63 6f 6e 73 20 28 63 6f 6e 73 20 61 es (cons (cons a
5270: 20 62 29 20 72 65 73 29 29 29 0a 09 64 62 20 22 b) res)))..db "
5280: 53 45 4c 45 43 54 20 69 64 2c 61 63 74 69 6f 6e SELECT id,action
5290: 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 ,owner,state,tar
52a0: 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 70 61 74 get,name,testpat
52b0: 74 2c 6b 65 79 6c 6f 63 6b 2c 70 61 72 61 6d 73 t,keylock,params
52c0: 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 FROM tasks_queu
52d0: 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 57 48 e . WH
52e0: 45 52 45 0a 20 20 20 20 20 20 20 20 20 20 20 20 ERE.
52f0: 20 20 74 61 72 67 65 74 20 3d 20 3f 20 41 4e 44 target = ? AND
5300: 20 6e 61 6d 65 20 3d 20 3f 20 41 4e 44 20 73 74 name = ? AND st
5310: 61 74 65 20 4c 49 4b 45 20 3f 20 41 4e 44 20 61 ate LIKE ? AND a
5320: 63 74 69 6f 6e 20 4c 49 4b 45 20 3f 20 41 4e 44 ction LIKE ? AND
5330: 20 74 65 73 74 70 61 74 74 20 4c 49 4b 45 20 3f testpatt LIKE ?
5340: 3b 22 0a 09 74 61 72 67 65 74 20 72 75 6e 2d 6e ;"..target run-n
5350: 61 6d 65 20 73 74 61 74 65 2d 70 61 74 74 20 61 ame state-patt a
5360: 63 74 69 6f 6e 2d 70 61 74 74 20 74 65 73 74 2d ction-patt test-
5370: 70 61 74 74 29 0a 20 20 20 20 20 20 20 72 65 73 patt). res
5380: 29 29 29 29 0a 0a 3b 3b 20 6b 69 6c 6c 20 61 6e ))))..;; kill an
5390: 79 20 72 75 6e 6e 65 72 20 70 72 6f 63 65 73 73 y runner process
53a0: 65 73 20 28 69 2e 65 2e 20 70 72 6f 63 65 73 73 es (i.e. process
53b0: 65 73 20 68 61 6e 64 6c 69 6e 67 20 2d 72 75 6e es handling -run
53c0: 74 65 73 74 73 29 20 74 68 61 74 20 6d 61 74 63 tests) that matc
53d0: 68 20 74 61 72 67 65 74 2f 72 75 6e 6e 61 6d 65 h target/runname
53e0: 0a 3b 3b 20 0a 3b 3b 20 64 6f 20 61 20 72 65 6d .;; .;; do a rem
53f0: 6f 74 65 20 63 61 6c 6c 20 74 6f 20 67 65 74 20 ote call to get
5400: 74 68 65 20 74 61 73 6b 20 71 75 65 75 65 20 69 the task queue i
5410: 6e 66 6f 20 62 75 74 20 64 6f 20 74 68 65 20 6b nfo but do the k
5420: 69 6c 6c 69 6e 67 20 61 73 20 73 65 6c 66 20 68 illing as self h
5430: 65 72 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ere..;;.(define
5440: 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e (tasks:kill-runn
5450: 65 72 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 er target run-na
5460: 6d 65 20 74 65 73 74 70 61 74 74 29 0a 20 20 28 me testpatt). (
5470: 6c 65 74 20 28 28 72 65 63 6f 72 64 73 20 20 20 let ((records
5480: 20 28 72 6d 74 3a 74 61 73 6b 73 2d 66 69 6e 64 (rmt:tasks-find
5490: 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f -task-queue-reco
54a0: 72 64 73 20 74 61 72 67 65 74 20 72 75 6e 2d 6e rds target run-n
54b0: 61 6d 65 20 74 65 73 74 70 61 74 74 20 22 72 75 ame testpatt "ru
54c0: 6e 6e 69 6e 67 22 20 22 72 75 6e 2d 74 65 73 74 nning" "run-test
54d0: 73 22 29 29 0a 09 28 68 6f 73 74 70 69 64 2d 72 s"))..(hostpid-r
54e0: 78 20 28 72 65 67 65 78 70 20 22 5c 5c 73 2b 28 x (regexp "\\s+(
54f0: 5c 5c 77 2b 29 5c 5c 73 2b 28 5c 5c 64 2b 29 24 \\w+)\\s+(\\d+)$
5500: 22 29 29 29 20 3b 3b 20 68 6f 73 74 20 70 69 64 "))) ;; host pid
5510: 20 69 73 20 61 74 20 65 6e 64 20 6f 66 20 70 61 is at end of pa
5520: 72 61 6d 20 73 74 72 69 6e 67 0a 20 20 20 20 28 ram string. (
5530: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 63 6f 72 64 if (null? record
5540: 73 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 s)..(debug:print
5550: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5560: 70 6f 72 74 2a 20 22 4e 6f 20 72 75 6e 20 6c 61 port* "No run la
5570: 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 65 unching processe
5580: 73 20 66 6f 75 6e 64 20 66 6f 72 20 22 20 74 61 s found for " ta
5590: 72 67 65 74 20 22 20 2f 20 22 20 72 75 6e 2d 6e rget " / " run-n
55a0: 61 6d 65 20 22 20 77 69 74 68 20 74 65 73 74 70 ame " with testp
55b0: 61 74 74 20 22 20 28 6f 72 20 74 65 73 74 70 61 att " (or testpa
55c0: 74 74 20 22 2a 20 6e 6f 20 74 65 73 74 70 61 74 tt "* no testpat
55d0: 74 20 73 70 65 63 69 66 69 65 64 21 20 2a 22 29 t specified! *")
55e0: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
55f0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5600: 6f 72 74 2a 20 22 46 6f 75 6e 64 20 22 20 28 6c ort* "Found " (l
5610: 65 6e 67 74 68 20 72 65 63 6f 72 64 73 29 20 22 ength records) "
5620: 20 72 75 6e 28 73 29 20 74 6f 20 6b 69 6c 6c 2e run(s) to kill.
5630: 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ")). (for-eac
5640: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
5650: 28 72 65 63 6f 72 64 29 0a 20 20 20 20 20 20 20 (record).
5660: 28 6c 65 74 2a 20 28 28 70 61 72 61 6d 2d 6b 65 (let* ((param-ke
5670: 79 20 28 6c 69 73 74 2d 72 65 66 20 72 65 63 6f y (list-ref reco
5680: 72 64 20 38 29 29 0a 09 20 20 20 20 20 20 28 6d rd 8)).. (m
5690: 61 74 63 68 2d 64 61 74 20 28 73 74 72 69 6e 67 atch-dat (string
56a0: 2d 73 65 61 72 63 68 20 68 6f 73 74 70 69 64 2d -search hostpid-
56b0: 72 78 20 70 61 72 61 6d 2d 6b 65 79 29 29 29 0a rx param-key))).
56c0: 09 20 28 69 66 20 6d 61 74 63 68 2d 64 61 74 0a . (if match-dat.
56d0: 09 20 20 20 20 20 28 6c 65 74 20 28 28 68 6f 73 . (let ((hos
56e0: 74 6e 61 6d 65 20 20 28 63 61 64 72 20 6d 61 74 tname (cadr mat
56f0: 63 68 2d 64 61 74 29 29 0a 09 09 20 20 20 28 70 ch-dat))... (p
5700: 69 64 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 id (string
5710: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 20 ->number (caddr
5720: 6d 61 74 63 68 2d 64 61 74 29 29 29 29 0a 09 20 match-dat))))..
5730: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
5740: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
5750: 67 2d 70 6f 72 74 2a 20 22 53 65 6e 64 69 6e 67 g-port* "Sending
5760: 20 53 49 47 49 4e 54 20 74 6f 20 70 72 6f 63 65 SIGINT to proce
5770: 73 73 20 22 20 70 69 64 20 22 20 6f 6e 20 68 6f ss " pid " on ho
5780: 73 74 20 22 20 68 6f 73 74 6e 61 6d 65 29 0a 09 st " hostname)..
5790: 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 (if (equa
57a0: 6c 3f 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d l? (get-host-nam
57b0: 65 29 20 68 6f 73 74 6e 61 6d 65 29 0a 09 09 20 e) hostname)...
57c0: 20 20 28 69 66 20 28 70 72 6f 63 65 73 73 3a 61 (if (process:a
57d0: 6c 69 76 65 3f 20 70 69 64 29 0a 09 09 20 20 20 live? pid)...
57e0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 (begin.... (
57f0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
5800: 73 0a 09 09 09 20 20 65 78 6e 0a 09 09 09 20 20 s.... exn....
5810: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 64 (begin.... (d
5820: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5830: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5840: 22 4b 69 6c 6c 20 6f 66 20 70 72 6f 63 65 73 73 "Kill of process
5850: 20 22 20 70 69 64 20 22 20 6f 6e 20 68 6f 73 74 " pid " on host
5860: 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 66 61 " hostname " fa
5870: 69 6c 65 64 2e 22 29 0a 09 09 09 20 20 20 20 28 iled.").... (
5880: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
5890: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
58a0: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
58b0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
58c0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
58d0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
58e0: 0a 09 09 09 20 20 20 20 23 74 29 0a 09 09 09 20 .... #t)....
58f0: 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
5900: 20 70 69 64 20 73 69 67 6e 61 6c 2f 69 6e 74 29 pid signal/int)
5910: 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
5920: 65 65 70 21 20 35 29 0a 09 09 09 20 20 28 69 66 eep! 5).... (if
5930: 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f (process:alive?
5940: 20 70 69 64 29 0a 09 09 09 20 20 20 20 20 20 28 pid).... (
5950: 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 70 process-signal p
5960: 69 64 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 id signal/kill))
5970: 29 29 29 0a 09 09 20 20 20 3b 3b 20 20 28 63 61 )))... ;; (ca
5980: 6c 6c 2d 77 69 74 68 2d 65 6e 76 69 72 6f 6e 6d ll-with-environm
5990: 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 0a 09 09 ent-variables...
59a0: 20 20 20 28 6c 65 74 20 28 28 6f 6c 64 2d 74 61 (let ((old-ta
59b0: 72 67 65 74 68 6f 73 74 20 28 67 65 74 65 6e 76 rgethost (getenv
59c0: 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 29 29 "TARGETHOST")))
59d0: 0a 09 09 20 20 20 20 20 28 73 65 74 65 6e 76 20 ... (setenv
59e0: 22 54 41 52 47 45 54 48 4f 53 54 22 20 68 6f 73 "TARGETHOST" hos
59f0: 74 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 28 73 tname)... (s
5a00: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
5a10: 54 5f 4c 4f 47 46 22 20 22 73 65 72 76 65 72 2d T_LOGF" "server-
5a20: 6b 69 6c 6c 73 2e 6c 6f 67 22 29 0a 09 09 20 20 kills.log")...
5a30: 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (system (conc
5a40: 20 22 6e 62 66 61 6b 65 20 6b 69 6c 6c 20 22 20 "nbfake kill "
5a50: 70 69 64 29 29 0a 09 09 20 20 20 20 20 28 69 66 pid))... (if
5a60: 20 6f 6c 64 2d 74 61 72 67 65 74 68 6f 73 74 20 old-targethost
5a70: 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 (setenv "TARGETH
5a80: 4f 53 54 22 20 6f 6c 64 2d 74 61 72 67 65 74 68 OST" old-targeth
5a90: 6f 73 74 29 29 0a 09 09 20 20 20 20 20 28 75 6e ost))... (un
5aa0: 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f setenv "TARGETHO
5ab0: 53 54 22 29 0a 09 09 20 20 20 20 20 28 75 6e 73 ST")... (uns
5ac0: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
5ad0: 54 5f 4c 4f 47 46 22 29 29 29 29 0a 09 20 20 20 T_LOGF"))))..
5ae0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
5af0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
5b00: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 20 72 65 log-port* "no re
5b10: 63 6f 72 64 20 6f 72 20 69 6d 70 72 6f 70 65 72 cord or improper
5b20: 20 72 65 63 6f 72 64 20 66 6f 72 20 22 20 74 61 record for " ta
5b30: 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d rget "/" run-nam
5b40: 65 20 22 20 69 6e 20 74 61 73 6b 73 5f 71 75 65 e " in tasks_que
5b50: 75 65 20 69 6e 20 6d 61 69 6e 2e 64 62 22 29 29 ue in main.db"))
5b60: 29 29 0a 20 20 20 20 20 72 65 63 6f 72 64 73 29 )). records)
5b70: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
5b80: 74 61 73 6b 73 3a 73 74 61 72 74 2d 72 75 6e 20 tasks:start-run
5b90: 64 62 73 74 72 75 63 74 20 6d 64 62 20 74 61 73 dbstruct mdb tas
5ba0: 6b 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 66 k).;; (let ((f
5bb0: 6c 61 67 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d lags (make-hash-
5bc0: 74 61 62 6c 65 29 29 29 0a 3b 3b 20 20 20 20 20 table))).;;
5bd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5be0: 20 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 20 flags "-rerun"
5bf0: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 3b "NOT_STARTED").;
5c00: 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ; (if (not (
5c10: 73 74 72 69 6e 67 3d 3f 20 28 74 61 73 6b 73 3a string=? (tasks:
5c20: 74 61 73 6b 2d 67 65 74 2d 70 61 72 61 6d 73 20 task-get-params
5c30: 74 61 73 6b 29 20 22 22 29 29 0a 3b 3b 20 09 28 task) "")).;; .(
5c40: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
5c50: 66 6c 61 67 73 20 22 2d 73 65 74 76 61 72 73 22 flags "-setvars"
5c60: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
5c70: 2d 70 61 72 61 6d 73 20 74 61 73 6b 29 29 29 0a -params task))).
5c80: 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 53 ;; (print "S
5c90: 74 61 72 74 69 6e 67 20 72 75 6e 20 22 20 74 61 tarting run " ta
5ca0: 73 6b 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 69 sk).;; ;; si
5cb0: 6c 6c 79 6e 65 73 73 2c 20 6a 75 73 74 20 63 61 llyness, just ca
5cc0: 6c 6c 20 74 68 65 20 64 61 6d 6e 20 72 6f 75 74 ll the damn rout
5cd0: 69 6e 65 20 77 69 74 68 20 74 68 65 20 74 61 73 ine with the tas
5ce0: 6b 20 76 65 63 74 6f 72 20 61 6e 64 20 62 65 20 k vector and be
5cf0: 64 6f 6e 65 20 77 69 74 68 20 69 74 2e 20 46 49 done with it. FI
5d00: 58 4d 45 20 53 4f 4d 45 44 41 59 0a 3b 3b 20 20 XME SOMEDAY.;;
5d10: 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 (runs:run-tes
5d20: 74 73 20 64 62 0a 3b 3b 20 09 09 20 20 20 20 28 ts db.;; .. (
5d30: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 tasks:task-get-t
5d40: 61 72 67 65 74 20 74 61 73 6b 29 0a 3b 3b 20 09 arget task).;; .
5d50: 09 20 20 20 20 28 74 61 73 6b 73 3a 74 61 73 6b . (tasks:task
5d60: 2d 67 65 74 2d 6e 61 6d 65 20 20 20 74 61 73 6b -get-name task
5d70: 29 0a 3b 3b 20 09 09 20 20 20 20 28 74 61 73 6b ).;; .. (task
5d80: 73 3a 74 61 73 6b 2d 67 65 74 2d 74 65 73 74 20 s:task-get-test
5d90: 20 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 task).;; ..
5da0: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
5db0: 2d 69 74 65 6d 20 20 20 74 61 73 6b 29 0a 3b 3b -item task).;;
5dc0: 20 09 09 20 20 20 20 28 74 61 73 6b 73 3a 74 61 .. (tasks:ta
5dd0: 73 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 61 sk-get-owner ta
5de0: 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 66 6c 61 sk).;; .. fla
5df0: 67 73 29 0a 3b 3b 20 20 20 20 20 28 74 61 73 6b gs).;; (task
5e00: 73 3a 73 65 74 2d 73 74 61 74 65 20 6d 64 62 20 s:set-state mdb
5e10: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
5e20: 69 64 20 74 61 73 6b 29 20 22 77 61 69 74 69 6e id task) "waitin
5e30: 67 22 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 g"))).;; .;; (de
5e40: 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 6f 6c 6c fine (tasks:roll
5e50: 75 70 2d 72 75 6e 73 20 64 62 20 6d 64 62 20 74 up-runs db mdb t
5e60: 61 73 6b 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 ask).;; (let*
5e70: 28 28 66 6c 61 67 73 20 28 6d 61 6b 65 2d 68 61 ((flags (make-ha
5e80: 73 68 2d 74 61 62 6c 65 29 29 20 0a 3b 3b 20 09 sh-table)) .;; .
5e90: 20 28 6b 65 79 73 20 20 28 64 62 3a 67 65 74 2d (keys (db:get-
5ea0: 6b 65 79 73 20 64 62 29 29 0a 3b 3b 20 09 20 28 keys db)).;; . (
5eb0: 6b 65 79 76 61 6c 73 20 28 6b 65 79 73 3a 74 61 keyvals (keys:ta
5ec0: 72 67 65 74 2d 6b 65 79 76 61 6c 20 6b 65 79 73 rget-keyval keys
5ed0: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
5ee0: 2d 74 61 72 67 65 74 20 74 61 73 6b 29 29 29 29 -target task))))
5ef0: 0a 3b 3b 20 20 20 20 20 3b 3b 20 28 68 61 73 68 .;; ;; (hash
5f00: 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 -table-set! flag
5f10: 73 20 22 2d 72 65 72 75 6e 22 20 22 4e 4f 54 5f s "-rerun" "NOT_
5f20: 53 54 41 52 54 45 44 22 29 0a 3b 3b 20 20 20 20 STARTED").;;
5f30: 20 28 70 72 69 6e 74 20 22 53 74 61 72 74 69 6e (print "Startin
5f40: 67 20 72 6f 6c 6c 75 70 20 22 20 74 61 73 6b 29 g rollup " task)
5f50: 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 69 6c 6c 79 .;; ;; silly
5f60: 6e 65 73 73 2c 20 6a 75 73 74 20 63 61 6c 6c 20 ness, just call
5f70: 74 68 65 20 64 61 6d 6e 20 72 6f 75 74 69 6e 65 the damn routine
5f80: 20 77 69 74 68 20 74 68 65 20 74 61 73 6b 20 76 with the task v
5f90: 65 63 74 6f 72 20 61 6e 64 20 62 65 20 64 6f 6e ector and be don
5fa0: 65 20 77 69 74 68 20 69 74 2e 20 46 49 58 4d 45 e with it. FIXME
5fb0: 20 53 4f 4d 45 44 41 59 0a 3b 3b 20 20 20 20 20 SOMEDAY.;;
5fc0: 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e (runs:rollup-run
5fd0: 20 64 62 0a 3b 3b 20 09 09 20 20 20 20 20 6b 65 db.;; .. ke
5fe0: 79 73 20 0a 3b 3b 20 09 09 20 20 20 20 20 6b 65 ys .;; .. ke
5ff0: 79 76 61 6c 73 0a 3b 3b 20 09 09 20 20 20 20 20 yvals.;; ..
6000: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
6010: 6e 61 6d 65 20 20 74 61 73 6b 29 0a 3b 3b 20 09 name task).;; .
6020: 09 20 20 20 20 20 28 74 61 73 6b 73 3a 74 61 73 . (tasks:tas
6030: 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 k-get-owner tas
6040: 6b 29 29 0a 3b 3b 20 20 20 20 20 28 74 61 73 6b k)).;; (task
6050: 73 3a 73 65 74 2d 73 74 61 74 65 20 6d 64 62 20 s:set-state mdb
6060: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
6070: 69 64 20 74 61 73 6b 29 20 22 77 61 69 74 69 6e id task) "waitin
6080: 67 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d g")))..;;=======
6090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
60d0: 3b 3b 20 20 53 20 59 20 4e 20 43 20 20 20 54 20 ;; S Y N C T
60e0: 4f 20 20 20 50 20 4f 20 53 20 54 20 47 20 52 20 O P O S T G R
60f0: 45 20 53 20 51 20 4c 0a 3b 3b 3d 3d 3d 3d 3d 3d E S Q L.;;======
6100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6140: 0a 0a 3b 3b 20 49 6e 20 74 68 65 20 73 70 69 72 ..;; In the spir
6150: 69 74 20 6f 66 20 22 64 75 6d 70 20 79 6f 75 72 it of "dump your
6160: 20 6a 75 6e 6b 20 69 6e 20 74 68 65 20 74 61 73 junk in the tas
6170: 6b 73 20 6d 6f 64 75 6c 65 22 20 49 27 6c 6c 20 ks module" I'll
6180: 70 75 74 20 74 68 65 0a 3b 3b 20 73 79 6e 63 20 put the.;; sync
6190: 74 6f 20 70 6f 73 74 67 72 65 73 20 68 65 72 65 to postgres here
61a0: 20 66 6f 72 20 6e 6f 77 2e 0a 0a 3b 3b 20 61 74 for now...;; at
61b0: 74 65 6d 70 74 20 74 6f 20 61 75 74 6f 6d 61 74 tempt to automat
61c0: 69 63 61 6c 6c 79 20 73 65 74 20 75 70 20 61 6e ically set up an
61d0: 20 61 72 65 61 2e 20 63 61 6c 6c 20 6f 6e 6c 79 area. call only
61e0: 20 69 66 20 67 65 74 20 61 72 65 61 20 62 79 20 if get area by
61f0: 70 61 74 68 0a 3b 3b 20 72 65 74 75 72 6e 73 20 path.;; returns
6200: 6e 61 75 67 68 74 20 6f 66 20 69 6e 74 65 72 65 naught of intere
6210: 73 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 st.;;.(define (t
6220: 61 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 62 asks:set-area db
6230: 68 20 63 6f 6e 66 69 67 64 61 74 20 23 21 6b 65 h configdat #!ke
6240: 79 20 28 74 6f 70 70 61 74 68 20 23 66 29 29 20 y (toppath #f))
6250: 3b 3b 20 63 6f 75 6c 64 20 49 20 73 61 66 65 6c ;; could I safel
6260: 79 20 70 75 74 20 2a 74 6f 70 70 61 74 68 2a 20 y put *toppath*
6270: 69 6e 20 66 6f 72 20 74 68 65 20 64 65 66 61 75 in for the defau
6280: 6c 74 20 66 6f 72 20 74 6f 70 70 61 74 68 3f 20 lt for toppath?
6290: 77 68 65 6e 20 77 6f 75 6c 64 20 69 74 20 62 65 when would it be
62a0: 20 65 76 61 6c 75 61 74 65 64 3f 0a 20 20 28 6c evaluated?. (l
62b0: 65 74 20 6c 6f 6f 70 20 28 28 61 72 65 61 2d 6e et loop ((area-n
62c0: 61 6d 65 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 ame (or (configf
62d0: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
62e0: 74 20 22 73 65 74 75 70 22 20 22 61 72 65 61 2d t "setup" "area-
62f0: 6e 61 6d 65 22 29 0a 09 09 09 20 20 20 20 28 63 name").... (c
6300: 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e ommon:get-area-n
6310: 61 6d 65 29 29 29 0a 09 20 20 20 20 20 28 6d 6f ame))).. (mo
6320: 64 69 66 69 65 72 20 20 27 6e 6f 6e 65 29 29 0a difier 'none)).
6330: 20 20 20 20 28 6c 65 74 20 28 28 73 75 63 63 65 (let ((succe
6340: 73 73 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 ss (handle-excep
6350: 74 69 6f 6e 73 0a 09 09 20 20 20 20 20 20 20 65 tions... e
6360: 78 6e 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 xn... (beg
6370: 69 6e 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 in.... (debug:pr
6380: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
6390: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
63a0: 20 63 61 6e 6e 6f 74 20 63 72 65 61 74 65 20 61 cannot create a
63b0: 72 65 61 20 65 6e 74 72 79 2c 20 22 20 28 28 63 rea entry, " ((c
63c0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
63d0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
63e0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
63f0: 09 09 09 20 23 66 29 20 3b 3b 20 46 49 58 4d 45 ... #f) ;; FIXME
6400: 3a 20 49 20 64 6f 6e 27 74 20 63 61 72 65 20 66 : I don't care f
6410: 6f 72 20 6e 6f 77 20 62 75 74 20 49 20 73 68 6f or now but I sho
6420: 75 6c 64 20 6c 6f 6f 6b 20 61 74 20 2a 77 68 79 uld look at *why
6430: 2a 20 74 68 65 72 65 20 77 61 73 20 61 6e 20 65 * there was an e
6440: 78 63 65 70 74 69 6f 6e 0a 09 09 20 20 20 20 20 xception...
6450: 28 70 67 64 62 3a 61 64 64 2d 61 72 65 61 20 64 (pgdb:add-area d
6460: 62 68 20 61 72 65 61 2d 6e 61 6d 65 20 28 6f 72 bh area-name (or
6470: 20 74 6f 70 70 61 74 68 20 2a 74 6f 70 70 61 74 toppath *toppat
6480: 68 2a 29 29 29 29 29 0a 20 20 20 20 20 20 28 6f h*))))). (o
6490: 72 20 73 75 63 63 65 73 73 0a 09 20 20 28 63 61 r success.. (ca
64a0: 73 65 20 6d 6f 64 69 66 69 65 72 0a 09 20 20 20 se modifier..
64b0: 20 28 28 6e 6f 6e 65 29 28 6c 6f 6f 70 20 28 63 ((none)(loop (c
64c0: 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 75 73 65 onc (current-use
64d0: 72 2d 6e 61 6d 65 29 20 22 5f 22 20 61 72 65 61 r-name) "_" area
64e0: 2d 6e 61 6d 65 29 20 27 75 73 65 72 29 29 0a 09 -name) 'user))..
64f0: 20 20 20 20 28 28 75 73 65 72 29 28 6c 6f 6f 70 ((user)(loop
6500: 20 28 63 6f 6e 63 20 28 73 75 62 73 74 72 69 6e (conc (substrin
6510: 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 g (common:get-ar
6520: 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 75 72 ea-path-signatur
6530: 65 29 20 30 20 34 29 0a 09 09 09 20 20 20 20 20 e) 0 4)....
6540: 20 20 61 72 65 61 2d 6e 61 6d 65 29 20 27 61 72 area-name) 'ar
6550: 65 61 73 69 67 29 29 0a 09 20 20 20 20 28 65 6c easig)).. (el
6560: 73 65 20 23 66 29 29 29 29 29 29 20 3b 3b 20 67 se #f)))))) ;; g
6570: 69 76 65 20 75 70 0a 0a 28 64 65 66 69 6e 65 20 ive up..(define
6580: 28 74 61 73 6b 3a 70 72 69 6e 74 2d 72 75 6e 74 (task:print-runt
6590: 69 6d 65 20 72 75 6e 2d 74 69 6d 65 73 20 73 61 ime run-times sa
65a0: 70 65 72 61 74 6f 72 29 0a 28 66 6f 72 2d 65 61 perator).(for-ea
65b0: 63 68 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ch. (lambda (
65c0: 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 29 0a 20 run-time-info).
65d0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d (let* ((run-
65e0: 6e 61 6d 65 20 20 28 76 65 63 74 6f 72 2d 72 65 name (vector-re
65f0: 66 20 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 20 f run-time-info
6600: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
6610: 28 72 75 6e 2d 74 69 6d 65 20 20 28 76 65 63 74 (run-time (vect
6620: 6f 72 2d 72 65 66 20 72 75 6e 2d 74 69 6d 65 2d or-ref run-time-
6630: 69 6e 66 6f 20 31 29 29 0a 20 20 20 20 20 20 20 info 1)).
6640: 20 20 20 20 20 28 74 61 72 67 65 74 20 20 28 76 (target (v
6650: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 2d 74 69 ector-ref run-ti
6660: 6d 65 2d 69 6e 66 6f 20 32 29 29 29 0a 20 20 20 me-info 2))).
6670: 20 20 20 20 20 28 70 72 69 6e 74 20 74 61 72 67 (print targ
6680: 65 74 20 73 61 70 65 72 61 74 6f 72 20 72 75 6e et saperator run
6690: 2d 6e 61 6d 65 20 73 61 70 65 72 61 74 6f 72 20 -name saperator
66a0: 72 75 6e 2d 74 69 6d 65 20 29 29 29 0a 20 20 20 run-time ))).
66b0: 72 75 6e 2d 74 69 6d 65 73 29 29 0a 0a 28 64 65 run-times))..(de
66c0: 66 69 6e 65 20 28 74 61 73 6b 3a 70 72 69 6e 74 fine (task:print
66d0: 2d 72 75 6e 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e -runtime-as-json
66e0: 20 72 75 6e 2d 74 69 6d 65 73 29 0a 20 28 6c 65 run-times). (le
66f0: 74 20 6c 6f 6f 70 20 28 28 72 75 6e 2d 74 69 6d t loop ((run-tim
6700: 65 2d 69 6e 66 6f 20 28 63 61 72 20 72 75 6e 2d e-info (car run-
6710: 74 69 6d 65 73 29 29 0a 20 20 20 20 20 20 20 20 times)).
6720: 20 20 20 20 28 72 65 6d 61 20 28 63 64 72 20 72 (rema (cdr r
6730: 75 6e 2d 74 69 6d 65 73 29 29 20 0a 20 20 20 20 un-times)) .
6740: 20 20 20 20 20 20 20 20 28 73 74 72 20 22 22 29 (str "")
6750: 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 ). (let* ((r
6760: 75 6e 2d 6e 61 6d 65 20 20 28 76 65 63 74 6f 72 un-name (vector
6770: 2d 72 65 66 20 72 75 6e 2d 74 69 6d 65 2d 69 6e -ref run-time-in
6780: 66 6f 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 fo 0)).
6790: 20 20 20 28 72 75 6e 2d 74 69 6d 65 20 20 28 76 (run-time (v
67a0: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 2d 74 69 ector-ref run-ti
67b0: 6d 65 2d 69 6e 66 6f 20 31 29 29 0a 20 20 20 20 me-info 1)).
67c0: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 (target
67d0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
67e0: 2d 74 69 6d 65 2d 69 6e 66 6f 20 32 29 29 29 0a -time-info 2))).
67f0: 20 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 ;(print
6800: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 74 72 (not (equal? str
6810: 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 20 28 ""))). (
6820: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
6830: 73 74 72 20 22 22 29 29 20 0a 20 20 20 20 20 20 str "")) .
6840: 20 20 20 20 20 20 28 73 65 74 21 20 73 74 72 20 (set! str
6850: 28 63 6f 6e 63 20 73 74 72 20 22 2c 22 29 29 29 (conc str ",")))
6860: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 . (if (nu
6870: 6c 6c 3f 20 72 65 6d 61 29 0a 09 09 28 70 72 69 ll? rema)...(pri
6880: 6e 74 20 22 5b 22 20 73 74 72 20 22 7b 74 61 72 nt "[" str "{tar
6890: 67 65 74 3a 22 20 74 61 72 67 65 74 20 22 2c 72 get:" target ",r
68a0: 75 6e 2d 6e 61 6d 65 3a 22 20 72 75 6e 2d 6e 61 un-name:" run-na
68b0: 6d 65 20 22 2c 20 72 75 6e 2d 74 69 6d 65 3a 22 me ", run-time:"
68c0: 20 72 75 6e 2d 74 69 6d 65 20 22 7d 5d 22 29 0a run-time "}]").
68d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
68e0: 70 20 28 63 61 72 20 72 65 6d 61 29 20 28 63 64 p (car rema) (cd
68f0: 72 20 72 65 6d 61 29 20 28 63 6f 6e 63 20 73 74 r rema) (conc st
6900: 72 20 22 7b 74 61 72 67 65 74 3a 22 20 74 61 72 r "{target:" tar
6910: 67 65 74 20 22 2c 20 72 75 6e 2d 6e 61 6d 65 3a get ", run-name:
6920: 22 20 72 75 6e 2d 6e 61 6d 65 20 22 2c 20 72 75 " run-name ", ru
6930: 6e 2d 74 69 6d 65 3a 22 20 72 75 6e 2d 74 69 6d n-time:" run-tim
6940: 65 20 22 7d 22 29 29 29 29 29 29 0a 0a 28 64 65 e "}"))))))..(de
6950: 66 69 6e 65 20 28 74 61 73 6b 3a 67 65 74 2d 72 fine (task:get-r
6960: 75 6e 2d 74 69 6d 65 73 29 0a 20 20 20 28 6c 65 un-times). (le
6970: 74 2a 20 28 20 0a 20 20 20 20 20 20 20 20 20 20 t* ( .
6980: 20 28 72 75 6e 2d 70 61 74 74 20 28 69 66 20 28 (run-patt (if (
6990: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
69a0: 75 6e 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 un-patt").
69b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69c0: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
69d0: 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 20 20 20 "-run-patt").
69e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69f0: 20 20 20 20 20 22 25 22 29 29 0a 20 20 20 20 20 "%")).
6a00: 20 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 (target-pa
6a10: 74 74 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 tt (if (args:get
6a20: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 -arg "-target-pa
6a30: 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 tt").
6a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 (ar
6a50: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
6a60: 67 65 74 2d 70 61 74 74 22 29 0a 20 20 20 20 20 get-patt").
6a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a80: 20 20 20 22 25 22 29 29 0a 20 0a 20 20 20 20 20 "%")). .
6a90: 20 20 20 20 20 20 28 72 75 6e 2d 74 69 6d 65 73 (run-times
6aa0: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 74 (rmt:get-run-t
6ab0: 69 6d 65 73 20 20 72 75 6e 2d 70 61 74 74 20 74 imes run-patt t
6ac0: 61 72 67 65 74 2d 70 61 74 74 20 29 29 29 0a 20 arget-patt ))).
6ad0: 20 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 (if (eq? (leng
6ae0: 74 68 20 72 75 6e 2d 74 69 6d 65 73 29 20 30 29 th run-times) 0)
6af0: 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 . (begin.
6b00: 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 61 (print "Data
6b10: 20 6e 6f 74 20 66 6f 75 6e 64 21 21 22 29 0a 20 not found!!").
6b20: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a 20 (exit))).
6b30: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 (if (equal? (a
6b40: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 75 rgs:get-arg "-du
6b50: 6d 70 6d 6f 64 65 22 29 20 22 6a 73 6f 6e 22 29 mpmode") "json")
6b60: 0a 20 20 20 20 20 20 20 28 74 61 73 6b 3a 70 72 . (task:pr
6b70: 69 6e 74 2d 72 75 6e 74 69 6d 65 2d 61 73 2d 6a int-runtime-as-j
6b80: 73 6f 6e 20 72 75 6e 2d 74 69 6d 65 73 29 0a 20 son run-times).
6b90: 20 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 (if (equ
6ba0: 61 6c 3f 20 28 61 72 67 73 3a 67 65 74 2d 61 72 al? (args:get-ar
6bb0: 67 20 22 2d 64 75 6d 70 6d 6f 64 65 22 29 20 22 g "-dumpmode") "
6bc0: 63 73 76 22 29 0a 09 20 20 20 20 20 28 74 61 73 csv").. (tas
6bd0: 6b 3a 70 72 69 6e 74 2d 72 75 6e 74 69 6d 65 20 k:print-runtime
6be0: 72 75 6e 2d 74 69 6d 65 73 20 22 2c 22 29 0a 09 run-times ",")..
6bf0: 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 (task:print
6c00: 2d 72 75 6e 74 69 6d 65 20 72 75 6e 2d 74 69 6d -runtime run-tim
6c10: 65 73 20 22 20 20 22 29 29 29 29 29 0a 0a 0a 28 es " ")))))...(
6c20: 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 70 72 69 define (task:pri
6c30: 6e 74 2d 74 65 73 74 74 69 6d 65 20 74 65 73 74 nt-testtime test
6c40: 2d 74 69 6d 65 73 20 73 61 70 65 72 61 74 6f 72 -times saperator
6c50: 29 0a 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 ).(for-each.
6c60: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 74 69 (lambda (test-ti
6c70: 6d 65 2d 69 6e 66 6f 29 0a 20 20 20 20 20 28 6c me-info). (l
6c80: 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 et* ((test-name
6c90: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
6ca0: 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 30 29 29 0a t-time-info 0)).
6cb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
6cc0: 74 2d 74 69 6d 65 20 20 28 76 65 63 74 6f 72 2d t-time (vector-
6cd0: 72 65 66 20 74 65 73 74 2d 74 69 6d 65 2d 69 6e ref test-time-in
6ce0: 66 6f 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 fo 2)).
6cf0: 20 20 20 28 74 65 73 74 2d 69 74 65 6d 20 20 28 (test-item (
6d00: 69 66 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d if (eq? (string-
6d10: 6c 65 6e 67 74 68 20 28 76 65 63 74 6f 72 2d 72 length (vector-r
6d20: 65 66 20 74 65 73 74 2d 74 69 6d 65 2d 69 6e 66 ef test-time-inf
6d30: 6f 20 31 29 29 20 30 29 0a 20 20 20 20 20 20 20 o 1)) 0).
6d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d50: 20 20 20 20 20 20 20 20 22 4e 2f 41 22 0a 09 09 "N/A"...
6d60: 09 09 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 ..(vector-ref te
6d70: 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 31 29 29 st-time-info 1))
6d80: 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 69 6e )). (prin
6d90: 74 20 20 74 65 73 74 2d 6e 61 6d 65 20 73 61 70 t test-name sap
6da0: 65 72 61 74 6f 72 20 74 65 73 74 2d 69 74 65 6d erator test-item
6db0: 20 73 61 70 65 72 61 74 6f 72 20 74 65 73 74 2d saperator test-
6dc0: 74 69 6d 65 20 29 29 29 0a 20 20 20 74 65 73 74 time ))). test
6dd0: 2d 74 69 6d 65 73 29 29 0a 0a 28 64 65 66 69 6e -times))..(defin
6de0: 65 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 e (task:print-te
6df0: 73 74 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 sttime-as-json t
6e00: 65 73 74 2d 74 69 6d 65 73 29 0a 20 28 6c 65 74 est-times). (let
6e10: 20 6c 6f 6f 70 20 28 28 74 65 73 74 2d 74 69 6d loop ((test-tim
6e20: 65 2d 69 6e 66 6f 20 28 63 61 72 20 74 65 73 74 e-info (car test
6e30: 2d 74 69 6d 65 73 29 29 0a 20 20 20 20 20 20 20 -times)).
6e40: 20 20 20 20 20 28 72 65 6d 61 20 28 63 64 72 20 (rema (cdr
6e50: 74 65 73 74 2d 74 69 6d 65 73 29 29 20 0a 20 20 test-times)) .
6e60: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 20 22 (str "
6e70: 22 29 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 ")). (let* (
6e80: 28 74 65 73 74 2d 6e 61 6d 65 20 20 28 76 65 63 (test-name (vec
6e90: 74 6f 72 2d 72 65 66 20 74 65 73 74 2d 74 69 6d tor-ref test-tim
6ea0: 65 2d 69 6e 66 6f 20 30 29 29 0a 20 20 20 20 20 e-info 0)).
6eb0: 20 20 20 20 20 20 20 28 74 65 73 74 2d 74 69 6d (test-tim
6ec0: 65 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 e (vector-ref t
6ed0: 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 32 29 est-time-info 2)
6ee0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
6ef0: 74 65 6d 20 20 28 76 65 63 74 6f 72 2d 72 65 66 tem (vector-ref
6f00: 20 74 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 test-time-info
6f10: 31 29 29 29 0a 20 20 20 20 20 20 20 20 3b 28 70 1))). ;(p
6f20: 72 69 6e 74 20 28 6e 6f 74 20 28 65 71 75 61 6c rint (not (equal
6f30: 3f 20 73 74 72 20 22 22 29 29 29 0a 20 20 20 20 ? str ""))).
6f40: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
6f50: 75 61 6c 3f 20 73 74 72 20 22 22 29 29 20 0a 20 ual? str "")) .
6f60: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
6f70: 20 73 74 72 20 28 63 6f 6e 63 20 73 74 72 20 22 str (conc str "
6f80: 2c 22 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 ,"))). (i
6f90: 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 61 29 0a 09 f (null? rema)..
6fa0: 09 28 70 72 69 6e 74 20 22 5b 22 20 73 74 72 20 .(print "[" str
6fb0: 22 7b 74 65 73 74 2d 6e 61 6d 65 3a 22 20 74 65 "{test-name:" te
6fc0: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
6fd0: 70 61 74 68 3a 22 20 69 74 65 6d 20 22 2c 20 74 path:" item ", t
6fe0: 65 73 74 2d 74 69 6d 65 3a 22 20 74 65 73 74 2d est-time:" test-
6ff0: 74 69 6d 65 20 22 7d 5d 22 29 0a 20 20 20 20 20 time "}]").
7000: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 (loop (ca
7010: 72 20 72 65 6d 61 29 20 28 63 64 72 20 72 65 6d r rema) (cdr rem
7020: 61 29 20 28 63 6f 6e 63 20 73 74 72 20 22 7b 74 a) (conc str "{t
7030: 65 73 74 2d 6e 61 6d 65 3a 22 20 74 65 73 74 2d est-name:" test-
7040: 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 name ", item-pat
7050: 68 3a 22 20 69 74 65 6d 20 22 2c 20 74 65 73 74 h:" item ", test
7060: 2d 74 69 6d 65 3a 22 20 74 65 73 74 2d 74 69 6d -time:" test-tim
7070: 65 20 22 7d 22 29 29 29 29 29 29 0a 0a 0a 20 28 e "}"))))))... (
7080: 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 67 65 74 define (task:get
7090: 2d 74 65 73 74 2d 74 69 6d 65 73 29 0a 20 20 20 -test-times).
70a0: 28 6c 65 74 2a 20 28 28 72 75 6e 6e 61 6d 65 20 (let* ((runname
70b0: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
70c0: 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 20 20 g "-runname").
70d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70e0: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
70f0: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
7100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7110: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 #f)).
7120: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 (target
7130: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
7140: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 20 g "-target").
7150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7160: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
7170: 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 rg "-target").
7180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7190: 20 20 20 20 20 20 23 66 29 29 0a 20 0a 20 20 20 #f)). .
71a0: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 74 69 (test-ti
71b0: 6d 65 73 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 mes (rmt:get-te
71c0: 73 74 2d 74 69 6d 65 73 20 20 72 75 6e 6e 61 6d st-times runnam
71d0: 65 20 74 61 72 67 65 74 20 29 29 29 0a 20 20 20 e target ))).
71e0: 28 69 66 20 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 (if (not runname
71f0: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
7200: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 (print "Err
7210: 6f 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 or: Missing argu
7220: 6d 65 6e 74 20 2d 72 75 6e 6e 61 6d 65 22 29 0a ment -runname").
7230: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 20 0a (exit))) .
7240: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d (if (string-
7250: 63 6f 6e 74 61 69 6e 73 20 72 75 6e 6e 61 6d 65 contains runname
7260: 20 22 25 22 29 0a 20 20 20 20 20 20 28 62 65 67 "%"). (beg
7270: 69 6e 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 in. (print
7280: 22 45 72 72 6f 72 3a 20 49 6e 76 61 6c 69 64 20 "Error: Invalid
7290: 72 75 6e 6e 61 6d 65 2c 20 27 25 27 20 6e 6f 74 runname, '%' not
72a0: 20 61 6c 6c 6f 77 65 64 20 20 28 22 20 72 75 6e allowed (" run
72b0: 6e 61 6d 65 20 22 29 20 22 29 0a 20 20 20 20 20 name ") ").
72c0: 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 69 (exit))). (i
72d0: 66 20 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 f (not target).
72e0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
72f0: 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f 72 3a (print "Error:
7300: 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d 65 6e Missing argumen
7310: 74 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 t -target").
7320: 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 20 (exit))).
7330: 28 69 66 20 20 28 73 74 72 69 6e 67 2d 63 6f 6e (if (string-con
7340: 74 61 69 6e 73 20 74 61 72 67 65 74 20 22 25 22 tains target "%"
7350: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
7360: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 (print "Err
7370: 6f 72 3a 20 49 6e 76 61 6c 69 64 20 74 61 72 67 or: Invalid targ
7380: 65 74 2c 20 27 25 27 20 6e 6f 74 20 61 6c 6c 6f et, '%' not allo
7390: 77 65 64 20 20 28 22 20 74 61 72 67 65 74 20 22 wed (" target "
73a0: 29 20 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 ) "). (exit
73b0: 29 29 29 0a 20 0a 20 20 20 28 69 66 20 28 65 71 ))). . (if (eq
73c0: 3f 20 28 6c 65 6e 67 74 68 20 74 65 73 74 2d 74 ? (length test-t
73d0: 69 6d 65 73 29 20 30 29 0a 20 20 20 20 20 28 62 imes) 0). (b
73e0: 65 67 69 6e 0a 20 20 20 20 20 20 20 28 70 72 69 egin. (pri
73f0: 6e 74 20 22 44 61 74 61 20 6e 6f 74 20 66 6f 75 nt "Data not fou
7400: 6e 64 21 21 22 29 0a 20 20 20 20 20 20 20 28 65 nd!!"). (e
7410: 78 69 74 29 29 29 0a 20 20 20 28 69 66 20 28 65 xit))). (if (e
7420: 71 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 74 2d qual? (args:get-
7430: 61 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 22 29 arg "-dumpmode")
7440: 20 22 6a 73 6f 6e 22 29 0a 20 20 20 20 20 20 20 "json").
7450: 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 74 (task:print-test
7460: 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 65 73 time-as-json tes
7470: 74 2d 74 69 6d 65 73 29 0a 20 20 20 20 20 20 20 t-times).
7480: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 (if (equal? (a
7490: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 75 rgs:get-arg "-du
74a0: 6d 70 6d 6f 64 65 22 29 20 22 63 73 76 22 29 0a mpmode") "csv").
74b0: 09 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 6e . (task:prin
74c0: 74 2d 74 65 73 74 74 69 6d 65 20 74 65 73 74 2d t-testtime test-
74d0: 74 69 6d 65 73 20 22 2c 22 29 0a 09 20 20 20 20 times ",")..
74e0: 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 (task:print-tes
74f0: 74 74 69 6d 65 20 74 65 73 74 2d 74 69 6d 65 73 ttime test-times
7500: 20 22 20 20 22 29 29 29 29 29 0a 0a 0a 0a 3b 3b " ")))))....;;
7510: 20 67 65 74 73 20 6d 74 70 67 2d 72 75 6e 2d 69 gets mtpg-run-i
7520: 64 20 61 6e 64 20 73 79 6e 63 73 20 74 68 65 20 d and syncs the
7530: 72 65 63 6f 72 64 20 69 66 20 64 69 66 66 65 72 record if differ
7540: 65 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ent.;;.(define (
7550: 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 tasks:run-id->mt
7560: 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 61 pg-run-id dbh ca
7570: 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 ched-info run-id
7580: 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c area-info small
7590: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
75a0: 74 69 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 time). (let* ((
75b0: 72 75 6e 73 2d 68 74 20 28 68 61 73 68 2d 74 61 runs-ht (hash-ta
75c0: 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 ble-ref cached-i
75d0: 6e 66 6f 20 27 72 75 6e 73 29 29 0a 09 20 28 72 nfo 'runs)).. (r
75e0: 75 6e 69 6e 66 20 20 28 68 61 73 68 2d 74 61 62 uninf (hash-tab
75f0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
7600: 75 6e 73 2d 68 74 20 72 75 6e 2d 69 64 20 23 66 uns-ht run-id #f
7610: 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 )). (are
7620: 61 2d 69 64 20 28 76 65 63 74 6f 72 2d 72 65 66 a-id (vector-ref
7630: 20 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 29 0a area-info 0))).
7640: 20 20 20 20 20 20 20 28 69 66 20 72 75 6e 69 6e (if runin
7650: 66 0a 09 72 75 6e 69 6e 66 20 3b 3b 20 61 6c 72 f..runinf ;; alr
7660: 65 61 64 79 20 63 61 63 68 65 64 0a 09 28 6c 65 eady cached..(le
7670: 74 2a 20 28 28 72 75 6e 2d 64 61 74 20 20 20 20 t* ((run-dat
7680: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 (rmt:get-run-inf
7690: 6f 20 72 75 6e 2d 69 64 29 29 20 20 20 20 20 20 o run-id))
76a0: 20 20 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 ;; NOTE
76b0: 3a 20 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 : get-run-info r
76c0: 65 74 75 72 6e 73 20 61 20 76 65 63 74 6f 72 20 eturns a vector
76d0: 3c 20 72 6f 77 20 68 65 61 64 65 72 20 3e 0a 09 < row header >..
76e0: 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 (run-name
76f0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d (rmt:get-run-
7700: 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e name-from-id run
7710: 2d 69 64 29 29 0a 09 20 20 20 20 20 20 20 28 72 -id)).. (r
7720: 6f 77 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 ow (db:ge
7730: 74 2d 72 6f 77 73 20 72 75 6e 2d 64 61 74 29 29 t-rows run-dat))
7740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7750: 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 ;; yes, this
7760: 72 65 74 75 72 6e 73 20 61 20 73 69 6e 67 6c 65 returns a single
7770: 20 72 6f 77 0a 09 20 20 20 20 20 20 20 28 68 65 row.. (he
7780: 61 64 65 72 20 20 20 20 20 28 64 62 3a 67 65 74 ader (db:get
7790: 2d 68 65 61 64 65 72 20 72 75 6e 2d 64 61 74 29 -header run-dat)
77a0: 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 65 ).. (state
77b0: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 (db:get-va
77c0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f lue-by-header ro
77d0: 77 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 w header "state"
77e0: 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 )).. (stat
77f0: 75 73 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 us (db:get-v
7800: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
7810: 6f 77 20 68 65 61 64 65 72 20 22 73 74 61 74 75 ow header "statu
7820: 73 22 29 29 0a 09 20 20 20 20 20 20 20 28 6f 77 s")).. (ow
7830: 6e 65 72 20 20 20 20 20 20 28 64 62 3a 67 65 74 ner (db:get
7840: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
7850: 20 72 6f 77 20 68 65 61 64 65 72 20 22 6f 77 6e row header "own
7860: 65 72 22 29 29 0a 09 20 20 20 20 20 20 20 28 65 er")).. (e
7870: 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a 67 65 vent-time (db:ge
7880: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
7890: 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 65 76 r row header "ev
78a0: 65 6e 74 5f 74 69 6d 65 22 29 29 0a 09 20 20 20 ent_time"))..
78b0: 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 (comment
78c0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
78d0: 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 -header row head
78e0: 65 72 20 22 63 6f 6d 6d 65 6e 74 22 29 29 0a 09 er "comment"))..
78f0: 20 20 20 20 20 20 20 28 66 61 69 6c 2d 63 6f 75 (fail-cou
7900: 6e 74 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 nt (db:get-value
7910: 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 -by-header row h
7920: 65 61 64 65 72 20 22 66 61 69 6c 5f 63 6f 75 6e eader "fail_coun
7930: 74 22 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 t")).. (pa
7940: 73 73 2d 63 6f 75 6e 74 20 28 64 62 3a 67 65 74 ss-count (db:get
7950: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
7960: 20 72 6f 77 20 68 65 61 64 65 72 20 22 70 61 73 row header "pas
7970: 73 5f 63 6f 75 6e 74 22 29 29 0a 20 20 20 20 20 s_count")).
7980: 20 20 20 20 20 20 20 20 20 20 28 64 62 2d 63 6f (db-co
7990: 6e 74 6f 75 72 20 28 64 62 3a 67 65 74 2d 76 61 ntour (db:get-va
79a0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f lue-by-header ro
79b0: 77 20 68 65 61 64 65 72 20 22 63 6f 6e 74 6f 75 w header "contou
79c0: 72 22 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f r")).. (co
79d0: 6e 74 6f 75 72 20 20 20 20 28 69 66 20 28 61 72 ntour (if (ar
79e0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
79f0: 70 65 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 20 0a pend-contour") .
7a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a20: 20 28 69 66 20 28 61 6e 64 20 64 62 2d 63 6f 6e (if (and db-con
7a30: 74 6f 75 72 20 28 6e 6f 74 20 28 65 71 75 61 6c tour (not (equal
7a40: 3f 20 64 62 2d 63 6f 6e 74 6f 75 72 20 22 22 29 ? db-contour "")
7a50: 29 20 20 28 73 74 72 69 6e 67 3f 20 64 62 2d 63 ) (string? db-c
7a60: 6f 6e 74 6f 75 72 20 29 29 20 0a 20 20 20 20 20 ontour )) .
7a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a90: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ac0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
7ad0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a :print-info 10 *
7ae0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7af0: 2a 20 20 22 64 62 2d 63 6f 6e 74 6f 75 72 22 20 * "db-contour"
7b00: 64 62 2d 63 6f 6e 74 6f 75 72 29 20 0a 20 09 09 db-contour) . ..
7b10: 09 09 09 09 64 62 2d 63 6f 6e 74 6f 75 72 29 0a ....db-contour).
7b20: 09 09 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 ..... (args:g
7b30: 65 74 2d 61 72 67 20 22 2d 63 6f 6e 74 6f 75 72 et-arg "-contour
7b40: 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ")))).
7b50: 20 20 20 20 20 28 72 75 6e 2d 74 61 67 20 28 69 (run-tag (i
7b60: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
7b70: 22 2d 72 75 6e 2d 74 61 67 22 29 0a 20 20 20 20 "-run-tag").
7b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b90: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
7ba0: 74 2d 61 72 67 20 22 2d 72 75 6e 2d 74 61 67 22 t-arg "-run-tag"
7bb0: 29 0a 09 09 09 09 09 09 09 09 09 22 22 29 29 0a ).........."")).
7bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7bd0: 6c 61 73 74 2d 75 70 64 61 74 65 20 28 64 62 3a last-update (db:
7be0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
7bf0: 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 der row header "
7c00: 6c 61 73 74 5f 75 70 64 61 74 65 22 29 29 0a 09 last_update"))..
7c10: 20 20 20 20 20 20 20 28 6b 65 79 74 61 72 67 20 (keytarg
7c20: 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 67 73 (if (or (args
7c30: 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 :get-arg "-prepe
7c40: 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 20 28 61 72 nd-contour") (ar
7c50: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
7c60: 66 69 78 2d 74 61 72 67 65 74 22 29 29 0a 09 20 fix-target"))..
7c70: 20 20 20 20 20 20 09 09 09 28 63 6f 6e 63 20 22 ...(conc "
7c80: 4d 54 5f 43 4f 4e 54 4f 55 52 2f 4d 54 5f 41 52 MT_CONTOUR/MT_AR
7c90: 45 41 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 EA/" (string-int
7ca0: 65 72 73 70 65 72 73 65 20 28 72 6d 74 3a 67 65 ersperse (rmt:ge
7cb0: 74 2d 6b 65 79 73 29 20 22 2f 22 29 29 20 28 73 t-keys) "/")) (s
7cc0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7cd0: 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 e (rmt:get-keys)
7ce0: 20 22 2f 22 29 29 29 20 3b 3b 20 65 2e 67 2e 20 "/"))) ;; e.g.
7cf0: 76 65 72 73 69 6f 6e 2f 69 74 65 72 61 74 69 6f version/iteratio
7d00: 6e 2f 70 6c 61 74 66 6f 72 6d 0a 20 20 20 20 20 n/platform.
7d10: 20 20 20 20 20 20 20 20 20 20 28 62 61 73 65 2d (base-
7d20: 74 61 72 67 65 74 20 20 20 20 20 20 28 72 6d 74 target (rmt
7d30: 3a 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d :get-target run-
7d40: 69 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 61 id)).. (ta
7d50: 72 67 65 74 20 20 20 20 20 28 69 66 20 28 6f 72 rget (if (or
7d60: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7d70: 2d 70 72 65 70 65 6e 64 2d 63 6f 6e 74 6f 75 72 -prepend-contour
7d80: 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ") (args:get-arg
7d90: 20 22 2d 70 72 65 66 69 78 2d 74 61 72 67 65 74 "-prefix-target
7da0: 22 29 29 20 0a 09 20 20 20 20 20 20 20 09 09 09 ")) .. ...
7db0: 28 63 6f 6e 63 20 28 6f 72 20 28 61 72 67 73 3a (conc (or (args:
7dc0: 67 65 74 2d 61 72 67 20 22 2d 70 72 65 66 69 78 get-arg "-prefix
7dd0: 2d 74 61 72 67 65 74 22 29 20 28 63 6f 6e 63 20 -target") (conc
7de0: 63 6f 6e 74 6f 75 72 20 22 2f 22 20 28 63 6f 6d contour "/" (com
7df0: 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d mon:get-area-nam
7e00: 65 29 20 22 2f 22 29 29 20 62 61 73 65 2d 74 61 e) "/")) base-ta
7e10: 72 67 65 74 29 20 62 61 73 65 2d 74 61 72 67 65 rget) base-targe
7e20: 74 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 t))
7e30: 20 20 20 20 3b 3b 20 65 2e 67 2e 20 76 31 2e 36 ;; e.g. v1.6
7e40: 33 2f 61 33 65 31 2f 75 62 75 6e 74 75 0a 09 20 3/a3e1/ubuntu..
7e50: 20 20 20 20 20 20 28 73 70 65 63 2d 69 64 20 20 (spec-id
7e60: 20 20 28 70 67 64 62 3a 67 65 74 2d 74 74 79 70 (pgdb:get-ttyp
7e70: 65 20 64 62 68 20 6b 65 79 74 61 72 67 29 29 0a e dbh keytarg)).
7e80: 09 20 20 20 20 20 20 20 28 70 75 62 6c 69 73 68 . (publish
7e90: 2d 74 69 6d 65 20 28 69 66 20 28 61 72 67 73 3a -time (if (args:
7ea0: 67 65 74 2d 61 72 67 20 22 2d 63 70 2d 65 76 65 get-arg "-cp-eve
7eb0: 6e 74 74 69 6d 65 2d 74 6f 2d 70 75 62 6c 69 73 nttime-to-publis
7ec0: 68 74 69 6d 65 22 29 0a 20 20 20 20 20 20 20 20 htime").
7ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ee0: 20 20 20 20 65 76 65 6e 74 2d 74 69 6d 65 0a 20 event-time.
7ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f00: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
7f10: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 20 0a 09 nt-seconds))) ..
7f20: 20 20 20 20 20 20 20 28 6e 65 77 2d 72 75 6e 2d (new-run-
7f30: 69 64 20 28 69 66 20 28 61 6e 64 20 72 75 6e 2d id (if (and run-
7f40: 6e 61 6d 65 20 62 61 73 65 2d 74 61 72 67 65 74 name base-target
7f50: 29 20 28 70 67 64 62 3a 67 65 74 2d 72 75 6e 2d ) (pgdb:get-run-
7f60: 69 64 20 64 62 68 20 73 70 65 63 2d 69 64 20 74 id dbh spec-id t
7f70: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 61 arget run-name a
7f80: 72 65 61 2d 69 64 29 20 23 66 29 29 29 0a 20 20 rea-id) #f))).
7f90: 20 20 20 20 20 20 20 28 69 66 20 6e 65 77 2d 72 (if new-r
7fa0: 75 6e 2d 69 64 0a 09 20 20 20 20 20 20 20 20 20 un-id..
7fb0: 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 20 28 28 (begin ;; let ((
7fc0: 72 75 6e 2d 72 65 63 6f 72 64 20 28 70 67 64 62 run-record (pgdb
7fd0: 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 64 62 :get-run-info db
7fe0: 68 20 6e 65 77 2d 72 75 6e 2d 69 64 29 29 0a 09 h new-run-id))..
7ff0: 09 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 . (hash-t
8000: 61 62 6c 65 2d 73 65 74 21 20 72 75 6e 73 2d 68 able-set! runs-h
8010: 74 20 72 75 6e 2d 69 64 20 6e 65 77 2d 72 75 6e t run-id new-run
8020: 2d 69 64 29 0a 09 09 3b 3b 20 65 6e 73 75 72 65 -id)...;; ensure
8030: 20 6b 65 79 20 66 69 65 6c 64 73 20 61 72 65 20 key fields are
8040: 75 70 20 74 6f 20 64 61 74 65 0a 20 20 20 20 20 up to date.
8050: 3b 3b 20 69 66 20 6c 61 73 74 5f 75 70 64 61 74 ;; if last_updat
8060: 65 20 3d 3d 20 70 67 64 62 5f 6c 61 73 74 5f 75 e == pgdb_last_u
8070: 70 64 61 74 65 20 64 6f 20 6e 6f 74 20 75 70 64 pdate do not upd
8080: 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 ate smallest-las
8090: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 20 0a t-update-time .
80a0: 20 20 20 20 28 6c 65 74 2a 20 28 28 70 67 64 62 (let* ((pgdb
80b0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 28 70 67 -last-update (pg
80c0: 64 62 3a 67 65 74 2d 72 75 6e 2d 6c 61 73 74 2d db:get-run-last-
80d0: 75 70 64 61 74 65 20 64 62 68 20 6e 65 77 2d 72 update dbh new-r
80e0: 75 6e 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 un-id)).
80f0: 20 20 20 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d (smallest-tim
8100: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
8110: 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 f/default smalle
8120: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
8130: 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 ime "smallest-ti
8140: 6d 65 22 20 23 66 29 29 29 0a 20 20 20 20 20 28 me" #f))). (
8150: 69 66 20 28 61 6e 64 20 20 28 3e 20 6c 61 73 74 if (and (> last
8160: 2d 75 70 64 61 74 65 20 70 67 64 62 2d 6c 61 73 -update pgdb-las
8170: 74 2d 75 70 64 61 74 65 29 20 28 6f 72 20 28 6e t-update) (or (n
8180: 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 ot smallest-time
8190: 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 74 65 ) (< last-update
81a0: 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 29 smallest-time))
81b0: 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ). (hash-
81c0: 74 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c table-set! small
81d0: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
81e0: 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 time "smallest-t
81f0: 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 74 65 ime" last-update
8200: 29 29 29 0a 09 09 28 70 67 64 62 3a 72 65 66 72 )))...(pgdb:refr
8210: 65 73 68 2d 72 75 6e 2d 69 6e 66 6f 0a 09 09 20 esh-run-info...
8220: 64 62 68 0a 09 09 20 6e 65 77 2d 72 75 6e 2d 69 dbh... new-run-i
8230: 64 0a 09 09 20 73 74 61 74 65 20 73 74 61 74 75 d... state statu
8240: 73 20 6f 77 6e 65 72 20 65 76 65 6e 74 2d 74 69 s owner event-ti
8250: 6d 65 20 63 6f 6d 6d 65 6e 74 20 66 61 69 6c 2d me comment fail-
8260: 63 6f 75 6e 74 20 70 61 73 73 2d 63 6f 75 6e 74 count pass-count
8270: 20 61 72 65 61 2d 69 64 20 6c 61 73 74 2d 75 70 area-id last-up
8280: 64 61 74 65 20 70 75 62 6c 69 73 68 2d 74 69 6d date publish-tim
8290: 65 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 e). (debug:p
82a0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
82b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
82c0: 57 6f 72 6b 69 6e 67 20 6f 6e 20 72 75 6e 2d 69 Working on run-i
82d0: 64 20 22 20 72 75 6e 2d 69 64 20 22 20 70 67 64 d " run-id " pgd
82e0: 62 2d 69 64 20 22 20 20 6e 65 77 2d 72 75 6e 2d b-id " new-run-
82f0: 69 64 20 29 0a 20 20 20 20 20 28 69 66 20 28 6e id ). (if (n
8300: 6f 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 74 ot (equal? run-t
8310: 61 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 ag "")). (t
8320: 61 73 6b 3a 61 64 64 2d 72 75 6e 2d 74 61 67 20 ask:add-run-tag
8330: 64 62 68 20 6e 65 77 2d 72 75 6e 2d 69 64 20 72 dbh new-run-id r
8340: 75 6e 2d 74 61 67 29 29 0a 09 09 6e 65 77 2d 72 un-tag))...new-r
8350: 75 6e 2d 69 64 29 20 0a 20 20 20 20 20 20 0a 09 un-id) . ..
8360: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e (if (or (n
8370: 6f 74 20 73 74 61 74 65 29 20 28 65 71 75 61 6c ot state) (equal
8380: 3f 20 73 74 61 74 65 20 22 64 65 6c 65 74 65 64 ? state "deleted
8390: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 62 ")). (b
83a0: 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 egin .
83b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
83c0: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
83d0: 2d 70 6f 72 74 2a 20 20 22 57 61 72 6e 69 6e 67 -port* "Warning
83e0: 3a 20 52 75 6e 20 77 69 74 68 20 69 64 20 22 20 : Run with id "
83f0: 72 75 6e 2d 69 64 20 22 20 77 61 73 20 63 72 65 run-id " was cre
8400: 61 74 65 64 20 61 66 74 65 72 20 70 72 65 76 69 ated after previ
8410: 6f 75 73 20 73 79 6e 63 20 61 6e 64 20 64 65 6c ous sync and del
8420: 65 74 65 64 20 62 65 66 6f 72 65 20 74 68 65 20 eted before the
8430: 73 79 6e 63 22 29 20 23 66 29 0a 20 20 20 20 20 sync") #f).
8440: 20 20 20 20 20 28 69 66 20 28 68 61 6e 64 6c 65 (if (handle
8450: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 -exceptions...
8460: 20 20 20 20 20 20 65 78 6e 0a 09 09 20 20 20 20 exn...
8470: 20 20 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e (begin (prin
8480: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 t-call-chain).
8490: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
84a0: 6e 74 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 nt ((condition-p
84b0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
84c0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
84d0: 65 78 6e 29 29 20 20 20 20 20 0a 09 09 09 20 20 exn)) ....
84e0: 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 #f).
84f0: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
8500: 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d 72 75 (pgdb:insert-ru
8510: 6e 0a 09 09 20 20 20 20 20 64 62 68 0a 09 09 20 n... dbh...
8520: 20 20 20 20 73 70 65 63 2d 69 64 20 74 61 72 67 spec-id targ
8530: 65 74 20 72 75 6e 2d 6e 61 6d 65 20 73 74 61 74 et run-name stat
8540: 65 20 73 74 61 74 75 73 20 6f 77 6e 65 72 20 65 e status owner e
8550: 76 65 6e 74 2d 74 69 6d 65 20 63 6f 6d 6d 65 6e vent-time commen
8560: 74 20 66 61 69 6c 2d 63 6f 75 6e 74 20 70 61 73 t fail-count pas
8570: 73 2d 63 6f 75 6e 74 20 20 61 72 65 61 2d 69 64 s-count area-id
8580: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 75 62 last-update pub
8590: 6c 69 73 68 2d 74 69 6d 65 29 29 0a 09 09 20 20 lish-time))...
85a0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6d 61 (let* ((sma
85b0: 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 llest-time (hash
85c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
85d0: 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 lt smallest-last
85e0: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d -update-time "sm
85f0: 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 allest-time" #f)
8600: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8610: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 (if (or (not sma
8620: 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c llest-time) (< l
8630: 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c ast-update small
8640: 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 est-time)).
8650: 20 20 20 09 09 09 09 28 68 61 73 68 2d 74 61 62 ....(hash-tab
8660: 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 le-set! smallest
8670: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d -last-update-tim
8680: 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 e "smallest-time
8690: 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a " last-update)).
86a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
86b0: 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 sks:run-id->mtpg
86c0: 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 -run-id dbh cach
86d0: 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 ed-info run-id a
86e0: 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 rea-info smalles
86f0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 t-last-update-ti
8700: 6d 65 29 29 0a 09 09 20 20 23 66 29 29 29 29 29 me))... #f)))))
8710: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ))..(define (tas
8720: 6b 3a 61 64 64 2d 72 75 6e 2d 74 61 67 20 64 62 k:add-run-tag db
8730: 68 20 72 75 6e 2d 69 64 20 74 61 67 29 20 0a 20 h run-id tag) .
8740: 20 28 6c 65 74 2a 20 28 28 74 61 67 2d 69 6e 66 (let* ((tag-inf
8750: 6f 20 28 70 67 64 62 3a 67 65 74 2d 74 61 67 2d o (pgdb:get-tag-
8760: 69 6e 66 6f 2d 62 79 2d 6e 61 6d 65 20 64 62 68 info-by-name dbh
8770: 20 74 61 67 29 29 29 0a 20 20 20 28 69 66 20 28 tag))). (if (
8780: 6e 6f 74 20 74 61 67 2d 69 6e 66 6f 29 0a 20 20 not tag-info).
8790: 20 20 20 28 62 65 67 69 6e 20 20 20 0a 20 20 20 (begin .
87a0: 20 20 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 78 (if (handle-ex
87b0: 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e ceptions.. exn
87c0: 0a 09 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 .. (begin .
87d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
87e0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
87f0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8800: 74 2a 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d t* ((condition-
8810: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
8820: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
8830: 20 65 78 6e 29 29 20 20 20 20 20 0a 09 20 20 20 exn)) ..
8840: 23 66 29 0a 09 20 20 20 28 70 67 64 62 3a 69 6e #f).. (pgdb:in
8850: 73 65 72 74 2d 74 61 67 20 20 64 62 68 20 20 20 sert-tag dbh
8860: 74 61 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 tag)).
8870: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
8880: 74 21 20 74 61 67 2d 69 6e 66 6f 20 28 70 67 64 t! tag-info (pgd
8890: 62 3a 67 65 74 2d 74 61 67 2d 69 6e 66 6f 2d 62 b:get-tag-info-b
88a0: 79 2d 6e 61 6d 65 20 64 62 68 20 74 61 67 29 29 y-name dbh tag))
88b0: 0a 09 09 20 20 23 66 29 29 29 0a 20 20 20 20 20 ... #f))).
88c0: 3b 3b 61 64 64 20 74 6f 20 61 72 65 61 5f 74 61 ;;add to area_ta
88d0: 67 73 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 2d gs. (handle-
88e0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 exceptions.. e
88f0: 78 6e 0a 09 20 20 20 28 62 65 67 69 6e 20 0a 20 xn.. (begin .
8900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
8910: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8920: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
8930: 6f 72 74 2a 20 20 28 28 63 6f 6e 64 69 74 69 6f ort* ((conditio
8940: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
8950: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
8960: 65 29 20 65 78 6e 29 29 20 20 20 20 20 0a 09 20 e) exn)) ..
8970: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
8980: 20 28 69 66 20 28 6e 6f 74 20 28 70 67 64 62 3a (if (not (pgdb:
8990: 69 73 2d 72 75 6e 2d 74 61 67 65 64 2d 77 69 74 is-run-taged-wit
89a0: 68 2d 61 2d 74 61 67 20 64 62 68 20 28 76 65 63 h-a-tag dbh (vec
89b0: 74 6f 72 2d 72 65 66 20 74 61 67 2d 69 6e 66 6f tor-ref tag-info
89c0: 20 30 29 20 20 72 75 6e 2d 69 64 29 29 20 20 0a 0) run-id)) .
89d0: 09 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 . (pgdb:insert
89e0: 2d 72 75 6e 2d 74 61 67 20 20 64 62 68 20 20 20 -run-tag dbh
89f0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 61 67 2d (vector-ref tag-
8a00: 69 6e 66 6f 20 30 29 20 20 72 75 6e 2d 69 64 29 info 0) run-id)
8a10: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
8a20: 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 2d tasks:sync-test-
8a30: 73 74 65 70 73 20 64 62 68 20 63 61 63 68 65 64 steps dbh cached
8a40: 2d 69 6e 66 6f 20 74 65 73 74 2d 73 74 65 70 2d -info test-step-
8a50: 69 64 73 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 ids smallest-las
8a60: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 0a 20 t-update-time).
8a70: 3b 20 28 70 72 69 6e 74 20 22 53 79 6e 63 20 53 ; (print "Sync S
8a80: 74 65 70 73 20 22 20 74 65 73 74 2d 73 74 65 70 teps " test-step
8a90: 2d 69 64 73 20 29 0a 20 20 28 6c 65 74 20 28 28 -ids ). (let ((
8aa0: 74 65 73 74 2d 68 74 20 28 68 61 73 68 2d 74 61 test-ht (hash-ta
8ab0: 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 ble-ref cached-i
8ac0: 6e 66 6f 20 27 74 65 73 74 73 29 29 0a 20 20 20 nfo 'tests)).
8ad0: 20 20 20 20 20 28 73 74 65 70 2d 68 74 20 28 68 (step-ht (h
8ae0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 ash-table-ref ca
8af0: 63 68 65 64 2d 69 6e 66 6f 20 27 73 74 65 70 73 ched-info 'steps
8b00: 29 29 0a 20 20 20 20 20 20 20 20 28 72 75 6e 2d )). (run-
8b10: 69 64 2d 69 6e 20 23 66 29 0a 20 20 20 20 20 20 id-in #f).
8b20: 20 20 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ). (for-eac
8b30: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
8b40: 74 65 73 74 2d 73 74 65 70 2d 69 64 29 0a 20 20 test-step-id).
8b50: 20 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 2d (set! run-
8b60: 69 64 2d 69 6e 20 28 63 64 72 20 74 65 73 74 2d id-in (cdr test-
8b70: 73 74 65 70 2d 69 64 29 29 0a 20 20 20 20 20 20 step-id)).
8b80: 20 20 28 73 65 74 21 20 74 65 73 74 2d 73 74 65 (set! test-ste
8b90: 70 2d 69 64 20 28 63 61 72 20 74 65 73 74 2d 73 p-id (car test-s
8ba0: 74 65 70 2d 69 64 29 29 0a 20 0a 0a 20 20 20 20 tep-id)). ..
8bb0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
8bc0: 2d 73 74 65 70 2d 69 6e 66 6f 20 20 28 72 6d 74 -step-info (rmt
8bd0: 3a 67 65 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d :get-steps-info-
8be0: 62 79 2d 69 64 20 72 75 6e 2d 69 64 2d 69 6e 20 by-id run-id-in
8bf0: 74 65 73 74 2d 73 74 65 70 2d 69 64 29 29 0a 20 test-step-id)).
8c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
8c10: 74 65 70 2d 69 64 20 28 74 64 62 3a 73 74 65 70 tep-id (tdb:step
8c20: 2d 67 65 74 2d 69 64 20 74 65 73 74 2d 73 74 65 -get-id test-ste
8c30: 70 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 p-info)).
8c40: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 (test-id
8c50: 20 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d (tdb:step-get-
8c60: 74 65 73 74 5f 69 64 20 20 20 20 74 65 73 74 2d test_id test-
8c70: 73 74 65 70 2d 69 6e 66 6f 29 29 20 20 20 0a 09 step-info)) ..
8c80: 20 20 20 20 20 20 20 28 73 74 65 70 6e 61 6d 65 (stepname
8c90: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
8ca0: 74 65 70 6e 61 6d 65 20 20 74 65 73 74 2d 73 74 tepname test-st
8cb0: 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 ep-info))..
8cc0: 20 20 28 73 74 61 74 65 20 28 74 64 62 3a 73 74 (state (tdb:st
8cd0: 65 70 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 ep-get-state tes
8ce0: 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 09 0a 09 t-step-info))...
8cf0: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 28 (status (
8d00: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
8d10: 74 75 73 20 74 65 73 74 2d 73 74 65 70 2d 69 6e tus test-step-in
8d20: 66 6f 29 29 09 0a 09 20 20 20 20 20 20 20 28 65 fo))... (e
8d30: 76 65 6e 74 5f 74 69 6d 65 20 28 74 64 62 3a 73 vent_time (tdb:s
8d40: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
8d50: 6d 65 20 20 74 65 73 74 2d 73 74 65 70 2d 69 6e me test-step-in
8d60: 66 6f 29 29 09 0a 09 20 20 20 20 20 20 20 28 63 fo))... (c
8d70: 6f 6d 6d 65 6e 74 20 20 28 74 64 62 3a 73 74 65 omment (tdb:ste
8d80: 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 74 65 p-get-comment te
8d90: 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 09 0a st-step-info))..
8da0: 09 20 20 20 20 20 20 20 28 6c 6f 67 66 69 6c 65 . (logfile
8db0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c (tdb:step-get-l
8dc0: 6f 67 66 69 6c 65 20 74 65 73 74 2d 73 74 65 70 ogfile test-step
8dd0: 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 20 -info))..
8de0: 20 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 28 (last-update (
8df0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 61 73 tdb:step-get-las
8e00: 74 5f 75 70 64 61 74 65 20 74 65 73 74 2d 73 74 t_update test-st
8e10: 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 ep-info))..
8e20: 20 20 28 70 67 64 62 2d 74 65 73 74 2d 69 64 20 (pgdb-test-id
8e30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8e40: 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 68 74 /default test-ht
8e50: 20 74 65 73 74 2d 69 64 20 23 66 29 29 0a 09 09 test-id #f))...
8e60: 09 09 20 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d .. (smallest-tim
8e70: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
8e80: 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 f/default smalle
8e90: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
8ea0: 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 ime "smallest-ti
8eb0: 6d 65 22 20 23 66 29 29 0a 20 20 20 20 20 20 20 me" #f)).
8ec0: 20 20 28 70 67 64 62 2d 73 74 65 70 2d 69 64 20 (pgdb-step-id
8ed0: 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 64 (if pgdb-test-id
8ee0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8ef0: 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 (pgdb
8f00: 3a 67 65 74 2d 74 65 73 74 2d 73 74 65 70 2d 69 :get-test-step-i
8f10: 64 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d d dbh pgdb-test-
8f20: 69 64 20 73 74 65 70 6e 61 6d 65 20 73 74 61 74 id stepname stat
8f30: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
8f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
8f50: 29 29 0a 20 20 20 20 28 69 66 20 73 74 65 70 2d )). (if step-
8f60: 69 64 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 id. (begin
8f70: 20 0a 20 20 20 20 20 20 20 20 28 69 66 20 70 67 . (if pg
8f80: 64 62 2d 74 65 73 74 2d 69 64 0a 20 20 20 20 20 db-test-id.
8f90: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
8fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
8fb0: 66 20 20 70 67 64 62 2d 73 74 65 70 2d 69 64 0a f pgdb-step-id.
8fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fd0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
8fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
8ff0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9000: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
9010: 6f 72 74 2a 20 20 22 55 70 64 61 74 69 6e 67 20 ort* "Updating
9020: 65 78 69 73 74 69 6e 67 20 74 65 73 74 2d 73 74 existing test-st
9030: 65 70 20 77 69 74 68 20 74 65 73 74 2d 69 64 3a ep with test-id:
9040: 20 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e 64 " test-id " and
9050: 20 73 74 65 70 2d 69 64 20 22 20 73 74 65 70 2d step-id " step-
9060: 69 64 20 22 20 70 67 64 62 20 74 65 73 74 20 69 id " pgdb test i
9070: 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d 69 d: " pgdb-test-i
9080: 64 20 22 20 70 67 64 62 20 73 74 65 70 20 69 64 d " pgdb step id
9090: 20 22 20 70 67 64 62 2d 73 74 65 70 2d 69 64 20 " pgdb-step-id
90a0: 29 0a 09 09 09 09 09 09 09 09 09 09 28 6c 65 74 )...........(let
90b0: 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 70 * ((pgdb-last-up
90c0: 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d 74 date (pgdb:get-t
90d0: 65 73 74 2d 73 74 65 70 2d 6c 61 73 74 2d 75 70 est-step-last-up
90e0: 64 61 74 65 20 64 62 68 20 70 67 64 62 2d 73 74 date dbh pgdb-st
90f0: 65 70 2d 69 64 29 29 29 0a 20 20 20 20 20 20 20 ep-id))).
9100: 20 20 28 69 66 20 28 61 6e 64 20 20 28 3e 20 6c (if (and (> l
9110: 61 73 74 2d 75 70 64 61 74 65 20 70 67 64 62 2d ast-update pgdb-
9120: 6c 61 73 74 2d 75 70 64 61 74 65 29 20 28 6f 72 last-update) (or
9130: 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 (not smallest-t
9140: 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 ime) (< last-upd
9150: 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d ate smallest-tim
9160: 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 e))). (ha
9170: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 6d sh-table-set! sm
9180: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
9190: 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 te-time "smalles
91a0: 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 t-time" last-upd
91b0: 61 74 65 29 29 29 20 0a 20 20 20 20 20 20 20 20 ate))) .
91c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
91d0: 62 3a 75 70 64 61 74 65 2d 74 65 73 74 2d 73 74 b:update-test-st
91e0: 65 70 20 64 62 68 20 70 67 64 62 2d 73 74 65 70 ep dbh pgdb-step
91f0: 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d 69 64 -id pgdb-test-id
9200: 20 73 74 65 70 6e 61 6d 65 20 73 74 61 74 65 20 stepname state
9210: 73 74 61 74 75 73 20 65 76 65 6e 74 5f 74 69 6d status event_tim
9220: 65 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c e comment logfil
9230: 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a e last-update)).
9240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9250: 20 20 20 20 28 62 65 67 69 6e 0a 20 09 09 20 20 (begin. ..
9260: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9270: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
9280: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 49 6e 73 -log-port* "Ins
9290: 65 72 74 69 6e 67 20 74 65 73 74 2d 73 74 65 70 erting test-step
92a0: 20 77 69 74 68 20 74 65 73 74 2d 69 64 3a 20 22 with test-id: "
92b0: 20 74 65 73 74 2d 69 64 20 22 20 61 6e 64 20 73 test-id " and s
92c0: 74 65 70 2d 69 64 20 22 20 73 74 65 70 2d 69 64 tep-id " step-id
92d0: 20 20 22 20 70 67 64 62 20 74 65 73 74 20 69 64 " pgdb test id
92e0: 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d 69 64 : " pgdb-test-id
92f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9300: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
9310: 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d not smallest-tim
9320: 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 74 e) (< last-updat
9330: 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 e smallest-time)
9340: 29 0a 20 20 20 20 20 20 20 20 09 09 09 09 20 20 ). ....
9350: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
9360: 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 set! smallest-la
9370: 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 st-update-time "
9380: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c smallest-time" l
9390: 61 73 74 2d 75 70 64 61 74 65 29 29 0a 20 20 20 ast-update)).
93a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93b0: 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d (pgdb:insert-
93c0: 74 65 73 74 2d 73 74 65 70 20 64 62 68 20 70 67 test-step dbh pg
93d0: 64 62 2d 74 65 73 74 2d 69 64 20 73 74 65 70 6e db-test-id stepn
93e0: 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 ame state status
93f0: 20 65 76 65 6e 74 5f 74 69 6d 65 20 63 6f 6d 6d event_time comm
9400: 65 6e 74 20 6c 6f 67 66 69 6c 65 20 6c 61 73 74 ent logfile last
9410: 2d 75 70 64 61 74 65 20 29 0a 20 20 20 20 20 20 -update ).
9420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9430: 28 73 65 74 21 20 70 67 64 62 2d 73 74 65 70 2d (set! pgdb-step-
9440: 69 64 20 20 28 70 67 64 62 3a 67 65 74 2d 74 65 id (pgdb:get-te
9450: 73 74 2d 73 74 65 70 2d 69 64 20 64 62 68 20 70 st-step-id dbh p
9460: 67 64 62 2d 74 65 73 74 2d 69 64 20 73 74 65 70 gdb-test-id step
9470: 6e 61 6d 65 20 73 74 61 74 65 29 29 29 29 0a 20 name state)))).
9480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9490: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
94a0: 73 74 65 70 2d 68 74 20 73 74 65 70 2d 69 64 20 step-ht step-id
94b0: 70 67 64 62 2d 73 74 65 70 2d 69 64 20 29 29 0a pgdb-step-id )).
94c0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
94d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
94e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
94f0: 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 73 74 20 * "Error: Test
9500: 6e 6f 74 20 63 61 73 68 65 64 22 29 29 29 0a 20 not cashed"))).
9510: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9520: 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c t-info 1 *defaul
9530: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 45 72 t-log-port* "Er
9540: 72 6f 72 3a 20 43 6f 75 6c 64 20 6e 6f 74 20 67 ror: Could not g
9550: 65 74 20 74 65 73 74 20 73 74 65 70 20 69 6e 66 et test step inf
9560: 6f 20 66 6f 72 20 73 74 65 70 20 69 64 20 22 20 o for step id "
9570: 74 65 73 74 2d 73 74 65 70 2d 69 64 20 29 29 29 test-step-id )))
9580: 29 09 3b 3b 20 74 68 69 73 20 69 73 20 61 20 77 ).;; this is a w
9590: 69 65 72 64 20 73 65 6e 61 72 69 6f 20 6e 65 65 ierd senario nee
95a0: 64 20 74 6f 20 64 65 62 75 67 20 20 20 20 20 20 d to debug
95b0: 09 0a 20 20 20 74 65 73 74 2d 73 74 65 70 2d 69 .. test-step-i
95c0: 64 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ds)))..(define (
95d0: 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 2d tasks:sync-test-
95e0: 67 65 6e 2d 64 61 74 61 20 64 62 68 20 63 61 63 gen-data dbh cac
95f0: 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d 64 61 hed-info test-da
9600: 74 61 2d 69 64 73 20 73 6d 61 6c 6c 65 73 74 2d ta-ids smallest-
9610: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
9620: 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d ). (let ((test-
9630: 68 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ht (hash-table-r
9640: 65 66 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 ef cached-info '
9650: 74 65 73 74 73 29 29 0a 20 20 20 20 20 20 20 20 tests)).
9660: 28 64 61 74 61 2d 68 74 20 28 68 61 73 68 2d 74 (data-ht (hash-t
9670: 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d able-ref cached-
9680: 69 6e 66 6f 20 27 64 61 74 61 29 29 0a 20 20 20 info 'data)).
9690: 20 20 20 20 20 28 72 75 6e 2d 69 64 2d 69 6e 20 (run-id-in
96a0: 23 66 29 0a 20 20 20 20 20 20 20 20 29 0a 20 20 #f). ).
96b0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
96c0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 64 (lambda (test-d
96d0: 61 74 61 2d 69 64 29 0a 20 20 20 20 20 20 20 20 ata-id).
96e0: 28 73 65 74 21 20 72 75 6e 2d 69 64 2d 69 6e 20 (set! run-id-in
96f0: 28 63 64 72 20 74 65 73 74 2d 64 61 74 61 2d 69 (cdr test-data-i
9700: 64 29 29 0a 20 20 20 20 20 20 20 20 28 73 65 74 d)). (set
9710: 21 20 74 65 73 74 2d 64 61 74 61 2d 69 64 20 28 ! test-data-id (
9720: 63 61 72 20 74 65 73 74 2d 64 61 74 61 2d 69 64 car test-data-id
9730: 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a )). (let*
9740: 20 28 28 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 ((test-data-inf
9750: 6f 20 20 28 72 6d 74 3a 67 65 74 2d 64 61 74 61 o (rmt:get-data
9760: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
9770: 69 64 2d 69 6e 20 74 65 73 74 2d 64 61 74 61 2d id-in test-data-
9780: 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 id)).
9790: 20 20 20 20 28 64 61 74 61 2d 69 64 20 28 64 62 (data-id (db
97a0: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 69 :test-data-get-i
97b0: 64 20 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 d test-data-inf
97c0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 o)).
97d0: 20 20 20 28 74 65 73 74 2d 69 64 20 20 28 64 62 (test-id (db
97e0: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 :test-data-get-t
97f0: 65 73 74 5f 69 64 20 20 20 74 65 73 74 2d 64 61 est_id test-da
9800: 74 61 2d 69 6e 66 6f 29 29 20 20 20 0a 09 20 20 ta-info)) ..
9810: 20 20 20 20 20 28 63 61 74 65 67 6f 72 79 20 20 (category
9820: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9830: 74 2d 63 61 74 65 67 6f 72 79 20 20 74 65 73 74 t-category test
9840: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a 09 20 20 -data-info))..
9850: 20 20 20 20 20 28 76 61 72 69 61 62 6c 65 20 20 (variable
9860: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9870: 74 2d 76 61 72 69 61 62 6c 65 20 74 65 73 74 2d t-variable test-
9880: 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 20 data-info))...
9890: 20 20 20 20 20 28 76 61 6c 75 65 20 28 64 62 3a (value (db:
98a0: 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 76 61 test-data-get-va
98b0: 6c 75 65 20 20 74 65 73 74 2d 64 61 74 61 2d 69 lue test-data-i
98c0: 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 20 20 20 nfo))..
98d0: 20 20 20 20 20 20 28 65 78 70 65 63 74 65 64 20 (expected
98e0: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
98f0: 74 2d 65 78 70 65 63 74 65 64 20 20 74 65 73 74 t-expected test
9900: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a 20 20 20 -data-info)).
9910: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 6f 6c (tol
9920: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
9930: 65 74 2d 74 6f 6c 20 20 74 65 73 74 2d 64 61 74 et-tol test-dat
9940: 61 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 a-info)).
9950: 20 20 20 20 20 20 20 20 28 75 6e 69 74 73 20 28 (units (
9960: 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 db:test-data-get
9970: 2d 75 6e 69 74 73 20 20 74 65 73 74 2d 64 61 74 -units test-dat
9980: 61 2d 69 6e 66 6f 29 29 20 20 20 20 20 0a 09 20 a-info)) ..
9990: 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 (comment
99a0: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
99b0: 74 2d 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d 64 t-comment test-d
99c0: 61 74 61 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 ata-info))..
99d0: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 61 74 (stat
99e0: 75 73 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 us (db:test-data
99f0: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 -get-status test
9a00: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 -data-info))...
9a10: 20 20 20 20 20 20 28 74 79 70 65 20 28 64 62 3a (type (db:
9a20: 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 79 test-data-get-ty
9a30: 70 65 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 pe test-data-inf
9a40: 6f 29 29 0a 09 09 09 09 20 28 6c 61 73 74 2d 75 o))..... (last-u
9a50: 70 64 61 74 65 20 28 64 62 3a 74 65 73 74 2d 64 pdate (db:test-d
9a60: 61 74 61 2d 67 65 74 2d 6c 61 73 74 5f 75 70 64 ata-get-last_upd
9a70: 61 74 65 20 74 65 73 74 2d 64 61 74 61 2d 69 6e ate test-data-in
9a80: 66 6f 29 29 0a 09 09 09 09 20 28 73 6d 61 6c 6c fo))..... (small
9a90: 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 est-time (hash-t
9aa0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
9ab0: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
9ac0: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
9ad0: 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 29 0a lest-time" #f)).
9ae0: 20 20 20 09 0a 09 20 20 20 20 20 20 20 28 70 67 ... (pg
9af0: 64 62 2d 74 65 73 74 2d 69 64 20 20 28 68 61 73 db-test-id (has
9b00: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
9b10: 75 6c 74 20 74 65 73 74 2d 68 74 20 74 65 73 74 ult test-ht test
9b20: 2d 69 64 20 23 66 29 29 0a 20 20 20 20 20 20 20 -id #f)).
9b30: 20 20 20 20 20 20 20 20 28 70 67 64 62 2d 64 61 (pgdb-da
9b40: 74 61 2d 69 64 20 28 69 66 20 70 67 64 62 2d 74 ta-id (if pgdb-t
9b50: 65 73 74 2d 69 64 20 0a 20 20 20 20 20 20 20 20 est-id .
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b70: 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a 67 (pgdb:g
9b80: 65 74 2d 74 65 73 74 2d 64 61 74 61 2d 69 64 20 et-test-data-id
9b90: 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 dbh pgdb-test-id
9ba0: 20 63 61 74 65 67 6f 72 79 20 76 61 72 69 61 62 category variab
9bb0: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
9bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bd0: 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 #f))).
9be0: 28 69 66 20 64 61 74 61 2d 69 64 0a 20 20 20 20 (if data-id.
9bf0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
9c00: 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 (if pgdb-test-i
9c10: 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 62 65 d. (be
9c20: 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 gin .
9c30: 20 20 20 20 20 28 69 66 20 20 70 67 64 62 2d 64 (if pgdb-d
9c40: 61 74 61 2d 69 64 0a 20 20 20 20 20 20 20 20 20 ata-id.
9c50: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
9c60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9c70: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9c80: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
9c90: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 70 t-log-port* "Up
9ca0: 64 61 74 69 6e 67 20 65 78 69 73 74 69 6e 67 20 dating existing
9cb0: 74 65 73 74 2d 64 61 74 61 20 77 69 74 68 20 74 test-data with t
9cc0: 65 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 est-id: " test-i
9cd0: 64 20 22 20 61 6e 64 20 20 64 61 74 61 2d 69 64 d " and data-id
9ce0: 20 22 20 64 61 74 61 2d 69 64 20 22 20 70 67 64 " data-id " pgd
9cf0: 62 20 74 65 73 74 20 69 64 3a 20 22 20 70 67 64 b test id: " pgd
9d00: 62 2d 74 65 73 74 2d 69 64 20 22 20 70 67 64 62 b-test-id " pgdb
9d10: 20 64 61 74 61 20 69 64 20 22 20 70 67 64 62 2d data id " pgdb-
9d20: 64 61 74 61 2d 69 64 29 0a 20 20 20 20 20 20 20 data-id).
9d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
9d40: 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 t* ((pgdb-last-u
9d50: 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d pdate (pgdb:get-
9d60: 74 65 73 74 2d 64 61 74 61 2d 6c 61 73 74 2d 75 test-data-last-u
9d70: 70 64 61 74 65 20 64 62 68 20 70 67 64 62 2d 64 pdate dbh pgdb-d
9d80: 61 74 61 2d 69 64 29 29 29 0a 20 20 20 20 20 20 ata-id))).
9d90: 20 20 20 28 69 66 20 28 61 6e 64 20 20 28 3e 20 (if (and (>
9da0: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 67 64 last-update pgd
9db0: 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 28 b-last-update) (
9dc0: 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 or (not smallest
9dd0: 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 -time) (< last-u
9de0: 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 pdate smallest-t
9df0: 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 ime))). (
9e00: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9e10: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
9e20: 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c date-time "small
9e30: 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 est-time" last-u
9e40: 70 64 61 74 65 29 29 29 20 0a 20 20 20 20 20 20 pdate))) .
9e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
9e60: 67 64 62 3a 75 70 64 61 74 65 2d 74 65 73 74 2d gdb:update-test-
9e70: 64 61 74 61 20 64 62 68 20 70 67 64 62 2d 64 61 data dbh pgdb-da
9e80: 74 61 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d ta-id pgdb-test-
9e90: 69 64 20 20 63 61 74 65 67 6f 72 79 20 76 61 72 id category var
9ea0: 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 iable value expe
9eb0: 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 cted tol units c
9ec0: 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 omment status ty
9ed0: 70 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 pe last-update))
9ee0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9ef0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 09 09 20 (begin. ..
9f00: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9f10: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
9f20: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 49 6e t-log-port* "In
9f30: 73 65 72 74 69 6e 67 20 74 65 73 74 2d 64 61 74 serting test-dat
9f40: 61 20 77 69 74 68 20 74 65 73 74 2d 69 64 3a 20 a with test-id:
9f50: 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e 64 20 " test-id " and
9f60: 64 61 74 61 2d 69 64 20 22 20 64 61 74 61 2d 69 data-id " data-i
9f70: 64 20 22 20 70 67 64 62 20 74 65 73 74 20 69 64 d " pgdb test id
9f80: 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d 69 64 : " pgdb-test-id
9f90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9fa0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 68 61 (if (ha
9fb0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
9fc0: 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 20 20 .. exn...
9fd0: 20 20 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e (begin (prin
9fe0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 t-call-chain).
9ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a000: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
a010: 6e 74 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 nt ((condition-p
a020: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
a030: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
a040: 65 78 6e 29 29 20 20 20 20 20 0a 09 09 09 23 66 exn)) ....#f
a050: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a060: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
a070: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
a080: 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 61 b:insert-test-da
a090: 74 61 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 ta dbh pgdb-test
a0a0: 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 -id category var
a0b0: 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 iable value expe
a0c0: 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 cted tol units c
a0d0: 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 omment status ty
a0e0: 70 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 pe last-update))
a0f0: 0a 09 09 20 20 20 20 20 20 20 3b 28 74 61 73 6b ... ;(task
a100: 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 s:run-id->mtpg-r
a110: 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 un-id dbh cached
a120: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 -info run-id are
a130: 61 2d 69 6e 66 6f 29 0a 20 20 20 20 20 20 20 20 a-info).
a140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
a150: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
a160: 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 67 64 ;(pgd
a170: 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 61 b:insert-test-da
a180: 74 61 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 ta dbh pgdb-test
a190: 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 -id category var
a1a0: 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 iable value expe
a1b0: 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 cted tol units c
a1c0: 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 omment status ty
a1d0: 70 65 20 29 0a 09 09 09 09 09 09 09 09 09 09 09 pe )............
a1e0: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 (if (or (not sma
a1f0: 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c llest-time) (< l
a200: 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c ast-update small
a210: 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 est-time)).
a220: 20 20 20 09 09 09 09 09 09 09 09 28 68 61 73 68 ........(hash
a230: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c -table-set! smal
a240: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
a250: 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d -time "smallest-
a260: 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 74 time" last-updat
a270: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
a280: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
a290: 70 67 64 62 2d 64 61 74 61 2d 69 64 20 20 28 70 pgdb-data-id (p
a2a0: 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 64 61 74 gdb:get-test-dat
a2b0: 61 2d 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 a-id dbh pgdb-te
a2c0: 73 74 2d 69 64 20 20 63 61 74 65 67 6f 72 79 20 st-id category
a2d0: 76 61 72 69 61 62 6c 65 29 29 29 0a 09 09 20 20 variable)))...
a2e0: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
a2f0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
a300: 6c 65 2d 73 65 74 21 20 64 61 74 61 2d 68 74 20 le-set! data-ht
a310: 64 61 74 61 2d 69 64 20 70 67 64 62 2d 64 61 74 data-id pgdb-dat
a320: 61 2d 69 64 20 29 29 0a 20 20 20 20 20 20 20 20 a-id )).
a330: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
a340: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
a350: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
a360: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
a370: 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 73 rt* "Error: Tes
a380: 74 20 6e 6f 74 20 69 6e 20 70 67 64 62 22 29 29 t not in pgdb"))
a390: 29 29 0a 0a 20 20 20 20 20 20 28 64 65 62 75 67 )).. (debug
a3a0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
a3b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
a3c0: 20 20 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 20 "Error: Could
a3d0: 6e 6f 74 20 67 65 74 20 74 65 73 74 20 64 61 74 not get test dat
a3e0: 61 20 69 6e 66 6f 20 66 6f 72 20 64 61 74 61 20 a info for data
a3f0: 69 64 20 22 20 74 65 73 74 2d 64 61 74 61 2d 69 id " test-data-i
a400: 64 20 29 29 29 29 09 3b 3b 20 74 68 69 73 20 69 d )))).;; this i
a410: 73 20 61 20 77 69 65 72 64 20 73 65 6e 61 72 69 s a wierd senari
a420: 6f 20 6e 65 65 64 20 74 6f 20 64 65 62 75 67 20 o need to debug
a430: 20 20 20 20 20 09 0a 20 20 20 74 65 73 74 2d 64 .. test-d
a440: 61 74 61 2d 69 64 73 29 29 29 0a 0a 0a 0a 28 64 ata-ids)))....(d
a450: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e efine (tasks:syn
a460: 63 2d 74 65 73 74 73 2d 64 61 74 61 20 64 62 68 c-tests-data dbh
a470: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 cached-info tes
a480: 74 2d 69 64 73 20 61 72 65 61 2d 69 6e 66 6f 20 t-ids area-info
a490: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
a4a0: 64 61 74 65 2d 74 69 6d 65 29 0a 20 20 28 6c 65 date-time). (le
a4b0: 74 20 28 28 74 65 73 74 2d 68 74 20 28 68 61 73 t ((test-ht (has
a4c0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 h-table-ref cach
a4d0: 65 64 2d 69 6e 66 6f 20 27 74 65 73 74 73 29 29 ed-info 'tests))
a4e0: 0a 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 . (run-id
a4f0: 2d 69 6e 20 23 66 29 29 0a 20 20 20 20 28 66 6f -in #f)). (fo
a500: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
a510: 62 64 61 20 28 74 65 73 74 2d 69 64 29 0a 20 20 bda (test-id).
a520: 20 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 2d (set! run-
a530: 69 64 2d 69 6e 20 20 28 63 64 72 20 74 65 73 74 id-in (cdr test
a540: 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 28 73 -id)). (s
a550: 65 74 21 20 74 65 73 74 2d 69 64 20 28 63 61 72 et! test-id (car
a560: 20 74 65 73 74 2d 69 64 29 29 0a 0a 20 20 20 20 test-id))..
a570: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a580: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
a590: 70 6f 72 74 2a 20 20 22 74 65 73 74 2d 69 64 3a port* "test-id:
a5a0: 20 22 20 74 65 73 74 2d 69 64 20 22 20 72 75 6e " test-id " run
a5b0: 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 2d 69 6e -id: " run-id-in
a5c0: 29 20 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ) . (let*
a5d0: 28 28 74 65 73 74 2d 69 6e 66 6f 20 20 20 20 28 ((test-info (
a5e0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
a5f0: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 2d 69 o-by-id run-id-i
a600: 6e 20 74 65 73 74 2d 69 64 29 29 0a 09 20 20 20 n test-id))..
a610: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 (run-id
a620: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
a630: 6e 5f 69 64 20 20 20 20 74 65 73 74 2d 69 6e 66 n_id test-inf
a640: 6f 29 29 20 3b 3b 20 6c 6f 6f 6b 20 74 68 65 73 o)) ;; look thes
a650: 65 20 75 70 20 69 6e 20 64 62 5f 72 65 63 6f 72 e up in db_recor
a660: 64 73 2e 73 63 6d 0a 09 20 20 20 20 20 20 28 74 ds.scm.. (t
a670: 65 73 74 2d 69 64 20 20 20 20 20 20 28 64 62 3a est-id (db:
a680: 74 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 20 test-get-id
a690: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
a6a0: 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 (test-name
a6b0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
a6c0: 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 2d -testname test-
a6d0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 69 info)).. (i
a6e0: 74 65 6d 2d 70 61 74 68 20 20 20 20 28 64 62 3a tem-path (db:
a6f0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
a700: 74 68 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 th test-info))..
a710: 20 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 (state
a720: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
a730: 2d 73 74 61 74 65 20 20 20 20 20 74 65 73 74 2d -state test-
a740: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 73 info)).. (s
a750: 74 61 74 75 73 20 20 20 20 20 20 20 28 64 62 3a tatus (db:
a760: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
a770: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
a780: 20 20 20 20 20 20 28 68 6f 73 74 20 20 20 20 20 (host
a790: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
a7a0: 2d 68 6f 73 74 20 20 20 20 20 20 74 65 73 74 2d -host test-
a7b0: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 28 info)). (
a7c0: 70 69 64 20 20 20 20 20 20 20 20 20 20 28 64 62 pid (db
a7d0: 3a 74 65 73 74 2d 67 65 74 2d 70 72 6f 63 65 73 :test-get-proces
a7e0: 73 5f 69 64 20 74 65 73 74 2d 69 6e 66 6f 29 29 s_id test-info))
a7f0: 20 0a 09 20 20 20 20 20 20 28 63 70 75 6c 6f 61 .. (cpuloa
a800: 64 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d d (db:test-
a810: 67 65 74 2d 63 70 75 6c 6f 61 64 20 20 20 74 65 get-cpuload te
a820: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
a830: 20 28 64 69 73 6b 66 72 65 65 20 20 20 20 20 28 (diskfree (
a840: 64 62 3a 74 65 73 74 2d 67 65 74 2d 64 69 73 6b db:test-get-disk
a850: 66 72 65 65 20 20 74 65 73 74 2d 69 6e 66 6f 29 free test-info)
a860: 29 0a 09 20 20 20 20 20 20 28 75 6e 61 6d 65 20 ).. (uname
a870: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
a880: 67 65 74 2d 75 6e 61 6d 65 20 20 20 20 20 74 65 get-uname te
a890: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
a8a0: 20 28 72 75 6e 2d 64 69 72 20 20 20 20 20 20 28 (run-dir (
a8b0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
a8c0: 69 72 20 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 ir test-info)
a8d0: 29 0a 09 20 20 20 20 20 20 28 6c 6f 67 2d 66 69 ).. (log-fi
a8e0: 6c 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d le (db:test-
a8f0: 67 65 74 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 get-final_logf t
a900: 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 est-info))..
a910: 20 20 28 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 (run-duration
a920: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
a930: 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d 69 _duration test-i
a940: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 63 6f nfo)).. (co
a950: 6d 6d 65 6e 74 20 20 20 20 20 20 28 64 62 3a 74 mment (db:t
a960: 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 est-get-comment
a970: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 test-info))..
a980: 20 20 20 20 20 28 65 76 65 6e 74 2d 74 69 6d 65 (event-time
a990: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
a9a0: 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 2d event_time test-
a9b0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 61 info)).. (a
a9c0: 72 63 68 69 76 65 64 20 20 20 20 20 28 64 62 3a rchived (db:
a9d0: 74 65 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 test-get-archive
a9e0: 64 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 20 d test-info)).
a9f0: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 75 70 64 (last-upd
aa00: 61 74 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ate (db:test-ge
aa10: 74 2d 6c 61 73 74 5f 75 70 64 61 74 65 20 20 74 t-last_update t
aa20: 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 est-info))..
aa30: 20 20 28 70 67 64 62 2d 72 75 6e 2d 69 64 20 20 (pgdb-run-id
aa40: 28 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d (tasks:run-id->m
aa50: 74 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 tpg-run-id dbh c
aa60: 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 ached-info run-i
aa70: 64 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c d area-info smal
aa80: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
aa90: 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -time)).
aaa0: 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 (smallest-time (
aab0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
aac0: 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d efault smallest-
aad0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
aae0: 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 "smallest-time"
aaf0: 20 23 66 29 29 20 20 20 20 20 20 20 0a 09 20 20 #f)) ..
ab00: 20 20 20 20 28 70 67 64 62 2d 74 65 73 74 2d 69 (pgdb-test-i
ab10: 64 20 28 69 66 20 70 67 64 62 2d 72 75 6e 2d 69 d (if pgdb-run-i
ab20: 64 20 0a 09 09 09 09 28 62 65 67 69 6e 0a 20 20 d .....(begin.
ab30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab50: 3b 28 70 72 69 6e 74 20 70 67 64 62 2d 72 75 6e ;(print pgdb-run
ab60: 2d 69 64 29 20 20 20 20 0a 20 20 20 20 20 20 20 -id) .
ab70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab80: 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a (pgdb:
ab90: 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 68 20 get-test-id dbh
aba0: 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 pgdb-run-id test
abb0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
abc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
abd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
abe0: 20 20 20 23 66 29 29 29 0a 09 20 3b 3b 20 22 69 #f))).. ;; "i
abf0: 64 22 20 20 20 20 20 20 20 20 20 20 20 22 72 75 d" "ru
ac00: 6e 5f 69 64 22 20 20 20 20 20 20 20 20 22 74 65 n_id" "te
ac10: 73 74 6e 61 6d 65 22 20 20 22 73 74 61 74 65 22 stname" "state"
ac20: 20 20 20 20 20 20 22 73 74 61 74 75 73 22 20 20 "status"
ac30: 20 20 20 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 "event_time"
ac40: 0a 09 20 3b 3b 20 22 68 6f 73 74 22 20 20 20 20 .. ;; "host"
ac50: 20 20 20 20 20 22 63 70 75 6c 6f 61 64 22 20 20 "cpuload"
ac60: 20 20 20 20 20 22 64 69 73 6b 66 72 65 65 22 20 "diskfree"
ac70: 20 22 75 6e 61 6d 65 22 20 20 20 20 20 20 22 72 "uname" "r
ac80: 75 6e 64 69 72 22 20 20 20 20 20 20 22 69 74 65 undir" "ite
ac90: 6d 5f 70 61 74 68 22 0a 09 20 3b 3b 20 22 72 75 m_path".. ;; "ru
aca0: 6e 5f 64 75 72 61 74 69 6f 6e 22 20 22 66 69 6e n_duration" "fin
acb0: 61 6c 5f 6c 6f 67 66 22 20 20 20 20 22 63 6f 6d al_logf" "com
acc0: 6d 65 6e 74 22 20 20 20 22 73 68 6f 72 74 64 69 ment" "shortdi
acd0: 72 22 20 20 20 22 61 74 74 65 6d 70 74 6e 75 6d r" "attemptnum
ace0: 22 20 20 22 61 72 63 68 69 76 65 64 22 0a 20 20 " "archived".
acf0: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
ad00: 6e 6f 74 20 69 74 65 6d 2d 70 61 74 68 29 20 28 not item-path) (
ad10: 73 74 72 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 string-null? ite
ad20: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 m-path)).
ad30: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
ad40: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
ad50: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 6f lt-log-port* "Wo
ad60: 72 6b 69 6e 67 20 6f 6e 20 52 75 6e 20 69 64 20 rking on Run id
ad70: 3a 20 22 20 72 75 6e 2d 69 64 20 22 20 61 6e 64 : " run-id " and
ad80: 20 74 65 73 74 20 6e 61 6d 65 20 3a 20 22 20 74 test name : " t
ad90: 65 73 74 2d 6e 61 6d 65 29 29 20 0a 20 20 20 20 est-name)) .
ada0: 20 20 20 20 20 28 69 66 20 70 67 64 62 2d 72 75 (if pgdb-ru
adb0: 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 n-id.
adc0: 28 62 65 67 69 6e 0a 09 20 20 20 28 69 66 20 70 (begin.. (if p
add0: 67 64 62 2d 74 65 73 74 2d 69 64 20 3b 3b 20 68 gdb-test-id ;; h
ade0: 61 76 65 20 61 20 72 65 63 6f 72 64 0a 09 20 20 ave a record..
adf0: 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 (begin ;; let
ae00: 20 28 28 6b 65 79 2d 6e 61 6d 65 20 28 63 6f 6e ((key-name (con
ae10: 63 20 72 75 6e 2d 69 64 20 22 2f 22 20 74 65 73 c run-id "/" tes
ae20: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
ae30: 70 61 74 68 29 29 29 0a 09 20 20 20 20 20 20 20 path)))..
ae40: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
ae50: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
ae60: 2d 70 6f 72 74 2a 20 20 22 55 70 64 61 74 69 6e -port* "Updatin
ae70: 67 20 65 78 69 73 74 69 6e 67 20 74 65 73 74 20 g existing test
ae80: 77 69 74 68 20 72 75 6e 2d 69 64 3a 20 22 20 72 with run-id: " r
ae90: 75 6e 2d 69 64 20 22 20 61 6e 64 20 74 65 73 74 un-id " and test
aea0: 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 -id: " test-id "
aeb0: 20 70 67 64 62 20 72 75 6e 20 69 64 3a 20 22 20 pgdb run id: "
aec0: 70 67 64 62 2d 72 75 6e 2d 69 64 20 22 20 20 70 pgdb-run-id " p
aed0: 67 64 62 2d 74 65 73 74 2d 69 64 20 22 20 20 70 gdb-test-id " p
aee0: 67 64 62 2d 74 65 73 74 2d 69 64 29 0a 20 20 20 gdb-test-id).
aef0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 67 (let* ((pg
af00: 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 28 db-last-update (
af10: 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 6c 61 pgdb:get-test-la
af20: 73 74 2d 75 70 64 61 74 65 20 64 62 68 20 70 67 st-update dbh pg
af30: 64 62 2d 74 65 73 74 2d 69 64 29 29 29 0a 20 20 db-test-id))).
af40: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
af50: 20 28 3e 20 20 6c 61 73 74 2d 75 70 64 61 74 65 (> last-update
af60: 20 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 pgdb-last-updat
af70: 65 29 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c e) (or (not smal
af80: 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 lest-time) (< la
af90: 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 st-update smalle
afa0: 73 74 2d 74 69 6d 65 29 29 29 20 3b 3b 69 66 20 st-time))) ;;if
afb0: 6c 61 73 74 2d 75 70 64 61 74 65 20 69 73 20 73 last-update is s
afc0: 61 6d 65 20 61 73 20 70 67 64 62 2d 6c 61 73 74 ame as pgdb-last
afd0: 2d 75 70 64 61 74 65 20 74 68 65 6e 20 69 74 20 -update then it
afe0: 69 73 20 73 61 66 65 20 74 6f 20 61 73 73 75 6d is safe to assum
aff0: 65 20 74 68 65 20 72 65 63 6f 72 64 73 20 61 72 e the records ar
b000: 65 20 69 64 65 6e 74 69 63 61 6c 20 61 6e 64 20 e identical and
b010: 77 65 20 63 61 6e 20 75 73 65 20 61 20 6c 61 72 we can use a lar
b020: 67 65 72 20 6c 61 73 74 20 75 70 64 61 74 65 20 ger last update
b030: 74 69 6d 65 2e 0a 20 20 20 20 20 20 20 20 28 68 time.. (h
b040: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
b050: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
b060: 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 ate-time "smalle
b070: 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 st-time" last-up
b080: 64 61 74 65 29 29 29 20 0a 09 20 20 20 20 20 20 date))) ..
b090: 20 28 70 67 64 62 3a 75 70 64 61 74 65 2d 74 65 (pgdb:update-te
b0a0: 73 74 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 st dbh pgdb-test
b0b0: 2d 69 64 20 70 67 64 62 2d 72 75 6e 2d 69 64 20 -id pgdb-run-id
b0c0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
b0d0: 61 74 68 20 73 74 61 74 65 20 73 74 61 74 75 73 ath state status
b0e0: 20 68 6f 73 74 20 63 70 75 6c 6f 61 64 20 64 69 host cpuload di
b0f0: 73 6b 66 72 65 65 20 75 6e 61 6d 65 20 72 75 6e skfree uname run
b100: 2d 64 69 72 20 6c 6f 67 2d 66 69 6c 65 20 72 75 -dir log-file ru
b110: 6e 2d 64 75 72 61 74 69 6f 6e 20 63 6f 6d 6d 65 n-duration comme
b120: 6e 74 20 65 76 65 6e 74 2d 74 69 6d 65 20 61 72 nt event-time ar
b130: 63 68 69 76 65 64 20 6c 61 73 74 2d 75 70 64 61 chived last-upda
b140: 74 65 20 70 69 64 29 29 0a 09 20 20 20 20 20 28 te pid)).. (
b150: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
b160: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
b170: 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 4 *default-l
b180: 6f 67 2d 70 6f 72 74 2a 20 20 22 49 6e 73 65 72 og-port* "Inser
b190: 74 69 6e 67 20 74 65 73 74 20 77 69 74 68 20 72 ting test with r
b1a0: 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 20 un-id: " run-id
b1b0: 22 20 61 6e 64 20 74 65 73 74 2d 69 64 3a 20 22 " and test-id: "
b1c0: 20 74 65 73 74 2d 69 64 20 20 22 20 70 67 64 62 test-id " pgdb
b1d0: 20 72 75 6e 20 69 64 3a 20 22 20 70 67 64 62 2d run id: " pgdb-
b1e0: 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 20 run-id).
b1f0: 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d (pgdb:insert-
b200: 74 65 73 74 20 64 62 68 20 70 67 64 62 2d 72 75 test dbh pgdb-ru
b210: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
b220: 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 tem-path state s
b230: 74 61 74 75 73 20 68 6f 73 74 20 63 70 75 6c 6f tatus host cpulo
b240: 61 64 20 64 69 73 6b 66 72 65 65 20 75 6e 61 6d ad diskfree unam
b250: 65 20 72 75 6e 2d 64 69 72 20 6c 6f 67 2d 66 69 e run-dir log-fi
b260: 6c 65 20 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 le run-duration
b270: 63 6f 6d 6d 65 6e 74 20 65 76 65 6e 74 2d 74 69 comment event-ti
b280: 6d 65 20 61 72 63 68 69 76 65 64 20 6c 61 73 74 me archived last
b290: 2d 75 70 64 61 74 65 20 70 69 64 29 0a 20 20 20 -update pid).
b2a0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 (if (or
b2b0: 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 (not smallest-t
b2c0: 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 ime) (< last-upd
b2d0: 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d ate smallest-tim
b2e0: 65 29 29 0a 20 20 20 20 20 20 20 20 09 09 09 09 e)). ....
b2f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
b300: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
b310: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
b320: 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d lest-time" last-
b330: 75 70 64 61 74 65 29 29 0a 20 20 20 20 20 20 20 update)).
b340: 20 20 20 20 28 73 65 74 21 20 70 67 64 62 2d 74 (set! pgdb-t
b350: 65 73 74 2d 69 64 20 28 70 67 64 62 3a 67 65 74 est-id (pgdb:get
b360: 2d 74 65 73 74 2d 69 64 20 64 62 68 20 70 67 64 -test-id dbh pgd
b370: 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b-run-id test-na
b380: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 me item-path))))
b390: 0a 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 . (has
b3a0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
b3b0: 74 2d 68 74 20 74 65 73 74 2d 69 64 20 70 67 64 t-ht test-id pgd
b3c0: 62 2d 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 b-test-id)).
b3d0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
b3e0: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
b3f0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
b400: 57 41 52 4e 49 4e 47 3a 20 53 6b 69 70 70 69 6e WARNING: Skippin
b410: 67 20 72 75 6e 20 77 69 74 68 20 72 75 6e 2d 69 g run with run-i
b420: 64 3a 22 20 72 75 6e 2d 69 64 20 22 2e 20 54 68 d:" run-id ". Th
b430: 69 73 20 72 75 6e 20 77 61 73 20 63 72 65 61 74 is run was creat
b440: 65 64 20 61 66 74 65 72 20 70 72 69 76 69 6f 75 ed after priviou
b450: 73 20 73 79 6e 63 20 61 6e 64 20 72 65 6d 6f 76 s sync and remov
b460: 65 64 20 62 65 66 6f 72 65 20 74 68 69 73 20 73 ed before this s
b470: 79 6e 63 2e 22 29 29 29 29 0a 20 20 20 20 20 74 ync.")))). t
b480: 65 73 74 2d 69 64 73 29 29 29 0a 0a 28 64 65 66 est-ids)))..(def
b490: 69 6e 65 20 28 74 61 73 6b 3a 61 64 64 2d 61 72 ine (task:add-ar
b4a0: 65 61 2d 74 61 67 20 64 62 68 20 61 72 65 61 2d ea-tag dbh area-
b4b0: 69 6e 66 6f 20 74 61 67 29 20 0a 20 20 28 6c 65 info tag) . (le
b4c0: 74 2a 20 28 28 74 61 67 2d 69 6e 66 6f 20 28 70 t* ((tag-info (p
b4d0: 67 64 62 3a 67 65 74 2d 74 61 67 2d 69 6e 66 6f gdb:get-tag-info
b4e0: 2d 62 79 2d 6e 61 6d 65 20 64 62 68 20 74 61 67 -by-name dbh tag
b4f0: 29 29 29 0a 20 20 20 28 69 66 20 28 6e 6f 74 20 ))). (if (not
b500: 74 61 67 2d 69 6e 66 6f 29 0a 20 20 20 20 20 28 tag-info). (
b510: 62 65 67 69 6e 20 20 20 0a 20 20 20 20 20 28 69 begin . (i
b520: 66 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 f (handle-except
b530: 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 ions.. exn..
b540: 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 (begin .
b550: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
b560: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 rint-info 1 *def
b570: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
b580: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
b590: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
b5a0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
b5b0: 29 29 20 20 20 20 20 0a 09 20 20 20 23 66 29 0a )) .. #f).
b5c0: 09 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 . (pgdb:insert
b5d0: 2d 74 61 67 20 20 64 62 68 20 20 20 74 61 67 29 -tag dbh tag)
b5e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b5f0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 74 (set! t
b600: 61 67 2d 69 6e 66 6f 20 28 70 67 64 62 3a 67 65 ag-info (pgdb:ge
b610: 74 2d 74 61 67 2d 69 6e 66 6f 2d 62 79 2d 6e 61 t-tag-info-by-na
b620: 6d 65 20 64 62 68 20 74 61 67 29 29 0a 09 09 20 me dbh tag))...
b630: 20 23 66 29 29 29 0a 20 20 20 20 20 3b 3b 61 64 #f))). ;;ad
b640: 64 20 74 6f 20 61 72 65 61 5f 74 61 67 73 0a 20 d to area_tags.
b650: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
b660: 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 ptions.. exn..
b670: 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 (begin .
b680: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
b690: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
b6a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b6b0: 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 ((condition-pr
b6c0: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
b6d0: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
b6e0: 78 6e 29 29 20 20 20 20 20 0a 09 20 20 20 23 66 xn)) .. #f
b6f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 ). (if
b700: 20 28 6e 6f 74 20 28 70 67 64 62 3a 69 73 2d 61 (not (pgdb:is-a
b710: 72 65 61 2d 74 61 67 65 64 2d 77 69 74 68 2d 61 rea-taged-with-a
b720: 2d 74 61 67 20 64 62 68 20 28 76 65 63 74 6f 72 -tag dbh (vector
b730: 2d 72 65 66 20 74 61 67 2d 69 6e 66 6f 20 30 29 -ref tag-info 0)
b740: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 (vector-ref ar
b750: 65 61 2d 69 6e 66 6f 20 30 29 29 29 20 20 0a 09 ea-info 0))) ..
b760: 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d (pgdb:insert-
b770: 61 72 65 61 2d 74 61 67 20 20 64 62 68 20 20 20 area-tag dbh
b780: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 61 67 2d (vector-ref tag-
b790: 69 6e 66 6f 20 30 29 20 20 28 76 65 63 74 6f 72 info 0) (vector
b7a0: 2d 72 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 30 -ref area-info 0
b7b0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
b7c0: 28 74 61 73 6b 73 3a 73 79 6e 63 2d 72 75 6e 2d (tasks:sync-run-
b7d0: 64 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d data dbh cached-
b7e0: 69 6e 66 6f 20 72 75 6e 2d 69 64 73 20 61 72 65 info run-ids are
b7f0: 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d a-info smallest-
b800: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
b810: 29 20 0a 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 ) . (for-each.
b820: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e (lambda (run
b830: 2d 69 64 29 0a 20 20 20 20 20 20 28 64 65 62 75 -id). (debu
b840: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
b850: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
b860: 2a 20 20 20 22 43 68 65 63 6b 20 69 66 20 72 75 * "Check if ru
b870: 6e 20 77 69 74 68 20 22 20 72 75 6e 2d 69 64 20 n with " run-id
b880: 22 20 6e 65 65 64 73 20 74 6f 20 62 65 20 73 79 " needs to be sy
b890: 6e 63 65 64 22 20 29 0a 20 20 20 20 20 20 20 28 nced" ). (
b8a0: 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 tasks:run-id->mt
b8b0: 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 61 pg-run-id dbh ca
b8c0: 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 ched-info run-id
b8d0: 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c area-info small
b8e0: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
b8f0: 74 69 6d 65 29 29 0a 72 75 6e 2d 69 64 73 29 29 time)).run-ids))
b900: 0a 0a 0a 3b 3b 20 67 65 74 20 72 75 6e 73 20 63 ...;; get runs c
b910: 68 61 6e 67 65 64 20 73 69 6e 63 65 20 6c 61 73 hanged since las
b920: 74 20 73 79 6e 63 0a 3b 3b 20 28 64 65 66 69 6e t sync.;; (defin
b930: 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 e (tasks:sync-te
b940: 73 74 2d 64 61 74 61 20 64 62 68 20 63 61 63 68 st-data dbh cach
b950: 65 64 2d 69 6e 66 6f 20 61 72 65 61 2d 69 6e 66 ed-info area-inf
b960: 6f 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 o).;; (let* ((
b970: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
b980: 3a 73 79 6e 63 2d 74 6f 2d 70 6f 73 74 67 72 65 :sync-to-postgre
b990: 73 20 63 6f 6e 66 69 67 64 61 74 20 64 65 73 74 s configdat dest
b9a0: 29 0a 20 20 28 70 72 69 6e 74 20 22 49 6e 20 73 ). (print "In s
b9b0: 79 6e 63 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 ync"). (let* ((
b9c0: 64 62 68 20 20 20 20 20 20 20 20 20 28 70 67 64 dbh (pgd
b9d0: 62 3a 6f 70 65 6e 20 63 6f 6e 66 69 67 64 61 74 b:open configdat
b9e0: 20 64 62 6e 61 6d 65 3a 20 64 65 73 74 29 29 0a dbname: dest)).
b9f0: 09 20 28 61 72 65 61 2d 69 6e 66 6f 20 20 20 28 . (area-info (
ba00: 70 67 64 62 3a 67 65 74 2d 61 72 65 61 2d 62 79 pgdb:get-area-by
ba10: 2d 70 61 74 68 20 64 62 68 20 2a 74 6f 70 70 61 -path dbh *toppa
ba20: 74 68 2a 29 29 0a 09 20 28 63 61 63 68 65 64 2d th*)).. (cached-
ba30: 69 6e 66 6f 20 28 6d 61 6b 65 2d 68 61 73 68 2d info (make-hash-
ba40: 74 61 62 6c 65 29 29 0a 09 20 28 73 74 61 72 74 table)).. (start
ba50: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
ba60: 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 seconds)).
ba70: 20 20 20 28 74 65 73 74 2d 70 61 74 74 20 20 20 (test-patt
ba80: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
ba90: 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a 09 g "-testpatt")..
baa0: 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 . (args:get
bab0: 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 -arg "-testpatt"
bac0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
bad0: 20 20 20 20 20 20 20 20 22 25 22 29 29 0a 20 20 "%")).
bae0: 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 20 (target
baf0: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
bb00: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
bb10: 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 ... (args:g
bb20: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
bb30: 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 0a 20 )... #f)).
bb40: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d (run-nam
bb50: 65 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 e (if (args:ge
bb60: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
bb70: 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 )... (args:g
bb80: 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 et-arg "-runname
bb90: 22 29 0a 09 09 20 20 20 20 20 23 66 29 29 29 0a ")... #f))).
bba0: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 61 (if (and ta
bbb0: 72 67 65 74 20 20 28 6e 6f 74 20 72 75 6e 2d 6e rget (not run-n
bbc0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 28 62 65 ame)). (be
bbd0: 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 45 gin.. (print "E
bbe0: 72 72 6f 72 3a 20 50 72 6f 76 69 64 65 20 72 75 rror: Provide ru
bbf0: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 20 nname").
bc00: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
bc10: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
bc20: 74 61 72 67 65 74 29 20 20 72 75 6e 2d 6e 61 6d target) run-nam
bc30: 65 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 6e e). (begin
bc40: 0a 09 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f .. (print "Erro
bc50: 72 3a 20 50 72 6f 76 69 64 65 20 74 61 72 67 65 r: Provide targe
bc60: 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 t"). (e
bc70: 78 69 74 20 31 29 29 29 0a 20 20 20 20 3b 28 70 xit 1))). ;(p
bc80: 72 69 6e 74 20 22 31 32 33 22 29 0a 20 20 20 20 rint "123").
bc90: 3b 28 65 78 69 74 20 31 29 0a 20 20 20 20 28 66 ;(exit 1). (f
bca0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
bcb0: 28 64 74 79 70 65 29 0a 09 09 28 68 61 73 68 2d (dtype)...(hash-
bcc0: 74 61 62 6c 65 2d 73 65 74 21 20 63 61 63 68 65 table-set! cache
bcd0: 64 2d 69 6e 66 6f 20 64 74 79 70 65 20 28 6d 61 d-info dtype (ma
bce0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
bcf0: 0a 09 20 20 20 20 20 20 27 28 72 75 6e 73 20 74 .. '(runs t
bd00: 61 72 67 65 74 73 20 74 65 73 74 73 20 73 74 65 argets tests ste
bd10: 70 73 20 64 61 74 61 29 29 0a 20 20 20 20 28 68 ps data)). (h
bd20: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
bd30: 61 63 68 65 64 2d 69 6e 66 6f 20 27 73 74 61 72 ached-info 'star
bd40: 74 20 73 74 61 72 74 29 20 3b 3b 20 77 68 65 6e t start) ;; when
bd50: 20 64 6f 6e 65 20 77 65 27 6c 6c 20 73 65 74 20 done we'll set
bd60: 73 79 6e 63 20 74 69 6d 65 73 20 74 6f 20 74 68 sync times to th
bd70: 69 73 0a 20 20 20 20 28 69 66 20 61 72 65 61 2d is. (if area-
bd80: 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 6c 61 info..(let* ((la
bd90: 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 28 69 66 st-sync-time (if
bda0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
bdb0: 2d 73 69 6e 63 65 22 29 20 28 73 74 72 69 6e 67 -since") (string
bdc0: 2d 3e 6e 75 6d 62 65 72 20 28 61 72 67 73 3a 67 ->number (args:g
bdd0: 65 74 2d 61 72 67 20 22 2d 73 69 6e 63 65 22 29 et-arg "-since")
bde0: 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 ) (vector-ref ar
bdf0: 65 61 2d 69 6e 66 6f 20 33 29 29 29 0a 09 20 20 ea-info 3)))..
be00: 20 20 20 20 20 28 73 6d 61 6c 6c 65 73 74 2d 6c (smallest-l
be10: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
be20: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
be30: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
be40: 20 20 20 28 63 68 61 6e 67 65 64 20 20 20 20 20 (changed
be50: 20 28 69 66 20 28 61 6e 64 20 74 61 72 67 65 74 (if (and target
be60: 20 72 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 run-name).
be70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be80: 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d (rmt:get-
be90: 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 73 20 74 run-record-ids t
bea0: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 28 arget run-name (
beb0: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 20 74 65 rmt:get-keys) te
bec0: 73 74 2d 70 61 74 74 29 0a 20 20 20 20 20 20 20 st-patt).
bed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bee0: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 63 68 (rmt:get-ch
bef0: 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 anged-record-ids
bf00: 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 last-sync-time)
bf10: 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 2d )).. (run-
bf20: 69 64 73 20 20 20 20 20 20 20 20 28 61 6c 69 73 ids (alis
bf30: 74 2d 72 65 66 20 27 72 75 6e 73 20 20 20 20 20 t-ref 'runs
bf40: 20 20 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 changed))..
bf50: 20 20 20 20 28 74 65 73 74 2d 69 64 73 20 20 20 (test-ids
bf60: 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 (alist-ref '
bf70: 74 65 73 74 73 20 20 20 20 20 20 63 68 61 6e 67 tests chang
bf80: 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 ed)).. (te
bf90: 73 74 2d 73 74 65 70 2d 69 64 73 20 20 28 61 6c st-step-ids (al
bfa0: 69 73 74 2d 72 65 66 20 27 74 65 73 74 5f 73 74 ist-ref 'test_st
bfb0: 65 70 73 20 63 68 61 6e 67 65 64 29 29 0a 09 20 eps changed))..
bfc0: 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 74 61 (test-data
bfd0: 2d 69 64 73 20 20 28 61 6c 69 73 74 2d 72 65 66 -ids (alist-ref
bfe0: 20 27 74 65 73 74 5f 64 61 74 61 20 20 63 68 61 'test_data cha
bff0: 6e 67 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 nged)).. (
c000: 72 75 6e 2d 73 74 61 74 2d 69 64 73 20 20 20 28 run-stat-ids (
c010: 61 6c 69 73 74 2d 72 65 66 20 27 72 75 6e 5f 73 alist-ref 'run_s
c020: 74 61 74 73 20 20 63 68 61 6e 67 65 64 29 29 0a tats changed)).
c030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c040: 61 72 65 61 2d 74 61 67 20 20 20 20 28 69 66 20 area-tag (if
c050: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
c060: 61 72 65 61 2d 74 61 67 22 29 20 0a 20 20 20 20 area-tag") .
c070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c080: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 (ar
c090: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 65 gs:get-arg "-are
c0a0: 61 2d 74 61 67 22 29 0a 20 20 20 20 20 20 20 20 a-tag").
c0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c0c0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 72 (if (ar
c0d0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 65 gs:get-arg "-are
c0e0: 61 22 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 a") .
c0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c100: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
c110: 74 2d 61 72 67 20 22 2d 61 72 65 61 22 29 20 0a t-arg "-area") .
c120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c140: 20 20 20 22 22 29 29 29 29 0a 20 20 20 20 20 20 "")))).
c150: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 (if (and (e
c160: 71 75 61 6c 3f 20 61 72 65 61 2d 74 61 67 20 22 qual? area-tag "
c170: 22 29 20 28 6e 6f 74 20 28 70 67 64 62 3a 69 73 ") (not (pgdb:is
c180: 2d 61 72 65 61 2d 74 61 67 65 64 20 64 62 68 20 -area-taged dbh
c190: 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 61 (vector-ref area
c1a0: 2d 69 6e 66 6f 20 30 29 29 29 29 0a 20 20 20 20 -info 0)))).
c1b0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 61 72 (set! ar
c1c0: 65 61 2d 74 61 67 20 2a 64 65 66 61 75 6c 74 2d ea-tag *default-
c1d0: 61 72 65 61 2d 74 61 67 2a 29 29 20 0a 20 20 20 area-tag*)) .
c1e0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
c1f0: 20 28 65 71 75 61 6c 3f 20 61 72 65 61 2d 74 61 (equal? area-ta
c200: 67 20 22 22 29 29 20 0a 20 20 20 20 20 20 20 20 g "")) .
c210: 20 20 20 20 20 28 74 61 73 6b 3a 61 64 64 2d 61 (task:add-a
c220: 72 65 61 2d 74 61 67 20 64 62 68 20 61 72 65 61 rea-tag dbh area
c230: 2d 69 6e 66 6f 20 61 72 65 61 2d 74 61 67 29 29 -info area-tag))
c240: 20 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 . (if
c250: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d (not (null? run-
c260: 69 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ids)).
c270: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
c280: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
c290: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
c2a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
c2b0: 22 73 79 6e 63 69 6e 67 20 72 75 6e 73 3a 20 22 "syncing runs: "
c2c0: 20 72 75 6e 2d 69 64 73 29 20 20 20 0a 09 20 20 run-ids) ..
c2d0: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 (tasks:sync
c2e0: 2d 72 75 6e 2d 64 61 74 61 20 64 62 68 20 63 61 -run-data dbh ca
c2f0: 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 ched-info run-id
c300: 73 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c s area-info smal
c310: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
c320: 2d 74 69 6d 65 29 20 0a 20 20 20 20 20 20 20 20 -time) .
c330: 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 ).
c340: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
c350: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
c360: 2d 69 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 -ids)).
c370: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
c380: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
c390: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
c3a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
c3b0: 22 73 79 6e 63 69 6e 67 20 74 65 73 74 73 3a 20 "syncing tests:
c3c0: 22 20 74 65 73 74 2d 69 64 73 29 0a 09 20 20 20 " test-ids)..
c3d0: 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 (tasks:sync-t
c3e0: 65 73 74 73 2d 64 61 74 61 20 64 62 68 20 63 61 ests-data dbh ca
c3f0: 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d 69 ched-info test-i
c400: 64 73 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 ds area-info sma
c410: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
c420: 65 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 e-time).
c430: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
c440: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
c450: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 73 lt-log-port* "s
c460: 79 6e 63 69 6e 67 20 74 65 73 74 20 73 74 65 70 yncing test step
c470: 73 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s").
c480: 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 (tasks:sync-te
c490: 73 74 2d 73 74 65 70 73 20 64 62 68 20 63 61 63 st-steps dbh cac
c4a0: 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d 73 74 hed-info test-st
c4b0: 65 70 2d 69 64 73 20 73 6d 61 6c 6c 65 73 74 2d ep-ids smallest-
c4c0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
c4d0: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
c4e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
c4f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
c500: 20 22 73 79 6e 63 69 6e 67 20 74 65 73 74 20 64 "syncing test d
c510: 61 74 61 22 29 0a 20 20 20 20 20 20 20 20 20 20 ata").
c520: 20 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d (tasks:sync-
c530: 74 65 73 74 2d 67 65 6e 2d 64 61 74 61 20 64 62 test-gen-data db
c540: 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 h cached-info te
c550: 73 74 2d 64 61 74 61 2d 69 64 73 20 73 6d 61 6c st-data-ids smal
c560: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
c570: 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 -time).
c580: 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 29 ). )
c590: 0a 20 20 20 20 20 28 6c 65 74 2a 20 20 28 28 73 . (let* ((s
c5a0: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 61 mallest-time (ha
c5b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
c5c0: 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 ault smallest-la
c5d0: 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 st-update-time "
c5e0: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 28 smallest-time" (
c5f0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
c600: 29 29 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a ))). (debug:
c610: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 73 6d print-info 0 "sm
c620: 61 6c 6c 65 73 74 2d 74 69 6d 65 20 3a 22 20 73 allest-time :" s
c630: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 20 22 20 mallest-time "
c640: 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 22 last-sync-time "
c650: 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 last-sync-time)
c660: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 . (if (not (a
c670: 6e 64 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 nd target run-na
c680: 6d 65 29 29 20 0a 09 20 20 28 69 66 20 28 6f 72 me)) .. (if (or
c690: 20 28 61 6e 64 20 73 6d 61 6c 6c 65 73 74 2d 74 (and smallest-t
c6a0: 69 6d 65 20 28 3e 20 73 6d 61 6c 6c 65 73 74 2d ime (> smallest-
c6b0: 74 69 6d 65 20 6c 61 73 74 2d 73 79 6e 63 2d 74 time last-sync-t
c6c0: 69 6d 65 29 29 20 28 61 6e 64 20 73 6d 61 6c 6c ime)) (and small
c6d0: 65 73 74 2d 74 69 6d 65 20 28 65 71 3f 20 6c 61 est-time (eq? la
c6e0: 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 30 29 29 st-sync-time 0))
c6f0: 29 0a 09 09 09 09 28 70 67 64 62 3a 77 72 69 74 ).....(pgdb:writ
c700: 65 2d 73 79 6e 63 2d 74 69 6d 65 20 64 62 68 20 e-sync-time dbh
c710: 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 area-info smalle
c720: 73 74 2d 74 69 6d 65 29 29 29 29 29 20 3b 3b 74 st-time))))) ;;t
c730: 68 69 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 his needs to be
c740: 63 68 61 6e 67 65 64 0a 09 28 69 66 20 28 74 61 changed..(if (ta
c750: 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 62 68 sks:set-area dbh
c760: 20 63 6f 6e 66 69 67 64 61 74 29 0a 09 20 20 20 configdat)..
c770: 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 6f 2d (tasks:sync-to-
c780: 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 67 64 postgres configd
c790: 61 74 20 64 65 73 74 29 0a 09 20 20 20 20 28 62 at dest).. (b
c7a0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
c7b0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
c7c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
c7d0: 52 52 4f 52 3a 20 75 6e 61 62 6c 65 20 74 6f 20 RROR: unable to
c7e0: 63 72 65 61 74 65 20 61 6e 20 61 72 65 61 20 72 create an area r
c7f0: 65 63 6f 72 64 22 29 0a 09 20 20 20 20 20 20 23 ecord").. #
c800: 66 29 29 29 29 29 0a 0a f)))))..