- Removing planet package installation
- Fixing responsible for DrDr imagined code - Code reorganization - Handling environment variables in hash-table and with env - Removing futures-build - Cleaning up committer email content svn: r18434
This commit is contained in:
Jay McCarthy
parent
b020c8dc21
commit
a6214b7731
|
|
@ -6,7 +6,7 @@
|
|||
"notify.ss"
|
||||
"cache.ss"
|
||||
"dirstruct.ss"
|
||||
"run-collect.ss"
|
||||
"status.ss"
|
||||
"path-utils.ss"
|
||||
"rendering.ss")
|
||||
(provide (all-from-out "rendering.ss"))
|
||||
|
|
@ -90,6 +90,14 @@
|
|||
(define responsible-ht/c
|
||||
(hash/c string? (hash/c symbol? (listof path?))))
|
||||
|
||||
(define (responsible-ht->status-ht diff)
|
||||
(for/hash ([id (in-list responsible-ht-severity)])
|
||||
(define id-l
|
||||
(for*/list ([(_ ht) (in-hash diff)]
|
||||
[f (in-list (hash-ref ht id empty))])
|
||||
f))
|
||||
(values id (remove-duplicates id-l))))
|
||||
|
||||
(provide/contract
|
||||
[rendering->responsible-ht
|
||||
(exact-positive-integer? rendering? . -> . responsible-ht/c)]
|
||||
|
|
@ -160,21 +168,26 @@
|
|||
(list
|
||||
(format "~a:" committer)
|
||||
(format "You are receiving this email because the DrDr test of revision ~a (which you committed) contained a NEW condition that may need inspecting." cur-rev)
|
||||
(for*/list ([(r ht) (in-hash diff)]
|
||||
[(id files) (in-hash ht)]
|
||||
[f (in-list files)])
|
||||
(format "\t~a (~a)" (path->url f) id))
|
||||
(let ([diff-smash (responsible-ht->status-ht diff)])
|
||||
(for/list ([(id paths) (in-hash diff-smash)]
|
||||
#:when (not (symbol=? id 'changes)))
|
||||
(if (empty? paths)
|
||||
empty
|
||||
(list (format "\t~a" id)
|
||||
(for/list ([f (in-list paths)])
|
||||
(format "\t\t~a" (path->url f)))
|
||||
""))))
|
||||
"")
|
||||
empty)
|
||||
(for/list ([r (in-list responsibles)])
|
||||
(list (format "~a:" r)
|
||||
"You are receiving this email because a file you are responsible for has a condition that may need inspecting."
|
||||
(for/list ([(id files) (in-hash (hash-ref responsible-ht r))]
|
||||
#:when (not (symbol=? id 'changes)))
|
||||
(list (format "\t~a:" id)
|
||||
(for/list ([f (in-list files)])
|
||||
(format "\t\t~a" (path->url f)))
|
||||
""))
|
||||
(list* (format "~a:" r)
|
||||
"You are receiving this email because a file you are responsible for has a condition that may need inspecting."
|
||||
(for/list ([(id files) (in-hash (hash-ref responsible-ht r))]
|
||||
#:when (not (symbol=? id 'changes)))
|
||||
(list (format "\t~a:" id)
|
||||
(for/list ([f (in-list files)])
|
||||
(format "\t\t~a" (path->url f)))
|
||||
""))
|
||||
""))))))
|
||||
|
||||
(send-mail-message "drdr"
|
||||
|
|
@ -248,10 +261,10 @@
|
|||
#f))
|
||||
(define responsible
|
||||
(or (svn-property-value/root (trunk-path log-pth) plt:responsible)
|
||||
(and (regexp-match #rx"^/planet" (path->string* log-pth))
|
||||
(and (regexp-match #rx"/planet/" (path->string* log-pth))
|
||||
"jay")
|
||||
; XXX maybe mflatt, eli, or tewk
|
||||
(and (regexp-match #rx"^/src" (path->string* log-pth))
|
||||
(and (regexp-match #rx"/src/" (path->string* log-pth))
|
||||
"jay")
|
||||
"unknown"))
|
||||
(define lc
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require "run-collect.ss"
|
||||
"cache.ss"
|
||||
(require "cache.ss"
|
||||
"dirstruct.ss"
|
||||
"svn.ss"
|
||||
"monitor-svn.ss")
|
||||
|
|
|
|||
|
|
@ -4,6 +4,9 @@
|
|||
(define number-of-cpus
|
||||
(make-parameter 1))
|
||||
|
||||
(define current-subprocess-timeout-seconds
|
||||
(make-parameter (* 60 10)))
|
||||
|
||||
(define plt-directory
|
||||
(make-parameter (build-path (current-directory))))
|
||||
|
||||
|
|
@ -81,6 +84,7 @@
|
|||
(path-timing-log p))
|
||||
|
||||
(provide/contract
|
||||
[current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
||||
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
|
||||
[current-rev (parameter/c (or/c false/c exact-nonnegative-integer?))]
|
||||
[previous-rev (parameter/c (or/c false/c exact-nonnegative-integer?))]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
#lang scheme
|
||||
(require "run-collect.ss"
|
||||
"path-utils.ss"
|
||||
(require "path-utils.ss"
|
||||
"svn.ss")
|
||||
|
||||
(define (testable-file? pth)
|
||||
|
|
@ -26,16 +25,11 @@
|
|||
(regexp-split #rx" " s))]))
|
||||
|
||||
(define (path-timeout a-path)
|
||||
(match
|
||||
(with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(string->number (svn-property-value/root a-path SVN-PROP:timeout)))
|
||||
[#f
|
||||
(current-subprocess-timeout-seconds)]
|
||||
[(? number? n)
|
||||
n]))
|
||||
(with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(string->number (svn-property-value/root a-path SVN-PROP:timeout))))
|
||||
|
||||
(provide/contract
|
||||
[SVN-PROP:command-line string?]
|
||||
[SVN-PROP:timeout string?]
|
||||
[path-command-line (path-string? . -> . (or/c (listof string?) false/c))]
|
||||
[path-timeout (path-string? . -> . exact-nonnegative-integer?)])
|
||||
[path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))])
|
||||
|
|
@ -1,5 +1 @@
|
|||
(("schematics" "schemeunit.plt" 2 10 #f)
|
||||
("cce" "scheme.plt" 4 1 #f)
|
||||
("lizorkin" "sxml.plt" 2 1 #f)
|
||||
("jaymccarthy" "sqlite.plt" 4 5 #f)
|
||||
("cobbe" "views.plt" 1 1 #f))
|
||||
()
|
||||
|
|
|
|||
|
|
@ -6,10 +6,21 @@
|
|||
"run-collect.ss"
|
||||
"cache.ss"
|
||||
"dirstruct.ss"
|
||||
"replay.ss"
|
||||
"notify.ss"
|
||||
"path-utils.ss"
|
||||
"sema.ss"
|
||||
"svn.ss")
|
||||
|
||||
(define current-env (make-parameter (make-immutable-hash empty)))
|
||||
(define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...)
|
||||
(parameterize ([current-env
|
||||
(for/fold ([env (current-env)])
|
||||
([k (in-list (list env-expr ...))]
|
||||
[v (in-list (list val-expr ...))])
|
||||
(hash-set env k v))])
|
||||
expr ...))
|
||||
|
||||
(define (build-revision rev)
|
||||
(define rev-dir (revision-dir rev))
|
||||
(define co-dir (revision-trunk-dir rev))
|
||||
|
|
@ -27,50 +38,45 @@
|
|||
(lambda ()
|
||||
(notify! "Removing checkout directory: ~a" co-dir)
|
||||
(safely-delete-directory co-dir)
|
||||
; XXX Give it its own timeout
|
||||
(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
|
||||
(svn-checkout
|
||||
(plt-repository) rev
|
||||
(path->string co-dir)))))
|
||||
(local [(define repo (plt-repository))
|
||||
(define to-dir
|
||||
(path->string co-dir))]
|
||||
(notify! "Checking out ~a@~a into ~a"
|
||||
repo rev to-dir)
|
||||
(run/collect/wait/log
|
||||
; XXX Give it its own timeout
|
||||
#:timeout (current-make-install-timeout-seconds)
|
||||
#:env (current-env)
|
||||
(build-path log-dir "svn-checkout")
|
||||
(svn-path)
|
||||
(list
|
||||
"checkout"
|
||||
"--quiet"
|
||||
"-r" (number->string rev)
|
||||
repo
|
||||
to-dir)))))
|
||||
;; Make the build directory
|
||||
(make-directory* build-dir)
|
||||
;; Run Configure, Make, Make Install
|
||||
(parameterize ([current-directory build-dir])
|
||||
(run/collect/wait/log
|
||||
#:timeout (current-subprocess-timeout-seconds)
|
||||
#:env (current-env)
|
||||
(build-path log-dir "src" "build" "configure")
|
||||
(path->string (build-path src-dir "configure")))
|
||||
(parameterize ([current-subprocess-timeout-seconds (current-make-timeout-seconds)])
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "build" "make")
|
||||
(make-path) "-j" (number->string (number-of-cpus))))
|
||||
(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "build" "make-install")
|
||||
(make-path) "-j" (number->string (number-of-cpus)) "install"))
|
||||
#;(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "build" "setup-plt-no-docs")
|
||||
setup-plt-path "--no-docs"))
|
||||
#;(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "build" "setup-plt")
|
||||
setup-plt-path)))
|
||||
;; Test Futures
|
||||
(make-directory* futures-build-dir)
|
||||
;; Run Configure, Make, Test
|
||||
(parameterize ([current-directory futures-build-dir])
|
||||
(path->string (build-path src-dir "configure"))
|
||||
empty)
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "futures-build" "configure")
|
||||
(path->string (build-path src-dir "configure")) "--enable-futures")
|
||||
(parameterize ([current-subprocess-timeout-seconds (current-make-timeout-seconds)]
|
||||
[current-directory (build-path futures-build-dir "mzscheme")])
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "futures-build" "mzscheme" "make")
|
||||
(make-path) "-j" (number->string (number-of-cpus)))
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "src" "futures-build" "mzscheme" "futures-startup-test")
|
||||
(path->string (build-path futures-build-dir "mzscheme" "mzscheme3m")) "-e" "(printf \"startedup\n\")")
|
||||
)))
|
||||
#:timeout (current-make-timeout-seconds)
|
||||
#:env (current-env)
|
||||
(build-path log-dir "src" "build" "make")
|
||||
(make-path)
|
||||
(list "-j" (number->string (number-of-cpus))))
|
||||
(run/collect/wait/log
|
||||
#:timeout (current-make-install-timeout-seconds)
|
||||
#:env (current-env)
|
||||
(build-path log-dir "src" "build" "make-install")
|
||||
(make-path)
|
||||
(list "-j" (number->string (number-of-cpus)) "install"))))
|
||||
|
||||
(define (call-with-temporary-directory thunk)
|
||||
(define tempdir (symbol->string (gensym 'tmpdir)))
|
||||
|
|
@ -85,10 +91,44 @@
|
|||
(define-syntax-rule (with-temporary-directory e)
|
||||
(call-with-temporary-directory (lambda () e)))
|
||||
|
||||
(define (semaphore-wait* sema how-many)
|
||||
(unless (zero? how-many)
|
||||
(semaphore-wait sema)
|
||||
(semaphore-wait* sema (sub1 how-many))))
|
||||
(define (with-running-program command args thunk)
|
||||
(define-values (new-command new-args)
|
||||
(command+args+env->command+args
|
||||
#:env (current-env)
|
||||
command args))
|
||||
(define-values
|
||||
(the-process stdout stdin stderr)
|
||||
(apply subprocess
|
||||
#f #;(current-error-port)
|
||||
#f
|
||||
#f #;(current-error-port)
|
||||
new-command new-args))
|
||||
; Die if this program does
|
||||
(define parent
|
||||
(current-thread))
|
||||
(define waiter
|
||||
(thread
|
||||
(lambda ()
|
||||
(subprocess-wait the-process)
|
||||
(printf "Killing parent because wrapper is dead...~n")
|
||||
(kill-thread parent))))
|
||||
|
||||
; Run without stdin
|
||||
(close-output-port stdin)
|
||||
|
||||
(begin0
|
||||
; Run the thunk
|
||||
(thunk)
|
||||
|
||||
; Close the output ports
|
||||
(close-input-port stdout)
|
||||
(close-input-port stderr)
|
||||
|
||||
; Kill the guard
|
||||
(kill-thread waiter)
|
||||
|
||||
; Kill the process
|
||||
(subprocess-kill the-process #t)))
|
||||
|
||||
(define-runtime-path package-list "pkgs")
|
||||
(define (planet-packages)
|
||||
|
|
@ -133,7 +173,9 @@
|
|||
(local [(define log-pth (trunk->log pth))]
|
||||
(if (file-exists? log-pth)
|
||||
(semaphore-post dir-sema)
|
||||
(local [(define pth-timeout (path-timeout pth))
|
||||
(local [(define pth-timeout
|
||||
(or (path-timeout pth)
|
||||
(current-subprocess-timeout-seconds)))
|
||||
(define pth-cmd/general (path-command-line pth))
|
||||
(define pth-cmd
|
||||
(match pth-cmd/general
|
||||
|
|
@ -153,17 +195,17 @@
|
|||
(submit-job!
|
||||
test-workers
|
||||
(lambda ()
|
||||
; XXX Maybe this should destroy the old home and copy in a new one
|
||||
; Otherwise it is a source of randomness
|
||||
(with-temporary-directory
|
||||
(parameterize ([current-subprocess-timeout-seconds pth-timeout])
|
||||
(apply run/collect/wait/log log-pth
|
||||
"/usr/bin/env"
|
||||
(format "DISPLAY=~a"
|
||||
(format ":~a" (+ XSERVER-OFFSET (current-worker))))
|
||||
(format "HOME=~a"
|
||||
(home-dir (current-worker)))
|
||||
(pth-cmd))))
|
||||
(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
|
||||
(with-temporary-directory
|
||||
(run/collect/wait/log log-pth
|
||||
#:timeout pth-timeout
|
||||
#:env (current-env)
|
||||
(first l)
|
||||
(rest l))))
|
||||
(semaphore-post dir-sema)))
|
||||
(semaphore-post dir-sema)))))))
|
||||
files)
|
||||
|
|
@ -174,26 +216,32 @@
|
|||
(write-cache! dir-log (current-seconds))
|
||||
(semaphore-post upper-sema)))))))
|
||||
; Some setup
|
||||
; XXX Give it its own timeout
|
||||
(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
|
||||
(for ([pp (in-list (planet-packages))])
|
||||
(match pp
|
||||
[`(,auth ,pkg ,majn ,minn ,ver)
|
||||
(define maj (number->string majn))
|
||||
(define min (number->string minn))
|
||||
(run/collect/wait/log
|
||||
(build-path log-dir "planet" auth pkg maj min)
|
||||
planet-path "install" auth pkg maj min)])))
|
||||
(for ([pp (in-list (planet-packages))])
|
||||
(match pp
|
||||
[`(,auth ,pkg ,majn ,minn ,ver)
|
||||
(define maj (number->string majn))
|
||||
(define min (number->string minn))
|
||||
(run/collect/wait/log
|
||||
; XXX Give it its own timeout
|
||||
#:timeout (current-make-install-timeout-seconds)
|
||||
#:env (current-env)
|
||||
(build-path log-dir "planet" auth pkg maj min)
|
||||
planet-path
|
||||
(list "install" auth pkg maj min))]))
|
||||
(run/collect/wait/log
|
||||
#:timeout (current-subprocess-timeout-seconds)
|
||||
#:env (current-env)
|
||||
(build-path log-dir "src" "build" "set-browser.ss")
|
||||
mzscheme-path "-t" (path->string* (build-path (drdr-directory) "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))])
|
||||
(copy-directory/files (getenv "HOME") (home-dir i)))))
|
||||
(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)
|
||||
|
|
@ -204,33 +252,9 @@
|
|||
|
||||
(define (home-dir i)
|
||||
(format "~a~a"
|
||||
(getenv "HOME")
|
||||
(hash-ref (current-env) "HOME")
|
||||
i))
|
||||
|
||||
(define-syntax (with-env stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([env-expr val-expr] ...) expr ...)
|
||||
(with-syntax ([(env-val ...) (generate-temporaries #'(env-expr ...))]
|
||||
[(old-env-val ...) (generate-temporaries #'(env-expr ...))]
|
||||
[(new-env-val ...) (generate-temporaries #'(env-expr ...))])
|
||||
(syntax/loc stx
|
||||
(local [(define env-val env-expr)
|
||||
...
|
||||
(define old-env-val (getenv env-val))
|
||||
...
|
||||
(define new-env-val val-expr)
|
||||
...]
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(putenv env-val new-env-val)
|
||||
...)
|
||||
(lambda ()
|
||||
expr ...)
|
||||
(lambda ()
|
||||
(when old-env-val
|
||||
(putenv env-val old-env-val))
|
||||
...)))))]))
|
||||
|
||||
(define (recur-many i r f)
|
||||
(if (zero? i)
|
||||
(f)
|
||||
|
|
@ -281,7 +305,7 @@
|
|||
(safely-delete-directory (format "/tmp/.tX~a-lock" i))
|
||||
(safely-delete-directory (build-path tmp-dir (format ".tX~a-lock" i)))
|
||||
(with-running-program
|
||||
(Xvfb-path) (list (format ":~a" i) "-screen" "0" "800x600x24")
|
||||
(Xvfb-path) (list (format ":~a" i) "-screen" "0" "800x600x24" "-ac" "-br" "-bs" "-kb")
|
||||
(lambda ()
|
||||
(with-running-program
|
||||
(fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init")
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
"cache.ss"
|
||||
(except-in "dirstruct.ss"
|
||||
revision-trunk-dir)
|
||||
"run-collect.ss"
|
||||
"status.ss"
|
||||
"monitor-svn.ss"
|
||||
"metadata.ss"
|
||||
"formats.ss"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme
|
||||
(require "replay.ss"
|
||||
"cache.ss"
|
||||
"run-collect.ss")
|
||||
"status.ss")
|
||||
|
||||
; XXX Rewrite to work with logs in dbm
|
||||
|
||||
|
|
|
|||
|
|
@ -4,8 +4,14 @@
|
|||
"rewriting.ss"
|
||||
"cache.ss")
|
||||
|
||||
(define current-subprocess-timeout-seconds
|
||||
(make-parameter (* 60 10)))
|
||||
(define (command+args+env->command+args
|
||||
#:env env
|
||||
cmd args)
|
||||
(values "/usr/bin/env"
|
||||
(append (for/list ([(k v) (in-hash env)])
|
||||
(format "~a=~a" k v))
|
||||
(list* cmd
|
||||
args))))
|
||||
|
||||
(define (read-until-evt port-evt k)
|
||||
(if port-evt
|
||||
|
|
@ -16,19 +22,26 @@
|
|||
(k bs))))
|
||||
never-evt))
|
||||
|
||||
(define (run/collect/wait command . args)
|
||||
(define (run/collect/wait
|
||||
#:env env
|
||||
#:timeout timeout
|
||||
command args)
|
||||
(define start-time
|
||||
(current-inexact-milliseconds))
|
||||
|
||||
; Run the command
|
||||
(define-values (new-command new-args)
|
||||
(command+args+env->command+args
|
||||
#:env env
|
||||
command args))
|
||||
(define command-line
|
||||
(list* command args))
|
||||
(define-values
|
||||
(the-process stdout stdin stderr)
|
||||
(apply subprocess
|
||||
#f #f #f
|
||||
command
|
||||
args))
|
||||
new-command
|
||||
new-args))
|
||||
|
||||
(notify! "Running: ~a ~S" command args)
|
||||
|
||||
|
|
@ -39,7 +52,7 @@
|
|||
(local
|
||||
[(define the-alarm
|
||||
(alarm-evt (+ (current-inexact-milliseconds)
|
||||
(* 1000 (current-subprocess-timeout-seconds)))))
|
||||
(* 1000 timeout))))
|
||||
(define (slurp-output-evt loop stdout stderr log)
|
||||
(choice-evt
|
||||
(read-until-evt stdout
|
||||
|
|
@ -84,55 +97,28 @@
|
|||
|
||||
final-status))
|
||||
|
||||
(define (run/collect/wait/log log-path . rcw-args)
|
||||
(define (run/collect/wait/log log-path command
|
||||
#:timeout timeout
|
||||
#:env env
|
||||
args)
|
||||
(define ran? #f)
|
||||
(cache/file
|
||||
log-path
|
||||
(lambda ()
|
||||
(set! ran? #t)
|
||||
(rewrite-status
|
||||
(apply run/collect/wait rcw-args))))
|
||||
(run/collect/wait
|
||||
#:timeout timeout
|
||||
#:env env
|
||||
command args))))
|
||||
ran?)
|
||||
|
||||
(define (with-running-program command args thunk)
|
||||
(define-values
|
||||
(the-process stdout stdin stderr)
|
||||
(apply subprocess
|
||||
(current-error-port) #f
|
||||
(current-error-port)
|
||||
command
|
||||
args))
|
||||
; Die if this program does
|
||||
(define parent
|
||||
(current-thread))
|
||||
(define waiter
|
||||
(thread
|
||||
(lambda ()
|
||||
(subprocess-wait the-process)
|
||||
(printf "Killing parent because wrapper is dead...~n")
|
||||
(kill-thread parent))))
|
||||
|
||||
; Run without stdin
|
||||
(close-output-port stdin)
|
||||
|
||||
(begin0
|
||||
; Run the thunk
|
||||
(thunk)
|
||||
|
||||
; Close the output ports
|
||||
#;(close-input-port stdout)
|
||||
#;(close-input-port stderr)
|
||||
|
||||
; Kill the guard
|
||||
(kill-thread waiter)
|
||||
|
||||
; Kill the process
|
||||
(subprocess-kill the-process #t)))
|
||||
|
||||
(provide
|
||||
(all-from-out "status.ss"))
|
||||
(provide/contract
|
||||
[current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
||||
[with-running-program (string? (listof string?) (-> any) . -> . any)]
|
||||
[run/collect/wait ((string?) () #:rest (listof string?) . ->* . status?)]
|
||||
[run/collect/wait/log ((path-string? string?) () #:rest (listof string?) . ->* . boolean?)])
|
||||
[command+args+env->command+args
|
||||
(string? (listof string?) #:env (hash/c string? string?) . -> . (values string? (listof string?)))]
|
||||
[run/collect/wait/log
|
||||
(path-string? string?
|
||||
#:env (hash/c string? string?)
|
||||
#:timeout exact-nonnegative-integer?
|
||||
(listof string?)
|
||||
. -> . boolean?)])
|
||||
9
collects/meta/drdr/sema.ss
Normal file
9
collects/meta/drdr/sema.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
#lang scheme
|
||||
|
||||
(define (semaphore-wait* sema how-many)
|
||||
(unless (zero? how-many)
|
||||
(semaphore-wait sema)
|
||||
(semaphore-wait* sema (sub1 how-many))))
|
||||
|
||||
(provide/contract
|
||||
[semaphore-wait* (semaphore? exact-nonnegative-integer? . -> . void)])
|
||||
|
|
@ -1,7 +1,5 @@
|
|||
#lang scheme
|
||||
(require xml
|
||||
"run-collect.ss"
|
||||
"replay.ss"
|
||||
"notify.ss"
|
||||
(prefix-in ffi: (planet jaymccarthy/svn-prop)))
|
||||
|
||||
|
|
@ -180,25 +178,4 @@
|
|||
[changes (listof svn-change?)])]
|
||||
[struct svn-change
|
||||
([action symbol?]
|
||||
[path path-string?])])
|
||||
|
||||
(define (svn-checkout repo rev to-dir)
|
||||
(notify! "Checking out ~a@~a into ~a"
|
||||
repo rev to-dir)
|
||||
(local
|
||||
[(define svn-status
|
||||
(run/collect/wait
|
||||
(svn-path)
|
||||
"checkout"
|
||||
"--quiet"
|
||||
"-r" (number->string rev)
|
||||
repo
|
||||
to-dir))]
|
||||
(unless (and (exit? svn-status)
|
||||
(zero? (exit-code svn-status)))
|
||||
(printf "Replaying SVN output:~n")
|
||||
(replay-status svn-status)
|
||||
(error 'svn-checkout "Error on checkout!"))))
|
||||
|
||||
(provide/contract
|
||||
[svn-checkout (string? exact-nonnegative-integer? string? . -> . void)])
|
||||
[path path-string?])])
|
||||
|
|
@ -5,6 +5,7 @@
|
|||
"notify.ss"
|
||||
"path-utils.ss"
|
||||
"dirstruct.ss"
|
||||
"sema.ss"
|
||||
"cache.ss")
|
||||
|
||||
(define test-workers (make-job-queue (number-of-cpus)))
|
||||
|
|
@ -83,7 +84,6 @@
|
|||
(find-files (revision-log-dir start-revision)
|
||||
empty))
|
||||
|
||||
(for ([i (in-range how-many-files)])
|
||||
(semaphore-wait count-sema))
|
||||
(semaphore-wait* count-sema how-many-files)
|
||||
|
||||
(stop-job-queue! test-workers)
|
||||
Loading…
Reference in New Issue
Block a user