Artifact
13152d30be1d0fbc5c8eaf3a9d84955ae72e2758:
0000: 0a 3b 3b 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 3d 0a 3b 3b 20 43 6f 70 =========.;; Cop
0050: 79 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 yright 2017, Mat
0060: 74 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b thew Welland..;;
0070: 20 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 .;; This file i
0080: 73 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 s part of Megate
0090: 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d st..;; .;; M
00a0: 65 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 egatest is free
00b0: 73 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 software: you ca
00c0: 6e 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 n redistribute i
00d0: 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a t and/or modify.
00e0: 3b 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 ;; it under
00f0: 74 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 the terms of the
0100: 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 GNU General Pub
0110: 6c 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 lic License as p
0120: 75 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 ublished by.;;
0130: 20 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 the Free Soft
0140: 77 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c ware Foundation,
0150: 20 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 either version
0160: 33 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 3 of the License
0170: 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 , or.;; (at
0180: 79 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 your option) any
0190: 20 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a later version..
01a0: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
01b0: 65 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 est is distribut
01c0: 65 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 ed in the hope t
01d0: 68 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 hat it will be u
01e0: 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 seful,.;; bu
01f0: 74 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 t WITHOUT ANY WA
0200: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
0210: 65 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 even the implied
0220: 20 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 warranty of.;;
0230: 20 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c MERCHANTABIL
0240: 49 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 ITY or FITNESS F
0250: 4f 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 OR A PARTICULAR
0260: 50 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 PURPOSE. See th
0270: 65 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e e.;; GNU Gen
0280: 65 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 eral Public Lice
0290: 6e 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 nse for more det
02a0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 ails..;; .;;
02b0: 20 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 You should have
02c0: 20 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 received a copy
02d0: 20 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 of the GNU Gene
02e0: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
02f0: 73 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 se.;; along
0300: 77 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 with Megatest.
0310: 49 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 If not, see <htt
0320: 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f p://www.gnu.org/
0330: 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d licenses/>...;;=
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 3d 0a 0a 28 64 65 63 6c 61 72 65 20 =====..(declare
0390: 28 75 6e 69 74 20 61 72 63 68 69 76 65 6d 6f 64 (unit archivemod
03a0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
03b0: 73 20 64 65 62 75 67 70 72 69 6e 74 29 29 0a 28 s debugprint)).(
03c0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co
03d0: 6d 6d 6f 6e 6d 6f 64 29 29 0a 28 64 65 63 6c 61 mmonmod)).(decla
03e0: 72 65 20 28 75 73 65 73 20 63 6f 6e 66 69 67 66 re (uses configf
03f0: 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mod)).(declare (
0400: 75 73 65 73 20 6d 74 61 72 67 73 29 29 0a 28 64 uses mtargs)).(d
0410: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 76 eclare (uses mtv
0420: 65 72 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 er)).;; (declare
0430: 20 28 75 73 65 73 20 63 73 76 2d 78 6d 6c 29 29 (uses csv-xml))
0440: 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 .;; (declare (us
0450: 65 73 20 6b 65 79 73 6d 6f 64 29 29 0a 28 64 65 es keysmod)).(de
0460: 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 6d 6f clare (uses mtmo
0470: 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 d)).(declare (us
0480: 65 73 20 64 62 6d 6f 64 29 29 0a 28 64 65 63 6c es dbmod)).(decl
0490: 61 72 65 20 28 75 73 65 73 20 72 6d 74 6d 6f 64 are (uses rmtmod
04a0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
04b0: 73 20 6c 61 75 6e 63 68 6d 6f 64 29 29 0a 28 64 s launchmod)).(d
04c0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 70 72 6f eclare (uses pro
04d0: 63 65 73 73 6d 6f 64 29 29 0a 28 64 65 63 6c 61 cessmod)).(decla
04e0: 72 65 20 28 75 73 65 73 20 73 65 72 76 65 72 6d re (uses serverm
04f0: 6f 64 29 29 0a 0a 28 6d 6f 64 75 6c 65 20 61 72 od))..(module ar
0500: 63 68 69 76 65 6d 6f 64 0a 09 2a 0a 09 0a 28 69 chivemod..*...(i
0510: 6d 70 6f 72 74 20 73 63 68 65 6d 65 0a 09 28 70 mport scheme..(p
0520: 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 refix sqlite3 sq
0530: 6c 69 74 65 33 3a 29 0a 09 63 68 69 63 6b 65 6e lite3:)..chicken
0540: 2e 62 61 73 65 0a 09 63 68 69 63 6b 65 6e 2e 63 .base..chicken.c
0550: 6f 6e 64 69 74 69 6f 6e 0a 09 63 68 69 63 6b 65 ondition..chicke
0560: 6e 2e 66 69 6c 65 0a 09 63 68 69 63 6b 65 6e 2e n.file..chicken.
0570: 66 69 6c 65 2e 70 6f 73 69 78 0a 09 63 68 69 63 file.posix..chic
0580: 6b 65 6e 2e 66 6f 72 6d 61 74 0a 09 63 68 69 63 ken.format..chic
0590: 6b 65 6e 2e 69 6f 0a 09 63 68 69 63 6b 65 6e 2e ken.io..chicken.
05a0: 70 61 74 68 6e 61 6d 65 0a 09 63 68 69 63 6b 65 pathname..chicke
05b0: 6e 2e 70 6f 72 74 0a 09 63 68 69 63 6b 65 6e 2e n.port..chicken.
05c0: 70 72 65 74 74 79 2d 70 72 69 6e 74 0a 09 63 68 pretty-print..ch
05d0: 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 0a 09 63 icken.process..c
05e0: 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 2d 63 hicken.process-c
05f0: 6f 6e 74 65 78 74 0a 09 63 68 69 63 6b 65 6e 2e ontext..chicken.
0600: 70 72 6f 63 65 73 73 2d 63 6f 6e 74 65 78 74 2e process-context.
0610: 70 6f 73 69 78 0a 09 63 68 69 63 6b 65 6e 2e 73 posix..chicken.s
0620: 6f 72 74 0a 09 63 68 69 63 6b 65 6e 2e 73 74 72 ort..chicken.str
0630: 69 6e 67 0a 09 63 68 69 63 6b 65 6e 2e 74 69 6d ing..chicken.tim
0640: 65 0a 09 63 68 69 63 6b 65 6e 2e 74 69 6d 65 2e e..chicken.time.
0650: 70 6f 73 69 78 0a 09 73 79 73 74 65 6d 2d 69 6e posix..system-in
0660: 66 6f 72 6d 61 74 69 6f 6e 0a 09 0a 09 28 70 72 formation....(pr
0670: 65 66 69 78 20 62 61 73 65 36 34 20 62 61 73 65 efix base64 base
0680: 36 34 3a 29 0a 3b 3b 20 09 63 73 76 2d 78 6d 6c 64:).;; .csv-xml
0690: 0a 09 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c ..directory-util
06a0: 73 0a 09 6d 61 74 63 68 61 62 6c 65 0a 09 72 65 s..matchable..re
06b0: 67 65 78 0a 09 73 31 31 6e 0a 09 73 72 66 69 2d gex..s11n..srfi-
06c0: 31 0a 09 73 72 66 69 2d 31 33 0a 09 73 72 66 69 1..srfi-13..srfi
06d0: 2d 31 38 0a 09 73 72 66 69 2d 36 39 0a 09 73 74 -18..srfi-69..st
06e0: 61 63 6b 0a 09 74 79 70 65 64 2d 72 65 63 6f 72 ack..typed-recor
06f0: 64 73 0a 09 7a 33 0a 09 6d 64 35 0a 09 6d 65 73 ds..z3..md5..mes
0700: 73 61 67 65 2d 64 69 67 65 73 74 0a 09 0a 09 28 sage-digest....(
0710: 70 72 65 66 69 78 20 6d 74 61 72 67 73 20 61 72 prefix mtargs ar
0720: 67 73 3a 29 0a 09 63 6f 6d 6d 6f 6e 6d 6f 64 0a gs:)..commonmod.
0730: 09 63 6f 6e 66 69 67 66 6d 6f 64 0a 09 64 65 62 .configfmod..deb
0740: 75 67 70 72 69 6e 74 0a 3b 3b 20 09 6b 65 79 73 ugprint.;; .keys
0750: 6d 6f 64 0a 09 6d 74 6d 6f 64 0a 09 6d 74 76 65 mod..mtmod..mtve
0760: 72 0a 09 64 62 6d 6f 64 0a 09 72 6d 74 6d 6f 64 r..dbmod..rmtmod
0770: 0a 09 6c 61 75 6e 63 68 6d 6f 64 0a 09 70 72 6f ..launchmod..pro
0780: 63 65 73 73 6d 6f 64 0a 09 73 65 72 76 65 72 6d cessmod..serverm
0790: 6f 64 0a 09 0a 09 29 0a 0a 3b 3b 20 20 73 74 72 od....)..;; str
07a0: 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 59 20 ftime('%m/%d/%Y
07b0: 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 27 2c %H:%M:%S','now',
07c0: 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 3b 3b 20 'localtime').;;
07d0: 0a 3b 3b 20 28 75 73 65 20 28 70 72 65 66 69 78 .;; (use (prefix
07e0: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
07f0: 3a 29 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 :) srfi-1 posix
0800: 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 regex regex-case
0810: 20 73 72 66 69 2d 36 39 20 66 6f 72 6d 61 74 20 srfi-69 format
0820: 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 md5 message-dige
0830: 73 74 20 73 72 66 69 2d 31 38 29 0a 3b 3b 20 0a st srfi-18).;; .
0840: 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 6e 69 ;; (declare (uni
0850: 74 20 61 72 63 68 69 76 65 29 29 0a 3b 3b 20 28 t archive)).;; (
0860: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 declare (uses db
0870: 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 )).;; (declare (
0880: 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b uses common)).;;
0890: 20 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 63 .;; (include "c
08a0: 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 ommon_records.sc
08b0: 6d 22 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 m").;; (include
08c0: 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 "db_records.scm"
08d0: 29 0a 3b 3b 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ).;; .;;========
08e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
0920: 3b 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ; .;;===========
0930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
0970: 4e 4f 54 20 43 55 52 52 45 4e 54 4c 59 20 55 53 NOT CURRENTLY US
0980: 45 44 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 ED.;;.;; (define
0990: 20 28 61 72 63 68 69 76 65 3a 6d 61 69 6e 20 6c (archive:main l
09a0: 69 6e 6b 74 72 65 65 20 74 61 72 67 65 74 20 72 inktree target r
09b0: 75 6e 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 20 unname testname
09c0: 69 74 65 6d 70 61 74 68 20 6f 70 74 69 6f 6e 73 itempath options
09d0: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 65 ).;; (let ((te
09e0: 73 74 64 69 72 20 28 63 6f 6e 63 20 6c 69 6e 6b stdir (conc link
09f0: 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 20 tree "/" target
0a00: 22 2f 22 20 72 75 6e 6e 61 6d 65 20 22 2f 22 20 "/" runname "/"
0a10: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
0a20: 6d 70 61 74 68 29 29 0a 3b 3b 20 09 28 66 6c 61 mpath)).;; .(fla
0a30: 76 6f 72 20 20 27 70 6c 61 69 6e 29 20 3b 3b 20 vor 'plain) ;;
0a40: 74 79 70 65 20 6f 66 20 6d 61 63 68 69 6e 65 20 type of machine
0a50: 74 6f 20 72 75 6e 20 6a 6f 62 73 20 6f 6e 0a 3b to run jobs on.;
0a60: 3b 20 09 28 6d 61 78 6c 6f 61 64 20 31 2e 35 29 ; .(maxload 1.5)
0a70: 20 20 20 3b 3b 20 6d 61 78 20 61 6c 6c 6f 77 65 ;; max allowe
0a80: 64 20 6c 6f 61 64 20 66 6f 72 20 74 68 69 73 20 d load for this
0a90: 77 6f 72 6b 0a 3b 3b 20 09 28 61 64 69 73 6b 73 work.;; .(adisks
0aa0: 20 20 28 61 72 63 68 69 76 65 3a 67 65 74 2d 61 (archive:get-a
0ab0: 72 63 68 69 76 65 2d 64 69 73 6b 73 29 29 29 0a rchive-disks))).
0ac0: 3b 3b 20 20 20 20 20 3b 3b 20 67 65 74 20 74 65 ;; ;; get te
0ad0: 73 74 64 69 72 20 73 69 7a 65 0a 3b 3b 20 20 20 stdir size.;;
0ae0: 20 20 3b 3b 20 20 20 2d 20 68 61 6e 64 20 6f 66 ;; - hand of
0af0: 66 20 64 75 20 74 6f 20 6a 6f 62 20 6d 67 72 0a f du to job mgr.
0b00: 3b 3b 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 ;; (if (and
0b10: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
0b20: 73 74 73 3f 20 74 65 73 74 64 69 72 29 0a 3b 3b sts? testdir).;;
0b30: 20 09 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 . (file-wri
0b40: 74 61 62 6c 65 3f 20 74 65 73 74 64 69 72 29 29 table? testdir))
0b50: 0a 3b 3b 20 09 28 6c 65 74 2a 20 28 28 64 75 73 .;; .(let* ((dus
0b60: 65 64 20 20 28 6a 6f 62 72 75 6e 6e 65 72 3a 72 ed (jobrunner:r
0b70: 75 6e 2d 6a 6f 62 20 0a 3b 3b 20 09 09 09 66 6c un-job .;; ...fl
0b80: 61 76 6f 72 20 20 3b 3b 20 6d 61 63 68 69 6e 65 avor ;; machine
0b90: 20 74 79 70 65 0a 3b 3b 20 09 09 09 6d 61 78 6c type.;; ...maxl
0ba0: 6f 61 64 20 3b 3b 20 6d 61 78 20 61 6c 6c 6f 77 oad ;; max allow
0bb0: 65 64 20 6c 6f 61 64 0a 3b 3b 20 09 09 09 27 28 ed load.;; ...'(
0bc0: 29 20 20 20 20 20 3b 3b 20 70 72 65 76 61 72 73 ) ;; prevars
0bd0: 20 2d 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 - environment v
0be0: 61 72 73 20 74 6f 20 73 65 74 20 66 6f 72 20 74 ars to set for t
0bf0: 68 65 20 6a 6f 62 0a 3b 3b 20 09 09 09 63 6f 6d he job.;; ...com
0c00: 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d 73 70 61 mon:get-disk-spa
0c10: 63 65 2d 75 73 65 64 20 20 3b 3b 20 69 66 20 61 ce-used ;; if a
0c20: 20 70 72 6f 63 20 63 61 6c 6c 20 69 74 2c 20 69 proc call it, i
0c30: 66 20 61 20 73 74 72 69 6e 67 20 69 74 20 69 73 f a string it is
0c40: 20 61 20 75 6e 69 78 20 63 6f 6d 6d 61 6e 64 0a a unix command.
0c50: 3b 3b 20 09 09 09 28 6c 69 73 74 20 74 65 73 74 ;; ...(list test
0c60: 64 69 72 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 dir))).;; .
0c70: 20 20 28 61 70 61 74 68 20 20 28 61 72 63 68 69 (apath (archi
0c80: 76 65 3a 67 65 74 2d 61 72 63 68 69 76 65 20 74 ve:get-archive t
0c90: 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 estname itempath
0ca0: 20 64 75 73 65 64 29 29 29 0a 3b 3b 20 09 20 20 dused))).;; .
0cb0: 28 6a 6f 62 72 75 6e 6e 65 72 3a 72 75 6e 2d 6a (jobrunner:run-j
0cc0: 6f 62 0a 3b 3b 20 09 20 20 20 66 6c 61 76 6f 72 ob.;; . flavor
0cd0: 0a 3b 3b 20 09 20 20 20 6d 61 78 6c 6f 61 64 0a .;; . maxload.
0ce0: 3b 3b 20 09 20 20 20 27 28 29 0a 3b 3b 20 09 20 ;; . '().;; .
0cf0: 20 20 61 72 63 68 69 76 65 3a 72 75 6e 2d 62 75 archive:run-bu
0d00: 70 0a 3b 3b 20 09 20 20 20 28 6c 69 73 74 20 74 p.;; . (list t
0d10: 65 73 74 64 69 72 20 61 70 61 74 68 29 29 29 29 estdir apath))))
0d20: 29 29 0a 09 20 20 0a 3b 3b 20 47 65 74 20 61 72 )).. .;; Get ar
0d30: 63 68 69 76 65 20 64 69 73 6b 73 20 66 72 6f 6d chive disks from
0d40: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
0d50: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 61 72 63 .;;.(define (arc
0d60: 68 69 76 65 3a 67 65 74 2d 61 72 63 68 69 76 65 hive:get-archive
0d70: 2d 64 69 73 6b 73 29 0a 20 20 28 6c 65 74 20 28 -disks). (let (
0d80: 28 73 65 63 74 69 6f 6e 20 28 63 6f 6e 66 69 67 (section (config
0d90: 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 2a 63 f:get-section *c
0da0: 6f 6e 66 69 67 64 61 74 2a 20 22 61 72 63 68 69 onfigdat* "archi
0db0: 76 65 2d 64 69 73 6b 73 22 29 29 29 0a 20 20 20 ve-disks"))).
0dc0: 20 28 69 66 20 73 65 63 74 69 6f 6e 0a 09 73 65 (if section..se
0dd0: 63 74 69 6f 6e 0a 09 27 28 29 29 29 29 0a 0a 3b ction..'())))..;
0de0: 3b 20 6c 6f 6f 6b 20 66 6f 72 20 74 68 65 20 62 ; look for the b
0df0: 65 73 74 20 63 61 6e 64 69 64 61 74 65 20 61 72 est candidate ar
0e00: 63 68 69 76 65 20 61 72 65 61 2c 20 65 6c 73 65 chive area, else
0e10: 20 63 72 65 61 74 65 20 6e 65 77 20 0a 3b 3b 20 create new .;;
0e20: 61 72 65 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 area.;;.(define
0e30: 28 61 72 63 68 69 76 65 3a 67 65 74 2d 61 72 63 (archive:get-arc
0e40: 68 69 76 65 20 74 65 73 74 6e 61 6d 65 20 69 74 hive testname it
0e50: 65 6d 70 61 74 68 20 64 75 73 65 64 29 0a 20 20 empath dused).
0e60: 3b 3b 20 6c 6f 6f 6b 20 75 70 20 69 6e 20 61 72 ;; look up in ar
0e70: 63 68 69 76 65 5f 61 6c 6c 6f 63 61 74 69 6f 6e chive_allocation
0e80: 73 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 s if there is a
0e90: 70 72 65 2d 75 73 65 64 20 61 72 63 68 69 76 65 pre-used archive
0ea0: 0a 20 20 3b 3b 20 77 69 74 68 20 61 64 65 71 75 . ;; with adequ
0eb0: 61 74 65 20 64 69 73 6b 73 70 61 63 65 0a 20 20 ate diskspace.
0ec0: 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 65 78 69 ;;. (let* ((exi
0ed0: 73 74 69 6e 67 2d 62 6c 6f 63 6b 73 20 28 72 6d sting-blocks (rm
0ee0: 74 3a 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c t:archive-get-al
0ef0: 6c 6f 63 61 74 69 6f 6e 73 20 74 65 73 74 6e 61 locations testna
0f00: 6d 65 20 69 74 65 6d 70 61 74 68 20 64 75 73 65 me itempath duse
0f10: 64 29 29 0a 09 20 28 63 61 6e 64 69 64 61 74 65 d)).. (candidate
0f20: 2d 64 69 73 6b 73 20 28 6d 61 70 20 28 6c 61 6d -disks (map (lam
0f30: 62 64 61 20 28 62 6c 6f 63 6b 29 0a 09 09 09 09 bda (block).....
0f40: 20 28 6c 69 73 74 0a 09 09 09 09 20 20 28 76 65 (list..... (ve
0f50: 63 74 6f 72 2d 72 65 66 20 62 6c 6f 63 6b 20 31 ctor-ref block 1
0f60: 29 20 20 20 3b 3b 20 61 72 63 68 69 76 65 2d 61 ) ;; archive-a
0f70: 72 65 61 2d 6e 61 6d 65 0a 09 09 09 09 20 20 28 rea-name..... (
0f80: 76 65 63 74 6f 72 2d 72 65 66 20 62 6c 6f 63 6b vector-ref block
0f90: 20 32 29 29 29 20 3b 3b 20 64 69 73 6b 2d 70 61 2))) ;; disk-pa
0fa0: 74 68 0a 09 09 09 20 20 20 20 20 20 20 65 78 69 th.... exi
0fb0: 73 74 69 6e 67 2d 62 6c 6f 63 6b 73 29 29 29 0a sting-blocks))).
0fc0: 20 20 20 20 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a (or (common:
0fd0: 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f get-disk-with-mo
0fe0: 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 63 61 st-free-space ca
0ff0: 6e 64 69 64 61 74 65 2d 64 69 73 6b 73 20 64 75 ndidate-disks du
1000: 73 65 64 29 0a 09 28 61 72 63 68 69 76 65 3a 61 sed)..(archive:a
1010: 6c 6c 6f 63 61 74 65 2d 6e 65 77 2d 61 72 63 68 llocate-new-arch
1020: 69 76 65 2d 62 6c 6f 63 6b 20 23 66 20 23 66 20 ive-block #f #f
1030: 23 66 29 29 29 29 20 3b 3b 20 42 52 4f 4b 45 4e #f)))) ;; BROKEN
1040: 2e 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 . testname itemp
1050: 61 74 68 29 29 29 29 0a 0a 3b 3b 20 61 6c 6c 6f ath))))..;; allo
1060: 63 61 74 65 20 61 20 6e 65 77 20 61 72 63 68 69 cate a new archi
1070: 76 65 20 61 72 65 61 0a 3b 3b 0a 28 64 65 66 69 ve area.;;.(defi
1080: 6e 65 20 28 61 72 63 68 69 76 65 3a 61 6c 6c 6f ne (archive:allo
1090: 63 61 74 65 2d 6e 65 77 2d 61 72 63 68 69 76 65 cate-new-archive
10a0: 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 69 64 2d 63 -block blockid-c
10b0: 61 63 68 65 20 72 75 6e 2d 61 72 65 61 2d 68 6f ache run-area-ho
10c0: 6d 65 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d me testsuite-nam
10d0: 65 20 64 6e 65 65 64 65 64 20 74 61 72 67 65 74 e dneeded target
10e0: 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 6e run-name test-n
10f0: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 ame). (let ((ke
1100: 79 20 28 63 6f 6e 63 20 74 65 73 74 73 75 69 74 y (conc testsuit
1110: 65 2d 6e 61 6d 65 20 22 2f 22 20 74 61 72 67 65 e-name "/" targe
1120: 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 t "/" run-name "
1130: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a /" test-name))).
1140: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
1150: 62 6c 65 2d 65 78 69 73 74 73 3f 20 62 6c 6f 63 ble-exists? bloc
1160: 6b 69 64 2d 63 61 63 68 65 20 6b 65 79 29 0a 09 kid-cache key)..
1170: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
1180: 62 6c 6f 63 6b 69 64 2d 63 61 63 68 65 20 6b 65 blockid-cache ke
1190: 79 29 0a 09 28 6c 65 74 2a 20 28 28 70 73 63 72 y)..(let* ((pscr
11a0: 69 70 74 20 20 20 20 20 28 63 6f 6e 66 69 67 66 ipt (configf
11b0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
11c0: 61 74 2a 20 22 61 72 63 68 69 76 65 22 20 22 70 at* "archive" "p
11d0: 61 74 68 73 63 72 69 70 74 22 29 29 0a 09 20 20 athscript"))..
11e0: 20 20 20 20 20 28 70 73 63 72 69 70 74 2d 63 6d (pscript-cm
11f0: 64 20 28 63 6f 6e 63 20 70 73 63 72 69 70 74 20 d (conc pscript
1200: 22 20 22 20 74 65 73 74 73 75 69 74 65 2d 6e 61 " " testsuite-na
1210: 6d 65 20 22 20 22 20 74 61 72 67 65 74 20 22 20 me " " target "
1220: 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 22 20 74 " run-name " " t
1230: 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 est-name))..
1240: 20 20 20 28 61 70 61 74 68 20 20 20 20 20 20 20 (apath
1250: 28 69 66 20 70 73 63 72 69 70 74 0a 09 09 09 09 (if pscript.....
1260: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
1270: 6e 73 0a 09 09 09 09 20 65 78 6e 0a 09 09 09 09 ns..... exn.....
1280: 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 28 (begin..... (
1290: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
12a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
12b0: 20 22 45 52 52 4f 52 3a 20 73 63 72 69 70 74 20 "ERROR: script
12c0: 5c 22 22 20 70 73 63 72 69 70 74 2d 63 6d 64 20 \"" pscript-cmd
12d0: 22 5c 22 20 66 61 69 6c 65 64 20 74 6f 20 72 75 "\" failed to ru
12e0: 6e 20 70 72 6f 70 65 72 6c 79 2e 20 65 78 6e 3d n properly. exn=
12f0: 22 20 65 78 6e 29 0a 09 09 09 09 20 20 20 28 65 " exn)..... (e
1300: 78 69 74 20 31 29 29 0a 09 09 09 09 20 28 77 69 xit 1))..... (wi
1310: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
1320: 70 65 0a 09 09 09 09 20 20 70 73 63 72 69 70 74 pe..... pscript
1330: 2d 63 6d 64 0a 09 09 09 09 20 20 72 65 61 64 2d -cmd..... read-
1340: 6c 69 6e 65 29 29 0a 09 09 09 09 23 66 29 29 20 line)).....#f))
1350: 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 75 ;; this is the u
1360: 73 65 72 2d 63 61 6c 63 75 6c 61 74 65 64 20 61 ser-calculated a
1370: 72 63 68 69 76 65 20 70 61 74 68 0a 09 20 20 20 rchive path..
1380: 20 20 20 20 28 61 64 69 73 6b 73 20 20 20 20 28 (adisks (
1390: 61 72 63 68 69 76 65 3a 67 65 74 2d 61 72 63 68 archive:get-arch
13a0: 69 76 65 2d 64 69 73 6b 73 29 29 0a 09 20 20 20 ive-disks))..
13b0: 20 20 20 20 28 62 65 73 74 2d 64 69 73 6b 20 28 (best-disk (
13c0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d common:get-disk-
13d0: 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 65 2d 73 with-most-free-s
13e0: 70 61 63 65 20 61 64 69 73 6b 73 20 64 6e 65 65 pace adisks dnee
13f0: 64 65 64 29 29 29 0a 09 20 20 28 69 66 20 62 65 ded))).. (if be
1400: 73 74 2d 64 69 73 6b 0a 09 20 20 20 20 20 20 28 st-disk.. (
1410: 6c 65 74 2a 20 28 28 62 64 69 73 6b 2d 6e 61 6d let* ((bdisk-nam
1420: 65 20 20 20 20 28 63 61 72 20 62 65 73 74 2d 64 e (car best-d
1430: 69 73 6b 29 29 0a 09 09 20 20 20 20 20 28 62 64 isk))... (bd
1440: 69 73 6b 2d 70 61 74 68 20 20 20 20 28 63 64 72 isk-path (cdr
1450: 20 62 65 73 74 2d 64 69 73 6b 29 29 0a 09 09 20 best-disk))...
1460: 20 20 20 20 28 61 72 65 61 2d 6b 65 79 20 20 20 (area-key
1470: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 6d (substring (m
1480: 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 essage-digest-st
1490: 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 ring (md5-primit
14a0: 69 76 65 29 20 72 75 6e 2d 61 72 65 61 2d 68 6f ive) run-area-ho
14b0: 6d 65 29 20 30 20 35 29 29 0a 09 09 20 20 20 20 me) 0 5))...
14c0: 20 28 62 64 69 73 6b 2d 69 64 20 20 20 20 20 20 (bdisk-id
14d0: 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 72 65 67 (rmt:archive-reg
14e0: 69 73 74 65 72 2d 64 69 73 6b 20 62 64 69 73 6b ister-disk bdisk
14f0: 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 70 61 74 68 -name bdisk-path
1500: 20 28 67 65 74 2d 64 66 20 62 64 69 73 6b 2d 70 (get-df bdisk-p
1510: 61 74 68 29 29 29 0a 09 09 20 20 20 20 20 28 61 ath)))... (a
1520: 72 63 68 69 76 65 2d 6e 61 6d 65 20 20 28 69 66 rchive-name (if
1530: 20 61 70 61 74 68 0a 09 09 09 09 09 61 70 61 74 apath......apat
1540: 68 0a 09 09 09 09 09 28 6c 65 74 20 28 28 73 65 h......(let ((se
1550: 63 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e c (current-secon
1560: 64 73 29 29 29 0a 09 09 09 09 09 20 20 28 63 6f ds)))...... (co
1570: 6e 63 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 nc (time->string
1580: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
1590: 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 22 29 -time sec) "%Y")
15a0: 0a 09 09 09 09 09 09 22 5f 71 22 20 28 73 65 63 ......."_q" (sec
15b0: 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 73 65 onds->quarter se
15c0: 63 29 20 22 2f 22 0a 09 09 09 09 09 09 74 65 73 c) "/".......tes
15d0: 74 73 75 69 74 65 2d 6e 61 6d 65 20 22 5f 22 20 tsuite-name "_"
15e0: 61 72 65 61 2d 6b 65 79 29 29 29 29 0a 09 09 20 area-key))))...
15f0: 20 20 20 20 28 61 72 63 68 69 76 65 2d 70 61 74 (archive-pat
1600: 68 20 20 28 63 6f 6e 63 20 62 64 69 73 6b 2d 70 h (conc bdisk-p
1610: 61 74 68 20 22 2f 22 20 61 72 63 68 69 76 65 2d ath "/" archive-
1620: 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 20 28 62 name))... (b
1630: 6c 6f 63 6b 2d 69 64 20 20 20 20 20 20 28 72 6d lock-id (rm
1640: 74 3a 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 t:archive-regist
1650: 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 62 64 er-block-name bd
1660: 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 isk-id archive-p
1670: 61 74 68 29 29 29 0a 09 09 3b 3b 20 20 20 28 61 ath)))...;; (a
1680: 6c 6c 6f 63 61 74 69 6f 6e 2d 69 64 20 28 72 6d llocation-id (rm
1690: 74 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 t:archive-alloca
16a0: 74 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 te-testsuite/are
16b0: 61 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b a-to-block block
16c0: 2d 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 -id testsuite-na
16d0: 6d 65 20 61 72 65 61 2d 6b 65 79 29 29 29 0a 09 me area-key)))..
16e0: 09 28 69 66 20 62 6c 6f 63 6b 2d 69 64 20 3b 3b .(if block-id ;;
16f0: 20 28 61 6e 64 20 62 6c 6f 63 6b 2d 69 64 20 61 (and block-id a
1700: 6c 6c 6f 63 61 74 69 6f 6e 2d 69 64 29 0a 09 09 llocation-id)...
1710: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
1720: 63 6f 6e 73 20 62 6c 6f 63 6b 2d 69 64 20 61 72 cons block-id ar
1730: 63 68 69 76 65 2d 70 61 74 68 29 29 29 0a 09 09 chive-path)))...
1740: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
1750: 65 2d 73 65 74 21 20 62 6c 6f 63 6b 69 64 2d 63 e-set! blockid-c
1760: 61 63 68 65 20 6b 65 79 20 72 65 73 29 0a 09 09 ache key res)...
1770: 20 20 20 20 20 20 72 65 73 29 0a 09 09 20 20 20 res)...
1780: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
1790: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
17a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
17b0: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 64 * "WARNING: no d
17c0: 69 73 6b 20 66 6f 75 6e 64 20 66 6f 72 20 22 20 isk found for "
17d0: 74 61 72 67 65 74 20 22 2c 20 22 20 72 75 6e 2d target ", " run-
17e0: 6e 61 6d 65 20 22 2c 20 22 20 74 65 73 74 2d 6e name ", " test-n
17f0: 61 6d 65 20 22 2c 20 20 61 72 63 68 69 76 65 2d ame ", archive-
1800: 70 61 74 68 3d 22 20 61 72 63 68 69 76 65 2d 70 path=" archive-p
1810: 61 74 68 29 0a 09 09 20 20 20 20 20 20 23 66 29 ath)... #f)
1820: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
1830: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
1840: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1850: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e ort* "WARNING: n
1860: 6f 20 64 69 73 6b 20 66 6f 75 6e 64 20 66 6f 72 o disk found for
1870: 20 22 20 74 61 72 67 65 74 20 22 2c 20 22 20 72 " target ", " r
1880: 75 6e 2d 6e 61 6d 65 20 22 2c 20 22 20 74 65 73 un-name ", " tes
1890: 74 2d 6e 61 6d 65 20 29 0a 09 09 23 66 29 29 29 t-name )...#f)))
18a0: 29 29 29 20 3b 3b 20 6e 6f 20 62 65 73 74 20 64 ))) ;; no best d
18b0: 69 73 6b 20 66 6f 75 6e 64 0a 0a 3b 3b 20 61 72 isk found..;; ar
18c0: 63 68 69 76 65 20 2d 20 72 75 6e 20 62 75 70 0a chive - run bup.
18d0: 3b 3b 0a 3b 3b 20 31 2e 20 63 72 65 61 74 65 20 ;;.;; 1. create
18e0: 74 68 65 20 62 75 70 20 64 69 72 20 69 66 20 6e the bup dir if n
18f0: 6f 74 20 65 78 69 73 74 73 0a 3b 3b 20 32 2e 20 ot exists.;; 2.
1900: 73 74 61 72 74 20 74 68 65 20 64 75 20 6f 66 20 start the du of
1910: 65 61 63 68 20 64 69 72 65 63 74 6f 72 79 0a 3b each directory.;
1920: 3b 20 33 2e 20 67 65 6e 20 69 6e 64 65 78 0a 3b ; 3. gen index.;
1930: 3b 20 34 2e 20 73 61 76 65 0a 3b 3b 0a 28 64 65 ; 4. save.;;.(de
1940: 66 69 6e 65 20 28 61 72 63 68 69 76 65 3a 72 75 fine (archive:ru
1950: 6e 2d 62 75 70 20 61 72 63 68 69 76 65 2d 63 6f n-bup archive-co
1960: 6d 6d 61 6e 64 20 72 75 6e 2d 69 64 20 72 75 6e mmand run-id run
1970: 2d 6e 61 6d 65 20 74 65 73 74 73 20 72 70 2d 6d -name tests rp-m
1980: 75 74 65 78 20 62 75 70 2d 6d 75 74 65 78 29 0a utex bup-mutex).
1990: 20 20 3b 3b 20 6d 6f 76 65 20 74 68 65 20 67 65 ;; move the ge
19a0: 74 74 69 6e 67 20 6f 66 20 61 72 63 68 69 76 65 tting of archive
19b0: 20 73 70 61 63 65 20 64 6f 77 6e 20 69 6e 74 6f space down into
19c0: 20 74 68 65 20 62 65 6c 6f 77 20 62 6c 6f 63 6b the below block
19d0: 20 73 6f 20 74 68 61 74 20 61 20 73 69 6e 67 6c so that a singl
19e0: 65 20 72 75 6e 20 63 61 6e 20 0a 20 20 3b 3b 20 e run can . ;;
19f0: 61 6c 6c 6f 63 61 74 65 20 61 73 20 6e 65 65 64 allocate as need
1a00: 65 64 20 73 68 6f 75 6c 64 20 61 20 64 69 73 6b ed should a disk
1a10: 20 66 69 6c 6c 20 75 70 0a 20 20 3b 3b 0a 20 20 fill up. ;;.
1a20: 28 6c 65 74 2a 20 28 28 62 6c 6f 63 6b 69 64 2d (let* ((blockid-
1a30: 63 61 63 68 65 20 20 28 6d 61 6b 65 2d 68 61 73 cache (make-has
1a40: 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 73 6e h-table)).. (tsn
1a50: 61 6d 65 20 20 20 20 20 20 20 20 20 28 63 6f 6d ame (com
1a60: 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d mon:get-area-nam
1a70: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 e)). (ta
1a80: 72 67 65 74 20 20 20 20 20 20 20 20 20 28 73 74 rget (st
1a90: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
1aa0: 20 28 6d 61 70 20 63 61 64 72 20 28 72 6d 74 3a (map cadr (rmt:
1ab0: 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 get-key-val-pair
1ac0: 73 20 72 75 6e 2d 69 64 29 29 20 22 2f 22 29 29 s run-id)) "/"))
1ad0: 0a 09 20 28 6d 69 6e 2d 73 70 61 63 65 20 20 20 .. (min-space
1ae0: 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (string->numb
1af0: 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a er (or (configf:
1b00: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
1b10: 74 2a 20 22 61 72 63 68 69 76 65 22 20 22 6d 69 t* "archive" "mi
1b20: 6e 73 70 61 63 65 22 29 20 22 31 30 30 30 22 29 nspace") "1000")
1b30: 29 29 0a 09 20 28 61 72 63 68 2d 67 72 6f 75 70 )).. (arch-group
1b40: 73 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d s (make-hash-
1b50: 74 61 62 6c 65 29 29 20 3b 3b 20 61 72 63 68 69 table)) ;; archi
1b60: 76 65 20 67 72 6f 75 70 73 2c 20 65 61 63 68 20 ve groups, each
1b70: 63 6f 72 72 6f 73 70 6f 6e 64 73 20 74 6f 20 61 corrosponds to a
1b80: 20 62 75 70 20 61 72 65 61 0a 09 20 28 64 69 73 bup area.. (dis
1b90: 6b 2d 67 72 6f 75 70 73 20 20 20 20 28 6d 61 6b k-groups (mak
1ba0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1bb0: 3b 20 0a 09 20 28 74 65 73 74 2d 67 72 6f 75 70 ; .. (test-group
1bc0: 73 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d s (make-hash-
1bd0: 74 61 62 6c 65 29 29 20 3b 3b 20 74 68 65 73 65 table)) ;; these
1be0: 20 74 77 6f 20 28 64 69 73 6b 20 61 6e 64 20 74 two (disk and t
1bf0: 65 73 74 20 67 72 6f 75 70 73 29 20 63 6f 75 6c est groups) coul
1c00: 64 20 62 65 20 63 6f 6d 62 69 6e 65 64 20 6e 69 d be combined ni
1c10: 63 65 6c 79 0a 09 20 28 74 65 73 74 2d 64 69 72 cely.. (test-dir
1c20: 73 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 s (make-has
1c30: 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 62 75 70 h-table)).. (bup
1c40: 2d 65 78 65 20 20 20 20 20 20 20 20 28 6f 72 20 -exe (or
1c50: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
1c60: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 61 72 63 *configdat* "arc
1c70: 68 69 76 65 22 20 22 62 75 70 22 29 20 22 62 75 hive" "bup") "bu
1c80: 70 22 29 29 0a 09 20 28 63 6f 6d 70 72 65 73 73 p")).. (compress
1c90: 20 20 20 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 (or (conf
1ca0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
1cb0: 69 67 64 61 74 2a 20 22 61 72 63 68 69 76 65 22 igdat* "archive"
1cc0: 20 22 63 6f 6d 70 72 65 73 73 22 29 20 22 39 22 "compress") "9"
1cd0: 29 29 0a 09 20 28 6c 69 6e 6b 74 72 65 65 20 20 )).. (linktree
1ce0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
1cf0: 2d 6c 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 -linktree)) ;; (
1d00: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
1d10: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
1d20: 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 p" "linktree")))
1d30: 0a 09 20 28 61 72 63 68 69 76 65 72 20 20 20 20 .. (archiver
1d40: 20 20 20 28 6c 65 74 20 28 28 73 20 28 63 6f 6e (let ((s (con
1d50: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
1d60: 66 69 67 64 61 74 2a 20 22 61 72 63 68 69 76 65 figdat* "archive
1d70: 22 20 22 61 72 63 68 69 76 65 72 22 29 29 29 0a " "archiver"))).
1d80: 09 09 09 20 20 20 28 69 66 20 73 20 28 73 74 72 ... (if s (str
1d90: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 29 20 27 ing->symbol s) '
1da0: 62 75 70 29 29 29 0a 09 20 28 61 72 63 68 69 76 bup))).. (archiv
1db0: 65 72 2d 63 6d 64 20 20 20 28 63 61 73 65 20 61 er-cmd (case a
1dc0: 72 63 68 69 76 65 72 0a 09 09 09 20 20 20 28 28 rchiver.... ((
1dd0: 74 61 72 29 20 22 74 61 72 20 63 66 6a 20 41 52 tar) "tar cfj AR
1de0: 43 48 49 56 45 5f 4e 41 4d 45 2e 74 61 72 2e 62 CHIVE_NAME.tar.b
1df0: 7a 32 20 22 29 0a 09 09 09 20 20 20 28 28 37 7a z2 ").... ((7z
1e00: 29 20 20 22 20 37 7a 20 75 20 2d 74 37 7a 20 2d ) " 7z u -t7z -
1e10: 6d 30 3d 6c 7a 6d 61 20 2d 6d 78 3d 39 20 2d 6d m0=lzma -mx=9 -m
1e20: 66 62 3d 36 34 20 2d 6d 64 3d 33 32 6d 20 2d 6d fb=64 -md=32m -m
1e30: 73 3d 6f 6e 20 41 52 43 48 49 56 45 5f 4e 41 4d s=on ARCHIVE_NAM
1e40: 45 2e 37 7a 20 22 29 0a 09 09 09 20 20 20 28 65 E.7z ").... (e
1e50: 6c 73 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 lse #f))).
1e60: 20 20 20 28 73 72 63 2d 61 72 63 68 69 76 65 2d (src-archive-
1e70: 6c 69 6e 6b 74 72 65 65 20 28 72 6d 74 3a 67 65 linktree (rmt:ge
1e80: 74 2d 76 61 72 20 72 75 6e 2d 69 64 20 22 73 72 t-var run-id "sr
1e90: 63 2d 61 72 63 68 69 76 65 2d 6c 69 6e 6b 74 72 c-archive-linktr
1ea0: 65 65 22 29 29 20 20 0a 09 20 28 70 72 69 6e 74 ee")) .. (print
1eb0: 2d 70 72 65 66 69 78 20 20 20 20 20 20 22 52 75 -prefix "Ru
1ec0: 6e 6e 69 6e 67 3a 20 22 29 20 3b 3b 20 63 68 61 nning: ") ;; cha
1ed0: 6e 67 65 20 74 6f 20 23 66 20 74 6f 20 74 75 72 nge to #f to tur
1ee0: 6e 20 6f 66 66 20 70 72 69 6e 74 69 6e 67 0a 09 n off printing..
1ef0: 20 28 70 72 65 63 6c 65 61 6e 2d 73 70 65 63 20 (preclean-spec
1f00: 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 (configf:get-se
1f10: 63 74 69 6f 6e 20 2a 63 6f 6e 66 69 67 64 61 74 ction *configdat
1f20: 2a 20 22 61 72 63 68 69 76 65 2d 70 72 65 63 6c * "archive-precl
1f30: 65 61 6e 22 29 29 29 0a 0a 20 20 20 20 20 28 69 ean"))).. (i
1f40: 66 20 28 6f 72 20 28 6e 6f 74 20 73 72 63 2d 61 f (or (not src-a
1f50: 72 63 68 69 76 65 2d 6c 69 6e 6b 74 72 65 65 29 rchive-linktree)
1f60: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 72 (not (equal? sr
1f70: 63 2d 61 72 63 68 69 76 65 2d 6c 69 6e 6b 74 72 c-archive-linktr
1f80: 65 65 20 6c 69 6e 6b 74 72 65 65 29 29 29 20 20 ee linktree)))
1f90: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 28 72 . (r
1fa0: 6d 74 3a 73 65 74 2d 76 61 72 20 22 73 72 63 2d mt:set-var "src-
1fb0: 61 72 63 68 69 76 65 2d 6c 69 6e 6b 74 72 65 65 archive-linktree
1fc0: 22 20 20 6c 69 6e 6b 74 72 65 65 29 29 0a 20 20 " linktree)).
1fd0: 20 20 3b 3b 20 20 20 20 20 28 74 65 73 74 73 3a ;; (tests:
1fe0: 6d 61 74 63 68 20 70 61 74 74 20 74 65 73 74 6e match patt testn
1ff0: 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 20 ame itempath).
2000: 20 20 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 . ;; from t
2010: 68 65 20 74 65 73 74 20 69 6e 66 6f 20 62 69 6e he test info bin
2020: 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 the path to the
2030: 20 74 65 73 74 20 62 79 20 73 74 65 6d 0a 20 20 test by stem.
2040: 20 20 3b 3b 0a 20 20 20 20 28 66 6f 72 2d 65 61 ;;. (for-ea
2050: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
2060: 28 74 65 73 74 2d 64 61 74 29 0a 20 20 20 20 20 (test-dat).
2070: 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 (let* ((item-p
2080: 61 74 68 20 20 20 20 20 20 20 20 20 28 64 62 3a ath (db:
2090: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
20a0: 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 th test-dat))..
20b0: 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 (test-name
20c0: 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 (db:test
20d0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 -get-testname t
20e0: 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 est-dat))..
20f0: 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 20 (test-id
2100: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
2110: 2d 69 64 20 20 20 20 20 20 20 20 74 65 73 74 2d -id test-
2120: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 72 75 dat)).. (ru
2130: 6e 2d 69 64 20 20 20 20 20 20 20 20 20 20 20 20 n-id
2140: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
2150: 5f 69 64 20 20 20 20 74 65 73 74 2d 64 61 74 29 _id test-dat)
2160: 29 0a 09 20 20 20 20 20 20 09 20 20 20 20 20 20 ).. .
2170: 0a 09 20 20 20 20 20 20 28 74 6f 70 6c 65 76 65 .. (topleve
2180: 6c 2f 63 68 69 6c 64 72 65 6e 20 28 61 6e 64 20 l/children (and
2190: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 73 2d (db:test-get-is-
21a0: 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 2d 64 61 toplevel test-da
21b0: 74 29 0a 09 09 09 09 20 20 20 20 20 20 28 3e 20 t)..... (>
21c0: 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 76 (rmt:test-toplev
21d0: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
21e0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 20 30 -id test-name) 0
21f0: 29 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 ))).. (test
2200: 2d 70 61 72 74 69 61 6c 2d 70 61 74 68 20 28 63 -partial-path (c
2210: 6f 6e 63 20 74 61 72 67 65 74 20 22 2f 22 20 72 onc target "/" r
2220: 75 6e 2d 6e 61 6d 65 20 22 2f 22 20 28 64 62 3a un-name "/" (db:
2230: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
2240: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
2250: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 em-path)))..
2260: 20 20 3b 3b 20 6e 6f 74 65 20 74 68 65 20 74 72 ;; note the tr
2270: 61 69 6c 69 6e 67 20 73 6c 61 73 68 20 74 6f 20 ailing slash to
2280: 67 65 74 20 74 68 65 20 64 69 72 20 69 6e 73 70 get the dir insp
2290: 69 74 65 20 6f 66 20 69 74 20 62 65 69 6e 67 20 ite of it being
22a0: 61 20 6c 69 6e 6b 0a 09 20 20 20 20 20 20 28 74 a link.. (t
22b0: 65 73 74 2d 70 61 74 68 20 20 20 20 20 20 20 20 est-path
22c0: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
22d0: 22 2f 22 20 74 65 73 74 2d 70 61 72 74 69 61 6c "/" test-partial
22e0: 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 -path)).. (
22f0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 72 70 2d 6d mutex-lock! rp-m
2300: 75 74 65 78 29 0a 09 20 20 20 20 20 20 28 74 65 utex).. (te
2310: 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 st-physical-path
2320: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (if (common:fil
2330: 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 70 e-exists? test-p
2340: 61 74 68 29 20 0a 09 09 09 09 20 20 20 20 20 20 ath) .....
2350: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 (common:real-pat
2360: 68 20 74 65 73 74 2d 70 61 74 68 29 0a 09 09 09 h test-path)....
2370: 09 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 20 . #f))..
2380: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
2390: 21 20 72 70 2d 6d 75 74 65 78 29 0a 09 20 20 20 ! rp-mutex)..
23a0: 20 20 20 28 70 61 72 74 69 61 6c 2d 70 61 74 68 (partial-path
23b0: 2d 69 6e 64 65 78 20 28 69 66 20 74 65 73 74 2d -index (if test-
23c0: 70 68 79 73 69 63 61 6c 2d 70 61 74 68 20 28 73 physical-path (s
23d0: 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 74 ubstring-index t
23e0: 65 73 74 2d 70 61 72 74 69 61 6c 2d 70 61 74 68 est-partial-path
23f0: 20 74 65 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 test-physical-p
2400: 61 74 68 29 20 23 66 29 29 0a 09 20 20 20 20 20 ath) #f))..
2410: 20 28 74 65 73 74 2d 62 61 73 65 20 20 20 20 20 (test-base
2420: 20 20 20 20 28 69 66 20 28 61 6e 64 20 70 61 72 (if (and par
2430: 74 69 61 6c 2d 70 61 74 68 2d 69 6e 64 65 78 20 tial-path-index
2440: 0a 09 09 09 09 09 20 20 74 65 73 74 2d 70 68 79 ...... test-phy
2450: 73 69 63 61 6c 2d 70 61 74 68 20 29 0a 09 09 09 sical-path )....
2460: 09 20 20 20 20 20 28 73 75 62 73 74 72 69 6e 67 . (substring
2470: 20 74 65 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 test-physical-p
2480: 61 74 68 0a 09 09 09 09 09 09 30 0a 09 09 09 09 ath.......0.....
2490: 09 09 70 61 72 74 69 61 6c 2d 70 61 74 68 2d 69 ..partial-path-i
24a0: 6e 64 65 78 29 0a 09 09 09 09 20 20 20 20 20 23 ndex)..... #
24b0: 66 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 77 65 f)).. ;; we
24c0: 20 6e 65 65 64 20 6f 75 72 20 61 72 63 68 69 76 need our archiv
24d0: 65 20 64 69 72 20 63 68 65 63 6b 65 64 20 66 6f e dir checked fo
24e0: 72 20 65 76 65 72 79 20 74 65 73 74 20 74 6f 20 r every test to
24f0: 65 6e 61 62 6c 65 20 66 6f 6c 6b 73 20 77 68 6f enable folks who
2500: 20 77 61 6e 74 20 74 6f 20 73 74 6f 72 65 20 6f want to store o
2510: 74 68 65 72 20 77 61 79 73 2e 0a 09 20 20 20 20 ther ways...
2520: 20 20 28 61 72 63 68 69 76 65 2d 69 6e 66 6f 20 (archive-info
2530: 28 61 72 63 68 69 76 65 3a 61 6c 6c 6f 63 61 74 (archive:allocat
2540: 65 2d 6e 65 77 2d 61 72 63 68 69 76 65 2d 62 6c e-new-archive-bl
2550: 6f 63 6b 20 62 6c 6f 63 6b 69 64 2d 63 61 63 68 ock blockid-cach
2560: 65 20 2a 74 6f 70 70 61 74 68 2a 20 74 73 6e 61 e *toppath* tsna
2570: 6d 65 20 6d 69 6e 2d 73 70 61 63 65 20 74 61 72 me min-space tar
2580: 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 get run-name tes
2590: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 t-name))..
25a0: 28 61 72 63 68 69 76 65 2d 64 69 72 20 20 28 69 (archive-dir (i
25b0: 66 20 61 72 63 68 69 76 65 2d 69 6e 66 6f 20 28 f archive-info (
25c0: 63 64 72 20 61 72 63 68 69 76 65 2d 69 6e 66 6f cdr archive-info
25d0: 29 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 61 ) #f)).. (a
25e0: 72 63 68 69 76 65 2d 69 64 20 20 20 28 69 66 20 rchive-id (if
25f0: 61 72 63 68 69 76 65 2d 69 6e 66 6f 20 28 63 61 archive-info (ca
2600: 72 20 61 72 63 68 69 76 65 2d 69 6e 66 6f 29 20 r archive-info)
2610: 2d 31 29 29 29 0a 09 20 0a 09 20 28 69 66 20 28 -1))).. .. (if (
2620: 6e 6f 74 20 61 72 63 68 69 76 65 2d 64 69 72 29 not archive-dir)
2630: 20 3b 3b 20 6e 6f 20 61 72 63 68 69 76 65 20 64 ;; no archive d
2640: 69 73 6b 20 66 6f 75 6e 64 2c 20 74 68 69 73 20 isk found, this
2650: 69 73 20 66 61 74 61 6c 0a 09 20 20 20 20 20 28 is fatal.. (
2660: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 64 begin.. (d
2670: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
2680: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2690: 22 46 41 54 41 4c 3a 20 4e 6f 20 61 72 63 68 69 "FATAL: No archi
26a0: 76 65 20 64 69 73 6b 73 20 66 6f 75 6e 64 2e 20 ve disks found.
26b0: 50 6c 65 61 73 65 20 61 64 64 20 64 69 73 6b 73 Please add disks
26c0: 20 77 69 74 68 20 61 74 20 6c 65 61 73 74 20 22 with at least "
26d0: 0a 09 09 09 20 20 20 20 6d 69 6e 2d 73 70 61 63 .... min-spac
26e0: 65 20 22 20 4d 42 20 73 70 61 63 65 20 74 6f 20 e " MB space to
26f0: 74 68 65 20 5b 61 72 63 68 69 76 65 2d 64 69 73 the [archive-dis
2700: 6b 73 5d 20 73 65 63 74 69 6f 6e 20 6f 66 20 6d ks] section of m
2710: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 egatest.config")
2720: 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
2730: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2740: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 20 -log-port* "
2750: 20 20 20 75 73 65 20 5b 61 72 63 68 69 76 65 5d use [archive]
2760: 20 6d 69 6e 73 70 61 63 65 20 74 6f 20 73 70 65 minspace to spe
2770: 63 69 66 79 20 6d 69 6e 69 6d 75 6d 20 61 76 61 cify minimum ava
2780: 69 6c 61 62 6c 65 20 73 70 61 63 65 22 29 0a 09 ilable space")..
2790: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
27a0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
27b0: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 64 69 73 og-port* " dis
27c0: 6b 73 3a 20 22 0a 09 09 09 20 20 20 20 28 73 74 ks: ".... (st
27d0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
27e0: 20 28 6d 61 70 20 63 61 64 72 20 28 61 72 63 68 (map cadr (arch
27f0: 69 76 65 3a 67 65 74 2d 61 72 63 68 69 76 65 2d ive:get-archive-
2800: 64 69 73 6b 73 29 29 20 22 5c 6e 20 20 20 20 20 disks)) "\n
2810: 20 20 20 20 22 29 29 0a 09 20 20 20 20 20 20 20 "))..
2820: 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 20 (exit 1))..
2830: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2840: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2850: 2d 70 6f 72 74 2a 20 22 55 73 69 6e 67 20 70 61 -port* "Using pa
2860: 74 68 20 22 20 61 72 63 68 69 76 65 2d 64 69 72 th " archive-dir
2870: 20 22 20 66 6f 72 20 61 72 63 68 69 76 69 6e 67 " for archiving
2880: 20 74 65 73 74 20 22 20 74 65 73 74 2d 70 61 74 test " test-pat
2890: 68 29 29 0a 0a 09 20 3b 3b 20 70 72 65 63 6c 65 h))... ;; precle
28a0: 61 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 65 an the test dire
28b0: 63 74 6f 72 79 20 70 65 72 20 74 68 65 20 73 70 ctory per the sp
28c0: 65 63 20 69 66 20 70 72 6f 76 69 64 65 64 0a 09 ec if provided..
28d0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
28e0: 20 70 72 65 63 6c 65 61 6e 2d 73 70 65 63 29 29 preclean-spec))
28f0: 20 3b 3b 20 77 65 27 76 65 20 62 65 65 6e 20 61 ;; we've been a
2900: 73 6b 65 64 20 74 6f 20 70 72 65 63 6c 65 61 6e sked to preclean
2910: 20 62 65 66 6f 72 65 20 61 72 63 68 69 76 69 6e before archivin
2920: 67 0a 09 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f g.. (let loo
2930: 70 20 28 28 73 70 65 63 20 28 63 61 72 20 70 72 p ((spec (car pr
2940: 65 63 6c 65 61 6e 2d 73 70 65 63 29 29 0a 09 09 eclean-spec))...
2950: 09 28 74 61 69 6c 20 28 63 64 72 20 70 72 65 63 .(tail (cdr prec
2960: 6c 65 61 6e 2d 73 70 65 63 29 29 29 0a 09 20 20 lean-spec)))..
2970: 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e (if (> (len
2980: 67 74 68 20 73 70 65 63 29 20 31 29 0a 09 09 20 gth spec) 1)...
2990: 20 20 28 6c 65 74 20 28 28 74 65 73 74 73 70 65 (let ((testspe
29a0: 63 20 28 63 61 72 20 73 70 65 63 29 29 0a 09 09 c (car spec))...
29b0: 09 20 28 72 75 6c 65 73 20 20 20 20 28 63 61 64 . (rules (cad
29c0: 72 20 73 70 65 63 29 29 29 0a 09 09 20 20 20 20 r spec)))...
29d0: 20 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 (if (tests:matc
29e0: 68 20 74 65 73 74 73 70 65 63 20 74 65 73 74 2d h testspec test-
29f0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
2a00: 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 20 ... (begin....
2a10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2a20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2a30: 74 2a 20 22 49 4e 46 4f 3a 20 63 6c 65 61 6e 75 t* "INFO: cleanu
2a40: 70 20 72 65 71 75 65 73 74 65 64 20 66 6f 72 20 p requested for
2a50: 22 20 74 65 73 74 2d 70 68 79 73 69 63 61 6c 2d " test-physical-
2a60: 70 61 74 68 29 0a 09 09 09 20 20 20 28 63 6f 6d path).... (com
2a70: 6d 6f 6e 3a 64 69 72 2d 63 6c 65 61 6e 2d 75 70 mon:dir-clean-up
2a80: 20 74 65 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 test-physical-p
2a90: 61 74 68 20 72 75 6c 65 73 20 72 65 6d 6f 76 65 ath rules remove
2aa0: 2d 65 6d 70 74 79 3a 20 23 74 29 29 0a 09 09 09 -empty: #t))....
2ab0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
2ac0: 20 74 61 69 6c 29 29 0a 09 09 09 20 20 20 20 20 tail))....
2ad0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c 29 (loop (car tail)
2ae0: 28 63 64 72 20 74 61 69 6c 29 29 29 29 29 0a 09 (cdr tail)))))..
2af0: 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 . (begin...
2b00: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2b10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2b20: 72 74 2a 20 22 45 52 52 4f 52 3a 20 62 61 64 20 rt* "ERROR: bad
2b30: 73 70 65 63 20 6c 69 6e 65 20 69 6e 20 5b 61 72 spec line in [ar
2b40: 63 68 69 76 65 2d 70 72 65 63 6c 65 61 6e 5d 20 chive-preclean]
2b50: 73 65 63 74 69 6f 6e 2e 20 5c 22 22 20 73 70 65 section. \"" spe
2b60: 63 20 22 5c 22 22 29 0a 09 09 20 20 20 20 20 28 c "\"")... (
2b70: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
2b80: 61 69 6c 29 29 28 6c 6f 6f 70 20 28 63 61 72 20 ail))(loop (car
2b90: 74 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 29 tail)(cdr tail))
2ba0: 29 29 29 29 29 0a 09 20 28 63 6f 6e 64 0a 09 20 ))))).. (cond..
2bb0: 20 28 74 6f 70 6c 65 76 65 6c 2f 63 68 69 6c 64 (toplevel/child
2bc0: 72 65 6e 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ren.. (debug:p
2bd0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2be0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
2bf0: 4e 47 3a 20 63 61 6e 6e 6f 74 20 61 72 63 68 69 NG: cannot archi
2c00: 76 65 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 ve " test-name "
2c10: 20 77 69 74 68 20 69 64 20 22 20 74 65 73 74 2d with id " test-
2c20: 69 64 0a 09 09 09 22 20 61 73 20 69 74 20 69 73 id...." as it is
2c30: 20 61 20 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 a toplevel test
2c40: 20 77 69 74 68 20 63 68 69 6c 64 72 65 6e 22 29 with children")
2c50: 29 0a 09 20 20 28 28 6e 6f 74 20 28 63 6f 6d 6d ).. ((not (comm
2c60: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
2c70: 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 test-path))..
2c80: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2c90: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2ca0: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e * "WARNING: Cann
2cb0: 6f 74 20 61 72 63 68 69 76 65 20 22 20 74 65 73 ot archive " tes
2cc0: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
2cd0: 70 61 74 68 0a 09 09 09 22 20 61 73 20 70 61 74 path...." as pat
2ce0: 68 20 22 20 74 65 73 74 2d 70 61 74 68 20 22 20 h " test-path "
2cf0: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 22 29 does not exist")
2d00: 29 0a 09 20 20 28 65 6c 73 65 0a 09 20 20 20 28 ).. (else.. (
2d10: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 debug:print 2 *d
2d20: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2d30: 0a 09 09 09 22 46 72 6f 6d 20 74 65 73 74 2d 64 ...."From test-d
2d40: 61 74 3d 22 20 74 65 73 74 2d 64 61 74 20 22 20 at=" test-dat "
2d50: 64 65 72 69 76 65 64 20 74 68 65 20 66 6f 6c 6c derived the foll
2d60: 6f 77 69 6e 67 3a 5c 6e 22 0a 09 09 09 22 74 65 owing:\n"...."te
2d70: 73 74 2d 70 61 72 74 69 61 6c 2d 70 61 74 68 20 st-partial-path
2d80: 20 3d 20 22 20 74 65 73 74 2d 70 61 72 74 69 61 = " test-partia
2d90: 6c 2d 70 61 74 68 20 22 5c 6e 22 0a 09 09 09 22 l-path "\n"...."
2da0: 74 65 73 74 2d 70 61 74 68 20 20 20 20 20 20 20 test-path
2db0: 20 20 20 3d 20 22 20 74 65 73 74 2d 70 61 74 68 = " test-path
2dc0: 20 22 5c 6e 22 0a 09 09 09 22 74 65 73 74 2d 70 "\n"...."test-p
2dd0: 68 79 73 69 63 61 6c 2d 70 61 74 68 20 3d 20 22 hysical-path = "
2de0: 20 74 65 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 test-physical-p
2df0: 61 74 68 20 22 5c 6e 22 0a 09 09 09 22 70 61 72 ath "\n"...."par
2e00: 74 69 61 6c 2d 70 61 74 68 2d 69 6e 64 65 78 20 tial-path-index
2e10: 3d 20 22 20 70 61 72 74 69 61 6c 2d 70 61 74 68 = " partial-path
2e20: 2d 69 6e 64 65 78 20 22 5c 6e 22 0a 09 09 09 22 -index "\n"...."
2e30: 74 65 73 74 2d 62 61 73 65 20 20 20 20 20 20 20 test-base
2e40: 20 20 20 3d 20 22 20 74 65 73 74 2d 62 61 73 65 = " test-base
2e50: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl
2e60: 65 2d 73 65 74 21 20 64 69 73 6b 2d 67 72 6f 75 e-set! disk-grou
2e70: 70 73 20 74 65 73 74 2d 62 61 73 65 0a 09 09 09 ps test-base....
2e80: 20 20 20 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 (cons test-p
2e90: 68 79 73 69 63 61 6c 2d 70 61 74 68 20 28 68 61 hysical-path (ha
2ea0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
2eb0: 61 75 6c 74 20 64 69 73 6b 2d 67 72 6f 75 70 73 ault disk-groups
2ec0: 20 74 65 73 74 2d 62 61 73 65 20 27 28 29 29 29 test-base '()))
2ed0: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl
2ee0: 65 2d 73 65 74 21 20 74 65 73 74 2d 67 72 6f 75 e-set! test-grou
2ef0: 70 73 20 74 65 73 74 2d 62 61 73 65 0a 09 09 09 ps test-base....
2f00: 20 20 20 20 28 63 6f 6e 73 20 74 65 73 74 2d 64 (cons test-d
2f10: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
2f20: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
2f30: 67 72 6f 75 70 73 20 74 65 73 74 2d 62 61 73 65 groups test-base
2f40: 20 27 28 29 29 29 29 0a 09 20 20 20 28 68 61 73 '()))).. (has
2f50: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 61 72 63 h-table-set! arc
2f60: 68 2d 67 72 6f 75 70 73 20 74 65 73 74 2d 62 61 h-groups test-ba
2f70: 73 65 0a 09 09 09 20 20 20 20 28 63 6f 6e 73 20 se.... (cons
2f80: 61 72 63 68 69 76 65 2d 69 6e 66 6f 20 28 68 61 archive-info (ha
2f90: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
2fa0: 61 75 6c 74 20 61 72 63 68 2d 67 72 6f 75 70 73 ault arch-groups
2fb0: 20 74 65 73 74 2d 62 61 73 65 20 27 28 29 29 29 test-base '()))
2fc0: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl
2fd0: 65 2d 73 65 74 21 20 74 65 73 74 2d 64 69 72 73 e-set! test-dirs
2fe0: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 70 61 test-id test-pa
2ff0: 74 68 29 29 29 29 29 0a 09 20 20 20 3b 3b 20 74 th))))).. ;; t
3000: 65 73 74 2d 70 61 74 68 29 29 29 29 0a 20 20 20 est-path)))).
3010: 20 20 74 65 73 74 73 29 0a 20 20 20 20 28 64 65 tests). (de
3020: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3030: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3040: 49 4e 46 4f 3a 20 44 49 53 4b 20 47 52 4f 55 50 INFO: DISK GROUP
3050: 53 3d 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d S=" (hash-table-
3060: 3e 61 6c 69 73 74 20 64 69 73 6b 2d 67 72 6f 75 >alist disk-grou
3070: 70 73 29 29 0a 20 20 20 20 3b 3b 20 66 6f 72 20 ps)). ;; for
3080: 65 61 63 68 20 64 69 73 6b 2d 67 72 6f 75 70 2c each disk-group,
3090: 20 69 6e 69 74 69 61 6c 69 7a 65 20 74 68 65 20 initialize the
30a0: 62 75 70 20 61 72 65 61 20 69 66 20 6e 65 65 64 bup area if need
30b0: 65 64 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ed. (for-each
30c0: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
30d0: 74 65 73 74 2d 62 61 73 65 29 0a 20 20 20 20 20 test-base).
30e0: 20 20 28 6c 65 74 2a 20 28 28 64 69 73 6b 2d 67 (let* ((disk-g
30f0: 72 6f 75 70 20 28 68 61 73 68 2d 74 61 62 6c 65 roup (hash-table
3100: 2d 72 65 66 20 64 69 73 6b 2d 67 72 6f 75 70 73 -ref disk-groups
3110: 20 74 65 73 74 2d 62 61 73 65 29 29 0a 09 20 20 test-base))..
3120: 20 20 20 20 28 61 72 63 68 2d 67 72 6f 75 70 20 (arch-group
3130: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
3140: 61 72 63 68 2d 67 72 6f 75 70 73 20 74 65 73 74 arch-groups test
3150: 2d 62 61 73 65 29 29 0a 09 20 20 20 20 20 20 28 -base)).. (
3160: 61 72 63 68 2d 69 6e 66 6f 20 20 28 63 61 72 20 arch-info (car
3170: 61 72 63 68 2d 67 72 6f 75 70 29 29 20 3b 3b 20 arch-group)) ;;
3180: 64 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 68 don't know yet h
3190: 6f 77 20 74 68 69 73 20 77 69 6c 6c 20 77 6f 72 ow this will wor
31a0: 6b 2c 20 63 61 6e 20 49 20 67 65 74 20 6d 6f 72 k, can I get mor
31b0: 65 20 74 68 61 6e 20 6f 6e 65 20 70 6f 73 73 69 e than one possi
31c0: 62 69 6c 69 74 79 3f 0a 09 20 20 20 20 20 20 28 bility?.. (
31d0: 61 72 63 68 69 76 65 2d 69 64 20 20 20 20 28 63 archive-id (c
31e0: 61 72 20 61 72 63 68 2d 69 6e 66 6f 29 29 0a 09 ar arch-info))..
31f0: 20 20 20 20 20 20 28 61 72 63 68 69 76 65 2d 64 (archive-d
3200: 69 72 20 20 20 28 63 64 72 20 61 72 63 68 2d 69 ir (cdr arch-i
3210: 6e 66 6f 29 29 29 0a 09 20 28 64 65 62 75 67 3a nfo))).. (debug:
3220: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
3230: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f 63 -log-port* "Proc
3240: 65 73 73 69 6e 67 20 64 69 73 6b 2d 67 72 6f 75 essing disk-grou
3250: 70 20 22 20 74 65 73 74 2d 62 61 73 65 29 0a 09 p " test-base)..
3260: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 (let* ((test-pa
3270: 74 68 73 2d 69 6e 20 28 68 61 73 68 2d 74 61 62 ths-in (hash-tab
3280: 6c 65 2d 72 65 66 20 64 69 73 6b 2d 67 72 6f 75 le-ref disk-grou
3290: 70 73 20 74 65 73 74 2d 62 61 73 65 29 29 0a 09 ps test-base))..
32a0: 09 28 74 65 73 74 2d 70 61 74 68 73 20 20 20 20 .(test-paths
32b0: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
32c0: 67 20 22 2d 69 6e 63 6c 75 64 65 22 29 0a 09 09 g "-include")...
32d0: 09 09 20 20 20 28 6c 65 74 20 28 28 73 75 62 70 .. (let ((subp
32e0: 61 74 68 73 20 28 73 74 72 69 6e 67 2d 73 70 6c aths (string-spl
32f0: 69 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 it (args:get-arg
3300: 20 22 2d 69 6e 63 6c 75 64 65 22 29 20 22 2c 22 "-include") ","
3310: 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 61 70 )))..... (ap
3320: 70 6c 79 20 61 70 70 65 6e 64 0a 09 09 09 09 09 ply append......
3330: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
3340: 20 28 70 29 0a 09 09 09 09 09 09 20 20 20 28 6d (p)....... (m
3350: 61 70 20 28 6c 61 6d 62 64 61 20 28 73 75 62 70 ap (lambda (subp
3360: 29 0a 09 09 09 09 09 09 09 20 20 28 63 6f 6e 63 )........ (conc
3370: 20 70 20 22 2f 22 20 73 75 62 70 29 29 0a 09 09 p "/" subp))...
3380: 09 09 09 09 09 73 75 62 70 61 74 68 73 29 29 0a .....subpaths)).
3390: 09 09 09 09 09 09 20 74 65 73 74 2d 70 61 74 68 ...... test-path
33a0: 73 2d 69 6e 29 29 29 0a 09 09 09 09 20 20 20 74 s-in)))..... t
33b0: 65 73 74 2d 70 61 74 68 73 2d 69 6e 29 29 29 0a est-paths-in))).
33c0: 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 6f . (if (not (co
33d0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
33e0: 3f 20 61 72 63 68 69 76 65 2d 64 69 72 29 29 0a ? archive-dir)).
33f0: 09 20 20 20 20 20 20 20 28 63 72 65 61 74 65 2d . (create-
3400: 64 69 72 65 63 74 6f 72 79 20 61 72 63 68 69 76 directory archiv
3410: 65 2d 64 69 72 20 23 74 29 29 0a 09 20 20 20 28 e-dir #t)).. (
3420: 63 61 73 65 20 61 72 63 68 69 76 65 72 0a 09 20 case archiver..
3430: 20 20 20 20 28 28 62 75 70 29 20 3b 3b 20 41 72 ((bup) ;; Ar
3440: 63 68 69 76 65 20 75 73 69 6e 67 20 62 75 70 0a chive using bup.
3450: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 62 . (let* ((b
3460: 75 70 2d 69 6e 69 74 2d 70 61 72 61 6d 73 20 20 up-init-params
3470: 28 6c 69 73 74 20 22 2d 64 22 20 61 72 63 68 69 (list "-d" archi
3480: 76 65 2d 64 69 72 20 22 69 6e 69 74 22 29 29 0a ve-dir "init")).
3490: 09 09 20 20 20 20 20 28 62 75 70 2d 69 6e 64 65 .. (bup-inde
34a0: 78 2d 70 61 72 61 6d 73 20 28 61 70 70 65 6e 64 x-params (append
34b0: 20 28 6c 69 73 74 20 22 2d 64 22 20 61 72 63 68 (list "-d" arch
34c0: 69 76 65 2d 64 69 72 20 22 69 6e 64 65 78 22 29 ive-dir "index")
34d0: 20 74 65 73 74 2d 70 61 74 68 73 29 29 0a 09 09 test-paths))...
34e0: 20 20 20 20 20 28 62 75 70 2d 73 61 76 65 2d 70 (bup-save-p
34f0: 61 72 61 6d 73 20 20 28 61 70 70 65 6e 64 20 28 arams (append (
3500: 6c 69 73 74 20 22 2d 64 22 20 61 72 63 68 69 76 list "-d" archiv
3510: 65 2d 64 69 72 20 22 73 61 76 65 22 20 3b 3b 20 e-dir "save" ;;
3520: 28 63 6f 6e 63 20 22 2d 2d 73 74 72 69 70 2d 70 (conc "--strip-p
3530: 61 74 68 3d 22 20 6c 69 6e 6b 74 72 65 65 29 0a ath=" linktree).
3540: 09 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 ...... (conc
3550: 20 22 2d 22 20 63 6f 6d 70 72 65 73 73 29 20 3b "-" compress) ;
3560: 3b 20 6f 72 20 28 63 6f 6e 63 20 22 2d 2d 63 6f ; or (conc "--co
3570: 6d 70 72 65 73 73 3d 22 20 63 6f 6d 70 72 65 73 mpress=" compres
3580: 73 29 0a 09 09 09 09 09 09 20 20 20 20 20 22 2d s)....... "-
3590: 6e 22 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e n" (conc (common
35a0: 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 29 20 :get-area-name)
35b0: 22 2d 22 28 73 74 72 69 6e 67 2d 73 75 62 73 74 "-"(string-subst
35c0: 69 74 75 74 65 20 22 2f 22 20 22 2d 22 20 74 61 itute "/" "-" ta
35d0: 72 67 65 74 20 22 20 22 29 29 0a 09 09 09 09 09 rget " "))......
35e0: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2d 2d 73 . (conc "--s
35f0: 74 72 69 70 2d 70 61 74 68 3d 22 20 28 63 6f 6e trip-path=" (con
3600: 63 20 74 65 73 74 2d 62 61 73 65 20 74 61 72 67 c test-base targ
3610: 65 74 20 22 2f 22 20 29 29 20 3b 3b 20 69 66 20 et "/" )) ;; if
3620: 77 65 20 70 75 73 68 20 74 6f 20 74 68 65 20 64 we push to the d
3630: 69 72 65 63 74 6f 72 79 20 64 6f 20 77 65 20 6e irectory do we n
3640: 65 65 64 20 74 68 69 73 3f 0a 09 09 09 09 09 09 eed this?.......
3650: 20 20 20 20 20 29 0a 09 09 09 09 09 20 20 20 20 )......
3660: 20 20 20 74 65 73 74 2d 70 61 74 68 73 29 29 29 test-paths)))
3670: 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d ...(if (not (com
3680: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
3690: 20 28 63 6f 6e 63 20 61 72 63 68 69 76 65 2d 64 (conc archive-d
36a0: 69 72 20 22 2f 48 45 41 44 22 29 29 29 0a 09 09 ir "/HEAD")))...
36b0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
36c0: 20 20 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 68 ;; replace th
36d0: 69 73 20 77 69 74 68 20 6a 6f 62 72 75 6e 6e 65 is with jobrunne
36e0: 72 20 73 74 75 66 66 20 65 6e 76 65 6e 74 75 61 r stuff enventua
36f0: 6c 6c 79 0a 09 09 20 20 20 20 20 20 28 64 65 62 lly... (deb
3700: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
3710: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3720: 74 2a 20 22 49 6e 69 74 20 62 75 70 20 69 6e 20 t* "Init bup in
3730: 22 20 61 72 63 68 69 76 65 2d 64 69 72 29 0a 09 " archive-dir)..
3740: 09 20 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 . ;; (mutex
3750: 2d 6c 6f 63 6b 21 20 62 75 70 2d 6d 75 74 65 78 -lock! bup-mutex
3760: 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2d 76 )... (let-v
3770: 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 61 6c alues (((pid-val
3780: 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 exit-status exi
3790: 74 2d 63 6f 64 65 29 20 28 72 75 6e 2d 6e 2d 77 t-code) (run-n-w
37a0: 61 69 74 20 62 75 70 2d 65 78 65 20 70 61 72 61 ait bup-exe para
37b0: 6d 73 3a 20 62 75 70 2d 69 6e 69 74 2d 70 61 72 ms: bup-init-par
37c0: 61 6d 73 20 70 72 69 6e 74 2d 63 6d 64 3a 20 70 ams print-cmd: p
37d0: 72 69 6e 74 2d 70 72 65 66 69 78 29 29 29 0a 20 rint-prefix))).
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 28 69 66 20 28 6e 6f 74 20 (if (not
3800: 28 65 71 3f 20 65 78 69 74 2d 63 6f 64 65 20 30 (eq? exit-code 0
3810: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3830: 20 28 62 65 67 69 6e 20 20 20 20 0a 20 20 20 20 (begin .
3840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3850: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
3860: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
3870: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3880: 2a 20 22 54 68 65 72 65 20 77 61 73 20 61 6e 20 * "There was an
3890: 65 72 72 6f 72 20 69 6e 69 74 69 61 6c 69 7a 69 error initializi
38a0: 6e 67 20 62 75 70 2e 20 41 72 63 68 69 76 65 20 ng bup. Archive
38b0: 66 61 69 6c 65 64 2e 22 29 0a 20 20 20 20 20 20 failed.").
38c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38d0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
38e0: 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 )))... ;; (
38f0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 62 75 mutex-unlock! bu
3900: 70 2d 6d 75 74 65 78 29 0a 09 09 20 20 20 20 20 p-mutex)...
3910: 20 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 ))...(debug:pri
3920: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
3930: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e lt-log-port* "In
3940: 64 65 78 69 6e 67 20 64 61 74 61 20 74 6f 20 62 dexing data to b
3950: 65 20 61 72 63 68 69 76 65 64 22 29 0a 09 09 3b e archived")...;
3960: 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 62 ; (mutex-lock! b
3970: 75 70 2d 6d 75 74 65 78 29 0a 09 09 28 6c 65 74 up-mutex)...(let
3980: 2d 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 -values (((pid-v
3990: 61 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 al exit-status e
39a0: 78 69 74 2d 63 6f 64 65 29 20 28 72 75 6e 2d 6e xit-code) (run-n
39b0: 2d 77 61 69 74 20 62 75 70 2d 65 78 65 20 70 61 -wait bup-exe pa
39c0: 72 61 6d 73 3a 20 62 75 70 2d 69 6e 64 65 78 2d rams: bup-index-
39d0: 70 61 72 61 6d 73 20 70 72 69 6e 74 2d 63 6d 64 params print-cmd
39e0: 3a 20 70 72 69 6e 74 2d 70 72 65 66 69 78 29 29 : print-prefix))
39f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3a00: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
3a10: 71 3f 20 65 78 69 74 2d 63 6f 64 65 20 30 29 29 q? exit-code 0))
3a20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3a40: 62 65 67 69 6e 20 20 20 20 0a 20 20 20 20 20 20 begin .
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a60: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
3a70: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
3a80: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3a90: 22 54 68 65 72 65 20 77 61 73 20 61 6e 20 65 72 "There was an er
3aa0: 72 6f 72 20 49 6e 64 65 78 69 6e 67 20 62 75 70 ror Indexing bup
3ab0: 2e 20 41 72 63 68 69 76 65 20 66 61 69 6c 65 64 . Archive failed
3ac0: 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 .").
3ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ae0: 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 09 (exit 1))))...
3af0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3b00: 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 2 *default-log
3b10: 2d 70 6f 72 74 2a 20 22 41 72 63 68 69 76 69 6e -port* "Archivin
3b20: 67 20 64 61 74 61 20 77 69 74 68 20 62 75 70 22 g data with bup"
3b30: 29 0a 09 09 28 6c 65 74 2d 76 61 6c 75 65 73 20 )...(let-values
3b40: 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 74 2d (((pid-val exit-
3b50: 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 status exit-code
3b60: 29 20 28 72 75 6e 2d 6e 2d 77 61 69 74 20 62 75 ) (run-n-wait bu
3b70: 70 2d 65 78 65 20 70 61 72 61 6d 73 3a 20 62 75 p-exe params: bu
3b80: 70 2d 73 61 76 65 2d 70 61 72 61 6d 73 20 70 72 p-save-params pr
3b90: 69 6e 74 2d 63 6d 64 3a 20 70 72 69 6e 74 2d 70 int-cmd: print-p
3ba0: 72 65 66 69 78 29 29 29 0a 20 20 20 20 20 20 20 refix))).
3bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3bc0: 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 78 69 74 f (not (eq? exit
3bd0: 2d 63 6f 64 65 20 30 29 29 0a 20 20 20 20 20 20 -code 0)).
3be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bf0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 20 (begin
3c00: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c20: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
3c30: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
3c40: 6f 67 2d 70 6f 72 74 2a 20 22 54 68 65 72 65 20 og-port* "There
3c50: 77 61 73 20 61 6e 20 61 72 63 68 69 76 69 6e 67 was an archiving
3c60: 20 64 61 74 61 20 77 69 74 68 20 62 75 70 2e 20 data with bup.
3c70: 41 72 63 68 69 76 65 20 66 61 69 6c 65 64 2e 22 Archive failed."
3c80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ca0: 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 09 20 (exit 1))))))..
3cb0: 20 20 20 20 28 28 37 7a 20 74 61 72 29 0a 09 20 ((7z tar)..
3cc0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 (for-each..
3cd0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
3ce0: 74 65 73 74 2d 64 61 74 29 0a 09 09 20 28 6c 65 test-dat)... (le
3cf0: 74 2a 20 28 28 74 65 73 74 2d 69 64 20 20 20 20 t* ((test-id
3d00: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
3d10: 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 74 65 get-id te
3d20: 73 74 2d 64 61 74 29 29 0a 09 09 09 28 74 65 73 st-dat))....(tes
3d30: 74 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 20 28 t-name (
3d40: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
3d50: 6e 61 6d 65 20 20 74 65 73 74 2d 64 61 74 29 29 name test-dat))
3d60: 0a 09 09 09 28 69 74 65 6d 2d 70 61 74 68 20 20 ....(item-path
3d70: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
3d80: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
3d90: 73 74 2d 64 61 74 29 29 0a 09 09 09 28 74 65 73 st-dat))....(tes
3da0: 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 20 20 20 28 t-full-name (
3db0: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
3dc0: 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 l-name test-name
3dd0: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 09 09 item-path))....
3de0: 28 72 75 6e 2d 69 64 20 20 20 20 20 20 20 20 20 (run-id
3df0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
3e00: 72 75 6e 5f 69 64 20 20 20 20 74 65 73 74 2d 64 run_id test-d
3e10: 61 74 29 29 0a 09 09 09 28 74 61 72 67 65 74 20 at))....(target
3e20: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
3e30: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
3e40: 6d 61 70 20 63 61 64 72 20 28 72 6d 74 3a 67 65 map cadr (rmt:ge
3e50: 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 t-key-val-pairs
3e60: 72 75 6e 2d 69 64 29 29 20 22 2f 22 29 29 0a 09 run-id)) "/"))..
3e70: 09 09 28 72 75 6e 2d 6e 61 6d 65 20 20 20 20 20 ..(run-name
3e80: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 (rmt:get-ru
3e90: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 n-name-from-id r
3ea0: 75 6e 2d 69 64 29 29 0a 09 09 09 28 73 6f 75 72 un-id))....(sour
3eb0: 63 65 2d 64 69 72 20 20 20 20 20 20 20 20 28 68 ce-dir (h
3ec0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
3ed0: 73 74 2d 64 69 72 73 20 74 65 73 74 2d 69 64 29 st-dirs test-id)
3ee0: 29 20 3b 3b 20 28 63 6f 6e 63 20 74 65 73 74 2d ) ;; (conc test-
3ef0: 62 61 73 65 20 22 2f 22 20 74 65 73 74 2d 6e 61 base "/" test-na
3f00: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
3f10: 29 29 0a 09 09 09 28 74 61 72 67 65 74 2d 64 69 ))....(target-di
3f20: 72 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 r (string
3f30: 2d 73 75 62 73 74 69 74 75 74 65 20 22 2f 24 22 -substitute "/$"
3f40: 20 22 22 20 28 63 6f 6e 63 20 61 72 63 68 69 76 "" (conc archiv
3f50: 65 2d 64 69 72 20 22 2f 22 20 74 61 72 67 65 74 e-dir "/" target
3f60: 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 2f "/" run-name "/
3f70: 22 20 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 " test-full-name
3f80: 29 29 29 29 0a 09 09 20 20 20 3b 3b 20 63 72 65 ))))... ;; cre
3f90: 61 74 65 20 74 68 65 20 74 65 73 74 20 61 6e 64 ate the test and
3fa0: 20 69 74 65 6d 2d 70 61 74 68 20 6c 65 76 65 6c item-path level
3fb0: 73 20 75 6e 64 65 72 20 61 72 63 68 69 76 65 2d s under archive-
3fc0: 64 69 72 0a 09 09 20 20 20 28 63 72 65 61 74 65 dir... (create
3fd0: 2d 64 69 72 65 63 74 6f 72 79 20 28 70 61 74 68 -directory (path
3fe0: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 74 name-directory t
3ff0: 61 72 67 65 74 2d 64 69 72 29 20 23 74 29 0a 09 arget-dir) #t)..
4000: 09 20 20 20 28 72 75 6e 2d 6e 2d 77 61 69 74 0a . (run-n-wait.
4010: 09 09 20 20 20 20 28 63 6f 6e 63 0a 09 09 20 20 .. (conc...
4020: 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 (string-subst
4030: 69 74 75 74 65 20 22 41 52 43 48 49 56 45 5f 4e itute "ARCHIVE_N
4040: 41 4d 45 22 20 74 61 72 67 65 74 2d 64 69 72 20 AME" target-dir
4050: 61 72 63 68 69 76 65 72 2d 63 6d 64 29 20 22 20 archiver-cmd) "
4060: 22 0a 09 09 20 20 20 20 20 22 2e 22 0a 09 09 20 "... "."...
4070: 20 20 20 20 29 0a 09 09 20 20 20 20 70 72 69 6e )... prin
4080: 74 2d 63 6d 64 3a 20 70 72 69 6e 74 2d 70 72 65 t-cmd: print-pre
4090: 66 69 78 0a 09 09 20 20 20 20 72 75 6e 2d 64 69 fix... run-di
40a0: 72 3a 20 73 6f 75 72 63 65 2d 64 69 72 29 29 29 r: source-dir)))
40b0: 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 .. (hash-t
40c0: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 67 72 able-ref test-gr
40d0: 6f 75 70 73 20 74 65 73 74 2d 62 61 73 65 29 29 oups test-base))
40e0: 29 29 0a 09 20 20 20 3b 3b 20 28 6d 75 74 65 78 )).. ;; (mutex
40f0: 2d 75 6e 6c 6f 63 6b 21 20 62 75 70 2d 6d 75 74 -unlock! bup-mut
4100: 65 78 29 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 ex).. (for-eac
4110: 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h.. (lambda (
4120: 74 65 73 74 2d 64 61 74 29 0a 09 20 20 20 20 20 test-dat)..
4130: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 (let ((test-id
4140: 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 (db:te
4150: 73 74 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 st-get-id
4160: 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 20 20 test-dat))...
4170: 20 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 20 (run-id
4180: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
4190: 74 2d 72 75 6e 5f 69 64 20 20 20 20 74 65 73 74 t-run_id test
41a0: 2d 64 61 74 29 29 29 0a 09 09 28 72 6d 74 3a 74 -dat)))...(rmt:t
41b0: 65 73 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d est-set-archive-
41c0: 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 block-id run-id
41d0: 74 65 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d test-id archive-
41e0: 69 64 29 0a 09 09 28 69 66 20 28 6d 65 6d 62 65 id)...(if (membe
41f0: 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e r (symbol->strin
4200: 67 20 61 72 63 68 69 76 65 2d 63 6f 6d 6d 61 6e g archive-comman
4210: 64 29 20 27 28 22 73 61 76 65 2d 72 65 6d 6f 76 d) '("save-remov
4220: 65 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e")).
4230: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
4240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4250: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
4260: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
4270: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
4280: 6d 6f 76 65 20 74 65 73 74 64 61 74 22 29 0a 09 move testdat")..
4290: 09 20 20 20 20 28 72 75 6e 73 3a 72 65 6d 6f 76 . (runs:remov
42a0: 65 2d 74 65 73 74 2d 64 69 72 65 63 74 6f 72 79 e-test-directory
42b0: 20 74 65 73 74 2d 64 61 74 20 27 61 72 63 68 69 test-dat 'archi
42c0: 76 65 2d 72 65 6d 6f 76 65 29 29 29 29 29 0a 09 ve-remove)))))..
42d0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
42e0: 72 65 66 20 74 65 73 74 2d 67 72 6f 75 70 73 20 ref test-groups
42f0: 74 65 73 74 2d 62 61 73 65 29 29 29 29 29 0a 20 test-base))))).
4300: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
4310: 65 2d 6b 65 79 73 20 64 69 73 6b 2d 67 72 6f 75 e-keys disk-grou
4320: 70 73 29 29 0a 20 20 20 20 23 74 29 29 0a 0a 28 ps)). #t))..(
4330: 64 65 66 69 6e 65 20 28 61 72 63 68 69 76 65 3a define (archive:
4340: 6d 65 67 61 74 65 73 74 2d 64 62 20 74 61 72 67 megatest-db targ
4350: 65 74 2d 70 61 74 74 20 72 75 6e 2d 70 61 74 74 et-patt run-patt
4360: 29 0a 20 28 6c 65 74 2a 20 28 28 62 6c 6f 63 6b ). (let* ((block
4370: 69 64 2d 63 61 63 68 65 20 20 28 6d 61 6b 65 2d id-cache (make-
4380: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 hash-table)).
4390: 20 20 20 20 20 28 74 73 6e 61 6d 65 20 20 20 20 (tsname
43a0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
43b0: 2d 61 72 65 61 2d 6e 61 6d 65 29 29 0a 20 20 20 -area-name)).
43c0: 20 20 20 20 20 28 6d 69 6e 2d 73 70 61 63 65 20 (min-space
43d0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
43e0: 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 mber (or (config
43f0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
4400: 64 61 74 2a 20 22 61 72 63 68 69 76 65 22 20 22 dat* "archive" "
4410: 6d 69 6e 73 70 61 63 65 22 29 20 22 31 30 30 30 minspace") "1000
4420: 22 29 29 29 0a 20 20 20 20 20 20 20 20 28 62 75 "))). (bu
4430: 70 2d 65 78 65 20 20 20 20 20 20 20 20 28 6f 72 p-exe (or
4440: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
4450: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 61 72 *configdat* "ar
4460: 63 68 69 76 65 22 20 22 62 75 70 22 29 20 22 62 chive" "bup") "b
4470: 75 70 22 29 29 0a 09 28 63 6f 6d 70 72 65 73 73 up"))..(compress
4480: 20 20 20 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 (or (conf
4490: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
44a0: 69 67 64 61 74 2a 20 22 61 72 63 68 69 76 65 22 igdat* "archive"
44b0: 20 22 63 6f 6d 70 72 65 73 73 22 29 20 22 39 22 "compress") "9"
44c0: 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 63 68 )). (arch
44d0: 69 76 65 72 20 20 20 20 20 20 20 28 6c 65 74 20 iver (let
44e0: 28 28 73 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ((s (configf:loo
44f0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
4500: 22 61 72 63 68 69 76 65 22 20 22 61 72 63 68 69 "archive" "archi
4510: 76 65 72 22 29 29 29 0a 09 09 09 20 20 20 28 69 ver"))).... (i
4520: 66 20 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d f s (string->sym
4530: 62 6f 6c 20 73 29 20 27 62 75 70 29 29 29 0a 20 bol s) 'bup))).
4540: 20 20 20 20 20 20 20 28 72 73 79 6e 63 2d 65 78 (rsync-ex
4550: 65 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c e (or (configf:l
4560: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
4570: 2a 20 22 61 72 63 68 69 76 65 22 20 22 72 73 79 * "archive" "rsy
4580: 6e 63 22 29 20 22 72 73 79 6e 63 22 29 29 20 20 nc") "rsync"))
4590: 20 0a 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 . (print
45a0: 2d 70 72 65 66 69 78 20 20 20 20 20 20 22 52 75 -prefix "Ru
45b0: 6e 6e 69 6e 67 3a 20 22 29 20 0a 20 20 20 20 20 nning: ") .
45c0: 20 20 20 28 61 72 63 68 69 76 65 2d 69 6e 66 6f (archive-info
45d0: 20 28 61 72 63 68 69 76 65 3a 61 6c 6c 6f 63 61 (archive:alloca
45e0: 74 65 2d 6e 65 77 2d 61 72 63 68 69 76 65 2d 62 te-new-archive-b
45f0: 6c 6f 63 6b 20 62 6c 6f 63 6b 69 64 2d 63 61 63 lock blockid-cac
4600: 68 65 20 2a 74 6f 70 70 61 74 68 2a 20 74 73 6e he *toppath* tsn
4610: 61 6d 65 20 6d 69 6e 2d 73 70 61 63 65 20 74 61 ame min-space ta
4620: 72 67 65 74 2d 70 61 74 74 20 72 75 6e 2d 70 61 rget-patt run-pa
4630: 74 74 20 22 6d 65 67 61 74 65 73 74 2d 64 62 22 tt "megatest-db"
4640: 29 29 0a 09 28 61 72 63 68 69 76 65 2d 64 69 72 ))..(archive-dir
4650: 20 20 28 69 66 20 61 72 63 68 69 76 65 2d 69 6e (if archive-in
4660: 66 6f 20 28 63 64 72 20 61 72 63 68 69 76 65 2d fo (cdr archive-
4670: 69 6e 66 6f 29 20 23 66 29 29 0a 09 28 61 72 63 info) #f))..(arc
4680: 68 69 76 65 2d 69 64 20 20 20 28 69 66 20 61 72 hive-id (if ar
4690: 63 68 69 76 65 2d 69 6e 66 6f 20 28 63 61 72 20 chive-info (car
46a0: 61 72 63 68 69 76 65 2d 69 6e 66 6f 29 20 2d 31 archive-info) -1
46b0: 29 29 0a 20 20 20 28 68 6f 6d 65 2d 68 6f 73 74 )). (home-host
46c0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
46d0: 29 20 3b 3b 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ) ;; common:get-
46e0: 68 6f 6d 65 68 6f 73 74 29 29 20 3b 3b 20 54 4f homehost)) ;; TO
46f0: 44 4f 3a 20 46 69 78 20 74 68 69 73 2e 0a 20 20 DO: Fix this..
4700: 20 20 20 20 20 20 28 61 72 63 68 69 76 65 2d 74 (archive-t
4710: 69 6d 65 20 28 73 65 63 6f 6e 64 73 2d 3e 73 74 ime (seconds->st
4720: 64 2d 74 69 6d 65 2d 73 74 72 20 28 63 75 72 72 d-time-str (curr
4730: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 ent-seconds))).
4740: 20 20 20 20 20 20 20 28 61 72 63 68 69 76 65 2d (archive-
4750: 73 74 61 67 69 6e 67 2d 64 62 20 28 63 6f 6e 63 staging-db (conc
4760: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e 64 62 *toppath* "/.db
4770: 2d 73 6e 61 70 73 68 6f 74 2f 61 72 63 68 69 76 -snapshot/archiv
4780: 65 5f 22 20 61 72 63 68 69 76 65 2d 74 69 6d 65 e_" archive-time
4790: 29 29 0a 20 20 20 20 20 20 20 20 28 74 6d 70 2d )). (tmp-
47a0: 64 62 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 63 db-path (conc (c
47b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 ommon:get-db-tmp
47c0: 2d 61 72 65 61 29 20 22 2f 6d 65 67 61 74 65 73 -area) "/megates
47d0: 74 2e 64 62 22 29 29 0a 20 20 20 20 20 20 20 20 t.db")).
47e0: 28 64 62 66 69 6c 65 20 20 20 20 20 20 20 20 20 (dbfile
47f0: 20 20 20 20 28 63 6f 6e 63 20 20 61 72 63 68 69 (conc archi
4800: 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 20 22 2f ve-staging-db "/
4810: 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 29 20 megatest.db")))
4820: 0a 20 20 20 20 20 20 20 20 28 63 72 65 61 74 65 . (create
4830: 2d 64 69 72 65 63 74 6f 72 79 20 61 72 63 68 69 -directory archi
4840: 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 20 23 74 ve-staging-db #t
4850: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2d 76 ). (let-v
4860: 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 61 6c alues (((pid-val
4870: 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 exit-status exi
4880: 74 2d 63 6f 64 65 29 20 28 72 75 6e 2d 6e 2d 77 t-code) (run-n-w
4890: 61 69 74 20 72 73 79 6e 63 2d 65 78 65 20 70 61 ait rsync-exe pa
48a0: 72 61 6d 73 3a 20 28 6c 69 73 74 20 22 2d 76 22 rams: (list "-v"
48b0: 20 28 63 6f 6e 63 20 28 63 61 72 20 68 6f 6d 65 (conc (car home
48c0: 2d 68 6f 73 74 29 20 22 3a 22 74 6d 70 2d 64 62 -host) ":"tmp-db
48d0: 2d 70 61 74 68 29 20 61 72 63 68 69 76 65 2d 73 -path) archive-s
48e0: 74 61 67 69 6e 67 2d 64 62 29 20 70 72 69 6e 74 taging-db) print
48f0: 2d 63 6d 64 3a 20 70 72 69 6e 74 2d 70 72 65 66 -cmd: print-pref
4900: 69 78 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ix))).
4910: 20 20 28 69 66 20 28 65 71 3f 20 65 78 69 74 2d (if (eq? exit-
4920: 63 6f 64 65 20 30 29 20 20 20 0a 20 20 20 20 20 code 0) .
4930: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 61 (case a
4940: 72 63 68 69 76 65 72 0a 09 20 20 20 20 20 20 20 rchiver..
4950: 20 28 28 62 75 70 29 20 3b 3b 20 41 72 63 68 69 ((bup) ;; Archi
4960: 76 65 20 75 73 69 6e 67 20 62 75 70 0a 09 20 20 ve using bup..
4970: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
4980: 62 75 70 2d 69 6e 69 74 2d 70 61 72 61 6d 73 20 bup-init-params
4990: 20 28 6c 69 73 74 20 22 2d 64 22 20 61 72 63 68 (list "-d" arch
49a0: 69 76 65 2d 64 69 72 20 22 69 6e 69 74 22 29 29 ive-dir "init"))
49b0: 0a 09 09 20 20 20 20 20 20 20 20 20 28 62 75 70 ... (bup
49c0: 2d 69 6e 64 65 78 2d 70 61 72 61 6d 73 20 28 6c -index-params (l
49d0: 69 73 74 20 22 2d 64 22 20 61 72 63 68 69 76 65 ist "-d" archive
49e0: 2d 64 69 72 20 22 69 6e 64 65 78 22 20 61 72 63 -dir "index" arc
49f0: 68 69 76 65 2d 73 74 61 67 69 6e 67 2d 64 62 29 hive-staging-db)
4a00: 29 0a 09 09 20 20 20 20 20 20 20 20 20 28 62 75 )... (bu
4a10: 70 2d 73 61 76 65 2d 70 61 72 61 6d 73 20 20 28 p-save-params (
4a20: 6c 69 73 74 20 22 2d 64 22 20 61 72 63 68 69 76 list "-d" archiv
4a30: 65 2d 64 69 72 20 22 73 61 76 65 22 20 3b 3b 20 e-dir "save" ;;
4a40: 28 63 6f 6e 63 20 22 2d 2d 73 74 72 69 70 2d 70 (conc "--strip-p
4a50: 61 74 68 3d 22 20 6c 69 6e 6b 74 72 65 65 29 0a ath=" linktree).
4a60: 09 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 ...... (conc
4a70: 20 22 2d 22 20 63 6f 6d 70 72 65 73 73 29 20 3b "-" compress) ;
4a80: 3b 20 6f 72 20 28 63 6f 6e 63 20 22 2d 2d 63 6f ; or (conc "--co
4a90: 6d 70 72 65 73 73 3d 22 20 63 6f 6d 70 72 65 73 mpress=" compres
4aa0: 73 29 0a 09 09 09 09 09 09 20 20 20 20 20 22 2d s)....... "-
4ab0: 6e 22 20 28 63 6f 6e 63 20 74 73 6e 61 6d 65 20 n" (conc tsname
4ac0: 22 2d 6d 65 67 61 74 65 73 74 2d 64 62 22 20 29 "-megatest-db" )
4ad0: 0a 09 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e ....... (con
4ae0: 63 20 22 2d 2d 73 74 72 69 70 2d 70 61 74 68 3d c "--strip-path=
4af0: 22 20 61 72 63 68 69 76 65 2d 73 74 61 67 69 6e " archive-stagin
4b00: 67 2d 64 62 20 29 20 3b 3b 20 69 66 20 77 65 20 g-db ) ;; if we
4b10: 70 75 73 68 20 74 6f 20 74 68 65 20 64 69 72 65 push to the dire
4b20: 63 74 6f 72 79 20 64 6f 20 77 65 20 6e 65 65 64 ctory do we need
4b30: 20 74 68 69 73 3f 0a 09 09 09 09 09 09 20 20 20 this?.......
4b40: 20 20 64 62 66 69 6c 65 29 29 29 0a 20 20 20 20 dbfile))).
4b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b60: 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e (if (not (common
4b70: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 :file-exists? (c
4b80: 6f 6e 63 20 61 72 63 68 69 76 65 2d 64 69 72 20 onc archive-dir
4b90: 22 2f 48 45 41 44 22 29 29 29 0a 09 09 20 20 20 "/HEAD")))...
4ba0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
4bb0: 20 20 20 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 ;; replace t
4bc0: 68 69 73 20 77 69 74 68 20 6a 6f 62 72 75 6e 6e his with jobrunn
4bd0: 65 72 20 73 74 75 66 66 20 65 6e 76 65 6e 74 75 er stuff enventu
4be0: 61 6c 6c 79 0a 09 09 20 20 20 20 20 20 20 20 28 ally... (
4bf0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4c00: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
4c10: 70 6f 72 74 2a 20 22 49 6e 69 74 20 62 75 70 20 port* "Init bup
4c20: 69 6e 20 22 20 61 72 63 68 69 76 65 2d 64 69 72 in " archive-dir
4c30: 29 0a 09 09 20 20 20 20 20 20 20 20 20 28 6c 65 )... (le
4c40: 74 2d 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d t-values (((pid-
4c50: 76 61 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 val exit-status
4c60: 65 78 69 74 2d 63 6f 64 65 29 28 72 75 6e 2d 6e exit-code)(run-n
4c70: 2d 77 61 69 74 20 62 75 70 2d 65 78 65 20 70 61 -wait bup-exe pa
4c80: 72 61 6d 73 3a 20 62 75 70 2d 69 6e 69 74 2d 70 rams: bup-init-p
4c90: 61 72 61 6d 73 20 70 72 69 6e 74 2d 63 6d 64 3a arams print-cmd:
4ca0: 20 70 72 69 6e 74 2d 70 72 65 66 69 78 29 29 29 print-prefix)))
4cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4cc0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4cd0: 6e 6f 74 20 28 65 71 3f 20 65 78 69 74 2d 63 6f not (eq? exit-co
4ce0: 64 65 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 de 0)).
4cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d00: 20 20 20 20 20 28 62 65 67 69 6e 20 20 20 20 0a (begin .
4d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
4d30: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
4d40: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4d50: 70 6f 72 74 2a 20 22 54 68 65 72 65 20 77 61 73 port* "There was
4d60: 20 61 6e 20 65 72 72 6f 72 20 69 6e 69 74 69 61 an error initia
4d70: 6c 69 7a 69 6e 67 20 62 75 70 2e 20 41 72 63 68 lizing bup. Arch
4d80: 69 76 65 20 66 61 69 6c 65 64 2e 22 29 0a 20 20 ive failed.").
4d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4da0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
4db0: 74 20 31 29 29 29 29 29 29 0a 09 09 20 20 20 20 t 1))))))...
4dc0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4dd0: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
4de0: 67 2d 70 6f 72 74 2a 20 22 49 6e 64 65 78 69 6e g-port* "Indexin
4df0: 67 20 64 61 74 61 20 74 6f 20 62 65 20 61 72 63 g data to be arc
4e00: 68 69 76 65 64 22 29 0a 09 09 20 20 20 20 20 28 hived")... (
4e10: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 70 69 let-values (((pi
4e20: 64 2d 76 61 6c 20 65 78 69 74 2d 73 74 61 74 75 d-val exit-statu
4e30: 73 20 65 78 69 74 2d 63 6f 64 65 29 20 28 72 75 s exit-code) (ru
4e40: 6e 2d 6e 2d 77 61 69 74 20 62 75 70 2d 65 78 65 n-n-wait bup-exe
4e50: 20 70 61 72 61 6d 73 3a 20 62 75 70 2d 69 6e 64 params: bup-ind
4e60: 65 78 2d 70 61 72 61 6d 73 20 70 72 69 6e 74 2d ex-params print-
4e70: 63 6d 64 3a 20 70 72 69 6e 74 2d 70 72 65 66 69 cmd: print-prefi
4e80: 78 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x))).
4e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
4ea0: 20 28 6e 6f 74 20 28 65 71 3f 20 65 78 69 74 2d (not (eq? exit-
4eb0: 63 6f 64 65 20 30 29 29 0a 20 20 20 20 20 20 20 code 0)).
4ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ed0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 20 20 (begin
4ee0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f00: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
4f10: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
4f20: 67 2d 70 6f 72 74 2a 20 22 54 68 65 72 65 20 77 g-port* "There w
4f30: 61 73 20 61 6e 20 65 72 72 6f 72 20 49 6e 64 65 as an error Inde
4f40: 78 69 6e 67 20 62 75 70 2e 20 41 72 63 68 69 76 xing bup. Archiv
4f50: 65 20 66 61 69 6c 65 64 2e 22 29 0a 20 20 20 20 e failed.").
4f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f70: 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 (exit
4f80: 31 29 29 29 29 0a 09 09 20 20 20 20 20 28 64 65 1))))... (de
4f90: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
4fa0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4fb0: 72 74 2a 20 22 41 72 63 68 69 76 69 6e 67 20 64 rt* "Archiving d
4fc0: 61 74 61 20 77 69 74 68 20 62 75 70 22 29 0a 09 ata with bup")..
4fd0: 09 20 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 . (let-value
4fe0: 73 20 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 s (((pid-val exi
4ff0: 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f t-status exit-co
5000: 64 65 29 20 28 72 75 6e 2d 6e 2d 77 61 69 74 20 de) (run-n-wait
5010: 62 75 70 2d 65 78 65 20 70 61 72 61 6d 73 3a 20 bup-exe params:
5020: 62 75 70 2d 73 61 76 65 2d 70 61 72 61 6d 73 20 bup-save-params
5030: 70 72 69 6e 74 2d 63 6d 64 3a 20 70 72 69 6e 74 print-cmd: print
5040: 2d 70 72 65 66 69 78 29 29 29 0a 20 20 20 20 20 -prefix))).
5050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5060: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
5070: 3f 20 65 78 69 74 2d 63 6f 64 65 20 30 29 29 0a ? exit-code 0)).
5080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
50a0: 65 67 69 6e 20 20 20 20 0a 20 20 20 20 20 20 20 egin .
50b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50c0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
50d0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
50e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
50f0: 54 68 65 72 65 20 77 61 73 20 61 6e 20 65 72 72 There was an err
5100: 6f 72 20 61 72 63 68 69 76 69 6e 67 20 64 61 74 or archiving dat
5110: 61 20 77 69 74 68 20 62 75 70 2e 20 41 72 63 68 a with bup. Arch
5120: 69 76 65 20 66 61 69 6c 65 64 2e 22 29 0a 20 20 ive failed.").
5130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5140: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
5150: 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 1)).
5160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5170: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5180: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5190: 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 6f 20 72 65 log-port* "To re
51a0: 73 74 6f 72 65 20 6d 65 67 61 74 65 73 74 2e 64 store megatest.d
51b0: 62 20 72 75 6e 20 6d 65 67 61 74 65 73 74 20 2d b run megatest -
51c0: 61 72 63 68 69 76 65 20 72 65 70 6c 69 63 61 63 archive replicac
51d0: 74 65 2d 64 62 20 2d 73 6f 75 72 63 65 20 61 72 te-db -source ar
51e0: 63 68 69 76 65 2d 64 69 72 20 2d 74 69 6d 65 2d chive-dir -time-
51f0: 73 74 61 6d 70 20 3c 74 73 3e 2e 20 43 75 72 72 stamp <ts>. Curr
5200: 65 6e 74 20 74 69 6d 65 73 74 61 6d 70 3a 20 22 ent timestamp: "
5210: 20 28 73 65 63 6f 6e 64 73 2d 3e 73 74 64 2d 74 (seconds->std-t
5220: 69 6d 65 2d 73 74 72 20 28 63 75 72 72 65 6e 74 ime-str (current
5230: 2d 73 65 63 6f 6e 64 73 29 29 29 29 29 29 29 20 -seconds)))))))
5240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5250: 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 (else.
5260: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
5270: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5280: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5290: 22 4e 6f 20 73 75 70 70 6f 72 74 20 66 6f 72 20 "No support for
52a0: 64 61 74 61 62 73 65 20 61 72 63 68 69 76 69 6e databse archivin
52b0: 67 20 77 69 74 68 20 22 20 61 72 63 68 69 76 65 g with " archive
52c0: 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 r))).
52d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
52e0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
52f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 68 65 t-log-port* "The
5300: 72 65 20 77 61 73 20 61 6e 20 65 72 72 6f 72 20 re was an error
5310: 72 73 79 6e 63 69 6e 67 20 74 6d 70 20 64 61 74 rsyncing tmp dat
5320: 61 62 61 73 65 22 29 29 29 29 29 0a 0a 28 64 65 abase")))))..(de
5330: 66 69 6e 65 20 28 61 72 63 68 69 76 65 3a 72 65 fine (archive:re
5340: 73 74 6f 72 65 2d 64 62 20 61 72 63 68 69 76 65 store-db archive
5350: 2d 70 61 74 68 20 74 73 29 0a 20 20 20 28 6c 65 -path ts). (le
5360: 74 2a 20 28 28 62 75 70 2d 65 78 65 20 20 20 20 t* ((bup-exe
5370: 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 (or (
5380: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
5390: 63 6f 6e 66 69 67 64 61 74 2a 20 22 61 72 63 68 configdat* "arch
53a0: 69 76 65 22 20 22 62 75 70 22 29 20 22 62 75 70 ive" "bup") "bup
53b0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 ")). (ar
53c0: 63 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c 2d 70 chive-internal-p
53d0: 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f ath (conc (commo
53e0: 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 29 n:get-area-name)
53f0: 20 22 2d 6d 65 67 61 74 65 73 74 2d 64 62 2f 22 "-megatest-db/"
5400: 20 74 73 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 ts "/megatest.d
5410: 62 22 20 29 29 0a 20 20 20 20 20 20 20 20 20 28 b" )). (
5420: 62 75 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 61 bup-restore-para
5430: 6d 73 20 20 28 6c 69 73 74 20 22 2d 64 22 20 61 ms (list "-d" a
5440: 72 63 68 69 76 65 2d 70 61 74 68 20 22 72 65 73 rchive-path "res
5450: 74 6f 72 65 22 20 22 2d 43 22 20 2a 74 6f 70 70 tore" "-C" *topp
5460: 61 74 68 2a 20 61 72 63 68 69 76 65 2d 69 6e 74 ath* archive-int
5470: 65 72 6e 61 6c 2d 70 61 74 68 29 29 29 0a 09 09 ernal-path)))...
5480: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5490: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
54a0: 67 2d 70 6f 72 74 2a 20 22 52 65 73 74 6f 72 69 g-port* "Restori
54b0: 6e 67 20 61 72 63 68 69 76 65 64 20 64 61 74 61 ng archived data
54c0: 20 74 6f 20 22 20 2a 74 6f 70 70 61 74 68 2a 20 to " *toppath*
54d0: 22 20 66 72 6f 6d 20 61 72 63 68 69 76 65 20 69 " from archive i
54e0: 6e 20 22 20 61 72 63 68 69 76 65 2d 70 61 74 68 n " archive-path
54f0: 20 22 20 2e 2e 2e 20 22 20 61 72 63 68 69 76 65 " ... " archive
5500: 2d 69 6e 74 65 72 6e 61 6c 2d 70 61 74 68 29 0a -internal-path).
5510: 09 09 20 28 72 75 6e 2d 6e 2d 77 61 69 74 20 62 .. (run-n-wait b
5520: 75 70 2d 65 78 65 20 70 61 72 61 6d 73 3a 20 62 up-exe params: b
5530: 75 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 61 6d up-restore-param
5540: 73 20 70 72 69 6e 74 2d 63 6d 64 3a 20 22 52 75 s print-cmd: "Ru
5550: 6e 6e 69 6e 67 3a 22 29 29 0a 20 20 20 28 73 6c nning:")). (sl
5560: 65 65 70 20 32 29 0a 0a 20 20 20 3b 3b 20 54 4f eep 2).. ;; TO
5570: 44 4f 3a 20 72 65 73 74 6f 72 65 20 74 68 69 73 DO: restore this
5580: 20 66 75 6e 63 74 69 6f 6e 61 6c 69 74 79 0a 20 functionality.
5590: 20 20 0a 20 20 20 20 20 20 23 3b 28 64 62 3a 6d . #;(db:m
55a0: 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 20 ulti-db-sync .
55b0: 20 20 20 20 20 28 64 62 3a 73 65 74 75 70 20 23 (db:setup #
55c0: 66 29 0a 20 20 20 20 20 20 20 27 6b 69 6c 6c 73 f). 'kills
55d0: 65 72 76 65 72 73 0a 20 20 20 20 20 20 20 3b 27 ervers. ;'
55e0: 64 65 6a 75 6e 6b 0a 20 20 20 20 20 20 20 3b 27 dejunk. ;'
55f0: 61 64 6a 2d 74 65 73 74 69 64 73 0a 20 20 20 20 adj-testids.
5600: 20 20 20 27 6f 6c 64 32 6e 65 77 0a 20 20 20 20 'old2new.
5610: 20 20 20 29 0a 20 20 20 20 20 20 28 64 65 62 75 ). (debu
5620: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
5630: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5640: 2a 20 22 64 72 6f 70 70 69 6e 67 20 74 72 69 67 * "dropping trig
5650: 67 65 72 73 20 74 6f 20 75 70 64 61 74 65 20 6c gers to update l
5660: 69 6e 6b 74 72 65 65 22 29 20 0a 20 20 20 20 20 inktree") .
5670: 20 28 72 6d 74 3a 64 72 6f 70 2d 61 6c 6c 2d 74 (rmt:drop-all-t
5680: 72 69 67 67 65 72 73 29 0a 20 20 20 20 28 6c 65 riggers). (le
5690: 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 20 20 t* ((linktree
56a0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
56b0: 6c 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 63 linktree)) ;; (c
56c0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
56d0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
56e0: 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a " "linktree"))).
56f0: 09 20 20 28 73 72 63 2d 61 72 63 68 69 76 65 2d . (src-archive-
5700: 6c 69 6e 6b 74 72 65 65 20 28 72 6d 74 3a 67 65 linktree (rmt:ge
5710: 74 2d 76 61 72 20 23 66 20 22 73 72 63 2d 61 72 t-var #f "src-ar
5720: 63 68 69 76 65 2d 6c 69 6e 6b 74 72 65 65 22 29 chive-linktree")
5730: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
5740: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 72 63 2d not (equal? src-
5750: 61 72 63 68 69 76 65 2d 6c 69 6e 6b 74 72 65 65 archive-linktree
5760: 20 6c 69 6e 6b 74 72 65 65 29 29 0a 20 20 20 20 linktree)).
5770: 20 20 20 20 20 20 20 28 72 6d 74 3a 75 70 64 61 (rmt:upda
5780: 74 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 te-tesdata-on-re
5790: 70 69 6c 63 61 74 65 2d 64 62 20 73 72 63 2d 61 pilcate-db src-a
57a0: 72 63 68 69 76 65 2d 6c 69 6e 6b 74 72 65 65 20 rchive-linktree
57b0: 6c 69 6e 6b 74 72 65 65 29 29 0a 20 20 20 20 20 linktree)).
57c0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
57d0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 print-info 1 *de
57e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
57f0: 22 63 72 65 61 74 69 6e 67 20 74 72 69 67 67 65 "creating trigge
5800: 72 73 20 61 66 74 65 72 20 75 70 64 61 74 69 6e rs after updatin
5810: 67 20 6c 69 6e 6b 74 72 65 65 22 29 20 20 20 0a g linktree") .
5820: 20 20 20 20 20 20 20 28 72 6d 74 3a 63 72 65 61 (rmt:crea
5830: 74 65 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 29 te-all-triggers)
5840: 0a 29 29 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 .)) ..(define (
5850: 61 72 63 68 69 76 65 3a 6c 73 2d 3e 6c 69 73 74 archive:ls->list
5860: 20 20 62 75 70 2d 65 78 65 20 61 72 63 68 69 76 bup-exe archiv
5870: 65 2d 64 69 72 20 69 6e 74 65 72 6e 61 6c 2d 70 e-dir internal-p
5880: 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 63 6d ath). (let ((cm
5890: 64 20 28 63 6f 6e 63 20 62 75 70 2d 65 78 65 20 d (conc bup-exe
58a0: 22 20 2d 64 20 22 20 61 72 63 68 69 76 65 2d 64 " -d " archive-d
58b0: 69 72 20 20 22 20 6c 73 20 2d 6c 20 22 20 69 6e ir " ls -l " in
58c0: 74 65 72 6e 61 6c 2d 70 61 74 68 20 22 7c 20 61 ternal-path "| a
58d0: 77 6b 20 27 7b 70 72 69 6e 74 20 24 36 7d 27 20 wk '{print $6}'
58e0: 7c 20 73 6f 72 74 22 29 29 0a 20 20 20 20 20 20 | sort")).
58f0: 20 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 (res '())).
5900: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5910: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
5920: 67 2d 70 6f 72 74 2a 20 63 6d 64 29 0a 20 20 20 g-port* cmd).
5930: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
5940: 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
5950: 20 20 23 66 20 3b 3b 20 61 6e 79 74 68 69 6e 67 #f ;; anything
5960: 20 67 6f 65 73 20 77 72 6f 6e 67 20 2d 20 61 73 goes wrong - as
5970: 73 75 6d 65 20 74 68 65 20 70 72 6f 63 65 73 73 sume the process
5980: 20 69 6e 20 4e 4f 54 20 72 75 6e 6e 69 6e 67 2e in NOT running.
5990: 0a 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 . (with-inpu
59a0: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 t-from-pipe .
59b0: 20 20 20 63 6d 64 0a 20 20 20 20 20 20 28 6c 61 cmd. (la
59c0: 6d 62 64 61 20 28 29 0a 09 28 6c 65 74 2a 20 28 mbda ()..(let* (
59d0: 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 73 (inl (read-lines
59e0: 29 29 29 0a 09 20 20 28 72 65 76 65 72 73 65 20 ))).. (reverse
59f0: 69 6e 6c 29 29 29 29 29 29 29 0a 0a 28 64 65 66 inl)))))))..(def
5a00: 69 6e 65 20 28 74 69 6d 65 2d 73 74 72 69 6e 67 ine (time-string
5a10: 2d 3e 73 65 63 6f 6e 64 73 20 74 73 74 72 20 64 ->seconds tstr d
5a20: 73 2d 66 6c 61 67 29 0a 20 28 6c 65 74 2a 20 28 s-flag). (let* (
5a30: 28 61 74 69 6d 65 20 28 73 74 72 69 6e 67 2d 3e (atime (string->
5a40: 74 69 6d 65 20 74 73 74 72 20 22 25 59 2d 25 6d time tstr "%Y-%m
5a50: 2d 25 64 2d 25 48 25 4d 25 53 22 29 29 29 0a 20 -%d-%H%M%S"))).
5a60: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
5a70: 74 21 20 61 74 69 6d 65 20 38 20 64 73 2d 66 6c t! atime 8 ds-fl
5a80: 61 67 29 0a 20 20 20 20 20 28 6c 6f 63 61 6c 2d ag). (local-
5a90: 74 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 61 74 time->seconds at
5aa0: 69 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ime)))..(define
5ab0: 28 73 65 63 6f 6e 64 73 2d 3e 73 74 64 2d 74 69 (seconds->std-ti
5ac0: 6d 65 2d 73 74 72 20 73 65 63 29 0a 20 20 28 74 me-str sec). (t
5ad0: 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 20 20 20 ime->string .
5ae0: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
5af0: 74 69 6d 65 20 73 65 63 29 0a 20 20 20 22 25 59 time sec). "%Y
5b00: 2d 25 6d 2d 25 64 2d 25 48 25 4d 25 53 22 29 29 -%m-%d-%H%M%S"))
5b10: 0a 20 0a 0a 28 64 65 66 69 6e 65 20 28 61 72 63 . ..(define (arc
5b20: 68 69 76 65 3a 67 65 74 2d 74 69 6d 65 73 74 61 hive:get-timesta
5b30: 6d 70 2d 64 69 72 20 62 75 70 2d 65 78 65 20 61 mp-dir bup-exe a
5b40: 72 63 68 69 76 65 2d 64 69 72 20 74 65 73 74 73 rchive-dir tests
5b50: 75 69 74 65 2d 6e 61 6d 65 20 74 61 72 67 65 74 uite-name target
5b60: 20 74 65 73 74 2d 70 61 72 74 69 61 6c 2d 70 61 test-partial-pa
5b70: 74 68 20 74 65 73 74 2d 6c 61 73 74 2d 75 70 64 th test-last-upd
5b80: 61 74 65 29 0a 20 20 20 20 28 64 65 62 75 67 3a ate). (debug:
5b90: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5ba0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5bb0: 22 54 65 73 74 20 6c 61 73 74 20 75 70 64 61 74 "Test last updat
5bc0: 65 20 74 69 6d 65 3a 22 20 28 73 65 63 6f 6e 64 e time:" (second
5bd0: 73 2d 3e 73 74 64 2d 74 69 6d 65 2d 73 74 72 20 s->std-time-str
5be0: 74 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 test-last-update
5bf0: 29 29 20 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 )) . (let* ((
5c00: 69 6e 74 65 72 6e 61 6c 2d 70 61 74 68 20 28 63 internal-path (c
5c10: 6f 6e 63 20 74 65 73 74 73 75 69 74 65 2d 6e 61 onc testsuite-na
5c20: 6d 65 20 22 2d 22 20 74 61 72 67 65 74 29 29 0a me "-" target)).
5c30: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 63 68 (arch
5c40: 69 76 65 2d 75 70 64 61 74 65 2d 64 65 6c 61 79 ive-update-delay
5c50: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
5c60: 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (or (configf:lo
5c70: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
5c80: 20 22 61 72 63 68 69 76 65 22 20 22 74 65 73 74 "archive" "test
5c90: 2d 75 70 64 61 74 65 2d 64 65 6c 61 79 22 29 20 -update-delay")
5ca0: 22 39 30 30 22 20 29 29 29 20 20 0a 20 20 20 20 "900" ))) .
5cb0: 20 20 20 20 20 20 20 28 74 73 2d 6c 69 73 74 20 (ts-list
5cc0: 28 61 72 63 68 69 76 65 3a 6c 73 2d 3e 6c 69 73 (archive:ls->lis
5cd0: 74 20 20 62 75 70 2d 65 78 65 20 61 72 63 68 69 t bup-exe archi
5ce0: 76 65 2d 64 69 72 20 69 6e 74 65 72 6e 61 6c 2d ve-dir internal-
5cf0: 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 path)).
5d00: 20 20 28 64 73 2d 66 6c 61 67 20 28 76 65 63 74 (ds-flag (vect
5d10: 6f 72 2d 72 65 66 20 28 73 65 63 6f 6e 64 73 2d or-ref (seconds-
5d20: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 29 20 38 29 29 >local-time) 8))
5d30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 ). (le
5d40: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
5d50: 72 20 74 73 2d 6c 69 73 74 29 29 0a 20 20 20 20 r ts-list)).
5d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d70: 20 20 20 28 74 61 69 6c 20 28 63 64 72 20 74 73 (tail (cdr ts
5d80: 2d 6c 69 73 74 29 29 29 0a 20 20 20 20 20 20 20 -list))).
5d90: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5da0: 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 74 61 69 6c (and (null? tail
5db0: 29 20 28 65 71 75 61 6c 3f 20 68 65 64 20 22 6c ) (equal? hed "l
5dc0: 61 74 65 73 74 22 29 29 0a 20 20 20 20 20 20 20 atest")).
5dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5de0: 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
5df0: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
5e00: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 69 (not (null? tai
5e10: 6c 29 29 20 28 65 71 75 61 6c 3f 20 68 65 64 20 l)) (equal? hed
5e20: 22 6c 61 74 65 73 74 22 29 29 0a 20 20 20 20 20 "latest")).
5e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e40: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
5e50: 69 6c 29 20 28 63 64 72 20 74 61 69 6c 29 29 0a il) (cdr tail)).
5e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e70: 20 20 28 6c 65 74 2a 20 28 28 61 72 63 68 69 76 (let* ((archiv
5e80: 65 2d 73 65 63 6f 6e 64 73 20 28 74 69 6d 65 2d e-seconds (time-
5e90: 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 string->seconds
5ea0: 68 65 64 20 64 73 2d 66 6c 61 67 29 29 29 0a 20 hed ds-flag))).
5eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ec0: 20 20 20 28 69 66 20 28 3c 20 28 61 62 73 20 28 (if (< (abs (
5ed0: 2d 20 61 72 63 68 69 76 65 2d 73 65 63 6f 6e 64 - archive-second
5ee0: 73 20 74 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 s test-last-upda
5ef0: 74 65 29 29 20 61 72 63 68 69 76 65 2d 75 70 64 te)) archive-upd
5f00: 61 74 65 2d 64 65 6c 61 79 29 0a 20 20 20 20 20 ate-delay).
5f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5f20: 6c 65 74 2a 20 28 28 74 65 73 74 2d 6c 69 73 74 let* ((test-list
5f30: 20 28 61 72 63 68 69 76 65 3a 6c 73 2d 3e 6c 69 (archive:ls->li
5f40: 73 74 20 20 62 75 70 2d 65 78 65 20 61 72 63 68 st bup-exe arch
5f50: 69 76 65 2d 64 69 72 20 28 63 6f 6e 63 20 69 6e ive-dir (conc in
5f60: 74 65 72 6e 61 6c 2d 70 61 74 68 20 22 2f 22 20 ternal-path "/"
5f70: 68 65 64 20 22 2f 22 20 74 65 73 74 2d 70 61 72 hed "/" test-par
5f80: 74 69 61 6c 2d 70 61 74 68 29 29 29 29 0a 20 20 tial-path)))).
5f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fa0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 (if (>
5fb0: 28 6c 65 6e 67 74 68 20 74 65 73 74 2d 6c 69 73 (length test-lis
5fc0: 74 29 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 t) 0).
5fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fe0: 20 20 20 20 20 68 65 64 0a 20 20 20 20 20 20 20 hed.
5ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6000: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
6010: 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 29 20 0a (null? tail)) .
6020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6040: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 69 6c (loop (car tail
6050: 29 20 28 63 64 72 20 74 61 69 6c 29 29 0a 20 20 ) (cdr tail)).
6060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
6080: 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 f))).
6090: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
60a0: 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 20 (null? tail).
60b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60c0: 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 #f.
60d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60e0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
60f0: 61 69 6c 29 20 28 63 64 72 20 74 61 69 6c 29 29 ail) (cdr tail))
6100: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
6110: 65 20 28 61 72 63 68 69 76 65 3a 62 75 70 2d 72 e (archive:bup-r
6120: 65 73 74 6f 72 65 20 61 72 63 68 69 76 65 2d 63 estore archive-c
6130: 6f 6d 6d 61 6e 64 20 72 75 6e 2d 69 64 20 72 75 ommand run-id ru
6140: 6e 2d 6e 61 6d 65 20 74 65 73 74 73 20 72 70 2d n-name tests rp-
6150: 6d 75 74 65 78 20 62 75 70 2d 6d 75 74 65 78 29 mutex bup-mutex)
6160: 20 20 3b 3b 20 6d 6f 76 65 20 74 68 65 20 67 65 ;; move the ge
6170: 74 74 69 6e 67 20 6f 66 20 61 72 63 68 69 76 65 tting of archive
6180: 20 73 70 61 63 65 20 64 6f 77 6e 20 69 6e 74 6f space down into
6190: 20 74 68 65 20 62 65 6c 6f 77 20 62 6c 6f 63 6b the below block
61a0: 20 73 6f 20 74 68 61 74 20 61 20 73 69 6e 67 6c so that a singl
61b0: 65 20 72 75 6e 20 63 61 6e 20 0a 20 20 3b 3b 20 e run can . ;;
61c0: 61 6c 6c 6f 63 61 74 65 20 61 73 20 6e 65 65 64 allocate as need
61d0: 65 64 20 73 68 6f 75 6c 64 20 61 20 64 69 73 6b ed should a disk
61e0: 20 66 69 6c 6c 20 75 70 0a 20 20 3b 3b 0a 20 20 fill up. ;;.
61f0: 28 6c 65 74 2a 20 28 28 62 75 70 2d 65 78 65 20 (let* ((bup-exe
6200: 20 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 (or (config
6210: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
6220: 64 61 74 2a 20 22 61 72 63 68 69 76 65 22 20 22 dat* "archive" "
6230: 62 75 70 22 29 20 22 62 75 70 22 29 29 0a 09 20 bup") "bup"))..
6240: 28 6c 69 6e 6b 74 72 65 65 20 20 20 20 20 28 63 (linktree (c
6250: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 ommon:get-linktr
6260: 65 65 29 29 29 20 3b 3b 20 28 63 6f 6e 66 69 67 ee))) ;; (config
6270: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
6280: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 dat* "setup" "li
6290: 6e 6b 74 72 65 65 22 29 29 29 0a 0a 20 20 20 20 nktree")))..
62a0: 3b 3b 20 66 72 6f 6d 20 74 68 65 20 74 65 73 74 ;; from the test
62b0: 20 69 6e 66 6f 20 62 69 6e 20 74 68 65 20 70 61 info bin the pa
62c0: 74 68 20 74 6f 20 74 68 65 20 74 65 73 74 20 62 th to the test b
62d0: 79 20 73 74 65 6d 0a 20 20 20 20 3b 3b 0a 20 20 y stem. ;;.
62e0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
62f0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 64 (lambda (test-d
6300: 61 74 29 0a 20 20 20 20 20 20 20 3b 3b 20 57 68 at). ;; Wh
6310: 65 6e 20 72 65 73 74 6f 72 69 6e 67 20 74 65 73 en restoring tes
6320: 74 2d 64 61 74 20 77 69 6c 6c 20 69 6e 69 74 69 t-dat will initi
6330: 61 6c 6c 79 20 63 6f 6e 74 61 69 6e 20 61 6e 20 ally contain an
6340: 6f 6c 64 20 61 6e 64 20 69 6e 76 61 6c 69 64 20 old and invalid
6350: 70 61 74 68 20 74 6f 20 74 68 65 20 74 65 73 74 path to the test
6360: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
6370: 62 65 73 74 2d 64 69 73 6b 20 20 20 20 20 20 20 best-disk
6380: 20 20 28 67 65 74 2d 62 65 73 74 2d 64 69 73 6b (get-best-disk
6390: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 23 66 29 *configdat* #f)
63a0: 29 20 3b 3b 20 42 55 47 3a 20 67 65 74 20 74 68 ) ;; BUG: get th
63b0: 65 20 74 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 e testconfig and
63c0: 20 75 73 65 20 69 74 20 68 65 72 65 2e 20 4f 74 use it here. Ot
63d0: 68 65 72 77 69 73 65 20 64 61 74 61 20 70 75 6c herwise data pul
63e0: 6c 65 64 20 6f 75 74 20 6f 66 20 61 72 63 68 69 led out of archi
63f0: 76 65 20 63 6f 75 6c 64 20 65 6e 64 20 75 70 20 ve could end up
6400: 6f 6e 20 74 68 65 20 77 72 6f 6e 67 20 6b 69 6e on the wrong kin
6410: 64 20 6f 66 20 64 69 73 6b 2e 0a 09 20 20 20 20 d of disk...
6420: 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 (item-path
6430: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
6440: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
6450: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 74 -dat)).. (t
6460: 65 73 74 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 est-name
6470: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
6480: 73 74 6e 61 6d 65 20 20 74 65 73 74 2d 64 61 74 stname test-dat
6490: 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
64a0: 69 64 20 20 20 20 20 20 20 20 20 20 20 28 64 62 id (db
64b0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 :test-get-id
64c0: 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 test-dat))..
64d0: 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 20 20 (run-id
64e0: 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 (db:tes
64f0: 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 20 t-get-run_id
6500: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 test-dat))..
6510: 20 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 20 (keyvals
6520: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 (rmt:get-ke
6530: 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d y-val-pairs run-
6540: 69 64 29 29 0a 09 20 20 20 20 20 20 28 74 61 72 id)).. (tar
6550: 67 65 74 20 20 20 20 20 20 20 20 20 20 20 20 28 get (
6560: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
6570: 73 65 20 28 6d 61 70 20 63 61 64 72 20 6b 65 79 se (map cadr key
6580: 76 61 6c 73 29 20 22 2f 22 29 29 0a 09 20 20 20 vals) "/"))..
6590: 20 20 20 0a 09 20 20 20 20 20 20 28 74 6f 70 6c .. (topl
65a0: 65 76 65 6c 2f 63 68 69 6c 64 72 65 6e 20 28 61 evel/children (a
65b0: 6e 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nd (db:test-get-
65c0: 69 73 2d 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 is-toplevel test
65d0: 2d 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 20 -dat).....
65e0: 28 3e 20 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 (> (rmt:test-top
65f0: 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 level-num-items
6600: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
6610: 29 20 30 29 29 29 0a 09 20 20 20 20 20 20 28 74 ) 0))).. (t
6620: 65 73 74 2d 70 61 72 74 69 61 6c 2d 70 61 74 68 est-partial-path
6630: 20 28 63 6f 6e 63 20 20 72 75 6e 2d 6e 61 6d 65 (conc run-name
6640: 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 6d 61 "/" (db:test-ma
6650: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
6660: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
6670: 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 6e 6f ))).. ;; no
6680: 74 65 20 74 68 65 20 74 72 61 69 6c 69 6e 67 20 te the trailing
6690: 73 6c 61 73 68 20 74 6f 20 67 65 74 20 74 68 65 slash to get the
66a0: 20 64 69 72 20 69 6e 73 70 69 74 65 20 6f 66 20 dir inspite of
66b0: 69 74 20 62 65 69 6e 67 20 61 20 6c 69 6e 6b 0a it being a link.
66c0: 09 20 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 . (test-pat
66d0: 68 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 h (conc
66e0: 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 65 73 linktree "/" tes
66f0: 74 2d 70 61 72 74 69 61 6c 2d 70 61 74 68 29 29 t-partial-path))
6700: 0a 09 20 20 20 20 20 20 3b 3b 20 69 66 20 74 68 .. ;; if th
6710: 65 20 6f 6c 64 20 70 61 74 68 20 77 61 73 20 6e e old path was n
6720: 6f 74 20 64 65 6c 65 74 65 64 20 74 68 65 6e 20 ot deleted then
6730: 70 72 65 76 2d 74 65 73 74 2d 70 68 79 73 69 63 prev-test-physic
6740: 61 6c 2d 70 61 74 68 20 77 69 6c 6c 20 65 6e 64 al-path will end
6750: 20 75 70 20 70 6f 69 6e 74 69 6e 67 20 74 6f 20 up pointing to
6760: 61 20 72 65 61 6c 20 64 69 72 65 63 74 6f 72 79 a real directory
6770: 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c .. (mutex-l
6780: 6f 63 6b 21 20 72 70 2d 6d 75 74 65 78 29 0a 09 ock! rp-mutex)..
6790: 20 20 20 20 20 20 28 70 72 65 76 2d 74 65 73 74 (prev-test
67a0: 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 20 28 -physical-path (
67b0: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d if (common:file-
67c0: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 70 61 74 exists? test-pat
67d0: 68 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 72 h)...... ;; (r
67e0: 65 61 64 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e ead-symbolic-lin
67f0: 6b 20 74 65 73 74 2d 70 61 74 68 20 23 74 29 0a k test-path #t).
6800: 09 09 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a ..... (common:
6810: 72 65 61 6c 2d 70 61 74 68 20 74 65 73 74 2d 70 real-path test-p
6820: 61 74 68 29 0a 09 09 09 09 09 20 20 20 23 66 29 ath)...... #f)
6830: 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d ).. (mutex-
6840: 75 6e 6c 6f 63 6b 21 20 72 70 2d 6d 75 74 65 78 unlock! rp-mutex
6850: 29 0a 09 20 20 20 20 20 20 28 6e 65 77 2d 74 65 ).. (new-te
6860: 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 st-physical-path
6870: 20 20 28 63 6f 6e 63 20 62 65 73 74 2d 64 69 73 (conc best-dis
6880: 6b 20 22 2f 22 20 74 65 73 74 2d 70 61 72 74 69 k "/" test-parti
6890: 61 6c 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 al-path))..
68a0: 20 28 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d (archive-block-
68b0: 69 64 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 id (db:te
68c0: 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 64 20 st-get-archived
68d0: 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 test-dat)).
68e0: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6c (test-l
68f0: 61 73 74 2d 75 70 64 61 74 65 20 20 20 20 20 20 ast-update
6900: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 6c (db:test-get-l
6910: 61 73 74 5f 75 70 64 61 74 65 20 74 65 73 74 2d ast_update test-
6920: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 61 72 dat)).. (ar
6930: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f chive-block-info
6940: 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d (rmt:test-
6950: 67 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 get-archive-bloc
6960: 6b 2d 69 6e 66 6f 20 61 72 63 68 69 76 65 2d 62 k-info archive-b
6970: 6c 6f 63 6b 2d 69 64 29 29 0a 09 20 20 20 20 20 lock-id))..
6980: 20 28 61 72 63 68 69 76 65 2d 70 61 74 68 20 20 (archive-path
6990: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 76 (if (v
69a0: 65 63 74 6f 72 3f 20 61 72 63 68 69 76 65 2d 62 ector? archive-b
69b0: 6c 6f 63 6b 2d 69 6e 66 6f 29 0a 09 09 09 09 09 lock-info)......
69c0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 (vector-ref a
69d0: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 rchive-block-inf
69e0: 6f 20 32 29 20 3b 3b 20 6c 6f 6f 6b 20 69 6e 20 o 2) ;; look in
69f0: 64 62 2e 73 63 6d 20 66 6f 72 20 74 65 73 74 2d db.scm for test-
6a00: 67 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 get-archive-bloc
6a10: 6b 2d 69 6e 66 6f 20 66 6f 72 20 74 68 65 20 76 k-info for the v
6a20: 65 63 74 6f 72 20 72 65 63 6f 72 64 20 69 6e 66 ector record inf
6a30: 6f 0a 09 09 09 09 09 20 20 20 23 66 29 29 20 3b o...... #f)) ;
6a40: 3b 20 6e 6f 20 61 72 63 68 69 76 65 20 66 6f 75 ; no archive fou
6a50: 6e 64 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 nd?.
6a60: 20 20 28 61 72 63 68 69 76 65 2d 74 69 6d 65 73 (archive-times
6a70: 74 61 6d 70 2d 64 69 72 20 20 20 28 69 66 20 61 tamp-dir (if a
6a80: 72 63 68 69 76 65 2d 70 61 74 68 20 28 61 72 63 rchive-path (arc
6a90: 68 69 76 65 3a 67 65 74 2d 74 69 6d 65 73 74 61 hive:get-timesta
6aa0: 6d 70 2d 64 69 72 20 62 75 70 2d 65 78 65 20 61 mp-dir bup-exe a
6ab0: 72 63 68 69 76 65 2d 70 61 74 68 20 28 63 6f 6d rchive-path (com
6ac0: 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d mon:get-area-nam
6ad0: 65 29 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 e) (string-subst
6ae0: 69 74 75 74 65 20 22 2f 22 20 22 2d 22 20 74 61 itute "/" "-" ta
6af0: 72 67 65 74 20 22 20 22 29 20 74 65 73 74 2d 70 rget " ") test-p
6b00: 61 72 74 69 61 6c 2d 70 61 74 68 20 74 65 73 74 artial-path test
6b10: 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 23 66 -last-update) #f
6b20: 29 29 20 20 0a 09 20 20 20 20 20 20 28 61 72 63 )) .. (arc
6b30: 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c 2d 70 61 hive-internal-pa
6b40: 74 68 20 20 20 28 63 6f 6e 63 20 28 63 6f 6d 6d th (conc (comm
6b50: 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 on:get-area-name
6b60: 29 20 22 2d 22 20 28 73 74 72 69 6e 67 2d 73 75 ) "-" (string-su
6b70: 62 73 74 69 74 75 74 65 20 22 2f 22 20 22 2d 22 bstitute "/" "-"
6b80: 20 74 61 72 67 65 74 20 22 20 22 29 20 22 2f 22 target " ") "/"
6b90: 20 61 72 63 68 69 76 65 2d 74 69 6d 65 73 74 61 archive-timesta
6ba0: 6d 70 2d 64 69 72 20 22 2f 22 20 74 65 73 74 2d mp-dir "/" test-
6bb0: 70 61 72 74 69 61 6c 2d 70 61 74 68 29 29 0a 09 partial-path))..
6bc0: 20 20 20 20 20 20 28 69 6e 63 6c 75 64 65 2d 70 (include-p
6bd0: 61 74 68 73 20 20 20 20 20 20 20 20 20 20 20 28 aths (
6be0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 69 args:get-arg "-i
6bf0: 6e 63 6c 75 64 65 22 29 29 0a 09 20 20 20 20 20 nclude"))..
6c00: 20 28 65 78 63 6c 75 64 65 2d 70 61 74 74 65 72 (exclude-patter
6c10: 6e 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a n (args:
6c20: 67 65 74 2d 61 72 67 20 22 2d 65 78 63 6c 75 64 get-arg "-exclud
6c30: 65 2d 72 78 22 29 29 0a 09 20 20 20 20 20 20 28 e-rx")).. (
6c40: 65 78 63 6c 75 64 65 2d 66 69 6c 65 20 20 20 20 exclude-file
6c50: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
6c60: 74 2d 61 72 67 20 22 2d 65 78 63 6c 75 64 65 2d t-arg "-exclude-
6c70: 72 78 2d 66 72 6f 6d 22 29 29 29 0a 09 20 28 69 rx-from"))).. (i
6c80: 66 20 28 6e 6f 74 20 61 72 63 68 69 76 65 2d 74 f (not archive-t
6c90: 69 6d 65 73 74 61 6d 70 2d 64 69 72 29 0a 20 20 imestamp-dir).
6ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
6cb0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
6cc0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6cd0: 6f 72 74 2a 20 22 41 72 63 68 69 76 65 20 6e 6f ort* "Archive no
6ce0: 74 20 66 6f 75 6e 64 20 66 6f 72 20 74 65 73 74 t found for test
6cf0: 73 75 69 74 65 22 20 28 63 6f 6d 6d 6f 6e 3a 67 suite" (common:g
6d00: 65 74 2d 61 72 65 61 2d 6e 61 6d 65 29 20 22 20 et-area-name) "
6d10: 72 75 6e 2f 74 65 73 74 2f 69 74 65 6d 70 61 74 run/test/itempat
6d20: 68 22 20 74 65 73 74 2d 70 61 72 74 69 61 6c 2d h" test-partial-
6d30: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 28 path). (
6d40: 62 65 67 69 6e 20 20 20 20 0a 09 20 3b 3b 20 73 begin .. ;; s
6d50: 6f 6d 65 20 73 61 6e 69 74 79 20 63 68 65 63 6b ome sanity check
6d60: 73 2c 20 6d 6f 76 65 20 61 6e 20 65 78 69 73 74 s, move an exist
6d70: 69 6e 67 20 70 61 74 68 20 6f 75 74 20 6f 66 20 ing path out of
6d80: 74 68 65 20 77 61 79 20 2d 20 69 69 66 20 69 74 the way - iif it
6d90: 20 69 73 20 6e 6f 74 20 61 20 74 6f 70 6c 65 76 is not a toplev
6da0: 65 6c 20 77 69 74 68 20 63 68 69 6c 64 72 65 6e el with children
6db0: 0a 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 . (debug
6dc0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
6dd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6de0: 20 22 41 72 63 68 69 76 65 20 74 69 6d 65 3a 20 "Archive time:
6df0: 22 20 61 72 63 68 69 76 65 2d 74 69 6d 65 73 74 " archive-timest
6e00: 61 6d 70 2d 64 69 72 29 0a 09 20 28 69 66 20 28 amp-dir).. (if (
6e10: 61 6e 64 20 28 6e 6f 74 20 74 6f 70 6c 65 76 65 and (not topleve
6e20: 6c 2f 63 68 69 6c 64 72 65 6e 29 20 20 3b 3b 20 l/children) ;;
6e30: 73 70 65 63 69 61 6c 20 68 61 6e 64 6c 69 6e 67 special handling
6e40: 20 6e 65 65 64 65 64 20 66 6f 72 20 74 6f 70 6c needed for topl
6e50: 65 76 65 6c 20 77 69 74 68 20 63 68 69 6c 64 72 evel with childr
6e60: 65 6e 0a 09 09 20 20 70 72 65 76 2d 74 65 73 74 en... prev-test
6e70: 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 0a 09 -physical-path..
6e80: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d . (common:file-
6e90: 65 78 69 73 74 73 3f 20 70 72 65 76 2d 74 65 73 exists? prev-tes
6ea0: 74 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 29 t-physical-path)
6eb0: 29 20 3b 3b 20 77 68 61 74 20 74 6f 20 64 6f 3f ) ;; what to do?
6ec0: 20 61 62 6f 72 74 20 6f 72 20 63 6c 65 61 6e 20 abort or clean
6ed0: 75 70 20 6f 72 20 6c 69 6e 6b 20 69 74 20 69 6e up or link it in
6ee0: 3f 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ?.. (let* ((
6ef0: 62 61 73 65 20 28 70 61 74 68 6e 61 6d 65 2d 64 base (pathname-d
6f00: 69 72 65 63 74 6f 72 79 20 70 72 65 76 2d 74 65 irectory prev-te
6f10: 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 st-physical-path
6f20: 29 29 0a 09 09 20 20 20 20 28 64 69 72 6e 20 28 ))... (dirn (
6f30: 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 20 20 pathname-file
6f40: 20 20 20 70 72 65 76 2d 74 65 73 74 2d 70 68 79 prev-test-phy
6f50: 73 69 63 61 6c 2d 70 61 74 68 29 29 0a 09 09 20 sical-path))...
6f60: 20 20 20 28 6e 65 77 6e 20 28 63 6f 6e 63 20 62 (newn (conc b
6f70: 61 73 65 20 22 2f 2e 22 20 64 69 72 6e 29 29 29 ase "/." dirn)))
6f80: 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
6f90: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
6fa0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6fb0: 20 22 74 68 65 20 6f 6c 64 20 64 69 72 65 63 74 "the old direct
6fc0: 6f 72 79 20 22 20 70 72 65 76 2d 74 65 73 74 2d ory " prev-test-
6fd0: 70 68 79 73 69 63 61 6c 2d 70 61 74 68 20 22 2c physical-path ",
6fe0: 20 73 74 69 6c 6c 20 65 78 69 73 74 73 21 20 4d still exists! M
6ff0: 6f 76 69 6e 67 20 69 74 20 74 6f 20 22 20 6e 65 oving it to " ne
7000: 77 6e 29 0a 09 20 20 20 20 20 20 20 28 72 65 6e wn).. (ren
7010: 61 6d 65 2d 66 69 6c 65 20 70 72 65 76 2d 74 65 ame-file prev-te
7020: 73 74 2d 70 68 79 73 69 63 61 6c 2d 70 61 74 68 st-physical-path
7030: 20 6e 65 77 6e 29 29 29 0a 0a 09 20 28 69 66 20 newn)))... (if
7040: 28 61 6e 64 20 61 72 63 68 69 76 65 2d 70 61 74 (and archive-pat
7050: 68 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 6e h ;; no point in
7060: 20 70 72 6f 63 65 65 64 69 6e 67 20 69 66 20 74 proceeding if t
7070: 68 65 72 65 20 69 73 20 6e 6f 20 61 63 74 75 61 here is no actua
7080: 6c 20 61 72 63 68 69 76 65 0a 09 09 20 20 28 6e l archive... (n
7090: 6f 74 20 74 6f 70 6c 65 76 65 6c 2f 63 68 69 6c ot toplevel/chil
70a0: 64 72 65 6e 29 29 0a 09 20 20 20 20 20 28 62 65 dren)).. (be
70b0: 67 69 6e 0a 09 20 20 20 20 20 20 20 3b 3b 20 43 gin.. ;; C
70c0: 52 45 41 54 45 20 57 4f 52 4b 20 41 52 45 41 0a REATE WORK AREA.
70d0: 09 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 2d . ;; test-
70e0: 73 72 63 2d 70 61 74 68 20 3d 3d 20 23 66 20 20 src-path == #f
70f0: 20 20 20 3d 3d 3e 20 64 6f 6e 27 74 20 63 6f 70 ==> don't cop
7100: 79 20 69 6e 20 64 61 74 61 20 66 72 6f 6d 20 74 y in data from t
7110: 65 73 74 73 20 64 69 72 65 63 74 6f 72 79 0a 09 ests directory..
7120: 20 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 64 61 ;; itemda
7130: 74 20 20 20 20 20 20 20 3d 3d 20 73 74 72 69 6e t == strin
7140: 67 20 3d 3d 3e 20 75 73 65 20 64 69 72 65 63 74 g ==> use direct
7150: 6c 79 0a 09 20 20 20 20 20 20 20 28 63 72 65 61 ly.. (crea
7160: 74 65 2d 77 6f 72 6b 2d 61 72 65 61 20 72 75 6e te-work-area run
7170: 2d 69 64 20 72 75 6e 2d 6e 61 6d 65 20 6b 65 79 -id run-name key
7180: 76 61 6c 73 20 74 65 73 74 2d 69 64 20 23 66 20 vals test-id #f
7190: 62 65 73 74 2d 64 69 73 6b 20 74 65 73 74 2d 6e best-disk test-n
71a0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 3b ame item-path) ;
71b0: 3b 20 23 21 6b 65 79 20 28 72 65 6d 74 72 69 65 ; #!key (remtrie
71c0: 73 20 32 29 29 0a 09 20 20 20 20 20 20 20 3b 3b s 2)).. ;;
71d0: 20 31 2e 20 47 65 74 20 74 68 65 20 62 6c 6f 63 1. Get the bloc
71e0: 6b 20 69 64 20 66 72 6f 6d 20 74 68 65 20 74 65 k id from the te
71f0: 73 74 20 69 6e 66 6f 0a 09 20 20 20 20 20 20 20 st info..
7200: 3b 3b 20 32 2e 20 47 65 74 20 74 68 65 20 62 6c ;; 2. Get the bl
7210: 6f 63 6b 20 64 61 74 61 20 67 69 76 65 6e 20 74 ock data given t
7220: 68 65 20 62 6c 6f 63 6b 20 69 64 0a 09 20 20 20 he block id..
7230: 20 20 20 20 3b 3b 20 33 2e 20 43 6f 6e 73 74 72 ;; 3. Constr
7240: 75 63 74 20 74 68 65 20 70 61 74 68 73 20 65 74 uct the paths et
7250: 63 2e 20 66 6f 72 20 74 68 65 20 66 6f 6c 6c 6f c. for the follo
7260: 77 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a 0a 09 20 wing command:..
7270: 20 20 20 20 20 20 3b 3b 20 62 75 70 20 2d 64 20 ;; bup -d
7280: 2f 74 6d 70 2f 6d 61 74 74 2f 61 64 69 73 6b 31 /tmp/matt/adisk1
7290: 2f 32 30 31 35 5f 71 31 2f 66 75 6c 6c 72 75 6e /2015_q1/fullrun
72a0: 5f 65 31 61 34 30 2f 20 72 65 73 74 6f 72 65 20 _e1a40/ restore
72b0: 2d 43 20 2f 74 6d 70 2f 73 65 65 6d 65 20 66 75 -C /tmp/seeme fu
72c0: 6c 6c 72 75 6e 2d 33 30 2f 6c 61 74 65 73 74 2f llrun-30/latest/
72d0: 75 62 75 6e 74 75 2f 6e 66 73 2f 6e 6f 6e 65 2f ubuntu/nfs/none/
72e0: 77 30 32 2e 31 2e 32 30 2e 35 34 5f 62 2f 0a 09 w02.1.20.54_b/..
72f0: 20 20 20 20 20 20 20 3b 3b 20 44 4f 20 42 55 50 ;; DO BUP
7300: 20 52 45 53 54 4f 52 45 0a 09 20 20 20 20 20 20 RESTORE..
7310: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 (let* ((new-tes
7320: 74 2d 64 61 74 20 20 20 20 20 20 20 20 28 72 6d t-dat (rm
7330: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
7340: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
7350: 74 2d 69 64 29 29 0a 09 09 20 20 20 20 20 20 28 t-id))... (
7360: 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 20 20 new-test-path
7370: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector?
7380: 20 6e 65 77 2d 74 65 73 74 2d 64 61 74 20 29 0a new-test-dat ).
7390: 09 09 09 09 09 20 20 20 20 20 20 20 28 64 62 3a ..... (db:
73a0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
73b0: 6e 65 77 2d 74 65 73 74 2d 64 61 74 29 0a 09 09 new-test-dat)...
73c0: 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
73d0: 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 ....... (debug:p
73e0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
73f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
7400: 22 75 6e 61 62 6c 65 20 74 6f 20 67 65 74 20 64 "unable to get d
7410: 61 74 61 20 66 6f 72 20 72 75 6e 2d 69 64 3d 22 ata for run-id="
7420: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
7430: 69 64 3d 22 20 74 65 73 74 2d 69 64 29 0a 09 09 id=" test-id)...
7440: 09 09 09 09 20 28 65 78 69 74 20 31 29 29 29 29 .... (exit 1))))
7450: 0a 09 09 20 20 20 20 20 20 3b 3b 20 6e 65 77 2d ... ;; new-
7460: 74 65 73 74 2d 70 61 74 68 20 77 6f 6e 27 74 20 test-path won't
7470: 77 6f 72 6b 20 2d 20 6d 75 73 74 20 75 73 65 20 work - must use
7480: 62 65 73 74 2d 64 69 73 6b 20 69 6e 73 74 65 61 best-disk instea
7490: 64 3f 20 4e 6f 70 65 2c 20 6e 65 77 2d 74 65 73 d? Nope, new-tes
74a0: 74 2d 70 61 74 68 20 62 75 74 20 74 61 63 6b 20 t-path but tack
74b0: 6f 6e 20 2f 2e 2e 0a 09 09 20 20 20 20 20 20 28 on /..... (
74c0: 62 75 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 61 bup-restore-para
74d0: 6d 73 20 20 28 6c 69 73 74 20 22 2d 64 22 20 61 ms (list "-d" a
74e0: 72 63 68 69 76 65 2d 70 61 74 68 20 22 72 65 73 rchive-path "res
74f0: 74 6f 72 65 22 20 22 2d 43 22 20 28 63 6f 6e 63 tore" "-C" (conc
7500: 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 22 new-test-path "
7510: 2f 2e 2e 22 29 20 61 72 63 68 69 76 65 2d 69 6e /..") archive-in
7520: 74 65 72 6e 61 6c 2d 70 61 74 68 29 29 29 0a 09 ternal-path)))..
7530: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
7540: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
7550: 6f 67 2d 70 6f 72 74 2a 20 22 52 65 73 74 6f 72 og-port* "Restor
7560: 69 6e 67 20 61 72 63 68 69 76 65 64 20 64 61 74 ing archived dat
7570: 61 20 74 6f 20 22 20 6e 65 77 2d 74 65 73 74 2d a to " new-test-
7580: 70 68 79 73 69 63 61 6c 2d 70 61 74 68 20 22 20 physical-path "
7590: 66 72 6f 6d 20 61 72 63 68 69 76 65 20 69 6e 20 from archive in
75a0: 22 20 61 72 63 68 69 76 65 2d 70 61 74 68 20 22 " archive-path "
75b0: 20 2e 2e 2e 20 22 20 61 72 63 68 69 76 65 2d 69 ... " archive-i
75c0: 6e 74 65 72 6e 61 6c 2d 70 61 74 68 29 0a 20 20 nternal-path).
75d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
75e0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
75f0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7600: 70 6f 72 74 2a 20 62 75 70 2d 65 78 65 20 22 20 port* bup-exe "
7610: 22 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 20 " (string-join
7620: 62 75 70 2d 72 65 73 74 6f 72 65 2d 70 61 72 61 bup-restore-para
7630: 6d 73 20 22 20 22 29 29 0a 09 09 20 3b 3b 20 28 ms " "))... ;; (
7640: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 62 75 70 2d mutex-lock! bup-
7650: 6d 75 74 65 78 29 0a 09 09 20 28 72 75 6e 2d 6e mutex)... (run-n
7660: 2d 77 61 69 74 20 62 75 70 2d 65 78 65 20 70 61 -wait bup-exe pa
7670: 72 61 6d 73 3a 20 62 75 70 2d 72 65 73 74 6f 72 rams: bup-restor
7680: 65 2d 70 61 72 61 6d 73 20 70 72 69 6e 74 2d 63 e-params print-c
7690: 6d 64 3a 20 23 66 29 0a 09 09 20 3b 3b 20 28 6d md: #f)... ;; (m
76a0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 62 75 70 utex-unlock! bup
76b0: 2d 6d 75 74 65 78 29 0a 09 09 20 28 6d 74 3a 74 -mutex)... (mt:t
76c0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
76d0: 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 atus-by-id run-i
76e0: 64 20 74 65 73 74 2d 69 64 20 22 43 4f 4d 50 4c d test-id "COMPL
76f0: 45 54 45 44 22 20 23 66 20 23 66 29 29 29 0a 09 ETED" #f #f)))..
7700: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7710: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
7720: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f lt-log-port* "No
7730: 20 61 72 63 68 69 76 65 20 70 61 74 68 20 69 6e archive path in
7740: 20 74 68 65 20 72 65 63 6f 72 64 20 66 6f 72 20 the record for
7750: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
7760: 22 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 " test-id=" test
7770: 2d 69 64 29 29 29 29 29 29 0a 20 20 20 20 20 28 -id)))))). (
7780: 66 69 6c 74 65 72 20 76 65 63 74 6f 72 3f 20 74 filter vector? t
7790: 65 73 74 73 29 29 29 29 0a 0a 28 64 65 66 69 6e ests))))..(defin
77a0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 79 6f e (common:get-yo
77b0: 75 6e 67 65 73 74 2d 74 65 73 74 20 74 65 73 74 ungest-test test
77c0: 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s). (if (null?
77d0: 74 65 73 74 73 29 0a 20 20 20 20 20 20 23 66 0a tests). #f.
77e0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
77f0: 20 23 66 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 #f))..(for-each
7800: 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 .. (lambda (test
7810: 2d 64 61 74 29 0a 09 20 20 20 28 6c 65 74 20 28 -dat).. (let (
7820: 28 65 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a (event-time (db:
7830: 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 test-get-event_t
7840: 69 6d 65 20 74 65 73 74 2d 64 61 74 29 29 29 0a ime test-dat))).
7850: 09 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e . (if (or (n
7860: 6f 74 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 ot res)... (
7870: 3e 20 65 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 > event-time (db
7880: 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f :test-get-event_
7890: 74 69 6d 65 20 72 65 73 29 29 29 0a 09 09 20 28 time res)))... (
78a0: 73 65 74 21 20 72 65 73 20 74 65 73 74 2d 64 61 set! res test-da
78b0: 74 29 29 29 29 0a 09 20 74 65 73 74 73 29 0a 09 t)))).. tests)..
78c0: 72 65 73 29 29 29 0a 09 20 20 20 0a 3b 3b 20 66 res))).. .;; f
78d0: 72 6f 6d 20 61 6e 20 61 72 63 68 69 76 65 20 67 rom an archive g
78e0: 65 74 20 61 20 73 70 65 63 69 66 69 63 20 70 61 et a specific pa
78f0: 74 68 20 2d 20 77 6f 72 6b 73 20 4f 4e 4c 59 20 th - works ONLY
7900: 77 69 74 68 20 62 75 70 20 66 6f 72 20 6e 6f 77 with bup for now
7910: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 61 72 63 .;;.(define (arc
7920: 68 69 76 65 3a 62 75 70 2d 67 65 74 2d 64 61 74 hive:bup-get-dat
7930: 61 20 61 72 63 68 69 76 65 2d 63 6f 6d 6d 61 6e a archive-comman
7940: 64 20 72 75 6e 2d 69 64 2d 69 6e 20 72 75 6e 2d d run-id-in run-
7950: 6e 61 6d 65 2d 69 6e 20 74 65 73 74 73 20 72 70 name-in tests rp
7960: 2d 6d 75 74 65 78 20 62 75 70 2d 6d 75 74 65 78 -mutex bup-mutex
7970: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 ). (if (null? t
7980: 65 73 74 73 29 0a 20 20 20 20 20 20 28 64 65 62 ests). (deb
7990: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
79a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
79b0: 74 2a 20 22 67 65 74 2d 64 61 74 61 20 63 61 6c t* "get-data cal
79c0: 6c 65 64 20 77 69 74 68 20 6e 6f 20 6d 61 74 63 led with no matc
79d0: 68 69 6e 67 20 74 65 73 74 73 20 74 6f 20 6f 70 hing tests to op
79e0: 65 72 61 74 65 20 6f 6e 2e 22 29 0a 20 20 20 20 erate on.").
79f0: 20 20 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
7a00: 28 62 75 70 2d 65 78 65 20 20 20 20 20 20 28 6f (bup-exe (o
7a10: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
7a20: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 61 p *configdat* "a
7a30: 72 63 68 69 76 65 22 20 22 62 75 70 22 29 20 22 rchive" "bup") "
7a40: 62 75 70 22 29 29 0a 09 20 20 20 20 20 28 6c 69 bup")).. (li
7a50: 6e 6b 74 72 65 65 20 20 20 20 20 28 63 6f 6d 6d nktree (comm
7a60: 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 on:get-linktree)
7a70: 29 20 3b 3b 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ) ;; (configf:lo
7a80: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
7a90: 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 "setup" "linktr
7aa0: 65 65 22 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 ee"))).. ;;
7ab0: 28 74 65 73 74 2d 64 61 74 20 20 20 20 20 28 63 (test-dat (c
7ac0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 79 6f 75 6e 67 65 ommon:get-younge
7ad0: 73 74 2d 74 65 73 74 20 74 65 73 74 73 29 29 0a st-test tests)).
7ae0: 09 20 20 20 20 20 28 64 65 73 74 70 61 74 68 20 . (destpath
7af0: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
7b00: 67 20 22 2d 64 65 73 74 22 29 29 29 0a 09 28 63 g "-dest")))..(c
7b10: 6f 6e 64 0a 09 20 28 28 6e 75 6c 6c 3f 20 74 65 ond.. ((null? te
7b20: 73 74 73 29 0a 09 20 20 28 64 65 62 75 67 3a 70 sts).. (debug:p
7b30: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
7b40: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a fault-log-port*.
7b50: 09 09 09 20 20 20 20 20 22 4e 6f 20 74 65 73 74 ... "No test
7b60: 20 6d 61 74 63 68 69 6e 67 20 70 72 6f 76 69 64 matching provid
7b70: 65 64 20 74 61 72 67 65 74 2c 20 72 75 6e 6e 61 ed target, runna
7b80: 6d 65 20 70 61 74 74 65 72 6e 20 61 6e 64 20 74 me pattern and t
7b90: 65 73 74 20 70 61 74 74 65 72 6e 20 66 6f 75 6e est pattern foun
7ba0: 64 2e 22 29 29 0a 09 20 28 28 66 69 6c 65 2d 65 d.")).. ((file-e
7bb0: 78 69 73 74 73 3f 20 64 65 73 74 70 61 74 68 29 xists? destpath)
7bc0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
7bd0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
7be0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 t-log-port*....
7bf0: 20 20 20 20 22 44 65 73 74 69 6e 61 74 69 6f 6e "Destination
7c00: 20 70 61 74 68 20 61 6c 72 65 61 64 20 65 78 69 path alread exi
7c10: 73 74 73 21 20 50 6c 65 61 73 65 20 72 65 6d 6f sts! Please remo
7c20: 76 65 20 69 74 20 62 65 66 6f 72 65 20 72 75 6e ve it before run
7c30: 6e 69 6e 67 20 67 65 74 2e 22 29 29 0a 09 20 28 ning get.")).. (
7c40: 65 6c 73 65 0a 09 20 20 28 6c 65 74 20 6c 6f 6f else.. (let loo
7c50: 70 20 28 28 72 65 6d 2d 74 65 73 74 73 20 74 65 p ((rem-tests te
7c60: 73 74 73 29 29 0a 09 20 20 20 20 28 6c 65 74 2a sts)).. (let*
7c70: 20 28 28 74 65 73 74 2d 64 61 74 20 20 20 20 20 ((test-dat
7c80: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
7c90: 2d 79 6f 75 6e 67 65 73 74 2d 74 65 73 74 20 72 -youngest-test r
7ca0: 65 6d 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 em-tests))...
7cb0: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 20 (item-path
7cc0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
7cd0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 item-path test-d
7ce0: 61 74 29 29 0a 09 09 20 20 20 28 74 65 73 74 2d at))... (test-
7cf0: 6e 61 6d 65 20 20 20 20 20 20 20 20 20 28 64 62 name (db
7d00: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
7d10: 6d 65 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 me test-dat))..
7d20: 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 . (test-id
7d30: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
7d40: 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 74 65 get-id te
7d50: 73 74 2d 64 61 74 29 29 0a 09 09 20 20 20 28 72 st-dat))... (r
7d60: 75 6e 2d 69 64 20 20 20 20 20 20 20 20 20 20 20 un-id
7d70: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
7d80: 6e 5f 69 64 20 20 20 20 74 65 73 74 2d 64 61 74 n_id test-dat
7d90: 29 29 0a 09 09 20 20 20 28 72 75 6e 2d 6e 61 6d ))... (run-nam
7da0: 65 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a e (rmt:
7db0: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
7dc0: 6d 2d 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 09 m-id run-id))...
7dd0: 20 20 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 (keyvals
7de0: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b (rmt:get-k
7df0: 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e ey-val-pairs run
7e00: 2d 69 64 29 29 0a 09 09 20 20 20 28 74 61 72 67 -id))... (targ
7e10: 65 74 20 20 20 20 20 20 20 20 20 20 20 20 28 73 et (s
7e20: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7e30: 65 20 28 6d 61 70 20 63 61 64 72 20 6b 65 79 76 e (map cadr keyv
7e40: 61 6c 73 29 20 22 2f 22 29 29 0a 09 09 20 20 20 als) "/"))...
7e50: 0a 09 09 20 20 20 28 74 6f 70 6c 65 76 65 6c 2f ... (toplevel/
7e60: 63 68 69 6c 64 72 65 6e 20 28 61 6e 64 20 28 64 children (and (d
7e70: 62 3a 74 65 73 74 2d 67 65 74 2d 69 73 2d 74 6f b:test-get-is-to
7e80: 70 6c 65 76 65 6c 20 74 65 73 74 2d 64 61 74 29 plevel test-dat)
7e90: 0a 09 09 09 09 09 20 20 20 28 3e 20 28 72 6d 74 ...... (> (rmt
7ea0: 3a 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e :test-toplevel-n
7eb0: 75 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 um-items run-id
7ec0: 74 65 73 74 2d 6e 61 6d 65 29 20 30 29 29 29 0a test-name) 0))).
7ed0: 09 09 20 20 20 28 74 65 73 74 2d 70 61 72 74 69 .. (test-parti
7ee0: 61 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 61 al-path (conc ta
7ef0: 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d rget "/" run-nam
7f00: 65 20 22 2f 22 0a 09 09 09 09 09 20 20 20 20 28 e "/"...... (
7f10: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
7f20: 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 l-name test-name
7f30: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 09 item-path)))...
7f40: 20 20 20 3b 3b 20 6e 6f 74 65 20 74 68 65 20 74 ;; note the t
7f50: 72 61 69 6c 69 6e 67 20 73 6c 61 73 68 20 74 6f railing slash to
7f60: 20 67 65 74 20 74 68 65 20 64 69 72 20 69 6e 73 get the dir ins
7f70: 70 69 74 65 20 6f 66 20 69 74 20 62 65 69 6e 67 pite of it being
7f80: 20 61 20 6c 69 6e 6b 0a 09 09 20 20 20 28 74 65 a link... (te
7f90: 73 74 2d 70 61 74 68 20 20 20 20 20 20 20 20 20 st-path
7fa0: 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 (conc linktree "
7fb0: 2f 22 20 74 65 73 74 2d 70 61 72 74 69 61 6c 2d /" test-partial-
7fc0: 70 61 74 68 29 29 0a 09 09 20 20 20 28 61 72 63 path))... (arc
7fd0: 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 20 20 hive-block-id
7fe0: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
7ff0: 74 2d 61 72 63 68 69 76 65 64 20 74 65 73 74 2d t-archived test-
8000: 64 61 74 29 29 0a 09 09 20 20 20 28 61 72 63 68 dat))... (arch
8010: 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 20 ive-block-info
8020: 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 (rmt:test-ge
8030: 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d t-archive-block-
8040: 69 6e 66 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f info archive-blo
8050: 63 6b 2d 69 64 29 29 0a 09 09 20 20 20 28 61 72 ck-id))... (ar
8060: 63 68 69 76 65 2d 70 61 74 68 20 20 20 20 20 20 chive-path
8070: 20 20 20 20 20 20 28 69 66 20 28 76 65 63 74 6f (if (vecto
8080: 72 3f 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b r? archive-block
8090: 2d 69 6e 66 6f 29 0a 09 09 09 09 09 09 28 76 65 -info).......(ve
80a0: 63 74 6f 72 2d 72 65 66 20 61 72 63 68 69 76 65 ctor-ref archive
80b0: 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 32 29 0a 09 -block-info 2)..
80c0: 09 09 09 09 09 23 66 29 29 0a 09 09 20 20 20 28 .....#f))... (
80d0: 61 72 63 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c archive-internal
80e0: 2d 70 61 74 68 20 20 20 28 63 6f 6e 63 20 28 63 -path (conc (c
80f0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e ommon:get-area-n
8100: 61 6d 65 29 20 22 2d 22 20 72 75 6e 2d 69 64 0a ame) "-" run-id.
8110: 09 09 09 09 09 09 20 20 22 2f 6c 61 74 65 73 74 ...... "/latest
8120: 2f 22 20 74 65 73 74 2d 70 61 72 74 69 61 6c 2d /" test-partial-
8130: 70 61 74 68 29 29 0a 09 09 20 20 20 28 69 6e 63 path))... (inc
8140: 6c 75 64 65 2d 70 61 74 68 73 20 20 20 20 20 20 lude-paths
8150: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
8160: 72 67 20 22 2d 69 6e 63 6c 75 64 65 22 29 29 0a rg "-include")).
8170: 09 09 20 20 20 28 65 78 63 6c 75 64 65 2d 70 61 .. (exclude-pa
8180: 74 74 65 72 6e 20 20 20 20 20 20 20 20 20 28 61 ttern (a
8190: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 65 78 rgs:get-arg "-ex
81a0: 63 6c 75 64 65 2d 72 78 22 29 29 0a 09 09 20 20 clude-rx"))...
81b0: 20 28 65 78 63 6c 75 64 65 2d 66 69 6c 65 20 20 (exclude-file
81c0: 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a (args:
81d0: 67 65 74 2d 61 72 67 20 22 2d 65 78 63 6c 75 64 get-arg "-exclud
81e0: 65 2d 72 78 2d 66 72 6f 6d 22 29 29 29 0a 09 20 e-rx-from")))..
81f0: 20 20 20 20 20 0a 09 20 20 20 20 20 20 28 69 66 .. (if
8200: 20 28 61 6e 64 20 61 72 63 68 69 76 65 2d 70 61 (and archive-pa
8210: 74 68 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 th ;; no point i
8220: 6e 20 70 72 6f 63 65 65 64 69 6e 67 20 69 66 20 n proceeding if
8230: 74 68 65 72 65 20 69 73 20 6e 6f 20 61 63 74 75 there is no actu
8240: 61 6c 20 61 72 63 68 69 76 65 0a 09 09 20 20 20 al archive...
8250: 20 20 20 20 28 6e 6f 74 20 74 6f 70 6c 65 76 65 (not topleve
8260: 6c 2f 63 68 69 6c 64 72 65 6e 29 29 0a 09 09 20 l/children))...
8270: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 6c (begin... (l
8280: 65 74 2a 20 28 28 62 75 70 2d 72 65 73 74 6f 72 et* ((bup-restor
8290: 65 2d 70 61 72 61 6d 73 20 28 61 70 70 65 6e 64 e-params (append
82a0: 20 28 6c 69 73 74 20 22 2d 64 22 20 61 72 63 68 (list "-d" arch
82b0: 69 76 65 2d 70 61 74 68 20 22 72 65 73 74 6f 72 ive-path "restor
82c0: 65 22 20 22 2d 43 22 20 28 6f 72 20 64 65 73 74 e" "-C" (or dest
82d0: 70 61 74 68 20 22 64 61 74 61 22 29 29 0a 09 09 path "data"))...
82e0: 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 22 20 .... ;; "
82f0: 22 20 3b 3b 20 57 68 61 74 20 69 73 20 74 68 65 " ;; What is the
8300: 20 65 6d 70 74 79 20 73 74 72 69 6e 67 20 66 6f empty string fo
8310: 72 3f 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 r?.......
8320: 28 69 66 20 69 6e 63 6c 75 64 65 2d 70 61 74 68 (if include-path
8330: 73 0a 09 09 09 09 09 09 09 20 20 20 28 6d 61 70 s........ (map
8340: 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 09 (lambda (p)....
8350: 09 09 09 09 09 20 20 28 63 6f 6e 63 20 61 72 63 ..... (conc arc
8360: 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c 2d 70 61 hive-internal-pa
8370: 74 68 20 22 2f 22 20 70 29 29 0a 09 09 09 09 09 th "/" p))......
8380: 09 09 09 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ...(string-split
8390: 20 69 6e 63 6c 75 64 65 2d 70 61 74 68 73 20 22 include-paths "
83a0: 2c 22 29 29 0a 09 09 09 09 09 09 09 20 20 20 28 ,"))........ (
83b0: 6c 69 73 74 20 61 72 63 68 69 76 65 2d 69 6e 74 list archive-int
83c0: 65 72 6e 61 6c 2d 70 61 74 68 29 29 29 29 29 0a ernal-path))))).
83d0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
83e0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
83f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8400: 52 65 73 74 6f 72 69 6e 67 20 61 72 63 68 69 76 Restoring archiv
8410: 65 64 20 64 61 74 61 20 74 6f 20 22 20 28 6f 72 ed data to " (or
8420: 20 64 65 73 74 70 61 74 68 20 22 64 61 74 61 22 destpath "data"
8430: 29 0a 09 09 09 09 09 22 20 66 72 6f 6d 20 61 72 )......" from ar
8440: 63 68 69 76 65 20 69 6e 20 22 20 61 72 63 68 69 chive in " archi
8450: 76 65 2d 70 61 74 68 20 22 20 2e 2e 2e 20 22 20 ve-path " ... "
8460: 61 72 63 68 69 76 65 2d 69 6e 74 65 72 6e 61 6c archive-internal
8470: 2d 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 28 -path)... (
8480: 72 75 6e 2d 6e 2d 77 61 69 74 20 62 75 70 2d 65 run-n-wait bup-e
8490: 78 65 20 70 61 72 61 6d 73 3a 20 62 75 70 2d 72 xe params: bup-r
84a0: 65 73 74 6f 72 65 2d 70 61 72 61 6d 73 20 70 72 estore-params pr
84b0: 69 6e 74 2d 63 6d 64 3a 20 23 74 29 29 29 0a 09 int-cmd: #t)))..
84c0: 09 20 20 28 6c 65 74 20 28 28 6e 65 77 2d 72 65 . (let ((new-re
84d0: 6d 2d 74 65 73 74 73 20 28 66 69 6c 74 65 72 20 m-tests (filter
84e0: 28 6c 61 6d 62 64 61 20 28 74 64 61 74 29 0a 09 (lambda (tdat)..
84f0: 09 09 09 09 09 20 28 6f 72 20 28 6e 6f 74 20 28 ..... (or (not (
8500: 65 71 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 eq? (db:test-get
8510: 2d 69 64 20 74 64 61 74 29 20 74 65 73 74 2d 69 -id tdat) test-i
8520: 64 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 d))....... (
8530: 6e 6f 74 20 28 65 71 3f 20 28 64 62 3a 74 65 73 not (eq? (db:tes
8540: 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 74 64 61 t-get-run_id tda
8550: 74 29 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 09 t) run-id))))...
8560: 09 09 09 20 20 20 20 20 20 20 72 65 6d 2d 74 65 ... rem-te
8570: 73 74 73 29 20 29 29 0a 09 09 20 20 20 20 28 64 sts) ))... (d
8580: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8590: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
85a0: 6f 72 74 2a 0a 09 09 09 09 20 20 20 20 20 20 22 ort*..... "
85b0: 4e 6f 20 61 72 63 68 69 76 65 20 70 61 74 68 20 No archive path
85c0: 69 6e 20 74 68 65 20 72 65 63 6f 72 64 20 66 6f in the record fo
85d0: 72 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 r run-id=" run-i
85e0: 64 0a 09 09 09 09 20 20 20 20 20 20 22 20 74 65 d..... " te
85f0: 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 20 st-id=" test-id
8600: 22 2c 20 73 6b 69 70 70 69 6e 67 2e 22 29 0a 09 ", skipping.")..
8610: 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
8620: 6e 65 77 2d 72 65 6d 2d 74 65 73 74 73 29 0a 09 new-rem-tests)..
8630: 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 ..(begin.... (d
8640: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8650: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
8660: 6f 72 74 2a 20 22 4e 6f 20 61 72 63 68 69 76 65 ort* "No archive
8670: 73 20 66 6f 75 6e 64 20 66 6f 72 20 22 20 74 61 s found for " ta
8680: 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d rget "/" run-nam
8690: 65 20 22 2e 2e 2e 22 29 0a 09 09 09 20 20 23 66 e "...").... #f
86a0: 29 0a 09 09 09 28 6c 6f 6f 70 20 6e 65 77 2d 72 )....(loop new-r
86b0: 65 6d 2d 74 65 73 74 73 29 29 29 29 29 29 29 29 em-tests))))))))
86c0: 29 29 29 0a 20 20 0a 0a 0a 29 0a ))). ...).