aboutsummaryrefslogtreecommitdiff
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
parenta4824c60ef5ffc0cae3771a16524287904a1c8bd (diff)
downloadguix-6554be68b43d5b240c8075cdbb479c66a9780f59.tar
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.
-rw-r--r--gnu/packages/package-management.scm37
-rw-r--r--guix/git-download.scm43
2 files changed, 43 insertions, 37 deletions
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 26802e0c62..8291740998 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -25,7 +25,6 @@
#:use-module (guix utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system python)
- #:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+ asl2.0))
#:use-module (gnu packages)
#:use-module (gnu packages guile)
@@ -53,10 +52,6 @@
#:use-module (gnu packages tls)
#:use-module (gnu packages ssh)
#:use-module (gnu packages vim)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (ice-9 popen)
- #:use-module (ice-9 rdelim)
#:use-module (ice-9 match))
(define (boot-guile-uri arch)
@@ -275,38 +270,8 @@ generated file."
(_
#t)))
-(define (make-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."
- (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 (cut parent-directory? <> file) files))
- ((or 'regular 'symlink)
- (any (cut string-suffix? <> file) files))
- (_
- #f))))))
-
(define-public current-guix
- (let ((select? (delay (or (make-git-predicate
+ (let ((select? (delay (or (git-predicate
(string-append (current-source-directory)
"/../.."))
source-file?))))
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