Artifact
5b21746964003fe3bbb5af4c67b1b1c3e08c1f70:
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 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ====..;;========
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
03d0: 3b 20 43 70 75 6d 6f 64 3a 0a 3b 3b 0a 3b 3b 20 ; Cpumod:.;;.;;
03e0: 20 20 50 75 74 20 74 68 69 6e 67 73 20 68 65 72 Put things her
03f0: 65 20 64 6f 6e 27 74 20 66 69 74 20 61 6e 79 77 e don't fit anyw
0400: 68 65 72 65 20 65 6c 73 65 0a 3b 3b 3d 3d 3d 3d here else.;;====
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0450: 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e ==..(declare (un
0460: 69 74 20 61 72 63 68 69 76 65 6d 6f 64 29 29 0a it archivemod)).
0470: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0480: 64 65 62 75 67 70 72 69 6e 74 29 29 0a 28 64 65 debugprint)).(de
0490: 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 61 72 clare (uses mtar
04a0: 67 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 gs)).(declare (u
04b0: 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a ses commonmod)).
04c0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 (declare (uses c
04d0: 6f 6e 66 69 67 66 6d 6f 64 29 29 0a 28 64 65 63 onfigfmod)).(dec
04e0: 6c 61 72 65 20 28 75 73 65 73 20 66 73 6d 6f 64 lare (uses fsmod
04f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0500: 73 20 70 72 6f 63 65 73 73 6d 6f 64 29 29 0a 28 s processmod)).(
0510: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 declare (uses mt
0520: 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mod)).(declare (
0530: 75 73 65 73 20 64 62 6d 6f 64 29 29 0a 28 64 65 uses dbmod)).(de
0540: 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 66 69 clare (uses dbfi
0550: 6c 65 29 29 0a 0a 28 75 73 65 20 73 72 66 69 2d le))..(use srfi-
0560: 36 39 29 0a 0a 28 6d 6f 64 75 6c 65 20 61 72 63 69)..(module arc
0570: 68 69 76 65 6d 6f 64 0a 09 28 0a 09 20 61 72 63 hivemod..(.. arc
0580: 68 69 76 65 3a 67 65 74 2d 61 72 63 68 69 76 65 hive:get-archive
0590: 2d 64 69 73 6b 73 0a 09 20 61 72 63 68 69 76 65 -disks.. archive
05a0: 3a 61 6c 6c 6f 63 61 74 65 2d 6e 65 77 2d 61 72 :allocate-new-ar
05b0: 63 68 69 76 65 2d 62 6c 6f 63 6b 0a 09 20 61 72 chive-block.. ar
05c0: 63 68 69 76 65 3a 67 65 74 2d 74 69 6d 65 73 74 chive:get-timest
05d0: 61 6d 70 2d 64 69 72 0a 09 20 61 72 63 68 69 76 amp-dir.. archiv
05e0: 65 3a 6d 65 67 61 74 65 73 74 2d 64 62 0a 09 20 e:megatest-db..
05f0: 61 72 63 68 69 76 65 3a 62 75 70 2d 67 65 74 2d archive:bup-get-
0600: 64 61 74 61 0a 0a 0a 09 20 29 0a 0a 28 69 6d 70 data.... )..(imp
0610: 6f 72 74 20 73 63 68 65 6d 65 29 0a 28 63 6f 6e ort scheme).(con
0620: 64 2d 65 78 70 61 6e 64 0a 20 28 63 68 69 63 6b d-expand. (chick
0630: 65 6e 2d 34 0a 20 20 0a 20 20 28 69 6d 70 6f 72 en-4. . (impor
0640: 74 20 63 68 69 63 6b 65 6e 0a 09 20 20 70 6f 72 t chicken.. por
0650: 74 73 0a 09 20 20 28 70 72 65 66 69 78 20 62 61 ts.. (prefix ba
0660: 73 65 36 34 20 62 61 73 65 36 34 3a 29 0a 0a 09 se64 base64:)...
0670: 20 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 (prefix sqlite
0680: 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 20 20 64 3 sqlite3:).. d
0690: 61 74 61 2d 73 74 72 75 63 74 75 72 65 73 0a 09 ata-structures..
06a0: 20 20 65 78 74 72 61 73 0a 09 20 20 66 69 6c 65 extras.. file
06b0: 73 0a 09 20 20 6d 61 74 63 68 61 62 6c 65 0a 09 s.. matchable..
06c0: 20 20 6d 64 35 0a 09 20 20 6d 65 73 73 61 67 65 md5.. message
06d0: 2d 64 69 67 65 73 74 0a 09 20 20 70 61 74 68 6e -digest.. pathn
06e0: 61 6d 65 2d 65 78 70 61 6e 64 0a 09 20 20 70 6f ame-expand.. po
06f0: 73 69 78 0a 09 20 20 70 6f 73 69 78 2d 65 78 74 six.. posix-ext
0700: 72 61 73 0a 09 20 20 0a 09 20 20 64 65 62 75 67 ras.. .. debug
0710: 70 72 69 6e 74 0a 09 20 20 28 70 72 65 66 69 78 print.. (prefix
0720: 20 6d 74 61 72 67 73 20 61 72 67 73 3a 29 0a 09 mtargs args:)..
0730: 20 20 29 0a 20 20 28 75 73 65 20 73 72 66 69 2d ). (use srfi-
0740: 36 39 29 29 0a 20 28 63 68 69 63 6b 65 6e 2d 35 69)). (chicken-5
0750: 0a 20 20 28 69 6d 70 6f 72 74 20 28 70 72 65 66 . (import (pref
0760: 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 ix sqlite3 sqlit
0770: 65 33 3a 29 0a 09 20 20 3b 3b 20 64 61 74 61 2d e3:).. ;; data-
0780: 73 74 72 75 63 74 75 72 65 73 0a 09 20 20 3b 3b structures.. ;;
0790: 20 65 78 74 72 61 73 0a 09 20 20 3b 3b 20 66 69 extras.. ;; fi
07a0: 6c 65 73 0a 09 20 20 3b 3b 20 70 6f 73 69 78 0a les.. ;; posix.
07b0: 09 20 20 3b 3b 20 70 6f 73 69 78 2d 65 78 74 72 . ;; posix-extr
07c0: 61 73 0a 09 20 20 63 68 69 63 6b 65 6e 2e 62 61 as.. chicken.ba
07d0: 73 65 0a 09 20 20 63 68 69 63 6b 65 6e 2e 63 6f se.. chicken.co
07e0: 6e 64 69 74 69 6f 6e 0a 09 20 20 63 68 69 63 6b ndition.. chick
07f0: 65 6e 2e 66 69 6c 65 0a 09 20 20 63 68 69 63 6b en.file.. chick
0800: 65 6e 2e 66 69 6c 65 2e 70 6f 73 69 78 0a 09 20 en.file.posix..
0810: 20 63 68 69 63 6b 65 6e 2e 69 6f 0a 09 20 20 63 chicken.io.. c
0820: 68 69 63 6b 65 6e 2e 70 61 74 68 6e 61 6d 65 0a hicken.pathname.
0830: 09 20 20 63 68 69 63 6b 65 6e 2e 70 6f 72 74 0a . chicken.port.
0840: 09 20 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 . chicken.proce
0850: 73 73 0a 09 20 20 63 68 69 63 6b 65 6e 2e 70 72 ss.. chicken.pr
0860: 6f 63 65 73 73 2d 63 6f 6e 74 65 78 74 0a 09 20 ocess-context..
0870: 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 chicken.process
0880: 2d 63 6f 6e 74 65 78 74 2e 70 6f 73 69 78 0a 09 -context.posix..
0890: 20 20 63 68 69 63 6b 65 6e 2e 73 6f 72 74 0a 09 chicken.sort..
08a0: 20 20 63 68 69 63 6b 65 6e 2e 73 74 72 69 6e 67 chicken.string
08b0: 0a 09 20 20 63 68 69 63 6b 65 6e 2e 74 69 6d 65 .. chicken.time
08c0: 0a 09 20 20 63 68 69 63 6b 65 6e 2e 74 69 6d 65 .. chicken.time
08d0: 2e 70 6f 73 69 78 0a 09 20 20 0a 09 20 20 6d 61 .posix.. .. ma
08e0: 74 63 68 61 62 6c 65 0a 09 20 20 6d 64 35 0a 09 tchable.. md5..
08f0: 20 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 message-digest
0900: 0a 09 20 20 70 61 74 68 6e 61 6d 65 2d 65 78 70 .. pathname-exp
0910: 61 6e 64 0a 09 20 20 72 65 67 65 78 0a 09 20 20 and.. regex..
0920: 72 65 67 65 78 2d 63 61 73 65 0a 09 20 20 73 72 regex-case.. sr
0930: 66 69 2d 31 0a 09 20 20 73 72 66 69 2d 31 38 0a fi-1.. srfi-18.
0940: 09 20 20 73 72 66 69 2d 36 39 0a 09 20 20 74 79 . srfi-69.. ty
0950: 70 65 64 2d 72 65 63 6f 72 64 73 0a 09 20 20 73 ped-records.. s
0960: 79 73 74 65 6d 2d 69 6e 66 6f 72 6d 61 74 69 6f ystem-informatio
0970: 6e 0a 0a 09 20 20 64 65 62 75 67 70 72 69 6e 74 n... debugprint
0980: 0a 09 20 20 0a 20 20 29 29 29 0a 28 69 6d 70 6f .. . ))).(impo
0990: 72 74 20 64 65 62 75 67 70 72 69 6e 74 0a 09 63 rt debugprint..c
09a0: 6f 6d 6d 6f 6e 6d 6f 64 0a 09 63 6f 6e 66 69 67 ommonmod..config
09b0: 66 6d 6f 64 0a 09 66 73 6d 6f 64 0a 09 72 6d 74 fmod..fsmod..rmt
09c0: 6d 6f 64 0a 09 70 72 6f 63 65 73 73 6d 6f 64 0a mod..processmod.
09d0: 09 6d 74 6d 6f 64 0a 09 64 62 6d 6f 64 0a 09 64 .mtmod..dbmod..d
09e0: 62 66 69 6c 65 0a 09 28 70 72 65 66 69 78 20 6d bfile..(prefix m
09f0: 74 61 72 67 73 20 61 72 67 73 3a 29 0a 0a 09 72 targs args:)...r
0a00: 65 67 65 78 0a 09 72 65 67 65 78 2d 63 61 73 65 egex..regex-case
0a10: 0a 09 73 70 61 72 73 65 2d 76 65 63 74 6f 72 73 ..sparse-vectors
0a20: 0a 09 73 72 66 69 2d 31 0a 09 73 72 66 69 2d 31 ..srfi-1..srfi-1
0a30: 33 0a 09 73 72 66 69 2d 31 38 0a 09 73 72 66 69 3..srfi-18..srfi
0a40: 2d 36 39 0a 09 74 79 70 65 64 2d 72 65 63 6f 72 -69..typed-recor
0a50: 64 73 0a 09 7a 33 0a 09 29 0a 09 0a 3b 3b 20 28 ds..z3..)...;; (
0a60: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0a70: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 3b 3b records.scm").;;
0a80: 20 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 (include "db_re
0a90: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 3d cords.scm")..;;=
0aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ae0: 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 3d 3d 3d 3d =====.;; .;;====
0af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b30: 3d 3d 0a 0a 3b 3b 20 3b 3b 20 4e 4f 54 20 43 55 ==..;; ;; NOT CU
0b40: 52 52 45 4e 54 4c 59 20 55 53 45 44 0a 3b 3b 20 RRENTLY USED.;;
0b50: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 61 ;;.;; (define (a
0b60: 72 63 68 69 76 65 3a 6d 61 69 6e 20 6c 69 6e 6b rchive:main link
0b70: 74 72 65 65 20 74 61 72 67 65 74 20 72 75 6e 6e tree target runn
0b80: 61 6d 65 20 74 65 73 74 6e 61 6d 65 20 69 74 65 ame testname ite
0b90: 6d 70 61 74 68 20 6f 70 74 69 6f 6e 73 29 0a 3b mpath options).;
0ba0: 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 64 ; (let ((testd
0bb0: 69 72 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 ir (conc linktre
0bc0: 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 2f 22 e "/" target "/"
0bd0: 20 72 75 6e 6e 61 6d 65 20 22 2f 22 20 74 65 73 runname "/" tes
0be0: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 tname "/" itempa
0bf0: 74 74 29 29 0a 3b 3b 20 09 28 66 6c 61 76 6f 72 tt)).;; .(flavor
0c00: 20 20 27 70 6c 61 69 6e 29 20 3b 3b 20 74 79 70 'plain) ;; typ
0c10: 65 20 6f 66 20 6d 61 63 68 69 6e 65 20 74 6f 20 e of machine to
0c20: 72 75 6e 20 6a 6f 62 73 20 6f 6e 0a 3b 3b 20 09 run jobs on.;; .
0c30: 28 6d 61 78 6c 6f 61 64 20 31 2e 35 29 20 20 20 (maxload 1.5)
0c40: 3b 3b 20 6d 61 78 20 61 6c 6c 6f 77 65 64 20 6c ;; max allowed l
0c50: 6f 61 64 20 66 6f 72 20 74 68 69 73 20 77 6f 72 oad for this wor
0c60: 6b 0a 3b 3b 20 09 28 61 64 69 73 6b 73 20 20 28 k.;; .(adisks (
0c70: 61 72 63 68 69 76 65 3a 67 65 74 2d 61 72 63 68 archive:get-arch
0c80: 69 76 65 2d 64 69 73 6b 73 29 29 29 0a 3b 3b 20 ive-disks))).;;
0c90: 20 20 20 20 3b 3b 20 67 65 74 20 74 65 73 74 64 ;; get testd
0ca0: 69 72 20 73 69 7a 65 0a 3b 3b 20 20 20 20 20 3b ir size.;; ;
0cb0: 3b 20 20 20 2d 20 68 61 6e 64 20 6f 66 66 20 64 ; - hand off d
0cc0: 75 20 74 6f 20 6a 6f 62 20 6d 67 72 0a 3b 3b 20 u to job mgr.;;
0cd0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 63 6f (if (and (co
0ce0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
0cf0: 3f 20 74 65 73 74 64 69 72 29 0a 3b 3b 20 09 20 ? testdir).;; .
0d00: 20 20 20 20 28 66 69 6c 65 2d 69 73 2d 77 72 69 (file-is-wri
0d10: 74 61 62 6c 65 3f 20 74 65 73 74 64 69 72 29 29 table? testdir))
0d20: 0a 3b 3b 20 09 28 6c 65 74 2a 20 28 28 64 75 73 .;; .(let* ((dus
0d30: 65 64 20 20 28 6a 6f 62 72 75 6e 6e 65 72 3a 72 ed (jobrunner:r
0d40: 75 6e 2d 6a 6f 62 20 0a 3b 3b 20 09 09 09 66 6c un-job .;; ...fl
0d50: 61 76 6f 72 20 20 3b 3b 20 6d 61 63 68 69 6e 65 avor ;; machine
0d60: 20 74 79 70 65 0a 3b 3b 20 09 09 09 6d 61 78 6c type.;; ...maxl
0d70: 6f 61 64 20 3b 3b 20 6d 61 78 20 61 6c 6c 6f 77 oad ;; max allow
0d80: 65 64 20 6c 6f 61 64 0a 3b 3b 20 09 09 09 27 28 ed load.;; ...'(
0d90: 29 20 20 20 20 20 3b 3b 20 70 72 65 76 61 72 73 ) ;; prevars
0da0: 20 2d 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 - environment v
0db0: 61 72 73 20 74 6f 20 73 65 74 20 66 6f 72 20 74 ars to set for t
0dc0: 68 65 20 6a 6f 62 0a 3b 3b 20 09 09 09 63 6f 6d he job.;; ...com
0dd0: 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d 73 70 61 mon:get-disk-spa
0de0: 63 65 2d 75 73 65 64 20 20 3b 3b 20 69 66 20 61 ce-used ;; if a
0df0: 20 70 72 6f 63 20 63 61 6c 6c 20 69 74 2c 20 69 proc call it, i
0e00: 66 20 61 20 73 74 72 69 6e 67 20 69 74 20 69 73 f a string it is
0e10: 20 61 20 75 6e 69 78 20 63 6f 6d 6d 61 6e 64 0a a unix command.
0e20: 3b 3b 20 09 09 09 28 6c 69 73 74 20 74 65 73 74 ;; ...(list test
0e30: 64 69 72 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 dir))).;; .
0e40: 20 20 28 61 70 61 74 68 20 20 28 61 72 63 68 69 (apath (archi
0e50: 76 65 3a 67 65 74 2d 61 72 63 68 69 76 65 20 74 ve:get-archive t
0e60: 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 estname itempath
0e70: 20 64 75 73 65 64 29 29 29 0a 3b 3b 20 09 20 20 dused))).;; .
0e80: 28 6a 6f 62 72 75 6e 6e 65 72 3a 72 75 6e 2d 6a (jobrunner:run-j
0e90: 6f 62 0a 3b 3b 20 09 20 20 20 66 6c 61 76 6f 72 ob.;; . flavor
0ea0: 0a 3b 3b 20 09 20 20 20 6d 61 78 6c 6f 61 64 0a .;; . maxload.
0eb0: 3b 3b 20 09 20 20 20 27 28 29 0a 3b 3b 20 09 20 ;; . '().;; .
0ec0: 20 20 61 72 63 68 69 76 65 3a 72 75 6e 2d 62 75 archive:run-bu
0ed0: 70 0a 3b 3b 20 09 20 20 20 28 6c 69 73 74 20 74 p.;; . (list t
0ee0: 65 73 74 64 69 72 20 61 70 61 74 68 29 29 29 29 estdir apath))))
0ef0: 29 29 0a 09 20 20 0a 3b 3b 20 47 65 74 20 61 72 )).. .;; Get ar
0f00: 63 68 69 76 65 20 64 69 73 6b 73 20 66 72 6f 6d chive disks from
0f10: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
0f20: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 61 72 63 .;;.(define (arc
0f30: 68 69 76 65 3a 67 65 74 2d 61 72 63 68 69 76 65 hive:get-archive
0f40: 2d 64 69 73 6b 73 29 0a 20 20 28 6c 65 74 20 28 -disks). (let (
0f50: 28 73 65 63 74 69 6f 6e 20 28 63 6f 6e 66 69 67 (section (config
0f60: 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 2a 63 f:get-section *c
0f70: 6f 6e 66 69 67 64 61 74 2a 20 22 61 72 63 68 69 onfigdat* "archi
0f80: 76 65 2d 64 69 73 6b 73 22 29 29 29 0a 20 20 20 ve-disks"))).
0f90: 20 28 69 66 20 73 65 63 74 69 6f 6e 0a 09 73 65 (if section..se
0fa0: 63 74 69 6f 6e 0a 09 27 28 29 29 29 29 0a 0a 3b ction..'())))..;
0fb0: 3b 20 6c 6f 6f 6b 20 66 6f 72 20 74 68 65 20 62 ; look for the b
0fc0: 65 73 74 20 63 61 6e 64 69 64 61 74 65 20 61 72 est candidate ar
0fd0: 63 68 69 76 65 20 61 72 65 61 2c 20 65 6c 73 65 chive area, else
0fe0: 20 63 72 65 61 74 65 20 6e 65 77 20 0a 3b 3b 20 create new .;;
0ff0: 61 72 65 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 area.;;.(define
1000: 28 61 72 63 68 69 76 65 3a 67 65 74 2d 61 72 63 (archive:get-arc
1010: 68 69 76 65 20 74 65 73 74 6e 61 6d 65 20 69 74 hive testname it
1020: 65 6d 70 61 74 68 20 64 75 73 65 64 29 0a 20 20 empath dused).
1030: 3b 3b 20 6c 6f 6f 6b 20 75 70 20 69 6e 20 61 72 ;; look up in ar
1040: 63 68 69 76 65 5f 61 6c 6c 6f 63 61 74 69 6f 6e chive_allocation
1050: 73 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 s if there is a
1060: 70 72 65 2d 75 73 65 64 20 61 72 63 68 69 76 65 pre-used archive
1070: 0a 20 20 3b 3b 20 77 69 74 68 20 61 64 65 71 75 . ;; with adequ
1080: 61 74 65 20 64 69 73 6b 73 70 61 63 65 0a 20 20 ate diskspace.
1090: 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 65 78 69 ;;. (let* ((exi
10a0: 73 74 69 6e 67 2d 62 6c 6f 63 6b 73 20 28 72 6d sting-blocks (rm
10b0: 74 3a 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c t:archive-get-al
10c0: 6c 6f 63 61 74 69 6f 6e 73 20 74 65 73 74 6e 61 locations testna
10d0: 6d 65 20 69 74 65 6d 70 61 74 68 20 64 75 73 65 me itempath duse
10e0: 64 29 29 0a 09 20 28 63 61 6e 64 69 64 61 74 65 d)).. (candidate
10f0: 2d 64 69 73 6b 73 20 28 6d 61 70 20 28 6c 61 6d -disks (map (lam
1100: 62 64 61 20 28 62 6c 6f 63 6b 29 0a 09 09 09 09 bda (block).....
1110: 20 28 6c 69 73 74 0a 09 09 09 09 20 20 28 76 65 (list..... (ve
1120: 63 74 6f 72 2d 72 65 66 20 62 6c 6f 63 6b 20 31 ctor-ref block 1
1130: 29 20 20 20 3b 3b 20 61 72 63 68 69 76 65 2d 61 ) ;; archive-a
1140: 72 65 61 2d 6e 61 6d 65 0a 09 09 09 09 20 20 28 rea-name..... (
1150: 76 65 63 74 6f 72 2d 72 65 66 20 62 6c 6f 63 6b vector-ref block
1160: 20 32 29 29 29 20 3b 3b 20 64 69 73 6b 2d 70 61 2))) ;; disk-pa
1170: 74 68 0a 09 09 09 20 20 20 20 20 20 20 65 78 69 th.... exi
1180: 73 74 69 6e 67 2d 62 6c 6f 63 6b 73 29 29 29 0a sting-blocks))).
1190: 20 20 20 20 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a (or (common:
11a0: 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f get-disk-with-mo
11b0: 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 63 61 st-free-space ca
11c0: 6e 64 69 64 61 74 65 2d 64 69 73 6b 73 20 64 75 ndidate-disks du
11d0: 73 65 64 29 0a 09 28 61 72 63 68 69 76 65 3a 61 sed)..(archive:a
11e0: 6c 6c 6f 63 61 74 65 2d 6e 65 77 2d 61 72 63 68 llocate-new-arch
11f0: 69 76 65 2d 62 6c 6f 63 6b 20 23 66 20 23 66 20 ive-block #f #f
1200: 23 66 29 29 29 29 20 3b 3b 20 42 52 4f 4b 45 4e #f)))) ;; BROKEN
1210: 2e 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 . testname itemp
1220: 61 74 68 29 29 29 29 0a 0a 3b 3b 20 61 6c 6c 6f ath))))..;; allo
1230: 63 61 74 65 20 61 20 6e 65 77 20 61 72 63 68 69 cate a new archi
1240: 76 65 20 61 72 65 61 0a 3b 3b 0a 28 64 65 66 69 ve area.;;.(defi
1250: 6e 65 20 28 61 72 63 68 69 76 65 3a 61 6c 6c 6f ne (archive:allo
1260: 63 61 74 65 2d 6e 65 77 2d 61 72 63 68 69 76 65 cate-new-archive
1270: 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 69 64 2d 63 -block blockid-c
1280: 61 63 68 65 20 72 75 6e 2d 61 72 65 61 2d 68 6f ache run-area-ho
1290: 6d 65 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d me testsuite-nam
12a0: 65 20 64 6e 65 65 64 65 64 20 74 61 72 67 65 74 e dneeded target
12b0: 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 6e run-name test-n
12c0: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 ame). (let ((ke
12d0: 79 20 28 63 6f 6e 63 20 74 65 73 74 73 75 69 74 y (conc testsuit
12e0: 65 2d 6e 61 6d 65 20 22 2f 22 20 74 61 72 67 65 e-name "/" targe
12f0: 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 t "/" run-name "
1300: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a /" test-name))).
1310: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
1320: 62 6c 65 2d 65 78 69 73 74 73 3f 20 62 6c 6f 63 ble-exists? bloc
1330: 6b 69 64 2d 63 61 63 68 65 20 6b 65 79 29 0a 09 kid-cache key)..
1340: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
1350: 62 6c 6f 63 6b 69 64 2d 63 61 63 68 65 20 6b 65 blockid-cache ke
1360: 79 29 0a 09 28 6c 65 74 2a 20 28 28 70 73 63 72 y)..(let* ((pscr
1370: 69 70 74 20 20 20 20 20 28 63 6f 6e 66 69 67 66 ipt (configf
1380: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
1390: 61 74 2a 20 22 61 72 63 68 69 76 65 22 20 22 70 at* "archive" "p
13a0: 61 74 68 73 63 72 69 70 74 22 29 29 0a 09 20 20 athscript"))..
13b0: 20 20 20 20 20 28 70 73 63 72 69 70 74 2d 63 6d (pscript-cm
13c0: 64 20 28 63 6f 6e 63 20 70 73 63 72 69 70 74 20 d (conc pscript
13d0: 22 20 22 20 74 65 73 74 73 75 69 74 65 2d 6e 61 " " testsuite-na
13e0: 6d 65 20 22 20 22 20 74 61 72 67 65 74 20 22 20 me " " target "
13f0: 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 22 20 74 " run-name " " t
1400: 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 est-name))..
1410: 20 20 20 28 61 70 61 74 68 20 20 20 20 20 20 20 (apath
1420: 28 69 66 20 70 73 63 72 69 70 74 0a 09 09 09 09 (if pscript.....
1430: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
1440: 6e 73 0a 09 09 09 09 20 65 78 6e 0a 09 09 09 09 ns..... exn.....
1450: 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 28 (begin..... (
1460: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1470: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1480: 20 22 45 52 52 4f 52 3a 20 73 63 72 69 70 74 20 "ERROR: script
1490: 5c 22 22 20 70 73 63 72 69 70 74 2d 63 6d 64 20 \"" pscript-cmd
14a0: 22 5c 22 20 66 61 69 6c 65 64 20 74 6f 20 72 75 "\" failed to ru
14b0: 6e 20 70 72 6f 70 65 72 6c 79 2e 20 65 78 6e 3d n properly. exn=
14c0: 22 20 65 78 6e 29 0a 09 09 09 09 20 20 20 28 65 " exn)..... (e
14d0: 78 69 74 20 31 29 29 0a 09 09 09 09 20 28 77 69 xit 1))..... (wi
14e0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
14f0: 70 65 0a 09 09 09 09 20 20 70 73 63 72 69 70 74 pe..... pscript
1500: 2d 63 6d 64 0a 09 09 09 09 20 20 72 65 61 64 2d -cmd..... read-
1510: 6c 69 6e 65 29 29 0a 09 09 09 09 23 66 29 29 20 line)).....#f))
1520: 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 75 ;; this is the u
1530: 73 65 72 2d 63 61 6c 63 75 6c 61 74 65 64 20 61 ser-calculated a
1540: 72 63 68 69 76 65 20 70 61 74 68 0a 09 20 20 20 rchive path..
1550: 20 20 20 20 28 61 64 69 73 6b 73 20 20 20 20 28 (adisks (
1560: 61 72 63 68 69 76 65 3a 67 65 74 2d 61 72 63 68 archive:get-arch
1570: 69 76 65 2d 64 69 73 6b 73 29 29 0a 09 20 20 20 ive-disks))..
1580: 20 20 20 20 28 62 65 73 74 2d 64 69 73 6b 20 28 (best-disk (
1590: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d common:get-disk-
15a0: 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 65 2d 73 with-most-free-s
15b0: 70 61 63 65 20 61 64 69 73 6b 73 20 64 6e 65 65 pace adisks dnee
15c0: 64 65 64 29 29 29 0a 09 20 20 28 69 66 20 62 65 ded))).. (if be
15d0: 73 74 2d 64 69 73 6b 0a 09 20 20 20 20 20 20 28 st-disk.. (
15e0: 6c 65 74 2a 20 28 28 62 64 69 73 6b 2d 6e 61 6d let* ((bdisk-nam
15f0: 65 20 20 20 20 28 63 61 72 20 62 65 73 74 2d 64 e (car best-d
1600: 69 73 6b 29 29 0a 09 09 20 20 20 20 20 28 62 64 isk))... (bd
1610: 69 73 6b 2d 70 61 74 68 20 20 20 20 28 63 64 72 isk-path (cdr
1620: 20 62 65 73 74 2d 64 69 73 6b 29 29 0a 09 09 20 best-disk))...
1630: 20 20 20 20 28 61 72 65 61 2d 6b 65 79 20 20 20 (area-key
1640: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 6d (substring (m
1650: 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 essage-digest-st
1660: 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 ring (md5-primit
1670: 69 76 65 29 20 72 75 6e 2d 61 72 65 61 2d 68 6f ive) run-area-ho
1680: 6d 65 29 20 30 20 35 29 29 0a 09 09 20 20 20 20 me) 0 5))...
1690: 20 28 62 64 69 73 6b 2d 69 64 20 20 20 20 20 20 (bdisk-id
16a0: 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 72 65 67 (rmt:archive-reg
16b0: 69 73 74 65 72 2d 64 69 73 6b 20 62 64 69 73 6b ister-disk bdisk
16c0: 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 70 61 74 68 -name bdisk-path
16d0: 20 28 67 65 74 2d 64 66 20 62 64 69 73 6b 2d 70 (get-df bdisk-p
16e0: 61 74 68 29 29 29 0a 09 09 20 20 20 20 20 28 61 ath)))... (a
16f0: 72 63 68 69 76 65 2d 6e 61 6d 65 20 20 28 69 66 rchive-name (if
1700: 20 61 70 61 74 68 0a 09 09 09 09 09 61 70 61 74 apath......apat
1710: 68 0a 09 09 09 09 09 28 6c 65 74 20 28 28 73 65 h......(let ((se
1720: 63 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e c (current-secon
1730: 64 73 29 29 29 0a 09 09 09 09 09 20 20 28 63 6f ds)))...... (co
1740: 6e 63 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 nc (time->string
1750: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
1760: 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 22 29 -time sec) "%Y")
1770: 0a 09 09 09 09 09 09 22 5f 71 22 20 28 73 65 63 ......."_q" (sec
1780: 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 73 65 onds->quarter se
1790: 63 29 20 22 2f 22 0a 09 09 09 09 09 09 74 65 73 c) "/".......tes
17a0: 74 73 75 69 74 65 2d 6e 61 6d 65 20 22 5f 22 20 tsuite-name "_"
17b0: 61 72 65 61 2d 6b 65 79 29 29 29 29 0a 09 09 20 area-key))))...
17c0: 20 20 20 20 28 61 72 63 68 69 76 65 2d 70 61 74 (archive-pat
17d0: 68 20 20 28 63 6f 6e 63 20 62 64 69 73 6b 2d 70 h (conc bdisk-p
17e0: 61 74 68 20 22 2f 22 20 61 72 63 68 69 76 65 2d ath "/" archive-
17f0: 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 20 28 62 name))... (b
1800: 6c 6f 63 6b 2d 69 64 20 20 20 20 20 20 28 72 6d lock-id (rm
1810: 74 3a 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 t:archive-regist
1820: 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 62 64 er-block-name bd
1830: 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 isk-id archive-p
1840: 61 74 68 29 29 29 0a 09 09 3b 3b 20 20 20 28 61 ath)))...;; (a
1850: 6c 6c 6f 63 61 74 69 6f 6e 2d 69 64 20 28 72 6d llocation-id (rm
1860: 74 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 t:archive-alloca
1870: 74 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 te-testsuite/are
1880: 61 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b a-to-block block
1890: 2d 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 -id testsuite-na
18a0: 6d 65 20 61 72 65 61 2d 6b 65 79 29 29 29 0a 09 me area-key)))..
18b0: 09 28 69 66 20 62 6c 6f 63 6b 2d 69 64 20 3b 3b .(if block-id ;;
18c0: 20 28 61 6e 64 20 62 6c 6f 63 6b 2d 69 64 20 61 (and block-id a
18d0: 6c 6c 6f 63 61 74 69 6f 6e 2d 69 64 29 0a 09 09 llocation-id)...
18e0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
18f0: 63 6f 6e 73 20 62 6c 6f 63 6b 2d 69 64 20 61 72 cons block-id ar
1900: 63 68 69 76 65 2d 70 61 74 68 29 29 29 0a 09 09 chive-path)))...
1910: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
1920: 65 2d 73 65 74 21 20 62 6c 6f 63 6b 69 64 2d 63 e-set! blockid-c
1930: 61 63 68 65 20 6b 65 79 20 72 65 73 29 0a 09 09 ache key res)...
1940: 20 20 20 20 20 20 72 65 73 29 0a 09 09 20 20 20 res)...
1950: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
1960: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1970: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1980: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 64 * "WARNING: no d
1990: 69 73 6b 20 66 6f 75 6e 64 20 66 6f 72 20 22 20 isk found for "
19a0: 74 61 72 67 65 74 20 22 2c 20 22 20 72 75 6e 2d target ", " run-
19b0: 6e 61 6d 65 20 22 2c 20 22 20 74 65 73 74 2d 6e name ", " test-n
19c0: 61 6d 65 20 22 2c 20 20 61 72 63 68 69 76 65 2d ame ", archive-
19d0: 70 61 74 68 3d 22 20 61 72 63 68 69 76 65 2d 70 path=" archive-p
19e0: 61 74 68 29 0a 09 09 20 20 20 20 20 20 23 66 29 ath)... #f)
19f0: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
1a00: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
1a10: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1a20: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e ort* "WARNING: n
1a30: 6f 20 64 69 73 6b 20 66 6f 75 6e 64 20 66 6f 72 o disk found for
1a40: 20 22 20 74 61 72 67 65 74 20 22 2c 20 22 20 72 " target ", " r
1a50: 75 6e 2d 6e 61 6d 65 20 22 2c 20 22 20 74 65 73 un-name ", " tes
1a60: 74 2d 6e 61 6d 65 20 29 0a 09 09 23 66 29 29 29 t-name )...#f)))
1a70: 29 29 29 20 3b 3b 20 6e 6f 20 62 65 73 74 20 64 ))) ;; no best d
1a80: 69 73 6b 20 66 6f 75 6e 64 0a 0a 0a 28 64 65 66 isk found...(def
1a90: 69 6e 65 20 28 61 72 63 68 69 76 65 3a 6d 65 67 ine (archive:meg
1aa0: 61 74 65 73 74 2d 64 62 20 74 61 72 67 65 74 2d atest-db target-
1ab0: 70 61 74 74 20 72 75 6e 2d 70 61 74 74 29 0a 20 patt run-patt).
1ac0: 28 6c 65 74 2a 20 28 28 62 6c 6f 63 6b 69 64 2d (let* ((blockid-
1ad0: 63 61 63 68 65 20 20 28 6d 61 6b 65 2d 68 61 73 cache (make-has
1ae0: 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 20 20 20 h-table)).
1af0: 20 20 28 74 73 6e 61 6d 65 20 20 20 20 20 20 20 (tsname
1b00: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 (common:get-te
1b10: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 20 stsuite-name)).
1b20: 20 20 20 20 20 20 20 28 6d 69 6e 2d 73 70 61 63 (min-spac
1b30: 65 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e e (string->
1b40: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
1b50: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
1b60: 69 67 64 61 74 2a 20 22 61 72 63 68 69 76 65 22 igdat* "archive"
1b70: 20 22 6d 69 6e 73 70 61 63 65 22 29 20 22 31 30 "minspace") "10
1b80: 30 30 22 29 29 29 0a 20 20 20 20 20 20 20 20 28 00"))). (
1b90: 62 75 70 2d 65 78 65 20 20 20 20 20 20 20 20 28 bup-exe (
1ba0: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
1bb0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
1bc0: 61 72 63 68 69 76 65 22 20 22 62 75 70 22 29 20 archive" "bup")
1bd0: 22 62 75 70 22 29 29 0a 09 28 63 6f 6d 70 72 65 "bup"))..(compre
1be0: 73 73 20 20 20 20 20 20 20 28 6f 72 20 28 63 6f ss (or (co
1bf0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
1c00: 6e 66 69 67 64 61 74 2a 20 22 61 72 63 68 69 76 nfigdat* "archiv
1c10: 65 22 20 22 63 6f 6d 70 72 65 73 73 22 29 20 22 e" "compress") "
1c20: 39 22 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 9")). (ar
1c30: 63 68 69 76 65 72 20 20 20 20 20 20 20 28 6c 65 chiver (le
1c40: 74 20 28 28 73 20 28 63 6f 6e 66 69 67 66 3a 6c t ((s (configf:l
1c50: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
1c60: 2a 20 22 61 72 63 68 69 76 65 22 20 22 61 72 63 * "archive" "arc
1c70: 68 69 76 65 72 22 29 29 29 0a 09 09 09 20 20 20 hiver")))....
1c80: 28 69 66 20 73 20 28 73 74 72 69 6e 67 2d 3e 73 (if s (string->s
1c90: 79 6d 62 6f 6c 20 73 29 20 27 62 75 70 29 29 29 ymbol s) 'bup)))
1ca0: 0a 20 20 20 20 20 20 20 20 28 72 73 79 6e 63 2d . (rsync-
1cb0: 65 78 65 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 exe (or (configf
1cc0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
1cd0: 61 74 2a 20 22 61 72 63 68 69 76 65 22 20 22 72 at* "archive" "r
1ce0: 73 79 6e 63 22 29 20 22 72 73 79 6e 63 22 29 29 sync") "rsync"))
1cf0: 20 20 20 0a 20 20 20 20 20 20 20 20 28 70 72 69 . (pri
1d00: 6e 74 2d 70 72 65 66 69 78 20 20 20 20 20 20 22 nt-prefix "
1d10: 52 75 6e 6e 69 6e 67 3a 20 22 29 20 0a 20 20 20 Running: ") .
1d20: 20 20 20 20 20 28 61 72 63 68 69 76 65 2d 69 6e (archive-in
1d30: 66 6f 20 28 61 72 63 68 69 76 65 3a 61 6c 6c 6f fo (archive:allo
1d40: 63 61 74 65 2d 6e 65 77 2d 61 72 63 68 69 76 65 cate-new-archive
1d50: 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 69 64 2d 63 -block blockid-c
1d60: 61 63 68 65 20 2a 74 6f 70 70 61 74 68 2a 20 74 ache *toppath* t
1d70: 73 6e 61 6d 65 20 6d 69 6e 2d 73 70 61 63 65 20 sname min-space
1d80: 74 61 72 67 65 74 2d 70 61 74 74 20 72 75 6e 2d target-patt run-
1d90: 70 61 74 74 20 22 6d 65 67 61 74 65 73 74 2d 64 patt "megatest-d
1da0: 62 22 29 29 0a 09 28 61 72 63 68 69 76 65 2d 64 b"))..(archive-d
1db0: 69 72 20 20 28 69 66 20 61 72 63 68 69 76 65 2d ir (if archive-
1dc0: 69 6e 66 6f 20 28 63 64 72 20 61 72 63 68 69 76 info (cdr archiv
1dd0: 65 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 28 61 e-info) #f))..(a
1de0: 72 63 68 69 76 65 2d 69 64 20 20 20 28 69 66 20 rchive-id (if
1df0: 61 72 63 68 69 76 65 2d 69 6e 66 6f 20 28 63 61 archive-info (ca
1e00: 72 20 61 72 63 68 69 76 65 2d 69 6e 66 6f 29 20 r archive-info)
1e10: 2d 31 29 29 0a 20 20 20 20 20 20 20 20 28 68 6f -1)). (ho
1e20: 6d 65 2d 68 6f 73 74 20 20 20 20 28 67 65 74 2d me-host (get-
1e30: 68 6f 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 46 host-name)) ;; F
1e40: 49 58 4d 45 21 20 28 73 65 72 76 65 72 3a 63 68 IXME! (server:ch
1e50: 6f 6f 73 65 2d 73 65 72 76 65 72 20 2a 74 6f 70 oose-server *top
1e60: 70 61 74 68 2a 20 27 68 6f 6d 65 68 6f 73 74 29 path* 'homehost)
1e70: 29 0a 20 20 20 20 20 20 20 20 28 61 72 63 68 69 ). (archi
1e80: 76 65 2d 74 69 6d 65 20 28 73 65 63 6f 6e 64 73 ve-time (seconds
1e90: 2d 3e 73 74 64 2d 74 69 6d 65 2d 73 74 72 20 28 ->std-time-str (
1ea0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
1eb0: 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 63 68 )). (arch
1ec0: 69 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 20 28 ive-staging-db (
1ed0: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
1ee0: 2f 2e 64 62 2d 73 6e 61 70 73 68 6f 74 2f 61 72 /.db-snapshot/ar
1ef0: 63 68 69 76 65 5f 22 20 61 72 63 68 69 76 65 2d chive_" archive-
1f00: 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 28 time)). (
1f10: 74 6d 70 2d 64 62 2d 70 61 74 68 20 28 63 6f 6e tmp-db-path (con
1f20: 63 20 28 64 62 66 69 6c 65 3a 6d 61 6b 65 2d 74 c (dbfile:make-t
1f30: 6d 70 64 69 72 2d 6e 61 6d 65 20 2a 74 6f 70 70 mpdir-name *topp
1f40: 61 74 68 2a 20 22 22 29 20 22 2f 6d 65 67 61 74 ath* "") "/megat
1f50: 65 73 74 2e 64 62 22 29 29 0a 20 20 20 20 20 20 est.db")).
1f60: 20 20 28 64 62 66 69 6c 65 20 20 20 20 20 20 20 (dbfile
1f70: 20 20 20 20 20 20 28 63 6f 6e 63 20 20 61 72 63 (conc arc
1f80: 68 69 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 20 hive-staging-db
1f90: 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 "/megatest.db"))
1fa0: 29 20 0a 20 20 20 20 20 20 20 20 28 63 72 65 61 ) . (crea
1fb0: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 61 72 63 te-directory arc
1fc0: 68 69 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 20 hive-staging-db
1fd0: 23 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 #t). (let
1fe0: 2d 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 -values (((pid-v
1ff0: 61 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 al exit-status e
2000: 78 69 74 2d 63 6f 64 65 29 20 28 72 75 6e 2d 6e xit-code) (run-n
2010: 2d 77 61 69 74 20 72 73 79 6e 63 2d 65 78 65 20 -wait rsync-exe
2020: 70 61 72 61 6d 73 3a 20 28 6c 69 73 74 20 22 2d params: (list "-
2030: 76 22 20 28 63 6f 6e 63 20 68 6f 6d 65 2d 68 6f v" (conc home-ho
2040: 73 74 20 22 3a 22 74 6d 70 2d 64 62 2d 70 61 74 st ":"tmp-db-pat
2050: 68 29 20 61 72 63 68 69 76 65 2d 73 74 61 67 69 h) archive-stagi
2060: 6e 67 2d 64 62 29 20 70 72 69 6e 74 2d 63 6d 64 ng-db) print-cmd
2070: 3a 20 70 72 69 6e 74 2d 70 72 65 66 69 78 29 29 : print-prefix))
2080: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
2090: 66 20 28 65 71 3f 20 65 78 69 74 2d 63 6f 64 65 f (eq? exit-code
20a0: 20 30 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 0) .
20b0: 20 20 20 20 20 28 63 61 73 65 20 61 72 63 68 69 (case archi
20c0: 76 65 72 0a 09 20 20 20 20 20 20 20 20 28 28 62 ver.. ((b
20d0: 75 70 29 20 3b 3b 20 41 72 63 68 69 76 65 20 75 up) ;; Archive u
20e0: 73 69 6e 67 20 62 75 70 0a 09 20 20 20 20 20 20 sing bup..
20f0: 20 20 20 20 28 6c 65 74 2a 20 28 28 62 75 70 2d (let* ((bup-
2100: 69 6e 69 74 2d 70 61 72 61 6d 73 20 20 28 6c 69 init-params (li
2110: 73 74 20 22 2d 64 22 20 61 72 63 68 69 76 65 2d st "-d" archive-
2120: 64 69 72 20 22 69 6e 69 74 22 29 29 0a 09 09 20 dir "init"))...
2130: 20 20 20 20 20 20 20 20 28 62 75 70 2d 69 6e 64 (bup-ind
2140: 65 78 2d 70 61 72 61 6d 73 20 28 6c 69 73 74 20 ex-params (list
2150: 22 2d 64 22 20 61 72 63 68 69 76 65 2d 64 69 72 "-d" archive-dir
2160: 20 22 69 6e 64 65 78 22 20 61 72 63 68 69 76 65 "index" archive
2170: 2d 73 74 61 67 69 6e 67 2d 64 62 29 29 0a 09 09 -staging-db))...
2180: 20 20 20 20 20 20 20 20 20 28 62 75 70 2d 73 61 (bup-sa
2190: 76 65 2d 70 61 72 61 6d 73 20 20 28 6c 69 73 74 ve-params (list
21a0: 20 22 2d 64 22 20 61 72 63 68 69 76 65 2d 64 69 "-d" archive-di
21b0: 72 20 22 73 61 76 65 22 20 3b 3b 20 28 63 6f 6e r "save" ;; (con
21c0: 63 20 22 2d 2d 73 74 72 69 70 2d 70 61 74 68 3d c "--strip-path=
21d0: 22 20 6c 69 6e 6b 74 72 65 65 29 0a 09 09 09 09 " linktree).....
21e0: 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2d 22 .. (conc "-"
21f0: 20 63 6f 6d 70 72 65 73 73 29 20 3b 3b 20 6f 72 compress) ;; or
2200: 20 28 63 6f 6e 63 20 22 2d 2d 63 6f 6d 70 72 65 (conc "--compre
2210: 73 73 3d 22 20 63 6f 6d 70 72 65 73 73 29 0a 09 ss=" compress)..
2220: 09 09 09 09 09 20 20 20 20 20 22 2d 6e 22 20 28 ..... "-n" (
2230: 63 6f 6e 63 20 74 73 6e 61 6d 65 20 22 2d 6d 65 conc tsname "-me
2240: 67 61 74 65 73 74 2d 64 62 22 20 29 0a 09 09 09 gatest-db" )....
2250: 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2d ... (conc "-
2260: 2d 73 74 72 69 70 2d 70 61 74 68 3d 22 20 61 72 -strip-path=" ar
2270: 63 68 69 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 chive-staging-db
2280: 20 29 20 3b 3b 20 69 66 20 77 65 20 70 75 73 68 ) ;; if we push
2290: 20 74 6f 20 74 68 65 20 64 69 72 65 63 74 6f 72 to the director
22a0: 79 20 64 6f 20 77 65 20 6e 65 65 64 20 74 68 69 y do we need thi
22b0: 73 3f 0a 09 09 09 09 09 09 20 20 20 20 20 64 62 s?....... db
22c0: 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 20 file))).
22d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
22e0: 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (not (common:fil
22f0: 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 e-exists? (conc
2300: 61 72 63 68 69 76 65 2d 64 69 72 20 22 2f 48 45 archive-dir "/HE
2310: 41 44 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 AD")))... (
2320: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 20 begin...
2330: 3b 3b 20 72 65 70 6c 61 63 65 20 74 68 69 73 20 ;; replace this
2340: 77 69 74 68 20 6a 6f 62 72 75 6e 6e 65 72 20 73 with jobrunner s
2350: 74 75 66 66 20 65 6e 76 65 6e 74 75 61 6c 6c 79 tuff enventually
2360: 0a 09 09 20 20 20 20 20 20 20 20 28 64 65 62 75 ... (debu
2370: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
2380: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2390: 2a 20 22 49 6e 69 74 20 62 75 70 20 69 6e 20 22 * "Init bup in "
23a0: 20 61 72 63 68 69 76 65 2d 64 69 72 29 0a 09 09 archive-dir)...
23b0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2d 76 61 (let-va
23c0: 6c 75 65 73 20 28 28 28 70 69 64 2d 76 61 6c 20 lues (((pid-val
23d0: 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 exit-status exit
23e0: 2d 63 6f 64 65 29 28 72 75 6e 2d 6e 2d 77 61 69 -code)(run-n-wai
23f0: 74 20 62 75 70 2d 65 78 65 20 70 61 72 61 6d 73 t bup-exe params
2400: 3a 20 62 75 70 2d 69 6e 69 74 2d 70 61 72 61 6d : bup-init-param
2410: 73 20 70 72 69 6e 74 2d 63 6d 64 3a 20 70 72 69 s print-cmd: pri
2420: 6e 74 2d 70 72 65 66 69 78 29 29 29 0a 20 20 20 nt-prefix))).
2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2440: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
2450: 28 65 71 3f 20 65 78 69 74 2d 63 6f 64 65 20 30 (eq? exit-code 0
2460: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2480: 20 28 62 65 67 69 6e 20 20 20 20 0a 20 20 20 20 (begin .
2490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24a0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
24b0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
24c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
24d0: 2a 20 22 54 68 65 72 65 20 77 61 73 20 61 6e 20 * "There was an
24e0: 65 72 72 6f 72 20 69 6e 69 74 69 61 6c 69 7a 69 error initializi
24f0: 6e 67 20 62 75 70 2e 20 41 72 63 68 69 76 65 20 ng bup. Archive
2500: 66 61 69 6c 65 64 2e 22 29 0a 20 20 20 20 20 20 failed.").
2510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2520: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
2530: 29 29 29 29 29 0a 09 09 20 20 20 20 20 28 64 65 )))))... (de
2540: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
2550: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2560: 72 74 2a 20 22 49 6e 64 65 78 69 6e 67 20 64 61 rt* "Indexing da
2570: 74 61 20 74 6f 20 62 65 20 61 72 63 68 69 76 65 ta to be archive
2580: 64 22 29 0a 09 09 20 20 20 20 20 28 6c 65 74 2d d")... (let-
2590: 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 61 values (((pid-va
25a0: 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 l exit-status ex
25b0: 69 74 2d 63 6f 64 65 29 20 28 72 75 6e 2d 6e 2d it-code) (run-n-
25c0: 77 61 69 74 20 62 75 70 2d 65 78 65 20 70 61 72 wait bup-exe par
25d0: 61 6d 73 3a 20 62 75 70 2d 69 6e 64 65 78 2d 70 ams: bup-index-p
25e0: 61 72 61 6d 73 20 70 72 69 6e 74 2d 63 6d 64 3a arams print-cmd:
25f0: 20 70 72 69 6e 74 2d 70 72 65 66 69 78 29 29 29 print-prefix)))
2600: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2610: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
2620: 74 20 28 65 71 3f 20 65 78 69 74 2d 63 6f 64 65 t (eq? exit-code
2630: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
2640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2650: 20 20 20 28 62 65 67 69 6e 20 20 20 20 0a 20 20 (begin .
2660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2670: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
2680: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
2690: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
26a0: 72 74 2a 20 22 54 68 65 72 65 20 77 61 73 20 61 rt* "There was a
26b0: 6e 20 65 72 72 6f 72 20 49 6e 64 65 78 69 6e 67 n error Indexing
26c0: 20 62 75 70 2e 20 41 72 63 68 69 76 65 20 66 61 bup. Archive fa
26d0: 69 6c 65 64 2e 22 29 0a 20 20 20 20 20 20 20 20 iled.").
26e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26f0: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
2700: 29 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a )... (debug:
2710: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
2720: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2730: 22 41 72 63 68 69 76 69 6e 67 20 64 61 74 61 20 "Archiving data
2740: 77 69 74 68 20 62 75 70 22 29 0a 09 09 20 20 20 with bup")...
2750: 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 (let-values ((
2760: 28 70 69 64 2d 76 61 6c 20 65 78 69 74 2d 73 74 (pid-val exit-st
2770: 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 20 atus exit-code)
2780: 28 72 75 6e 2d 6e 2d 77 61 69 74 20 62 75 70 2d (run-n-wait bup-
2790: 65 78 65 20 70 61 72 61 6d 73 3a 20 62 75 70 2d exe params: bup-
27a0: 73 61 76 65 2d 70 61 72 61 6d 73 20 70 72 69 6e save-params prin
27b0: 74 2d 63 6d 64 3a 20 70 72 69 6e 74 2d 70 72 65 t-cmd: print-pre
27c0: 66 69 78 29 29 29 0a 20 20 20 20 20 20 20 20 20 fix))).
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 78 (if (not (eq? ex
27f0: 69 74 2d 63 6f 64 65 20 30 29 29 0a 20 20 20 20 it-code 0)).
2800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2810: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
2820: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
2830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2840: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2850: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
2860: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 68 65 72 -log-port* "Ther
2870: 65 20 77 61 73 20 61 6e 20 65 72 72 6f 72 20 61 e was an error a
2880: 72 63 68 69 76 69 6e 67 20 64 61 74 61 20 77 69 rchiving data wi
2890: 74 68 20 62 75 70 2e 20 41 72 63 68 69 76 65 20 th bup. Archive
28a0: 66 61 69 6c 65 64 2e 22 29 0a 20 20 20 20 20 20 failed.").
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28c0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
28d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
28f0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2900: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2910: 70 6f 72 74 2a 20 22 54 6f 20 72 65 73 74 6f 72 port* "To restor
2920: 65 20 6d 65 67 61 74 65 73 74 2e 64 62 20 72 75 e megatest.db ru
2930: 6e 20 6d 65 67 61 74 65 73 74 20 2d 61 72 63 68 n megatest -arch
2940: 69 76 65 20 72 65 70 6c 69 63 61 63 74 65 2d 64 ive replicacte-d
2950: 62 20 2d 73 6f 75 72 63 65 20 61 72 63 68 69 76 b -source archiv
2960: 65 2d 64 69 72 20 2d 74 69 6d 65 2d 73 74 61 6d e-dir -time-stam
2970: 70 20 3c 74 73 3e 2e 20 43 75 72 72 65 6e 74 20 p <ts>. Current
2980: 74 69 6d 65 73 74 61 6d 70 3a 20 22 20 28 73 65 timestamp: " (se
2990: 63 6f 6e 64 73 2d 3e 73 74 64 2d 74 69 6d 65 2d conds->std-time-
29a0: 73 74 72 20 28 63 75 72 72 65 6e 74 2d 73 65 63 str (current-sec
29b0: 6f 6e 64 73 29 29 29 29 29 29 29 20 0a 20 20 20 onds))))))) .
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
29d0: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
29e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
29f0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
2a00: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 t-log-port* "No
2a10: 73 75 70 70 6f 72 74 20 66 6f 72 20 64 61 74 61 support for data
2a20: 62 73 65 20 61 72 63 68 69 76 69 6e 67 20 77 69 bse archiving wi
2a30: 74 68 20 22 20 61 72 63 68 69 76 65 72 29 29 29 th " archiver)))
2a40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2a50: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
2a60: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
2a70: 67 2d 70 6f 72 74 2a 20 22 54 68 65 72 65 20 77 g-port* "There w
2a80: 61 73 20 61 6e 20 65 72 72 6f 72 20 72 73 79 6e as an error rsyn
2a90: 63 69 6e 67 20 74 6d 70 20 64 61 74 61 62 61 73 cing tmp databas
2aa0: 65 22 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 e")))))..(define
2ab0: 20 28 61 72 63 68 69 76 65 3a 72 65 73 74 6f 72 (archive:restor
2ac0: 65 2d 64 62 20 61 72 63 68 69 76 65 2d 70 61 74 e-db archive-pat
2ad0: 68 20 74 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 h ts). (let* (
2ae0: 28 62 75 70 2d 65 78 65 20 20 20 20 20 20 20 20 (bup-exe
2af0: 20 20 20 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 (or (conf
2b00: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
2b10: 69 67 64 61 74 2a 20 22 61 72 63 68 69 76 65 22 igdat* "archive"
2b20: 20 22 62 75 70 22 29 20 22 62 75 70 22 29 29 0a "bup") "bup")).
2b30: 20 20 20 20 20 20 20 20 20 28 61 72 63 68 69 76 (archiv
2b40: 65 2d 69 6e 74 65 72 6e 61 6c 2d 70 61 74 68 20 e-internal-path
2b50: 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (conc (common:ge
2b60: 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 t-testsuite-name
2b70: 29 20 22 2d 6d 65 67 61 74 65 73 74 2d 64 62 2f ) "-megatest-db/
2b80: 22 20 74 73 20 22 2f 6d 65 67 61 74 65 73 74 2e " ts "/megatest.
2b90: 64 62 22 20 29 29 0a 20 20 20 20 20 20 20 20 20 db" )).
2ba0: 28 62 75 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 (bup-restore-par
2bb0: 61 6d 73 20 20 28 6c 69 73 74 20 22 2d 64 22 20 ams (list "-d"
2bc0: 61 72 63 68 69 76 65 2d 70 61 74 68 20 22 72 65 archive-path "re
2bd0: 73 74 6f 72 65 22 20 22 2d 43 22 20 2a 74 6f 70 store" "-C" *top
2be0: 70 61 74 68 2a 20 61 72 63 68 69 76 65 2d 69 6e path* archive-in
2bf0: 74 65 72 6e 61 6c 2d 70 61 74 68 29 29 29 0a 09 ternal-path)))..
2c00: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
2c10: 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
2c20: 6f 67 2d 70 6f 72 74 2a 20 22 52 65 73 74 6f 72 og-port* "Restor
2c30: 69 6e 67 20 61 72 63 68 69 76 65 64 20 64 61 74 ing archived dat
2c40: 61 20 74 6f 20 22 20 2a 74 6f 70 70 61 74 68 2a a to " *toppath*
2c50: 20 22 20 66 72 6f 6d 20 61 72 63 68 69 76 65 20 " from archive
2c60: 69 6e 20 22 20 61 72 63 68 69 76 65 2d 70 61 74 in " archive-pat
2c70: 68 20 22 20 2e 2e 2e 20 22 20 61 72 63 68 69 76 h " ... " archiv
2c80: 65 2d 69 6e 74 65 72 6e 61 6c 2d 70 61 74 68 29 e-internal-path)
2c90: 0a 09 09 20 28 72 75 6e 2d 6e 2d 77 61 69 74 20 ... (run-n-wait
2ca0: 62 75 70 2d 65 78 65 20 70 61 72 61 6d 73 3a 20 bup-exe params:
2cb0: 62 75 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 61 bup-restore-para
2cc0: 6d 73 20 70 72 69 6e 74 2d 63 6d 64 3a 20 22 52 ms print-cmd: "R
2cd0: 75 6e 6e 69 6e 67 3a 22 29 29 0a 20 20 20 20 20 unning:")).
2ce0: 20 28 73 6c 65 65 70 20 32 29 0a 20 20 20 20 20 (sleep 2).
2cf0: 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 (db:multi-db-sy
2d00: 6e 63 20 0a 20 20 20 20 20 20 20 28 64 62 3a 73 nc . (db:s
2d10: 65 74 75 70 29 20 3b 3b 20 28 64 62 3a 73 65 74 etup) ;; (db:set
2d20: 75 70 2d 64 62 20 2a 64 62 73 74 72 75 63 74 2d up-db *dbstruct-
2d30: 64 62 73 2a 20 2a 74 6f 70 70 61 74 68 2a 20 23 dbs* *toppath* #
2d40: 66 29 0a 20 20 20 20 20 20 20 27 6b 69 6c 6c 73 f). 'kills
2d50: 65 72 76 65 72 73 0a 20 20 20 20 20 20 20 3b 27 ervers. ;'
2d60: 64 65 6a 75 6e 6b 0a 20 20 20 20 20 20 20 3b 27 dejunk. ;'
2d70: 61 64 6a 2d 74 65 73 74 69 64 73 0a 20 20 20 20 adj-testids.
2d80: 20 20 20 27 6f 6c 64 32 6e 65 77 0a 20 20 20 20 'old2new.
2d90: 20 20 20 29 0a 20 20 20 20 20 20 28 64 65 62 75 ). (debu
2da0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
2db0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2dc0: 2a 20 22 64 72 6f 70 70 69 6e 67 20 74 72 69 67 * "dropping trig
2dd0: 67 65 72 73 20 74 6f 20 75 70 64 61 74 65 20 6c gers to update l
2de0: 69 6e 6b 74 72 65 65 22 29 20 0a 20 20 20 20 20 inktree") .
2df0: 20 28 72 6d 74 3a 64 72 6f 70 2d 61 6c 6c 2d 74 (rmt:drop-all-t
2e00: 72 69 67 67 65 72 73 29 0a 20 20 20 20 28 6c 65 riggers). (le
2e10: 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 20 20 t* ((linktree
2e20: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
2e30: 6c 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 63 linktree)) ;; (c
2e40: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
2e50: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
2e60: 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a " "linktree"))).
2e70: 09 20 20 28 73 72 63 2d 61 72 63 68 69 76 65 2d . (src-archive-
2e80: 6c 69 6e 6b 74 72 65 65 20 28 72 6d 74 3a 67 65 linktree (rmt:ge
2e90: 74 2d 76 61 72 20 22 73 72 63 2d 61 72 63 68 69 t-var "src-archi
2ea0: 76 65 2d 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a ve-linktree"))).
2eb0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
2ec0: 20 28 65 71 75 61 6c 3f 20 73 72 63 2d 61 72 63 (equal? src-arc
2ed0: 68 69 76 65 2d 6c 69 6e 6b 74 72 65 65 20 6c 69 hive-linktree li
2ee0: 6e 6b 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 nktree)).
2ef0: 20 20 20 20 28 72 6d 74 3a 75 70 64 61 74 65 2d (rmt:update-
2f00: 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 70 69 6c tesdata-on-repil
2f10: 63 61 74 65 2d 64 62 20 73 72 63 2d 61 72 63 68 cate-db src-arch
2f20: 69 76 65 2d 6c 69 6e 6b 74 72 65 65 20 6c 69 6e ive-linktree lin
2f30: 6b 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 ktree)).
2f40: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2f50: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
2f60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 72 lt-log-port* "cr
2f70: 65 61 74 69 6e 67 20 74 72 69 67 67 65 72 73 20 eating triggers
2f80: 61 66 74 65 72 20 75 70 64 61 74 69 6e 67 20 6c after updating l
2f90: 69 6e 6b 74 72 65 65 22 29 20 20 20 0a 20 20 20 inktree") .
2fa0: 20 20 20 20 28 72 6d 74 3a 63 72 65 61 74 65 2d (rmt:create-
2fb0: 61 6c 6c 2d 74 72 69 67 67 65 72 73 29 0a 29 29 all-triggers).))
2fc0: 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 61 72 63 ..(define (arc
2fd0: 68 69 76 65 3a 6c 73 2d 3e 6c 69 73 74 20 20 62 hive:ls->list b
2fe0: 75 70 2d 65 78 65 20 61 72 63 68 69 76 65 2d 64 up-exe archive-d
2ff0: 69 72 20 69 6e 74 65 72 6e 61 6c 2d 70 61 74 68 ir internal-path
3000: 29 0a 20 20 28 6c 65 74 20 28 28 63 6d 64 20 28 ). (let ((cmd (
3010: 63 6f 6e 63 20 62 75 70 2d 65 78 65 20 22 20 2d conc bup-exe " -
3020: 64 20 22 20 61 72 63 68 69 76 65 2d 64 69 72 20 d " archive-dir
3030: 20 22 20 6c 73 20 2d 6c 20 22 20 69 6e 74 65 72 " ls -l " inter
3040: 6e 61 6c 2d 70 61 74 68 20 22 7c 20 61 77 6b 20 nal-path "| awk
3050: 27 7b 70 72 69 6e 74 20 24 36 7d 27 20 7c 20 73 '{print $6}' | s
3060: 6f 72 74 22 29 29 0a 20 20 20 20 20 20 20 20 28 ort")). (
3070: 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 64 res '())). (d
3080: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3090: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
30a0: 6f 72 74 2a 20 63 6d 64 29 0a 20 20 20 20 28 68 ort* cmd). (h
30b0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
30c0: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 23 . exn. #
30d0: 66 20 3b 3b 20 61 6e 79 74 68 69 6e 67 20 67 6f f ;; anything go
30e0: 65 73 20 77 72 6f 6e 67 20 2d 20 61 73 73 75 6d es wrong - assum
30f0: 65 20 74 68 65 20 70 72 6f 63 65 73 73 20 69 6e e the process in
3100: 20 4e 4f 54 20 72 75 6e 6e 69 6e 67 2e 0a 20 20 NOT running..
3110: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
3120: 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 20 rom-pipe .
3130: 63 6d 64 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 cmd. (lambd
3140: 61 20 28 29 0a 09 28 6c 65 74 2a 20 28 28 69 6e a ()..(let* ((in
3150: 6c 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 l (read-lines)))
3160: 0a 09 20 20 28 72 65 76 65 72 73 65 20 69 6e 6c .. (reverse inl
3170: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
3180: 20 28 74 69 6d 65 2d 73 74 72 69 6e 67 2d 3e 73 (time-string->s
3190: 65 63 6f 6e 64 73 20 74 73 74 72 20 64 73 2d 66 econds tstr ds-f
31a0: 6c 61 67 29 0a 20 28 6c 65 74 2a 20 28 28 61 74 lag). (let* ((at
31b0: 69 6d 65 20 28 73 74 72 69 6e 67 2d 3e 74 69 6d ime (string->tim
31c0: 65 20 74 73 74 72 20 22 25 59 2d 25 6d 2d 25 64 e tstr "%Y-%m-%d
31d0: 2d 25 48 25 4d 25 53 22 29 29 29 0a 20 20 20 20 -%H%M%S"))).
31e0: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
31f0: 61 74 69 6d 65 20 38 20 64 73 2d 66 6c 61 67 29 atime 8 ds-flag)
3200: 0a 20 20 20 20 20 28 6c 6f 63 61 6c 2d 74 69 6d . (local-tim
3210: 65 2d 3e 73 65 63 6f 6e 64 73 20 61 74 69 6d 65 e->seconds atime
3220: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
3230: 63 6f 6e 64 73 2d 3e 73 74 64 2d 74 69 6d 65 2d conds->std-time-
3240: 73 74 72 20 73 65 63 29 0a 20 20 28 74 69 6d 65 str sec). (time
3250: 2d 3e 73 74 72 69 6e 67 20 0a 20 20 20 28 73 65 ->string . (se
3260: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
3270: 65 20 73 65 63 29 0a 20 20 20 22 25 59 2d 25 6d e sec). "%Y-%m
3280: 2d 25 64 2d 25 48 25 4d 25 53 22 29 29 0a 20 0a -%d-%H%M%S")). .
3290: 0a 28 64 65 66 69 6e 65 20 28 61 72 63 68 69 76 .(define (archiv
32a0: 65 3a 67 65 74 2d 74 69 6d 65 73 74 61 6d 70 2d e:get-timestamp-
32b0: 64 69 72 20 62 75 70 2d 65 78 65 20 61 72 63 68 dir bup-exe arch
32c0: 69 76 65 2d 64 69 72 20 74 65 73 74 73 75 69 74 ive-dir testsuit
32d0: 65 2d 6e 61 6d 65 20 74 61 72 67 65 74 20 74 65 e-name target te
32e0: 73 74 2d 70 61 72 74 69 61 6c 2d 70 61 74 68 20 st-partial-path
32f0: 74 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 test-last-update
3300: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
3310: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
3320: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 65 lt-log-port* "Te
3330: 73 74 20 6c 61 73 74 20 75 70 64 61 74 65 20 74 st last update t
3340: 69 6d 65 3a 22 20 28 73 65 63 6f 6e 64 73 2d 3e ime:" (seconds->
3350: 73 74 64 2d 74 69 6d 65 2d 73 74 72 20 74 65 73 std-time-str tes
3360: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 29 20 t-last-update))
3370: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 69 6e 74 . (let* ((int
3380: 65 72 6e 61 6c 2d 70 61 74 68 20 28 63 6f 6e 63 ernal-path (conc
3390: 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 testsuite-name
33a0: 22 2d 22 20 74 61 72 67 65 74 29 29 0a 20 20 20 "-" target)).
33b0: 20 20 20 20 20 20 20 20 28 61 72 63 68 69 76 65 (archive
33c0: 2d 75 70 64 61 74 65 2d 64 65 6c 61 79 20 28 73 -update-delay (s
33d0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f tring->number (o
33e0: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
33f0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 61 p *configdat* "a
3400: 72 63 68 69 76 65 22 20 22 74 65 73 74 2d 75 70 rchive" "test-up
3410: 64 61 74 65 2d 64 65 6c 61 79 22 29 20 22 39 30 date-delay") "90
3420: 30 22 20 29 29 29 20 20 0a 20 20 20 20 20 20 20 0" ))) .
3430: 20 20 20 20 28 74 73 2d 6c 69 73 74 20 28 61 72 (ts-list (ar
3440: 63 68 69 76 65 3a 6c 73 2d 3e 6c 69 73 74 20 20 chive:ls->list
3450: 62 75 70 2d 65 78 65 20 61 72 63 68 69 76 65 2d bup-exe archive-
3460: 64 69 72 20 69 6e 74 65 72 6e 61 6c 2d 70 61 74 dir internal-pat
3470: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 h)). (
3480: 64 73 2d 66 6c 61 67 20 28 76 65 63 74 6f 72 2d ds-flag (vector-
3490: 72 65 66 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f ref (seconds->lo
34a0: 63 61 6c 2d 74 69 6d 65 29 20 38 29 29 29 0a 20 cal-time) 8))).
34b0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c (let l
34c0: 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 oop ((hed (car t
34d0: 73 2d 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 s-list)).
34e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
34f0: 28 74 61 69 6c 20 28 63 64 72 20 74 73 2d 6c 69 (tail (cdr ts-li
3500: 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 st))).
3510: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e (if (an
3520: 64 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 20 28 d (null? tail) (
3530: 65 71 75 61 6c 3f 20 68 65 64 20 22 6c 61 74 65 equal? hed "late
3540: 73 74 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 st")).
3550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
3560: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3570: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e (if (and (n
3580: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 29 ot (null? tail))
3590: 20 28 65 71 75 61 6c 3f 20 68 65 64 20 22 6c 61 (equal? hed "la
35a0: 74 65 73 74 22 29 29 0a 20 20 20 20 20 20 20 20 test")).
35b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35c0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
35d0: 20 28 63 64 72 20 74 61 69 6c 29 29 0a 20 20 20 (cdr tail)).
35e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
35f0: 6c 65 74 2a 20 28 28 61 72 63 68 69 76 65 2d 73 let* ((archive-s
3600: 65 63 6f 6e 64 73 20 28 74 69 6d 65 2d 73 74 72 econds (time-str
3610: 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 68 65 64 ing->seconds hed
3620: 20 64 73 2d 66 6c 61 67 29 29 29 0a 20 20 20 20 ds-flag))).
3630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3640: 28 69 66 20 28 3c 20 28 61 62 73 20 28 2d 20 61 (if (< (abs (- a
3650: 72 63 68 69 76 65 2d 73 65 63 6f 6e 64 73 20 74 rchive-seconds t
3660: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 est-last-update)
3670: 29 20 61 72 63 68 69 76 65 2d 75 70 64 61 74 65 ) archive-update
3680: 2d 64 65 6c 61 79 29 0a 20 20 20 20 20 20 20 20 -delay).
3690: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
36a0: 2a 20 28 28 74 65 73 74 2d 6c 69 73 74 20 28 61 * ((test-list (a
36b0: 72 63 68 69 76 65 3a 6c 73 2d 3e 6c 69 73 74 20 rchive:ls->list
36c0: 20 62 75 70 2d 65 78 65 20 61 72 63 68 69 76 65 bup-exe archive
36d0: 2d 64 69 72 20 28 63 6f 6e 63 20 69 6e 74 65 72 -dir (conc inter
36e0: 6e 61 6c 2d 70 61 74 68 20 22 2f 22 20 68 65 64 nal-path "/" hed
36f0: 20 22 2f 22 20 74 65 73 74 2d 70 61 72 74 69 61 "/" test-partia
3700: 6c 2d 70 61 74 68 29 29 29 29 0a 20 20 20 20 20 l-path)))).
3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3720: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 (if (> (le
3730: 6e 67 74 68 20 74 65 73 74 2d 6c 69 73 74 29 20 ngth test-list)
3740: 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 0).
3750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3760: 20 20 68 65 64 0a 20 20 20 20 20 20 20 20 20 20 hed.
3770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3780: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n
3790: 75 6c 6c 3f 20 74 61 69 6c 29 29 20 0a 20 20 20 ull? tail)) .
37a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
37c0: 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 20 28 oop (car tail) (
37d0: 63 64 72 20 74 61 69 6c 29 29 0a 20 20 20 20 20 cdr tail)).
37e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37f0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
3800: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3810: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
3820: 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 20 20 20 20 ll? tail).
3830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3840: 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 #f.
3850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3860: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
3870: 29 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 ) (cdr tail)))))
3880: 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 )))))...(define
3890: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 79 6f 75 6e (common:get-youn
38a0: 67 65 73 74 2d 74 65 73 74 20 74 65 73 74 73 29 gest-test tests)
38b0: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 . (if (null? te
38c0: 73 74 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 sts). #f.
38d0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 (let ((res #
38e0: 66 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 f))..(for-each..
38f0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 64 (lambda (test-d
3900: 61 74 29 0a 09 20 20 20 28 6c 65 74 20 28 28 65 at).. (let ((e
3910: 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a 74 65 vent-time (db:te
3920: 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d st-get-event_tim
3930: 65 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 20 e test-dat)))..
3940: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
3950: 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 3e 20 res)... (>
3960: 65 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a 74 event-time (db:t
3970: 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 est-get-event_ti
3980: 6d 65 20 72 65 73 29 29 29 0a 09 09 20 28 73 65 me res)))... (se
3990: 74 21 20 72 65 73 20 74 65 73 74 2d 64 61 74 29 t! res test-dat)
39a0: 29 29 29 0a 09 20 74 65 73 74 73 29 0a 09 72 65 ))).. tests)..re
39b0: 73 29 29 29 0a 09 20 20 20 0a 3b 3b 20 66 72 6f s))).. .;; fro
39c0: 6d 20 61 6e 20 61 72 63 68 69 76 65 20 67 65 74 m an archive get
39d0: 20 61 20 73 70 65 63 69 66 69 63 20 70 61 74 68 a specific path
39e0: 20 2d 20 77 6f 72 6b 73 20 4f 4e 4c 59 20 77 69 - works ONLY wi
39f0: 74 68 20 62 75 70 20 66 6f 72 20 6e 6f 77 0a 3b th bup for now.;
3a00: 3b 0a 28 64 65 66 69 6e 65 20 28 61 72 63 68 69 ;.(define (archi
3a10: 76 65 3a 62 75 70 2d 67 65 74 2d 64 61 74 61 20 ve:bup-get-data
3a20: 61 72 63 68 69 76 65 2d 63 6f 6d 6d 61 6e 64 20 archive-command
3a30: 72 75 6e 2d 69 64 2d 69 6e 20 72 75 6e 2d 6e 61 run-id-in run-na
3a40: 6d 65 2d 69 6e 20 74 65 73 74 73 20 72 70 2d 6d me-in tests rp-m
3a50: 75 74 65 78 20 62 75 70 2d 6d 75 74 65 78 29 0a utex bup-mutex).
3a60: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 (if (null? tes
3a70: 74 73 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 ts). (debug
3a80: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
3a90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3aa0: 20 22 67 65 74 2d 64 61 74 61 20 63 61 6c 6c 65 "get-data calle
3ab0: 64 20 77 69 74 68 20 6e 6f 20 6d 61 74 63 68 69 d with no matchi
3ac0: 6e 67 20 74 65 73 74 73 20 74 6f 20 6f 70 65 72 ng tests to oper
3ad0: 61 74 65 20 6f 6e 2e 22 29 0a 20 20 20 20 20 20 ate on.").
3ae0: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 62 . (let* ((b
3af0: 75 70 2d 65 78 65 20 20 20 20 20 20 28 6f 72 20 up-exe (or
3b00: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
3b10: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 61 72 63 *configdat* "arc
3b20: 68 69 76 65 22 20 22 62 75 70 22 29 20 22 62 75 hive" "bup") "bu
3b30: 70 22 29 29 0a 09 20 20 20 20 20 28 6c 69 6e 6b p")).. (link
3b40: 74 72 65 65 20 20 20 20 20 28 63 6f 6d 6d 6f 6e tree (common
3b50: 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 20 :get-linktree))
3b60: 3b 3b 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b ;; (configf:look
3b70: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
3b80: 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 setup" "linktree
3b90: 22 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 74 "))).. ;; (t
3ba0: 65 73 74 2d 64 61 74 20 20 20 20 20 28 63 6f 6d est-dat (com
3bb0: 6d 6f 6e 3a 67 65 74 2d 79 6f 75 6e 67 65 73 74 mon:get-youngest
3bc0: 2d 74 65 73 74 20 74 65 73 74 73 29 29 0a 09 20 -test tests))..
3bd0: 20 20 20 20 28 64 65 73 74 70 61 74 68 20 20 20 (destpath
3be0: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
3bf0: 22 2d 64 65 73 74 22 29 29 29 0a 09 28 63 6f 6e "-dest")))..(con
3c00: 64 0a 09 20 28 28 6e 75 6c 6c 3f 20 74 65 73 74 d.. ((null? test
3c10: 73 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 s).. (debug:pri
3c20: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
3c30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 ult-log-port*...
3c40: 09 20 20 20 20 20 22 4e 6f 20 74 65 73 74 20 6d . "No test m
3c50: 61 74 63 68 69 6e 67 20 70 72 6f 76 69 64 65 64 atching provided
3c60: 20 74 61 72 67 65 74 2c 20 72 75 6e 6e 61 6d 65 target, runname
3c70: 20 70 61 74 74 65 72 6e 20 61 6e 64 20 74 65 73 pattern and tes
3c80: 74 20 70 61 74 74 65 72 6e 20 66 6f 75 6e 64 2e t pattern found.
3c90: 22 29 29 0a 09 20 28 28 66 69 6c 65 2d 65 78 69 ")).. ((file-exi
3ca0: 73 74 73 3f 20 64 65 73 74 70 61 74 68 29 0a 09 sts? destpath)..
3cb0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
3cc0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
3cd0: 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 20 20 log-port*....
3ce0: 20 20 22 44 65 73 74 69 6e 61 74 69 6f 6e 20 70 "Destination p
3cf0: 61 74 68 20 61 6c 72 65 61 64 20 65 78 69 73 74 ath alread exist
3d00: 73 21 20 50 6c 65 61 73 65 20 72 65 6d 6f 76 65 s! Please remove
3d10: 20 69 74 20 62 65 66 6f 72 65 20 72 75 6e 6e 69 it before runni
3d20: 6e 67 20 67 65 74 2e 22 29 29 0a 09 20 28 65 6c ng get.")).. (el
3d30: 73 65 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 se.. (let loop
3d40: 28 28 72 65 6d 2d 74 65 73 74 73 20 74 65 73 74 ((rem-tests test
3d50: 73 29 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 s)).. (let* (
3d60: 28 74 65 73 74 2d 64 61 74 20 20 20 20 20 20 20 (test-dat
3d70: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 79 (common:get-y
3d80: 6f 75 6e 67 65 73 74 2d 74 65 73 74 20 72 65 6d oungest-test rem
3d90: 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 28 69 -tests))... (i
3da0: 74 65 6d 2d 70 61 74 68 20 20 20 20 20 20 20 20 tem-path
3db0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
3dc0: 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 61 74 em-path test-dat
3dd0: 29 29 0a 09 09 20 20 20 28 74 65 73 74 2d 6e 61 ))... (test-na
3de0: 6d 65 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 me (db:t
3df0: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
3e00: 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 20 test-dat))...
3e10: 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 (test-id
3e20: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
3e30: 74 2d 69 64 20 20 20 20 20 20 20 20 74 65 73 74 t-id test
3e40: 2d 64 61 74 29 29 0a 09 09 20 20 20 28 72 75 6e -dat))... (run
3e50: 2d 69 64 20 20 20 20 20 20 20 20 20 20 20 20 28 -id (
3e60: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f db:test-get-run_
3e70: 69 64 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 id test-dat))
3e80: 0a 09 09 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 ... (run-name
3e90: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
3ea0: 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d t-run-name-from-
3eb0: 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 09 20 20 id run-id))...
3ec0: 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 20 20 (keyvals
3ed0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 (rmt:get-key
3ee0: 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 -val-pairs run-i
3ef0: 64 29 29 0a 09 09 20 20 20 28 74 61 72 67 65 74 d))... (target
3f00: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
3f10: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
3f20: 28 6d 61 70 20 63 61 64 72 20 6b 65 79 76 61 6c (map cadr keyval
3f30: 73 29 20 22 2f 22 29 29 0a 09 09 20 20 20 0a 09 s) "/"))... ..
3f40: 09 20 20 20 28 74 6f 70 6c 65 76 65 6c 2f 63 68 . (toplevel/ch
3f50: 69 6c 64 72 65 6e 20 28 61 6e 64 20 28 64 62 3a ildren (and (db:
3f60: 74 65 73 74 2d 67 65 74 2d 69 73 2d 74 6f 70 6c test-get-is-topl
3f70: 65 76 65 6c 20 74 65 73 74 2d 64 61 74 29 0a 09 evel test-dat)..
3f80: 09 09 09 09 20 20 20 28 3e 20 28 72 6d 74 3a 74 .... (> (rmt:t
3f90: 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d est-toplevel-num
3fa0: 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 -items run-id te
3fb0: 73 74 2d 6e 61 6d 65 29 20 30 29 29 29 0a 09 09 st-name) 0)))...
3fc0: 20 20 20 28 74 65 73 74 2d 70 61 72 74 69 61 6c (test-partial
3fd0: 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 61 72 67 -path (conc targ
3fe0: 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 et "/" run-name
3ff0: 22 2f 22 0a 09 09 09 09 09 20 20 20 20 28 64 62 "/"...... (db
4000: 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
4010: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
4020: 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 09 20 20 tem-path)))...
4030: 20 3b 3b 20 6e 6f 74 65 20 74 68 65 20 74 72 61 ;; note the tra
4040: 69 6c 69 6e 67 20 73 6c 61 73 68 20 74 6f 20 67 iling slash to g
4050: 65 74 20 74 68 65 20 64 69 72 20 69 6e 73 70 69 et the dir inspi
4060: 74 65 20 6f 66 20 69 74 20 62 65 69 6e 67 20 61 te of it being a
4070: 20 6c 69 6e 6b 0a 09 09 20 20 20 28 74 65 73 74 link... (test
4080: 2d 70 61 74 68 20 20 20 20 20 20 20 20 20 28 63 -path (c
4090: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
40a0: 20 74 65 73 74 2d 70 61 72 74 69 61 6c 2d 70 61 test-partial-pa
40b0: 74 68 29 29 0a 09 09 20 20 20 28 61 72 63 68 69 th))... (archi
40c0: 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 20 20 20 20 ve-block-id
40d0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
40e0: 61 72 63 68 69 76 65 64 20 74 65 73 74 2d 64 61 archived test-da
40f0: 74 29 29 0a 09 09 20 20 20 28 61 72 63 68 69 76 t))... (archiv
4100: 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 20 20 20 e-block-info
4110: 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d (rmt:test-get-
4120: 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e archive-block-in
4130: 66 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b fo archive-block
4140: 2d 69 64 29 29 0a 09 09 20 20 20 28 61 72 63 68 -id))... (arch
4150: 69 76 65 2d 70 61 74 68 20 20 20 20 20 20 20 20 ive-path
4160: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector?
4170: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
4180: 6e 66 6f 29 0a 09 09 09 09 09 09 28 76 65 63 74 nfo).......(vect
4190: 6f 72 2d 72 65 66 20 61 72 63 68 69 76 65 2d 62 or-ref archive-b
41a0: 6c 6f 63 6b 2d 69 6e 66 6f 20 32 29 0a 09 09 09 lock-info 2)....
41b0: 09 09 09 23 66 29 29 0a 09 09 20 20 20 28 61 72 ...#f))... (ar
41c0: 63 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c 2d 70 chive-internal-p
41d0: 61 74 68 20 20 20 28 63 6f 6e 63 20 28 63 6f 6d ath (conc (com
41e0: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
41f0: 65 2d 6e 61 6d 65 29 20 22 2d 22 20 72 75 6e 2d e-name) "-" run-
4200: 69 64 0a 09 09 09 09 09 09 20 20 22 2f 6c 61 74 id....... "/lat
4210: 65 73 74 2f 22 20 74 65 73 74 2d 70 61 72 74 69 est/" test-parti
4220: 61 6c 2d 70 61 74 68 29 29 0a 09 09 20 20 20 28 al-path))... (
4230: 69 6e 63 6c 75 64 65 2d 70 61 74 68 73 20 20 20 include-paths
4240: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
4250: 74 2d 61 72 67 20 22 2d 69 6e 63 6c 75 64 65 22 t-arg "-include"
4260: 29 29 0a 09 09 20 20 20 28 65 78 63 6c 75 64 65 ))... (exclude
4270: 2d 70 61 74 74 65 72 6e 20 20 20 20 20 20 20 20 -pattern
4280: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
4290: 2d 65 78 63 6c 75 64 65 2d 72 78 22 29 29 0a 09 -exclude-rx"))..
42a0: 09 20 20 20 28 65 78 63 6c 75 64 65 2d 66 69 6c . (exclude-fil
42b0: 65 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 e (ar
42c0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 65 78 63 gs:get-arg "-exc
42d0: 6c 75 64 65 2d 72 78 2d 66 72 6f 6d 22 29 29 29 lude-rx-from")))
42e0: 0a 09 20 20 20 20 20 20 0a 09 20 20 20 20 20 20 .. ..
42f0: 28 69 66 20 28 61 6e 64 20 61 72 63 68 69 76 65 (if (and archive
4300: 2d 70 61 74 68 20 3b 3b 20 6e 6f 20 70 6f 69 6e -path ;; no poin
4310: 74 20 69 6e 20 70 72 6f 63 65 65 64 69 6e 67 20 t in proceeding
4320: 69 66 20 74 68 65 72 65 20 69 73 20 6e 6f 20 61 if there is no a
4330: 63 74 75 61 6c 20 61 72 63 68 69 76 65 0a 09 09 ctual archive...
4340: 20 20 20 20 20 20 20 28 6e 6f 74 20 74 6f 70 6c (not topl
4350: 65 76 65 6c 2f 63 68 69 6c 64 72 65 6e 29 29 0a evel/children)).
4360: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 .. (begin...
4370: 20 28 6c 65 74 2a 20 28 28 62 75 70 2d 72 65 73 (let* ((bup-res
4380: 74 6f 72 65 2d 70 61 72 61 6d 73 20 28 61 70 70 tore-params (app
4390: 65 6e 64 20 28 6c 69 73 74 20 22 2d 64 22 20 61 end (list "-d" a
43a0: 72 63 68 69 76 65 2d 70 61 74 68 20 22 72 65 73 rchive-path "res
43b0: 74 6f 72 65 22 20 22 2d 43 22 20 28 6f 72 20 64 tore" "-C" (or d
43c0: 65 73 74 70 61 74 68 20 22 64 61 74 61 22 29 29 estpath "data"))
43d0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b ....... ;;
43e0: 20 22 20 22 20 3b 3b 20 57 68 61 74 20 69 73 20 " " ;; What is
43f0: 74 68 65 20 65 6d 70 74 79 20 73 74 72 69 6e 67 the empty string
4400: 20 66 6f 72 3f 0a 09 09 09 09 09 09 20 20 20 20 for?.......
4410: 20 20 20 28 69 66 20 69 6e 63 6c 75 64 65 2d 70 (if include-p
4420: 61 74 68 73 0a 09 09 09 09 09 09 09 20 20 20 28 aths........ (
4430: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a map (lambda (p).
4440: 09 09 09 09 09 09 09 09 20 20 28 63 6f 6e 63 20 ........ (conc
4450: 61 72 63 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c archive-internal
4460: 2d 70 61 74 68 20 22 2f 22 20 70 29 29 0a 09 09 -path "/" p))...
4470: 09 09 09 09 09 09 28 73 74 72 69 6e 67 2d 73 70 ......(string-sp
4480: 6c 69 74 20 69 6e 63 6c 75 64 65 2d 70 61 74 68 lit include-path
4490: 73 20 22 2c 22 29 29 0a 09 09 09 09 09 09 09 20 s ","))........
44a0: 20 20 28 6c 69 73 74 20 61 72 63 68 69 76 65 2d (list archive-
44b0: 69 6e 74 65 72 6e 61 6c 2d 70 61 74 68 29 29 29 internal-path)))
44c0: 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 ))... (debu
44d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
44e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
44f0: 2a 20 22 52 65 73 74 6f 72 69 6e 67 20 61 72 63 * "Restoring arc
4500: 68 69 76 65 64 20 64 61 74 61 20 74 6f 20 22 20 hived data to "
4510: 28 6f 72 20 64 65 73 74 70 61 74 68 20 22 64 61 (or destpath "da
4520: 74 61 22 29 0a 09 09 09 09 09 22 20 66 72 6f 6d ta")......" from
4530: 20 61 72 63 68 69 76 65 20 69 6e 20 22 20 61 72 archive in " ar
4540: 63 68 69 76 65 2d 70 61 74 68 20 22 20 2e 2e 2e chive-path " ...
4550: 20 22 20 61 72 63 68 69 76 65 2d 69 6e 74 65 72 " archive-inter
4560: 6e 61 6c 2d 70 61 74 68 29 0a 09 09 20 20 20 20 nal-path)...
4570: 20 20 28 72 75 6e 2d 6e 2d 77 61 69 74 20 62 75 (run-n-wait bu
4580: 70 2d 65 78 65 20 70 61 72 61 6d 73 3a 20 62 75 p-exe params: bu
4590: 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 61 6d 73 p-restore-params
45a0: 20 70 72 69 6e 74 2d 63 6d 64 3a 20 23 74 29 29 print-cmd: #t))
45b0: 29 0a 09 09 20 20 28 6c 65 74 20 28 28 6e 65 77 )... (let ((new
45c0: 2d 72 65 6d 2d 74 65 73 74 73 20 28 66 69 6c 74 -rem-tests (filt
45d0: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 64 61 74 er (lambda (tdat
45e0: 29 0a 09 09 09 09 09 09 20 28 6f 72 20 28 6e 6f )....... (or (no
45f0: 74 20 28 65 71 3f 20 28 64 62 3a 74 65 73 74 2d t (eq? (db:test-
4600: 67 65 74 2d 69 64 20 74 64 61 74 29 20 74 65 73 get-id tdat) tes
4610: 74 2d 69 64 29 29 0a 09 09 09 09 09 09 20 20 20 t-id)).......
4620: 20 20 28 6e 6f 74 20 28 65 71 3f 20 28 64 62 3a (not (eq? (db:
4630: 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 test-get-run_id
4640: 74 64 61 74 29 20 72 75 6e 2d 69 64 29 29 29 29 tdat) run-id))))
4650: 0a 09 09 09 09 09 20 20 20 20 20 20 20 72 65 6d ...... rem
4660: 2d 74 65 73 74 73 29 20 29 29 0a 09 09 20 20 20 -tests) ))...
4670: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4680: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
4690: 67 2d 70 6f 72 74 2a 0a 09 09 09 09 20 20 20 20 g-port*.....
46a0: 20 20 22 4e 6f 20 61 72 63 68 69 76 65 20 70 61 "No archive pa
46b0: 74 68 20 69 6e 20 74 68 65 20 72 65 63 6f 72 64 th in the record
46c0: 20 66 6f 72 20 72 75 6e 2d 69 64 3d 22 20 72 75 for run-id=" ru
46d0: 6e 2d 69 64 0a 09 09 09 09 20 20 20 20 20 20 22 n-id..... "
46e0: 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d test-id=" test-
46f0: 69 64 20 22 2c 20 73 6b 69 70 70 69 6e 67 2e 22 id ", skipping."
4700: 29 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 6c )... (if (nul
4710: 6c 3f 20 6e 65 77 2d 72 65 6d 2d 74 65 73 74 73 l? new-rem-tests
4720: 29 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 )....(begin....
4730: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4740: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
4750: 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 61 72 63 68 g-port* "No arch
4760: 69 76 65 73 20 66 6f 75 6e 64 20 66 6f 72 20 22 ives found for "
4770: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d target "/" run-
4780: 6e 61 6d 65 20 22 2e 2e 2e 22 29 0a 09 09 09 20 name "...")....
4790: 20 23 66 29 0a 09 09 09 28 6c 6f 6f 70 20 6e 65 #f)....(loop ne
47a0: 77 2d 72 65 6d 2d 74 65 73 74 73 29 29 29 29 29 w-rem-tests)))))
47b0: 29 29 29 29 29 29 0a 20 20 0a 29 0a )))))). .).