Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Sat, 2 Oct 2021 10:22:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
Message #230 received at 50960 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 50960 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH v2 04/11] DRAFT shell: By default load the local 'guix.scm' or 'manifest.scm' file. Date: Mon, 11 Oct 2021 23:38:02 +0200
DRAFT: Add doc.
* guix/scripts/shell.scm (parse-args): Add call to 'auto-detect-manifest'.
(find-file-in-parent-directories, auto-detect-manifest): New procedures.
* tests/guix-shell.sh: Add test.
---
guix/scripts/shell.scm | 67 ++++++++++++++++++++++++++++++++++++++----
tests/guix-shell.sh | 36 +++++++++++++++++++++++
2 files changed, 98 insertions(+), 5 deletions(-)
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 190dd8837d..39d843bde7 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -22,6 +22,8 @@ (define-module (guix scripts shell)
#:autoload (guix scripts build) (show-build-options-help)
#:autoload (guix transformations) (show-transformation-options-help)
#:use-module (guix scripts)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
@@ -41,6 +43,8 @@ (define (show-help)
(display (G_ "
-f, --file=FILE create environment for the package that the code within
FILE evaluates to"))
+ (display (G_ "
+ -q inhibit loading of 'guix.scm' and 'manifest.scm'"))
(show-environment-options-help)
(newline)
@@ -99,7 +103,10 @@ (define %options
(option '(#\f "file") #t #f
(lambda (opt name arg result)
(alist-cons 'load (tag-package-arg result arg)
- result))))
+ result)))
+ (option '(#\q) #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'explicit-loading? #t result))))
(filter-map (lambda (opt)
(and (not (any (lambda (name)
(member name to-remove))
@@ -122,10 +129,60 @@ (define (handle-argument arg result)
(let ((args command (break (cut string=? "--" <>) args)))
(let ((opts (parse-command-line args %options (list %default-options)
#:argument-handler handle-argument)))
- (match command
- (() opts)
- (("--") opts)
- (("--" command ...) (alist-cons 'exec command opts))))))
+ (auto-detect-manifest
+ (match command
+ (() opts)
+ (("--") opts)
+ (("--" command ...) (alist-cons 'exec command opts)))))))
+
+(define (find-file-in-parent-directories candidates)
+ "Find one of CANDIDATES in the current directory or one of its ancestors."
+ (define start (getcwd))
+ (define device (stat:dev (stat start)))
+
+ (let loop ((directory start))
+ (let ((stat (stat directory)))
+ (and (= (stat:uid stat) (getuid))
+ (= (stat:dev stat) device)
+ (or (any (lambda (candidate)
+ (let ((candidate (string-append directory "/" candidate)))
+ (and (file-exists? candidate) candidate)))
+ candidates)
+ (and (not (string=? directory "/"))
+ (loop (dirname directory)))))))) ;lexical ".." resolution
+
+(define (auto-detect-manifest opts)
+ "If OPTS do not specify packages or a manifest, load a \"guix.scm\" or
+\"manifest.scm\" file from the current directory or one of its ancestors.
+Return the modified OPTS."
+ (define (options-contain-payload? opts)
+ (match opts
+ (() #f)
+ ((('package . _) . _) #t)
+ ((('load . _) . _) #t)
+ ((('manifest . _) . _) #t)
+ ((('expression . _) . _) #t)
+ ((_ . rest) (options-contain-payload? rest))))
+
+ (define interactive?
+ (not (assoc-ref opts 'exec)))
+
+ (define disallow-implicit-load?
+ (assoc-ref opts 'explicit-loading?))
+
+ (if (or (not interactive?)
+ disallow-implicit-load?
+ (options-contain-payload? opts))
+ opts
+ (match (find-file-in-parent-directories '("guix.scm" "manifest.scm"))
+ (#f
+ (warning (G_ "no packages specified; creating an empty environment~%"))
+ opts)
+ (file
+ (info (G_ "loading environment from '~a'...~%") file)
+ (match (basename file)
+ ("guix.scm" (alist-cons 'load `(package ,file) opts))
+ ("manifest.scm" (alist-cons 'manifest file opts)))))))
(define-command (guix-shell . args)
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index f08637f7ff..0988ca0a75 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -31,6 +31,36 @@ guix shell --bootstrap --pure guile-bootstrap -- guile --version
# '--ad-hoc' is a thing of the past.
! guix shell --ad-hoc guile-bootstrap
+# Ignoring 'manifest.scm' and 'guix.scm' in non-interactive use.
+cat > "$tmpdir/guix.scm" <<EOF
+This is a broken guix.scm file.
+EOF
+(cd "$tmpdir"; guix shell --bootstrap -- true)
+mv "$tmpdir/guix.scm" "$tmpdir/manifest.scm"
+(cd "$tmpdir"; guix shell --bootstrap -- true)
+rm "$tmpdir/manifest.scm"
+
+# Honoring the local 'manifest.scm' file.
+cat > "$tmpdir/manifest.scm" <<EOF
+(specifications->manifest '("guile-bootstrap"))
+EOF
+cat > "$tmpdir/fake-shell.sh" <<EOF
+#!$SHELL
+# This fake shell allows us to test interactive use.
+exec echo "\$GUIX_ENVIRONMENT"
+EOF
+chmod +x "$tmpdir/fake-shell.sh"
+profile1="$(cd "$tmpdir"; SHELL="$(realpath fake-shell.sh)" guix shell --bootstrap)"
+profile2="$(guix shell --bootstrap guile-bootstrap -- "$SHELL" -c 'echo $GUIX_ENVIRONMENT')"
+test -n "$profile1"
+test "$profile1" = "$profile2"
+rm "$tmpdir/manifest.scm"
+
+# Do not read manifest when passed '-q'.
+echo "Broken manifest." > "$tmpdir/manifest.scm"
+(cd "$tmpdir"; SHELL="$(realpath fake-shell.sh)" guix shell --bootstrap -q)
+rm "$tmpdir/manifest.scm"
+
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then
# Compute the build environment for the initial GNU Make.
@@ -51,4 +81,10 @@ then
# 'make-boot0' itself must not be listed.
! guix gc --references "$profile" | grep make-boot0
+
+ # Honoring the local 'guix.scm' file.
+ echo '(@ (guix tests) gnu-make-for-tests)' > "$tmpdir/guix.scm"
+ (cd "$tmpdir"; guix shell --bootstrap --search-paths --pure > "b")
+ cmp "$tmpdir/a" "$tmpdir/b"
+ rm "$tmpdir/guix.scm"
fi
--
2.33.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.