summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMathieu Lirzin <mthl@gnu.org>2017-01-29 00:34:48 +0100
committerChristopher Allan Webber <cwebber@dustycloud.org>2017-02-09 13:56:54 -0600
commit6554be68b43d5b240c8075cdbb479c66a9780f59 (patch)
tree6e3fc03d1bed2b6261101b7269255aa272575c45 /guix
parenta4824c60ef5ffc0cae3771a16524287904a1c8bd (diff)
downloadgnu-guix-6554be68b43d5b240c8075cdbb479c66a9780f59.tar
gnu-guix-6554be68b43d5b240c8075cdbb479c66a9780f59.tar.gz
git-download: Add 'git-predicate'.
* guix/git-download.scm (git-predicate): New procedure. * gnu/packages/package-management.scm (current-guix): Use it. (make-git-predicate): Remove.
Diffstat (limited to 'guix')
-rw-r--r--guix/git-download.scm43
1 files changed, 42 insertions, 1 deletions
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 62e625c715..5d86ab2b62 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +18,7 @@
;;; 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)
@@ -24,6 +26,9 @@
#:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-packages)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
#:export (git-reference
git-reference?
git-reference-url
@@ -32,7 +37,8 @@
git-fetch
git-version
- git-file-name))
+ git-file-name
+ git-predicate))
;;; Commentary:
;;;
@@ -119,4 +125,39 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
"Return the file-name for packages using git-download."
(string-append name "-" version "-checkout"))
+(define (git-predicate directory)
+ "Return a predicate that returns true if a file is part of the Git checkout
+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'."
+ (define (parent-directory? thing directory)
+ ;; Return #t if DIRECTORY is the parent of THING.
+ (or (string-suffix? thing directory)
+ (and (string-index thing #\/)
+ (parent-directory? (dirname thing) directory))))
+
+ (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))))))
+ (status (close-pipe pipe)))
+ (and (zero? status)
+ (lambda (file stat)
+ (match (stat:type stat)
+ ('directory
+ ;; 'git ls-files' does not list directories, only regular files,
+ ;; so we need this special trick.
+ (any (lambda (f) (parent-directory? f file))
+ files))
+ ((or 'regular 'symlink)
+ (any (lambda (f) (string-suffix? f file))
+ files))
+ (_
+ #f))))))
+
;;; git-download.scm ends here