Adds scm-export-repo', which can be used instead of
scm-checkout' to
get a clean directory.
This commit is contained in:
parent
9f0d446ffd
commit
27f76f2da0
|
@ -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"
|
||||
|
|
|
@ -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?)])
|
||||
|
|
Loading…
Reference in New Issue
Block a user