diff options
| -rw-r--r-- | guix/git-download.scm | 119 |
1 files changed, 42 insertions, 77 deletions
diff --git a/guix/git-download.scm b/guix/git-download.scm index 33f102bc6c..e6e0ec2ac5 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; @@ -19,7 +19,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix git-download) - #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) @@ -27,9 +26,8 @@ #:use-module (guix packages) #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) + #:use-module (git) #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:export (git-reference @@ -153,41 +151,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;;; 'git-predicate'. ;;; -(define (files->directory-tree files) - "Return a tree of vhashes representing the directory listed in FILES, a list -like '(\"a/b\" \"b/c/d\")." - (fold (lambda (file result) - (let loop ((file (string-split file #\/)) - (result result)) - (match file - ((_) - result) - ((directory children ...) - (match (vhash-assoc directory result) - (#f - (vhash-cons directory (loop children vlist-null) - result)) - ((_ . previous) - ;; XXX: 'vhash-delete' is O(n). - (vhash-cons directory (loop children previous) - (vhash-delete directory result))))) - (() - result)))) - vlist-null - files)) - -(define (directory-in-tree? tree directory) - "Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed -in TREE." - (let loop ((directory (string-split directory #\/)) - (tree tree)) - (match directory - (() - #t) - ((head . tail) - (match (vhash-assoc head tree) - ((_ . sub-tree) (loop tail sub-tree)) - (#f #f)))))) +(define (git-file-list directory) + "Return the list of files checked in in the Git repository at DIRECTORY. +The result is similar to that of the 'git ls-files' command, except that it +also includes directories, not just regular files. The returned file names +are relative to DIRECTORY, which is not necessarily the root of the checkout." + (let* ((directory (canonicalize-path directory)) + (dot-git (repository-discover directory)) + (top (dirname dot-git)) + (repository (repository-open dot-git)) + (head (repository-head repository)) + (oid (reference-target head)) + (commit (commit-lookup repository oid)) + (tree (commit-tree commit)) + (files (tree-list tree))) + (repository-close! repository) + (if (string=? top directory) + files + (let ((relative (string-append + (string-drop directory + (+ 1 (string-length top))) + "/"))) + (filter-map (lambda (file) + (and (string-prefix? relative file) + (string-drop file (string-length relative)))) + files))))) (define (git-predicate directory) "Return a predicate that returns true if a file is part of the Git checkout @@ -195,43 +183,20 @@ living at DIRECTORY. Upon Git failure, return #f instead of a predicate. The returned predicate takes two arguments FILE and STAT where FILE is an absolute file name and STAT is the result of 'lstat'." - (let* ((pipe (with-directory-excursion directory - (open-pipe* OPEN_READ "git" "ls-files"))) - (files (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (reverse lines)) - (line - (loop (cons line lines)))))) - (directory-tree (files->directory-tree files)) - (inodes (fold (lambda (file result) - (let ((stat - (lstat (string-append directory "/" - file)))) - (vhash-consv (stat:ino stat) (stat:dev stat) - result))) - vlist-null - files)) - - ;; Note: For this to work we must *not* call 'canonicalize-path' on - ;; DIRECTORY or we would get discrepancies of the returned lambda is - ;; called with a non-canonical file name. - (prefix-length (+ 1 (string-length directory))) - - (status (close-pipe pipe))) - (and (zero? status) - (lambda (file stat) - (match (stat:type stat) - ('directory - (directory-in-tree? directory-tree - (string-drop file prefix-length))) - ((or 'regular 'symlink) - ;; Comparing file names is always tricky business so we rely on - ;; inode numbers instead - (match (vhash-assv (stat:ino stat) inodes) - ((_ . dev) (= dev (stat:dev stat))) - (#f #f))) - (_ - #f)))))) + (let* ((files (git-file-list directory)) + (inodes (fold (lambda (file result) + (let ((stat + (lstat (string-append directory "/" + file)))) + (vhash-consv (stat:ino stat) (stat:dev stat) + result))) + vlist-null + files))) + (lambda (file stat) + ;; Comparing file names is always tricky business so we rely on inode + ;; numbers instead. + (match (vhash-assv (stat:ino stat) inodes) + ((_ . dev) (= dev (stat:dev stat))) + (#f #f))))) ;;; git-download.scm ends here |