;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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 upstream)
+ #:use-module (guix memoization)
+ #: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
%package-module-path
fold-packages
+ scheme-modules ;XXX: for lack of a better place
find-packages-by-name
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+output))
(&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."
(map string->symbol
(string-tokenize (string-drop-right file 4) not-slash)))))
-(define* (package-modules directory #:optional sub-directory)
- "Return the list of modules that provide packages for the distribution.
+(define* (scheme-modules directory #:optional sub-directory)
+ "Return the list of Scheme modules available under DIRECTORY.
Optionally, narrow the search to SUB-DIRECTORY."
(define prefix-len
(string-length directory))
(fold-right (lambda (spec result)
(match spec
((? string? directory)
- (append (package-modules directory) result))
+ (append (scheme-modules directory) result))
((directory . sub-directory)
- (append (package-modules directory sub-directory)
+ (append (scheme-modules directory sub-directory)
result))))
'()
path))
(fold2 (lambda (module result seen)
(fold2 (lambda (var result seen)
(if (and (package? var)
- (not (vhash-assq var seen)))
+ (not (vhash-assq var seen))
+ (not (hidden-package? var)))
(values (proc var result)
(vhash-consq var #t seen))
(values result seen)))
matching)))))
(define find-newest-available-packages
- (memoize
- (lambda ()
- "Return a vhash keyed by package names, and with
+ (mlambda ()
+ "Return a vhash keyed by package names, and with
associated values of the form
(newest-version newest-package ...)
where the preferred package is listed first."
- ;; FIXME: Currently, the preferred package is whichever one
- ;; was found last by 'fold-packages'. Find a better solution.
- (fold-packages (lambda (p r)
- (let ((name (package-name p))
- (version (package-version p)))
- (match (vhash-assoc name r)
- ((_ newest-so-far . pkgs)
- (case (version-compare version newest-so-far)
- ((>) (vhash-cons name `(,version ,p) r))
- ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
- ((<) r)))
- (#f (vhash-cons name `(,version ,p) r)))))
- vlist-null))))
+ ;; FIXME: Currently, the preferred package is whichever one
+ ;; was found last by 'fold-packages'. Find a better solution.
+ (fold-packages (lambda (p r)
+ (let ((name (package-name p))
+ (version (package-version p)))
+ (match (vhash-assoc name r)
+ ((_ newest-so-far . pkgs)
+ (case (version-compare version newest-so-far)
+ ((>) (vhash-cons name `(,version ,p) r))
+ ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
+ ((<) r)))
+ (#f (vhash-cons name `(,version ,p) r)))))
+ vlist-null)))
(define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest
(#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)))
- ;; XXX: This could work with non-GNU packages as well. However,
- ;; GNU's FTP-based updater would be too slow if it weren't memoized,
- ;; and the generic interface in (guix upstream) doesn't support
- ;; that.
- (match (waiting (latest-release name
- #:ftp-open ftp-open*
- #:ftp-close (const #f))
- (_ "looking for the latest release of GNU ~a...") name)
- ((? upstream-source? source)
- (let ((latest-version
- (string-append (upstream-source-package source) "-"
- (upstream-source-version source))))
- (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~%")))
+
+ (match (package-superseded pkg)
+ ((? package? new)
+ (info (_ "package '~a' has been superseded by '~a'~%")
+ (package-name pkg) (package-name new))
+ new)
+ (#f
+ pkg)))
+ (x
+ (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@2.0.9
guile:debug
- guile-2.0.9: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."
- (define (ensure-output p sub-drv)
- (if (member sub-drv (package-outputs p))
- sub-drv
- (leave (_ "package `~a' lacks output `~a'~%")
- (package-full-name p)
- sub-drv)))
-
(let-values (((name version sub-drv)
(package-specification->name+version+output spec output)))
- (match (find-best-packages-by-name name version)
- ((p)
- (values p (ensure-output p sub-drv)))
- ((p p* ...)
- (warning (_ "ambiguous package specification `~a'~%")
- spec)
- (warning (_ "choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
- (values p (ensure-output p sub-drv)))
- (()
- (leave (_ "~a: package not found~%") spec)))))
+ (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))))))
HCoop / jackhill / guix / guix.git / blobdiff