Adds scm-export-repo', which can be used instead of scm-checkout' to

get a clean directory.
This commit is contained in:
Eli Barzilay 2010-05-13 00:52:47 -04:00
parent 9f0d446ffd
commit 27f76f2da0
2 changed files with 27 additions and 4 deletions

View File

@ -61,7 +61,7 @@
(define tmp-file (make-temporary-file "props~a.ss" #f (current-temporary-directory)))
(and
; Checkout the props file
(scm-export
(scm-export-file
rev
(plt-repository)
"collects/meta/props"

View File

@ -42,6 +42,17 @@
[_
#f]))
(define (pipe/proc cmds)
(if (null? (cdr cmds))
((car cmds))
(let-values ([(i o) (make-pipe 4096)])
(parameterize ([current-output-port o])
(thread (lambda () ((car cmds)) (close-output-port o))))
(parameterize ([current-input-port i])
(pipe/proc (cdr cmds))))))
(define-syntax-rule (pipe expr exprs ...)
(pipe/proc (list (lambda () expr) (lambda () exprs) ...)))
(define (system/output-port #:k k #:stdout [init-stdout #f] . as)
(define _ (printf "~S~n" as))
(define-values (sp stdout stdin stderr)
@ -150,7 +161,7 @@
(provide/contract
[scm-commit-author ((or/c git-push? svn-rev-log?) . -> . string?)])
(define (scm-export rev repo file dest)
(define (scm-export-file rev repo file dest)
(define commit
(push-data-end-commit (push-info rev)))
(call-with-output-file*
@ -164,6 +175,17 @@
(git-path) "--no-pager" "show" (format "~a:~a" commit file)))))
(void))
(define (scm-export-repo rev repo dest)
(pipe
(system*
(git-path) "archive"
(format "--remote=~a" repo)
(format "--prefix=~a/" (regexp-replace #rx"/+$" (path->string* dest) ""))
"--format=tar"
(push-data-end-commit (push-info rev)))
(system* (find-executable-path "tar") "xf" "-" "--absolute-names"))
(void))
(define (scm-checkout rev repo dest)
(system* (git-path) "clone" (path->string* repo) (path->string* dest))
(parameterize ([current-directory dest])
@ -188,5 +210,6 @@
(provide/contract
[scm-update (path? . -> . void?)]
[scm-revisions-after (exact-nonnegative-integer? . -> . (listof exact-nonnegative-integer?))]
[scm-export (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])
[scm-export-file (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-export-repo (exact-nonnegative-integer? path-string? path-string? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])