diff --git a/collects/meta/drdr/plt-build.ss b/collects/meta/drdr/plt-build.ss index ab206f4d65..d8d93cef3b 100644 --- a/collects/meta/drdr/plt-build.ss +++ b/collects/meta/drdr/plt-build.ss @@ -197,9 +197,7 @@ (lambda () (define l (pth-cmd)) (with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))] - ["HOME" (home-dir (current-worker))]) - ; XXX Maybe this should destroy the old home and copy in a new one - ; Otherwise it is a source of randomness + ["HOME" (make-fresh-home-dir)]) (with-temporary-directory (run/collect/wait/log log-pth #:timeout pth-timeout @@ -234,14 +232,6 @@ (build-path log-dir "src" "build" "set-browser.ss") mzscheme-path (list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss")))) - ; Make home directories - (cache/file/timestamp - (build-path rev-dir "homedir-dup") - (lambda () - (notify! "Copying home directory for each worker") - (for ([i (in-range (number-of-cpus))]) - (with-handlers ([exn:fail? void]) - (copy-directory/files (hash-ref (current-env) "HOME") (home-dir i)))))) ; And go (notify! "Starting testing") (test-directory collects-pth top-sema) @@ -250,10 +240,11 @@ (notify! "Stopping testing") (stop-job-queue! test-workers)) -(define (home-dir i) - (format "~a~a" - (hash-ref (current-env) "HOME") - i)) +(define (make-fresh-home-dir) + (define new-dir (make-temporary-file "home~a" 'directory)) + (with-handlers ([exn:fail? void]) + (copy-directory/files (hash-ref (current-env) "HOME") new-dir)) + (path->string new-dir)) (define (recur-many i r f) (if (zero? i) diff --git a/collects/meta/drdr/rewriting.ss b/collects/meta/drdr/rewriting.ss index 01f482d1f0..f0ba0e6a18 100644 --- a/collects/meta/drdr/rewriting.ss +++ b/collects/meta/drdr/rewriting.ss @@ -1,30 +1,31 @@ #lang scheme -(require "dirstruct.ss" - "status.ss") +(require "status.ss") -(define (rewrite-status s) - (if (current-rev) - (local [(define from (number->string (current-rev)))] - (match s - [(struct exit (start end command-line output-log code)) - (make-exit start end (rewrite-strings from command-line) (rewrite-events from output-log) code)] - [(struct timeout (start end command-line output-log)) - (make-timeout start end (rewrite-strings from command-line) (rewrite-events from output-log))])) - s)) +(define (rewrite-status #:rewrite rewrite-string s) + (match s + [(struct exit (start end command-line output-log code)) + (make-exit start end + (rewrite-strings #:rewrite rewrite-string command-line) + (rewrite-events #:rewrite rewrite-string output-log) + code)] + [(struct timeout (start end command-line output-log)) + (make-timeout start end + (rewrite-strings #:rewrite rewrite-string command-line) + (rewrite-events #:rewrite rewrite-string output-log))])) -(define (rewrite-strings from los) - (map (curry rewrite-string from) los)) -(define (rewrite-events from loe) - (map (rewrite-event from) loe)) -(define (rewrite-event from) +(define (rewrite-strings #:rewrite rewrite-string los) + (map rewrite-string los)) +(define (rewrite-events #:rewrite rewrite-string loe) + (map (rewrite-event #:rewrite rewrite-string) loe)) +(define (rewrite-event #:rewrite rewrite-bytes) (match-lambda - [(struct stdout (b)) (make-stdout (rewrite-bytes from b))] - [(struct stderr (b)) (make-stderr (rewrite-bytes from b))])) + [(struct stdout (b)) (make-stdout (rewrite-bytes b))] + [(struct stderr (b)) (make-stderr (rewrite-bytes b))])) -(define (rewrite-string from s) - (regexp-replace* from s "")) -(define rewrite-bytes rewrite-string) +(define rewrite-string/c + ((or/c string? bytes?) . -> . (or/c string? bytes?))) (provide/contract - [rewrite-status (status? . -> . status?)]) \ No newline at end of file + [rewrite-string/c contract?] + [rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)]) \ No newline at end of file diff --git a/collects/meta/drdr/run-collect.ss b/collects/meta/drdr/run-collect.ss index 93792bac56..c4aaa3d221 100644 --- a/collects/meta/drdr/run-collect.ss +++ b/collects/meta/drdr/run-collect.ss @@ -2,6 +2,7 @@ (require "status.ss" "notify.ss" "rewriting.ss" + "dirstruct.ss" "cache.ss") (define (command+args+env->command+args @@ -97,6 +98,17 @@ final-status)) +(define-syntax regexp-replace** + (syntax-rules () + [(_ () s) s] + [(_ ([pat0 subst0] + [pat subst] + ...) + s) + (regexp-replace* pat0 + (regexp-replace** ([pat subst] ...) s) + subst0)])) + (define (run/collect/wait/log log-path command #:timeout timeout #:env env @@ -105,8 +117,20 @@ (cache/file log-path (lambda () + (define rev (number->string (current-rev))) + (define home (hash-ref env "HOME")) + (define tmp (hash-ref env "TMPDIR")) + (define cwd (path->string (current-directory))) + (define (rewrite s) + (regexp-replace** ([rev ""] + [home ""] + [tmp ""] + [cwd ""]) + s)) + (set! ran? #t) (rewrite-status + #:rewrite rewrite (run/collect/wait #:timeout timeout #:env env