;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix packages)
#:use-module (guix ui)
#:use-module (guix utils)
- #:use-module ((guix ftp-client) #:select (ftp-open))
- #:use-module (guix gnu-maintenance)
+ #:use-module (guix combinators)
+ #:use-module ((guix build utils)
+ #:select ((package-name->name+version
+ . hyphen-separated-name->name+version)))
#:use-module (ice-9 ftw)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-39)
#:export (search-patch
+ search-patches
search-bootstrap-binary
%patch-path
%bootstrap-binaries-path
find-best-packages-by-name
find-newest-available-packages
- package-direct-dependents
- package-transitive-dependents
- package-covering-dependents
-
- check-package-freshness
-
- specification->package))
+ specification->package
+ specification->package+output))
;;; Commentary:
;;;
(&message (message (format #f (_ "~a: patch not found")
file-name)))))))
+(define-syntax-rule (search-patches file-name ...)
+ "Return the list of absolute file names corresponding to each
+FILE-NAME found in %PATCH-PATH."
+ (list (search-patch file-name) ...))
+
(define (search-bootstrap-binary file-name system)
"Search the bootstrap binary FILE-NAME for SYSTEM. Raise an error if not
found."
(let ((packages (delay
(fold-packages (lambda (p r)
(vhash-cons (package-name p) p r))
- vlist-null))))
+ vlist-null)))
+ (version>? (lambda (p1 p2)
+ (version>? (package-version p1) (package-version p2)))))
(lambda* (name #:optional version)
"Return the list of packages with the given NAME. If VERSION is not #f,
-then only return packages whose version is equal to VERSION."
- (let ((matching (vhash-fold* cons '() name (force packages))))
+then only return packages whose version is prefixed by VERSION, sorted in
+decreasing version order."
+ (let ((matching (sort (vhash-fold* cons '() name (force packages))
+ version>?)))
(if version
(filter (lambda (package)
- (string=? (package-version package) version))
+ (string-prefix? version (package-version package)))
matching)
matching)))))
(#f '()))))
\f
-(define* (vhash-refq vhash key #:optional (dflt #f))
- "Look up KEY in the vhash VHASH, and return the value (if any) associated
-with it. If KEY is not found, return DFLT (or `#f' if no DFLT argument is
-supplied). Uses `eq?' for equality testing."
- (or (and=> (vhash-assq key vhash) cdr)
- dflt))
-
-(define package-dependencies
- (memoize
- (lambda ()
- "Return a vhash keyed by package, and with associated values that are a
-list of packages that depend on that package."
- (fold-packages
- (lambda (package dag)
- (fold
- (lambda (in d)
- ;; Insert a graph edge from each of package's inputs to package.
- (vhash-consq in
- (cons package (vhash-refq d in '()))
- (vhash-delq in d)))
- dag
- (match (package-direct-inputs package)
- (((labels packages . _) ...)
- packages) )))
- vlist-null))))
-
-(define (package-direct-dependents packages)
- "Return a list of packages from the distribution that directly depend on the
-packages in PACKAGES."
- (delete-duplicates
- (concatenate
- (map (lambda (p)
- (vhash-refq (package-dependencies) p '()))
- packages))))
-
-(define (package-transitive-dependents packages)
- "Return the transitive dependent packages of the distribution packages in
-PACKAGES---i.e. the dependents of those packages, plus their dependents,
-recursively."
- (let ((dependency-dag (package-dependencies)))
- (fold-tree
- cons '()
- (lambda (node) (vhash-refq dependency-dag node))
- ;; Start with the dependents to avoid including PACKAGES in the result.
- (package-direct-dependents packages))))
-
-(define (package-covering-dependents packages)
- "Return a minimal list of packages from the distribution whose dependencies
-include all of PACKAGES and all packages that depend on PACKAGES."
- (let ((dependency-dag (package-dependencies)))
- (fold-tree-leaves
- cons '()
- (lambda (node) (vhash-refq dependency-dag node))
- ;; Start with the dependents to avoid including PACKAGES in the result.
- (package-direct-dependents packages))))
-
-\f
(define %sigint-prompt
;; The prompt to jump to upon SIGINT.
(make-prompt-tag "interruptible"))
(lambda (k signum)
(handler signum))))
-(define-syntax-rule (waiting exp fmt rest ...)
- "Display the given message while EXP is being evaluated."
- (let* ((message (format #f fmt rest ...))
- (blank (make-string (string-length message) #\space)))
- (display message (current-error-port))
- (force-output (current-error-port))
- (call-with-sigint-handler
- (lambda ()
- (dynamic-wind
- (const #f)
- (lambda () exp)
- (lambda ()
- ;; Clear the line.
- (display #\cr (current-error-port))
- (display blank (current-error-port))
- (display #\cr (current-error-port))
- (force-output (current-error-port)))))
- (lambda (signum)
- (format (current-error-port) " interrupted by signal ~a~%" SIGINT)
- #f))))
-
-(define ftp-open*
- ;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new
- ;; FTP connection for each package, esp. since most of them are to the same
- ;; server. This has a noticeable impact when doing "guix upgrade -u".
- (memoize ftp-open))
-
-(define (check-package-freshness package)
- "Check whether PACKAGE has a newer version available upstream, and report
-it."
- ;; TODO: Automatically inject the upstream version when desired.
-
- (catch #t
- (lambda ()
- (when (false-if-exception (gnu-package? package))
- (let ((name (package-name package))
- (full-name (package-full-name package)))
- (match (waiting (latest-release name
- #:ftp-open ftp-open*
- #:ftp-close (const #f))
- (_ "looking for the latest release of GNU ~a...") name)
- ((? gnu-release? release)
- (let ((latest-version
- (string-append (gnu-release-package release) "-"
- (gnu-release-version release))))
- (when (version>? latest-version full-name)
- (format (current-error-port)
- (_ "~a: note: using ~a \
-but ~a is available upstream~%")
- (location->string (package-location package))
- full-name latest-version))))
- (_ #t)))))
- (lambda (key . args)
- ;; Silently ignore networking errors rather than preventing
- ;; installation.
- (case key
- ((getaddrinfo-error ftp-error) #f)
- (else (apply throw key args))))))
+\f
+;;;
+;;; Package specification.
+;;;
+
+(define* (%find-package spec name version #:key fallback?)
+ (match (find-best-packages-by-name name version)
+ ((pkg . pkg*)
+ (unless (null? pkg*)
+ (warning (_ "ambiguous package specification `~a'~%") spec)
+ (warning (_ "choosing ~a from ~a~%")
+ (package-full-name pkg)
+ (location->string (package-location pkg))))
+ (when fallback?
+ (warning (_ "deprecated NAME-VERSION syntax; \
+use NAME@VERSION instead~%")))
+ pkg)
+ (_
+ (if version
+ (leave (_ "~A: package not found for version ~a~%") name version)
+ (if (not fallback?)
+ ;; XXX: Fallback to the older specification style with an hyphen
+ ;; between NAME and VERSION, for backward compatibility.
+ (call-with-values
+ (lambda ()
+ (hyphen-separated-name->name+version name))
+ (cut %find-package spec <> <> #:fallback? #t))
+
+ ;; The fallback case didn't find anything either, so bail out.
+ (leave (_ "~A: unknown package~%") name))))))
(define (specification->package spec)
"Return a package matching SPEC. SPEC may be a package name, or a package
-name followed by a hyphen and a version number. If the version number is not
+name followed by an at-sign and a version number. If the version number is not
present, return the preferred newest version."
- (let-values (((name version)
- (package-name->name+version spec)))
- (match (find-best-packages-by-name name version)
- ((p) ; one match
- p)
- ((p x ...) ; several matches
- (warning (_ "ambiguous package specification `~a'~%") spec)
- (warning (_ "choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
- p)
- (_ ; no matches
- (if version
- (leave (_ "~A: package not found for version ~a~%")
- name version)
- (leave (_ "~A: unknown package~%") name))))))
+ (let-values (((name version) (package-name->name+version spec)))
+ (%find-package spec name version)))
+
+(define* (specification->package+output spec #:optional (output "out"))
+ "Return the package and output specified by SPEC, or #f and #f; SPEC may
+optionally contain a version number and an output name, as in these examples:
+
+ guile
+ guile@2.0.9
+ guile:debug
+ guile@2.0.9:debug
+
+If SPEC does not specify a version number, return the preferred newest
+version; if SPEC does not specify an output, return OUTPUT."
+ (let-values (((name version sub-drv)
+ (package-specification->name+version+output spec output)))
+ (match (%find-package spec name version)
+ (#f
+ (values #f #f))
+ (package
+ (if (member sub-drv (package-outputs package))
+ (values package sub-drv)
+ (leave (_ "package `~a' lacks output `~a'~%")
+ (package-full-name package)
+ sub-drv))))))