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 29 29 0a 28 64 65 63 6c 61 72 65 20 28 db)).(declare (
03d0: 75 73 65 73 20 72 6d 74 29 29 0a 28 64 65 63 6c uses rmt)).(decl
03e0: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common
03f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0400: 73 20 70 67 64 62 29 29 0a 0a 3b 3b 20 28 69 6d s pgdb))..;; (im
0410: 70 6f 72 74 20 70 67 64 62 29 20 3b 3b 20 70 67 port pgdb) ;; pg
0420: 64 62 20 69 73 20 61 20 6d 6f 64 75 6c 65 0a 0a db is a module..
0430: 28 69 6e 63 6c 75 64 65 20 22 74 61 73 6b 5f 72 (include "task_r
0440: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0450: 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 clude "db_record
0460: 73 2e 73 63 6d 22 29 0a 0a 3b 3b 3d 3d 3d 3d 3d s.scm")..;;=====
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 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 0a 3b 3b 20 54 61 73 6b 73 20 64 62 0a 3b 3b =.;; Tasks db.;;
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 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 77 61 69 74 20 ======..;; wait
0510: 75 70 20 74 6f 20 61 70 72 6f 78 20 6e 20 73 65 up to aprox n se
0520: 63 6f 6e 64 73 20 66 6f 72 20 61 20 6a 6f 75 72 conds for a jour
0530: 6e 61 6c 20 74 6f 20 67 6f 20 61 77 61 79 0a 3b nal to go away.;
0540: 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ;.(define (tasks
0550: 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c :wait-on-journal
0560: 20 70 61 74 68 20 6e 20 23 21 6b 65 79 20 28 72 path n #!key (r
0570: 65 6d 6f 76 65 20 23 66 29 28 77 61 69 74 69 6e emove #f)(waitin
0580: 67 2d 6d 73 67 20 23 66 29 29 0a 20 20 28 69 66 g-msg #f)). (if
0590: 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 70 (not (string? p
05a0: 61 74 68 29 29 0a 20 20 20 20 20 20 28 64 65 62 ath)). (deb
05b0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
05c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
05d0: 72 74 2a 20 22 43 61 6c 6c 65 64 20 74 61 73 6b rt* "Called task
05e0: 73 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 s:wait-on-journa
05f0: 6c 20 77 69 74 68 20 70 61 74 68 3d 22 20 70 61 l with path=" pa
0600: 74 68 20 22 20 28 6e 6f 74 20 61 20 73 74 72 69 th " (not a stri
0610: 6e 67 29 22 29 0a 20 20 20 20 20 20 28 6c 65 74 ng)"). (let
0620: 20 28 28 66 75 6c 6c 70 61 74 68 20 28 63 6f 6e ((fullpath (con
0630: 63 20 70 61 74 68 20 22 2d 6a 6f 75 72 6e 61 6c c path "-journal
0640: 22 29 29 29 0a 09 28 68 61 6e 64 6c 65 2d 65 78 ")))..(handle-ex
0650: 63 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e 0a 09 ceptions.. exn..
0660: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 (begin.. (pri
0670: 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 nt-call-chain (c
0680: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
0690: 74 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 t)).. (debug:p
06a0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
06b0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
06c0: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
06d0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
06e0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
06f0: 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 28 64 ge) exn)).. (d
0700: 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 ebug:print 5 *de
0710: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0720: 22 20 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 " exn=" (conditi
0730: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 on->list exn))..
0740: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
0750: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
0760: 6f 72 74 2a 20 22 74 61 73 6b 73 3a 77 61 69 74 ort* "tasks:wait
0770: 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c 20 66 61 69 6c -on-journal fail
0780: 65 64 2e 20 43 6f 6e 74 69 6e 75 69 6e 67 20 6f ed. Continuing o
0790: 6e 2c 20 79 6f 75 20 63 61 6e 20 69 67 6e 6f 72 n, you can ignor
07a0: 65 20 74 68 69 73 20 63 61 6c 6c 2d 63 68 61 69 e this call-chai
07b0: 6e 22 29 0a 09 20 20 20 23 74 29 20 3b 3b 20 69 n").. #t) ;; i
07c0: 66 20 73 74 75 66 66 20 67 6f 65 73 20 77 72 6f f stuff goes wro
07d0: 6e 67 20 6a 75 73 74 20 61 6c 6c 6f 77 20 69 74 ng just allow it
07e0: 20 74 6f 20 6d 6f 76 65 20 6f 6e 0a 09 20 28 6c to move on.. (l
07f0: 65 74 20 6c 6f 6f 70 20 28 28 6a 6f 75 72 6e 61 et loop ((journa
0800: 6c 2d 65 78 69 73 74 73 20 28 63 6f 6d 6d 6f 6e l-exists (common
0810: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 :file-exists? fu
0820: 6c 6c 70 61 74 68 29 29 0a 09 09 20 20 20 20 28 llpath))... (
0830: 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 20 6e count n
0840: 29 29 20 3b 3b 20 77 61 69 74 20 74 65 6e 20 74 )) ;; wait ten t
0850: 69 6d 65 73 20 2e 2e 2e 0a 09 20 20 20 28 69 66 imes ..... (if
0860: 20 6a 6f 75 72 6e 61 6c 2d 65 78 69 73 74 73 0a journal-exists.
0870: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
0880: 09 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 69 . (if (and waiti
0890: 6e 67 2d 6d 73 67 0a 09 09 09 20 20 28 65 71 3f ng-msg.... (eq?
08a0: 20 28 6d 6f 64 75 6c 6f 20 6e 20 33 30 29 20 30 (modulo n 30) 0
08b0: 29 29 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 ))... (debug
08c0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
08d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 77 61 69 74 t-log-port* wait
08e0: 69 6e 67 2d 6d 73 67 29 29 0a 09 09 20 28 69 66 ing-msg))... (if
08f0: 20 28 3e 20 63 6f 75 6e 74 20 30 29 0a 09 09 20 (> count 0)...
0900: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
0910: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
0920: 70 21 20 31 29 0a 09 09 20 20 20 20 20 20 20 28 p! 1)... (
0930: 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c loop (common:fil
0940: 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 70 61 e-exists? fullpa
0950: 74 68 29 0a 09 09 09 20 20 20 20 20 28 2d 20 63 th).... (- c
0960: 6f 75 6e 74 20 31 29 29 29 0a 09 09 20 20 20 20 ount 1)))...
0970: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
0980: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
0990: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
09a0: 74 2a 20 22 45 52 52 4f 52 3a 20 72 65 6d 6f 76 t* "ERROR: remov
09b0: 69 6e 67 20 74 68 65 20 6a 6f 75 72 6e 61 6c 20 ing the journal
09c0: 66 69 6c 65 20 22 20 66 75 6c 6c 70 61 74 68 20 file " fullpath
09d0: 22 2c 20 74 68 69 73 20 69 73 20 6e 6f 74 20 67 ", this is not g
09e0: 6f 6f 64 2e 20 4c 6f 6f 6b 20 66 6f 72 20 64 69 ood. Look for di
09f0: 73 6b 20 66 75 6c 6c 2c 20 77 72 69 74 65 20 61 sk full, write a
0a00: 63 63 65 73 73 20 61 6e 64 20 6f 74 68 65 72 20 ccess and other
0a10: 69 73 73 75 65 73 2e 22 29 0a 09 09 20 20 20 20 issues.")...
0a20: 20 20 20 28 69 66 20 72 65 6d 6f 76 65 20 28 73 (if remove (s
0a30: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 ystem (conc "rm
0a40: 2d 72 66 20 22 20 66 75 6c 6c 70 61 74 68 29 29 -rf " fullpath))
0a50: 29 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 )... #f)))
0a60: 0a 09 20 20 20 20 20 20 20 23 74 29 29 29 29 29 .. #t)))))
0a70: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )..(define (task
0a80: 73 3a 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 61 s:get-task-db-pa
0a90: 74 68 29 0a 20 20 28 6c 65 74 20 28 28 64 62 64 th). (let ((dbd
0aa0: 69 72 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 ir (or (configf
0ab0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
0ac0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6d 6f 6e at* "setup" "mon
0ad0: 69 74 6f 72 64 69 72 22 29 0a 09 09 20 20 20 20 itordir")...
0ae0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
0af0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
0b00: 75 70 22 20 22 64 62 64 69 72 22 29 0a 09 09 20 up" "dbdir")...
0b10: 20 20 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e (conc (common
0b20: 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 20 22 :get-linktree) "
0b30: 2f 2e 64 62 22 29 29 29 29 0a 20 20 20 20 28 68 /.db")))). (h
0b40: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
0b50: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 . exn. (
0b60: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 65 begin. (de
0b70: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
0b80: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
0b90: 6f 72 74 2a 20 22 43 6f 75 6c 64 6e 27 74 20 63 ort* "Couldn't c
0ba0: 72 65 61 74 65 20 70 61 74 68 20 74 6f 20 22 20 reate path to "
0bb0: 64 62 64 69 72 29 0a 20 20 20 20 20 20 20 28 65 dbdir). (e
0bc0: 78 69 74 20 31 29 29 0a 20 20 20 20 20 28 69 66 xit 1)). (if
0bd0: 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 79 (not (directory
0be0: 3f 20 64 62 64 69 72 29 29 28 63 72 65 61 74 65 ? dbdir))(create
0bf0: 2d 64 69 72 65 63 74 6f 72 79 20 64 62 64 69 72 -directory dbdir
0c00: 20 23 74 29 29 29 0a 20 20 20 20 64 62 64 69 72 #t))). dbdir
0c10: 29 29 0a 0a 3b 3b 20 49 66 20 66 69 6c 65 20 65 ))..;; If file e
0c20: 78 69 73 74 73 20 41 4e 44 0a 3b 3b 20 20 20 20 xists AND.;;
0c30: 66 69 6c 65 20 72 65 61 64 61 62 6c 65 0a 3b 3b file readable.;;
0c40: 20 20 20 20 20 20 20 20 20 3d 3d 3e 20 6f 70 65 ==> ope
0c50: 6e 20 69 74 0a 3b 3b 20 49 66 20 66 69 6c 65 20 n it.;; If file
0c60: 65 78 69 73 74 73 20 41 4e 44 0a 3b 3b 20 20 20 exists AND.;;
0c70: 20 66 69 6c 65 20 4e 4f 54 20 72 65 61 64 61 62 file NOT readab
0c80: 6c 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 3d 3d le.;; ==
0c90: 3e 20 6f 70 65 6e 20 69 6e 2d 6d 65 6d 20 76 65 > open in-mem ve
0ca0: 72 73 69 6f 6e 0a 3b 3b 20 49 66 20 66 69 6c 65 rsion.;; If file
0cb0: 20 4e 4f 54 20 65 78 69 73 74 73 0a 3b 3b 20 20 NOT exists.;;
0cc0: 20 20 3d 3d 3e 20 6f 70 65 6e 20 69 6e 2d 6d 65 ==> open in-me
0cd0: 6d 20 76 65 72 73 69 6f 6e 0a 3b 3b 0a 28 64 65 m version.;;.(de
0ce0: 66 69 6e 65 20 28 74 61 73 6b 73 3a 6f 70 65 6e fine (tasks:open
0cf0: 2d 64 62 20 23 21 6b 65 79 20 28 6e 75 6d 72 65 -db #!key (numre
0d00: 74 72 69 65 73 20 34 29 29 0a 20 20 28 69 66 20 tries 4)). (if
0d10: 2a 74 61 73 6b 2d 64 62 2a 0a 20 20 20 20 20 20 *task-db*.
0d20: 2a 74 61 73 6b 2d 64 62 2a 0a 20 20 20 20 20 20 *task-db*.
0d30: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
0d40: 6e 73 0a 20 20 20 20 20 20 20 65 78 6e 0a 20 20 ns. exn.
0d50: 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 (if (> numr
0d60: 65 74 72 69 65 73 20 30 29 0a 09 20 20 20 28 62 etries 0).. (b
0d70: 65 67 69 6e 0a 09 20 20 20 20 20 28 70 72 69 6e egin.. (prin
0d80: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
0d90: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
0da0: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
0db0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0dc0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 -log-port* " mes
0dd0: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
0de0: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
0df0: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
0e00: 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 age) exn))..
0e10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
0e20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0e30: 74 2a 20 22 20 65 78 6e 3d 22 20 28 63 6f 6e 64 t* " exn=" (cond
0e40: 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
0e50: 29 0a 09 20 20 20 20 20 28 74 68 72 65 61 64 2d ).. (thread-
0e60: 73 6c 65 65 70 21 20 31 29 0a 09 20 20 20 20 20 sleep! 1)..
0e70: 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 6e (tasks:open-db n
0e80: 75 6d 72 65 74 72 69 65 73 20 28 2d 20 6e 75 6d umretries (- num
0e90: 72 65 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 retries 1)))..
0ea0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 70 (begin.. (p
0eb0: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
0ec0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
0ed0: 6f 72 74 29 29 0a 09 20 20 20 20 20 28 64 65 62 ort)).. (deb
0ee0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
0ef0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
0f00: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
0f10: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
0f20: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
0f30: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 essage) exn))..
0f40: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0f50: 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 5 *default-log-
0f60: 70 6f 72 74 2a 20 22 20 65 78 6e 3d 22 20 28 63 port* " exn=" (c
0f70: 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 ondition->list e
0f80: 78 6e 29 29 29 29 0a 20 20 20 20 20 20 20 28 6c xn)))). (l
0f90: 65 74 2a 20 28 28 64 62 70 61 74 68 20 20 20 20 et* ((dbpath
0fa0: 20 20 20 20 28 64 62 3a 64 62 66 69 6c 65 2d 70 (db:dbfile-p
0fb0: 61 74 68 20 29 29 20 3b 3b 20 28 74 61 73 6b 73 ath )) ;; (tasks
0fc0: 3a 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 61 74 :get-task-db-pat
0fd0: 68 29 29 0a 09 20 20 20 20 20 20 28 64 62 66 69 h)).. (dbfi
0fe0: 6c 65 20 20 20 20 20 20 20 28 63 6f 6e 63 20 64 le (conc d
0ff0: 62 70 61 74 68 20 22 2f 6d 6f 6e 69 74 6f 72 2e bpath "/monitor.
1000: 64 62 22 29 29 0a 09 20 20 20 20 20 20 28 61 76 db")).. (av
1010: 61 69 6c 20 20 20 20 20 20 20 20 28 74 61 73 6b ail (task
1020: 73 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 s:wait-on-journa
1030: 6c 20 64 62 70 61 74 68 20 31 30 29 29 20 3b 3b l dbpath 10)) ;;
1040: 20 77 61 69 74 20 75 70 20 74 6f 20 61 62 6f 75 wait up to abou
1050: 74 20 31 30 20 73 65 63 6f 6e 64 73 20 66 6f 72 t 10 seconds for
1060: 20 74 68 65 20 6a 6f 75 72 6e 61 6c 20 74 6f 20 the journal to
1070: 67 6f 20 61 77 61 79 0a 09 20 20 20 20 20 20 28 go away.. (
1080: 65 78 69 73 74 73 20 20 20 20 20 20 20 28 63 6f exists (co
1090: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
10a0: 3f 20 64 62 70 61 74 68 29 29 0a 09 20 20 20 20 ? dbpath))..
10b0: 20 20 28 77 72 69 74 65 2d 61 63 63 65 73 73 20 (write-access
10c0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
10d0: 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 20 ss? dbpath))..
10e0: 20 20 20 20 28 6d 64 62 20 20 20 20 20 20 20 20 (mdb
10f0: 20 20 28 63 6f 6e 64 20 3b 3b 20 77 68 61 74 20 (cond ;; what
1100: 74 68 65 20 68 65 6b 20 69 73 20 2a 74 6f 70 70 the hek is *topp
1110: 61 74 68 2a 20 64 6f 69 6e 67 20 68 65 72 65 3f ath* doing here?
1120: 0a 09 09 09 20 20 20 20 20 28 28 61 6e 64 20 28 .... ((and (
1130: 73 74 72 69 6e 67 3f 20 2a 74 6f 70 70 61 74 68 string? *toppath
1140: 2a 29 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 *)(file-write-ac
1150: 63 65 73 73 3f 20 2a 74 6f 70 70 61 74 68 2a 29 cess? *toppath*)
1160: 29 0a 09 09 09 20 20 20 20 20 20 28 73 71 6c 69 ).... (sqli
1170: 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 te3:open-databas
1180: 65 20 64 62 66 69 6c 65 29 29 0a 09 09 09 20 20 e dbfile))....
1190: 20 20 20 28 28 66 69 6c 65 2d 72 65 61 64 2d 61 ((file-read-a
11a0: 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 20 20 ccess? dbpath)
11b0: 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d (sqlite3:open-
11c0: 64 61 74 61 62 61 73 65 20 64 62 66 69 6c 65 29 database dbfile)
11d0: 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 ).... (else
11e0: 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 (sqlite3:open-da
11f0: 74 61 62 61 73 65 20 22 3a 6d 65 6d 6f 72 79 3a tabase ":memory:
1200: 22 29 29 29 29 20 3b 3b 20 28 6e 65 76 65 72 2d ")))) ;; (never-
1210: 67 69 76 65 2d 75 70 2d 6f 70 65 6e 2d 64 62 20 give-up-open-db
1220: 64 62 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 dbpath))..
1230: 28 68 61 6e 64 6c 65 72 20 20 20 20 20 20 28 73 (handler (s
1240: 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 qlite3:make-busy
1250: 2d 74 69 6d 65 6f 75 74 20 33 36 30 30 30 29 29 -timeout 36000))
1260: 29 0a 09 20 28 69 66 20 28 61 6e 64 20 65 78 69 ).. (if (and exi
1270: 73 74 73 0a 09 09 20 20 28 6e 6f 74 20 77 72 69 sts... (not wri
1280: 74 65 2d 61 63 63 65 73 73 29 29 0a 09 20 20 20 te-access))..
1290: 20 20 28 73 65 74 21 20 2a 64 62 2d 77 72 69 74 (set! *db-writ
12a0: 65 2d 61 63 63 65 73 73 2a 20 77 72 69 74 65 2d e-access* write-
12b0: 61 63 63 65 73 73 29 29 20 3b 3b 20 6f 6e 6c 79 access)) ;; only
12c0: 20 75 6e 73 65 74 20 73 6f 20 6f 74 68 65 72 20 unset so other
12d0: 64 62 27 73 20 61 6c 73 6f 20 63 61 6e 20 75 73 db's also can us
12e0: 65 20 74 68 69 73 20 63 6f 6e 74 72 6f 6c 0a 09 e this control..
12f0: 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 (sqlite3:set-bu
1300: 73 79 2d 68 61 6e 64 6c 65 72 21 20 6d 64 62 20 sy-handler! mdb
1310: 68 61 6e 64 6c 65 72 29 0a 09 20 28 64 62 3a 73 handler).. (db:s
1320: 65 74 2d 73 79 6e 63 20 6d 64 62 29 20 3b 3b 20 et-sync mdb) ;;
1330: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
1340: 20 6d 64 62 20 28 63 6f 6e 63 20 22 50 52 41 47 mdb (conc "PRAG
1350: 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d MA synchronous =
1360: 20 30 3b 22 29 29 0a 09 20 3b 3b 20 20 28 69 66 0;")).. ;; (if
1370: 20 28 6f 72 20 28 61 6e 64 20 28 6e 6f 74 20 65 (or (and (not e
1380: 78 69 73 74 73 29 0a 09 20 3b 3b 20 09 20 20 20 xists).. ;; .
1390: 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 (file-write-a
13a0: 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 74 68 2a ccess? *toppath*
13b0: 29 29 0a 09 20 3b 3b 20 09 20 28 6e 6f 74 20 28 )).. ;; . (not (
13c0: 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 file-read-access
13d0: 3f 20 64 62 70 61 74 68 29 29 29 0a 09 20 3b 3b ? dbpath))).. ;;
13e0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 3b (begin.. ;
13f0: 3b 20 0a 09 20 3b 3b 20 54 41 53 4b 53 20 51 55 ; .. ;; TASKS QU
1400: 45 55 45 20 4d 4f 56 45 44 20 54 4f 20 6d 61 69 EUE MOVED TO mai
1410: 6e 2e 64 62 0a 09 20 3b 3b 0a 09 20 3b 3b 20 28 n.db.. ;;.. ;; (
1420: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
1430: 6d 64 62 20 22 43 52 45 41 54 45 20 54 41 42 4c mdb "CREATE TABL
1440: 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
1450: 74 61 73 6b 73 5f 71 75 65 75 65 20 28 69 64 20 tasks_queue (id
1460: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
1470: 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b KEY,. ;;
1480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1490: 20 20 20 20 20 20 20 20 61 63 74 69 6f 6e 20 54 action T
14a0: 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a EXT DEFAULT '',.
14b0: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
14c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14d0: 20 20 20 6f 77 6e 65 72 20 54 45 58 54 2c 0a 20 owner TEXT,.
14e0: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
14f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1500: 20 20 73 74 61 74 65 20 54 45 58 54 20 44 45 46 state TEXT DEF
1510: 41 55 4c 54 20 27 6e 65 77 27 2c 0a 20 20 20 20 AULT 'new',.
1520: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
1530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
1540: 61 72 67 65 74 20 54 45 58 54 20 44 45 46 41 55 arget TEXT DEFAU
1550: 4c 54 20 27 27 2c 0a 20 20 20 20 20 20 20 20 20 LT '',.
1560: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
1570: 20 20 20 20 20 20 20 20 20 20 6e 61 6d 65 20 54 name T
1580: 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a EXT DEFAULT '',.
1590: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
15a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15b0: 20 20 20 74 65 73 74 70 61 74 74 20 54 45 58 54 testpatt TEXT
15c0: 20 44 45 46 41 55 4c 54 20 27 27 2c 0a 20 20 20 DEFAULT '',.
15d0: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
15e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15f0: 6b 65 79 6c 6f 63 6b 20 54 45 58 54 2c 0a 20 20 keylock TEXT,.
1600: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
1610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1620: 20 70 61 72 61 6d 73 20 54 45 58 54 2c 0a 20 20 params TEXT,.
1630: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
1640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1650: 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 20 54 creation_time T
1660: 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 IMESTAMP,.
1670: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
1680: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 78 65 exe
1690: 63 75 74 69 6f 6e 5f 74 69 6d 65 20 54 49 4d 45 cution_time TIME
16a0: 53 54 41 4d 50 29 3b 22 29 0a 09 20 28 73 71 6c STAMP);").. (sql
16b0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 ite3:execute mdb
16c0: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
16d0: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 6d 6f 6e F NOT EXISTS mon
16e0: 69 74 6f 72 73 20 28 69 64 20 49 4e 54 45 47 45 itors (id INTEGE
16f0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 R PRIMARY KEY,.
1700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 p
1720: 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 id INTEGER,.
1730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1740: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 72 star
1750: 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 t_time TIMESTAMP
1760: 2c 0a 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 20 6c 61 73 74 5f 75 70 64 61 74 65 20 54 49 last_update TI
1790: 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 MESTAMP,.
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 20 20 68 6f 73 74 6e 61 6d hostnam
17c0: 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 e TEXT,.
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 75 73 65 72 6e 61 6d 65 username
17f0: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 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 43 4f 4e 53 54 52 41 49 4e 54 CONSTRAINT
1820: 20 6d 6f 6e 69 74 6f 72 73 5f 63 6f 6e 73 74 72 monitors_constr
1830: 61 69 6e 74 20 55 4e 49 51 55 45 20 28 70 69 64 aint UNIQUE (pid
1840: 2c 68 6f 73 74 6e 61 6d 65 29 29 3b 22 29 0a 09 ,hostname));")..
1850: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
1860: 65 20 6d 64 62 20 22 43 52 45 41 54 45 20 54 41 e mdb "CREATE TA
1870: 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 BLE IF NOT EXIST
1880: 53 20 73 65 72 76 65 72 73 20 28 69 64 20 49 4e S servers (id IN
1890: 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 TEGER PRIMARY KE
18a0: 59 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 Y,.
18b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18c0: 20 20 20 20 20 70 69 64 20 49 4e 54 45 47 45 52 pid INTEGER
18d0: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
18e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18f0: 20 20 20 20 69 6e 74 65 72 66 61 63 65 20 54 45 interface TE
1900: 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 XT,.
1910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1920: 20 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 54 hostname T
1930: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 EXT,.
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 70 6f 72 74 20 49 4e 54 45 port INTE
1960: 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 20 GER,.
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 70 75 62 70 6f 72 74 20 49 pubport I
1990: 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 NTEGER,.
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 73 74 61 72 74 5f start_
19c0: 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 2c 0a time TIMESTAMP,.
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 20
19f0: 20 20 70 72 69 6f 72 69 74 79 20 49 4e 54 45 47 priority INTEG
1a00: 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 ER,.
1a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a20: 20 20 20 20 20 20 73 74 61 74 65 20 54 45 58 54 state TEXT
1a30: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
1a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a50: 20 20 20 20 6d 74 5f 76 65 72 73 69 6f 6e 20 54 mt_version T
1a60: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 EXT,.
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 68 65 61 72 74 62 65 61 74 heartbeat
1a90: 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 TIMESTAMP,.
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 20 20 74 72 tr
1ac0: 61 6e 73 70 6f 72 74 20 54 45 58 54 2c 0a 20 20 ansport TEXT,.
1ad0: 20 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: 72 75 6e 5f 69 64 20 49 4e 54 45 47 45 52 29 3b run_id INTEGER);
1b00: 22 29 0a 09 20 3b 3b 20 20 20 20 20 20 20 20 20 ").. ;;
1b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b20: 20 20 20 20 20 20 43 4f 4e 53 54 52 41 49 4e 54 CONSTRAINT
1b30: 20 73 65 72 76 65 72 73 5f 63 6f 6e 73 74 72 61 servers_constra
1b40: 69 6e 74 20 55 4e 49 51 55 45 20 28 70 69 64 2c int UNIQUE (pid,
1b50: 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 29 29 3b hostname,port));
1b60: 22 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 ").. (sqlite3:ex
1b70: 65 63 75 74 65 20 6d 64 62 20 22 43 52 45 41 54 ecute mdb "CREAT
1b80: 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 E TABLE IF NOT E
1b90: 58 49 53 54 53 20 63 6c 69 65 6e 74 73 20 28 69 XISTS clients (i
1ba0: 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 d INTEGER PRIMAR
1bb0: 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 Y KEY,.
1bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1bd0: 20 20 20 20 20 20 20 20 20 73 65 72 76 65 72 5f server_
1be0: 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 id INTEGER,.
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 70 69 pi
1c10: 64 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 d INTEGER,.
1c20: 20 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 68 6f 73 hos
1c40: 74 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 tname TEXT,.
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 63 6d cm
1c70: 64 6c 69 6e 65 20 54 45 58 54 2c 0a 20 20 20 20 dline TEXT,.
1c80: 20 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 6c 6f lo
1ca0: 67 69 6e 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 gin_time TIMESTA
1cb0: 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 MP,.
1cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cd0: 20 20 20 20 20 20 6c 6f 67 6f 75 74 5f 74 69 6d logout_tim
1ce0: 65 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 e TIMESTAMP DEFA
1cf0: 55 4c 54 20 2d 31 2c 0a 20 20 20 20 20 20 20 20 ULT -1,.
1d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d10: 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 49 CONSTRAI
1d20: 4e 54 20 63 6c 69 65 6e 74 73 5f 63 6f 6e 73 74 NT clients_const
1d30: 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 70 69 raint UNIQUE (pi
1d40: 64 2c 68 6f 73 74 6e 61 6d 65 29 29 3b 22 29 0a d,hostname));").
1d50: 09 20 20 20 20 20 20 20 0a 09 20 20 20 20 20 20 . ..
1d60: 20 3b 29 29 0a 09 20 28 73 65 74 21 20 2a 74 61 ;)).. (set! *ta
1d70: 73 6b 2d 64 62 2a 20 28 63 6f 6e 73 20 6d 64 62 sk-db* (cons mdb
1d80: 20 64 62 70 61 74 68 29 29 0a 09 20 2a 74 61 73 dbpath)).. *tas
1d90: 6b 2d 64 62 2a 29 29 29 29 0a 0a 3b 3b 3d 3d 3d k-db*))))..;;===
1da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1de0: 3d 3d 3d 0a 3b 3b 20 53 65 72 76 65 72 20 61 6e ===.;; Server an
1df0: 64 20 63 6c 69 65 6e 74 20 6d 61 6e 61 67 65 6d d client managem
1e00: 65 6e 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ent.;;==========
1e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
1e50: 20 6d 61 6b 65 2d 76 65 63 74 6f 72 2d 72 65 63 make-vector-rec
1e60: 6f 72 64 20 74 61 73 6b 73 20 68 6f 73 74 69 6e ord tasks hostin
1e70: 66 6f 20 69 64 20 69 6e 74 65 72 66 61 63 65 20 fo id interface
1e80: 70 6f 72 74 20 70 75 62 70 6f 72 74 20 74 72 61 port pubport tra
1e90: 6e 73 70 6f 72 74 20 70 69 64 20 68 6f 73 74 6e nsport pid hostn
1ea0: 61 6d 65 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ame.(define (tas
1eb0: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get-
1ec0: 69 64 20 20 20 20 20 20 20 20 20 20 76 65 63 29 id vec)
1ed0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
1ee0: 20 76 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 vec 0)).(define
1ef0: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
1f00: 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 20 -get-interface
1f10: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
1f20: 2d 72 65 66 20 20 76 65 63 20 31 29 29 0a 28 64 -ref vec 1)).(d
1f30: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 efine (tasks:hos
1f40: 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 20 20 tinfo-get-port
1f50: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
1f60: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
1f70: 29 29 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )).(define (task
1f80: 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 s:hostinfo-get-p
1f90: 75 62 70 6f 72 74 20 20 20 20 20 76 65 63 29 20 ubport vec)
1fa0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
1fb0: 76 65 63 20 33 29 29 0a 28 64 65 66 69 6e 65 20 vec 3)).(define
1fc0: 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d (tasks:hostinfo-
1fd0: 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 20 20 20 get-transport
1fe0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
1ff0: 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 64 65 ref vec 4)).(de
2000: 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 fine (tasks:host
2010: 69 6e 66 6f 2d 67 65 74 2d 70 69 64 20 20 20 20 info-get-pid
2020: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
2030: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 29 ctor-ref vec 5)
2040: 29 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ).(define (tasks
2050: 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 68 6f :hostinfo-get-ho
2060: 73 74 6e 61 6d 65 20 20 20 20 76 65 63 29 20 20 stname vec)
2070: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
2080: 65 63 20 36 29 29 0a 0a 28 64 65 66 69 6e 65 20 ec 6))..(define
2090: 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 65 72 76 (tasks:need-serv
20a0: 65 72 20 72 75 6e 2d 69 64 29 0a 20 20 28 65 71 er run-id). (eq
20b0: 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ual? (configf:lo
20c0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
20d0: 20 22 73 65 72 76 65 72 22 20 22 72 65 71 75 69 "server" "requi
20e0: 72 65 64 22 29 20 22 79 65 73 22 29 29 0a 0a 3b red") "yes"))..;
20f0: 3b 20 6e 6f 20 65 6c 65 67 61 6e 63 65 20 68 65 ; no elegance he
2100: 72 65 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 6e re ....;;.(defin
2110: 65 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 e (tasks:kill-se
2120: 72 76 65 72 20 68 6f 73 74 6e 61 6d 65 20 70 69 rver hostname pi
2130: 64 20 23 21 6b 65 79 20 28 6b 69 6c 6c 2d 73 77 d #!key (kill-sw
2140: 69 74 63 68 20 22 22 29 29 0a 20 20 28 64 65 62 itch "")). (deb
2150: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
2160: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2170: 74 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 t* "Attempting t
2180: 6f 20 6b 69 6c 6c 20 73 65 72 76 65 72 20 70 72 o kill server pr
2190: 6f 63 65 73 73 20 22 20 70 69 64 20 22 20 6f 6e ocess " pid " on
21a0: 20 68 6f 73 74 20 22 20 68 6f 73 74 6e 61 6d 65 host " hostname
21b0: 29 0a 20 20 28 73 65 74 65 6e 76 20 22 54 41 52 ). (setenv "TAR
21c0: 47 45 54 48 4f 53 54 22 20 68 6f 73 74 6e 61 6d GETHOST" hostnam
21d0: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 67 e). (let* ((log
21e0: 64 69 72 20 28 69 66 20 28 64 69 72 65 63 74 6f dir (if (directo
21f0: 72 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f 67 73 ry-exists? "logs
2200: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
2210: 20 20 20 20 20 20 20 22 6c 6f 67 73 2f 22 0a 20 "logs/".
2220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2230: 20 20 20 22 22 29 29 0a 20 20 20 20 20 20 20 20 "")).
2240: 20 28 6c 6f 67 66 69 6c 65 20 28 69 66 20 6c 6f (logfile (if lo
2250: 67 64 69 72 20 28 63 6f 6e 63 20 22 6c 6f 67 73 gdir (conc "logs
2260: 2f 73 65 72 76 65 72 2d 22 70 69 64 22 2d 22 68 /server-"pid"-"h
2270: 6f 73 74 6e 61 6d 65 22 2e 6c 6f 67 22 29 20 23 ostname".log") #
2280: 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 67 7a f)). (gz
2290: 66 69 6c 65 20 20 28 69 66 20 6c 6f 67 66 69 6c file (if logfil
22a0: 65 20 28 63 6f 6e 63 20 6c 6f 67 66 69 6c 65 20 e (conc logfile
22b0: 22 2e 67 7a 22 29 29 29 29 0a 20 20 20 20 28 73 ".gz")))). (s
22c0: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
22d0: 54 5f 4c 4f 47 46 22 20 28 63 6f 6e 63 20 6c 6f T_LOGF" (conc lo
22e0: 67 64 69 72 20 22 73 65 72 76 65 72 2d 6b 69 6c gdir "server-kil
22f0: 6c 73 2e 6c 6f 67 22 29 29 0a 0a 20 20 20 20 28 ls.log")).. (
2300: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6e 62 system (conc "nb
2310: 66 61 6b 65 20 6b 69 6c 6c 20 22 6b 69 6c 6c 2d fake kill "kill-
2320: 73 77 69 74 63 68 22 20 22 70 69 64 29 29 0a 0a switch" "pid))..
2330: 20 20 20 20 28 77 68 65 6e 20 6c 6f 67 66 69 6c (when logfil
2340: 65 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d e. (thread-
2350: 73 6c 65 65 70 21 20 30 2e 35 29 0a 20 20 20 20 sleep! 0.5).
2360: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (if (common:fi
2370: 6c 65 2d 65 78 69 73 74 73 3f 20 67 7a 66 69 6c le-exists? gzfil
2380: 65 29 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 e) (delete-file
2390: 67 7a 66 69 6c 65 29 29 0a 20 20 20 20 20 20 28 gzfile)). (
23a0: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 67 7a system (conc "gz
23b0: 69 70 20 22 20 6c 6f 67 66 69 6c 65 29 29 0a 20 ip " logfile)).
23c0: 20 20 20 20 20 0a 20 20 20 20 20 20 28 75 6e 73 . (uns
23d0: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
23e0: 54 5f 4c 4f 47 46 22 29 0a 20 20 20 20 20 20 28 T_LOGF"). (
23f0: 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 unsetenv "TARGET
2400: 48 4f 53 54 22 29 29 29 29 0a 20 20 20 20 0a 20 HOST")))). .
2410: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 4f =========.;; M O
2460: 20 4e 20 49 20 54 20 4f 20 52 20 53 0a 3b 3b 3d N I T O R S.;;=
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 3d 3d ================
2490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24b0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
24c0: 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d 6d 6f 6e tasks:remove-mon
24d0: 69 74 6f 72 2d 72 65 63 6f 72 64 20 6d 64 62 29 itor-record mdb)
24e0: 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 . (sqlite3:exec
24f0: 75 74 65 20 6d 64 62 20 22 44 45 4c 45 54 45 20 ute mdb "DELETE
2500: 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 73 20 57 48 FROM monitors WH
2510: 45 52 45 20 70 69 64 3d 3f 20 41 4e 44 20 68 6f ERE pid=? AND ho
2520: 73 74 6e 61 6d 65 3d 3f 3b 22 0a 09 09 20 20 20 stname=?;"...
2530: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
2540: 2d 69 64 29 0a 09 09 20 20 20 28 67 65 74 2d 68 -id)... (get-h
2550: 6f 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 65 ost-name)))..(de
2560: 66 69 6e 65 20 28 74 61 73 6b 73 3a 67 65 74 2d fine (tasks:get-
2570: 6d 6f 6e 69 74 6f 72 73 20 6d 64 62 29 0a 20 20 monitors mdb).
2580: 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 29 (let ((res '()))
2590: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
25a0: 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 r-each-row.
25b0: 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 65 6d (lambda (a . rem
25c0: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
25d0: 65 73 20 28 63 6f 6e 73 20 28 61 70 70 6c 79 20 es (cons (apply
25e0: 76 65 63 74 6f 72 20 61 20 72 65 6d 29 20 72 65 vector a rem) re
25f0: 73 29 29 29 0a 20 20 20 20 20 6d 64 62 0a 20 20 s))). mdb.
2600: 20 20 20 22 53 45 4c 45 43 54 20 69 64 2c 70 69 "SELECT id,pi
2610: 64 2c 73 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 d,strftime('%m/%
2620: 64 2f 25 59 20 25 48 3a 25 4d 27 2c 64 61 74 65 d/%Y %H:%M',date
2630: 74 69 6d 65 28 73 74 61 72 74 5f 74 69 6d 65 2c time(start_time,
2640: 27 75 6e 69 78 65 70 6f 63 68 27 29 2c 27 6c 6f 'unixepoch'),'lo
2650: 63 61 6c 74 69 6d 65 27 29 2c 73 74 72 66 74 69 caltime'),strfti
2660: 6d 65 28 27 25 6d 2f 25 64 2f 25 59 20 25 48 3a me('%m/%d/%Y %H:
2670: 25 4d 3a 25 53 27 2c 64 61 74 65 74 69 6d 65 28 %M:%S',datetime(
2680: 6c 61 73 74 5f 75 70 64 61 74 65 2c 27 75 6e 69 last_update,'uni
2690: 78 65 70 6f 63 68 27 29 2c 27 6c 6f 63 61 6c 74 xepoch'),'localt
26a0: 69 6d 65 27 29 2c 68 6f 73 74 6e 61 6d 65 2c 75 ime'),hostname,u
26b0: 73 65 72 6e 61 6d 65 20 46 52 4f 4d 20 6d 6f 6e sername FROM mon
26c0: 69 74 6f 72 73 20 4f 52 44 45 52 20 42 59 20 6c itors ORDER BY l
26d0: 61 73 74 5f 75 70 64 61 74 65 20 41 53 43 3b 22 ast_update ASC;"
26e0: 29 0a 20 20 20 20 28 72 65 76 65 72 73 65 20 72 ). (reverse r
26f0: 65 73 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 es). ))..(def
2700: 69 6e 65 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 ine (tasks:monit
2710: 6f 72 73 2d 3e 74 65 78 74 2d 74 61 62 6c 65 20 ors->text-table
2720: 6d 6f 6e 69 74 6f 72 73 29 0a 20 20 28 6c 65 74 monitors). (let
2730: 20 28 28 66 6d 74 73 74 72 20 22 7e 34 61 7e 38 ((fmtstr "~4a~8
2740: 61 7e 32 30 61 7e 32 30 61 7e 31 30 61 7e 31 30 a~20a~20a~10a~10
2750: 61 22 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 a")). (conc (
2760: 66 6f 72 6d 61 74 20 23 66 20 66 6d 74 73 74 72 format #f fmtstr
2770: 20 22 69 64 22 20 22 70 69 64 22 20 22 73 74 61 "id" "pid" "sta
2780: 72 74 20 74 69 6d 65 22 20 22 6c 61 73 74 20 75 rt time" "last u
2790: 70 64 61 74 65 22 20 22 68 6f 73 74 6e 61 6d 65 pdate" "hostname
27a0: 22 20 22 75 73 65 72 22 29 20 22 5c 6e 22 0a 09 " "user") "\n"..
27b0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
27c0: 70 65 72 73 65 20 0a 09 20 20 20 28 6d 61 70 20 perse .. (map
27d0: 28 6c 61 6d 62 64 61 20 28 6d 6f 6e 69 74 6f 72 (lambda (monitor
27e0: 29 0a 09 09 20 20 28 66 6f 72 6d 61 74 20 23 66 )... (format #f
27f0: 20 66 6d 74 73 74 72 0a 09 09 09 20 20 28 74 61 fmtstr.... (ta
2800: 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d sks:monitor-get-
2810: 69 64 20 20 20 20 20 20 20 20 20 20 6d 6f 6e 69 id moni
2820: 74 6f 72 29 0a 09 09 09 20 20 28 74 61 73 6b 73 tor).... (tasks
2830: 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 70 69 64 :monitor-get-pid
2840: 20 20 20 20 20 20 20 20 20 6d 6f 6e 69 74 6f 72 monitor
2850: 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f ).... (tasks:mo
2860: 6e 69 74 6f 72 2d 67 65 74 2d 73 74 61 72 74 5f nitor-get-start_
2870: 74 69 6d 65 20 20 6d 6f 6e 69 74 6f 72 29 0a 09 time monitor)..
2880: 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 .. (tasks:monit
2890: 6f 72 2d 67 65 74 2d 6c 61 73 74 5f 75 70 64 61 or-get-last_upda
28a0: 74 65 20 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 te monitor)....
28b0: 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d (tasks:monitor-
28c0: 67 65 74 2d 68 6f 73 74 6e 61 6d 65 20 20 20 20 get-hostname
28d0: 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 20 28 74 monitor).... (t
28e0: 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 asks:monitor-get
28f0: 2d 75 73 65 72 6e 61 6d 65 20 20 20 20 6d 6f 6e -username mon
2900: 69 74 6f 72 29 29 29 0a 09 09 6d 6f 6e 69 74 6f itor)))...monito
2910: 72 73 29 0a 09 20 20 20 22 5c 6e 22 29 29 29 29 rs).. "\n"))))
2920: 0a 20 20 20 0a 3b 3b 20 75 70 64 61 74 65 20 74 . .;; update t
2930: 68 65 20 6c 61 73 74 5f 75 70 64 61 74 65 20 66 he last_update f
2940: 69 65 6c 64 20 77 69 74 68 20 74 68 65 20 63 75 ield with the cu
2950: 72 72 65 6e 74 20 74 69 6d 65 20 61 6e 64 0a 3b rrent time and.;
2960: 3b 20 69 66 20 61 6e 79 20 6d 6f 6e 69 74 6f 72 ; if any monitor
2970: 73 20 61 70 70 65 61 72 20 64 65 61 64 2c 20 72 s appear dead, r
2980: 65 6d 6f 76 65 20 74 68 65 6d 0a 28 64 65 66 69 emove them.(defi
2990: 6e 65 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f ne (tasks:monito
29a0: 72 73 2d 75 70 64 61 74 65 20 6d 64 62 29 0a 20 rs-update mdb).
29b0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
29c0: 65 20 6d 64 62 20 22 55 50 44 41 54 45 20 6d 6f e mdb "UPDATE mo
29d0: 6e 69 74 6f 72 73 20 53 45 54 20 6c 61 73 74 5f nitors SET last_
29e0: 75 70 64 61 74 65 3d 73 74 72 66 74 69 6d 65 28 update=strftime(
29f0: 27 25 73 27 2c 27 6e 6f 77 27 29 20 57 48 45 52 '%s','now') WHER
2a00: 45 20 70 69 64 3d 3f 20 41 4e 44 20 68 6f 73 74 E pid=? AND host
2a10: 6e 61 6d 65 3d 3f 3b 22 0a 09 09 09 20 20 28 63 name=?;".... (c
2a20: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
2a30: 64 29 0a 09 09 09 20 20 28 67 65 74 2d 68 6f 73 d).... (get-hos
2a40: 74 2d 6e 61 6d 65 29 29 0a 20 20 28 6c 65 74 20 t-name)). (let
2a50: 28 28 64 65 61 64 6c 69 73 74 20 27 28 29 29 29 ((deadlist '()))
2a60: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
2a70: 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 r-each-row.
2a80: 28 6c 61 6d 62 64 61 20 28 69 64 20 70 69 64 20 (lambda (id pid
2a90: 68 6f 73 74 20 6c 61 73 74 2d 75 70 64 61 74 65 host last-update
2aa0: 20 64 65 6c 74 61 29 0a 20 20 20 20 20 20 20 28 delta). (
2ab0: 70 72 69 6e 74 20 22 47 6f 69 6e 67 20 74 6f 20 print "Going to
2ac0: 64 65 6c 65 74 65 20 73 74 61 6c 65 20 72 65 63 delete stale rec
2ad0: 6f 72 64 20 66 6f 72 20 6d 6f 6e 69 74 6f 72 20 ord for monitor
2ae0: 77 69 74 68 20 70 69 64 20 22 20 70 69 64 20 22 with pid " pid "
2af0: 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 20 on host " host
2b00: 22 20 6c 61 73 74 20 75 70 64 61 74 65 64 20 22 " last updated "
2b10: 20 64 65 6c 74 61 20 22 20 73 65 63 6f 6e 64 73 delta " seconds
2b20: 20 61 67 6f 22 29 0a 20 20 20 20 20 20 20 28 73 ago"). (s
2b30: 65 74 21 20 64 65 61 64 6c 69 73 74 20 28 63 6f et! deadlist (co
2b40: 6e 73 20 69 64 20 64 65 61 64 6c 69 73 74 29 29 ns id deadlist))
2b50: 29 0a 20 20 20 20 20 6d 64 62 20 0a 20 20 20 20 ). mdb .
2b60: 20 22 53 45 4c 45 43 54 20 69 64 2c 70 69 64 2c "SELECT id,pid,
2b70: 68 6f 73 74 6e 61 6d 65 2c 6c 61 73 74 5f 75 70 hostname,last_up
2b80: 64 61 74 65 2c 73 74 72 66 74 69 6d 65 28 27 25 date,strftime('%
2b90: 73 27 2c 27 6e 6f 77 27 29 2d 6c 61 73 74 5f 75 s','now')-last_u
2ba0: 70 64 61 74 65 20 41 53 20 64 65 6c 74 61 20 46 pdate AS delta F
2bb0: 52 4f 4d 20 6d 6f 6e 69 74 6f 72 73 20 57 48 45 ROM monitors WHE
2bc0: 52 45 20 64 65 6c 74 61 20 3e 20 37 30 30 3b 22 RE delta > 700;"
2bd0: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 ). (sqlite3:e
2be0: 78 65 63 75 74 65 20 6d 64 62 20 28 63 6f 6e 63 xecute mdb (conc
2bf0: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 6d 6f "DELETE FROM mo
2c00: 6e 69 74 6f 72 73 20 57 48 45 52 45 20 69 64 20 nitors WHERE id
2c10: 49 4e 20 28 27 22 20 28 73 74 72 69 6e 67 2d 69 IN ('" (string-i
2c20: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
2c30: 63 6f 6e 63 20 64 65 61 64 6c 69 73 74 29 20 22 conc deadlist) "
2c40: 27 2c 27 22 29 20 22 27 29 3b 22 29 29 29 0a 20 ','") "');"))).
2c50: 20 29 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b ).(define (task
2c60: 73 3a 72 65 67 69 73 74 65 72 2d 6d 6f 6e 69 74 s:register-monit
2c70: 6f 72 20 64 62 20 70 6f 72 74 29 0a 20 20 28 6c or db port). (l
2c80: 65 74 2a 20 28 28 70 69 64 20 28 63 75 72 72 65 et* ((pid (curre
2c90: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a nt-process-id)).
2ca0: 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 . (hostname (get
2cb0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 -host-name)).. (
2cc0: 75 73 65 72 69 6e 66 6f 20 28 75 73 65 72 2d 69 userinfo (user-i
2cd0: 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 72 nformation (curr
2ce0: 65 6e 74 2d 75 73 65 72 2d 69 64 29 29 29 0a 09 ent-user-id)))..
2cf0: 20 28 75 73 65 72 6e 61 6d 65 20 28 63 61 72 20 (username (car
2d00: 75 73 65 72 69 6e 66 6f 29 29 29 0a 20 20 20 20 userinfo))).
2d10: 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 (print "Register
2d20: 20 6d 6f 6e 69 74 6f 72 2c 20 70 69 64 3a 20 22 monitor, pid: "
2d30: 20 70 69 64 20 22 2c 20 68 6f 73 74 6e 61 6d 65 pid ", hostname
2d40: 3a 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 2c 20 : " hostname ",
2d50: 70 6f 72 74 3a 20 22 20 70 6f 72 74 20 22 2c 20 port: " port ",
2d60: 75 73 65 72 6e 61 6d 65 3a 20 22 20 75 73 65 72 username: " user
2d70: 6e 61 6d 65 29 0a 20 20 20 20 28 73 71 6c 69 74 name). (sqlit
2d80: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 e3:execute db "I
2d90: 4e 53 45 52 54 20 49 4e 54 4f 20 6d 6f 6e 69 74 NSERT INTO monit
2da0: 6f 72 73 20 28 70 69 64 2c 73 74 61 72 74 5f 74 ors (pid,start_t
2db0: 69 6d 65 2c 6c 61 73 74 5f 75 70 64 61 74 65 2c ime,last_update,
2dc0: 68 6f 73 74 6e 61 6d 65 2c 75 73 65 72 6e 61 6d hostname,usernam
2dd0: 65 29 20 56 41 4c 55 45 53 20 28 3f 2c 73 74 72 e) VALUES (?,str
2de0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
2df0: 29 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c ),strftime('%s',
2e00: 27 6e 6f 77 27 29 2c 3f 2c 3f 29 3b 22 0a 09 09 'now'),?,?);"...
2e10: 20 20 20 20 20 70 69 64 20 68 6f 73 74 6e 61 6d pid hostnam
2e20: 65 20 75 73 65 72 6e 61 6d 65 29 29 29 0a 0a 28 e username)))..(
2e30: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 67 65 define (tasks:ge
2e40: 74 2d 6e 75 6d 2d 61 6c 69 76 65 2d 6d 6f 6e 69 t-num-alive-moni
2e50: 74 6f 72 73 20 6d 64 62 29 0a 20 20 28 6c 65 74 tors mdb). (let
2e60: 20 28 28 72 65 73 20 30 29 29 0a 20 20 20 20 28 ((res 0)). (
2e70: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
2e80: 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 6d 62 -row . (lamb
2e90: 64 61 20 28 63 6f 75 6e 74 29 0a 20 20 20 20 20 da (count).
2ea0: 20 20 28 73 65 74 21 20 72 65 73 20 63 6f 75 6e (set! res coun
2eb0: 74 29 29 0a 20 20 20 20 20 6d 64 62 0a 20 20 20 t)). mdb.
2ec0: 20 20 22 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 "SELECT count(
2ed0: 69 64 29 20 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 id) FROM monitor
2ee0: 73 20 57 48 45 52 45 20 6c 61 73 74 5f 75 70 64 s WHERE last_upd
2ef0: 61 74 65 20 3c 20 28 73 74 72 66 74 69 6d 65 28 ate < (strftime(
2f00: 27 25 73 27 2c 27 6e 6f 77 27 29 20 2d 20 33 30 '%s','now') - 30
2f10: 30 29 20 41 4e 44 20 75 73 65 72 6e 61 6d 65 3d 0) AND username=
2f20: 3f 3b 22 0a 20 20 20 20 20 28 63 61 72 20 28 75 ?;". (car (u
2f30: 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 ser-information
2f40: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
2f50: 29 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a 0a )))). res))..
2f60: 3b 3b 20 0a 23 3b 28 64 65 66 69 6e 65 20 28 74 ;; .#;(define (t
2f70: 61 73 6b 73 3a 73 74 61 72 74 2d 6d 6f 6e 69 74 asks:start-monit
2f80: 6f 72 20 64 62 20 6d 64 62 29 0a 20 20 28 69 66 or db mdb). (if
2f90: 20 28 3e 20 28 74 61 73 6b 73 3a 67 65 74 2d 6e (> (tasks:get-n
2fa0: 75 6d 2d 61 6c 69 76 65 2d 6d 6f 6e 69 74 6f 72 um-alive-monitor
2fb0: 73 20 6d 64 62 29 20 32 29 20 3b 3b 20 68 61 76 s mdb) 2) ;; hav
2fc0: 65 20 74 77 6f 20 72 75 6e 6e 69 6e 67 2c 20 6e e two running, n
2fd0: 6f 20 6e 65 65 64 20 66 6f 72 20 6d 6f 72 65 0a o need for more.
2fe0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2ff0: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
3000: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f lt-log-port* "No
3010: 74 20 73 74 61 72 74 69 6e 67 20 6d 6f 6e 69 74 t starting monit
3020: 6f 72 2c 20 61 6c 72 65 61 64 79 20 68 61 76 65 or, already have
3030: 20 6d 6f 72 65 20 74 68 61 6e 20 74 77 6f 20 72 more than two r
3040: 75 6e 6e 69 6e 67 22 29 0a 20 20 20 20 20 20 28 unning"). (
3050: 6c 65 74 2a 20 28 28 6d 65 67 61 74 65 73 74 64 let* ((megatestd
3060: 62 20 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 b (conc *top
3070: 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 65 73 74 path* "/megatest
3080: 2e 64 62 22 29 29 0a 09 20 20 20 20 20 28 6d 6f .db")).. (mo
3090: 6e 69 74 6f 72 64 62 66 20 20 20 20 20 28 63 6f nitordbf (co
30a0: 6e 63 20 28 64 62 3a 64 62 66 69 6c 65 2d 70 61 nc (db:dbfile-pa
30b0: 74 68 20 23 66 29 20 22 2f 6d 6f 6e 69 74 6f 72 th #f) "/monitor
30c0: 2e 64 62 22 29 29 0a 09 20 20 20 20 20 28 6c 61 .db")).. (la
30d0: 73 74 2d 64 62 2d 75 70 64 61 74 65 20 30 29 29 st-db-update 0))
30e0: 20 3b 3b 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 ;; (file-modifi
30f0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6d 65 67 61 cation-time mega
3100: 74 65 73 74 64 62 29 29 29 0a 09 28 74 61 73 6b testdb)))..(task
3110: 3a 72 65 67 69 73 74 65 72 2d 6d 6f 6e 69 74 6f :register-monito
3120: 72 20 6d 64 62 29 0a 09 28 6c 65 74 20 6c 6f 6f r mdb)..(let loo
3130: 70 20 28 28 63 6f 75 6e 74 20 20 20 20 20 20 30 p ((count 0
3140: 29 0a 09 09 20 20 20 28 6e 65 78 74 2d 74 6f 75 )... (next-tou
3150: 63 68 20 30 29 29 20 3b 3b 20 6e 65 78 74 2d 74 ch 0)) ;; next-t
3160: 6f 75 63 68 20 69 73 20 74 68 65 20 74 69 6d 65 ouch is the time
3170: 20 77 68 65 72 65 20 77 65 20 6e 65 65 64 20 74 where we need t
3180: 6f 20 75 70 64 61 74 65 20 6c 61 73 74 5f 75 70 o update last_up
3190: 64 61 74 65 0a 09 20 20 3b 3b 20 69 66 20 74 68 date.. ;; if th
31a0: 65 20 64 62 20 68 61 73 20 62 65 65 6e 20 6d 6f e db has been mo
31b0: 64 69 66 69 65 64 20 77 65 27 64 20 62 65 73 74 dified we'd best
31c0: 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 61 73 look at the tas
31d0: 6b 20 71 75 65 75 65 0a 09 20 20 28 6c 65 74 20 k queue.. (let
31e0: 28 28 6d 6f 64 74 69 6d 65 20 28 66 69 6c 65 2d ((modtime (file-
31f0: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
3200: 65 20 6d 65 67 61 74 65 73 74 64 62 70 61 74 68 e megatestdbpath
3210: 20 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 3e ))).. (if (>
3220: 20 6d 6f 64 74 69 6d 65 20 6c 61 73 74 2d 64 62 modtime last-db
3230: 2d 75 70 64 61 74 65 29 0a 09 09 28 74 61 73 6b -update)...(task
3240: 73 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 20 s:process-queue
3250: 64 62 29 29 20 3b 3b 20 42 52 4f 4b 45 4e 2e 20 db)) ;; BROKEN.
3260: 6d 64 62 20 6c 61 73 74 2d 64 62 2d 75 70 64 61 mdb last-db-upda
3270: 74 65 20 6d 65 67 61 74 65 73 74 64 62 20 6e 65 te megatestdb ne
3280: 78 74 2d 74 6f 75 63 68 29 29 0a 09 20 20 20 20 xt-touch))..
3290: 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 50 6f 73 73 ;; WARNING: Poss
32a0: 69 62 6c 65 20 72 61 63 65 20 63 6f 6e 64 69 74 ible race condit
32b0: 6f 6e 20 68 65 72 65 21 21 0a 09 20 20 20 20 3b on here!!.. ;
32c0: 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 75 70 ; should this up
32d0: 64 61 74 65 20 62 65 20 69 6d 6d 65 64 69 61 74 date be immediat
32e0: 65 6c 79 20 61 66 74 65 72 20 74 68 65 20 74 61 ely after the ta
32f0: 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 63 61 sk-get-action ca
3300: 6c 6c 20 61 62 6f 76 65 3f 0a 09 20 20 20 20 28 ll above?.. (
3310: 69 66 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 if (> (current-s
3320: 65 63 6f 6e 64 73 29 20 6e 65 78 74 2d 74 6f 75 econds) next-tou
3330: 63 68 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 ch)...(begin...
3340: 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 73 (tasks:monitors
3350: 2d 75 70 64 61 74 65 20 6d 64 62 29 0a 09 09 20 -update mdb)...
3360: 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 (loop (+ count
3370: 31 29 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 1)(+ (current-se
3380: 63 6f 6e 64 73 29 20 32 34 30 29 29 29 0a 09 09 conds) 240)))...
3390: 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 (loop (+ count 1
33a0: 29 20 6e 65 78 74 2d 74 6f 75 63 68 29 29 29 29 ) next-touch))))
33b0: 29 29 29 0a 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d ))). .;;===
33c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3400: 3d 3d 3d 0a 3b 3b 20 54 20 41 20 53 20 4b 20 53 ===.;; T A S K S
3410: 20 20 20 51 20 55 20 45 20 55 20 45 0a 3b 3b 0a Q U E U E.;;.
3420: 3b 3b 20 20 20 4e 4f 54 45 3a 3a 20 54 68 65 73 ;; NOTE:: Thes
3430: 65 20 6f 70 65 72 61 74 65 20 6f 6e 20 74 61 73 e operate on tas
3440: 6b 5f 71 75 65 75 65 20 77 68 69 63 68 20 69 73 k_queue which is
3450: 20 69 6e 20 6d 61 69 6e 2e 64 62 0a 3b 3b 0a 3b in main.db.;;.;
3460: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 45 =======..;; NOTE
34b0: 3a 20 49 74 20 6d 69 67 68 74 20 62 65 20 67 6f : It might be go
34c0: 6f 64 20 74 6f 20 61 64 64 20 6f 6e 65 20 6d 6f od to add one mo
34d0: 72 65 20 6c 61 79 65 72 20 6f 66 20 63 68 65 63 re layer of chec
34e0: 6b 69 6e 67 20 74 6f 20 65 6e 73 75 72 65 0a 3b king to ensure.;
34f0: 3b 20 20 20 20 20 20 20 74 68 61 74 20 6e 6f 20 ; that no
3500: 74 61 73 6b 20 67 65 74 73 20 72 75 6e 20 69 6e task gets run in
3510: 20 70 61 72 61 6c 6c 65 6c 2e 0a 0a 3b 3b 20 69 parallel...;; i
3520: 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 d INTEGER PRIMAR
3530: 59 20 4b 45 59 2c 0a 3b 3b 20 61 63 74 69 6f 6e Y KEY,.;; action
3540: 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 TEXT DEFAULT ''
3550: 2c 0a 3b 3b 20 6f 77 6e 65 72 20 54 45 58 54 2c ,.;; owner TEXT,
3560: 0a 3b 3b 20 73 74 61 74 65 20 54 45 58 54 20 44 .;; state TEXT D
3570: 45 46 41 55 4c 54 20 27 6e 65 77 27 2c 0a 3b 3b EFAULT 'new',.;;
3580: 20 74 61 72 67 65 74 20 54 45 58 54 20 44 45 46 target TEXT DEF
3590: 41 55 4c 54 20 27 27 2c 0a 3b 3b 20 6e 61 6d 65 AULT '',.;; name
35a0: 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 TEXT DEFAULT ''
35b0: 2c 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 54 45 ,.;; testpatt TE
35c0: 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a 3b XT DEFAULT '',.;
35d0: 3b 20 6b 65 79 6c 6f 63 6b 20 54 45 58 54 2c 0a ; keylock TEXT,.
35e0: 3b 3b 20 70 61 72 61 6d 73 20 54 45 58 54 2c 0a ;; params TEXT,.
35f0: 3b 3b 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 ;; creation_time
3600: 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 55 TIMESTAMP DEFAU
3610: 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 LT (strftime('%s
3620: 27 2c 27 6e 6f 77 27 29 29 2c 0a 3b 3b 20 65 78 ','now')),.;; ex
3630: 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 54 49 4d ecution_time TIM
3640: 45 53 54 41 4d 50 29 3b 0a 0a 0a 3b 3b 20 72 65 ESTAMP);...;; re
3650: 67 69 73 74 65 72 20 61 20 74 61 73 6b 0a 28 64 gister a task.(d
3660: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 61 64 64 efine (tasks:add
3670: 20 64 62 73 74 72 75 63 74 20 61 63 74 69 6f 6e dbstruct action
3680: 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 72 75 owner target ru
3690: 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 70 nname testpatt p
36a0: 61 72 61 6d 73 29 0a 20 20 28 64 62 3a 77 69 74 arams). (db:wit
36b0: 68 2d 64 62 20 0a 20 20 20 64 62 73 74 72 75 63 h-db . dbstruc
36c0: 74 20 23 66 20 23 74 0a 20 20 20 28 6c 61 6d 62 t #f #t. (lamb
36d0: 64 61 20 28 64 62 29 0a 20 20 20 20 20 28 73 71 da (db). (sq
36e0: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
36f0: 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 74 61 "INSERT INTO ta
3700: 73 6b 73 5f 71 75 65 75 65 20 28 61 63 74 69 6f sks_queue (actio
3710: 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 n,owner,state,ta
3720: 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 70 61 rget,name,testpa
3730: 74 74 2c 70 61 72 61 6d 73 2c 63 72 65 61 74 69 tt,params,creati
3740: 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 69 6f on_time,executio
3750: 6e 5f 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 n_time).
3760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3770: 20 20 20 20 20 56 41 4c 55 45 53 20 28 3f 2c 3f VALUES (?,?
3780: 2c 27 6e 65 77 27 2c 3f 2c 3f 2c 3f 2c 3f 2c 73 ,'new',?,?,?,?,s
3790: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
37a0: 77 27 29 2c 30 29 3b 22 20 0a 09 09 20 20 20 20 w'),0);" ...
37b0: 20 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 20 20 action...
37c0: 20 6f 77 6e 65 72 0a 09 09 20 20 20 20 20 20 74 owner... t
37d0: 61 72 67 65 74 0a 09 09 20 20 20 20 20 20 72 75 arget... ru
37e0: 6e 6e 61 6d 65 0a 09 09 20 20 20 20 20 20 74 65 nname... te
37f0: 73 74 70 61 74 74 0a 09 09 20 20 20 20 20 20 28 stpatt... (
3800: 69 66 20 70 61 72 61 6d 73 20 70 61 72 61 6d 73 if params params
3810: 20 22 22 29 29 29 29 29 0a 0a 28 64 65 66 69 6e "")))))..(defin
3820: 65 20 28 6b 65 79 73 3a 6b 65 79 2d 76 61 6c 73 e (keys:key-vals
3830: 2d 68 61 73 68 2d 3e 74 61 72 67 65 74 20 6b 65 -hash->target ke
3840: 79 73 20 6b 65 79 2d 70 61 72 61 6d 73 29 0a 20 ys key-params).
3850: 20 28 6c 65 74 20 28 28 74 6d 70 20 28 68 61 73 (let ((tmp (has
3860: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3870: 75 6c 74 20 6b 65 79 2d 70 61 72 61 6d 73 20 28 ult key-params (
3880: 76 65 63 74 6f 72 2d 72 65 66 20 28 63 61 72 20 vector-ref (car
3890: 6b 65 79 73 29 20 30 29 20 22 22 29 29 29 0a 20 keys) 0) ""))).
38a0: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
38b0: 68 20 6b 65 79 73 29 20 31 29 0a 09 28 66 6f 72 h keys) 1)..(for
38c0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
38d0: 65 79 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 ey)... (set!
38e0: 74 6d 70 20 28 63 6f 6e 63 20 74 6d 70 20 22 2f tmp (conc tmp "/
38f0: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 " (hash-table-re
3900: 66 2f 64 65 66 61 75 6c 74 20 6b 65 79 2d 70 61 f/default key-pa
3910: 72 61 6d 73 20 28 76 65 63 74 6f 72 2d 72 65 66 rams (vector-ref
3920: 20 6b 65 79 20 30 29 20 22 22 29 29 29 29 0a 09 key 0) ""))))..
3930: 09 20 20 28 63 64 72 20 6b 65 79 73 29 29 29 0a . (cdr keys))).
3940: 20 20 20 20 74 6d 70 29 29 0a 09 09 09 09 09 09 tmp)).......
3950: 09 09 0a 3b 3b 20 66 6f 72 20 75 73 65 20 66 72 ...;; for use fr
3960: 6f 6d 20 74 68 65 20 67 75 69 2c 20 6e 6f 74 20 om the gui, not
3970: 70 6f 72 74 65 64 0a 3b 3b 0a 3b 3b 20 28 64 65 ported.;;.;; (de
3980: 66 69 6e 65 20 28 74 61 73 6b 73 3a 61 64 64 2d fine (tasks:add-
3990: 66 72 6f 6d 2d 70 61 72 61 6d 73 20 6d 64 62 20 from-params mdb
39a0: 61 63 74 69 6f 6e 20 6b 65 79 73 20 6b 65 79 2d action keys key-
39b0: 70 61 72 61 6d 73 20 76 61 72 2d 70 61 72 61 6d params var-param
39c0: 73 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 s).;; (let ((t
39d0: 61 72 67 65 74 20 20 20 20 28 6b 65 79 73 3a 6b arget (keys:k
39e0: 65 79 2d 76 61 6c 73 2d 68 61 73 68 2d 3e 74 61 ey-vals-hash->ta
39f0: 72 67 65 74 20 6b 65 79 73 20 6b 65 79 2d 70 61 rget keys key-pa
3a00: 72 61 6d 73 29 29 0a 3b 3b 20 09 28 6f 77 6e 65 rams)).;; .(owne
3a10: 72 20 20 20 20 20 28 63 61 72 20 28 75 73 65 72 r (car (user
3a20: 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 -information (cu
3a30: 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 29 29 rrent-user-id)))
3a40: 29 0a 3b 3b 20 09 28 72 75 6e 6e 61 6d 65 20 20 ).;; .(runname
3a50: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3a60: 2f 64 65 66 61 75 6c 74 20 76 61 72 2d 70 61 72 /default var-par
3a70: 61 6d 73 20 22 72 75 6e 6e 61 6d 65 22 20 23 66 ams "runname" #f
3a80: 29 29 0a 3b 3b 20 09 28 74 65 73 74 70 61 74 74 )).;; .(testpatt
3a90: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 s (hash-table-re
3aa0: 66 2f 64 65 66 61 75 6c 74 20 76 61 72 2d 70 61 f/default var-pa
3ab0: 72 61 6d 73 20 22 74 65 73 74 70 61 74 74 73 22 rams "testpatts"
3ac0: 20 22 25 22 29 29 0a 3b 3b 20 09 28 70 61 72 61 "%")).;; .(para
3ad0: 6d 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ms (hash-tabl
3ae0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 76 61 e-ref/default va
3af0: 72 2d 70 61 72 61 6d 73 20 22 70 61 72 61 6d 73 r-params "params
3b00: 22 20 20 20 20 22 22 29 29 29 0a 3b 3b 20 20 20 " ""))).;;
3b10: 20 20 28 74 61 73 6b 73 3a 61 64 64 20 6d 64 62 (tasks:add mdb
3b20: 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 action owner ta
3b30: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 rget runname tes
3b40: 74 70 61 74 74 73 20 70 61 72 61 6d 73 29 29 29 tpatts params)))
3b50: 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 6f 6e 65 20 ..;; return one
3b60: 74 61 73 6b 20 66 72 6f 6d 20 74 68 6f 73 65 20 task from those
3b70: 77 68 6f 20 61 72 65 20 27 6e 65 77 27 20 4f 52 who are 'new' OR
3b80: 20 27 77 61 69 74 69 6e 67 27 20 41 4e 44 20 6d 'waiting' AND m
3b90: 6f 72 65 20 74 68 61 6e 20 31 30 73 65 63 20 6f ore than 10sec o
3ba0: 6c 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ld.;;.(define (t
3bb0: 61 73 6b 73 3a 73 6e 61 67 2d 61 2d 74 61 73 6b asks:snag-a-task
3bc0: 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 6c 65 dbstruct). (le
3bd0: 74 20 28 28 72 65 73 20 20 20 20 23 66 29 0a 09 t ((res #f)..
3be0: 28 6b 65 79 74 78 74 20 28 63 6f 6e 63 20 28 63 (keytxt (conc (c
3bf0: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
3c00: 64 29 20 22 2d 22 20 28 67 65 74 2d 68 6f 73 74 d) "-" (get-host
3c10: 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 61 72 20 -name) "-" (car
3c20: 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f (user-informatio
3c30: 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d n (current-user-
3c40: 69 64 29 29 29 29 29 29 0a 20 20 20 20 28 64 62 id)))))). (db
3c50: 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 20 64 62 :with-db. db
3c60: 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 struct #f #t.
3c70: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 (lambda (db).
3c80: 20 20 20 20 20 20 3b 3b 20 66 69 72 73 74 20 72 ;; first r
3c90: 61 6e 64 6f 6d 6c 79 20 73 65 74 20 61 20 6e 65 andomly set a ne
3ca0: 77 20 74 6f 20 70 69 64 2d 68 6f 73 74 6e 61 6d w to pid-hostnam
3cb0: 65 2d 68 6f 73 74 6e 61 6d 65 0a 20 20 20 20 20 e-hostname.
3cc0: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
3cd0: 74 65 0a 09 64 62 20 0a 09 22 55 50 44 41 54 45 te..db .."UPDATE
3ce0: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 tasks_queue SET
3cf0: 20 6b 65 79 6c 6f 63 6b 3d 3f 20 57 48 45 52 45 keylock=? WHERE
3d00: 20 69 64 20 49 4e 0a 20 20 20 20 20 20 20 20 20 id IN.
3d10: 20 20 28 53 45 4c 45 43 54 20 69 64 20 46 52 4f (SELECT id FRO
3d20: 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 0a 20 M tasks_queue .
3d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 WHE
3d40: 52 45 20 73 74 61 74 65 3d 27 6e 65 77 27 20 4f RE state='new' O
3d50: 52 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 R .
3d60: 20 20 20 20 20 20 20 28 73 74 61 74 65 3d 27 77 (state='w
3d70: 61 69 74 69 6e 67 27 20 41 4e 44 20 28 73 74 72 aiting' AND (str
3d80: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
3d90: 29 2d 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 )-execution_time
3da0: 29 20 3e 20 31 30 29 20 4f 52 0a 20 20 20 20 20 ) > 10) OR.
3db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
3dc0: 74 61 74 65 3d 27 72 65 73 65 74 27 0a 20 20 20 tate='reset'.
3dd0: 20 20 20 20 20 20 20 20 20 20 20 4f 52 44 45 52 ORDER
3de0: 20 42 59 20 52 41 4e 44 4f 4d 28 29 20 4c 49 4d BY RANDOM() LIM
3df0: 49 54 20 31 29 3b 22 20 6b 65 79 74 78 74 29 0a IT 1);" keytxt).
3e00: 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 . (sqlite3
3e10: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 :for-each-row..(
3e20: 6c 61 6d 62 64 61 20 28 69 64 20 2e 20 72 65 6d lambda (id . rem
3e30: 29 0a 09 20 20 28 73 65 74 21 20 72 65 73 20 28 ).. (set! res (
3e40: 61 70 70 6c 79 20 76 65 63 74 6f 72 20 69 64 20 apply vector id
3e50: 72 65 6d 29 29 29 0a 09 64 62 0a 09 22 53 45 4c rem)))..db.."SEL
3e60: 45 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 ECT id,action,ow
3e70: 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 ner,state,target
3e80: 2c 6e 61 6d 65 2c 74 65 73 74 2c 69 74 65 6d 2c ,name,test,item,
3e90: 70 61 72 61 6d 73 2c 63 72 65 61 74 69 6f 6e 5f params,creation_
3ea0: 74 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e 5f 74 time,execution_t
3eb0: 69 6d 65 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 ime FROM tasks_q
3ec0: 75 65 75 65 20 57 48 45 52 45 20 6b 65 79 6c 6f ueue WHERE keylo
3ed0: 63 6b 3d 3f 20 4f 52 44 45 52 20 42 59 20 65 78 ck=? ORDER BY ex
3ee0: 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 41 53 43 ecution_time ASC
3ef0: 20 4c 49 4d 49 54 20 31 3b 22 20 6b 65 79 74 78 LIMIT 1;" keytx
3f00: 74 29 0a 20 20 20 20 20 20 20 28 69 66 20 72 65 t). (if re
3f10: 73 20 3b 3b 20 79 65 70 2c 20 68 61 76 65 20 77 s ;; yep, have w
3f20: 6f 72 6b 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 ork to be done..
3f30: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
3f40: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
3f50: 20 64 62 20 22 55 50 44 41 54 45 20 74 61 73 6b db "UPDATE task
3f60: 73 5f 71 75 65 75 65 20 53 45 54 20 73 74 61 74 s_queue SET stat
3f70: 65 3d 27 69 6e 70 72 6f 67 72 65 73 73 27 2c 65 e='inprogress',e
3f80: 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 3d 73 74 xecution_time=st
3f90: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
3fa0: 27 29 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 0a ') WHERE id=?;".
3fb0: 09 09 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a ... (tasks:
3fc0: 74 61 73 6b 2d 67 65 74 2d 69 64 20 72 65 73 29 task-get-id res)
3fd0: 29 0a 09 20 20 20 20 20 72 65 73 29 0a 09 20 20 ).. res)..
3fe0: 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e #f)))))..(defin
3ff0: 65 20 28 74 61 73 6b 73 3a 72 65 73 65 74 2d 73 e (tasks:reset-s
4000: 74 75 63 6b 2d 74 61 73 6b 73 20 64 62 73 74 72 tuck-tasks dbstr
4010: 75 63 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 uct). (let ((re
4020: 73 20 27 28 29 29 29 0a 20 20 20 20 28 64 62 3a s '())). (db:
4030: 77 69 74 68 2d 64 62 0a 20 20 20 20 20 64 62 73 with-db. dbs
4040: 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 20 truct #f #t.
4050: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
4060: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f (sqlite3:fo
4070: 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 6c 61 6d r-each-row..(lam
4080: 62 64 61 20 28 69 64 20 64 65 6c 74 61 29 0a 09 bda (id delta)..
4090: 20 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e (set! res (con
40a0: 73 20 69 64 20 72 65 73 29 29 29 0a 09 64 62 0a s id res)))..db.
40b0: 09 22 53 45 4c 45 43 54 20 69 64 2c 73 74 72 66 ."SELECT id,strf
40c0: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
40d0: 2d 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 -execution_time
40e0: 41 53 20 64 65 6c 74 61 20 46 52 4f 4d 20 74 61 AS delta FROM ta
40f0: 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 45 20 sks_queue WHERE
4100: 73 74 61 74 65 3d 27 69 6e 70 72 6f 67 72 65 73 state='inprogres
4110: 73 27 20 41 4e 44 20 64 65 6c 74 61 3e 37 30 30 s' AND delta>700
4120: 20 4f 52 44 45 52 20 42 59 20 64 65 6c 74 61 20 ORDER BY delta
4130: 44 45 53 43 20 4c 49 4d 49 54 20 32 3b 22 29 0a DESC LIMIT 2;").
4140: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
4150: 65 78 65 63 75 74 65 20 0a 09 64 62 20 0a 09 28 execute ..db ..(
4160: 63 6f 6e 63 20 22 55 50 44 41 54 45 20 74 61 73 conc "UPDATE tas
4170: 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 74 61 ks_queue SET sta
4180: 74 65 3d 27 72 65 73 65 74 27 20 57 48 45 52 45 te='reset' WHERE
4190: 20 69 64 20 49 4e 20 28 27 22 20 28 73 74 72 69 id IN ('" (stri
41a0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
41b0: 6d 61 70 20 63 6f 6e 63 20 72 65 73 29 20 22 27 map conc res) "'
41c0: 2c 27 22 29 20 22 27 29 3b 22 29 0a 09 29 29 29 ,'") "');")..)))
41d0: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 6c ))..;; return al
41e0: 6c 20 74 61 73 6b 73 20 69 6e 20 74 68 65 20 74 l tasks in the t
41f0: 61 73 6b 73 5f 71 75 65 75 65 20 74 61 62 6c 65 asks_queue table
4200: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 .;;.(define (tas
4210: 6b 73 3a 67 65 74 2d 74 61 73 6b 73 20 64 62 73 ks:get-tasks dbs
4220: 74 72 75 63 74 20 74 79 70 65 73 20 73 74 61 74 truct types stat
4230: 65 73 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 es). (let ((res
4240: 20 27 28 29 29 29 0a 20 20 20 20 28 64 62 3a 77 '())). (db:w
4250: 69 74 68 2d 64 62 0a 20 20 20 20 20 64 62 73 74 ith-db. dbst
4260: 72 75 63 74 20 23 66 20 23 66 0a 20 20 20 20 20 ruct #f #f.
4270: 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 (lambda (db).
4280: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
4290: 2d 65 61 63 68 2d 72 6f 77 0a 09 28 6c 61 6d 62 -each-row..(lamb
42a0: 64 61 20 28 69 64 20 2e 20 72 65 6d 29 0a 09 20 da (id . rem)..
42b0: 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 (set! res (cons
42c0: 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 69 (apply vector i
42d0: 64 20 72 65 6d 29 20 72 65 73 29 29 29 0a 09 64 d rem) res)))..d
42e0: 62 0a 09 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 b..(conc "SELECT
42f0: 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e 65 72 id,action,owner
4300: 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c 6e 61 ,state,target,na
4310: 6d 65 2c 74 65 73 74 2c 69 74 65 6d 2c 70 61 72 me,test,item,par
4320: 61 6d 73 2c 63 72 65 61 74 69 6f 6e 5f 74 69 6d ams,creation_tim
4330: 65 2c 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 e,execution_time
4340: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4350: 20 20 20 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 FROM tasks_q
4360: 75 65 75 65 20 22 0a 09 20 20 20 20 20 20 3b 3b ueue ".. ;;
4370: 20 57 48 45 52 45 20 20 0a 09 20 20 20 20 20 20 WHERE ..
4380: 3b 3b 20 20 20 73 74 61 74 65 20 49 4e 20 22 20 ;; state IN "
4390: 73 74 61 74 65 73 73 74 72 20 22 20 41 4e 44 20 statesstr " AND
43a0: 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 61 63 74 .. ;; act
43b0: 69 6f 6e 20 49 4e 20 22 20 61 63 74 69 6f 6e 73 ion IN " actions
43c0: 73 74 72 20 0a 09 20 20 20 20 20 20 22 20 4f 52 str .. " OR
43d0: 44 45 52 20 42 59 20 63 72 65 61 74 69 6f 6e 5f DER BY creation_
43e0: 74 69 6d 65 20 44 45 53 43 3b 22 29 29 0a 20 20 time DESC;")).
43f0: 20 20 20 20 20 72 65 73 29 29 29 29 0a 0a 28 64 res))))..(d
4400: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 67 65 74 efine (tasks:get
4410: 2d 6c 61 73 74 20 64 62 73 74 72 75 63 74 20 74 -last dbstruct t
4420: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 arget runname).
4430: 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 (let ((res #f))
4440: 0a 20 20 20 20 28 64 62 3a 77 69 74 68 2d 64 62 . (db:with-db
4450: 0a 20 20 20 20 20 64 62 73 74 72 75 63 74 20 23 . dbstruct #
4460: 66 20 23 66 0a 20 20 20 20 20 28 6c 61 6d 62 64 f #f. (lambd
4470: 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 28 73 a (db). (s
4480: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
4490: 72 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 64 row..(lambda (id
44a0: 20 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 74 21 . rem).. (set!
44b0: 20 72 65 73 20 28 61 70 70 6c 79 20 76 65 63 74 res (apply vect
44c0: 6f 72 20 69 64 20 72 65 6d 29 29 29 0a 09 64 62 or id rem)))..db
44d0: 0a 09 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 ..(conc "SELECT
44e0: 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c id,action,owner,
44f0: 73 74 61 74 65 2c 74 61 72 67 65 74 2c 6e 61 6d state,target,nam
4500: 65 2c 74 65 73 74 70 61 74 74 2c 6b 65 79 6c 6f e,testpatt,keylo
4510: 63 6b 2c 70 61 72 61 6d 73 2c 63 72 65 61 74 69 ck,params,creati
4520: 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 69 6f on_time,executio
4530: 6e 5f 74 69 6d 65 20 0a 20 20 20 20 20 20 20 20 n_time .
4540: 20 20 20 20 20 20 20 20 20 20 46 52 4f 4d 20 74 FROM t
4550: 61 73 6b 73 5f 71 75 65 75 65 20 0a 20 09 20 20 asks_queue . .
4560: 20 20 20 20 20 57 48 45 52 45 20 20 0a 09 20 20 WHERE ..
4570: 20 20 20 20 20 20 74 61 72 67 65 74 20 3d 20 3f target = ?
4580: 20 41 4e 44 20 6e 61 6d 65 20 3d 3f 0a 09 20 20 AND name =?..
4590: 20 20 20 20 20 4f 52 44 45 52 20 42 59 20 63 72 ORDER BY cr
45a0: 65 61 74 69 6f 6e 5f 74 69 6d 65 20 44 45 53 43 eation_time DESC
45b0: 20 4c 49 4d 49 54 20 31 3b 22 29 0a 09 74 61 72 LIMIT 1;")..tar
45c0: 67 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 get runname).
45d0: 20 20 20 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 res))))..;;
45e0: 72 65 6d 6f 76 65 20 74 61 73 6b 73 20 67 69 76 remove tasks giv
45f0: 65 6e 20 62 79 20 61 20 73 74 72 69 6e 67 20 6f en by a string o
4600: 66 20 6e 75 6d 62 65 72 73 20 63 6f 6d 6d 61 20 f numbers comma
4610: 73 65 70 61 72 61 74 65 64 0a 28 64 65 66 69 6e separated.(defin
4620: 65 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d e (tasks:remove-
4630: 71 75 65 75 65 2d 65 6e 74 72 69 65 73 20 64 62 queue-entries db
4640: 73 74 72 75 63 74 20 74 61 73 6b 2d 69 64 73 29 struct task-ids)
4650: 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 . (db:with-db.
4660: 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 74 dbstruct #f #t
4670: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 . (lambda (db)
4680: 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
4690: 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 xecute db (conc
46a0: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 74 61 73 "DELETE FROM tas
46b0: 6b 73 5f 71 75 65 75 65 20 57 48 45 52 45 20 69 ks_queue WHERE i
46c0: 64 20 49 4e 20 28 22 20 74 61 73 6b 2d 69 64 73 d IN (" task-ids
46d0: 20 22 29 3b 22 29 29 29 29 29 0a 0a 23 3b 28 64 ");")))))..#;(d
46e0: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 70 72 6f efine (tasks:pro
46f0: 63 65 73 73 2d 71 75 65 75 65 20 64 62 73 74 72 cess-queue dbstr
4700: 75 63 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 uct). (let* ((t
4710: 61 73 6b 20 20 20 28 74 61 73 6b 73 3a 73 6e 61 ask (tasks:sna
4720: 67 2d 61 2d 74 61 73 6b 20 64 62 73 74 72 75 63 g-a-task dbstruc
4730: 74 29 29 0a 09 20 28 61 63 74 69 6f 6e 20 28 69 t)).. (action (i
4740: 66 20 74 61 73 6b 20 28 74 61 73 6b 73 3a 74 61 f task (tasks:ta
4750: 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 74 61 sk-get-action ta
4760: 73 6b 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 sk) #f))). (i
4770: 66 20 61 63 74 69 6f 6e 20 28 70 72 69 6e 74 20 f action (print
4780: 22 74 61 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 "tasks:process-q
4790: 75 65 75 65 20 74 61 73 6b 3a 20 22 20 74 61 73 ueue task: " tas
47a0: 6b 29 29 0a 20 20 20 20 28 69 66 20 61 63 74 69 k)). (if acti
47b0: 6f 6e 0a 09 28 63 61 73 65 20 28 73 74 72 69 6e on..(case (strin
47c0: 67 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 69 6f 6e g->symbol action
47d0: 29 0a 09 20 20 28 28 72 75 6e 29 20 20 20 20 20 ).. ((run)
47e0: 20 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 72 (tasks:start-r
47f0: 75 6e 20 20 20 20 20 64 62 73 74 72 75 63 74 20 un dbstruct
4800: 74 61 73 6b 29 29 0a 09 20 20 28 28 72 65 6d 6f task)).. ((remo
4810: 76 65 29 20 20 20 20 28 74 61 73 6b 73 3a 72 65 ve) (tasks:re
4820: 6d 6f 76 65 2d 72 75 6e 73 20 20 20 64 62 73 74 move-runs dbst
4830: 72 75 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 ruct task)).. (
4840: 28 6c 6f 63 6b 29 20 20 20 20 20 20 28 74 61 73 (lock) (tas
4850: 6b 73 3a 6c 6f 63 6b 2d 72 75 6e 73 20 20 20 20 ks:lock-runs
4860: 20 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 dbstruct task))
4870: 0a 09 20 20 3b 3b 20 28 28 6d 6f 6e 69 74 6f 72 .. ;; ((monitor
4880: 29 20 20 20 28 74 61 73 6b 73 3a 73 74 61 72 74 ) (tasks:start
4890: 2d 6d 6f 6e 69 74 6f 72 20 64 62 20 74 61 73 6b -monitor db task
48a0: 29 29 0a 09 20 20 23 3b 28 28 72 6f 6c 6c 75 70 )).. #;((rollup
48b0: 29 20 20 20 20 28 74 61 73 6b 73 3a 72 6f 6c 6c ) (tasks:roll
48c0: 75 70 2d 72 75 6e 73 20 20 20 64 62 73 74 72 75 up-runs dbstru
48d0: 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 28 75 ct task)).. ((u
48e0: 70 64 61 74 65 6d 65 74 61 29 28 74 61 73 6b 73 pdatemeta)(tasks
48f0: 3a 75 70 64 61 74 65 2d 6d 65 74 61 20 20 20 64 :update-meta d
4900: 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a 09 bstruct task))..
4910: 20 20 23 3b 28 28 6b 69 6c 6c 29 20 20 20 20 20 #;((kill)
4920: 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 6d 6f 6e (tasks:kill-mon
4930: 69 74 6f 72 73 20 64 62 73 74 72 75 63 74 20 74 itors dbstruct t
4940: 61 73 6b 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ask))))))..(defi
4950: 6e 65 20 28 74 61 73 6b 73 3a 74 61 73 6b 73 2d ne (tasks:tasks-
4960: 3e 74 65 78 74 20 74 61 73 6b 73 29 0a 20 20 28 >text tasks). (
4970: 6c 65 74 20 28 28 66 6d 74 73 74 72 20 22 7e 31 let ((fmtstr "~1
4980: 30 61 7e 31 30 61 7e 31 30 61 7e 31 32 61 7e 32 0a~10a~10a~12a~2
4990: 30 61 7e 31 32 61 7e 31 32 61 7e 31 30 61 22 29 0a~12a~12a~10a")
49a0: 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 66 6f 72 ). (conc (for
49b0: 6d 61 74 20 23 66 20 66 6d 74 73 74 72 20 22 69 mat #f fmtstr "i
49c0: 64 22 20 22 61 63 74 69 6f 6e 22 20 22 6f 77 6e d" "action" "own
49d0: 65 72 22 20 22 73 74 61 74 65 22 20 22 74 61 72 er" "state" "tar
49e0: 67 65 74 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 get" "runname" "
49f0: 74 65 73 74 70 61 74 74 73 22 20 22 70 61 72 61 testpatts" "para
4a00: 6d 73 22 29 20 22 5c 6e 22 0a 09 20 20 28 73 74 ms") "\n".. (st
4a10: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
4a20: 20 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 .. (map (lamb
4a30: 64 61 20 28 74 61 73 6b 29 0a 09 09 20 20 28 66 da (task)... (f
4a40: 6f 72 6d 61 74 20 23 66 20 66 6d 74 73 74 72 0a ormat #f fmtstr.
4a50: 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b ... (tasks:task
4a60: 2d 67 65 74 2d 69 64 20 20 20 20 20 74 61 73 6b -get-id task
4a70: 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 ).... (tasks:ta
4a80: 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 74 61 sk-get-action ta
4a90: 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a sk).... (tasks:
4aa0: 74 61 73 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 task-get-owner
4ab0: 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b task).... (task
4ac0: 73 3a 74 61 73 6b 2d 67 65 74 2d 73 74 61 74 65 s:task-get-state
4ad0: 20 20 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 task).... (ta
4ae0: 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 61 72 sks:task-get-tar
4af0: 67 65 74 20 74 61 73 6b 29 0a 09 09 09 20 20 28 get task).... (
4b00: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6e tasks:task-get-n
4b10: 61 6d 65 20 20 20 74 61 73 6b 29 0a 09 09 09 20 ame task)....
4b20: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
4b30: 2d 74 65 73 74 70 61 74 74 20 74 61 73 6b 29 0a -testpatt task).
4b40: 09 09 09 20 20 3b 3b 20 28 74 61 73 6b 73 3a 74 ... ;; (tasks:t
4b50: 61 73 6b 2d 67 65 74 2d 69 74 65 6d 20 20 20 74 ask-get-item t
4b60: 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 ask).... (tasks
4b70: 3a 74 61 73 6b 2d 67 65 74 2d 70 61 72 61 6d 73 :task-get-params
4b80: 20 74 61 73 6b 29 29 29 0a 09 09 74 61 73 6b 73 task)))...tasks
4b90: 29 20 22 5c 6e 22 29 29 29 29 0a 20 20 20 0a 28 ) "\n")))). .(
4ba0: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 65 define (tasks:se
4bb0: 74 2d 73 74 61 74 65 20 64 62 73 74 72 75 63 74 t-state dbstruct
4bc0: 20 74 61 73 6b 2d 69 64 20 73 74 61 74 65 29 0a task-id state).
4bd0: 20 20 28 64 62 3a 77 69 74 68 2d 64 62 20 0a 20 (db:with-db .
4be0: 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 74 dbstruct #f #t
4bf0: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 . (lambda (db)
4c00: 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
4c10: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
4c20: 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 E tasks_queue SE
4c30: 54 20 73 74 61 74 65 3d 3f 20 57 48 45 52 45 20 T state=? WHERE
4c40: 69 64 3d 3f 3b 22 20 0a 09 09 20 20 20 20 20 20 id=?;" ...
4c50: 73 74 61 74 65 20 0a 09 09 20 20 20 20 20 20 74 state ... t
4c60: 61 73 6b 2d 69 64 29 29 29 29 0a 0a 3b 3b 3d 3d ask-id))))..;;==
4c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cb0: 3d 3d 3d 3d 0a 3b 3b 20 41 63 63 65 73 73 20 75 ====.;; Access u
4cc0: 73 69 6e 67 20 74 61 73 6b 20 6b 65 79 20 28 73 sing task key (s
4cd0: 74 6f 72 65 64 20 69 6e 20 70 61 72 61 6d 73 3b tored in params;
4ce0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
4cf0: 69 73 74 20 66 6c 61 67 73 29 20 68 6f 73 74 6e ist flags) hostn
4d00: 61 6d 65 20 70 69 64 0a 3b 3b 3d 3d 3d 3d 3d 3d ame pid.;;======
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d50: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
4d60: 3a 70 61 72 61 6d 2d 6b 65 79 2d 3e 69 64 20 64 :param-key->id d
4d70: 62 73 74 72 75 63 74 20 74 61 73 6b 2d 70 61 72 bstruct task-par
4d80: 61 6d 73 29 0a 20 20 28 64 62 3a 77 69 74 68 2d ams). (db:with-
4d90: 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 23 db. dbstruct #
4da0: 66 20 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 f #f. (lambda
4db0: 28 64 62 29 0a 20 20 20 20 20 28 68 61 6e 64 6c (db). (handl
4dc0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
4dd0: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 23 66 0a exn. #f.
4de0: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 (sqlite3:f
4df0: 69 72 73 74 2d 72 65 73 75 6c 74 20 64 62 20 22 irst-result db "
4e00: 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 74 SELECT id FROM t
4e10: 61 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 45 asks_queue WHERE
4e20: 20 70 61 72 61 6d 73 20 4c 49 4b 45 20 3f 3b 22 params LIKE ?;"
4e30: 0a 09 09 09 20 20 20 20 74 61 73 6b 2d 70 61 72 .... task-par
4e40: 61 6d 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ams)))))..(defin
4e50: 65 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 74 61 e (tasks:set-sta
4e60: 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b te-given-param-k
4e70: 65 79 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ey dbstruct para
4e80: 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 29 m-key new-state)
4e90: 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 . (db:with-db.
4ea0: 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 74 dbstruct #f #t
4eb0: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 . (lambda (db)
4ec0: 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
4ed0: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
4ee0: 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 E tasks_queue SE
4ef0: 54 20 73 74 61 74 65 3d 3f 20 57 48 45 52 45 20 T state=? WHERE
4f00: 70 61 72 61 6d 73 20 4c 49 4b 45 20 3f 3b 22 20 params LIKE ?;"
4f10: 6e 65 77 2d 73 74 61 74 65 20 70 61 72 61 6d 2d new-state param-
4f20: 6b 65 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 key))))..(define
4f30: 20 28 74 61 73 6b 73 3a 67 65 74 2d 72 65 63 6f (tasks:get-reco
4f40: 72 64 73 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d rds-given-param-
4f50: 6b 65 79 20 64 62 73 74 72 75 63 74 20 70 61 72 key dbstruct par
4f60: 61 6d 2d 6b 65 79 20 73 74 61 74 65 2d 70 61 74 am-key state-pat
4f70: 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 20 74 65 t action-patt te
4f80: 73 74 2d 70 61 74 74 29 0a 20 20 28 64 62 3a 77 st-patt). (db:w
4f90: 69 74 68 2d 64 62 0a 20 20 20 64 62 73 74 72 75 ith-db. dbstru
4fa0: 63 74 20 23 66 20 23 66 0a 20 20 20 28 6c 61 6d ct #f #f. (lam
4fb0: 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 28 68 bda (db). (h
4fc0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
4fd0: 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 . exn.
4fe0: 20 27 28 29 0a 20 20 20 20 20 20 28 73 71 6c 69 '(). (sqli
4ff0: 74 65 33 3a 66 69 72 73 74 2d 72 6f 77 20 64 62 te3:first-row db
5000: 20 22 53 45 4c 45 43 54 20 69 64 2c 61 63 74 69 "SELECT id,acti
5010: 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 on,owner,state,t
5020: 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 70 arget,name,testp
5030: 61 74 74 2c 6b 65 79 6c 6f 63 6b 2c 70 61 72 61 att,keylock,para
5040: 6d 73 20 57 48 45 52 45 0a 20 20 20 20 20 20 20 ms WHERE.
5050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5060: 20 20 20 20 20 20 20 20 70 61 72 61 6d 73 20 4c params L
5070: 49 4b 45 20 3f 20 41 4e 44 20 73 74 61 74 65 20 IKE ? AND state
5080: 4c 49 4b 45 20 3f 20 41 4e 44 20 61 63 74 69 6f LIKE ? AND actio
5090: 6e 20 4c 49 4b 45 20 3f 20 41 4e 44 20 74 65 73 n LIKE ? AND tes
50a0: 74 70 61 74 74 20 4c 49 4b 45 20 3f 3b 22 0a 09 tpatt LIKE ?;"..
50b0: 09 09 20 70 61 72 61 6d 2d 6b 65 79 20 73 74 61 .. param-key sta
50c0: 74 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 te-patt action-p
50d0: 61 74 74 20 74 65 73 74 2d 70 61 74 74 29 29 29 att test-patt)))
50e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ))..(define (tas
50f0: 6b 73 3a 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 ks:find-task-que
5100: 75 65 2d 72 65 63 6f 72 64 73 20 64 62 73 74 72 ue-records dbstr
5110: 75 63 74 20 74 61 72 67 65 74 20 72 75 6e 2d 6e uct target run-n
5120: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 ame test-patt st
5130: 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d ate-patt action-
5140: 70 61 74 74 29 0a 20 20 3b 3b 20 28 68 61 6e 64 patt). ;; (hand
5150: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
5160: 3b 3b 20 20 65 78 6e 0a 20 20 3b 3b 20 20 27 28 ;; exn. ;; '(
5170: 29 0a 20 20 3b 3b 20 20 28 73 71 6c 69 74 65 33 ). ;; (sqlite3
5180: 3a 66 69 72 73 74 2d 72 6f 77 0a 20 20 28 6c 65 :first-row. (le
5190: 74 20 28 28 64 62 20 28 64 62 3a 64 65 6c 61 79 t ((db (db:delay
51a0: 2d 69 66 2d 62 75 73 79 20 28 64 62 3a 67 65 74 -if-busy (db:get
51b0: 2d 64 62 20 64 62 73 74 72 75 63 74 29 29 29 0a -db dbstruct))).
51c0: 09 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 .(res '())).
51d0: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
51e0: 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 6d h-row . (lam
51f0: 62 64 61 20 28 61 20 2e 20 62 29 0a 20 20 20 20 bda (a . b).
5200: 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 6f (set! res (co
5210: 6e 73 20 28 63 6f 6e 73 20 61 20 62 29 20 72 65 ns (cons a b) re
5220: 73 29 29 29 0a 20 20 20 20 20 64 62 20 22 53 45 s))). db "SE
5230: 4c 45 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f LECT id,action,o
5240: 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 wner,state,targe
5250: 74 2c 6e 61 6d 65 2c 74 65 73 74 70 61 74 74 2c t,name,testpatt,
5260: 6b 65 79 6c 6f 63 6b 2c 70 61 72 61 6d 73 20 46 keylock,params F
5270: 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 ROM tasks_queue
5280: 0a 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 . WHER
5290: 45 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 E.
52a0: 74 61 72 67 65 74 20 3d 20 3f 20 41 4e 44 20 6e target = ? AND n
52b0: 61 6d 65 20 3d 20 3f 20 41 4e 44 20 73 74 61 74 ame = ? AND stat
52c0: 65 20 4c 49 4b 45 20 3f 20 41 4e 44 20 61 63 74 e LIKE ? AND act
52d0: 69 6f 6e 20 4c 49 4b 45 20 3f 20 41 4e 44 20 74 ion LIKE ? AND t
52e0: 65 73 74 70 61 74 74 20 4c 49 4b 45 20 3f 3b 22 estpatt LIKE ?;"
52f0: 0a 20 20 20 20 20 74 61 72 67 65 74 20 72 75 6e . target run
5300: 2d 6e 61 6d 65 20 73 74 61 74 65 2d 70 61 74 74 -name state-patt
5310: 20 61 63 74 69 6f 6e 2d 70 61 74 74 20 74 65 73 action-patt tes
5320: 74 2d 70 61 74 74 29 0a 20 20 20 20 72 65 73 29 t-patt). res)
5330: 29 20 3b 3b 20 29 0a 0a 3b 3b 20 6b 69 6c 6c 20 ) ;; )..;; kill
5340: 61 6e 79 20 72 75 6e 6e 65 72 20 70 72 6f 63 65 any runner proce
5350: 73 73 65 73 20 28 69 2e 65 2e 20 70 72 6f 63 65 sses (i.e. proce
5360: 73 73 65 73 20 68 61 6e 64 6c 69 6e 67 20 2d 72 sses handling -r
5370: 75 6e 74 65 73 74 73 29 20 74 68 61 74 20 6d 61 untests) that ma
5380: 74 63 68 20 74 61 72 67 65 74 2f 72 75 6e 6e 61 tch target/runna
5390: 6d 65 0a 3b 3b 20 0a 3b 3b 20 64 6f 20 61 20 72 me.;; .;; do a r
53a0: 65 6d 6f 74 65 20 63 61 6c 6c 20 74 6f 20 67 65 emote call to ge
53b0: 74 20 74 68 65 20 74 61 73 6b 20 71 75 65 75 65 t the task queue
53c0: 20 69 6e 66 6f 20 62 75 74 20 64 6f 20 74 68 65 info but do the
53d0: 20 6b 69 6c 6c 69 6e 67 20 61 73 20 73 65 6c 66 killing as self
53e0: 20 68 65 72 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e here..;;.(defin
53f0: 65 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 e (tasks:kill-ru
5400: 6e 6e 65 72 20 74 61 72 67 65 74 20 72 75 6e 2d nner target run-
5410: 6e 61 6d 65 20 74 65 73 74 70 61 74 74 29 0a 20 name testpatt).
5420: 20 28 6c 65 74 20 28 28 72 65 63 6f 72 64 73 20 (let ((records
5430: 20 20 20 28 72 6d 74 3a 74 61 73 6b 73 2d 66 69 (rmt:tasks-fi
5440: 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 nd-task-queue-re
5450: 63 6f 72 64 73 20 74 61 72 67 65 74 20 72 75 6e cords target run
5460: 2d 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 22 -name testpatt "
5470: 72 75 6e 6e 69 6e 67 22 20 22 72 75 6e 2d 74 65 running" "run-te
5480: 73 74 73 22 29 29 0a 09 28 68 6f 73 74 70 69 64 sts"))..(hostpid
5490: 2d 72 78 20 28 72 65 67 65 78 70 20 22 5c 5c 73 -rx (regexp "\\s
54a0: 2b 28 5c 5c 77 2b 29 5c 5c 73 2b 28 5c 5c 64 2b +(\\w+)\\s+(\\d+
54b0: 29 24 22 29 29 29 20 3b 3b 20 68 6f 73 74 20 70 )$"))) ;; host p
54c0: 69 64 20 69 73 20 61 74 20 65 6e 64 20 6f 66 20 id is at end of
54d0: 70 61 72 61 6d 20 73 74 72 69 6e 67 0a 20 20 20 param string.
54e0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 63 6f (if (null? reco
54f0: 72 64 73 29 0a 09 28 64 65 62 75 67 3a 70 72 69 rds)..(debug:pri
5500: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
5510: 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 72 75 6e 20 g-port* "No run
5520: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
5530: 73 65 73 20 66 6f 75 6e 64 20 66 6f 72 20 22 20 ses found for "
5540: 74 61 72 67 65 74 20 22 20 2f 20 22 20 72 75 6e target " / " run
5550: 2d 6e 61 6d 65 20 22 20 77 69 74 68 20 74 65 73 -name " with tes
5560: 74 70 61 74 74 20 22 20 28 6f 72 20 74 65 73 74 tpatt " (or test
5570: 70 61 74 74 20 22 2a 20 6e 6f 20 74 65 73 74 70 patt "* no testp
5580: 61 74 74 20 73 70 65 63 69 66 69 65 64 21 20 2a att specified! *
5590: 22 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e "))..(debug:prin
55a0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
55b0: 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 22 20 -port* "Found "
55c0: 28 6c 65 6e 67 74 68 20 72 65 63 6f 72 64 73 29 (length records)
55d0: 20 22 20 72 75 6e 28 73 29 20 74 6f 20 6b 69 6c " run(s) to kil
55e0: 6c 2e 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 l.")). (for-e
55f0: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
5600: 61 20 28 72 65 63 6f 72 64 29 0a 20 20 20 20 20 a (record).
5610: 20 20 28 6c 65 74 2a 20 28 28 70 61 72 61 6d 2d (let* ((param-
5620: 6b 65 79 20 28 6c 69 73 74 2d 72 65 66 20 72 65 key (list-ref re
5630: 63 6f 72 64 20 38 29 29 0a 09 20 20 20 20 20 20 cord 8))..
5640: 28 6d 61 74 63 68 2d 64 61 74 20 28 73 74 72 69 (match-dat (stri
5650: 6e 67 2d 73 65 61 72 63 68 20 68 6f 73 74 70 69 ng-search hostpi
5660: 64 2d 72 78 20 70 61 72 61 6d 2d 6b 65 79 29 29 d-rx param-key))
5670: 29 0a 09 20 28 69 66 20 6d 61 74 63 68 2d 64 61 ).. (if match-da
5680: 74 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 68 t.. (let ((h
5690: 6f 73 74 6e 61 6d 65 20 20 28 63 61 64 72 20 6d ostname (cadr m
56a0: 61 74 63 68 2d 64 61 74 29 29 0a 09 09 20 20 20 atch-dat))...
56b0: 28 70 69 64 20 20 20 20 20 20 20 28 73 74 72 69 (pid (stri
56c0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 ng->number (cadd
56d0: 72 20 6d 61 74 63 68 2d 64 61 74 29 29 29 29 0a r match-dat)))).
56e0: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
56f0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5700: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 6e 64 69 log-port* "Sendi
5710: 6e 67 20 53 49 47 49 4e 54 20 74 6f 20 70 72 6f ng SIGINT to pro
5720: 63 65 73 73 20 22 20 70 69 64 20 22 20 6f 6e 20 cess " pid " on
5730: 68 6f 73 74 20 22 20 68 6f 73 74 6e 61 6d 65 29 host " hostname)
5740: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 65 71 .. (if (eq
5750: 75 61 6c 3f 20 28 67 65 74 2d 68 6f 73 74 2d 6e ual? (get-host-n
5760: 61 6d 65 29 20 68 6f 73 74 6e 61 6d 65 29 0a 09 ame) hostname)..
5770: 09 20 20 20 28 69 66 20 28 70 72 6f 63 65 73 73 . (if (process
5780: 3a 61 6c 69 76 65 3f 20 70 69 64 29 0a 09 09 20 :alive? pid)...
5790: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
57a0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
57b0: 6f 6e 73 0a 09 09 09 20 20 65 78 6e 0a 09 09 09 ons.... exn....
57c0: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
57d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
57e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
57f0: 2a 20 22 4b 69 6c 6c 20 6f 66 20 70 72 6f 63 65 * "Kill of proce
5800: 73 73 20 22 20 70 69 64 20 22 20 6f 6e 20 68 6f ss " pid " on ho
5810: 73 74 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 st " hostname "
5820: 66 61 69 6c 65 64 2e 22 29 0a 09 09 09 20 20 20 failed.")....
5830: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
5840: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5850: 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 t* " message: "
5860: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
5870: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
5880: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
5890: 29 29 0a 09 09 09 20 20 20 20 23 74 29 0a 09 09 )).... #t)...
58a0: 09 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e . (process-sign
58b0: 61 6c 20 70 69 64 20 73 69 67 6e 61 6c 2f 69 6e al pid signal/in
58c0: 74 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d t).... (thread-
58d0: 73 6c 65 65 70 21 20 35 29 0a 09 09 09 20 20 28 sleep! 5).... (
58e0: 69 66 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 if (process:aliv
58f0: 65 3f 20 70 69 64 29 0a 09 09 09 20 20 20 20 20 e? pid)....
5900: 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
5910: 20 70 69 64 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c pid signal/kill
5920: 29 29 29 29 29 0a 09 09 20 20 20 3b 3b 20 20 28 )))))... ;; (
5930: 63 61 6c 6c 2d 77 69 74 68 2d 65 6e 76 69 72 6f call-with-enviro
5940: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 0a nment-variables.
5950: 09 09 20 20 20 28 6c 65 74 20 28 28 6f 6c 64 2d .. (let ((old-
5960: 74 61 72 67 65 74 68 6f 73 74 20 28 67 65 74 65 targethost (gete
5970: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 nv "TARGETHOST")
5980: 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 65 6e ))... (seten
5990: 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 20 68 v "TARGETHOST" h
59a0: 6f 73 74 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 ostname)...
59b0: 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 (setenv "TARGETH
59c0: 4f 53 54 5f 4c 4f 47 46 22 20 22 73 65 72 76 65 OST_LOGF" "serve
59d0: 72 2d 6b 69 6c 6c 73 2e 6c 6f 67 22 29 0a 09 09 r-kills.log")...
59e0: 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f (system (co
59f0: 6e 63 20 22 6e 62 66 61 6b 65 20 6b 69 6c 6c 20 nc "nbfake kill
5a00: 22 20 70 69 64 29 29 0a 09 09 20 20 20 20 20 28 " pid))... (
5a10: 69 66 20 6f 6c 64 2d 74 61 72 67 65 74 68 6f 73 if old-targethos
5a20: 74 20 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 t (setenv "TARGE
5a30: 54 48 4f 53 54 22 20 6f 6c 64 2d 74 61 72 67 65 THOST" old-targe
5a40: 74 68 6f 73 74 29 29 0a 09 09 20 20 20 20 20 28 thost))... (
5a50: 75 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 unsetenv "TARGET
5a60: 48 4f 53 54 22 29 0a 09 09 20 20 20 20 20 28 75 HOST")... (u
5a70: 6e 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 nsetenv "TARGETH
5a80: 4f 53 54 5f 4c 4f 47 46 22 29 29 29 29 0a 09 20 OST_LOGF"))))..
5a90: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5aa0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
5ab0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 20 t-log-port* "no
5ac0: 72 65 63 6f 72 64 20 6f 72 20 69 6d 70 72 6f 70 record or improp
5ad0: 65 72 20 72 65 63 6f 72 64 20 66 6f 72 20 22 20 er record for "
5ae0: 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e target "/" run-n
5af0: 61 6d 65 20 22 20 69 6e 20 74 61 73 6b 73 5f 71 ame " in tasks_q
5b00: 75 65 75 65 20 69 6e 20 6d 61 69 6e 2e 64 62 22 ueue in main.db"
5b10: 29 29 29 29 0a 20 20 20 20 20 72 65 63 6f 72 64 )))). record
5b20: 73 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 s)))..;; (define
5b30: 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 72 75 (tasks:start-ru
5b40: 6e 20 64 62 73 74 72 75 63 74 20 6d 64 62 20 74 n dbstruct mdb t
5b50: 61 73 6b 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 ask).;; (let (
5b60: 28 66 6c 61 67 73 20 28 6d 61 6b 65 2d 68 61 73 (flags (make-has
5b70: 68 2d 74 61 62 6c 65 29 29 29 0a 3b 3b 20 20 20 h-table))).;;
5b80: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
5b90: 74 21 20 66 6c 61 67 73 20 22 2d 72 65 72 75 6e t! flags "-rerun
5ba0: 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 " "NOT_STARTED")
5bb0: 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 .;; (if (not
5bc0: 20 28 73 74 72 69 6e 67 3d 3f 20 28 74 61 73 6b (string=? (task
5bd0: 73 3a 74 61 73 6b 2d 67 65 74 2d 70 61 72 61 6d s:task-get-param
5be0: 73 20 74 61 73 6b 29 20 22 22 29 29 0a 3b 3b 20 s task) "")).;;
5bf0: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
5c00: 21 20 66 6c 61 67 73 20 22 2d 73 65 74 76 61 72 ! flags "-setvar
5c10: 73 22 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 s" (tasks:task-g
5c20: 65 74 2d 70 61 72 61 6d 73 20 74 61 73 6b 29 29 et-params task))
5c30: 29 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 ).;; (print
5c40: 22 53 74 61 72 74 69 6e 67 20 72 75 6e 20 22 20 "Starting run "
5c50: 74 61 73 6b 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 task).;; ;;
5c60: 73 69 6c 6c 79 6e 65 73 73 2c 20 6a 75 73 74 20 sillyness, just
5c70: 63 61 6c 6c 20 74 68 65 20 64 61 6d 6e 20 72 6f call the damn ro
5c80: 75 74 69 6e 65 20 77 69 74 68 20 74 68 65 20 74 utine with the t
5c90: 61 73 6b 20 76 65 63 74 6f 72 20 61 6e 64 20 62 ask vector and b
5ca0: 65 20 64 6f 6e 65 20 77 69 74 68 20 69 74 2e 20 e done with it.
5cb0: 46 49 58 4d 45 20 53 4f 4d 45 44 41 59 0a 3b 3b FIXME SOMEDAY.;;
5cc0: 20 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 (runs:run-t
5cd0: 65 73 74 73 20 64 62 0a 3b 3b 20 09 09 20 20 20 ests db.;; ..
5ce0: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
5cf0: 2d 74 61 72 67 65 74 20 74 61 73 6b 29 0a 3b 3b -target task).;;
5d00: 20 09 09 20 20 20 20 28 74 61 73 6b 73 3a 74 61 .. (tasks:ta
5d10: 73 6b 2d 67 65 74 2d 6e 61 6d 65 20 20 20 74 61 sk-get-name ta
5d20: 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 28 74 61 sk).;; .. (ta
5d30: 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 65 73 sks:task-get-tes
5d40: 74 20 20 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 t task).;; ..
5d50: 20 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 (tasks:task-g
5d60: 65 74 2d 69 74 65 6d 20 20 20 74 61 73 6b 29 0a et-item task).
5d70: 3b 3b 20 09 09 20 20 20 20 28 74 61 73 6b 73 3a ;; .. (tasks:
5d80: 74 61 73 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 task-get-owner
5d90: 74 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 66 task).;; .. f
5da0: 6c 61 67 73 29 0a 3b 3b 20 20 20 20 20 28 74 61 lags).;; (ta
5db0: 73 6b 73 3a 73 65 74 2d 73 74 61 74 65 20 6d 64 sks:set-state md
5dc0: 62 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 b (tasks:task-ge
5dd0: 74 2d 69 64 20 74 61 73 6b 29 20 22 77 61 69 74 t-id task) "wait
5de0: 69 6e 67 22 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 ing"))).;; .;; (
5df0: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 6f define (tasks:ro
5e00: 6c 6c 75 70 2d 72 75 6e 73 20 64 62 20 6d 64 62 llup-runs db mdb
5e10: 20 74 61 73 6b 29 0a 3b 3b 20 20 20 28 6c 65 74 task).;; (let
5e20: 2a 20 28 28 66 6c 61 67 73 20 28 6d 61 6b 65 2d * ((flags (make-
5e30: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 0a 3b 3b hash-table)) .;;
5e40: 20 09 20 28 6b 65 79 73 20 20 28 64 62 3a 67 65 . (keys (db:ge
5e50: 74 2d 6b 65 79 73 20 64 62 29 29 0a 3b 3b 20 09 t-keys db)).;; .
5e60: 20 28 6b 65 79 76 61 6c 73 20 28 6b 65 79 73 3a (keyvals (keys:
5e70: 74 61 72 67 65 74 2d 6b 65 79 76 61 6c 20 6b 65 target-keyval ke
5e80: 79 73 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 ys (tasks:task-g
5e90: 65 74 2d 74 61 72 67 65 74 20 74 61 73 6b 29 29 et-target task))
5ea0: 29 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 28 68 61 )).;; ;; (ha
5eb0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 6c sh-table-set! fl
5ec0: 61 67 73 20 22 2d 72 65 72 75 6e 22 20 22 4e 4f ags "-rerun" "NO
5ed0: 54 5f 53 54 41 52 54 45 44 22 29 0a 3b 3b 20 20 T_STARTED").;;
5ee0: 20 20 20 28 70 72 69 6e 74 20 22 53 74 61 72 74 (print "Start
5ef0: 69 6e 67 20 72 6f 6c 6c 75 70 20 22 20 74 61 73 ing rollup " tas
5f00: 6b 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 69 6c k).;; ;; sil
5f10: 6c 79 6e 65 73 73 2c 20 6a 75 73 74 20 63 61 6c lyness, just cal
5f20: 6c 20 74 68 65 20 64 61 6d 6e 20 72 6f 75 74 69 l the damn routi
5f30: 6e 65 20 77 69 74 68 20 74 68 65 20 74 61 73 6b ne with the task
5f40: 20 76 65 63 74 6f 72 20 61 6e 64 20 62 65 20 64 vector and be d
5f50: 6f 6e 65 20 77 69 74 68 20 69 74 2e 20 46 49 58 one with it. FIX
5f60: 4d 45 20 53 4f 4d 45 44 41 59 0a 3b 3b 20 20 20 ME SOMEDAY.;;
5f70: 20 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 (runs:rollup-r
5f80: 75 6e 20 64 62 0a 3b 3b 20 09 09 20 20 20 20 20 un db.;; ..
5f90: 6b 65 79 73 20 0a 3b 3b 20 09 09 20 20 20 20 20 keys .;; ..
5fa0: 6b 65 79 76 61 6c 73 0a 3b 3b 20 09 09 20 20 20 keyvals.;; ..
5fb0: 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 (tasks:task-ge
5fc0: 74 2d 6e 61 6d 65 20 20 74 61 73 6b 29 0a 3b 3b t-name task).;;
5fd0: 20 09 09 20 20 20 20 20 28 74 61 73 6b 73 3a 74 .. (tasks:t
5fe0: 61 73 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 ask-get-owner t
5ff0: 61 73 6b 29 29 0a 3b 3b 20 20 20 20 20 28 74 61 ask)).;; (ta
6000: 73 6b 73 3a 73 65 74 2d 73 74 61 74 65 20 6d 64 sks:set-state md
6010: 62 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 b (tasks:task-ge
6020: 74 2d 69 64 20 74 61 73 6b 29 20 22 77 61 69 74 t-id task) "wait
6030: 69 6e 67 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d ing")))..;;=====
6040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6080: 3d 0a 3b 3b 20 20 53 20 59 20 4e 20 43 20 20 20 =.;; S Y N C
6090: 54 20 4f 20 20 20 50 20 4f 20 53 20 54 20 47 20 T O P O S T G
60a0: 52 20 45 20 53 20 51 20 4c 0a 3b 3b 3d 3d 3d 3d R E S Q L.;;====
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 3d ================
60d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60f0: 3d 3d 0a 0a 3b 3b 20 49 6e 20 74 68 65 20 73 70 ==..;; In the sp
6100: 69 72 69 74 20 6f 66 20 22 64 75 6d 70 20 79 6f irit of "dump yo
6110: 75 72 20 6a 75 6e 6b 20 69 6e 20 74 68 65 20 74 ur junk in the t
6120: 61 73 6b 73 20 6d 6f 64 75 6c 65 22 20 49 27 6c asks module" I'l
6130: 6c 20 70 75 74 20 74 68 65 0a 3b 3b 20 73 79 6e l put the.;; syn
6140: 63 20 74 6f 20 70 6f 73 74 67 72 65 73 20 68 65 c to postgres he
6150: 72 65 20 66 6f 72 20 6e 6f 77 2e 0a 0a 3b 3b 20 re for now...;;
6160: 61 74 74 65 6d 70 74 20 74 6f 20 61 75 74 6f 6d attempt to autom
6170: 61 74 69 63 61 6c 6c 79 20 73 65 74 20 75 70 20 atically set up
6180: 61 6e 20 61 72 65 61 2e 20 63 61 6c 6c 20 6f 6e an area. call on
6190: 6c 79 20 69 66 20 67 65 74 20 61 72 65 61 20 62 ly if get area b
61a0: 79 20 70 61 74 68 0a 3b 3b 20 72 65 74 75 72 6e y path.;; return
61b0: 73 20 6e 61 75 67 68 74 20 6f 66 20 69 6e 74 65 s naught of inte
61c0: 72 65 73 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 rest.;;.(define
61d0: 28 74 61 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 (tasks:set-area
61e0: 64 62 68 20 63 6f 6e 66 69 67 64 61 74 20 23 21 dbh configdat #!
61f0: 6b 65 79 20 28 74 6f 70 70 61 74 68 20 23 66 29 key (toppath #f)
6200: 29 20 3b 3b 20 63 6f 75 6c 64 20 49 20 73 61 66 ) ;; could I saf
6210: 65 6c 79 20 70 75 74 20 2a 74 6f 70 70 61 74 68 ely put *toppath
6220: 2a 20 69 6e 20 66 6f 72 20 74 68 65 20 64 65 66 * in for the def
6230: 61 75 6c 74 20 66 6f 72 20 74 6f 70 70 61 74 68 ault for toppath
6240: 3f 20 77 68 65 6e 20 77 6f 75 6c 64 20 69 74 20 ? when would it
6250: 62 65 20 65 76 61 6c 75 61 74 65 64 3f 0a 20 20 be evaluated?.
6260: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 61 72 65 61 (let loop ((area
6270: 2d 6e 61 6d 65 20 28 6f 72 20 28 63 6f 6e 66 69 -name (or (confi
6280: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
6290: 64 61 74 20 22 73 65 74 75 70 22 20 22 61 72 65 dat "setup" "are
62a0: 61 2d 6e 61 6d 65 22 29 0a 09 09 09 20 20 20 20 a-name")....
62b0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 (common:get-area
62c0: 2d 6e 61 6d 65 29 29 29 0a 09 20 20 20 20 20 28 -name))).. (
62d0: 6d 6f 64 69 66 69 65 72 20 20 27 6e 6f 6e 65 29 modifier 'none)
62e0: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 73 75 63 ). (let ((suc
62f0: 63 65 73 73 20 28 68 61 6e 64 6c 65 2d 65 78 63 cess (handle-exc
6300: 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 20 20 eptions...
6310: 20 65 78 6e 0a 09 09 20 20 20 20 20 20 20 28 62 exn... (b
6320: 65 67 69 6e 0a 09 09 09 20 28 64 65 62 75 67 3a egin.... (debug:
6330: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
6340: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
6350: 52 3a 20 63 61 6e 6e 6f 74 20 63 72 65 61 74 65 R: cannot create
6360: 20 61 72 65 61 20 65 6e 74 72 79 2c 20 22 20 28 area entry, " (
6370: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
6380: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
6390: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
63a0: 29 0a 09 09 09 20 23 66 29 20 3b 3b 20 46 49 58 ).... #f) ;; FIX
63b0: 4d 45 3a 20 49 20 64 6f 6e 27 74 20 63 61 72 65 ME: I don't care
63c0: 20 66 6f 72 20 6e 6f 77 20 62 75 74 20 49 20 73 for now but I s
63d0: 68 6f 75 6c 64 20 6c 6f 6f 6b 20 61 74 20 2a 77 hould look at *w
63e0: 68 79 2a 20 74 68 65 72 65 20 77 61 73 20 61 6e hy* there was an
63f0: 20 65 78 63 65 70 74 69 6f 6e 0a 09 09 20 20 20 exception...
6400: 20 20 28 70 67 64 62 3a 61 64 64 2d 61 72 65 61 (pgdb:add-area
6410: 20 64 62 68 20 61 72 65 61 2d 6e 61 6d 65 20 28 dbh area-name (
6420: 6f 72 20 74 6f 70 70 61 74 68 20 2a 74 6f 70 70 or toppath *topp
6430: 61 74 68 2a 29 29 29 29 29 0a 20 20 20 20 20 20 ath*))))).
6440: 28 6f 72 20 73 75 63 63 65 73 73 0a 09 20 20 28 (or success.. (
6450: 63 61 73 65 20 6d 6f 64 69 66 69 65 72 0a 09 20 case modifier..
6460: 20 20 20 28 28 6e 6f 6e 65 29 28 6c 6f 6f 70 20 ((none)(loop
6470: 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 75 (conc (current-u
6480: 73 65 72 2d 6e 61 6d 65 29 20 22 5f 22 20 61 72 ser-name) "_" ar
6490: 65 61 2d 6e 61 6d 65 29 20 27 75 73 65 72 29 29 ea-name) 'user))
64a0: 0a 09 20 20 20 20 28 28 75 73 65 72 29 28 6c 6f .. ((user)(lo
64b0: 6f 70 20 28 63 6f 6e 63 20 28 73 75 62 73 74 72 op (conc (substr
64c0: 69 6e 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ing (common:get-
64d0: 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 area-path-signat
64e0: 75 72 65 29 20 30 20 34 29 0a 09 09 09 20 20 20 ure) 0 4)....
64f0: 20 20 20 20 61 72 65 61 2d 6e 61 6d 65 29 20 27 area-name) '
6500: 61 72 65 61 73 69 67 29 29 0a 09 20 20 20 20 28 areasig)).. (
6510: 65 6c 73 65 20 23 66 29 29 29 29 29 29 20 3b 3b else #f)))))) ;;
6520: 20 67 69 76 65 20 75 70 0a 0a 28 64 65 66 69 6e give up..(defin
6530: 65 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 72 75 e (task:print-ru
6540: 6e 74 69 6d 65 20 72 75 6e 2d 74 69 6d 65 73 20 ntime run-times
6550: 73 61 70 65 72 61 74 6f 72 29 0a 28 66 6f 72 2d saperator).(for-
6560: 65 61 63 68 0a 20 20 20 20 28 6c 61 6d 62 64 61 each. (lambda
6570: 20 28 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 29 (run-time-info)
6580: 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 . (let* ((ru
6590: 6e 2d 6e 61 6d 65 20 20 28 76 65 63 74 6f 72 2d n-name (vector-
65a0: 72 65 66 20 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 ref run-time-inf
65b0: 6f 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 o 0)).
65c0: 20 20 28 72 75 6e 2d 74 69 6d 65 20 20 28 76 65 (run-time (ve
65d0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 2d 74 69 6d ctor-ref run-tim
65e0: 65 2d 69 6e 66 6f 20 31 29 29 0a 20 20 20 20 20 e-info 1)).
65f0: 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 20 (target
6600: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 2d (vector-ref run-
6610: 74 69 6d 65 2d 69 6e 66 6f 20 32 29 29 29 0a 20 time-info 2))).
6620: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 74 61 (print ta
6630: 72 67 65 74 20 73 61 70 65 72 61 74 6f 72 20 72 rget saperator r
6640: 75 6e 2d 6e 61 6d 65 20 73 61 70 65 72 61 74 6f un-name saperato
6650: 72 20 72 75 6e 2d 74 69 6d 65 20 29 29 29 0a 20 r run-time ))).
6660: 20 20 72 75 6e 2d 74 69 6d 65 73 29 29 0a 0a 28 run-times))..(
6670: 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 70 72 69 define (task:pri
6680: 6e 74 2d 72 75 6e 74 69 6d 65 2d 61 73 2d 6a 73 nt-runtime-as-js
6690: 6f 6e 20 72 75 6e 2d 74 69 6d 65 73 29 0a 20 28 on run-times). (
66a0: 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 2d 74 let loop ((run-t
66b0: 69 6d 65 2d 69 6e 66 6f 20 28 63 61 72 20 72 75 ime-info (car ru
66c0: 6e 2d 74 69 6d 65 73 29 29 0a 20 20 20 20 20 20 n-times)).
66d0: 20 20 20 20 20 20 28 72 65 6d 61 20 28 63 64 72 (rema (cdr
66e0: 20 72 75 6e 2d 74 69 6d 65 73 29 29 20 0a 20 20 run-times)) .
66f0: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 20 22 (str "
6700: 22 29 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 ")). (let* (
6710: 28 72 75 6e 2d 6e 61 6d 65 20 20 28 76 65 63 74 (run-name (vect
6720: 6f 72 2d 72 65 66 20 72 75 6e 2d 74 69 6d 65 2d or-ref run-time-
6730: 69 6e 66 6f 20 30 29 29 0a 20 20 20 20 20 20 20 info 0)).
6740: 20 20 20 20 20 28 72 75 6e 2d 74 69 6d 65 20 20 (run-time
6750: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 2d (vector-ref run-
6760: 74 69 6d 65 2d 69 6e 66 6f 20 31 29 29 0a 20 20 time-info 1)).
6770: 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 (targe
6780: 74 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 t (vector-ref r
6790: 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 20 32 29 29 un-time-info 2))
67a0: 29 0a 20 20 20 20 20 20 20 20 3b 28 70 72 69 6e ). ;(prin
67b0: 74 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 t (not (equal? s
67c0: 74 72 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 tr ""))).
67d0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
67e0: 3f 20 73 74 72 20 22 22 29 29 20 0a 20 20 20 20 ? str "")) .
67f0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 73 74 (set! st
6800: 72 20 28 63 6f 6e 63 20 73 74 72 20 22 2c 22 29 r (conc str ",")
6810: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
6820: 6e 75 6c 6c 3f 20 72 65 6d 61 29 0a 09 09 28 70 null? rema)...(p
6830: 72 69 6e 74 20 22 5b 22 20 73 74 72 20 22 7b 74 rint "[" str "{t
6840: 61 72 67 65 74 3a 22 20 74 61 72 67 65 74 20 22 arget:" target "
6850: 2c 72 75 6e 2d 6e 61 6d 65 3a 22 20 72 75 6e 2d ,run-name:" run-
6860: 6e 61 6d 65 20 22 2c 20 72 75 6e 2d 74 69 6d 65 name ", run-time
6870: 3a 22 20 72 75 6e 2d 74 69 6d 65 20 22 7d 5d 22 :" run-time "}]"
6880: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ). (l
6890: 6f 6f 70 20 28 63 61 72 20 72 65 6d 61 29 20 28 oop (car rema) (
68a0: 63 64 72 20 72 65 6d 61 29 20 28 63 6f 6e 63 20 cdr rema) (conc
68b0: 73 74 72 20 22 7b 74 61 72 67 65 74 3a 22 20 74 str "{target:" t
68c0: 61 72 67 65 74 20 22 2c 20 72 75 6e 2d 6e 61 6d arget ", run-nam
68d0: 65 3a 22 20 72 75 6e 2d 6e 61 6d 65 20 22 2c 20 e:" run-name ",
68e0: 72 75 6e 2d 74 69 6d 65 3a 22 20 72 75 6e 2d 74 run-time:" run-t
68f0: 69 6d 65 20 22 7d 22 29 29 29 29 29 29 0a 0a 28 ime "}"))))))..(
6900: 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 67 65 74 define (task:get
6910: 2d 72 75 6e 2d 74 69 6d 65 73 29 0a 20 20 20 28 -run-times). (
6920: 6c 65 74 2a 20 28 20 0a 20 20 20 20 20 20 20 20 let* ( .
6930: 20 20 20 28 72 75 6e 2d 70 61 74 74 20 28 69 66 (run-patt (if
6940: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6950: 2d 72 75 6e 2d 70 61 74 74 22 29 0a 20 20 20 20 -run-patt").
6960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6970: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
6980: 67 20 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 20 g "-run-patt").
6990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69a0: 20 20 20 20 20 20 20 22 25 22 29 29 0a 20 20 20 "%")).
69b0: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 2d (target-
69c0: 70 61 74 74 20 28 69 66 20 28 61 72 67 73 3a 67 patt (if (args:g
69d0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d et-arg "-target-
69e0: 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 patt").
69f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6a00: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
6a10: 61 72 67 65 74 2d 70 61 74 74 22 29 0a 20 20 20 arget-patt").
6a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a30: 20 20 20 20 20 22 25 22 29 29 0a 20 0a 20 20 20 "%")). .
6a40: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 74 69 6d (run-tim
6a50: 65 73 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e es (rmt:get-run
6a60: 2d 74 69 6d 65 73 20 20 72 75 6e 2d 70 61 74 74 -times run-patt
6a70: 20 74 61 72 67 65 74 2d 70 61 74 74 20 29 29 29 target-patt )))
6a80: 0a 20 20 20 28 69 66 20 28 65 71 3f 20 28 6c 65 . (if (eq? (le
6a90: 6e 67 74 68 20 72 75 6e 2d 74 69 6d 65 73 29 20 ngth run-times)
6aa0: 30 29 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 0). (begin.
6ab0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 (print "Da
6ac0: 74 61 20 6e 6f 74 20 66 6f 75 6e 64 21 21 22 29 ta not found!!")
6ad0: 0a 20 20 20 20 20 20 20 28 65 78 69 74 29 29 29 . (exit)))
6ae0: 0a 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 . (if (equal?
6af0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
6b00: 64 75 6d 70 6d 6f 64 65 22 29 20 22 6a 73 6f 6e dumpmode") "json
6b10: 22 29 0a 20 20 20 20 20 20 20 28 74 61 73 6b 3a "). (task:
6b20: 70 72 69 6e 74 2d 72 75 6e 74 69 6d 65 2d 61 73 print-runtime-as
6b30: 2d 6a 73 6f 6e 20 72 75 6e 2d 74 69 6d 65 73 29 -json run-times)
6b40: 0a 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 . (if (e
6b50: 71 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 74 2d qual? (args:get-
6b60: 61 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 22 29 arg "-dumpmode")
6b70: 20 22 63 73 76 22 29 0a 09 20 20 20 20 20 28 74 "csv").. (t
6b80: 61 73 6b 3a 70 72 69 6e 74 2d 72 75 6e 74 69 6d ask:print-runtim
6b90: 65 20 72 75 6e 2d 74 69 6d 65 73 20 22 2c 22 29 e run-times ",")
6ba0: 0a 09 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 .. (task:pri
6bb0: 6e 74 2d 72 75 6e 74 69 6d 65 20 72 75 6e 2d 74 nt-runtime run-t
6bc0: 69 6d 65 73 20 22 20 20 22 29 29 29 29 29 0a 0a imes " ")))))..
6bd0: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 70 .(define (task:p
6be0: 72 69 6e 74 2d 74 65 73 74 74 69 6d 65 20 74 65 rint-testtime te
6bf0: 73 74 2d 74 69 6d 65 73 20 73 61 70 65 72 61 74 st-times saperat
6c00: 6f 72 29 0a 28 66 6f 72 2d 65 61 63 68 0a 20 20 or).(for-each.
6c10: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
6c20: 74 69 6d 65 2d 69 6e 66 6f 29 0a 20 20 20 20 20 time-info).
6c30: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d (let* ((test-nam
6c40: 65 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 e (vector-ref t
6c50: 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 30 29 est-time-info 0)
6c60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 74 ). (t
6c70: 65 73 74 2d 74 69 6d 65 20 20 28 76 65 63 74 6f est-time (vecto
6c80: 72 2d 72 65 66 20 74 65 73 74 2d 74 69 6d 65 2d r-ref test-time-
6c90: 69 6e 66 6f 20 32 29 29 0a 20 20 20 20 20 20 20 info 2)).
6ca0: 20 20 20 20 20 28 74 65 73 74 2d 69 74 65 6d 20 (test-item
6cb0: 20 28 69 66 20 28 65 71 3f 20 28 73 74 72 69 6e (if (eq? (strin
6cc0: 67 2d 6c 65 6e 67 74 68 20 28 76 65 63 74 6f 72 g-length (vector
6cd0: 2d 72 65 66 20 74 65 73 74 2d 74 69 6d 65 2d 69 -ref test-time-i
6ce0: 6e 66 6f 20 31 29 29 20 30 29 0a 20 20 20 20 20 nfo 1)) 0).
6cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d00: 20 20 20 20 20 20 20 20 20 20 22 4e 2f 41 22 0a "N/A".
6d10: 09 09 09 09 28 76 65 63 74 6f 72 2d 72 65 66 20 ....(vector-ref
6d20: 74 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 31 test-time-info 1
6d30: 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 )))). (pr
6d40: 69 6e 74 20 20 74 65 73 74 2d 6e 61 6d 65 20 73 int test-name s
6d50: 61 70 65 72 61 74 6f 72 20 74 65 73 74 2d 69 74 aperator test-it
6d60: 65 6d 20 73 61 70 65 72 61 74 6f 72 20 74 65 73 em saperator tes
6d70: 74 2d 74 69 6d 65 20 29 29 29 0a 20 20 20 74 65 t-time ))). te
6d80: 73 74 2d 74 69 6d 65 73 29 29 0a 0a 28 64 65 66 st-times))..(def
6d90: 69 6e 65 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d ine (task:print-
6da0: 74 65 73 74 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e testtime-as-json
6db0: 20 74 65 73 74 2d 74 69 6d 65 73 29 0a 20 28 6c test-times). (l
6dc0: 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 2d 74 et loop ((test-t
6dd0: 69 6d 65 2d 69 6e 66 6f 20 28 63 61 72 20 74 65 ime-info (car te
6de0: 73 74 2d 74 69 6d 65 73 29 29 0a 20 20 20 20 20 st-times)).
6df0: 20 20 20 20 20 20 20 28 72 65 6d 61 20 28 63 64 (rema (cd
6e00: 72 20 74 65 73 74 2d 74 69 6d 65 73 29 29 20 0a r test-times)) .
6e10: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
6e20: 20 22 22 29 29 0a 20 20 20 20 20 28 6c 65 74 2a "")). (let*
6e30: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 28 76 ((test-name (v
6e40: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 2d 74 ector-ref test-t
6e50: 69 6d 65 2d 69 6e 66 6f 20 30 29 29 0a 20 20 20 ime-info 0)).
6e60: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 74 (test-t
6e70: 69 6d 65 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ime (vector-ref
6e80: 20 74 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 test-time-info
6e90: 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
6ea0: 28 69 74 65 6d 20 20 28 76 65 63 74 6f 72 2d 72 (item (vector-r
6eb0: 65 66 20 74 65 73 74 2d 74 69 6d 65 2d 69 6e 66 ef test-time-inf
6ec0: 6f 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 3b o 1))). ;
6ed0: 28 70 72 69 6e 74 20 28 6e 6f 74 20 28 65 71 75 (print (not (equ
6ee0: 61 6c 3f 20 73 74 72 20 22 22 29 29 29 0a 20 20 al? str ""))).
6ef0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
6f00: 65 71 75 61 6c 3f 20 73 74 72 20 22 22 29 29 20 equal? str ""))
6f10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 . (se
6f20: 74 21 20 73 74 72 20 28 63 6f 6e 63 20 73 74 72 t! str (conc str
6f30: 20 22 2c 22 29 29 29 0a 20 20 20 20 20 20 20 20 ","))).
6f40: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 61 29 (if (null? rema)
6f50: 0a 09 09 28 70 72 69 6e 74 20 22 5b 22 20 73 74 ...(print "[" st
6f60: 72 20 22 7b 74 65 73 74 2d 6e 61 6d 65 3a 22 20 r "{test-name:"
6f70: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 test-name ", ite
6f80: 6d 2d 70 61 74 68 3a 22 20 69 74 65 6d 20 22 2c m-path:" item ",
6f90: 20 74 65 73 74 2d 74 69 6d 65 3a 22 20 74 65 73 test-time:" tes
6fa0: 74 2d 74 69 6d 65 20 22 7d 5d 22 29 0a 20 20 20 t-time "}]").
6fb0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
6fc0: 63 61 72 20 72 65 6d 61 29 20 28 63 64 72 20 72 car rema) (cdr r
6fd0: 65 6d 61 29 20 28 63 6f 6e 63 20 73 74 72 20 22 ema) (conc str "
6fe0: 7b 74 65 73 74 2d 6e 61 6d 65 3a 22 20 74 65 73 {test-name:" tes
6ff0: 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 t-name ", item-p
7000: 61 74 68 3a 22 20 69 74 65 6d 20 22 2c 20 74 65 ath:" item ", te
7010: 73 74 2d 74 69 6d 65 3a 22 20 74 65 73 74 2d 74 st-time:" test-t
7020: 69 6d 65 20 22 7d 22 29 29 29 29 29 29 0a 0a 0a ime "}"))))))...
7030: 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 67 (define (task:g
7040: 65 74 2d 74 65 73 74 2d 74 69 6d 65 73 29 0a 20 et-test-times).
7050: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 6e 61 6d (let* ((runnam
7060: 65 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d e (if (args:get-
7070: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7090: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
70a0: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
70b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
70c0: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 #f)).
70d0: 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 (targe
70e0: 74 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d t (if (args:get-
70f0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 arg "-target").
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 28 61 72 67 73 3a 67 65 74 (args:get
7120: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
7130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7140: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 0a 20 #f)). .
7150: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
7160: 74 69 6d 65 73 20 20 28 72 6d 74 3a 67 65 74 2d times (rmt:get-
7170: 74 65 73 74 2d 74 69 6d 65 73 20 20 72 75 6e 6e test-times runn
7180: 61 6d 65 20 74 61 72 67 65 74 20 29 29 29 0a 20 ame target ))).
7190: 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 6e 61 (if (not runna
71a0: 6d 65 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e me). (begin
71b0: 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 . (print "E
71c0: 72 72 6f 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 rror: Missing ar
71d0: 67 75 6d 65 6e 74 20 2d 72 75 6e 6e 61 6d 65 22 gument -runname"
71e0: 29 0a 20 20 20 20 20 20 28 65 78 69 74 29 29 29 ). (exit)))
71f0: 20 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 6e . (if (strin
7200: 67 2d 63 6f 6e 74 61 69 6e 73 20 72 75 6e 6e 61 g-contains runna
7210: 6d 65 20 22 25 22 29 0a 20 20 20 20 20 20 28 62 me "%"). (b
7220: 65 67 69 6e 0a 20 20 20 20 20 20 28 70 72 69 6e egin. (prin
7230: 74 20 22 45 72 72 6f 72 3a 20 49 6e 76 61 6c 69 t "Error: Invali
7240: 64 20 72 75 6e 6e 61 6d 65 2c 20 27 25 27 20 6e d runname, '%' n
7250: 6f 74 20 61 6c 6c 6f 77 65 64 20 20 28 22 20 72 ot allowed (" r
7260: 75 6e 6e 61 6d 65 20 22 29 20 22 29 0a 20 20 20 unname ") ").
7270: 20 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 (exit))).
7280: 28 69 66 20 28 6e 6f 74 20 74 61 72 67 65 74 29 (if (not target)
7290: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 . (begin.
72a0: 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f (print "Erro
72b0: 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d r: Missing argum
72c0: 65 6e 74 20 2d 74 61 72 67 65 74 22 29 0a 20 20 ent -target").
72d0: 20 20 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 (exit))).
72e0: 20 20 28 69 66 20 20 28 73 74 72 69 6e 67 2d 63 (if (string-c
72f0: 6f 6e 74 61 69 6e 73 20 74 61 72 67 65 74 20 22 ontains target "
7300: 25 22 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e %"). (begin
7310: 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 . (print "E
7320: 72 72 6f 72 3a 20 49 6e 76 61 6c 69 64 20 74 61 rror: Invalid ta
7330: 72 67 65 74 2c 20 27 25 27 20 6e 6f 74 20 61 6c rget, '%' not al
7340: 6c 6f 77 65 64 20 20 28 22 20 74 61 72 67 65 74 lowed (" target
7350: 20 22 29 20 22 29 0a 20 20 20 20 20 20 28 65 78 ") "). (ex
7360: 69 74 29 29 29 0a 20 0a 20 20 20 28 69 66 20 28 it))). . (if (
7370: 65 71 3f 20 28 6c 65 6e 67 74 68 20 74 65 73 74 eq? (length test
7380: 2d 74 69 6d 65 73 29 20 30 29 0a 20 20 20 20 20 -times) 0).
7390: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 70 (begin. (p
73a0: 72 69 6e 74 20 22 44 61 74 61 20 6e 6f 74 20 66 rint "Data not f
73b0: 6f 75 6e 64 21 21 22 29 0a 20 20 20 20 20 20 20 ound!!").
73c0: 28 65 78 69 74 29 29 29 0a 20 20 20 28 69 66 20 (exit))). (if
73d0: 28 65 71 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 (equal? (args:ge
73e0: 74 2d 61 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 t-arg "-dumpmode
73f0: 22 29 20 22 6a 73 6f 6e 22 29 0a 20 20 20 20 20 ") "json").
7400: 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 (task:print-te
7410: 73 74 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 sttime-as-json t
7420: 65 73 74 2d 74 69 6d 65 73 29 0a 20 20 20 20 20 est-times).
7430: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
7440: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7450: 64 75 6d 70 6d 6f 64 65 22 29 20 22 63 73 76 22 dumpmode") "csv"
7460: 29 0a 09 20 20 20 20 20 28 74 61 73 6b 3a 70 72 ).. (task:pr
7470: 69 6e 74 2d 74 65 73 74 74 69 6d 65 20 74 65 73 int-testtime tes
7480: 74 2d 74 69 6d 65 73 20 22 2c 22 29 0a 09 20 20 t-times ",")..
7490: 20 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 (task:print-t
74a0: 65 73 74 74 69 6d 65 20 74 65 73 74 2d 74 69 6d esttime test-tim
74b0: 65 73 20 22 20 20 22 29 29 29 29 29 0a 0a 0a 0a es " ")))))....
74c0: 3b 3b 20 67 65 74 73 20 6d 74 70 67 2d 72 75 6e ;; gets mtpg-run
74d0: 2d 69 64 20 61 6e 64 20 73 79 6e 63 73 20 74 68 -id and syncs th
74e0: 65 20 72 65 63 6f 72 64 20 69 66 20 64 69 66 66 e record if diff
74f0: 65 72 65 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 erent.;;.(define
7500: 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e (tasks:run-id->
7510: 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 mtpg-run-id dbh
7520: 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d cached-info run-
7530: 69 64 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 id area-info sma
7540: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
7550: 65 2d 74 69 6d 65 29 0a 20 20 28 6c 65 74 2a 20 e-time). (let*
7560: 28 28 72 75 6e 73 2d 68 74 20 28 68 61 73 68 2d ((runs-ht (hash-
7570: 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 table-ref cached
7580: 2d 69 6e 66 6f 20 27 72 75 6e 73 29 29 0a 09 20 -info 'runs))..
7590: 28 72 75 6e 69 6e 66 20 20 28 68 61 73 68 2d 74 (runinf (hash-t
75a0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
75b0: 20 72 75 6e 73 2d 68 74 20 72 75 6e 2d 69 64 20 runs-ht run-id
75c0: 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 #f)). (a
75d0: 72 65 61 2d 69 64 20 28 76 65 63 74 6f 72 2d 72 rea-id (vector-r
75e0: 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 ef area-info 0))
75f0: 29 0a 20 20 20 20 20 20 20 28 69 66 20 72 75 6e ). (if run
7600: 69 6e 66 0a 09 72 75 6e 69 6e 66 20 3b 3b 20 61 inf..runinf ;; a
7610: 6c 72 65 61 64 79 20 63 61 63 68 65 64 0a 09 28 lready cached..(
7620: 6c 65 74 2a 20 28 28 72 75 6e 2d 64 61 74 20 20 let* ((run-dat
7630: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 (rmt:get-run-i
7640: 6e 66 6f 20 72 75 6e 2d 69 64 29 29 20 20 20 20 nfo run-id))
7650: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4e 4f ;; NO
7660: 54 45 3a 20 67 65 74 2d 72 75 6e 2d 69 6e 66 6f TE: get-run-info
7670: 20 72 65 74 75 72 6e 73 20 61 20 76 65 63 74 6f returns a vecto
7680: 72 20 3c 20 72 6f 77 20 68 65 61 64 65 72 20 3e r < row header >
7690: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 .. (run-na
76a0: 6d 65 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 me (rmt:get-ru
76b0: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 n-name-from-id r
76c0: 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 20 20 un-id))..
76d0: 28 72 6f 77 20 20 20 20 20 20 20 20 28 64 62 3a (row (db:
76e0: 67 65 74 2d 72 6f 77 73 20 72 75 6e 2d 64 61 74 get-rows run-dat
76f0: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
7700: 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 ;; yes, thi
7710: 73 20 72 65 74 75 72 6e 73 20 61 20 73 69 6e 67 s returns a sing
7720: 6c 65 20 72 6f 77 0a 09 20 20 20 20 20 20 20 28 le row.. (
7730: 68 65 61 64 65 72 20 20 20 20 20 28 64 62 3a 67 header (db:g
7740: 65 74 2d 68 65 61 64 65 72 20 72 75 6e 2d 64 61 et-header run-da
7750: 74 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 t)).. (sta
7760: 74 65 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d te (db:get-
7770: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7780: 72 6f 77 20 68 65 61 64 65 72 20 22 73 74 61 74 row header "stat
7790: 65 22 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 e")).. (st
77a0: 61 74 75 73 20 20 20 20 20 28 64 62 3a 67 65 74 atus (db:get
77b0: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
77c0: 20 72 6f 77 20 68 65 61 64 65 72 20 22 73 74 61 row header "sta
77d0: 74 75 73 22 29 29 0a 09 20 20 20 20 20 20 20 28 tus")).. (
77e0: 6f 77 6e 65 72 20 20 20 20 20 20 28 64 62 3a 67 owner (db:g
77f0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7800: 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 6f er row header "o
7810: 77 6e 65 72 22 29 29 0a 09 20 20 20 20 20 20 20 wner"))..
7820: 28 65 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a (event-time (db:
7830: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
7840: 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 der row header "
7850: 65 76 65 6e 74 5f 74 69 6d 65 22 29 29 0a 09 20 event_time"))..
7860: 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 (comment
7870: 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d (db:get-value-
7880: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
7890: 61 64 65 72 20 22 63 6f 6d 6d 65 6e 74 22 29 29 ader "comment"))
78a0: 0a 09 20 20 20 20 20 20 20 28 66 61 69 6c 2d 63 .. (fail-c
78b0: 6f 75 6e 74 20 28 64 62 3a 67 65 74 2d 76 61 6c ount (db:get-val
78c0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 ue-by-header row
78d0: 20 68 65 61 64 65 72 20 22 66 61 69 6c 5f 63 6f header "fail_co
78e0: 75 6e 74 22 29 29 0a 09 20 20 20 20 20 20 20 28 unt")).. (
78f0: 70 61 73 73 2d 63 6f 75 6e 74 20 28 64 62 3a 67 pass-count (db:g
7900: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7910: 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 70 er row header "p
7920: 61 73 73 5f 63 6f 75 6e 74 22 29 29 0a 20 20 20 ass_count")).
7930: 20 20 20 20 20 20 28 64 62 2d 63 6f 6e 74 6f 75 (db-contou
7940: 72 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d r (db:get-value-
7950: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
7960: 61 64 65 72 20 22 63 6f 6e 74 6f 75 72 22 29 29 ader "contour"))
7970: 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 74 6f 75 .. (contou
7980: 72 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 r (if (args:g
7990: 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 6e 64 et-arg "-prepend
79a0: 2d 63 6f 6e 74 6f 75 72 22 29 20 0a 20 20 20 20 -contour") .
79b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
79d0: 20 28 61 6e 64 20 64 62 2d 63 6f 6e 74 6f 75 72 (and db-contour
79e0: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 64 62 (not (equal? db
79f0: 2d 63 6f 6e 74 6f 75 72 20 22 22 29 29 20 20 28 -contour "")) (
7a00: 73 74 72 69 6e 67 3f 20 64 62 2d 63 6f 6e 74 6f string? db-conto
7a10: 75 72 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 ur )) .
7a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a40: 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 (begin .
7a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a70: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7a80: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
7a90: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 64 lt-log-port* "d
7aa0: 62 2d 63 6f 6e 74 6f 75 72 22 29 20 0a 20 09 09 b-contour") . ..
7ab0: 09 09 09 09 64 62 2d 63 6f 6e 74 6f 75 72 29 0a ....db-contour).
7ac0: 09 09 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 ..... (args:g
7ad0: 65 74 2d 61 72 67 20 22 2d 63 6f 6e 74 6f 75 72 et-arg "-contour
7ae0: 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 ")))). (
7af0: 72 75 6e 2d 74 61 67 20 28 69 66 20 28 61 72 67 run-tag (if (arg
7b00: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d s:get-arg "-run-
7b10: 74 61 67 22 29 0a 20 20 20 20 20 20 20 20 20 20 tag").
7b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b30: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
7b40: 22 2d 72 75 6e 2d 74 61 67 22 29 0a 09 09 09 09 "-run-tag").....
7b50: 09 09 09 09 09 22 22 29 29 0a 20 20 20 20 20 20 ....."")).
7b60: 20 20 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 (last-update
7b70: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
7b80: 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 -header row head
7b90: 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 er "last_update"
7ba0: 29 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 74 )).. (keyt
7bb0: 61 72 67 20 20 20 20 28 69 66 20 28 6f 72 20 28 arg (if (or (
7bc0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 args:get-arg "-p
7bd0: 72 65 70 65 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 repend-contour")
7be0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7bf0: 2d 70 72 65 66 69 78 2d 74 61 72 67 65 74 22 29 -prefix-target")
7c00: 29 0a 09 20 20 20 20 20 20 20 09 09 09 28 63 6f ).. ...(co
7c10: 6e 63 20 22 4d 54 5f 43 4f 4e 54 4f 55 52 2f 4d nc "MT_CONTOUR/M
7c20: 54 5f 41 52 45 41 2f 22 20 28 73 74 72 69 6e 67 T_AREA/" (string
7c30: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 72 6d -intersperse (rm
7c40: 74 3a 67 65 74 2d 6b 65 79 73 29 20 22 2f 22 29 t:get-keys) "/")
7c50: 29 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 ) (string-inters
7c60: 70 65 72 73 65 20 28 72 6d 74 3a 67 65 74 2d 6b perse (rmt:get-k
7c70: 65 79 73 29 20 22 2f 22 29 29 29 20 3b 3b 20 65 eys) "/"))) ;; e
7c80: 2e 67 2e 20 76 65 72 73 69 6f 6e 2f 69 74 65 72 .g. version/iter
7c90: 61 74 69 6f 6e 2f 70 6c 61 74 66 6f 72 6d 0a 09 ation/platform..
7ca0: 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 20 (target
7cb0: 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 67 73 (if (or (args
7cc0: 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 :get-arg "-prepe
7cd0: 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 20 28 61 72 nd-contour") (ar
7ce0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
7cf0: 66 69 78 2d 74 61 72 67 65 74 22 29 29 20 0a 09 fix-target")) ..
7d00: 20 20 20 20 20 20 20 09 09 09 28 63 6f 6e 63 20 ...(conc
7d10: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
7d20: 67 20 22 2d 70 72 65 66 69 78 2d 74 61 72 67 65 g "-prefix-targe
7d30: 74 22 29 20 28 63 6f 6e 63 20 63 6f 6e 74 6f 75 t") (conc contou
7d40: 72 20 22 2f 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 r "/" (common:ge
7d50: 74 2d 61 72 65 61 2d 6e 61 6d 65 29 20 22 2f 22 t-area-name) "/"
7d60: 29 29 20 28 72 6d 74 3a 67 65 74 2d 74 61 72 67 )) (rmt:get-targ
7d70: 65 74 20 72 75 6e 2d 69 64 29 29 20 28 72 6d 74 et run-id)) (rmt
7d80: 3a 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d :get-target run-
7d90: 69 64 29 29 29 20 20 20 20 20 20 20 20 20 20 20 id)))
7da0: 20 20 20 20 20 20 3b 3b 20 65 2e 67 2e 20 76 31 ;; e.g. v1
7db0: 2e 36 33 2f 61 33 65 31 2f 75 62 75 6e 74 75 0a .63/a3e1/ubuntu.
7dc0: 09 20 20 20 20 20 20 20 28 73 70 65 63 2d 69 64 . (spec-id
7dd0: 20 20 20 20 28 70 67 64 62 3a 67 65 74 2d 74 74 (pgdb:get-tt
7de0: 79 70 65 20 64 62 68 20 6b 65 79 74 61 72 67 29 ype dbh keytarg)
7df0: 29 0a 09 20 20 20 20 20 20 20 28 70 75 62 6c 69 ).. (publi
7e00: 73 68 2d 74 69 6d 65 20 28 69 66 20 28 61 72 67 sh-time (if (arg
7e10: 73 3a 67 65 74 2d 61 72 67 20 22 2d 63 70 2d 65 s:get-arg "-cp-e
7e20: 76 65 6e 74 74 69 6d 65 2d 74 6f 2d 70 75 62 6c venttime-to-publ
7e30: 69 73 68 74 69 6d 65 22 29 0a 20 20 20 20 20 20 ishtime").
7e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e50: 20 20 20 20 20 20 65 76 65 6e 74 2d 74 69 6d 65 event-time
7e60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7e70: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur
7e80: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 20 rent-seconds)))
7e90: 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d 72 75 .. (new-ru
7ea0: 6e 2d 69 64 20 28 70 67 64 62 3a 67 65 74 2d 72 n-id (pgdb:get-r
7eb0: 75 6e 2d 69 64 20 64 62 68 20 73 70 65 63 2d 69 un-id dbh spec-i
7ec0: 64 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d d target run-nam
7ed0: 65 20 61 72 65 61 2d 69 64 29 29 29 0a 20 20 20 e area-id))).
7ee0: 20 20 20 20 20 20 28 69 66 20 6e 65 77 2d 72 75 (if new-ru
7ef0: 6e 2d 69 64 0a 09 20 20 20 20 20 20 20 20 20 28 n-id.. (
7f00: 62 65 67 69 6e 20 3b 3b 20 6c 65 74 20 28 28 72 begin ;; let ((r
7f10: 75 6e 2d 72 65 63 6f 72 64 20 28 70 67 64 62 3a un-record (pgdb:
7f20: 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 64 62 68 get-run-info dbh
7f30: 20 6e 65 77 2d 72 75 6e 2d 69 64 29 29 0a 09 09 new-run-id))...
7f40: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
7f50: 62 6c 65 2d 73 65 74 21 20 72 75 6e 73 2d 68 74 ble-set! runs-ht
7f60: 20 72 75 6e 2d 69 64 20 6e 65 77 2d 72 75 6e 2d run-id new-run-
7f70: 69 64 29 0a 09 09 3b 3b 20 65 6e 73 75 72 65 20 id)...;; ensure
7f80: 6b 65 79 20 66 69 65 6c 64 73 20 61 72 65 20 75 key fields are u
7f90: 70 20 74 6f 20 64 61 74 65 0a 20 20 20 20 20 3b p to date. ;
7fa0: 3b 20 69 66 20 6c 61 73 74 5f 75 70 64 61 74 65 ; if last_update
7fb0: 20 3d 3d 20 70 67 64 62 5f 6c 61 73 74 5f 75 70 == pgdb_last_up
7fc0: 64 61 74 65 20 64 6f 20 6e 6f 74 20 75 70 64 61 date do not upda
7fd0: 74 65 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 te smallest-last
7fe0: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 20 0a 20 -update-time .
7ff0: 20 20 20 28 6c 65 74 2a 20 28 28 70 67 64 62 2d (let* ((pgdb-
8000: 6c 61 73 74 2d 75 70 64 61 74 65 20 28 70 67 64 last-update (pgd
8010: 62 3a 67 65 74 2d 72 75 6e 2d 6c 61 73 74 2d 75 b:get-run-last-u
8020: 70 64 61 74 65 20 64 62 68 20 6e 65 77 2d 72 75 pdate dbh new-ru
8030: 6e 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 n-id)).
8040: 20 20 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 (smallest-time
8050: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8060: 2f 64 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 /default smalles
8070: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 t-last-update-ti
8080: 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d me "smallest-tim
8090: 65 22 20 23 66 29 29 29 0a 20 20 20 20 20 28 69 e" #f))). (i
80a0: 66 20 28 61 6e 64 20 20 28 3e 20 6c 61 73 74 2d f (and (> last-
80b0: 75 70 64 61 74 65 20 70 67 64 62 2d 6c 61 73 74 update pgdb-last
80c0: 2d 75 70 64 61 74 65 29 20 28 6f 72 20 28 6e 6f -update) (or (no
80d0: 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 t smallest-time)
80e0: 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 74 65 20 (< last-update
80f0: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 29 29 smallest-time)))
8100: 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 . (hash-t
8110: 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 able-set! 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 6c 61 73 74 2d 75 70 64 61 74 65 29 me" last-update)
8150: 29 29 0a 09 09 28 70 67 64 62 3a 72 65 66 72 65 ))...(pgdb:refre
8160: 73 68 2d 72 75 6e 2d 69 6e 66 6f 0a 09 09 20 64 sh-run-info... d
8170: 62 68 0a 09 09 20 6e 65 77 2d 72 75 6e 2d 69 64 bh... new-run-id
8180: 0a 09 09 20 73 74 61 74 65 20 73 74 61 74 75 73 ... state status
8190: 20 6f 77 6e 65 72 20 65 76 65 6e 74 2d 74 69 6d owner event-tim
81a0: 65 20 63 6f 6d 6d 65 6e 74 20 66 61 69 6c 2d 63 e comment fail-c
81b0: 6f 75 6e 74 20 70 61 73 73 2d 63 6f 75 6e 74 20 ount pass-count
81c0: 61 72 65 61 2d 69 64 20 6c 61 73 74 2d 75 70 64 area-id last-upd
81d0: 61 74 65 20 70 75 62 6c 69 73 68 2d 74 69 6d 65 ate publish-time
81e0: 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 ). (debug:pr
81f0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
8200: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
8210: 6f 72 6b 69 6e 67 20 6f 6e 20 72 75 6e 2d 69 64 orking on run-id
8220: 20 22 20 72 75 6e 2d 69 64 20 22 20 70 67 64 62 " run-id " pgdb
8230: 2d 69 64 20 22 20 20 6e 65 77 2d 72 75 6e 2d 69 -id " new-run-i
8240: 64 20 29 0a 20 20 20 20 20 28 69 66 20 28 6e 6f d ). (if (no
8250: 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 74 61 t (equal? run-ta
8260: 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 61 g "")). (ta
8270: 73 6b 3a 61 64 64 2d 72 75 6e 2d 74 61 67 20 64 sk:add-run-tag d
8280: 62 68 20 6e 65 77 2d 72 75 6e 2d 69 64 20 72 75 bh new-run-id ru
8290: 6e 2d 74 61 67 29 29 0a 09 09 6e 65 77 2d 72 75 n-tag))...new-ru
82a0: 6e 2d 69 64 29 20 0a 20 20 20 20 20 20 0a 09 20 n-id) . ..
82b0: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
82c0: 20 73 74 61 74 65 20 22 64 65 6c 65 74 65 64 22 state "deleted"
82d0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 67 ). (beg
82e0: 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 28 64 in . (d
82f0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8300: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
8310: 6f 72 74 2a 20 20 22 57 61 72 6e 69 6e 67 3a 20 ort* "Warning:
8320: 52 75 6e 20 77 69 74 68 20 69 64 20 22 20 72 75 Run with id " ru
8330: 6e 2d 69 64 20 22 20 77 61 73 20 63 72 65 61 74 n-id " was creat
8340: 65 64 20 61 66 74 65 72 20 70 72 65 76 69 6f 75 ed after previou
8350: 73 20 73 79 6e 63 20 61 6e 64 20 64 65 6c 65 74 s sync and delet
8360: 65 64 20 62 65 66 6f 72 65 20 74 68 65 20 73 79 ed before the sy
8370: 6e 63 22 29 20 23 66 29 0a 20 20 20 20 20 20 20 nc") #f).
8380: 20 20 20 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 (if (handle-e
8390: 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 xceptions...
83a0: 20 20 20 20 65 78 6e 0a 09 09 20 20 20 20 20 20 exn...
83b0: 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e 74 2d (begin (print-
83c0: 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 20 20 call-chain).
83d0: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
83e0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
83f0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
8400: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
8410: 6e 29 29 20 20 20 20 20 0a 09 09 09 20 20 20 20 n)) ....
8420: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
8430: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
8440: 70 67 64 62 3a 69 6e 73 65 72 74 2d 72 75 6e 0a pgdb:insert-run.
8450: 09 09 20 20 20 20 20 64 62 68 0a 09 09 20 20 20 .. dbh...
8460: 20 20 73 70 65 63 2d 69 64 20 74 61 72 67 65 74 spec-id target
8470: 20 72 75 6e 2d 6e 61 6d 65 20 73 74 61 74 65 20 run-name state
8480: 73 74 61 74 75 73 20 6f 77 6e 65 72 20 65 76 65 status owner eve
8490: 6e 74 2d 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 nt-time comment
84a0: 66 61 69 6c 2d 63 6f 75 6e 74 20 70 61 73 73 2d fail-count pass-
84b0: 63 6f 75 6e 74 20 20 61 72 65 61 2d 69 64 20 6c count area-id l
84c0: 61 73 74 2d 75 70 64 61 74 65 20 70 75 62 6c 69 ast-update publi
84d0: 73 68 2d 74 69 6d 65 29 29 0a 09 09 20 20 20 20 sh-time))...
84e0: 20 20 20 28 6c 65 74 2a 20 28 28 73 6d 61 6c 6c (let* ((small
84f0: 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 est-time (hash-t
8500: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
8510: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
8520: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
8530: 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 29 29 lest-time" #f)))
8540: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 . (i
8550: 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c f (or (not small
8560: 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 est-time) (< las
8570: 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 t-update smalles
8580: 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 t-time)).
8590: 20 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ....(hash-table
85a0: 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c -set! smallest-l
85b0: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
85c0: 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 "smallest-time"
85d0: 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 20 20 last-update)).
85e0: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 73 6b (task
85f0: 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 s:run-id->mtpg-r
8600: 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 un-id dbh cached
8610: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 -info run-id are
8620: 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d a-info smallest-
8630: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
8640: 29 29 0a 09 09 20 20 23 66 29 29 29 29 29 29 29 ))... #f)))))))
8650: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 3a ..(define (task:
8660: 61 64 64 2d 72 75 6e 2d 74 61 67 20 64 62 68 20 add-run-tag dbh
8670: 72 75 6e 2d 69 64 20 74 61 67 29 20 0a 20 20 28 run-id tag) . (
8680: 6c 65 74 2a 20 28 28 74 61 67 2d 69 6e 66 6f 20 let* ((tag-info
8690: 28 70 67 64 62 3a 67 65 74 2d 74 61 67 2d 69 6e (pgdb:get-tag-in
86a0: 66 6f 2d 62 79 2d 6e 61 6d 65 20 64 62 68 20 74 fo-by-name dbh t
86b0: 61 67 29 29 29 0a 20 20 20 28 69 66 20 28 6e 6f ag))). (if (no
86c0: 74 20 74 61 67 2d 69 6e 66 6f 29 0a 20 20 20 20 t tag-info).
86d0: 20 28 62 65 67 69 6e 20 20 20 0a 20 20 20 20 20 (begin .
86e0: 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (if (handle-exce
86f0: 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 ptions.. exn..
8700: 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 (begin .
8710: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
8720: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
8730: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
8740: 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 ((condition-pr
8750: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
8760: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
8770: 78 6e 29 29 20 20 20 20 20 0a 09 20 20 20 23 66 xn)) .. #f
8780: 29 0a 09 20 20 20 28 70 67 64 62 3a 69 6e 73 65 ).. (pgdb:inse
8790: 72 74 2d 74 61 67 20 20 64 62 68 20 20 20 74 61 rt-tag dbh ta
87a0: 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 g)).
87b0: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
87c0: 20 74 61 67 2d 69 6e 66 6f 20 28 70 67 64 62 3a tag-info (pgdb:
87d0: 67 65 74 2d 74 61 67 2d 69 6e 66 6f 2d 62 79 2d get-tag-info-by-
87e0: 6e 61 6d 65 20 64 62 68 20 74 61 67 29 29 0a 09 name dbh tag))..
87f0: 09 20 20 23 66 29 29 29 0a 20 20 20 20 20 3b 3b . #f))). ;;
8800: 61 64 64 20 74 6f 20 61 72 65 61 5f 74 61 67 73 add to area_tags
8810: 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 . (handle-ex
8820: 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e ceptions.. exn
8830: 0a 09 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 .. (begin .
8840: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
8850: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
8860: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8870: 74 2a 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d t* ((condition-
8880: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
8890: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
88a0: 20 65 78 6e 29 29 20 20 20 20 20 0a 09 20 20 20 exn)) ..
88b0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 #f). (
88c0: 69 66 20 28 6e 6f 74 20 28 70 67 64 62 3a 69 73 if (not (pgdb:is
88d0: 2d 72 75 6e 2d 74 61 67 65 64 2d 77 69 74 68 2d -run-taged-with-
88e0: 61 2d 74 61 67 20 64 62 68 20 28 76 65 63 74 6f a-tag dbh (vecto
88f0: 72 2d 72 65 66 20 74 61 67 2d 69 6e 66 6f 20 30 r-ref tag-info 0
8900: 29 20 20 72 75 6e 2d 69 64 29 29 20 20 0a 09 20 ) run-id)) ..
8910: 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d 72 (pgdb:insert-r
8920: 75 6e 2d 74 61 67 20 20 64 62 68 20 20 20 28 76 un-tag dbh (v
8930: 65 63 74 6f 72 2d 72 65 66 20 74 61 67 2d 69 6e ector-ref tag-in
8940: 66 6f 20 30 29 20 20 72 75 6e 2d 69 64 29 29 29 fo 0) run-id)))
8950: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 ))...(define (ta
8960: 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 2d 73 74 sks:sync-test-st
8970: 65 70 73 20 64 62 68 20 63 61 63 68 65 64 2d 69 eps dbh cached-i
8980: 6e 66 6f 20 74 65 73 74 2d 73 74 65 70 2d 69 64 nfo test-step-id
8990: 73 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d s smallest-last-
89a0: 75 70 64 61 74 65 2d 74 69 6d 65 29 0a 20 3b 20 update-time). ;
89b0: 28 70 72 69 6e 74 20 22 53 79 6e 63 20 53 74 65 (print "Sync Ste
89c0: 70 73 20 22 20 74 65 73 74 2d 73 74 65 70 2d 69 ps " test-step-i
89d0: 64 73 20 29 0a 20 20 28 6c 65 74 20 28 28 74 65 ds ). (let ((te
89e0: 73 74 2d 68 74 20 28 68 61 73 68 2d 74 61 62 6c st-ht (hash-tabl
89f0: 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 6e 66 e-ref cached-inf
8a00: 6f 20 27 74 65 73 74 73 29 29 0a 20 20 20 20 20 o 'tests)).
8a10: 20 20 20 28 73 74 65 70 2d 68 74 20 28 68 61 73 (step-ht (has
8a20: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 h-table-ref cach
8a30: 65 64 2d 69 6e 66 6f 20 27 73 74 65 70 73 29 29 ed-info 'steps))
8a40: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
8a50: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
8a60: 73 74 2d 73 74 65 70 2d 69 64 29 0a 20 20 20 20 st-step-id).
8a70: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
8a80: 2d 73 74 65 70 2d 69 6e 66 6f 20 20 28 72 6d 74 -step-info (rmt
8a90: 3a 67 65 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d :get-steps-info-
8aa0: 62 79 2d 69 64 20 74 65 73 74 2d 73 74 65 70 2d by-id test-step-
8ab0: 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 id)).
8ac0: 20 20 20 20 28 73 74 65 70 2d 69 64 20 28 74 64 (step-id (td
8ad0: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 74 65 b:step-get-id te
8ae0: 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a 20 st-step-info)).
8af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
8b00: 65 73 74 2d 69 64 20 20 28 74 64 62 3a 73 74 65 est-id (tdb:ste
8b10: 70 2d 67 65 74 2d 74 65 73 74 5f 69 64 20 20 20 p-get-test_id
8b20: 20 74 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 test-step-info)
8b30: 29 20 20 20 0a 09 20 20 20 20 20 20 20 28 73 74 ) .. (st
8b40: 65 70 6e 61 6d 65 20 28 74 64 62 3a 73 74 65 70 epname (tdb:step
8b50: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 20 74 -get-stepname t
8b60: 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a est-step-info)).
8b70: 09 20 20 20 20 20 20 20 28 73 74 61 74 65 20 28 . (state (
8b80: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
8b90: 74 65 20 74 65 73 74 2d 73 74 65 70 2d 69 6e 66 te test-step-inf
8ba0: 6f 29 29 09 0a 09 20 20 20 20 20 20 20 28 73 74 o))... (st
8bb0: 61 74 75 73 20 28 74 64 62 3a 73 74 65 70 2d 67 atus (tdb:step-g
8bc0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d 73 et-status test-s
8bd0: 74 65 70 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 tep-info))...
8be0: 20 20 20 20 28 65 76 65 6e 74 5f 74 69 6d 65 20 (event_time
8bf0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
8c00: 65 6e 74 5f 74 69 6d 65 20 20 74 65 73 74 2d 73 ent_time test-s
8c10: 74 65 70 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 tep-info))...
8c20: 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 28 74 (comment (t
8c30: 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d db:step-get-comm
8c40: 65 6e 74 20 74 65 73 74 2d 73 74 65 70 2d 69 6e ent test-step-in
8c50: 66 6f 29 29 09 0a 09 20 20 20 20 20 20 20 28 6c fo))... (l
8c60: 6f 67 66 69 6c 65 20 28 74 64 62 3a 73 74 65 70 ogfile (tdb:step
8c70: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 74 65 73 -get-logfile tes
8c80: 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 09 0a 20 t-step-info))..
8c90: 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d 75 70 (last-up
8ca0: 64 61 74 65 20 28 74 64 62 3a 73 74 65 70 2d 67 date (tdb:step-g
8cb0: 65 74 2d 6c 61 73 74 5f 75 70 64 61 74 65 20 74 et-last_update t
8cc0: 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a est-step-info)).
8cd0: 09 20 20 20 20 20 20 20 28 70 67 64 62 2d 74 65 . (pgdb-te
8ce0: 73 74 2d 69 64 20 20 28 68 61 73 68 2d 74 61 62 st-id (hash-tab
8cf0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
8d00: 65 73 74 2d 68 74 20 74 65 73 74 2d 69 64 20 23 est-ht test-id #
8d10: 66 29 29 0a 09 09 09 09 20 28 73 6d 61 6c 6c 65 f))..... (smalle
8d20: 73 74 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 61 st-time (hash-ta
8d30: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8d40: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
8d50: 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c date-time "small
8d60: 65 73 74 2d 74 69 6d 65 22 20 23 66 29 29 0a 20 est-time" #f)).
8d70: 20 20 20 20 20 20 20 20 28 70 67 64 62 2d 73 74 (pgdb-st
8d80: 65 70 2d 69 64 20 28 69 66 20 70 67 64 62 2d 74 ep-id (if pgdb-t
8d90: 65 73 74 2d 69 64 20 0a 20 20 20 20 20 20 20 20 est-id .
8da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8db0: 20 28 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d (pgdb:get-test-
8dc0: 73 74 65 70 2d 69 64 20 64 62 68 20 70 67 64 62 step-id dbh pgdb
8dd0: 2d 74 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d -test-id stepnam
8de0: 65 20 73 74 61 74 65 29 0a 20 20 20 20 20 20 20 e state).
8df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e00: 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 #f))). (if
8e10: 20 73 74 65 70 2d 69 64 0a 20 20 20 20 20 20 28 step-id. (
8e20: 62 65 67 69 6e 20 20 0a 20 20 20 20 20 20 20 20 begin .
8e30: 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 64 (if pgdb-test-id
8e40: 0a 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 . (beg
8e50: 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 in .
8e60: 20 20 20 20 28 69 66 20 20 70 67 64 62 2d 73 74 (if pgdb-st
8e70: 65 70 2d 69 64 0a 20 20 20 20 20 20 20 20 20 20 ep-id.
8e80: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
8e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ea0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8eb0: 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 -info 1 *default
8ec0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 70 64 -log-port* "Upd
8ed0: 61 74 69 6e 67 20 65 78 69 73 74 69 6e 67 20 74 ating existing t
8ee0: 65 73 74 2d 73 74 65 70 20 77 69 74 68 20 74 65 est-step with te
8ef0: 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 64 st-id: " test-id
8f00: 20 22 20 61 6e 64 20 73 74 65 70 2d 69 64 20 22 " and step-id "
8f10: 20 73 74 65 70 2d 69 64 20 22 20 70 67 64 62 20 step-id " pgdb
8f20: 74 65 73 74 20 69 64 3a 20 22 20 70 67 64 62 2d test id: " pgdb-
8f30: 74 65 73 74 2d 69 64 20 22 20 70 67 64 62 20 73 test-id " pgdb s
8f40: 74 65 70 20 69 64 20 22 20 70 67 64 62 2d 73 74 tep id " pgdb-st
8f50: 65 70 2d 69 64 20 29 0a 09 09 09 09 09 09 09 09 ep-id ).........
8f60: 09 09 28 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c ..(let* ((pgdb-l
8f70: 61 73 74 2d 75 70 64 61 74 65 20 28 70 67 64 62 ast-update (pgdb
8f80: 3a 67 65 74 2d 74 65 73 74 2d 73 74 65 70 2d 6c :get-test-step-l
8f90: 61 73 74 2d 75 70 64 61 74 65 20 64 62 68 20 70 ast-update dbh p
8fa0: 67 64 62 2d 73 74 65 70 2d 69 64 29 29 29 0a 20 gdb-step-id))).
8fb0: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
8fc0: 20 20 28 3e 20 6c 61 73 74 2d 75 70 64 61 74 65 (> last-update
8fd0: 20 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 pgdb-last-updat
8fe0: 65 29 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c e) (or (not smal
8ff0: 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 lest-time) (< la
9000: 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 st-update smalle
9010: 73 74 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 st-time))).
9020: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
9030: 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 et! smallest-las
9040: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 t-update-time "s
9050: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 mallest-time" la
9060: 73 74 2d 75 70 64 61 74 65 29 29 29 20 0a 20 20 st-update))) .
9070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9080: 20 20 28 70 67 64 62 3a 75 70 64 61 74 65 2d 74 (pgdb:update-t
9090: 65 73 74 2d 73 74 65 70 20 64 62 68 20 70 67 64 est-step dbh pgd
90a0: 62 2d 73 74 65 70 2d 69 64 20 70 67 64 62 2d 74 b-step-id pgdb-t
90b0: 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 est-id stepname
90c0: 73 74 61 74 65 20 73 74 61 74 75 73 20 65 76 65 state status eve
90d0: 6e 74 5f 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 nt_time comment
90e0: 6c 6f 67 66 69 6c 65 20 6c 61 73 74 2d 75 70 64 logfile last-upd
90f0: 61 74 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ate)).
9100: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
9110: 0a 20 09 09 20 20 20 20 20 20 28 64 65 62 75 67 . .. (debug
9120: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
9130: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
9140: 20 20 22 49 6e 73 65 72 74 69 6e 67 20 74 65 73 "Inserting tes
9150: 74 2d 73 74 65 70 20 77 69 74 68 20 74 65 73 74 t-step with test
9160: 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 -id: " test-id "
9170: 20 61 6e 64 20 73 74 65 70 2d 69 64 20 22 20 73 and step-id " s
9180: 74 65 70 2d 69 64 20 20 22 20 70 67 64 62 20 74 tep-id " pgdb t
9190: 65 73 74 20 69 64 3a 20 22 20 70 67 64 62 2d 74 est id: " pgdb-t
91a0: 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 20 20 est-id).
91b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
91c0: 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 (or (not smalle
91d0: 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 st-time) (< last
91e0: 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 -update smallest
91f0: 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -time)).
9200: 09 09 09 09 20 20 20 20 20 20 28 68 61 73 68 2d .... (hash-
9210: 74 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c table-set! small
9220: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
9230: 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 time "smallest-t
9240: 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 74 65 ime" last-update
9250: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
9260: 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a 69 (pgdb:i
9270: 6e 73 65 72 74 2d 74 65 73 74 2d 73 74 65 70 20 nsert-test-step
9280: 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 dbh pgdb-test-id
9290: 20 73 74 65 70 6e 61 6d 65 20 73 74 61 74 65 20 stepname state
92a0: 73 74 61 74 75 73 20 65 76 65 6e 74 5f 74 69 6d status event_tim
92b0: 65 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c e comment logfil
92c0: 65 20 6c 61 73 74 2d 75 70 64 61 74 65 20 29 0a e last-update ).
92d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92e0: 20 20 20 20 20 20 28 73 65 74 21 20 70 67 64 62 (set! pgdb
92f0: 2d 73 74 65 70 2d 69 64 20 20 28 70 67 64 62 3a -step-id (pgdb:
9300: 67 65 74 2d 74 65 73 74 2d 73 74 65 70 2d 69 64 get-test-step-id
9310: 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 dbh pgdb-test-i
9320: 64 20 73 74 65 70 6e 61 6d 65 20 73 74 61 74 65 d stepname state
9330: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
9340: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
9350: 2d 73 65 74 21 20 73 74 65 70 2d 68 74 20 73 74 -set! step-ht st
9360: 65 70 2d 69 64 20 70 67 64 62 2d 73 74 65 70 2d ep-id pgdb-step-
9370: 69 64 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 id )).
9380: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
9390: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
93a0: 67 2d 70 6f 72 74 2a 20 20 22 45 72 72 6f 72 3a g-port* "Error:
93b0: 20 54 65 73 74 20 6e 6f 74 20 63 61 73 68 65 64 Test not cashed
93c0: 22 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 "))). (debu
93d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
93e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
93f0: 2a 20 20 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 * "Error: Could
9400: 20 6e 6f 74 20 67 65 74 20 74 65 73 74 20 73 74 not get test st
9410: 65 70 20 69 6e 66 6f 20 66 6f 72 20 73 74 65 70 ep info for step
9420: 20 69 64 20 22 20 74 65 73 74 2d 73 74 65 70 2d id " test-step-
9430: 69 64 20 29 29 29 29 09 3b 3b 20 74 68 69 73 20 id )))).;; this
9440: 69 73 20 61 20 77 69 65 72 64 20 73 65 6e 61 72 is a wierd senar
9450: 69 6f 20 6e 65 65 64 20 74 6f 20 64 65 62 75 67 io need to debug
9460: 20 20 20 20 20 20 09 0a 20 20 20 74 65 73 74 2d .. test-
9470: 73 74 65 70 2d 69 64 73 29 29 29 0a 0a 28 64 65 step-ids)))..(de
9480: 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 fine (tasks:sync
9490: 2d 74 65 73 74 2d 67 65 6e 2d 64 61 74 61 20 64 -test-gen-data d
94a0: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 bh cached-info t
94b0: 65 73 74 2d 64 61 74 61 2d 69 64 73 20 73 6d 61 est-data-ids sma
94c0: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
94d0: 65 2d 74 69 6d 65 29 0a 20 20 28 6c 65 74 20 28 e-time). (let (
94e0: 28 74 65 73 74 2d 68 74 20 28 68 61 73 68 2d 74 (test-ht (hash-t
94f0: 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d able-ref cached-
9500: 69 6e 66 6f 20 27 74 65 73 74 73 29 29 0a 20 20 info 'tests)).
9510: 20 20 20 20 20 20 28 64 61 74 61 2d 68 74 20 28 (data-ht (
9520: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 hash-table-ref c
9530: 61 63 68 65 64 2d 69 6e 66 6f 20 27 64 61 74 61 ached-info 'data
9540: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
9550: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
9560: 74 65 73 74 2d 64 61 74 61 2d 69 64 29 0a 20 20 test-data-id).
9570: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
9580: 73 74 2d 64 61 74 61 2d 69 6e 66 6f 20 20 28 72 st-data-info (r
9590: 6d 74 3a 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f mt:get-data-info
95a0: 2d 62 79 2d 69 64 20 74 65 73 74 2d 64 61 74 61 -by-id test-data
95b0: 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 -id)).
95c0: 20 20 20 20 20 28 64 61 74 61 2d 69 64 20 28 64 (data-id (d
95d0: 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d b:test-data-get-
95e0: 69 64 20 20 74 65 73 74 2d 64 61 74 61 2d 69 6e id test-data-in
95f0: 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 fo)).
9600: 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 28 64 (test-id (d
9610: 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d b:test-data-get-
9620: 74 65 73 74 5f 69 64 20 20 20 74 65 73 74 2d 64 test_id test-d
9630: 61 74 61 2d 69 6e 66 6f 29 29 20 20 20 0a 09 20 ata-info)) ..
9640: 20 20 20 20 20 20 28 63 61 74 65 67 6f 72 79 20 (category
9650: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
9660: 65 74 2d 63 61 74 65 67 6f 72 79 20 20 74 65 73 et-category tes
9670: 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a 09 20 t-data-info))..
9680: 20 20 20 20 20 20 28 76 61 72 69 61 62 6c 65 20 (variable
9690: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
96a0: 65 74 2d 76 61 72 69 61 62 6c 65 20 74 65 73 74 et-variable test
96b0: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 -data-info))...
96c0: 20 20 20 20 20 20 28 76 61 6c 75 65 20 28 64 62 (value (db
96d0: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 76 :test-data-get-v
96e0: 61 6c 75 65 20 20 74 65 73 74 2d 64 61 74 61 2d alue test-data-
96f0: 69 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 20 20 info))..
9700: 20 20 20 20 20 20 20 28 65 78 70 65 63 74 65 64 (expected
9710: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
9720: 65 74 2d 65 78 70 65 63 74 65 64 20 20 74 65 73 et-expected tes
9730: 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a 20 20 t-data-info)).
9740: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 6f (to
9750: 6c 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d l (db:test-data-
9760: 67 65 74 2d 74 6f 6c 20 20 74 65 73 74 2d 64 61 get-tol test-da
9770: 74 61 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 ta-info)).
9780: 20 20 20 20 20 20 20 20 20 28 75 6e 69 74 73 20 (units
9790: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
97a0: 74 2d 75 6e 69 74 73 20 20 74 65 73 74 2d 64 61 t-units test-da
97b0: 74 61 2d 69 6e 66 6f 29 29 20 20 20 20 20 0a 09 ta-info)) ..
97c0: 20 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 (comment
97d0: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
97e0: 65 74 2d 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d et-comment test-
97f0: 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 20 20 20 data-info))..
9800: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 61 (sta
9810: 74 75 73 20 28 64 62 3a 74 65 73 74 2d 64 61 74 tus (db:test-dat
9820: 61 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 a-get-status tes
9830: 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 t-data-info))...
9840: 20 20 20 20 20 20 20 28 74 79 70 65 20 28 64 62 (type (db
9850: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 :test-data-get-t
9860: 79 70 65 20 74 65 73 74 2d 64 61 74 61 2d 69 6e ype test-data-in
9870: 66 6f 29 29 0a 09 09 09 09 20 28 6c 61 73 74 2d fo))..... (last-
9880: 75 70 64 61 74 65 20 28 64 62 3a 74 65 73 74 2d update (db:test-
9890: 64 61 74 61 2d 67 65 74 2d 6c 61 73 74 5f 75 70 data-get-last_up
98a0: 64 61 74 65 20 74 65 73 74 2d 64 61 74 61 2d 69 date test-data-i
98b0: 6e 66 6f 29 29 0a 09 09 09 09 20 28 73 6d 61 6c nfo))..... (smal
98c0: 6c 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 2d lest-time (hash-
98d0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
98e0: 74 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d t smallest-last-
98f0: 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 update-time "sma
9900: 6c 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 29 llest-time" #f))
9910: 0a 20 20 20 09 0a 09 20 20 20 20 20 20 20 28 70 . ... (p
9920: 67 64 62 2d 74 65 73 74 2d 69 64 20 20 28 68 61 gdb-test-id (ha
9930: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
9940: 61 75 6c 74 20 74 65 73 74 2d 68 74 20 74 65 73 ault test-ht tes
9950: 74 2d 69 64 20 23 66 29 29 0a 20 20 20 20 20 20 t-id #f)).
9960: 20 20 20 20 20 20 20 20 20 28 70 67 64 62 2d 64 (pgdb-d
9970: 61 74 61 2d 69 64 20 28 69 66 20 70 67 64 62 2d ata-id (if pgdb-
9980: 74 65 73 74 2d 69 64 20 0a 20 20 20 20 20 20 20 test-id .
9990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99a0: 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a (pgdb:
99b0: 67 65 74 2d 74 65 73 74 2d 64 61 74 61 2d 69 64 get-test-data-id
99c0: 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 dbh pgdb-test-i
99d0: 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 69 61 d category varia
99e0: 62 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ble).
99f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a00: 20 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 #f))).
9a10: 20 28 69 66 20 64 61 74 61 2d 69 64 0a 20 20 20 (if data-id.
9a20: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
9a30: 20 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d (if pgdb-test-
9a40: 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 62 id. (b
9a50: 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 egin .
9a60: 20 20 20 20 20 20 28 69 66 20 20 70 67 64 62 2d (if pgdb-
9a70: 64 61 74 61 2d 69 64 0a 20 20 20 20 20 20 20 20 data-id.
9a80: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
9a90: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
9aa0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9ab0: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
9ac0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 lt-log-port* "U
9ad0: 70 64 61 74 69 6e 67 20 65 78 69 73 74 69 6e 67 pdating existing
9ae0: 20 74 65 73 74 2d 64 61 74 61 20 77 69 74 68 20 test-data with
9af0: 74 65 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d test-id: " test-
9b00: 69 64 20 22 20 61 6e 64 20 20 64 61 74 61 2d 69 id " and data-i
9b10: 64 20 22 20 64 61 74 61 2d 69 64 20 22 20 70 67 d " data-id " pg
9b20: 64 62 20 74 65 73 74 20 69 64 3a 20 22 20 70 67 db test id: " pg
9b30: 64 62 2d 74 65 73 74 2d 69 64 20 22 20 70 67 64 db-test-id " pgd
9b40: 62 20 64 61 74 61 20 69 64 20 22 20 70 67 64 62 b data id " pgdb
9b50: 2d 64 61 74 61 2d 69 64 29 0a 20 20 20 20 20 20 -data-id).
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
9b70: 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d et* ((pgdb-last-
9b80: 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 update (pgdb:get
9b90: 2d 74 65 73 74 2d 64 61 74 61 2d 6c 61 73 74 2d -test-data-last-
9ba0: 75 70 64 61 74 65 20 64 62 68 20 70 67 64 62 2d update dbh pgdb-
9bb0: 64 61 74 61 2d 69 64 29 29 29 0a 20 20 20 20 20 data-id))).
9bc0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 20 28 3e (if (and (>
9bd0: 20 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 67 last-update pg
9be0: 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 db-last-update)
9bf0: 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 (or (not smalles
9c00: 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d t-time) (< last-
9c10: 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d update smallest-
9c20: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 time))).
9c30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
9c40: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
9c50: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
9c60: 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d lest-time" last-
9c70: 75 70 64 61 74 65 29 29 29 20 0a 20 20 20 20 20 update))) .
9c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9c90: 70 67 64 62 3a 75 70 64 61 74 65 2d 74 65 73 74 pgdb:update-test
9ca0: 2d 64 61 74 61 20 64 62 68 20 70 67 64 62 2d 64 -data dbh pgdb-d
9cb0: 61 74 61 2d 69 64 20 70 67 64 62 2d 74 65 73 74 ata-id pgdb-test
9cc0: 2d 69 64 20 20 63 61 74 65 67 6f 72 79 20 76 61 -id category va
9cd0: 72 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 riable value exp
9ce0: 65 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 ected tol units
9cf0: 63 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 comment status t
9d00: 79 70 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 ype last-update)
9d10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9d20: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 09 09 (begin. ..
9d30: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9d40: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
9d50: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 49 lt-log-port* "I
9d60: 6e 73 65 72 74 69 6e 67 20 74 65 73 74 2d 64 61 nserting test-da
9d70: 74 61 20 77 69 74 68 20 74 65 73 74 2d 69 64 3a ta with test-id:
9d80: 20 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e 64 " test-id " and
9d90: 20 64 61 74 61 2d 69 64 20 22 20 64 61 74 61 2d data-id " data-
9da0: 69 64 20 22 20 70 67 64 62 20 74 65 73 74 20 69 id " pgdb test i
9db0: 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d 69 d: " pgdb-test-i
9dc0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d).
9dd0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 68 (if (h
9de0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
9df0: 0a 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 20 ... exn...
9e00: 20 20 20 20 20 28 62 65 67 69 6e 20 28 70 72 69 (begin (pri
9e10: 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 nt-call-chain).
9e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
9e40: 69 6e 74 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d int ((condition-
9e50: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
9e60: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
9e70: 20 65 78 6e 29 29 20 20 20 20 20 0a 09 09 09 23 exn)) ....#
9e80: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
9e90: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 (pg
9eb0: 64 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 db:insert-test-d
9ec0: 61 74 61 20 64 62 68 20 70 67 64 62 2d 74 65 73 ata dbh pgdb-tes
9ed0: 74 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 t-id category va
9ee0: 72 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 riable value exp
9ef0: 65 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 ected tol units
9f00: 63 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 comment status t
9f10: 79 70 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 ype last-update)
9f20: 29 0a 09 09 20 20 20 20 20 20 20 3b 28 74 61 73 )... ;(tas
9f30: 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d ks:run-id->mtpg-
9f40: 72 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 run-id dbh cache
9f50: 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 d-info run-id ar
9f60: 65 61 2d 69 6e 66 6f 29 0a 20 20 20 20 20 20 20 ea-info).
9f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9f80: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
9f90: 20 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 67 ;(pg
9fa0: 64 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 db:insert-test-d
9fb0: 61 74 61 20 64 62 68 20 70 67 64 62 2d 74 65 73 ata dbh pgdb-tes
9fc0: 74 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 t-id category va
9fd0: 72 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 riable value exp
9fe0: 65 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 ected tol units
9ff0: 63 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 comment status t
a000: 79 70 65 20 29 0a 09 09 09 09 09 09 09 09 09 09 ype )...........
a010: 09 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d .(if (or (not sm
a020: 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 allest-time) (<
a030: 6c 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c last-update smal
a040: 6c 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 lest-time)).
a050: 20 20 20 20 09 09 09 09 09 09 09 09 28 68 61 73 ........(has
a060: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 h-table-set! sma
a070: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
a080: 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 e-time "smallest
a090: 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 -time" last-upda
a0a0: 74 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 te)).
a0b0: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
a0c0: 20 70 67 64 62 2d 64 61 74 61 2d 69 64 20 20 28 pgdb-data-id (
a0d0: 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 64 61 pgdb:get-test-da
a0e0: 74 61 2d 69 64 20 64 62 68 20 70 67 64 62 2d 74 ta-id dbh pgdb-t
a0f0: 65 73 74 2d 69 64 20 20 63 61 74 65 67 6f 72 79 est-id category
a100: 20 76 61 72 69 61 62 6c 65 29 29 29 0a 09 09 20 variable)))...
a110: 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 #f))).
a120: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
a130: 62 6c 65 2d 73 65 74 21 20 64 61 74 61 2d 68 74 ble-set! data-ht
a140: 20 64 61 74 61 2d 69 64 20 70 67 64 62 2d 64 61 data-id pgdb-da
a150: 74 61 2d 69 64 20 29 29 0a 20 20 20 20 20 20 20 ta-id )).
a160: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
a170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
a180: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
a190: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
a1a0: 6f 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 ort* "Error: Te
a1b0: 73 74 20 6e 6f 74 20 69 6e 20 70 67 64 62 22 29 st not in pgdb")
a1c0: 29 29 29 0a 0a 20 20 20 20 20 20 28 64 65 62 75 ))).. (debu
a1d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
a1e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
a1f0: 2a 20 20 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 * "Error: Could
a200: 20 6e 6f 74 20 67 65 74 20 74 65 73 74 20 64 61 not get test da
a210: 74 61 20 69 6e 66 6f 20 66 6f 72 20 64 61 74 61 ta info for data
a220: 20 69 64 20 22 20 74 65 73 74 2d 64 61 74 61 2d id " test-data-
a230: 69 64 20 29 29 29 29 09 3b 3b 20 74 68 69 73 20 id )))).;; this
a240: 69 73 20 61 20 77 69 65 72 64 20 73 65 6e 61 72 is a wierd senar
a250: 69 6f 20 6e 65 65 64 20 74 6f 20 64 65 62 75 67 io need to debug
a260: 20 20 20 20 20 20 09 0a 20 20 20 74 65 73 74 2d .. test-
a270: 64 61 74 61 2d 69 64 73 29 29 29 0a 0a 0a 0a 28 data-ids)))....(
a280: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 define (tasks:sy
a290: 6e 63 2d 74 65 73 74 73 2d 64 61 74 61 20 64 62 nc-tests-data db
a2a0: 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 h cached-info te
a2b0: 73 74 2d 69 64 73 20 61 72 65 61 2d 69 6e 66 6f st-ids area-info
a2c0: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
a2d0: 70 64 61 74 65 2d 74 69 6d 65 29 0a 20 20 28 6c pdate-time). (l
a2e0: 65 74 20 28 28 74 65 73 74 2d 68 74 20 28 68 61 et ((test-ht (ha
a2f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 63 sh-table-ref cac
a300: 68 65 64 2d 69 6e 66 6f 20 27 74 65 73 74 73 29 hed-info 'tests)
a310: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
a320: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 . (lambda (t
a330: 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 3b 20 est-id). ;
a340: 28 70 72 69 6e 74 20 74 65 73 74 2d 69 64 29 0a (print test-id).
a350: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
a360: 65 73 74 2d 69 6e 66 6f 20 20 20 20 28 72 6d 74 est-info (rmt
a370: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
a380: 79 2d 69 64 20 23 66 20 74 65 73 74 2d 69 64 29 y-id #f test-id)
a390: 29 0a 09 20 20 20 20 20 20 28 72 75 6e 2d 69 64 ).. (run-id
a3a0: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
a3b0: 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 20 74 65 get-run_id te
a3c0: 73 74 2d 69 6e 66 6f 29 29 20 3b 3b 20 6c 6f 6f st-info)) ;; loo
a3d0: 6b 20 74 68 65 73 65 20 75 70 20 69 6e 20 64 62 k these up in db
a3e0: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 0a 09 20 20 _records.scm..
a3f0: 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 (test-id
a400: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
a410: 64 20 20 20 20 20 20 20 20 74 65 73 74 2d 69 6e d test-in
a420: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 fo)).. (tes
a430: 74 2d 6e 61 6d 65 20 20 20 20 28 64 62 3a 74 65 t-name (db:te
a440: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
a450: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
a460: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 (item-path
a470: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
a480: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 69 6e tem-path test-in
a490: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 73 74 61 fo)).. (sta
a4a0: 74 65 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 te (db:te
a4b0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 st-get-state
a4c0: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
a4d0: 20 20 20 20 28 73 74 61 74 75 73 20 20 20 20 20 (status
a4e0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
a4f0: 74 61 74 75 73 20 20 20 20 74 65 73 74 2d 69 6e tatus test-in
a500: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 68 6f 73 fo)).. (hos
a510: 74 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 t (db:te
a520: 73 74 2d 67 65 74 2d 68 6f 73 74 20 20 20 20 20 st-get-host
a530: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 test-info)).
a540: 20 20 20 20 20 28 70 69 64 20 20 20 20 20 20 20 (pid
a550: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
a560: 70 72 6f 63 65 73 73 5f 69 64 20 74 65 73 74 2d process_id test-
a570: 69 6e 66 6f 29 29 20 0a 09 20 20 20 20 20 20 28 info)) .. (
a580: 63 70 75 6c 6f 61 64 20 20 20 20 20 20 28 64 62 cpuload (db
a590: 3a 74 65 73 74 2d 67 65 74 2d 63 70 75 6c 6f 61 :test-get-cpuloa
a5a0: 64 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a d test-info)).
a5b0: 09 20 20 20 20 20 20 28 64 69 73 6b 66 72 65 65 . (diskfree
a5c0: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
a5d0: 74 2d 64 69 73 6b 66 72 65 65 20 20 74 65 73 74 t-diskfree test
a5e0: 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 -info)).. (
a5f0: 75 6e 61 6d 65 20 20 20 20 20 20 20 20 28 64 62 uname (db
a600: 3a 74 65 73 74 2d 67 65 74 2d 75 6e 61 6d 65 20 :test-get-uname
a610: 20 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a test-info)).
a620: 09 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 20 . (run-dir
a630: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
a640: 74 2d 72 75 6e 64 69 72 20 20 20 20 74 65 73 74 t-rundir test
a650: 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 -info)).. (
a660: 6c 6f 67 2d 66 69 6c 65 20 20 20 20 20 28 64 62 log-file (db
a670: 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 6c 5f :test-get-final_
a680: 6c 6f 67 66 20 74 65 73 74 2d 69 6e 66 6f 29 29 logf test-info))
a690: 0a 09 20 20 20 20 20 20 28 72 75 6e 2d 64 75 72 .. (run-dur
a6a0: 61 74 69 6f 6e 20 28 64 62 3a 74 65 73 74 2d 67 ation (db:test-g
a6b0: 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 et-run_duration
a6c0: 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 test-info))..
a6d0: 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 (comment
a6e0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f (db:test-get-co
a6f0: 6d 6d 65 6e 74 20 20 20 74 65 73 74 2d 69 6e 66 mment test-inf
a700: 6f 29 29 0a 09 20 20 20 20 20 20 28 65 76 65 6e o)).. (even
a710: 74 2d 74 69 6d 65 20 20 20 28 64 62 3a 74 65 73 t-time (db:tes
a720: 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 t-get-event_time
a730: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
a740: 20 20 20 20 28 61 72 63 68 69 76 65 64 20 20 20 (archived
a750: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 61 (db:test-get-a
a760: 72 63 68 69 76 65 64 20 20 74 65 73 74 2d 69 6e rchived test-in
a770: 66 6f 29 29 0a 20 20 20 20 20 20 20 20 28 6c 61 fo)). (la
a780: 73 74 2d 75 70 64 61 74 65 20 20 28 64 62 3a 74 st-update (db:t
a790: 65 73 74 2d 67 65 74 2d 6c 61 73 74 5f 75 70 64 est-get-last_upd
a7a0: 61 74 65 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 ate test-info))
a7b0: 0a 09 20 20 20 20 20 20 28 70 67 64 62 2d 72 75 .. (pgdb-ru
a7c0: 6e 2d 69 64 20 20 28 74 61 73 6b 73 3a 72 75 6e n-id (tasks:run
a7d0: 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 -id->mtpg-run-id
a7e0: 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f dbh cached-info
a7f0: 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 69 6e 66 run-id area-inf
a800: 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d o smallest-last-
a810: 75 70 64 61 74 65 2d 74 69 6d 65 29 29 0a 20 20 update-time)).
a820: 20 20 20 20 20 20 28 73 6d 61 6c 6c 65 73 74 2d (smallest-
a830: 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 time (hash-table
a840: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 -ref/default sma
a850: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
a860: 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 e-time "smallest
a870: 2d 74 69 6d 65 22 20 23 66 29 29 20 20 20 20 20 -time" #f))
a880: 20 20 0a 09 20 20 20 20 20 20 28 70 67 64 62 2d .. (pgdb-
a890: 74 65 73 74 2d 69 64 20 28 69 66 20 70 67 64 62 test-id (if pgdb
a8a0: 2d 72 75 6e 2d 69 64 20 0a 09 09 09 09 28 62 65 -run-id .....(be
a8b0: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
a8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a8d0: 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 70 67 ;(print pg
a8e0: 64 62 2d 72 75 6e 2d 69 64 29 20 20 20 20 0a 20 db-run-id) .
a8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a910: 28 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (pgdb:get-test-i
a920: 64 20 64 62 68 20 70 67 64 62 2d 72 75 6e 2d 69 d dbh pgdb-run-i
a930: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
a940: 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
a950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a960: 20 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 09 #f)))..
a970: 20 3b 3b 20 22 69 64 22 20 20 20 20 20 20 20 20 ;; "id"
a980: 20 20 20 22 72 75 6e 5f 69 64 22 20 20 20 20 20 "run_id"
a990: 20 20 20 22 74 65 73 74 6e 61 6d 65 22 20 20 22 "testname" "
a9a0: 73 74 61 74 65 22 20 20 20 20 20 20 22 73 74 61 state" "sta
a9b0: 74 75 73 22 20 20 20 20 20 20 22 65 76 65 6e 74 tus" "event
a9c0: 5f 74 69 6d 65 22 0a 09 20 3b 3b 20 22 68 6f 73 _time".. ;; "hos
a9d0: 74 22 20 20 20 20 20 20 20 20 20 22 63 70 75 6c t" "cpul
a9e0: 6f 61 64 22 20 20 20 20 20 20 20 22 64 69 73 6b oad" "disk
a9f0: 66 72 65 65 22 20 20 22 75 6e 61 6d 65 22 20 20 free" "uname"
aa00: 20 20 20 20 22 72 75 6e 64 69 72 22 20 20 20 20 "rundir"
aa10: 20 20 22 69 74 65 6d 5f 70 61 74 68 22 0a 09 20 "item_path"..
aa20: 3b 3b 20 22 72 75 6e 5f 64 75 72 61 74 69 6f 6e ;; "run_duration
aa30: 22 20 22 66 69 6e 61 6c 5f 6c 6f 67 66 22 20 20 " "final_logf"
aa40: 20 20 22 63 6f 6d 6d 65 6e 74 22 20 20 20 22 73 "comment" "s
aa50: 68 6f 72 74 64 69 72 22 20 20 20 22 61 74 74 65 hortdir" "atte
aa60: 6d 70 74 6e 75 6d 22 20 20 22 61 72 63 68 69 76 mptnum" "archiv
aa70: 65 64 22 0a 20 20 20 20 20 20 20 20 20 28 69 66 ed". (if
aa80: 20 70 67 64 62 2d 72 75 6e 2d 69 64 0a 20 20 20 pgdb-run-id.
aa90: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
aaa0: 20 20 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 (if pgdb-test
aab0: 2d 69 64 20 3b 3b 20 68 61 76 65 20 61 20 72 65 -id ;; have a re
aac0: 63 6f 72 64 0a 09 20 20 20 20 20 28 62 65 67 69 cord.. (begi
aad0: 6e 20 3b 3b 20 6c 65 74 20 28 28 6b 65 79 2d 6e n ;; let ((key-n
aae0: 61 6d 65 20 28 63 6f 6e 63 20 72 75 6e 2d 69 64 ame (conc run-id
aaf0: 20 22 2f 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 "/" test-name "
ab00: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a /" item-path))).
ab10: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
ab20: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
ab30: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
ab40: 22 55 70 64 61 74 69 6e 67 20 65 78 69 73 74 69 "Updating existi
ab50: 6e 67 20 74 65 73 74 20 77 69 74 68 20 72 75 6e ng test with run
ab60: 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 20 22 20 -id: " run-id "
ab70: 61 6e 64 20 74 65 73 74 2d 69 64 3a 20 22 20 74 and test-id: " t
ab80: 65 73 74 2d 69 64 20 22 20 70 67 64 62 20 72 75 est-id " pgdb ru
ab90: 6e 20 69 64 3a 20 22 20 70 67 64 62 2d 72 75 6e n id: " pgdb-run
aba0: 2d 69 64 20 22 20 20 70 67 64 62 2d 74 65 73 74 -id " pgdb-test
abb0: 2d 69 64 20 22 20 20 70 67 64 62 2d 74 65 73 74 -id " pgdb-test
abc0: 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 28 6c -id). (l
abd0: 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d et* ((pgdb-last-
abe0: 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 update (pgdb:get
abf0: 2d 74 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 -test-last-updat
ac00: 65 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d e dbh pgdb-test-
ac10: 69 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 id))). (
ac20: 69 66 20 28 61 6e 64 20 20 28 3e 20 20 6c 61 73 if (and (> las
ac30: 74 2d 75 70 64 61 74 65 20 70 67 64 62 2d 6c 61 t-update pgdb-la
ac40: 73 74 2d 75 70 64 61 74 65 29 20 28 6f 72 20 28 st-update) (or (
ac50: 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d not smallest-tim
ac60: 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 74 e) (< last-updat
ac70: 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 e smallest-time)
ac80: 29 29 20 3b 3b 69 66 20 6c 61 73 74 2d 75 70 64 )) ;;if last-upd
ac90: 61 74 65 20 69 73 20 73 61 6d 65 20 61 73 20 70 ate is same as p
aca0: 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 gdb-last-update
acb0: 74 68 65 6e 20 69 74 20 69 73 20 73 61 66 65 20 then it is safe
acc0: 74 6f 20 61 73 73 75 6d 65 20 74 68 65 20 72 65 to assume the re
acd0: 63 6f 72 64 73 20 61 72 65 20 69 64 65 6e 74 69 cords are identi
ace0: 63 61 6c 20 61 6e 64 20 77 65 20 63 61 6e 20 75 cal and we can u
acf0: 73 65 20 61 20 6c 61 72 67 65 72 20 6c 61 73 74 se a larger last
ad00: 20 75 70 64 61 74 65 20 74 69 6d 65 2e 0a 20 20 update time..
ad10: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
ad20: 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d e-set! smallest-
ad30: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
ad40: 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 "smallest-time"
ad50: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 20 last-update)))
ad60: 0a 09 20 20 20 20 20 20 20 28 70 67 64 62 3a 75 .. (pgdb:u
ad70: 70 64 61 74 65 2d 74 65 73 74 20 64 62 68 20 70 pdate-test dbh p
ad80: 67 64 62 2d 74 65 73 74 2d 69 64 20 70 67 64 62 gdb-test-id pgdb
ad90: 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d -run-id test-nam
ada0: 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 e item-path stat
adb0: 65 20 73 74 61 74 75 73 20 68 6f 73 74 20 63 70 e status host cp
adc0: 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 75 uload diskfree u
add0: 6e 61 6d 65 20 72 75 6e 2d 64 69 72 20 6c 6f 67 name run-dir log
ade0: 2d 66 69 6c 65 20 72 75 6e 2d 64 75 72 61 74 69 -file run-durati
adf0: 6f 6e 20 63 6f 6d 6d 65 6e 74 20 65 76 65 6e 74 on comment event
ae00: 2d 74 69 6d 65 20 61 72 63 68 69 76 65 64 20 6c -time archived l
ae10: 61 73 74 2d 75 70 64 61 74 65 20 70 69 64 29 29 ast-update pid))
ae20: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 .. (begin .
ae30: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
ae40: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
ae50: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ae60: 20 20 22 49 6e 73 65 72 74 69 6e 67 20 74 65 73 "Inserting tes
ae70: 74 20 77 69 74 68 20 72 75 6e 2d 69 64 3a 20 22 t with run-id: "
ae80: 20 72 75 6e 2d 69 64 20 22 20 61 6e 64 20 74 65 run-id " and te
ae90: 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 64 st-id: " test-id
aea0: 20 20 22 20 70 67 64 62 20 72 75 6e 20 69 64 3a " pgdb run id:
aeb0: 20 22 20 70 67 64 62 2d 72 75 6e 2d 69 64 29 0a " pgdb-run-id).
aec0: 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 (pgdb
aed0: 3a 69 6e 73 65 72 74 2d 74 65 73 74 20 64 62 68 :insert-test dbh
aee0: 20 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 pgdb-run-id tes
aef0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
af00: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 68 6f state status ho
af10: 73 74 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 st cpuload diskf
af20: 72 65 65 20 75 6e 61 6d 65 20 72 75 6e 2d 64 69 ree uname run-di
af30: 72 20 6c 6f 67 2d 66 69 6c 65 20 72 75 6e 2d 64 r log-file run-d
af40: 75 72 61 74 69 6f 6e 20 63 6f 6d 6d 65 6e 74 20 uration comment
af50: 65 76 65 6e 74 2d 74 69 6d 65 20 61 72 63 68 69 event-time archi
af60: 76 65 64 20 6c 61 73 74 2d 75 70 64 61 74 65 20 ved last-update
af70: 70 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 pid).
af80: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d (if (or (not sm
af90: 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 allest-time) (<
afa0: 6c 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c last-update smal
afb0: 6c 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 lest-time)).
afc0: 20 20 20 20 09 09 09 09 28 68 61 73 68 2d 74 61 ....(hash-ta
afd0: 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 ble-set! smalles
afe0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 t-last-update-ti
aff0: 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d me "smallest-tim
b000: 65 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 e" last-update))
b010: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 . (set
b020: 21 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 28 ! pgdb-test-id (
b030: 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 pgdb:get-test-id
b040: 20 64 62 68 20 70 67 64 62 2d 72 75 6e 2d 69 64 dbh pgdb-run-id
b050: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
b060: 70 61 74 68 29 29 29 29 0a 20 20 20 20 20 20 20 path)))).
b070: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
b080: 73 65 74 21 20 74 65 73 74 2d 68 74 20 74 65 73 set! test-ht tes
b090: 74 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d 69 t-id pgdb-test-i
b0a0: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 d)). (
b0b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
b0c0: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
b0d0: 70 6f 72 74 2a 20 20 22 57 41 52 4e 49 4e 47 3a port* "WARNING:
b0e0: 20 53 6b 69 70 70 69 6e 67 20 72 75 6e 20 77 69 Skipping run wi
b0f0: 74 68 20 72 75 6e 2d 69 64 3a 22 20 72 75 6e 2d th run-id:" run-
b100: 69 64 20 22 2e 20 54 68 69 73 20 72 75 6e 20 77 id ". This run w
b110: 61 73 20 63 72 65 61 74 65 64 20 61 66 74 65 72 as created after
b120: 20 70 72 69 76 69 6f 75 73 20 73 79 6e 63 20 61 privious sync a
b130: 6e 64 20 72 65 6d 6f 76 65 64 20 62 65 66 6f 72 nd removed befor
b140: 65 20 74 68 69 73 20 73 79 6e 63 2e 22 29 29 29 e this sync.")))
b150: 29 0a 20 20 20 20 20 74 65 73 74 2d 69 64 73 29 ). test-ids)
b160: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ))..(define (tas
b170: 6b 3a 61 64 64 2d 61 72 65 61 2d 74 61 67 20 64 k:add-area-tag d
b180: 62 68 20 61 72 65 61 2d 69 6e 66 6f 20 74 61 67 bh area-info tag
b190: 29 20 0a 20 20 28 6c 65 74 2a 20 28 28 74 61 67 ) . (let* ((tag
b1a0: 2d 69 6e 66 6f 20 28 70 67 64 62 3a 67 65 74 2d -info (pgdb:get-
b1b0: 74 61 67 2d 69 6e 66 6f 2d 62 79 2d 6e 61 6d 65 tag-info-by-name
b1c0: 20 64 62 68 20 74 61 67 29 29 29 0a 20 20 20 28 dbh tag))). (
b1d0: 69 66 20 28 6e 6f 74 20 74 61 67 2d 69 6e 66 6f if (not tag-info
b1e0: 29 0a 20 20 20 20 20 28 62 65 67 69 6e 20 20 20 ). (begin
b1f0: 0a 20 20 20 20 20 28 69 66 20 28 68 61 6e 64 6c . (if (handl
b200: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 e-exceptions..
b210: 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 6e 20 exn.. (begin
b220: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b230: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
b240: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
b250: 2d 70 6f 72 74 2a 20 20 28 28 63 6f 6e 64 69 74 -port* ((condit
b260: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
b270: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
b280: 61 67 65 29 20 65 78 6e 29 29 20 20 20 20 20 0a age) exn)) .
b290: 09 20 20 20 23 66 29 0a 09 20 20 20 28 70 67 64 . #f).. (pgd
b2a0: 62 3a 69 6e 73 65 72 74 2d 74 61 67 20 20 64 62 b:insert-tag db
b2b0: 68 20 20 20 74 61 67 29 29 0a 20 20 20 20 20 20 h tag)).
b2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b2d0: 20 28 73 65 74 21 20 74 61 67 2d 69 6e 66 6f 20 (set! tag-info
b2e0: 28 70 67 64 62 3a 67 65 74 2d 74 61 67 2d 69 6e (pgdb:get-tag-in
b2f0: 66 6f 2d 62 79 2d 6e 61 6d 65 20 64 62 68 20 74 fo-by-name dbh t
b300: 61 67 29 29 0a 09 09 20 20 23 66 29 29 29 0a 20 ag))... #f))).
b310: 20 20 20 20 3b 3b 61 64 64 20 74 6f 20 61 72 65 ;;add to are
b320: 61 5f 74 61 67 73 0a 20 20 20 20 20 28 68 61 6e a_tags. (han
b330: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
b340: 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 exn.. (begi
b350: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
b360: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
b370: 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 1 *default-l
b380: 6f 67 2d 70 6f 72 74 2a 20 20 28 28 63 6f 6e 64 og-port* ((cond
b390: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
b3a0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
b3b0: 73 73 61 67 65 29 20 65 78 6e 29 29 20 20 20 20 ssage) exn))
b3c0: 20 0a 09 20 20 20 23 66 29 0a 20 20 20 20 20 20 .. #f).
b3d0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 70 (if (not (p
b3e0: 67 64 62 3a 69 73 2d 61 72 65 61 2d 74 61 67 65 gdb:is-area-tage
b3f0: 64 2d 77 69 74 68 2d 61 2d 74 61 67 20 64 62 68 d-with-a-tag dbh
b400: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 61 67 (vector-ref tag
b410: 2d 69 6e 66 6f 20 30 29 20 20 28 76 65 63 74 6f -info 0) (vecto
b420: 72 2d 72 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 r-ref area-info
b430: 30 29 29 29 20 20 0a 09 20 20 20 28 70 67 64 62 0))) .. (pgdb
b440: 3a 69 6e 73 65 72 74 2d 61 72 65 61 2d 74 61 67 :insert-area-tag
b450: 20 20 64 62 68 20 20 20 28 76 65 63 74 6f 72 2d dbh (vector-
b460: 72 65 66 20 74 61 67 2d 69 6e 66 6f 20 30 29 20 ref tag-info 0)
b470: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 (vector-ref are
b480: 61 2d 69 6e 66 6f 20 30 29 29 29 29 29 29 0a 0a a-info 0))))))..
b490: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 (define (tasks:s
b4a0: 79 6e 63 2d 72 75 6e 2d 64 61 74 61 20 64 62 68 ync-run-data dbh
b4b0: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e cached-info run
b4c0: 2d 69 64 73 20 61 72 65 61 2d 69 6e 66 6f 20 73 -ids area-info s
b4d0: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
b4e0: 61 74 65 2d 74 69 6d 65 29 20 0a 20 20 28 66 6f ate-time) . (fo
b4f0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
b500: 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 20 20 20 bda (run-id).
b510: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
b520: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
b530: 6c 6f 67 2d 70 6f 72 74 2a 20 20 20 22 43 68 65 log-port* "Che
b540: 63 6b 20 69 66 20 72 75 6e 20 77 69 74 68 20 22 ck if run with "
b550: 20 72 75 6e 2d 69 64 20 22 20 6e 65 65 64 73 20 run-id " needs
b560: 74 6f 20 62 65 20 73 79 6e 63 65 64 22 20 29 0a to be synced" ).
b570: 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a 72 75 (tasks:ru
b580: 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 n-id->mtpg-run-i
b590: 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 d dbh cached-inf
b5a0: 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 69 6e o run-id area-in
b5b0: 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 fo smallest-last
b5c0: 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 29 0a 72 -update-time)).r
b5d0: 75 6e 2d 69 64 73 29 29 0a 0a 0a 3b 3b 20 67 65 un-ids))...;; ge
b5e0: 74 20 72 75 6e 73 20 63 68 61 6e 67 65 64 20 73 t runs changed s
b5f0: 69 6e 63 65 20 6c 61 73 74 20 73 79 6e 63 0a 3b ince last sync.;
b600: 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ; (define (tasks
b610: 3a 73 79 6e 63 2d 74 65 73 74 2d 64 61 74 61 20 :sync-test-data
b620: 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 dbh cached-info
b630: 61 72 65 61 2d 69 6e 66 6f 29 0a 3b 3b 20 20 20 area-info).;;
b640: 28 6c 65 74 2a 20 28 28 0a 0a 28 64 65 66 69 6e (let* ((..(defin
b650: 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 6f e (tasks:sync-to
b660: 2d 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 67 -postgres config
b670: 64 61 74 20 64 65 73 74 29 0a 20 20 28 70 72 69 dat dest). (pri
b680: 6e 74 20 22 49 6e 20 73 79 6e 63 22 29 0a 20 20 nt "In sync").
b690: 28 6c 65 74 2a 20 28 28 64 62 68 20 20 20 20 20 (let* ((dbh
b6a0: 20 20 20 20 28 70 67 64 62 3a 6f 70 65 6e 20 63 (pgdb:open c
b6b0: 6f 6e 66 69 67 64 61 74 20 64 62 6e 61 6d 65 3a onfigdat dbname:
b6c0: 20 64 65 73 74 29 29 0a 09 20 28 61 72 65 61 2d dest)).. (area-
b6d0: 69 6e 66 6f 20 20 20 28 70 67 64 62 3a 67 65 74 info (pgdb:get
b6e0: 2d 61 72 65 61 2d 62 79 2d 70 61 74 68 20 64 62 -area-by-path db
b6f0: 68 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 h *toppath*))..
b700: 28 63 61 63 68 65 64 2d 69 6e 66 6f 20 28 6d 61 (cached-info (ma
b710: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
b720: 09 20 28 73 74 61 72 74 20 20 20 20 20 20 20 28 . (start (
b730: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
b740: 29 0a 20 20 20 28 74 65 73 74 2d 70 61 74 74 20 ). (test-patt
b750: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
b760: 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 arg "-testpatt")
b770: 0a 09 09 09 09 09 09 09 09 09 09 09 28 61 72 67 ............(arg
b780: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 s:get-arg "-test
b790: 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 patt").
b7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
b7b0: 29 29 0a 20 20 20 28 74 61 72 67 65 74 20 20 20 )). (target
b7c0: 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a (if (args:
b7d0: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
b7e0: 22 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 ")..............
b7f0: 09 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 . (args:get-arg
b800: 22 2d 74 61 72 67 65 74 22 29 0a 09 09 09 09 09 "-target")......
b810: 09 09 09 09 09 09 09 09 23 66 29 29 0a 20 20 20 ........#f)).
b820: 20 28 72 75 6e 2d 6e 61 6d 65 20 20 20 20 20 20 (run-name
b830: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
b840: 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 -arg "-runname")
b850: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 20 ...............
b860: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
b870: 72 75 6e 6e 61 6d 65 22 29 0a 09 09 09 09 09 09 runname").......
b880: 09 09 09 09 09 09 09 23 66 29 29 29 0a 20 20 20 .......#f))).
b890: 20 20 28 69 66 20 28 61 6e 64 20 74 61 72 67 65 (if (and targe
b8a0: 74 20 20 28 6e 6f 74 20 72 75 6e 2d 6e 61 6d 65 t (not run-name
b8b0: 29 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 6e )). (begin
b8c0: 0a 09 09 09 09 09 28 70 72 69 6e 74 20 22 45 72 ......(print "Er
b8d0: 72 6f 72 3a 20 50 72 6f 76 69 64 65 20 72 75 6e ror: Provide run
b8e0: 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 20 20 name").
b8f0: 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 (exit 1))).
b900: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 74 (if (and (not t
b910: 61 72 67 65 74 29 20 20 72 75 6e 2d 6e 61 6d 65 arget) run-name
b920: 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a ). (begin.
b930: 09 09 09 09 09 28 70 72 69 6e 74 20 22 45 72 72 .....(print "Err
b940: 6f 72 3a 20 50 72 6f 76 69 64 65 20 74 61 72 67 or: Provide targ
b950: 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 et"). (
b960: 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 3b 28 exit 1))). ;(
b970: 70 72 69 6e 74 20 22 31 32 33 22 29 0a 20 20 20 print "123").
b980: 20 3b 28 65 78 69 74 20 31 29 20 0a 20 20 20 20 ;(exit 1) .
b990: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
b9a0: 61 20 28 64 74 79 70 65 29 0a 09 09 28 68 61 73 a (dtype)...(has
b9b0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 61 63 h-table-set! cac
b9c0: 68 65 64 2d 69 6e 66 6f 20 64 74 79 70 65 20 28 hed-info dtype (
b9d0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
b9e0: 29 29 0a 09 20 20 20 20 20 20 27 28 72 75 6e 73 )).. '(runs
b9f0: 20 74 61 72 67 65 74 73 20 74 65 73 74 73 20 73 targets tests s
ba00: 74 65 70 73 20 64 61 74 61 29 29 0a 20 20 20 20 teps data)).
ba10: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
ba20: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 73 74 cached-info 'st
ba30: 61 72 74 20 73 74 61 72 74 29 20 3b 3b 20 77 68 art start) ;; wh
ba40: 65 6e 20 64 6f 6e 65 20 77 65 27 6c 6c 20 73 65 en done we'll se
ba50: 74 20 73 79 6e 63 20 74 69 6d 65 73 20 74 6f 20 t sync times to
ba60: 74 68 69 73 0a 20 20 20 20 28 69 66 20 61 72 65 this. (if are
ba70: 61 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 a-info..(let* ((
ba80: 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 28 last-sync-time (
ba90: 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 61 2d vector-ref area-
baa0: 69 6e 66 6f 20 33 29 29 0a 09 20 20 20 20 20 20 info 3))..
bab0: 20 28 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d (smallest-last-
bac0: 75 70 64 61 74 65 2d 74 69 6d 65 20 20 28 6d 61 update-time (ma
bad0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
bae0: 20 20 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 (change
baf0: 64 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 d (if (and
bb00: 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 29 target run-name)
bb10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bb20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d (rm
bb30: 74 3a 67 65 74 2d 72 75 6e 2d 72 65 63 6f 72 64 t:get-run-record
bb40: 2d 69 64 73 20 74 61 72 67 65 74 20 72 75 6e 2d -ids target run-
bb50: 6e 61 6d 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 name (rmt:get-ke
bb60: 79 73 29 20 74 65 73 74 2d 70 61 74 74 29 0a 20 ys) test-patt).
bb70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb80: 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a (rmt:
bb90: 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f get-changed-reco
bba0: 72 64 2d 69 64 73 20 6c 61 73 74 2d 73 79 6e 63 rd-ids last-sync
bbb0: 2d 74 69 6d 65 29 29 29 0a 09 20 20 20 20 20 20 -time)))..
bbc0: 20 28 72 75 6e 2d 69 64 73 20 20 20 20 20 20 20 (run-ids
bbd0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 6e (alist-ref 'run
bbe0: 73 20 20 20 20 20 20 20 63 68 61 6e 67 65 64 29 s changed)
bbf0: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ).. (test-
bc00: 69 64 73 20 20 20 20 20 20 20 28 61 6c 69 73 74 ids (alist
bc10: 2d 72 65 66 20 27 74 65 73 74 73 20 20 20 20 20 -ref 'tests
bc20: 20 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 changed))..
bc30: 20 20 20 28 74 65 73 74 2d 73 74 65 70 2d 69 64 (test-step-id
bc40: 73 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 74 s (alist-ref 't
bc50: 65 73 74 5f 73 74 65 70 73 20 63 68 61 6e 67 65 est_steps change
bc60: 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 d)).. (tes
bc70: 74 2d 64 61 74 61 2d 69 64 73 20 20 28 61 6c 69 t-data-ids (ali
bc80: 73 74 2d 72 65 66 20 27 74 65 73 74 5f 64 61 74 st-ref 'test_dat
bc90: 61 20 20 63 68 61 6e 67 65 64 29 29 0a 09 20 20 a changed))..
bca0: 20 20 20 20 20 28 72 75 6e 2d 73 74 61 74 2d 69 (run-stat-i
bcb0: 64 73 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 ds (alist-ref
bcc0: 27 72 75 6e 5f 73 74 61 74 73 20 20 63 68 61 6e 'run_stats chan
bcd0: 67 65 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 ged)). (
bce0: 61 72 65 61 2d 74 61 67 20 20 20 20 28 69 66 20 area-tag (if
bcf0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
bd00: 61 72 65 61 2d 74 61 67 22 29 20 0a 20 20 20 20 area-tag") .
bd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 (ar
bd30: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 65 gs:get-arg "-are
bd40: 61 2d 74 61 67 22 29 0a 20 20 20 20 20 20 20 20 a-tag").
bd50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd60: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 72 (if (ar
bd70: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 65 gs:get-arg "-are
bd80: 61 22 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 a") .
bd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bda0: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
bdb0: 74 2d 61 72 67 20 22 2d 61 72 65 61 22 29 20 0a t-arg "-area") .
bdc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bdd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bde0: 20 20 20 22 22 29 29 29 29 0a 20 20 20 20 20 20 "")))).
bdf0: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 (if (and (e
be00: 71 75 61 6c 3f 20 61 72 65 61 2d 74 61 67 20 22 qual? area-tag "
be10: 22 29 20 28 6e 6f 74 20 28 70 67 64 62 3a 69 73 ") (not (pgdb:is
be20: 2d 61 72 65 61 2d 74 61 67 65 64 20 64 62 68 20 -area-taged dbh
be30: 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 61 (vector-ref area
be40: 2d 69 6e 66 6f 20 30 29 29 29 29 0a 20 20 20 20 -info 0)))).
be50: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 61 72 (set! ar
be60: 65 61 2d 74 61 67 20 2a 64 65 66 61 75 6c 74 2d ea-tag *default-
be70: 61 72 65 61 2d 74 61 67 2a 29 29 20 0a 20 20 20 area-tag*)) .
be80: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
be90: 20 28 65 71 75 61 6c 3f 20 61 72 65 61 2d 74 61 (equal? area-ta
bea0: 67 20 22 22 29 29 20 0a 20 20 20 20 20 20 20 20 g "")) .
beb0: 20 20 20 20 20 28 74 61 73 6b 3a 61 64 64 2d 61 (task:add-a
bec0: 72 65 61 2d 74 61 67 20 64 62 68 20 61 72 65 61 rea-tag dbh area
bed0: 2d 69 6e 66 6f 20 61 72 65 61 2d 74 61 67 29 29 -info area-tag))
bee0: 20 0a 09 20 20 28 69 66 20 28 6f 72 20 28 6e 6f .. (if (or (no
bef0: 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 69 64 t (null? test-id
bf00: 73 29 29 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 s)) (not (null?
bf10: 72 75 6e 2d 69 64 73 29 29 29 0a 09 20 20 20 20 run-ids)))..
bf20: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
bf30: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
bf40: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
bf50: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
bf60: 20 22 73 79 6e 63 69 6e 67 20 72 75 6e 73 22 29 "syncing runs")
bf70: 20 20 20 0a 09 20 20 20 20 20 20 20 20 20 20 20 ..
bf80: 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 72 (tasks:sync-r
bf90: 75 6e 2d 64 61 74 61 20 64 62 68 20 63 61 63 68 un-data dbh cach
bfa0: 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 73 20 ed-info run-ids
bfb0: 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 area-info smalle
bfc0: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
bfd0: 69 6d 65 29 20 0a 20 20 20 20 20 20 20 20 20 20 ime) .
bfe0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
bff0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
c000: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 73 lt-log-port* "s
c010: 79 6e 63 69 6e 67 20 74 65 73 74 73 22 29 0a 09 yncing tests")..
c020: 09 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 . (ta
c030: 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 73 2d 64 sks:sync-tests-d
c040: 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d 69 ata dbh cached-i
c050: 6e 66 6f 20 74 65 73 74 2d 69 64 73 20 61 72 65 nfo test-ids are
c060: 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d a-info smallest-
c070: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
c080: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c090: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
c0a0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
c0b0: 6f 67 2d 70 6f 72 74 2a 20 20 22 73 79 6e 63 69 og-port* "synci
c0c0: 6e 67 20 74 65 73 74 20 73 74 65 70 73 22 29 0a ng test steps").
c0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c0e0: 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 (tasks:sync-test
c0f0: 2d 73 74 65 70 73 20 64 62 68 20 63 61 63 68 65 -steps dbh cache
c100: 64 2d 69 6e 66 6f 20 74 65 73 74 2d 73 74 65 70 d-info test-step
c110: 2d 69 64 73 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 -ids smallest-la
c120: 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 0a st-update-time).
c130: 09 09 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 ........(debug:p
c140: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
c150: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
c160: 22 73 79 6e 63 69 6e 67 20 74 65 73 74 20 64 61 "syncing test da
c170: 74 61 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ta").
c180: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 (tasks:sync
c190: 2d 74 65 73 74 2d 67 65 6e 2d 64 61 74 61 20 64 -test-gen-data d
c1a0: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 bh cached-info t
c1b0: 65 73 74 2d 64 61 74 61 2d 69 64 73 20 73 6d 61 est-data-ids sma
c1c0: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
c1d0: 65 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 e-time).
c1e0: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
c1f0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 64 6f 6e 65 2d 2d ----------done--
c200: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 22 29 29 -------------"))
c210: 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 20 28 28 ). (let* ((
c220: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 smallest-time (h
c230: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
c240: 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c fault smallest-l
c250: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
c260: 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 "smallest-time"
c270: 23 66 29 29 29 0a 20 20 20 20 20 28 64 65 62 75 #f))). (debu
c280: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
c290: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 3a 22 smallest-time :"
c2a0: 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 20 smallest-time
c2b0: 22 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 " last-sync-time
c2c0: 20 22 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d " last-sync-tim
c2d0: 65 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 e). (if (not
c2e0: 28 61 6e 64 20 74 61 72 67 65 74 20 72 75 6e 2d (and target run-
c2f0: 6e 61 6d 65 29 29 20 0a 09 20 20 28 69 66 20 28 name)) .. (if (
c300: 6f 72 20 28 61 6e 64 20 73 6d 61 6c 6c 65 73 74 or (and smallest
c310: 2d 74 69 6d 65 20 28 3e 20 73 6d 61 6c 6c 65 73 -time (> smalles
c320: 74 2d 74 69 6d 65 20 6c 61 73 74 2d 73 79 6e 63 t-time last-sync
c330: 2d 74 69 6d 65 29 29 20 28 61 6e 64 20 73 6d 61 -time)) (and sma
c340: 6c 6c 65 73 74 2d 74 69 6d 65 20 28 65 71 3f 20 llest-time (eq?
c350: 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 30 last-sync-time 0
c360: 29 29 29 0a 09 09 09 09 28 70 67 64 62 3a 77 72 ))).....(pgdb:wr
c370: 69 74 65 2d 73 79 6e 63 2d 74 69 6d 65 20 64 62 ite-sync-time db
c380: 68 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c h area-info smal
c390: 6c 65 73 74 2d 74 69 6d 65 29 29 29 29 29 20 3b lest-time))))) ;
c3a0: 3b 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 62 ;this needs to b
c3b0: 65 20 63 68 61 6e 67 65 64 0a 09 28 69 66 20 28 e changed..(if (
c3c0: 74 61 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 tasks:set-area d
c3d0: 62 68 20 63 6f 6e 66 69 67 64 61 74 29 0a 09 20 bh configdat)..
c3e0: 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 (tasks:sync-t
c3f0: 6f 2d 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 o-postgres confi
c400: 67 64 61 74 20 64 65 73 74 29 0a 09 20 20 20 20 gdat dest)..
c410: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
c420: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
c430: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
c440: 22 45 52 52 4f 52 3a 20 75 6e 61 62 6c 65 20 74 "ERROR: unable t
c450: 6f 20 63 72 65 61 74 65 20 61 6e 20 61 72 65 61 o create an area
c460: 20 72 65 63 6f 72 64 22 29 0a 09 20 20 20 20 20 record")..
c470: 20 23 66 29 29 29 29 29 0a 0a #f)))))..