From db6b9d2f4bc59511904e8c1412d0257675c46095 Mon Sep 17 00:00:00 2001 From: Simon South Date: Sat, 5 Dec 2020 10:27:55 -0500 Subject: services: Add transmission-daemon service. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/file-sharing.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * po/packages/POTFILES.in: Add it. * tests/services/file-sharing.scm: New file. * Makefile.am (SCM_TESTS): Add it. * doc/guix.texi (File-Sharing Services): New section. Signed-off-by: 宋文武 --- tests/services/file-sharing.scm | 59 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) create mode 100644 tests/services/file-sharing.scm (limited to 'tests') diff --git a/tests/services/file-sharing.scm b/tests/services/file-sharing.scm new file mode 100644 index 0000000000..27bec57325 --- /dev/null +++ b/tests/services/file-sharing.scm @@ -0,0 +1,59 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Simon South +;;; +;;; 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 (tests services file-sharing) + #:use-module (gnu services file-sharing) + #:use-module (srfi srfi-64)) + +;;; Tests for the (gnu services file-sharing) module. + +(test-begin "file-sharing") + + +;;; +;;; Transmission Daemon. +;;; + +(define %transmission-salt-length 8) + +(define (valid-transmission-salt? salt) + (and (string? salt) + (eqv? (string-length salt) %transmission-salt-length))) + +(test-assert "transmission-random-salt" + (valid-transmission-salt? (transmission-random-salt))) + +(test-equal "transmission-password-hash, typical values" + "{ef6fba106cdef3aac64d1410090cae353cbecde53ceVVQO2" + (transmission-password-hash "transmission" "3ceVVQO2")) + +(test-equal "transmission-password-hash, empty password" + "{820f816515d8969d058d07a1de018650619ee7ffCp.I5SWg" + (transmission-password-hash "" "Cp.I5SWg")) + +(test-error "transmission-password-hash, salt value too short" + (transmission-password-hash + "transmission" + (make-string (- %transmission-salt-length 1) #\a))) + +(test-error "transmission-password-hash, salt value too long" + (transmission-password-hash + "transmission" + (make-string (+ %transmission-salt-length 1) #\a))) + +(test-end "file-sharing") -- cgit v1.2.3 From ee2a5da80a9bda25542c00a7a35a9ddddcbd58af Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 19 Jan 2021 18:09:28 +0100 Subject: scripts: system: Remove 'vm-image' command. Remove the 'vm-image' command that has been superseded by the 'image' command. * gnu/system/vm.scm (system-qemu-image): Remove it. * guix/scripts/system.scm (system-derivation-for-action): Mark 'vm-image' command as deprecated and use the image API to produce the VM image. (perform-action, show-help): Adapt accordingly. * tests/guix-system.sh: Ditto. * doc/guix.texi (Invoking guix system, Running Guix in a VM): Ditto. * etc/completion/fish/guix.fish: Ditto. * etc/completion/zsh/_guix: Ditto. --- doc/guix.texi | 33 +++++++++++------------ etc/completion/fish/guix.fish | 7 +++-- etc/completion/zsh/_guix | 2 +- gnu/system/vm.scm | 63 ------------------------------------------- guix/scripts/system.scm | 24 ++++++++--------- tests/guix-system.sh | 2 +- 6 files changed, 33 insertions(+), 98 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 942d5f93df..69897169bd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -32575,8 +32575,7 @@ size of the image. @cindex System images, creation in various formats @cindex Creating system images in various formats -@item vm-image -@itemx image +@item image @itemx docker-image Return a virtual machine, disk image, or Docker image of the operating system declared in @var{file} that stands alone. By default, @@ -32620,15 +32619,15 @@ the image to it using the following command: The @code{--list-image-types} command lists all the available image types. -@cindex vm-image, creating virtual machine images -When using @code{vm-image}, the returned image is in qcow2 format, which -the QEMU emulator can efficiently use. @xref{Running Guix in a VM}, for -more information on how to run the image in a virtual machine. The -@code{grub-bootloader} bootloader is always used independently of what -is declared in the @code{operating-system} file passed as argument. -This is to make it easier to work with QEMU, which uses the SeaBIOS BIOS -by default, expecting a bootloader to be installed in the Master Boot -Record (MBR). +@cindex creating virtual machine images +When using the @code{qcow2} image type, the returned image is in qcow2 +format, which the QEMU emulator can efficiently use. @xref{Running Guix +in a VM}, for more information on how to run the image in a virtual +machine. The @code{grub-bootloader} bootloader is always used +independently of what is declared in the @code{operating-system} file +passed as argument. This is to make it easier to work with QEMU, which +uses the SeaBIOS BIOS by default, expecting a bootloader to be installed +in the Master Boot Record (MBR). @cindex docker-image, creating docker images When using @code{docker-image}, a Docker image is produced. Guix builds @@ -32723,7 +32722,7 @@ create a virtual machine image that contains provenance information, you can run: @example -guix system vm-image --save-provenance config.scm +guix system image -t qcow2 --save-provenance config.scm @end example That way, the resulting image will effectively ``embed its own source'' @@ -32746,10 +32745,10 @@ When this option is omitted, @command{guix system} uses the for burning on CDs and DVDs. @item --image-size=@var{size} -For the @code{vm-image} and @code{image} actions, create an image -of the given @var{size}. @var{size} may be a number of bytes, or it may -include a unit as a suffix (@pxref{Block size, size specifications,, -coreutils, GNU Coreutils}). +For the @code{image} action, create an image of the given @var{size}. +@var{size} may be a number of bytes, or it may include a unit as a +suffix (@pxref{Block size, size specifications,, coreutils, GNU +Coreutils}). When this option is omitted, @command{guix system} computes an estimate of the image size as a function of the size of the system declared in @@ -33112,7 +33111,7 @@ If you built your own image, you must copy it out of the store before you can use it. When invoking QEMU, you must choose a system emulator that is suitable for your hardware platform. Here is a minimal QEMU invocation that will boot the result of @command{guix system -vm-image} on x86_64 hardware: +image -t qcow2} on x86_64 hardware: @example $ qemu-system-x86_64 \ diff --git a/etc/completion/fish/guix.fish b/etc/completion/fish/guix.fish index 73bd176112..422baab4bb 100644 --- a/etc/completion/fish/guix.fish +++ b/etc/completion/fish/guix.fish @@ -133,7 +133,7 @@ complete -f -c guix -n '__fish_guix_using_command pull' -l url -d 'download the complete -f -c guix -n '__fish_guix_using_command pull' -l bootstrap -d 'use the bootstrap Guile to build the new Guix' #### system -set -l remotecommands reconfigure roll-back switch-generation list-generations build container vm vm-image disk-image init extension-graph shepherd-graph load-path keep-failed keep-going dry-run fallback no-substitutes substitutes-urls no-grafts no-offload max-silent-time timeout verbosity rounds cores max-jobs derivation on-error image-size no-grub share expose full-boot +set -l remotecommands reconfigure roll-back switch-generation list-generations build container vm image init extension-graph shepherd-graph load-path keep-failed keep-going dry-run fallback no-substitutes substitutes-urls no-grafts no-offload max-silent-time timeout verbosity rounds cores max-jobs derivation on-error image-size no-grub share expose full-boot complete -f -c guix -n '__fish_guix_needs_command' -a system -d 'Build the operating system declared in FILE according to ACTION.' complete -f -c guix -n '__fish_guix_using_command system' -l reconfigure -d 'switch to a new operating system configuration' complete -f -c guix -n '__fish_guix_using_command system' -l roll-back -d 'switch to the previous operating system configuration' @@ -142,8 +142,7 @@ complete -f -c guix -n '__fish_guix_using_command system' -l list-generations -d complete -f -c guix -n '__fish_guix_using_command system' -l build -d 'build the operating system without installing anything' complete -f -c guix -n '__fish_guix_using_command system' -l container -d 'build a container that shares the host\'s store' complete -f -c guix -n '__fish_guix_using_command system' -l vm -d 'build a virtual machine image that shares the host\'s store' -complete -f -c guix -n '__fish_guix_using_command system' -l vm-image -d 'build a freestanding virtual machine image' -complete -f -c guix -n '__fish_guix_using_command system' -l disk-image -d 'build a disk image, suitable for a USB stick' +complete -f -c guix -n '__fish_guix_using_command system' -l image -d 'build a disk image, suitable for a USB stick' complete -f -c guix -n '__fish_guix_using_command system' -l init -d 'initialize a root file system to run GNU' complete -f -c guix -n '__fish_guix_using_command system' -l extension-graph -d 'emit the service extension graph in Dot format' complete -f -c guix -n '__fish_guix_using_command system' -l shepherd-graph -d 'emit the graph of shepherd services in Dot format' @@ -167,7 +166,7 @@ complete -f -c guix -n '__fish_guix_using_command system' -s M -d 'allow at most complete -f -c guix -n '__fish_guix_using_command system' -a "--max-jobs=" -d 'allow at most N build jobs' complete -f -c guix -n '__fish_guix_using_command system' -s d -l derivation -d 'return the derivation of the given system' complete -f -c guix -n '__fish_guix_using_command system' -a "--on-error=" -d 'apply STRATEGY when an error occurs while reading FILE' -complete -f -c guix -n '__fish_guix_using_command system' -a "--image-size=" -d 'for \'vm-image\', produce an image of SIZE' +complete -f -c guix -n '__fish_guix_using_command system' -a "--image-size=" -d 'for \'image\', produce an image of SIZE' complete -f -c guix -n '__fish_guix_using_command system' -l no-grub -d 'for \'init\', do not install GRUB' complete -f -c guix -n '__fish_guix_using_command system' -a "--share=" -d 'for \'vm\', share host file system according to SPEC' complete -f -c guix -n '__fish_guix_using_command system' -a "--expose=" -d 'for \'vm\', expose host file system according to SPEC' diff --git a/etc/completion/zsh/_guix b/etc/completion/zsh/_guix index ae93b62b1d..aa1a859e0d 100644 --- a/etc/completion/zsh/_guix +++ b/etc/completion/zsh/_guix @@ -383,7 +383,7 @@ _guix_list_installed_packages() '--max-jobs=[allow at most N build jobs]:N' \ '--derivation[return the derivation of the given system]' \ '--on-error=[apply STRATEGY when an error occurs while reading FILE]:STRATEGY' \ - '--image-size=[for "vm-image", produce an image of SIZE]:SIZE' \ + '--image-size=[for "image", produce an image of SIZE]:SIZE' \ '--no-grub[for "init", do not install GRUB]' \ '--share=[for "vm", share host file system according to SPEC]:SPEC' \ '--expose=[for "vm", expose host file system according to SPEC]:SPEC' \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 1afae6b4ed..d7ae048b81 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -73,7 +73,6 @@ #:export (expression->derivation-in-linux-vm qemu-image virtualized-operating-system - system-qemu-image system-qemu-image/shared-store system-qemu-image/shared-store-script @@ -557,68 +556,6 @@ the operating system." #:single-file-output? #t #:references-graphs `((,graph ,os))))) - -;;; -;;; VM and disk images. -;;; - -(define* (system-qemu-image os - #:key - (file-system-type "ext4") - (disk-image-size (* 900 (expt 2 20)))) - "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes -of the GNU system as described by OS." - (define file-systems-to-keep - ;; Keep only file systems other than root and not normally bound to real - ;; devices. - (remove (lambda (fs) - (let ((target (file-system-mount-point fs)) - (source (file-system-device fs))) - (or (string=? target "/") - (and (string? source) - (string-prefix? "/dev/" source)) - (uuid? source) - (file-system-label? source)))) - (operating-system-file-systems os))) - - (define root-uuid - ;; UUID of the root file system. - (operating-system-uuid os - (if (string=? file-system-type "iso9660") - 'iso9660 - 'dce))) - - - (let* ((os (operating-system - (inherit os) - - ;; As in 'virtualized-operating-system', use BIOS-style GRUB. - (bootloader (bootloader-configuration - (bootloader grub-bootloader) - (target "/dev/vda"))) - - ;; Assume we have an initrd with the whole QEMU shebang. - - ;; Force our own root file system. Refer to it by UUID so that - ;; it works regardless of how the image is used ("qemu -hda", - ;; Xen, etc.). - (file-systems (cons (file-system - (mount-point "/") - (device root-uuid) - (type file-system-type)) - file-systems-to-keep)))) - (bootcfg (operating-system-bootcfg os))) - (qemu-image #:os os - #:bootcfg-drv bootcfg - #:bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os)) - #:disk-image-size disk-image-size - #:file-system-type file-system-type - #:file-system-uuid root-uuid - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)) - #:copy-inputs? #t))) - ;;; ;;; VMs that share file systems with the host. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 19b8c5163c..ead20a071e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -695,8 +695,6 @@ checking this by themselves in their 'check' procedure." os #:mappings mappings #:shared-network? container-shared-network?)) - ((vm-image) - (system-qemu-image os #:disk-image-size image-size)) ((vm) (system-qemu-image/shared-store-script os #:full-boot? full-boot? @@ -705,11 +703,16 @@ checking this by themselves in their 'check' procedure." image-size (* 70 (expt 2 20))) #:mappings mappings)) - ((image disk-image) - (let* ((base-image (os->image os #:type image-type)) + ((image disk-image vm-image) + (let* ((image-type (if (eq? action 'vm-image) + qcow2-image-type + image-type)) + (base-image (os->image os #:type image-type)) (base-target (image-target base-image))) (when (eq? action 'disk-image) (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) + (when (eq? action 'vm-image) + (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) (lower-object (system-image (image @@ -781,9 +784,8 @@ and TARGET arguments." "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for -the 'vm-image' and 'image' actions. IMAGE-TYPE is the type of image to -be built. When VOLATILE-ROOT? is #t, the root file system is mounted -volatile. +the 'image' action. IMAGE-TYPE is the type of image to be built. When +VOLATILE-ROOT? is #t, the root file system is mounted volatile. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? @@ -968,8 +970,6 @@ Some ACTIONS support additional ARGS.\n")) container build a container that shares the host's store\n")) (display (G_ "\ vm build a virtual machine image that shares the host's store\n")) - (display (G_ "\ - vm-image build a freestanding virtual machine image\n")) (display (G_ "\ image build a Guix System image\n")) (display (G_ "\ @@ -999,7 +999,7 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " -t, --image-type=TYPE for 'image', produce an image of TYPE")) (display (G_ " - --image-size=SIZE for 'vm-image', produce an image of SIZE")) + --image-size=SIZE for 'image', produce an image of SIZE")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) (display (G_ " @@ -1017,8 +1017,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " -N, --network for 'container', allow containers to access the network")) (display (G_ " - -r, --root=FILE for 'vm', 'vm-image', 'image', 'container', - and 'build', make FILE a symlink to the result, and + -r, --root=FILE for 'vm', 'image', 'container' and 'build', + make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " --full-boot for 'vm', make a full boot sequence")) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 24cc2591d5..8bc0dcf2fc 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -339,7 +339,7 @@ done # Verify that the disk image types can be built. guix system -n vm gnu/system/examples/vm-image.tmpl -guix system -n vm-image gnu/system/examples/vm-image.tmpl +guix system -n image -t qcow2 gnu/system/examples/vm-image.tmpl # This invocation was taken care of in the loop above: # guix system -n disk-image gnu/system/examples/bare-bones.tmpl guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl -- cgit v1.2.3 From 6e8cdf1d26092cb9654e179b04730fff7c15c94f Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 20 Jan 2021 10:56:08 +0100 Subject: scripts: system: Accept records as input. * guix/scripts/system.scm (system-derivation-for-action): Replace "os" argument by "image". Remove "image-size", "image-type", "label" and "volatile-root?" arguments. (perform-action): Ditto. (process-action): Construct the record and pass it to "perform-action" procedure. * tests/guix-system.sh: Adapt accordingly. * gnu/system/images/hurd.scm: Return the default image. * gnu/system/images/novena.scm: Ditto. * gnu/system/images/pine64.scm: Ditto. * gnu/system/images/pinebook-pro.scm Ditto. --- gnu/system/images/hurd.scm | 3 + gnu/system/images/novena.scm | 3 + gnu/system/images/pine64.scm | 3 + gnu/system/images/pinebook-pro.scm | 3 + guix/scripts/system.scm | 132 ++++++++++++++++++------------------- tests/guix-system.sh | 7 +- 6 files changed, 80 insertions(+), 71 deletions(-) (limited to 'tests') diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm index 4417952c5d..eac5b7f7e6 100644 --- a/gnu/system/images/hurd.scm +++ b/gnu/system/images/hurd.scm @@ -111,3 +111,6 @@ (inherit (os->image hurd-barebones-os #:type hurd-qcow2-image-type)) (name 'hurd-barebones.qcow2))) + +;; Return the default image. +hurd-barebones-qcow2-image diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm index dfaf2c60ee..1cd724ff88 100644 --- a/gnu/system/images/novena.scm +++ b/gnu/system/images/novena.scm @@ -59,3 +59,6 @@ (inherit (os->image novena-barebones-os #:type novena-image-type)) (name 'novena-barebones-raw-image))) + +;; Return the default image. +novena-barebones-raw-image diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm index 63b31399a5..613acd5cfd 100644 --- a/gnu/system/images/pine64.scm +++ b/gnu/system/images/pine64.scm @@ -64,3 +64,6 @@ (inherit (os->image pine64-barebones-os #:type pine64-image-type)) (name 'pine64-barebones-raw-image))) + +;; Return the default image. +pine64-barebones-raw-image diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm index 22997fd742..b56a7ea409 100644 --- a/gnu/system/images/pinebook-pro.scm +++ b/gnu/system/images/pinebook-pro.scm @@ -66,3 +66,6 @@ (inherit (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type)) (name 'pinebook-pro-barebones-raw-image))) + +;; Return the default image. +pinebook-pro-barebones-raw-image diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ead20a071e..e3cf99acc6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -680,13 +680,15 @@ checking this by themselves in their 'check' procedure." ;;; Action. ;;; -(define* (system-derivation-for-action os action - #:key image-size image-type - full-boot? container-shared-network? - mappings label - volatile-root?) - "Return as a monadic value the derivation for OS according to ACTION." - (mlet %store-monad ((target (current-target-system))) +(define* (system-derivation-for-action image action + #:key + full-boot? + container-shared-network? + mappings) + "Return as a monadic value the derivation for IMAGE according to ACTION." + (mlet %store-monad ((target (current-target-system)) + (os -> (image-operating-system image)) + (image-size -> (image-size image))) (case action ((build init reconfigure) (operating-system-derivation os)) @@ -704,25 +706,11 @@ checking this by themselves in their 'check' procedure." (* 70 (expt 2 20))) #:mappings mappings)) ((image disk-image vm-image) - (let* ((image-type (if (eq? action 'vm-image) - qcow2-image-type - image-type)) - (base-image (os->image os #:type image-type)) - (base-target (image-target base-image))) - (when (eq? action 'disk-image) - (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) - (when (eq? action 'vm-image) - (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) - (lower-object - (system-image - (image - (inherit (if label - (image-with-label base-image label) - base-image)) - (target (or base-target target)) - (size image-size) - (operating-system os) - (volatile-root? volatile-root?)))))) + (when (eq? action 'disk-image) + (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) + (when (eq? action 'vm-image) + (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) + (lower-object (system-image image))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?))))) @@ -768,7 +756,7 @@ and TARGET arguments." (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) (return (primitive-eval (lowered-gexp-sexp lowered)))))) -(define* (perform-action action os +(define* (perform-action action image #:key (validate-reconfigure ensure-forward-reconfigure) save-provenance? @@ -776,16 +764,13 @@ and TARGET arguments." install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target - image-size image-type - volatile-root? - full-boot? label container-shared-network? + full-boot? + container-shared-network? (mappings '()) (gc-root #f)) - "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install + "Perform ACTION for IMAGE. INSTALL-BOOTLOADER? specifies whether to install bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the -target root directory; IMAGE-SIZE is the size of the image to be built, for -the 'image' action. IMAGE-TYPE is the type of image to be built. When -VOLATILE-ROOT? is #t, the root file system is mounted volatile. +target root directory. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? @@ -807,6 +792,9 @@ static checks." '() (map boot-parameters->menu-entry (profile-boot-parameters)))) + (define os + (image-operating-system image)) + (define bootloader (operating-system-bootloader os)) @@ -829,11 +817,7 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((sys (system-derivation-for-action os action - #:label label - #:image-type image-type - #:image-size image-size - #:volatile-root? volatile-root? + ((sys (system-derivation-for-action image action #:full-boot? full-boot? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -1169,9 +1153,9 @@ Some ACTIONS support additional ARGS.\n")) ACTION must be one of the sub-commands that takes an operating system declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." - (define (ensure-operating-system file-or-exp obj) - (unless (operating-system? obj) - (leave (G_ "'~a' does not return an operating system~%") + (define (ensure-operating-system-or-image file-or-exp obj) + (unless (or (operating-system? obj) (image? obj)) + (leave (G_ "'~a' does not return an operating system or an image~%") file-or-exp)) obj) @@ -1185,27 +1169,47 @@ resulting from command-line parsing." (expr (assoc-ref opts 'expression)) (system (assoc-ref opts 'system)) (target (assoc-ref opts 'target)) - (transform (if save-provenance? - (cut operating-system-with-provenance <> file) - identity)) - (os (transform - (ensure-operating-system - (or file expr) - (cond - ((and expr file) - (leave - (G_ "both file and expression cannot be specified~%"))) - (expr - (read/eval expr)) - (file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error))) - (else - (leave (G_ "no configuration specified~%"))))))) - + (transform (lambda (obj) + (if (and save-provenance? (operating-system? obj)) + (operating-system-with-provenance obj file) + obj))) + (obj (transform + (ensure-operating-system-or-image + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) (label (assoc-ref opts 'label)) + (image-type (lookup-image-type-by-name + (assoc-ref opts 'image-type))) + (image (let* ((image-type (if (eq? action 'vm-image) + qcow2-image-type + image-type)) + (image-size (assoc-ref opts 'image-size)) + (volatile? (assoc-ref opts 'volatile-root?)) + (base-image (if (operating-system? obj) + (os->image obj + #:type image-type) + obj)) + (base-target (image-target base-image))) + (image + (inherit (if label + (image-with-label base-image label) + base-image)) + (target (or base-target target)) + (size image-size) + (volatile-root? volatile?)))) + (os (image-operating-system image)) (target-file (match args ((first second) second) (_ #f))) @@ -1241,7 +1245,7 @@ resulting from command-line parsing." (warn-about-old-distro #:suggested-command "guix system reconfigure")) - (perform-action action os + (perform-action action image #:dry-run? dry? #:derivations-only? (assoc-ref opts 'derivations-only?) @@ -1250,11 +1254,6 @@ resulting from command-line parsing." (assoc-ref opts 'skip-safety-checks?) #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) - #:image-type (lookup-image-type-by-name - (assoc-ref opts 'image-type)) - #:image-size (assoc-ref opts 'image-size) - #:volatile-root? - (assoc-ref opts 'volatile-root?) #:full-boot? (assoc-ref opts 'full-boot?) #:container-shared-network? (assoc-ref opts 'container-shared-network?) @@ -1264,7 +1263,6 @@ resulting from command-line parsing." (_ #f)) opts) #:install-bootloader? bootloader? - #:label label #:target target-file #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 8bc0dcf2fc..238c8929a8 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -337,12 +337,11 @@ for example in gnu/system/examples/*.tmpl; do guix system -n disk-image $target "$example" done -# Verify that the disk image types can be built. +# Verify that the images can be built. guix system -n vm gnu/system/examples/vm-image.tmpl +guix system -n image gnu/system/images/pinebook-pro.scm guix system -n image -t qcow2 gnu/system/examples/vm-image.tmpl -# This invocation was taken care of in the loop above: -# guix system -n disk-image gnu/system/examples/bare-bones.tmpl -guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl +guix system -n image -t iso9660 gnu/system/examples/bare-bones.tmpl guix system -n docker-image gnu/system/examples/docker-image.tmpl # Verify that at least the raw image type is available. -- cgit v1.2.3 From 9a38bed2cf32e9462badfa43e74cdd4580e804fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 22 Feb 2021 10:52:21 +0100 Subject: packages: 'package-field-location' handles 'search-path' returning #f. Fixes . Reported by zimoun . This is similar to the fix in d10474c38d58bdc676e64336769dc2e00cdfa8ed. * guix/packages.scm (package-field-location): Handle FILE not in %LOAD-PATH. * tests/guix-lint.sh: Add test. --- guix/packages.scm | 51 ++++++++++++++++++++++++++++----------------------- tests/guix-lint.sh | 5 +++++ 2 files changed, 33 insertions(+), 23 deletions(-) (limited to 'tests') diff --git a/guix/packages.scm b/guix/packages.scm index 9305dabcec..57bc148002 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -475,29 +475,34 @@ object." (match (package-location package) (($ file line column) - (catch 'system-error - (lambda () - ;; In general we want to keep relative file names for modules. - (call-with-input-file (search-path %load-path file) - (lambda (port) - (goto port line column) - (match (read port) - (('package inits ...) - (let ((field (assoc field inits))) - (match field - ((_ value) - (let ((loc (and=> (source-properties value) - source-properties->location))) - (and loc - ;; Preserve the original file name, which may be a - ;; relative file name. - (set-field loc (location-file) file)))) - (_ - #f)))) - (_ - #f))))) - (lambda _ - #f))) + (match (search-path %load-path file) + ((? string? file) + (catch 'system-error + (lambda () + ;; In general we want to keep relative file names for modules. + (call-with-input-file file + (lambda (port) + (goto port line column) + (match (read port) + (('package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + (let ((loc (and=> (source-properties value) + source-properties->location))) + (and loc + ;; Preserve the original file name, which may be a + ;; relative file name. + (set-field loc (location-file) file)))) + (_ + #f)))) + (_ + #f))))) + (lambda _ + #f))) + (#f + ;; FILE could not be found in %LOAD-PATH. + #f))) (_ #f))) diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index fdf548fbf1..97c2ea83fe 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -90,3 +90,8 @@ guix lint -L $module_dir -c inputs-should-be-native dummy dummy@42 dummy # that it does find it anyway. See . (cd "$module_dir"/.. ; guix lint -c formatting -L "$(basename "$module_dir")" dummy@42) 2>&1 > "$module_dir/out" test -z "$(cat "$module_dir/out")" + +# Likewise, when there's a warning, 'package-field-location' used to crash +# because it can't find "t-xyz/foo.scm". See . +(cd "$module_dir"/.. ; guix lint -c synopsis -L "$(basename "$module_dir")" dummy@42) 2>&1 > "$module_dir/out" +grep_warning "`cat "$module_dir/out"`" -- cgit v1.2.3 From fc6d6aee6659acb293eb33f498fdac3b47a19a48 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Feb 2021 20:54:27 +0100 Subject: gexp: 'gexp-inputs' returns a list of records. This slightly reduces memory allocation. * guix/gexp.scm (lower-inputs): Expect a list of rather than a list of tuples. (lower-reference-graphs)[tuple->gexp-input]: New procedure. Use it. (gexp-inputs): Return a list of rather than a list of tuples. * tests/gexp.scm (gexp-input->tuple): New procedure. ("one input package") ("one input package, dotted list") ("one input origin") ("one local file") ("one local file, symlink") ("one plain file") ("two input packages, one derivation, one file") ("file-append") ("file-append, output") ("file-append, nested") ("let-system") ("let-system, nested") ("ungexp + ungexp-native") ("ungexp + ungexp-native, nested") ("ungexp + ungexp-native, nested, special mixture") ("input list") ("input list + ungexp-native") ("input list splicing") ("input list splicing + ungexp-native-splicing") ("gexp list splicing + ungexp-splicing"): Adjust accordingly. --- guix/gexp.scm | 37 ++++++++++++---------- tests/gexp.scm | 96 +++++++++++++++++++++++++++++++++++----------------------- 2 files changed, 79 insertions(+), 54 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 8dd824c512..8e80d4adbe 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -842,24 +842,23 @@ When TARGET is true, use it as the cross-compilation target triplet." (with-monad %store-monad (>>= (mapm/accumulate-builds (match-lambda - (((? struct? thing) sub-drv ...) - (mlet %store-monad ((obj (lower-object - thing system #:target target))) + (($ (? store-item? item)) + (return item)) + (($ thing output native?) + (mlet %store-monad ((obj (lower-object thing system + #:target + (and (not native?) + target)))) (return (match obj ((? derivation? drv) - (let ((outputs (if (null? sub-drv) - '("out") - sub-drv))) - (derivation-input drv outputs))) + (derivation-input drv (list output))) ((? store-item? item) item) ((? self-quoting?) ;; Some inputs such as can lower to ;; a self-quoting object that FILTERM will filter ;; out. - #f))))) - (((? store-item? item)) - (return item))) + #f)))))) inputs) filterm))) @@ -867,9 +866,16 @@ When TARGET is true, use it as the cross-compilation target triplet." "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a #:reference-graphs argument, lower it such that each INPUT is replaced by the corresponding or store item." + (define tuple->gexp-input + (match-lambda + ((thing) + (%gexp-input thing "out" #t)) + ((thing output) + (%gexp-input thing output #t)))) + (match graphs (((file-names . inputs) ...) - (mlet %store-monad ((inputs (lower-inputs inputs + (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs) #:system system #:target target))) (return (map cons file-names inputs)))))) @@ -1213,9 +1219,8 @@ The other arguments are as for 'derivation'." #:properties properties)))) (define* (gexp-inputs exp #:key native?) - "Return the input list for EXP. When NATIVE? is true, return only native -references; otherwise, return only non-native references." - ;; TODO: Return records instead of tuples. + "Return the list of for EXP. When NATIVE? is true, return only +native references; otherwise, return only non-native references." (define (add-reference-inputs ref result) (match ref (($ (? gexp? exp) _ #t) @@ -1229,12 +1234,12 @@ references; otherwise, return only non-native references." result)) (($ (? string? str)) (if (direct-store-path? str) - (cons `(,str) result) + (cons ref result) result)) (($ (? struct? thing) output n?) (if (and (eqv? n? native?) (lookup-compiler thing)) ;; THING is a derivation, or a package, or an origin, etc. - (cons `(,thing ,output) result) + (cons ref result) result)) (($ (lst ...) output n?) (fold-right add-reference-inputs result diff --git a/tests/gexp.scm b/tests/gexp.scm index 6e92f0e4b3..f742c5db76 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,6 +63,9 @@ #:target target) #:guile-for-build (%guile-for-build))) +(define (gexp-input->tuple input) + (list (gexp-input-thing input) (gexp-input-output input))) + (define %extension-package ;; Example of a package to use when testing 'with-extensions'. (dummy-package "extension" @@ -106,8 +109,8 @@ (let ((exp (gexp (display (ungexp coreutils))))) (and (gexp? exp) (match (gexp-inputs exp) - (((p "out")) - (eq? p coreutils))) + ((input) + (eq? (gexp-input-thing input) coreutils))) (equal? `(display ,(derivation->output-path (package-derivation %store coreutils))) (gexp->sexp* exp))))) @@ -116,8 +119,8 @@ (let ((exp (gexp (coreutils . (ungexp coreutils))))) (and (gexp? exp) (match (gexp-inputs exp) - (((p "out")) - (eq? p coreutils))) + ((input) + (eq? (gexp-input-thing input) coreutils))) (equal? `(coreutils . ,(derivation->output-path (package-derivation %store coreutils))) (gexp->sexp* exp))))) @@ -126,8 +129,9 @@ (let ((exp (gexp (display (ungexp (package-source coreutils)))))) (and (gexp? exp) (match (gexp-inputs exp) - (((o "out")) - (eq? o (package-source coreutils)))) + ((input) + (and (eq? (gexp-input-thing input) (package-source coreutils)) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,(derivation->output-path (package-source-derivation %store (package-source coreutils)))) @@ -141,8 +145,9 @@ "sha256" file))) (and (gexp? exp) (match (gexp-inputs exp) - (((x "out")) - (eq? x local))) + ((input) + (and (eq? (gexp-input-thing input) local) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,intd) (gexp->sexp* exp))))) (test-assert "one local file, symlink" @@ -158,8 +163,9 @@ "sha256" file))) (and (gexp? exp) (match (gexp-inputs exp) - (((x "out")) - (eq? x local))) + ((input) + (and (eq? (gexp-input-thing input) local) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,intd) (gexp->sexp* exp))))) (lambda () (false-if-exception (delete-file link)))))) @@ -201,8 +207,9 @@ (expected (add-text-to-store %store "hi" "Hello, world!"))) (and (gexp? exp) (match (gexp-inputs exp) - (((x "out")) - (eq? x file))) + ((input) + (and (eq? (gexp-input-thing input) file) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,expected) (gexp->sexp* exp))))) (test-assert "same input twice" @@ -211,8 +218,9 @@ (display (ungexp coreutils)))))) (and (gexp? exp) (match (gexp-inputs exp) - (((p "out")) - (eq? p coreutils))) + ((input) + (and (eq? (gexp-input-thing input) coreutils) + (string=? (gexp-input-output input) "out")))) (let ((e `(display ,(derivation->output-path (package-derivation %store coreutils))))) (equal? `(begin ,e ,e) (gexp->sexp* exp)))))) @@ -228,9 +236,8 @@ (display (ungexp drv)) (display (ungexp txt)))))) (define (match-input thing) - (match-lambda - ((drv-or-pkg _ ...) - (eq? thing drv-or-pkg)))) + (lambda (input) + (eq? (gexp-input-thing input) thing))) (and (gexp? exp) (= 4 (length (gexp-inputs exp))) @@ -255,8 +262,9 @@ (string-append (derivation->output-path drv) "/bin/guile")))) (match (gexp-inputs exp) - (((thing "out")) - (eq? thing fa)))))) + ((input) + (and (eq? (gexp-input-thing input) fa) + (string=? (gexp-input-output input) "out"))))))) (test-assert "file-append, output" (let* ((drv (package-derivation %store glibc)) @@ -268,8 +276,9 @@ (string-append (derivation->output-path drv "debug") "/lib/debug")))) (match (gexp-inputs exp) - (((thing "debug")) - (eq? thing fa)))))) + ((input) + (and (eq? (gexp-input-thing input) fa) + (string=? (gexp-input-output input) "debug"))))))) (test-assert "file-append, nested" (let* ((drv (package-derivation %store glibc)) @@ -283,8 +292,8 @@ (string-append (derivation->output-path drv) "/bin/getent")))) (match (gexp-inputs exp) - (((thing "out")) - (eq? thing file)))))) + ((input) + (eq? (gexp-input-thing input) file)))))) (test-assert "file-append, raw store item" (let* ((obj (plain-file "example.txt" "Hello!")) @@ -346,8 +355,11 @@ (low (run-with-store %store (lower-gexp exp)))) (list (lowered-gexp-sexp low) (match (gexp-inputs exp) - (((($ (@@ (guix gexp) )) "out")) - '(system-binding)) + ((input) + (and (eq? (struct-vtable (gexp-input-thing input)) + (@@ (guix gexp) )) + (string=? (gexp-input-output input) "out") + '(system-binding))) (x x)) (gexp-native-inputs exp) 'low @@ -388,8 +400,11 @@ (x x)) (gexp-inputs exp) (match (gexp-native-inputs exp) - (((($ (@@ (guix gexp) )) "out")) - '(system-binding)) + ((input) + (and (eq? (struct-vtable (gexp-input-thing input)) + (@@ (guix gexp) )) + (string=? (gexp-input-output input) "out") + '(system-binding))) (x x))))) (test-assert "ungexp + ungexp-native" @@ -408,10 +423,10 @@ (package-cross-derivation %store binutils target)))) (and (lset= equal? `((,%bootstrap-guile "out") (,glibc "out")) - (gexp-native-inputs exp)) + (map gexp-input->tuple (gexp-native-inputs exp))) (lset= equal? `((,coreutils "out") (,binutils "out")) - (gexp-inputs exp)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) @@ -419,7 +434,9 @@ (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) (ungexp %bootstrap-guile))))) - (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) + (list (map gexp-input->tuple (gexp-inputs exp)) + '<> + (map gexp-input->tuple (gexp-native-inputs exp))))) (test-equal "ungexp + ungexp-native, nested, special mixture" `(() <> ((,coreutils "out"))) @@ -427,7 +444,9 @@ ;; (gexp-native-inputs exp) used to return '(), wrongfully. (let* ((foo (gexp (foo (ungexp-native coreutils)))) (exp (gexp (bar (ungexp foo))))) - (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) + (list (map gexp-input->tuple (gexp-inputs exp)) + '<> + (map gexp-input->tuple (gexp-native-inputs exp))))) (test-assert "input list" (let ((exp (gexp (display @@ -438,7 +457,7 @@ (package-derivation %store coreutils)))) (and (lset= equal? `((,%bootstrap-guile "out") (,coreutils "out")) - (gexp-inputs exp)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display '(,guile ,cu)) (gexp->sexp* exp))))) @@ -457,10 +476,10 @@ (package-cross-derivation %store binutils target)))) (and (lset= equal? `((,%bootstrap-guile "out") (,coreutils "out")) - (gexp-native-inputs exp)) + (map gexp-input->tuple (gexp-native-inputs exp))) (lset= equal? `((,glibc "out") (,binutils "out")) - (gexp-inputs exp)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (gexp->sexp* exp target))))) @@ -474,7 +493,7 @@ (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug") (,%bootstrap-guile "out")) - (gexp-inputs exp)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) `(list ,@(cons 5 outputs)))))) @@ -484,7 +503,7 @@ (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug") (,%bootstrap-guile "out")) - (gexp-native-inputs exp)) + (map gexp-input->tuple (gexp-native-inputs exp))) (null? (gexp-inputs exp)) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) @@ -492,7 +511,8 @@ (test-assert "gexp list splicing + ungexp-splicing" (let* ((inner (gexp (ungexp-native glibc))) (exp (gexp (list (ungexp-splicing (list inner)))))) - (and (equal? `((,glibc "out")) (gexp-native-inputs exp)) + (and (equal? `((,glibc "out")) + (map gexp-input->tuple (gexp-native-inputs exp))) (null? (gexp-inputs exp)) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) -- cgit v1.2.3 From 4fa9d48fd47df45372fddf2251c3fc0afd48fda0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Feb 2021 21:46:18 +0100 Subject: gexp: 'gexp-inputs' returns both native and non-native inputs. This avoids double traversal of references and extra bookkeeping, thereby further reducing memory allocations. * guix/gexp.scm (lower-gexp): Include only one call to 'lower-inputs'. (gexp-inputs): Remove #:native? parameter. [set-gexp-input-native?]: New procedure. [add-reference-inputs]: Use it. (gexp-native-inputs): Remove. * tests/gexp.scm (gexp-native-inputs): Remove. (gexp-input->tuple): Include 'gexp-input-native?'. ("let-system") ("let-system, nested") ("ungexp + ungexp-native") ("ungexp + ungexp-native, nested") ("ungexp + ungexp-native, nested, special mixture") ("input list") ("input list + ungexp-native") ("input list splicing") ("input list splicing + ungexp-native-splicing") ("gexp list splicing + ungexp-splicing"): Adjust accordingly. --- guix/gexp.scm | 31 ++++++++++++------------------- tests/gexp.scm | 54 +++++++++++++++++++++--------------------------------- 2 files changed, 33 insertions(+), 52 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 8e80d4adbe..7a3228ec2e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1006,13 +1006,9 @@ derivations--e.g., code evaluated for its side effects." (guile (if guile-for-build (return guile-for-build) (default-guile-derivation system))) - (normals (lower-inputs (gexp-inputs exp) + (inputs (lower-inputs (gexp-inputs exp) #:system system #:target target)) - (natives (lower-inputs (gexp-native-inputs exp) - #:system system - #:target #f)) - (inputs -> (append normals natives)) (sexp (gexp->sexp exp #:system system #:target target)) @@ -1218,26 +1214,26 @@ The other arguments are as for 'derivation'." #:substitutable? substitutable? #:properties properties)))) -(define* (gexp-inputs exp #:key native?) - "Return the list of for EXP. When NATIVE? is true, return only -native references; otherwise, return only non-native references." +(define (gexp-inputs exp) + "Return the list of for EXP." + (define set-gexp-input-native? + (match-lambda + (($ thing output) + (%gexp-input thing output #t)))) + (define (add-reference-inputs ref result) (match ref (($ (? gexp? exp) _ #t) - (if native? - (append (gexp-inputs exp) - (gexp-inputs exp #:native? #t) - result) - result)) - (($ (? gexp? exp) _ #f) - (append (gexp-inputs exp #:native? native?) + (append (map set-gexp-input-native? (gexp-inputs exp)) result)) + (($ (? gexp? exp) _ #f) + (append (gexp-inputs exp) result)) (($ (? string? str)) (if (direct-store-path? str) (cons ref result) result)) (($ (? struct? thing) output n?) - (if (and (eqv? n? native?) (lookup-compiler thing)) + (if (lookup-compiler thing) ;; THING is a derivation, or a package, or an origin, etc. (cons ref result) result)) @@ -1261,9 +1257,6 @@ native references; otherwise, return only non-native references." '() (gexp-references exp))) -(define gexp-native-inputs - (cut gexp-inputs <> #:native? #t)) - (define (gexp-outputs exp) "Return the outputs referred to by EXP as a list of strings." (define (add-reference-output ref result) diff --git a/tests/gexp.scm b/tests/gexp.scm index f742c5db76..0bd1237316 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -51,8 +51,6 @@ ;; For white-box testing. (define (gexp-inputs x) ((@@ (guix gexp) gexp-inputs) x)) -(define (gexp-native-inputs x) - ((@@ (guix gexp) gexp-native-inputs) x)) (define (gexp-outputs x) ((@@ (guix gexp) gexp-outputs) x)) (define (gexp->sexp . x) @@ -64,7 +62,8 @@ #:guile-for-build (%guile-for-build))) (define (gexp-input->tuple input) - (list (gexp-input-thing input) (gexp-input-output input))) + (list (gexp-input-thing input) (gexp-input-output input) + (gexp-input-native? input))) (define %extension-package ;; Example of a package to use when testing 'with-extensions'. @@ -347,7 +346,7 @@ (string-append (derivation->output-path drv) "/bin/touch")))))) (test-equal "let-system" - (list `(begin ,(%current-system) #t) '(system-binding) '() + (list `(begin ,(%current-system) #t) '(system-binding) 'low '() '()) (let* ((exp #~(begin #$(let-system system system) @@ -361,7 +360,6 @@ (string=? (gexp-input-output input) "out") '(system-binding))) (x x)) - (gexp-native-inputs exp) 'low (lowered-gexp-inputs low) (lowered-gexp-sources low)))) @@ -383,7 +381,6 @@ (test-equal "let-system, nested" (list `(system* ,(string-append "qemu-system-" (%current-system)) "-m" "256") - '() '(system-binding)) (let ((exp #~(system* #+(let-system (system target) @@ -398,12 +395,12 @@ (basename command)) ,@rest)) (x x)) - (gexp-inputs exp) - (match (gexp-native-inputs exp) + (match (gexp-inputs exp) ((input) (and (eq? (struct-vtable (gexp-input-thing input)) (@@ (guix gexp) )) (string=? (gexp-input-output input) "out") + (gexp-input-native? input) '(system-binding))) (x x))))) @@ -422,31 +419,26 @@ (bu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,glibc "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (lset= equal? - `((,coreutils "out") (,binutils "out")) + `((,%bootstrap-guile "out" #t) + (,coreutils "out" #f) + (,glibc "out" #t) + (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) (test-equal "ungexp + ungexp-native, nested" - (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) + `((,%bootstrap-guile "out" #f) (,coreutils "out" #t)) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) (ungexp %bootstrap-guile))))) - (list (map gexp-input->tuple (gexp-inputs exp)) - '<> - (map gexp-input->tuple (gexp-native-inputs exp))))) + (map gexp-input->tuple (gexp-inputs exp)))) (test-equal "ungexp + ungexp-native, nested, special mixture" - `(() <> ((,coreutils "out"))) + `((,coreutils "out" #t)) - ;; (gexp-native-inputs exp) used to return '(), wrongfully. (let* ((foo (gexp (foo (ungexp-native coreutils)))) (exp (gexp (bar (ungexp foo))))) - (list (map gexp-input->tuple (gexp-inputs exp)) - '<> - (map gexp-input->tuple (gexp-native-inputs exp))))) + (map gexp-input->tuple (gexp-inputs exp)))) (test-assert "input list" (let ((exp (gexp (display @@ -456,7 +448,7 @@ (cu (derivation->output-path (package-derivation %store coreutils)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,coreutils "out")) + `((,%bootstrap-guile "out" #f) (,coreutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display '(,guile ,cu)) (gexp->sexp* exp))))) @@ -475,10 +467,8 @@ (xbu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,coreutils "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (lset= equal? - `((,glibc "out") (,binutils "out")) + `((,%bootstrap-guile "out" #t) (,coreutils "out" #t) + (,glibc "out" #f) (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (gexp->sexp* exp target))))) @@ -492,7 +482,7 @@ (package-derivation %store %bootstrap-guile)))) (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? - `((,glibc "debug") (,%bootstrap-guile "out")) + `((,glibc "debug" #f) (,%bootstrap-guile "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) `(list ,@(cons 5 outputs)))))) @@ -502,18 +492,16 @@ %bootstrap-guile)) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? - `((,glibc "debug") (,%bootstrap-guile "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (null? (gexp-inputs exp)) + `((,glibc "debug" #t) (,%bootstrap-guile "out" #t)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-assert "gexp list splicing + ungexp-splicing" (let* ((inner (gexp (ungexp-native glibc))) (exp (gexp (list (ungexp-splicing (list inner)))))) - (and (equal? `((,glibc "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (null? (gexp-inputs exp)) + (and (equal? `((,glibc "out" #t)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) -- cgit v1.2.3 From b57de6fea126f907a873ae14ad8b32dc32456e8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 17 Feb 2021 14:25:43 +0100 Subject: gexp: Micro-optimize 'gexp->sexp' and 'lower-inputs'. * guix/gexp.scm (lower-inputs, gexp->sexp): Change keyword parameters to positional parameters. Adjust callers accordingly. * tests/gexp.scm (gexp->sexp*, "gexp->file"): Adjust accordingly. --- guix/gexp.scm | 20 ++++++-------------- tests/gexp.scm | 5 ++--- 2 files changed, 8 insertions(+), 17 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 6990d33651..943b336539 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -826,8 +826,7 @@ list." (one-of symbol? string? keyword? pair? null? array? number? boolean? char?))) -(define* (lower-inputs inputs - #:key system target) +(define (lower-inputs inputs system target) "Turn any object from INPUTS into a derivation input for SYSTEM or a store item (a \"source\"); return the corresponding input list as a monadic value. When TARGET is true, use it as the cross-compilation target triplet." @@ -874,8 +873,7 @@ corresponding or store item." (match graphs (((file-names . inputs) ...) (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs) - #:system system - #:target target))) + system target))) (return (map cons file-names inputs)))))) (define* (lower-references lst #:key system target) @@ -1005,11 +1003,8 @@ derivations--e.g., code evaluated for its side effects." (return guile-for-build) (default-guile-derivation system))) (inputs (lower-inputs (gexp-inputs exp) - #:system system - #:target target)) - (sexp (gexp->sexp exp - #:system system - #:target target)) + system target)) + (sexp (gexp->sexp exp system target)) (extensions -> (gexp-extensions exp)) (exts (mapm %store-monad (lambda (obj) @@ -1278,9 +1273,7 @@ The other arguments are as for 'derivation'." (delete-duplicates (add-reference-output (gexp-references exp) '()))) -(define* (gexp->sexp exp #:key - (system (%current-system)) - (target (%current-target-system))) +(define (gexp->sexp exp system target) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" (define* (reference->sexp ref #:optional native?) @@ -1293,8 +1286,7 @@ and in the current monad setting (system type, etc.)" (return `((@ (guile) getenv) ,output))) (($ (? gexp? exp) output n?) (gexp->sexp exp - #:system system - #:target (if (or n? native?) #f target))) + system (if (or n? native?) #f target))) (($ (refs ...) output n?) (mapm %store-monad (lambda (ref) diff --git a/tests/gexp.scm b/tests/gexp.scm index 0bd1237316..a30d0ff6b4 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -57,8 +57,7 @@ (apply (@@ (guix gexp) gexp->sexp) x)) (define* (gexp->sexp* exp #:optional target) - (run-with-store %store (gexp->sexp exp - #:target target) + (run-with-store %store (gexp->sexp exp (%current-system) target) #:guile-for-build (%guile-for-build))) (define (gexp-input->tuple input) @@ -540,7 +539,7 @@ (test-assertm "gexp->file" (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) (guile (package-file %bootstrap-guile)) - (sexp (gexp->sexp exp)) + (sexp (gexp->sexp exp (%current-system) #f)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) -- cgit v1.2.3 From 7e9d9f28e997e7faad28cdd1c416be174d6986e7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 22 Feb 2021 15:20:41 +0100 Subject: syscalls: Add 'mounts' and the record type. * guix/build/syscalls.scm (): New record type. (option-string->mount-flags, mount-flags) (octal-decode, mounts): New procedures. (mount-points): Rewrite in terms of 'mount'. * tests/syscalls.scm ("mounts"): New test. --- guix/build/syscalls.scm | 112 +++++++++++++++++++++++++++++++++++++++++++++--- tests/syscalls.scm | 16 ++++++- 2 files changed, 121 insertions(+), 7 deletions(-) (limited to 'tests') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index b19a7a271b..552343a481 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe @@ -54,7 +54,18 @@ UMOUNT_NOFOLLOW restart-on-EINTR + + mount? + mount-device-number + mount-source + mount-point + mount-type + mount-options + mount-flags + + mounts mount-points + swapon swapoff @@ -521,17 +532,106 @@ constants from ." (when update-mtab? (remove-from-mtab target))))) -(define (mount-points) - "Return the mounts points for currently mounted file systems." - (call-with-input-file "/proc/mounts" +;; Mount point information. +(define-record-type + (%mount source point devno type options) + mount? + (devno mount-device-number) ;st_dev + (source mount-source) ;string + (point mount-point) ;string + (type mount-type) ;string + (options mount-options)) ;string + +(define (option-string->mount-flags str) + "Parse the \"option string\" STR as it appears in /proc/mounts and similar, +and return two values: a mount bitmask (inclusive or of MS_* constants), and +the remaining unprocessed options." + ;; Why do we need to do this? Because mount flags and mount options are + ;; often lumped together; this is the case in /proc/mounts & co., so we need + ;; to extract the bits that actually correspond to mount flags. + + (define not-comma + (char-set-complement (char-set #\,))) + + (define lst + (string-tokenize str not-comma)) + + (let loop ((options lst) + (mask 0) + (remainder '())) + (match options + (() + (values mask (string-concatenate-reverse remainder))) + ((head . tail) + (letrec-syntax ((match-options (syntax-rules (=>) + ((_) + (loop tail mask + (cons head remainder))) + ((_ (str => bit) rest ...) + (if (string=? str head) + (loop tail (logior bit mask) + remainder) + (match-options rest ...)))))) + (match-options ("rw" => 0) + ("ro" => MS_RDONLY) + ("nosuid" => MS_NOSUID) + ("nodev" => MS_NODEV) + ("noexec" => MS_NOEXEC) + ("relatime" => MS_RELATIME) + ("noatime" => MS_NOATIME))))))) + +(define (mount-flags mount) + "Return the mount flags of MOUNT, a record, as an inclusive or of +MS_* constants." + (option-string->mount-flags (mount-options mount))) + +(define (octal-decode str) + "Decode octal escapes from STR and return the corresponding string. STR may +look like this: \"white\\040space\", which is decoded as \"white space\"." + (define char-set:octal + (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) + (define (octal? c) + (char-set-contains? char-set:octal c)) + + (let loop ((chars (string->list str)) + (result '())) + (match chars + (() + (list->string (reverse result))) + ((#\\ (? octal? a) (? octal? b) (? octal? c) . rest) + (loop rest + (cons (integer->char + (string->number (list->string (list a b c)) 8)) + result))) + ((head . tail) + (loop tail (cons head result)))))) + +(define (mounts) + "Return the list of mounts ( records) visible in the namespace of the +current process." + (define (string->device-number str) + (match (string-split str #\:) + (((= string->number major) (= string->number minor)) + (+ (* major 256) minor)))) + + (call-with-input-file "/proc/self/mountinfo" (lambda (port) (let loop ((result '())) (let ((line (read-line port))) (if (eof-object? line) (reverse result) (match (string-tokenize line) - ((source mount-point _ ...) - (loop (cons mount-point result)))))))))) + ((id parent-id major:minor root mount-point + options _ type source _ ...) + (let ((devno (string->device-number major:minor))) + (loop (cons (%mount (octal-decode source) + (octal-decode mount-point) + devno type options) + result))))))))))) + +(define (mount-points) + "Return the mounts points for currently mounted file systems." + (map mount-point (mounts))) (define swapon (let ((proc (syscall->procedure int "swapon" (list '* int)))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 09aa228e8e..706dd4177f 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2020 Simon South ;;; Copyright © 2020 Mathieu Othacehe @@ -56,6 +56,20 @@ ;; Both return values have been encountered in the wild. (memv (system-error-errno args) (list EPERM ENOENT))))) +(test-assert "mounts" + ;; Check for one of the common mount points. + (let ((mounts (mounts))) + (any (match-lambda + ((point . type) + (let ((mount (find (lambda (mount) + (string=? (mount-point mount) point)) + mounts))) + (and mount + (string=? (mount-type mount) type))))) + '(("/proc" . "proc") + ("/sys" . "sysfs") + ("/dev/shm" . "tmpfs"))))) + (test-assert "mount-points" ;; Reportedly "/" is not always listed as a mount point, so check a few ;; others (see .) -- cgit v1.2.3 From 9fc4e94986e68e0e33b260e2389765e2d3b7dd07 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Mar 2021 12:27:18 +0100 Subject: gexp: #:references-graphs refers to non-native derivations. Fixes a regression introduced in c6d6aee6659acb293eb33f498fdac3b47a19a48, where #:reference-graphs would end up referring to native inputs. This would notably break the compilation of systems using a childhurd, because they would attempt to build the 'hurd' package natively. * guix/gexp.scm (lower-reference-graphs)[tuple->gexp-input]: Honor TARGET. * tests/gexp.scm ("gexp->derivation #:references-graphs cross-compilation"): New test. --- guix/gexp.scm | 4 ++-- tests/gexp.scm | 16 ++++++++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 8cd44ba534..b72b8f4061 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -875,9 +875,9 @@ corresponding or store item." (define tuple->gexp-input (match-lambda ((thing) - (%gexp-input thing "out" #t)) + (%gexp-input thing "out" (not target))) ((thing output) - (%gexp-input thing output #t)))) + (%gexp-input thing output (not target))))) (match graphs (((file-names . inputs) ...) diff --git a/tests/gexp.scm b/tests/gexp.scm index a30d0ff6b4..834e78b9a0 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1095,6 +1095,22 @@ importing.* \\(guix config\\) from the host" (call-with-input-file g-guile read) (list (derivation->output-path guile-drv) bash)))))) +(test-assertm "gexp->derivation #:references-graphs cross-compilation" + ;; The objects passed in #:references-graphs implicitly refer to + ;; cross-compiled derivations. Make sure this is the case. + (mlet* %store-monad ((drv1 (lower-object coreutils (%current-system) + #:target "i586-pc-gnu")) + (drv2 (lower-object coreutils (%current-system) + #:target #f)) + (drv3 (gexp->derivation "three" + #~(symlink #$coreutils #$output) + #:target "i586-pc-gnu" + #:references-graphs + `(("coreutils" ,coreutils)))) + (refs (references* (derivation-file-name drv3)))) + (return (and (member (derivation-file-name drv1) refs) + (not (member (derivation-file-name drv2) refs)))))) + (test-assertm "gexp->derivation #:allowed-references" (mlet %store-monad ((drv (gexp->derivation "allowed-refs" #~(begin -- cgit v1.2.3 From 90ea8b16eb519a88d8f739fea5a416c0b99de19f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Mar 2021 10:57:46 +0100 Subject: profiles: 'package->manifest-entry' preserves transformations by default. Previously, transformations applied from a manifest (rather than via "guix install") would be lost. This change fixes that and simplifies things. Reported by zimoun at . * guix/profiles.scm (default-properties): New procedure. (package->manifest-entry): Use it for #:properties. * guix/scripts/pack.scm (guix-pack)[with-transformations]: Remove. Remove caller. * guix/scripts/package.scm (transaction-upgrade-entry): Remove calls to 'manifest-entry-with-transformations'. * tests/guix-package.sh: Add test. * tests/transformations.scm ("options->transformation + package->manifest-entry"): New test. --- guix/profiles.scm | 9 ++++++++- guix/scripts/pack.scm | 31 +++++++++++++------------------ guix/scripts/package.scm | 6 ++---- tests/guix-package.sh | 15 +++++++++++++++ tests/transformations.scm | 10 ++++++++++ 5 files changed, 48 insertions(+), 23 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index ea8bc6e593..67d90532c1 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -362,9 +362,16 @@ file name." #t lst))) +(define (default-properties package) + "Return the default properties of a manifest entry for PACKAGE." + ;; Preserve transformation options by default. + (match (assq-ref (package-properties package) 'transformations) + (#f '()) + (transformations `((transformations . ,transformations))))) + (define* (package->manifest-entry package #:optional (output "out") #:key (parent (delay #f)) - (properties '())) + (properties (default-properties package))) "Return a manifest entry for the OUTPUT of package PACKAGE." ;; For each dependency, keep a promise pointing to its "parent" entry. (letrec* ((deps (map (match-lambda diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 8ecdcb823f..b653138f2c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich @@ -1170,24 +1170,19 @@ Create a bundle of PACKAGE.\n")) manifest)) identity)) - (define (with-transformations manifest) - (map-manifest-entries manifest-entry-with-transformations - manifest)) - (with-provenance - (with-transformations - (cond - ((and (not (null? manifests)) (not (null? packages))) - (leave (G_ "both a manifest and a package list were given~%"))) - ((not (null? manifests)) - (concatenate-manifests - (map (lambda (file) - (let ((user-module (make-user-module - '((guix profiles) (gnu))))) - (load* file user-module))) - manifests))) - (else - (packages->manifest packages))))))) + (cond + ((and (not (null? manifests)) (not (null? packages))) + (leave (G_ "both a manifest and a package list were given~%"))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) + (else + (packages->manifest packages)))))) (with-error-handling (with-store store diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 8234a1703d..fc5bf8137b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -235,14 +235,12 @@ non-zero relevance score." (case (version-compare candidate-version version) ((>) (manifest-transaction-install-entry - (manifest-entry-with-transformations - (package->manifest-entry* pkg output)) + (package->manifest-entry* pkg output) transaction)) ((<) transaction) ((=) - (let* ((new (manifest-entry-with-transformations - (package->manifest-entry* pkg output)))) + (let* ((new (package->manifest-entry* pkg output))) ;; Here we want to determine whether the NEW actually ;; differs from ENTRY, but we need to intercept ;; 'build-things' calls because they would prevent us from diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7eaad6823f..39e2b514c3 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -386,6 +386,21 @@ guix package -I # '--dry-run' is passed. GUIX_BUILD_OPTIONS="--no-grafts" +# Install using the "imperative model", export a manifest, instantiate it, and +# make sure we get the same profile. +guix package --bootstrap -i guile-bootstrap --without-tests=foo +profile_directory="$(readlink -f "$default_profile")" +guix package --export-manifest > "$tmpfile" +grep 'without-tests.*foo' "$tmpfile" +guix package --rollback --bootstrap +guix package --bootstrap -m "$tmpfile" +test "$(readlink -f "$default_profile")" = "$profile_directory" +guix package --export-manifest > "$tmpfile.2nd" +cmp "$tmpfile" "$tmpfile.2nd" + +rm -f "$tmpfile.2nd" +guix package --rollback --bootstrap + # Applying a manifest file. cat > "$module_dir/manifest.scm"<manifest-entry + manifest-entry-properties)) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) @@ -413,6 +416,13 @@ `((with-latest . "foo"))))) (package-version (t p))))) +(test-equal "options->transformation + package->manifest-entry" + '((transformations . ((without-tests . "foo")))) + (let* ((p (dummy-package "foo")) + (t (options->transformation '((without-tests . "foo")))) + (e (package->manifest-entry (t p)))) + (manifest-entry-properties e))) + (test-end) ;;; Local Variables: -- cgit v1.2.3