;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix packages)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module (guix diagnostics)
#:use-module (guix discovery)
#:use-module (guix memoization)
#:use-module ((guix build utils)
#:use-module (ice-9 binary-ports)
#:autoload (system base compile) (compile)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-39)
+ #:use-module (srfi srfi-71)
#:export (search-patch
search-patches
search-auxiliary-file
%auxiliary-files-path
%package-module-path
%default-package-module-path
+ cache-is-authoritative?
fold-packages
fold-available-packages
specification->package+output
specification->location
specifications->manifest
+ specifications->packages
+
+ package-unique-version-prefix
generate-package-cache))
(define (search-patch file-name)
"Search the patch FILE-NAME. Raise an error if not found."
(or (search-path (%patch-path) file-name)
- (raise (condition
- (&message (message (format #f (G_ "~a: patch not found")
- file-name)))))))
+ (raise (formatted-message (G_ "~a: patch not found")
+ file-name))))
(define-syntax-rule (search-patches file-name ...)
"Return the list of absolute file names corresponding to each
;; Search path for package modules. Each item must be either a directory
;; name or a pair whose car is a directory and whose cdr is a sub-directory
;; to narrow the search.
- (let*-values (((not-colon)
- (char-set-complement (char-set #\:)))
- ((environment)
- (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
- not-colon))
- ((channels-scm channels-go)
- (package-path-entries)))
+ (let* ((not-colon (char-set-complement (char-set #\:)))
+ (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
+ not-colon))
+ (channels-scm channels-go (package-path-entries)))
;; Automatically add channels and items from $GUIX_PACKAGE_PATH to Guile's
;; search path. For historical reasons, $GUIX_PACKAGE_PATH goes to the
;; front; channels go to the back so that they don't override Guix' own
(string=? (package-version p) highest))
matches))))))
+;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
+(set! find-best-packages-by-name find-best-packages-by-name)
+
(define (generate-package-cache directory)
"Generate under DIRECTORY a cache of all the available packages.
(define cache-file
(string-append directory %package-cache-file))
- (define (expand-cache module symbol variable result+seen)
- (match (false-if-exception (variable-ref variable))
- ((? package? package)
- (match result+seen
- ((result . seen)
- (if (or (vhash-assq package seen)
- (hidden-package? package))
- (cons result seen)
- (cons (cons `#(,(package-name package)
- ,(package-version package)
- ,(module-name module)
- ,symbol
- ,(package-outputs package)
- ,(->bool (supported-package? package))
- ,(->bool (package-superseded package))
- ,@(let ((loc (package-location package)))
- (if loc
- `(,(location-file loc)
- ,(location-line loc)
- ,(location-column loc))
- '(#f #f #f))))
- result)
- (vhash-consq package #t seen))))))
- (_
- result+seen)))
-
- (define exp
- (first
- (fold-module-public-variables* expand-cache
- (cons '() vlist-null)
+ (define expand-cache
+ (match-lambda*
+ (((module symbol variable) (result . seen))
+ (let ((package (variable-ref variable)))
+ (if (or (vhash-assq package seen)
+ (hidden-package? package))
+ (cons result seen)
+ (cons (cons `#(,(package-name package)
+ ,(package-version package)
+ ,(module-name module)
+ ,symbol
+ ,(package-outputs package)
+ ,(->bool (supported-package? package))
+ ,(->bool (package-superseded package))
+ ,@(let ((loc (package-location package)))
+ (if loc
+ `(,(location-file loc)
+ ,(location-line loc)
+ ,(location-column loc))
+ '(#f #f #f))))
+ result)
+ (vhash-consq package #t seen)))))))
+
+ (define entry-key
+ (match-lambda
+ ((module symbol variable)
+ (let ((value (variable-ref variable)))
+ (string-append (package-name value) (package-version value)
+ (object->string module)
+ (symbol->string symbol))))))
+
+ (define (entry<? a b)
+ (string<? (entry-key a) (entry-key b)))
+
+ (define variables
+ ;; First sort variables so that 'expand-cache' later dismisses
+ ;; already-seen package objects in a deterministic fashion.
+ (sort
+ (fold-module-public-variables* (lambda (module symbol variable lst)
+ (let ((value (false-if-exception
+ (variable-ref variable))))
+ (if (package? value)
+ (cons (list module symbol variable)
+ lst)
+ lst)))
+ '()
(all-modules (%package-module-path)
#:warn
- warn-about-load-error))))
+ warn-about-load-error))
+ entry<?))
+
+ (define exp
+ (first (fold expand-cache (cons '() vlist-null) variables)))
(mkdir-p (dirname cache-file))
(call-with-output-file cache-file
"Return a package matching SPEC. SPEC may be a package name, or a package
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)))
+ (let ((name version (package-name->name+version spec)))
(%find-package spec name version)))
(define (specification->location spec)
"Return the location of the highest-numbered package matching SPEC, a
specification such as \"guile@2\" or \"emacs\"."
- (let-values (((name version) (package-name->name+version spec)))
+ (let ((name version (package-name->name+version spec)))
(match (find-package-locations name version)
(()
(if version
When OUTPUT is false and SPEC does not specify any output, return #f as the
output."
- (let-values (((name version sub-drv)
- (package-specification->name+version+output spec output)))
+ (let ((name version sub-drv
+ (package-specification->name+version+output spec output)))
(match (%find-package spec name version)
(#f
(values #f #f))
(package-full-name package)
sub-drv))))))
+(define (specifications->packages specs)
+ "Given SPECS, a list of specifications such as \"emacs@25.2\" or
+\"guile:debug\", return a list of package/output tuples."
+ ;; This procedure exists so users of 'guix home' don't have to write out the
+ ;; (map (compose list specification->package+output)... boilerplate.
+ (map (compose list specification->package+output) specs))
+
(define (specifications->manifest specs)
"Given SPECS, a list of specifications such as \"emacs@25.2\" or
\"guile:debug\", return a profile manifest."
;; This procedure exists mostly so users of 'guix package -m' don't have to
;; fiddle with multiple-value returns.
(packages->manifest
- (map (compose list specification->package+output) specs)))
+ (specifications->packages specs)))
+
+(define (package-unique-version-prefix name version)
+ "Search among all the versions of package NAME that are available, and
+return the shortest unambiguous version prefix to designate VERSION. If only
+one version of the package is available, return the empty string."
+ (match (map package-version (find-packages-by-name name))
+ ((_)
+ ;; A single version of NAME is available, so do not specify the version
+ ;; number, even if the available version doesn't match VERSION.
+ "")
+ (versions
+ ;; If VERSION is the latest version, don't specify any version.
+ ;; Otherwise return the shortest unique version prefix. Note that this
+ ;; is based on the currently available packages so the result may vary
+ ;; over time.
+ (if (every (cut version>? version <>)
+ (delete version versions))
+ ""
+ (version-unique-prefix version versions)))))
HCoop / jackhill / guix / guix.git / blobdiff