From 27f76f2da05c93f66be8ff879f2021f4626d537d Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Thu, 13 May 2010 00:52:47 -0400
Subject: [PATCH] Adds `scm-export-repo', which can be used instead of
 `scm-checkout' to get a clean directory.

---
 collects/meta/drdr/metadata.ss |  2 +-
 collects/meta/drdr/scm.ss      | 29 ++++++++++++++++++++++++++---
 2 files changed, 27 insertions(+), 4 deletions(-)

diff --git a/collects/meta/drdr/metadata.ss b/collects/meta/drdr/metadata.ss
index 8d952e9cb9..6de61f36ef 100644
--- a/collects/meta/drdr/metadata.ss
+++ b/collects/meta/drdr/metadata.ss
@@ -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" 
diff --git a/collects/meta/drdr/scm.ss b/collects/meta/drdr/scm.ss
index 95bb4abc91..8449f94407 100644
--- a/collects/meta/drdr/scm.ss
+++ b/collects/meta/drdr/scm.ss
@@ -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?)])
\ No newline at end of file
+ [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?)])