Artifact
2fb43e8a5abbfbfef103525aba248d4dfc2ae9bb:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 73 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 sqlite3 srfi-1
01f0: 70 6f 73 69 78 20 72 65 67 65 78 2d 63 61 73 65 posix regex-case
0200: 20 62 61 73 65 36 34 20 66 6f 72 6d 61 74 20 64 base64 format d
0210: 6f 74 2d 6c 6f 63 6b 69 6e 67 20 63 73 76 2d 78 ot-locking csv-x
0220: 6d 6c 20 7a 33 29 0a 28 72 65 71 75 69 72 65 2d ml z3).(require-
0230: 65 78 74 65 6e 73 69 6f 6e 20 73 71 6c 69 74 65 extension sqlite
0240: 33 20 72 65 67 65 78 20 70 6f 73 69 78 29 0a 0a 3 regex posix)..
0250: 28 72 65 71 75 69 72 65 2d 65 78 74 65 6e 73 69 (require-extensi
0260: 6f 6e 20 28 73 72 66 69 20 31 38 29 20 65 78 74 on (srfi 18) ext
0270: 72 61 73 20 74 63 70 20 72 70 63 29 0a 0a 28 69 ras tcp rpc)..(i
0280: 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 mport (prefix sq
0290: 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 lite3 sqlite3:))
02a0: 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 .(import (prefix
02b0: 20 62 61 73 65 36 34 20 62 61 73 65 36 34 3a 29 base64 base64:)
02c0: 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 )..(declare (uni
02d0: 74 20 63 6f 6d 6d 6f 6e 29 29 0a 0a 28 69 6e 63 t common))..(inc
02e0: 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 lude "common_rec
02f0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 ords.scm")..;; (
0300: 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 require-library
0310: 6d 61 72 67 73 29 0a 3b 3b 20 28 69 6e 63 6c 75 margs).;; (inclu
0320: 64 65 20 22 6d 61 72 67 73 2e 73 63 6d 22 29 0a de "margs.scm").
0330: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 6f 6c 64 2d .;; (define old-
0340: 65 78 69 74 20 65 78 69 74 29 0a 3b 3b 20 0a 3b exit exit).;; .;
0350: 3b 20 28 64 65 66 69 6e 65 20 28 65 78 69 74 20 ; (define (exit
0360: 2e 20 63 6f 64 65 29 0a 3b 3b 20 20 20 28 69 66 . code).;; (if
0370: 20 28 6e 75 6c 6c 3f 20 63 6f 64 65 29 0a 3b 3b (null? code).;;
0380: 20 20 20 20 20 20 20 28 6f 6c 64 2d 65 78 69 74 (old-exit
0390: 29 0a 3b 3b 20 20 20 20 20 20 20 28 6f 6c 64 2d ).;; (old-
03a0: 65 78 69 74 20 63 6f 64 65 29 29 29 0a 0a 28 64 exit code)))..(d
03b0: 65 66 69 6e 65 20 67 65 74 65 6e 76 20 67 65 74 efine getenv get
03c0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
03d0: 69 61 62 6c 65 29 0a 28 64 65 66 69 6e 65 20 28 iable).(define (
03e0: 73 61 66 65 2d 73 65 74 65 6e 76 20 6b 65 79 20 safe-setenv key
03f0: 76 61 6c 29 0a 20 20 28 69 66 20 28 61 6e 64 20 val). (if (and
0400: 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 28 73 74 (string? val)(st
0410: 72 69 6e 67 3f 20 6b 65 79 29 29 0a 20 20 20 20 ring? key)).
0420: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
0430: 69 6f 6e 73 0a 20 20 20 20 20 20 20 65 78 6e 0a ions. exn.
0440: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
0450: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 62 61 int 0 "ERROR: ba
0460: 64 20 76 61 6c 75 65 20 66 6f 72 20 73 65 74 65 d value for sete
0470: 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c nv, key=" key ",
0480: 20 76 61 6c 75 65 3d 22 20 76 61 6c 29 0a 20 20 value=" val).
0490: 20 20 20 20 20 28 73 65 74 65 6e 76 20 6b 65 79 (setenv key
04a0: 20 76 61 6c 29 29 0a 20 20 20 20 20 20 28 64 65 val)). (de
04b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
04c0: 4f 52 3a 20 62 61 64 20 76 61 6c 75 65 20 66 6f OR: bad value fo
04d0: 72 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 r setenv, key="
04e0: 6b 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 key ", value=" v
04f0: 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 al)))..(define h
0500: 6f 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f 4d ome (getenv "HOM
0510: 45 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 65 E")).(define use
0520: 72 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 22 r (getenv "USER"
0530: 29 29 0a 0a 3b 3b 20 47 4c 4f 42 41 4c 20 47 4c ))..;; GLOBAL GL
0540: 45 54 43 48 45 53 0a 28 64 65 66 69 6e 65 2d 72 ETCHES.(define-r
0550: 65 63 6f 72 64 20 6d 65 67 61 74 65 73 74 3a 61 ecord megatest:a
0560: 72 65 61 0a 20 20 6e 61 6d 65 20 20 20 20 20 20 rea. name
0570: 20 20 20 20 20 20 20 20 20 3b 3b 20 61 72 65 61 ;; area
0580: 20 6e 61 6d 65 0a 20 20 70 61 74 68 20 20 20 20 name. path
0590: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6d 74 ;; mt
05a0: 20 72 75 6e 20 61 72 65 61 20 68 6f 6d 65 0a 20 run area home.
05b0: 20 74 72 61 6e 73 70 6f 72 74 20 20 20 20 20 20 transport
05c0: 20 20 20 20 3b 3b 20 64 65 66 61 75 6c 74 73 20 ;; defaults
05d0: 74 6f 20 68 74 74 70 0a 20 20 63 6f 6e 66 69 67 to http. config
05e0: 69 6e 66 6f 20 20 20 20 20 20 20 20 20 3b 3b 20 info ;;
05f0: 6c 65 67 61 63 79 20 63 6f 6e 66 69 67 20 66 6f legacy config fo
0600: 72 6d 61 74 0a 20 20 63 6f 6e 66 69 67 64 61 74 rmat. configdat
0610: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6d 65 67 ;; meg
0620: 61 74 65 73 74 20 63 6f 6e 66 69 67 0a 20 20 64 atest config. d
0630: 65 6e 6f 69 73 65 20 20 20 20 20 20 20 20 20 20 enoise
0640: 20 20 3b 3b 20 66 6f 63 61 6c 20 70 6f 69 6e 74 ;; focal point
0650: 20 66 6f 72 20 6e 6f 74 20 0a 20 20 63 6c 69 65 for not . clie
0660: 6e 74 2d 73 69 67 6e 61 74 75 72 65 20 20 20 3b nt-signature ;
0670: 3b 20 6b 65 79 20 66 6f 72 20 63 6c 69 65 6e 74 ; key for client
0680: 2d 73 65 72 76 65 72 20 63 6f 6e 76 65 72 73 61 -server conversa
0690: 74 69 6f 6e 0a 20 20 72 65 6d 6f 74 65 20 20 20 tion. remote
06a0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 68 61 73 ;; has
06b0: 68 20 6f 66 20 61 6c 6c 20 74 68 65 20 63 6c 69 h of all the cli
06c0: 65 6e 74 20 73 69 64 65 20 63 6f 6e 6e 6e 65 63 ent side connnec
06d0: 74 69 6f 6e 73 0a 20 20 72 75 6e 2d 6b 65 79 73 tions. run-keys
06e0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 61 ;; ta
06f0: 72 67 65 74 20 6b 65 79 73 20 66 6f 72 20 74 68 rget keys for th
0700: 69 73 20 61 72 65 61 0a 20 20 72 75 6e 73 20 20 is area. runs
0710: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0720: 75 73 65 64 20 69 6e 20 64 61 73 68 62 6f 61 72 used in dashboar
0730: 64 0a 20 20 72 65 61 64 2d 6f 6e 6c 79 20 20 20 d. read-only
0740: 20 20 20 20 20 20 20 3b 3b 20 63 61 6e 20 49 20 ;; can I
0750: 77 72 69 74 65 20 74 6f 20 74 68 69 73 20 61 72 write to this ar
0760: 65 61 3f 0a 20 20 29 0a 0a 28 64 65 66 69 6e 65 ea?. )..(define
0770: 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 *already-seen-r
0780: 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 23 unconfig-info* #
0790: 66 29 0a 28 64 65 66 69 6e 65 20 2a 77 61 69 74 f).(define *wait
07a0: 69 6e 67 2d 71 75 65 75 65 2a 20 20 20 20 20 28 ing-queue* (
07b0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
07c0: 29 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d ).(define *test-
07d0: 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 28 6d meta-updated* (m
07e0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
07f0: 0a 28 64 65 66 69 6e 65 20 2a 67 6c 6f 62 61 6c .(define *global
0800: 65 78 69 74 73 74 61 74 75 73 2a 20 20 30 29 20 exitstatus* 0)
0810: 3b 3b 20 61 74 74 65 6d 70 74 20 74 6f 20 77 6f ;; attempt to wo
0820: 72 6b 20 61 72 6f 75 6e 64 20 70 6f 73 73 69 62 rk around possib
0830: 6c 65 20 74 68 72 65 61 64 20 69 73 73 75 65 73 le thread issues
0840: 0a 28 64 65 66 69 6e 65 20 2a 70 61 73 73 6e 75 .(define *passnu
0850: 6d 2a 20 20 20 20 20 20 20 20 20 20 20 30 29 20 m* 0)
0860: 3b 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 ;; when running
0870: 74 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 track calls to r
0880: 75 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 un-tests or simi
0890: 6c 61 72 0a 28 64 65 66 69 6e 65 20 2a 77 72 69 lar.(define *wri
08a0: 74 65 2d 66 72 65 71 75 65 6e 63 79 2a 20 20 20 te-frequency*
08b0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
08c0: 29 29 20 3b 3b 20 72 75 6e 2d 69 64 20 3d 3e 20 )) ;; run-id =>
08d0: 28 76 65 63 74 6f 72 20 28 63 75 72 72 65 6e 74 (vector (current
08e0: 2d 73 65 63 6f 6e 64 73 29 20 30 29 29 0a 28 64 -seconds) 0)).(d
08f0: 65 66 69 6e 65 20 2a 61 6c 74 2d 6c 6f 67 2d 66 efine *alt-log-f
0900: 69 6c 65 2a 20 23 66 29 20 20 3b 3b 20 75 73 65 ile* #f) ;; use
0910: 64 20 62 79 20 2d 6c 6f 67 0a 28 64 65 66 69 6e d by -log.(defin
0920: 65 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 e *common:denois
0930: 65 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 e* (make-hash
0940: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 6f 72 20 -table)) ;; for
0950: 6c 6f 77 20 6e 6f 69 73 65 20 70 72 69 6e 74 69 low noise printi
0960: 6e 67 0a 0a 3b 3b 20 44 41 54 41 42 41 53 45 0a ng..;; DATABASE.
0970: 28 64 65 66 69 6e 65 20 2a 64 62 73 74 72 75 63 (define *dbstruc
0980: 74 2d 64 62 2a 20 20 23 66 29 0a 28 64 65 66 69 t-db* #f).(defi
0990: 6e 65 20 2a 64 62 2d 73 74 61 74 73 2a 20 20 20 ne *db-stats*
09a0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
09b0: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 ash-table)) ;; h
09c0: 61 73 68 20 6f 66 20 76 65 63 74 6f 72 73 20 3c ash of vectors <
09d0: 20 63 6f 75 6e 74 20 64 75 72 61 74 69 6f 6e 2d count duration-
09e0: 74 6f 74 61 6c 20 3e 0a 28 64 65 66 69 6e 65 20 total >.(define
09f0: 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a *db-stats-mutex*
0a00: 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 (make-mute
0a10: 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d x)).(define *db-
0a20: 73 79 6e 63 2d 6d 75 74 65 78 2a 20 20 20 20 20 sync-mutex*
0a30: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
0a40: 28 64 65 66 69 6e 65 20 2a 64 62 2d 6d 75 6c 74 (define *db-mult
0a50: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 28 6d i-sync-mutex* (m
0a60: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 ake-mutex)).(def
0a70: 69 6e 65 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 ine *db-local-sy
0a80: 6e 63 2a 20 20 20 20 20 20 20 28 6d 61 6b 65 2d nc* (make-
0a90: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
0aa0: 75 73 65 64 20 74 6f 20 72 65 63 6f 72 64 20 6c used to record l
0ab0: 61 73 74 20 74 6f 75 63 68 20 6f 66 20 64 62 0a ast touch of db.
0ac0: 28 64 65 66 69 6e 65 20 2a 6d 65 67 61 74 65 73 (define *megates
0ad0: 74 2d 64 62 2a 20 20 20 20 20 20 20 20 20 23 66 t-db* #f
0ae0: 29 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d ).(define *last-
0af0: 64 62 2d 61 63 63 65 73 73 2a 20 20 20 20 20 20 db-access*
0b00: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
0b10: 29 29 20 20 3b 3b 20 75 70 64 61 74 65 20 77 68 )) ;; update wh
0b20: 65 6e 20 64 62 20 69 73 20 61 63 63 65 73 73 65 en db is accesse
0b30: 64 20 76 69 61 20 73 65 72 76 65 72 0a 28 64 65 d via server.(de
0b40: 66 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d 61 fine *db-write-a
0b50: 63 63 65 73 73 2a 20 20 20 20 20 23 74 29 0a 28 ccess* #t).(
0b60: 64 65 66 69 6e 65 20 2a 69 6e 6d 65 6d 64 62 2a define *inmemdb*
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
0b80: 0a 28 64 65 66 69 6e 65 20 2a 74 61 73 6b 2d 64 .(define *task-d
0b90: 62 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 23 b* #
0ba0: 66 29 20 3b 3b 20 28 76 65 63 74 6f 72 20 64 62 f) ;; (vector db
0bb0: 20 70 61 74 68 2d 74 6f 2d 64 62 29 0a 28 64 65 path-to-db).(de
0bc0: 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 73 2d fine *db-access-
0bd0: 61 6c 6c 6f 77 65 64 2a 20 20 20 23 74 29 20 3b allowed* #t) ;
0be0: 3b 20 66 6c 61 67 20 74 6f 20 61 6c 6c 6f 77 20 ; flag to allow
0bf0: 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 2a access.(define *
0c00: 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a db-access-mutex*
0c10: 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 (make-mutex
0c20: 29 29 0a 0a 3b 3b 20 53 45 52 56 45 52 0a 28 64 ))..;; SERVER.(d
0c30: 65 66 69 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e 74 efine *my-client
0c40: 2d 73 69 67 6e 61 74 75 72 65 2a 20 23 66 29 0a -signature* #f).
0c50: 3b 3b 20 28 64 65 66 69 6e 65 20 2a 74 72 61 6e ;; (define *tran
0c60: 73 70 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 27 sport-type* '
0c70: 68 74 74 70 29 20 20 20 20 20 20 20 20 20 20 20 http)
0c80: 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 20 77 69 ;; override wi
0c90: 74 68 20 5b 73 65 72 76 65 72 5d 20 74 72 61 6e th [server] tran
0ca0: 73 70 6f 72 74 20 68 74 74 70 7c 72 70 63 7c 6e sport http|rpc|n
0cb0: 6d 73 67 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a msg.;; (define *
0cc0: 72 75 6e 72 65 6d 6f 74 65 2a 20 20 20 20 20 20 runremote*
0cd0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
0ce0: 62 6c 65 29 29 20 3b 3b 20 69 66 20 73 65 74 20 ble)) ;; if set
0cf0: 75 70 20 66 6f 72 20 73 65 72 76 65 72 20 63 6f up for server co
0d00: 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 74 68 69 73 mmunication this
0d10: 20 77 69 6c 6c 20 68 6f 6c 64 20 3c 68 6f 73 74 will hold <host
0d20: 20 70 6f 72 74 3e 0a 0a 28 64 65 66 69 6e 65 20 port>..(define
0d30: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 65 6d 6f (common:get-remo
0d40: 74 65 20 72 65 6d 6f 74 65 20 72 75 6e 2d 69 64 te remote run-id
0d50: 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 6f ). (let ((ht (o
0d60: 72 20 72 65 6d 6f 74 65 20 2a 72 75 6e 72 65 6d r remote *runrem
0d70: 6f 74 65 2a 29 29 29 0a 20 20 20 20 28 69 66 20 ote*))). (if
0d80: 68 74 0a 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ht..(hash-table-
0d90: 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 72 ref/default ht r
0da0: 75 6e 2d 69 64 20 23 66 29 0a 09 23 66 29 29 29 un-id #f)..#f)))
0db0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
0dc0: 6e 3a 73 65 74 2d 72 65 6d 6f 74 65 21 20 72 65 n:set-remote! re
0dd0: 6d 6f 74 65 20 72 75 6e 2d 69 64 20 76 61 6c 75 mote run-id valu
0de0: 65 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 e). (let ((ht (
0df0: 6f 72 20 72 65 6d 6f 74 65 20 2a 72 75 6e 72 65 or remote *runre
0e00: 6d 6f 74 65 2a 29 29 29 0a 20 20 20 20 28 69 66 mote*))). (if
0e10: 20 68 74 0a 09 28 68 61 73 68 2d 74 61 62 6c 65 ht..(hash-table
0e20: 2d 73 65 74 21 20 68 74 20 72 75 6e 2d 69 64 20 -set! ht run-id
0e30: 76 61 6c 75 65 29 29 29 29 0a 0a 28 64 65 66 69 value))))..(defi
0e40: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 65 6c 2d 72 ne (common:del-r
0e50: 65 6d 6f 74 65 21 20 72 65 6d 6f 74 65 20 72 75 emote! remote ru
0e60: 6e 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 28 68 n-id). (let ((h
0e70: 74 20 28 6f 72 20 72 65 6d 6f 74 65 20 2a 72 75 t (or remote *ru
0e80: 6e 72 65 6d 6f 74 65 2a 29 29 29 0a 20 20 20 20 nremote*))).
0e90: 28 69 66 20 68 74 0a 09 28 68 61 73 68 2d 74 61 (if ht..(hash-ta
0ea0: 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 74 20 72 ble-delete! ht r
0eb0: 75 6e 2d 69 64 29 29 29 29 0a 0a 28 64 65 66 69 un-id))))..(defi
0ec0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 ne (common:get-r
0ed0: 65 6d 6f 74 65 2d 61 6c 6c 20 72 65 6d 6f 74 65 emote-all remote
0ee0: 29 0a 20 20 28 6c 65 74 20 28 28 68 74 20 28 6f ). (let ((ht (o
0ef0: 72 20 72 65 6d 6f 74 65 20 2a 72 75 6e 72 65 6d r remote *runrem
0f00: 6f 74 65 2a 29 29 29 0a 20 20 20 20 28 69 66 20 ote*))). (if
0f10: 68 74 0a 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ht..(hash-table-
0f20: 6b 65 79 73 20 68 74 29 0a 09 27 28 29 29 29 29 keys ht)..'())))
0f30: 0a 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 63 ..(define *max-c
0f40: 61 63 68 65 2d 73 69 7a 65 2a 20 20 20 20 30 29 ache-size* 0)
0f50: 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 65 64 .(define *logged
0f60: 2d 69 6e 2d 63 6c 69 65 6e 74 73 2a 20 28 6d 61 -in-clients* (ma
0f70: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
0f80: 28 64 65 66 69 6e 65 20 2a 63 6c 69 65 6e 74 2d (define *client-
0f90: 6e 6f 6e 2d 62 6c 6f 63 6b 69 6e 67 2d 6d 6f 64 non-blocking-mod
0fa0: 65 2a 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a e* #f).(define *
0fb0: 73 65 72 76 65 72 2d 69 64 2a 20 20 20 20 20 20 server-id*
0fc0: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
0fd0: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 20 20 20 server-info*
0fe0: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
0ff0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 20 20 time-to-exit*
1000: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
1010: 72 65 63 65 69 76 65 64 2d 72 65 73 70 6f 6e 73 received-respons
1020: 65 2a 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a e* #f).(define *
1030: 64 65 66 61 75 6c 74 2d 6e 75 6d 74 72 69 65 73 default-numtries
1040: 2a 20 20 31 30 29 0a 28 64 65 66 69 6e 65 20 2a * 10).(define *
1050: 73 65 72 76 65 72 2d 72 75 6e 2a 20 20 20 20 20 server-run*
1060: 20 20 20 23 74 29 0a 28 64 65 66 69 6e 65 20 2a #t).(define *
1070: 72 75 6e 2d 69 64 2a 20 20 20 20 20 20 20 20 20 run-id*
1080: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
1090: 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a server-kind-run*
10a0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
10b0: 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a ble))..(define *
10c0: 74 61 72 67 65 74 2a 20 20 20 20 20 20 20 20 20 target*
10d0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
10e0: 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 ble)) ;; cache t
10f0: 68 65 20 74 61 72 67 65 74 20 68 65 72 65 3b 20 he target here;
1100: 74 61 72 67 65 74 20 69 73 20 6b 65 79 76 61 6c target is keyval
1110: 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e 2f 6b 65 1/keyval2/.../ke
1120: 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 20 2a 6b yvalN.(define *k
1130: 65 79 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 eys*
1140: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
1150: 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 68 le)) ;; cache th
1160: 65 20 6b 65 79 73 20 68 65 72 65 0a 28 64 65 66 e keys here.(def
1170: 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a 20 20 20 ine *keyvals*
1180: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1190: 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 sh-table)).(defi
11a0: 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 61 74 68 ne *toptest-path
11b0: 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 s* (make-has
11c0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 h-table)) ;; cac
11d0: 68 65 20 74 6f 70 74 65 73 74 20 70 61 74 68 20 he toptest path
11e0: 73 65 74 74 69 6e 67 73 20 68 65 72 65 0a 28 64 settings here.(d
11f0: 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 61 74 68 efine *test-path
1200: 73 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d s* (make-
1210: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1220: 63 61 63 68 65 20 74 65 73 74 2d 69 64 20 74 6f cache test-id to
1230: 20 74 65 73 74 20 72 75 6e 20 70 61 74 68 73 20 test run paths
1240: 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 74 65 here.(define *te
1250: 73 74 2d 69 64 73 2a 20 20 20 20 20 20 20 20 20 st-ids*
1260: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1270: 65 29 29 20 3b 3b 20 63 61 63 68 65 20 72 75 6e e)) ;; cache run
1280: 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 2c 20 61 -id, testname, a
1290: 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 3d 3e 20 nd item-path =>
12a0: 74 65 73 74 2d 69 64 0a 28 64 65 66 69 6e 65 20 test-id.(define
12b0: 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 20 20 20 *test-info*
12c0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
12d0: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
12e0: 74 68 65 20 74 65 73 74 20 69 6e 66 6f 20 72 65 the test info re
12f0: 63 6f 72 64 73 2c 20 75 70 64 61 74 65 20 74 68 cords, update th
1300: 65 20 73 74 61 74 65 2c 20 73 74 61 74 75 73 2c e state, status,
1310: 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 65 74 run_duration et
1320: 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 61 74 2e c. from testdat.
1330: 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e db..(define *run
1340: 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 20 20 -info-cache*
1350: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1360: 29 29 20 3b 3b 20 72 75 6e 20 69 6e 66 6f 20 69 )) ;; run info i
1370: 73 20 73 74 61 62 6c 65 2c 20 6e 6f 20 6e 65 65 s stable, no nee
1380: 64 20 74 6f 20 72 65 67 65 74 0a 0a 3b 3b 20 41 d to reget..;; A
1390: 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 46 49 58 wful. Please FIX
13a0: 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 2d ME.(define *env-
13b0: 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 vars-by-run-id*
13c0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
13d0: 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 75 72 72 )).(define *curr
13e0: 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 20 20 20 ent-run-name*
13f0: 23 66 29 0a 0a 3b 3b 20 54 65 73 74 63 6f 6e 66 #f)..;; Testconf
1400: 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 69 67 ig and runconfig
1410: 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 69 6e caches. .(defin
1420: 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 e *testconfigs*
1430: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1440: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 73 74 -table)) ;; test
1450: 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 63 6f 6e -name => testcon
1460: 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e fig.(define *run
1470: 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 20 20 configs*
1480: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1490: 29 29 20 3b 3b 20 74 61 72 67 65 74 20 20 20 20 )) ;; target
14a0: 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a 0a 3b 3b => runconfig..;;
14b0: 20 54 68 69 73 20 69 73 20 61 20 63 61 63 68 65 This is a cache
14c0: 20 6f 66 20 70 72 65 2d 72 65 71 73 20 6d 65 74 of pre-reqs met
14d0: 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 6c 63 20 , don't re-calc
14e0: 69 6e 20 63 61 73 65 73 20 77 68 65 72 65 20 63 in cases where c
14f0: 61 6c 6c 65 64 20 77 69 74 68 20 73 61 6d 65 20 alled with same
1500: 70 61 72 61 6d 73 20 6c 65 73 73 20 74 68 61 6e params less than
1510: 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f 6e 64 73 .;; five seconds
1520: 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 2a 70 72 ago.(define *pr
1530: 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 68 65 e-reqs-met-cache
1540: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
1550: 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 le))..(define (c
1560: 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 ommon:clear-cach
1570: 65 73 29 0a 20 20 28 73 65 74 21 20 2a 74 61 72 es). (set! *tar
1580: 67 65 74 2a 20 20 20 20 20 20 20 20 20 20 20 20 get*
1590: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
15a0: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 6b 65 79 e)). (set! *key
15b0: 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s*
15c0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
15d0: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 6b 65 79 e)). (set! *key
15e0: 76 61 6c 73 2a 20 20 20 20 20 20 20 20 20 20 20 vals*
15f0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1600: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 6f 70 e)). (set! *top
1610: 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 20 test-paths*
1620: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1630: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 e)). (set! *tes
1640: 74 2d 70 61 74 68 73 2a 20 20 20 20 20 20 20 20 t-paths*
1650: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1660: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 e)). (set! *tes
1670: 74 2d 69 64 73 2a 20 20 20 20 20 20 20 20 20 20 t-ids*
1680: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1690: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 e)). (set! *tes
16a0: 74 2d 69 6e 66 6f 2a 20 20 20 20 20 20 20 20 20 t-info*
16b0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
16c0: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 72 75 6e e)). (set! *run
16d0: 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 20 20 -info-cache*
16e0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
16f0: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 65 6e 76 e)). (set! *env
1700: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
1710: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1720: 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 e)). (set! *tes
1730: 74 2d 69 64 2d 63 61 63 68 65 2a 20 20 20 20 20 t-id-cache*
1740: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1750: 65 29 29 29 0a 0a 3b 3b 20 47 65 6e 65 72 69 63 e)))..;; Generic
1760: 20 73 74 72 69 6e 67 20 64 61 74 61 62 61 73 65 string database
1770: 0a 28 64 65 66 69 6e 65 20 73 64 62 3a 71 72 79 .(define sdb:qry
1780: 20 23 66 29 20 3b 3b 20 28 6d 61 6b 65 2d 73 64 #f) ;; (make-sd
1790: 62 3a 71 72 79 29 29 20 3b 3b 20 20 27 69 6e 69 b:qry)) ;; 'ini
17a0: 74 20 23 66 29 0a 3b 3b 20 47 65 6e 65 72 69 63 t #f).;; Generic
17b0: 20 70 61 74 68 20 64 61 74 61 62 61 73 65 0a 28 path database.(
17c0: 64 65 66 69 6e 65 20 2a 66 64 62 2a 20 23 66 29 define *fdb* #f)
17d0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
17e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 20 ==========.;; L
1820: 4f 20 43 20 4b 20 45 20 52 20 53 20 20 20 41 20 O C K E R S A
1830: 4e 20 44 20 20 20 42 20 4c 20 4f 20 43 20 4b 20 N D B L O C K
1840: 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E R S .;;=======
1850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1890: 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 72 74 68 65 .;; block furthe
18a0: 72 20 61 63 63 65 73 73 65 73 20 74 6f 20 64 61 r accesses to da
18b0: 74 61 62 61 73 65 73 2e 20 43 61 6c 6c 20 74 68 tabases. Call th
18c0: 69 73 20 62 65 66 6f 72 65 20 73 68 75 74 74 69 is before shutti
18d0: 6e 67 20 64 62 20 64 6f 77 6e 0a 28 64 65 66 69 ng db down.(defi
18e0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d 62 6c ne (common:db-bl
18f0: 6f 63 6b 2d 66 75 72 74 68 65 72 2d 71 75 65 72 ock-further-quer
1900: 69 65 73 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f ies). (mutex-lo
1910: 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d ck! *db-access-m
1920: 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a utex*). (set! *
1930: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
1940: 64 2a 20 23 66 29 0a 20 20 28 6d 75 74 65 78 2d d* #f). (mutex-
1950: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 unlock! *db-acce
1960: 73 73 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 ss-mutex*))..(de
1970: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d fine (common:db-
1980: 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 3f 29 access-allowed?)
1990: 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 62 . (let ((val (b
19a0: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 6d 75 egin.. (mu
19b0: 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 tex-lock! *db-ac
19c0: 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 09 20 20 cess-mutex*)..
19d0: 20 20 20 20 20 2a 64 62 2d 61 63 63 65 73 73 2d *db-access-
19e0: 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 20 20 20 20 allowed*..
19f0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
1a00: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
1a10: 2a 29 29 29 29 0a 20 20 20 20 76 61 6c 29 29 0a *)))). val)).
1a20: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 55 20 53 =========.;; U S
1a70: 20 45 20 46 20 55 20 4c 20 20 20 53 20 54 20 55 E F U L S T U
1a80: 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d F F.;;=========
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
1ad0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
1ae0: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 77 ow-noise-print w
1af0: 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 0a 20 aitval . keys).
1b00: 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 (let* ((key
1b10: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
1b20: 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 perse (map conc
1b30: 6b 65 79 73 29 20 22 2d 22 20 29 29 0a 09 20 28 keys) "-" )).. (
1b40: 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d 74 lasttime (hash-t
1b50: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1b60: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
1b70: 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 63 75 72 * key 0)).. (cur
1b80: 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 rtime (current-s
1b90: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 econds))). (i
1ba0: 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 f (> (- currtime
1bb0: 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 lasttime) waitv
1bc0: 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 al)..(begin.. (
1bd0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1be0: 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a *common:denoise*
1bf0: 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a 09 key currtime)..
1c00: 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 #t)..#f)))..(d
1c10: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
1c20: 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a t-megatest-exe).
1c30: 20 20 28 69 66 20 28 67 65 74 65 6e 76 20 22 4d (if (getenv "M
1c40: 54 5f 4d 45 47 41 54 45 53 54 22 29 20 28 67 65 T_MEGATEST") (ge
1c50: 74 65 6e 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 tenv "MT_MEGATES
1c60: 54 22 29 20 22 6d 65 67 61 74 65 73 74 22 29 29 T") "megatest"))
1c70: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
1c80: 6e 3a 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 n:read-encoded-s
1c90: 74 72 69 6e 67 20 69 6e 73 74 72 29 0a 20 20 28 tring instr). (
1ca0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
1cb0: 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 68 61 6e s. exn. (han
1cc0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
1cd0: 20 20 20 65 78 6e 0a 20 20 20 20 28 62 65 67 69 exn. (begi
1ce0: 6e 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 n. (debug:p
1cf0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 72 rint 0 "ERROR: r
1d00: 65 63 65 69 76 65 64 20 62 61 64 20 65 6e 63 6f eceived bad enco
1d10: 64 65 64 20 73 74 72 69 6e 67 20 5c 22 22 20 69 ded string \"" i
1d20: 6e 73 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 nstr "\", messag
1d30: 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
1d40: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
1d50: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
1d60: 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 28 70 ) exn)). (p
1d70: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
1d80: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
1d90: 6f 72 74 29 29 0a 20 20 20 20 20 20 23 66 29 0a ort)). #f).
1da0: 20 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e 2d (read (open-
1db0: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 62 61 input-string (ba
1dc0: 73 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f se64:base64-deco
1dd0: 64 65 20 69 6e 73 74 72 29 29 29 29 0a 20 20 20 de instr)))).
1de0: 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 (read (open-inpu
1df0: 74 2d 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 t-string (z3:dec
1e00: 6f 64 65 2d 62 75 66 66 65 72 20 28 62 61 73 65 ode-buffer (base
1e10: 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 64:base64-decode
1e20: 20 69 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b instr))))))..;;
1e30: 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 dot-locking egg
1e40: 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f seems not to wo
1e50: 72 6b 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 rk, using this f
1e60: 6f 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 or now.;; if loc
1e70: 6b 20 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 k is older than
1e80: 65 78 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e expire-time then
1e90: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 remove it and t
1ea0: 72 79 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 ry again.;; to g
1eb0: 65 74 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 et the lock.;;.(
1ec0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
1ed0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
1ee0: 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 fname #!key (exp
1ef0: 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 ire-time 300)).
1f00: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
1f10: 73 3f 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 s? fname).
1f20: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
1f30: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 nt-seconds)(file
1f40: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
1f50: 6d 65 20 66 6e 61 6d 65 29 29 20 65 78 70 69 72 me fname)) expir
1f60: 65 2d 74 69 6d 65 29 0a 09 20 20 28 62 65 67 69 e-time).. (begi
1f70: 6e 0a 09 20 20 20 20 28 64 65 6c 65 74 65 2d 66 n.. (delete-f
1f80: 69 6c 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 ile* fname)..
1f90: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
1fa0: 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 file-lock fname
1fb0: 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 expire-time: exp
1fc0: 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 23 66 ire-time)).. #f
1fd0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b ). (let ((k
1fe0: 65 79 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 ey-string (conc
1ff0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
2000: 22 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f "-" (current-pro
2010: 63 65 73 73 2d 69 64 29 29 29 29 0a 09 28 77 69 cess-id))))..(wi
2020: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
2030: 65 20 66 6e 61 6d 65 0a 09 20 20 28 6c 61 6d 62 e fname.. (lamb
2040: 64 61 20 28 29 0a 09 20 20 20 20 28 70 72 69 6e da ().. (prin
2050: 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a t key-string))).
2060: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
2070: 30 2e 32 35 29 0a 09 28 77 69 74 68 2d 69 6e 70 0.25)..(with-inp
2080: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 ut-from-file fna
2090: 6d 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 29 me.. (lambda ()
20a0: 0a 09 20 20 20 20 28 65 71 75 61 6c 3f 20 6b 65 .. (equal? ke
20b0: 79 2d 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c y-string (read-l
20c0: 69 6e 65 29 29 29 29 29 29 29 0a 09 0a 28 64 65 ine)))))))...(de
20d0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d fine (common:sim
20e0: 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 ple-file-release
20f0: 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 0a 20 20 28 -lock fname). (
2100: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 delete-file* fna
2110: 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d me))..;;========
2120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2160: 3b 20 53 20 54 20 41 20 54 20 45 20 53 20 20 20 ; S T A T E S
2170: 41 20 4e 20 44 20 20 20 53 20 54 20 41 20 54 20 A N D S T A T
2180: 55 20 53 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d U S E S.;;======
2190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21d0: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f ..(define *commo
21e0: 6e 3a 73 74 64 2d 73 74 61 74 65 73 2a 20 20 20 n:std-states*
21f0: 0a 20 20 27 28 28 30 20 22 43 4f 4d 50 4c 45 54 . '((0 "COMPLET
2200: 45 44 22 29 0a 20 20 20 20 28 31 20 22 4e 4f 54 ED"). (1 "NOT
2210: 5f 53 54 41 52 54 45 44 22 29 0a 20 20 20 20 28 _STARTED"). (
2220: 32 20 22 52 55 4e 4e 49 4e 47 22 29 0a 20 20 20 2 "RUNNING").
2230: 20 28 33 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 (3 "REMOTEHOSTS
2240: 54 41 52 54 22 29 0a 20 20 20 20 28 34 20 22 4c TART"). (4 "L
2250: 41 55 4e 43 48 45 44 22 29 0a 20 20 20 20 28 35 AUNCHED"). (5
2260: 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 20 20 28 "KILLED"). (
2270: 36 20 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 6 "KILLREQ").
2280: 20 28 37 20 22 53 54 55 43 4b 22 29 0a 20 20 20 (7 "STUCK").
2290: 20 28 38 20 22 41 52 43 48 49 56 45 44 22 29 29 (8 "ARCHIVED"))
22a0: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d )..(define *comm
22b0: 6f 6e 3a 73 74 64 2d 73 74 61 74 75 73 65 73 2a on:std-statuses*
22c0: 0a 20 20 27 28 28 30 20 22 50 41 53 53 22 29 0a . '((0 "PASS").
22d0: 20 20 20 20 28 31 20 22 57 41 52 4e 22 29 0a 20 (1 "WARN").
22e0: 20 20 20 28 32 20 22 46 41 49 4c 22 29 0a 20 20 (2 "FAIL").
22f0: 20 20 28 33 20 22 43 48 45 43 4b 22 29 0a 20 20 (3 "CHECK").
2300: 20 20 28 34 20 22 6e 2f 61 22 29 0a 20 20 20 20 (4 "n/a").
2310: 28 35 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 (5 "WAIVED").
2320: 20 28 36 20 22 53 4b 49 50 22 29 0a 20 20 20 20 (6 "SKIP").
2330: 28 37 20 22 44 45 4c 45 54 45 44 22 29 0a 20 20 (7 "DELETED").
2340: 20 20 28 38 20 22 53 54 55 43 4b 2f 44 45 41 44 (8 "STUCK/DEAD
2350: 22 29 0a 20 20 20 20 28 39 20 22 41 42 4f 52 54 "). (9 "ABORT
2360: 22 29 29 29 0a 0a 3b 3b 20 54 68 65 73 65 20 61 ")))..;; These a
2370: 72 65 20 73 74 6f 70 70 69 6e 67 20 63 6f 6e 64 re stopping cond
2380: 69 74 69 6f 6e 73 20 74 68 61 74 20 70 72 65 76 itions that prev
2390: 65 6e 74 20 61 20 74 65 73 74 20 66 72 6f 6d 20 ent a test from
23a0: 62 65 69 6e 67 20 72 75 6e 0a 28 64 65 66 69 6e being run.(defin
23b0: 65 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 e *common:cant-r
23c0: 75 6e 2d 73 74 61 74 65 73 2d 73 79 6d 2a 20 0a un-states-sym* .
23d0: 20 20 27 28 43 4f 4d 50 4c 45 54 45 44 20 4b 49 '(COMPLETED KI
23e0: 4c 4c 45 44 20 57 41 49 56 45 44 20 55 4e 4b 4e LLED WAIVED UNKN
23f0: 4f 57 4e 20 49 4e 43 4f 4d 50 4c 45 54 45 20 41 OWN INCOMPLETE A
2400: 42 4f 52 54 20 41 52 43 48 49 56 45 44 29 29 0a BORT ARCHIVED)).
2410: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 =========.;; D E
2460: 20 42 20 55 20 47 20 47 20 49 20 4e 20 47 20 20 B U G G I N G
2470: 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d S T U F F .;;==
2480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24c0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 76 ====..(define *v
24d0: 65 72 62 6f 73 69 74 79 2a 20 20 20 20 20 20 20 erbosity*
24e0: 20 20 31 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 1).(define *lo
24f0: 67 67 69 6e 67 2a 20 20 20 20 20 20 20 20 20 20 gging*
2500: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 #f)..(define (g
2510: 65 74 2d 77 69 74 68 2d 64 65 66 61 75 6c 74 20 et-with-default
2520: 76 61 6c 20 64 65 66 61 75 6c 74 29 0a 20 20 28 val default). (
2530: 6c 65 74 20 28 28 76 61 6c 20 28 61 72 67 73 3a let ((val (args:
2540: 67 65 74 2d 61 72 67 20 76 61 6c 29 29 29 0a 20 get-arg val))).
2550: 20 20 20 28 69 66 20 76 61 6c 20 76 61 6c 20 64 (if val val d
2560: 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 efault)))..(defi
2570: 6e 65 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c ne (assoc/defaul
2580: 74 20 6b 65 79 20 6c 73 74 20 2e 20 64 65 66 61 t key lst . defa
2590: 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ult). (let ((re
25a0: 73 20 28 61 73 73 6f 63 20 6b 65 79 20 6c 73 74 s (assoc key lst
25b0: 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 73 20 ))). (if res
25c0: 28 63 61 64 72 20 72 65 73 29 28 69 66 20 28 6e (cadr res)(if (n
25d0: 75 6c 6c 3f 20 64 65 66 61 75 6c 74 29 20 23 66 ull? default) #f
25e0: 20 28 63 61 72 20 64 65 66 61 75 6c 74 29 29 29 (car default)))
25f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
2600: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
2610: 65 2d 6e 61 6d 65 20 61 72 65 61 2d 64 61 74 29 e-name area-dat)
2620: 0a 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a . (or (configf:
2630: 6c 6f 6f 6b 75 70 20 28 6d 65 67 61 74 65 73 74 lookup (megatest
2640: 3a 61 72 65 61 2d 63 6f 6e 66 69 67 64 61 74 20 :area-configdat
2650: 61 72 65 61 2d 64 61 74 29 20 22 73 65 74 75 70 area-dat) "setup
2660: 22 20 22 74 65 73 74 73 75 69 74 65 22 20 29 0a " "testsuite" ).
2670: 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 6d 65 (pathname
2680: 2d 66 69 6c 65 20 28 6d 65 67 61 74 65 73 74 3a -file (megatest:
2690: 61 72 65 61 2d 70 61 74 68 20 20 20 20 20 20 61 area-path a
26a0: 72 65 61 2d 64 61 74 29 29 29 29 0a 0a 3b 3b 3d rea-dat))))..;;=
26b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
26f0: 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 =====.;; E X I T
2700: 20 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e H A N D L I N
2710: 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;===========
2720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
2760: 66 69 6e 65 20 28 73 74 64 2d 65 78 69 74 2d 70 fine (std-exit-p
2770: 72 6f 63 65 64 75 72 65 20 61 72 65 61 2d 64 61 rocedure area-da
2780: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 6e 6f 2d t). (let* ((no-
2790: 68 75 72 72 79 20 20 28 69 66 20 2a 74 69 6d 65 hurry (if *time
27a0: 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 -to-exit* ;; hur
27b0: 72 79 20 75 70 0a 09 09 20 20 20 20 20 20 20 23 ry up... #
27c0: 66 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 f... (begi
27d0: 6e 0a 09 09 09 20 28 73 65 74 21 20 2a 74 69 6d n.... (set! *tim
27e0: 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 e-to-exit* #t)..
27f0: 09 09 20 23 74 29 29 29 0a 20 20 20 20 20 20 20 .. #t))).
2800: 20 20 28 63 6f 6e 66 69 67 64 61 74 20 28 6d 65 (configdat (me
2810: 67 61 74 65 73 74 3a 61 72 65 61 2d 63 6f 6e 66 gatest:area-conf
2820: 69 67 64 61 74 20 61 72 65 61 2d 64 61 74 29 29 igdat area-dat))
2830: 0a 09 20 28 72 75 6e 2d 69 64 73 20 20 20 28 68 .. (run-ids (h
2840: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a ash-table-keys *
2850: 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a 29 29 db-local-sync*))
2860: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
2870: 6e 74 2d 69 6e 66 6f 20 34 20 22 73 74 61 72 74 nt-info 4 "start
2880: 69 6e 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 ing exit process
2890: 2c 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 , finalizing dat
28a0: 61 62 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 abases."). (i
28b0: 66 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 f (and no-hurry
28c0: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
28d0: 65 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 e 18))..(rmt:pri
28e0: 6e 74 2d 64 62 2d 73 74 61 74 73 20 61 72 65 61 nt-db-stats area
28f0: 2d 64 61 74 29 29 0a 20 20 20 20 28 6c 65 74 20 -dat)). (let
2900: 28 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 ((th1 (make-thre
2910: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b ad (lambda () ;;
2920: 20 74 68 72 65 61 64 20 66 6f 72 20 63 6c 65 61 thread for clea
2930: 6e 69 6e 67 20 75 70 2c 20 67 69 76 65 20 69 74 ning up, give it
2940: 20 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 09 09 five seconds...
2950: 09 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
2960: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d (not (null? run-
2970: 69 64 73 29 29 0a 09 09 09 09 20 20 20 20 20 20 ids)).....
2980: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
2990: 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 75 configdat "setu
29a0: 70 22 20 22 6d 65 67 61 74 65 73 74 2d 64 62 22 p" "megatest-db"
29b0: 29 29 0a 09 09 09 09 20 20 28 69 66 20 6e 6f 2d ))..... (if no-
29c0: 68 75 72 72 79 20 28 64 62 3a 6d 75 6c 74 69 2d hurry (db:multi-
29d0: 64 62 2d 73 79 6e 63 20 72 75 6e 2d 69 64 73 20 db-sync run-ids
29e0: 27 6e 65 77 32 6f 6c 64 29 29 29 0a 09 09 09 20 'new2old)))....
29f0: 20 20 20 20 20 28 69 66 20 2a 64 62 73 74 72 75 (if *dbstru
2a00: 63 74 2d 64 62 2a 20 28 64 62 3a 63 6c 6f 73 65 ct-db* (db:close
2a10: 2d 61 6c 6c 20 2a 64 62 73 74 72 75 63 74 2d 64 -all *dbstruct-d
2a20: 62 2a 20 61 72 65 61 2d 64 61 74 29 29 0a 09 09 b* area-dat))...
2a30: 09 20 20 20 20 20 20 28 69 66 20 2a 69 6e 6d 65 . (if *inme
2a40: 6d 64 62 2a 20 20 20 20 20 28 64 62 3a 63 6c 6f mdb* (db:clo
2a50: 73 65 2d 61 6c 6c 20 2a 69 6e 6d 65 6d 64 62 2a se-all *inmemdb*
2a60: 20 61 72 65 61 2d 64 61 74 29 29 0a 09 09 09 20 area-dat))....
2a70: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 2a 6d (if (and *m
2a80: 65 67 61 74 65 73 74 2d 64 62 2a 0a 09 09 09 09 egatest-db*.....
2a90: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
2aa0: 64 61 74 61 62 61 73 65 3f 20 2a 6d 65 67 61 74 database? *megat
2ab0: 65 73 74 2d 64 62 2a 29 29 0a 09 09 09 09 20 20 est-db*)).....
2ac0: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 (begin..... (
2ad0: 73 71 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 70 sqlite3:interrup
2ae0: 74 21 20 2a 6d 65 67 61 74 65 73 74 2d 64 62 2a t! *megatest-db*
2af0: 29 0a 09 09 09 09 20 20 20 20 28 73 71 6c 69 74 )..... (sqlit
2b00: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 2a 6d 65 e3:finalize! *me
2b10: 67 61 74 65 73 74 2d 64 62 2a 20 23 74 29 0a 09 gatest-db* #t)..
2b20: 09 09 09 20 20 20 20 28 73 65 74 21 20 2a 6d 65 ... (set! *me
2b30: 67 61 74 65 73 74 2d 64 62 2a 20 23 66 29 29 29 gatest-db* #f)))
2b40: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 2a 74 .... (if *t
2b50: 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 09 09 09 ask-db* .....
2b60: 20 20 28 6c 65 74 20 28 28 64 62 20 28 63 64 72 (let ((db (cdr
2b70: 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 0a 09 09 *task-db*)))...
2b80: 09 09 20 20 20 20 28 69 66 20 28 73 71 6c 69 74 .. (if (sqlit
2b90: 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 62 29 e3:database? db)
2ba0: 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ......(begin....
2bb0: 09 09 20 20 28 73 71 6c 69 74 65 33 3a 69 6e 74 .. (sqlite3:int
2bc0: 65 72 72 75 70 74 21 20 64 62 29 0a 09 09 09 09 errupt! db).....
2bd0: 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 . (sqlite3:fina
2be0: 6c 69 7a 65 21 20 64 62 20 23 74 29 0a 09 09 09 lize! db #t)....
2bf0: 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 .. (vector-set!
2c00: 20 2a 74 61 73 6b 2d 64 62 2a 20 30 20 23 66 29 *task-db* 0 #f)
2c10: 29 29 29 29 29 20 22 43 6c 65 61 6e 75 70 20 64 ))))) "Cleanup d
2c20: 62 20 65 78 69 74 20 74 68 72 65 61 64 22 29 29 b exit thread"))
2c30: 0a 09 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 .. (th2 (make-t
2c40: 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 hread (lambda ()
2c50: 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
2c60: 3a 70 72 69 6e 74 20 34 20 22 41 74 74 65 6d 70 :print 4 "Attemp
2c70: 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e ting clean exit.
2c80: 20 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 Please be patie
2c90: 6e 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 nt and wait a fe
2ca0: 77 20 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a 09 w seconds...")..
2cb0: 09 09 20 20 20 20 20 20 28 69 66 20 6e 6f 2d 68 .. (if no-h
2cc0: 75 72 72 79 0a 09 09 09 09 20 20 28 74 68 72 65 urry..... (thre
2cd0: 61 64 2d 73 6c 65 65 70 21 20 35 29 20 3b 3b 20 ad-sleep! 5) ;;
2ce0: 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 75 give the clean u
2cf0: 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 6f p few seconds to
2d00: 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a 09 do it's stuff..
2d10: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
2d20: 65 70 21 20 31 29 29 0a 09 09 09 20 20 20 20 20 ep! 1))....
2d30: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2d40: 22 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a " Done.").
2d50: 09 09 09 20 20 20 20 20 20 29 0a 09 09 09 20 20 ... )....
2d60: 20 20 22 63 6c 65 61 6e 20 65 78 69 74 22 29 29 "clean exit"))
2d70: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
2d80: 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 start! th2).
2d90: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
2da0: 20 74 68 31 29 0a 20 20 20 20 20 20 28 74 68 72 th1). (thr
2db0: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 ead-join! th2)))
2dc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d )..(define (std-
2dd0: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 signal-handler s
2de0: 69 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 ignum). ;; (sig
2df0: 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d nal-mask! signum
2e00: 29 0a 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d ). (set! *time-
2e10: 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 28 to-exit* #t). (
2e20: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
2e30: 52 52 4f 52 3a 20 52 65 63 65 69 76 65 64 20 73 RROR: Received s
2e40: 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
2e50: 20 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 74 6c exiting promptl
2e60: 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d 65 78 y"). ;; (std-ex
2e70: 69 74 2d 70 72 6f 63 65 64 75 72 65 29 20 3b 3b it-procedure) ;;
2e80: 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 64 20 shouldn't need
2e90: 74 68 69 73 20 73 69 6e 63 65 20 77 65 20 61 72 this since we ar
2ea0: 65 20 65 78 69 74 69 6e 67 20 61 6e 64 20 69 74 e exiting and it
2eb0: 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 64 20 will be called
2ec0: 61 6e 79 77 61 79 0a 20 20 28 65 78 69 74 29 29 anyway. (exit))
2ed0: 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 ..(set-signal-ha
2ee0: 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e ndler! signal/in
2ef0: 74 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 t std-signal-ha
2f00: 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a 28 73 ndler) ;; ^C.(s
2f10: 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 et-signal-handle
2f20: 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 r! signal/term s
2f30: 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 td-signal-handle
2f40: 72 29 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 r).(set-signal-h
2f50: 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 73 andler! signal/s
2f60: 74 6f 70 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 top std-signal-h
2f70: 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 5a 0a 0a andler) ;; ^Z..
2f80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fc0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 69 73 63 ========.;; Misc
2fd0: 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d utils.;;=======
2fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3020: 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 73 74 72 69 .;; Convert stri
3030: 6e 67 73 20 6c 69 6b 65 20 22 35 73 20 32 68 20 ngs like "5s 2h
3040: 33 6d 22 20 3d 3e 20 36 30 78 36 30 78 32 20 2b 3m" => 60x60x2 +
3050: 20 33 78 36 30 20 2b 20 35 0a 28 64 65 66 69 6e 3x60 + 5.(defin
3060: 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 e (common:hms-st
3070: 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 74 73 ring->seconds ts
3080: 74 72 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 tr). (let ((par
3090: 74 73 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 ts (string-s
30a0: 70 6c 69 74 20 74 73 74 72 29 29 0a 09 28 74 69 plit tstr))..(ti
30b0: 6d 65 2d 73 65 63 73 20 30 29 0a 09 3b 3b 20 73 me-secs 0)..;; s
30c0: 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d 69 6e 75 =seconds, m=minu
30d0: 74 65 73 2c 20 68 3d 68 6f 75 72 73 2c 20 64 3d tes, h=hours, d=
30e0: 64 61 79 73 0a 09 28 74 72 78 20 20 20 20 20 20 days..(trx
30f0: 20 28 72 65 67 65 78 70 20 22 28 5c 5c 64 2b 29 (regexp "(\\d+)
3100: 28 5b 73 6d 68 64 5d 29 22 29 29 29 0a 20 20 20 ([smhd])"))).
3110: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
3120: 64 61 20 28 70 61 72 74 29 0a 09 09 28 6c 65 74 da (part)...(let
3130: 20 28 28 6d 61 74 63 68 20 20 28 73 74 72 69 6e ((match (strin
3140: 67 2d 6d 61 74 63 68 20 74 72 78 20 70 61 72 74 g-match trx part
3150: 29 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 )))... (if matc
3160: 68 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 h... (let (
3170: 28 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (val (string->nu
3180: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
3190: 29 29 29 0a 09 09 09 20 20 20 20 28 75 6e 74 20 ))).... (unt
31a0: 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a (caddr match))).
31b0: 09 09 09 28 69 66 20 76 61 6c 20 0a 09 09 09 20 ...(if val ....
31c0: 20 20 20 28 73 65 74 21 20 74 69 6d 65 2d 73 65 (set! time-se
31d0: 63 73 20 28 2b 20 74 69 6d 65 2d 73 65 63 73 20 cs (+ time-secs
31e0: 28 2a 20 76 61 6c 0a 09 09 09 09 09 09 09 20 20 (* val........
31f0: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
3200: 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 0a 09 09 09 >symbol unt)....
3210: 09 09 09 09 20 20 20 20 20 20 28 28 73 29 20 31 .... ((s) 1
3220: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 )........ (
3230: 28 6d 29 20 36 30 29 0a 09 09 09 09 09 09 09 20 (m) 60)........
3240: 20 20 20 20 20 28 28 68 29 20 28 2a 20 36 30 20 ((h) (* 60
3250: 36 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 60))........
3260: 20 20 28 28 64 29 20 28 2a 20 32 34 20 36 30 20 ((d) (* 24 60
3270: 36 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 60))........
3280: 20 20 28 65 6c 73 65 20 30 29 29 29 29 29 29 29 (else 0)))))))
3290: 29 29 29 0a 09 20 20 20 20 20 20 70 61 72 74 73 ))).. parts
32a0: 29 0a 20 20 20 20 74 69 6d 65 2d 73 65 63 73 29 ). time-secs)
32b0: 29 0a 09 09 20 20 20 20 20 20 20 0a 28 64 65 66 )... .(def
32c0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 ine (common:vers
32d0: 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 ion-signature).
32e0: 20 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d (conc megatest-
32f0: 76 65 72 73 69 6f 6e 20 22 2d 22 20 28 73 75 62 version "-" (sub
3300: 73 74 72 69 6e 67 20 6d 65 67 61 74 65 73 74 2d string megatest-
3310: 66 6f 73 73 69 6c 2d 68 61 73 68 20 30 20 34 29 fossil-hash 0 4)
3320: 29 29 0a 0a 3b 3b 20 6f 6e 65 2d 6f 66 20 61 72 ))..;; one-of ar
3330: 67 73 20 64 65 66 69 6e 65 64 0a 28 64 65 66 69 gs defined.(defi
3340: 6e 65 20 28 61 72 67 73 2d 64 65 66 69 6e 65 64 ne (args-defined
3350: 3f 20 2e 20 70 61 72 61 6d 29 0a 20 20 28 6c 65 ? . param). (le
3360: 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 t ((res #f)).
3370: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
3380: 20 28 6c 61 6d 62 64 61 20 28 61 72 67 29 0a 20 (lambda (arg).
3390: 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a (if (args:
33a0: 67 65 74 2d 61 72 67 20 61 72 67 29 28 73 65 74 get-arg arg)(set
33b0: 21 20 72 65 73 20 23 74 29 29 29 0a 20 20 20 20 ! res #t))).
33c0: 20 70 61 72 61 6d 29 0a 20 20 20 20 72 65 73 29 param). res)
33d0: 29 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 )..;; convert st
33e0: 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 20 uff to a number
33f0: 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 66 if possible.(def
3400: 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 ine (any->number
3410: 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a 20 val). (cond .
3420: 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 ((number? val)
3430: 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 6e val). ((strin
3440: 67 3f 20 76 61 6c 29 20 28 73 74 72 69 6e 67 2d g? val) (string-
3450: 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 20 >number val)).
3460: 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 ((symbol? val)
3470: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 79 (any->number (sy
3480: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c mbol->string val
3490: 29 29 29 0a 20 20 20 28 65 6c 73 65 20 23 66 29 ))). (else #f)
34a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 ))..(define (any
34b0: 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 73 ->number-if-poss
34c0: 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 74 ible val). (let
34d0: 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 6d ((num (any->num
34e0: 62 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 28 ber val))). (
34f0: 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 29 if num num val))
3500: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 74 74 )..(define (patt
3510: 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d -list-match item
3520: 20 70 61 74 74 73 29 0a 20 20 28 64 65 62 75 67 patts). (debug
3530: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 70 :print-info 8 "p
3540: 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 att-list-match i
3550: 74 65 6d 3d 22 20 69 74 65 6d 20 22 20 70 61 74 tem=" item " pat
3560: 74 73 3d 22 20 70 61 74 74 73 29 0a 20 20 28 69 ts=" patts). (i
3570: 66 20 28 61 6e 64 20 69 74 65 6d 20 70 61 74 74 f (and item patt
3580: 73 29 20 20 3b 3b 20 68 65 72 65 20 77 65 20 61 s) ;; here we a
3590: 72 65 20 66 69 6c 74 65 72 69 6e 67 20 66 6f 72 re filtering for
35a0: 20 6d 61 74 63 68 65 73 20 77 69 74 68 20 69 74 matches with it
35b0: 65 6d 20 70 61 74 74 65 72 6e 73 0a 20 20 20 20 em patterns.
35c0: 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 (let ((res #f)
35d0: 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 74 68 72 6f ) ;; look thro
35e0: 75 67 68 20 61 6c 6c 20 74 68 65 20 69 74 65 6d ugh all the item
35f0: 2d 70 61 74 74 73 20 69 66 20 64 65 66 69 6e 65 -patts if define
3600: 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 70 61 74 d, format is pat
3610: 74 31 2c 70 61 74 74 32 2c 70 61 74 74 33 20 2e t1,patt2,patt3 .
3620: 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 73 20 25 .. wildcard is %
3630: 0a 09 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 28 ..(for-each .. (
3640: 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a 09 20 lambda (patt)..
3650: 20 20 28 6c 65 74 20 28 28 6d 6f 64 70 61 74 74 (let ((modpatt
3660: 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 (string-substit
3670: 75 74 65 20 22 25 22 20 22 2e 2a 22 20 70 61 74 ute "%" ".*" pat
3680: 74 20 23 74 29 29 29 0a 09 20 20 20 20 20 28 64 t #t))).. (d
3690: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
36a0: 31 30 20 22 70 61 74 74 20 22 20 70 61 74 74 20 10 "patt " patt
36b0: 22 20 6d 6f 64 70 61 74 74 20 22 20 6d 6f 64 70 " modpatt " modp
36c0: 61 74 74 29 0a 09 20 20 20 20 20 28 69 66 20 28 att).. (if (
36d0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 string-match (re
36e0: 67 65 78 70 20 6d 6f 64 70 61 74 74 29 20 69 74 gexp modpatt) it
36f0: 65 6d 29 0a 09 09 20 28 73 65 74 21 20 72 65 73 em)... (set! res
3700: 20 23 74 29 29 29 29 0a 09 20 28 73 74 72 69 6e #t)))).. (strin
3710: 67 2d 73 70 6c 69 74 20 70 61 74 74 73 20 22 2c g-split patts ",
3720: 22 29 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 "))..res).
3730: 23 74 29 29 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 #t))..;; (map pr
3740: 69 6e 74 20 28 6d 61 70 20 63 61 72 20 28 68 61 int (map car (ha
3750: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
3760: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 72 75 (read-config "ru
3770: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
3780: 20 23 66 20 23 74 29 29 29 29 0a 28 64 65 66 69 #f #t)))).(defi
3790: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 ne (common:get-r
37a0: 75 6e 63 6f 6e 66 69 67 2d 74 61 72 67 65 74 73 unconfig-targets
37b0: 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 #!key (configf
37c0: 23 66 29 29 0a 20 20 28 73 6f 72 74 20 28 6d 61 #f)). (sort (ma
37d0: 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 6c p car (hash-tabl
37e0: 65 2d 3e 61 6c 69 73 74 0a 09 09 20 20 28 6f 72 e->alist... (or
37f0: 20 63 6f 6e 66 69 67 66 0a 09 09 20 20 20 20 20 configf...
3800: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 72 (read-config "r
3810: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
3820: 22 0a 09 09 09 20 20 20 20 20 20 20 23 66 20 23 ".... #f #
3830: 74 29 29 29 29 0a 09 73 74 72 69 6e 67 3c 3f 29 t))))..string<?)
3840: 29 0a 0a 3b 3b 20 27 28 70 72 69 6e 74 20 28 73 )..;; '(print (s
3850: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
3860: 65 20 28 6d 61 70 20 63 61 64 72 20 28 68 61 73 e (map cadr (has
3870: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3880: 75 6c 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 ult (read-config
3890: 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 "megatest.confi
38a0: 67 22 20 5c 23 66 20 5c 23 74 29 20 22 64 69 73 g" \#f \#t) "dis
38b0: 6b 73 22 20 27 22 27 22 27 28 22 6e 6f 6e 65 22 ks" '"'"'("none"
38c0: 20 22 22 29 29 29 20 22 5c 6e 22 29 29 27 0a 28 ""))) "\n"))'.(
38d0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
38e0: 65 74 2d 64 69 73 6b 73 20 23 21 6b 65 79 20 28 et-disks #!key (
38f0: 63 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 28 configf #f)). (
3900: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3910: 65 66 61 75 6c 74 20 0a 20 20 20 28 6f 72 20 63 efault . (or c
3920: 6f 6e 66 69 67 66 20 28 72 65 61 64 2d 63 6f 6e onfigf (read-con
3930: 66 69 67 20 22 6d 65 67 61 74 65 73 74 2e 63 6f fig "megatest.co
3940: 6e 66 69 67 22 20 23 66 20 23 74 29 29 0a 20 20 nfig" #f #t)).
3950: 20 22 64 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 "disks" '("none
3960: 22 20 22 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d " "")))..;;=====
3970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39b0: 3d 0a 3b 3b 20 54 20 41 20 52 20 47 20 45 20 54 =.;; T A R G E T
39c0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
39d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
3a10: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 fine (common:arg
3a20: 73 2d 67 65 74 2d 74 61 72 67 65 74 20 23 21 6b s-get-target #!k
3a30: 65 79 20 28 73 70 6c 69 74 20 23 66 29 29 0a 20 ey (split #f)).
3a40: 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 20 (let* ((target
3a50: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
3a60: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 rg "-reqtarg")..
3a70: 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 . (args:get
3a80: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
3a90: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 61 72 ... (if (ar
3aa0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
3ab0: 67 65 74 22 29 0a 09 09 09 20 20 28 61 72 67 73 get").... (args
3ac0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
3ad0: 74 22 29 0a 09 09 09 20 20 28 67 65 74 65 6e 76 t").... (getenv
3ae0: 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 29 "MT_TARGET"))))
3af0: 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 66 20 .. (tlist (if
3b00: 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d 73 target (string-s
3b10: 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 20 plit target "/"
3b20: 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 61 6c #t) '())).. (val
3b30: 69 64 20 20 20 28 69 66 20 74 61 72 67 65 74 0a id (if target.
3b40: 09 09 20 20 20 20 20 20 28 61 6e 64 20 28 6e 6f .. (and (no
3b50: 74 20 28 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 t (null? tlist))
3b60: 0a 09 09 09 20 20 20 28 6e 75 6c 6c 3f 20 28 66 .... (null? (f
3b70: 69 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e 75 6c ilter string-nul
3b80: 6c 3f 20 74 6c 69 73 74 29 29 29 0a 09 09 20 20 l? tlist)))...
3b90: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 #f))). (i
3ba0: 66 20 76 61 6c 69 64 0a 09 28 69 66 20 73 70 6c f valid..(if spl
3bb0: 69 74 0a 09 20 20 20 20 74 6c 69 73 74 0a 09 20 it.. tlist..
3bc0: 20 20 20 74 61 72 67 65 74 29 0a 09 28 69 66 20 target)..(if
3bd0: 74 61 72 67 65 74 0a 09 20 20 20 20 28 62 65 67 target.. (beg
3be0: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
3bf0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
3c00: 20 49 6e 76 61 6c 69 64 20 74 61 72 67 65 74 2c Invalid target,
3c10: 20 73 70 61 63 65 73 20 6f 72 20 62 6c 61 6e 6b spaces or blank
3c20: 73 20 6e 6f 74 20 61 6c 6c 6f 77 65 64 20 5c 22 s not allowed \"
3c30: 22 20 74 61 72 67 65 74 20 22 5c 22 22 29 0a 09 " target "\"")..
3c40: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 23 #f).. #
3c50: 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d f))))..;;=======
3c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3ca0: 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 4c 20 49 ;; M I S C L I
3cb0: 20 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d S T S.;;=======
3cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3d00: 0a 3b 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 .;; items in lis
3d10: 74 61 20 61 72 65 20 6d 61 74 63 68 65 64 20 76 ta are matched v
3d20: 61 6c 75 65 20 61 6e 64 20 70 6f 73 69 74 69 6f alue and positio
3d30: 6e 20 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 65 n in listb.;; re
3d40: 74 75 72 6e 20 74 68 65 20 72 65 6d 61 69 6e 69 turn the remaini
3d50: 6e 67 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 ng items in list
3d60: 62 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 b or #f.;;.(defi
3d70: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d ne (common:list-
3d80: 69 73 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 61 is-sublist lista
3d90: 20 6c 69 73 74 62 29 0a 20 20 28 69 66 20 28 6e listb). (if (n
3da0: 75 6c 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 20 ull? lista).
3db0: 20 20 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 69 listb ;; all i
3dc0: 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 72 tems in listb ar
3dd0: 65 20 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 20 e "remaining".
3de0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
3df0: 74 68 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 68 th lista)(length
3e00: 20 6c 69 73 74 62 29 29 20 0a 09 20 20 23 66 0a listb)) .. #f.
3e10: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 . (let loop ((h
3e20: 65 64 61 20 28 63 61 72 20 6c 69 73 74 61 29 29 eda (car lista))
3e30: 0a 09 09 20 20 20 20 20 28 74 61 6c 61 20 28 63 ... (tala (c
3e40: 64 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 dr lista))...
3e50: 20 20 28 68 65 64 62 20 28 63 61 72 20 6c 69 73 (hedb (car lis
3e60: 74 62 29 29 0a 09 09 20 20 20 20 20 28 74 61 6c tb))... (tal
3e70: 62 20 28 63 64 72 20 6c 69 73 74 62 29 29 29 0a b (cdr listb))).
3e80: 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
3e90: 20 68 65 64 61 20 68 65 64 62 29 0a 09 09 28 69 heda hedb)...(i
3ea0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 3b f (null? tala) ;
3eb0: 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 09 ; we are done...
3ec0: 20 20 20 20 74 61 6c 62 0a 09 09 20 20 20 20 28 talb... (
3ed0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 61 29 0a loop (car tala).
3ee0: 09 09 09 20 20 28 63 64 72 20 74 61 6c 61 29 0a ... (cdr tala).
3ef0: 09 09 09 20 20 28 63 61 72 20 74 61 6c 62 29 0a ... (car talb).
3f00: 09 09 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 ... (cdr talb))
3f10: 29 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 )...#f)))))..;;
3f20: 4e 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 Needed for long
3f30: 6c 69 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 lists to be sort
3f40: 65 64 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 ed where (apply
3f50: 6d 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b max ... ) dies.;
3f60: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
3f70: 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 n:max inlst). (
3f80: 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 let loop ((max-v
3f90: 61 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a al (car inlst)).
3fa0: 09 20 20 20 20 20 28 68 65 64 20 20 20 20 20 28 . (hed (
3fb0: 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 car inlst))..
3fc0: 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 (tal (cdr
3fd0: 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 inlst))). (if
3fe0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
3ff0: 29 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 ))..(loop (max h
4000: 65 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 ed max-val)..
4010: 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 (car tal)..
4020: 20 20 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 (cdr tal))..
4030: 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c (max hed max-val
4040: 29 29 29 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ))))...;;=======
4050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
4090: 3b 3b 20 4d 75 6e 67 65 20 64 61 74 61 20 69 6e ;; Munge data in
40a0: 74 6f 20 6e 69 63 65 20 66 6f 72 6d 73 0a 3b 3b to nice forms.;;
40b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40f0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 ======..;; Gener
4100: 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f 72 ate an index for
4110: 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 6f a sparse list o
4120: 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b 20 f key values.;;
4130: 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 6f ( (rowname1 co
4140: 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f 77 lname1 val1)(row
4150: 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 76 name2 colname2 v
4160: 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e 20 al2) ).;;.;; =>
4170: 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e .;;.;; ( (rown
4180: 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 32 ame1 0)(rowname2
4190: 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 61 1)) ;; rowna
41a0: 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 20 mes -> num.;;
41b0: 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 63 (colname1 0)(c
41c0: 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 3b olname2 1)) ) ;
41d0: 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e 75 ; colnames -> nu
41e0: 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e 61 m.;; .;; optiona
41f0: 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f 20 l apply proc to
4200: 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 61 rownum colnum va
4210: 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d lue.(define (com
4220: 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 2d mon:sparse-list-
4230: 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 64 generate-index d
4240: 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 20 ata #!key (proc
4250: 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c #f)). (if (null
4260: 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 6c ? data). (l
4270: 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 20 ist '() '()).
4280: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
4290: 65 64 20 28 63 61 72 20 64 61 74 61 29 29 0a 09 ed (car data))..
42a0: 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 61 . (tal (cdr data
42b0: 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 20 ))... (rownames
42c0: 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d 65 '())... (colname
42d0: 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e 75 s '())... (rownu
42e0: 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e 75 m 0)... (colnu
42f0: 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 28 m 0))..(let* (
4300: 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 20 (rowkey
4310: 20 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 20 (car hed))..
4320: 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 20 (colkey
4330: 20 20 20 20 20 20 20 28 63 61 64 72 20 20 68 65 (cadr he
4340: 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c d)).. (val
4350: 75 65 20 20 20 20 20 20 20 20 20 20 20 28 63 61 ue (ca
4360: 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 20 ddr hed))..
4370: 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 (existing-rowd
4380: 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 79 at (assoc rowkey
4390: 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 20 rownames))..
43a0: 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 6f (existing-co
43b0: 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c 6b ldat (assoc colk
43c0: 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 20 ey colnames))..
43d0: 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 6e (curr-rown
43e0: 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 74 um (if exist
43f0: 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e 75 ing-rowdat rownu
4400: 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 29 m (+ rownum 1)))
4410: 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 63 .. (curr-c
4420: 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 olnum (if ex
4430: 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f isting-coldat co
4440: 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 31 lnum (+ colnum 1
4450: 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 ))).. (new
4460: 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 66 -rownames (if
4470: 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 existing-rowdat
4480: 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 20 rownames (cons
4490: 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 72 (list rowkey cur
44a0: 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 6d r-rownum) rownam
44b0: 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e es))).. (n
44c0: 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 28 ew-colnames (
44d0: 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 if existing-cold
44e0: 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f 6e at colnames (con
44f0: 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 63 s (list colkey c
4500: 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c 6e urr-colnum) coln
4510: 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 28 ames)))).. ;; (
4520: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4530: 20 30 20 22 50 72 6f 63 65 73 73 69 6e 67 20 72 0 "Processing r
4540: 65 63 6f 72 64 3a 20 22 20 68 65 64 20 29 0a 09 ecord: " hed )..
4550: 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f 63 (if proc (proc
4560: 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 63 75 72 curr-rownum cur
4570: 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 6b 65 79 20 r-colnum rowkey
4580: 63 6f 6c 6b 65 79 20 76 61 6c 75 65 29 29 0a 09 colkey value))..
4590: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
45a0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 6e ).. (list n
45b0: 65 77 2d 72 6f 77 6e 61 6d 65 73 20 6e 65 77 2d ew-rownames new-
45c0: 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 20 20 20 20 colnames)..
45d0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
45e0: 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 6c 29 ... (cdr tal)
45f0: 0a 09 09 20 20 20 20 6e 65 77 2d 72 6f 77 6e 61 ... new-rowna
4600: 6d 65 73 0a 09 09 20 20 20 20 6e 65 77 2d 63 6f mes... new-co
4610: 6c 6e 61 6d 65 73 0a 09 09 20 20 20 20 28 69 66 lnames... (if
4620: 20 28 3e 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 (> curr-rownum
4630: 72 6f 77 6e 75 6d 29 20 63 75 72 72 2d 72 6f 77 rownum) curr-row
4640: 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a 09 09 20 20 num rownum)...
4650: 20 20 28 69 66 20 28 3e 20 63 75 72 72 2d 63 6f (if (> curr-co
4660: 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 20 63 75 72 lnum colnum) cur
4670: 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 r-colnum colnum)
4680: 0a 09 09 20 20 20 20 29 29 29 29 29 29 0a 0a 3b ... ))))))..;
4690: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
46a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
46b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
46c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
46d0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 79 73 74 65 =======.;; Syste
46e0: 6d 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d m stuff.;;======
46f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4730: 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 20 6e 69 ..;; return a ni
4740: 63 65 20 63 6c 65 61 6e 20 70 61 74 68 6e 61 6d ce clean pathnam
4750: 65 20 6d 61 64 65 20 61 62 73 6f 6c 75 74 65 0a e made absolute.
4760: 28 64 65 66 69 6e 65 20 28 6e 69 63 65 2d 70 61 (define (nice-pa
4770: 74 68 20 64 69 72 29 0a 20 20 28 6e 6f 72 6d 61 th dir). (norma
4780: 6c 69 7a 65 2d 70 61 74 68 6e 61 6d 65 20 28 69 lize-pathname (i
4790: 66 20 28 61 62 73 6f 6c 75 74 65 2d 70 61 74 68 f (absolute-path
47a0: 6e 61 6d 65 3f 20 64 69 72 29 0a 09 09 09 20 20 name? dir)....
47b0: 64 69 72 0a 09 09 09 20 20 28 63 6f 6e 63 20 28 dir.... (conc (
47c0: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
47d0: 79 29 20 22 2f 22 20 64 69 72 29 29 29 29 0a 0a y) "/" dir))))..
47e0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 63 70 75 (define (get-cpu
47f0: 2d 6c 6f 61 64 29 0a 20 20 28 63 61 72 20 28 63 -load). (car (c
4800: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f ommon:get-cpu-lo
4810: 61 64 29 29 29 0a 3b 3b 20 20 20 28 6c 65 74 2a ad))).;; (let*
4820: 20 28 28 6c 6f 61 64 2d 72 65 73 20 28 63 6d 64 ((load-res (cmd
4830: 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 -run->list "upti
4840: 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 me")).;; . (load
4850: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f -rx (regexp "lo
4860: 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 ad average:\\s+(
4870: 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 \\d+)")).;; . (c
4880: 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 pu-load #f)).;;
4890: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
48a0: 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 ambda (l).;; ..(
48b0: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
48c0: 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d ing-search load-
48d0: 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 rx l))).;; .. (
48e0: 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 if match.;; ..
48f0: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 (let ((newva
4900: 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 l (string->numbe
4910: 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 r (cadr match)))
4920: 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 6d ).;; ...(if (num
4930: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 ber? newval).;;
4940: 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 75 ... (set! cpu
4950: 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 29 -load newval))))
4960: 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 61 )).;; . (ca
4970: 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 r load-res)).;;
4980: 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a cpu-load))..
4990: 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 20 ;; get cpu load
49a0: 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 by reading from
49b0: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 /proc/loadavg, r
49c0: 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 eturn all three
49d0: 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e values.;;.(defin
49e0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 e (common:get-cp
49f0: 75 2d 6c 6f 61 64 29 0a 20 20 28 77 69 74 68 2d u-load). (with-
4a00: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
4a10: 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 "/proc/loadavg"
4a20: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 . (lambda ()(
4a30: 6c 69 73 74 20 28 72 65 61 64 29 28 72 65 61 64 list (read)(read
4a40: 29 28 72 65 61 64 29 29 29 29 29 0a 0a 28 64 65 )(read)))))..(de
4a50: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 fine (common:wai
4a60: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
4a70: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
4a80: 69 74 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 itdelay #!key (c
4a90: 6f 75 6e 74 20 31 30 30 30 29 29 0a 20 20 28 6c ount 1000)). (l
4aa0: 65 74 2a 20 28 28 6c 6f 61 64 61 76 67 20 28 63 et* ((loadavg (c
4ab0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f ommon:get-cpu-lo
4ac0: 61 64 29 29 0a 09 20 28 66 69 72 73 74 20 20 20 ad)).. (first
4ad0: 28 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 (car loadavg))..
4ae0: 20 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 20 (next (cadr
4af0: 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 6a loadavg)).. (adj
4b00: 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 load (* maxload
4b10: 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f 61 numcpus)).. (loa
4b20: 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e 65 djmp (- first ne
4b30: 78 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a xt))). (cond.
4b40: 20 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 69 ((and (> fi
4b50: 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 rst adjload)..
4b60: 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 (> count 0)).
4b70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4b80: 2d 69 6e 66 6f 20 30 20 22 77 61 69 74 69 6e 67 -info 0 "waiting
4b90: 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 " waitdelay " s
4ba0: 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f econds due to lo
4bb0: 61 64 20 22 20 66 69 72 73 74 20 22 20 65 78 63 ad " first " exc
4bc0: 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 20 22 20 eeding max of "
4bd0: 61 64 6a 6c 6f 61 64 29 0a 20 20 20 20 20 20 28 adjload). (
4be0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 thread-sleep! wa
4bf0: 69 74 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 itdelay). (
4c00: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
4c10: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
4c20: 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 numcpus waitdela
4c30: 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e y count: (- coun
4c40: 74 20 31 29 29 29 0a 20 20 20 20 20 28 28 61 6e t 1))). ((an
4c50: 64 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 6e 75 6d d (> loadjmp num
4c60: 63 70 75 73 29 0a 09 20 20 20 28 3e 20 63 6f 75 cpus).. (> cou
4c70: 6e 74 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 nt 0)). (de
4c80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
4c90: 20 22 77 61 69 74 69 6e 67 20 22 20 77 61 69 74 "waiting " wait
4ca0: 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 delay " seconds
4cb0: 64 75 65 20 74 6f 20 6c 6f 61 64 20 6a 75 6d 70 due to load jump
4cc0: 20 22 20 6c 6f 61 64 6a 6d 70 20 22 20 3e 20 6e " loadjmp " > n
4cd0: 75 6d 63 70 75 73 20 22 20 6e 75 6d 63 70 75 73 umcpus " numcpus
4ce0: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
4cf0: 73 6c 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 sleep! waitdelay
4d00: 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ). (common:
4d10: 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 wait-for-cpuload
4d20: 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 maxload numcpus
4d30: 20 77 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 waitdelay count
4d40: 3a 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 29 29 : (- count 1))))
4d50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
4d60: 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 73 mon:get-num-cpus
4d70: 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ). (with-input-
4d80: 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 from-file "/proc
4d90: 2f 63 70 75 69 6e 66 6f 22 0a 20 20 20 20 28 6c /cpuinfo". (l
4da0: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 28 ambda (). (
4db0: 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 let loop ((numcp
4dc0: 75 20 30 29 0a 09 09 20 28 69 6e 6c 20 20 20 20 u 0)... (inl
4dd0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 28 (read-line)))..(
4de0: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
4df0: 69 6e 6c 29 0a 09 20 20 20 20 6e 75 6d 63 70 75 inl).. numcpu
4e00: 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 .. (loop (if
4e10: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
4e20: 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c processor\\s+:\\
4e30: 73 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 s+\\d+$" inl)...
4e40: 20 20 20 20 20 20 28 2b 20 6e 75 6d 63 70 75 20 (+ numcpu
4e50: 31 29 0a 09 09 20 20 20 20 20 20 6e 75 6d 63 70 1)... numcp
4e60: 75 29 0a 09 09 20 20 28 72 65 61 64 2d 6c 69 6e u)... (read-lin
4e70: 65 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e e)))))))..(defin
4e80: 65 20 28 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 e (get-uname . p
4e90: 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 arams). (let* (
4ea0: 28 75 6e 61 6d 65 2d 72 65 73 20 28 63 6d 64 2d (uname-res (cmd-
4eb0: 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 run->list (conc
4ec0: 22 75 6e 61 6d 65 20 22 20 28 69 66 20 28 6e 75 "uname " (if (nu
4ed0: 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 2d 61 22 ll? params) "-a"
4ee0: 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 (car params))))
4ef0: 29 0a 09 20 28 75 6e 61 6d 65 20 23 66 29 29 0a ).. (uname #f)).
4f00: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 (if (null? (
4f10: 63 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a car uname-res)).
4f20: 09 22 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 ."unknown"..(caa
4f30: 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a r uname-res)))).
4f40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 =========.;; D I
4f90: 20 53 20 4b 20 20 20 53 20 50 20 41 20 43 20 45 S K S P A C E
4fa0: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
4fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4ff0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
5000: 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 65 64 20 disk-space-used
5010: 66 70 61 74 68 29 0a 20 20 28 77 69 74 68 2d 69 fpath). (with-i
5020: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 nput-from-pipe (
5030: 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 6e 2f 64 conc "/usr/bin/d
5040: 75 20 2d 73 20 22 20 66 70 61 74 68 29 20 72 65 u -s " fpath) re
5050: 61 64 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 ad))..(define (g
5060: 65 74 2d 64 66 20 70 61 74 68 29 0a 20 20 28 6c et-df path). (l
5070: 65 74 2a 20 28 28 64 66 2d 72 65 73 75 6c 74 73 et* ((df-results
5080: 20 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 (cmd-run->list
5090: 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 74 68 (conc "df " path
50a0: 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 78 20 ))).. (space-rx
50b0: 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 2d 39 (regexp "([0-9
50c0: 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 ]+)\\s+([0-9]+)%
50d0: 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 20 20 ")).. (freespc
50e0: 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 28 77 #f)). ;; (w
50f0: 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 73 29 rite df-results)
5100: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
5110: 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 6c 65 lambda (l)...(le
5120: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
5130: 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 2d 72 g-search space-r
5140: 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 20 6d x l)))... (if m
5150: 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 28 6c atch ... (l
5160: 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 74 72 et ((newval (str
5170: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
5180: 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 09 28 r match))))....(
5190: 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 if (number? newv
51a0: 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 al).... (set!
51b0: 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 6c 29 freespc newval)
51c0: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 63 61 ))))).. (ca
51d0: 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 0a 20 r df-results)).
51e0: 20 20 20 66 72 65 65 73 70 63 29 29 0a 20 20 0a freespc)). .
51f0: 3b 3b 20 70 61 74 68 73 20 69 73 20 6c 69 73 74 ;; paths is list
5200: 20 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 6d 65 of lists ((name
5210: 20 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b 3b 0a path) ... ).;;.
5220: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
5230: 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f get-disk-with-mo
5240: 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 64 69 st-free-space di
5250: 73 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 20 28 sks minsize). (
5260: 6c 65 74 20 28 28 62 65 73 74 20 20 20 20 20 23 let ((best #
5270: 66 29 0a 09 28 62 65 73 74 73 69 7a 65 20 30 29 f)..(bestsize 0)
5280: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
5290: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 . (lambda (d
52a0: 69 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 isk-num).
52b0: 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 68 20 (let* ((dirpath
52c0: 20 20 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 (cadr (assoc
52d0: 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 29 29 disk-num disks))
52e0: 29 0a 09 20 20 20 20 20 20 28 66 72 65 65 73 70 ).. (freesp
52f0: 63 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 20 20 c (cond....
5300: 20 28 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 ((not (director
5310: 79 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 09 y? dirpath))....
5320: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
5330: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
5340: 35 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 20 50 "disks not a
5350: 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a dir " disk-num).
5360: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
5370: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 0 "WARNING: dis
5380: 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 k " disk-num " a
5390: 74 20 70 61 74 68 20 22 20 64 69 72 70 61 74 68 t path " dirpath
53a0: 20 22 20 69 73 20 6e 6f 74 20 61 20 64 69 72 65 " is not a dire
53b0: 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 69 6e 67 ctory - ignoring
53c0: 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 2d it.")).... -
53d0: 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 28 1).... ((not (
53e0: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
53f0: 73 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 09 s? dirpath))....
5400: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
5410: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
5420: 35 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 77 72 50 "disks not wr
5430: 69 74 65 61 62 6c 65 20 22 20 64 69 73 6b 2d 6e iteable " disk-n
5440: 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 um).....(debug:p
5450: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
5460: 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d disk " disk-num
5470: 20 22 20 61 74 20 70 61 74 68 20 22 20 64 69 72 " at path " dir
5480: 70 61 74 68 20 22 20 69 73 20 6e 6f 74 20 77 72 path " is not wr
5490: 69 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f 72 69 iteable - ignori
54a0: 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 ng it."))....
54b0: 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 -1).... ((not
54c0: 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d 72 65 (eq? (string-re
54d0: 66 20 64 69 72 70 61 74 68 20 30 29 20 23 5c 2f f dirpath 0) #\/
54e0: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 63 )).... (if (c
54f0: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
5500: 70 72 69 6e 74 20 35 30 20 22 64 69 73 6b 73 20 print 50 "disks
5510: 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 70 61 74 not a proper pat
5520: 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 h " disk-num)...
5530: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
5540: 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 "WARNING: disk
5550: 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 " disk-num " at
5560: 70 61 74 68 20 22 20 64 69 72 70 61 74 68 20 22 path " dirpath "
5570: 20 69 73 20 6e 6f 74 20 61 20 66 75 6c 6c 79 20 is not a fully
5580: 71 75 61 6c 69 66 69 65 64 20 70 61 74 68 20 2d qualified path -
5590: 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 ignoring it."))
55a0: 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 .... -1)....
55b0: 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 28 (else.... (
55c0: 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 29 get-df dirpath))
55d0: 29 29 29 0a 09 20 28 69 66 20 28 3e 20 66 72 65 ))).. (if (> fre
55e0: 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 0a 09 espc bestsize)..
55f0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
5600: 20 20 20 20 28 73 65 74 21 20 62 65 73 74 20 20 (set! best
5610: 20 20 20 28 63 6f 6e 73 20 64 69 73 6b 2d 6e 75 (cons disk-nu
5620: 6d 20 64 69 72 70 61 74 68 29 29 0a 09 20 20 20 m dirpath))..
5630: 20 20 20 20 28 73 65 74 21 20 62 65 73 74 73 69 (set! bestsi
5640: 7a 65 20 66 72 65 65 73 70 63 29 29 29 29 29 0a ze freespc))))).
5650: 20 20 20 20 20 28 6d 61 70 20 63 61 72 20 64 69 (map car di
5660: 73 6b 73 29 29 0a 20 20 20 20 28 69 66 20 28 61 sks)). (if (a
5670: 6e 64 20 62 65 73 74 20 28 3e 20 62 65 73 74 73 nd best (> bests
5680: 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 0a 09 62 ize minsize))..b
5690: 65 73 74 0a 09 23 66 29 29 29 20 3b 3b 20 23 66 est..#f))) ;; #f
56a0: 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 6b 20 63 means no disk c
56b0: 61 6e 64 69 64 61 74 65 20 66 6f 75 6e 64 0a 0a andidate found..
56c0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
56d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5700: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e 20 ========.;; E N
5710: 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 20 4e 20 V I R O N M E N
5720: 54 20 20 20 56 20 41 20 52 20 53 0a 3b 3b 3d 3d T V A R S.;;==
5730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5770: 3d 3d 3d 3d 0a 09 20 20 20 20 20 20 0a 28 64 65 ====.. .(de
5780: 66 69 6e 65 20 28 73 61 76 65 2d 65 6e 76 69 72 fine (save-envir
5790: 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 onment-as-files
57a0: 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 69 67 6e fname #!key (ign
57b0: 6f 72 65 76 61 72 73 20 28 6c 69 73 74 20 22 55 orevars (list "U
57c0: 53 45 52 22 20 22 48 4f 4d 45 22 20 22 44 49 53 SER" "HOME" "DIS
57d0: 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 53 PLAY" "LS_COLORS
57e0: 22 20 22 58 4b 45 59 53 59 4d 44 42 22 20 22 45 " "XKEYSYMDB" "E
57f0: 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 4c 41 47 DITOR" "MAKEFLAG
5800: 53 22 20 22 4d 41 4b 45 46 22 29 29 29 0a 20 20 S" "MAKEF"))).
5810: 28 6c 65 74 20 28 28 65 6e 76 76 61 72 73 20 28 (let ((envvars (
5820: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
5830: 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 20 variables)).
5840: 20 20 20 20 28 77 68 69 74 65 73 70 20 28 72 65 (whitesp (re
5850: 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 2d gexp "[^a-zA-Z0-
5860: 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 29 9_\\-:,.\\/%$]")
5870: 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 )). (with-ou
5880: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f tput-to-file (co
5890: 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 68 22 29 nc fname ".csh")
58a0: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
58b0: 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f (). (fo
58c0: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
58d0: 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 keyval)...
58e0: 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 28 63 (let* ((key (c
58f0: 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 ar keyval))....
5900: 20 20 20 20 28 76 61 6c 20 20 20 28 63 64 72 20 (val (cdr
5910: 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 keyval))....
5920: 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 74 72 (delim (if (str
5930: 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 ing-search white
5940: 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 22 5c sp val) ......"\
5950: 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a 09 09 ""......"")))...
5960: 09 28 70 72 69 6e 74 20 28 69 66 20 28 6d 65 6d .(print (if (mem
5970: 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 ber key ignoreva
5980: 72 73 29 0a 09 09 09 09 20 20 20 22 23 20 73 65 rs)..... "# se
5990: 74 65 6e 76 20 22 0a 09 09 09 09 20 20 20 22 73 tenv "..... "s
59a0: 65 74 65 6e 76 20 22 29 0a 09 09 09 20 20 20 20 etenv ")....
59b0: 20 20 20 6b 65 79 20 22 20 22 20 64 65 6c 69 6d key " " delim
59c0: 20 76 61 6c 20 64 65 6c 69 6d 29 29 29 0a 09 09 val delim)))...
59d0: 20 20 20 20 65 6e 76 76 61 72 73 29 29 29 0a 20 envvars))).
59e0: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
59f0: 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 -to-file (conc f
5a00: 6e 61 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 20 name ".sh").
5a10: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
5a20: 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 (for-eac
5a30: 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 h (lambda (keyva
5a40: 6c 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a l)... (let*
5a50: 20 28 28 6b 65 79 20 28 63 61 72 20 6b 65 79 76 ((key (car keyv
5a60: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 61 al)).... (va
5a70: 6c 20 28 63 64 72 20 6b 65 79 76 61 6c 29 29 0a l (cdr keyval)).
5a80: 09 09 09 20 20 20 20 20 28 64 65 6c 69 6d 20 28 ... (delim (
5a90: 69 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 if (string-searc
5aa0: 68 20 77 68 69 74 65 73 70 20 76 61 6c 29 20 0a h whitesp val) .
5ab0: 09 09 09 09 09 22 5c 22 22 0a 09 09 09 09 09 22 ....."\""......"
5ac0: 22 29 29 29 0a 09 09 09 28 70 72 69 6e 74 20 28 ")))....(print (
5ad0: 69 66 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 if (member key i
5ae0: 67 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 gnorevars).....
5af0: 20 20 22 23 20 65 78 70 6f 72 74 20 22 0a 09 09 "# export "...
5b00: 09 09 20 20 20 22 65 78 70 6f 72 74 20 22 29 0a .. "export ").
5b10: 09 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 3d ... key "=
5b20: 22 20 64 65 6c 69 6d 20 76 61 6c 20 64 65 6c 69 " delim val deli
5b30: 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 m))).
5b40: 20 20 20 20 20 20 20 20 20 65 6e 76 76 61 72 73 envvars
5b50: 29 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 73 6f )))))..;; set so
5b60: 6d 65 20 65 6e 76 20 76 61 72 73 20 66 72 6f 6d me env vars from
5b70: 20 61 6e 20 61 6c 69 73 74 2c 20 72 65 74 75 72 an alist, retur
5b80: 6e 20 61 6e 20 61 6c 69 73 74 20 77 69 74 68 20 n an alist with
5b90: 6f 72 69 67 69 6e 61 6c 20 76 61 6c 75 65 73 0a original values.
5ba0: 3b 3b 20 28 28 22 56 41 52 22 20 22 76 61 6c 75 ;; (("VAR" "valu
5bb0: 65 22 29 20 2e 2e 2e 29 0a 28 64 65 66 69 6e 65 e") ...).(define
5bc0: 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 (alist->env-var
5bd0: 73 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6c 69 s lst). (if (li
5be0: 73 74 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 28 st? lst). (
5bf0: 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 29 0a let ((res '())).
5c00: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
5c10: 64 61 20 28 70 29 0a 09 09 20 20 20 20 28 6c 65 da (p)... (le
5c20: 74 2a 20 28 28 76 61 72 20 28 63 61 72 20 20 70 t* ((var (car p
5c30: 29 29 0a 09 09 09 20 20 20 28 76 61 6c 20 28 63 )).... (val (c
5c40: 61 64 72 20 70 29 29 0a 09 09 09 20 20 20 28 70 adr p)).... (p
5c50: 72 76 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d rv (get-environm
5c60: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 76 61 72 ent-variable var
5c70: 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 65 74 )))... (set
5c80: 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 ! res (cons (lis
5c90: 74 20 76 61 72 20 70 72 76 29 20 72 65 73 29 29 t var prv) res))
5ca0: 0a 09 09 20 20 20 20 20 20 28 69 66 20 76 61 6c ... (if val
5cb0: 20 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 76 .... (setenv v
5cc0: 61 72 20 28 2d 3e 73 74 72 69 6e 67 20 76 61 6c ar (->string val
5cd0: 29 29 0a 09 09 09 20 20 28 75 6e 73 65 74 65 6e )).... (unseten
5ce0: 76 20 76 61 72 29 29 29 29 0a 09 09 20 20 6c 73 v var))))... ls
5cf0: 74 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 27 t)..res). '
5d00: 28 29 29 29 0a 09 09 20 20 0a 3b 3b 3d 3d 3d 3d ()))... .;;====
5d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d50: 3d 3d 0a 3b 3b 20 74 69 6d 65 20 61 6e 64 20 64 ==.;; time and d
5d60: 61 74 65 20 6e 69 63 65 20 74 6f 20 68 61 76 65 ate nice to have
5d70: 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d stuff.;;=======
5d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5dc0: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
5dd0: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 s->hr-min-sec se
5de0: 63 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 cs). (let* ((hr
5df0: 73 20 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 s (quotient secs
5e00: 20 33 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 3600)).. (min (
5e10: 71 75 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 quotient (- secs
5e20: 20 28 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 (* hrs 3600)) 6
5e30: 30 29 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 0)).. (sec (- se
5e40: 63 73 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 cs (* hrs 3600)(
5e50: 2a 20 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 * min 60)))).
5e60: 20 28 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 (conc (if (> hr
5e70: 73 20 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 s 0)(conc hrs "h
5e80: 72 20 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 r ") "").. (if
5e90: 28 3e 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d (> min 0)(conc m
5ea0: 69 6e 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 in "m ") "")..
5eb0: 20 73 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 sec "s")))..(de
5ec0: 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 fine (seconds->t
5ed0: 69 6d 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a ime-string sec).
5ee0: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 (time->string
5ef0: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
5f00: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 cal-time sec) "%
5f10: 48 3a 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 H:%M:%S"))..(def
5f20: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f ine (seconds->wo
5f30: 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 rk-week/day-time
5f40: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
5f50: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
5f60: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
5f70: 63 29 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 c) "ww%V.%u %H:%
5f80: 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
5f90: 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 econds->work-wee
5fa0: 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 k/day sec). (ti
5fb0: 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 me->string. (s
5fc0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
5fd0: 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 me sec) "ww%V.%u
5fe0: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
5ff0: 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b conds->year-work
6000: 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 -week/day sec).
6010: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 (time->string.
6020: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
6030: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 l-time sec) "%yw
6040: 77 25 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 w%V.%w"))..(defi
6050: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
6060: 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d r-work-week/day-
6070: 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d time sec). (tim
6080: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
6090: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
60a0: 65 20 73 65 63 29 20 22 25 79 77 77 25 56 2e 25 e sec) "%yww%V.%
60b0: 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 w %H:%M"))..(def
60c0: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 71 75 ine (seconds->qu
60d0: 61 72 74 65 72 20 73 65 63 29 0a 20 20 28 63 61 arter sec). (ca
60e0: 73 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 se (string->numb
60f0: 65 72 0a 09 20 28 74 69 6d 65 2d 3e 73 74 72 69 er.. (time->stri
6100: 6e 67 20 0a 09 20 20 28 73 65 63 6f 6e 64 73 2d ng .. (seconds-
6110: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
6120: 0a 09 20 20 22 25 6d 22 29 29 0a 20 20 20 20 28 .. "%m")). (
6130: 28 31 20 32 20 33 29 20 31 29 0a 20 20 20 20 28 (1 2 3) 1). (
6140: 28 34 20 35 20 36 29 20 32 29 0a 20 20 20 20 28 (4 5 6) 2). (
6150: 28 37 20 38 20 39 29 20 33 29 0a 20 20 20 20 28 (7 8 9) 3). (
6160: 28 31 30 20 31 31 20 31 32 29 20 34 29 0a 20 20 (10 11 12) 4).
6170: 20 20 28 65 6c 73 65 20 23 66 29 29 29 0a 0a 3b (else #f)))..;
6180: 3b 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 3d 3d 3d 3d 3d 3d 3d ================
61b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
61c0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 6c 6f 72 =======.;; Color
61d0: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
61e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
61f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 ==========.
6220: 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f .(define (commo
6230: 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f n:name->iup-colo
6240: 72 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 r name). (case
6250: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
6260: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
6270: 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 name)). ((re
6280: 64 29 20 20 20 20 22 32 32 33 20 33 33 20 34 39 d) "223 33 49
6290: 22 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 "). ((grey)
62a0: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 0a "192 192 192").
62b0: 20 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 ((orange) "2
62c0: 35 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 55 172 13").
62d0: 28 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 ((purple) "This
62e0: 69 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e is unfinished ..
62f0: 2e 22 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e .")))..;; (defin
6300: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
6310: 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 lor-for-state-st
6320: 61 74 75 73 20 73 74 61 74 65 20 73 74 61 74 75 atus state statu
6330: 73 29 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 s).;; (case (s
6340: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
6350: 61 74 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f ate).;; ((CO
6360: 4d 50 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 MPLETED).;;
6370: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
6380: 73 79 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b symbol status).;
6390: 3b 20 20 20 20 20 20 20 20 28 28 50 41 53 53 29 ; ((PASS)
63a0: 20 20 20 20 20 20 20 20 22 37 30 20 20 32 34 39 "70 249
63b0: 20 37 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 73").;;
63c0: 28 28 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 ((WARN WAIVED) "
63d0: 32 35 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 255 172 13").;;
63e0: 20 20 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 ((SKIP)
63f0: 20 20 20 20 20 20 22 32 33 30 20 32 33 30 20 30 "230 230 0
6400: 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c ").;; (el
6410: 73 65 20 22 32 32 33 20 33 33 20 34 39 22 29 29 se "223 33 49"))
6420: 29 0a 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 ).;; ((LAUNC
6430: 48 45 44 29 20 20 20 20 20 20 20 20 20 22 31 30 HED) "10
6440: 31 20 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 1 123 142").;;
6450: 20 20 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 ((CHECK)
6460: 20 20 20 20 20 20 20 22 32 35 35 20 31 30 30 20 "255 100
6470: 35 30 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 50").;; ((RE
6480: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 MOTEHOSTSTART)
6490: 22 35 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b "50 130 195").;
64a0: 3b 20 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 ; ((RUNNING)
64b0: 20 20 20 20 20 20 20 20 20 20 22 39 20 20 20 31 "9 1
64c0: 33 31 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 31 232").;;
64d0: 28 28 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 ((KILLREQ)
64e0: 20 20 20 20 22 33 39 20 20 38 32 20 20 32 30 36 "39 82 206
64f0: 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c ").;; ((KILL
6500: 45 44 29 20 20 20 20 20 20 20 20 20 20 20 22 32 ED) "2
6510: 33 34 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 34 101 17").;;
6520: 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 ((NOT_STARTED
6530: 29 20 20 20 20 20 20 22 32 34 30 20 32 34 30 20 ) "240 240
6540: 32 34 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 240").;; (el
6550: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
6560: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 29 "192 192 192"))
6570: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
6580: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
6590: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
65a0: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 . (cond. ((eq
65b0: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 ual? status "PAS
65c0: 53 22 29 20 20 20 20 22 67 72 65 65 6e 22 29 0a S") "green").
65d0: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
65e0: 75 73 20 22 46 41 49 4c 22 29 20 20 20 20 22 72 us "FAIL") "r
65f0: 65 64 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ed"). ((equal?
6600: 20 73 74 61 74 75 73 20 22 57 41 52 4e 22 29 20 status "WARN")
6610: 20 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 "orange").
6620: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
6630: 22 4b 49 4c 4c 45 44 22 29 20 20 22 6f 72 61 6e "KILLED") "oran
6640: 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ge"). ((equal?
6650: 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 52 45 51 status "KILLREQ
6660: 22 29 20 22 70 75 72 70 6c 65 22 29 0a 20 20 20 ") "purple").
6670: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
6680: 22 52 55 4e 4e 49 4e 47 22 29 20 22 62 6c 75 65 "RUNNING") "blue
6690: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
66a0: 74 61 74 75 73 20 22 41 42 4f 52 54 22 29 20 20 tatus "ABORT")
66b0: 20 22 62 72 6f 77 6e 22 29 0a 20 20 20 28 65 6c "brown"). (el
66c0: 73 65 20 22 62 6c 61 63 6b 22 29 29 29 0a se "black"))).