ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

git-download: Add 'git-predicate'.

Browse source 
* guix/git-download.scm (git-predicate): New procedure.
* gnu/packages/package-management.scm (current-guix): Use it.
(make-git-predicate): Remove.
This commit is contained in:
Mathieu Lirzin 2017-01-29 00:34:48 +01:00 committed by Christopher Allan Webber
parent a4824c60ef
commit 6554be68b4
No known key found for this signature in database
GPG key ID: 4BC025925FF8F4D3
2 changed files with 43 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
gnu/packages/package-management.scm
View file

@ -25,7 +25,6 @@ (define-module (gnu packages package-management)
#: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 @@ (define-module (gnu packages package-management)
#: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 @@ (define (wrong-extension? 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?))))

43
guix/git-download.scm
View file

@ -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 @@ (define-module (guix git-download)
#: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 @@ (define-module (guix git-download)
git-fetch
git-version
git-file-name))
git-file-name
git-predicate))
;;; Commentary:
;;;
@ -119,4 +125,39 @@ (define (git-file-name name version)
"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