0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 39 2c 20 4d 61 74 74 right 2019, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 74 61 73 6b 73 6d 6f 64 29 29 0a unit tasksmod)).
03a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 (declare (uses c
03b0: 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 0a 28 6d 6f 64 ommonmod))..(mod
03c0: 75 6c 65 20 74 61 73 6b 73 6d 6f 64 0a 09 2a 0a ule tasksmod..*.
03d0: 09 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 ..(import scheme
03e0: 20 63 68 69 63 6b 65 6e 20 64 61 74 61 2d 73 74 chicken data-st
03f0: 72 75 63 74 75 72 65 73 20 65 78 74 72 61 73 29 ructures extras)
0400: 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 .(import (prefix
0410: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
0420: 3a 29 20 70 6f 73 69 78 20 74 79 70 65 64 2d 72 :) posix typed-r
0430: 65 63 6f 72 64 73 20 73 72 66 69 2d 31 38 20 73 ecords srfi-18 s
0440: 72 66 69 2d 36 39 20 66 6f 72 6d 61 74 20 70 6f rfi-69 format po
0450: 72 74 73 20 73 72 66 69 2d 31 20 6d 61 74 63 68 rts srfi-1 match
0460: 61 62 6c 65 29 0a 28 69 6d 70 6f 72 74 20 63 6f able).(import co
0470: 6d 6d 6f 6e 6d 6f 64 29 0a 3b 3b 20 28 75 73 65 mmonmod).;; (use
0480: 20 28 70 72 65 66 69 78 20 75 6c 65 78 20 75 6c (prefix ulex ul
0490: 65 78 3a 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 ex:))..(include
04a0: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
04b0: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
04c0: 74 61 73 6b 5f 72 65 63 6f 72 64 73 2e 73 63 6d task_records.scm
04d0: 22 29 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
0520: 54 61 73 6b 73 20 64 62 0a 3b 3b 3d 3d 3d 3d 3d Tasks db.;;=====
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 0a 0a 3b 3b 20 77 61 69 74 20 75 70 20 74 6f =..;; wait up to
0580: 20 61 70 72 6f 78 20 6e 20 73 65 63 6f 6e 64 73 aprox n seconds
0590: 20 66 6f 72 20 61 20 6a 6f 75 72 6e 61 6c 20 74 for a journal t
05a0: 6f 20 67 6f 20 61 77 61 79 0a 3b 3b 0a 23 3b 28 o go away.;;.#;(
05b0: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 77 61 define (tasks:wa
05c0: 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c 20 70 61 it-on-journal pa
05d0: 74 68 20 6e 20 23 21 6b 65 79 20 28 72 65 6d 6f th n #!key (remo
05e0: 76 65 20 23 66 29 28 77 61 69 74 69 6e 67 2d 6d ve #f)(waiting-m
05f0: 73 67 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e sg #f)). (if (n
0600: 6f 74 20 28 73 74 72 69 6e 67 3f 20 70 61 74 68 ot (string? path
0610: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
0620: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
0630: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0640: 20 22 43 61 6c 6c 65 64 20 74 61 73 6b 73 3a 77 "Called tasks:w
0650: 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c 20 77 ait-on-journal w
0660: 69 74 68 20 70 61 74 68 3d 22 20 70 61 74 68 20 ith path=" path
0670: 22 20 28 6e 6f 74 20 61 20 73 74 72 69 6e 67 29 " (not a string)
0680: 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 "). (let ((
0690: 66 75 6c 6c 70 61 74 68 20 28 63 6f 6e 63 20 70 fullpath (conc p
06a0: 61 74 68 20 22 2d 6a 6f 75 72 6e 61 6c 22 29 29 ath "-journal"))
06b0: 29 0a 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 )..(handle-excep
06c0: 74 69 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 28 62 tions.. exn.. (b
06d0: 65 67 69 6e 0a 09 20 20 20 28 70 72 69 6e 74 2d egin.. (print-
06e0: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
06f0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
0700: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
0710: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
0720: 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 -port* " message
0730: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
0740: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
0750: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
0760: 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 62 75 exn)).. (debu
0770: 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 66 61 75 g:print 5 *defau
0780: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 65 lt-log-port* " e
0790: 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d xn=" (condition-
07a0: 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 20 20 >list exn))..
07b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
07c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
07d0: 2a 20 22 74 61 73 6b 73 3a 77 61 69 74 2d 6f 6e * "tasks:wait-on
07e0: 2d 6a 6f 75 72 6e 61 6c 20 66 61 69 6c 65 64 2e -journal failed.
07f0: 20 43 6f 6e 74 69 6e 75 69 6e 67 20 6f 6e 2c 20 Continuing on,
0800: 79 6f 75 20 63 61 6e 20 69 67 6e 6f 72 65 20 74 you can ignore t
0810: 68 69 73 20 63 61 6c 6c 2d 63 68 61 69 6e 22 29 his call-chain")
0820: 0a 09 20 20 20 23 74 29 20 3b 3b 20 69 66 20 73 .. #t) ;; if s
0830: 74 75 66 66 20 67 6f 65 73 20 77 72 6f 6e 67 20 tuff goes wrong
0840: 6a 75 73 74 20 61 6c 6c 6f 77 20 69 74 20 74 6f just allow it to
0850: 20 6d 6f 76 65 20 6f 6e 0a 09 20 28 6c 65 74 20 move on.. (let
0860: 6c 6f 6f 70 20 28 28 6a 6f 75 72 6e 61 6c 2d 65 loop ((journal-e
0870: 78 69 73 74 73 20 28 63 6f 6d 6d 6f 6e 3a 66 69 xists (common:fi
0880: 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 70 le-exists? fullp
0890: 61 74 68 29 29 0a 09 09 20 20 20 20 28 63 6f 75 ath))... (cou
08a0: 6e 74 20 20 20 20 20 20 20 20 20 20 6e 29 29 20 nt n))
08b0: 3b 3b 20 77 61 69 74 20 74 65 6e 20 74 69 6d 65 ;; wait ten time
08c0: 73 20 2e 2e 2e 0a 09 20 20 20 28 69 66 20 6a 6f s ..... (if jo
08d0: 75 72 6e 61 6c 2d 65 78 69 73 74 73 0a 09 20 20 urnal-exists..
08e0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 (begin... (
08f0: 69 66 20 28 61 6e 64 20 77 61 69 74 69 6e 67 2d if (and waiting-
0900: 6d 73 67 0a 09 09 09 20 20 28 65 71 3f 20 28 6d msg.... (eq? (m
0910: 6f 64 75 6c 6f 20 6e 20 33 30 29 20 30 29 29 0a odulo n 30) 0)).
0920: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
0930: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0940: 6f 67 2d 70 6f 72 74 2a 20 77 61 69 74 69 6e 67 og-port* waiting
0950: 2d 6d 73 67 29 29 0a 09 09 20 28 69 66 20 28 3e -msg))... (if (>
0960: 20 63 6f 75 6e 74 20 30 29 0a 09 09 20 20 20 20 count 0)...
0970: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
0980: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
0990: 31 29 0a 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 1)... (loo
09a0: 70 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 p (common:file-e
09b0: 78 69 73 74 73 3f 20 66 75 6c 6c 70 61 74 68 29 xists? fullpath)
09c0: 0a 09 09 09 20 20 20 20 20 28 2d 20 63 6f 75 6e .... (- coun
09d0: 74 20 31 29 29 29 0a 09 09 20 20 20 20 20 28 62 t 1)))... (b
09e0: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 28 64 egin... (d
09f0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
0a00: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0a10: 22 45 52 52 4f 52 3a 20 72 65 6d 6f 76 69 6e 67 "ERROR: removing
0a20: 20 74 68 65 20 6a 6f 75 72 6e 61 6c 20 66 69 6c the journal fil
0a30: 65 20 22 20 66 75 6c 6c 70 61 74 68 20 22 2c 20 e " fullpath ",
0a40: 74 68 69 73 20 69 73 20 6e 6f 74 20 67 6f 6f 64 this is not good
0a50: 2e 20 4c 6f 6f 6b 20 66 6f 72 20 64 69 73 6b 20 . Look for disk
0a60: 66 75 6c 6c 2c 20 77 72 69 74 65 20 61 63 63 65 full, write acce
0a70: 73 73 20 61 6e 64 20 6f 74 68 65 72 20 69 73 73 ss and other iss
0a80: 75 65 73 2e 22 29 0a 09 09 20 20 20 20 20 20 20 ues.")...
0a90: 28 69 66 20 72 65 6d 6f 76 65 20 28 73 79 73 74 (if remove (syst
0aa0: 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 em (conc "rm -rf
0ab0: 20 22 20 66 75 6c 6c 70 61 74 68 29 29 29 0a 09 " fullpath)))..
0ac0: 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 09 20 . #f)))..
0ad0: 20 20 20 20 20 20 23 74 29 29 29 29 29 29 0a 0a #t))))))..
0ae0: 23 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 #;(define (tasks
0af0: 3a 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 61 74 :get-task-db-pat
0b00: 68 29 0a 20 20 28 6c 65 74 20 28 28 64 62 64 69 h). (let ((dbdi
0b10: 72 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a r (or (configf:
0b20: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
0b30: 74 2a 20 22 73 65 74 75 70 22 20 22 6d 6f 6e 69 t* "setup" "moni
0b40: 74 6f 72 64 69 72 22 29 0a 09 09 20 20 20 20 28 tordir")... (
0b50: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
0b60: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
0b70: 70 22 20 22 64 62 64 69 72 22 29 0a 09 09 20 20 p" "dbdir")...
0b80: 20 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a (conc (common:
0b90: 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 20 22 2f get-linktree) "/
0ba0: 2e 64 62 22 29 29 29 29 0a 20 20 20 20 28 68 61 .db")))). (ha
0bb0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
0bc0: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 exn. (b
0bd0: 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 65 62 egin. (deb
0be0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
0bf0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0c00: 72 74 2a 20 22 43 6f 75 6c 64 6e 27 74 20 63 72 rt* "Couldn't cr
0c10: 65 61 74 65 20 70 61 74 68 20 74 6f 20 22 20 64 eate path to " d
0c20: 62 64 69 72 29 0a 20 20 20 20 20 20 20 28 65 78 bdir). (ex
0c30: 69 74 20 31 29 29 0a 20 20 20 20 20 28 69 66 20 it 1)). (if
0c40: 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 79 3f (not (directory?
0c50: 20 64 62 64 69 72 29 29 28 63 72 65 61 74 65 2d dbdir))(create-
0c60: 64 69 72 65 63 74 6f 72 79 20 64 62 64 69 72 20 directory dbdir
0c70: 23 74 29 29 29 0a 20 20 20 20 64 62 64 69 72 29 #t))). dbdir)
0c80: 29 0a 0a 3b 3b 20 49 66 20 66 69 6c 65 20 65 78 )..;; If file ex
0c90: 69 73 74 73 20 41 4e 44 0a 3b 3b 20 20 20 20 66 ists AND.;; f
0ca0: 69 6c 65 20 72 65 61 64 61 62 6c 65 0a 3b 3b 20 ile readable.;;
0cb0: 20 20 20 20 20 20 20 20 3d 3d 3e 20 6f 70 65 6e ==> open
0cc0: 20 69 74 0a 3b 3b 20 49 66 20 66 69 6c 65 20 65 it.;; If file e
0cd0: 78 69 73 74 73 20 41 4e 44 0a 3b 3b 20 20 20 20 xists AND.;;
0ce0: 66 69 6c 65 20 4e 4f 54 20 72 65 61 64 61 62 6c file NOT readabl
0cf0: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 3d 3d 3e e.;; ==>
0d00: 20 6f 70 65 6e 20 69 6e 2d 6d 65 6d 20 76 65 72 open in-mem ver
0d10: 73 69 6f 6e 0a 3b 3b 20 49 66 20 66 69 6c 65 20 sion.;; If file
0d20: 4e 4f 54 20 65 78 69 73 74 73 0a 3b 3b 20 20 20 NOT exists.;;
0d30: 20 3d 3d 3e 20 6f 70 65 6e 20 69 6e 2d 6d 65 6d ==> open in-mem
0d40: 20 76 65 72 73 69 6f 6e 0a 3b 3b 0a 23 3b 28 64 version.;;.#;(d
0d50: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6f 70 65 efine (tasks:ope
0d60: 6e 2d 64 62 20 61 6c 6c 64 61 74 20 23 21 6b 65 n-db alldat #!ke
0d70: 79 20 28 6e 75 6d 72 65 74 72 69 65 73 20 34 29 y (numretries 4)
0d80: 29 0a 20 20 0a 20 20 28 69 66 20 2a 74 61 73 6b ). . (if *task
0d90: 2d 64 62 2a 0a 20 20 20 20 20 20 2a 74 61 73 6b -db*. *task
0da0: 2d 64 62 2a 0a 20 20 20 20 20 20 28 68 61 6e 64 -db*. (hand
0db0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
0dc0: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 exn.
0dd0: 28 69 66 20 28 3e 20 6e 75 6d 72 65 74 72 69 65 (if (> numretrie
0de0: 73 20 30 29 0a 09 20 20 20 28 62 65 67 69 6e 0a s 0).. (begin.
0df0: 09 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c . (print-cal
0e00: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
0e10: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 -error-port))..
0e20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0e30: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0e40: 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a port* " message:
0e50: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
0e60: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
0e70: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
0e80: 65 78 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 exn)).. (deb
0e90: 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 66 61 ug:print 5 *defa
0ea0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
0eb0: 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e exn=" (condition
0ec0: 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 20 ->list exn))..
0ed0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
0ee0: 21 20 31 29 0a 09 20 20 20 20 20 28 74 61 73 6b ! 1).. (task
0ef0: 73 3a 6f 70 65 6e 2d 64 62 20 6e 75 6d 72 65 74 s:open-db numret
0f00: 72 69 65 73 20 28 2d 20 6e 75 6d 72 65 74 72 69 ries (- numretri
0f10: 65 73 20 31 29 29 29 0a 09 20 20 20 28 62 65 67 es 1))).. (beg
0f20: 69 6e 0a 09 20 20 20 20 20 28 70 72 69 6e 74 2d in.. (print-
0f30: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
0f40: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
0f50: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
0f60: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0f70: 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 og-port* " messa
0f80: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
0f90: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
0fa0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
0fb0: 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 e) exn)).. (
0fc0: 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 debug:print 5 *d
0fd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0fe0: 20 22 20 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 " exn=" (condit
0ff0: 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 29 ion->list exn)))
1000: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
1010: 28 64 62 70 61 74 68 20 20 20 20 20 20 20 20 28 (dbpath (
1020: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d common:get-db-tm
1030: 70 2d 61 72 65 61 20 2a 61 6c 6c 64 61 74 2a 29 p-area *alldat*)
1040: 29 20 3b 3b 20 28 74 61 73 6b 73 3a 67 65 74 2d ) ;; (tasks:get-
1050: 74 61 73 6b 2d 64 62 2d 70 61 74 68 29 29 0a 09 task-db-path))..
1060: 20 20 20 20 20 20 28 64 62 66 69 6c 65 20 20 20 (dbfile
1070: 20 20 20 20 28 63 6f 6e 63 20 64 62 70 61 74 68 (conc dbpath
1080: 20 22 2f 6d 6f 6e 69 74 6f 72 2e 64 62 22 29 29 "/monitor.db"))
1090: 0a 09 20 20 20 20 20 20 28 61 76 61 69 6c 20 20 .. (avail
10a0: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 77 61 69 (tasks:wai
10b0: 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c 20 64 62 70 t-on-journal dbp
10c0: 61 74 68 20 31 30 29 29 20 3b 3b 20 77 61 69 74 ath 10)) ;; wait
10d0: 20 75 70 20 74 6f 20 61 62 6f 75 74 20 31 30 20 up to about 10
10e0: 73 65 63 6f 6e 64 73 20 66 6f 72 20 74 68 65 20 seconds for the
10f0: 6a 6f 75 72 6e 61 6c 20 74 6f 20 67 6f 20 61 77 journal to go aw
1100: 61 79 0a 09 20 20 20 20 20 20 28 65 78 69 73 74 ay.. (exist
1110: 73 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a s (common:
1120: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 70 file-exists? dbp
1130: 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 77 72 ath)).. (wr
1140: 69 74 65 2d 61 63 63 65 73 73 20 28 66 69 6c 65 ite-access (file
1150: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 -write-access? d
1160: 62 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 bpath)).. (
1170: 6d 64 62 20 20 20 20 20 20 20 20 20 20 28 63 6f mdb (co
1180: 6e 64 20 3b 3b 20 77 68 61 74 20 74 68 65 20 68 nd ;; what the h
1190: 65 6b 20 69 73 20 2a 74 6f 70 70 61 74 68 2a 20 ek is *toppath*
11a0: 64 6f 69 6e 67 20 68 65 72 65 3f 0a 09 09 09 20 doing here?....
11b0: 20 20 20 20 28 28 61 6e 64 20 28 73 74 72 69 6e ((and (strin
11c0: 67 3f 20 2a 74 6f 70 70 61 74 68 2a 29 28 66 69 g? *toppath*)(fi
11d0: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
11e0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 09 09 *toppath*))....
11f0: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f (sqlite3:o
1200: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 64 62 66 pen-database dbf
1210: 69 6c 65 29 29 0a 09 09 09 20 20 20 20 20 28 28 ile)).... ((
1220: 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 file-read-access
1230: 3f 20 64 62 70 61 74 68 29 20 20 20 20 28 73 71 ? dbpath) (sq
1240: 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 lite3:open-datab
1250: 61 73 65 20 64 62 66 69 6c 65 29 29 0a 09 09 09 ase dbfile))....
1260: 20 20 20 20 20 28 65 6c 73 65 20 28 73 71 6c 69 (else (sqli
1270: 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 te3:open-databas
1280: 65 20 22 3a 6d 65 6d 6f 72 79 3a 22 29 29 29 29 e ":memory:"))))
1290: 20 3b 3b 20 28 6e 65 76 65 72 2d 67 69 76 65 2d ;; (never-give-
12a0: 75 70 2d 6f 70 65 6e 2d 64 62 20 64 62 70 61 74 up-open-db dbpat
12b0: 68 29 29 0a 09 20 20 20 20 20 20 28 68 61 6e 64 h)).. (hand
12c0: 6c 65 72 20 20 20 20 20 20 28 6d 61 6b 65 2d 62 ler (make-b
12d0: 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 36 30 30 usy-timeout 3600
12e0: 30 29 29 29 0a 09 20 28 69 66 20 28 61 6e 64 20 0))).. (if (and
12f0: 65 78 69 73 74 73 0a 09 09 20 20 28 6e 6f 74 20 exists... (not
1300: 77 72 69 74 65 2d 61 63 63 65 73 73 29 29 0a 09 write-access))..
1310: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 77 (set! *db-w
1320: 72 69 74 65 2d 61 63 63 65 73 73 2a 20 77 72 69 rite-access* wri
1330: 74 65 2d 61 63 63 65 73 73 29 29 20 3b 3b 20 6f te-access)) ;; o
1340: 6e 6c 79 20 75 6e 73 65 74 20 73 6f 20 6f 74 68 nly unset so oth
1350: 65 72 20 64 62 27 73 20 61 6c 73 6f 20 63 61 6e er db's also can
1360: 20 75 73 65 20 74 68 69 73 20 63 6f 6e 74 72 6f use this contro
1370: 6c 0a 09 20 28 73 71 6c 69 74 65 33 3a 73 65 74 l.. (sqlite3:set
1380: 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 6d -busy-handler! m
1390: 64 62 20 68 61 6e 64 6c 65 72 29 0a 09 20 28 64 db handler).. (d
13a0: 62 3a 73 65 74 2d 73 79 6e 63 20 6d 64 62 29 20 b:set-sync mdb)
13b0: 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 ;; (sqlite3:exec
13c0: 75 74 65 20 6d 64 62 20 28 63 6f 6e 63 20 22 50 ute mdb (conc "P
13d0: 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 RAGMA synchronou
13e0: 73 20 3d 20 30 3b 22 29 29 0a 09 20 3b 3b 20 20 s = 0;")).. ;;
13f0: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 6e 6f (if (or (and (no
1400: 74 20 65 78 69 73 74 73 29 0a 09 20 3b 3b 20 09 t exists).. ;; .
1410: 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 (file-writ
1420: 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 e-access? *toppa
1430: 74 68 2a 29 29 0a 09 20 3b 3b 20 09 20 28 6e 6f th*)).. ;; . (no
1440: 74 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 t (file-read-acc
1450: 65 73 73 3f 20 64 62 70 61 74 68 29 29 29 0a 09 ess? dbpath)))..
1460: 20 3b 3b 20 20 20 20 20 20 28 62 65 67 69 6e 0a ;; (begin.
1470: 09 20 3b 3b 20 0a 09 20 3b 3b 20 54 41 53 4b 53 . ;; .. ;; TASKS
1480: 20 51 55 45 55 45 20 4d 4f 56 45 44 20 54 4f 20 QUEUE MOVED TO
1490: 6d 61 69 6e 2e 64 62 0a 09 20 3b 3b 0a 09 20 3b main.db.. ;;.. ;
14a0: 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ; (sqlite3:execu
14b0: 74 65 20 6d 64 62 20 22 43 52 45 41 54 45 20 54 te mdb "CREATE T
14c0: 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 ABLE IF NOT EXIS
14d0: 54 53 20 74 61 73 6b 73 5f 71 75 65 75 65 20 28 TS tasks_queue (
14e0: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
14f0: 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 RY KEY,.
1500: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
1510: 20 20 20 20 20 20 20 20 20 20 20 61 63 74 69 6f actio
1520: 6e 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 n TEXT DEFAULT '
1530: 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ',. ;;
1540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1550: 20 20 20 20 20 20 6f 77 6e 65 72 20 54 45 58 54 owner TEXT
1560: 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ,. ;;
1570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1580: 20 20 20 20 20 73 74 61 74 65 20 54 45 58 54 20 state TEXT
1590: 44 45 46 41 55 4c 54 20 27 6e 65 77 27 2c 0a 20 DEFAULT 'new',.
15a0: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
15b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15c0: 20 20 74 61 72 67 65 74 20 54 45 58 54 20 44 45 target TEXT DE
15d0: 46 41 55 4c 54 20 27 27 2c 0a 20 20 20 20 20 20 FAULT '',.
15e0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
15f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 61 6d nam
1600: 65 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 e TEXT DEFAULT '
1610: 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ',. ;;
1620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1630: 20 20 20 20 20 20 74 65 73 74 70 61 74 74 20 54 testpatt T
1640: 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a EXT DEFAULT '',.
1650: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
1660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1670: 20 20 20 6b 65 79 6c 6f 63 6b 20 54 45 58 54 2c keylock TEXT,
1680: 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 . ;;
1690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16a0: 20 20 20 20 70 61 72 61 6d 73 20 54 45 58 54 2c params TEXT,
16b0: 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 . ;;
16c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16d0: 20 20 20 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d creation_tim
16e0: 65 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 e TIMESTAMP,.
16f0: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
1700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1710: 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 54 execution_time T
1720: 49 4d 45 53 54 41 4d 50 29 3b 22 29 0a 09 20 28 IMESTAMP);").. (
1730: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
1740: 6d 64 62 20 22 43 52 45 41 54 45 20 54 41 42 4c mdb "CREATE TABL
1750: 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
1760: 6d 6f 6e 69 74 6f 72 73 20 28 69 64 20 49 4e 54 monitors (id INT
1770: 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 EGER PRIMARY KEY
1780: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
1790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17a0: 20 20 70 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 pid INTEGER,.
17b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
17d0: 74 61 72 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 tart_time TIMEST
17e0: 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 AMP,.
17f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1800: 20 20 20 20 20 6c 61 73 74 5f 75 70 64 61 74 65 last_update
1810: 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 TIMESTAMP,.
1820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1830: 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 host
1840: 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 20 name TEXT,.
1850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1860: 20 20 20 20 20 20 20 20 20 20 20 75 73 65 72 6e usern
1870: 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 ame TEXT,.
1880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1890: 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 CONSTRA
18a0: 49 4e 54 20 6d 6f 6e 69 74 6f 72 73 5f 63 6f 6e INT monitors_con
18b0: 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 straint UNIQUE (
18c0: 70 69 64 2c 68 6f 73 74 6e 61 6d 65 29 29 3b 22 pid,hostname));"
18d0: 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ).. (sqlite3:exe
18e0: 63 75 74 65 20 6d 64 62 20 22 43 52 45 41 54 45 cute mdb "CREATE
18f0: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
1900: 49 53 54 53 20 73 65 72 76 65 72 73 20 28 69 64 ISTS servers (id
1910: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
1920: 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 KEY,.
1930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1940: 20 20 20 20 20 20 20 20 70 69 64 20 49 4e 54 45 pid INTE
1950: 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 20 GER,.
1960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1970: 20 20 20 20 20 20 20 69 6e 74 65 72 66 61 63 65 interface
1980: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
1990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19a0: 20 20 20 20 20 20 20 20 20 68 6f 73 74 6e 61 6d hostnam
19b0: 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 e TEXT,.
19c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19d0: 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 20 49 port I
19e0: 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 NTEGER,.
19f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a00: 20 20 20 20 20 20 20 20 20 20 70 75 62 70 6f 72 pubpor
1a10: 74 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 t INTEGER,.
1a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 sta
1a40: 72 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d rt_time TIMESTAM
1a50: 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 P,.
1a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a70: 20 20 20 20 20 70 72 69 6f 72 69 74 79 20 49 4e priority IN
1a80: 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 TEGER,.
1a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1aa0: 20 20 20 20 20 20 20 20 20 73 74 61 74 65 20 54 state T
1ab0: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 EXT,.
1ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ad0: 20 20 20 20 20 20 20 6d 74 5f 76 65 72 73 69 6f mt_versio
1ae0: 6e 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 n TEXT,.
1af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b00: 20 20 20 20 20 20 20 20 20 20 68 65 61 72 74 62 heartb
1b10: 65 61 74 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 eat TIMESTAMP,.
1b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b40: 20 74 72 61 6e 73 70 6f 72 74 20 54 45 58 54 2c transport TEXT,
1b50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b70: 20 20 20 72 75 6e 5f 69 64 20 49 4e 54 45 47 45 run_id INTEGE
1b80: 52 29 3b 22 29 0a 09 20 3b 3b 20 20 20 20 20 20 R);").. ;;
1b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ba0: 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 CONSTRA
1bb0: 49 4e 54 20 73 65 72 76 65 72 73 5f 63 6f 6e 73 INT servers_cons
1bc0: 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 70 traint UNIQUE (p
1bd0: 69 64 2c 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 id,hostname,port
1be0: 29 29 3b 22 29 0a 09 20 28 73 71 6c 69 74 65 33 ));").. (sqlite3
1bf0: 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 43 52 :execute mdb "CR
1c00: 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f EATE TABLE IF NO
1c10: 54 20 45 58 49 53 54 53 20 63 6c 69 65 6e 74 73 T EXISTS clients
1c20: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
1c30: 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 MARY KEY,.
1c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 72 76 serv
1c60: 65 72 5f 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 er_id INTEGER,.
1c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c90: 20 70 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 20 pid INTEGER,.
1ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cc0: 68 6f 73 74 6e 61 6d 65 20 54 45 58 54 2c 0a 20 hostname TEXT,.
1cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cf0: 20 63 6d 64 6c 69 6e 65 20 54 45 58 54 2c 0a 20 cmdline TEXT,.
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 20 20 20 20 20 20 20 20
1d20: 20 6c 6f 67 69 6e 5f 74 69 6d 65 20 54 49 4d 45 login_time TIME
1d30: 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 STAMP,.
1d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d50: 20 20 20 20 20 20 20 20 20 6c 6f 67 6f 75 74 5f logout_
1d60: 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 44 time TIMESTAMP D
1d70: 45 46 41 55 4c 54 20 2d 31 2c 0a 20 20 20 20 20 EFAULT -1,.
1d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d90: 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 CONST
1da0: 52 41 49 4e 54 20 63 6c 69 65 6e 74 73 5f 63 6f RAINT clients_co
1db0: 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 nstraint UNIQUE
1dc0: 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 29 29 3b (pid,hostname));
1dd0: 22 29 0a 09 20 20 20 20 20 20 20 0a 09 20 20 20 ").. ..
1de0: 20 20 20 20 3b 29 29 0a 09 20 28 73 65 74 21 20 ;)).. (set!
1df0: 2a 74 61 73 6b 2d 64 62 2a 20 28 63 6f 6e 73 20 *task-db* (cons
1e00: 6d 64 62 20 64 62 70 61 74 68 29 29 0a 09 20 2a mdb dbpath)).. *
1e10: 74 61 73 6b 2d 64 62 2a 29 29 29 29 0a 0a 3b 3b task-db*))))..;;
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 3d 3d 3d 3d ================
1e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e60: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 65 72 76 65 72 ======.;; Server
1e70: 20 61 6e 64 20 63 6c 69 65 6e 74 20 6d 61 6e 61 and client mana
1e80: 67 65 6d 65 6e 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d gement.;;=======
1e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1ed0: 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 74 6f 72 2d .;; make-vector-
1ee0: 72 65 63 6f 72 64 20 74 61 73 6b 73 20 68 6f 73 record tasks hos
1ef0: 74 69 6e 66 6f 20 69 64 20 69 6e 74 65 72 66 61 tinfo id interfa
1f00: 63 65 20 70 6f 72 74 20 70 75 62 70 6f 72 74 20 ce port pubport
1f10: 74 72 61 6e 73 70 6f 72 74 20 70 69 64 20 68 6f transport pid ho
1f20: 73 74 6e 61 6d 65 0a 28 64 65 66 69 6e 65 20 28 stname.(define (
1f30: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
1f40: 65 74 2d 69 64 20 20 20 20 20 20 20 20 20 20 76 et-id v
1f50: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
1f60: 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 66 ef vec 0)).(def
1f70: 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 ine (tasks:hosti
1f80: 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 nfo-get-interfac
1f90: 65 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 e vec) (vec
1fa0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 tor-ref vec 1))
1fb0: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
1fc0: 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 hostinfo-get-por
1fd0: 74 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 t vec)
1fe0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
1ff0: 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 74 c 2)).(define (t
2000: 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 asks:hostinfo-ge
2010: 74 2d 70 75 62 70 6f 72 74 20 20 20 20 20 76 65 t-pubport ve
2020: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
2030: 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 f vec 3)).(defi
2040: 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e ne (tasks:hostin
2050: 66 6f 2d 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 fo-get-transport
2060: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
2070: 6f 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a or-ref vec 4)).
2080: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 (define (tasks:h
2090: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 69 64 20 ostinfo-get-pid
20a0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
20b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
20c0: 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 74 61 5)).(define (ta
20d0: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get
20e0: 2d 68 6f 73 74 6e 61 6d 65 20 20 20 20 76 65 63 -hostname vec
20f0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
2100: 20 20 76 65 63 20 36 29 29 0a 0a 23 3b 28 64 65 vec 6))..#;(de
2110: 66 69 6e 65 20 28 74 61 73 6b 73 3a 6e 65 65 64 fine (tasks:need
2120: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a -server run-id).
2130: 20 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 (equal? (confi
2140: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
2150: 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 gdat* "server" "
2160: 72 65 71 75 69 72 65 64 22 29 20 22 79 65 73 22 required") "yes"
2170: 29 29 0a 0a 3b 3b 20 6e 6f 20 65 6c 65 67 61 6e ))..;; no elegan
2180: 63 65 20 68 65 72 65 20 2e 2e 2e 0a 3b 3b 0a 23 ce here ....;;.#
2190: 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a ;(define (tasks:
21a0: 6b 69 6c 6c 2d 73 65 72 76 65 72 20 68 6f 73 74 kill-server host
21b0: 6e 61 6d 65 20 70 69 64 20 23 21 6b 65 79 20 28 name pid #!key (
21c0: 6b 69 6c 6c 2d 73 77 69 74 63 68 20 22 22 29 29 kill-switch ""))
21d0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
21e0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
21f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d log-port* "Attem
2200: 70 74 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 73 65 pting to kill se
2210: 72 76 65 72 20 70 72 6f 63 65 73 73 20 22 20 70 rver process " p
2220: 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 id " on host " h
2230: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 73 65 74 65 ostname). (sete
2240: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 20 nv "TARGETHOST"
2250: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 hostname). (let
2260: 2a 20 28 28 6c 6f 67 64 69 72 20 28 69 66 20 28 * ((logdir (if (
2270: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
2280: 3f 20 22 6c 6f 67 73 22 29 0a 20 20 20 20 20 20 ? "logs").
2290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 6c "l
22a0: 6f 67 73 2f 22 0a 20 20 20 20 20 20 20 20 20 20 ogs/".
22b0: 20 20 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 "")).
22c0: 20 20 20 20 20 20 20 20 28 6c 6f 67 66 69 6c 65 (logfile
22d0: 20 28 69 66 20 6c 6f 67 64 69 72 20 28 63 6f 6e (if logdir (con
22e0: 63 20 22 6c 6f 67 73 2f 73 65 72 76 65 72 2d 22 c "logs/server-"
22f0: 70 69 64 22 2d 22 68 6f 73 74 6e 61 6d 65 22 2e pid"-"hostname".
2300: 6c 6f 67 22 29 20 23 66 29 29 0a 20 20 20 20 20 log") #f)).
2310: 20 20 20 20 28 67 7a 66 69 6c 65 20 20 28 69 66 (gzfile (if
2320: 20 6c 6f 67 66 69 6c 65 20 28 63 6f 6e 63 20 6c logfile (conc l
2330: 6f 67 66 69 6c 65 20 22 2e 67 7a 22 29 29 29 29 ogfile ".gz"))))
2340: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 54 41 . (setenv "TA
2350: 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 20 28 RGETHOST_LOGF" (
2360: 63 6f 6e 63 20 6c 6f 67 64 69 72 20 22 73 65 72 conc logdir "ser
2370: 76 65 72 2d 6b 69 6c 6c 73 2e 6c 6f 67 22 29 29 ver-kills.log"))
2380: 0a 0a 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 .. (system (c
2390: 6f 6e 63 20 22 6e 62 66 61 6b 65 20 6b 69 6c 6c onc "nbfake kill
23a0: 20 22 6b 69 6c 6c 2d 73 77 69 74 63 68 22 20 22 "kill-switch" "
23b0: 70 69 64 29 29 0a 0a 20 20 20 20 28 77 68 65 6e pid)).. (when
23c0: 20 6c 6f 67 66 69 6c 65 0a 20 20 20 20 20 20 28 logfile. (
23d0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
23e0: 35 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 5). (if (co
23f0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
2400: 3f 20 67 7a 66 69 6c 65 29 20 28 64 65 6c 65 74 ? gzfile) (delet
2410: 65 2d 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 0a e-file gzfile)).
2420: 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 (system (c
2430: 6f 6e 63 20 22 67 7a 69 70 20 22 20 6c 6f 67 66 onc "gzip " logf
2440: 69 6c 65 29 29 0a 20 20 20 20 20 20 0a 20 20 20 ile)). .
2450: 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 54 41 (unsetenv "TA
2460: 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 29 0a RGETHOST_LOGF").
2470: 20 20 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 (unsetenv
2480: 22 54 41 52 47 45 54 48 4f 53 54 22 29 29 29 29 "TARGETHOST"))))
2490: 0a 20 20 20 20 0a 20 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24e0: 0a 3b 3b 20 4d 20 4f 20 4e 20 49 20 54 20 4f 20 .;; M O N I T O
24f0: 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R S.;;==========
2500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 23 3b ============..#;
2540: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 (define (tasks:r
2550: 65 6d 6f 76 65 2d 6d 6f 6e 69 74 6f 72 2d 72 65 emove-monitor-re
2560: 63 6f 72 64 20 6d 64 62 29 0a 20 20 28 73 71 6c cord mdb). (sql
2570: 69 74 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 ite3:execute mdb
2580: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 6d 6f "DELETE FROM mo
2590: 6e 69 74 6f 72 73 20 57 48 45 52 45 20 70 69 64 nitors WHERE pid
25a0: 3d 3f 20 41 4e 44 20 68 6f 73 74 6e 61 6d 65 3d =? AND hostname=
25b0: 3f 3b 22 0a 09 09 20 20 20 28 63 75 72 72 65 6e ?;"... (curren
25c0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 0a 09 09 t-process-id)...
25d0: 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d (get-host-nam
25e0: 65 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 e)))..#;(define
25f0: 28 74 61 73 6b 73 3a 67 65 74 2d 6d 6f 6e 69 74 (tasks:get-monit
2600: 6f 72 73 20 6d 64 62 29 0a 20 20 28 6c 65 74 20 ors mdb). (let
2610: 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 ((res '())).
2620: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
2630: 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 h-row. (lamb
2640: 64 61 20 28 61 20 2e 20 72 65 6d 29 0a 20 20 20 da (a . rem).
2650: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 (set! res (c
2660: 6f 6e 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f ons (apply vecto
2670: 72 20 61 20 72 65 6d 29 20 72 65 73 29 29 29 0a r a rem) res))).
2680: 20 20 20 20 20 6d 64 62 0a 20 20 20 20 20 22 53 mdb. "S
2690: 45 4c 45 43 54 20 69 64 2c 70 69 64 2c 73 74 72 ELECT id,pid,str
26a0: 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 59 20 ftime('%m/%d/%Y
26b0: 25 48 3a 25 4d 27 2c 64 61 74 65 74 69 6d 65 28 %H:%M',datetime(
26c0: 73 74 61 72 74 5f 74 69 6d 65 2c 27 75 6e 69 78 start_time,'unix
26d0: 65 70 6f 63 68 27 29 2c 27 6c 6f 63 61 6c 74 69 epoch'),'localti
26e0: 6d 65 27 29 2c 73 74 72 66 74 69 6d 65 28 27 25 me'),strftime('%
26f0: 6d 2f 25 64 2f 25 59 20 25 48 3a 25 4d 3a 25 53 m/%d/%Y %H:%M:%S
2700: 27 2c 64 61 74 65 74 69 6d 65 28 6c 61 73 74 5f ',datetime(last_
2710: 75 70 64 61 74 65 2c 27 75 6e 69 78 65 70 6f 63 update,'unixepoc
2720: 68 27 29 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 h'),'localtime')
2730: 2c 68 6f 73 74 6e 61 6d 65 2c 75 73 65 72 6e 61 ,hostname,userna
2740: 6d 65 20 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 73 me FROM monitors
2750: 20 4f 52 44 45 52 20 42 59 20 6c 61 73 74 5f 75 ORDER BY last_u
2760: 70 64 61 74 65 20 41 53 43 3b 22 29 0a 20 20 20 pdate ASC;").
2770: 20 28 72 65 76 65 72 73 65 20 72 65 73 29 0a 20 (reverse res).
2780: 20 20 20 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 ))..#;(define
2790: 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 73 (tasks:monitors
27a0: 2d 3e 74 65 78 74 2d 74 61 62 6c 65 20 6d 6f 6e ->text-table mon
27b0: 69 74 6f 72 73 29 0a 20 20 28 6c 65 74 20 28 28 itors). (let ((
27c0: 66 6d 74 73 74 72 20 22 7e 34 61 7e 38 61 7e 32 fmtstr "~4a~8a~2
27d0: 30 61 7e 32 30 61 7e 31 30 61 7e 31 30 61 22 29 0a~20a~10a~10a")
27e0: 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 66 6f 72 ). (conc (for
27f0: 6d 61 74 20 23 66 20 66 6d 74 73 74 72 20 22 69 mat #f fmtstr "i
2800: 64 22 20 22 70 69 64 22 20 22 73 74 61 72 74 20 d" "pid" "start
2810: 74 69 6d 65 22 20 22 6c 61 73 74 20 75 70 64 61 time" "last upda
2820: 74 65 22 20 22 68 6f 73 74 6e 61 6d 65 22 20 22 te" "hostname" "
2830: 75 73 65 72 22 29 20 22 5c 6e 22 0a 09 20 20 28 user") "\n".. (
2840: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
2850: 73 65 20 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 se .. (map (la
2860: 6d 62 64 61 20 28 6d 6f 6e 69 74 6f 72 29 0a 09 mbda (monitor)..
2870: 09 20 20 28 66 6f 72 6d 61 74 20 23 66 20 66 6d . (format #f fm
2880: 74 73 74 72 0a 09 09 09 20 20 28 74 61 73 6b 73 tstr.... (tasks
2890: 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 69 64 20 :monitor-get-id
28a0: 20 20 20 20 20 20 20 20 20 6d 6f 6e 69 74 6f 72 monitor
28b0: 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f ).... (tasks:mo
28c0: 6e 69 74 6f 72 2d 67 65 74 2d 70 69 64 20 20 20 nitor-get-pid
28d0: 20 20 20 20 20 20 6d 6f 6e 69 74 6f 72 29 0a 09 monitor)..
28e0: 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 .. (tasks:monit
28f0: 6f 72 2d 67 65 74 2d 73 74 61 72 74 5f 74 69 6d or-get-start_tim
2900: 65 20 20 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 e monitor)....
2910: 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d (tasks:monitor-
2920: 67 65 74 2d 6c 61 73 74 5f 75 70 64 61 74 65 20 get-last_update
2930: 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 20 28 74 monitor).... (t
2940: 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 asks:monitor-get
2950: 2d 68 6f 73 74 6e 61 6d 65 20 20 20 20 6d 6f 6e -hostname mon
2960: 69 74 6f 72 29 0a 09 09 09 20 20 28 74 61 73 6b itor).... (task
2970: 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 75 73 s:monitor-get-us
2980: 65 72 6e 61 6d 65 20 20 20 20 6d 6f 6e 69 74 6f ername monito
2990: 72 29 29 29 0a 09 09 6d 6f 6e 69 74 6f 72 73 29 r)))...monitors)
29a0: 0a 09 20 20 20 22 5c 6e 22 29 29 29 29 0a 20 20 .. "\n")))).
29b0: 20 0a 3b 3b 20 75 70 64 61 74 65 20 74 68 65 20 .;; update the
29c0: 6c 61 73 74 5f 75 70 64 61 74 65 20 66 69 65 6c last_update fiel
29d0: 64 20 77 69 74 68 20 74 68 65 20 63 75 72 72 65 d with the curre
29e0: 6e 74 20 74 69 6d 65 20 61 6e 64 0a 3b 3b 20 69 nt time and.;; i
29f0: 66 20 61 6e 79 20 6d 6f 6e 69 74 6f 72 73 20 61 f any monitors a
2a00: 70 70 65 61 72 20 64 65 61 64 2c 20 72 65 6d 6f ppear dead, remo
2a10: 76 65 20 74 68 65 6d 0a 23 3b 28 64 65 66 69 6e ve them.#;(defin
2a20: 65 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 e (tasks:monitor
2a30: 73 2d 75 70 64 61 74 65 20 6d 64 62 29 0a 20 20 s-update mdb).
2a40: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
2a50: 20 6d 64 62 20 22 55 50 44 41 54 45 20 6d 6f 6e mdb "UPDATE mon
2a60: 69 74 6f 72 73 20 53 45 54 20 6c 61 73 74 5f 75 itors SET last_u
2a70: 70 64 61 74 65 3d 73 74 72 66 74 69 6d 65 28 27 pdate=strftime('
2a80: 25 73 27 2c 27 6e 6f 77 27 29 20 57 48 45 52 45 %s','now') WHERE
2a90: 20 70 69 64 3d 3f 20 41 4e 44 20 68 6f 73 74 6e pid=? AND hostn
2aa0: 61 6d 65 3d 3f 3b 22 0a 09 09 09 20 20 28 63 75 ame=?;".... (cu
2ab0: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
2ac0: 29 0a 09 09 09 20 20 28 67 65 74 2d 68 6f 73 74 ).... (get-host
2ad0: 2d 6e 61 6d 65 29 29 0a 20 20 28 6c 65 74 20 28 -name)). (let (
2ae0: 28 64 65 61 64 6c 69 73 74 20 27 28 29 29 29 0a (deadlist '())).
2af0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
2b00: 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 -each-row. (
2b10: 6c 61 6d 62 64 61 20 28 69 64 20 70 69 64 20 68 lambda (id pid h
2b20: 6f 73 74 20 6c 61 73 74 2d 75 70 64 61 74 65 20 ost last-update
2b30: 64 65 6c 74 61 29 0a 20 20 20 20 20 20 20 28 70 delta). (p
2b40: 72 69 6e 74 20 22 47 6f 69 6e 67 20 74 6f 20 64 rint "Going to d
2b50: 65 6c 65 74 65 20 73 74 61 6c 65 20 72 65 63 6f elete stale reco
2b60: 72 64 20 66 6f 72 20 6d 6f 6e 69 74 6f 72 20 77 rd for monitor w
2b70: 69 74 68 20 70 69 64 20 22 20 70 69 64 20 22 20 ith pid " pid "
2b80: 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 20 22 on host " host "
2b90: 20 6c 61 73 74 20 75 70 64 61 74 65 64 20 22 20 last updated "
2ba0: 64 65 6c 74 61 20 22 20 73 65 63 6f 6e 64 73 20 delta " seconds
2bb0: 61 67 6f 22 29 0a 20 20 20 20 20 20 20 28 73 65 ago"). (se
2bc0: 74 21 20 64 65 61 64 6c 69 73 74 20 28 63 6f 6e t! deadlist (con
2bd0: 73 20 69 64 20 64 65 61 64 6c 69 73 74 29 29 29 s id deadlist)))
2be0: 0a 20 20 20 20 20 6d 64 62 20 0a 20 20 20 20 20 . mdb .
2bf0: 22 53 45 4c 45 43 54 20 69 64 2c 70 69 64 2c 68 "SELECT id,pid,h
2c00: 6f 73 74 6e 61 6d 65 2c 6c 61 73 74 5f 75 70 64 ostname,last_upd
2c10: 61 74 65 2c 73 74 72 66 74 69 6d 65 28 27 25 73 ate,strftime('%s
2c20: 27 2c 27 6e 6f 77 27 29 2d 6c 61 73 74 5f 75 70 ','now')-last_up
2c30: 64 61 74 65 20 41 53 20 64 65 6c 74 61 20 46 52 date AS delta FR
2c40: 4f 4d 20 6d 6f 6e 69 74 6f 72 73 20 57 48 45 52 OM monitors WHER
2c50: 45 20 64 65 6c 74 61 20 3e 20 37 30 30 3b 22 29 E delta > 700;")
2c60: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 . (sqlite3:ex
2c70: 65 63 75 74 65 20 6d 64 62 20 28 63 6f 6e 63 20 ecute mdb (conc
2c80: 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 6d 6f 6e "DELETE FROM mon
2c90: 69 74 6f 72 73 20 57 48 45 52 45 20 69 64 20 49 itors WHERE id I
2ca0: 4e 20 28 27 22 20 28 73 74 72 69 6e 67 2d 69 6e N ('" (string-in
2cb0: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 tersperse (map c
2cc0: 6f 6e 63 20 64 65 61 64 6c 69 73 74 29 20 22 27 onc deadlist) "'
2cd0: 2c 27 22 29 20 22 27 29 3b 22 29 29 29 0a 20 20 ,'") "');"))).
2ce0: 29 0a 23 3b 28 64 65 66 69 6e 65 20 28 74 61 73 ).#;(define (tas
2cf0: 6b 73 3a 72 65 67 69 73 74 65 72 2d 6d 6f 6e 69 ks:register-moni
2d00: 74 6f 72 20 64 62 20 70 6f 72 74 29 0a 20 20 28 tor db port). (
2d10: 6c 65 74 2a 20 28 28 70 69 64 20 28 63 75 72 72 let* ((pid (curr
2d20: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
2d30: 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 .. (hostname (ge
2d40: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name))..
2d50: 28 75 73 65 72 69 6e 66 6f 20 28 75 73 65 72 2d (userinfo (user-
2d60: 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 information (cur
2d70: 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 29 29 0a rent-user-id))).
2d80: 09 20 28 75 73 65 72 6e 61 6d 65 20 28 63 61 72 . (username (car
2d90: 20 75 73 65 72 69 6e 66 6f 29 29 29 0a 20 20 20 userinfo))).
2da0: 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 (print "Registe
2db0: 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 69 64 3a 20 r monitor, pid:
2dc0: 22 20 70 69 64 20 22 2c 20 68 6f 73 74 6e 61 6d " pid ", hostnam
2dd0: 65 3a 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 2c e: " hostname ",
2de0: 20 70 6f 72 74 3a 20 22 20 70 6f 72 74 20 22 2c port: " port ",
2df0: 20 75 73 65 72 6e 61 6d 65 3a 20 22 20 75 73 65 username: " use
2e00: 72 6e 61 6d 65 29 0a 20 20 20 20 28 73 71 6c 69 rname). (sqli
2e10: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
2e20: 49 4e 53 45 52 54 20 49 4e 54 4f 20 6d 6f 6e 69 INSERT INTO moni
2e30: 74 6f 72 73 20 28 70 69 64 2c 73 74 61 72 74 5f tors (pid,start_
2e40: 74 69 6d 65 2c 6c 61 73 74 5f 75 70 64 61 74 65 time,last_update
2e50: 2c 68 6f 73 74 6e 61 6d 65 2c 75 73 65 72 6e 61 ,hostname,userna
2e60: 6d 65 29 20 56 41 4c 55 45 53 20 28 3f 2c 73 74 me) VALUES (?,st
2e70: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
2e80: 27 29 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 '),strftime('%s'
2e90: 2c 27 6e 6f 77 27 29 2c 3f 2c 3f 29 3b 22 0a 09 ,'now'),?,?);"..
2ea0: 09 20 20 20 20 20 70 69 64 20 68 6f 73 74 6e 61 . pid hostna
2eb0: 6d 65 20 75 73 65 72 6e 61 6d 65 29 29 29 0a 0a me username)))..
2ec0: 23 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 #;(define (tasks
2ed0: 3a 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 2d 6d :get-num-alive-m
2ee0: 6f 6e 69 74 6f 72 73 20 6d 64 62 29 0a 20 20 28 onitors mdb). (
2ef0: 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a 20 20 let ((res 0)).
2f00: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
2f10: 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c ach-row . (l
2f20: 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 20 20 ambda (count).
2f30: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 63 (set! res c
2f40: 6f 75 6e 74 29 29 0a 20 20 20 20 20 6d 64 62 0a ount)). mdb.
2f50: 20 20 20 20 20 22 53 45 4c 45 43 54 20 63 6f 75 "SELECT cou
2f60: 6e 74 28 69 64 29 20 46 52 4f 4d 20 6d 6f 6e 69 nt(id) FROM moni
2f70: 74 6f 72 73 20 57 48 45 52 45 20 6c 61 73 74 5f tors WHERE last_
2f80: 75 70 64 61 74 65 20 3c 20 28 73 74 72 66 74 69 update < (strfti
2f90: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 20 2d me('%s','now') -
2fa0: 20 33 30 30 29 20 41 4e 44 20 75 73 65 72 6e 61 300) AND userna
2fb0: 6d 65 3d 3f 3b 22 0a 20 20 20 20 20 28 63 61 72 me=?;". (car
2fc0: 20 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 (user-informati
2fd0: 6f 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 on (current-user
2fe0: 2d 69 64 29 29 29 29 0a 20 20 20 20 72 65 73 29 -id)))). res)
2ff0: 29 0a 0a 3b 3b 20 0a 23 3b 28 64 65 66 69 6e 65 )..;; .#;(define
3000: 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 6d 6f (tasks:start-mo
3010: 6e 69 74 6f 72 20 64 62 20 6d 64 62 29 0a 20 20 nitor db mdb).
3020: 28 69 66 20 28 3e 20 28 74 61 73 6b 73 3a 67 65 (if (> (tasks:ge
3030: 74 2d 6e 75 6d 2d 61 6c 69 76 65 2d 6d 6f 6e 69 t-num-alive-moni
3040: 74 6f 72 73 20 6d 64 62 29 20 32 29 20 3b 3b 20 tors mdb) 2) ;;
3050: 68 61 76 65 20 74 77 6f 20 72 75 6e 6e 69 6e 67 have two running
3060: 2c 20 6e 6f 20 6e 65 65 64 20 66 6f 72 20 6d 6f , no need for mo
3070: 72 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a re. (debug:
3080: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 print-info 1 *de
3090: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
30a0: 22 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 6d 6f "Not starting mo
30b0: 6e 69 74 6f 72 2c 20 61 6c 72 65 61 64 79 20 68 nitor, already h
30c0: 61 76 65 20 6d 6f 72 65 20 74 68 61 6e 20 74 77 ave more than tw
30d0: 6f 20 72 75 6e 6e 69 6e 67 22 29 0a 20 20 20 20 o running").
30e0: 20 20 28 6c 65 74 2a 20 28 28 6d 65 67 61 74 65 (let* ((megate
30f0: 73 74 64 62 20 20 20 20 20 28 63 6f 6e 63 20 2a stdb (conc *
3100: 74 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 toppath* "/megat
3110: 65 73 74 2e 64 62 22 29 29 0a 09 20 20 20 20 20 est.db"))..
3120: 28 6d 6f 6e 69 74 6f 72 64 62 66 20 20 20 20 20 (monitordbf
3130: 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (conc (common:ge
3140: 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 20 2a 61 t-db-tmp-area *a
3150: 6c 6c 64 61 74 2a 29 20 22 2f 6d 6f 6e 69 74 6f lldat*) "/monito
3160: 72 2e 64 62 22 29 29 0a 09 20 20 20 20 20 28 6c r.db")).. (l
3170: 61 73 74 2d 64 62 2d 75 70 64 61 74 65 20 30 29 ast-db-update 0)
3180: 29 20 3b 3b 20 28 66 69 6c 65 2d 6d 6f 64 69 66 ) ;; (file-modif
3190: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6d 65 67 ication-time meg
31a0: 61 74 65 73 74 64 62 29 29 29 0a 09 28 74 61 73 atestdb)))..(tas
31b0: 6b 3a 72 65 67 69 73 74 65 72 2d 6d 6f 6e 69 74 k:register-monit
31c0: 6f 72 20 6d 64 62 29 0a 09 28 6c 65 74 20 6c 6f or mdb)..(let lo
31d0: 6f 70 20 28 28 63 6f 75 6e 74 20 20 20 20 20 20 op ((count
31e0: 30 29 0a 09 09 20 20 20 28 6e 65 78 74 2d 74 6f 0)... (next-to
31f0: 75 63 68 20 30 29 29 20 3b 3b 20 6e 65 78 74 2d uch 0)) ;; next-
3200: 74 6f 75 63 68 20 69 73 20 74 68 65 20 74 69 6d touch is the tim
3210: 65 20 77 68 65 72 65 20 77 65 20 6e 65 65 64 20 e where we need
3220: 74 6f 20 75 70 64 61 74 65 20 6c 61 73 74 5f 75 to update last_u
3230: 70 64 61 74 65 0a 09 20 20 3b 3b 20 69 66 20 74 pdate.. ;; if t
3240: 68 65 20 64 62 20 68 61 73 20 62 65 65 6e 20 6d he db has been m
3250: 6f 64 69 66 69 65 64 20 77 65 27 64 20 62 65 73 odified we'd bes
3260: 74 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 61 t look at the ta
3270: 73 6b 20 71 75 65 75 65 0a 09 20 20 28 6c 65 74 sk queue.. (let
3280: 20 28 28 6d 6f 64 74 69 6d 65 20 28 66 69 6c 65 ((modtime (file
3290: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
32a0: 6d 65 20 6d 65 67 61 74 65 73 74 64 62 70 61 74 me megatestdbpat
32b0: 68 20 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 h ))).. (if (
32c0: 3e 20 6d 6f 64 74 69 6d 65 20 6c 61 73 74 2d 64 > modtime last-d
32d0: 62 2d 75 70 64 61 74 65 29 0a 09 09 28 74 61 73 b-update)...(tas
32e0: 6b 73 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 ks:process-queue
32f0: 20 64 62 29 29 20 3b 3b 20 42 52 4f 4b 45 4e 2e db)) ;; BROKEN.
3300: 20 6d 64 62 20 6c 61 73 74 2d 64 62 2d 75 70 64 mdb last-db-upd
3310: 61 74 65 20 6d 65 67 61 74 65 73 74 64 62 20 6e ate megatestdb n
3320: 65 78 74 2d 74 6f 75 63 68 29 29 0a 09 20 20 20 ext-touch))..
3330: 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 50 6f 73 ;; WARNING: Pos
3340: 73 69 62 6c 65 20 72 61 63 65 20 63 6f 6e 64 69 sible race condi
3350: 74 6f 6e 20 68 65 72 65 21 21 0a 09 20 20 20 20 ton here!!..
3360: 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 75 ;; should this u
3370: 70 64 61 74 65 20 62 65 20 69 6d 6d 65 64 69 61 pdate be immedia
3380: 74 65 6c 79 20 61 66 74 65 72 20 74 68 65 20 74 tely after the t
3390: 61 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 63 ask-get-action c
33a0: 61 6c 6c 20 61 62 6f 76 65 3f 0a 09 20 20 20 20 all above?..
33b0: 28 69 66 20 28 3e 20 28 63 75 72 72 65 6e 74 2d (if (> (current-
33c0: 73 65 63 6f 6e 64 73 29 20 6e 65 78 74 2d 74 6f seconds) next-to
33d0: 75 63 68 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 uch)...(begin...
33e0: 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 (tasks:monitor
33f0: 73 2d 75 70 64 61 74 65 20 6d 64 62 29 0a 09 09 s-update mdb)...
3400: 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 (loop (+ count
3410: 20 31 29 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 1)(+ (current-s
3420: 65 63 6f 6e 64 73 29 20 32 34 30 29 29 29 0a 09 econds) 240)))..
3430: 09 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 .(loop (+ count
3440: 31 29 20 6e 65 78 74 2d 74 6f 75 63 68 29 29 29 1) next-touch)))
3450: 29 29 29 29 0a 20 20 20 20 20 20 0a 3b 3b 3d 3d )))). .;;==
3460: 3d 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 0a 3b 3b 20 54 20 41 20 53 20 4b 20 ====.;; T A S K
34b0: 53 20 20 20 51 20 55 20 45 20 55 20 45 0a 3b 3b S Q U E U E.;;
34c0: 0a 3b 3b 20 20 20 4e 4f 54 45 3a 3a 20 54 68 65 .;; NOTE:: The
34d0: 73 65 20 6f 70 65 72 61 74 65 20 6f 6e 20 74 61 se operate on ta
34e0: 73 6b 5f 71 75 65 75 65 20 77 68 69 63 68 20 69 sk_queue which i
34f0: 73 20 69 6e 20 6d 61 69 6e 2e 64 62 0a 3b 3b 0a s in main.db.;;.
3500: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
3510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3540: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 ========..;; NOT
3550: 45 3a 20 49 74 20 6d 69 67 68 74 20 62 65 20 67 E: It might be g
3560: 6f 6f 64 20 74 6f 20 61 64 64 20 6f 6e 65 20 6d ood to add one m
3570: 6f 72 65 20 6c 61 79 65 72 20 6f 66 20 63 68 65 ore layer of che
3580: 63 6b 69 6e 67 20 74 6f 20 65 6e 73 75 72 65 0a cking to ensure.
3590: 3b 3b 20 20 20 20 20 20 20 74 68 61 74 20 6e 6f ;; that no
35a0: 20 74 61 73 6b 20 67 65 74 73 20 72 75 6e 20 69 task gets run i
35b0: 6e 20 70 61 72 61 6c 6c 65 6c 2e 0a 0a 3b 3b 20 n parallel...;;
35c0: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
35d0: 52 59 20 4b 45 59 2c 0a 3b 3b 20 61 63 74 69 6f RY KEY,.;; actio
35e0: 6e 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 n TEXT DEFAULT '
35f0: 27 2c 0a 3b 3b 20 6f 77 6e 65 72 20 54 45 58 54 ',.;; owner TEXT
3600: 2c 0a 3b 3b 20 73 74 61 74 65 20 54 45 58 54 20 ,.;; state TEXT
3610: 44 45 46 41 55 4c 54 20 27 6e 65 77 27 2c 0a 3b DEFAULT 'new',.;
3620: 3b 20 74 61 72 67 65 74 20 54 45 58 54 20 44 45 ; target TEXT DE
3630: 46 41 55 4c 54 20 27 27 2c 0a 3b 3b 20 6e 61 6d FAULT '',.;; nam
3640: 65 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 e TEXT DEFAULT '
3650: 27 2c 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 54 ',.;; testpatt T
3660: 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a EXT DEFAULT '',.
3670: 3b 3b 20 6b 65 79 6c 6f 63 6b 20 54 45 58 54 2c ;; keylock TEXT,
3680: 0a 3b 3b 20 70 61 72 61 6d 73 20 54 45 58 54 2c .;; params TEXT,
3690: 0a 3b 3b 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d .;; creation_tim
36a0: 65 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 e TIMESTAMP DEFA
36b0: 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 ULT (strftime('%
36c0: 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 3b 3b 20 65 s','now')),.;; e
36d0: 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 54 49 xecution_time TI
36e0: 4d 45 53 54 41 4d 50 29 3b 0a 0a 0a 3b 3b 20 72 MESTAMP);...;; r
36f0: 65 67 69 73 74 65 72 20 61 20 74 61 73 6b 0a 23 egister a task.#
3700: 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a ;(define (tasks:
3710: 61 64 64 20 64 62 73 74 72 75 63 74 20 61 63 74 add dbstruct act
3720: 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 ion owner target
3730: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 runname testpat
3740: 74 20 70 61 72 61 6d 73 29 0a 20 20 28 64 62 3a t params). (db:
3750: 77 69 74 68 2d 64 62 20 0a 20 20 20 64 62 73 74 with-db . dbst
3760: 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 28 6c ruct #f #t. (l
3770: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
3780: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
3790: 20 64 62 20 22 49 4e 53 45 52 54 20 49 4e 54 4f db "INSERT INTO
37a0: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 28 61 63 tasks_queue (ac
37b0: 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 tion,owner,state
37c0: 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 ,target,name,tes
37d0: 74 70 61 74 74 2c 70 61 72 61 6d 73 2c 63 72 65 tpatt,params,cre
37e0: 61 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 ation_time,execu
37f0: 74 69 6f 6e 5f 74 69 6d 65 29 0a 20 20 20 20 20 tion_time).
3800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3810: 20 20 20 20 20 20 20 20 56 41 4c 55 45 53 20 28 VALUES (
3820: 3f 2c 3f 2c 27 6e 65 77 27 2c 3f 2c 3f 2c 3f 2c ?,?,'new',?,?,?,
3830: 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c ?,strftime('%s',
3840: 27 6e 6f 77 27 29 2c 30 29 3b 22 20 0a 09 09 20 'now'),0);" ...
3850: 20 20 20 20 20 61 63 74 69 6f 6e 0a 09 09 20 20 action...
3860: 20 20 20 20 6f 77 6e 65 72 0a 09 09 20 20 20 20 owner...
3870: 20 20 74 61 72 67 65 74 0a 09 09 20 20 20 20 20 target...
3880: 20 72 75 6e 6e 61 6d 65 0a 09 09 20 20 20 20 20 runname...
3890: 20 74 65 73 74 70 61 74 74 0a 09 09 20 20 20 20 testpatt...
38a0: 20 20 28 69 66 20 70 61 72 61 6d 73 20 70 61 72 (if params par
38b0: 61 6d 73 20 22 22 29 29 29 29 29 0a 0a 23 3b 28 ams "")))))..#;(
38c0: 64 65 66 69 6e 65 20 28 6b 65 79 73 3a 6b 65 79 define (keys:key
38d0: 2d 76 61 6c 73 2d 68 61 73 68 2d 3e 74 61 72 67 -vals-hash->targ
38e0: 65 74 20 6b 65 79 73 20 6b 65 79 2d 70 61 72 61 et keys key-para
38f0: 6d 73 29 0a 20 20 28 6c 65 74 20 28 28 74 6d 70 ms). (let ((tmp
3900: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3910: 2f 64 65 66 61 75 6c 74 20 6b 65 79 2d 70 61 72 /default key-par
3920: 61 6d 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ams (vector-ref
3930: 28 63 61 72 20 6b 65 79 73 29 20 30 29 20 22 22 (car keys) 0) ""
3940: 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 ))). (if (> (
3950: 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 31 29 0a length keys) 1).
3960: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
3970: 64 61 20 28 6b 65 79 29 0a 09 09 20 20 20 20 28 da (key)... (
3980: 73 65 74 21 20 74 6d 70 20 28 63 6f 6e 63 20 74 set! tmp (conc t
3990: 6d 70 20 22 2f 22 20 28 68 61 73 68 2d 74 61 62 mp "/" (hash-tab
39a0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6b le-ref/default k
39b0: 65 79 2d 70 61 72 61 6d 73 20 28 76 65 63 74 6f ey-params (vecto
39c0: 72 2d 72 65 66 20 6b 65 79 20 30 29 20 22 22 29 r-ref key 0) "")
39d0: 29 29 29 0a 09 09 20 20 28 63 64 72 20 6b 65 79 )))... (cdr key
39e0: 73 29 29 29 0a 20 20 20 20 74 6d 70 29 29 0a 09 s))). tmp))..
39f0: 09 09 09 09 09 09 09 0a 3b 3b 20 66 6f 72 20 75 ........;; for u
3a00: 73 65 20 66 72 6f 6d 20 74 68 65 20 67 75 69 2c se from the gui,
3a10: 20 6e 6f 74 20 70 6f 72 74 65 64 0a 3b 3b 0a 3b not ported.;;.;
3a20: 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ; (define (tasks
3a30: 3a 61 64 64 2d 66 72 6f 6d 2d 70 61 72 61 6d 73 :add-from-params
3a40: 20 6d 64 62 20 61 63 74 69 6f 6e 20 6b 65 79 73 mdb action keys
3a50: 20 6b 65 79 2d 70 61 72 61 6d 73 20 76 61 72 2d key-params var-
3a60: 70 61 72 61 6d 73 29 0a 3b 3b 20 20 20 28 6c 65 params).;; (le
3a70: 74 20 28 28 74 61 72 67 65 74 20 20 20 20 28 6b t ((target (k
3a80: 65 79 73 3a 6b 65 79 2d 76 61 6c 73 2d 68 61 73 eys:key-vals-has
3a90: 68 2d 3e 74 61 72 67 65 74 20 6b 65 79 73 20 6b h->target keys k
3aa0: 65 79 2d 70 61 72 61 6d 73 29 29 0a 3b 3b 20 09 ey-params)).;; .
3ab0: 28 6f 77 6e 65 72 20 20 20 20 20 28 63 61 72 20 (owner (car
3ac0: 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f (user-informatio
3ad0: 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d n (current-user-
3ae0: 69 64 29 29 29 29 0a 3b 3b 20 09 28 72 75 6e 6e id)))).;; .(runn
3af0: 61 6d 65 20 20 20 28 68 61 73 68 2d 74 61 62 6c ame (hash-tabl
3b00: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 76 61 e-ref/default va
3b10: 72 2d 70 61 72 61 6d 73 20 22 72 75 6e 6e 61 6d r-params "runnam
3b20: 65 22 20 23 66 29 29 0a 3b 3b 20 09 28 74 65 73 e" #f)).;; .(tes
3b30: 74 70 61 74 74 73 20 28 68 61 73 68 2d 74 61 62 tpatts (hash-tab
3b40: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 76 le-ref/default v
3b50: 61 72 2d 70 61 72 61 6d 73 20 22 74 65 73 74 70 ar-params "testp
3b60: 61 74 74 73 22 20 22 25 22 29 29 0a 3b 3b 20 09 atts" "%")).;; .
3b70: 28 70 61 72 61 6d 73 20 20 20 20 28 68 61 73 68 (params (hash
3b80: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3b90: 6c 74 20 76 61 72 2d 70 61 72 61 6d 73 20 22 70 lt var-params "p
3ba0: 61 72 61 6d 73 22 20 20 20 20 22 22 29 29 29 0a arams" ""))).
3bb0: 3b 3b 20 20 20 20 20 28 74 61 73 6b 73 3a 61 64 ;; (tasks:ad
3bc0: 64 20 6d 64 62 20 61 63 74 69 6f 6e 20 6f 77 6e d mdb action own
3bd0: 65 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d er target runnam
3be0: 65 20 74 65 73 74 70 61 74 74 73 20 70 61 72 61 e testpatts para
3bf0: 6d 73 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e ms)))..;; return
3c00: 20 6f 6e 65 20 74 61 73 6b 20 66 72 6f 6d 20 74 one task from t
3c10: 68 6f 73 65 20 77 68 6f 20 61 72 65 20 27 6e 65 hose who are 'ne
3c20: 77 27 20 4f 52 20 27 77 61 69 74 69 6e 67 27 20 w' OR 'waiting'
3c30: 41 4e 44 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 AND more than 10
3c40: 73 65 63 20 6f 6c 64 0a 3b 3b 0a 23 3b 28 64 65 sec old.;;.#;(de
3c50: 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 6e 61 67 fine (tasks:snag
3c60: 2d 61 2d 74 61 73 6b 20 64 62 73 74 72 75 63 74 -a-task dbstruct
3c70: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 20 ). (let ((res
3c80: 20 20 23 66 29 0a 09 28 6b 65 79 74 78 74 20 28 #f)..(keytxt (
3c90: 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 conc (current-pr
3ca0: 6f 63 65 73 73 2d 69 64 29 20 22 2d 22 20 28 67 ocess-id) "-" (g
3cb0: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d et-host-name) "-
3cc0: 22 20 28 63 61 72 20 28 75 73 65 72 2d 69 6e 66 " (car (user-inf
3cd0: 6f 72 6d 61 74 69 6f 6e 20 28 63 75 72 72 65 6e ormation (curren
3ce0: 74 2d 75 73 65 72 2d 69 64 29 29 29 29 29 29 0a t-user-id)))))).
3cf0: 20 20 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a (db:with-db.
3d00: 20 20 20 20 20 64 62 73 74 72 75 63 74 20 23 66 dbstruct #f
3d10: 20 23 74 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 #t. (lambda
3d20: 20 28 64 62 29 0a 20 20 20 20 20 20 20 3b 3b 20 (db). ;;
3d30: 66 69 72 73 74 20 72 61 6e 64 6f 6d 6c 79 20 73 first randomly s
3d40: 65 74 20 61 20 6e 65 77 20 74 6f 20 70 69 64 2d et a new to pid-
3d50: 68 6f 73 74 6e 61 6d 65 2d 68 6f 73 74 6e 61 6d hostname-hostnam
3d60: 65 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 e. (sqlite
3d70: 33 3a 65 78 65 63 75 74 65 0a 09 64 62 20 0a 09 3:execute..db ..
3d80: 22 55 50 44 41 54 45 20 74 61 73 6b 73 5f 71 75 "UPDATE tasks_qu
3d90: 65 75 65 20 53 45 54 20 6b 65 79 6c 6f 63 6b 3d eue SET keylock=
3da0: 3f 20 57 48 45 52 45 20 69 64 20 49 4e 0a 20 20 ? WHERE id IN.
3db0: 20 20 20 20 20 20 20 20 20 28 53 45 4c 45 43 54 (SELECT
3dc0: 20 69 64 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 id FROM tasks_q
3dd0: 75 65 75 65 20 0a 20 20 20 20 20 20 20 20 20 20 ueue .
3de0: 20 20 20 20 57 48 45 52 45 20 73 74 61 74 65 3d WHERE state=
3df0: 27 6e 65 77 27 20 4f 52 20 0a 20 20 20 20 20 20 'new' OR .
3e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
3e10: 74 61 74 65 3d 27 77 61 69 74 69 6e 67 27 20 41 tate='waiting' A
3e20: 4e 44 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 ND (strftime('%s
3e30: 27 2c 27 6e 6f 77 27 29 2d 65 78 65 63 75 74 69 ','now')-executi
3e40: 6f 6e 5f 74 69 6d 65 29 20 3e 20 31 30 29 20 4f on_time) > 10) O
3e50: 52 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 R.
3e60: 20 20 20 20 20 20 73 74 61 74 65 3d 27 72 65 73 state='res
3e70: 65 74 27 0a 20 20 20 20 20 20 20 20 20 20 20 20 et'.
3e80: 20 20 4f 52 44 45 52 20 42 59 20 52 41 4e 44 4f ORDER BY RANDO
3e90: 4d 28 29 20 4c 49 4d 49 54 20 31 29 3b 22 20 6b M() LIMIT 1);" k
3ea0: 65 79 74 78 74 29 0a 0a 20 20 20 20 20 20 20 28 eytxt).. (
3eb0: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
3ec0: 2d 72 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 -row..(lambda (i
3ed0: 64 20 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 74 d . rem).. (set
3ee0: 21 20 72 65 73 20 28 61 70 70 6c 79 20 76 65 63 ! res (apply vec
3ef0: 74 6f 72 20 69 64 20 72 65 6d 29 29 29 0a 09 64 tor id rem)))..d
3f00: 62 0a 09 22 53 45 4c 45 43 54 20 69 64 2c 61 63 b.."SELECT id,ac
3f10: 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 tion,owner,state
3f20: 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 ,target,name,tes
3f30: 74 2c 69 74 65 6d 2c 70 61 72 61 6d 73 2c 63 72 t,item,params,cr
3f40: 65 61 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 eation_time,exec
3f50: 75 74 69 6f 6e 5f 74 69 6d 65 20 46 52 4f 4d 20 ution_time FROM
3f60: 74 61 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 tasks_queue WHER
3f70: 45 20 6b 65 79 6c 6f 63 6b 3d 3f 20 4f 52 44 45 E keylock=? ORDE
3f80: 52 20 42 59 20 65 78 65 63 75 74 69 6f 6e 5f 74 R BY execution_t
3f90: 69 6d 65 20 41 53 43 20 4c 49 4d 49 54 20 31 3b ime ASC LIMIT 1;
3fa0: 22 20 6b 65 79 74 78 74 29 0a 20 20 20 20 20 20 " keytxt).
3fb0: 20 28 69 66 20 72 65 73 20 3b 3b 20 79 65 70 2c (if res ;; yep,
3fc0: 20 68 61 76 65 20 77 6f 72 6b 20 74 6f 20 62 65 have work to be
3fd0: 20 64 6f 6e 65 0a 09 20 20 20 28 62 65 67 69 6e done.. (begin
3fe0: 0a 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a .. (sqlite3:
3ff0: 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 execute db "UPDA
4000: 54 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 TE tasks_queue S
4010: 45 54 20 73 74 61 74 65 3d 27 69 6e 70 72 6f 67 ET state='inprog
4020: 72 65 73 73 27 2c 65 78 65 63 75 74 69 6f 6e 5f ress',execution_
4030: 74 69 6d 65 3d 73 74 72 66 74 69 6d 65 28 27 25 time=strftime('%
4040: 73 27 2c 27 6e 6f 77 27 29 20 57 48 45 52 45 20 s','now') WHERE
4050: 69 64 3d 3f 3b 22 0a 09 09 09 20 20 20 20 20 20 id=?;"....
4060: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
4070: 69 64 20 72 65 73 29 29 0a 09 20 20 20 20 20 72 id res)).. r
4080: 65 73 29 0a 09 20 20 20 23 66 29 29 29 29 29 0a es).. #f))))).
4090: 0a 23 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b .#;(define (task
40a0: 73 3a 72 65 73 65 74 2d 73 74 75 63 6b 2d 74 61 s:reset-stuck-ta
40b0: 73 6b 73 20 64 62 73 74 72 75 63 74 29 0a 20 20 sks dbstruct).
40c0: 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 29 (let ((res '()))
40d0: 0a 20 20 20 20 28 64 62 3a 77 69 74 68 2d 64 62 . (db:with-db
40e0: 0a 20 20 20 20 20 64 62 73 74 72 75 63 74 20 23 . dbstruct #
40f0: 66 20 23 74 0a 20 20 20 20 20 28 6c 61 6d 62 64 f #t. (lambd
4100: 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 28 73 a (db). (s
4110: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
4120: 72 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 64 row..(lambda (id
4130: 20 64 65 6c 74 61 29 0a 09 20 20 28 73 65 74 21 delta).. (set!
4140: 20 72 65 73 20 28 63 6f 6e 73 20 69 64 20 72 65 res (cons id re
4150: 73 29 29 29 0a 09 64 62 0a 09 22 53 45 4c 45 43 s)))..db.."SELEC
4160: 54 20 69 64 2c 73 74 72 66 74 69 6d 65 28 27 25 T id,strftime('%
4170: 73 27 2c 27 6e 6f 77 27 29 2d 65 78 65 63 75 74 s','now')-execut
4180: 69 6f 6e 5f 74 69 6d 65 20 41 53 20 64 65 6c 74 ion_time AS delt
4190: 61 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 a FROM tasks_que
41a0: 75 65 20 57 48 45 52 45 20 73 74 61 74 65 3d 27 ue WHERE state='
41b0: 69 6e 70 72 6f 67 72 65 73 73 27 20 41 4e 44 20 inprogress' AND
41c0: 64 65 6c 74 61 3e 37 30 30 20 4f 52 44 45 52 20 delta>700 ORDER
41d0: 42 59 20 64 65 6c 74 61 20 44 45 53 43 20 4c 49 BY delta DESC LI
41e0: 4d 49 54 20 32 3b 22 29 0a 20 20 20 20 20 20 20 MIT 2;").
41f0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
4200: 20 0a 09 64 62 20 0a 09 28 63 6f 6e 63 20 22 55 ..db ..(conc "U
4210: 50 44 41 54 45 20 74 61 73 6b 73 5f 71 75 65 75 PDATE tasks_queu
4220: 65 20 53 45 54 20 73 74 61 74 65 3d 27 72 65 73 e SET state='res
4230: 65 74 27 20 57 48 45 52 45 20 69 64 20 49 4e 20 et' WHERE id IN
4240: 28 27 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 ('" (string-inte
4250: 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e rsperse (map con
4260: 63 20 72 65 73 29 20 22 27 2c 27 22 29 20 22 27 c res) "','") "'
4270: 29 3b 22 29 0a 09 29 29 29 29 29 0a 0a 3b 3b 20 );")..)))))..;;
4280: 72 65 74 75 72 6e 20 61 6c 6c 20 74 61 73 6b 73 return all tasks
4290: 20 69 6e 20 74 68 65 20 74 61 73 6b 73 5f 71 75 in the tasks_qu
42a0: 65 75 65 20 74 61 62 6c 65 0a 3b 3b 0a 23 3b 28 eue table.;;.#;(
42b0: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 67 65 define (tasks:ge
42c0: 74 2d 74 61 73 6b 73 20 64 62 73 74 72 75 63 74 t-tasks dbstruct
42d0: 20 74 79 70 65 73 20 73 74 61 74 65 73 29 0a 20 types states).
42e0: 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 (let ((res '())
42f0: 29 0a 20 20 20 20 28 64 62 3a 77 69 74 68 2d 64 ). (db:with-d
4300: 62 0a 20 20 20 20 20 64 62 73 74 72 75 63 74 20 b. dbstruct
4310: 23 66 20 23 66 0a 20 20 20 20 20 28 6c 61 6d 62 #f #f. (lamb
4320: 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 28 da (db). (
4330: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
4340: 2d 72 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 -row..(lambda (i
4350: 64 20 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 74 d . rem).. (set
4360: 21 20 72 65 73 20 28 63 6f 6e 73 20 28 61 70 70 ! res (cons (app
4370: 6c 79 20 76 65 63 74 6f 72 20 69 64 20 72 65 6d ly vector id rem
4380: 29 20 72 65 73 29 29 29 0a 09 64 62 0a 09 28 63 ) res)))..db..(c
4390: 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 64 2c 61 onc "SELECT id,a
43a0: 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 ction,owner,stat
43b0: 65 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 e,target,name,te
43c0: 73 74 2c 69 74 65 6d 2c 70 61 72 61 6d 73 2c 63 st,item,params,c
43d0: 72 65 61 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 reation_time,exe
43e0: 63 75 74 69 6f 6e 5f 74 69 6d 65 20 0a 20 20 20 cution_time .
43f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 F
4400: 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 ROM tasks_queue
4410: 22 0a 09 20 20 20 20 20 20 3b 3b 20 57 48 45 52 ".. ;; WHER
4420: 45 20 20 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 E .. ;;
4430: 73 74 61 74 65 20 49 4e 20 22 20 73 74 61 74 65 state IN " state
4440: 73 73 74 72 20 22 20 41 4e 44 20 0a 09 20 20 20 sstr " AND ..
4450: 20 20 20 3b 3b 20 20 20 61 63 74 69 6f 6e 20 49 ;; action I
4460: 4e 20 22 20 61 63 74 69 6f 6e 73 73 74 72 20 0a N " actionsstr .
4470: 09 20 20 20 20 20 20 22 20 4f 52 44 45 52 20 42 . " ORDER B
4480: 59 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 20 Y creation_time
4490: 44 45 53 43 3b 22 29 29 0a 20 20 20 20 20 20 20 DESC;")).
44a0: 72 65 73 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 res))))..#;(defi
44b0: 6e 65 20 28 74 61 73 6b 73 3a 67 65 74 2d 6c 61 ne (tasks:get-la
44c0: 73 74 20 64 62 73 74 72 75 63 74 20 74 61 72 67 st dbstruct targ
44d0: 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c et runname). (l
44e0: 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 et ((res #f)).
44f0: 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 (db:with-db.
4500: 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 dbstruct #f #
4510: 66 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 f. (lambda (
4520: 64 62 29 0a 20 20 20 20 20 20 20 28 73 71 6c 69 db). (sqli
4530: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
4540: 0a 09 28 6c 61 6d 62 64 61 20 28 69 64 20 2e 20 ..(lambda (id .
4550: 72 65 6d 29 0a 09 20 20 28 73 65 74 21 20 72 65 rem).. (set! re
4560: 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 s (apply vector
4570: 69 64 20 72 65 6d 29 29 29 0a 09 64 62 0a 09 28 id rem)))..db..(
4580: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 64 2c conc "SELECT id,
4590: 61 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 action,owner,sta
45a0: 74 65 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 te,target,name,t
45b0: 65 73 74 70 61 74 74 2c 6b 65 79 6c 6f 63 6b 2c estpatt,keylock,
45c0: 70 61 72 61 6d 73 2c 63 72 65 61 74 69 6f 6e 5f params,creation_
45d0: 74 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e 5f 74 time,execution_t
45e0: 69 6d 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 ime .
45f0: 20 20 20 20 20 20 20 46 52 4f 4d 20 74 61 73 6b FROM task
4600: 73 5f 71 75 65 75 65 20 0a 20 09 20 20 20 20 20 s_queue . .
4610: 20 20 57 48 45 52 45 20 20 0a 09 20 20 20 20 20 WHERE ..
4620: 20 20 20 74 61 72 67 65 74 20 3d 20 3f 20 41 4e target = ? AN
4630: 44 20 6e 61 6d 65 20 3d 3f 0a 09 20 20 20 20 20 D name =?..
4640: 20 20 4f 52 44 45 52 20 42 59 20 63 72 65 61 74 ORDER BY creat
4650: 69 6f 6e 5f 74 69 6d 65 20 44 45 53 43 20 4c 49 ion_time DESC LI
4660: 4d 49 54 20 31 3b 22 29 0a 09 74 61 72 67 65 74 MIT 1;")..target
4670: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 runname).
4680: 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 72 65 6d res))))..;; rem
4690: 6f 76 65 20 74 61 73 6b 73 20 67 69 76 65 6e 20 ove tasks given
46a0: 62 79 20 61 20 73 74 72 69 6e 67 20 6f 66 20 6e by a string of n
46b0: 75 6d 62 65 72 73 20 63 6f 6d 6d 61 20 73 65 70 umbers comma sep
46c0: 61 72 61 74 65 64 0a 23 3b 28 64 65 66 69 6e 65 arated.#;(define
46d0: 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d 71 (tasks:remove-q
46e0: 75 65 75 65 2d 65 6e 74 72 69 65 73 20 64 62 73 ueue-entries dbs
46f0: 74 72 75 63 74 20 74 61 73 6b 2d 69 64 73 29 0a truct task-ids).
4700: 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 (db:with-db.
4710: 20 64 62 73 74 72 75 63 74 20 23 66 20 23 74 0a dbstruct #f #t.
4720: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a (lambda (db).
4730: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 (sqlite3:ex
4740: 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 ecute db (conc "
4750: 44 45 4c 45 54 45 20 46 52 4f 4d 20 74 61 73 6b DELETE FROM task
4760: 73 5f 71 75 65 75 65 20 57 48 45 52 45 20 69 64 s_queue WHERE id
4770: 20 49 4e 20 28 22 20 74 61 73 6b 2d 69 64 73 20 IN (" task-ids
4780: 22 29 3b 22 29 29 29 29 29 0a 0a 23 3b 28 64 65 ");")))))..#;(de
4790: 66 69 6e 65 20 28 74 61 73 6b 73 3a 70 72 6f 63 fine (tasks:proc
47a0: 65 73 73 2d 71 75 65 75 65 20 64 62 73 74 72 75 ess-queue dbstru
47b0: 63 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 61 ct). (let* ((ta
47c0: 73 6b 20 20 20 28 74 61 73 6b 73 3a 73 6e 61 67 sk (tasks:snag
47d0: 2d 61 2d 74 61 73 6b 20 64 62 73 74 72 75 63 74 -a-task dbstruct
47e0: 29 29 0a 09 20 28 61 63 74 69 6f 6e 20 28 69 66 )).. (action (if
47f0: 20 74 61 73 6b 20 28 74 61 73 6b 73 3a 74 61 73 task (tasks:tas
4800: 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 74 61 73 k-get-action tas
4810: 6b 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 k) #f))). (if
4820: 20 61 63 74 69 6f 6e 20 28 70 72 69 6e 74 20 22 action (print "
4830: 74 61 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 75 tasks:process-qu
4840: 65 75 65 20 74 61 73 6b 3a 20 22 20 74 61 73 6b eue task: " task
4850: 29 29 0a 20 20 20 20 28 69 66 20 61 63 74 69 6f )). (if actio
4860: 6e 0a 09 28 63 61 73 65 20 28 73 74 72 69 6e 67 n..(case (string
4870: 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 69 6f 6e 29 ->symbol action)
4880: 0a 09 20 20 28 28 72 75 6e 29 20 20 20 20 20 20 .. ((run)
4890: 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 72 75 (tasks:start-ru
48a0: 6e 20 20 20 20 20 64 62 73 74 72 75 63 74 20 74 n dbstruct t
48b0: 61 73 6b 29 29 0a 09 20 20 28 28 72 65 6d 6f 76 ask)).. ((remov
48c0: 65 29 20 20 20 20 28 74 61 73 6b 73 3a 72 65 6d e) (tasks:rem
48d0: 6f 76 65 2d 72 75 6e 73 20 20 20 64 62 73 74 72 ove-runs dbstr
48e0: 75 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 28 uct task)).. ((
48f0: 6c 6f 63 6b 29 20 20 20 20 20 20 28 74 61 73 6b lock) (task
4900: 73 3a 6c 6f 63 6b 2d 72 75 6e 73 20 20 20 20 20 s:lock-runs
4910: 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a dbstruct task)).
4920: 09 20 20 3b 3b 20 28 28 6d 6f 6e 69 74 6f 72 29 . ;; ((monitor)
4930: 20 20 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d (tasks:start-
4940: 6d 6f 6e 69 74 6f 72 20 64 62 20 74 61 73 6b 29 monitor db task)
4950: 29 0a 09 20 20 28 28 72 6f 6c 6c 75 70 29 20 20 ).. ((rollup)
4960: 20 20 28 74 61 73 6b 73 3a 72 6f 6c 6c 75 70 2d (tasks:rollup-
4970: 72 75 6e 73 20 20 20 64 62 73 74 72 75 63 74 20 runs dbstruct
4980: 74 61 73 6b 29 29 0a 09 20 20 28 28 75 70 64 61 task)).. ((upda
4990: 74 65 6d 65 74 61 29 28 74 61 73 6b 73 3a 75 70 temeta)(tasks:up
49a0: 64 61 74 65 2d 6d 65 74 61 20 20 20 64 62 73 74 date-meta dbst
49b0: 72 75 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 ruct task)).. (
49c0: 28 6b 69 6c 6c 29 20 20 20 20 20 20 28 74 61 73 (kill) (tas
49d0: 6b 73 3a 6b 69 6c 6c 2d 6d 6f 6e 69 74 6f 72 73 ks:kill-monitors
49e0: 20 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 dbstruct task))
49f0: 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 ))))..#;(define
4a00: 28 74 61 73 6b 73 3a 74 61 73 6b 73 2d 3e 74 65 (tasks:tasks->te
4a10: 78 74 20 74 61 73 6b 73 29 0a 20 20 28 6c 65 74 xt tasks). (let
4a20: 20 28 28 66 6d 74 73 74 72 20 22 7e 31 30 61 7e ((fmtstr "~10a~
4a30: 31 30 61 7e 31 30 61 7e 31 32 61 7e 32 30 61 7e 10a~10a~12a~20a~
4a40: 31 32 61 7e 31 32 61 7e 31 30 61 22 29 29 0a 20 12a~12a~10a")).
4a50: 20 20 20 28 63 6f 6e 63 20 28 66 6f 72 6d 61 74 (conc (format
4a60: 20 23 66 20 66 6d 74 73 74 72 20 22 69 64 22 20 #f fmtstr "id"
4a70: 22 61 63 74 69 6f 6e 22 20 22 6f 77 6e 65 72 22 "action" "owner"
4a80: 20 22 73 74 61 74 65 22 20 22 74 61 72 67 65 74 "state" "target
4a90: 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 74 65 73 " "runname" "tes
4aa0: 74 70 61 74 74 73 22 20 22 70 61 72 61 6d 73 22 tpatts" "params"
4ab0: 29 20 22 5c 6e 22 0a 09 20 20 28 73 74 72 69 6e ) "\n".. (strin
4ac0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
4ad0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
4ae0: 28 74 61 73 6b 29 0a 09 09 20 20 28 66 6f 72 6d (task)... (form
4af0: 61 74 20 23 66 20 66 6d 74 73 74 72 0a 09 09 09 at #f fmtstr....
4b00: 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 (tasks:task-ge
4b10: 74 2d 69 64 20 20 20 20 20 74 61 73 6b 29 0a 09 t-id task)..
4b20: 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d .. (tasks:task-
4b30: 67 65 74 2d 61 63 74 69 6f 6e 20 74 61 73 6b 29 get-action task)
4b40: 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 .... (tasks:tas
4b50: 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 k-get-owner tas
4b60: 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 k).... (tasks:t
4b70: 61 73 6b 2d 67 65 74 2d 73 74 61 74 65 20 20 74 ask-get-state t
4b80: 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 ask).... (tasks
4b90: 3a 74 61 73 6b 2d 67 65 74 2d 74 61 72 67 65 74 :task-get-target
4ba0: 20 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 task).... (tas
4bb0: 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6e 61 6d 65 ks:task-get-name
4bc0: 20 20 20 74 61 73 6b 29 0a 09 09 09 20 20 28 74 task).... (t
4bd0: 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 65 asks:task-get-te
4be0: 73 74 20 20 20 74 61 73 6b 29 0a 09 09 09 20 20 st task)....
4bf0: 3b 3b 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 ;; (tasks:task-g
4c00: 65 74 2d 69 74 65 6d 20 20 20 74 61 73 6b 29 0a et-item task).
4c10: 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b ... (tasks:task
4c20: 2d 67 65 74 2d 70 61 72 61 6d 73 20 74 61 73 6b -get-params task
4c30: 29 29 29 0a 09 09 74 61 73 6b 73 29 20 22 5c 6e )))...tasks) "\n
4c40: 22 29 29 29 29 0a 20 20 20 0a 23 3b 28 64 65 66 ")))). .#;(def
4c50: 69 6e 65 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 ine (tasks:set-s
4c60: 74 61 74 65 20 64 62 73 74 72 75 63 74 20 74 61 tate dbstruct ta
4c70: 73 6b 2d 69 64 20 73 74 61 74 65 29 0a 20 20 28 sk-id state). (
4c80: 64 62 3a 77 69 74 68 2d 64 62 20 0a 20 20 20 64 db:with-db . d
4c90: 62 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 bstruct #f #t.
4ca0: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
4cb0: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
4cc0: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
4cd0: 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 asks_queue SET s
4ce0: 74 61 74 65 3d 3f 20 57 48 45 52 45 20 69 64 3d tate=? WHERE id=
4cf0: 3f 3b 22 20 0a 09 09 20 20 20 20 20 20 73 74 61 ?;" ... sta
4d00: 74 65 20 0a 09 09 20 20 20 20 20 20 74 61 73 6b te ... task
4d10: 2d 69 64 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d -id))))..;;=====
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d60: 3d 0a 3b 3b 20 41 63 63 65 73 73 20 75 73 69 6e =.;; Access usin
4d70: 67 20 74 61 73 6b 20 6b 65 79 20 28 73 74 6f 72 g task key (stor
4d80: 65 64 20 69 6e 20 70 61 72 61 6d 73 3b 20 28 68 ed in params; (h
4d90: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
4da0: 20 66 6c 61 67 73 29 20 68 6f 73 74 6e 61 6d 65 flags) hostname
4db0: 20 70 69 64 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d pid.;;=========
4dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 23 =============..#
4e00: 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a ;(define (tasks:
4e10: 70 61 72 61 6d 2d 6b 65 79 2d 3e 69 64 20 64 62 param-key->id db
4e20: 73 74 72 75 63 74 20 74 61 73 6b 2d 70 61 72 61 struct task-para
4e30: 6d 73 29 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 ms). (db:with-d
4e40: 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 23 66 b. dbstruct #f
4e50: 20 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 #f. (lambda (
4e60: 64 62 29 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 db). (handle
4e70: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
4e80: 20 20 65 78 6e 0a 20 20 20 20 20 20 23 66 0a 20 exn. #f.
4e90: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 (sqlite3:fi
4ea0: 72 73 74 2d 72 65 73 75 6c 74 20 64 62 20 22 53 rst-result db "S
4eb0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 74 61 ELECT id FROM ta
4ec0: 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 45 20 sks_queue WHERE
4ed0: 70 61 72 61 6d 73 20 4c 49 4b 45 20 3f 3b 22 0a params LIKE ?;".
4ee0: 09 09 09 20 20 20 20 74 61 73 6b 2d 70 61 72 61 ... task-para
4ef0: 6d 73 29 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 ms)))))..#;(defi
4f00: 6e 65 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 74 ne (tasks:set-st
4f10: 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d ate-given-param-
4f20: 6b 65 79 20 64 62 73 74 72 75 63 74 20 70 61 72 key dbstruct par
4f30: 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 am-key new-state
4f40: 29 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a ). (db:with-db.
4f50: 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 dbstruct #f #
4f60: 74 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 t. (lambda (db
4f70: 29 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a ). (sqlite3:
4f80: 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 execute db "UPDA
4f90: 54 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 TE tasks_queue S
4fa0: 45 54 20 73 74 61 74 65 3d 3f 20 57 48 45 52 45 ET state=? WHERE
4fb0: 20 70 61 72 61 6d 73 20 4c 49 4b 45 20 3f 3b 22 params LIKE ?;"
4fc0: 20 6e 65 77 2d 73 74 61 74 65 20 70 61 72 61 6d new-state param
4fd0: 2d 6b 65 79 29 29 29 29 0a 0a 23 3b 28 64 65 66 -key))))..#;(def
4fe0: 69 6e 65 20 28 74 61 73 6b 73 3a 67 65 74 2d 72 ine (tasks:get-r
4ff0: 65 63 6f 72 64 73 2d 67 69 76 65 6e 2d 70 61 72 ecords-given-par
5000: 61 6d 2d 6b 65 79 20 64 62 73 74 72 75 63 74 20 am-key dbstruct
5010: 70 61 72 61 6d 2d 6b 65 79 20 73 74 61 74 65 2d param-key state-
5020: 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 patt action-patt
5030: 20 74 65 73 74 2d 70 61 74 74 29 0a 20 20 28 64 test-patt). (d
5040: 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 64 62 73 b:with-db. dbs
5050: 74 72 75 63 74 20 23 66 20 23 66 0a 20 20 20 28 truct #f #f. (
5060: 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 lambda (db).
5070: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
5080: 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 ons. exn.
5090: 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 28 73 '(). (s
50a0: 71 6c 69 74 65 33 3a 66 69 72 73 74 2d 72 6f 77 qlite3:first-row
50b0: 20 64 62 20 22 53 45 4c 45 43 54 20 69 64 2c 61 db "SELECT id,a
50c0: 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 ction,owner,stat
50d0: 65 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 e,target,name,te
50e0: 73 74 70 61 74 74 2c 6b 65 79 6c 6f 63 6b 2c 70 stpatt,keylock,p
50f0: 61 72 61 6d 73 20 57 48 45 52 45 0a 20 20 20 20 arams WHERE.
5100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5110: 20 20 20 20 20 20 20 20 20 20 20 70 61 72 61 6d param
5120: 73 20 4c 49 4b 45 20 3f 20 41 4e 44 20 73 74 61 s LIKE ? AND sta
5130: 74 65 20 4c 49 4b 45 20 3f 20 41 4e 44 20 61 63 te LIKE ? AND ac
5140: 74 69 6f 6e 20 4c 49 4b 45 20 3f 20 41 4e 44 20 tion LIKE ? AND
5150: 74 65 73 74 70 61 74 74 20 4c 49 4b 45 20 3f 3b testpatt LIKE ?;
5160: 22 0a 09 09 09 20 70 61 72 61 6d 2d 6b 65 79 20 ".... param-key
5170: 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f state-patt actio
5180: 6e 2d 70 61 74 74 20 74 65 73 74 2d 70 61 74 74 n-patt test-patt
5190: 29 29 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 )))))..#;(define
51a0: 20 28 74 61 73 6b 73 3a 66 69 6e 64 2d 74 61 73 (tasks:find-tas
51b0: 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 k-queue-records
51c0: 64 62 73 74 72 75 63 74 20 74 61 72 67 65 74 20 dbstruct target
51d0: 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 run-name test-pa
51e0: 74 74 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 tt state-patt ac
51f0: 74 69 6f 6e 2d 70 61 74 74 29 0a 20 20 3b 3b 20 tion-patt). ;;
5200: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
5210: 6e 73 0a 20 20 3b 3b 20 20 65 78 6e 0a 20 20 3b ns. ;; exn. ;
5220: 3b 20 20 27 28 29 0a 20 20 3b 3b 20 20 28 73 71 ; '(). ;; (sq
5230: 6c 69 74 65 33 3a 66 69 72 73 74 2d 72 6f 77 0a lite3:first-row.
5240: 20 20 28 6c 65 74 20 28 28 64 62 20 28 64 62 3a (let ((db (db:
5250: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 64 delay-if-busy (d
5260: 62 3a 67 65 74 2d 64 62 20 64 62 73 74 72 75 63 b:get-db dbstruc
5270: 74 29 29 29 0a 09 28 72 65 73 20 27 28 29 29 29 t)))..(res '()))
5280: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
5290: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 r-each-row .
52a0: 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 29 (lambda (a . b)
52b0: 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 . (set! re
52c0: 73 20 28 63 6f 6e 73 20 28 63 6f 6e 73 20 61 20 s (cons (cons a
52d0: 62 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 b) res))). d
52e0: 62 20 22 53 45 4c 45 43 54 20 69 64 2c 61 63 74 b "SELECT id,act
52f0: 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c ion,owner,state,
5300: 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 target,name,test
5310: 70 61 74 74 2c 6b 65 79 6c 6f 63 6b 2c 70 61 72 patt,keylock,par
5320: 61 6d 73 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 ams FROM tasks_q
5330: 75 65 75 65 20 0a 20 20 20 20 20 20 20 20 20 20 ueue .
5340: 20 57 48 45 52 45 0a 20 20 20 20 20 20 20 20 20 WHERE.
5350: 20 20 20 20 20 74 61 72 67 65 74 20 3d 20 3f 20 target = ?
5360: 41 4e 44 20 6e 61 6d 65 20 3d 20 3f 20 41 4e 44 AND name = ? AND
5370: 20 73 74 61 74 65 20 4c 49 4b 45 20 3f 20 41 4e state LIKE ? AN
5380: 44 20 61 63 74 69 6f 6e 20 4c 49 4b 45 20 3f 20 D action LIKE ?
5390: 41 4e 44 20 74 65 73 74 70 61 74 74 20 4c 49 4b AND testpatt LIK
53a0: 45 20 3f 3b 22 0a 20 20 20 20 20 74 61 72 67 65 E ?;". targe
53b0: 74 20 72 75 6e 2d 6e 61 6d 65 20 73 74 61 74 65 t run-name state
53c0: 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 -patt action-pat
53d0: 74 20 74 65 73 74 2d 70 61 74 74 29 0a 20 20 20 t test-patt).
53e0: 20 72 65 73 29 29 20 3b 3b 20 29 0a 0a 3b 3b 20 res)) ;; )..;;
53f0: 6b 69 6c 6c 20 61 6e 79 20 72 75 6e 6e 65 72 20 kill any runner
5400: 70 72 6f 63 65 73 73 65 73 20 28 69 2e 65 2e 20 processes (i.e.
5410: 70 72 6f 63 65 73 73 65 73 20 68 61 6e 64 6c 69 processes handli
5420: 6e 67 20 2d 72 75 6e 74 65 73 74 73 29 20 74 68 ng -runtests) th
5430: 61 74 20 6d 61 74 63 68 20 74 61 72 67 65 74 2f at match target/
5440: 72 75 6e 6e 61 6d 65 0a 3b 3b 20 0a 3b 3b 20 64 runname.;; .;; d
5450: 6f 20 61 20 72 65 6d 6f 74 65 20 63 61 6c 6c 20 o a remote call
5460: 74 6f 20 67 65 74 20 74 68 65 20 74 61 73 6b 20 to get the task
5470: 71 75 65 75 65 20 69 6e 66 6f 20 62 75 74 20 64 queue info but d
5480: 6f 20 74 68 65 20 6b 69 6c 6c 69 6e 67 20 61 73 o the killing as
5490: 20 73 65 6c 66 20 68 65 72 65 2e 0a 3b 3b 0a 23 self here..;;.#
54a0: 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a ;(define (tasks:
54b0: 6b 69 6c 6c 2d 72 75 6e 6e 65 72 20 74 61 72 67 kill-runner targ
54c0: 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 et run-name test
54d0: 70 61 74 74 29 0a 20 20 28 6c 65 74 20 28 28 72 patt). (let ((r
54e0: 65 63 6f 72 64 73 20 20 20 20 28 72 6d 74 3a 74 ecords (rmt:t
54f0: 61 73 6b 73 2d 66 69 6e 64 2d 74 61 73 6b 2d 71 asks-find-task-q
5500: 75 65 75 65 2d 72 65 63 6f 72 64 73 20 74 61 72 ueue-records tar
5510: 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 get run-name tes
5520: 74 70 61 74 74 20 22 72 75 6e 6e 69 6e 67 22 20 tpatt "running"
5530: 22 72 75 6e 2d 74 65 73 74 73 22 29 29 0a 09 28 "run-tests"))..(
5540: 68 6f 73 74 70 69 64 2d 72 78 20 28 72 65 67 65 hostpid-rx (rege
5550: 78 70 20 22 5c 5c 73 2b 28 5c 5c 77 2b 29 5c 5c xp "\\s+(\\w+)\\
5560: 73 2b 28 5c 5c 64 2b 29 24 22 29 29 29 20 3b 3b s+(\\d+)$"))) ;;
5570: 20 68 6f 73 74 20 70 69 64 20 69 73 20 61 74 20 host pid is at
5580: 65 6e 64 20 6f 66 20 70 61 72 61 6d 20 73 74 72 end of param str
5590: 69 6e 67 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ing. (if (nul
55a0: 6c 3f 20 72 65 63 6f 72 64 73 29 0a 09 28 64 65 l? records)..(de
55b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
55c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
55d0: 4e 6f 20 72 75 6e 20 6c 61 75 6e 63 68 69 6e 67 No run launching
55e0: 20 70 72 6f 63 65 73 73 65 73 20 66 6f 75 6e 64 processes found
55f0: 20 66 6f 72 20 22 20 74 61 72 67 65 74 20 22 20 for " target "
5600: 2f 20 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 77 / " run-name " w
5610: 69 74 68 20 74 65 73 74 70 61 74 74 20 22 20 28 ith testpatt " (
5620: 6f 72 20 74 65 73 74 70 61 74 74 20 22 2a 20 6e or testpatt "* n
5630: 6f 20 74 65 73 74 70 61 74 74 20 73 70 65 63 69 o testpatt speci
5640: 66 69 65 64 21 20 2a 22 29 29 0a 09 28 64 65 62 fied! *"))..(deb
5650: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5660: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 ult-log-port* "F
5670: 6f 75 6e 64 20 22 20 28 6c 65 6e 67 74 68 20 72 ound " (length r
5680: 65 63 6f 72 64 73 29 20 22 20 72 75 6e 28 73 29 ecords) " run(s)
5690: 20 74 6f 20 6b 69 6c 6c 2e 22 29 29 0a 20 20 20 to kill.")).
56a0: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
56b0: 20 28 6c 61 6d 62 64 61 20 28 72 65 63 6f 72 64 (lambda (record
56c0: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
56d0: 28 70 61 72 61 6d 2d 6b 65 79 20 28 6c 69 73 74 (param-key (list
56e0: 2d 72 65 66 20 72 65 63 6f 72 64 20 38 29 29 0a -ref record 8)).
56f0: 09 20 20 20 20 20 20 28 6d 61 74 63 68 2d 64 61 . (match-da
5700: 74 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 t (string-search
5710: 20 68 6f 73 74 70 69 64 2d 72 78 20 70 61 72 61 hostpid-rx para
5720: 6d 2d 6b 65 79 29 29 29 0a 09 20 28 69 66 20 6d m-key))).. (if m
5730: 61 74 63 68 2d 64 61 74 0a 09 20 20 20 20 20 28 atch-dat.. (
5740: 6c 65 74 20 28 28 68 6f 73 74 6e 61 6d 65 20 20 let ((hostname
5750: 28 63 61 64 72 20 6d 61 74 63 68 2d 64 61 74 29 (cadr match-dat)
5760: 29 0a 09 09 20 20 20 28 70 69 64 20 20 20 20 20 )... (pid
5770: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
5780: 72 20 28 63 61 64 64 72 20 6d 61 74 63 68 2d 64 r (caddr match-d
5790: 61 74 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 at)))).. (
57a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
57b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
57c0: 20 22 53 65 6e 64 69 6e 67 20 53 49 47 49 4e 54 "Sending SIGINT
57d0: 20 74 6f 20 70 72 6f 63 65 73 73 20 22 20 70 69 to process " pi
57e0: 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f d " on host " ho
57f0: 73 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 stname)..
5800: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 67 65 74 (if (equal? (get
5810: 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 68 6f 73 74 -host-name) host
5820: 6e 61 6d 65 29 0a 09 09 20 20 20 28 69 66 20 28 name)... (if (
5830: 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 70 process:alive? p
5840: 69 64 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 id)... (be
5850: 67 69 6e 0a 09 09 09 20 28 68 61 6e 64 6c 65 2d gin.... (handle-
5860: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 exceptions....
5870: 65 78 6e 0a 09 09 09 20 20 28 62 65 67 69 6e 0a exn.... (begin.
5880: 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
5890: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
58a0: 6f 67 2d 70 6f 72 74 2a 20 22 4b 69 6c 6c 20 6f og-port* "Kill o
58b0: 66 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 20 f process " pid
58c0: 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 " on host " host
58d0: 6e 61 6d 65 20 22 20 66 61 69 6c 65 64 2e 22 29 name " failed.")
58e0: 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 .... (debug:p
58f0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5900: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
5910: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
5920: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
5930: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
5940: 67 65 29 20 65 78 6e 29 29 0a 09 09 09 20 20 20 ge) exn))....
5950: 20 23 74 29 0a 09 09 09 20 20 28 70 72 6f 63 65 #t).... (proce
5960: 73 73 2d 73 69 67 6e 61 6c 20 70 69 64 20 73 69 ss-signal pid si
5970: 67 6e 61 6c 2f 69 6e 74 29 0a 09 09 09 20 20 28 gnal/int).... (
5980: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 thread-sleep! 5)
5990: 0a 09 09 09 20 20 28 69 66 20 28 70 72 6f 63 65 .... (if (proce
59a0: 73 73 3a 61 6c 69 76 65 3f 20 70 69 64 29 0a 09 ss:alive? pid)..
59b0: 09 09 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 .. (process
59c0: 2d 73 69 67 6e 61 6c 20 70 69 64 20 73 69 67 6e -signal pid sign
59d0: 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 0a 09 09 20 al/kill)))))...
59e0: 20 20 3b 3b 20 20 28 63 61 6c 6c 2d 77 69 74 68 ;; (call-with
59f0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
5a00: 69 61 62 6c 65 73 0a 09 09 20 20 20 28 6c 65 74 iables... (let
5a10: 20 28 28 6f 6c 64 2d 74 61 72 67 65 74 68 6f 73 ((old-targethos
5a20: 74 20 28 67 65 74 65 6e 76 20 22 54 41 52 47 45 t (getenv "TARGE
5a30: 54 48 4f 53 54 22 29 29 29 0a 09 09 20 20 20 20 THOST")))...
5a40: 20 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 (setenv "TARGET
5a50: 48 4f 53 54 22 20 68 6f 73 74 6e 61 6d 65 29 0a HOST" hostname).
5a60: 09 09 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 .. (setenv "
5a70: 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 TARGETHOST_LOGF"
5a80: 20 22 73 65 72 76 65 72 2d 6b 69 6c 6c 73 2e 6c "server-kills.l
5a90: 6f 67 22 29 0a 09 09 20 20 20 20 20 28 73 79 73 og")... (sys
5aa0: 74 65 6d 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b tem (conc "nbfak
5ab0: 65 20 6b 69 6c 6c 20 22 20 70 69 64 29 29 0a 09 e kill " pid))..
5ac0: 09 20 20 20 20 20 28 69 66 20 6f 6c 64 2d 74 61 . (if old-ta
5ad0: 72 67 65 74 68 6f 73 74 20 28 73 65 74 65 6e 76 rgethost (setenv
5ae0: 20 22 54 41 52 47 45 54 48 4f 53 54 22 20 6f 6c "TARGETHOST" ol
5af0: 64 2d 74 61 72 67 65 74 68 6f 73 74 29 29 0a 09 d-targethost))..
5b00: 09 20 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 . (unsetenv
5b10: 22 54 41 52 47 45 54 48 4f 53 54 22 29 0a 09 09 "TARGETHOST")...
5b20: 20 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 (unsetenv "
5b30: 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 TARGETHOST_LOGF"
5b40: 29 29 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 )))).. (debu
5b50: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
5b60: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5b70: 74 2a 20 22 6e 6f 20 72 65 63 6f 72 64 20 6f 72 t* "no record or
5b80: 20 69 6d 70 72 6f 70 65 72 20 72 65 63 6f 72 64 improper record
5b90: 20 66 6f 72 20 22 20 74 61 72 67 65 74 20 22 2f for " target "/
5ba0: 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 69 6e 20 " run-name " in
5bb0: 74 61 73 6b 73 5f 71 75 65 75 65 20 69 6e 20 6d tasks_queue in m
5bc0: 61 69 6e 2e 64 62 22 29 29 29 29 0a 20 20 20 20 ain.db")))).
5bd0: 20 72 65 63 6f 72 64 73 29 29 29 0a 0a 3b 3b 20 records)))..;;
5be0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 (define (tasks:s
5bf0: 74 61 72 74 2d 72 75 6e 20 64 62 73 74 72 75 63 tart-run dbstruc
5c00: 74 20 6d 64 62 20 74 61 73 6b 29 0a 3b 3b 20 20 t mdb task).;;
5c10: 20 28 6c 65 74 20 28 28 66 6c 61 67 73 20 28 6d (let ((flags (m
5c20: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
5c30: 29 0a 3b 3b 20 20 20 20 20 28 68 61 73 68 2d 74 ).;; (hash-t
5c40: 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 20 able-set! flags
5c50: 22 2d 72 65 72 75 6e 22 20 22 4e 4f 54 5f 53 54 "-rerun" "NOT_ST
5c60: 41 52 54 45 44 22 29 0a 3b 3b 20 20 20 20 20 28 ARTED").;; (
5c70: 69 66 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d if (not (string=
5c80: 3f 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 ? (tasks:task-ge
5c90: 74 2d 70 61 72 61 6d 73 20 74 61 73 6b 29 20 22 t-params task) "
5ca0: 22 29 29 0a 3b 3b 20 09 28 68 61 73 68 2d 74 61 ")).;; .(hash-ta
5cb0: 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 20 22 ble-set! flags "
5cc0: 2d 73 65 74 76 61 72 73 22 20 28 74 61 73 6b 73 -setvars" (tasks
5cd0: 3a 74 61 73 6b 2d 67 65 74 2d 70 61 72 61 6d 73 :task-get-params
5ce0: 20 74 61 73 6b 29 29 29 0a 3b 3b 20 20 20 20 20 task))).;;
5cf0: 28 70 72 69 6e 74 20 22 53 74 61 72 74 69 6e 67 (print "Starting
5d00: 20 72 75 6e 20 22 20 74 61 73 6b 29 0a 3b 3b 20 run " task).;;
5d10: 20 20 20 20 3b 3b 20 73 69 6c 6c 79 6e 65 73 73 ;; sillyness
5d20: 2c 20 6a 75 73 74 20 63 61 6c 6c 20 74 68 65 20 , just call the
5d30: 64 61 6d 6e 20 72 6f 75 74 69 6e 65 20 77 69 74 damn routine wit
5d40: 68 20 74 68 65 20 74 61 73 6b 20 76 65 63 74 6f h the task vecto
5d50: 72 20 61 6e 64 20 62 65 20 64 6f 6e 65 20 77 69 r and be done wi
5d60: 74 68 20 69 74 2e 20 46 49 58 4d 45 20 53 4f 4d th it. FIXME SOM
5d70: 45 44 41 59 0a 3b 3b 20 20 20 20 20 28 72 75 6e EDAY.;; (run
5d80: 73 3a 72 75 6e 2d 74 65 73 74 73 20 64 62 0a 3b s:run-tests db.;
5d90: 3b 20 09 09 20 20 20 20 28 74 61 73 6b 73 3a 74 ; .. (tasks:t
5da0: 61 73 6b 2d 67 65 74 2d 74 61 72 67 65 74 20 74 ask-get-target t
5db0: 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 28 74 ask).;; .. (t
5dc0: 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6e 61 asks:task-get-na
5dd0: 6d 65 20 20 20 74 61 73 6b 29 0a 3b 3b 20 09 09 me task).;; ..
5de0: 20 20 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d (tasks:task-
5df0: 67 65 74 2d 74 65 73 74 20 20 20 74 61 73 6b 29 get-test task)
5e00: 0a 3b 3b 20 09 09 20 20 20 20 28 74 61 73 6b 73 .;; .. (tasks
5e10: 3a 74 61 73 6b 2d 67 65 74 2d 69 74 65 6d 20 20 :task-get-item
5e20: 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 task).;; ..
5e30: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
5e40: 6f 77 6e 65 72 20 20 74 61 73 6b 29 0a 3b 3b 20 owner task).;;
5e50: 09 09 20 20 20 20 66 6c 61 67 73 29 0a 3b 3b 20 .. flags).;;
5e60: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 (tasks:set-s
5e70: 74 61 74 65 20 6d 64 62 20 28 74 61 73 6b 73 3a tate mdb (tasks:
5e80: 74 61 73 6b 2d 67 65 74 2d 69 64 20 74 61 73 6b task-get-id task
5e90: 29 20 22 77 61 69 74 69 6e 67 22 29 29 29 0a 3b ) "waiting"))).;
5ea0: 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 ; .;; (define (t
5eb0: 61 73 6b 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 73 asks:rollup-runs
5ec0: 20 64 62 20 6d 64 62 20 74 61 73 6b 29 0a 3b 3b db mdb task).;;
5ed0: 20 20 20 28 6c 65 74 2a 20 28 28 66 6c 61 67 73 (let* ((flags
5ee0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
5ef0: 65 29 29 20 0a 3b 3b 20 09 20 28 6b 65 79 73 20 e)) .;; . (keys
5f00: 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 (db:get-keys db
5f10: 29 29 0a 3b 3b 20 09 20 28 6b 65 79 76 61 6c 73 )).;; . (keyvals
5f20: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 6b 65 (keys:target-ke
5f30: 79 76 61 6c 20 6b 65 79 73 20 28 74 61 73 6b 73 yval keys (tasks
5f40: 3a 74 61 73 6b 2d 67 65 74 2d 74 61 72 67 65 74 :task-get-target
5f50: 20 74 61 73 6b 29 29 29 29 0a 3b 3b 20 20 20 20 task)))).;;
5f60: 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ;; (hash-table-
5f70: 73 65 74 21 20 66 6c 61 67 73 20 22 2d 72 65 72 set! flags "-rer
5f80: 75 6e 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 un" "NOT_STARTED
5f90: 22 29 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 ").;; (print
5fa0: 20 22 53 74 61 72 74 69 6e 67 20 72 6f 6c 6c 75 "Starting rollu
5fb0: 70 20 22 20 74 61 73 6b 29 0a 3b 3b 20 20 20 20 p " task).;;
5fc0: 20 3b 3b 20 73 69 6c 6c 79 6e 65 73 73 2c 20 6a ;; sillyness, j
5fd0: 75 73 74 20 63 61 6c 6c 20 74 68 65 20 64 61 6d ust call the dam
5fe0: 6e 20 72 6f 75 74 69 6e 65 20 77 69 74 68 20 74 n routine with t
5ff0: 68 65 20 74 61 73 6b 20 76 65 63 74 6f 72 20 61 he task vector a
6000: 6e 64 20 62 65 20 64 6f 6e 65 20 77 69 74 68 20 nd be done with
6010: 69 74 2e 20 46 49 58 4d 45 20 53 4f 4d 45 44 41 it. FIXME SOMEDA
6020: 59 0a 3b 3b 20 20 20 20 20 28 72 75 6e 73 3a 72 Y.;; (runs:r
6030: 6f 6c 6c 75 70 2d 72 75 6e 20 64 62 0a 3b 3b 20 ollup-run db.;;
6040: 09 09 20 20 20 20 20 6b 65 79 73 20 0a 3b 3b 20 .. keys .;;
6050: 09 09 20 20 20 20 20 6b 65 79 76 61 6c 73 0a 3b .. keyvals.;
6060: 3b 20 09 09 20 20 20 20 20 28 74 61 73 6b 73 3a ; .. (tasks:
6070: 74 61 73 6b 2d 67 65 74 2d 6e 61 6d 65 20 20 74 task-get-name t
6080: 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 20 28 ask).;; .. (
6090: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6f tasks:task-get-o
60a0: 77 6e 65 72 20 20 74 61 73 6b 29 29 0a 3b 3b 20 wner task)).;;
60b0: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 (tasks:set-s
60c0: 74 61 74 65 20 6d 64 62 20 28 74 61 73 6b 73 3a tate mdb (tasks:
60d0: 74 61 73 6b 2d 67 65 74 2d 69 64 20 74 61 73 6b task-get-id task
60e0: 29 20 22 77 61 69 74 69 6e 67 22 29 29 29 0a 0a ) "waiting")))..
60f0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6130: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 59 ========.;; S Y
6140: 20 4e 20 43 20 20 20 54 20 4f 20 20 20 50 20 4f N C T O P O
6150: 20 53 20 54 20 47 20 52 20 45 20 53 20 51 20 4c S T G R E S Q L
6160: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
61a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 49 6e =========..;; In
61b0: 20 74 68 65 20 73 70 69 72 69 74 20 6f 66 20 22 the spirit of "
61c0: 64 75 6d 70 20 79 6f 75 72 20 6a 75 6e 6b 20 69 dump your junk i
61d0: 6e 20 74 68 65 20 74 61 73 6b 73 20 6d 6f 64 75 n the tasks modu
61e0: 6c 65 22 20 49 27 6c 6c 20 70 75 74 20 74 68 65 le" I'll put the
61f0: 0a 3b 3b 20 73 79 6e 63 20 74 6f 20 70 6f 73 74 .;; sync to post
6200: 67 72 65 73 20 68 65 72 65 20 66 6f 72 20 6e 6f gres here for no
6210: 77 2e 0a 0a 3b 3b 20 61 74 74 65 6d 70 74 20 74 w...;; attempt t
6220: 6f 20 61 75 74 6f 6d 61 74 69 63 61 6c 6c 79 20 o automatically
6230: 73 65 74 20 75 70 20 61 6e 20 61 72 65 61 2e 20 set up an area.
6240: 63 61 6c 6c 20 6f 6e 6c 79 20 69 66 20 67 65 74 call only if get
6250: 20 61 72 65 61 20 62 79 20 70 61 74 68 0a 3b 3b area by path.;;
6260: 20 72 65 74 75 72 6e 73 20 6e 61 75 67 68 74 20 returns naught
6270: 6f 66 20 69 6e 74 65 72 65 73 74 0a 3b 3b 0a 23 of interest.;;.#
6280: 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a ;(define (tasks:
6290: 73 65 74 2d 61 72 65 61 20 64 62 68 20 63 6f 6e set-area dbh con
62a0: 66 69 67 64 61 74 20 23 21 6b 65 79 20 28 74 6f figdat #!key (to
62b0: 70 70 61 74 68 20 23 66 29 29 20 3b 3b 20 63 6f ppath #f)) ;; co
62c0: 75 6c 64 20 49 20 73 61 66 65 6c 79 20 70 75 74 uld I safely put
62d0: 20 2a 74 6f 70 70 61 74 68 2a 20 69 6e 20 66 6f *toppath* in fo
62e0: 72 20 74 68 65 20 64 65 66 61 75 6c 74 20 66 6f r the default fo
62f0: 72 20 74 6f 70 70 61 74 68 3f 20 77 68 65 6e 20 r toppath? when
6300: 77 6f 75 6c 64 20 69 74 20 62 65 20 65 76 61 6c would it be eval
6310: 75 61 74 65 64 3f 0a 20 20 28 6c 65 74 20 6c 6f uated?. (let lo
6320: 6f 70 20 28 28 61 72 65 61 2d 6e 61 6d 65 20 28 op ((area-name (
6330: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
6340: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 up configdat "se
6350: 74 75 70 22 20 22 61 72 65 61 2d 6e 61 6d 65 22 tup" "area-name"
6360: 29 0a 09 09 09 20 20 20 20 28 63 6f 6d 6d 6f 6e ).... (common
6370: 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 20 2a :get-area-name *
6380: 61 6c 6c 64 61 74 2a 29 29 29 0a 09 20 20 20 20 alldat*)))..
6390: 20 28 6d 6f 64 69 66 69 65 72 20 20 27 6e 6f 6e (modifier 'non
63a0: 65 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 73 e)). (let ((s
63b0: 75 63 63 65 73 73 20 28 68 61 6e 64 6c 65 2d 65 uccess (handle-e
63c0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 xceptions...
63d0: 20 20 20 65 78 6e 0a 09 09 20 20 20 20 20 20 20 exn...
63e0: 28 62 65 67 69 6e 0a 09 09 09 20 28 64 65 62 75 (begin.... (debu
63f0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
6400: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
6410: 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 63 72 65 61 ROR: cannot crea
6420: 74 65 20 61 72 65 61 20 65 6e 74 72 79 2c 20 22 te area entry, "
6430: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
6440: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
6450: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
6460: 6e 29 29 0a 09 09 09 20 23 66 29 20 3b 3b 20 46 n)).... #f) ;; F
6470: 49 58 4d 45 3a 20 49 20 64 6f 6e 27 74 20 63 61 IXME: I don't ca
6480: 72 65 20 66 6f 72 20 6e 6f 77 20 62 75 74 20 49 re for now but I
6490: 20 73 68 6f 75 6c 64 20 6c 6f 6f 6b 20 61 74 20 should look at
64a0: 2a 77 68 79 2a 20 74 68 65 72 65 20 77 61 73 20 *why* there was
64b0: 61 6e 20 65 78 63 65 70 74 69 6f 6e 0a 09 09 20 an exception...
64c0: 20 20 20 20 28 70 67 64 62 3a 61 64 64 2d 61 72 (pgdb:add-ar
64d0: 65 61 20 64 62 68 20 61 72 65 61 2d 6e 61 6d 65 ea dbh area-name
64e0: 20 28 6f 72 20 74 6f 70 70 61 74 68 20 2a 74 6f (or toppath *to
64f0: 70 70 61 74 68 2a 29 29 29 29 29 0a 20 20 20 20 ppath*))))).
6500: 20 20 28 6f 72 20 73 75 63 63 65 73 73 0a 09 20 (or success..
6510: 20 28 63 61 73 65 20 6d 6f 64 69 66 69 65 72 0a (case modifier.
6520: 09 20 20 20 20 28 28 6e 6f 6e 65 29 28 6c 6f 6f . ((none)(loo
6530: 70 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 p (conc (current
6540: 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 5f 22 20 -user-name) "_"
6550: 61 72 65 61 2d 6e 61 6d 65 29 20 27 75 73 65 72 area-name) 'user
6560: 29 29 0a 09 20 20 20 20 28 28 75 73 65 72 29 28 )).. ((user)(
6570: 6c 6f 6f 70 20 28 63 6f 6e 63 20 28 73 75 62 73 loop (conc (subs
6580: 74 72 69 6e 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 tring (common:ge
6590: 74 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e t-area-path-sign
65a0: 61 74 75 72 65 29 20 30 20 34 29 0a 09 09 09 20 ature) 0 4)....
65b0: 20 20 20 20 20 20 61 72 65 61 2d 6e 61 6d 65 29 area-name)
65c0: 20 27 61 72 65 61 73 69 67 29 29 0a 09 20 20 20 'areasig))..
65d0: 20 28 65 6c 73 65 20 23 66 29 29 29 29 29 29 20 (else #f))))))
65e0: 3b 3b 20 67 69 76 65 20 75 70 0a 0a 23 3b 28 64 ;; give up..#;(d
65f0: 65 66 69 6e 65 20 28 74 61 73 6b 3a 70 72 69 6e efine (task:prin
6600: 74 2d 72 75 6e 74 69 6d 65 20 72 75 6e 2d 74 69 t-runtime run-ti
6610: 6d 65 73 20 73 61 70 65 72 61 74 6f 72 29 0a 28 mes saperator).(
6620: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 28 6c 61 for-each. (la
6630: 6d 62 64 61 20 28 72 75 6e 2d 74 69 6d 65 2d 69 mbda (run-time-i
6640: 6e 66 6f 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 nfo). (let*
6650: 28 28 72 75 6e 2d 6e 61 6d 65 20 20 28 76 65 63 ((run-name (vec
6660: 74 6f 72 2d 72 65 66 20 72 75 6e 2d 74 69 6d 65 tor-ref run-time
6670: 2d 69 6e 66 6f 20 30 29 29 0a 20 20 20 20 20 20 -info 0)).
6680: 20 20 20 20 20 20 28 72 75 6e 2d 74 69 6d 65 20 (run-time
6690: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
66a0: 2d 74 69 6d 65 2d 69 6e 66 6f 20 31 29 29 0a 20 -time-info 1)).
66b0: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 (targ
66c0: 65 74 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 et (vector-ref
66d0: 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 20 32 29 run-time-info 2)
66e0: 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 69 6e )). (prin
66f0: 74 20 74 61 72 67 65 74 20 73 61 70 65 72 61 74 t target saperat
6700: 6f 72 20 72 75 6e 2d 6e 61 6d 65 20 73 61 70 65 or run-name sape
6710: 72 61 74 6f 72 20 72 75 6e 2d 74 69 6d 65 20 29 rator run-time )
6720: 29 29 0a 20 20 20 72 75 6e 2d 74 69 6d 65 73 29 )). run-times)
6730: 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 74 61 )..#;(define (ta
6740: 73 6b 3a 70 72 69 6e 74 2d 72 75 6e 74 69 6d 65 sk:print-runtime
6750: 2d 61 73 2d 6a 73 6f 6e 20 72 75 6e 2d 74 69 6d -as-json run-tim
6760: 65 73 29 0a 20 28 6c 65 74 20 6c 6f 6f 70 20 28 es). (let loop (
6770: 28 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 20 28 (run-time-info (
6780: 63 61 72 20 72 75 6e 2d 74 69 6d 65 73 29 29 0a car run-times)).
6790: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 6d (rem
67a0: 61 20 28 63 64 72 20 72 75 6e 2d 74 69 6d 65 73 a (cdr run-times
67b0: 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 )) .
67c0: 28 73 74 72 20 22 22 29 29 0a 20 20 20 20 20 28 (str "")). (
67d0: 6c 65 74 2a 20 28 28 72 75 6e 2d 6e 61 6d 65 20 let* ((run-name
67e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
67f0: 2d 74 69 6d 65 2d 69 6e 66 6f 20 30 29 29 0a 20 -time-info 0)).
6800: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d (run-
6810: 74 69 6d 65 20 20 28 76 65 63 74 6f 72 2d 72 65 time (vector-re
6820: 66 20 72 75 6e 2d 74 69 6d 65 2d 69 6e 66 6f 20 f run-time-info
6830: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
6840: 28 74 61 72 67 65 74 20 20 28 76 65 63 74 6f 72 (target (vector
6850: 2d 72 65 66 20 72 75 6e 2d 74 69 6d 65 2d 69 6e -ref run-time-in
6860: 66 6f 20 32 29 29 29 0a 20 20 20 20 20 20 20 20 fo 2))).
6870: 3b 28 70 72 69 6e 74 20 28 6e 6f 74 20 28 65 71 ;(print (not (eq
6880: 75 61 6c 3f 20 73 74 72 20 22 22 29 29 29 0a 20 ual? str ""))).
6890: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
68a0: 28 65 71 75 61 6c 3f 20 73 74 72 20 22 22 29 29 (equal? str ""))
68b0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 . (s
68c0: 65 74 21 20 73 74 72 20 28 63 6f 6e 63 20 73 74 et! str (conc st
68d0: 72 20 22 2c 22 29 29 29 0a 20 20 20 20 20 20 20 r ","))).
68e0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 61 (if (null? rema
68f0: 29 0a 09 09 28 70 72 69 6e 74 20 22 5b 22 20 73 )...(print "[" s
6900: 74 72 20 22 7b 74 61 72 67 65 74 3a 22 20 74 61 tr "{target:" ta
6910: 72 67 65 74 20 22 2c 72 75 6e 2d 6e 61 6d 65 3a rget ",run-name:
6920: 22 20 72 75 6e 2d 6e 61 6d 65 20 22 2c 20 72 75 " run-name ", ru
6930: 6e 2d 74 69 6d 65 3a 22 20 72 75 6e 2d 74 69 6d n-time:" run-tim
6940: 65 20 22 7d 5d 22 29 0a 20 20 20 20 20 20 20 20 e "}]").
6950: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 (loop (car r
6960: 65 6d 61 29 20 28 63 64 72 20 72 65 6d 61 29 20 ema) (cdr rema)
6970: 28 63 6f 6e 63 20 73 74 72 20 22 7b 74 61 72 67 (conc str "{targ
6980: 65 74 3a 22 20 74 61 72 67 65 74 20 22 2c 20 72 et:" target ", r
6990: 75 6e 2d 6e 61 6d 65 3a 22 20 72 75 6e 2d 6e 61 un-name:" run-na
69a0: 6d 65 20 22 2c 20 72 75 6e 2d 74 69 6d 65 3a 22 me ", run-time:"
69b0: 20 72 75 6e 2d 74 69 6d 65 20 22 7d 22 29 29 29 run-time "}")))
69c0: 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 )))..#;(define (
69d0: 74 61 73 6b 3a 67 65 74 2d 72 75 6e 2d 74 69 6d task:get-run-tim
69e0: 65 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 20 0a es). (let* ( .
69f0: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d (run-
6a00: 70 61 74 74 20 28 69 66 20 28 61 72 67 73 3a 67 patt (if (args:g
6a10: 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 70 61 74 et-arg "-run-pat
6a20: 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t").
6a30: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 (arg
6a40: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d s:get-arg "-run-
6a50: 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 patt").
6a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
6a70: 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 %")).
6a80: 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 69 66 (target-patt (if
6a90: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6aa0: 2d 74 61 72 67 65 74 2d 70 61 74 74 22 29 0a 20 -target-patt").
6ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ac0: 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 (args:get
6ad0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 -arg "-target-pa
6ae0: 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 tt").
6af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
6b00: 29 29 0a 20 0a 20 20 20 20 20 20 20 20 20 20 20 )). .
6b10: 28 72 75 6e 2d 74 69 6d 65 73 20 20 28 72 6d 74 (run-times (rmt
6b20: 3a 67 65 74 2d 72 75 6e 2d 74 69 6d 65 73 20 20 :get-run-times
6b30: 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d run-patt target-
6b40: 70 61 74 74 20 29 29 29 0a 20 20 20 28 69 66 20 patt ))). (if
6b50: 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 72 75 6e (eq? (length run
6b60: 2d 74 69 6d 65 73 29 20 30 29 0a 20 20 20 20 20 -times) 0).
6b70: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 70 (begin. (p
6b80: 72 69 6e 74 20 22 44 61 74 61 20 6e 6f 74 20 66 rint "Data not f
6b90: 6f 75 6e 64 21 21 22 29 0a 20 20 20 20 20 20 20 ound!!").
6ba0: 28 65 78 69 74 29 29 29 0a 20 20 20 28 69 66 20 (exit))). (if
6bb0: 28 65 71 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 (equal? (args:ge
6bc0: 74 2d 61 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 t-arg "-dumpmode
6bd0: 22 29 20 22 6a 73 6f 6e 22 29 0a 20 20 20 20 20 ") "json").
6be0: 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 72 75 (task:print-ru
6bf0: 6e 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 72 75 ntime-as-json ru
6c00: 6e 2d 74 69 6d 65 73 29 0a 20 20 20 20 20 20 20 n-times).
6c10: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 (if (equal? (a
6c20: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 75 rgs:get-arg "-du
6c30: 6d 70 6d 6f 64 65 22 29 20 22 63 73 76 22 29 0a mpmode") "csv").
6c40: 09 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 6e . (task:prin
6c50: 74 2d 72 75 6e 74 69 6d 65 20 72 75 6e 2d 74 69 t-runtime run-ti
6c60: 6d 65 73 20 22 2c 22 29 0a 09 20 20 20 20 20 28 mes ",").. (
6c70: 74 61 73 6b 3a 70 72 69 6e 74 2d 72 75 6e 74 69 task:print-runti
6c80: 6d 65 20 72 75 6e 2d 74 69 6d 65 73 20 22 20 20 me run-times "
6c90: 22 29 29 29 29 29 0a 0a 0a 23 3b 28 64 65 66 69 ")))))...#;(defi
6ca0: 6e 65 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 ne (task:print-t
6cb0: 65 73 74 74 69 6d 65 20 74 65 73 74 2d 74 69 6d esttime test-tim
6cc0: 65 73 20 73 61 70 65 72 61 74 6f 72 29 0a 28 66 es saperator).(f
6cd0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 28 6c 61 6d or-each. (lam
6ce0: 62 64 61 20 28 74 65 73 74 2d 74 69 6d 65 2d 69 bda (test-time-i
6cf0: 6e 66 6f 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 nfo). (let*
6d00: 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 28 76 65 ((test-name (ve
6d10: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 2d 74 69 ctor-ref test-ti
6d20: 6d 65 2d 69 6e 66 6f 20 30 29 29 0a 20 20 20 20 me-info 0)).
6d30: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 74 69 (test-ti
6d40: 6d 65 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 me (vector-ref
6d50: 74 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 32 test-time-info 2
6d60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
6d70: 74 65 73 74 2d 69 74 65 6d 20 20 28 69 66 20 28 test-item (if (
6d80: 65 71 3f 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 eq? (string-leng
6d90: 74 68 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 th (vector-ref t
6da0: 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 31 29 est-time-info 1)
6db0: 29 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 ) 0).
6dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6dd0: 20 20 20 20 22 4e 2f 41 22 0a 09 09 09 09 28 76 "N/A".....(v
6de0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 2d 74 ector-ref test-t
6df0: 69 6d 65 2d 69 6e 66 6f 20 31 29 29 29 29 0a 20 ime-info 1)))).
6e00: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 20 74 (print t
6e10: 65 73 74 2d 6e 61 6d 65 20 73 61 70 65 72 61 74 est-name saperat
6e20: 6f 72 20 74 65 73 74 2d 69 74 65 6d 20 73 61 70 or test-item sap
6e30: 65 72 61 74 6f 72 20 74 65 73 74 2d 74 69 6d 65 erator test-time
6e40: 20 29 29 29 0a 20 20 20 74 65 73 74 2d 74 69 6d ))). test-tim
6e50: 65 73 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 es))..#;(define
6e60: 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 74 (task:print-test
6e70: 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 65 73 time-as-json tes
6e80: 74 2d 74 69 6d 65 73 29 0a 20 28 6c 65 74 20 6c t-times). (let l
6e90: 6f 6f 70 20 28 28 74 65 73 74 2d 74 69 6d 65 2d oop ((test-time-
6ea0: 69 6e 66 6f 20 28 63 61 72 20 74 65 73 74 2d 74 info (car test-t
6eb0: 69 6d 65 73 29 29 0a 20 20 20 20 20 20 20 20 20 imes)).
6ec0: 20 20 20 28 72 65 6d 61 20 28 63 64 72 20 74 65 (rema (cdr te
6ed0: 73 74 2d 74 69 6d 65 73 29 29 20 0a 20 20 20 20 st-times)) .
6ee0: 20 20 20 20 20 20 20 20 28 73 74 72 20 22 22 29 (str "")
6ef0: 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 ). (let* ((t
6f00: 65 73 74 2d 6e 61 6d 65 20 20 28 76 65 63 74 6f est-name (vecto
6f10: 72 2d 72 65 66 20 74 65 73 74 2d 74 69 6d 65 2d r-ref test-time-
6f20: 69 6e 66 6f 20 30 29 29 0a 20 20 20 20 20 20 20 info 0)).
6f30: 20 20 20 20 20 28 74 65 73 74 2d 74 69 6d 65 20 (test-time
6f40: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
6f50: 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 32 29 29 0a t-time-info 2)).
6f60: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 74 65 (ite
6f70: 6d 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 m (vector-ref t
6f80: 65 73 74 2d 74 69 6d 65 2d 69 6e 66 6f 20 31 29 est-time-info 1)
6f90: 29 29 0a 20 20 20 20 20 20 20 20 3b 28 70 72 69 )). ;(pri
6fa0: 6e 74 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 nt (not (equal?
6fb0: 73 74 72 20 22 22 29 29 29 0a 20 20 20 20 20 20 str ""))).
6fc0: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa
6fd0: 6c 3f 20 73 74 72 20 22 22 29 29 20 0a 20 20 20 l? str "")) .
6fe0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 73 (set! s
6ff0: 74 72 20 28 63 6f 6e 63 20 73 74 72 20 22 2c 22 tr (conc str ","
7000: 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ))). (if
7010: 28 6e 75 6c 6c 3f 20 72 65 6d 61 29 0a 09 09 28 (null? rema)...(
7020: 70 72 69 6e 74 20 22 5b 22 20 73 74 72 20 22 7b print "[" str "{
7030: 74 65 73 74 2d 6e 61 6d 65 3a 22 20 74 65 73 74 test-name:" test
7040: 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 -name ", item-pa
7050: 74 68 3a 22 20 69 74 65 6d 20 22 2c 20 74 65 73 th:" item ", tes
7060: 74 2d 74 69 6d 65 3a 22 20 74 65 73 74 2d 74 69 t-time:" test-ti
7070: 6d 65 20 22 7d 5d 22 29 0a 20 20 20 20 20 20 20 me "}]").
7080: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
7090: 72 65 6d 61 29 20 28 63 64 72 20 72 65 6d 61 29 rema) (cdr rema)
70a0: 20 28 63 6f 6e 63 20 73 74 72 20 22 7b 74 65 73 (conc str "{tes
70b0: 74 2d 6e 61 6d 65 3a 22 20 74 65 73 74 2d 6e 61 t-name:" test-na
70c0: 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3a me ", item-path:
70d0: 22 20 69 74 65 6d 20 22 2c 20 74 65 73 74 2d 74 " item ", test-t
70e0: 69 6d 65 3a 22 20 74 65 73 74 2d 74 69 6d 65 20 ime:" test-time
70f0: 22 7d 22 29 29 29 29 29 29 0a 0a 0a 23 3b 20 28 "}"))))))...#; (
7100: 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 67 65 74 define (task:get
7110: 2d 74 65 73 74 2d 74 69 6d 65 73 29 0a 20 20 20 -test-times).
7120: 28 6c 65 74 2a 20 28 28 72 75 6e 6e 61 6d 65 20 (let* ((runname
7130: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
7140: 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 20 20 g "-runname").
7150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7160: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
7170: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
7180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7190: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 #f)).
71a0: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 (target
71b0: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
71c0: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 20 g "-target").
71d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71e0: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
71f0: 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 rg "-target").
7200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7210: 20 20 20 20 20 20 23 66 29 29 0a 20 0a 20 20 20 #f)). .
7220: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 74 69 (test-ti
7230: 6d 65 73 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 mes (rmt:get-te
7240: 73 74 2d 74 69 6d 65 73 20 20 72 75 6e 6e 61 6d st-times runnam
7250: 65 20 74 61 72 67 65 74 20 29 29 29 0a 20 20 20 e target ))).
7260: 28 69 66 20 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 (if (not runname
7270: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
7280: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 (print "Err
7290: 6f 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 or: Missing argu
72a0: 6d 65 6e 74 20 2d 72 75 6e 6e 61 6d 65 22 29 0a ment -runname").
72b0: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 20 0a (exit))) .
72c0: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d (if (string-
72d0: 63 6f 6e 74 61 69 6e 73 20 72 75 6e 6e 61 6d 65 contains runname
72e0: 20 22 25 22 29 0a 20 20 20 20 20 20 28 62 65 67 "%"). (beg
72f0: 69 6e 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 in. (print
7300: 22 45 72 72 6f 72 3a 20 49 6e 76 61 6c 69 64 20 "Error: Invalid
7310: 72 75 6e 6e 61 6d 65 2c 20 27 25 27 20 6e 6f 74 runname, '%' not
7320: 20 61 6c 6c 6f 77 65 64 20 20 28 22 20 72 75 6e allowed (" run
7330: 6e 61 6d 65 20 22 29 20 22 29 0a 20 20 20 20 20 name ") ").
7340: 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 69 (exit))). (i
7350: 66 20 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 f (not target).
7360: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
7370: 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f 72 3a (print "Error:
7380: 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d 65 6e Missing argumen
7390: 74 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 t -target").
73a0: 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 20 (exit))).
73b0: 28 69 66 20 20 28 73 74 72 69 6e 67 2d 63 6f 6e (if (string-con
73c0: 74 61 69 6e 73 20 74 61 72 67 65 74 20 22 25 22 tains target "%"
73d0: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
73e0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 (print "Err
73f0: 6f 72 3a 20 49 6e 76 61 6c 69 64 20 74 61 72 67 or: Invalid targ
7400: 65 74 2c 20 27 25 27 20 6e 6f 74 20 61 6c 6c 6f et, '%' not allo
7410: 77 65 64 20 20 28 22 20 74 61 72 67 65 74 20 22 wed (" target "
7420: 29 20 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 ) "). (exit
7430: 29 29 29 0a 20 0a 20 20 20 28 69 66 20 28 65 71 ))). . (if (eq
7440: 3f 20 28 6c 65 6e 67 74 68 20 74 65 73 74 2d 74 ? (length test-t
7450: 69 6d 65 73 29 20 30 29 0a 20 20 20 20 20 28 62 imes) 0). (b
7460: 65 67 69 6e 0a 20 20 20 20 20 20 20 28 70 72 69 egin. (pri
7470: 6e 74 20 22 44 61 74 61 20 6e 6f 74 20 66 6f 75 nt "Data not fou
7480: 6e 64 21 21 22 29 0a 20 20 20 20 20 20 20 28 65 nd!!"). (e
7490: 78 69 74 29 29 29 0a 20 20 20 28 69 66 20 28 65 xit))). (if (e
74a0: 71 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 74 2d qual? (args:get-
74b0: 61 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 22 29 arg "-dumpmode")
74c0: 20 22 6a 73 6f 6e 22 29 0a 20 20 20 20 20 20 20 "json").
74d0: 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 74 (task:print-test
74e0: 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 65 73 time-as-json tes
74f0: 74 2d 74 69 6d 65 73 29 0a 20 20 20 20 20 20 20 t-times).
7500: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 (if (equal? (a
7510: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 75 rgs:get-arg "-du
7520: 6d 70 6d 6f 64 65 22 29 20 22 63 73 76 22 29 0a mpmode") "csv").
7530: 09 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 6e . (task:prin
7540: 74 2d 74 65 73 74 74 69 6d 65 20 74 65 73 74 2d t-testtime test-
7550: 74 69 6d 65 73 20 22 2c 22 29 0a 09 20 20 20 20 times ",")..
7560: 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 (task:print-tes
7570: 74 74 69 6d 65 20 74 65 73 74 2d 74 69 6d 65 73 ttime test-times
7580: 20 22 20 20 22 29 29 29 29 29 0a 0a 0a 0a 3b 3b " ")))))....;;
7590: 20 67 65 74 73 20 6d 74 70 67 2d 72 75 6e 2d 69 gets mtpg-run-i
75a0: 64 20 61 6e 64 20 73 79 6e 63 73 20 74 68 65 20 d and syncs the
75b0: 72 65 63 6f 72 64 20 69 66 20 64 69 66 66 65 72 record if differ
75c0: 65 6e 74 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 ent.;;.#;(define
75d0: 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e (tasks:run-id->
75e0: 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 mtpg-run-id dbh
75f0: 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d cached-info run-
7600: 69 64 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 id area-info sma
7610: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
7620: 65 2d 74 69 6d 65 29 0a 20 20 28 6c 65 74 2a 20 e-time). (let*
7630: 28 28 72 75 6e 73 2d 68 74 20 28 68 61 73 68 2d ((runs-ht (hash-
7640: 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 table-ref cached
7650: 2d 69 6e 66 6f 20 27 72 75 6e 73 29 29 0a 09 20 -info 'runs))..
7660: 28 72 75 6e 69 6e 66 20 20 28 68 61 73 68 2d 74 (runinf (hash-t
7670: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7680: 20 72 75 6e 73 2d 68 74 20 72 75 6e 2d 69 64 20 runs-ht run-id
7690: 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 #f)). (a
76a0: 72 65 61 2d 69 64 20 28 76 65 63 74 6f 72 2d 72 rea-id (vector-r
76b0: 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 ef area-info 0))
76c0: 29 0a 20 20 20 20 20 20 20 28 69 66 20 72 75 6e ). (if run
76d0: 69 6e 66 0a 09 72 75 6e 69 6e 66 20 3b 3b 20 61 inf..runinf ;; a
76e0: 6c 72 65 61 64 79 20 63 61 63 68 65 64 0a 09 28 lready cached..(
76f0: 6c 65 74 2a 20 28 28 72 75 6e 2d 64 61 74 20 20 let* ((run-dat
7700: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 (rmt:get-run-i
7710: 6e 66 6f 20 72 75 6e 2d 69 64 29 29 20 20 20 20 nfo run-id))
7720: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4e 4f ;; NO
7730: 54 45 3a 20 67 65 74 2d 72 75 6e 2d 69 6e 66 6f TE: get-run-info
7740: 20 72 65 74 75 72 6e 73 20 61 20 76 65 63 74 6f returns a vecto
7750: 72 20 3c 20 72 6f 77 20 68 65 61 64 65 72 20 3e r < row header >
7760: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 .. (run-na
7770: 6d 65 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 me (rmt:get-ru
7780: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 n-name-from-id r
7790: 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 20 20 un-id))..
77a0: 28 72 6f 77 20 20 20 20 20 20 20 20 28 64 62 3a (row (db:
77b0: 67 65 74 2d 72 6f 77 73 20 72 75 6e 2d 64 61 74 get-rows run-dat
77c0: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
77d0: 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 ;; yes, thi
77e0: 73 20 72 65 74 75 72 6e 73 20 61 20 73 69 6e 67 s returns a sing
77f0: 6c 65 20 72 6f 77 0a 09 20 20 20 20 20 20 20 28 le row.. (
7800: 68 65 61 64 65 72 20 20 20 20 20 28 64 62 3a 67 header (db:g
7810: 65 74 2d 68 65 61 64 65 72 20 72 75 6e 2d 64 61 et-header run-da
7820: 74 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 t)).. (sta
7830: 74 65 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d te (db:get-
7840: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7850: 72 6f 77 20 68 65 61 64 65 72 20 22 73 74 61 74 row header "stat
7860: 65 22 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 e")).. (st
7870: 61 74 75 73 20 20 20 20 20 28 64 62 3a 67 65 74 atus (db:get
7880: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
7890: 20 72 6f 77 20 68 65 61 64 65 72 20 22 73 74 61 row header "sta
78a0: 74 75 73 22 29 29 0a 09 20 20 20 20 20 20 20 28 tus")).. (
78b0: 6f 77 6e 65 72 20 20 20 20 20 20 28 64 62 3a 67 owner (db:g
78c0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
78d0: 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 6f er row header "o
78e0: 77 6e 65 72 22 29 29 0a 09 20 20 20 20 20 20 20 wner"))..
78f0: 28 65 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a (event-time (db:
7900: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
7910: 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 der row header "
7920: 65 76 65 6e 74 5f 74 69 6d 65 22 29 29 0a 09 20 event_time"))..
7930: 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 (comment
7940: 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d (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 6d 6d 65 6e 74 22 29 29 ader "comment"))
7970: 0a 09 20 20 20 20 20 20 20 28 66 61 69 6c 2d 63 .. (fail-c
7980: 6f 75 6e 74 20 28 64 62 3a 67 65 74 2d 76 61 6c ount (db:get-val
7990: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 ue-by-header row
79a0: 20 68 65 61 64 65 72 20 22 66 61 69 6c 5f 63 6f header "fail_co
79b0: 75 6e 74 22 29 29 0a 09 20 20 20 20 20 20 20 28 unt")).. (
79c0: 70 61 73 73 2d 63 6f 75 6e 74 20 28 64 62 3a 67 pass-count (db:g
79d0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
79e0: 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 70 er row header "p
79f0: 61 73 73 5f 63 6f 75 6e 74 22 29 29 0a 20 20 20 ass_count")).
7a00: 20 20 20 20 20 20 28 64 62 2d 63 6f 6e 74 6f 75 (db-contou
7a10: 72 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d r (db:get-value-
7a20: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
7a30: 61 64 65 72 20 22 63 6f 6e 74 6f 75 72 22 29 29 ader "contour"))
7a40: 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 74 6f 75 .. (contou
7a50: 72 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 r (if (args:g
7a60: 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 6e 64 et-arg "-prepend
7a70: 2d 63 6f 6e 74 6f 75 72 22 29 20 0a 20 20 20 20 -contour") .
7a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
7aa0: 20 28 61 6e 64 20 64 62 2d 63 6f 6e 74 6f 75 72 (and db-contour
7ab0: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 64 62 (not (equal? db
7ac0: 2d 63 6f 6e 74 6f 75 72 20 22 22 29 29 20 20 28 -contour "")) (
7ad0: 73 74 72 69 6e 67 3f 20 64 62 2d 63 6f 6e 74 6f string? db-conto
7ae0: 75 72 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 ur )) .
7af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b10: 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 (begin .
7b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b40: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7b50: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
7b60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 64 lt-log-port* "d
7b70: 62 2d 63 6f 6e 74 6f 75 72 22 29 20 0a 20 09 09 b-contour") . ..
7b80: 09 09 09 09 64 62 2d 63 6f 6e 74 6f 75 72 29 0a ....db-contour).
7b90: 09 09 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 ..... (args:g
7ba0: 65 74 2d 61 72 67 20 22 2d 63 6f 6e 74 6f 75 72 et-arg "-contour
7bb0: 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 ")))). (
7bc0: 72 75 6e 2d 74 61 67 20 28 69 66 20 28 61 72 67 run-tag (if (arg
7bd0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d s:get-arg "-run-
7be0: 74 61 67 22 29 0a 20 20 20 20 20 20 20 20 20 20 tag").
7bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c00: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
7c10: 22 2d 72 75 6e 2d 74 61 67 22 29 0a 09 09 09 09 "-run-tag").....
7c20: 09 09 09 09 09 22 22 29 29 0a 20 20 20 20 20 20 ....."")).
7c30: 20 20 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 (last-update
7c40: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
7c50: 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 -header row head
7c60: 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 er "last_update"
7c70: 29 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 74 )).. (keyt
7c80: 61 72 67 20 20 20 20 28 69 66 20 28 6f 72 20 28 arg (if (or (
7c90: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 args:get-arg "-p
7ca0: 72 65 70 65 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 repend-contour")
7cb0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7cc0: 2d 70 72 65 66 69 78 2d 74 61 72 67 65 74 22 29 -prefix-target")
7cd0: 29 0a 09 20 20 20 20 20 20 20 09 09 09 28 63 6f ).. ...(co
7ce0: 6e 63 20 22 4d 54 5f 43 4f 4e 54 4f 55 52 2f 4d nc "MT_CONTOUR/M
7cf0: 54 5f 41 52 45 41 2f 22 20 28 73 74 72 69 6e 67 T_AREA/" (string
7d00: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 72 6d -intersperse (rm
7d10: 74 3a 67 65 74 2d 6b 65 79 73 29 20 22 2f 22 29 t:get-keys) "/")
7d20: 29 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 ) (string-inters
7d30: 70 65 72 73 65 20 28 72 6d 74 3a 67 65 74 2d 6b perse (rmt:get-k
7d40: 65 79 73 29 20 22 2f 22 29 29 29 20 3b 3b 20 65 eys) "/"))) ;; e
7d50: 2e 67 2e 20 76 65 72 73 69 6f 6e 2f 69 74 65 72 .g. version/iter
7d60: 61 74 69 6f 6e 2f 70 6c 61 74 66 6f 72 6d 0a 09 ation/platform..
7d70: 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 20 (target
7d80: 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 67 73 (if (or (args
7d90: 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 :get-arg "-prepe
7da0: 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 20 28 61 72 nd-contour") (ar
7db0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
7dc0: 66 69 78 2d 74 61 72 67 65 74 22 29 29 20 0a 09 fix-target")) ..
7dd0: 20 20 20 20 20 20 20 09 09 09 28 63 6f 6e 63 20 ...(conc
7de0: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
7df0: 67 20 22 2d 70 72 65 66 69 78 2d 74 61 72 67 65 g "-prefix-targe
7e00: 74 22 29 20 28 63 6f 6e 63 20 63 6f 6e 74 6f 75 t") (conc contou
7e10: 72 20 22 2f 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 r "/" (common:ge
7e20: 74 2d 61 72 65 61 2d 6e 61 6d 65 20 2a 61 6c 6c t-area-name *all
7e30: 64 61 74 2a 29 20 22 2f 22 29 29 20 28 72 6d 74 dat*) "/")) (rmt
7e40: 3a 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d :get-target run-
7e50: 69 64 29 29 20 28 72 6d 74 3a 67 65 74 2d 74 61 id)) (rmt:get-ta
7e60: 72 67 65 74 20 72 75 6e 2d 69 64 29 29 29 20 20 rget run-id)))
7e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
7e80: 3b 20 65 2e 67 2e 20 76 31 2e 36 33 2f 61 33 65 ; e.g. v1.63/a3e
7e90: 31 2f 75 62 75 6e 74 75 0a 09 20 20 20 20 20 20 1/ubuntu..
7ea0: 20 28 73 70 65 63 2d 69 64 20 20 20 20 28 70 67 (spec-id (pg
7eb0: 64 62 3a 67 65 74 2d 74 74 79 70 65 20 64 62 68 db:get-ttype dbh
7ec0: 20 6b 65 79 74 61 72 67 29 29 0a 09 20 20 20 20 keytarg))..
7ed0: 20 20 20 28 70 75 62 6c 69 73 68 2d 74 69 6d 65 (publish-time
7ee0: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
7ef0: 72 67 20 22 2d 63 70 2d 65 76 65 6e 74 74 69 6d rg "-cp-eventtim
7f00: 65 2d 74 6f 2d 70 75 62 6c 69 73 68 74 69 6d 65 e-to-publishtime
7f10: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
7f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 e
7f30: 76 65 6e 74 2d 74 69 6d 65 0a 20 20 20 20 20 20 vent-time.
7f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f50: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 (current-se
7f60: 63 6f 6e 64 73 29 29 29 20 0a 09 20 20 20 20 20 conds))) ..
7f70: 20 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 28 70 (new-run-id (p
7f80: 67 64 62 3a 67 65 74 2d 72 75 6e 2d 69 64 20 64 gdb:get-run-id d
7f90: 62 68 20 73 70 65 63 2d 69 64 20 74 61 72 67 65 bh spec-id targe
7fa0: 74 20 72 75 6e 2d 6e 61 6d 65 20 61 72 65 61 2d t run-name area-
7fb0: 69 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 id))). (
7fc0: 69 66 20 6e 65 77 2d 72 75 6e 2d 69 64 0a 09 20 if new-run-id..
7fd0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 3b (begin ;
7fe0: 3b 20 6c 65 74 20 28 28 72 75 6e 2d 72 65 63 6f ; let ((run-reco
7ff0: 72 64 20 28 70 67 64 62 3a 67 65 74 2d 72 75 6e rd (pgdb:get-run
8000: 2d 69 6e 66 6f 20 64 62 68 20 6e 65 77 2d 72 75 -info dbh new-ru
8010: 6e 2d 69 64 29 29 0a 09 09 20 20 20 20 20 20 20 n-id))...
8020: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
8030: 21 20 72 75 6e 73 2d 68 74 20 72 75 6e 2d 69 64 ! runs-ht run-id
8040: 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 09 09 3b new-run-id)...;
8050: 3b 20 65 6e 73 75 72 65 20 6b 65 79 20 66 69 65 ; ensure key fie
8060: 6c 64 73 20 61 72 65 20 75 70 20 74 6f 20 64 61 lds are up to da
8070: 74 65 0a 20 20 20 20 20 3b 3b 20 69 66 20 6c 61 te. ;; if la
8080: 73 74 5f 75 70 64 61 74 65 20 3d 3d 20 70 67 64 st_update == pgd
8090: 62 5f 6c 61 73 74 5f 75 70 64 61 74 65 20 64 6f b_last_update do
80a0: 20 6e 6f 74 20 75 70 64 61 74 65 20 73 6d 61 6c not update smal
80b0: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
80c0: 2d 74 69 6d 65 20 20 0a 20 20 20 20 28 6c 65 74 -time . (let
80d0: 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 70 * ((pgdb-last-up
80e0: 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d 72 date (pgdb:get-r
80f0: 75 6e 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 64 un-last-update d
8100: 62 68 20 6e 65 77 2d 72 75 6e 2d 69 64 29 29 0a bh new-run-id)).
8110: 20 20 20 20 20 20 20 20 20 20 20 28 73 6d 61 6c (smal
8120: 6c 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 2d lest-time (hash-
8130: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
8140: 74 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d t smallest-last-
8150: 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 update-time "sma
8160: 6c 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 29 llest-time" #f))
8170: 29 0a 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 ). (if (and
8180: 20 28 3e 20 6c 61 73 74 2d 75 70 64 61 74 65 20 (> last-update
8190: 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 pgdb-last-update
81a0: 29 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c ) (or (not small
81b0: 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 est-time) (< las
81c0: 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 t-update smalles
81d0: 74 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 t-time))).
81e0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
81f0: 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 t! smallest-last
8200: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d -update-time "sm
8210: 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 allest-time" las
8220: 74 2d 75 70 64 61 74 65 29 29 29 0a 09 09 28 70 t-update)))...(p
8230: 67 64 62 3a 72 65 66 72 65 73 68 2d 72 75 6e 2d gdb:refresh-run-
8240: 69 6e 66 6f 0a 09 09 20 64 62 68 0a 09 09 20 6e info... dbh... n
8250: 65 77 2d 72 75 6e 2d 69 64 0a 09 09 20 73 74 61 ew-run-id... sta
8260: 74 65 20 73 74 61 74 75 73 20 6f 77 6e 65 72 20 te status owner
8270: 65 76 65 6e 74 2d 74 69 6d 65 20 63 6f 6d 6d 65 event-time comme
8280: 6e 74 20 66 61 69 6c 2d 63 6f 75 6e 74 20 70 61 nt fail-count pa
8290: 73 73 2d 63 6f 75 6e 74 20 61 72 65 61 2d 69 64 ss-count area-id
82a0: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 75 62 last-update pub
82b0: 6c 69 73 68 2d 74 69 6d 65 29 0a 20 20 20 20 20 lish-time).
82c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
82d0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
82e0: 2d 70 6f 72 74 2a 20 22 57 6f 72 6b 69 6e 67 20 -port* "Working
82f0: 6f 6e 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d on run-id " run-
8300: 69 64 20 22 20 70 67 64 62 2d 69 64 20 22 20 20 id " pgdb-id "
8310: 6e 65 77 2d 72 75 6e 2d 69 64 20 29 0a 20 20 20 new-run-id ).
8320: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa
8330: 6c 3f 20 72 75 6e 2d 74 61 67 20 22 22 29 29 0a l? run-tag "")).
8340: 20 20 20 20 20 20 28 74 61 73 6b 3a 61 64 64 2d (task:add-
8350: 72 75 6e 2d 74 61 67 20 64 62 68 20 6e 65 77 2d run-tag dbh new-
8360: 72 75 6e 2d 69 64 20 72 75 6e 2d 74 61 67 29 29 run-id run-tag))
8370: 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 29 20 0a ...new-run-id) .
8380: 20 20 20 20 20 20 0a 09 20 20 20 20 20 20 28 69 .. (i
8390: 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 65 20 f (equal? state
83a0: 22 64 65 6c 65 74 65 64 22 29 0a 20 20 20 20 20 "deleted").
83b0: 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 (begin .
83c0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
83d0: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
83e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
83f0: 57 61 72 6e 69 6e 67 3a 20 52 75 6e 20 77 69 74 Warning: Run wit
8400: 68 20 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 h id " run-id "
8410: 77 61 73 20 63 72 65 61 74 65 64 20 61 66 74 65 was created afte
8420: 72 20 70 72 65 76 69 6f 75 73 20 73 79 6e 63 20 r previous sync
8430: 61 6e 64 20 64 65 6c 65 74 65 64 20 62 65 66 6f and deleted befo
8440: 72 65 20 74 68 65 20 73 79 6e 63 22 29 20 23 66 re the sync") #f
8450: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
8460: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
8470: 6e 73 0a 09 09 20 20 20 20 20 20 20 20 65 78 6e ns... exn
8480: 0a 09 09 20 20 20 20 20 20 20 20 28 62 65 67 69 ... (begi
8490: 6e 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 n (print-call-ch
84a0: 61 69 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 ain).
84b0: 20 20 20 28 70 72 69 6e 74 20 28 28 63 6f 6e 64 (print ((cond
84c0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
84d0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
84e0: 73 73 61 67 65 29 20 65 78 6e 29 29 20 20 20 20 ssage) exn))
84f0: 20 0a 09 09 09 20 20 20 20 20 20 23 66 29 0a 20 .... #f).
8500: 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 .
8510: 20 20 20 20 20 20 20 20 28 70 67 64 62 3a 69 6e (pgdb:in
8520: 73 65 72 74 2d 72 75 6e 0a 09 09 20 20 20 20 20 sert-run...
8530: 64 62 68 0a 09 09 20 20 20 20 20 73 70 65 63 2d dbh... spec-
8540: 69 64 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 id target run-na
8550: 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 me state status
8560: 6f 77 6e 65 72 20 65 76 65 6e 74 2d 74 69 6d 65 owner event-time
8570: 20 63 6f 6d 6d 65 6e 74 20 66 61 69 6c 2d 63 6f comment fail-co
8580: 75 6e 74 20 70 61 73 73 2d 63 6f 75 6e 74 20 20 unt pass-count
8590: 61 72 65 61 2d 69 64 20 6c 61 73 74 2d 75 70 64 area-id last-upd
85a0: 61 74 65 20 70 75 62 6c 69 73 68 2d 74 69 6d 65 ate publish-time
85b0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 ))... (let
85c0: 2a 20 28 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d * ((smallest-tim
85d0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
85e0: 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 f/default smalle
85f0: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
8600: 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 ime "smallest-ti
8610: 6d 65 22 20 23 66 29 29 29 0a 20 20 20 20 20 20 me" #f))).
8620: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
8630: 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d not smallest-tim
8640: 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 74 e) (< last-updat
8650: 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 e smallest-time)
8660: 29 0a 20 20 20 20 20 20 20 20 09 09 09 09 28 68 ). ....(h
8670: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
8680: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
8690: 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 ate-time "smalle
86a0: 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 st-time" last-up
86b0: 64 61 74 65 29 29 0a 20 20 20 20 20 20 20 20 20 date)).
86c0: 20 20 20 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 (tasks:run-i
86d0: 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 d->mtpg-run-id d
86e0: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 bh cached-info r
86f0: 75 6e 2d 69 64 20 61 72 65 61 2d 69 6e 66 6f 20 un-id area-info
8700: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
8710: 64 61 74 65 2d 74 69 6d 65 29 29 0a 09 09 20 20 date-time))...
8720: 23 66 29 29 29 29 29 29 29 0a 0a 23 3b 28 64 65 #f)))))))..#;(de
8730: 66 69 6e 65 20 28 74 61 73 6b 3a 61 64 64 2d 72 fine (task:add-r
8740: 75 6e 2d 74 61 67 20 64 62 68 20 72 75 6e 2d 69 un-tag dbh run-i
8750: 64 20 74 61 67 29 20 0a 20 20 28 6c 65 74 2a 20 d tag) . (let*
8760: 28 28 74 61 67 2d 69 6e 66 6f 20 28 70 67 64 62 ((tag-info (pgdb
8770: 3a 67 65 74 2d 74 61 67 2d 69 6e 66 6f 2d 62 79 :get-tag-info-by
8780: 2d 6e 61 6d 65 20 64 62 68 20 74 61 67 29 29 29 -name dbh tag)))
8790: 0a 20 20 20 28 69 66 20 28 6e 6f 74 20 74 61 67 . (if (not tag
87a0: 2d 69 6e 66 6f 29 0a 20 20 20 20 20 28 62 65 67 -info). (beg
87b0: 69 6e 20 20 20 0a 20 20 20 20 20 28 69 66 20 28 in . (if (
87c0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
87d0: 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 20 28 62 s.. exn.. (b
87e0: 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 egin .
87f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8800: 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c t-info 1 *defaul
8810: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 28 63 t-log-port* ((c
8820: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
8830: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
8840: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 20 'message) exn))
8850: 20 20 20 20 0a 09 20 20 20 23 66 29 0a 09 20 20 .. #f)..
8860: 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d 74 61 (pgdb:insert-ta
8870: 67 20 20 64 62 68 20 20 20 74 61 67 29 29 0a 20 g dbh tag)).
8880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8890: 20 20 20 20 20 20 28 73 65 74 21 20 74 61 67 2d (set! tag-
88a0: 69 6e 66 6f 20 28 70 67 64 62 3a 67 65 74 2d 74 info (pgdb:get-t
88b0: 61 67 2d 69 6e 66 6f 2d 62 79 2d 6e 61 6d 65 20 ag-info-by-name
88c0: 64 62 68 20 74 61 67 29 29 0a 09 09 20 20 23 66 dbh tag))... #f
88d0: 29 29 29 0a 20 20 20 20 20 3b 3b 61 64 64 20 74 ))). ;;add t
88e0: 6f 20 61 72 65 61 5f 74 61 67 73 0a 20 20 20 20 o area_tags.
88f0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
8900: 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 20 ons.. exn..
8910: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
8920: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
8930: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
8940: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 ult-log-port* (
8950: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
8960: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
8970: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
8980: 29 20 20 20 20 20 0a 09 20 20 20 23 66 29 0a 20 ) .. #f).
8990: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
89a0: 6f 74 20 28 70 67 64 62 3a 69 73 2d 72 75 6e 2d ot (pgdb:is-run-
89b0: 74 61 67 65 64 2d 77 69 74 68 2d 61 2d 74 61 67 taged-with-a-tag
89c0: 20 64 62 68 20 28 76 65 63 74 6f 72 2d 72 65 66 dbh (vector-ref
89d0: 20 74 61 67 2d 69 6e 66 6f 20 30 29 20 20 72 75 tag-info 0) ru
89e0: 6e 2d 69 64 29 29 20 20 0a 09 20 20 20 28 70 67 n-id)) .. (pg
89f0: 64 62 3a 69 6e 73 65 72 74 2d 72 75 6e 2d 74 61 db:insert-run-ta
8a00: 67 20 20 64 62 68 20 20 20 28 76 65 63 74 6f 72 g dbh (vector
8a10: 2d 72 65 66 20 74 61 67 2d 69 6e 66 6f 20 30 29 -ref tag-info 0)
8a20: 20 20 72 75 6e 2d 69 64 29 29 29 29 29 0a 0a 0a run-id)))))...
8a30: 23 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 #;(define (tasks
8a40: 3a 73 79 6e 63 2d 74 65 73 74 2d 73 74 65 70 73 :sync-test-steps
8a50: 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f dbh cached-info
8a60: 20 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 73 test-step-ids s
8a70: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
8a80: 61 74 65 2d 74 69 6d 65 29 0a 20 3b 20 28 70 72 ate-time). ; (pr
8a90: 69 6e 74 20 22 53 79 6e 63 20 53 74 65 70 73 20 int "Sync Steps
8aa0: 22 20 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 " test-step-ids
8ab0: 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d ). (let ((test-
8ac0: 68 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ht (hash-table-r
8ad0: 65 66 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 ef cached-info '
8ae0: 74 65 73 74 73 29 29 0a 20 20 20 20 20 20 20 20 tests)).
8af0: 28 73 74 65 70 2d 68 74 20 28 68 61 73 68 2d 74 (step-ht (hash-t
8b00: 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d able-ref cached-
8b10: 69 6e 66 6f 20 27 73 74 65 70 73 29 29 29 0a 20 info 'steps))).
8b20: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
8b30: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
8b40: 73 74 65 70 2d 69 64 29 0a 20 20 20 20 20 20 20 step-id).
8b50: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 74 (let* ((test-st
8b60: 65 70 2d 69 6e 66 6f 20 20 28 72 6d 74 3a 67 65 ep-info (rmt:ge
8b70: 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d t-steps-info-by-
8b80: 69 64 20 74 65 73 74 2d 73 74 65 70 2d 69 64 29 id test-step-id)
8b90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8ba0: 20 28 73 74 65 70 2d 69 64 20 28 74 64 62 3a 73 (step-id (tdb:s
8bb0: 74 65 70 2d 67 65 74 2d 69 64 20 74 65 73 74 2d tep-get-id test-
8bc0: 73 74 65 70 2d 69 6e 66 6f 29 29 0a 20 20 20 20 step-info)).
8bd0: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
8be0: 2d 69 64 20 20 28 74 64 62 3a 73 74 65 70 2d 67 -id (tdb:step-g
8bf0: 65 74 2d 74 65 73 74 5f 69 64 20 20 20 20 74 65 et-test_id te
8c00: 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 20 20 st-step-info))
8c10: 20 0a 09 20 20 20 20 20 20 20 28 73 74 65 70 6e .. (stepn
8c20: 61 6d 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 ame (tdb:step-ge
8c30: 74 2d 73 74 65 70 6e 61 6d 65 20 20 74 65 73 74 t-stepname test
8c40: 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 -step-info))..
8c50: 20 20 20 20 20 28 73 74 61 74 65 20 28 74 64 62 (state (tdb
8c60: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 :step-get-state
8c70: 74 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 test-step-info))
8c80: 09 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 75 ... (statu
8c90: 73 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d s (tdb:step-get-
8ca0: 73 74 61 74 75 73 20 74 65 73 74 2d 73 74 65 70 status test-step
8cb0: 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 20 20 20 -info))...
8cc0: 20 28 65 76 65 6e 74 5f 74 69 6d 65 20 28 74 64 (event_time (td
8cd0: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
8ce0: 5f 74 69 6d 65 20 20 74 65 73 74 2d 73 74 65 70 _time test-step
8cf0: 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 20 20 20 -info))...
8d00: 20 28 63 6f 6d 6d 65 6e 74 20 20 28 74 64 62 3a (comment (tdb:
8d10: 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 step-get-comment
8d20: 20 74 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 test-step-info)
8d30: 29 09 0a 09 20 20 20 20 20 20 20 28 6c 6f 67 66 )... (logf
8d40: 69 6c 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 ile (tdb:step-ge
8d50: 74 2d 6c 6f 67 66 69 6c 65 20 74 65 73 74 2d 73 t-logfile test-s
8d60: 74 65 70 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 tep-info))..
8d70: 20 20 20 20 20 28 6c 61 73 74 2d 75 70 64 61 74 (last-updat
8d80: 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d e (tdb:step-get-
8d90: 6c 61 73 74 5f 75 70 64 61 74 65 20 74 65 73 74 last_update test
8da0: 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 -step-info))..
8db0: 20 20 20 20 20 28 70 67 64 62 2d 74 65 73 74 2d (pgdb-test-
8dc0: 69 64 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d id (hash-table-
8dd0: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
8de0: 2d 68 74 20 74 65 73 74 2d 69 64 20 23 66 29 29 -ht test-id #f))
8df0: 0a 09 09 09 09 20 28 73 6d 61 6c 6c 65 73 74 2d ..... (smallest-
8e00: 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 time (hash-table
8e10: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 -ref/default sma
8e20: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
8e30: 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 e-time "smallest
8e40: 2d 74 69 6d 65 22 20 23 66 29 29 0a 20 20 20 20 -time" #f)).
8e50: 20 20 20 20 20 28 70 67 64 62 2d 73 74 65 70 2d (pgdb-step-
8e60: 69 64 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 id (if pgdb-test
8e70: 2d 69 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 -id .
8e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
8e90: 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 73 74 65 gdb:get-test-ste
8ea0: 70 2d 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 p-id dbh pgdb-te
8eb0: 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 73 st-id stepname s
8ec0: 74 61 74 65 29 0a 20 20 20 20 20 20 20 20 20 20 tate).
8ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ee0: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 74 #f))). (if st
8ef0: 65 70 2d 69 64 0a 20 20 20 20 20 20 28 62 65 67 ep-id. (beg
8f00: 69 6e 20 20 0a 20 20 20 20 20 20 20 20 28 69 66 in . (if
8f10: 20 70 67 64 62 2d 74 65 73 74 2d 69 64 0a 20 20 pgdb-test-id.
8f20: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
8f30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8f40: 20 28 69 66 20 20 70 67 64 62 2d 73 74 65 70 2d (if pgdb-step-
8f50: 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 id.
8f60: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
8f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f80: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8f90: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
8fa0: 67 2d 70 6f 72 74 2a 20 20 22 55 70 64 61 74 69 g-port* "Updati
8fb0: 6e 67 20 65 78 69 73 74 69 6e 67 20 74 65 73 74 ng existing test
8fc0: 2d 73 74 65 70 20 77 69 74 68 20 74 65 73 74 2d -step with test-
8fd0: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 id: " test-id "
8fe0: 61 6e 64 20 73 74 65 70 2d 69 64 20 22 20 73 74 and step-id " st
8ff0: 65 70 2d 69 64 20 22 20 70 67 64 62 20 74 65 73 ep-id " pgdb tes
9000: 74 20 69 64 3a 20 22 20 70 67 64 62 2d 74 65 73 t id: " pgdb-tes
9010: 74 2d 69 64 20 22 20 70 67 64 62 20 73 74 65 70 t-id " pgdb step
9020: 20 69 64 20 22 20 70 67 64 62 2d 73 74 65 70 2d id " pgdb-step-
9030: 69 64 20 29 0a 09 09 09 09 09 09 09 09 09 09 28 id )...........(
9040: 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 let* ((pgdb-last
9050: 2d 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 -update (pgdb:ge
9060: 74 2d 74 65 73 74 2d 73 74 65 70 2d 6c 61 73 74 t-test-step-last
9070: 2d 75 70 64 61 74 65 20 64 62 68 20 70 67 64 62 -update dbh pgdb
9080: 2d 73 74 65 70 2d 69 64 29 29 29 0a 20 20 20 20 -step-id))).
9090: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 20 28 (if (and (
90a0: 3e 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 67 > last-update pg
90b0: 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 db-last-update)
90c0: 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 (or (not smalles
90d0: 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d t-time) (< last-
90e0: 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d update smallest-
90f0: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 time))).
9100: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
9110: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
9120: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
9130: 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d lest-time" last-
9140: 75 70 64 61 74 65 29 29 29 20 0a 20 20 20 20 20 update))) .
9150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9160: 70 67 64 62 3a 75 70 64 61 74 65 2d 74 65 73 74 pgdb:update-test
9170: 2d 73 74 65 70 20 64 62 68 20 70 67 64 62 2d 73 -step dbh pgdb-s
9180: 74 65 70 2d 69 64 20 70 67 64 62 2d 74 65 73 74 tep-id pgdb-test
9190: 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 73 74 61 -id stepname sta
91a0: 74 65 20 73 74 61 74 75 73 20 65 76 65 6e 74 5f te status event_
91b0: 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 time comment log
91c0: 66 69 6c 65 20 6c 61 73 74 2d 75 70 64 61 74 65 file last-update
91d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
91e0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 09 (begin. .
91f0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
9200: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
9210: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
9220: 49 6e 73 65 72 74 69 6e 67 20 74 65 73 74 2d 73 Inserting test-s
9230: 74 65 70 20 77 69 74 68 20 74 65 73 74 2d 69 64 tep with test-id
9240: 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e : " test-id " an
9250: 64 20 73 74 65 70 2d 69 64 20 22 20 73 74 65 70 d step-id " step
9260: 2d 69 64 20 20 22 20 70 67 64 62 20 74 65 73 74 -id " pgdb test
9270: 20 69 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 id: " pgdb-test
9280: 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 -id).
9290: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6f (if (o
92a0: 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d r (not smallest-
92b0: 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 time) (< last-up
92c0: 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 date smallest-ti
92d0: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 09 09 09 me)). ...
92e0: 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
92f0: 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 le-set! smallest
9300: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d -last-update-tim
9310: 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 e "smallest-time
9320: 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a " last-update)).
9330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9340: 20 20 20 20 20 20 28 70 67 64 62 3a 69 6e 73 65 (pgdb:inse
9350: 72 74 2d 74 65 73 74 2d 73 74 65 70 20 64 62 68 rt-test-step dbh
9360: 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 73 74 pgdb-test-id st
9370: 65 70 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 epname state sta
9380: 74 75 73 20 65 76 65 6e 74 5f 74 69 6d 65 20 63 tus event_time c
9390: 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 20 6c omment logfile l
93a0: 61 73 74 2d 75 70 64 61 74 65 20 29 0a 20 20 20 ast-update ).
93b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93c0: 20 20 20 28 73 65 74 21 20 70 67 64 62 2d 73 74 (set! pgdb-st
93d0: 65 70 2d 69 64 20 20 28 70 67 64 62 3a 67 65 74 ep-id (pgdb:get
93e0: 2d 74 65 73 74 2d 73 74 65 70 2d 69 64 20 64 62 -test-step-id db
93f0: 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 73 h pgdb-test-id s
9400: 74 65 70 6e 61 6d 65 20 73 74 61 74 65 29 29 29 tepname state)))
9410: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9420: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
9430: 74 21 20 73 74 65 70 2d 68 74 20 73 74 65 70 2d t! step-ht step-
9440: 69 64 20 70 67 64 62 2d 73 74 65 70 2d 69 64 20 id pgdb-step-id
9450: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 )). (d
9460: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9470: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
9480: 6f 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 ort* "Error: Te
9490: 73 74 20 6e 6f 74 20 63 61 73 68 65 64 22 29 29 st not cashed"))
94a0: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
94b0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 rint-info 1 *def
94c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
94d0: 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 20 6e 6f "Error: Could no
94e0: 74 20 67 65 74 20 74 65 73 74 20 73 74 65 70 20 t get test step
94f0: 69 6e 66 6f 20 66 6f 72 20 73 74 65 70 20 69 64 info for step id
9500: 20 22 20 74 65 73 74 2d 73 74 65 70 2d 69 64 20 " test-step-id
9510: 29 29 29 29 09 3b 3b 20 74 68 69 73 20 69 73 20 )))).;; this is
9520: 61 20 77 69 65 72 64 20 73 65 6e 61 72 69 6f 20 a wierd senario
9530: 6e 65 65 64 20 74 6f 20 64 65 62 75 67 20 20 20 need to debug
9540: 20 20 20 09 0a 20 20 20 74 65 73 74 2d 73 74 65 .. test-ste
9550: 70 2d 69 64 73 29 29 29 0a 0a 23 3b 28 64 65 66 p-ids)))..#;(def
9560: 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d ine (tasks:sync-
9570: 74 65 73 74 2d 67 65 6e 2d 64 61 74 61 20 64 62 test-gen-data db
9580: 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 h cached-info te
9590: 73 74 2d 64 61 74 61 2d 69 64 73 20 73 6d 61 6c st-data-ids smal
95a0: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
95b0: 2d 74 69 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 -time). (let ((
95c0: 74 65 73 74 2d 68 74 20 28 68 61 73 68 2d 74 61 test-ht (hash-ta
95d0: 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 ble-ref cached-i
95e0: 6e 66 6f 20 27 74 65 73 74 73 29 29 0a 20 20 20 nfo 'tests)).
95f0: 20 20 20 20 20 28 64 61 74 61 2d 68 74 20 28 68 (data-ht (h
9600: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 ash-table-ref ca
9610: 63 68 65 64 2d 69 6e 66 6f 20 27 64 61 74 61 29 ched-info 'data)
9620: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
9630: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 . (lambda (t
9640: 65 73 74 2d 64 61 74 61 2d 69 64 29 0a 20 20 20 est-data-id).
9650: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
9660: 74 2d 64 61 74 61 2d 69 6e 66 6f 20 20 28 72 6d t-data-info (rm
9670: 74 3a 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d t:get-data-info-
9680: 62 79 2d 69 64 20 74 65 73 74 2d 64 61 74 61 2d by-id test-data-
9690: 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 id)).
96a0: 20 20 20 20 28 64 61 74 61 2d 69 64 20 28 64 62 (data-id (db
96b0: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 69 :test-data-get-i
96c0: 64 20 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 d test-data-inf
96d0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 o)).
96e0: 20 20 20 28 74 65 73 74 2d 69 64 20 20 28 64 62 (test-id (db
96f0: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 :test-data-get-t
9700: 65 73 74 5f 69 64 20 20 20 74 65 73 74 2d 64 61 est_id test-da
9710: 74 61 2d 69 6e 66 6f 29 29 20 20 20 0a 09 20 20 ta-info)) ..
9720: 20 20 20 20 20 28 63 61 74 65 67 6f 72 79 20 20 (category
9730: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9740: 74 2d 63 61 74 65 67 6f 72 79 20 20 74 65 73 74 t-category test
9750: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a 09 20 20 -data-info))..
9760: 20 20 20 20 20 28 76 61 72 69 61 62 6c 65 20 20 (variable
9770: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9780: 74 2d 76 61 72 69 61 62 6c 65 20 74 65 73 74 2d t-variable test-
9790: 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 20 data-info))...
97a0: 20 20 20 20 20 28 76 61 6c 75 65 20 28 64 62 3a (value (db:
97b0: 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 76 61 test-data-get-va
97c0: 6c 75 65 20 20 74 65 73 74 2d 64 61 74 61 2d 69 lue test-data-i
97d0: 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 20 20 20 nfo))..
97e0: 20 20 20 20 20 20 28 65 78 70 65 63 74 65 64 20 (expected
97f0: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9800: 74 2d 65 78 70 65 63 74 65 64 20 20 74 65 73 74 t-expected test
9810: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a 20 20 20 -data-info)).
9820: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 6f 6c (tol
9830: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
9840: 65 74 2d 74 6f 6c 20 20 74 65 73 74 2d 64 61 74 et-tol test-dat
9850: 61 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 a-info)).
9860: 20 20 20 20 20 20 20 20 28 75 6e 69 74 73 20 28 (units (
9870: 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 db:test-data-get
9880: 2d 75 6e 69 74 73 20 20 74 65 73 74 2d 64 61 74 -units test-dat
9890: 61 2d 69 6e 66 6f 29 29 20 20 20 20 20 0a 09 20 a-info)) ..
98a0: 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 (comment
98b0: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
98c0: 74 2d 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d 64 t-comment test-d
98d0: 61 74 61 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 ata-info))..
98e0: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 61 74 (stat
98f0: 75 73 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 us (db:test-data
9900: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 -get-status test
9910: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 -data-info))...
9920: 20 20 20 20 20 20 28 74 79 70 65 20 28 64 62 3a (type (db:
9930: 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 79 test-data-get-ty
9940: 70 65 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 pe test-data-inf
9950: 6f 29 29 0a 09 09 09 09 20 28 6c 61 73 74 2d 75 o))..... (last-u
9960: 70 64 61 74 65 20 28 64 62 3a 74 65 73 74 2d 64 pdate (db:test-d
9970: 61 74 61 2d 67 65 74 2d 6c 61 73 74 5f 75 70 64 ata-get-last_upd
9980: 61 74 65 20 74 65 73 74 2d 64 61 74 61 2d 69 6e ate test-data-in
9990: 66 6f 29 29 0a 09 09 09 09 20 28 73 6d 61 6c 6c fo))..... (small
99a0: 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 est-time (hash-t
99b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
99c0: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
99d0: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
99e0: 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 29 0a lest-time" #f)).
99f0: 20 20 20 09 0a 09 20 20 20 20 20 20 20 28 70 67 ... (pg
9a00: 64 62 2d 74 65 73 74 2d 69 64 20 20 28 68 61 73 db-test-id (has
9a10: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
9a20: 75 6c 74 20 74 65 73 74 2d 68 74 20 74 65 73 74 ult test-ht test
9a30: 2d 69 64 20 23 66 29 29 0a 20 20 20 20 20 20 20 -id #f)).
9a40: 20 20 20 20 20 20 20 20 28 70 67 64 62 2d 64 61 (pgdb-da
9a50: 74 61 2d 69 64 20 28 69 66 20 70 67 64 62 2d 74 ta-id (if pgdb-t
9a60: 65 73 74 2d 69 64 20 0a 20 20 20 20 20 20 20 20 est-id .
9a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a80: 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a 67 (pgdb:g
9a90: 65 74 2d 74 65 73 74 2d 64 61 74 61 2d 69 64 20 et-test-data-id
9aa0: 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 dbh pgdb-test-id
9ab0: 20 63 61 74 65 67 6f 72 79 20 76 61 72 69 61 62 category variab
9ac0: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
9ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ae0: 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 #f))).
9af0: 28 69 66 20 64 61 74 61 2d 69 64 0a 20 20 20 20 (if data-id.
9b00: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
9b10: 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 (if pgdb-test-i
9b20: 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 62 65 d. (be
9b30: 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 gin .
9b40: 20 20 20 20 20 28 69 66 20 20 70 67 64 62 2d 64 (if pgdb-d
9b50: 61 74 61 2d 69 64 0a 20 20 20 20 20 20 20 20 20 ata-id.
9b60: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
9b70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9b80: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9b90: 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c t-info 1 *defaul
9ba0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 70 t-log-port* "Up
9bb0: 64 61 74 69 6e 67 20 65 78 69 73 74 69 6e 67 20 dating existing
9bc0: 74 65 73 74 2d 64 61 74 61 20 77 69 74 68 20 74 test-data with t
9bd0: 65 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 est-id: " test-i
9be0: 64 20 22 20 61 6e 64 20 20 64 61 74 61 2d 69 64 d " and data-id
9bf0: 20 22 20 64 61 74 61 2d 69 64 20 22 20 70 67 64 " data-id " pgd
9c00: 62 20 74 65 73 74 20 69 64 3a 20 22 20 70 67 64 b test id: " pgd
9c10: 62 2d 74 65 73 74 2d 69 64 20 22 20 70 67 64 62 b-test-id " pgdb
9c20: 20 64 61 74 61 20 69 64 20 22 20 70 67 64 62 2d data id " pgdb-
9c30: 64 61 74 61 2d 69 64 29 0a 20 20 20 20 20 20 20 data-id).
9c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
9c50: 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 t* ((pgdb-last-u
9c60: 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d pdate (pgdb:get-
9c70: 74 65 73 74 2d 64 61 74 61 2d 6c 61 73 74 2d 75 test-data-last-u
9c80: 70 64 61 74 65 20 64 62 68 20 70 67 64 62 2d 64 pdate dbh pgdb-d
9c90: 61 74 61 2d 69 64 29 29 29 0a 20 20 20 20 20 20 ata-id))).
9ca0: 20 20 20 28 69 66 20 28 61 6e 64 20 20 28 3e 20 (if (and (>
9cb0: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 67 64 last-update pgd
9cc0: 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 28 b-last-update) (
9cd0: 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 or (not smallest
9ce0: 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 -time) (< last-u
9cf0: 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 pdate smallest-t
9d00: 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 ime))). (
9d10: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9d20: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
9d30: 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c date-time "small
9d40: 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 est-time" last-u
9d50: 70 64 61 74 65 29 29 29 20 0a 20 20 20 20 20 20 pdate))) .
9d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
9d70: 67 64 62 3a 75 70 64 61 74 65 2d 74 65 73 74 2d gdb:update-test-
9d80: 64 61 74 61 20 64 62 68 20 70 67 64 62 2d 64 61 data dbh pgdb-da
9d90: 74 61 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d ta-id pgdb-test-
9da0: 69 64 20 20 63 61 74 65 67 6f 72 79 20 76 61 72 id category var
9db0: 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 iable value expe
9dc0: 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 cted tol units c
9dd0: 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 omment status ty
9de0: 70 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 pe last-update))
9df0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9e00: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 09 09 20 (begin. ..
9e10: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9e20: 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c t-info 1 *defaul
9e30: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 49 6e t-log-port* "In
9e40: 73 65 72 74 69 6e 67 20 74 65 73 74 2d 64 61 74 serting test-dat
9e50: 61 20 77 69 74 68 20 74 65 73 74 2d 69 64 3a 20 a with test-id:
9e60: 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e 64 20 " test-id " and
9e70: 64 61 74 61 2d 69 64 20 22 20 64 61 74 61 2d 69 data-id " data-i
9e80: 64 20 22 20 70 67 64 62 20 74 65 73 74 20 69 64 d " pgdb test id
9e90: 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d 69 64 : " pgdb-test-id
9ea0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9eb0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 68 61 (if (ha
9ec0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
9ed0: 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 20 20 .. exn...
9ee0: 20 20 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e (begin (prin
9ef0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 t-call-chain).
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f10: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
9f20: 6e 74 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 nt ((condition-p
9f30: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
9f40: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
9f50: 65 78 6e 29 29 20 20 20 20 20 0a 09 09 09 23 66 exn)) ....#f
9f60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9f70: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
9f80: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
9f90: 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 61 b:insert-test-da
9fa0: 74 61 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 ta dbh pgdb-test
9fb0: 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 -id category var
9fc0: 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 iable value expe
9fd0: 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 cted tol units c
9fe0: 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 omment status ty
9ff0: 70 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 pe last-update))
a000: 0a 09 09 20 20 20 20 20 20 20 3b 28 74 61 73 6b ... ;(task
a010: 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 s:run-id->mtpg-r
a020: 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 un-id dbh cached
a030: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 -info run-id are
a040: 61 2d 69 6e 66 6f 29 0a 20 20 20 20 20 20 20 20 a-info).
a050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
a060: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
a070: 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 67 64 ;(pgd
a080: 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 61 b:insert-test-da
a090: 74 61 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 ta dbh pgdb-test
a0a0: 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 -id category var
a0b0: 69 61 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 iable value expe
a0c0: 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 cted tol units c
a0d0: 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 omment status ty
a0e0: 70 65 20 29 0a 09 09 09 09 09 09 09 09 09 09 09 pe )............
a0f0: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 (if (or (not sma
a100: 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c llest-time) (< l
a110: 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c ast-update small
a120: 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 est-time)).
a130: 20 20 20 09 09 09 09 09 09 09 09 28 68 61 73 68 ........(hash
a140: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c -table-set! smal
a150: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
a160: 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d -time "smallest-
a170: 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 74 time" last-updat
a180: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
a190: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
a1a0: 70 67 64 62 2d 64 61 74 61 2d 69 64 20 20 28 70 pgdb-data-id (p
a1b0: 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 64 61 74 gdb:get-test-dat
a1c0: 61 2d 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 a-id dbh pgdb-te
a1d0: 73 74 2d 69 64 20 20 63 61 74 65 67 6f 72 79 20 st-id category
a1e0: 76 61 72 69 61 62 6c 65 29 29 29 0a 09 09 20 20 variable)))...
a1f0: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
a200: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
a210: 6c 65 2d 73 65 74 21 20 64 61 74 61 2d 68 74 20 le-set! data-ht
a220: 64 61 74 61 2d 69 64 20 70 67 64 62 2d 64 61 74 data-id pgdb-dat
a230: 61 2d 69 64 20 29 29 0a 20 20 20 20 20 20 20 20 a-id )).
a240: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
a250: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
a260: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
a270: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
a280: 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 73 rt* "Error: Tes
a290: 74 20 6e 6f 74 20 69 6e 20 70 67 64 62 22 29 29 t not in pgdb"))
a2a0: 29 29 0a 0a 20 20 20 20 20 20 28 64 65 62 75 67 )).. (debug
a2b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
a2c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
a2d0: 20 20 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 20 "Error: Could
a2e0: 6e 6f 74 20 67 65 74 20 74 65 73 74 20 64 61 74 not get test dat
a2f0: 61 20 69 6e 66 6f 20 66 6f 72 20 64 61 74 61 20 a info for data
a300: 69 64 20 22 20 74 65 73 74 2d 64 61 74 61 2d 69 id " test-data-i
a310: 64 20 29 29 29 29 09 3b 3b 20 74 68 69 73 20 69 d )))).;; this i
a320: 73 20 61 20 77 69 65 72 64 20 73 65 6e 61 72 69 s a wierd senari
a330: 6f 20 6e 65 65 64 20 74 6f 20 64 65 62 75 67 20 o need to debug
a340: 20 20 20 20 20 09 0a 20 20 20 74 65 73 74 2d 64 .. test-d
a350: 61 74 61 2d 69 64 73 29 29 29 0a 0a 0a 0a 23 3b ata-ids)))....#;
a360: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 (define (tasks:s
a370: 79 6e 63 2d 74 65 73 74 73 2d 64 61 74 61 20 64 ync-tests-data d
a380: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 bh cached-info t
a390: 65 73 74 2d 69 64 73 20 61 72 65 61 2d 69 6e 66 est-ids area-inf
a3a0: 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d o smallest-last-
a3b0: 75 70 64 61 74 65 2d 74 69 6d 65 29 0a 20 20 28 update-time). (
a3c0: 6c 65 74 20 28 28 74 65 73 74 2d 68 74 20 28 68 let ((test-ht (h
a3d0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 ash-table-ref ca
a3e0: 63 68 65 64 2d 69 6e 66 6f 20 27 74 65 73 74 73 ched-info 'tests
a3f0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
a400: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
a410: 74 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 3b test-id). ;
a420: 20 28 70 72 69 6e 74 20 74 65 73 74 2d 69 64 29 (print test-id)
a430: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
a440: 74 65 73 74 2d 69 6e 66 6f 20 20 20 20 28 72 6d test-info (rm
a450: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
a460: 62 79 2d 69 64 20 23 66 20 74 65 73 74 2d 69 64 by-id #f test-id
a470: 29 29 0a 09 20 20 20 20 20 20 28 72 75 6e 2d 69 )).. (run-i
a480: 64 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 d (db:test
a490: 2d 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 20 74 -get-run_id t
a4a0: 65 73 74 2d 69 6e 66 6f 29 29 20 3b 3b 20 6c 6f est-info)) ;; lo
a4b0: 6f 6b 20 74 68 65 73 65 20 75 70 20 69 6e 20 64 ok these up in d
a4c0: 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 0a 09 20 b_records.scm..
a4d0: 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 (test-id
a4e0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
a4f0: 69 64 20 20 20 20 20 20 20 20 74 65 73 74 2d 69 id test-i
a500: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 74 65 nfo)).. (te
a510: 73 74 2d 6e 61 6d 65 20 20 20 20 28 64 62 3a 74 st-name (db:t
a520: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
a530: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 test-info))..
a540: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
a550: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
a560: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 69 item-path test-i
a570: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 73 74 nfo)).. (st
a580: 61 74 65 20 20 20 20 20 20 20 20 28 64 62 3a 74 ate (db:t
a590: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 est-get-state
a5a0: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 test-info))..
a5b0: 20 20 20 20 20 28 73 74 61 74 75 73 20 20 20 20 (status
a5c0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
a5d0: 73 74 61 74 75 73 20 20 20 20 74 65 73 74 2d 69 status test-i
a5e0: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 68 6f nfo)).. (ho
a5f0: 73 74 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 st (db:t
a600: 65 73 74 2d 67 65 74 2d 68 6f 73 74 20 20 20 20 est-get-host
a610: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 20 20 test-info)).
a620: 20 20 20 20 20 20 28 70 69 64 20 20 20 20 20 20 (pid
a630: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
a640: 2d 70 72 6f 63 65 73 73 5f 69 64 20 74 65 73 74 -process_id test
a650: 2d 69 6e 66 6f 29 29 20 0a 09 20 20 20 20 20 20 -info)) ..
a660: 28 63 70 75 6c 6f 61 64 20 20 20 20 20 20 28 64 (cpuload (d
a670: 62 3a 74 65 73 74 2d 67 65 74 2d 63 70 75 6c 6f b:test-get-cpulo
a680: 61 64 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 ad test-info))
a690: 0a 09 20 20 20 20 20 20 28 64 69 73 6b 66 72 65 .. (diskfre
a6a0: 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 e (db:test-g
a6b0: 65 74 2d 64 69 73 6b 66 72 65 65 20 20 74 65 73 et-diskfree tes
a6c0: 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 t-info))..
a6d0: 28 75 6e 61 6d 65 20 20 20 20 20 20 20 20 28 64 (uname (d
a6e0: 62 3a 74 65 73 74 2d 67 65 74 2d 75 6e 61 6d 65 b:test-get-uname
a6f0: 20 20 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 test-info))
a700: 0a 09 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 .. (run-dir
a710: 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
a720: 65 74 2d 72 75 6e 64 69 72 20 20 20 20 74 65 73 et-rundir tes
a730: 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 t-info))..
a740: 28 6c 6f 67 2d 66 69 6c 65 20 20 20 20 20 28 64 (log-file (d
a750: 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 6c b:test-get-final
a760: 5f 6c 6f 67 66 20 74 65 73 74 2d 69 6e 66 6f 29 _logf test-info)
a770: 29 0a 09 20 20 20 20 20 20 28 72 75 6e 2d 64 75 ).. (run-du
a780: 72 61 74 69 6f 6e 20 28 64 62 3a 74 65 73 74 2d ration (db:test-
a790: 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e get-run_duration
a7a0: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
a7b0: 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 (comment
a7c0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 (db:test-get-c
a7d0: 6f 6d 6d 65 6e 74 20 20 20 74 65 73 74 2d 69 6e omment test-in
a7e0: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 65 76 65 fo)).. (eve
a7f0: 6e 74 2d 74 69 6d 65 20 20 20 28 64 62 3a 74 65 nt-time (db:te
a800: 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d st-get-event_tim
a810: 65 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 e test-info))..
a820: 20 20 20 20 20 28 61 72 63 68 69 76 65 64 20 20 (archived
a830: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
a840: 61 72 63 68 69 76 65 64 20 20 74 65 73 74 2d 69 archived test-i
a850: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 28 6c nfo)). (l
a860: 61 73 74 2d 75 70 64 61 74 65 20 20 28 64 62 3a ast-update (db:
a870: 74 65 73 74 2d 67 65 74 2d 6c 61 73 74 5f 75 70 test-get-last_up
a880: 64 61 74 65 20 20 74 65 73 74 2d 69 6e 66 6f 29 date test-info)
a890: 29 0a 09 20 20 20 20 20 20 28 70 67 64 62 2d 72 ).. (pgdb-r
a8a0: 75 6e 2d 69 64 20 20 28 74 61 73 6b 73 3a 72 75 un-id (tasks:ru
a8b0: 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 n-id->mtpg-run-i
a8c0: 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 d dbh cached-inf
a8d0: 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 69 6e o run-id area-in
a8e0: 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 fo smallest-last
a8f0: 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 29 0a 20 -update-time)).
a900: 20 20 20 20 20 20 20 28 73 6d 61 6c 6c 65 73 74 (smallest
a910: 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c -time (hash-tabl
a920: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6d e-ref/default sm
a930: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
a940: 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 te-time "smalles
a950: 74 2d 74 69 6d 65 22 20 23 66 29 29 20 20 20 20 t-time" #f))
a960: 20 20 20 0a 09 20 20 20 20 20 20 28 70 67 64 62 .. (pgdb
a970: 2d 74 65 73 74 2d 69 64 20 28 69 66 20 70 67 64 -test-id (if pgd
a980: 62 2d 72 75 6e 2d 69 64 20 0a 09 09 09 09 28 62 b-run-id .....(b
a990: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
a9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9b0: 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 70 ;(print p
a9c0: 67 64 62 2d 72 75 6e 2d 69 64 29 20 20 20 20 0a gdb-run-id) .
a9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9f0: 20 28 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d (pgdb:get-test-
aa00: 69 64 20 64 62 68 20 70 67 64 62 2d 72 75 6e 2d id dbh pgdb-run-
aa10: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
aa20: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 m-path)).
aa30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa40: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 29 0a #f))).
aa50: 09 20 3b 3b 20 22 69 64 22 20 20 20 20 20 20 20 . ;; "id"
aa60: 20 20 20 20 22 72 75 6e 5f 69 64 22 20 20 20 20 "run_id"
aa70: 20 20 20 20 22 74 65 73 74 6e 61 6d 65 22 20 20 "testname"
aa80: 22 73 74 61 74 65 22 20 20 20 20 20 20 22 73 74 "state" "st
aa90: 61 74 75 73 22 20 20 20 20 20 20 22 65 76 65 6e atus" "even
aaa0: 74 5f 74 69 6d 65 22 0a 09 20 3b 3b 20 22 68 6f t_time".. ;; "ho
aab0: 73 74 22 20 20 20 20 20 20 20 20 20 22 63 70 75 st" "cpu
aac0: 6c 6f 61 64 22 20 20 20 20 20 20 20 22 64 69 73 load" "dis
aad0: 6b 66 72 65 65 22 20 20 22 75 6e 61 6d 65 22 20 kfree" "uname"
aae0: 20 20 20 20 20 22 72 75 6e 64 69 72 22 20 20 20 "rundir"
aaf0: 20 20 20 22 69 74 65 6d 5f 70 61 74 68 22 0a 09 "item_path"..
ab00: 20 3b 3b 20 22 72 75 6e 5f 64 75 72 61 74 69 6f ;; "run_duratio
ab10: 6e 22 20 22 66 69 6e 61 6c 5f 6c 6f 67 66 22 20 n" "final_logf"
ab20: 20 20 20 22 63 6f 6d 6d 65 6e 74 22 20 20 20 22 "comment" "
ab30: 73 68 6f 72 74 64 69 72 22 20 20 20 22 61 74 74 shortdir" "att
ab40: 65 6d 70 74 6e 75 6d 22 20 20 22 61 72 63 68 69 emptnum" "archi
ab50: 76 65 64 22 0a 20 20 20 20 20 20 20 20 20 28 69 ved". (i
ab60: 66 20 70 67 64 62 2d 72 75 6e 2d 69 64 0a 20 20 f pgdb-run-id.
ab70: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
ab80: 09 20 20 20 28 69 66 20 70 67 64 62 2d 74 65 73 . (if pgdb-tes
ab90: 74 2d 69 64 20 3b 3b 20 68 61 76 65 20 61 20 72 t-id ;; have a r
aba0: 65 63 6f 72 64 0a 09 20 20 20 20 20 28 62 65 67 ecord.. (beg
abb0: 69 6e 20 3b 3b 20 6c 65 74 20 28 28 6b 65 79 2d in ;; let ((key-
abc0: 6e 61 6d 65 20 28 63 6f 6e 63 20 72 75 6e 2d 69 name (conc run-i
abd0: 64 20 22 2f 22 20 74 65 73 74 2d 6e 61 6d 65 20 d "/" test-name
abe0: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
abf0: 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
ac00: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
ac10: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
ac20: 20 22 55 70 64 61 74 69 6e 67 20 65 78 69 73 74 "Updating exist
ac30: 69 6e 67 20 74 65 73 74 20 77 69 74 68 20 72 75 ing test with ru
ac40: 6e 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 20 22 n-id: " run-id "
ac50: 20 61 6e 64 20 74 65 73 74 2d 69 64 3a 20 22 20 and test-id: "
ac60: 74 65 73 74 2d 69 64 20 22 20 70 67 64 62 20 72 test-id " pgdb r
ac70: 75 6e 20 69 64 3a 20 22 20 70 67 64 62 2d 72 75 un id: " pgdb-ru
ac80: 6e 2d 69 64 20 22 20 20 70 67 64 62 2d 74 65 73 n-id " pgdb-tes
ac90: 74 2d 69 64 20 22 20 20 70 67 64 62 2d 74 65 73 t-id " pgdb-tes
aca0: 74 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 28 t-id). (
acb0: 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 let* ((pgdb-last
acc0: 2d 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 -update (pgdb:ge
acd0: 74 2d 74 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 t-test-last-upda
ace0: 74 65 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 te dbh pgdb-test
acf0: 2d 69 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 -id))).
ad00: 28 69 66 20 28 61 6e 64 20 20 28 3e 20 20 6c 61 (if (and (> la
ad10: 73 74 2d 75 70 64 61 74 65 20 70 67 64 62 2d 6c st-update pgdb-l
ad20: 61 73 74 2d 75 70 64 61 74 65 29 20 28 6f 72 20 ast-update) (or
ad30: 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 (not smallest-ti
ad40: 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 me) (< last-upda
ad50: 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 te smallest-time
ad60: 29 29 29 20 3b 3b 69 66 20 6c 61 73 74 2d 75 70 ))) ;;if last-up
ad70: 64 61 74 65 20 69 73 20 73 61 6d 65 20 61 73 20 date is same as
ad80: 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 pgdb-last-update
ad90: 20 74 68 65 6e 20 69 74 20 69 73 20 73 61 66 65 then it is safe
ada0: 20 74 6f 20 61 73 73 75 6d 65 20 74 68 65 20 72 to assume the r
adb0: 65 63 6f 72 64 73 20 61 72 65 20 69 64 65 6e 74 ecords are ident
adc0: 69 63 61 6c 20 61 6e 64 20 77 65 20 63 61 6e 20 ical and we can
add0: 75 73 65 20 61 20 6c 61 72 67 65 72 20 6c 61 73 use a larger las
ade0: 74 20 75 70 64 61 74 65 20 74 69 6d 65 2e 0a 20 t update time..
adf0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
ae00: 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 le-set! smallest
ae10: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d -last-update-tim
ae20: 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 e "smallest-time
ae30: 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 " last-update)))
ae40: 20 0a 09 20 20 20 20 20 20 20 28 70 67 64 62 3a .. (pgdb:
ae50: 75 70 64 61 74 65 2d 74 65 73 74 20 64 62 68 20 update-test dbh
ae60: 70 67 64 62 2d 74 65 73 74 2d 69 64 20 70 67 64 pgdb-test-id pgd
ae70: 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b-run-id test-na
ae80: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 me item-path sta
ae90: 74 65 20 73 74 61 74 75 73 20 68 6f 73 74 20 63 te status host c
aea0: 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 puload diskfree
aeb0: 75 6e 61 6d 65 20 72 75 6e 2d 64 69 72 20 6c 6f uname run-dir lo
aec0: 67 2d 66 69 6c 65 20 72 75 6e 2d 64 75 72 61 74 g-file run-durat
aed0: 69 6f 6e 20 63 6f 6d 6d 65 6e 74 20 65 76 65 6e ion comment even
aee0: 74 2d 74 69 6d 65 20 61 72 63 68 69 76 65 64 20 t-time archived
aef0: 6c 61 73 74 2d 75 70 64 61 74 65 20 70 69 64 29 last-update pid)
af00: 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 20 0a ).. (begin .
af10: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
af20: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
af30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
af40: 2a 20 20 22 49 6e 73 65 72 74 69 6e 67 20 74 65 * "Inserting te
af50: 73 74 20 77 69 74 68 20 72 75 6e 2d 69 64 3a 20 st with run-id:
af60: 22 20 72 75 6e 2d 69 64 20 22 20 61 6e 64 20 74 " run-id " and t
af70: 65 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 est-id: " test-i
af80: 64 20 20 22 20 70 67 64 62 20 72 75 6e 20 69 64 d " pgdb run id
af90: 3a 20 22 20 70 67 64 62 2d 72 75 6e 2d 69 64 29 : " pgdb-run-id)
afa0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 . (pgd
afb0: 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 20 64 62 b:insert-test db
afc0: 68 20 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 65 h pgdb-run-id te
afd0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
afe0: 68 20 73 74 61 74 65 20 73 74 61 74 75 73 20 68 h state status h
aff0: 6f 73 74 20 63 70 75 6c 6f 61 64 20 64 69 73 6b ost cpuload disk
b000: 66 72 65 65 20 75 6e 61 6d 65 20 72 75 6e 2d 64 free uname run-d
b010: 69 72 20 6c 6f 67 2d 66 69 6c 65 20 72 75 6e 2d ir log-file run-
b020: 64 75 72 61 74 69 6f 6e 20 63 6f 6d 6d 65 6e 74 duration comment
b030: 20 65 76 65 6e 74 2d 74 69 6d 65 20 61 72 63 68 event-time arch
b040: 69 76 65 64 20 6c 61 73 74 2d 75 70 64 61 74 65 ived last-update
b050: 20 70 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 pid).
b060: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 (if (or (not s
b070: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c mallest-time) (<
b080: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 last-update sma
b090: 6c 6c 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 20 llest-time)).
b0a0: 20 20 20 20 20 09 09 09 09 28 68 61 73 68 2d 74 ....(hash-t
b0b0: 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 able-set! smalle
b0c0: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
b0d0: 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 ime "smallest-ti
b0e0: 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 me" last-update)
b0f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 ). (se
b100: 74 21 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 t! pgdb-test-id
b110: 28 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (pgdb:get-test-i
b120: 64 20 64 62 68 20 70 67 64 62 2d 72 75 6e 2d 69 d dbh pgdb-run-i
b130: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
b140: 2d 70 61 74 68 29 29 29 29 0a 20 20 20 20 20 20 -path)))).
b150: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
b160: 2d 73 65 74 21 20 74 65 73 74 2d 68 74 20 74 65 -set! test-ht te
b170: 73 74 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d st-id pgdb-test-
b180: 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 id)).
b190: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
b1a0: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
b1b0: 2d 70 6f 72 74 2a 20 20 22 57 41 52 4e 49 4e 47 -port* "WARNING
b1c0: 3a 20 53 6b 69 70 70 69 6e 67 20 72 75 6e 20 77 : Skipping run w
b1d0: 69 74 68 20 72 75 6e 2d 69 64 3a 22 20 72 75 6e ith run-id:" run
b1e0: 2d 69 64 20 22 2e 20 54 68 69 73 20 72 75 6e 20 -id ". This run
b1f0: 77 61 73 20 63 72 65 61 74 65 64 20 61 66 74 65 was created afte
b200: 72 20 70 72 69 76 69 6f 75 73 20 73 79 6e 63 20 r privious sync
b210: 61 6e 64 20 72 65 6d 6f 76 65 64 20 62 65 66 6f and removed befo
b220: 72 65 20 74 68 69 73 20 73 79 6e 63 2e 22 29 29 re this sync."))
b230: 29 29 0a 20 20 20 20 20 74 65 73 74 2d 69 64 73 )). test-ids
b240: 29 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 )))..#;(define (
b250: 74 61 73 6b 3a 61 64 64 2d 61 72 65 61 2d 74 61 task:add-area-ta
b260: 67 20 64 62 68 20 61 72 65 61 2d 69 6e 66 6f 20 g dbh area-info
b270: 74 61 67 29 20 0a 20 20 28 6c 65 74 2a 20 28 28 tag) . (let* ((
b280: 74 61 67 2d 69 6e 66 6f 20 28 70 67 64 62 3a 67 tag-info (pgdb:g
b290: 65 74 2d 74 61 67 2d 69 6e 66 6f 2d 62 79 2d 6e et-tag-info-by-n
b2a0: 61 6d 65 20 64 62 68 20 74 61 67 29 29 29 0a 20 ame dbh tag))).
b2b0: 20 20 28 69 66 20 28 6e 6f 74 20 74 61 67 2d 69 (if (not tag-i
b2c0: 6e 66 6f 29 0a 20 20 20 20 20 28 62 65 67 69 6e nfo). (begin
b2d0: 20 20 20 0a 20 20 20 20 20 28 69 66 20 28 68 61 . (if (ha
b2e0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
b2f0: 09 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 . exn.. (beg
b300: 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 in .
b310: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
b320: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
b330: 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 28 63 6f 6e log-port* ((con
b340: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
b350: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
b360: 65 73 73 61 67 65 29 20 65 78 6e 29 29 20 20 20 essage) exn))
b370: 20 20 0a 09 20 20 20 23 66 29 0a 09 20 20 20 28 .. #f).. (
b380: 70 67 64 62 3a 69 6e 73 65 72 74 2d 74 61 67 20 pgdb:insert-tag
b390: 20 64 62 68 20 20 20 74 61 67 29 29 0a 20 20 20 dbh tag)).
b3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3b0: 20 20 20 20 28 73 65 74 21 20 74 61 67 2d 69 6e (set! tag-in
b3c0: 66 6f 20 28 70 67 64 62 3a 67 65 74 2d 74 61 67 fo (pgdb:get-tag
b3d0: 2d 69 6e 66 6f 2d 62 79 2d 6e 61 6d 65 20 64 62 -info-by-name db
b3e0: 68 20 74 61 67 29 29 0a 09 09 20 20 23 66 29 29 h tag))... #f))
b3f0: 29 0a 20 20 20 20 20 3b 3b 61 64 64 20 74 6f 20 ). ;;add to
b400: 61 72 65 61 5f 74 61 67 73 0a 20 20 20 20 20 28 area_tags. (
b410: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
b420: 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 20 28 62 s.. exn.. (b
b430: 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 egin .
b440: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
b450: 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c t-info 1 *defaul
b460: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 28 63 t-log-port* ((c
b470: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
b480: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
b490: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 20 'message) exn))
b4a0: 20 20 20 20 0a 09 20 20 20 23 66 29 0a 20 20 20 .. #f).
b4b0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
b4c0: 20 28 70 67 64 62 3a 69 73 2d 61 72 65 61 2d 74 (pgdb:is-area-t
b4d0: 61 67 65 64 2d 77 69 74 68 2d 61 2d 74 61 67 20 aged-with-a-tag
b4e0: 64 62 68 20 28 76 65 63 74 6f 72 2d 72 65 66 20 dbh (vector-ref
b4f0: 74 61 67 2d 69 6e 66 6f 20 30 29 20 20 28 76 65 tag-info 0) (ve
b500: 63 74 6f 72 2d 72 65 66 20 61 72 65 61 2d 69 6e ctor-ref area-in
b510: 66 6f 20 30 29 29 29 20 20 0a 09 20 20 20 28 70 fo 0))) .. (p
b520: 67 64 62 3a 69 6e 73 65 72 74 2d 61 72 65 61 2d gdb:insert-area-
b530: 74 61 67 20 20 64 62 68 20 20 20 28 76 65 63 74 tag dbh (vect
b540: 6f 72 2d 72 65 66 20 74 61 67 2d 69 6e 66 6f 20 or-ref tag-info
b550: 30 29 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 0) (vector-ref
b560: 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 29 29 29 area-info 0)))))
b570: 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 74 61 )..#;(define (ta
b580: 73 6b 73 3a 73 79 6e 63 2d 72 75 6e 2d 64 61 74 sks:sync-run-dat
b590: 61 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 a dbh cached-inf
b5a0: 6f 20 72 75 6e 2d 69 64 73 20 61 72 65 61 2d 69 o run-ids area-i
b5b0: 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 nfo smallest-las
b5c0: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 20 0a t-update-time) .
b5d0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
b5e0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 (lambda (run-id
b5f0: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
b600: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 rint-info 1 *def
b610: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
b620: 20 22 43 68 65 63 6b 20 69 66 20 72 75 6e 20 77 "Check if run w
b630: 69 74 68 20 22 20 72 75 6e 2d 69 64 20 22 20 6e ith " run-id " n
b640: 65 65 64 73 20 74 6f 20 62 65 20 73 79 6e 63 65 eeds to be synce
b650: 64 22 20 29 0a 20 20 20 20 20 20 20 28 74 61 73 d" ). (tas
b660: 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d ks:run-id->mtpg-
b670: 72 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 run-id dbh cache
b680: 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 d-info run-id ar
b690: 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 ea-info smallest
b6a0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d -last-update-tim
b6b0: 65 29 29 0a 72 75 6e 2d 69 64 73 29 29 0a 0a 0a e)).run-ids))...
b6c0: 3b 3b 20 67 65 74 20 72 75 6e 73 20 63 68 61 6e ;; get runs chan
b6d0: 67 65 64 20 73 69 6e 63 65 20 6c 61 73 74 20 73 ged since last s
b6e0: 79 6e 63 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ync.;; (define (
b6f0: 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 2d tasks:sync-test-
b700: 64 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d data dbh cached-
b710: 69 6e 66 6f 20 61 72 65 61 2d 69 6e 66 6f 29 0a info area-info).
b720: 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 0a 0a 23 ;; (let* ((..#
b730: 3b 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a ;(define (tasks:
b740: 73 79 6e 63 2d 74 6f 2d 70 6f 73 74 67 72 65 73 sync-to-postgres
b750: 20 63 6f 6e 66 69 67 64 61 74 20 64 65 73 74 29 configdat dest)
b760: 0a 20 20 28 70 72 69 6e 74 20 22 49 6e 20 73 79 . (print "In sy
b770: 6e 63 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 nc"). (let* ((d
b780: 62 68 20 20 20 20 20 20 20 20 20 28 70 67 64 62 bh (pgdb
b790: 3a 6f 70 65 6e 20 63 6f 6e 66 69 67 64 61 74 20 :open configdat
b7a0: 64 62 6e 61 6d 65 3a 20 64 65 73 74 29 29 0a 09 dbname: dest))..
b7b0: 20 28 61 72 65 61 2d 69 6e 66 6f 20 20 20 28 70 (area-info (p
b7c0: 67 64 62 3a 67 65 74 2d 61 72 65 61 2d 62 79 2d gdb:get-area-by-
b7d0: 70 61 74 68 20 64 62 68 20 2a 74 6f 70 70 61 74 path dbh *toppat
b7e0: 68 2a 29 29 0a 09 20 28 63 61 63 68 65 64 2d 69 h*)).. (cached-i
b7f0: 6e 66 6f 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 nfo (make-hash-t
b800: 61 62 6c 65 29 29 0a 09 20 28 73 74 61 72 74 20 able)).. (start
b810: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
b820: 65 63 6f 6e 64 73 29 29 0a 20 20 20 28 74 65 73 econds)). (tes
b830: 74 2d 70 61 74 74 20 20 20 28 69 66 20 28 61 72 t-patt (if (ar
b840: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
b850: 74 70 61 74 74 22 29 0a 09 09 09 09 09 09 09 09 tpatt").........
b860: 09 09 09 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ...(args:get-arg
b870: 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a 20 20 "-testpatt").
b880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b890: 20 20 20 20 22 25 22 29 29 0a 20 20 20 28 74 61 "%")). (ta
b8a0: 72 67 65 74 20 20 20 20 20 20 20 20 20 28 69 66 rget (if
b8b0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
b8c0: 2d 74 61 72 67 65 74 22 29 0a 09 09 09 09 09 09 -target").......
b8d0: 09 09 09 09 09 09 09 09 20 28 61 72 67 73 3a 67 ........ (args:g
b8e0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
b8f0: 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 23 )..............#
b900: 66 29 29 0a 20 20 20 20 28 72 75 6e 2d 6e 61 6d f)). (run-nam
b910: 65 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 e (if (a
b920: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
b930: 6e 6e 61 6d 65 22 29 0a 09 09 09 09 09 09 09 09 nname").........
b940: 09 09 09 09 09 09 20 28 61 72 67 73 3a 67 65 74 ...... (args:get
b950: 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 -arg "-runname")
b960: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 23 66 ..............#f
b970: 29 29 29 0a 20 20 20 20 20 28 69 66 20 28 61 6e ))). (if (an
b980: 64 20 74 61 72 67 65 74 20 20 28 6e 6f 74 20 72 d target (not r
b990: 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 un-name)).
b9a0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 28 70 72 (begin......(pr
b9b0: 69 6e 74 20 22 45 72 72 6f 72 3a 20 50 72 6f 76 int "Error: Prov
b9c0: 69 64 65 20 72 75 6e 6e 61 6d 65 22 29 0a 20 20 ide runname").
b9d0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
b9e0: 29 29 0a 20 20 20 20 20 28 69 66 20 28 61 6e 64 )). (if (and
b9f0: 20 28 6e 6f 74 20 74 61 72 67 65 74 29 20 20 72 (not target) r
ba00: 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 un-name).
ba10: 28 62 65 67 69 6e 0a 09 09 09 09 09 28 70 72 69 (begin......(pri
ba20: 6e 74 20 22 45 72 72 6f 72 3a 20 50 72 6f 76 69 nt "Error: Provi
ba30: 64 65 20 74 61 72 67 65 74 22 29 0a 20 20 20 20 de target").
ba40: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
ba50: 0a 20 20 20 20 3b 28 70 72 69 6e 74 20 22 31 32 . ;(print "12
ba60: 33 22 29 0a 20 20 20 20 3b 28 65 78 69 74 20 31 3"). ;(exit 1
ba70: 29 20 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ) . (for-each
ba80: 20 28 6c 61 6d 62 64 61 20 28 64 74 79 70 65 29 (lambda (dtype)
ba90: 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
baa0: 65 74 21 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 et! cached-info
bab0: 64 74 79 70 65 20 28 6d 61 6b 65 2d 68 61 73 68 dtype (make-hash
bac0: 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 20 20 20 -table)))..
bad0: 20 27 28 72 75 6e 73 20 74 61 72 67 65 74 73 20 '(runs targets
bae0: 74 65 73 74 73 20 73 74 65 70 73 20 64 61 74 61 tests steps data
baf0: 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 )). (hash-tab
bb00: 6c 65 2d 73 65 74 21 20 63 61 63 68 65 64 2d 69 le-set! cached-i
bb10: 6e 66 6f 20 27 73 74 61 72 74 20 73 74 61 72 74 nfo 'start start
bb20: 29 20 3b 3b 20 77 68 65 6e 20 64 6f 6e 65 20 77 ) ;; when done w
bb30: 65 27 6c 6c 20 73 65 74 20 73 79 6e 63 20 74 69 e'll set sync ti
bb40: 6d 65 73 20 74 6f 20 74 68 69 73 0a 20 20 20 20 mes to this.
bb50: 28 69 66 20 61 72 65 61 2d 69 6e 66 6f 0a 09 28 (if area-info..(
bb60: 6c 65 74 2a 20 28 28 6c 61 73 74 2d 73 79 6e 63 let* ((last-sync
bb70: 2d 74 69 6d 65 20 28 76 65 63 74 6f 72 2d 72 65 -time (vector-re
bb80: 66 20 61 72 65 61 2d 69 6e 66 6f 20 33 29 29 0a f area-info 3)).
bb90: 09 20 20 20 20 20 20 20 28 73 6d 61 6c 6c 65 73 . (smalles
bba0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 t-last-update-ti
bbb0: 6d 65 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 me (make-hash-t
bbc0: 61 62 6c 65 29 29 0a 20 20 20 20 20 20 20 20 20 able)).
bbd0: 28 63 68 61 6e 67 65 64 20 20 20 20 20 20 28 69 (changed (i
bbe0: 66 20 28 61 6e 64 20 74 61 72 67 65 74 20 72 75 f (and target ru
bbf0: 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 n-name).
bc00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc10: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e (rmt:get-run
bc20: 2d 72 65 63 6f 72 64 2d 69 64 73 20 74 61 72 67 -record-ids targ
bc30: 65 74 20 72 75 6e 2d 6e 61 6d 65 20 28 72 6d 74 et run-name (rmt
bc40: 3a 67 65 74 2d 6b 65 79 73 29 20 74 65 73 74 2d :get-keys) test-
bc50: 70 61 74 74 29 0a 20 20 20 20 20 20 20 20 20 20 patt).
bc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc70: 20 20 28 72 6d 74 3a 67 65 74 2d 63 68 61 6e 67 (rmt:get-chang
bc80: 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 20 6c 61 ed-record-ids la
bc90: 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 29 29 0a st-sync-time))).
bca0: 09 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 73 . (run-ids
bcb0: 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 (alist-r
bcc0: 65 66 20 27 72 75 6e 73 20 20 20 20 20 20 20 63 ef 'runs c
bcd0: 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 20 20 hanged))..
bce0: 20 28 74 65 73 74 2d 69 64 73 20 20 20 20 20 20 (test-ids
bcf0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 74 65 73 (alist-ref 'tes
bd00: 74 73 20 20 20 20 20 20 63 68 61 6e 67 65 64 29 ts changed)
bd10: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ).. (test-
bd20: 73 74 65 70 2d 69 64 73 20 20 28 61 6c 69 73 74 step-ids (alist
bd30: 2d 72 65 66 20 27 74 65 73 74 5f 73 74 65 70 73 -ref 'test_steps
bd40: 20 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 changed))..
bd50: 20 20 20 28 74 65 73 74 2d 64 61 74 61 2d 69 64 (test-data-id
bd60: 73 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 74 s (alist-ref 't
bd70: 65 73 74 5f 64 61 74 61 20 20 63 68 61 6e 67 65 est_data change
bd80: 64 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e d)).. (run
bd90: 2d 73 74 61 74 2d 69 64 73 20 20 20 28 61 6c 69 -stat-ids (ali
bda0: 73 74 2d 72 65 66 20 27 72 75 6e 5f 73 74 61 74 st-ref 'run_stat
bdb0: 73 20 20 63 68 61 6e 67 65 64 29 29 0a 20 20 20 s changed)).
bdc0: 20 20 20 20 20 20 28 61 72 65 61 2d 74 61 67 20 (area-tag
bdd0: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
bde0: 2d 61 72 67 20 22 2d 61 72 65 61 2d 74 61 67 22 -arg "-area-tag"
bdf0: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
be00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be10: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
be20: 67 20 22 2d 61 72 65 61 2d 74 61 67 22 29 0a 20 g "-area-tag").
be30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be50: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
be60: 67 20 22 2d 61 72 65 61 22 29 20 0a 20 20 20 20 g "-area") .
be70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
be90: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 args:get-arg "-a
bea0: 72 65 61 22 29 20 0a 20 20 20 20 20 20 20 20 20 rea") .
beb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bec0: 20 20 20 20 20 20 20 20 20 20 22 22 29 29 29 29 ""))))
bed0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 . (if
bee0: 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 61 72 65 (and (equal? are
bef0: 61 2d 74 61 67 20 22 22 29 20 28 6e 6f 74 20 28 a-tag "") (not (
bf00: 70 67 64 62 3a 69 73 2d 61 72 65 61 2d 74 61 67 pgdb:is-area-tag
bf10: 65 64 20 64 62 68 20 28 76 65 63 74 6f 72 2d 72 ed dbh (vector-r
bf20: 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 ef area-info 0))
bf30: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
bf40: 73 65 74 21 20 61 72 65 61 2d 74 61 67 20 2a 64 set! area-tag *d
bf50: 65 66 61 75 6c 74 2d 61 72 65 61 2d 74 61 67 2a efault-area-tag*
bf60: 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 )) . (
bf70: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
bf80: 61 72 65 61 2d 74 61 67 20 22 22 29 29 20 0a 20 area-tag "")) .
bf90: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 73 (tas
bfa0: 6b 3a 61 64 64 2d 61 72 65 61 2d 74 61 67 20 64 k:add-area-tag d
bfb0: 62 68 20 61 72 65 61 2d 69 6e 66 6f 20 61 72 65 bh area-info are
bfc0: 61 2d 74 61 67 29 29 20 0a 09 20 20 28 69 66 20 a-tag)) .. (if
bfd0: 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (or (not (null?
bfe0: 74 65 73 74 2d 69 64 73 29 29 20 28 6e 6f 74 20 test-ids)) (not
bff0: 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 73 29 29 (null? run-ids))
c000: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
c010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c020: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
c030: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
c040: 2d 70 6f 72 74 2a 20 20 22 73 79 6e 63 69 6e 67 -port* "syncing
c050: 20 72 75 6e 73 22 29 20 20 20 0a 09 20 20 20 20 runs") ..
c060: 20 20 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 (tasks
c070: 3a 73 79 6e 63 2d 72 75 6e 2d 64 61 74 61 20 64 :sync-run-data d
c080: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 bh cached-info r
c090: 75 6e 2d 69 64 73 20 61 72 65 61 2d 69 6e 66 6f un-ids area-info
c0a0: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
c0b0: 70 64 61 74 65 2d 74 69 6d 65 29 20 0a 20 20 20 pdate-time) .
c0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
c0d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
c0e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
c0f0: 72 74 2a 20 20 22 73 79 6e 63 69 6e 67 20 74 65 rt* "syncing te
c100: 73 74 73 22 29 0a 09 09 20 20 20 20 20 20 20 20 sts")...
c110: 20 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d (tasks:sync-
c120: 74 65 73 74 73 2d 64 61 74 61 20 64 62 68 20 63 tests-data dbh c
c130: 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d ached-info test-
c140: 69 64 73 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d ids area-info sm
c150: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
c160: 74 65 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 te-time).
c170: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
c180: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
c190: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
c1a0: 20 22 73 79 6e 63 69 6e 67 20 74 65 73 74 20 73 "syncing test s
c1b0: 74 65 70 73 22 29 0a 20 20 20 20 20 20 20 20 20 teps").
c1c0: 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 79 (tasks:sy
c1d0: 6e 63 2d 74 65 73 74 2d 73 74 65 70 73 20 64 62 nc-test-steps db
c1e0: 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 h cached-info te
c1f0: 73 74 2d 73 74 65 70 2d 69 64 73 20 73 6d 61 6c st-step-ids smal
c200: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
c210: 2d 74 69 6d 65 29 0a 09 09 09 09 09 09 09 09 28 -time).........(
c220: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
c230: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
c240: 70 6f 72 74 2a 20 20 22 73 79 6e 63 69 6e 67 20 port* "syncing
c250: 74 65 73 74 20 64 61 74 61 22 29 0a 20 20 20 20 test data").
c260: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 73 (tas
c270: 6b 73 3a 73 79 6e 63 2d 74 65 73 74 2d 67 65 6e ks:sync-test-gen
c280: 2d 64 61 74 61 20 64 62 68 20 63 61 63 68 65 64 -data dbh cached
c290: 2d 69 6e 66 6f 20 74 65 73 74 2d 64 61 74 61 2d -info test-data-
c2a0: 69 64 73 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 ids smallest-las
c2b0: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 0a 20 t-update-time).
c2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c2d0: 70 72 69 6e 74 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d print "---------
c2e0: 2d 64 6f 6e 65 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d -done-----------
c2f0: 2d 2d 2d 2d 22 29 29 29 0a 20 20 20 20 20 28 6c ----"))). (l
c300: 65 74 2a 20 20 28 28 73 6d 61 6c 6c 65 73 74 2d et* ((smallest-
c310: 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 time (hash-table
c320: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 -ref/default sma
c330: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
c340: 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 e-time "smallest
c350: 2d 74 69 6d 65 22 20 23 66 29 29 29 0a 20 20 20 -time" #f))).
c360: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
c370: 6e 66 6f 20 30 20 22 73 6d 61 6c 6c 65 73 74 2d nfo 0 "smallest-
c380: 74 69 6d 65 20 3a 22 20 73 6d 61 6c 6c 65 73 74 time :" smallest
c390: 2d 74 69 6d 65 20 20 22 20 6c 61 73 74 2d 73 79 -time " last-sy
c3a0: 6e 63 2d 74 69 6d 65 20 22 20 6c 61 73 74 2d 73 nc-time " last-s
c3b0: 79 6e 63 2d 74 69 6d 65 29 0a 20 20 20 20 28 69 ync-time). (i
c3c0: 66 20 28 6e 6f 74 20 28 61 6e 64 20 74 61 72 67 f (not (and targ
c3d0: 65 74 20 72 75 6e 2d 6e 61 6d 65 29 29 20 0a 09 et run-name)) ..
c3e0: 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 73 (if (or (and s
c3f0: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 3e 20 mallest-time (>
c400: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 6c 61 smallest-time la
c410: 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 29 20 28 st-sync-time)) (
c420: 61 6e 64 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d and smallest-tim
c430: 65 20 28 65 71 3f 20 6c 61 73 74 2d 73 79 6e 63 e (eq? last-sync
c440: 2d 74 69 6d 65 20 30 29 29 29 0a 09 09 09 09 28 -time 0))).....(
c450: 70 67 64 62 3a 77 72 69 74 65 2d 73 79 6e 63 2d pgdb:write-sync-
c460: 74 69 6d 65 20 64 62 68 20 61 72 65 61 2d 69 6e time dbh area-in
c470: 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 fo smallest-time
c480: 29 29 29 29 29 20 3b 3b 74 68 69 73 20 6e 65 65 ))))) ;;this nee
c490: 64 73 20 74 6f 20 62 65 20 63 68 61 6e 67 65 64 ds to be changed
c4a0: 0a 09 28 69 66 20 28 74 61 73 6b 73 3a 73 65 74 ..(if (tasks:set
c4b0: 2d 61 72 65 61 20 64 62 68 20 63 6f 6e 66 69 67 -area dbh config
c4c0: 64 61 74 29 0a 09 20 20 20 20 28 74 61 73 6b 73 dat).. (tasks
c4d0: 3a 73 79 6e 63 2d 74 6f 2d 70 6f 73 74 67 72 65 :sync-to-postgre
c4e0: 73 20 63 6f 6e 66 69 67 64 61 74 20 64 65 73 74 s configdat dest
c4f0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
c500: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
c510: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
c520: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 75 -port* "ERROR: u
c530: 6e 61 62 6c 65 20 74 6f 20 63 72 65 61 74 65 20 nable to create
c540: 61 6e 20 61 72 65 61 20 72 65 63 6f 72 64 22 29 an area record")
c550: 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 29 0a .. #f))))).
c560: 0a 0a 29 0a ..).