summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/copy.scm23
-rw-r--r--guix/scripts/download.scm2
-rw-r--r--guix/scripts/edit.scm29
-rw-r--r--guix/scripts/lint.scm7
-rw-r--r--guix/scripts/package.scm116
-rw-r--r--guix/scripts/pull.scm18
6 files changed, 109 insertions, 86 deletions
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 4c85929858..be4ce4364b 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +21,7 @@
#:use-module (guix scripts)
#:use-module (guix ssh)
#:use-module (guix store)
+ #:use-module (guix status)
#:use-module (guix utils)
#:use-module (guix derivations)
#:use-module (guix scripts build)
@@ -116,6 +117,8 @@ Copy ITEMS to or from the specified host over SSH.\n"))
--to=HOST send ITEMS to HOST"))
(display (G_ "
--from=HOST receive ITEMS from HOST"))
+ (display (G_ "
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
(newline)
(show-build-options-help)
(newline)
@@ -134,6 +137,11 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(option '("from") #t #f
(lambda (opt name arg result)
(alist-cons 'source arg result)))
+ (option '(#\v "verbosity") #t #f
+ (lambda (opt name arg result)
+ (let ((level (string->number* arg)))
+ (alist-cons 'verbosity level
+ (alist-delete 'verbosity result)))))
(option '(#\h "help") #f #f
(lambda args
(show-help)
@@ -152,7 +160,11 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
- (verbosity . 0)))
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
+ (debug . 0)
+ (verbosity . 2)))
;;;
@@ -164,6 +176,7 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(let* ((opts (parse-command-line args %options (list %default-options)))
(source (assoc-ref opts 'source))
(target (assoc-ref opts 'destination)))
- (cond (target (send-to-remote-host target opts))
- (source (retrieve-from-remote-host source opts))
- (else (leave (G_ "use '--to' or '--from'~%")))))))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (cond (target (send-to-remote-host target opts))
+ (source (retrieve-from-remote-host source opts))
+ (else (leave (G_ "use '--to' or '--from'~%"))))))))
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index b9162d3449..d8fe71ce12 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -77,7 +77,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
(format #t (G_ "
--no-check-certificate
do not validate the certificate of HTTPS servers "))
- (format #f (G_ "
+ (format #t (G_ "
-o, --output=FILE download to FILE"))
(newline)
(display (G_ "
diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm
index 8b2b61d76a..da3d2775e8 100644
--- a/guix/scripts/edit.scm
+++ b/guix/scripts/edit.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -21,7 +21,6 @@
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix utils)
- #:use-module (guix packages)
#:use-module (gnu packages)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-37)
@@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n"))
file path))
absolute-file-name))
-(define (package->location-specification package)
- "Return the location specification for PACKAGE for a typical editor command
+(define (location->location-specification location)
+ "Return the location specification for LOCATION for a typical editor command
line."
- (let ((loc (package-location package)))
- (list (string-append "+"
- (number->string
- (location-line loc)))
- (search-path* %load-path (location-file loc)))))
+ (list (string-append "+"
+ (number->string
+ (location-line location)))
+ (search-path* %load-path (location-file location))))
(define (guix-edit . args)
@@ -83,18 +81,13 @@ line."
'()))
(with-error-handling
- (let* ((specs (reverse (parse-arguments)))
- (packages (map specification->package specs)))
- (for-each (lambda (package)
- (unless (package-location package)
- (leave (G_ "source location of package '~a' is unknown~%")
- (package-full-name package))))
- packages)
+ (let* ((specs (reverse (parse-arguments)))
+ (locations (map specification->location specs)))
(catch 'system-error
(lambda ()
- (let ((file-names (append-map package->location-specification
- packages)))
+ (let ((file-names (append-map location->location-specification
+ locations)))
;; Use `system' instead of `exec' in order to sanely handle
;; possible command line arguments in %EDITOR.
(exit (system (string-join (cons (%editor) file-names))))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 0f315a9352..665adcfb8d 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -758,9 +758,10 @@ descriptions maintained upstream."
"Emit a warning if PACKAGE's source is an autogenerated tarball."
(define (check-source-uri uri)
(when (and (string=? (uri-host (string->uri uri)) "github.com")
- (string=? (third (split-and-decode-uri-path
- (uri-path (string->uri uri))))
- "archive"))
+ (match (split-and-decode-uri-path
+ (uri-path (string->uri uri)))
+ ((_ _ "archive" _ ...) #t)
+ (_ #f)))
(emit-warning package
(G_ "the source URI should not be an autogenerated tarball")
'source)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7ff6bfd6d8..a633d2ee6d 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'."
(define* (build-and-use-profile store profile manifest
#:key
+ (hooks %default-profile-hooks)
allow-collisions?
bootstrap? use-substitutes?
dry-run?)
"Build a new generation of PROFILE, a file name, using the packages
specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true,
-do not treat collisions in MANIFEST as an error."
+do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile
+hooks\" run when building the profile."
(when (equal? profile %current-profile)
(ensure-default-profile))
(let* ((prof-drv (run-with-store store
(profile-derivation manifest
#:allow-collisions? allow-collisions?
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
+ #:hooks (if bootstrap? '() hooks)
#:locales? (not bootstrap?))))
(prof (derivation->output-path prof-drv)))
(show-what-to-build store (list prof-drv)
@@ -220,31 +220,32 @@ of relevance scores."
('dismiss
transaction)
(($ <manifest-entry> name version output (? string? path))
- (match (vhash-assoc name (find-newest-available-packages))
- ((_ candidate-version pkg . rest)
- (match (package-superseded pkg)
- ((? package? new)
- (supersede entry new))
- (#f
- (case (version-compare candidate-version version)
- ((>)
- (manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
- transaction))
- ((<)
- transaction)
- ((=)
- (let ((candidate-path (derivation->output-path
- (package-derivation (%store) pkg))))
- ;; XXX: When there are propagated inputs, assume we need to
- ;; upgrade the whole entry.
- (if (and (string=? path candidate-path)
- (null? (package-propagated-inputs pkg)))
- transaction
- (manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
- transaction))))))))
- (#f
+ (match (find-best-packages-by-name name #f)
+ ((pkg . rest)
+ (let ((candidate-version (package-version pkg)))
+ (match (package-superseded pkg)
+ ((? package? new)
+ (supersede entry new))
+ (#f
+ (case (version-compare candidate-version version)
+ ((>)
+ (manifest-transaction-install-entry
+ (package->manifest-entry* pkg output)
+ transaction))
+ ((<)
+ transaction)
+ ((=)
+ (let ((candidate-path (derivation->output-path
+ (package-derivation (%store) pkg))))
+ ;; XXX: When there are propagated inputs, assume we need to
+ ;; upgrade the whole entry.
+ (if (and (string=? path candidate-path)
+ (null? (package-propagated-inputs pkg)))
+ transaction
+ (manifest-transaction-install-entry
+ (package->manifest-entry* pkg output)
+ transaction)))))))))
+ (()
(warning (G_ "package '~a' no longer exists~%") name)
transaction)))))
@@ -604,12 +605,12 @@ and upgrades."
(options->upgrade-predicate opts))
(define upgraded
- (fold-right (lambda (entry transaction)
- (if (upgrade? (manifest-entry-name entry))
- (transaction-upgrade-entry entry transaction)
- transaction))
- transaction
- (manifest-entries manifest)))
+ (fold (lambda (entry transaction)
+ (if (upgrade? (manifest-entry-name entry))
+ (transaction-upgrade-entry entry transaction)
+ transaction))
+ transaction
+ (manifest-entries manifest)))
(define to-install
(filter-map (match-lambda
@@ -735,29 +736,34 @@ processed, #f otherwise."
(('list-available regexp)
(let* ((regexp (and regexp (make-regexp* regexp)))
- (available (fold-packages
- (lambda (p r)
- (let ((n (package-name p)))
- (if (and (supported-package? p)
- (not (package-superseded p)))
- (if regexp
- (if (regexp-exec regexp n)
- (cons p r)
- r)
- (cons p r))
- r)))
+ (available (fold-available-packages
+ (lambda* (name version result
+ #:key outputs location
+ supported? superseded?
+ #:allow-other-keys)
+ (if (and supported? (not superseded?))
+ (if regexp
+ (if (regexp-exec regexp name)
+ (cons `(,name ,version
+ ,outputs ,location)
+ result)
+ result)
+ (cons `(,name ,version
+ ,outputs ,location)
+ result))
+ result))
'())))
(leave-on-EPIPE
- (for-each (lambda (p)
- (format #t "~a\t~a\t~a\t~a~%"
- (package-name p)
- (package-version p)
- (string-join (package-outputs p) ",")
- (location->string (package-location p))))
+ (for-each (match-lambda
+ ((name version outputs location)
+ (format #t "~a\t~a\t~a\t~a~%"
+ name version
+ (string-join outputs ",")
+ (location->string location))))
(sort available
- (lambda (p1 p2)
- (string<? (package-name p1)
- (package-name p2))))))
+ (match-lambda*
+ (((name1 . _) (name2 . _))
+ (string<? name1 name2))))))
#t))
(('search _)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 6d1914f7c2..d3a4401a01 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -34,11 +34,12 @@
#:use-module (guix channels)
#:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
+ #:autoload (guix build utils) (which)
#:use-module (guix git)
#:use-module (git)
#:use-module (gnu packages)
#:use-module ((guix scripts package) #:select (build-and-use-profile))
- #:use-module (gnu packages base)
+ #:use-module ((gnu packages base) #:select (canonical-package))
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap)
#:select (%bootstrap-guile))
@@ -125,8 +126,7 @@ Download and deploy the latest version of Guix.\n"))
(alist-cons 'ref `(commit . ,arg) result)))
(option '("branch") #t #f
(lambda (opt name arg result)
- (alist-cons 'ref `(branch . ,(string-append "origin/" arg))
- result)))
+ (alist-cons 'ref `(branch . ,arg) result)))
(option '(#\p "profile") #t #f
(lambda (opt name arg result)
(alist-cons 'profile (canonicalize-profile arg)
@@ -189,9 +189,19 @@ true, display what would be built without actually building it."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
(mbegin %store-monad
(update-profile profile manifest
+ #:hooks %channel-profile-hooks
#:dry-run? dry-run?)
(munless dry-run?
- (return (display-profile-news profile))))))
+ (return (display-profile-news profile))
+ (match (which "guix")
+ (#f (return #f))
+ (str
+ (let ((command (string-append profile "/bin/guix")))
+ (unless (string=? command str)
+ (display-hint (format #f (G_ "After setting @code{PATH}, run
+@command{hash guix} to make sure your shell refers to @file{~a}.")
+ command)))
+ (return #f))))))))
(define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates."
generated by cgit v1.2.3 (git 2.50.1) at 2025-08-05 21:24:42 +0000