[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: git-download: Add 'git-predicate'.
From: |
Christopher Allan Webber |
Subject: |
01/01: git-download: Add 'git-predicate'. |
Date: |
Thu, 9 Feb 2017 14:57:18 -0500 (EST) |
cwebber pushed a commit to branch master
in repository guix.
commit 6554be68b43d5b240c8075cdbb479c66a9780f59
Author: Mathieu Lirzin <address@hidden>
Date: Sun Jan 29 00:34:48 2017 +0100
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.
---
gnu/packages/package-management.scm | 37 +------------------------------
guix/git-download.scm | 43 ++++++++++++++++++++++++++++++++++++-
2 files changed, 43 insertions(+), 37 deletions(-)
diff --git a/gnu/packages/package-management.scm
b/gnu/packages/package-management.scm
index 26802e0..8291740 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 62e625c..5d86ab2 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 <address@hidden>
+;;; Copyright © 2017 Mathieu Lirzin <address@hidden>
;;;
;;; 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