diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/graph.scm | 105 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 70 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/system/search.scm | 10 |
4 files changed, 133 insertions, 92 deletions
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2e14857f1e..7558cb1e85 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -32,6 +32,10 @@ #:use-module (gnu packages) #:use-module (guix sets) #:use-module ((guix utils) #:select (location-file)) + #:use-module ((guix scripts build) + #:select (show-transformation-options-help + options->transformation + %transformation-options)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -446,36 +450,38 @@ package modules, while attempting to retain user package modules." ;;; (define %options - (list (option '(#\t "type") #t #f - (lambda (opt name arg result) - (alist-cons 'node-type (lookup-node-type arg) - result))) - (option '("list-types") #f #f - (lambda (opt name arg result) - (list-node-types) - (exit 0))) - (option '(#\b "backend") #t #f - (lambda (opt name arg result) - (alist-cons 'backend (lookup-backend arg) - result))) - (option '("list-backends") #f #f - (lambda (opt name arg result) - (list-backends) - (exit 0))) - (option '(#\e "expression") #t #f - (lambda (opt name arg result) - (alist-cons 'expression arg result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix edit"))))) + (cons* (option '(#\t "type") #t #f + (lambda (opt name arg result) + (alist-cons 'node-type (lookup-node-type arg) + result))) + (option '("list-types") #f #f + (lambda (opt name arg result) + (list-node-types) + (exit 0))) + (option '(#\b "backend") #t #f + (lambda (opt name arg result) + (alist-cons 'backend (lookup-backend arg) + result))) + (option '("list-backends") #f #f + (lambda (opt name arg result) + (list-backends) + (exit 0))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix graph"))) + + %transformation-options)) (define (show-help) ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be @@ -495,6 +501,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\"")) (newline) + (show-transformation-options-help) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -514,21 +522,28 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define (guix-graph . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options) - #:build-options? #f)) - (backend (assoc-ref opts 'backend)) - (type (assoc-ref opts 'node-type)) - (items (filter-map (match-lambda - (('argument . (? store-path? item)) - item) - (('argument . spec) - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts))) - (with-store store + (define opts + (parse-command-line args %options + (list %default-options) + #:build-options? #f)) + (define backend + (assoc-ref opts 'backend)) + (define type + (assoc-ref opts 'node-type)) + + (with-store store + (let* ((transform (options->transformation opts)) + (items (filter-map (match-lambda + (('argument . (? store-path? item)) + item) + (('argument . spec) + (transform store + (specification->package spec))) + (('expression . exp) + (transform store + (read/eval-package-expression exp))) + (_ #f)) + opts))) ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1a58d43e5c..bcd03a1df9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -42,6 +42,8 @@ #:autoload (guix store roots) (gc-roots) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) + #:use-module ((guix build syscalls) + #:select (with-file-lock/no-wait)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -876,36 +878,44 @@ processed, #f otherwise." (package-version item) (manifest-entry-version entry)))))) - ;; First, process roll-backs, generation removals, etc. - (for-each (match-lambda - ((key . arg) - (and=> (assoc-ref %actions key) - (lambda (proc) - (proc store profile arg opts - #:dry-run? dry-run?))))) - opts) - - ;; Then, process normal package removal/installation/upgrade. - (let* ((manifest (profile-manifest profile)) - (step1 (options->removable opts manifest - (manifest-transaction))) - (step2 (options->installable opts manifest step1)) - (step3 (manifest-transaction - (inherit step2) - (install (map transform-entry - (manifest-transaction-install step2))))) - (new (manifest-perform-transaction manifest step3))) - - (warn-about-old-distro) - - (unless (manifest-transaction-null? step3) - (show-manifest-transaction store manifest step3 - #:dry-run? dry-run?) - (build-and-use-profile store profile new - #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?)))) + + ;; First, acquire a lock on the profile, to ensure only one guix process + ;; is modifying it at a time. + (with-file-lock/no-wait (string-append profile ".lock") + (lambda (key . args) + (leave (G_ "profile ~a is locked by another process~%") + profile)) + + ;; Then, process roll-backs, generation removals, etc. + (for-each (match-lambda + ((key . arg) + (and=> (assoc-ref %actions key) + (lambda (proc) + (proc store profile arg opts + #:dry-run? dry-run?))))) + opts) + + ;; Then, process normal package removal/installation/upgrade. + (let* ((manifest (profile-manifest profile)) + (step1 (options->removable opts manifest + (manifest-transaction))) + (step2 (options->installable opts manifest step1)) + (step3 (manifest-transaction + (inherit step2) + (install (map transform-entry + (manifest-transaction-install step2))))) + (new (manifest-perform-transaction manifest step3))) + + (warn-about-old-distro) + + (unless (manifest-transaction-null? step3) + (show-manifest-transaction store manifest step3 + #:dry-run? dry-run?) + (build-and-use-profile store profile new + #:allow-collisions? allow-collisions? + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?))))) ;;; diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 80d070652b..92aac6066e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -235,12 +235,18 @@ purposes." (define title (channel-news-entry-title entry)) - (format port " ~a~%" - (highlight - (string-trim-right - (texi->plain-text (or (assoc-ref title language) - (assoc-ref title (%default-message-language)) - "")))))) + (let ((title (or (assoc-ref title language) + (assoc-ref title (%default-message-language)) + ""))) + (format port " ~a~%" + (highlight + (string-trim-right + (catch 'parser-error + (lambda () + (texi->plain-text title)) + + ;; When Texinfo markup is invalid, display it as-is. + (const title))))))) (define (display-news-entry entry language port) "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to @@ -252,14 +258,20 @@ PORT." (format port (dim (G_ " commit ~a~%")) (channel-news-entry-commit entry)) (newline port) - (format port " ~a~%" - (indented-string - (parameterize ((%text-width (- (%text-width) 4))) - (string-trim-right - (texi->plain-text (or (assoc-ref body language) - (assoc-ref body (%default-message-language)) - "")))) - 4))) + (let ((body (or (assoc-ref body language) + (assoc-ref body (%default-message-language)) + ""))) + (format port " ~a~%" + (indented-string + (parameterize ((%text-width (- (%text-width) 4))) + (string-trim-right + (catch 'parser-error + (lambda () + (texi->plain-text body)) + (lambda _ + ;; When Texinfo markup is invalid, display it as-is. + (fill-paragraph body (%text-width)))))) + 4)))) (define* (display-channel-specific-news new old #:key (port (current-output-port)) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index 5278062edd..d2eac06cca 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -65,9 +65,12 @@ provided TYPE has a default value." (define* (service-type->recutils type port #:optional (width (%text-width)) - #:key (extra-fields '())) + #:key + (extra-fields '()) + (hyperlinks? (supports-hyperlinks? port))) "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH -columns." +columns. When HYPERLINKS? is true, emit hyperlink escape sequences when +appropriate." (define width* ;; The available number of columns once we've taken into account space for ;; the initial "+ " prefix. @@ -84,7 +87,8 @@ columns." ;; Note: Don't i18n field names so that people can post-process it. (format port "name: ~a~%" (service-type-name type)) (format port "location: ~a~%" - (or (and=> (service-type-location type) location->string) + (or (and=> (service-type-location type) + (if hyperlinks? location->hyperlink location->string)) (G_ "unknown"))) (format port "extends: ~a~%" |