From c2e9942b8fc8918c3e1d9612f99bea06be9ff81d Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 2 Apr 2017 15:52:34 +0200 Subject: system: Rename kernel->grub-label to kernel->boot-label. * gnu/system.scm (kernel->grub-label): Rename to kernel->boot-label. (operating-system-grub.cfg): Adapt. (operating-system-parameters-file): Ditto. Signed-off-by: Danny Milosavljevic --- gnu/system.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 0f52351cf0..e74763d3d7 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -700,8 +700,8 @@ listed in OS. The C library expects to find it under (locale-directory definitions #:libcs (operating-system-locale-libcs os))) -(define (kernel->grub-label kernel) - "Return a label for the GRUB menu entry that boots KERNEL." +(define (kernel->boot-label kernel) + "Return a label for the bootloader menu entry that boots KERNEL." (string-append "GNU with " (string-titlecase (package-name kernel)) " " (package-version kernel) @@ -735,7 +735,7 @@ listed in OS. The C library expects to find it under ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) (store-fs -> (operating-system-store-file-system os)) - (label -> (kernel->grub-label (operating-system-kernel os))) + (label -> (kernel->boot-label (operating-system-kernel os))) (kernel -> (operating-system-kernel-file os)) (initrd (operating-system-initrd-file os)) (root-device -> (if (eq? 'uuid (file-system-title root-fs)) @@ -774,7 +774,7 @@ this file is the reconstruction of GRUB menu entries for old configurations." (mlet %store-monad ((initrd (operating-system-initrd-file os)) (root -> (operating-system-root-file-system os)) (store -> (operating-system-store-file-system os)) - (label -> (kernel->grub-label + (label -> (kernel->boot-label (operating-system-kernel os)))) (gexp->file "parameters" #~(boot-parameters -- cgit 1.4.1 From c76b3046f651e8f46db1a093fdfc78cdc0bc3a13 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 2 Apr 2017 15:52:29 +0200 Subject: system: Rename operating-system-grub.cfg to operating-system-bootcfg. * gnu/system.scm (operating-system-grub.cfg): Rename to... (operating-system-bootcfg): ... this. * gnu/system/vm.scm (system-disk-image): Use operating-system-bootcfg. (system-qemu-image): Use operating-system-bootcfg. (system-qemu-image/shared-store): Use operating-system-bootcfg. * guix/scripts/system.scm (perform-action): Use operating-system-bootcfg. Signed-off-by: Danny Milosavljevic --- gnu/system.scm | 9 +++++---- gnu/system/vm.scm | 18 +++++++++--------- guix/scripts/system.scm | 8 ++++---- 3 files changed, 18 insertions(+), 17 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index e74763d3d7..369dc20b8f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -92,7 +93,7 @@ operating-system-derivation operating-system-profile - operating-system-grub.cfg + operating-system-bootcfg operating-system-etc-directory operating-system-locale-directory operating-system-boot-script @@ -728,9 +729,9 @@ listed in OS. The C library expects to find it under "Return the file system that contains the store of OS." (store-file-system (operating-system-file-systems os))) -(define* (operating-system-grub.cfg os #:optional (old-entries '())) - "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the -\"old entries\" menu." +(define* (operating-system-bootcfg os #:optional (old-entries '())) + "Return the bootloader configuration file for OS. Use OLD-ENTRIES to +populate the \"old entries\" menu." (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 5c6e7f684a..ddb8981ec8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -284,10 +284,10 @@ to USB sticks meant to be read-only." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (grub.cfg (operating-system-grub.cfg os))) + (bootcfg (operating-system-bootcfg os))) (qemu-image #:name name #:os-derivation os-drv - #:grub-configuration grub.cfg + #:grub-configuration bootcfg #:disk-image-size disk-image-size #:disk-image-format "raw" #:file-system-type file-system-type @@ -295,7 +295,7 @@ to USB sticks meant to be read-only." #:copy-inputs? #t #:register-closures? #t #:inputs `(("system" ,os-drv) - ("grub.cfg" ,grub.cfg)))))) + ("grub.cfg" ,bootcfg)))))) (define* (system-qemu-image os #:key @@ -328,13 +328,13 @@ of the GNU system as described by OS." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (grub.cfg (operating-system-grub.cfg os))) + (bootcfg (operating-system-bootcfg os))) (qemu-image #:os-derivation os-drv - #:grub-configuration grub.cfg + #:grub-configuration bootcfg #:disk-image-size disk-image-size #:file-system-type file-system-type #:inputs `(("system" ,os-drv) - ("grub.cfg" ,grub.cfg)) + ("grub.cfg" ,bootcfg)) #:copy-inputs? #t)))) @@ -423,16 +423,16 @@ When FULL-BOOT? is true, return an image that does a complete boot sequence, bootloaded included; thus, make a disk image that contains everything the bootloader refers to: OS kernel, initrd, bootloader data, etc." (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (grub.cfg (operating-system-grub.cfg os))) + (bootcfg (operating-system-bootcfg os))) ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains ;; GRUB.CFG and all its dependencies, including the output of OS-DRV. ;; This is more than needed (we only need the kernel, initrd, GRUB for its ;; font, and the background image), but it's hard to filter that. (qemu-image #:os-derivation os-drv - #:grub-configuration grub.cfg + #:grub-configuration bootcfg #:disk-image-size disk-image-size #:inputs (if full-boot? - `(("grub.cfg" ,grub.cfg)) + `(("grub.cfg" ,bootcfg)) '()) ;; XXX: Passing #t here is too slow, so let it off by default. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8fe2a6b04e..a1c6d35909 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -622,10 +622,10 @@ output when building a system derivation, such as a disk image." (operating-system-bootloader os)))) (grub.cfg (if (eq? 'container action) (return #f) - (operating-system-grub.cfg os - (if (eq? 'init action) - '() - (profile-grub-entries))))) + (operating-system-bootcfg os + (if (eq? 'init action) + '() + (profile-grub-entries))))) ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC -- cgit 1.4.1 From 7085ca9690f6b3838ae3dc0f832c30e41681e835 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 15 Apr 2017 14:37:01 +0200 Subject: system: Rename (internal) grub-device to fs->boot-device. * gnu/system.scm (grub-device): Rename to... (fs->boot-device): ... this. (operating-system-grub.cfg): Adapt. (operating-system-parameters-file): Adapt. Signed-off-by: Danny Milosavljevic --- gnu/system.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 369dc20b8f..69cbc8a081 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -746,7 +746,7 @@ populate the \"old entries\" menu." (label label) ;; The device where the kernel and initrd live. - (device (grub-device store-fs)) + (device (fs->boot-device store-fs)) (device-mount-point (file-system-mount-point store-fs)) @@ -761,7 +761,7 @@ populate the \"old entries\" menu." (grub-configuration-file (operating-system-bootloader os) entries #:old-entries old-entries))) -(define (grub-device fs) +(define (fs->boot-device fs) "Given FS, a object, return a value suitable for use as the device in a ." (case (file-system-title fs) @@ -787,7 +787,7 @@ this file is the reconstruction of GRUB menu entries for old configurations." #$(operating-system-kernel-arguments os)) (initrd #$initrd) (store - (device #$(grub-device store)) + (device #$(fs->boot-device store)) (mount-point #$(file-system-mount-point store)))) #:set-load-path? #f))) -- cgit 1.4.1 From 2e58e05bb68d4b747882cfa2b460b132d456f54a Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 15 Apr 2017 16:19:06 +0200 Subject: system: Pass boot-parameters to (gnu system grub). * gnu/system.scm (operating-system-bootcfg): Pass boot-parameters. * gnu/system/grub.scm (boot-parameters->menu-entry): New variable. (grub-configuration-file): Use boot-parameters->menu-entry. Signed-off-by: Danny Milosavljevic --- gnu/system.scm | 11 ++++++----- gnu/system/grub.scm | 15 +++++++++++++-- 2 files changed, 19 insertions(+), 7 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 69cbc8a081..4721668ba3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -742,16 +742,17 @@ populate the \"old entries\" menu." (root-device -> (if (eq? 'uuid (file-system-title root-fs)) (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) - (entries -> (list (menu-entry + (entries -> (list (boot-parameters (label label) + (root-device root-device) ;; The device where the kernel and initrd live. - (device (fs->boot-device store-fs)) - (device-mount-point + (store-device (fs->boot-device store-fs)) + (store-mount-point (file-system-mount-point store-fs)) - (linux kernel) - (linux-arguments + (kernel kernel) + (kernel-arguments (cons* (string-append "--root=" root-device) #~(string-append "--system=" #$system) #~(string-append "--load=" #$system diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index bcfc3beae6..f2838d633d 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -26,6 +26,7 @@ #:use-module (guix gexp) #:use-module (guix download) #:use-module (gnu artwork) + #:use-module (gnu system) #:use-module (gnu system file-systems) #:autoload (gnu packages bootloaders) (grub) #:autoload (gnu packages compression) (gzip) @@ -266,6 +267,15 @@ code." (#f #~(format #f "search --file --set ~a" #$file))))) +(define (boot-parameters->menu-entry conf) + (menu-entry + (label (boot-parameters-label conf)) + (device (boot-parameters-store-device conf)) + (device-mount-point (boot-parameters-store-mount-point conf)) + (linux (boot-parameters-kernel conf)) + (linux-arguments (boot-parameters-kernel-arguments conf)) + (initrd (boot-parameters-initrd conf)))) + (define* (grub-configuration-file config entries #:key (system (%current-system)) @@ -275,7 +285,8 @@ code." object. OLD-ENTRIES is taken to be a list of menu entries corresponding to old generations of the system." (define all-entries - (append entries (grub-configuration-menu-entries config))) + (append (map boot-parameters->menu-entry entries) + (grub-configuration-menu-entries config))) (define entry->gexp (match-lambda @@ -321,7 +332,7 @@ set timeout=~a~%" #$@(if (pair? old-entries) #~((format port " submenu \"GNU system, old configurations...\" {~%") - #$@(map entry->gexp old-entries) + #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) (format port "}~%")) #~())))) -- cgit 1.4.1 From 958a1fda9e0ad41468cbdb88766e7c854dd32df4 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Sat, 15 Apr 2017 22:02:38 +0200 Subject: system: Make grub use instead of again. * gnu/system/grub.scm: Remove boot-parameters->menu-entry. (grub-configuration): Don't use boot-parameters->menu-entry. * gnu/system.scm (operating-system-bootcfg): Use menu-entry. * guix/scripts/system.scm (reinstall-grub): Use profile-grub-entries. (perform-action): Use profile-grub-entries. --- gnu/system.scm | 11 +++++------ gnu/system/grub.scm | 13 ++----------- guix/scripts/system.scm | 6 +++--- 3 files changed, 10 insertions(+), 20 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 4721668ba3..69cbc8a081 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -742,17 +742,16 @@ populate the \"old entries\" menu." (root-device -> (if (eq? 'uuid (file-system-title root-fs)) (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) - (entries -> (list (boot-parameters + (entries -> (list (menu-entry (label label) - (root-device root-device) ;; The device where the kernel and initrd live. - (store-device (fs->boot-device store-fs)) - (store-mount-point + (device (fs->boot-device store-fs)) + (device-mount-point (file-system-mount-point store-fs)) - (kernel kernel) - (kernel-arguments + (linux kernel) + (linux-arguments (cons* (string-append "--root=" root-device) #~(string-append "--system=" #$system) #~(string-append "--load=" #$system diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index f2838d633d..cde4b9e23a 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -267,15 +267,6 @@ code." (#f #~(format #f "search --file --set ~a" #$file))))) -(define (boot-parameters->menu-entry conf) - (menu-entry - (label (boot-parameters-label conf)) - (device (boot-parameters-store-device conf)) - (device-mount-point (boot-parameters-store-mount-point conf)) - (linux (boot-parameters-kernel conf)) - (linux-arguments (boot-parameters-kernel-arguments conf)) - (initrd (boot-parameters-initrd conf)))) - (define* (grub-configuration-file config entries #:key (system (%current-system)) @@ -285,7 +276,7 @@ code." object. OLD-ENTRIES is taken to be a list of menu entries corresponding to old generations of the system." (define all-entries - (append (map boot-parameters->menu-entry entries) + (append entries (grub-configuration-menu-entries config))) (define entry->gexp @@ -332,7 +323,7 @@ set timeout=~a~%" #$@(if (pair? old-entries) #~((format port " submenu \"GNU system, old configurations...\" {~%") - #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) + #$@(map entry->gexp old-entries) (format port "}~%")) #~())))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3ba420d8e7..9d86efdd77 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -456,9 +456,9 @@ open connection to the store." ;; from the actual past values for this generation's entry. (grub-config (grub-configuration (device root-device))) ;; Make the specified system generation the default entry. - (entries (profile-boot-parameters %system-profile (list number))) + (entries (profile-grub-entries %system-profile (list number))) (old-generations (delv number (generation-numbers %system-profile))) - (old-entries (profile-boot-parameters %system-profile old-generations)) + (old-entries (profile-grub-entries %system-profile old-generations)) (grub.cfg (run-with-store store (grub-configuration-file grub-config entries @@ -643,7 +643,7 @@ output when building a system derivation, such as a disk image." (operating-system-bootcfg os (if (eq? 'init action) '() - (profile-boot-parameters))))) + (profile-grub-entries))))) ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC -- cgit 1.4.1 From efe7d19a9edafb793dca21dcefce89ead3465030 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Apr 2017 22:12:37 +0200 Subject: services: 'service-parameters' becomes 'service-value'. * gnu/services.scm ()[parameters]: Rename to... [value]: ... this. Change calls to 'service-parameters' to 'service-value'. * gnu/system.scm, gnu/tests/base.scm, guix/scripts/system.scm, tests/services.scm: Likewise. * doc/guix.texi (Service Reference): Adjust accordingly. --- doc/guix.texi | 2 +- gnu/services.scm | 21 +++++++++++++-------- gnu/system.scm | 8 ++++---- gnu/tests/base.scm | 2 +- guix/scripts/system.scm | 6 +++--- tests/services.scm | 4 ++-- 6 files changed, 24 insertions(+), 19 deletions(-) (limited to 'gnu/system.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 07f52becf8..bf46f89bf2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -15684,7 +15684,7 @@ Return true if @var{obj} is a service. Return the type of @var{service}---i.e., a @code{} object. @end deffn -@deffn {Scheme Procedure} service-parameters @var{service} +@deffn {Scheme Procedure} service-value @var{service} Return the value associated with @var{service}. It represents its parameters. @end deffn diff --git a/gnu/services.scm b/gnu/services.scm index 9f6e323e18..af4cffe819 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -51,7 +51,8 @@ service service? service-kind - service-parameters + service-value + service-parameters ;deprecated simple-service modify-services @@ -142,10 +143,14 @@ ;; Services of a given type. (define-record-type - (service type parameters) + (service type value) service? (type service-kind) - (parameters service-parameters)) + (value service-value)) + +(define service-parameters + ;; Deprecated alias. + service-value) (define (simple-service name target value) "Return a service that extends TARGET with VALUE. This works by creating a @@ -161,7 +166,7 @@ singleton service type NAME, of which the returned service is an instance." service) ((_ svc (kind param => exp ...) clauses ...) (if (eq? (service-kind svc) kind) - (let ((param (service-parameters svc))) + (let ((param (service-value svc))) (service (service-kind svc) (begin exp ...))) (%modify-service svc clauses ...))))) @@ -321,7 +326,7 @@ file." (define* (activation-service->script service) "Return as a monadic value the activation script for SERVICE, a service of ACTIVATION-SCRIPT-TYPE." - (activation-script (service-parameters service))) + (activation-script (service-value service))) (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." @@ -432,7 +437,7 @@ and FILE could be \"/usr/bin/env\"." (define (etc-directory service) "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." - (files->etc-directory (service-parameters service))) + (files->etc-directory (service-value service))) (define (files->etc-directory files) (file-union "etc" files)) @@ -605,7 +610,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (match (find (matching-extension target) (service-type-extensions (service-kind service))) (($ _ compute) - (compute (service-parameters service)))))) + (compute (service-value service)))))) (match (filter (lambda (service) (eq? (service-kind service) target-type)) @@ -616,7 +621,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (extensions (map (apply-extension sink) dependents)) (extend (service-type-extend (service-kind sink))) (compose (service-type-compose (service-kind sink))) - (params (service-parameters sink))) + (params (service-value sink))) ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a ;; different type than the elements of EXTENSIONS. (if extend diff --git a/gnu/system.scm b/gnu/system.scm index 69cbc8a081..89c4150f99 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -615,7 +615,7 @@ hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) (boot (fold-services services #:target-type boot-service-type))) ;; BOOT is the script as a monadic value. - (service-parameters boot))) + (service-value boot))) (define (operating-system-user-accounts os) "Return the list of user accounts of OS." @@ -623,12 +623,12 @@ hardware-related operations as necessary when booting a Linux container." (account (fold-services services #:target-type account-service-type))) (filter user-account? - (service-parameters account)))) + (service-value account)))) (define (operating-system-shepherd-service-names os) "Return the list of Shepherd service names for OS." (append-map shepherd-service-provision - (service-parameters + (service-value (fold-services (operating-system-services os) #:target-type shepherd-root-service-type)))) @@ -638,7 +638,7 @@ hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) (system (fold-services services))) ;; SYSTEM contains the derivation as a monadic value. - (service-parameters system))) + (service-value system))) (define* (operating-system-profile os #:key container?) "Return a derivation that builds the system profile of OS." diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index bcb8299c73..6ce5ab3de1 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -56,7 +56,7 @@ passed a gexp denoting the marionette, and it must return gexp that is inserted before the first test. This is used to introduce an extra initialization step, such as entering a LUKS passphrase." (define special-files - (service-parameters + (service-value (fold-services (operating-system-services os) #:target-type special-files-service-type))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9d86efdd77..9ffdc15abb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -289,7 +289,7 @@ This is currently very conservative in that it does not stop or unload any running service. Unloading or stopping the wrong service ('udev', say) could bring the system down." (define new-services - (service-parameters + (service-value (fold-services (operating-system-services os) #:target-type shepherd-root-service-type))) @@ -487,7 +487,7 @@ open connection to the store." (define (service-node-label service) "Return a label to represent SERVICE." (let ((type (service-kind service)) - (value (service-parameters service))) + (value (service-value service))) (string-append (symbol->string (service-type-name type)) (cond ((or (number? value) (symbol? value)) (string-append " " (object->string value))) @@ -711,7 +711,7 @@ output when building a system derivation, such as a disk image." (let* ((services (operating-system-services os)) (pid1 (fold-services services #:target-type shepherd-root-service-type)) - (shepherds (service-parameters pid1)) ;list of + (shepherds (service-value pid1)) ;list of (sinks (filter (lambda (service) (null? (shepherd-service-requirement service))) shepherds))) diff --git a/tests/services.scm b/tests/services.scm index 8993c3dafc..7983427a7d 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,7 +75,7 @@ (iota 5 1))) #:target-type t1))) (and (eq? (service-kind r) t1) - (service-parameters r)))) + (service-value r)))) (test-assert "fold-services, ambiguity" (let* ((t1 (service-type (name 't1) (extensions '()) -- cgit 1.4.1 From e162050dfc0dee708a7ac5bfcf37d2afd6081604 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 18 Apr 2017 20:13:45 +0200 Subject: gnu: Add workaround for `date` regression in coreutils@8.26. See and . * gnu/packages/base.scm (coreutils-8.27): New variable. * gnu/system.scm (%base-packages): Use that instead of COREUTILS. --- gnu/packages/base.scm | 17 +++++++++++++++++ gnu/system.scm | 2 +- 2 files changed, 18 insertions(+), 1 deletion(-) (limited to 'gnu/system.scm') diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm index 5c36b612f1..7af166d6e5 100644 --- a/gnu/packages/base.scm +++ b/gnu/packages/base.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2014, 2015 Manolis Fragkiskos Ragkousis ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2017 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -361,6 +362,22 @@ functionality beyond that which is outlined in the POSIX standard.") (license gpl3+) (home-page "https://www.gnu.org/software/coreutils/"))) +;; We add version 8.27 here for use in (gnu system) due to a time +;; zone bug in `date' versions 8.25 - 8.26. +;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=23035 +;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26238 +(define-public coreutils-8.27 + (package + (inherit coreutils) + (version "8.27") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/coreutils/coreutils-" + version ".tar.xz")) + (sha256 + (base32 + "0sv547572iq8ayy8klir4hnngnx92a9nsazmf1wgzfc7xr4x74c8")))))) + (define-public coreutils-minimal ;; Coreutils without its optional dependencies. (package diff --git a/gnu/system.scm b/gnu/system.scm index 89c4150f99..f6ab7ded85 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -385,7 +385,7 @@ explicitly appear in OS." ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. (map canonical-package - (list guile-2.0 bash coreutils findutils grep sed + (list guile-2.0 bash coreutils-8.27 findutils grep sed diffutils patch gawk tar gzip bzip2 xz lzip)))) (define %default-issue -- cgit 1.4.1 From af98d25a1286e246e8da36d6d63b4d66e58f2cf8 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 21 Apr 2017 04:21:20 +0200 Subject: system: Rename operating-system-kernel-arguments to operating-system-user-kernel-arguments. * gnu/system.scm (operating-system-kernel-arguments): Rename to ... (operating-system-user-kernel-arguments): ... this. (): Adapt accordingly. (operating-system-bootcfg): Adapt accordingly. (operating-system-parameters-file): Adapt accordingly. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Adapt accordingly. --- gnu/system.scm | 8 ++++---- gnu/system/vm.scm | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index f6ab7ded85..4032e8e150 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -73,7 +73,7 @@ operating-system-hosts-file operating-system-kernel operating-system-kernel-file - operating-system-kernel-arguments + operating-system-user-kernel-arguments operating-system-initrd operating-system-users operating-system-groups @@ -129,7 +129,7 @@ operating-system? (kernel operating-system-kernel ; package (default linux-libre)) - (kernel-arguments operating-system-kernel-arguments + (kernel-arguments operating-system-user-kernel-arguments (default '())) ; list of gexps/strings (bootloader operating-system-bootloader) ; @@ -756,7 +756,7 @@ populate the \"old entries\" menu." #~(string-append "--system=" #$system) #~(string-append "--load=" #$system "/boot") - (operating-system-kernel-arguments os))) + (operating-system-user-kernel-arguments os))) (initrd initrd))))) (grub-configuration-file (operating-system-bootloader os) entries #:old-entries old-entries))) @@ -784,7 +784,7 @@ this file is the reconstruction of GRUB menu entries for old configurations." (root-device #$(file-system-device root)) (kernel #$(operating-system-kernel-file os)) (kernel-arguments - #$(operating-system-kernel-arguments os)) + #$(operating-system-user-kernel-arguments os)) (initrd #$initrd) (store (device #$(fs->boot-device store)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 374d8b6636..4f915c4f95 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -494,7 +494,7 @@ it is mostly useful when FULL-BOOT? is true." (string-append "--system=" #$os-drv) (string-append "--load=" #$os-drv "/boot") #$@(if graphic? #~() #~("console=ttyS0")) - #+@(operating-system-kernel-arguments os))) + #+@(operating-system-user-kernel-arguments os))) (define qemu-exec #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system))) -- cgit 1.4.1 From 71d04202026e2061f898a142a8381d55bee5fb00 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 21 Apr 2017 04:21:21 +0200 Subject: system: Rename operating-system-parameters-file to operating-system-boot-parameters-file. * gnu/system.scm (operating-system-parameters-file): Rename to ... (operating-system-boot-parameters-file): ... this. (operating-system-directory-base-entries): Adapt call site. --- gnu/system.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 4032e8e150..44190bdfc6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -278,7 +278,7 @@ value of the SYSTEM-SERVICE-TYPE service." (mlet %store-monad ((kernel -> (operating-system-kernel os)) (initrd (operating-system-initrd-file os)) - (params (operating-system-parameters-file os))) + (params (operating-system-boot-parameters-file os))) (return `(("kernel" ,kernel) ("parameters" ,params) ("initrd" ,initrd) @@ -769,7 +769,7 @@ device in a ." ((label) (file-system-device fs)) (else #f))) -(define (operating-system-parameters-file os) +(define (operating-system-boot-parameters-file os) "Return a file that describes the boot parameters of OS. The primary use of this file is the reconstruction of GRUB menu entries for old configurations." (mlet %store-monad ((initrd (operating-system-initrd-file os)) -- cgit 1.4.1 From 69daee23af49aeafcb1d250c90860f9253da719e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 May 2017 15:57:02 +0200 Subject: ui: Rename '_' to 'G_'. This avoids collisions with '_' when the latter is used as a 'match' pattern for instance. See . * guix/ui.scm: Rename '_' to 'G_'. * po/guix/Makevars (XGETTEXT_OPTIONS): Adjust accordingly. * build-aux/compile-all.scm (warnings): Remove 'format'. * gnu/packages.scm, gnu/services.scm, gnu/services/shepherd.scm, gnu/system.scm, gnu/system/shadow.scm, guix/gnupg.scm, guix/http-client.scm, guix/import/cpan.scm, guix/import/elpa.scm, guix/import/pypi.scm, guix/nar.scm, guix/scripts.scm, guix/scripts/archive.scm, guix/scripts/authenticate.scm, guix/scripts/build.scm, guix/scripts/challenge.scm, guix/scripts/container.scm, guix/scripts/container/exec.scm, guix/scripts/copy.scm, guix/scripts/download.scm, guix/scripts/edit.scm, guix/scripts/environment.scm, guix/scripts/gc.scm, guix/scripts/graph.scm, guix/scripts/hash.scm, guix/scripts/import.scm, guix/scripts/import/cpan.scm, guix/scripts/import/cran.scm, guix/scripts/import/crate.scm, guix/scripts/import/elpa.scm, guix/scripts/import/gem.scm, guix/scripts/import/gnu.scm, guix/scripts/import/hackage.scm, guix/scripts/import/nix.scm, guix/scripts/import/pypi.scm, guix/scripts/import/stackage.scm, guix/scripts/lint.scm, guix/scripts/offload.scm, guix/scripts/pack.scm, guix/scripts/package.scm, guix/scripts/perform-download.scm, guix/scripts/publish.scm, guix/scripts/pull.scm, guix/scripts/refresh.scm, guix/scripts/size.scm, guix/scripts/substitute.scm, guix/scripts/system.scm, guix/ssh.scm, guix/upstream.scm: Use 'G_' instead of '_'. Most of this change was obtained by running: "sed -i -e's/(_ "/(G_ "/g' `find -name \*.scm`". --- build-aux/compile-all.scm | 5 +- gnu/packages.scm | 18 +++--- gnu/services.scm | 10 ++-- gnu/services/shepherd.scm | 4 +- gnu/system.scm | 8 +-- gnu/system/shadow.scm | 4 +- guix/gnupg.scm | 2 +- guix/http-client.scm | 4 +- guix/import/cpan.scm | 2 +- guix/import/elpa.scm | 4 +- guix/import/pypi.scm | 6 +- guix/nar.scm | 4 +- guix/scripts.scm | 4 +- guix/scripts/archive.scm | 46 +++++++-------- guix/scripts/authenticate.scm | 12 ++-- guix/scripts/build.scm | 84 +++++++++++++-------------- guix/scripts/challenge.scm | 24 ++++---- guix/scripts/container.scm | 14 ++--- guix/scripts/container/exec.scm | 16 +++--- guix/scripts/copy.scm | 16 +++--- guix/scripts/download.scm | 24 ++++---- guix/scripts/edit.scm | 14 ++--- guix/scripts/environment.scm | 42 +++++++------- guix/scripts/gc.scm | 44 +++++++-------- guix/scripts/graph.scm | 30 +++++----- guix/scripts/hash.scm | 20 +++---- guix/scripts/import.scm | 14 ++--- guix/scripts/import/cpan.scm | 14 ++--- guix/scripts/import/cran.scm | 16 +++--- guix/scripts/import/crate.scm | 14 ++--- guix/scripts/import/elpa.scm | 16 +++--- guix/scripts/import/gem.scm | 14 ++--- guix/scripts/import/gnu.scm | 14 ++--- guix/scripts/import/hackage.scm | 24 ++++---- guix/scripts/import/nix.scm | 10 ++-- guix/scripts/import/pypi.scm | 14 ++--- guix/scripts/import/stackage.scm | 18 +++--- guix/scripts/lint.scm | 110 ++++++++++++++++++------------------ guix/scripts/offload.scm | 48 ++++++++-------- guix/scripts/pack.scm | 26 ++++----- guix/scripts/package.scm | 78 ++++++++++++------------- guix/scripts/perform-download.scm | 8 +-- guix/scripts/publish.scm | 46 +++++++-------- guix/scripts/pull.scm | 26 ++++----- guix/scripts/refresh.scm | 50 ++++++++-------- guix/scripts/size.scm | 22 ++++---- guix/scripts/substitute.scm | 66 +++++++++++----------- guix/scripts/system.scm | 116 +++++++++++++++++++------------------- guix/ssh.scm | 8 +-- guix/ui.scm | 116 +++++++++++++++++++------------------- guix/upstream.scm | 8 +-- po/guix/Makevars | 2 +- 52 files changed, 681 insertions(+), 678 deletions(-) (limited to 'gnu/system.scm') diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm index d077d75229..147bb80196 100644 --- a/build-aux/compile-all.scm +++ b/build-aux/compile-all.scm @@ -24,7 +24,10 @@ (guix build utils)) (define warnings - '(unsupported-warning format unbound-variable arity-mismatch)) + ;; FIXME: 'format' is missing because it reports "non-literal format + ;; strings" due to the fact that we use 'G_' instead of '_'. We'll need + ;; help from Guile to solve this. + '(unsupported-warning unbound-variable arity-mismatch)) (define host (getenv "host")) diff --git a/gnu/packages.scm b/gnu/packages.scm index bec8163b2b..08f1340612 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -89,7 +89,7 @@ "Search the patch FILE-NAME. Raise an error if not found." (or (search-path (%patch-path) file-name) (raise (condition - (&message (message (format #f (_ "~a: patch not found") + (&message (message (format #f (G_ "~a: patch not found") file-name))))))) (define-syntax-rule (search-patches file-name ...) @@ -105,7 +105,7 @@ found." (raise (condition (&message (message - (format #f (_ "could not find bootstrap binary '~a' \ + (format #f (G_ "could not find bootstrap binary '~a' \ for system '~a'") file-name system))))))) @@ -157,7 +157,7 @@ returned list is sorted in alphabetical order." result) (const #f) ; skip (lambda (path stat errno result) - (warning (_ "cannot access `~a': ~a~%") + (warning (G_ "cannot access `~a': ~a~%") path (strerror errno)) result) '() @@ -310,21 +310,21 @@ return its return value." (match (find-best-packages-by-name name version) ((pkg . pkg*) (unless (null? pkg*) - (warning (_ "ambiguous package specification `~a'~%") spec) - (warning (_ "choosing ~a@~a from ~a~%") + (warning (G_ "ambiguous package specification `~a'~%") spec) + (warning (G_ "choosing ~a@~a from ~a~%") (package-name pkg) (package-version pkg) (location->string (package-location pkg)))) (match (package-superseded pkg) ((? package? new) - (info (_ "package '~a' has been superseded by '~a'~%") + (info (G_ "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) - (leave (_ "~A: unknown package~%") name))))) + (leave (G_ "~A: package not found for version ~a~%") name version) + (leave (G_ "~A: unknown package~%") name))))) (define (specification->package spec) "Return a package matching SPEC. SPEC may be a package name, or a package @@ -352,6 +352,6 @@ version; if SPEC does not specify an output, return OUTPUT." (package (if (member sub-drv (package-outputs package)) (values package sub-drv) - (leave (_ "package `~a' lacks output `~a'~%") + (leave (G_ "package `~a' lacks output `~a'~%") (package-full-name package) sub-drv)))))) diff --git a/gnu/services.scm b/gnu/services.scm index b1b53fd18b..5c314748da 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -183,7 +183,7 @@ TYPE does not have a default value, an error is raised." (condition (&missing-value-service-error (type type) (location location)) (&message - (message (format #f (_ "~a: no value specified \ + (message (format #f (G_ "~a: no value specified \ for service of type '~a'") (location->string location) (service-type-name type))))))) @@ -624,7 +624,7 @@ kernel." (target-type target-type)) (&message (message - (format #f (_ "no target of type '~a' for service ~s") + (format #f (G_ "no target of type '~a' for service ~s") (service-type-name target-type) service)))))) (x @@ -635,7 +635,7 @@ kernel." (&message (message (format #f - (_ "more than one target service of type '~a'") + (G_ "more than one target service of type '~a'") (service-type-name target-type)))))))))) (fold add-edge edges (service-type-extensions (service-kind service)))) @@ -686,7 +686,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (service #f) (target-type target-type)) (&message - (message (format #f (_ "service of type '~a' not found") + (message (format #f (G_ "service of type '~a' not found") (service-type-name target-type))))))) (x (raise @@ -696,7 +696,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (&message (message (format #f - (_ "more than one target service of type '~a'") + (G_ "more than one target service of type '~a'") (service-type-name target-type))))))))) ;;; services.scm ends here. diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 5831220541..7281746ab2 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -163,7 +163,7 @@ assertion failure." (raise (condition (&message (message - (format #f (_ "service '~a' provided more than once") + (format #f (G_ "service '~a' provided more than once") symbol))))))) (for-each assert-unique (shepherd-service-provision service)) @@ -178,7 +178,7 @@ assertion failure." (raise (condition (&message (message - (format #f (_ "service '~a' requires '~a', \ + (format #f (G_ "service '~a' requires '~a', \ which is not provided by any service") (match (shepherd-service-provision service) ((head . _) head) diff --git a/gnu/system.scm b/gnu/system.scm index 44190bdfc6..a35a416cb0 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -522,7 +522,7 @@ This is for backward-compatibility of fields that used to be strings and are now file-like objects.." (match thing ((? string?) - (warning (_ "using a string for file '~a' is deprecated; \ + (warning (G_ "using a string for file '~a' is deprecated; \ use 'plain-file' instead~%") file-name) (plain-file file-name thing)) @@ -538,7 +538,7 @@ and are now file-like objects." (with-monad %store-monad (match thing ((? procedure?) - (warning (_ "using a monadic value for '~a' is deprecated; \ + (warning (G_ "using a monadic value for '~a' is deprecated; \ use 'plain-file' instead~%") file-name) thing) @@ -680,7 +680,7 @@ hardware-related operations as necessary when booting a Linux container." (#f (raise (condition (&message - (message (format #f (_ "~a: invalid locale name") name)))))) + (message (format #f (G_ "~a: invalid locale name") name)))))) (def def))) (define (operating-system-locale-directory os) @@ -862,7 +862,7 @@ this file is the reconstruction of GRUB menu entries for old configurations." (_ ;the old format "/"))))) (x ;unsupported format - (warning (_ "unrecognized boot parameters for '~a'~%") + (warning (G_ "unrecognized boot parameters for '~a'~%") system) #f))) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 1acfcc4866..b30ef8e390 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -220,7 +220,7 @@ set debug-file-directory ~/.guix-profile/lib/debug\n"))) (raise (condition (&message (message - (format #f (_ "supplementary group '~a' \ + (format #f (G_ "supplementary group '~a' \ of user '~a' is undeclared") group (user-account-name user)))))))) @@ -230,7 +230,7 @@ of user '~a' is undeclared") (raise (condition (&message (message - (format #f (_ "primary group '~a' \ + (format #f (G_ "primary group '~a' \ of user '~a' is undeclared") (user-account-group user) (user-account-name user))))))) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index ef8f9000dc..ac0ed5ab2d 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -166,7 +166,7 @@ and 'interactive' (default)." (define (receive?) (let ((answer - (begin (format #t (_ "~a~a~%") + (begin (format #t (G_ "~a~a~%") "Would you like to download this key " "and add it to your keyring?") (read-line)))) diff --git a/guix/http-client.scm b/guix/http-client.scm index 6874c51db6..3c5441c38c 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -262,7 +262,7 @@ Raise an '&http-get-error' condition if downloading fails." 302) ; found (redirection) (let ((uri (resolve-uri-reference (response-location resp) uri))) (close-port port) - (format #t (_ "following redirection to `~a'...~%") + (format #t (G_ "following redirection to `~a'...~%") (uri->string uri)) (loop uri))) (else @@ -274,7 +274,7 @@ Raise an '&http-get-error' condition if downloading fails." (message (format #f - (_ "~a: HTTP download failed: ~a (~s)") + (G_ "~a: HTTP download failed: ~a (~s)") (uri->string uri) code (response-reason-phrase resp)))))))))))) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index b19d56ddcf..32c5c310e1 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -288,7 +288,7 @@ META." ;; Warn about inputs that are part of perl's core (unless (null? core-inputs) (for-each (lambda (module) - (warning (_ "input '~a' of ~a is in Perl core~%") + (warning (G_ "input '~a' of ~a is in Perl core~%") module (package-name package))) core-inputs))) (let ((version (cpan-version meta)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index b1003304d0..858eea88e2 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -82,7 +82,7 @@ NAMES (strings)." ;; Use a relatively small TTL for the archive itself. (parameterize ((%http-cache-ttl (* 6 3600))) (call-with-downloaded-file url read)) - (leave (_ "~A: currently not supported~%") repo)))) + (leave (G_ "~A: currently not supported~%") repo)))) (define* (call-with-downloaded-file url proc #:optional (error-thunk #f)) "Fetch URL, store the content in a temporary file and call PROC with that @@ -94,7 +94,7 @@ return its value or leave if it's false." (lambda (key . args) (if error-thunk (error-thunk) - (leave (_ "~A: download failed~%") url))))) + (leave (G_ "~A: download failed~%") url))))) (define (is-elpa-package? name elpa-pkg-spec) "Return true if the string NAME corresponds to the name of the package diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 1e433e3fb3..4f9518f2eb 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -132,7 +132,7 @@ extracted in the current directory, and will be deleted." (string-drop-right basename 8)) (else (begin - (warning (_ "Unsupported archive format: \ + (warning (G_ "Unsupported archive format: \ cannot determine package dependencies")) #f))))) @@ -215,7 +215,7 @@ cannot determine package dependencies")) (delete-file req-file) (rmdir dirname))) (begin - (warning (_ "'tar xf' failed with exit code ~a\n") + (warning (G_ "'tar xf' failed with exit code ~a\n") exit-code) '()))) '()))) @@ -279,7 +279,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (and package (guard (c ((missing-source-error? c) (let ((package (missing-source-error-package c))) - (leave (_ "no source release for pypi package ~a ~a~%") + (leave (G_ "no source release for pypi package ~a ~a~%") (assoc-ref* package "info" "name") (assoc-ref* package "info" "version"))))) (let ((name (assoc-ref* package "info" "name")) diff --git a/guix/nar.scm b/guix/nar.scm index 739d3d3a57..9b4c608238 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -208,7 +208,7 @@ s-expression")) (hash (get-hash)) (has-sig? (= 1 (read-int port)))) (format log-port - (_ "importing file or directory '~a'...~%") + (G_ "importing file or directory '~a'...~%") file) ;; The signature may contain characters that are meant to be @@ -219,7 +219,7 @@ s-expression")) (begin (assert-valid-signature sig hash file) (format log-port - (_ "found valid signature for '~a'~%") + (G_ "found valid signature for '~a'~%") file) (finalize-store-file temp file #:references refs diff --git a/guix/scripts.scm b/guix/scripts.scm index bbee50bc3d..da35e71ac2 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -50,7 +50,7 @@ reporting." operand-proc seeds)) (lambda (key proc msg args . rest) ;; XXX: MSG is not i18n'd. - (leave (_ "invalid argument: ~a~%") + (leave (G_ "invalid argument: ~a~%") (apply format #f msg args))))) (define (environment-build-options) @@ -76,7 +76,7 @@ parameter of 'args-fold'." ;; Actual parsing takes place here. (apply args-fold* args options (lambda (opt name arg . rest) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) argument-handler seeds)) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 8137455a9d..5ea19784dc 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -58,41 +58,41 @@ (verbosity . 0))) (define (show-help) - (display (_ "Usage: guix archive [OPTION]... PACKAGE... + (display (G_ "Usage: guix archive [OPTION]... PACKAGE... Export/import one or more packages from/to the store.\n")) - (display (_ " + (display (G_ " --export export the specified files/packages to stdout")) - (display (_ " + (display (G_ " -r, --recursive combined with '--export', include dependencies")) - (display (_ " + (display (G_ " --import import from the archive passed on stdin")) - (display (_ " + (display (G_ " --missing print the files from stdin that are missing")) - (display (_ " + (display (G_ " -x, --extract=DIR extract the archive on stdin to DIR")) (newline) - (display (_ " + (display (G_ " --generate-key[=PARAMETERS] generate a key pair with the given parameters")) - (display (_ " + (display (G_ " --authorize authorize imports signed by the public key on stdin")) (newline) - (display (_ " + (display (G_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) - (display (_ " + (display (G_ " -S, --source build the packages' source derivations")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) (newline) (show-build-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -140,7 +140,7 @@ Export/import one or more packages from/to the store.\n")) (or arg %key-generation-parameters)))) (alist-cons 'generate-key params result))) (lambda (key proc err) - (leave (_ "invalid key generation parameters: ~a: ~a~%") + (leave (G_ "invalid key generation parameters: ~a: ~a~%") (error-source err) (error-string err)))))) (option '("authorize") #f #f @@ -179,7 +179,7 @@ derivation of a package." (let ((source (package-source p))) (if source (package-source-derivation store source) - (leave (_ "package `~a' has no source~%") + (leave (G_ "package `~a' has no source~%") (package-name p)))) (package-derivation store p system))) ((? procedure? proc) @@ -248,25 +248,25 @@ resulting archive to the standard output port." (build-derivations store drv)) (export-paths store files (current-output-port) #:recursive? (assoc-ref opts 'export-recursive?)) - (leave (_ "unable to export the given packages~%"))))) + (leave (G_ "unable to export the given packages~%"))))) (define (generate-key-pair parameters) "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the right place." (when (or (file-exists? %public-key-file) (file-exists? %private-key-file)) - (leave (_ "key pair exists under '~a'; remove it first~%") + (leave (G_ "key pair exists under '~a'; remove it first~%") (dirname %public-key-file))) (format (current-error-port) - (_ "Please wait while gathering entropy to generate the key pair; + (G_ "Please wait while gathering entropy to generate the key pair; this may take time...~%")) (let* ((pair (catch 'gcry-error (lambda () (generate-key parameters)) (lambda (key proc err) - (leave (_ "key generation failed: ~a: ~a~%") + (leave (G_ "key generation failed: ~a: ~a~%") (error-source err) (error-string err))))) (public (find-sexp-token pair 'public-key)) @@ -293,13 +293,13 @@ the input port." (lambda () (string->canonical-sexp (read-string (current-input-port)))) (lambda (key proc err) - (leave (_ "failed to read public key: ~a: ~a~%") + (leave (G_ "failed to read public key: ~a: ~a~%") (error-source err) (error-string err))))) (let ((key (read-key)) (acl (current-acl))) (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) - (leave (_ "s-expression does not denote a public key~%"))) + (leave (G_ "s-expression does not denote a public key~%"))) ;; Add KEY to the ACL and write that. (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) @@ -345,5 +345,5 @@ the input port." (restore-file (current-input-port) target))) (else (leave - (_ "either '--export' or '--import' \ + (G_ "either '--export' or '--import' \ must be specified~%")))))))))))) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index d9a312f1da..8b19dc871b 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -56,7 +56,7 @@ both the hash and the actual signature." ".pub") read-canonical-sexp) (leave - (_ "cannot find public key for secret key '~a'~%") + (G_ "cannot find public key for secret key '~a'~%") key-file))) (data (read-hash-data port (key-type public-key))) (signature (signature-sexp data secret-key public-key))) @@ -76,11 +76,11 @@ to stdout upon success." (let ((hash (hash-data->bytevector data))) (display (bytevector->base16-string hash)) #t) ; success - (leave (_ "error: invalid signature: ~a~%") + (leave (G_ "error: invalid signature: ~a~%") (canonical-sexp->string signature))) - (leave (_ "error: unauthorized public key: ~a~%") + (leave (G_ "error: unauthorized public key: ~a~%") (canonical-sexp->string subject))) - (leave (_ "error: corrupt signature data: ~a~%") + (leave (G_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) @@ -118,12 +118,12 @@ to stdout upon success." (("rsautl" "-verify" "-inkey" _ "-pubin") (validate-signature (current-input-port))) (("--help") - (display (_ "Usage: guix authenticate OPTION... + (display (G_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to be used internally by 'guix-daemon'.\n"))) (("--version") (show-version-and-exit "guix authenticate")) (else - (leave (_ "wrong arguments")))))) + (leave (G_ "wrong arguments")))))) ;;; authenticate.scm ends here diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 6bb1f72eb9..558e8e7719 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -121,7 +121,7 @@ found. Return #f if no build log was found." 0 paths)))) (lambda args - (leave (_ "failed to create GC root `~a': ~a~%") + (leave (G_ "failed to create GC root `~a': ~a~%") root (strerror (system-error-errno args))))))) (define register-root* @@ -203,7 +203,7 @@ could not be found." (proc (specification->package old) (specification->package new))) (x - (leave (_ "invalid replacement specification: ~s~%") spec)))) + (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) (define (transform-package-inputs replacement-specs) @@ -260,13 +260,13 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (parser 'with-graft))))) (define (show-transformation-options-help) - (display (_ " + (display (G_ " --with-source=SOURCE use SOURCE when building the corresponding package")) - (display (_ " + (display (G_ " --with-input=PACKAGE=REPLACEMENT replace dependency PACKAGE by REPLACEMENT")) - (display (_ " + (display (G_ " --with-graft=PACKAGE=REPLACEMENT graft REPLACEMENT on packages that refer to PACKAGE"))) @@ -291,7 +291,7 @@ derivation, etc.), applies the transformations specified by OPTS." (((name . transform) obj) (let ((new (transform store obj))) (when (eq? new obj) - (warning (_ "transformation '~a' had no effect on ~a~%") + (warning (G_ "transformation '~a' had no effect on ~a~%") name (if (package? obj) (package-full-name obj) @@ -309,37 +309,37 @@ derivation, etc.), applies the transformations specified by OPTS." "Display on the current output port help about the standard command-line options handled by 'set-build-options-from-command-line', and listed in '%standard-build-options'." - (display (_ " + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) - (display (_ " + (display (G_ " -K, --keep-failed keep build tree of failed builds")) - (display (_ " + (display (G_ " -k, --keep-going keep going when some of the derivations fail")) - (display (_ " + (display (G_ " -n, --dry-run do not build the derivations")) - (display (_ " + (display (G_ " --fallback fall back to building when the substituter fails")) - (display (_ " + (display (G_ " --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " + (display (G_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) - (display (_ " + (display (G_ " --no-grafts do not graft packages")) - (display (_ " + (display (G_ " --no-build-hook do not attempt to offload builds via the build hook")) - (display (_ " + (display (G_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) - (display (_ " + (display (G_ " --timeout=SECONDS mark the build as failed after SECONDS of activity")) - (display (_ " + (display (G_ " --verbosity=LEVEL use the given verbosity LEVEL")) - (display (_ " + (display (G_ " --rounds=N build N times in a row to detect non-determinism")) - (display (_ " + (display (G_ " -c, --cores=N allow the use of up to N CPU cores for the build")) - (display (_ " + (display (G_ " -M, --max-jobs=N allow at most N build jobs"))) (define (set-build-options-from-command-line store opts) @@ -445,14 +445,14 @@ options handled by 'set-build-options-from-command-line', and listed in (let ((c (false-if-exception (string->number arg)))) (if c (apply values (alist-cons 'cores c result) rest) - (leave (_ "not a number: '~a' option argument: ~a~%") + (leave (G_ "not a number: '~a' option argument: ~a~%") name arg))))) (option '(#\M "max-jobs") #t #f (lambda (opt name arg result . rest) (let ((c (false-if-exception (string->number arg)))) (if c (apply values (alist-cons 'max-jobs c result) rest) - (leave (_ "not a number: '~a' option argument: ~a~%") + (leave (G_ "not a number: '~a' option argument: ~a~%") name arg))))))) @@ -471,43 +471,43 @@ options handled by 'set-build-options-from-command-line', and listed in (verbosity . 0))) (define (show-help) - (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... + (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) - (display (_ " + (display (G_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) - (display (_ " + (display (G_ " -f, --file=FILE build the package or derivation that the code within FILE evaluates to")) - (display (_ " + (display (G_ " -S, --source build the packages' source derivations")) - (display (_ " + (display (G_ " --sources[=TYPE] build source derivations; TYPE may optionally be one of \"package\", \"all\" (default), or \"transitive\"")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " + (display (G_ " -d, --derivations return the derivation paths of the given packages")) - (display (_ " + (display (G_ " --check rebuild items to check for non-determinism issues")) - (display (_ " + (display (G_ " --repair repair the specified items")) - (display (_ " + (display (G_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) - (display (_ " + (display (G_ " -q, --quiet do not show the build log")) - (display (_ " + (display (G_ " --log-file return the log file names for the given derivations")) (newline) (show-build-options-help) (newline) (show-transformation-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -534,7 +534,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ("transitive" (alist-cons 'source package-transitive-sources result)) (else - (leave (_ "invalid argument: '~a' option argument: ~a, ~ + (leave (G_ "invalid argument: '~a' option argument: ~a, ~ must be one of 'package', 'all', or 'transitive'~%") name arg))))) (option '("check") #f #f @@ -587,7 +587,7 @@ must be one of 'package', 'all', or 'transitive'~%") build---packages, gexps, derivations, and so on." (define (validate-type x) (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) - (leave (_ "~s: not something we can build~%") x))) + (leave (G_ "~s: not something we can build~%") x))) (define (ensure-list x) (let ((lst (match x @@ -641,7 +641,7 @@ build." (match (package-source p) (#f (format (current-error-port) - (_ "~a: warning: \ + (G_ "~a: warning: \ package '~a' has no source~%") (location->string (package-location p)) (package-name p)) @@ -675,7 +675,7 @@ needed." (log-url store file #:base-urls urls)))) (if log (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") file)))) + (leave (G_ "no build log for '~a'~%") file)))) ;;; diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 815bb789c3..681394f9cf 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -188,10 +188,10 @@ object. When VERBOSE?, display matches in addition to mismatches and inconclusive reports." (define (report-hashes item local narinfos) (if local - (report (_ " local hash: ~a~%") (hash->string local)) - (report (_ " no local build for '~a'~%") item)) + (report (G_ " local hash: ~a~%") (hash->string local)) + (report (G_ " no local build for '~a'~%") item)) (for-each (lambda (narinfo) - (report (_ " ~50a: ~a~%") + (report (G_ " ~50a: ~a~%") (uri->string (narinfo-uri narinfo)) (hash->string (narinfo-hash->sha256 (narinfo-hash narinfo))))) @@ -199,15 +199,15 @@ inconclusive reports." (match comparison-report (($ item 'mismatch local (narinfos ...)) - (report (_ "~a contents differ:~%") item) + (report (G_ "~a contents differ:~%") item) (report-hashes item local narinfos)) (($ item 'inconclusive #f narinfos) - (warning (_ "could not challenge '~a': no local build~%") item)) + (warning (G_ "could not challenge '~a': no local build~%") item)) (($ item 'inconclusive locals ()) - (warning (_ "could not challenge '~a': no substitutes~%") item)) + (warning (G_ "could not challenge '~a': no substitutes~%") item)) (($ item 'match local (narinfos ...)) (when verbose? - (report (_ "~a contents match:~%") item) + (report (G_ "~a contents match:~%") item) (report-hashes item local narinfos))))) @@ -216,17 +216,17 @@ inconclusive reports." ;;; (define (show-help) - (display (_ "Usage: guix challenge [PACKAGE...] + (display (G_ "Usage: guix challenge [PACKAGE...] Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) - (display (_ " + (display (G_ " --substitute-urls=URLS compare build results with those at URLS")) - (display (_ " + (display (G_ " -v, --verbose show details about successful comparisons")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm index cd9f345b68..10aed2be75 100644 --- a/guix/scripts/container.scm +++ b/guix/scripts/container.scm @@ -22,17 +22,17 @@ #:export (guix-container)) (define (show-help) - (display (_ "Usage: guix container ACTION ARGS... + (display (G_ "Usage: guix container ACTION ARGS... Build and manipulate Linux containers.\n")) (newline) - (display (_ "The valid values for ACTION are:\n")) + (display (G_ "The valid values for ACTION are:\n")) (newline) - (display (_ "\ + (display (G_ "\ exec execute a command inside of an existing container\n")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -50,7 +50,7 @@ Build and manipulate Linux containers.\n")) (match args (() (format (current-error-port) - (_ "guix container: missing action~%"))) + (G_ "guix container: missing action~%"))) ((or ("-h") ("--help")) (show-help) (exit 0)) @@ -60,4 +60,4 @@ Build and manipulate Linux containers.\n")) (if (member action %actions) (apply (resolve-action action) args) (format (current-error-port) - (_ "guix container: invalid action~%"))))))) + (G_ "guix container: invalid action~%"))))))) diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index d6d267daff..d598f5cac4 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -37,12 +37,12 @@ (show-version-and-exit "guix container exec"))))) (define (show-help) - (display (_ "Usage: guix container exec PID COMMAND [ARGS...] + (display (G_ "Usage: guix container exec PID COMMAND [ARGS...] Execute COMMMAND within the container process PID.\n")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -66,7 +66,7 @@ and the other containing arguments for the command to be executed." (define (guix-container-exec . args) (define (handle-argument arg result) (if (assoc-ref result 'pid) - (leave (_ "~a: extraneous argument~%") arg) + (leave (G_ "~a: extraneous argument~%") arg) (alist-cons 'pid (string->number* arg) result))) (with-error-handling @@ -84,13 +84,13 @@ and the other containing arguments for the command to be executed." '("TERM")))) (unless pid - (leave (_ "no pid specified~%"))) + (leave (G_ "no pid specified~%"))) (when (null? command) - (leave (_ "no command specified~%"))) + (leave (G_ "no command specified~%"))) (unless (file-exists? (string-append "/proc/" (number->string pid))) - (leave (_ "no such process ~d~%") pid)) + (leave (G_ "no such process ~d~%") pid)) (let ((result (container-excursion pid (lambda () @@ -102,4 +102,4 @@ and the other containing arguments for the command to be executed." environment) (apply execlp program program program-args))))))) (unless (zero? result) - (leave (_ "exec failed with status ~d~%") result))))))) + (leave (G_ "exec failed with status ~d~%") result))))))) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index bc225044fb..45f7cbbad5 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -56,9 +56,9 @@ number (or #f) corresponding to SPEC." ((? integer? port) (values user host port)) (x - (leave (_ "~a: invalid TCP port number~%") port)))) + (leave (G_ "~a: invalid TCP port number~%") port)))) (x - (leave (_ "~a: invalid SSH specification~%") spec)))) + (leave (G_ "~a: invalid SSH specification~%") spec)))) (define (send-to-remote-host target opts) "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; @@ -109,18 +109,18 @@ package names, build the underlying packages before sending them." ;;; (define (show-help) - (display (_ "Usage: guix copy [OPTION]... ITEMS... + (display (G_ "Usage: guix copy [OPTION]... ITEMS... Copy ITEMS to or from the specified host over SSH.\n")) - (display (_ " + (display (G_ " --to=HOST send ITEMS to HOST")) - (display (_ " + (display (G_ " --from=HOST receive ITEMS from HOST")) (newline) (show-build-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -165,4 +165,4 @@ Copy ITEMS to or from the specified host over SSH.\n")) (target (assoc-ref opts 'destination))) (cond (target (send-to-remote-host target opts)) (source (retrieve-from-remote-host source opts)) - (else (leave (_ "use '--to' or '--from'~%"))))))) + (else (leave (G_ "use '--to' or '--from'~%"))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1ddfd648cd..bb3dc76741 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -64,23 +64,23 @@ (download-proc . ,download-to-store*))) (define (show-help) - (display (_ "Usage: guix download [OPTION] URL + (display (G_ "Usage: guix download [OPTION] URL Download the file at URL to the store or to the given file, and print its file name and the hash of its contents. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) - (format #t (_ " + (format #t (G_ " -f, --format=FMT write the hash in the given format")) - (format #t (_ " + (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) - (format #f (_ " + (format #f (G_ " -o, --output=FILE download to FILE")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -98,7 +98,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (leave (_ "unsupported hash format: ~a~%") arg)))) + (leave (G_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc (alist-delete 'format result)))) @@ -130,10 +130,10 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (when (assq 'argument result) - (leave (_ "~A: extraneous argument~%") arg)) + (leave (G_ "~A: extraneous argument~%") arg)) (alist-cons 'argument arg result)) %default-options)) @@ -141,9 +141,9 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (with-error-handling (let* ((opts (parse-options)) (arg (or (assq-ref opts 'argument) - (leave (_ "no download URI was specified~%")))) + (leave (G_ "no download URI was specified~%")))) (uri (or (string->uri arg) - (leave (_ "~a: failed to parse URI~%") + (leave (G_ "~a: failed to parse URI~%") arg))) (fetch (assq-ref opts 'download-proc)) (path (parameterize ((current-terminal-columns @@ -153,7 +153,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (assq-ref opts 'verify-certificate?)))) (hash (call-with-input-file (or path - (leave (_ "~a: download failed~%") + (leave (G_ "~a: download failed~%") arg)) port-sha256)) (fmt (assq-ref opts 'format))) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 555796a69c..8b2b61d76a 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -38,12 +38,12 @@ (show-version-and-exit "guix edit"))))) (define (show-help) - (display (_ "Usage: guix edit PACKAGE... + (display (G_ "Usage: guix edit PACKAGE... Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -59,7 +59,7 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (let ((absolute-file-name (search-path path file))) (unless absolute-file-name ;; Shouldn't happen unless somebody fiddled with the 'location' field. - (leave (_ "file '~a' not found in search path ~s~%") + (leave (G_ "file '~a' not found in search path ~s~%") file path)) absolute-file-name)) @@ -78,7 +78,7 @@ line." ;; Return the list of package names. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) cons '())) @@ -87,7 +87,7 @@ line." (packages (map specification->package specs))) (for-each (lambda (package) (unless (package-location package) - (leave (_ "source location of package '~a' is unknown~%") + (leave (G_ "source location of package '~a' is unknown~%") (package-full-name package)))) packages) @@ -100,5 +100,5 @@ line." (exit (system (string-join (cons (%editor) file-names)))))) (lambda args (let ((errno (system-error-errno args))) - (leave (_ "failed to launch '~a': ~a~%") + (leave (G_ "failed to launch '~a': ~a~%") (%editor) (strerror errno)))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 5a6abd00fb..0b2b964bf7 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -132,45 +132,45 @@ and an output string." (package->bag package))))) (define (show-help) - (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] + (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] Build an environment that includes the dependencies of PACKAGE and execute COMMAND or an interactive shell in that environment.\n")) - (display (_ " + (display (G_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) - (display (_ " + (display (G_ " -l, --load=FILE create environment for the package that the code within FILE evaluates to")) - (display (_ " + (display (G_ " --ad-hoc include all specified packages in the environment instead of only their inputs")) - (display (_ " + (display (G_ " --pure unset existing environment variables")) - (display (_ " + (display (G_ " --search-paths display needed environment variable definitions")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) - (display (_ " + (display (G_ " -C, --container run command within an isolated container")) - (display (_ " + (display (G_ " -N, --network allow containers to access the network")) - (display (_ " + (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) - (display (_ " + (display (G_ " --expose=SPEC for containers, expose read-only host file system according to SPEC")) - (display (_ " + (display (G_ " --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -501,16 +501,16 @@ Otherwise, return the derivation for the Bash package." "Check if containers can be created and exit with an informative error message if any test fails." (unless (user-namespace-supported?) - (report-error (_ "cannot create container: user namespaces unavailable\n")) - (leave (_ "is your kernel version < 3.10?\n"))) + (report-error (G_ "cannot create container: user namespaces unavailable\n")) + (leave (G_ "is your kernel version < 3.10?\n"))) (unless (unprivileged-user-namespace-supported?) - (report-error (_ "cannot create container: unprivileged user cannot create user namespaces\n")) - (leave (_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) + (report-error (G_ "cannot create container: unprivileged user cannot create user namespaces\n")) + (leave (G_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) (unless (setgroups-supported?) - (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) - (leave (_ "is your kernel version < 3.19?\n")))) + (report-error (G_ "cannot create container: /proc/self/setgroups does not exist\n")) + (leave (G_ "is your kernel version < 3.19?\n")))) (define (register-gc-root target root) "Make ROOT an indirect root to TARGET. This is procedure is idempotent." diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index bdfee4308c..221467a108 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -39,41 +39,41 @@ `((action . collect-garbage))) (define (show-help) - (display (_ "Usage: guix gc [OPTION]... PATHS... + (display (G_ "Usage: guix gc [OPTION]... PATHS... Invoke the garbage collector.\n")) - (display (_ " + (display (G_ " -C, --collect-garbage[=MIN] collect at least MIN bytes of garbage")) - (display (_ " + (display (G_ " -F, --free-space=FREE attempt to reach FREE available space in the store")) - (display (_ " + (display (G_ " -d, --delete attempt to delete PATHS")) - (display (_ " + (display (G_ " --optimize optimize the store by deduplicating identical files")) - (display (_ " + (display (G_ " --list-dead list dead paths")) - (display (_ " + (display (G_ " --list-live list live paths")) (newline) - (display (_ " + (display (G_ " --references list the references of PATHS")) - (display (_ " + (display (G_ " -R, --requisites list the requisites of PATHS")) - (display (_ " + (display (G_ " --referrers list the referrers of PATHS")) (newline) - (display (_ " + (display (G_ " --verify[=OPTS] verify the integrity of the store; OPTS is a comma-separated combination of 'repair' and 'contents'")) - (display (_ " + (display (G_ " --list-failures list cached build failures")) - (display (_ " + (display (G_ " --clear-failures remove PATHS from the set of cached failures")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -97,7 +97,7 @@ Invoke the garbage collector.\n")) (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (leave (_ "invalid amount of storage: ~a~%") + (leave (G_ "invalid amount of storage: ~a~%") arg)))) (#f result))))) (option '(#\F "free-space") #t #f @@ -161,7 +161,7 @@ Invoke the garbage collector.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -188,10 +188,10 @@ Invoke the garbage collector.\n")) (free (* (file-system-block-size fs) (file-system-blocks-available fs)))) (if (> free space) - (info (_ "already ~h bytes available on ~a, nothing to do~%") + (info (G_ "already ~h bytes available on ~a, nothing to do~%") free (%store-prefix)) (let ((to-free (- space free))) - (info (_ "freeing ~h bytes~%") to-free) + (info (G_ "freeing ~h bytes~%") to-free) (collect-garbage store to-free))))) (with-error-handling @@ -203,7 +203,7 @@ Invoke the garbage collector.\n")) opts))) (define (assert-no-extra-arguments) (unless (null? paths) - (leave (_ "extraneous arguments: ~{~a ~}~%") paths))) + (leave (G_ "extraneous arguments: ~{~a ~}~%") paths))) (define (list-relatives relatives) (for-each (compose (lambda (path) @@ -223,10 +223,10 @@ Invoke the garbage collector.\n")) (ensure-free-space store free-space)) (min-freed (let-values (((paths freed) (collect-garbage store min-freed))) - (info (_ "freed ~h bytes~%") freed))) + (info (G_ "freed ~h bytes~%") freed))) (else (let-values (((paths freed) (collect-garbage store))) - (info (_ "freed ~h bytes~%") freed)))))) + (info (G_ "freed ~h bytes~%") freed)))))) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 9804d41929..0af1fa3ad3 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -81,7 +81,7 @@ name." (raise (condition (&message - (message (format #f (_ "~a: invalid argument (package name expected)") + (message (format #f (G_ "~a: invalid argument (package name expected)") x)))))))) (define nodes-from-package @@ -305,7 +305,7 @@ substitutes." ((info) (values (substitutable-references info) store)) (() - (leave (_ "references for '~a' are not known~%") + (leave (G_ "references for '~a' are not known~%") item))))) (values (references store item) store)))) @@ -355,18 +355,18 @@ substitutes." (or (find (lambda (type) (string=? (node-type-name type) name)) %node-types) - (leave (_ "~a: unknown node type~%") name))) + (leave (G_ "~a: unknown node type~%") name))) (define (lookup-backend name) "Return the graph backend called NAME. Raise an error if it is not found." (or (find (lambda (backend) (string=? (graph-backend-name backend) name)) %graph-backends) - (leave (_ "~a: unknown backend~%") name))) + (leave (G_ "~a: unknown backend~%") name))) (define (list-node-types) "Print the available node types along with their synopsis." - (display (_ "The available node types are:\n")) + (display (G_ "The available node types are:\n")) (newline) (for-each (lambda (type) (format #t " - ~a: ~a~%" @@ -376,7 +376,7 @@ substitutes." (define (list-backends) "Print the available backends along with their synopsis." - (display (_ "The available backend types are:\n")) + (display (G_ "The available backend types are:\n")) (newline) (for-each (lambda (backend) (format #t " - ~a: ~a~%" @@ -420,22 +420,22 @@ substitutes." (define (show-help) ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be ;; translated. - (display (_ "Usage: guix graph PACKAGE... + (display (G_ "Usage: guix graph PACKAGE... Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) - (display (_ " + (display (G_ " -b, --backend=TYPE produce a graph with the given backend TYPE")) - (display (_ " + (display (G_ " --list-backends list the available graph backends")) - (display (_ " + (display (G_ " -t, --type=TYPE represent nodes of the given TYPE")) - (display (_ " + (display (G_ " --list-types list the available graph types")) - (display (_ " + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -453,7 +453,7 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (with-error-handling (let* ((opts (args-fold* args %options (lambda (opt name arg . rest) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index a048b53461..1fa6bb8d1f 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -44,21 +44,21 @@ `((format . ,bytevector->nix-base32-string))) (define (show-help) - (display (_ "Usage: guix hash [OPTION] FILE + (display (G_ "Usage: guix hash [OPTION] FILE Return the cryptographic hash of FILE. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) - (format #t (_ " + (format #t (G_ " -x, --exclude-vcs exclude version control directories")) - (format #t (_ " + (format #t (G_ " -f, --format=FMT write the hash in the given format")) - (format #t (_ " + (format #t (G_ " -r, --recursive compute the hash on FILE recursively")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -79,7 +79,7 @@ and 'hexadecimal' can be used as well).\n")) ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (leave (_ "unsupported hash format: ~a~%") + (leave (G_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc @@ -106,7 +106,7 @@ and 'hexadecimal' can be used as well).\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "unrecognized option: ~a~%") + (leave (G_ "unrecognized option: ~a~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) @@ -152,7 +152,7 @@ and 'hexadecimal' can be used as well).\n")) (lambda () (format #t "~a~%" (fmt (file-hash file)))) (lambda args - (leave (_ "~a~%") + (leave (G_ "~a~%") (strerror (system-error-errno args)))))) (x - (leave (_ "wrong number of arguments~%")))))) + (leave (G_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 8c2f705738..203cda8049 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -83,15 +83,15 @@ rather than \\n." (module-ref module proc))) (define (show-help) - (display (_ "Usage: guix import IMPORTER ARGS ... + (display (G_ "Usage: guix import IMPORTER ARGS ... Run IMPORTER with ARGS.\n")) (newline) - (display (_ "IMPORTER must be one of the importers listed below:\n")) + (display (G_ "IMPORTER must be one of the importers listed below:\n")) (newline) (format #t "~{ ~a~%~}" importers) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -100,7 +100,7 @@ Run IMPORTER with ARGS.\n")) (match args (() (format (current-error-port) - (_ "guix import: missing importer name~%"))) + (G_ "guix import: missing importer name~%"))) ((or ("-h") ("--help")) (show-help) (exit 0)) @@ -120,5 +120,5 @@ Run IMPORTER with ARGS.\n")) (newline)) expressions)) (x - (leave (_ "'~a' import failed~%") importer)))) - (leave (_ "~a: invalid importer~%") importer))))) + (leave (G_ "'~a' import failed~%") importer)))) + (leave (G_ "~a: invalid importer~%") importer))))) diff --git a/guix/scripts/import/cpan.scm b/guix/scripts/import/cpan.scm index 3d470f684d..77ffe1f38e 100644 --- a/guix/scripts/import/cpan.scm +++ b/guix/scripts/import/cpan.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import cpan PACKAGE-NAME + (display (G_ "Usage: guix import cpan PACKAGE-NAME Import and convert the CPAN package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -83,10 +83,10 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (cpan->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index c9a9eab762..d65c644c05 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -40,13 +40,13 @@ '()) (define (show-help) - (display (_ "Usage: guix import cran PACKAGE-NAME + (display (G_ "Usage: guix import cran PACKAGE-NAME Import and convert the CRAN package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -a, --archive=ARCHIVE specify the archive repository")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -79,7 +79,7 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -105,10 +105,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) (unless sexp - (leave (_ "failed to download description for package '~a'~%") + (leave (G_ "failed to download description for package '~a'~%") package-name)) sexp))) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 4337a0b623..cab9a4397b 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -40,11 +40,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import crate PACKAGE-NAME + (display (G_ "Usage: guix import crate PACKAGE-NAME Import and convert the crate.io package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -70,7 +70,7 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -85,10 +85,10 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (crate->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index b22a7c4c23..34eb16485e 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -38,13 +38,13 @@ '((repo . gnu))) (define (show-help) - (display (_ "Usage: guix import elpa PACKAGE-NAME + (display (G_ "Usage: guix import elpa PACKAGE-NAME Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) - (display (_ " + (display (G_ " -a, --archive=ARCHIVE specify the archive repository")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -74,7 +74,7 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -89,11 +89,11 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) ((package-name) (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) (unless sexp - (leave (_ "failed to download package '~a'~%") package-name)) + (leave (G_ "failed to download package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) ;;; elpa.scm ends here diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index a5dd2a7822..349a0a072a 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import gem PACKAGE-NAME + (display (G_ "Usage: guix import gem PACKAGE-NAME Import and convert the RubyGems package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -83,10 +83,10 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (gem->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/gnu.scm b/guix/scripts/import/gnu.scm index 66861f5837..ae98370037 100644 --- a/guix/scripts/import/gnu.scm +++ b/guix/scripts/import/gnu.scm @@ -37,18 +37,18 @@ '((key-download . interactive))) (define (show-help) - (display (_ "Usage: guix import gnu [OPTION...] PACKAGE + (display (G_ "Usage: guix import gnu [OPTION...] PACKAGE Return a package declaration template for PACKAGE, a GNU package.\n")) ;; '--key-download' taken from (guix scripts refresh). - (display (_ " + (display (G_ " --key-download=POLICY handle missing OpenPGP keys according to POLICY: 'always', 'never', and 'interactive', which is also used when 'key-download' is not specified")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -69,7 +69,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) (alist-cons 'key-download (string->symbol arg) result)) (x - (leave (_ "unsupported policy: ~a~%") + (leave (G_ "unsupported policy: ~a~%") arg))))) %standard-import-options)) @@ -83,7 +83,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -100,6 +100,6 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) (gnu->guix-package name #:key-download (assoc-ref opts 'key-download)))) (x - (leave (_ "wrong number of arguments~%")))))) + (leave (G_ "wrong number of arguments~%")))))) ;;; gnu.scm ends here diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index f2c20026b6..969f637846 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -44,23 +44,23 @@ (cabal-environment . ,`(("impl" . ,ghc-default-version))))) (define (show-help) - (display (_ "Usage: guix import hackage PACKAGE-NAME + (display (G_ "Usage: guix import hackage PACKAGE-NAME Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME includes a suffix constituted by a at-sign followed by a numerical version (as used with Guix packages), then a definition for the specified version of the package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available version.\n")) - (display (_ " + (display (G_ " -e ALIST, --cabal-environment=ALIST specify environment for Cabal evaluation")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -s, --stdin read from standard input")) - (display (_ " + (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -101,7 +101,7 @@ version.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -130,18 +130,18 @@ version.\n")) (() (run-importer "stdin" opts (lambda () - (leave (_ "failed to import cabal file \ + (leave (G_ "failed to import cabal file \ from standard input~%"))))) ((many ...) - (leave (_ "too many arguments~%")))) + (leave (G_ "too many arguments~%")))) (match args ((package-name) (run-importer package-name opts (lambda () - (leave (_ "failed to download cabal file \ + (leave (G_ "failed to download cabal file \ for package '~a'~%") package-name)))) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%"))))))) + (leave (G_ "too many arguments~%"))))))) diff --git a/guix/scripts/import/nix.scm b/guix/scripts/import/nix.scm index 05e6e4b85d..45ca7e3fcf 100644 --- a/guix/scripts/import/nix.scm +++ b/guix/scripts/import/nix.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import nix NIXPKGS ATTRIBUTE + (display (G_ "Usage: guix import nix NIXPKGS ATTRIBUTE Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -87,4 +87,4 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (location-file loc) (location-line loc)) expr)) (x - (leave (_ "wrong number of arguments~%")))))) + (leave (G_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 7166b014eb..59a925a3ca 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import pypi PACKAGE-NAME + (display (G_ "Usage: guix import pypi PACKAGE-NAME Import and convert the PyPI package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -83,10 +83,10 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (pypi->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm index f91b496d24..e6676e93e8 100644 --- a/guix/scripts/import/stackage.scm +++ b/guix/scripts/import/stackage.scm @@ -40,16 +40,16 @@ (include-test-dependencies? . #t))) (define (show-help) - (display (_ "Usage: guix import stackage PACKAGE-NAME + (display (G_ "Usage: guix import stackage PACKAGE-NAME Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -r VERSION, --lts-version=VERSION specify the LTS version to use")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -85,7 +85,7 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -105,12 +105,12 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (assoc-ref opts 'include-test-dependencies?) #:lts-version (assoc-ref opts 'lts-version)))) (unless sexp - (leave (_ "failed to download cabal file for package '~a'~%") + (leave (G_ "failed to download cabal file for package '~a'~%") package-name)) sexp))) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) ;;; stackage.scm ends here diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9e3e2ad95a..f2720f669e 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -132,11 +132,11 @@ monad." (define (list-checkers-and-exit) ;; Print information about all available checkers and exit. - (format #t (_ "Available checkers:~%")) + (format #t (G_ "Available checkers:~%")) (for-each (lambda (checker) (format #t "- ~a: ~a~%" (lint-checker-name checker) - (_ (lint-checker-description checker)))) + (G_ (lint-checker-description checker)))) %checkers) (exit 0)) @@ -156,7 +156,7 @@ monad." (define (check-not-empty description) (when (string-null? description) (emit-warning package - (_ "description should not be empty") + (G_ "description should not be empty") 'description))) (define (check-texinfo-markup description) @@ -166,7 +166,7 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f." (lambda () (texi->plain-text description)) (lambda (keys . args) (emit-warning package - (_ "Texinfo markup in description is invalid") + (G_ "Texinfo markup in description is invalid") 'description) #f))) @@ -176,7 +176,7 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html." (match (string-index description (char-set #\™ #\®)) ((and (? number?) index) (emit-warning package - (format #f (_ "description should not contain ~ + (format #f (G_ "description should not contain ~ trademark sign '~a' at ~d") (string-ref description index) index) 'description)) @@ -189,14 +189,14 @@ trademark sign '~a' at ~d") ;; TRANSLATORS: '@code' is Texinfo markup and must be kept ;; as is. - (_ "use @code or similar ornament instead of quotes") + (G_ "use @code or similar ornament instead of quotes") 'description))) (define (check-proper-start description) (unless (or (properly-starts-sentence? description) (string-prefix-ci? (package-name package) description)) (emit-warning package - (_ "description should start with an upper-case letter or digit") + (G_ "description should start with an upper-case letter or digit") 'description))) (define (check-end-of-sentence-space description) @@ -212,7 +212,7 @@ trademark sign '~a' at ~d") r (cons (match:start m) r))))))) (unless (null? infractions) (emit-warning package - (format #f (_ "sentences in description should be followed ~ + (format #f (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") (length infractions) infractions) @@ -230,7 +230,7 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (and=> (check-texinfo-markup description) check-proper-start)) (emit-warning package - (format #f (_ "invalid description: ~s") description) + (format #f (G_ "invalid description: ~s") description) 'description)))) (define (package-input-intersection inputs-to-check input-names) @@ -274,7 +274,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as (for-each (lambda (input) (emit-warning package - (format #f (_ "'~a' should probably be a native input") + (format #f (G_ "'~a' should probably be a native input") input) 'inputs-to-check)) (package-input-intersection inputs input-names)))) @@ -290,7 +290,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as (emit-warning package (format #f - (_ "'~a' should probably not be an input at all") + (G_ "'~a' should probably not be an input at all") input))) (package-input-intersection (package-direct-inputs package) input-names)))) @@ -307,7 +307,7 @@ line." (define (check-not-empty synopsis) (when (string-null? synopsis) (emit-warning package - (_ "synopsis should not be empty") + (G_ "synopsis should not be empty") 'synopsis))) (define (check-final-period synopsis) @@ -315,7 +315,7 @@ line." (when (and (string-suffix? "." synopsis) (not (string-suffix? "etc." synopsis))) (emit-warning package - (_ "no period allowed at the end of the synopsis") + (G_ "no period allowed at the end of the synopsis") 'synopsis))) (define check-start-article @@ -327,27 +327,27 @@ line." (when (or (string-prefix-ci? "A " synopsis) (string-prefix-ci? "An " synopsis)) (emit-warning package - (_ "no article allowed at the beginning of \ + (G_ "no article allowed at the beginning of \ the synopsis") 'synopsis))))) (define (check-synopsis-length synopsis) (when (>= (string-length synopsis) 80) (emit-warning package - (_ "synopsis should be less than 80 characters long") + (G_ "synopsis should be less than 80 characters long") 'synopsis))) (define (check-proper-start synopsis) (unless (properly-starts-sentence? synopsis) (emit-warning package - (_ "synopsis should start with an upper-case letter or digit") + (G_ "synopsis should start with an upper-case letter or digit") 'synopsis))) (define (check-start-with-package-name synopsis) (when (and (regexp-exec (package-name-regexp package) synopsis) (not (starts-with-abbreviation? synopsis))) (emit-warning package - (_ "synopsis should not start with the package name") + (G_ "synopsis should not start with the package name") 'synopsis))) (define (check-texinfo-markup synopsis) @@ -357,7 +357,7 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." (lambda () (texi->plain-text synopsis)) (lambda (keys . args) (emit-warning package - (_ "Texinfo markup in synopsis is invalid") + (G_ "Texinfo markup in synopsis is invalid") 'synopsis) #f))) @@ -376,7 +376,7 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." (proc synopsis)) checks)) (invalid - (emit-warning package (format #f (_ "invalid synopsis: ~s") invalid) + (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid) 'synopsis)))) (define* (probe-uri uri #:key timeout) @@ -476,7 +476,7 @@ warning for PACKAGE mentionning the FIELD." (begin (emit-warning package (format #f - (_ "URI ~a returned \ + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") (uri->string uri) length)) @@ -485,7 +485,7 @@ suspiciously small file (~a bytes)") (begin (emit-warning package (format #f - (_ "URI ~a not reachable: ~a (~s)") + (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) (response-code argument) (response-reason-phrase argument)) @@ -497,14 +497,14 @@ suspiciously small file (~a bytes)") (('error port command code message) (emit-warning package (format #f - (_ "URI ~a not reachable: ~a (~s)") + (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) code (string-trim-both message))) #f))) ((getaddrinfo-error) (emit-warning package (format #f - (_ "URI ~a domain not found: ~a") + (G_ "URI ~a domain not found: ~a") (uri->string uri) (gai-strerror (car argument))) field) @@ -512,7 +512,7 @@ suspiciously small file (~a bytes)") ((system-error) (emit-warning package (format #f - (_ "URI ~a unreachable: ~a") + (G_ "URI ~a unreachable: ~a") (uri->string uri) (strerror (system-error-errno @@ -521,7 +521,7 @@ suspiciously small file (~a bytes)") #f) ((tls-certificate-error) (emit-warning package - (format #f (_ "TLS certificate error: ~a") + (format #f (G_ "TLS certificate error: ~a") (tls-certificate-error-string argument)))) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. @@ -542,10 +542,10 @@ suspiciously small file (~a bytes)") (unless (or (string-contains (package-name package) "bootstrap") (string=? (package-name package) "ld-wrapper")) (emit-warning package - (_ "invalid value for home page") + (G_ "invalid value for home page") 'home-page))) (else - (emit-warning package (format #f (_ "invalid home page URL: ~s") + (emit-warning package (format #f (G_ "invalid home page URL: ~s") (package-home-page package)) 'home-page))))) @@ -565,7 +565,7 @@ patch could not be found." '())) (emit-warning package - (_ "file names of patches should start with the package name") + (G_ "file names of patches should start with the package name") 'patch-file-names)))) (define (escape-quotes str) @@ -603,7 +603,7 @@ descriptions maintained upstream." (or (not (string? downstream)) (not (string=? upstream downstream)))) (format (guix-warning-port) - (_ "~a: ~a: proposed synopsis: ~s~%") + (G_ "~a: ~a: proposed synopsis: ~s~%") (location->string loc) (package-full-name package) upstream))) @@ -616,7 +616,7 @@ descriptions maintained upstream." (not (string=? (fill-paragraph upstream 100) (fill-paragraph downstream 100))))) (format (guix-warning-port) - (_ "~a: ~a: proposed description:~% \"~a\"~%") + (G_ "~a: ~a: proposed description:~% \"~a\"~%") (location->string loc) (package-full-name package) (fill-paragraph (escape-quotes upstream) 77 7))))))) @@ -658,7 +658,7 @@ descriptions maintained upstream." ;; where *all* the URIs are unreachable. (unless success? (emit-warning package - (_ "all the source URIs are unreachable:") + (G_ "all the source URIs are unreachable:") 'source) (for-each (lambda (warning) (display warning (guix-warning-port))) @@ -681,7 +681,7 @@ descriptions maintained upstream." (let ((origin (package-source package))) (unless (or (not origin) (origin-file-name-valid? origin)) (emit-warning package - (_ "the source file name should contain the package name") + (G_ "the source file name should contain the package name") 'source)))) (define (check-mirror-url package) @@ -697,7 +697,7 @@ descriptions maintained upstream." (loop rest)) (prefix (emit-warning package - (format #f (_ "URL should be \ + (format #f (G_ "URL should be \ 'mirror://~a/~a'") mirror-id (string-drop uri (string-length prefix))) @@ -715,11 +715,11 @@ descriptions maintained upstream." (lambda () (guard (c ((nix-protocol-error? c) (emit-warning package - (format #f (_ "failed to create derivation: ~a") + (format #f (G_ "failed to create derivation: ~a") (nix-protocol-error-message c)))) ((message-condition? c) (emit-warning package - (format #f (_ "failed to create derivation: ~a") + (format #f (G_ "failed to create derivation: ~a") (condition-message c))))) (with-store store ;; Disable grafts since it can entail rebuilds. @@ -733,7 +733,7 @@ descriptions maintained upstream." (package-derivation store replacement #:graft? #f)))))) (lambda args (emit-warning package - (format #f (_ "failed to create derivation: ~s~%") + (format #f (G_ "failed to create derivation: ~s~%") args))))) (define (check-license package) @@ -743,7 +743,7 @@ descriptions maintained upstream." ((? license?) ...)) #t) (x - (emit-warning package (_ "invalid license field") + (emit-warning package (G_ "invalid license field") 'license)))) (define (patch-file-name patch) @@ -760,26 +760,26 @@ be determined." or HTTP errors. This allows network-less operation and makes problems with the NIST server non-fatal.." (guard (c ((http-get-error? c) - (warning (_ "failed to retrieve CVE vulnerabilities \ + (warning (G_ "failed to retrieve CVE vulnerabilities \ from ~s: ~a (~s)~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) - (warning (_ "assuming no CVE vulnerabilities~%")) + (warning (G_ "assuming no CVE vulnerabilities~%")) '())) (catch #t (lambda () (current-vulnerabilities)) (match-lambda* (('getaddrinfo-error errcode) - (warning (_ "failed to lookup NIST host: ~a~%") + (warning (G_ "failed to lookup NIST host: ~a~%") (gai-strerror errcode)) - (warning (_ "assuming no CVE vulnerabilities~%")) + (warning (G_ "assuming no CVE vulnerabilities~%")) '()) (('tls-certificate-error args ...) - (warning (_ "TLS certificate error: ~a") + (warning (G_ "TLS certificate error: ~a") (tls-certificate-error-string args)) - (warning (_ "assuming no CVE vulnerabilities~%")) + (warning (G_ "assuming no CVE vulnerabilities~%")) '()) (args (apply throw args)))))) @@ -817,7 +817,7 @@ from ~s: ~a (~s)~%") vulnerabilities))) (unless (null? unpatched) (emit-warning package - (format #f (_ "probably vulnerable to ~a") + (format #f (G_ "probably vulnerable to ~a") (string-join (map vulnerability-id unpatched) ", "))))))))) @@ -832,7 +832,7 @@ from ~s: ~a (~s)~%") (#f #t) (index (emit-warning package - (format #f (_ "tabulation on line ~a, column ~a") + (format #f (G_ "tabulation on line ~a, column ~a") line-number index))))) (define (report-trailing-white-space package line line-number) @@ -841,7 +841,7 @@ from ~s: ~a (~s)~%") (string=? line (string #\page))) (emit-warning package (format #f - (_ "trailing white space on line ~a") + (G_ "trailing white space on line ~a") line-number)))) (define (report-long-line package line line-number) @@ -851,7 +851,7 @@ from ~s: ~a (~s)~%") ;; much noise. (when (> (string-length line) 90) (emit-warning package - (format #f (_ "line ~a is way too long (~a characters)") + (format #f (G_ "line ~a is way too long (~a characters)") line-number (string-length line))))) (define %hanging-paren-rx @@ -862,7 +862,7 @@ from ~s: ~a (~s)~%") (when (regexp-exec %hanging-paren-rx line) (emit-warning package (format #f - (_ "line ~a: parentheses feel lonely, \ + (G_ "line ~a: parentheses feel lonely, \ move to the previous or next line") line-number)))) @@ -1001,17 +1001,17 @@ or a list thereof") '()) (define (show-help) - (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... + (display (G_ "Usage: guix lint [OPTION]... [PACKAGE]... Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n")) - (display (_ " + (display (G_ " -c, --checkers=CHECKER1,CHECKER2... only run the specified checkers")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -l, --list-checkers display the list of available lint checkers")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -1029,7 +1029,7 @@ run the checkers on all packages.\n")) (unless (memq c (map lint-checker-name %checkers)) - (leave (_ "~a: invalid checker~%") c))) + (leave (G_ "~a: invalid checker~%") c))) names) (alist-cons 'checkers (filter (lambda (checker) @@ -1058,7 +1058,7 @@ run the checkers on all packages.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index acdfb81698..74c0c5484c 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -130,14 +130,14 @@ determined." ;; Silently ignore missing file since this is a common case. (if (= ENOENT err) '() - (leave (_ "failed to open machine file '~a': ~a~%") + (leave (G_ "failed to open machine file '~a': ~a~%") file (strerror err))))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (leave (_ "~a: ~a~%") + (leave (G_ "~a: ~a~%") (location->string loc) message))) (x - (leave (_ "failed to load machine file '~a': ~s~%") + (leave (G_ "failed to load machine file '~a': ~s~%") file args)))))) (define (host-key->type+key host-key) @@ -161,7 +161,7 @@ can interpret meaningfully." (private-key-from-file file)) (lambda (key proc str . rest) (raise (condition - (&message (message (format #f (_ "failed to load SSH \ + (&message (message (format #f (G_ "failed to load SSH \ private key from '~a': ~a") file str)))))))) @@ -204,7 +204,7 @@ private key from '~a': ~a") (string=? (public-key->string server) key)) ;; Key mismatch: something's wrong. XXX: It could be that the server ;; provided its Ed25519 key when we where expecting its RSA key. - (leave (_ "server at '~a' returned host key '~a' of type '~a' \ + (leave (G_ "server at '~a' returned host key '~a' of type '~a' \ instead of '~a' of type '~a'~%") (build-machine-name machine) (public-key->string server) (get-key-type server) @@ -213,13 +213,13 @@ instead of '~a' of type '~a'~%") (let ((auth (userauth-public-key! session private))) (unless (eq? 'success auth) (disconnect! session) - (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (leave (G_ "SSH public key authentication failed for '~a': ~a~%") (build-machine-name machine) (get-error session)))) session) (x ;; Connection failed or timeout expired. - (leave (_ "failed to connect to '~a': ~a~%") + (leave (G_ "failed to connect to '~a': ~a~%") (build-machine-name machine) (get-error session)))))) @@ -346,7 +346,7 @@ MACHINE." (guard (c ((nix-protocol-error? c) (format (current-error-port) - (_ "derivation '~a' offloaded to '~a' failed: ~a~%") + (G_ "derivation '~a' offloaded to '~a' failed: ~a~%") (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) @@ -530,11 +530,11 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." "Bail out if NODE is not running Guile." (match (node-guile-version node) (#f - (leave (_ "Guile could not be started on '~a'~%") + (leave (G_ "Guile could not be started on '~a'~%") name)) ((? string? version) ;; Note: The version string already contains the word "Guile". - (info (_ "'~a' is running ~a~%") + (info (G_ "'~a' is running ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) @@ -546,10 +546,10 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (add-text-to-store store "test" "Hello, build machine!")))) ((? string? str) - (info (_ "Guix is usable on '~a' (test returned ~s)~%") + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") name str)) (x - (leave (_ "failed to use Guix module on '~a' (test returned ~s)~%") + (leave (G_ "failed to use Guix module on '~a' (test returned ~s)~%") name x)))) (define %random-state @@ -570,9 +570,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (send-files local (list item) remote)) (if (valid-path? remote item) - (info (_ "'~a' successfully imported '~a'~%") + (info (G_ "'~a' successfully imported '~a'~%") name item) - (leave (_ "'~a' was not properly imported on '~a'~%") + (leave (G_ "'~a' was not properly imported on '~a'~%") item name)))))) (define (assert-node-can-export node name daemon-socket) @@ -583,9 +583,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (with-store store (if (and (retrieve-files store (list item) remote) (valid-path? store item)) - (info (_ "successfully imported '~a' from '~a'~%") + (info (G_ "successfully imported '~a' from '~a'~%") item name) - (leave (_ "failed to import '~a' from '~a'~%") + (leave (G_ "failed to import '~a' from '~a'~%") item name))))) (define (check-machine-availability machine-file pred) @@ -600,7 +600,7 @@ machine." (let ((machines (filter pred (delete-duplicates (build-machines machine-file) build-machine=?)))) - (info (_ "testing ~a build machines defined in '~a'...~%") + (info (G_ "testing ~a build machines defined in '~a'...~%") (length machines) machine-file) (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) @@ -633,8 +633,8 @@ machine." ;; We rely on protocol-level compression from libssh to optimize large data ;; transfers. Warn if it's missing. (unless (zlib-support?) - (warning (_ "Guile-SSH lacks zlib support")) - (warning (_ "data transfers will *not* be compressed!"))) + (warning (G_ "Guile-SSH lacks zlib support")) + (warning (G_ "data transfers will *not* be compressed!"))) (match args ((system max-silent-time print-build-trace? build-timeout) @@ -659,7 +659,7 @@ machine." #:max-silent-time max-silent-time #:build-timeout build-timeout)))) (else - (leave (_ "invalid request line: ~s~%") line))) + (leave (G_ "invalid request line: ~s~%") line))) (loop (read-line))))))) (("test" rest ...) (with-error-handling @@ -671,20 +671,20 @@ machine." build-machine-name))) ((file) (values file (const #t))) (() (values %machine-file (const #t))) - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (check-machine-availability (or file %machine-file) pred)))) (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE + (format #t (G_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") %machine-file) - (display (_ " + (display (G_ " This tool is meant to be used internally by 'guix-daemon'.\n")) (show-bug-report-information)) (x - (leave (_ "invalid arguments: ~{~s ~}~%") x)))) + (leave (G_ "invalid arguments: ~{~s ~}~%") x)))) ;;; Local Variables: ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 165e4ccf2a..1595be1f52 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -71,7 +71,7 @@ found." (($ name*) (string=? name* name))) %compressors) - (leave (_ "~a: compressor not found~%") name))) + (leave (G_ "~a: compressor not found~%") name))) (define* (self-contained-tarball name profile #:key target @@ -307,7 +307,7 @@ the image." `((,source -> ,target) ,@symlinks) (alist-delete 'symlinks result eq?)))) (x - (leave (_ "~a: invalid symlink specification~%") + (leave (G_ "~a: invalid symlink specification~%") arg))))) (option '("localstatedir") #f #f (lambda (opt name arg result) @@ -317,30 +317,30 @@ the image." %standard-build-options))) (define (show-help) - (display (_ "Usage: guix pack [OPTION]... PACKAGE... + (display (G_ "Usage: guix pack [OPTION]... PACKAGE... Create a bundle of PACKAGE.\n")) (show-build-options-help) (newline) (show-transformation-options-help) (newline) - (display (_ " + (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) - (display (_ " + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " + (display (G_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) - (display (_ " + (display (G_ " -S, --symlink=SPEC create symlinks to the profile according to SPEC")) - (display (_ " + (display (G_ " --localstatedir include /var/guix in the resulting pack")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -379,7 +379,7 @@ Create a bundle of PACKAGE.\n")) (build-image (match (assq-ref %formats pack-format) ((? procedure? proc) proc) (#f - (leave (_ "~a: unknown pack format") + (leave (G_ "~a: unknown pack format") format)))) (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6be9d00aec..92676c2228 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -104,7 +104,7 @@ indirectly, or PROFILE." (define (rtfm) (format (current-error-port) - (_ "Try \"info '(guix) Invoking guix package'\" for \ + (G_ "Try \"info '(guix) Invoking guix package'\" for \ more information.~%")) (exit 1)) @@ -126,21 +126,21 @@ more information.~%")) ;; parent directory is root-owned and we're running ;; unprivileged. (format (current-error-port) - (_ "error: while creating directory `~a': ~a~%") + (G_ "error: while creating directory `~a': ~a~%") %profile-directory (strerror (system-error-errno args))) (format (current-error-port) - (_ "Please create the `~a' directory, with you as the owner.~%") + (G_ "Please create the `~a' directory, with you as the owner.~%") %profile-directory) (rtfm)))) ;; Bail out if it's not owned by the user. (unless (or (not s) (= (stat:uid s) (getuid))) (format (current-error-port) - (_ "error: directory `~a' is not owned by you~%") + (G_ "error: directory `~a' is not owned by you~%") %profile-directory) (format (current-error-port) - (_ "Please change the owner of `~a' to user ~s.~%") + (G_ "Please change the owner of `~a' to user ~s.~%") %profile-directory (or (getenv "USER") (getenv "LOGNAME") (getuid))) @@ -175,17 +175,17 @@ denote ranges as interpreted by 'matching-generations'." => (lambda (numbers) (when (memv current numbers) - (warning (_ "not removing generation ~a, which is current~%") + (warning (G_ "not removing generation ~a, which is current~%") current)) ;; Make sure we don't inadvertently remove the current ;; generation. (let ((numbers (delv current numbers))) (when (null-list? numbers) - (leave (_ "no matching generation~%"))) + (leave (G_ "no matching generation~%"))) (delete-generations store profile numbers)))) (else - (leave (_ "invalid syntax: ~a~%") pattern))))) + (leave (G_ "invalid syntax: ~a~%") pattern))))) (define* (build-and-use-profile store profile manifest #:key @@ -211,7 +211,7 @@ specified in MANIFEST, a manifest object." (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) + (format (current-error-port) (G_ "nothing to be done~%"))) (else (let* ((number (generation-number profile)) @@ -269,7 +269,7 @@ synopsis or description matches all of REGEXPS." "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a ." (define (supersede old new) - (info (_ "package '~a' has been superseded by '~a'~%") + (info (G_ "package '~a' has been superseded by '~a'~%") (manifest-entry-name old) (package-name new)) (manifest-transaction-install-entry (package->manifest-entry new (manifest-entry-output old)) @@ -341,7 +341,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (settings (search-path-environment-variables entries profiles #:kind kind))) (unless (null? settings) - (format #t (_ "The following environment variable definitions may be needed:~%")) + (format #t (G_ "The following environment variable definitions may be needed:~%")) (format #t "~{ ~a~%~}" settings)))) @@ -357,68 +357,68 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (substitutes? . #t))) (define (show-help) - (display (_ "Usage: guix package [OPTION]... + (display (G_ "Usage: guix package [OPTION]... Install, remove, or upgrade packages in a single transaction.\n")) - (display (_ " + (display (G_ " -i, --install PACKAGE ... install PACKAGEs")) - (display (_ " + (display (G_ " -e, --install-from-expression=EXP install the package EXP evaluates to")) - (display (_ " + (display (G_ " -f, --install-from-file=FILE install the package that the code within FILE evaluates to")) - (display (_ " + (display (G_ " -r, --remove PACKAGE ... remove PACKAGEs")) - (display (_ " + (display (G_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) - (display (_ " + (display (G_ " -m, --manifest=FILE create a new profile generation with the manifest from FILE")) - (display (_ " + (display (G_ " --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) - (display (_ " + (display (G_ " --roll-back roll back to the previous generation")) - (display (_ " + (display (G_ " --search-paths[=KIND] display needed environment variable definitions")) - (display (_ " + (display (G_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) - (display (_ " + (display (G_ " -d, --delete-generations[=PATTERN] delete generations matching PATTERN")) - (display (_ " + (display (G_ " -S, --switch-generation=PATTERN switch to a generation matching PATTERN")) - (display (_ " + (display (G_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (newline) - (display (_ " + (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) - (display (_ " + (display (G_ " --verbose produce verbose output")) (newline) - (display (_ " + (display (G_ " -s, --search=REGEXP search in synopsis and description using REGEXP")) - (display (_ " + (display (G_ " -I, --list-installed[=REGEXP] list installed packages matching REGEXP")) - (display (_ " + (display (G_ " -A, --list-available[=REGEXP] list available packages matching REGEXP")) - (display (_ " + (display (G_ " --show=PACKAGE show details about PACKAGE")) (newline) (show-build-options-help) (newline) (show-transformation-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -504,7 +504,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) (#f 'exact) (x - (leave (_ "~a: unsupported \ + (leave (G_ "~a: unsupported \ kind of search path~%") x))))) (values (cons `(query search-paths ,kind) @@ -697,7 +697,7 @@ processed, #f otherwise." (list-generation display-profile-content (car numbers)) (diff-profiles profile numbers))))) (else - (leave (_ "invalid syntax: ~a~%") + (leave (G_ "invalid syntax: ~a~%") pattern))) #t) @@ -788,7 +788,7 @@ processed, #f otherwise." (let ((number (relative-generation-spec->number profile spec))) (if number (switch-to-generation* profile number) - (leave (_ "cannot switch to generation '~a'~%") spec))))) + (leave (G_ "cannot switch to generation '~a'~%") spec))))) (define* (delete-generations-action store profile pattern opts #:key dry-run?) @@ -804,9 +804,9 @@ processed, #f otherwise." (bootstrap? (assoc-ref opts 'bootstrap?)) (substitutes? (assoc-ref opts 'substitutes?))) (if dry-run? - (format #t (_ "would install new manifest from '~a' with ~d entries~%") + (format #t (G_ "would install new manifest from '~a' with ~d entries~%") file (length (manifest-entries manifest))) - (format #t (_ "installing new manifest from '~a' with ~d entries~%") + (format #t (G_ "installing new manifest from '~a' with ~d entries~%") file (length (manifest-entries manifest)))) (build-and-use-profile store profile manifest #:bootstrap? bootstrap? @@ -877,7 +877,7 @@ processed, #f otherwise." ;; Process non-option argument ARG by calling back ARG-HANDLER. (if arg-handler (arg-handler arg result) - (leave (_ "~A: extraneous argument~%") arg))) + (leave (G_ "~A: extraneous argument~%") arg))) (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 59ade0a8c1..aee506af46 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -54,7 +54,7 @@ actual output is different from that when we're doing a 'bmCheck' or (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors")) (unless url - (leave (_ "~a: missing URL~%") (derivation-file-name drv))) + (leave (G_ "~a: missing URL~%") (derivation-file-name drv))) (let* ((output (or output output*)) (url (call-with-input-string url read)) @@ -62,7 +62,7 @@ actual output is different from that when we're doing a 'bmCheck' or (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) (unless (and algo hash) - (leave (_ "~a is not a fixed-output derivation~%") + (leave (G_ "~a is not a fixed-output derivation~%") (derivation-file-name drv))) ;; We're invoked by the daemon, which gives us write access to OUTPUT. @@ -86,7 +86,7 @@ actual output is different from that when we're doing a 'bmCheck' or (define (assert-low-privileges) (when (zero? (getuid)) - (leave (_ "refusing to run with elevated privileges (UID ~a)~%") + (leave (G_ "refusing to run with elevated privileges (UID ~a)~%") (getuid)))) (define (guix-perform-download . args) @@ -115,7 +115,7 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See (show-version-and-exit)) (x (leave - (_ "fixed-output derivation and output file name expected~%")))))) + (G_ "fixed-output derivation and output file name expected~%")))))) ;; Local Variables: ;; eval: (put 'derivation-let 'scheme-indent-function 2) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 8864c2ef8b..efaa549676 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -64,35 +64,35 @@ guix-publish)) (define (show-help) - (format #t (_ "Usage: guix publish [OPTION]... + (format #t (G_ "Usage: guix publish [OPTION]... Publish ~a over HTTP.\n") %store-directory) - (display (_ " + (display (G_ " -p, --port=PORT listen on PORT")) - (display (_ " + (display (G_ " --listen=HOST listen on the network interface for HOST")) - (display (_ " + (display (G_ " -u, --user=USER change privileges to USER as soon as possible")) - (display (_ " + (display (G_ " -C, --compression[=LEVEL] compress archives at LEVEL")) - (display (_ " + (display (G_ " -c, --cache=DIRECTORY cache published items to DIRECTORY")) - (display (_ " + (display (G_ " --workers=N use N workers to bake items")) - (display (_ " + (display (G_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) - (display (_ " + (display (G_ " --nar-path=PATH use PATH as the prefix for nar URLs")) - (display (_ " + (display (G_ " --public-key=FILE use FILE as the public key for signatures")) - (display (_ " + (display (G_ " --private-key=FILE use FILE as the private key for signatures")) - (display (_ " + (display (G_ " -r, --repl[=PORT] spawn REPL server on PORT")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -103,7 +103,7 @@ Publish ~a over HTTP.\n") %store-directory) (lambda () (getaddrinfo host)) (lambda (key error) - (leave (_ "lookup of host '~a' failed: ~a~%") + (leave (G_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) ;; Nar compression parameters. @@ -148,7 +148,7 @@ if ITEM is already compressed." (alist-cons 'address (addrinfo:addr info) result)) (() - (leave (_ "lookup of host '~a' returned nothing") + (leave (G_ "lookup of host '~a' returned nothing") name))))) (option '(#\C "compression") #f #t (lambda (opt name arg result) @@ -161,7 +161,7 @@ if ITEM is already compressed." (compression 'gzip level) result) (begin - (warning (_ "zlib support is missing; \ + (warning (G_ "zlib support is missing; \ compression disabled~%")) result)))))) (option '(#\c "cache") #t #f @@ -175,7 +175,7 @@ compression disabled~%")) (lambda (opt name arg result) (let ((duration (string->duration arg))) (unless duration - (leave (_ "~a: invalid duration~%") arg)) + (leave (G_ "~a: invalid duration~%") arg)) (alist-cons 'narinfo-ttl (time-second duration) result)))) (option '("nar-path") #t #f @@ -796,7 +796,7 @@ blocking." (setgid (passwd:gid user)) (setuid (passwd:uid user)))) (lambda (key proc message args . rest) - (leave (_ "user '~a' not found: ~a~%") + (leave (G_ "user '~a' not found: ~a~%") user (apply format #f message args))))) @@ -808,9 +808,9 @@ blocking." (with-error-handling (let* ((opts (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) - (leave (_ "~A: extraneous argument~%") arg)) + (leave (G_ "~A: extraneous argument~%") arg)) %default-options)) (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) @@ -837,12 +837,12 @@ blocking." (gather-user-privileges user)) (when (zero? (getuid)) - (warning (_ "server running as root; \ + (warning (G_ "server running as root; \ consider using the '--user' option!~%"))) (parameterize ((%public-key public-key) (%private-key private-key)) - (format #t (_ "publishing ~a on ~a, port ~d~%") + (format #t (G_ "publishing ~a on ~a, port ~d~%") %store-directory (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) (sockaddr:port address)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 8e31ad620c..82fcaa248c 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -75,18 +75,18 @@ `((tarball-url . ,%snapshot-url))) (define (show-help) - (display (_ "Usage: guix pull [OPTION]... + (display (G_ "Usage: guix pull [OPTION]... Download and deploy the latest version of Guix.\n")) - (display (_ " + (display (G_ " --verbose produce verbose output")) - (display (_ " + (display (G_ " --url=URL download the Guix tarball from URL")) - (display (_ " + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -153,7 +153,7 @@ store file name." (mbegin %store-monad (what-to-build (list tar gzip)) (built-derivations (list tar gzip)) - (format #t (_ "unpacking '~a'...~%") tarball) + (format #t (G_ "unpacking '~a'...~%") tarball) (let ((source (temporary-directory))) (with-directory-excursion source @@ -205,24 +205,24 @@ contained therein." (if (and (file-exists? latest) (string=? (readlink latest) source-dir)) (begin - (display (_ "Guix already up to date\n")) + (display (G_ "Guix already up to date\n")) (return #t)) (begin (switch-symlinks latest source-dir) (format #t - (_ "updated ~a successfully deployed under `~a'~%") + (G_ "updated ~a successfully deployed under `~a'~%") %guix-package-name latest) (return #t)))) - (leave (_ "failed to update Guix, check the build log~%"))))) + (leave (G_ "failed to update Guix, check the build log~%"))))) (define (guix-pull . args) (define (parse-options) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) - (leave (_ "~A: unexpected argument~%") arg)) + (leave (G_ "~A: unexpected argument~%") arg)) %default-options)) (define (use-le-certs? url) @@ -245,7 +245,7 @@ contained therein." (fetch-tarball store url))) (fetch-tarball store url)))) (unless tarball - (leave (_ "failed to download up-to-date source, exiting\n"))) + (leave (G_ "failed to download up-to-date source, exiting\n"))) (parameterize ((%guile-for-build (package-derivation store (if (assoc-ref opts 'bootstrap?) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index c0d589af17..645572f182 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -76,7 +76,7 @@ (alist-cons 'select (string->symbol arg) result)) (x - (leave (_ "~a: invalid selection; expected `core' or `non-core'~%") + (leave (G_ "~a: invalid selection; expected `core' or `non-core'~%") arg))))) (option '(#\t "type") #t #f (lambda (opt name arg result) @@ -107,7 +107,7 @@ (alist-cons 'key-download (string->symbol arg) result)) (x - (leave (_ "unsupported policy: ~a~%") + (leave (G_ "unsupported policy: ~a~%") arg))))) (option '(#\h "help") #f #f @@ -119,41 +119,41 @@ (show-version-and-exit "guix refresh"))))) (define (show-help) - (display (_ "Usage: guix refresh [OPTION]... [PACKAGE]... + (display (G_ "Usage: guix refresh [OPTION]... [PACKAGE]... Update package definitions to match the latest upstream version. When PACKAGE... is given, update only the specified packages. Otherwise update all the packages of the distribution, or the subset thereof specified with `--select'.\n")) - (display (_ " + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) - (display (_ " + (display (G_ " -u, --update update source files in place")) - (display (_ " + (display (G_ " -s, --select=SUBSET select all the packages in SUBSET, one of `core' or `non-core'")) - (display (_ " + (display (G_ " -t, --type=UPDATER,... restrict to updates from the specified updaters (e.g., 'gnu')")) - (display (_ " + (display (G_ " -L, --list-updaters list available updaters and exit")) - (display (_ " + (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) (newline) - (display (_ " + (display (G_ " --key-server=HOST use HOST as the OpenPGP key server")) - (display (_ " + (display (G_ " --gpg=COMMAND use COMMAND as the GnuPG 2.x command")) - (display (_ " + (display (G_ " --key-download=POLICY handle missing OpenPGP keys according to POLICY: 'always', 'never', and 'interactive', which is also used when 'key-download' is not specified")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -218,11 +218,11 @@ unavailable optional dependencies such as Guile-JSON." (or (find (lambda (updater) (eq? name (upstream-updater-name updater))) %updaters) - (leave (_ "~a: no such updater~%") name))) + (leave (G_ "~a: no such updater~%") name))) (define (list-updaters-and-exit) "Display available updaters and exit." - (format #t (_ "Available updaters:~%")) + (format #t (G_ "Available updaters:~%")) (newline) (let* ((packages (fold-packages cons '())) @@ -234,22 +234,22 @@ unavailable optional dependencies such as Guile-JSON." ;; TRANSLATORS: The parenthetical expression here is rendered ;; like "(42% coverage)" and denotes the fraction of packages ;; covered by the given updater. - (format #t (_ " - ~a: ~a (~2,1f% coverage)~%") + (format #t (G_ " - ~a: ~a (~2,1f% coverage)~%") (upstream-updater-name updater) - (_ (upstream-updater-description updater)) + (G_ (upstream-updater-description updater)) (* 100. (/ matches total))) (+ covered matches))) 0 %updaters)) (newline) - (format #t (_ "~2,1f% of the packages are covered by these updaters.~%") + (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%") (* 100. (/ covered total)))) (exit 0)) (define (warn-no-updater package) (format (current-error-port) - (_ "~a: warning: no updater for ~a~%") + (G_ "~a: warning: no updater for ~a~%") (location->string (package-location package)) (package-name package))) @@ -270,14 +270,14 @@ warn about packages that have no matching updater." (if (and=> tarball file-exists?) (begin (format (current-error-port) - (_ "~a: ~a: updating from version ~a to version ~a...~%") + (G_ "~a: ~a: updating from version ~a to version ~a...~%") (location->string loc) (package-name package) (package-version package) version) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) - (warning (_ "~a: version ~a could not be \ + (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") (package-name package) version)))) (when warn? @@ -293,7 +293,7 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (let ((loc (or (package-field-location package 'version) (package-location package)))) (format (current-error-port) - (_ "~a: ~a would be upgraded from ~a to ~a~%") + (G_ "~a: ~a would be upgraded from ~a to ~a~%") (location->string loc) (package-name package) (package-version package) (upstream-source-version source))))) @@ -335,7 +335,7 @@ WARN? is true and no updater exists for PACKAGE, print a warning." ((x) (format (current-output-port) - (_ "A single dependent package: ~a~%") + (G_ "A single dependent package: ~a~%") (full-name x))) (lst (format (current-output-port) @@ -358,7 +358,7 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index f612dae700..52f7cdd972 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -74,7 +74,7 @@ if ITEM is not in the store." ;; The nar size is an approximation, but a good one. (return (substitutable-nar-size info))) (() - (leave (_ "no available substitute information for '~a'~%") + (leave (G_ "no available substitute information for '~a'~%") item))))))) (define* (display-profile profile #:optional (port (current-output-port))) @@ -82,7 +82,7 @@ if ITEM is not in the store." (define MiB (expt 2 20)) (format port "~64a ~8a ~a\n" - (_ "store item") (_ "total") (_ "self")) + (G_ "store item") (G_ "total") (G_ "self")) (let ((whole (reduce + 0 (map profile-self-size profile)))) (for-each (match-lambda (($ name self total) @@ -94,7 +94,7 @@ if ITEM is not in the store." ((($ name1 self1 total1) ($ name2 self2 total2)) (> total1 total2))))) - (format port (_ "total: ~,1f MiB~%") (/ whole MiB 1.)))) + (format port (G_ "total: ~,1f MiB~%") (/ whole MiB 1.)))) (define display-profile* (lift display-profile %store-monad)) @@ -208,7 +208,7 @@ the name of a PNG file." ;; TRANSLATORS: This is the title of a graph, meaning that the graph ;; represents a profile of the store (the "store" being the place where ;; packages are stored.) - (make-page-map (_ "store profile") data + (make-page-map (G_ "store profile") data #:write-to-png file)) @@ -217,19 +217,19 @@ the name of a PNG file." ;;; (define (show-help) - (display (_ "Usage: guix size [OPTION]... PACKAGE + (display (G_ "Usage: guix size [OPTION]... PACKAGE Report the size of PACKAGE and its dependencies.\n")) - (display (_ " + (display (G_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) - (display (_ " + (display (G_ " -s, --system=SYSTEM consider packages for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " -m, --map-file=FILE write to FILE a graphical map of disk usage")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -278,7 +278,7 @@ Report the size of PACKAGE and its dependencies.\n")) (urls (assoc-ref opts 'substitute-urls))) (match files (() - (leave (_ "missing store item argument\n"))) + (leave (G_ "missing store item argument\n"))) ((files ..1) (leave-on-EPIPE ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b4e913a880..53162b3f9a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -111,7 +111,7 @@ (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") (cut string-ci=? <> "yes")) (begin - (warning (_ "authentication and authorization of substitutes \ + (warning (G_ "authentication and authorization of substitutes \ disabled!~%")) #t))) @@ -186,7 +186,7 @@ provide." (values port (stat:size (stat port))))) ((http https) (guard (c ((http-get-error? c) - (leave (_ "download from '~a' failed: ~a, ~s~%") + (leave (G_ "download from '~a' failed: ~a, ~s~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)))) @@ -199,9 +199,9 @@ provide." %fetch-timeout 0) (begin - (warning (_ "while fetching ~a: server is somewhat slow~%") + (warning (G_ "while fetching ~a: server is somewhat slow~%") (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%")) + (warning (G_ "try `--no-substitutes' if the problem persists~%")) ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, ;; and thus PORT had to be closed and re-opened. This is not the @@ -219,7 +219,7 @@ provide." (http-fetch uri #:text? #f #:port port #:verify-certificate? #f)))))) (else - (leave (_ "unsupported substitute URI scheme: ~a~%") + (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) (define-record-type @@ -254,12 +254,12 @@ failure, return #f and #f." #:verify-certificate? #f #:timeout %fetch-timeout))) (guard (c ((http-get-error? c) - (warning (_ "while fetching '~a': ~a (~s)~%") + (warning (G_ "while fetching '~a': ~a (~s)~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) (close-connection port) - (warning (_ "ignoring substitute server at '~s'~%") url) + (warning (G_ "ignoring substitute server at '~s'~%") url) (values #f #f))) (values (read-cache-info (http-fetch uri #:verify-certificate? #f @@ -309,11 +309,11 @@ Otherwise return #f." ((version host-name sig) (let ((maybe-number (string->number version))) (cond ((not (number? maybe-number)) - (leave (_ "signature version must be a number: ~s~%") + (leave (G_ "signature version must be a number: ~s~%") version)) ;; Currently, there are no other versions. ((not (= 1 maybe-number)) - (leave (_ "unsupported signature version: ~a~%") + (leave (G_ "unsupported signature version: ~a~%") maybe-number)) (else (let ((signature (utf8->string (base64-decode sig)))) @@ -321,11 +321,11 @@ Otherwise return #f." (lambda () (string->canonical-sexp signature)) (lambda (key proc err) - (leave (_ "signature is not a valid \ + (leave (G_ "signature is not a valid \ s-expression: ~s~%") signature)))))))) (x - (leave (_ "invalid format of the signature field: ~a~%") x)))) + (leave (G_ "invalid format of the signature field: ~a~%") x)))) (define (narinfo-maker str cache-url) "Return a narinfo constructor for narinfos originating from CACHE-URL. STR @@ -360,13 +360,13 @@ NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." (signature-case (signature hash acl) (valid-signature #t) (invalid-signature - (leave (_ "invalid signature for '~a'~%") uri)) + (leave (G_ "invalid signature for '~a'~%") uri)) (hash-mismatch - (leave (_ "hash mismatch for '~a'~%") uri)) + (leave (G_ "hash mismatch for '~a'~%") uri)) (unauthorized-key - (leave (_ "'~a' is signed with an unauthorized key~%") uri)) + (leave (G_ "'~a' is signed with an unauthorized key~%") uri)) (corrupt-signature - (leave (_ "signature on '~a' is corrupt~%") uri))))) + (leave (G_ "signature on '~a' is corrupt~%") uri))))) (define* (read-narinfo port #:optional url #:key size) @@ -404,17 +404,17 @@ or is signed by an unauthorized key." (if (not hash) (if %allow-unauthenticated-substitutes? narinfo - (leave (_ "substitute at '~a' lacks a signature~%") + (leave (G_ "substitute at '~a' lacks a signature~%") (uri->string (narinfo-uri narinfo)))) (let ((signature (narinfo-signature narinfo))) (unless %allow-unauthenticated-substitutes? (assert-valid-signature narinfo signature hash acl) (when verbose? (format (current-error-port) - (_ "Found valid signature for ~a~%") + (G_ "Found valid signature for ~a~%") (narinfo-path narinfo)) (format (current-error-port) - (_ "From ~a~%") + (G_ "From ~a~%") (uri->string (narinfo-uri narinfo))))) narinfo)))) @@ -448,7 +448,7 @@ entry is stored in a sub-directory specific to CACHE-URL." ;; "/gnu/store/foo". Gracefully handle that. (match (store-path-hash-part path) (#f - (leave (_ "'~a' does not name a store item~%") path)) + (leave (G_ "'~a' does not name a store item~%") path)) ((? string? hash-part) (string-append %narinfo-cache-directory "/" (bytevector->base32-string (sha256 (string->utf8 cache-url))) @@ -596,7 +596,7 @@ if file doesn't exist, and the narinfo otherwise." (display #\cr (current-error-port)) (force-output (current-error-port)) (format (current-error-port) - (_ "updating list of substitutes from '~a'... ~5,1f%") + (G_ "updating list of substitutes from '~a'... ~5,1f%") url (* 100. (/ done (length paths)))) (set! done (+ 1 done))))) @@ -651,7 +651,7 @@ if file doesn't exist, and the narinfo otherwise." paths))) (filter-map (cut narinfo-from-file <> url) files))) (else - (leave (_ "~s: unsupported server URI scheme~%") + (leave (G_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) (let-values (((cache-info port) @@ -661,7 +661,7 @@ if file doesn't exist, and the narinfo otherwise." (%store-prefix)) (do-fetch (string->uri url) port) ;reuse PORT (begin - (warning (_ "'~a' uses different store '~a'; ignoring it~%") + (warning (G_ "'~a' uses different store '~a'; ignoring it~%") url (cache-info-store-directory cache-info)) (close-connection port) #f))))) @@ -781,12 +781,12 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (lambda () exp ...) (match-lambda* (('getaddrinfo-error error) - (leave (_ "host name lookup error: ~a~%") + (leave (G_ "host name lookup error: ~a~%") (gai-strerror error))) (('gnutls-error error proc . rest) (let ((error->string (module-ref (resolve-interface '(gnutls)) 'error->string))) - (leave (_ "TLS error in procedure '~a': ~a~%") + (leave (G_ "TLS error in procedure '~a': ~a~%") proc (error->string error)))) (args (apply throw args))))))) @@ -797,19 +797,19 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;;; (define (show-help) - (display (_ "Usage: guix substitute [OPTION]... + (display (G_ "Usage: guix substitute [OPTION]... Internal tool to substitute a pre-built binary to a local build.\n")) - (display (_ " + (display (G_ " --query report on the availability of substitutes for the store file names passed on the standard input")) - (display (_ " + (display (G_ " --substitute STORE-FILE DESTINATION download STORE-FILE and store it as a Nar in file DESTINATION")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -875,7 +875,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; TRANSLATORS: The second part of this message looks like ;; "(4.1MiB installed)"; it shows the size of the package once ;; installed. - (_ "Downloading ~a~:[~*~; (~a installed)~]...~%") + (G_ "Downloading ~a~:[~*~; (~a installed)~]...~%") (uri->string uri) ;; Use the Nar size as an estimate of the installed size. (narinfo-size narinfo) @@ -932,7 +932,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." (let ((acl (acl->public-keys (current-acl)))) (when (or (null? acl) (singleton? acl)) - (warning (_ "ACL for archive imports seems to be uninitialized, \ + (warning (G_ "ACL for archive imports seems to be uninitialized, \ substitutes may be unavailable\n"))))) (define (daemon-options) @@ -982,7 +982,7 @@ default value." (define (validate-uri uri) (unless (string->uri uri) - (leave (_ "~a: invalid URI~%") uri))) + (leave (G_ "~a: invalid URI~%") uri))) (define (guix-substitute . args) "Implement the build daemon's substituter protocol." @@ -1040,7 +1040,7 @@ default value." (("--help") (show-help)) (opts - (leave (_ "~a: unrecognized options~%") opts)))))) + (leave (G_ "~a: unrecognized options~%") opts)))))) ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8fabdb5c14..18abfc43a8 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -130,7 +130,7 @@ BODY..., and restore them." #:prefix target #:state-directory state #:references refs) - (leave (_ "failed to register '~a' under '~a'~%") + (leave (G_ "failed to register '~a' under '~a'~%") item target)) (return #t)))) @@ -163,7 +163,7 @@ TARGET, and register them." (munless (false-if-exception (install-grub grub.cfg device target)) (delete-file temp-gc-root) - (leave (_ "failed to install GRUB on device '~a'~%") device)) + (leave (G_ "failed to install GRUB on device '~a'~%") device)) ;; Register GRUB.CFG as a GC root so that its dependencies (background ;; image, font, etc.) are not reclaimed. @@ -181,7 +181,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (with-monad %store-monad (if (string=? target "/") (begin - (warning (_ "initializing the current root file system~%")) + (warning (G_ "initializing the current root file system~%")) (return #t)) (begin ;; Make sure the target store exists. @@ -195,7 +195,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; . (if (zero? (geteuid)) (chown target 0 0) - (warning (_ "not running as 'root', so \ + (warning (G_ "not running as 'root', so \ the ownership of '~a' may be incorrect!~%") target)) @@ -236,21 +236,21 @@ expression in %STORE-MONAD." (values (run-with-store store (begin mbody ...)) store))) (lambda (key proc format-string format-args errno . rest) - (warning (_ "while talking to shepherd: ~a~%") + (warning (G_ "while talking to shepherd: ~a~%") (apply format #f format-string format-args)) (values #f store))))) (define (report-shepherd-error error) "Report ERROR, a '&shepherd-error' error condition object." (cond ((service-not-found-error? error) - (report-error (_ "service '~a' could not be found~%") + (report-error (G_ "service '~a' could not be found~%") (service-not-found-error-service error))) ((action-not-found-error? error) - (report-error (_ "service '~a' does not have an action '~a'~%") + (report-error (G_ "service '~a' does not have an action '~a'~%") (action-not-found-error-service error) (action-not-found-error-action error))) ((action-exception-error? error) - (report-error (_ "exception caught while executing '~a' \ + (report-error (G_ "exception caught while executing '~a' \ on service '~a':~%") (action-exception-error-action error) (action-exception-error-service error)) @@ -258,10 +258,10 @@ on service '~a':~%") (action-exception-error-key error) (action-exception-error-arguments error))) ((unknown-shepherd-error? error) - (report-error (_ "something went wrong: ~s~%") + (report-error (G_ "something went wrong: ~s~%") (unknown-shepherd-error-sexp error))) ((shepherd-error? error) - (report-error (_ "shepherd error~%"))) + (report-error (G_ "shepherd error~%"))) ((not error) ;not an error #t))) @@ -278,7 +278,7 @@ unload." to-unload)))) (#f (with-monad %store-monad - (warning (_ "failed to obtain list of shepherd services~%")) + (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) (define (upgrade-shepherd-services os) @@ -298,7 +298,7 @@ bring the system down." (call-with-service-upgrade-info new-services (lambda (to-load to-unload) (for-each (lambda (unload) - (info (_ "unloading service '~a'...~%") unload) + (info (G_ "unloading service '~a'...~%") unload) (unload-service unload)) to-unload) @@ -306,7 +306,7 @@ bring the system down." (munless (null? to-load) (let ((to-load-names (map shepherd-service-canonical-name to-load)) (to-start (filter shepherd-service-auto-start? to-load))) - (info (_ "loading new services:~{ ~a~}...~%") to-load-names) + (info (G_ "loading new services:~{ ~a~}...~%") to-load-names) (mlet %store-monad ((files (mapm %store-monad shepherd-service-file to-load))) ;; Here we assume that FILES are exactly those that were computed @@ -330,7 +330,7 @@ it atomically, and then run OS's activation script." (switch-symlinks generation system) (switch-symlinks profile generation) - (format #t (_ "activating system...~%")) + (format #t (G_ "activating system...~%")) ;; The activation script may change $PATH, among others, so protect ;; against that. @@ -441,7 +441,7 @@ generation as its default entry. STORE is an open connection to the store." (begin (reinstall-grub store number) (switch-to-generation* %system-profile number)) - (leave (_ "cannot switch to system generation '~a'~%") spec)))) + (leave (G_ "cannot switch to system generation '~a'~%") spec)))) (define (reinstall-grub store number) "Re-install grub for existing system profile generation NUMBER. STORE is an @@ -475,7 +475,7 @@ open connection to the store." (switch-symlinks temp-gc-root grub.cfg-path) (unless (false-if-exception (install-grub-config grub.cfg-path "/")) (delete-file temp-gc-root) - (leave (_ "failed to re-install GRUB configuration file: '~a'~%") + (leave (G_ "failed to re-install GRUB configuration file: '~a'~%") grub.cfg-path)) (rename-file temp-gc-root gc-root)))) @@ -542,12 +542,12 @@ list of services." root)) (kernel (boot-parameters-kernel params))) (display-generation profile number) - (format #t (_ " file name: ~a~%") generation) - (format #t (_ " canonical file name: ~a~%") (readlink* generation)) + (format #t (G_ " file name: ~a~%") generation) + (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) ;; TRANSLATORS: Please preserve the two-space indentation. - (format #t (_ " label: ~a~%") label) - (format #t (_ " root device: ~a~%") root-device) - (format #t (_ " kernel: ~a~%") kernel)))) + (format #t (G_ " label: ~a~%") label) + (format #t (G_ " root device: ~a~%") root-device) + (format #t (G_ " kernel: ~a~%") kernel)))) (define* (list-generations pattern #:optional (profile %system-profile)) "Display in a human-readable format all the system generations matching @@ -565,7 +565,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (leave-on-EPIPE (for-each display-system-generation numbers))))) (else - (leave (_ "invalid syntax: ~a~%") pattern)))) + (leave (G_ "invalid syntax: ~a~%") pattern)))) ;;; @@ -604,9 +604,9 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (string-append (config-directory) "/latest")) (unless (file-exists? latest) - (warning (_ "~a not found: 'guix pull' was never run~%") latest) - (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%")) - (warning (_ "Failing to do that may downgrade your system!~%")))) + (warning (G_ "~a not found: 'guix pull' was never run~%") latest) + (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) + (warning (G_ "Failing to do that may downgrade your system!~%")))) (define* (perform-action action os #:key bootloader? dry-run? derivations-only? @@ -681,7 +681,7 @@ output when building a system derivation, such as a disk image." device "/")))) ((init) (newline) - (format #t (_ "initializing operating system under '~a'...~%") + (format #t (G_ "initializing operating system under '~a'...~%") target) (install sys (canonicalize-path target) #:grub? bootloader? @@ -725,61 +725,61 @@ output when building a system derivation, such as a disk image." ;;; (define (show-help) - (display (_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] + (display (G_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] Build the operating system declared in FILE according to ACTION. Some ACTIONS support additional ARGS.\n")) (newline) - (display (_ "The valid values for ACTION are:\n")) + (display (G_ "The valid values for ACTION are:\n")) (newline) - (display (_ "\ + (display (G_ "\ reconfigure switch to a new operating system configuration\n")) - (display (_ "\ + (display (G_ "\ roll-back switch to the previous operating system configuration\n")) - (display (_ "\ + (display (G_ "\ switch-generation switch to an existing operating system configuration\n")) - (display (_ "\ + (display (G_ "\ list-generations list the system generations\n")) - (display (_ "\ + (display (G_ "\ build build the operating system without installing anything\n")) - (display (_ "\ + (display (G_ "\ container build a container that shares the host's store\n")) - (display (_ "\ + (display (G_ "\ vm build a virtual machine image that shares the host's store\n")) - (display (_ "\ + (display (G_ "\ vm-image build a freestanding virtual machine image\n")) - (display (_ "\ + (display (G_ "\ disk-image build a disk image, suitable for a USB stick\n")) - (display (_ "\ + (display (G_ "\ init initialize a root file system to run GNU\n")) - (display (_ "\ + (display (G_ "\ extension-graph emit the service extension graph in Dot format\n")) - (display (_ "\ + (display (G_ "\ shepherd-graph emit the graph of shepherd services in Dot format\n")) (show-build-options-help) - (display (_ " + (display (G_ " -d, --derivation return the derivation of the given system")) - (display (_ " + (display (G_ " --on-error=STRATEGY apply STRATEGY when an error occurs while reading FILE")) - (display (_ " + (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) - (display (_ " + (display (G_ " --no-bootloader for 'init', do not install a bootloader")) - (display (_ " + (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) - (display (_ " + (display (G_ " -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', and 'build', make FILE a symlink to the result, and register it as a garbage collector root")) - (display (_ " + (display (G_ " --expose=SPEC for 'vm', expose host file system according to SPEC")) - (display (_ " + (display (G_ " --full-boot for 'vm', make a full boot sequence")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -862,7 +862,7 @@ resulting from command-line parsing." (os (if file (load* file %user-module #:on-error (assoc-ref opts 'on-error)) - (leave (_ "no configuration file specified~%")))) + (leave (G_ "no configuration file specified~%")))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) @@ -912,21 +912,21 @@ argument list and OPTS is the option alist." (let ((pattern (match args (() "") ((pattern) pattern) - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (list-generations pattern))) ;; The following commands need to use the store, but they do not need an ;; operating system configuration file. ((switch-generation) (let ((pattern (match args ((pattern) pattern) - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (with-store store (set-build-options-from-command-line store opts) (switch-to-system-generation store pattern)))) ((roll-back) (let ((pattern (match args (() "") - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (with-store store (set-build-options-from-command-line store opts) (roll-back-system store)))) @@ -945,7 +945,7 @@ argument list and OPTS is the option alist." extension-graph shepherd-graph list-generations roll-back switch-generation) (alist-cons 'action action result)) - (else (leave (_ "~a: unknown action~%") action)))))) + (else (leave (G_ "~a: unknown action~%") action)))))) (define (match-pair car) ;; Return a procedure that matches a pair with CAR. @@ -960,14 +960,14 @@ argument list and OPTS is the option alist." (count (length args)) (action (assoc-ref opts 'action))) (define (fail) - (leave (_ "wrong number of arguments for action '~a'~%") + (leave (G_ "wrong number of arguments for action '~a'~%") action)) (unless action (format (current-error-port) - (_ "guix system: missing command name~%")) + (G_ "guix system: missing command name~%")) (format (current-error-port) - (_ "Try 'guix system --help' for more information.~%")) + (G_ "Try 'guix system --help' for more information.~%")) (exit 1)) (case action diff --git a/guix/ssh.scm b/guix/ssh.scm index 59fd002dc7..4fb145230d 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -18,7 +18,7 @@ (define-module (guix ssh) #:use-module (guix store) - #:use-module ((guix ui) #:select (_ N_)) + #:use-module ((guix ui) #:select (G_ N_)) #:use-module (ssh session) #:use-module (ssh auth) #:use-module (ssh key) @@ -80,13 +80,13 @@ Throw an error on failure." (disconnect! session) (raise (condition (&message - (message (format #f (_ "SSH authentication failed for '~a': ~a~%") + (message (format #f (G_ "SSH authentication failed for '~a': ~a~%") host (get-error session))))))))) (x ;; Connection failed or timeout expired. (raise (condition (&message - (message (format #f (_ "SSH connection to '~a' failed: ~a~%") + (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") host (get-error session)))))))))) (define* (remote-daemon-channel session @@ -269,7 +269,7 @@ LOCAL. When RECURSIVE? is true, retrieve the closure of FILES." (&message (message (format #f - (_ "failed to retrieve store items from '~a'") + (G_ "failed to retrieve store items from '~a'") (remote-store-host remote))))))) (let ((result (import-paths local port))) diff --git a/guix/ui.scm b/guix/ui.scm index ae59718747..e551d48c33 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -55,7 +55,7 @@ #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) - #:export (_ + #:export (G_ N_ P_ report-error @@ -117,7 +117,7 @@ ;; Text domain for package synopses and descriptions. "guix-packages") -(define _ (cut gettext <> %gettext-domain)) +(define G_ (cut gettext <> %gettext-domain)) (define N_ (cut ngettext <> <> <> %gettext-domain)) (define (P_ msgid) @@ -140,7 +140,7 @@ messages." (syntax-case x () ((name (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) - (free-identifier=? #'underscore #'_)) + (free-identifier=? #'underscore #'G_)) (with-syntax ((fmt* (augmented-format-string #'fmt)) (prefix (datum->syntax x prefix))) #'(format (guix-warning-port) (gettext fmt*) @@ -238,7 +238,7 @@ messages." (case on-error ((debug) (newline) - (display (_ "entering debugger; type ',bt' for a backtrace\n")) + (display (G_ "entering debugger; type ',bt' for a backtrace\n")) (start-repl #:debug (make-debug (stack->vector stack) 0 (error-string frame args) #f))) @@ -254,19 +254,19 @@ ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . rest) (let ((err (system-error-errno args))) - (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) + (report-error (G_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (_ "~a: error: ~a~%") + (format (current-error-port) (G_ "~a: error: ~a~%") (location->string loc) message))) (('srfi-34 obj) (if (message-condition? obj) - (report-error (_ "~a~%") + (report-error (G_ "~a~%") (gettext (condition-message obj) %gettext-domain)) - (report-error (_ "exception thrown: ~s~%") obj))) + (report-error (G_ "exception thrown: ~s~%") obj))) ((error args ...) - (report-error (_ "failed to load '~a':~%") file) + (report-error (G_ "failed to load '~a':~%") file) (apply display-error frame (current-error-port) args)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ @@ -275,20 +275,20 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . rest) (let ((err (system-error-errno args))) - (warning (_ "failed to load '~a': ~a~%") file (strerror err)))) + (warning (G_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (_ "~a: warning: ~a~%") + (format (current-error-port) (G_ "~a: warning: ~a~%") (location->string loc) message))) (('srfi-34 obj) (if (message-condition? obj) - (warning (_ "failed to load '~a': ~a~%") + (warning (G_ "failed to load '~a': ~a~%") file (gettext (condition-message obj) %gettext-domain)) - (warning (_ "failed to load '~a': exception thrown: ~s~%") + (warning (G_ "failed to load '~a': exception thrown: ~s~%") file obj))) ((error args ...) - (warning (_ "failed to load '~a':~%") file) + (warning (G_ "failed to load '~a':~%") file) (apply display-error #f (current-error-port) args)))) (define (install-locale) @@ -297,7 +297,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (lambda _ (setlocale LC_ALL "")) (lambda args - (warning (_ "failed to install locale: ~a~%") + (warning (G_ "failed to install locale: ~a~%") (strerror (system-error-errno args)))))) (define (initialize-guix) @@ -320,9 +320,9 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ - (_ "(C)") - (_ "the Guix authors\n")) - (display (_"\ + (G_ "(C)") + (G_ "the Guix authors\n")) + (display (G_"\ License GPLv3+: GNU GPL version 3 or later This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. @@ -334,11 +334,11 @@ There is NO WARRANTY, to the extent permitted by law. ;; package. Please add another line saying "Report translation bugs to ;; ...\n" with the address for translation bugs (typically your translation ;; team's web or email address). - (format #t (_ " + (format #t (G_ " Report bugs to: ~a.") %guix-bug-report-address) - (format #t (_ " + (format #t (G_ " ~a home page: <~a>") %guix-package-name %guix-home-page-url) - (display (_ " + (display (G_ " General help using GNU software: ")) (newline)) @@ -383,13 +383,13 @@ nicely." (lambda () (apply make-regexp regexp flags)) (lambda (key proc message . rest) - (leave (_ "'~a' is not a valid regular expression: ~a~%") + (leave (G_ "'~a' is not a valid regular expression: ~a~%") regexp message)))) (define (string->number* str) "Like `string->number', but error out with an error message on failure." (or (string->number str) - (leave (_ "~a: invalid number~%") str))) + (leave (G_ "~a: invalid number~%") str))) (define (size->number str) "Convert STR, a storage measurement representation such as \"1024\" or @@ -406,7 +406,7 @@ interpreted." str)) (num (string->number numstr))) (unless num - (leave (_ "invalid number: ~a~%") numstr)) + (leave (G_ "invalid number: ~a~%") numstr)) ((compose inexact->exact round) (* num @@ -429,7 +429,7 @@ interpreted." ("YB" (expt 10 24)) ("" 1) (x - (leave (_ "unknown unit: ~a~%") unit))))))) + (leave (G_ "unknown unit: ~a~%") unit))))))) (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." @@ -446,62 +446,62 @@ interpreted." (file (location-file location)) (line (location-line location)) (column (location-column location))) - (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") + (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") file line column (package-full-name package) input))) ((package-cross-build-system-error? c) (let* ((package (package-error-package c)) (loc (package-location package)) (system (package-build-system package))) - (leave (_ "~a: ~a: build system `~a' does not support cross builds~%") + (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%") (location->string loc) (package-full-name package) (build-system-name system)))) ((gexp-input-error? c) (let ((input (package-error-invalid-input c))) - (leave (_ "~s: invalid G-expression input~%") + (leave (G_ "~s: invalid G-expression input~%") (gexp-error-invalid-input c)))) ((profile-not-found-error? c) - (leave (_ "profile '~a' does not exist~%") + (leave (G_ "profile '~a' does not exist~%") (profile-error-profile c))) ((missing-generation-error? c) - (leave (_ "generation ~a of profile '~a' does not exist~%") + (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation c) (profile-error-profile c))) ((nar-error? c) (let ((file (nar-error-file c)) (port (nar-error-port c))) (if file - (leave (_ "corrupt input while restoring '~a' from ~s~%") + (leave (G_ "corrupt input while restoring '~a' from ~s~%") file (or (port-filename* port) port)) - (leave (_ "corrupt input while restoring archive from ~s~%") + (leave (G_ "corrupt input while restoring archive from ~s~%") (or (port-filename* port) port))))) ((nix-connection-error? c) - (leave (_ "failed to connect to `~a': ~a~%") + (leave (G_ "failed to connect to `~a': ~a~%") (nix-connection-error-file c) (strerror (nix-connection-error-code c)))) ((nix-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. - (leave (_ "build failed: ~a~%") + (leave (G_ "build failed: ~a~%") (nix-protocol-error-message c))) ((derivation-missing-output-error? c) - (leave (_ "reference to invalid output '~a' of derivation '~a'~%") + (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") (derivation-missing-output c) (derivation-file-name (derivation-error-derivation c)))) ((file-search-error? c) - (leave (_ "file '~a' could not be found in these \ + (leave (G_ "file '~a' could not be found in these \ directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. - (leave (_ "~a~%") + (leave (G_ "~a~%") (gettext (condition-message c) %gettext-domain)))) ;; Catch EPIPE and the likes. (catch 'system-error thunk (lambda (key proc format-string format-args . rest) - (leave (_ "~a: ~a~%") proc + (leave (G_ "~a: ~a~%") proc (apply format #f format-string format-args)))))) (define-syntax-rule (leave-on-EPIPE exp ...) @@ -536,22 +536,22 @@ similar." (lambda () (call-with-input-string str read)) (lambda args - (leave (_ "failed to read expression ~s: ~s~%") + (leave (G_ "failed to read expression ~s: ~s~%") str args))))) (catch #t (lambda () (eval exp (force %guix-user-module))) (lambda args - (report-error (_ "failed to evaluate expression '~a':~%") exp) + (report-error (G_ "failed to evaluate expression '~a':~%") exp) (match args (('syntax-error proc message properties form . rest) - (report-error (_ "syntax error: ~a~%") message)) + (report-error (G_ "syntax error: ~a~%") message)) (('srfi-34 obj) (if (message-condition? obj) - (report-error (_ "~a~%") + (report-error (G_ "~a~%") (gettext (condition-message obj) %gettext-domain)) - (report-error (_ "exception thrown: ~s~%") obj))) + (report-error (G_ "exception thrown: ~s~%") obj))) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) @@ -563,7 +563,7 @@ error." (match (read/eval str) ((? package? p) p) (x - (leave (_ "expression ~s does not evaluate to a package~%") + (leave (G_ "expression ~s does not evaluate to a package~%") str)))) (define (show-derivation-outputs derivation) @@ -771,7 +771,7 @@ replacement if PORT is not Unicode-capable." (define (location->string loc) "Return a human-friendly, GNU-standard representation of LOC." (match loc - (#f (_ "")) + (#f (G_ "")) (($ file line column) (format #f "~a:~a:~a" file line column)))) @@ -790,7 +790,7 @@ exists. Honor the XDG specs, (lambda args (let ((err (system-error-errno args))) ;; ERR is necessarily different from EEXIST. - (leave (_ "failed to create configuration directory `~a': ~a~%") + (leave (G_ "failed to create configuration directory `~a': ~a~%") dir (strerror err))))))) (define* (fill-paragraph str width #:optional (column 0)) @@ -921,7 +921,7 @@ WIDTH columns." (dependencies->recutils (filter package? inputs))))) (format port "location: ~a~%" (or (and=> (package-location p) location->string) - (_ "unknown"))) + (G_ "unknown"))) ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in ;; field identifiers. @@ -935,7 +935,7 @@ WIDTH columns." ((? license? license) (license-name license)) (x - (_ "unknown")))) + (G_ "unknown")))) (format port "synopsis: ~a~%" (string-map (match-lambda (#\newline #\space) @@ -1093,7 +1093,7 @@ DURATION-RELATION with the current time." (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." (unless (zero? number) - (let ((header (format #f (_ "Generation ~a\t~a") number + (let ((header (format #f (G_ "Generation ~a\t~a") number (date->string (time-utc->date (generation-time profile number)) @@ -1103,7 +1103,7 @@ DURATION-RELATION with the current time." ;; TRANSLATORS: The word "current" here is an adjective for ;; "Generation", as in "current generation". Use the appropriate ;; gender where applicable. - (format #t (_ "~a\t(current)~%") header) + (format #t (G_ "~a\t(current)~%") header) (format #t "~a~%" header))))) (define (display-profile-content-diff profile gen1 gen2) @@ -1146,7 +1146,7 @@ way." (profile-manifest (generation-file-name profile number)))))) (define (display-generation-change previous current) - (format #t (_ "switched from generation ~a to ~a~%") previous current)) + (format #t (G_ "switched from generation ~a to ~a~%") previous current)) (define (roll-back* store profile) "Like 'roll-back', but display what is happening." @@ -1162,7 +1162,7 @@ way." (define (delete-generation* store profile generation) "Like 'delete-generation', but display what is going on." - (format #t (_ "deleting ~a~%") + (format #t (G_ "deleting ~a~%") (generation-file-name profile generation)) (delete-generation store profile generation)) @@ -1193,7 +1193,7 @@ optionally contain a version number and an output name, as in these examples: (define (show-guix-usage) (format (current-error-port) - (_ "Try `guix --help' for more information.~%")) + (G_ "Try `guix --help' for more information.~%")) (exit 1)) (define (command-files) @@ -1221,10 +1221,10 @@ optionally contain a version number and an output name, as in these examples: (member command '("substitute" "authenticate" "offload" "perform-download"))) - (format #t (_ "Usage: guix COMMAND ARGS... + (format #t (G_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) (newline) - (format #t (_ "COMMAND must be one of the sub-commands listed below:\n")) + (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n")) (newline) ;; TODO: Display a synopsis of each command. (format #t "~{ ~a~%~}" (sort (remove internal? (commands)) @@ -1244,7 +1244,7 @@ found." (resolve-interface `(guix scripts ,command))) (lambda - (format (current-error-port) - (_ "guix: ~a: command not found~%") command) + (G_ "guix: ~a: command not found~%") command) (show-guix-usage)))) (let ((command-main (module-ref module @@ -1263,7 +1263,7 @@ and signal handling has already been set up." (match args (() (format (current-error-port) - (_ "guix: missing command name~%")) + (G_ "guix: missing command name~%")) (show-guix-usage)) ((or ("-h") ("--help")) (show-guix-help)) @@ -1271,7 +1271,7 @@ and signal handling has already been set up." (show-version-and-exit "guix")) (((? option? o) args ...) (format (current-error-port) - (_ "guix: unrecognized option '~a'~%") o) + (G_ "guix: unrecognized option '~a'~%") o) (show-guix-usage)) (("help" command) (apply run-guix-command (string->symbol command) diff --git a/guix/upstream.scm b/guix/upstream.scm index a47a52be3f..5083e6b805 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -209,9 +209,9 @@ values: 'interactive' (default), 'always', and 'never'." (if ret tarball (begin - (warning (_ "signature verification failed for `~a'~%") + (warning (G_ "signature verification failed for `~a'~%") url) - (warning (_ "(could be because the public key is not in your keyring)~%")) + (warning (G_ "(could be because the public key is not in your keyring)~%")) #f)))))) (define (find2 pred lst1 lst2) @@ -290,12 +290,12 @@ if an update was made, and #f otherwise." old-version version old-hash hash)) version) (begin - (warning (_ "~a: could not locate source file") + (warning (G_ "~a: could not locate source file") (location-file loc)) #f))) (begin (format (current-error-port) - (_ "~a: ~a: no `version' field in source; skipping~%") + (G_ "~a: ~a: no `version' field in source; skipping~%") (location->string (package-location package)) name))))) diff --git a/po/guix/Makevars b/po/guix/Makevars index 8ec7d8aed6..6e301b68ef 100644 --- a/po/guix/Makevars +++ b/po/guix/Makevars @@ -10,7 +10,7 @@ top_builddir = ../.. # we use 'n_' instead of the more usual 'N_' for no-ops. XGETTEXT_OPTIONS = \ --from-code=UTF-8 \ - --keyword=_ --keyword=N_:1,2 \ + --keyword=G_ --keyword=N_:1,2 \ --keyword=message \ --keyword=description \ --keyword=n_ -- cgit 1.4.1 From 40fad1c24ce60076e26f6dc8096e4716d31d90c3 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 21 Apr 2017 14:37:07 +0200 Subject: system: Factorize operating-system-boot-parameters-file. * gnu/system.scm (operating-system-boot-parameters): New variable. (operating-system-boot-parameters-file): Modify. --- gnu/system.scm | 64 +++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 21 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index a35a416cb0..cb7c1b0cec 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -769,27 +769,49 @@ device in a ." ((label) (file-system-device fs)) (else #f))) -(define (operating-system-boot-parameters-file os) - "Return a file that describes the boot parameters of OS. The primary use of -this file is the reconstruction of GRUB menu entries for old configurations." - (mlet %store-monad ((initrd (operating-system-initrd-file os)) - (root -> (operating-system-root-file-system os)) - (store -> (operating-system-store-file-system os)) - (label -> (kernel->boot-label - (operating-system-kernel os)))) - (gexp->file "parameters" - #~(boot-parameters - (version 0) - (label #$label) - (root-device #$(file-system-device root)) - (kernel #$(operating-system-kernel-file os)) - (kernel-arguments - #$(operating-system-user-kernel-arguments os)) - (initrd #$initrd) - (store - (device #$(fs->boot-device store)) - (mount-point #$(file-system-mount-point store)))) - #:set-load-path? #f))) +(define (operating-system-boot-parameters os system root-device) + "Return a monadic record that describes the boot parameters of OS. +SYSTEM is optional. If given, adds kernel arguments for that system to ." + (mlet* %store-monad + ((initrd (operating-system-initrd-file os)) + (store -> (operating-system-store-file-system os)) + (label -> (kernel->boot-label (operating-system-kernel os)))) + (return (boot-parameters + (label label) + (root-device root-device) + (kernel (operating-system-kernel-file os)) + (kernel-arguments + (operating-system-user-kernel-arguments os)) + (initrd initrd) + (store-device (fs->boot-device store)) + (store-mount-point (file-system-mount-point store)))))) + +(define* (operating-system-boot-parameters-file os #:optional (system.drv #f)) + "Return a file that describes the boot parameters of OS. The primary use of +this file is the reconstruction of GRUB menu entries for old configurations. +SYSTEM.DRV is optional. If given, adds kernel arguments for that system to the +returned file (since the returned file is then usually stored into the +content-addressed \"system\" directory, it's usually not a good idea +to give it because the content hash would change by the content hash +being stored into the \"parameters\" file)." + (mlet* %store-monad ((root -> (operating-system-root-file-system os)) + (device -> (file-system-device root)) + (params (operating-system-boot-parameters os + system.drv + device))) + (gexp->file "parameters" + #~(boot-parameters + (version 0) + (label #$(boot-parameters-label params)) + (root-device #$(boot-parameters-root-device params)) + (kernel #$(boot-parameters-kernel params)) + (kernel-arguments + #$(boot-parameters-kernel-arguments params)) + (initrd #$(boot-parameters-initrd params)) + (store + (device #$(boot-parameters-store-device params)) + (mount-point #$(boot-parameters-store-mount-point params)))) + #:set-load-path? #f))) ;;; -- cgit 1.4.1 From 33f0aa88155ee0718f21e7de24eb539cb9872217 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 21 Apr 2017 14:37:08 +0200 Subject: system: Introduce operating-system-kernel-arguments and use it. * gnu/system.scm (bootable-kernel-arguments): New variable. (operating-system-kernel-arguments): New variable. (operating-system-bootcfg): Use operating-system-kernel-arguments. (operating-system-boot-parameters): Use operating-system-kernel-arguments. --- gnu/system.scm | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index cb7c1b0cec..37a05b270b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -73,7 +73,7 @@ operating-system-hosts-file operating-system-kernel operating-system-kernel-file - operating-system-user-kernel-arguments + operating-system-kernel-arguments operating-system-initrd operating-system-users operating-system-groups @@ -122,6 +122,14 @@ ;;; ;;; Code: +(define (bootable-kernel-arguments kernel-arguments system.drv root-device) + "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be +booted from ROOT-DEVICE" + (cons* (string-append "--root=" root-device) + #~(string-append "--system=" #$system.drv) + #~(string-append "--load=" #$system.drv "/boot") + kernel-arguments)) + ;; System-wide configuration. ;; TODO: Add per-field docstrings/stexi. (define-record-type* operating-system @@ -182,6 +190,13 @@ (sudoers-file operating-system-sudoers-file ; file-like (default %sudoers-specification))) +(define (operating-system-kernel-arguments os system.drv root-device) + "Return all the kernel arguments, including the ones not specified +directly by the user." + (bootable-kernel-arguments (operating-system-user-kernel-arguments os) + system.drv + root-device)) + ;;; ;;; Services. @@ -756,7 +771,9 @@ populate the \"old entries\" menu." #~(string-append "--system=" #$system) #~(string-append "--load=" #$system "/boot") - (operating-system-user-kernel-arguments os))) + (operating-system-kernel-arguments os + system + root-device))) (initrd initrd))))) (grub-configuration-file (operating-system-bootloader os) entries #:old-entries old-entries))) @@ -781,7 +798,9 @@ SYSTEM is optional. If given, adds kernel arguments for that system to boot-device store)) (store-mount-point (file-system-mount-point store)))))) -- cgit 1.4.1 From 9530e73b496fefe65dcb936825b6beda79f7fdf2 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 21 Apr 2017 14:37:09 +0200 Subject: system: Introduce read-boot-parameters-file. * gnu/system.scm (read-boot-parameters): Remove export. (read-boot-parameters-file): New variable. Export it. * guix/scripts/system.scm (profile-boot-parameters): Use read-boot-parameters-file. (profile-grub-entries): Use read-boot-parameters-file. (reinstall-grub): Use read-boot-parameters-file. (display-system-generation): Use read-boot-parameters-file. --- gnu/system.scm | 22 +++++++++++++++++++++- guix/scripts/system.scm | 14 ++++---------- 2 files changed, 25 insertions(+), 11 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 37a05b270b..f213379f03 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -109,7 +109,7 @@ boot-parameters-kernel boot-parameters-kernel-arguments boot-parameters-initrd - read-boot-parameters + read-boot-parameters-file local-host-aliases %setuid-programs @@ -907,4 +907,24 @@ being stored into the \"parameters\" file)." system) #f))) +(define (read-boot-parameters-file system) + "Read boot parameters from SYSTEM's (system or generation) \"parameters\" +file and returns the corresponding object or #f if the +format is unrecognized. +The object has its kernel-arguments extended in order to make it bootable." + (let* ((file (string-append system "/parameters")) + (params (call-with-input-file file read-boot-parameters)) + (root (boot-parameters-root-device params)) + (root-device (if (bytevector? root) + (uuid->string root) + root)) + (kernel-arguments (boot-parameters-kernel-arguments params))) + (if params + (boot-parameters + (inherit params) + (kernel-arguments (bootable-kernel-arguments kernel-arguments + system + root-device))) + #f))) + ;;; system.scm ends here diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 18abfc43a8..9b77b03746 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -369,9 +369,7 @@ it atomically, and then run OS's activation script." NUMBERS, which is a list of generation numbers." (define (system->boot-parameters system number time) (unless-file-not-found - (let* ((file (string-append system "/parameters")) - (params (call-with-input-file file - read-boot-parameters))) + (let* ((params (read-boot-parameters-file system))) params))) (let* ((systems (map (cut generation-file-name profile <>) numbers)) @@ -387,9 +385,7 @@ NUMBERS, which is a list of generation numbers." NUMBERS, which is a list of generation numbers." (define (system->grub-entry system number time) (unless-file-not-found - (let* ((file (string-append system "/parameters")) - (params (call-with-input-file file - read-boot-parameters)) + (let* ((params (read-boot-parameters-file system)) (label (boot-parameters-label params)) (root (boot-parameters-root-device params)) (root-device (if (bytevector? root) @@ -447,9 +443,8 @@ generation as its default entry. STORE is an open connection to the store." "Re-install grub for existing system profile generation NUMBER. STORE is an open connection to the store." (let* ((generation (generation-file-name %system-profile number)) - (file (string-append generation "/parameters")) (params (unless-file-not-found - (call-with-input-file file read-boot-parameters))) + (read-boot-parameters-file generation))) (root-device (boot-parameters-root-device params)) ;; We don't currently keep track of past menu entries' details. The ;; default values will allow the system to boot, even if they differ @@ -533,8 +528,7 @@ list of services." "Display a summary of system generation NUMBER in a human-readable format." (unless (zero? number) (let* ((generation (generation-file-name profile number)) - (param-file (string-append generation "/parameters")) - (params (call-with-input-file param-file read-boot-parameters)) + (params (read-boot-parameters-file generation)) (label (boot-parameters-label params)) (root (boot-parameters-root-device params)) (root-device (if (bytevector? root) -- cgit 1.4.1 From 370ae085b5107a0928fd744a987fb4070bdf6a00 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 21 Apr 2017 14:37:12 +0200 Subject: system: Use operating-system-boot-parameters directly. * gnu/system.scm (operating-system-bootcfg): Use operating-system-boot-parameters directly. --- gnu/system.scm | 28 ++++------------------------ 1 file changed, 4 insertions(+), 24 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index f213379f03..38b936787f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -750,33 +750,13 @@ populate the \"old entries\" menu." (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) - (store-fs -> (operating-system-store-file-system os)) - (label -> (kernel->boot-label (operating-system-kernel os))) - (kernel -> (operating-system-kernel-file os)) - (initrd (operating-system-initrd-file os)) (root-device -> (if (eq? 'uuid (file-system-title root-fs)) (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) - (entries -> (list (menu-entry - (label label) - - ;; The device where the kernel and initrd live. - (device (fs->boot-device store-fs)) - (device-mount-point - (file-system-mount-point store-fs)) - - (linux kernel) - (linux-arguments - (cons* (string-append "--root=" root-device) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system - "/boot") - (operating-system-kernel-arguments os - system - root-device))) - (initrd initrd))))) - (grub-configuration-file (operating-system-bootloader os) entries - #:old-entries old-entries))) + (entry (operating-system-boot-parameters os system root-device))) + (grub-configuration-file (operating-system-bootloader os) + (list entry) + #:old-entries old-entries))) (define (fs->boot-device fs) "Given FS, a object, return a value suitable for use as the -- cgit 1.4.1 From 360874dd1c1aafddd82e389b9da09f69bddb2a20 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 5 May 2017 08:42:34 +0200 Subject: system: Clarify that SYSTEM is either a derivation or #f. * gnu/system.scm (operating-system-boot-parameters): Clarify that SYSTEM is either a derivation or #f. --- gnu/system.scm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 38b936787f..189a13262f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -766,9 +766,10 @@ device in a ." ((label) (file-system-device fs)) (else #f))) -(define (operating-system-boot-parameters os system root-device) - "Return a monadic record that describes the boot parameters of OS. -SYSTEM is optional. If given, adds kernel arguments for that system to ." +(define (operating-system-boot-parameters os system.drv root-device) + "Return a monadic record that describes the boot parameters +of OS. SYSTEM.DRV is either a derivation or #f. If it's a derivation, adds +kernel arguments for that derivation to ." (mlet* %store-monad ((initrd (operating-system-initrd-file os)) (store -> (operating-system-store-file-system os)) @@ -778,9 +779,9 @@ SYSTEM is optional. If given, adds kernel arguments for that system to boot-device store)) (store-mount-point (file-system-mount-point store)))))) -- cgit 1.4.1 From 8e815c5b6903a545c46b674c1cd1cc3180f835db Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 7 May 2017 11:30:24 +0200 Subject: system: Define before first use. Fixes . Reported by Mark H Weaver . * gnu/system.scm (, read-boot-parameters) (read-boot-parameters-file): Move before first use of the 'boot-parameters' macro. --- gnu/system.scm | 189 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 94 insertions(+), 95 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 189a13262f..748e3f7e9a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -199,6 +199,100 @@ directly by the user." ;;; +;;; Boot parameters +;;; + +(define-record-type* + boot-parameters make-boot-parameters boot-parameters? + (label boot-parameters-label) + ;; Because we will use the 'store-device' to create the GRUB search command, + ;; the 'store-device' has slightly different semantics than 'root-device'. + ;; The 'store-device' can be a file system uuid, a file system label, or #f, + ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not + ;; understand that. The 'root-device', on the other hand, corresponds + ;; exactly to the device field of the object representing the + ;; OS's root file system, so it might be a device path like "/dev/sda3". + (root-device boot-parameters-root-device) + (store-device boot-parameters-store-device) + (store-mount-point boot-parameters-store-mount-point) + (kernel boot-parameters-kernel) + (kernel-arguments boot-parameters-kernel-arguments) + (initrd boot-parameters-initrd)) + +(define (read-boot-parameters port) + "Read boot parameters from PORT and return the corresponding + object or #f if the format is unrecognized." + (match (read port) + (('boot-parameters ('version 0) + ('label label) ('root-device root) + ('kernel linux) + rest ...) + (boot-parameters + (label label) + (root-device root) + + ;; In the past, we would store the directory name of the kernel instead + ;; of the absolute file name of its image. Detect that and correct it. + (kernel (if (string=? linux (direct-store-path linux)) + (string-append linux "/" + (system-linux-image-file-name)) + linux)) + + (kernel-arguments + (match (assq 'kernel-arguments rest) + ((_ args) args) + (#f '()))) ;the old format + + (initrd + (match (assq 'initrd rest) + (('initrd ('string-append directory file)) ;the old format + (string-append directory file)) + (('initrd (? string? file)) + file))) + + (store-device + (match (assq 'store rest) + (('store ('device device) _ ...) + device) + (_ ;the old format + ;; Root might be a device path like "/dev/sda1", which is not a + ;; suitable GRUB device identifier. + (if (string-prefix? "/" root) + #f + root)))) + + (store-mount-point + (match (assq 'store rest) + (('store ('device _) ('mount-point mount-point) _ ...) + mount-point) + (_ ;the old format + "/"))))) + (x ;unsupported format + (warning (G_ "unrecognized boot parameters for '~a'~%") + system) + #f))) + +(define (read-boot-parameters-file system) + "Read boot parameters from SYSTEM's (system or generation) \"parameters\" +file and returns the corresponding object or #f if the +format is unrecognized. +The object has its kernel-arguments extended in order to make it bootable." + (let* ((file (string-append system "/parameters")) + (params (call-with-input-file file read-boot-parameters)) + (root (boot-parameters-root-device params)) + (root-device (if (bytevector? root) + (uuid->string root) + root)) + (kernel-arguments (boot-parameters-kernel-arguments params))) + (if params + (boot-parameters + (inherit params) + (kernel-arguments (bootable-kernel-arguments kernel-arguments + system + root-device))) + #f))) + +;;; ;;; Services. ;;; @@ -813,99 +907,4 @@ being stored into the \"parameters\" file)." (mount-point #$(boot-parameters-store-mount-point params)))) #:set-load-path? #f))) - -;;; -;;; Boot parameters -;;; - -(define-record-type* - boot-parameters make-boot-parameters boot-parameters? - (label boot-parameters-label) - ;; Because we will use the 'store-device' to create the GRUB search command, - ;; the 'store-device' has slightly different semantics than 'root-device'. - ;; The 'store-device' can be a file system uuid, a file system label, or #f, - ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not - ;; understand that. The 'root-device', on the other hand, corresponds - ;; exactly to the device field of the object representing the - ;; OS's root file system, so it might be a device path like "/dev/sda3". - (root-device boot-parameters-root-device) - (store-device boot-parameters-store-device) - (store-mount-point boot-parameters-store-mount-point) - (kernel boot-parameters-kernel) - (kernel-arguments boot-parameters-kernel-arguments) - (initrd boot-parameters-initrd)) - -(define (read-boot-parameters port) - "Read boot parameters from PORT and return the corresponding - object or #f if the format is unrecognized." - (match (read port) - (('boot-parameters ('version 0) - ('label label) ('root-device root) - ('kernel linux) - rest ...) - (boot-parameters - (label label) - (root-device root) - - ;; In the past, we would store the directory name of the kernel instead - ;; of the absolute file name of its image. Detect that and correct it. - (kernel (if (string=? linux (direct-store-path linux)) - (string-append linux "/" - (system-linux-image-file-name)) - linux)) - - (kernel-arguments - (match (assq 'kernel-arguments rest) - ((_ args) args) - (#f '()))) ;the old format - - (initrd - (match (assq 'initrd rest) - (('initrd ('string-append directory file)) ;the old format - (string-append directory file)) - (('initrd (? string? file)) - file))) - - (store-device - (match (assq 'store rest) - (('store ('device device) _ ...) - device) - (_ ;the old format - ;; Root might be a device path like "/dev/sda1", which is not a - ;; suitable GRUB device identifier. - (if (string-prefix? "/" root) - #f - root)))) - - (store-mount-point - (match (assq 'store rest) - (('store ('device _) ('mount-point mount-point) _ ...) - mount-point) - (_ ;the old format - "/"))))) - (x ;unsupported format - (warning (G_ "unrecognized boot parameters for '~a'~%") - system) - #f))) - -(define (read-boot-parameters-file system) - "Read boot parameters from SYSTEM's (system or generation) \"parameters\" -file and returns the corresponding object or #f if the -format is unrecognized. -The object has its kernel-arguments extended in order to make it bootable." - (let* ((file (string-append system "/parameters")) - (params (call-with-input-file file read-boot-parameters)) - (root (boot-parameters-root-device params)) - (root-device (if (bytevector? root) - (uuid->string root) - root)) - (kernel-arguments (boot-parameters-kernel-arguments params))) - (if params - (boot-parameters - (inherit params) - (kernel-arguments (bootable-kernel-arguments kernel-arguments - system - root-device))) - #f))) - ;;; system.scm ends here -- cgit 1.4.1 From 087efec496b91e3763be2e11e208d4a8f4ef3d43 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Mon, 8 May 2017 15:42:34 +0200 Subject: system: Remove circular dependency between (gnu system) and (gnu system grub). Followup to 8e815c5b6903a545c46b674c1cd1cc3180f835db. * gnu/system.scm: Remove (gnu system grub) import. (operating-system-bootcfg): Refer to (gnu system grub) within the procedure. --- gnu/system.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 748e3f7e9a..baba0b5dfc 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -48,7 +48,6 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services base) - #:use-module (gnu system grub) #:use-module (gnu system shadow) #:use-module (gnu system nss) #:use-module (gnu system locale) @@ -848,7 +847,7 @@ populate the \"old entries\" menu." (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) (entry (operating-system-boot-parameters os system root-device))) - (grub-configuration-file (operating-system-bootloader os) + ((@@ (gnu system grub) grub-configuration-file) (operating-system-bootloader os) (list entry) #:old-entries old-entries))) -- cgit 1.4.1 From f000828575d6fe16e774162051d29b9ed025414d Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Mon, 8 May 2017 22:16:55 +0200 Subject: system: Remove circular dependency between (gnu system) and (gnu system grub). Followup to 087efec496b91e3763be2e11e208d4a8f4ef3d43. * gnu/system.scm: (operating-system-bootcfg): Refer to (gnu system grub) by module-ref. --- gnu/system.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index baba0b5dfc..9fc6cc5e76 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -847,9 +847,11 @@ populate the \"old entries\" menu." (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) (entry (operating-system-boot-parameters os system root-device))) - ((@@ (gnu system grub) grub-configuration-file) (operating-system-bootloader os) - (list entry) - #:old-entries old-entries))) + ((module-ref (resolve-interface '(gnu system grub)) + 'grub-configuration-file) + (operating-system-bootloader os) + (list entry) + #:old-entries old-entries))) (define (fs->boot-device fs) "Given FS, a object, return a value suitable for use as the -- cgit 1.4.1 From 4e4e0185251e0660d625cc2b1243160b92e94faa Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Mon, 8 May 2017 22:03:37 +0300 Subject: system: Export 'read-boot-parameters'. This partially reverts commit 9530e73b496fefe65dcb936825b6beda79f7fdf2. * gnu/system.scm: Export 'read-boot-parameters' for backward compatibility. --- gnu/system.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 9fc6cc5e76..f9a0da9a75 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -108,6 +108,7 @@ boot-parameters-kernel boot-parameters-kernel-arguments boot-parameters-initrd + read-boot-parameters read-boot-parameters-file local-host-aliases -- cgit 1.4.1 From b09a8da4a2e50845a297e041762f3ff9e649c047 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 15 May 2017 22:24:18 +0200 Subject: bootloader: Add extlinux support. * gnu/bootloader.scm: New file. * gnu/bootloader/extlinux.scm: New file. * gnu/bootloader/grub.scm: New file. * gnu/local.mk: Build new files. * gnu/system.scm: Adapt to new bootloader api. * gnu/scripts/system.scm: Adapt to new bootloader api. * gnu.scm: Remove (gnu system grub) and replace by (gnu bootloader) and (gnu bootloader grub) modules. * gnu/system/grub.scm: Moved content to gnu/bootloader/grub.scm. * gnu/system/vm: Replace (gnu system grub) module by (gnu bootloader). * gnu/tests.scm: Ditto. * gnu/tests/nfs.scm: Ditto. --- gnu.scm | 4 +- gnu/bootloader.scm | 127 +++++++++++++ gnu/bootloader/extlinux.scm | 123 ++++++++++++ gnu/bootloader/grub.scm | 448 ++++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 4 +- gnu/system.scm | 14 +- gnu/system/grub.scm | 407 ---------------------------------------- gnu/system/vm.scm | 2 +- gnu/tests.scm | 3 +- gnu/tests/nfs.scm | 3 +- guix/scripts/system.scm | 20 +- 11 files changed, 728 insertions(+), 427 deletions(-) create mode 100644 gnu/bootloader.scm create mode 100644 gnu/bootloader/extlinux.scm create mode 100644 gnu/bootloader/grub.scm delete mode 100644 gnu/system/grub.scm (limited to 'gnu/system.scm') diff --git a/gnu.scm b/gnu.scm index 932e4cdd58..913ce61600 100644 --- a/gnu.scm +++ b/gnu.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Joshua S. Grant +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,7 +35,8 @@ '((gnu system) (gnu system mapped-devices) (gnu system file-systems) - (gnu system grub) ; 'grub-configuration' + (gnu bootloader) + (gnu bootloader grub) (gnu system pam) (gnu system shadow) ; 'user-account' (gnu system linux-initrd) diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm new file mode 100644 index 0000000000..4e77974d31 --- /dev/null +++ b/gnu/bootloader.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 David Craven +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017 Leo Famulari +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu bootloader) + #:use-module (guix discovery) + #:use-module (guix records) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:export (bootloader + bootloader? + bootloader-name + bootloader-package + bootloader-installer + bootloader-configuration-file + bootloader-configuration-file-generator + + bootloader-configuration + bootloader-configuration? + bootloader-configuration-bootloader + bootloader-configuration-device + bootloader-configuration-menu-entries + bootloader-configuration-default-entry + bootloader-configuration-timeout + bootloader-configuration-theme + bootloader-configuration-terminal-outputs + bootloader-configuration-terminal-inputs + bootloader-configuration-serial-unit + bootloader-configuration-serial-speed + bootloader-configuration-additional-configuration + + %bootloaders + lookup-bootloader-by-name)) + + +;;; +;;; Bootloader record. +;;; + +;; The record contains fields expressing how the bootloader +;; should be installed. Every bootloader in gnu/bootloader/ directory +;; has to be described by this record. + +(define-record-type* + bootloader make-bootloader + bootloader? + (name bootloader-name) + (package bootloader-package) + (installer bootloader-installer) + (configuration-file bootloader-configuration-file) + (configuration-file-generator bootloader-configuration-file-generator)) + + +;;; +;;; Bootloader configuration record. +;;; + +;; The record contains bootloader independant +;; configuration used to fill bootloader configuration file. + +(define-record-type* + bootloader-configuration make-bootloader-configuration + bootloader-configuration? + (bootloader bootloader-configuration-bootloader) ; + (device bootloader-configuration-device ; string + (default #f)) + (menu-entries bootloader-configuration-menu-entries ; list of + (default '())) + (default-entry bootloader-configuration-default-entry ; integer + (default 0)) + (timeout bootloader-configuration-timeout ; seconds as integer + (default 5)) + (theme bootloader-configuration-theme ; bootloader-specific theme + (default #f)) + (terminal-outputs bootloader-configuration-terminal-outputs ; list of symbols + (default '(gfxterm))) + (terminal-inputs bootloader-configuration-terminal-inputs ; list of symbols + (default '())) + (serial-unit bootloader-configuration-serial-unit ; integer | #f + (default #f)) + (serial-speed bootloader-configuration-serial-speed ; integer | #f + (default #f)) + (additional-configuration bootloader-configuration-additional-configuration ; record + (default #f))) + + +;;; +;;; Bootloaders. +;;; + +(define (bootloader-modules) + "Return the list of bootloader modules." + (all-modules (map (lambda (entry) + `(,entry . "gnu/bootloader")) + %load-path))) + +(define %bootloaders + ;; The list of publically-known bootloaders. + (delay (fold-module-public-variables (lambda (obj result) + (if (bootloader? obj) + (cons obj result) + result)) + '() + (bootloader-modules)))) + +(define (lookup-bootloader-by-name name) + "Return the bootloader called NAME." + (or (find (lambda (bootloader) + (eq? name (bootloader-name bootloader))) + (force %bootloaders)) + (leave (G_ "~a: no such bootloader~%") name))) diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm new file mode 100644 index 0000000000..a002001071 --- /dev/null +++ b/gnu/bootloader/extlinux.scm @@ -0,0 +1,123 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 David Craven +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu bootloader extlinux) + #:use-module (gnu bootloader) + #:use-module (gnu system) + #:use-module (gnu packages bootloaders) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix utils) + #:export (extlinux-bootloader + syslinux-bootloader + + extlinux-configuration + syslinux-configuration)) + +(define* (extlinux-configuration-file config entries + #:key + (system (%current-system)) + (old-entries '())) + "Return the U-Boot configuration file corresponding to CONFIG, a + object, and where the store is available at STORE-FS, a + object. OLD-ENTRIES is taken to be a list of menu entries +corresponding to old generations of the system." + + (define all-entries + (append entries (bootloader-configuration-menu-entries config))) + + (define (boot-parameters->gexp params) + (let ((label (boot-parameters-label params)) + (kernel (boot-parameters-kernel params)) + (kernel-arguments (boot-parameters-kernel-arguments params)) + (initrd (boot-parameters-initrd params))) + #~(format port "LABEL ~a + MENU LABEL ~a + KERNEL ~a + FDTDIR ~a/lib/dtbs + INITRD ~a + APPEND ~a +~%" + #$label #$label + #$kernel #$kernel #$initrd + (string-join (list #$@kernel-arguments))))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (let ((timeout #$(bootloader-configuration-timeout config))) + (format port " +UI menu.c32 +PROMPT ~a +TIMEOUT ~a~%" + (if (> timeout 0) 1 0) + ;; timeout is expressed in 1/10s of seconds. + (* 10 timeout)) + #$@(map boot-parameters->gexp all-entries) + + #$@(if (pair? old-entries) + #~((format port "~%") + #$@(map boot-parameters->gexp old-entries) + (format port "~%")) + #~()))))) + + (gexp->derivation "extlinux.conf" builder)) + + + + +;;; +;;; Install procedures. +;;; + +(define dd + #~(lambda (bs count if of) + (zero? (system* "dd" + (string-append "bs=" (number->string bs)) + (string-append "count=" (number->string count)) + (string-append "if=" if) + (string-append "of=" of))))) + +(define install-extlinux + #~(lambda (bootloader device mount-point) + (let ((extlinux (string-append bootloader "/sbin/extlinux")) + (install-dir (string-append mount-point "/boot/extlinux")) + (syslinux-dir (string-append bootloader "/share/syslinux"))) + (for-each (lambda (file) + (install-file file install-dir)) + (find-files syslinux-dir "\\.c32$")) + + (unless (and (zero? (system* extlinux "--install" install-dir)) + (#$dd 440 1 (string-append syslinux-dir "/mbr.bin") device)) + (error "failed to install SYSLINUX"))))) + + + +;;; +;;; Bootloader definitions. +;;; + +(define extlinux-bootloader + (bootloader + (name 'extlinux) + (package syslinux) + (installer install-extlinux) + (configuration-file "/boot/extlinux/extlinux.conf") + (configuration-file-generator extlinux-configuration-file))) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm new file mode 100644 index 0000000000..49616b7164 --- /dev/null +++ b/gnu/bootloader/grub.scm @@ -0,0 +1,448 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2017 Leo Famulari +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu bootloader grub) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix records) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix download) + #:use-module (gnu artwork) + #:use-module (gnu system) + #:use-module (gnu bootloader) + #:use-module (gnu system file-systems) + #:autoload (gnu packages bootloaders) (grub) + #:autoload (gnu packages compression) (gzip) + #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) + #:export (grub-image + grub-image? + grub-image-aspect-ratio + grub-image-file + + grub-theme + grub-theme? + grub-theme-images + grub-theme-color-normal + grub-theme-color-highlight + + %background-image + %default-theme + + grub-bootloader + grub-efi-bootloader + + grub-configuration)) + +;;; Commentary: +;;; +;;; Configuration of GNU GRUB. +;;; +;;; Code: + +(define (strip-mount-point mount-point file) + "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object +denoting a file name." + (if (string=? mount-point "/") + file + #~(let ((file #$file)) + (if (string-prefix? #$mount-point file) + (substring #$file #$(string-length mount-point)) + file)))) + +(define-record-type* + grub-image make-grub-image + grub-image? + (aspect-ratio grub-image-aspect-ratio ;rational number + (default 4/3)) + (file grub-image-file)) ;file-valued gexp (SVG) + +(define-record-type* + grub-theme make-grub-theme + grub-theme? + (images grub-theme-images + (default '())) ;list of + (color-normal grub-theme-color-normal + (default '((fg . cyan) (bg . blue)))) + (color-highlight grub-theme-color-highlight + (default '((fg . white) (bg . blue))))) + +(define %background-image + (grub-image + (aspect-ratio 4/3) + (file (file-append %artwork-repository + "/grub/GuixSD-fully-black-4-3.svg")))) + +(define %default-theme + ;; Default theme contributed by Felipe López. + (grub-theme + (images (list %background-image)) + (color-highlight '((fg . yellow) (bg . black))) + (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030 + +(define-record-type* + menu-entry make-menu-entry + menu-entry? + (label menu-entry-label) + (device menu-entry-device ; file system uuid, label, or #f + (default #f)) + (device-mount-point menu-entry-device-mount-point + (default "/")) + (linux menu-entry-linux) + (linux-arguments menu-entry-linux-arguments + (default '())) ; list of string-valued gexps + (initrd menu-entry-initrd)) ; file name of the initrd as a gexp + + +;;; +;;; Background image & themes. +;;; + +(define (bootloader-theme config) + "Return user defined theme in CONFIG if defined or %default-theme +otherwise." + (or (bootloader-configuration-theme config) %default-theme)) + +(define* (svg->png svg #:key width height) + "Build a PNG of HEIGHT x WIDTH from SVG." + (gexp->derivation "grub-image.png" + (with-imported-modules '((gnu build svg)) + #~(begin + ;; We need these two libraries. + (add-to-load-path (string-append #+guile-rsvg + "/share/guile/site/" + (effective-version))) + (add-to-load-path (string-append #+guile-cairo + "/share/guile/site/" + (effective-version))) + + (use-modules (gnu build svg)) + (svg->png #+svg #$output + #:width #$width + #:height #$height))))) + +(define* (grub-background-image config #:key (width 1024) (height 768)) + "Return the GRUB background image defined in CONFIG with a ratio of +WIDTH/HEIGHT, or #f if none was found." + (let* ((ratio (/ width height)) + (image (find (lambda (image) + (= (grub-image-aspect-ratio image) ratio)) + (grub-theme-images + (bootloader-theme config))))) + (if image + (svg->png (grub-image-file image) + #:width width #:height height) + (with-monad %store-monad + (return #f))))) + +(define* (eye-candy config store-device store-mount-point + #:key system port) + "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the +'grub.cfg' part concerned with graphics mode, background images, colors, and +all that. STORE-DEVICE designates the device holding the store, and +STORE-MOUNT-POINT is its mount point; these are used to determine where the +background image and fonts must be searched for. SYSTEM must be the target +system string---e.g., \"x86_64-linux\"." + (define setup-gfxterm-body + ;; Intel and EFI systems need to be switched into graphics mode, whereas + ;; most other modern architectures have no other mode and therefore don't + ;; need to be switched. + (if (string-match "^(x86_64|i[3-6]86)-" system) + " + # Leave 'gfxmode' to 'auto'. + insmod video_bochs + insmod video_cirrus + insmod gfxterm + + if [ \"${grub_platform}\" == efi ]; then + # This is for (U)EFI systems (these modules are unavailable in the + # non-EFI GRUB.) If we don't load them, GRUB boots in \"blind mode\", + # which isn't convenient. + insmod efi_gop + insmod efi_uga + else + # These are specific to non-EFI Intel machines. + insmod vbe + insmod vga + fi +" + "")) + + (define (setup-gfxterm config font-file) + (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config)) + #~(format #f "if loadfont ~a; then + setup_gfxterm +fi~%" #$font-file) + "")) + + (define (theme-colors type) + (let* ((theme (bootloader-theme config)) + (colors (type theme))) + (string-append (symbol->string (assoc-ref colors 'fg)) "/" + (symbol->string (assoc-ref colors 'bg))))) + + (define font-file + (strip-mount-point store-mount-point + (file-append grub "/share/grub/unicode.pf2"))) + + (mlet* %store-monad ((image (grub-background-image config))) + (return (and image + #~(format #$port " +function setup_gfxterm {~a} + +# Set 'root' to the partition that contains /gnu/store. +~a + +~a +~a + +insmod png +if background_image ~a; then + set color_normal=~a + set color_highlight=~a +else + set menu_color_normal=cyan/blue + set menu_color_highlight=white/blue +fi~%" + #$setup-gfxterm-body + #$(grub-root-search store-device font-file) + #$(setup-gfxterm config font-file) + #$(grub-setup-io config) + + #$(strip-mount-point store-mount-point image) + #$(theme-colors grub-theme-color-normal) + #$(theme-colors grub-theme-color-highlight)))))) + + +;;; +;;; Configuration file. +;;; + +(define (grub-setup-io config) + "Return GRUB commands to configure the input / output interfaces. The result +is a string that can be inserted in grub.cfg." + (let* ((symbols->string (lambda (list) + (string-join (map symbol->string list) " "))) + (outputs (bootloader-configuration-terminal-outputs config)) + (inputs (bootloader-configuration-terminal-inputs config)) + (unit (bootloader-configuration-serial-unit config)) + (speed (bootloader-configuration-serial-speed config)) + + ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT, + ;; as documented in GRUB manual section "Simple Configuration + ;; Handling". + (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3 + gfxterm vga_text mda_text morse spkmodem)) + (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3 + at_keyboard usb_keyboard)) + + (io (string-append + "terminal_output " + (symbols->string + (map + (lambda (output) + (if (memq output valid-outputs) output #f)) outputs)) "\n" + (if (null? inputs) + "" + (string-append + "terminal_input " + (symbols->string + (map + (lambda (input) + (if (memq input valid-inputs) input #f)) inputs)) "\n")) + ;; UNIT and SPEED are arguments to the same GRUB command + ;; ("serial"), so we process them together. + (if (or unit speed) + (string-append + "serial" + (if unit + ;; COM ports 1 through 4 + (if (and (exact-integer? unit) (<= unit 3) (>= unit 0)) + (string-append " --unit=" (number->string unit)) + #f) + "") + (if speed + (if (exact-integer? speed) + (string-append " --speed=" (number->string speed)) + #f) + "")) + "")))) + (format #f "~a" io))) + +(define (grub-root-search device file) + "Return the GRUB 'search' command to look for DEVICE, which contains FILE, +a gexp. The result is a gexp that can be inserted in the grub.cfg-generation +code." + ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but + ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of + ;; custom menu entries. In the latter case, don't emit a 'search' command. + (if (and (string? file) (not (string-prefix? "/" file))) + "" + (match device + ;; Preferably refer to DEVICE by its UUID or label. This is more + ;; efficient and less ambiguous, see . + ((? bytevector? uuid) + (format #f "search --fs-uuid --set ~a" + (uuid->string device))) + ((? string? label) + (format #f "search --label --set ~a" label)) + (#f + #~(format #f "search --file --set ~a" #$file))))) + +(define (boot-parameters->menu-entry conf) + "Convert a instance to a corresponding ." + (menu-entry + (label (boot-parameters-label conf)) + (device (boot-parameters-store-device conf)) + (device-mount-point (boot-parameters-store-mount-point conf)) + (linux (boot-parameters-kernel conf)) + (linux-arguments (boot-parameters-kernel-arguments conf)) + (initrd (boot-parameters-initrd conf)))) + +(define* (grub-configuration-file config entries + #:key + (system (%current-system)) + (old-entries '())) + "Return the GRUB configuration file corresponding to CONFIG, a + object, and where the store is available at +STORE-FS, a object. OLD-ENTRIES is taken to be a list of menu +entries corresponding to old generations of the system." + (define all-entries + (map boot-parameters->menu-entry + (append entries + (bootloader-configuration-menu-entries config)))) + + (define entry->gexp + (match-lambda + (($ label device device-mount-point + linux arguments initrd) + ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. + ;; Use the right file names for LINUX and INITRD in case + ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a + ;; separate partition. + (let ((linux (strip-mount-point device-mount-point linux)) + (initrd (strip-mount-point device-mount-point initrd))) + #~(format port "menuentry ~s { + ~a + linux ~a ~a + initrd ~a +}~%" + #$label + #$(grub-root-search device linux) + #$linux (string-join (list #$@arguments)) + #$initrd))))) + + (mlet %store-monad ((sugar (eye-candy config + (menu-entry-device (first all-entries)) + (menu-entry-device-mount-point + (first all-entries)) + #:system system + #:port #~port))) + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port + "# This file was generated from your GuixSD configuration. Any changes +# will be lost upon reconfiguration. +") + #$sugar + (format port " +set default=~a +set timeout=~a~%" + #$(bootloader-configuration-default-entry config) + #$(bootloader-configuration-timeout config)) + #$@(map entry->gexp all-entries) + + #$@(if (pair? old-entries) + #~((format port " +submenu \"GNU system, old configurations...\" {~%") + #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) + (format port "}~%")) + #~())))) + + (gexp->derivation "grub.cfg" builder))) + + + +;;; +;;; Install procedures. +;;; + +(define install-grub + #~(lambda (bootloader device mount-point) + ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. + (let ((grub (string-append bootloader "/sbin/grub-install")) + (install-dir (string-append mount-point "/boot"))) + ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or + ;; root partition. + (setenv "GRUB_ENABLE_CRYPTODISK" "y") + + (unless (zero? (system* grub "--no-floppy" + "--boot-directory" install-dir + device)) + (error "failed to install GRUB"))))) + + + +;;; +;;; Bootloader definitions. +;;; + +(define grub-bootloader + (bootloader + (name 'grub) + (package grub) + (installer install-grub) + (configuration-file "/boot/grub/grub.cfg") + (configuration-file-generator grub-configuration-file))) + +(define* grub-efi-bootloader + (bootloader + (inherit grub-bootloader) + (name 'grub-efi) + (package grub-efi))) + + +;;; +;;; Compatibility macros. +;;; + +(define-syntax grub-configuration + (syntax-rules (grub) + ((_ (grub package) fields ...) + (if (eq? package grub) + (bootloader-configuration + (bootloader grub-bootloader) + fields ...) + (bootloader-configuration + (bootloader grub-efi-bootloader) + fields ...))) + ((_ fields ...) + (bootloader-configuration + (bootloader grub-bootloader) + fields ...)))) + +;;; grub.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index c560c71725..d0c5b9daf8 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -36,6 +36,9 @@ GNU_SYSTEM_MODULES = \ gnu.scm \ %D%/artwork.scm \ + %D%/bootloader.scm \ + %D%/bootloader/grub.scm \ + %D%/bootloader/extlinux.scm \ %D%/packages.scm \ %D%/packages/abduco.scm \ %D%/packages/abiword.scm \ @@ -443,7 +446,6 @@ GNU_SYSTEM_MODULES = \ \ %D%/system.scm \ %D%/system/file-systems.scm \ - %D%/system/grub.scm \ %D%/system/install.scm \ %D%/system/linux-container.scm \ %D%/system/linux-initrd.scm \ diff --git a/gnu/system.scm b/gnu/system.scm index f9a0da9a75..a705bf6900 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -48,6 +48,7 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services base) + #:use-module (gnu bootloader) #:use-module (gnu system shadow) #:use-module (gnu system nss) #:use-module (gnu system locale) @@ -139,7 +140,7 @@ booted from ROOT-DEVICE" (default linux-libre)) (kernel-arguments operating-system-user-kernel-arguments (default '())) ; list of gexps/strings - (bootloader operating-system-bootloader) ; + (bootloader operating-system-bootloader) ; (initrd operating-system-initrd ; (list fs) -> M derivation (default base-initrd)) @@ -847,12 +848,11 @@ populate the \"old entries\" menu." (root-device -> (if (eq? 'uuid (file-system-title root-fs)) (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) - (entry (operating-system-boot-parameters os system root-device))) - ((module-ref (resolve-interface '(gnu system grub)) - 'grub-configuration-file) - (operating-system-bootloader os) - (list entry) - #:old-entries old-entries))) + (entry (operating-system-boot-parameters os system root-device)) + (bootloader-conf -> (operating-system-bootloader os))) + ((bootloader-configuration-file-generator + (bootloader-configuration-bootloader bootloader-conf)) + bootloader-conf (list entry) #:old-entries old-entries))) (define (fs->boot-device fs) "Given FS, a object, return a value suitable for use as the diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm deleted file mode 100644 index 85878de85c..0000000000 --- a/gnu/system/grub.scm +++ /dev/null @@ -1,407 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès -;;; Copyright © 2016 Chris Marusich -;;; Copyright © 2017 Leo Famulari -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu system grub) - #:use-module (guix store) - #:use-module (guix packages) - #:use-module (guix derivations) - #:use-module (guix records) - #:use-module (guix monads) - #:use-module (guix gexp) - #:use-module (guix download) - #:use-module (gnu artwork) - #:use-module (gnu system) - #:use-module (gnu system file-systems) - #:autoload (gnu packages bootloaders) (grub) - #:autoload (gnu packages compression) (gzip) - #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-1) - #:use-module (rnrs bytevectors) - #:export (grub-image - grub-image? - grub-image-aspect-ratio - grub-image-file - - grub-theme - grub-theme? - grub-theme-images - grub-theme-color-normal - grub-theme-color-highlight - - %background-image - %default-theme - - grub-configuration - grub-configuration? - grub-configuration-device - grub-configuration-grub - - menu-entry - menu-entry? - - grub-configuration-file)) - -;;; Commentary: -;;; -;;; Configuration of GNU GRUB. -;;; -;;; Code: - -(define (strip-mount-point mount-point file) - "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object -denoting a file name." - (if (string=? mount-point "/") - file - #~(let ((file #$file)) - (if (string-prefix? #$mount-point file) - (substring #$file #$(string-length mount-point)) - file)))) - -(define-record-type* - grub-image make-grub-image - grub-image? - (aspect-ratio grub-image-aspect-ratio ;rational number - (default 4/3)) - (file grub-image-file)) ;file-valued gexp (SVG) - -(define-record-type* - grub-theme make-grub-theme - grub-theme? - (images grub-theme-images - (default '())) ;list of - (color-normal grub-theme-color-normal - (default '((fg . cyan) (bg . blue)))) - (color-highlight grub-theme-color-highlight - (default '((fg . white) (bg . blue))))) - -(define %background-image - (grub-image - (aspect-ratio 4/3) - (file (file-append %artwork-repository - "/grub/GuixSD-fully-black-4-3.svg")))) - -(define %default-theme - ;; Default theme contributed by Felipe López. - (grub-theme - (images (list %background-image)) - (color-highlight '((fg . yellow) (bg . black))) - (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030 - -(define-record-type* - grub-configuration make-grub-configuration - grub-configuration? - (grub grub-configuration-grub ; package - (default (@ (gnu packages bootloaders) grub))) - (device grub-configuration-device) ; string - (menu-entries grub-configuration-menu-entries ; list - (default '())) - (default-entry grub-configuration-default-entry ; integer - (default 0)) - (timeout grub-configuration-timeout ; integer - (default 5)) - (theme grub-configuration-theme ; - (default %default-theme)) - (terminal-outputs grub-configuration-terminal-outputs ; list of symbols - (default '(gfxterm))) - (terminal-inputs grub-configuration-terminal-inputs ; list of symbols - (default '())) - (serial-unit grub-configuration-serial-unit ; integer | #f - (default #f)) - (serial-speed grub-configuration-serial-speed ; integer | #f - (default #f))) - -(define-record-type* - menu-entry make-menu-entry - menu-entry? - (label menu-entry-label) - (device menu-entry-device ; file system uuid, label, or #f - (default #f)) - (device-mount-point menu-entry-device-mount-point - (default "/")) - (linux menu-entry-linux) - (linux-arguments menu-entry-linux-arguments - (default '())) ; list of string-valued gexps - (initrd menu-entry-initrd)) ; file name of the initrd as a gexp - - -;;; -;;; Background image & themes. -;;; - -(define* (svg->png svg #:key width height) - "Build a PNG of HEIGHT x WIDTH from SVG." - (gexp->derivation "grub-image.png" - (with-imported-modules '((gnu build svg)) - #~(begin - ;; We need these two libraries. - (add-to-load-path (string-append #+guile-rsvg - "/share/guile/site/" - (effective-version))) - (add-to-load-path (string-append #+guile-cairo - "/share/guile/site/" - (effective-version))) - - (use-modules (gnu build svg)) - (svg->png #+svg #$output - #:width #$width - #:height #$height))))) - -(define* (grub-background-image config #:key (width 1024) (height 768)) - "Return the GRUB background image defined in CONFIG with a ratio of -WIDTH/HEIGHT, or #f if none was found." - (let* ((ratio (/ width height)) - (image (find (lambda (image) - (= (grub-image-aspect-ratio image) ratio)) - (grub-theme-images (grub-configuration-theme config))))) - (if image - (svg->png (grub-image-file image) - #:width width #:height height) - (with-monad %store-monad - (return #f))))) - -(define* (eye-candy config store-device store-mount-point - #:key system port) - "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the -'grub.cfg' part concerned with graphics mode, background images, colors, and -all that. STORE-DEVICE designates the device holding the store, and -STORE-MOUNT-POINT is its mount point; these are used to determine where the -background image and fonts must be searched for. SYSTEM must be the target -system string---e.g., \"x86_64-linux\"." - (define setup-gfxterm-body - ;; Intel and EFI systems need to be switched into graphics mode, whereas - ;; most other modern architectures have no other mode and therefore don't - ;; need to be switched. - (if (string-match "^(x86_64|i[3-6]86)-" system) - " - # Leave 'gfxmode' to 'auto'. - insmod video_bochs - insmod video_cirrus - insmod gfxterm - - if [ \"${grub_platform}\" == efi ]; then - # This is for (U)EFI systems (these modules are unavailable in the - # non-EFI GRUB.) If we don't load them, GRUB boots in \"blind mode\", - # which isn't convenient. - insmod efi_gop - insmod efi_uga - else - # These are specific to non-EFI Intel machines. - insmod vbe - insmod vga - fi -" - "")) - - (define (setup-gfxterm config font-file) - (if (memq 'gfxterm (grub-configuration-terminal-outputs config)) - #~(format #f "if loadfont ~a; then - setup_gfxterm -fi~%" #$font-file) - "")) - - (define (theme-colors type) - (let* ((theme (grub-configuration-theme config)) - (colors (type theme))) - (string-append (symbol->string (assoc-ref colors 'fg)) "/" - (symbol->string (assoc-ref colors 'bg))))) - - (define font-file - (strip-mount-point store-mount-point - (file-append grub "/share/grub/unicode.pf2"))) - - (mlet* %store-monad ((image (grub-background-image config))) - (return (and image - #~(format #$port " -function setup_gfxterm {~a} - -# Set 'root' to the partition that contains /gnu/store. -~a - -~a -~a - -insmod png -if background_image ~a; then - set color_normal=~a - set color_highlight=~a -else - set menu_color_normal=cyan/blue - set menu_color_highlight=white/blue -fi~%" - #$setup-gfxterm-body - #$(grub-root-search store-device font-file) - #$(setup-gfxterm config font-file) - #$(grub-setup-io config) - - #$(strip-mount-point store-mount-point image) - #$(theme-colors grub-theme-color-normal) - #$(theme-colors grub-theme-color-highlight)))))) - - -;;; -;;; Configuration file. -;;; - -(define (grub-setup-io config) - "Return GRUB commands to configure the input / output interfaces. The result -is a string that can be inserted in grub.cfg." - (let* ((symbols->string (lambda (list) - (string-join (map symbol->string list) " "))) - (outputs (grub-configuration-terminal-outputs config)) - (inputs (grub-configuration-terminal-inputs config)) - (unit (grub-configuration-serial-unit config)) - (speed (grub-configuration-serial-speed config)) - - ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT, - ;; as documented in GRUB manual section "Simple Configuration - ;; Handling". - (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3 - gfxterm vga_text mda_text morse spkmodem)) - (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3 - at_keyboard usb_keyboard)) - - (io (string-append - "terminal_output " - (symbols->string - (map - (lambda (output) - (if (memq output valid-outputs) output #f)) outputs)) "\n" - (if (null? inputs) - "" - (string-append - "terminal_input " - (symbols->string - (map - (lambda (input) - (if (memq input valid-inputs) input #f)) inputs)) "\n")) - ;; UNIT and SPEED are arguments to the same GRUB command - ;; ("serial"), so we process them together. - (if (or unit speed) - (string-append - "serial" - (if unit - ;; COM ports 1 through 4 - (if (and (exact-integer? unit) (<= unit 3) (>= unit 0)) - (string-append " --unit=" (number->string unit)) - #f) - "") - (if speed - (if (exact-integer? speed) - (string-append " --speed=" (number->string speed)) - #f) - "")) - "")))) - (format #f "~a" io))) - -(define (grub-root-search device file) - "Return the GRUB 'search' command to look for DEVICE, which contains FILE, -a gexp. The result is a gexp that can be inserted in the grub.cfg-generation -code." - ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but - ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of - ;; custom menu entries. In the latter case, don't emit a 'search' command. - (if (and (string? file) (not (string-prefix? "/" file))) - "" - (match device - ;; Preferably refer to DEVICE by its UUID or label. This is more - ;; efficient and less ambiguous, see . - ((? bytevector? uuid) - (format #f "search --fs-uuid --set ~a" - (uuid->string device))) - ((? string? label) - (format #f "search --label --set ~a" label)) - (#f - #~(format #f "search --file --set ~a" #$file))))) - -(define (boot-parameters->menu-entry conf) - "Convert a instance to a corresponding ." - (menu-entry - (label (boot-parameters-label conf)) - (device (boot-parameters-store-device conf)) - (device-mount-point (boot-parameters-store-mount-point conf)) - (linux (boot-parameters-kernel conf)) - (linux-arguments (boot-parameters-kernel-arguments conf)) - (initrd (boot-parameters-initrd conf)))) - -(define* (grub-configuration-file config entries - #:key - (system (%current-system)) - (old-entries '())) - "Return the GRUB configuration file corresponding to CONFIG, a - object, and where the store is available at STORE-FS, a - object. OLD-ENTRIES is taken to be a list of menu entries -corresponding to old generations of the system." - (define all-entries - (append (map boot-parameters->menu-entry entries) - (grub-configuration-menu-entries config))) - - (define entry->gexp - (match-lambda - (($ label device device-mount-point - linux arguments initrd) - ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. - ;; Use the right file names for LINUX and INITRD in case - ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a - ;; separate partition. - (let ((linux (strip-mount-point device-mount-point linux)) - (initrd (strip-mount-point device-mount-point initrd))) - #~(format port "menuentry ~s { - ~a - linux ~a ~a - initrd ~a -}~%" - #$label - #$(grub-root-search device linux) - #$linux (string-join (list #$@arguments)) - #$initrd))))) - - (mlet %store-monad ((sugar (eye-candy config - (menu-entry-device (first all-entries)) - (menu-entry-device-mount-point - (first all-entries)) - #:system system - #:port #~port))) - (define builder - #~(call-with-output-file #$output - (lambda (port) - (format port - "# This file was generated from your GuixSD configuration. Any changes -# will be lost upon reconfiguration. -") - #$sugar - (format port " -set default=~a -set timeout=~a~%" - #$(grub-configuration-default-entry config) - #$(grub-configuration-timeout config)) - #$@(map entry->gexp all-entries) - - #$@(if (pair? old-entries) - #~((format port " -submenu \"GNU system, old configurations...\" {~%") - #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) - (format port "}~%")) - #~())))) - - (gexp->derivation "grub.cfg" builder))) - -;;; grub.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2c8b954c80..080014cde4 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -49,7 +49,7 @@ #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module (gnu system linux-initrd) - #:use-module (gnu system grub) + #:use-module (gnu bootloader) #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) diff --git a/gnu/tests.scm b/gnu/tests.scm index 810711ab91..2886a982f4 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,8 +21,8 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix records) + #:use-module (gnu bootloader grub) #:use-module (gnu system) - #:use-module (gnu system grub) #:use-module (gnu system file-systems) #:use-module (gnu system shadow) #:use-module (gnu services) diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm index 1f28f5a5b8..9e1ac1d55a 100644 --- a/gnu/tests/nfs.scm +++ b/gnu/tests/nfs.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ludovic Courtès ;;; Copyright © 2016 John Darrington +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,8 +20,8 @@ (define-module (gnu tests nfs) #:use-module (gnu tests) + #:use-module (gnu bootloader grub) #:use-module (gnu system) - #:use-module (gnu system grub) #:use-module (gnu system file-systems) #:use-module (gnu system shadow) #:use-module (gnu system vm) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9c09767508..5fd0d7600c 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -38,10 +38,10 @@ #:use-module (guix build utils) #:use-module (gnu build install) #:use-module (gnu system) + #:use-module (gnu bootloader) #:use-module (gnu system file-systems) #:use-module (gnu system linux-container) #:use-module (gnu system vm) - #:use-module (gnu system grub) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services herd) @@ -598,8 +598,12 @@ output when building a system derivation, such as a disk image." #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) - (grub (package->derivation (grub-configuration-grub - (operating-system-bootloader os)))) + (bootloader (let ((bootloader (bootloader-package + (bootloader-configuration-bootloader + (operating-system-bootloader os))))) + (if bootloader + (package->derivation bootloader) + (return #f)))) (grub.cfg (if (eq? 'container action) (return #f) (operating-system-bootcfg os @@ -611,8 +615,8 @@ output when building a system derivation, such as a disk image." ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC ;; root. See . (drvs -> (if (memq action '(init reconfigure)) - (if bootloader? - (list sys grub.cfg grub) + (if (and bootloader? bootloader) + (list sys grub.cfg bootloader) (list sys grub.cfg)) (list sys))) (% (if derivations-only? @@ -628,8 +632,8 @@ output when building a system derivation, such as a disk image." drvs) ;; Make sure GRUB is accessible. - (when bootloader? - (let ((prefix (derivation->output-path grub))) + (when (and bootloader? bootloader) + (let ((prefix (derivation->output-path bootloader))) (setenv "PATH" (string-append prefix "/bin:" prefix "/sbin:" (getenv "PATH"))))) @@ -832,7 +836,7 @@ resulting from command-line parsing." ((first second) second) (_ #f))) (device (and bootloader? - (grub-configuration-device + (bootloader-configuration-device (operating-system-bootloader os))))) (with-store store -- cgit 1.4.1 From bcaf67c44f4556b4a632310013a06318811aa0f0 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 2 Apr 2017 15:10:52 +0200 Subject: bootloader: Add bootloader name to boot-parameters record. * gnu/system.scm ()[name]: New field. (boot-parameters-boot-name): Ditto. (operating-system-boot-parameters-file): Add new field. (operating-system-boot-parameters): Ditto. (read-boot-parameters): Ditto. --- gnu/system.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index a705bf6900..5bd60176fe 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -104,6 +104,7 @@ boot-parameters? boot-parameters-label boot-parameters-root-device + boot-parameters-boot-name boot-parameters-store-device boot-parameters-store-mount-point boot-parameters-kernel @@ -214,6 +215,7 @@ directly by the user." ;; exactly to the device field of the object representing the ;; OS's root file system, so it might be a device path like "/dev/sda3". (root-device boot-parameters-root-device) + (boot-name boot-parameters-boot-name) (store-device boot-parameters-store-device) (store-mount-point boot-parameters-store-mount-point) (kernel boot-parameters-kernel) @@ -232,6 +234,11 @@ directly by the user." (label label) (root-device root) + (boot-name + (match (assq 'boot-name rest) + ((_ args) args) + (#f 'grub))) ; for compatibility reasons. + ;; In the past, we would store the directory name of the kernel instead ;; of the absolute file name of its image. Detect that and correct it. (kernel (if (string=? linux (direct-store-path linux)) @@ -869,6 +876,9 @@ kernel arguments for that derivation to ." (mlet* %store-monad ((initrd (operating-system-initrd-file os)) (store -> (operating-system-store-file-system os)) + (bootloader -> (bootloader-configuration-bootloader + (operating-system-bootloader os))) + (boot-name -> (bootloader-name bootloader)) (label -> (kernel->boot-label (operating-system-kernel os)))) (return (boot-parameters (label label) @@ -879,6 +889,7 @@ kernel arguments for that derivation to ." (operating-system-kernel-arguments os system.drv root-device) (operating-system-user-kernel-arguments os))) (initrd initrd) + (boot-name boot-name) (store-device (fs->boot-device store)) (store-mount-point (file-system-mount-point store)))))) @@ -904,6 +915,7 @@ being stored into the \"parameters\" file)." (kernel-arguments #$(boot-parameters-kernel-arguments params)) (initrd #$(boot-parameters-initrd params)) + (boot-name #$(boot-parameters-boot-name params)) (store (device #$(boot-parameters-store-device params)) (mount-point #$(boot-parameters-store-mount-point params)))) -- cgit 1.4.1 From b55dd31660934b9eca1862e4015e72ab8360aeb1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 19 May 2017 23:36:56 +0200 Subject: system: Use Guile 2.2 rather than 2.0 in %BASE-PACKAGES. * gnu/system.scm (%base-packages): Change GUILE-2.0 to GUILE-2.2. --- gnu/system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 5bd60176fe..0076f2fcb1 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -502,7 +502,7 @@ explicitly appear in OS." ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. (map canonical-package - (list guile-2.0 bash coreutils-8.27 findutils grep sed + (list guile-2.2 bash coreutils-8.27 findutils grep sed diffutils patch gawk tar gzip bzip2 xz lzip)))) (define %default-issue -- cgit 1.4.1