Artifact
5c1deb5d33191a14f2df7e9c5252389347c6f148:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 unit commonmod))
03a0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
03b0: 64 65 62 75 67 70 72 69 6e 74 29 29 0a 0a 28 75 debugprint))..(u
03c0: 73 65 20 73 72 66 69 2d 36 39 29 0a 0a 28 6d 6f se srfi-69)..(mo
03d0: 64 75 6c 65 20 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 dule commonmod..
03e0: 2a 0a 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d *..(import schem
03f0: 65 29 0a 28 63 6f 6e 64 2d 65 78 70 61 6e 64 0a e).(cond-expand.
0400: 20 28 63 68 69 63 6b 65 6e 2d 34 0a 20 20 0a 20 (chicken-4. .
0410: 20 28 69 6d 70 6f 72 74 20 63 68 69 63 6b 65 6e (import chicken
0420: 0a 09 20 20 70 6f 72 74 73 0a 09 20 20 0a 09 20 .. ports.. ..
0430: 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 (prefix sqlite3
0440: 20 73 71 6c 69 74 65 33 3a 29 0a 09 20 20 64 61 sqlite3:).. da
0450: 74 61 2d 73 74 72 75 63 74 75 72 65 73 0a 09 20 ta-structures..
0460: 20 65 78 74 72 61 73 0a 09 20 20 66 69 6c 65 73 extras.. files
0470: 0a 09 20 20 6d 61 74 63 68 61 62 6c 65 0a 09 20 .. matchable..
0480: 20 6d 64 35 0a 09 20 20 6d 65 73 73 61 67 65 2d md5.. message-
0490: 64 69 67 65 73 74 0a 09 20 20 70 61 74 68 6e 61 digest.. pathna
04a0: 6d 65 2d 65 78 70 61 6e 64 0a 09 20 20 70 6f 73 me-expand.. pos
04b0: 69 78 0a 09 20 20 70 6f 73 69 78 2d 65 78 74 72 ix.. posix-extr
04c0: 61 73 0a 09 20 20 72 65 67 65 78 0a 09 20 20 72 as.. regex.. r
04d0: 65 67 65 78 2d 63 61 73 65 0a 09 20 20 73 72 66 egex-case.. srf
04e0: 69 2d 31 0a 09 20 20 73 72 66 69 2d 31 38 0a 09 i-1.. srfi-18..
04f0: 20 20 73 72 66 69 2d 36 39 0a 09 20 20 74 79 70 srfi-69.. typ
0500: 65 64 2d 72 65 63 6f 72 64 73 0a 0a 09 20 20 64 ed-records... d
0510: 65 62 75 67 70 72 69 6e 74 0a 09 20 20 29 0a 20 ebugprint.. ).
0520: 20 28 75 73 65 20 73 72 66 69 2d 36 39 29 29 0a (use srfi-69)).
0530: 20 28 63 68 69 63 6b 65 6e 2d 35 0a 20 20 28 69 (chicken-5. (i
0540: 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 mport (prefix sq
0550: 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 0a lite3 sqlite3:).
0560: 09 20 20 3b 3b 20 64 61 74 61 2d 73 74 72 75 63 . ;; data-struc
0570: 74 75 72 65 73 0a 09 20 20 3b 3b 20 65 78 74 72 tures.. ;; extr
0580: 61 73 0a 09 20 20 3b 3b 20 66 69 6c 65 73 0a 09 as.. ;; files..
0590: 20 20 3b 3b 20 70 6f 73 69 78 0a 09 20 20 3b 3b ;; posix.. ;;
05a0: 20 70 6f 73 69 78 2d 65 78 74 72 61 73 0a 09 20 posix-extras..
05b0: 20 63 68 69 63 6b 65 6e 2e 62 61 73 65 0a 09 20 chicken.base..
05c0: 20 63 68 69 63 6b 65 6e 2e 63 6f 6e 64 69 74 69 chicken.conditi
05d0: 6f 6e 0a 09 20 20 63 68 69 63 6b 65 6e 2e 66 69 on.. chicken.fi
05e0: 6c 65 0a 09 20 20 63 68 69 63 6b 65 6e 2e 66 69 le.. chicken.fi
05f0: 6c 65 2e 70 6f 73 69 78 0a 09 20 20 63 68 69 63 le.posix.. chic
0600: 6b 65 6e 2e 69 6f 0a 09 20 20 63 68 69 63 6b 65 ken.io.. chicke
0610: 6e 2e 70 61 74 68 6e 61 6d 65 0a 09 20 20 63 68 n.pathname.. ch
0620: 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 0a 09 20 icken.process..
0630: 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 chicken.process
0640: 2d 63 6f 6e 74 65 78 74 0a 09 20 20 63 68 69 63 -context.. chic
0650: 6b 65 6e 2e 70 72 6f 63 65 73 73 2d 63 6f 6e 74 ken.process-cont
0660: 65 78 74 2e 70 6f 73 69 78 0a 09 20 20 63 68 69 ext.posix.. chi
0670: 63 6b 65 6e 2e 73 6f 72 74 0a 09 20 20 63 68 69 cken.sort.. chi
0680: 63 6b 65 6e 2e 73 74 72 69 6e 67 0a 09 20 20 63 cken.string.. c
0690: 68 69 63 6b 65 6e 2e 74 69 6d 65 0a 09 20 20 63 hicken.time.. c
06a0: 68 69 63 6b 65 6e 2e 74 69 6d 65 2e 70 6f 73 69 hicken.time.posi
06b0: 78 0a 09 20 20 0a 09 20 20 6d 61 74 63 68 61 62 x.. .. matchab
06c0: 6c 65 0a 09 20 20 6d 64 35 0a 09 20 20 6d 65 73 le.. md5.. mes
06d0: 73 61 67 65 2d 64 69 67 65 73 74 0a 09 20 20 70 sage-digest.. p
06e0: 61 74 68 6e 61 6d 65 2d 65 78 70 61 6e 64 0a 09 athname-expand..
06f0: 20 20 72 65 67 65 78 0a 09 20 20 72 65 67 65 78 regex.. regex
0700: 2d 63 61 73 65 0a 09 20 20 73 72 66 69 2d 31 0a -case.. srfi-1.
0710: 09 20 20 73 72 66 69 2d 31 38 0a 09 20 20 73 72 . srfi-18.. sr
0720: 66 69 2d 36 39 0a 09 20 20 74 79 70 65 64 2d 72 fi-69.. typed-r
0730: 65 63 6f 72 64 73 0a 09 20 20 73 79 73 74 65 6d ecords.. system
0740: 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 0a 20 20 29 -information. )
0750: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
07a0: 43 4f 4e 54 45 4e 54 53 0a 3b 3b 0a 3b 3b 20 20 CONTENTS.;;.;;
07b0: 63 6f 6e 66 69 67 20 66 69 6c 65 20 75 74 69 6c config file util
07c0: 73 0a 3b 3b 20 20 6d 69 73 63 20 63 6f 6e 76 65 s.;; misc conve
07d0: 72 73 69 6f 6e 2c 20 64 61 74 61 20 6d 61 6e 69 rsion, data mani
07e0: 70 75 6c 61 74 69 6f 6e 20 66 75 6e 63 74 69 6f pulation functio
07f0: 6e 73 0a 3b 3b 20 20 74 65 73 74 73 75 69 74 65 ns.;; testsuite
0800: 20 61 6e 64 20 61 72 65 61 20 75 74 69 6c 69 74 and area utilit
0810: 65 73 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d es.;;.;;========
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0860: 28 69 6e 63 6c 75 64 65 20 22 6d 65 67 61 74 65 (include "megate
0870: 73 74 2d 76 65 72 73 69 6f 6e 2e 73 63 6d 22 29 st-version.scm")
0880: 0a 28 69 6e 63 6c 75 64 65 20 22 6d 65 67 61 74 .(include "megat
0890: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 2e est-fossil-hash.
08a0: 73 63 6d 22 29 0a 0a 3b 3b 20 68 74 74 70 20 2d scm")..;; http -
08b0: 20 75 73 65 20 74 68 65 20 6f 6c 64 20 68 74 74 use the old htt
08c0: 70 20 2b 20 69 6e 20 2f 74 6d 70 20 64 62 0a 3b p + in /tmp db.;
08d0: 3b 20 74 63 70 20 20 2d 20 75 73 65 20 74 63 70 ; tcp - use tcp
08e0: 20 74 72 61 6e 73 70 6f 72 74 20 77 69 74 68 20 transport with
08f0: 63 61 63 68 65 64 62 20 64 62 0a 3b 3b 20 6e 66 cachedb db.;; nf
0900: 73 20 20 2d 20 75 73 65 20 64 69 72 65 63 74 20 s - use direct
0910: 74 6f 20 64 69 73 6b 20 61 63 63 65 73 73 20 28 to disk access (
0920: 72 65 61 64 2d 6f 6e 6c 79 29 0a 3b 3b 0a 28 64 read-only).;;.(d
0930: 65 66 69 6e 65 20 72 6d 74 3a 74 72 61 6e 73 70 efine rmt:transp
0940: 6f 72 74 2d 6d 6f 64 65 20 28 6d 61 6b 65 2d 70 ort-mode (make-p
0950: 61 72 61 6d 65 74 65 72 20 27 74 63 70 29 29 0a arameter 'tcp)).
0960: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 66 75 .(define (get-fu
0970: 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 ll-version). (c
0980: 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 onc megatest-ver
0990: 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 sion "-" megates
09a0: 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a t-fossil-hash)).
09b0: 0a 28 64 65 66 69 6e 65 20 28 76 65 72 73 69 6f .(define (versio
09c0: 6e 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 n-signature). (
09d0: 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 conc megatest-ve
09e0: 72 73 69 6f 6e 20 22 2d 22 20 28 73 75 62 73 74 rsion "-" (subst
09f0: 72 69 6e 67 20 6d 65 67 61 74 65 73 74 2d 66 6f ring megatest-fo
0a00: 73 73 69 6c 2d 68 61 73 68 20 30 20 34 29 29 29 ssil-hash 0 4)))
0a10: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f ..(define *commo
0a20: 6e 3a 64 65 6e 6f 69 73 65 2a 20 20 20 20 28 6d n:denoise* (m
0a30: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0a40: 20 3b 3b 20 66 6f 72 20 6c 6f 77 20 6e 6f 69 73 ;; for low nois
0a50: 65 20 70 72 69 6e 74 69 6e 67 0a 0a 28 64 65 66 e printing..(def
0a60: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d ine (common:low-
0a70: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 77 61 69 74 noise-print wait
0a80: 76 61 6c 20 2e 20 6b 65 79 73 29 0a 20 20 28 6c val . keys). (l
0a90: 65 74 2a 20 28 28 6b 65 79 20 20 20 20 20 20 28 et* ((key (
0aa0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
0ab0: 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 6b 65 79 se (map conc key
0ac0: 73 29 20 22 2d 22 20 29 29 0a 09 20 28 6c 61 73 s) "-" )).. (las
0ad0: 74 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c ttime (hash-tabl
0ae0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 e-ref/default *c
0af0: 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 6b ommon:denoise* k
0b00: 65 79 20 30 29 29 0a 09 20 28 63 75 72 72 74 69 ey 0)).. (currti
0b10: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
0b20: 6e 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 nds))). (if (
0b30: 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 20 6c 61 > (- currtime la
0b40: 73 74 74 69 6d 65 29 20 77 61 69 74 76 61 6c 29 sttime) waitval)
0b50: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 68 61 73 ..(begin.. (has
0b60: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 63 6f h-table-set! *co
0b70: 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 mmon:denoise* ke
0b80: 79 20 63 75 72 72 74 69 6d 65 29 0a 09 20 20 23 y currtime).. #
0b90: 74 29 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 4b 45 t)..#f)))..;; KE
0ba0: 45 50 20 54 48 49 53 20 4f 4e 45 0a 3b 3b 0a 3b EP THIS ONE.;;.;
0bb0: 3b 20 63 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 ; client:get-sig
0bc0: 6e 61 74 75 72 65 0a 0a 28 64 65 66 69 6e 65 20 nature..(define
0bd0: 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 *my-client-signa
0be0: 74 75 72 65 2a 20 23 66 29 0a 0a 28 64 65 66 69 ture* #f)..(defi
0bf0: 6e 65 20 28 63 6c 69 65 6e 74 3a 67 65 74 2d 73 ne (client:get-s
0c00: 69 67 6e 61 74 75 72 65 29 0a 20 20 28 69 66 20 ignature). (if
0c10: 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 *my-client-signa
0c20: 74 75 72 65 2a 20 2a 6d 79 2d 63 6c 69 65 6e 74 ture* *my-client
0c30: 2d 73 69 67 6e 61 74 75 72 65 2a 0a 20 20 20 20 -signature*.
0c40: 20 20 28 6c 65 74 20 28 28 73 69 67 20 28 63 6f (let ((sig (co
0c50: 6e 63 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d nc (get-host-nam
0c60: 65 29 20 22 20 22 20 28 63 75 72 72 65 6e 74 2d e) " " (current-
0c70: 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 09 process-id))))..
0c80: 28 73 65 74 21 20 2a 6d 79 2d 63 6c 69 65 6e 74 (set! *my-client
0c90: 2d 73 69 67 6e 61 74 75 72 65 2a 20 73 69 67 29 -signature* sig)
0ca0: 0a 09 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 ..*my-client-sig
0cb0: 6e 61 74 75 72 65 2a 29 29 29 0a 0a 3b 3b 3d 3d nature*)))..;;==
0cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d00: 3d 3d 3d 3d 0a 3b 3b 20 63 6f 6e 66 69 67 20 66 ====.;; config f
0d10: 69 6c 65 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d ile utils.;;====
0d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d60: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6c 6f 6f ==..(define (loo
0d70: 6b 75 70 20 63 66 67 64 61 74 20 73 65 63 74 69 kup cfgdat secti
0d80: 6f 6e 20 76 61 72 29 0a 20 20 28 69 66 20 28 68 on var). (if (h
0d90: 61 73 68 2d 74 61 62 6c 65 3f 20 63 66 67 64 61 ash-table? cfgda
0da0: 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 t). (let ((
0db0: 73 65 63 74 64 61 74 20 28 68 61 73 68 2d 74 61 sectdat (hash-ta
0dc0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0dd0: 63 66 67 64 61 74 20 73 65 63 74 69 6f 6e 20 27 cfgdat section '
0de0: 28 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c ())))..(if (null
0df0: 3f 20 73 65 63 74 64 61 74 29 0a 09 20 20 20 20 ? sectdat)..
0e00: 23 66 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6d #f.. (let ((m
0e10: 61 74 63 68 20 28 61 73 73 6f 63 20 76 61 72 20 atch (assoc var
0e20: 73 65 63 74 64 61 74 29 29 29 0a 09 20 20 20 20 sectdat)))..
0e30: 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 28 (if match ;; (
0e40: 61 6e 64 20 6d 61 74 63 68 20 28 6c 69 73 74 3f and match (list?
0e50: 20 6d 61 74 63 68 29 28 3e 20 28 6c 65 6e 67 74 match)(> (lengt
0e60: 68 20 6d 61 74 63 68 29 20 31 29 29 0a 09 09 20 h match) 1))...
0e70: 20 28 63 61 64 72 20 6d 61 74 63 68 29 0a 09 09 (cadr match)...
0e80: 20 20 23 66 29 29 0a 09 20 20 20 20 29 29 0a 20 #f)).. )).
0e90: 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 72 65 #f))..;; re
0ea0: 74 75 72 6e 73 20 76 61 72 20 6b 65 79 31 3d 76 turns var key1=v
0eb0: 61 6c 31 3b 20 6b 65 79 32 3d 76 61 6c 32 20 2e al1; key2=val2 .
0ec0: 2e 2e 20 61 73 20 61 6c 69 73 74 0a 28 64 65 66 .. as alist.(def
0ed0: 69 6e 65 20 28 67 65 74 2d 6b 65 79 2d 6c 69 73 ine (get-key-lis
0ee0: 74 20 63 66 67 64 61 74 20 73 65 63 74 69 6f 6e t cfgdat section
0ef0: 20 76 61 72 29 0a 20 20 3b 3b 20 63 6f 6e 76 65 var). ;; conve
0f00: 72 74 20 73 74 72 69 6e 67 20 61 3d 31 3b 20 62 rt string a=1; b
0f10: 3d 32 3b 20 63 3d 61 20 73 69 6c 6c 79 20 74 68 =2; c=a silly th
0f20: 69 6e 67 3b 20 64 3d 0a 20 20 28 6c 65 74 20 28 ing; d=. (let (
0f30: 28 76 61 6c 73 74 72 20 28 6c 6f 6f 6b 75 70 20 (valstr (lookup
0f40: 63 66 67 64 61 74 20 73 65 63 74 69 6f 6e 20 76 cfgdat section v
0f50: 61 72 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 ar))). (if va
0f60: 6c 73 74 72 0a 09 28 76 61 6c 2d 3e 61 6c 69 73 lstr..(val->alis
0f70: 74 20 76 61 6c 73 74 72 29 0a 09 27 28 29 29 29 t valstr)..'()))
0f80: 29 20 3b 3b 20 73 68 6f 75 6c 64 20 69 74 20 72 ) ;; should it r
0f90: 65 74 75 72 6e 20 65 6d 70 74 79 20 6c 69 73 74 eturn empty list
0fa0: 20 6f 72 20 23 66 20 74 6f 20 69 6e 64 69 63 61 or #f to indica
0fb0: 74 65 20 6e 6f 74 20 73 65 74 3f 0a 0a 0a 28 64 te not set?...(d
0fc0: 65 66 69 6e 65 20 28 67 65 74 2d 73 65 63 74 69 efine (get-secti
0fd0: 6f 6e 20 63 66 67 64 61 74 20 73 65 63 74 69 6f on cfgdat sectio
0fe0: 6e 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 n). (hash-table
0ff0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 66 67 -ref/default cfg
1000: 64 61 74 20 73 65 63 74 69 6f 6e 20 27 28 29 29 dat section '())
1010: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
1020: 6f 6e 3a 6d 61 6b 65 2d 74 6d 70 64 69 72 2d 6e on:make-tmpdir-n
1030: 61 6d 65 20 61 72 65 61 70 61 74 68 20 74 6d 70 ame areapath tmp
1040: 61 64 6a 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 adj). (let* ((a
1050: 72 65 61 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 rea (pathname-fi
1060: 6c 65 20 61 72 65 61 70 61 74 68 29 29 0a 20 20 le areapath)).
1070: 20 20 20 20 20 20 20 28 64 6e 61 6d 65 20 28 63 (dname (c
1080: 6f 6e 63 20 22 2f 74 6d 70 2f 22 28 63 75 72 72 onc "/tmp/"(curr
1090: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 22 2f ent-user-name)"/
10a0: 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 62 megatest_localdb
10b0: 2f 22 20 61 72 65 61 20 22 2f 22 20 28 73 74 72 /" area "/" (str
10c0: 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 61 72 ing-translate ar
10d0: 65 61 70 61 74 68 20 22 2f 22 20 22 2e 22 29 20 eapath "/" ".")
10e0: 74 6d 70 61 64 6a 20 22 2f 2e 6d 74 64 62 22 29 tmpadj "/.mtdb")
10f0: 29 29 0a 20 20 20 20 28 75 6e 6c 65 73 73 20 28 )). (unless (
1100: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
1110: 3f 20 64 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 ? dname). (
1120: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
1130: 20 64 6e 61 6d 65 20 23 74 29 29 0a 20 20 20 20 dname #t)).
1140: 64 6e 61 6d 65 29 29 0a 0a 3b 3b 20 64 6f 74 2d dname))..;; dot-
1150: 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 65 6d locking egg seem
1160: 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 75 s not to work, u
1170: 73 69 6e 67 20 74 68 69 73 20 66 6f 72 20 6e 6f sing this for no
1180: 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 20 w.;; if lock is
1190: 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 70 69 72 older than expir
11a0: 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 6d 6f e-time then remo
11b0: 76 65 20 69 74 20 61 6e 64 20 74 72 79 20 61 67 ve it and try ag
11c0: 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 68 ain.;; to get th
11d0: 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e e lock.;;.(defin
11e0: 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 e (common:simple
11f0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 -file-lock fname
1200: 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 #!key (expire-t
1210: 69 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 ime 300)). (let
1220: 2a 20 28 28 6c 6f 63 6b 2d 65 78 69 73 74 73 20 * ((lock-exists
1230: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e (file-exists? fn
1240: 61 6d 65 29 29 0a 09 20 28 66 6d 6f 64 2d 74 69 ame)).. (fmod-ti
1250: 6d 65 20 28 69 66 20 6c 6f 63 6b 2d 65 78 69 73 me (if lock-exis
1260: 74 73 0a 09 09 09 28 63 75 72 72 65 6e 74 2d 73 ts....(current-s
1270: 65 63 6f 6e 64 73 29 0a 09 09 09 28 68 61 6e 64 econds)....(hand
1280: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
1290: 09 20 65 78 74 0a 09 09 09 20 28 63 75 72 72 65 . ext.... (curre
12a0: 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 20 nt-seconds)....
12b0: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
12c0: 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 29 on-time fname)))
12d0: 29 29 0a 20 20 20 20 28 69 66 20 6c 6f 63 6b 2d )). (if lock-
12e0: 65 78 69 73 74 73 0a 09 28 69 66 20 28 3e 20 28 exists..(if (> (
12f0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
1300: 64 73 29 20 66 6d 6f 64 2d 74 69 6d 65 29 20 65 ds) fmod-time) e
1310: 78 70 69 72 65 2d 74 69 6d 65 29 0a 09 20 20 20 xpire-time)..
1320: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
1330: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1340: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
1350: 70 6f 72 74 2a 20 22 52 65 6d 6f 76 69 6e 67 20 port* "Removing
1360: 73 74 61 6c 65 20 6c 6f 63 6b 20 22 66 6e 61 6d stale lock "fnam
1370: 65 29 0a 09 20 20 20 20 20 20 28 68 61 6e 64 6c e).. (handl
1380: 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 65 78 6e e-exceptions exn
1390: 20 23 66 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 #f (delete-file
13a0: 2a 20 66 6e 61 6d 65 29 29 09 0a 09 20 20 20 20 * fname))...
13b0: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
13c0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 -file-lock fname
13d0: 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 expire-time: ex
13e0: 70 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 20 pire-time))..
13f0: 20 23 66 29 0a 09 28 6c 65 74 20 28 28 6b 65 79 #f)..(let ((key
1400: 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 -string (conc (g
1410: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d et-host-name) "-
1420: 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 " (current-proce
1430: 73 73 2d 69 64 29 29 29 29 0a 09 20 20 28 77 69 ss-id)))).. (wi
1440: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
1450: 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 6c 61 e fname.. (la
1460: 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 mbda ().. (
1470: 70 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 print key-string
1480: 29 29 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 ))).. (thread-s
1490: 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 leep! 0.25).. (
14a0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
14b0: 20 66 6e 61 6d 65 29 20 3b 3b 20 28 63 6f 6d 6d fname) ;; (comm
14c0: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
14d0: 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 68 fname).. (h
14e0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
14f0: 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 exn.
1500: 20 20 20 20 20 23 66 20 0a 20 20 20 20 20 20 20 #f .
1510: 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 (with-i
1520: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 nput-from-file f
1530: 6e 61 6d 65 0a 09 20 20 09 20 20 28 6c 61 6d 62 name.. . (lamb
1540: 64 61 20 28 29 0a 09 09 20 20 20 20 28 65 71 75 da ()... (equ
1550: 61 6c 3f 20 6b 65 79 2d 73 74 72 69 6e 67 20 28 al? key-string (
1560: 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 read-line)))))..
1570: 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a 28 #f)))))..(
1580: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
1590: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d imple-file-lock-
15a0: 61 6e 64 2d 77 61 69 74 20 66 6e 61 6d 65 20 23 and-wait fname #
15b0: 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d !key (expire-tim
15c0: 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 28 e 300)). (let (
15d0: 28 65 6e 64 2d 74 69 6d 65 20 28 2b 20 65 78 70 (end-time (+ exp
15e0: 69 72 65 2d 74 69 6d 65 20 28 63 75 72 72 65 6e ire-time (curren
15f0: 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 t-seconds)))).
1600: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 67 6f (let loop ((go
1610: 74 2d 6c 6f 63 6b 20 28 63 6f 6d 6d 6f 6e 3a 73 t-lock (common:s
1620: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
1630: 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d fname expire-tim
1640: 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 e: expire-time))
1650: 29 0a 20 20 20 20 20 20 28 69 66 20 67 6f 74 2d ). (if got-
1660: 6c 6f 63 6b 0a 09 20 20 23 74 0a 09 20 20 28 69 lock.. #t.. (i
1670: 66 20 28 3e 20 65 6e 64 2d 74 69 6d 65 20 28 63 f (> end-time (c
1680: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
1690: 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
16a0: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
16b0: 33 29 0a 09 09 28 6c 6f 6f 70 20 28 63 6f 6d 6d 3)...(loop (comm
16c0: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
16d0: 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 ock fname expire
16e0: 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 -time: expire-ti
16f0: 6d 65 29 29 29 0a 09 20 20 20 20 20 20 23 66 29 me))).. #f)
1700: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
1710: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
1720: 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 e-release-lock f
1730: 6e 61 6d 65 29 0a 20 20 28 68 61 6e 64 6c 65 2d name). (handle-
1740: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
1750: 20 65 78 6e 0a 20 20 20 20 20 20 23 66 20 3b 3b exn. #f ;;
1760: 20 49 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 20 I don't really
1770: 63 61 72 65 20 77 68 79 20 74 68 69 73 20 66 61 care why this fa
1780: 69 6c 65 64 20 28 61 74 20 6c 65 61 73 74 20 66 iled (at least f
1790: 6f 72 20 6e 6f 77 29 0a 20 20 20 20 28 64 65 6c or now). (del
17a0: 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 ete-file* fname)
17b0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
17c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17d0: 3d 3d 3d 3d 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 0a 3b 3b 20 ============.;;
1800: 6d 69 73 63 20 63 6f 6e 76 65 72 73 69 6f 6e 2c misc conversion,
1810: 20 64 61 74 61 20 6d 61 6e 69 70 75 6c 61 74 69 data manipulati
1820: 6f 6e 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 3d on functions.;;=
1830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d =====..;;=======
1880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
18a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
18b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
18c0: 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 ;; return first
18d0: 63 6f 6d 6d 61 6e 64 20 74 68 61 74 20 65 78 69 command that exi
18e0: 73 74 73 2c 20 65 6c 73 65 20 23 66 0a 3b 3b 0a sts, else #f.;;.
18f0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
1900: 77 68 69 63 68 20 63 6d 64 73 29 0a 20 20 28 69 which cmds). (i
1910: 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 20 f (null? cmds).
1920: 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 6c #f. (l
1930: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
1940: 61 72 20 63 6d 64 73 29 29 0a 09 09 20 28 74 61 ar cmds))... (ta
1950: 6c 20 28 63 64 72 20 63 6d 64 73 29 29 29 0a 09 l (cdr cmds)))..
1960: 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 (let ((res (with
1970: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
1980: 20 28 63 6f 6e 63 20 22 77 68 69 63 68 20 22 20 (conc "which "
1990: 68 65 64 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 hed) read-line))
19a0: 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 ).. (if (and (s
19b0: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 tring? res)...
19c0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 (file-exists? r
19d0: 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a es)).. res.
19e0: 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
19f0: 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 ? tal)... #f...
1a00: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
1a10: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 )(cdr tal)))))))
1a20: 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f ). .(define (co
1a30: 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 mmon:get-megates
1a40: 74 2d 65 78 65 29 0a 20 20 28 6c 65 74 2a 20 28 t-exe). (let* (
1a50: 28 6d 74 65 78 65 20 28 6f 72 20 28 67 65 74 2d (mtexe (or (get-
1a60: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
1a70: 61 62 6c 65 20 22 4d 54 5f 4d 45 47 41 54 45 53 able "MT_MEGATES
1a80: 54 22 29 0a 09 09 20 20 20 20 28 63 6f 6d 6d 6f T")... (commo
1a90: 6e 3a 77 68 69 63 68 20 27 28 22 6d 65 67 61 74 n:which '("megat
1aa0: 65 73 74 22 29 29 0a 09 09 20 20 20 20 22 6d 65 est"))... "me
1ab0: 67 61 74 65 73 74 22 29 29 29 0a 20 20 20 20 28 gatest"))). (
1ac0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
1ad0: 20 6d 74 65 78 65 29 0a 09 28 72 65 61 6c 70 61 mtexe)..(realpa
1ae0: 74 68 20 6d 74 65 78 65 29 0a 09 6d 74 65 78 65 th mtexe)..mtexe
1af0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
1b00: 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 mmon:get-megates
1b10: 74 2d 65 78 65 2d 64 69 72 29 0a 20 20 28 6c 65 t-exe-dir). (le
1b20: 74 2a 20 28 28 6d 74 65 78 65 20 28 63 6f 6d 6d t* ((mtexe (comm
1b30: 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d on:get-megatest-
1b40: 65 78 65 29 29 29 0a 20 20 20 20 28 70 61 74 68 exe))). (path
1b50: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 6d name-directory m
1b60: 74 65 78 65 29 29 29 0a 0a 3b 3b 20 6d 6f 72 65 texe)))..;; more
1b70: 20 67 65 6e 65 72 69 63 20 61 6e 64 20 63 6f 6d generic and com
1b80: 70 72 65 68 65 6e 73 69 76 65 20 76 65 72 73 69 prehensive versi
1b90: 6f 6e 20 6f 66 20 67 65 74 2d 6d 65 67 61 74 65 on of get-megate
1ba0: 73 74 2d 65 78 65 0a 3b 3b 0a 28 64 65 66 69 6e st-exe.;;.(defin
1bb0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 74 e (common:get-mt
1bc0: 65 78 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 6d exe). (let* ((m
1bd0: 74 70 61 74 68 64 69 72 20 20 28 63 6f 6d 6d 6f tpathdir (commo
1be0: 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 n:get-megatest-e
1bf0: 78 65 2d 64 69 72 29 29 29 0a 20 20 20 20 28 6f xe-dir))). (o
1c00: 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 r (common:get-me
1c10: 67 61 74 65 73 74 2d 65 78 65 29 0a 09 28 69 66 gatest-exe)..(if
1c20: 20 6d 74 70 61 74 68 64 69 72 0a 09 20 20 20 20 mtpathdir..
1c30: 28 63 6f 6e 63 20 6d 74 70 61 74 68 64 69 72 22 (conc mtpathdir"
1c40: 2f 6d 65 67 61 74 65 73 74 22 29 0a 09 20 20 20 /megatest")..
1c50: 20 23 66 29 0a 09 22 6d 65 67 61 74 65 73 74 22 #f).."megatest"
1c60: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
1c70: 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 mmon:get-megates
1c80: 74 2d 65 78 65 2d 70 61 74 68 29 0a 20 20 28 6c t-exe-path). (l
1c90: 65 74 2a 20 28 28 6d 74 70 61 74 68 64 69 72 20 et* ((mtpathdir
1ca0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 (common:get-mega
1cb0: 74 65 73 74 2d 65 78 65 2d 64 69 72 29 29 29 0a test-exe-dir))).
1cc0: 20 20 20 20 28 63 6f 6e 63 20 6d 74 70 61 74 68 (conc mtpath
1cd0: 64 69 72 22 3a 22 28 67 65 74 2d 65 6e 76 69 72 dir":"(get-envir
1ce0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
1cf0: 22 50 41 54 48 22 29 20 22 3a 2e 22 29 29 29 0a "PATH") ":."))).
1d00: 0a 28 63 6f 6e 64 2d 65 78 70 61 6e 64 0a 20 28 .(cond-expand. (
1d10: 63 68 69 63 6b 65 6e 2d 34 0a 20 20 28 64 65 66 chicken-4. (def
1d20: 69 6e 65 20 28 72 65 61 6c 70 61 74 68 20 78 29 ine (realpath x)
1d30: 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 (resolve-pathna
1d40: 6d 65 20 20 28 70 61 74 68 6e 61 6d 65 2d 65 78 me (pathname-ex
1d50: 70 61 6e 64 20 28 6f 72 20 78 20 22 2f 64 65 76 pand (or x "/dev
1d60: 2f 6e 75 6c 6c 22 29 29 20 29 29 29 0a 20 28 63 /null")) ))). (c
1d70: 68 69 63 6b 65 6e 2d 35 0a 20 20 28 64 65 66 69 hicken-5. (defi
1d80: 6e 65 20 28 72 65 61 6c 70 61 74 68 20 78 29 20 ne (realpath x)
1d90: 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 6e (normalize-pathn
1da0: 61 6d 65 20 28 70 61 74 68 6e 61 6d 65 2d 65 78 ame (pathname-ex
1db0: 70 61 6e 64 20 28 6f 72 20 78 20 22 2f 64 65 76 pand (or x "/dev
1dc0: 2f 6e 75 6c 6c 22 29 29 29 29 29 29 0a 0a 3b 3b /null"))))))..;;
1dd0: 20 69 66 20 69 74 20 6c 6f 6f 6b 73 20 6c 69 6b if it looks lik
1de0: 65 20 61 20 6e 75 6d 62 65 72 20 2d 3e 20 63 6f e a number -> co
1df0: 6e 76 65 72 74 20 69 74 20 74 6f 20 61 20 6e 75 nvert it to a nu
1e00: 6d 62 65 72 2c 20 65 6c 73 65 20 72 65 74 75 72 mber, else retur
1e10: 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 n it.;;.(define
1e20: 28 6c 61 7a 79 2d 63 6f 6e 76 65 72 74 20 69 6e (lazy-convert in
1e30: 76 61 6c 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 val). (let* ((a
1e40: 73 2d 6e 75 6d 20 28 69 66 20 28 73 74 72 69 6e s-num (if (strin
1e50: 67 3f 20 69 6e 76 61 6c 29 28 73 74 72 69 6e 67 g? inval)(string
1e60: 2d 3e 6e 75 6d 62 65 72 20 69 6e 76 61 6c 29 20 ->number inval)
1e70: 23 66 29 29 29 0a 20 20 20 20 28 6f 72 20 61 73 #f))). (or as
1e80: 2d 6e 75 6d 20 69 6e 76 61 6c 29 29 29 0a 0a 3b -num inval)))..;
1e90: 3b 20 74 6f 20 27 28 28 61 20 2e 20 31 29 28 62 ; to '((a . 1)(b
1ea0: 20 2e 20 32 29 28 63 20 2e 20 22 61 20 73 69 6c . 2)(c . "a sil
1eb0: 6c 79 20 74 68 69 6e 67 22 29 28 64 20 2e 20 22 ly thing")(d . "
1ec0: 22 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ")).;;.(define (
1ed0: 76 61 6c 2d 3e 61 6c 69 73 74 20 76 61 6c 20 23 val->alist val #
1ee0: 21 6b 65 79 20 28 63 6f 6e 76 65 72 74 20 23 66 !key (convert #f
1ef0: 29 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 2d )). (let ((val-
1f00: 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c list (string-spl
1f10: 69 74 2d 66 69 65 6c 64 73 20 22 3b 5c 5c 73 2a it-fields ";\\s*
1f20: 22 20 76 61 6c 20 23 3a 69 6e 66 69 78 29 29 29 " val #:infix)))
1f30: 0a 20 20 20 20 28 69 66 20 76 61 6c 2d 6c 69 73 . (if val-lis
1f40: 74 0a 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 t..(map (lambda
1f50: 28 78 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 (x).. (let
1f60: 20 28 28 66 20 28 73 74 72 69 6e 67 2d 73 70 6c ((f (string-spl
1f70: 69 74 2d 66 69 65 6c 64 73 20 22 5c 5c 73 2a 3d it-fields "\\s*=
1f80: 5c 5c 73 2a 22 20 78 20 23 3a 69 6e 66 69 78 29 \\s*" x #:infix)
1f90: 29 29 0a 09 09 20 28 63 61 73 65 20 28 6c 65 6e ))... (case (len
1fa0: 67 74 68 20 66 29 0a 09 09 20 20 20 28 28 30 29 gth f)... ((0)
1fb0: 20 60 28 2c 23 66 29 29 20 20 3b 3b 20 6e 75 6c `(,#f)) ;; nul
1fc0: 6c 20 73 74 72 69 6e 67 20 63 61 73 65 0a 09 09 l string case...
1fd0: 20 20 20 28 28 31 29 20 60 28 2c 28 73 74 72 69 ((1) `(,(stri
1fe0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 61 72 20 ng->symbol (car
1ff0: 66 29 29 29 29 0a 09 09 20 20 20 28 28 32 29 20 f))))... ((2)
2000: 60 28 2c 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 `(,(string->symb
2010: 6f 6c 20 28 63 61 72 20 66 29 29 20 2e 0a 09 09 ol (car f)) ....
2020: 09 20 20 2c 28 6c 65 74 20 28 28 69 6e 76 61 6c . ,(let ((inval
2030: 20 28 63 61 64 72 20 66 29 29 29 0a 09 09 09 20 (cadr f)))....
2040: 20 20 20 20 28 69 66 20 63 6f 6e 76 65 72 74 20 (if convert
2050: 28 6c 61 7a 79 2d 63 6f 6e 76 65 72 74 20 69 6e (lazy-convert in
2060: 76 61 6c 29 20 69 6e 76 61 6c 29 29 29 29 0a 09 val) inval))))..
2070: 09 20 20 20 28 65 6c 73 65 20 66 29 29 29 29 0a . (else f)))).
2080: 09 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c . (filter (l
2090: 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 ambda (x)...
20a0: 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d (not (string-
20b0: 6d 61 74 63 68 20 22 5e 5c 5c 73 2a 22 20 78 29 match "^\\s*" x)
20c0: 29 29 0a 09 09 20 20 20 20 20 76 61 6c 2d 6c 69 ))... val-li
20d0: 73 74 29 29 0a 09 27 28 29 29 29 29 0a 0a 28 64 st))..'())))..(d
20e0: 65 66 69 6e 65 20 28 67 65 74 2d 63 70 75 2d 6c efine (get-cpu-l
20f0: 6f 61 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c oad). (let* ((l
2100: 6f 61 64 2d 69 6e 66 6f 20 28 77 69 74 68 2d 69 oad-info (with-i
2110: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 nput-from-file "
2120: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 72 /proc/loadavg" r
2130: 65 61 64 2d 6c 69 6e 65 73 29 29 29 0a 20 20 20 ead-lines))).
2140: 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 (map string->nu
2150: 6d 62 65 72 20 28 73 74 72 69 6e 67 2d 73 70 6c mber (string-spl
2160: 69 74 20 6c 6f 61 64 2d 69 6e 66 6f 29 29 29 29 it load-info))))
2170: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 75 72 72 65 ..(define *curre
2180: 6e 74 2d 68 6f 73 74 2d 63 6f 72 65 73 2a 20 23 nt-host-cores* #
2190: 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 f)..(define (get
21a0: 2d 63 75 72 72 65 6e 74 2d 68 6f 73 74 2d 63 6f -current-host-co
21b0: 72 65 73 29 0a 20 20 28 6f 72 20 2a 63 75 72 72 res). (or *curr
21c0: 65 6e 74 2d 68 6f 73 74 2d 63 6f 72 65 73 2a 0a ent-host-cores*.
21d0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 70 75 (let ((cpu
21e0: 2d 69 6e 66 6f 20 28 77 69 74 68 2d 69 6e 70 75 -info (with-inpu
21f0: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 t-from-file "/pr
2200: 6f 63 2f 63 70 75 69 6e 66 6f 22 20 72 65 61 64 oc/cpuinfo" read
2210: 2d 6c 69 6e 65 73 29 29 29 0a 09 28 6c 65 74 20 -lines)))..(let
2220: 6c 6f 6f 70 20 28 28 6c 69 6e 65 73 20 63 70 75 loop ((lines cpu
2230: 2d 69 6e 66 6f 29 29 0a 09 20 20 28 69 66 20 28 -info)).. (if (
2240: 6e 75 6c 6c 3f 20 6c 69 6e 65 73 29 0a 09 20 20 null? lines)..
2250: 20 20 20 20 31 20 3b 3b 20 67 6f 74 74 61 20 62 1 ;; gotta b
2260: 65 20 61 74 20 6c 65 61 73 74 20 6f 6e 65 21 0a e at least one!.
2270: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 . (let* ((i
2280: 6e 6c 20 28 63 61 72 20 6c 69 6e 65 73 29 29 0a nl (car lines)).
2290: 09 09 20 20 20 20 20 28 74 61 69 6c 20 28 63 64 .. (tail (cd
22a0: 72 20 6c 69 6e 65 73 29 29 0a 09 09 20 20 20 20 r lines))...
22b0: 20 28 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d (parts (string-
22c0: 73 70 6c 69 74 20 69 6e 6c 29 29 29 0a 09 09 28 split inl)))...(
22d0: 6d 61 74 63 68 20 70 61 72 74 73 0a 09 09 20 20 match parts...
22e0: 28 28 22 63 70 75 22 20 22 63 6f 72 65 73 22 20 (("cpu" "cores"
22f0: 22 3a 22 20 6e 75 6d 29 20 28 73 74 72 69 6e 67 ":" num) (string
2300: 2d 3e 6e 75 6d 62 65 72 20 6e 75 6d 29 29 0a 09 ->number num))..
2310: 09 20 20 28 65 6c 73 65 20 28 6c 6f 6f 70 20 74 . (else (loop t
2320: 61 69 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 ail)))))))))..(d
2330: 65 66 69 6e 65 20 28 6e 75 6d 62 65 72 2d 6f 66 efine (number-of
2340: 2d 70 72 6f 63 65 73 73 65 73 2d 72 75 6e 6e 69 -processes-runni
2350: 6e 67 20 70 72 6f 63 65 73 73 6e 61 6d 65 29 0a ng processname).
2360: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
2370: 6f 6d 2d 70 69 70 65 0a 20 20 20 28 63 6f 6e 63 om-pipe. (conc
2380: 20 22 70 73 20 2d 64 65 66 20 7c 20 65 67 72 65 "ps -def | egre
2390: 70 20 5c 22 22 70 72 6f 63 65 73 73 6e 61 6d 65 p \""processname
23a0: 22 5c 22 20 7c 77 63 20 2d 6c 22 29 0a 20 20 20 "\" |wc -l").
23b0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
23c0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
23d0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
23e0: 0a 3b 3b 20 67 65 74 20 74 68 65 20 6e 6f 72 6d .;; get the norm
23f0: 61 6c 69 7a 65 64 20 28 69 2e 65 2e 20 6c 6f 61 alized (i.e. loa
2400: 64 20 2f 20 6e 75 6d 63 70 75 73 29 20 66 6f 72 d / numcpus) for
2410: 20 2a 74 68 69 73 2a 20 68 6f 73 74 0a 3b 3b 0a *this* host.;;.
2420: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6e 6f 72 (define (get-nor
2430: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
2440: 29 0a 20 20 28 2f 20 28 67 65 74 2d 63 70 75 2d ). (/ (get-cpu-
2450: 6c 6f 61 64 29 28 67 65 74 2d 63 75 72 72 65 6e load)(get-curren
2460: 74 2d 68 6f 73 74 2d 63 6f 72 65 73 29 29 29 0a t-host-cores))).
2470: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 73 =========.;; tes
24c0: 74 73 75 69 74 65 20 61 6e 64 20 61 72 65 61 20 tsuite and area
24d0: 75 74 69 6c 69 74 65 73 0a 3b 3b 3d 3d 3d 3d 3d utilites.;;=====
24e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2520: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d =..(define (get-
2530: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 74 testsuite-name t
2540: 6f 70 70 61 74 68 20 63 6f 6e 66 69 67 64 61 74 oppath configdat
2550: 29 0a 20 20 28 6f 72 20 28 6c 6f 6f 6b 75 70 20 ). (or (lookup
2560: 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 75 70 configdat "setup
2570: 22 20 22 61 72 65 61 2d 6e 61 6d 65 22 29 0a 20 " "area-name").
2580: 20 20 20 20 20 28 6c 6f 6f 6b 75 70 20 63 6f 6e (lookup con
2590: 66 69 67 64 61 74 20 22 73 65 74 75 70 22 20 22 figdat "setup" "
25a0: 74 65 73 74 73 75 69 74 65 22 29 0a 20 20 20 20 testsuite").
25b0: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
25c0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
25d0: 54 45 53 54 53 55 49 54 45 5f 4e 41 4d 45 22 29 TESTSUITE_NAME")
25e0: 0a 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 . (if (stri
25f0: 6e 67 3f 20 74 6f 70 70 61 74 68 29 0a 20 20 20 ng? toppath).
2600: 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 6d 65 (pathname
2610: 2d 66 69 6c 65 20 74 6f 70 70 61 74 68 29 0a 20 -file toppath).
2620: 20 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a #f)))..
2630: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 61 72 65 (define (get-are
2640: 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 75 72 65 a-path-signature
2650: 20 74 6f 70 70 61 74 68 20 23 21 6f 70 74 69 6f toppath #!optio
2660: 6e 61 6c 20 28 73 68 6f 72 74 20 23 66 29 29 0a nal (short #f)).
2670: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6d 65 (let ((res (me
2680: 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 72 ssage-digest-str
2690: 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 69 ing (md5-primiti
26a0: 76 65 29 20 74 6f 70 70 61 74 68 29 29 29 0a 20 ve) toppath))).
26b0: 20 20 20 28 69 66 20 73 68 6f 72 74 0a 09 28 73 (if short..(s
26c0: 75 62 73 74 72 69 6e 67 20 72 65 73 20 30 20 34 ubstring res 0 4
26d0: 29 0a 09 72 65 73 29 29 29 0a 0a 28 64 65 66 69 )..res)))..(defi
26e0: 6e 65 20 28 67 65 74 2d 61 72 65 61 2d 6e 61 6d ne (get-area-nam
26f0: 65 20 63 6f 6e 66 69 67 64 61 74 20 74 6f 70 70 e configdat topp
2700: 61 74 68 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 ath #!optional (
2710: 73 68 6f 72 74 20 23 66 29 29 0a 20 20 3b 3b 20 short #f)). ;;
2720: 6c 6f 6f 6b 20 75 70 20 6d 79 20 61 72 65 61 20 look up my area
2730: 6e 61 6d 65 20 69 6e 20 61 72 65 61 73 20 74 61 name in areas ta
2740: 62 6c 65 20 28 66 75 74 75 72 65 29 0a 20 20 3b ble (future). ;
2750: 3b 20 67 65 6e 65 72 61 74 65 20 61 75 74 6f 20 ; generate auto
2760: 6e 61 6d 65 0a 20 20 28 63 6f 6e 63 20 28 67 65 name. (conc (ge
2770: 74 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e t-area-path-sign
2780: 61 74 75 72 65 20 74 6f 70 70 61 74 68 20 73 68 ature toppath sh
2790: 6f 72 74 29 0a 09 22 2d 22 0a 09 28 67 65 74 2d ort).."-"..(get-
27a0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 74 testsuite-name t
27b0: 6f 70 70 61 74 68 20 63 6f 6e 66 69 67 64 61 74 oppath configdat
27c0: 29 29 29 0a 0a 3b 3b 20 6e 65 65 64 20 67 65 6e )))..;; need gen
27d0: 65 72 69 63 20 66 69 6e 64 2d 72 65 63 6f 72 64 eric find-record
27e0: 2d 77 69 74 68 2d 76 61 72 2d 6e 6d 61 74 63 68 -with-var-nmatch
27f0: 69 6e 67 2d 76 61 6c 0a 3b 3b 0a 28 64 65 66 69 ing-val.;;.(defi
2800: 6e 65 20 28 70 61 74 68 2d 3e 61 72 65 61 2d 72 ne (path->area-r
2810: 65 63 6f 72 64 20 63 66 67 64 61 74 20 70 61 74 ecord cfgdat pat
2820: 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 65 h). (let* ((are
2830: 61 64 61 74 20 28 67 65 74 2d 63 66 67 2d 61 72 adat (get-cfg-ar
2840: 65 61 73 20 63 66 67 64 61 74 29 29 0a 09 20 28 eas cfgdat)).. (
2850: 61 6c 6c 20 20 20 20 20 28 66 69 6c 74 65 72 20 all (filter
2860: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 20 (lambda (x)....
2870: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 (let* ((keyva
2880: 6c 73 20 28 63 64 72 20 78 29 29 0a 09 09 09 09 ls (cdr x)).....
2890: 20 20 20 28 70 74 68 20 20 20 20 20 28 61 6c 69 (pth (ali
28a0: 73 74 2d 72 65 66 20 27 70 61 74 68 20 6b 65 79 st-ref 'path key
28b0: 76 61 6c 73 29 29 29 0a 09 09 09 20 20 20 20 20 vals)))....
28c0: 20 28 65 71 75 61 6c 3f 20 70 61 74 68 20 70 74 (equal? path pt
28d0: 68 29 29 29 0a 09 09 09 20 20 61 72 65 61 64 61 h))).... areada
28e0: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 t))). (if (nu
28f0: 6c 6c 3f 20 61 6c 6c 29 0a 09 23 66 0a 09 28 63 ll? all)..#f..(c
2900: 61 72 20 61 6c 6c 29 29 29 29 20 3b 3b 20 72 65 ar all)))) ;; re
2910: 74 75 72 6e 20 66 69 72 73 74 20 6d 61 74 63 68 turn first match
2920: 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 63 6f 6e ..;; given a con
2930: 66 69 67 20 72 65 74 75 72 6e 20 61 6e 20 61 6c fig return an al
2940: 69 73 74 20 6f 66 20 61 6c 69 73 74 73 0a 3b 3b ist of alists.;;
2950: 20 20 20 61 72 65 61 2d 6e 61 6d 65 20 3d 3e 20 area-name =>
2960: 64 61 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 data.;;.(define
2970: 28 67 65 74 2d 63 66 67 2d 61 72 65 61 73 20 63 (get-cfg-areas c
2980: 66 67 64 61 74 29 0a 20 20 28 6c 65 74 20 28 28 fgdat). (let ((
2990: 61 64 61 74 20 28 67 65 74 2d 73 65 63 74 69 6f adat (get-sectio
29a0: 6e 20 63 66 67 64 61 74 20 22 61 72 65 61 73 22 n cfgdat "areas"
29b0: 29 29 29 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 ))). (map (la
29c0: 6d 62 64 61 20 28 65 6e 74 72 79 29 0a 09 20 20 mbda (entry)..
29d0: 20 60 28 2c 28 63 61 72 20 65 6e 74 72 79 29 20 `(,(car entry)
29e0: 2e 20 0a 09 20 20 20 20 20 2c 28 76 61 6c 2d 3e . .. ,(val->
29f0: 61 6c 69 73 74 20 28 63 61 64 72 20 65 6e 74 72 alist (cadr entr
2a00: 79 29 29 29 29 0a 09 20 61 64 61 74 29 29 29 0a y)))).. adat))).
2a10: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 69 6d =========.;; tim
2a60: 65 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d e utils.;;======
2a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ab0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
2ac0: 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 0a 20 20 n:human-time).
2ad0: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 (time->string (s
2ae0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
2af0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
2b00: 6e 64 73 29 29 20 22 25 59 2d 25 6d 2d 25 64 20 nds)) "%Y-%m-%d
2b10: 25 48 3a 25 4d 3a 25 53 22 29 29 0a 0a 3b 3b 3d %H:%M:%S"))..;;=
2b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b60: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 4d 20 45 =====.;; T I M E
2b70: 20 20 20 41 20 4e 20 44 20 20 20 44 20 41 20 54 A N D D A T
2b80: 20 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E.;;===========
2b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
2bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c10: 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 6e 76 65 72 74 =====.;; Convert
2c20: 20 73 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 strings like "5
2c30: 73 20 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 s 2h 3m" => 60x6
2c40: 30 78 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 0x2 + 3x60 + 5.(
2c50: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 define (common:h
2c60: 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e ms-string->secon
2c70: 64 73 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 ds tstr). (let
2c80: 28 28 70 61 72 74 73 20 20 20 20 20 28 73 74 72 ((parts (str
2c90: 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 73 ing-split-fields
2ca0: 20 22 5c 5c 77 2b 22 20 74 73 74 72 29 29 0a 09 "\\w+" tstr))..
2cb0: 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a 09 3b (time-secs 0)..;
2cc0: 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d ; s=seconds, m=m
2cd0: 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 73 2c inutes, h=hours,
2ce0: 20 64 3d 64 61 79 73 2c 20 4d 3d 6d 6f 6e 74 68 d=days, M=month
2cf0: 73 2c 20 79 3d 79 65 61 72 73 2c 20 77 3d 77 65 s, y=years, w=we
2d00: 65 6b 73 0a 09 28 74 72 78 20 20 20 20 20 20 20 eks..(trx
2d10: 28 72 65 67 65 78 70 20 22 5e 28 5c 5c 64 2b 29 (regexp "^(\\d+)
2d20: 28 5b 73 6d 68 64 4d 79 77 5d 29 24 22 29 29 29 ([smhdMyw])$")))
2d30: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
2d40: 6c 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 09 lambda (part)...
2d50: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 73 (let ((match (s
2d60: 74 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 20 tring-match trx
2d70: 70 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 20 part)))... (if
2d80: 6d 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 6c match... (l
2d90: 65 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e 67 et ((val (string
2da0: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
2db0: 61 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 28 atch))).... (
2dc0: 75 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 68 unt (caddr match
2dd0: 29 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 0a )))....(if val .
2de0: 09 09 09 20 20 20 20 28 73 65 74 21 20 74 69 6d ... (set! tim
2df0: 65 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d 73 e-secs (+ time-s
2e00: 65 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 09 ecs (* val......
2e10: 09 09 20 20 20 20 28 63 61 73 65 20 28 73 74 72 .. (case (str
2e20: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 ing->symbol unt)
2e30: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
2e40: 73 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 s) 1)........
2e50: 20 20 20 28 28 6d 29 20 36 30 29 20 3b 3b 20 6d ((m) 60) ;; m
2e60: 69 6e 75 74 65 73 0a 09 09 09 09 09 09 09 20 20 inutes........
2e70: 20 20 20 20 28 28 68 29 20 33 36 30 30 29 0a 09 ((h) 3600)..
2e80: 09 09 09 09 09 09 20 20 20 20 20 20 28 28 64 29 ...... ((d)
2e90: 20 38 36 34 30 30 29 0a 09 09 09 09 09 09 09 20 86400)........
2ea0: 20 20 20 20 20 28 28 77 29 20 36 30 34 38 30 30 ((w) 604800
2eb0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 )........ (
2ec0: 28 4d 29 20 32 36 32 38 30 30 30 29 20 3b 3b 20 (M) 2628000) ;;
2ed0: 61 70 72 6f 78 69 6d 61 74 65 6c 79 20 6f 6e 65 aproximately one
2ee0: 20 6d 6f 6e 74 68 0a 09 09 09 09 09 09 09 20 20 month........
2ef0: 20 20 20 20 28 28 79 29 20 33 31 35 33 36 30 30 ((y) 3153600
2f00: 30 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 0)........
2f10: 28 65 6c 73 65 0a 09 09 09 09 09 09 09 20 20 20 (else........
2f20: 20 20 20 20 30 29 29 29 29 29 29 29 0a 09 09 20 0)))))))...
2f30: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
2f40: 45 52 52 4f 52 3a 20 63 61 6e 27 74 20 70 61 72 ERROR: can't par
2f50: 73 65 20 74 69 6d 65 73 74 72 69 6e 67 20 22 74 se timestring "t
2f60: 73 74 72 22 2c 20 63 6f 6d 70 6f 6e 65 6e 74 20 str", component
2f70: 22 70 61 72 74 29 0a 09 09 20 20 20 20 20 20 3b "part)... ;
2f80: 3b 20 63 61 6e 27 74 20 28 79 65 74 29 20 75 73 ; can't (yet) us
2f90: 65 20 64 65 62 75 67 70 72 69 6e 74 2e 20 72 65 e debugprint. re
2fa0: 6c 79 20 6f 6e 20 2d 73 68 6f 77 2d 63 6f 6e 66 ly on -show-conf
2fb0: 69 67 20 66 6f 72 20 75 73 65 72 20 74 6f 20 66 ig for user to f
2fc0: 69 6e 64 20 65 72 72 6f 72 73 0a 09 09 20 20 20 ind errors...
2fd0: 20 20 20 29 29 29 0a 09 20 20 20 20 20 20 70 61 ))).. pa
2fe0: 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d 73 65 rts). time-se
2ff0: 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 0a 28 cs))... .(
3000: 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d define (seconds-
3010: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 63 73 >hr-min-sec secs
3020: 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 73 20 ). (let* ((hrs
3030: 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 20 33 (quotient secs 3
3040: 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 71 75 600)).. (min (qu
3050: 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 20 28 otient (- secs (
3060: 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 30 29 * hrs 3600)) 60)
3070: 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 63 73 ).. (sec (- secs
3080: 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 2a 20 (* hrs 3600)(*
3090: 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 20 28 min 60)))). (
30a0: 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 73 20 conc (if (> hrs
30b0: 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 72 20 0)(conc hrs "hr
30c0: 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 28 3e ") "").. (if (>
30d0: 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d 69 6e min 0)(conc min
30e0: 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 20 73 "m ") "").. s
30f0: 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 66 69 ec "s")))..(defi
3100: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d ne (seconds->tim
3110: 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a 20 20 e-string sec).
3120: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 20 (time->string .
3130: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
3140: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 48 3a l-time sec) "%H:
3150: 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 69 6e %M:%S"))..(defin
3160: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b e (seconds->work
3170: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
3180: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
3190: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
31a0: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
31b0: 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 4d 22 "ww%V.%u %H:%M"
31c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
31d0: 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f onds->work-week/
31e0: 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d 65 day sec). (time
31f0: 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
3200: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
3210: 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 22 29 sec) "ww%V.%u")
3220: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
3230: 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 nds->year-work-w
3240: 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 eek/day sec). (
3250: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
3260: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
3270: 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 77 25 time sec) "%yww%
3280: 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 6e 65 V.%w"))..(define
3290: 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d (seconds->year-
32a0: 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 work-week/day-ti
32b0: 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d me sec). (time-
32c0: 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f >string. (seco
32d0: 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
32e0: 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 77 20 sec) "%Yww%V.%w
32f0: 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e %H:%M"))..(defin
3300: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 e (seconds->year
3310: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
3320: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
3330: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
3340: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
3350: 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a 25 4d "%Yw%V.%w %H:%M
3360: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
3370: 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 73 conds->quarter s
3380: 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 ec). (case (str
3390: 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 74 ing->number.. (t
33a0: 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 20 20 ime->string ..
33b0: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
33c0: 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 25 6d time sec).. "%m
33d0: 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 33 29 ")). ((1 2 3)
33e0: 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 36 29 1). ((4 5 6)
33f0: 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 39 29 2). ((7 8 9)
3400: 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 31 20 3). ((10 11
3410: 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 73 65 12) 4). (else
3420: 20 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d #f)))..;;======
3430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3470: 0a 3b 3b 20 62 61 73 69 63 20 49 53 4f 38 36 30 .;; basic ISO860
3480: 31 20 66 6f 72 6d 61 74 20 28 65 2e 67 2e 20 22 1 format (e.g. "
3490: 32 30 31 37 2d 30 32 2d 32 38 20 30 36 3a 30 32 2017-02-28 06:02
34a0: 3a 35 34 22 29 20 64 61 74 65 20 74 69 6d 65 20 :54") date time
34b0: 3d 3e 20 55 6e 69 78 20 65 70 6f 63 68 0a 3b 3b => Unix epoch.;;
34c0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
34d0: 3a 64 61 74 65 2d 74 69 6d 65 2d 3e 73 65 63 6f :date-time->seco
34e0: 6e 64 73 20 64 61 74 65 74 69 6d 65 29 0a 20 20 nds datetime).
34f0: 28 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e 73 65 63 (local-time->sec
3500: 6f 6e 64 73 20 28 73 74 72 69 6e 67 2d 3e 74 69 onds (string->ti
3510: 6d 65 20 64 61 74 65 74 69 6d 65 20 22 25 59 2d me datetime "%Y-
3520: 25 6d 2d 25 64 20 25 48 3a 25 4d 3a 25 53 22 29 %m-%d %H:%M:%S")
3530: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
3540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
3580: 67 69 76 65 6e 20 73 70 61 6e 20 6f 66 20 73 65 given span of se
3590: 63 6f 6e 64 73 20 74 73 74 61 72 74 20 74 6f 20 conds tstart to
35a0: 74 65 6e 64 0a 3b 3b 20 66 69 6e 64 20 73 74 61 tend.;; find sta
35b0: 72 74 20 74 69 6d 65 20 74 6f 20 6d 61 72 6b 20 rt time to mark
35c0: 61 6e 64 20 6d 61 72 6b 20 64 65 6c 74 61 0a 3b and mark delta.;
35d0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
35e0: 6e 3a 66 69 6e 64 2d 73 74 61 72 74 2d 6d 61 72 n:find-start-mar
35f0: 6b 2d 61 6e 64 2d 6d 61 72 6b 2d 64 65 6c 74 61 k-and-mark-delta
3600: 20 74 73 74 61 72 74 20 74 65 6e 64 29 0a 20 20 tstart tend).
3610: 28 6c 65 74 2a 20 28 28 64 65 6c 74 61 74 20 20 (let* ((deltat
3620: 20 28 2d 20 28 6d 61 78 20 74 65 6e 64 20 28 2b (- (max tend (+
3630: 20 74 65 6e 64 20 31 30 29 29 20 74 73 74 61 72 tend 10)) tstar
3640: 74 29 29 20 3b 3b 20 63 61 6e 27 74 20 68 61 6e t)) ;; can't han
3650: 64 6c 65 20 72 75 6e 73 20 6f 66 20 6c 65 73 73 dle runs of less
3660: 20 74 68 61 6e 20 34 20 73 65 63 6f 6e 64 73 2e than 4 seconds.
3670: 20 50 61 64 20 69 74 20 74 6f 20 31 30 20 73 65 Pad it to 10 se
3680: 63 6f 6e 64 73 20 2e 2e 2e 0a 09 20 28 72 65 73 conds ..... (res
3690: 75 6c 74 20 20 20 23 66 29 0a 09 20 28 6d 69 6e ult #f).. (min
36a0: 20 20 20 20 20 20 36 30 29 0a 09 20 28 68 72 20 60).. (hr
36b0: 20 20 20 20 20 20 28 2a 20 36 30 20 36 30 29 29 (* 60 60))
36c0: 0a 09 20 28 64 61 79 20 20 20 20 20 20 28 2a 20 .. (day (*
36d0: 32 34 20 68 72 29 29 0a 09 20 28 79 72 20 20 20 24 hr)).. (yr
36e0: 20 20 20 20 28 2a 20 33 36 35 20 64 61 79 29 29 (* 365 day))
36f0: 20 3b 3b 20 79 65 61 72 0a 09 20 28 6d 6f 20 20 ;; year.. (mo
3700: 20 20 20 20 20 28 2f 20 79 72 20 31 32 29 29 0a (/ yr 12)).
3710: 09 20 28 77 6b 20 20 20 20 20 20 20 28 2a 20 64 . (wk (* d
3720: 61 79 20 37 29 29 29 0a 20 20 20 20 28 66 6f 72 ay 7))). (for
3730: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
3740: 64 61 20 28 6d 61 78 2d 62 6c 6b 73 29 0a 20 20 da (max-blks).
3750: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 (for-each..
3760: 28 6c 61 6d 62 64 61 20 28 73 70 61 6e 29 20 3b (lambda (span) ;
3770: 3b 20 35 20 32 20 31 0a 09 20 20 28 69 66 20 28 ; 5 2 1.. (if (
3780: 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 20 20 20 not result)..
3790: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 (for-each ..
37a0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 (lambda (t
37b0: 69 6d 65 75 6e 69 74 20 74 69 6d 65 73 79 6d 29 imeunit timesym)
37c0: 20 3b 3b 20 79 65 61 72 20 6d 6f 6e 74 68 20 64 ;; year month d
37d0: 61 79 20 68 72 20 6d 69 6e 20 73 65 63 0a 09 09 ay hr min sec...
37e0: 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 (if (not result
37f0: 29 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 )... (let* (
3800: 28 74 69 6d 65 2d 62 6c 6b 20 28 2a 20 73 70 61 (time-blk (* spa
3810: 6e 20 74 69 6d 65 75 6e 69 74 29 29 0a 09 09 09 n timeunit))....
3820: 20 20 20 20 28 6e 75 6d 2d 62 6c 6b 73 20 28 71 (num-blks (q
3830: 75 6f 74 69 65 6e 74 20 64 65 6c 74 61 74 20 74 uotient deltat t
3840: 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 20 20 20 ime-blk)))...
3850: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 (if (and (>
3860: 6e 75 6d 2d 62 6c 6b 73 20 34 29 28 3c 20 6e 75 num-blks 4)(< nu
3870: 6d 2d 62 6c 6b 73 20 6d 61 78 2d 62 6c 6b 73 29 m-blks max-blks)
3880: 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 66 ).... (let ((f
3890: 69 72 73 74 20 28 2a 20 28 71 75 6f 74 69 65 6e irst (* (quotien
38a0: 74 20 74 73 74 61 72 74 20 74 69 6d 65 2d 62 6c t tstart time-bl
38b0: 6b 29 20 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 k) time-blk)))..
38c0: 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 73 .. (set! res
38d0: 75 6c 74 20 28 6c 69 73 74 20 73 70 61 6e 20 74 ult (list span t
38e0: 69 6d 65 75 6e 69 74 20 74 69 6d 65 2d 62 6c 6b imeunit time-blk
38f0: 20 66 69 72 73 74 20 74 69 6d 65 73 79 6d 29 29 first timesym))
3900: 0a 09 09 09 20 20 20 20 20 29 29 29 29 29 0a 09 .... )))))..
3910: 20 20 20 20 20 20 20 28 6c 69 73 74 20 79 72 20 (list yr
3920: 6d 6f 20 77 6b 20 64 61 79 20 68 72 20 6d 69 6e mo wk day hr min
3930: 20 31 29 0a 09 20 20 20 20 20 20 20 27 28 20 20 1).. '(
3940: 20 20 20 79 20 20 6d 6f 20 77 20 20 64 20 20 20 y mo w d
3950: 68 20 20 6d 20 20 20 73 29 29 29 29 0a 09 28 6c h m s))))..(l
3960: 69 73 74 20 38 20 36 20 35 20 32 20 31 29 29 29 ist 8 6 5 2 1)))
3970: 0a 20 20 20 20 20 27 28 35 20 31 30 20 31 35 20 . '(5 10 15
3980: 32 30 20 33 30 20 34 30 20 35 30 20 35 30 30 29 20 30 40 50 500)
3990: 29 0a 20 20 20 20 28 69 66 20 76 61 6c 75 65 73 ). (if values
39a0: 0a 09 28 61 70 70 6c 79 20 76 61 6c 75 65 73 20 ..(apply values
39b0: 72 65 73 75 6c 74 29 0a 09 28 76 61 6c 75 65 73 result)..(values
39c0: 20 30 20 64 61 79 20 31 20 30 20 27 64 29 29 29 0 day 1 0 'd)))
39d0: 29 0a 0a 3b 3b 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 3d 3d 3d 3d 3d ================
3a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 67 ===========.;; g
3a20: 69 76 65 6e 20 78 20 79 20 6c 69 6d 20 72 65 74 iven x y lim ret
3a30: 75 72 6e 20 74 68 65 20 63 72 6f 6e 20 65 78 70 urn the cron exp
3a40: 61 6e 73 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e ansion.;;.(defin
3a50: 65 20 28 63 6f 6d 6d 6f 6e 3a 65 78 70 61 6e 64 e (common:expand
3a60: 2d 63 72 6f 6e 2d 73 6c 61 73 68 20 78 20 79 20 -cron-slash x y
3a70: 6c 69 6d 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 lim). (let loop
3a80: 20 28 28 63 75 72 72 20 78 29 0a 09 20 20 20 20 ((curr x)..
3a90: 20 28 72 65 73 20 20 60 28 29 29 29 0a 20 20 20 (res `())).
3aa0: 20 28 69 66 20 28 3c 20 63 75 72 72 20 6c 69 6d (if (< curr lim
3ab0: 29 0a 09 28 6c 6f 6f 70 20 28 2b 20 63 75 72 72 )..(loop (+ curr
3ac0: 20 79 29 20 28 63 6f 6e 73 20 63 75 72 72 20 72 y) (cons curr r
3ad0: 65 73 29 29 0a 09 28 72 65 76 65 72 73 65 20 72 es))..(reverse r
3ae0: 65 73 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d es))))..;;======
3af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b30: 0a 3b 3b 20 65 78 70 61 6e 64 20 61 20 63 6f 6d .;; expand a com
3b40: 70 6c 65 78 20 63 72 6f 6e 20 73 74 72 69 6e 67 plex cron string
3b50: 20 74 6f 20 61 20 6c 69 73 74 20 6f 66 20 63 72 to a list of cr
3b60: 6f 6e 20 73 74 72 69 6e 67 73 0a 3b 3b 0a 3b 3b on strings.;;.;;
3b70: 20 20 78 2f 79 20 20 20 3d 3e 20 78 2c 20 78 2b x/y => x, x+
3b80: 79 2c 20 78 2b 32 79 2c 20 78 2b 33 79 20 77 68 y, x+2y, x+3y wh
3b90: 69 6c 65 20 78 2b 4e 79 3c 6d 61 78 5f 66 6f 72 ile x+Ny<max_for
3ba0: 5f 66 69 65 6c 64 0a 3b 3b 20 20 61 2c 62 2c 63 _field.;; a,b,c
3bb0: 20 3d 3e 20 61 2c 20 62 20 2c 63 0a 3b 3b 0a 3b => a, b ,c.;;.;
3bc0: 3b 20 20 20 4e 4f 54 45 3a 20 77 69 74 68 20 66 ; NOTE: with f
3bd0: 6c 61 74 74 65 6e 20 61 20 6c 6f 74 20 6f 66 20 latten a lot of
3be0: 74 68 65 20 63 72 75 64 20 62 65 6c 6f 77 20 63 the crud below c
3bf0: 61 6e 20 62 65 20 66 61 63 74 6f 72 65 64 20 64 an be factored d
3c00: 6f 77 6e 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 own..;;.(define
3c10: 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 70 (common:cron-exp
3c20: 61 6e 64 20 63 72 6f 6e 2d 73 74 72 29 0a 20 20 and cron-str).
3c30: 28 69 66 20 28 6c 69 73 74 3f 20 63 72 6f 6e 2d (if (list? cron-
3c40: 73 74 72 29 0a 20 20 20 20 20 20 28 66 6c 61 74 str). (flat
3c50: 74 65 6e 0a 20 20 20 20 20 20 20 28 66 6f 6c 64 ten. (fold
3c60: 20 28 6c 61 6d 62 64 61 20 28 78 20 72 65 73 29 (lambda (x res)
3c70: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6c 69 .. (if (li
3c80: 73 74 3f 20 78 29 0a 09 09 20 20 20 28 6c 65 74 st? x)... (let
3c90: 20 28 28 6e 65 77 72 65 73 20 28 6d 61 70 20 63 ((newres (map c
3ca0: 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e ommon:cron-expan
3cb0: 64 20 78 29 29 29 0a 09 09 20 20 20 20 20 28 61 d x)))... (a
3cc0: 70 70 65 6e 64 20 78 20 6e 65 77 72 65 73 29 29 ppend x newres))
3cd0: 0a 09 09 20 20 20 28 63 6f 6e 73 20 78 20 72 65 ... (cons x re
3ce0: 73 29 29 29 0a 09 20 20 20 20 20 27 28 29 0a 09 s))).. '()..
3cf0: 20 20 20 20 20 63 72 6f 6e 2d 73 74 72 29 29 20 cron-str))
3d00: 3b 3b 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 ;; (map common:c
3d10: 72 6f 6e 2d 65 78 70 61 6e 64 20 63 72 6f 6e 2d ron-expand cron-
3d20: 73 74 72 29 29 0a 20 20 20 20 20 20 28 6c 65 74 str)). (let
3d30: 20 28 28 63 72 6f 6e 2d 69 74 65 6d 73 20 28 73 ((cron-items (s
3d40: 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 72 6f 6e tring-split cron
3d50: 2d 73 74 72 29 29 0a 09 20 20 20 20 28 73 6c 61 -str)).. (sla
3d60: 73 68 2d 72 78 20 20 20 28 72 65 67 65 78 70 20 sh-rx (regexp
3d70: 22 28 5c 5c 64 2b 29 2f 28 5c 5c 64 2b 29 22 29 "(\\d+)/(\\d+)")
3d80: 29 0a 09 20 20 20 20 28 63 6f 6d 6d 61 2d 72 78 ).. (comma-rx
3d90: 20 20 20 28 72 65 67 65 78 70 20 22 2e 2a 2c 2e (regexp ".*,.
3da0: 2a 22 29 29 0a 09 20 20 20 20 28 6d 61 78 2d 76 *")).. (max-v
3db0: 61 6c 73 20 20 20 27 28 28 6d 69 6e 20 20 20 20 als '((min
3dc0: 20 20 20 20 2e 20 36 30 29 0a 09 09 09 20 20 28 . 60).... (
3dd0: 68 6f 75 72 20 20 20 20 20 20 20 2e 20 32 34 29 hour . 24)
3de0: 0a 09 09 09 20 20 28 64 61 79 6f 66 6d 6f 6e 74 .... (dayofmont
3df0: 68 20 2e 20 32 38 29 20 3b 3b 3b 20 42 55 47 21 h . 28) ;;; BUG!
3e00: 21 21 21 20 54 68 69 73 20 77 69 6c 6c 20 62 65 !!! This will be
3e10: 20 61 20 62 75 67 20 66 6f 72 20 73 6f 6d 65 20 a bug for some
3e20: 63 6f 6d 62 69 6e 61 74 69 6f 6e 73 0a 09 09 09 combinations....
3e30: 20 20 28 6d 6f 6e 74 68 20 20 20 20 20 20 2e 20 (month .
3e40: 31 32 29 0a 09 09 09 20 20 28 64 61 79 6f 66 77 12).... (dayofw
3e50: 65 65 6b 20 20 2e 20 37 29 29 29 29 0a 09 28 69 eek . 7))))..(i
3e60: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 63 72 6f f (< (length cro
3e70: 6e 2d 69 74 65 6d 73 29 20 35 29 20 3b 3b 20 62 n-items) 5) ;; b
3e80: 61 64 20 73 70 65 63 0a 09 20 20 20 20 63 72 6f ad spec.. cro
3e90: 6e 2d 73 74 72 20 3b 3b 20 60 28 2c 63 72 6f 6e n-str ;; `(,cron
3ea0: 2d 73 74 72 29 20 20 20 20 20 20 20 20 20 20 20 -str)
3eb0: 20 20 20 3b 3b 20 6a 75 73 74 20 72 65 74 75 72 ;; just retur
3ec0: 6e 20 74 68 65 20 73 74 72 69 6e 67 2c 20 73 6f n the string, so
3ed0: 6d 65 74 68 69 6e 67 20 64 6f 77 6e 73 74 72 65 mething downstre
3ee0: 61 6d 20 77 69 6c 6c 20 66 69 78 20 69 74 0a 09 am will fix it..
3ef0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
3f00: 68 65 64 20 20 28 63 61 72 20 63 72 6f 6e 2d 69 hed (car cron-i
3f10: 74 65 6d 73 29 29 0a 09 09 20 20 20 20 20 20 20 tems))...
3f20: 28 74 61 6c 20 20 28 63 64 72 20 63 72 6f 6e 2d (tal (cdr cron-
3f30: 69 74 65 6d 73 29 29 0a 09 09 20 20 20 20 20 20 items))...
3f40: 20 28 74 79 70 65 20 27 6d 69 6e 29 0a 09 09 20 (type 'min)...
3f50: 20 20 20 20 20 20 28 74 79 70 65 2d 74 61 6c 20 (type-tal
3f60: 27 28 68 6f 75 72 20 64 61 79 6f 66 6d 6f 6e 74 '(hour dayofmont
3f70: 68 20 6d 6f 6e 74 68 20 64 61 79 6f 66 77 65 65 h month dayofwee
3f80: 6b 29 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 k))... (re
3f90: 73 20 20 27 28 29 29 29 0a 09 20 20 20 20 20 20 s '()))..
3fa0: 28 72 65 67 65 78 2d 63 61 73 65 0a 09 09 20 20 (regex-case...
3fb0: 68 65 64 0a 09 09 28 73 6c 61 73 68 2d 72 78 20 hed...(slash-rx
3fc0: 28 20 5f 20 62 61 73 65 20 69 6e 63 72 20 29 20 ( _ base incr )
3fd0: 28 6c 65 74 2a 20 28 28 62 61 73 65 6e 20 20 20 (let* ((basen
3fe0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e (string->
3ff0: 6e 75 6d 62 65 72 20 62 61 73 65 29 29 0a 09 09 number base))...
4000: 09 09 09 09 20 28 69 6e 63 72 6e 20 20 20 20 20 .... (incrn
4010: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
4020: 6d 62 65 72 20 69 6e 63 72 29 29 0a 09 09 09 09 mber incr)).....
4030: 09 09 20 28 65 78 70 61 6e 64 65 64 2d 76 61 6c .. (expanded-val
4040: 73 20 20 28 63 6f 6d 6d 6f 6e 3a 65 78 70 61 6e s (common:expan
4050: 64 2d 63 72 6f 6e 2d 73 6c 61 73 68 20 62 61 73 d-cron-slash bas
4060: 65 6e 20 69 6e 63 72 6e 20 28 61 6c 69 73 74 2d en incrn (alist-
4070: 72 65 66 20 74 79 70 65 20 6d 61 78 2d 76 61 6c ref type max-val
4080: 73 29 29 29 0a 09 09 09 09 09 09 20 28 6e 65 77 s)))....... (new
4090: 2d 6c 69 73 74 2d 63 72 6f 6e 73 20 28 66 6f 6c -list-crons (fol
40a0: 64 20 28 6c 61 6d 62 64 61 20 28 78 20 6d 79 72 d (lambda (x myr
40b0: 65 73 29 0a 09 09 09 09 09 09 09 09 09 20 28 63 es).......... (c
40c0: 6f 6e 73 20 28 63 6f 6e 63 20 28 69 66 20 28 6e ons (conc (if (n
40d0: 75 6c 6c 3f 20 72 65 73 29 0a 09 09 09 09 09 09 ull? res).......
40e0: 09 09 09 09 09 20 22 22 0a 09 09 09 09 09 09 09 ..... ""........
40f0: 09 09 09 09 20 28 63 6f 6e 63 20 28 73 74 72 69 .... (conc (stri
4100: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 ng-intersperse r
4110: 65 73 20 22 20 22 29 20 22 20 22 29 29 0a 09 09 es " ") " "))...
4120: 09 09 09 09 09 09 09 09 20 20 20 20 20 78 20 22 ........ x "
4130: 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 " (string-inter
4140: 73 70 65 72 73 65 20 74 61 6c 20 22 20 22 29 29 sperse tal " "))
4150: 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ..........
4160: 20 6d 79 72 65 73 29 29 0a 09 09 09 09 09 09 09 myres))........
4170: 09 20 20 20 20 20 20 20 27 28 29 20 65 78 70 61 . '() expa
4180: 6e 64 65 64 2d 76 61 6c 73 29 29 29 0a 09 09 09 nded-vals)))....
4190: 09 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 .. ;; (print
41a0: 22 6e 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 3a "new-list-crons:
41b0: 20 22 20 6e 65 77 2d 6c 69 73 74 2d 63 72 6f 6e " new-list-cron
41c0: 73 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 28 s)...... ;; (
41d0: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 20 fold (lambda (x
41e0: 72 65 73 29 0a 09 09 09 09 09 20 20 20 20 3b 3b res)...... ;;
41f0: 20 09 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f . (if (list?
4200: 20 78 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 x)...... ;;
4210: 09 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 20 ..(let ((newres
4220: 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e (map common:cron
4230: 2d 65 78 70 61 6e 64 20 78 29 29 29 0a 09 09 09 -expand x)))....
4240: 09 09 20 20 20 20 3b 3b 20 09 09 20 20 28 61 70 .. ;; .. (ap
4250: 70 65 6e 64 20 78 20 6e 65 77 72 65 73 29 29 0a pend x newres)).
4260: 09 09 09 09 09 20 20 20 20 3b 3b 20 09 09 28 63 ..... ;; ..(c
4270: 6f 6e 73 20 78 20 72 65 73 29 29 29 0a 09 09 09 ons x res)))....
4280: 09 09 20 20 20 20 3b 3b 20 09 20 20 27 28 29 0a .. ;; . '().
4290: 09 09 09 09 09 20 20 20 20 28 66 6c 61 74 74 65 ..... (flatte
42a0: 6e 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 n (map common:cr
42b0: 6f 6e 2d 65 78 70 61 6e 64 20 6e 65 77 2d 6c 69 on-expand new-li
42c0: 73 74 2d 63 72 6f 6e 73 29 29 29 29 0a 09 09 3b st-crons))))...;
42d0: 3b 09 09 09 09 09 20 20 20 20 28 6d 61 70 20 63 ;..... (map c
42e0: 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e ommon:cron-expan
42f0: 64 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 d (map common:cr
4300: 6f 6e 2d 65 78 70 61 6e 64 20 6e 65 77 2d 6c 69 on-expand new-li
4310: 73 74 2d 63 72 6f 6e 73 29 29 29 29 0a 09 09 28 st-crons))))...(
4320: 65 6c 73 65 20 28 69 66 20 28 6e 75 6c 6c 3f 20 else (if (null?
4330: 74 61 6c 29 0a 09 09 09 20 20 63 72 6f 6e 2d 73 tal).... cron-s
4340: 74 72 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 tr.... (loop (c
4350: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4360: 28 63 61 72 20 74 79 70 65 2d 74 61 6c 29 28 63 (car type-tal)(c
4370: 64 72 20 74 79 70 65 2d 74 61 6c 29 28 61 70 70 dr type-tal)(app
4380: 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 65 end res (list he
4390: 64 29 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b d)))))))))))..;;
43a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
43b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
43c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
43d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
43e0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 67 69 76 65 6e 20 ======.;; given
43f0: 61 20 63 72 6f 6e 20 73 74 72 69 6e 67 20 61 6e a cron string an
4400: 64 20 74 68 65 20 6c 61 73 74 20 74 69 6d 65 20 d the last time
4410: 65 76 65 6e 74 20 77 61 73 20 70 72 6f 63 65 73 event was proces
4420: 73 65 64 20 72 65 74 75 72 6e 20 23 74 20 74 6f sed return #t to
4430: 20 72 75 6e 20 6f 72 20 23 66 20 74 6f 20 6e 6f run or #f to no
4440: 74 20 72 75 6e 0a 3b 3b 0a 3b 3b 20 20 6d 69 6e t run.;;.;; min
4450: 20 20 20 20 68 6f 75 72 20 20 20 64 61 79 6f 66 hour dayof
4460: 6d 6f 6e 74 68 20 6d 6f 6e 74 68 20 20 64 61 79 month month day
4470: 6f 66 77 65 65 6b 0a 3b 3b 20 30 2d 35 39 20 20 ofweek.;; 0-59
4480: 20 20 30 2d 32 33 20 20 20 31 2d 33 31 20 20 20 0-23 1-31
4490: 20 20 20 20 31 2d 31 32 20 20 20 30 2d 36 20 20 1-12 0-6
44a0: 20 20 20 20 20 20 20 20 23 23 23 20 4e 4f 54 45 ### NOTE
44b0: 3a 20 64 61 79 6f 66 77 65 65 6b 20 64 6f 65 73 : dayofweek does
44c0: 20 6e 6f 74 20 69 6e 63 6c 75 64 65 20 37 0a 3b not include 7.;
44d0: 3b 0a 3b 3b 20 20 23 74 20 3d 3e 20 79 65 73 2c ;.;; #t => yes,
44e0: 20 72 75 6e 20 74 68 65 20 6a 6f 62 0a 3b 3b 20 run the job.;;
44f0: 20 23 66 20 3d 3e 20 6e 6f 2c 20 64 6f 20 6e 6f #f => no, do no
4500: 74 20 72 75 6e 20 74 68 65 20 6a 6f 62 0a 3b 3b t run the job.;;
4510: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
4520: 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 63 72 6f 6e :cron-event cron
4530: 2d 73 74 72 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 -str now-seconds
4540: 2d 69 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 20 3b -in last-done) ;
4550: 3b 20 72 65 66 2d 73 65 63 6f 6e 64 73 20 3d 20 ; ref-seconds =
4560: 23 66 20 69 73 20 4e 4f 57 2e 0a 20 20 28 6c 65 #f is NOW.. (le
4570: 74 2a 20 28 28 63 72 6f 6e 2d 69 74 65 6d 73 20 t* ((cron-items
4580: 20 20 20 20 28 6d 61 70 20 73 74 72 69 6e 67 2d (map string-
4590: 3e 6e 75 6d 62 65 72 20 28 73 74 72 69 6e 67 2d >number (string-
45a0: 73 70 6c 69 74 20 63 72 6f 6e 2d 73 74 72 29 29 split cron-str))
45b0: 29 0a 09 20 28 6e 6f 77 2d 73 65 63 6f 6e 64 73 ).. (now-seconds
45c0: 20 20 20 20 28 6f 72 20 6e 6f 77 2d 73 65 63 6f (or now-seco
45d0: 6e 64 73 2d 69 6e 20 28 63 75 72 72 65 6e 74 2d nds-in (current-
45e0: 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 28 6e 6f seconds))).. (no
45f0: 77 2d 74 69 6d 65 20 20 20 20 20 20 20 28 73 65 w-time (se
4600: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
4610: 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 29 0a e now-seconds)).
4620: 09 20 28 6c 61 73 74 2d 64 6f 6e 65 2d 74 69 6d . (last-done-tim
4630: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 e (seconds->loca
4640: 6c 2d 74 69 6d 65 20 6c 61 73 74 2d 64 6f 6e 65 l-time last-done
4650: 29 29 0a 09 20 28 61 6c 6c 2d 74 69 6d 65 73 20 )).. (all-times
4660: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
4670: 74 61 62 6c 65 29 29 29 0a 20 20 20 20 3b 3b 20 table))). ;;
4680: 28 70 72 69 6e 74 20 22 63 72 6f 6e 2d 69 74 65 (print "cron-ite
4690: 6d 73 3a 20 22 20 63 72 6f 6e 2d 69 74 65 6d 73 ms: " cron-items
46a0: 20 22 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 "(length cron-i
46b0: 74 65 6d 73 29 3a 20 22 20 28 6c 65 6e 67 74 68 tems): " (length
46c0: 20 63 72 6f 6e 2d 69 74 65 6d 73 29 29 0a 20 20 cron-items)).
46d0: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
46e0: 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 74 65 (length cron-ite
46f0: 6d 73 29 20 35 29 29 20 3b 3b 20 64 6f 6e 27 74 ms) 5)) ;; don't
4700: 20 65 76 65 6e 20 74 72 79 20 74 6f 20 66 69 67 even try to fig
4710: 75 72 65 20 6f 75 74 20 6a 75 6e 6b 20 73 74 72 ure out junk str
4720: 69 6e 67 73 0a 09 23 66 0a 09 28 6d 61 74 63 68 ings..#f..(match
4730: 2d 6c 65 74 20 28 28 28 20 20 20 20 20 63 6d 69 -let ((( cmi
4740: 6e 20 63 68 6f 75 72 20 63 64 61 79 6f 66 6d 6f n chour cdayofmo
4750: 6e 74 68 20 63 6d 6f 6e 74 68 20 20 20 20 63 64 nth cmonth cd
4760: 61 79 6f 66 77 65 65 6b 29 0a 09 09 20 20 20 20 ayofweek)...
4770: 20 63 72 6f 6e 2d 69 74 65 6d 73 29 0a 09 09 20 cron-items)...
4780: 20 20 20 3b 3b 20 30 20 20 20 20 20 31 20 20 20 ;; 0 1
4790: 20 32 20 20 20 20 20 20 20 20 33 20 20 20 20 20 2 3
47a0: 20 20 20 20 34 20 20 20 20 35 20 20 20 20 20 20 4 5
47b0: 36 0a 09 09 20 20 20 20 28 28 6e 73 65 63 20 6e 6... ((nsec n
47c0: 6d 69 6e 20 6e 68 6f 75 72 20 6e 64 61 79 6f 66 min nhour ndayof
47d0: 6d 6f 6e 74 68 20 6e 6d 6f 6e 74 68 20 6e 79 72 month nmonth nyr
47e0: 20 6e 64 61 79 6f 66 77 65 65 6b 20 6e 37 20 6e ndayofweek n7 n
47f0: 38 20 6e 39 29 0a 09 09 20 20 20 20 20 28 76 65 8 n9)... (ve
4800: 63 74 6f 72 2d 3e 6c 69 73 74 20 6e 6f 77 2d 74 ctor->list now-t
4810: 69 6d 65 29 29 0a 09 09 20 20 20 20 28 28 6c 73 ime))... ((ls
4820: 65 63 20 6c 6d 69 6e 20 6c 68 6f 75 72 20 6c 64 ec lmin lhour ld
4830: 61 79 6f 66 6d 6f 6e 74 68 20 6c 6d 6f 6e 74 68 ayofmonth lmonth
4840: 20 6c 79 72 20 6c 64 61 79 6f 66 77 65 65 6b 20 lyr ldayofweek
4850: 6c 37 20 6c 38 20 6c 39 29 0a 09 09 20 20 20 20 l7 l8 l9)...
4860: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 6c (vector->list l
4870: 61 73 74 2d 64 6f 6e 65 2d 74 69 6d 65 29 29 29 ast-done-time)))
4880: 0a 09 20 20 3b 3b 20 63 72 65 61 74 65 20 61 6c .. ;; create al
4890: 6c 20 70 6f 73 73 69 62 6c 65 20 74 69 6d 65 20 l possible time
48a0: 73 6c 6f 74 73 0a 09 20 20 3b 3b 20 72 65 6d 6f slots.. ;; remo
48b0: 76 65 20 69 6e 76 61 6c 69 64 20 73 6c 6f 74 73 ve invalid slots
48c0: 20 64 75 65 20 74 6f 20 28 66 6f 72 20 65 78 61 due to (for exa
48d0: 6d 70 6c 65 29 20 64 61 79 20 6f 66 20 77 65 65 mple) day of wee
48e0: 6b 0a 09 20 20 3b 3b 20 67 65 74 20 74 68 65 20 k.. ;; get the
48f0: 73 74 61 72 74 20 61 6e 64 20 65 6e 64 20 65 6e start and end en
4900: 74 72 69 65 73 20 66 6f 72 20 74 68 65 20 72 65 tries for the re
4910: 66 2d 73 65 63 6f 6e 64 73 20 28 63 75 72 72 65 f-seconds (curre
4920: 6e 74 29 20 74 69 6d 65 0a 09 20 20 3b 3b 20 69 nt) time.. ;; i
4930: 66 20 6c 61 73 74 2d 64 6f 6e 65 20 3e 20 72 65 f last-done > re
4940: 66 2d 73 65 63 6f 6e 64 73 20 3d 3e 20 74 68 69 f-seconds => thi
4950: 73 20 69 73 20 61 6e 20 45 52 52 4f 52 21 0a 09 s is an ERROR!..
4960: 20 20 3b 3b 20 64 6f 65 73 20 74 68 65 20 6c 61 ;; does the la
4970: 73 74 2d 64 6f 6e 65 20 74 69 6d 65 20 66 61 6c st-done time fal
4980: 6c 20 69 6e 20 74 68 65 20 6c 65 67 69 74 20 72 l in the legit r
4990: 65 67 69 6f 6e 3f 0a 09 20 20 3b 3b 20 20 20 20 egion?.. ;;
49a0: 79 65 73 20 3d 3e 20 23 66 20 20 64 6f 20 6e 6f yes => #f do no
49b0: 74 20 72 75 6e 20 61 67 61 69 6e 20 74 68 69 73 t run again this
49c0: 20 63 6f 6d 6d 61 6e 64 0a 09 20 20 3b 3b 20 20 command.. ;;
49d0: 20 20 6e 6f 20 20 3d 3e 20 23 74 20 20 6f 6b 20 no => #t ok
49e0: 74 6f 20 72 75 6e 20 74 68 65 20 63 6f 6d 6d 61 to run the comma
49f0: 6e 64 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 20 nd.. (for-each
4a00: 3b 3b 20 6d 6f 6e 74 68 0a 09 20 20 20 28 6c 61 ;; month.. (la
4a10: 6d 62 64 61 20 28 6d 6f 6e 74 68 29 0a 09 20 20 mbda (month)..
4a20: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 3b 3b 20 (for-each ;;
4a30: 64 61 79 6f 66 6d 6f 6e 74 68 0a 09 20 20 20 20 dayofmonth..
4a40: 20 20 28 6c 61 6d 62 64 61 20 28 64 6f 6d 29 0a (lambda (dom).
4a50: 09 09 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 28 ..(for-each... (
4a60: 6c 61 6d 62 64 61 20 28 68 72 29 20 3b 3b 20 68 lambda (hr) ;; h
4a70: 6f 75 72 0a 09 09 20 20 20 28 66 6f 72 2d 65 61 our... (for-ea
4a80: 63 68 0a 09 09 20 20 20 20 28 6c 61 6d 62 64 61 ch... (lambda
4a90: 20 28 6d 69 6e 75 74 65 29 20 3b 3b 20 6d 69 6e (minute) ;; min
4aa0: 75 74 65 0a 09 09 20 20 20 20 20 20 28 6c 65 74 ute... (let
4ab0: 20 28 28 63 6f 70 79 2d 6e 6f 77 20 28 61 70 70 ((copy-now (app
4ac0: 6c 79 20 76 65 63 74 6f 72 20 28 76 65 63 74 6f ly vector (vecto
4ad0: 72 2d 3e 6c 69 73 74 20 6e 6f 77 2d 74 69 6d 65 r->list now-time
4ae0: 29 29 29 29 0a 09 09 09 28 76 65 63 74 6f 72 2d ))))....(vector-
4af0: 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 30 20 set! copy-now 0
4b00: 30 29 20 3b 3b 20 66 6f 72 63 65 20 73 65 63 6f 0) ;; force seco
4b10: 6e 64 73 20 74 6f 20 7a 65 72 6f 0a 09 09 09 28 nds to zero....(
4b20: 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f 70 79 vector-set! copy
4b30: 2d 6e 6f 77 20 31 20 6d 69 6e 75 74 65 29 0a 09 -now 1 minute)..
4b40: 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 ..(vector-set! c
4b50: 6f 70 79 2d 6e 6f 77 20 32 20 68 72 29 0a 09 09 opy-now 2 hr)...
4b60: 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f .(vector-set! co
4b70: 70 79 2d 6e 6f 77 20 33 20 64 6f 6d 29 20 20 3b py-now 3 dom) ;
4b80: 3b 20 64 6f 6d 20 69 73 20 61 6c 72 65 61 64 79 ; dom is already
4b90: 20 63 6f 72 72 65 63 74 65 64 20 66 6f 72 20 7a corrected for z
4ba0: 65 72 6f 20 72 65 66 65 72 65 6e 63 65 64 0a 09 ero referenced..
4bb0: 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 ..(vector-set! c
4bc0: 6f 70 79 2d 6e 6f 77 20 34 20 6d 6f 6e 74 68 29 opy-now 4 month)
4bd0: 0a 09 09 09 28 6c 65 74 2a 20 28 28 63 6f 70 79 ....(let* ((copy
4be0: 2d 6e 6f 77 2d 73 65 63 73 20 28 6c 6f 63 61 6c -now-secs (local
4bf0: 2d 74 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 63 -time->seconds c
4c00: 6f 70 79 2d 6e 6f 77 29 29 0a 09 09 09 20 20 20 opy-now))....
4c10: 20 20 20 20 28 6e 65 77 2d 63 6f 70 79 20 20 20 (new-copy
4c20: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
4c30: 61 6c 2d 74 69 6d 65 20 63 6f 70 79 2d 6e 6f 77 al-time copy-now
4c40: 2d 73 65 63 73 29 29 29 20 3b 3b 20 72 65 6d 61 -secs))) ;; rema
4c50: 6b 65 20 74 68 65 20 74 69 6d 65 20 76 65 63 74 ke the time vect
4c60: 6f 72 0a 09 09 09 20 20 28 69 66 20 28 6f 72 20 or.... (if (or
4c70: 28 6e 6f 74 20 63 64 61 79 6f 66 77 65 65 6b 29 (not cdayofweek)
4c80: 0a 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 28 ..... (equal? (
4c90: 76 65 63 74 6f 72 2d 72 65 66 20 6e 65 77 2d 63 vector-ref new-c
4ca0: 6f 70 79 20 36 29 0a 09 09 09 09 09 20 20 63 64 opy 6)...... cd
4cb0: 61 79 6f 66 77 65 65 6b 29 29 20 3b 3b 20 69 66 ayofweek)) ;; if
4cc0: 20 74 68 65 20 64 61 79 20 69 73 20 73 70 65 63 the day is spec
4cd0: 69 66 69 65 64 20 61 6e 64 20 61 20 6d 61 74 63 ified and a matc
4ce0: 68 20 4f 52 20 69 66 20 74 68 65 20 64 61 79 20 h OR if the day
4cf0: 69 73 20 4e 4f 54 20 73 70 65 63 69 66 69 65 64 is NOT specified
4d00: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6f .... (if (o
4d10: 72 20 28 6e 6f 74 20 63 64 61 79 6f 66 6d 6f 6e r (not cdayofmon
4d20: 74 68 29 0a 09 09 09 09 20 20 20 20 20 20 28 65 th)..... (e
4d30: 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 qual? (vector-re
4d40: 66 20 6e 65 77 2d 63 6f 70 79 20 33 29 0a 09 09 f new-copy 3)...
4d50: 09 09 09 20 20 20 20 20 20 28 2b 20 31 20 63 64 ... (+ 1 cd
4d60: 61 79 6f 66 6d 6f 6e 74 68 29 29 29 20 3b 3b 20 ayofmonth))) ;;
4d70: 69 66 20 74 68 65 20 6d 6f 6e 74 68 20 69 73 20 if the month is
4d80: 73 70 65 63 69 66 69 65 64 20 61 6e 64 20 61 20 specified and a
4d90: 6d 61 74 63 68 20 4f 52 20 69 66 20 74 68 65 20 match OR if the
4da0: 6d 6f 6e 74 68 20 69 73 20 4e 4f 54 20 73 70 65 month is NOT spe
4db0: 63 69 66 69 65 64 0a 09 09 09 09 20 20 28 68 61 cified..... (ha
4dc0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 61 6c sh-table-set! al
4dd0: 6c 2d 74 69 6d 65 73 20 63 6f 70 79 2d 6e 6f 77 l-times copy-now
4de0: 2d 73 65 63 73 20 6e 65 77 2d 63 6f 70 79 29 29 -secs new-copy))
4df0: 29 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 63 ))))... (if c
4e00: 6d 69 6e 0a 09 09 09 60 28 2c 63 6d 69 6e 29 20 min....`(,cmin)
4e10: 20 3b 3b 20 69 66 20 67 69 76 65 6e 20 63 6d 69 ;; if given cmi
4e20: 6e 2c 20 68 61 76 65 20 74 6f 20 75 73 65 20 69 n, have to use i
4e30: 74 0a 09 09 09 28 6c 69 73 74 20 28 2d 20 6e 6d t....(list (- nm
4e40: 69 6e 20 31 29 20 6e 6d 69 6e 20 28 2b 20 6e 6d in 1) nmin (+ nm
4e50: 69 6e 20 31 29 29 29 29 29 20 3b 3b 20 6d 69 6e in 1))))) ;; min
4e60: 75 74 65 0a 09 09 20 28 69 66 20 63 68 6f 75 72 ute... (if chour
4e70: 0a 09 09 20 20 20 20 20 60 28 2c 63 68 6f 75 72 ... `(,chour
4e80: 29 0a 09 09 20 20 20 20 20 28 6c 69 73 74 20 28 )... (list (
4e90: 2d 20 6e 68 6f 75 72 20 31 29 20 6e 68 6f 75 72 - nhour 1) nhour
4ea0: 20 28 2b 20 6e 68 6f 75 72 20 31 29 29 29 29 29 (+ nhour 1)))))
4eb0: 20 3b 3b 20 68 6f 75 72 0a 09 20 20 20 20 20 20 ;; hour..
4ec0: 28 69 66 20 63 64 61 79 6f 66 6d 6f 6e 74 68 0a (if cdayofmonth.
4ed0: 09 09 20 20 60 28 2c 63 64 61 79 6f 66 6d 6f 6e .. `(,cdayofmon
4ee0: 74 68 29 0a 09 09 20 20 28 6c 69 73 74 20 28 2d th)... (list (-
4ef0: 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 31 29 20 ndayofmonth 1)
4f00: 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 28 2b 20 6e ndayofmonth (+ n
4f10: 64 61 79 6f 66 6d 6f 6e 74 68 20 31 29 29 29 29 dayofmonth 1))))
4f20: 29 0a 09 20 20 20 28 69 66 20 63 6d 6f 6e 74 68 ).. (if cmonth
4f30: 0a 09 20 20 20 20 20 20 20 60 28 2c 63 6d 6f 6e .. `(,cmon
4f40: 74 68 29 0a 09 20 20 20 20 20 20 20 28 6c 69 73 th).. (lis
4f50: 74 20 28 2d 20 6e 6d 6f 6e 74 68 20 31 29 20 6e t (- nmonth 1) n
4f60: 6d 6f 6e 74 68 20 28 2b 20 6e 6d 6f 6e 74 68 20 month (+ nmonth
4f70: 31 29 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 1)))).. (let ((
4f80: 62 65 66 6f 72 65 20 23 66 29 0a 09 09 28 69 73 before #f)...(is
4f90: 2d 69 6e 20 20 23 66 29 29 0a 09 20 20 20 20 28 -in #f)).. (
4fa0: 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 28 for-each.. (
4fb0: 6c 61 6d 62 64 61 20 28 6d 6f 6d 65 6e 74 29 0a lambda (moment).
4fc0: 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 . (if (and
4fd0: 20 62 65 66 6f 72 65 0a 09 09 09 28 3c 3d 20 62 before....(<= b
4fe0: 65 66 6f 72 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 efore now-second
4ff0: 73 29 0a 09 09 09 28 3e 3d 20 6d 6f 6d 65 6e 74 s)....(>= moment
5000: 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 29 0a 09 now-seconds))..
5010: 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 . (begin...
5020: 20 20 3b 3b 20 28 70 72 69 6e 74 29 0a 09 09 20 ;; (print)...
5030: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 42 ;; (print "B
5040: 65 66 6f 72 65 3a 20 22 20 28 74 69 6d 65 2d 3e efore: " (time->
5050: 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
5060: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 62 65 66 6f >local-time befo
5070: 72 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 re)))... ;;
5080: 28 70 72 69 6e 74 20 22 4e 6f 77 3a 20 20 20 20 (print "Now:
5090: 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
50a0: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
50b0: 74 69 6d 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 time now-seconds
50c0: 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 28 70 )))... ;; (p
50d0: 72 69 6e 74 20 22 41 66 74 65 72 3a 20 20 22 20 rint "After: "
50e0: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 (time->string (s
50f0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
5100: 6d 65 20 6d 6f 6d 65 6e 74 29 29 29 0a 09 09 20 me moment)))...
5110: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4c ;; (print "L
5120: 61 73 74 3a 20 20 20 22 20 28 74 69 6d 65 2d 3e ast: " (time->
5130: 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
5140: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6c 61 73 74 >local-time last
5150: 2d 64 6f 6e 65 29 29 29 0a 09 09 20 20 20 20 20 -done)))...
5160: 28 69 66 20 28 3c 20 20 6c 61 73 74 2d 64 6f 6e (if (< last-don
5170: 65 20 62 65 66 6f 72 65 29 0a 09 09 09 20 28 73 e before).... (s
5180: 65 74 21 20 69 73 2d 69 6e 20 62 65 66 6f 72 65 et! is-in before
5190: 29 29 0a 09 09 20 20 20 20 20 29 29 0a 09 20 20 ))... ))..
51a0: 20 20 20 20 20 28 73 65 74 21 20 62 65 66 6f 72 (set! befor
51b0: 65 20 6d 6f 6d 65 6e 74 29 29 0a 09 20 20 20 20 e moment))..
51c0: 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 (sort (hash-tab
51d0: 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 69 6d 65 le-keys all-time
51e0: 73 29 20 3c 29 29 0a 09 20 20 20 20 69 73 2d 69 s) <)).. is-i
51f0: 6e 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 n)))))..(define
5200: 28 63 6f 6d 6d 6f 6e 3a 65 78 74 65 6e 64 65 64 (common:extended
5210: 2d 63 72 6f 6e 20 20 63 72 6f 6e 2d 73 74 72 20 -cron cron-str
5220: 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 6c now-seconds-in l
5230: 61 73 74 2d 64 6f 6e 65 29 0a 20 20 28 6c 65 74 ast-done). (let
5240: 20 28 28 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e ((expanded-cron
5250: 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 (common:cron-ex
5260: 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 29 29 29 pand cron-str)))
5270: 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 . (if (string
5280: 3f 20 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e 29 ? expanded-cron)
5290: 0a 09 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ..(common:cron-e
52a0: 76 65 6e 74 20 65 78 70 61 6e 64 65 64 2d 63 72 vent expanded-cr
52b0: 6f 6e 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 on now-seconds-i
52c0: 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 0a 09 28 6c n last-done)..(l
52d0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
52e0: 61 72 20 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e ar expanded-cron
52f0: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 ))... (tal (cd
5300: 72 20 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e 29 r expanded-cron)
5310: 29 29 0a 09 20 20 28 69 66 20 28 63 6f 6d 6d 6f )).. (if (commo
5320: 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 68 65 64 n:cron-event hed
5330: 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 now-seconds-in
5340: 6c 61 73 74 2d 64 6f 6e 65 29 0a 09 20 20 20 20 last-done)..
5350: 20 20 23 74 0a 09 20 20 20 20 20 20 28 69 66 20 #t.. (if
5360: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
5370: 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 #f... (loop (ca
5380: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
5390: 29 29 29 29 29 29 0a 0a 0a 0a 3b 3b 3d 3d 3d 3d ))))))....;;====
53a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53e0: 3d 3d 0a 3b 3b 20 6d 69 73 63 20 73 74 75 66 66 ==.;; misc stuff
53f0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
5400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
5440: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 ne (common:get-s
5450: 69 67 6e 61 74 75 72 65 20 73 74 72 29 0a 20 20 ignature str).
5460: 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d (message-digest-
5470: 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d string (md5-prim
5480: 69 74 69 76 65 29 20 73 74 72 29 29 0a 0a 3b 3b itive) str))..;;
5490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54d0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 61 73 68 20 6f ======.;; hash o
54e0: 66 20 68 61 73 68 73 0a 3b 3b 3d 3d 3d 3d 3d 3d f hashs.;;======
54f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5530: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 68 6f ..(define (db:ho
5540: 68 2d 73 65 74 21 20 64 61 74 20 6b 65 79 31 20 h-set! dat key1
5550: 6b 65 79 32 20 76 61 6c 29 0a 20 20 28 6c 65 74 key2 val). (let
5560: 2a 20 28 28 73 75 62 68 61 73 68 20 28 68 61 73 * ((subhash (has
5570: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
5580: 75 6c 74 20 64 61 74 20 6b 65 79 31 20 23 66 29 ult dat key1 #f)
5590: 29 29 0a 20 20 20 20 28 69 66 20 73 75 62 68 61 )). (if subha
55a0: 73 68 0a 09 28 68 61 73 68 2d 74 61 62 6c 65 2d sh..(hash-table-
55b0: 73 65 74 21 20 73 75 62 68 61 73 68 20 6b 65 79 set! subhash key
55c0: 32 20 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 2 val)..(begin..
55d0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
55e0: 74 21 20 64 61 74 20 6b 65 79 31 20 28 6d 61 6b t! dat key1 (mak
55f0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
5600: 20 20 28 64 62 3a 68 6f 68 2d 73 65 74 21 20 64 (db:hoh-set! d
5610: 61 74 20 6b 65 79 31 20 6b 65 79 32 20 76 61 6c at key1 key2 val
5620: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
5630: 64 62 3a 68 6f 68 2d 67 65 74 20 64 61 74 20 6b db:hoh-get dat k
5640: 65 79 31 20 6b 65 79 32 29 0a 20 20 28 6c 65 74 ey1 key2). (let
5650: 2a 20 28 28 73 75 62 68 61 73 68 20 28 68 61 73 * ((subhash (has
5660: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
5670: 75 6c 74 20 64 61 74 20 6b 65 79 31 20 23 66 29 ult dat key1 #f)
5680: 29 29 0a 20 20 20 20 28 61 6e 64 20 73 75 62 68 )). (and subh
5690: 61 73 68 0a 09 20 28 68 61 73 68 2d 74 61 62 6c ash.. (hash-tabl
56a0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 75 e-ref/default su
56b0: 62 68 61 73 68 20 6b 65 79 32 20 23 66 29 29 29 bhash key2 #f)))
56c0: 29 0a 0a 3b 3b 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 3d 3d 3d 0a 3b 3b 20 77 ===========.;; w
5710: 68 65 6e 20 63 61 6c 6c 65 64 20 66 72 6f 6d 20 hen called from
5720: 61 20 77 72 61 70 70 65 72 20 49 20 6e 65 65 64 a wrapper I need
5730: 20 73 6f 6d 65 74 69 6d 65 73 20 74 6f 20 66 69 sometimes to fi
5740: 6e 64 20 74 68 65 20 63 61 6c 6c 69 6e 67 0a 3b nd the calling.;
5750: 3b 20 77 72 61 70 70 65 72 2c 20 74 68 69 73 20 ; wrapper, this
5760: 69 73 20 66 6f 72 20 64 61 73 68 62 6f 61 72 64 is for dashboard
5770: 20 74 6f 20 66 69 6e 64 20 74 68 65 20 63 6f 72 to find the cor
5780: 72 65 63 74 20 6d 65 67 61 74 65 73 74 2e 0a 3b rect megatest..;
5790: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
57a0: 6e 3a 66 69 6e 64 2d 6c 6f 63 61 6c 2d 6d 65 67 n:find-local-meg
57b0: 61 74 65 73 74 20 23 21 6f 70 74 69 6f 6e 61 6c atest #!optional
57c0: 20 28 70 72 6f 67 6e 61 6d 65 20 22 6d 65 67 61 (progname "mega
57d0: 74 65 73 74 22 29 29 0a 20 20 28 6c 65 74 20 28 test")). (let (
57e0: 28 72 65 73 20 28 66 69 6c 74 65 72 20 66 69 6c (res (filter fil
57f0: 65 2d 65 78 69 73 74 73 3f 0a 09 09 20 20 20 20 e-exists?...
5800: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 75 (map (lambda (u
5810: 70 64 69 72 29 0a 09 09 09 20 20 20 20 28 6c 65 pdir).... (le
5820: 74 2a 20 28 28 6c 6d 20 20 28 63 61 72 20 28 61 t* ((lm (car (a
5830: 72 67 76 29 29 29 0a 09 09 09 09 20 20 20 28 64 rgv)))..... (d
5840: 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 ir (pathname-dir
5850: 65 63 74 6f 72 79 20 6c 6d 29 29 0a 09 09 09 09 ectory lm)).....
5860: 20 20 20 28 65 78 65 20 28 70 61 74 68 6e 61 6d (exe (pathnam
5870: 65 2d 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 e-strip-director
5880: 79 20 6c 6d 29 29 29 0a 09 09 09 20 20 20 20 20 y lm)))....
5890: 20 28 63 6f 6e 63 20 28 69 66 20 64 69 72 20 28 (conc (if dir (
58a0: 63 6f 6e 63 20 64 69 72 20 22 2f 22 29 20 22 22 conc dir "/") ""
58b0: 29 0a 09 09 09 09 20 20 20 20 28 63 61 73 65 20 )..... (case
58c0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
58d0: 65 78 65 29 0a 09 09 09 09 20 20 20 20 20 20 28 exe)..... (
58e0: 28 64 62 6f 61 72 64 29 20 20 20 20 28 63 6f 6e (dboard) (con
58f0: 63 20 75 70 64 69 72 20 70 72 6f 67 6e 61 6d 65 c updir progname
5900: 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 28 6d ))..... ((m
5910: 74 65 73 74 29 20 20 20 20 20 28 63 6f 6e 63 20 test) (conc
5920: 75 70 64 69 72 20 70 72 6f 67 6e 61 6d 65 29 29 updir progname))
5930: 0a 09 09 09 09 20 20 20 20 20 20 28 28 64 61 73 ..... ((das
5940: 68 62 6f 61 72 64 29 20 70 72 6f 67 6e 61 6d 65 hboard) progname
5950: 29 0a 09 09 09 09 20 20 20 20 20 20 28 65 6c 73 )..... (els
5960: 65 20 65 78 65 29 29 29 29 29 0a 09 09 09 20 20 e exe)))))....
5970: 27 28 22 2e 2e 2f 2e 2e 2f 22 20 22 2e 2e 2f 22 '("../../" "../"
5980: 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e ))))). (if (n
5990: 75 6c 6c 3f 20 72 65 73 29 0a 09 28 62 65 67 69 ull? res)..(begi
59a0: 6e 0a 09 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 n.. ;; (debug:p
59b0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
59c0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 log-port* "Faile
59d0: 64 20 74 6f 20 66 69 6e 64 20 74 68 69 73 20 65 d to find this e
59e0: 78 65 63 75 74 61 62 6c 65 21 20 55 73 69 6e 67 xecutable! Using
59f0: 20 77 68 61 74 20 63 61 6e 20 62 65 20 66 6f 75 what can be fou
5a00: 6e 64 20 6f 6e 20 74 68 65 20 70 61 74 68 22 29 nd on the path")
5a10: 0a 09 20 20 70 72 6f 67 6e 61 6d 65 29 0a 09 28 .. progname)..(
5a20: 63 61 72 20 72 65 73 29 29 29 29 0a 0a 28 64 65 car res))))..(de
5a30: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 6e fine (common:gen
5a40: 65 72 69 63 2d 73 73 68 20 73 73 68 2d 63 6f 6d eric-ssh ssh-com
5a50: 6d 61 6e 64 20 70 72 6f 63 20 64 65 66 61 75 6c mand proc defaul
5a60: 74 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 6d 73 t #!optional (ms
5a70: 67 2d 70 72 6f 63 20 23 66 29 29 0a 20 20 28 6c g-proc #f)). (l
5a80: 65 74 20 28 28 69 6e 70 20 23 66 29 29 0a 20 20 et ((inp #f)).
5a90: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
5aa0: 69 6f 6e 73 0a 09 65 78 6e 0a 20 20 20 20 20 20 ions..exn.
5ab0: 28 62 65 67 69 6e 0a 09 28 63 6c 6f 73 65 2d 69 (begin..(close-i
5ac0: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 nput-port inp)..
5ad0: 28 69 66 20 6d 73 67 2d 70 72 6f 63 0a 09 20 20 (if msg-proc..
5ae0: 20 20 28 6d 73 67 2d 70 72 6f 63 29 0a 09 20 20 (msg-proc)..
5af0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5b00: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5b10: 72 74 2a 20 22 43 6f 6d 6d 61 6e 64 3a 20 5c 22 rt* "Command: \"
5b20: 22 73 73 68 2d 63 6f 6d 6d 61 6e 64 22 5c 22 20 "ssh-command"\"
5b30: 66 61 69 6c 65 64 2e 20 65 78 6e 3d 22 65 78 6e failed. exn="exn
5b40: 29 29 0a 09 64 65 66 61 75 6c 74 29 0a 20 20 20 ))..default).
5b50: 20 20 20 28 73 65 74 21 20 69 6e 70 20 28 6f 70 (set! inp (op
5b60: 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 73 73 en-input-pipe ss
5b70: 68 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 h-command)).
5b80: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
5b90: 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 09 28 6c 61 om-port inp..(la
5ba0: 6d 62 64 61 20 28 29 0a 09 20 20 28 6c 65 74 20 mbda ().. (let
5bb0: 28 28 72 65 73 20 28 70 72 6f 63 29 29 29 0a 09 ((res (proc)))..
5bc0: 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 (close-input
5bd0: 2d 70 6f 72 74 20 69 6e 70 29 0a 09 20 20 20 20 -port inp)..
5be0: 72 65 73 29 29 29 29 29 29 0a 0a 3b 3b 20 74 68 res))))))..;; th
5bf0: 69 73 20 69 73 20 61 20 63 6c 6f 73 65 20 64 75 is is a close du
5c00: 70 6c 69 63 61 74 65 20 6f 66 3a 0a 3b 3b 20 20 plicate of:.;;
5c10: 20 20 70 72 6f 63 65 73 73 3a 61 6c 69 73 74 2d process:alist-
5c20: 6f 6e 2d 68 6f 73 74 3f 0a 3b 3b 20 20 20 20 70 on-host?.;; p
5c30: 72 6f 63 65 73 73 3a 61 6c 69 76 65 0a 3b 3b 0a rocess:alive.;;.
5c40: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 6d (define (commonm
5c50: 6f 64 3a 69 73 2d 74 65 73 74 2d 61 6c 69 76 65 od:is-test-alive
5c60: 20 68 6f 73 74 20 70 69 64 29 0a 20 20 28 6c 65 host pid). (le
5c70: 74 2a 20 28 28 73 61 6d 65 2d 68 6f 73 74 20 28 t* ((same-host (
5c80: 65 71 75 61 6c 3f 20 68 6f 73 74 20 28 67 65 74 equal? host (get
5c90: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 -host-name)))..
5ca0: 28 63 6d 64 20 28 63 6f 6e 63 20 0a 09 20 20 20 (cmd (conc ..
5cb0: 20 20 20 20 28 69 66 20 73 61 6d 65 2d 68 6f 73 (if same-hos
5cc0: 74 20 22 22 20 28 63 6f 6e 63 20 22 73 73 68 20 t "" (conc "ssh
5cd0: 22 68 6f 73 74 22 20 22 29 29 0a 09 20 20 20 20 "host" "))..
5ce0: 20 20 20 22 70 73 74 72 65 65 20 2d 41 20 22 70 "pstree -A "p
5cf0: 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 id))). (if (a
5d00: 6e 64 20 68 6f 73 74 20 70 69 64 0a 09 20 20 20 nd host pid..
5d10: 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 68 (not (equal? h
5d20: 6f 73 74 20 22 6e 2f 61 22 29 29 29 0a 09 0a 09 ost "n/a")))....
5d30: 28 6c 65 74 2a 20 28 28 6f 75 74 70 75 74 20 28 (let* ((output (
5d40: 69 66 20 73 61 6d 65 2d 68 6f 73 74 0a 09 09 09 if same-host....
5d50: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
5d60: 72 6f 6d 2d 70 69 70 65 20 63 6d 64 20 72 65 61 rom-pipe cmd rea
5d70: 64 2d 6c 69 6e 65 73 29 0a 09 09 09 20 20 20 28 d-lines).... (
5d80: 63 6f 6d 6d 6f 6e 3a 67 65 6e 65 72 69 63 2d 73 common:generic-s
5d90: 73 68 20 63 6d 64 20 72 65 61 64 2d 6c 69 6e 65 sh cmd read-line
5da0: 73 20 27 28 29 29 29 29 29 20 3b 3b 20 28 77 69 s '())))) ;; (wi
5db0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
5dc0: 70 65 20 63 6d 64 20 72 65 61 64 2d 6c 69 6e 65 pe cmd read-line
5dd0: 73 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 s))).. (debug:p
5de0: 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d rint 2 *default-
5df0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e 6e 69 log-port* "Runni
5e00: 6e 67 20 22 20 63 6d 64 20 22 20 72 65 63 65 69 ng " cmd " recei
5e10: 76 65 64 20 22 20 6f 75 74 70 75 74 29 0a 09 20 ved " output)..
5e20: 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 (if (eq? (lengt
5e30: 68 20 6f 75 74 70 75 74 29 20 30 29 0a 09 20 20 h output) 0)..
5e40: 20 20 20 20 23 66 0a 09 20 20 20 20 20 20 23 74 #f.. #t
5e50: 29 29 0a 09 23 74 29 29 29 20 3b 3b 20 61 73 73 ))..#t))) ;; ass
5e60: 75 6d 69 6e 67 20 62 61 64 20 71 75 65 72 79 20 uming bad query
5e70: 69 73 20 61 62 6f 75 74 20 61 20 6c 69 76 65 20 is about a live
5e80: 74 65 73 74 20 69 73 20 6c 69 6b 65 6c 79 20 6e test is likely n
5e90: 6f 74 20 74 68 65 20 72 69 67 68 74 20 74 68 69 ot the right thi
5ea0: 6e 67 20 74 6f 20 64 6f 3f 0a 0a 0a 29 0a ng to do?...).