Package: guix-patches;
Reported by: David Elsing <david.elsing <at> posteo.net>
Date: Sun, 29 Oct 2023 18:43:02 UTC
Severity: normal
Tags: patch
To reply to this bug, email your comments to 66824 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#66824; Package guix-patches.
(Sun, 29 Oct 2023 18:43:02 GMT) Full text and rfc822 format available.David Elsing <david.elsing <at> posteo.net>:guix-patches <at> gnu.org.
(Sun, 29 Oct 2023 18:43:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: David Elsing <david.elsing <at> posteo.net> To: guix-patches <at> gnu.org Cc: David Elsing <david.elsing <at> posteo.net> Subject: [WIP PATCH] [WIP] Reference original packages in grafted packages. Date: Sun, 29 Oct 2023 18:40:04 +0000
For a grafted package, a symbolic link is created to the ungrafted package in
the .guix-grafts subdirectory. This is activated by default can be disabled by
passing the --no-graft-reference-original option.
---
This addresses https://issues.guix.gnu.org/54495. Would something like
this be acceptable? In my opinion, it would make garbage collector
roots much more useful in the presence of grafts.
I named the symlink file by the store directory name of the grafted
package itself to avoid collisions.
Most of this patch consists of passing graft-reference-original? around
in addition to graft?, I'm not sure of the name however.
When graft? is #f, the derivations are the same regardless of
graft-reference-original?, so it does not need to be set to #f in the
--no-grafts case.
guix/build/graft.scm | 22 +++++++++++++++++-----
guix/gexp.scm | 26 ++++++++++++++++++++++----
guix/grafts.scm | 24 +++++++++++++++++-------
guix/packages.scm | 13 ++++++++++---
guix/scripts.scm | 8 ++++++--
guix/scripts/archive.scm | 5 ++++-
guix/scripts/build.scm | 22 ++++++++++++++++++++--
guix/scripts/environment.scm | 5 ++++-
guix/scripts/home.scm | 5 ++++-
guix/scripts/package.scm | 5 ++++-
guix/scripts/pull.scm | 5 ++++-
guix/scripts/shell.scm | 12 +++++++++---
guix/scripts/system.scm | 5 ++++-
guix/store.scm | 18 ++++++++++++++++++
14 files changed, 143 insertions(+), 32 deletions(-)
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index 281dbaba6f..83a7f20f76 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -340,7 +340,8 @@ (define not-slash
(() #t))))
(define* (rewrite-directory directory output mapping
- #:optional (store (%store-directory)))
+ #:optional (store (%store-directory))
+ #:key (reference-original? #t))
"Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
file name pairs."
@@ -417,7 +418,14 @@ (define (rewrite-leaf file)
(exit-on-exception rewrite-leaf)
(find-files directory (const #t)
#:directories? #t))
- (rename-matching-files output mapping))
+ (rename-matching-files output mapping)
+
+ (when reference-original?
+ ;; Create a symbolic link to the original directory
+ (mkdir-p* (string-append output "/.guix-grafts"))
+ (symlink directory
+ (string-append output "/.guix-grafts/"
+ (basename output)))))
(define %graft-hooks
;; Default list of hooks run after grafting.
@@ -425,14 +433,18 @@ (define %graft-hooks
(define* (graft old-outputs new-outputs mapping
#:key (log-port (current-output-port))
- (hooks %graft-hooks))
+ (hooks %graft-hooks)
+ (reference-original? #t))
"Apply the grafts described by MAPPING on OLD-OUTPUTS, leading to
NEW-OUTPUTS. MAPPING must be a list of file name pairs; OLD-OUTPUTS and
-NEW-OUTPUTS are lists of output name/file name pairs."
+NEW-OUTPUTS are lists of output name/file name pairs. If REFERENCE-ORIGINAL?
+is #t, a symlink to the corresponding directory in NEW-OUTPUTS is added to
+each directory in OLD-OUTPUTS."
(for-each (lambda (input output)
(format log-port "grafting '~a' -> '~a'...~%" input output)
(force-output)
- (rewrite-directory input output mapping))
+ (rewrite-directory input output mapping
+ #:reference-original? reference-original?))
(match old-outputs
(((names . files) ...)
files))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 0fe4f1c98a..6cf4da0cdc 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -286,7 +286,8 @@ (define* (lower-object obj
(mlet %store-monad ((target (if (eq? target 'current)
(current-target-system)
(return target)))
- (graft? (grafting?)))
+ (graft? (grafting?))
+ (graft-reference-original? (graft-referencing-original?)))
(let loop ((obj obj))
(match (lookup-compiler obj)
(#f
@@ -302,7 +303,8 @@ (define* (lower-object obj
(loop lowered)
(return lowered)))
obj
- system target graft?)))))))
+ system target graft?
+ graft-reference-original?)))))))
(define* (lower+expand-object obj
#:optional (system (%current-system))
@@ -317,11 +319,14 @@ (define* (lower+expand-object obj
(raise (condition (&gexp-input-error (input obj)))))
(lower
(mlet* %store-monad ((graft? (grafting?))
+ (graft-reference-original?
+ (graft-referencing-original?))
(lowered (if (derivation? obj)
(return obj)
(mcached (lower obj system target)
- obj
- system target graft?))))
+ obj system target
+ graft?
+ graft-reference-original?))))
;; LOWER might return something that needs to be further
;; lowered.
(if (struct? lowered)
@@ -1011,6 +1016,7 @@ (define* (lower-gexp exp
(system (%current-system))
(target 'current)
(graft? (%graft?))
+ (graft-reference-original? (%graft-reference-original?))
(guile-for-build (%guile-for-build))
(effective-version "3.0")
@@ -1047,6 +1053,8 @@ (define (search-path modules extensions suffix)
;; '%current-target-system' to be looked up at >>=
;; time.
(graft? (set-grafting graft?))
+ (graft-reference-original?
+ (set-graft-reference-original graft-reference-original?))
(system -> (or system (%current-system)))
(target -> (if (eq? target 'current)
@@ -1073,6 +1081,7 @@ (define (search-path modules extensions suffix)
#:module-path module-path))
(modules -> (car modules+compiled))
(compiled -> (cdr modules+compiled)))
+
(define load-path
(search-path modules exts
(string-append "/share/guile/site/" effective-version)))
@@ -1084,6 +1093,7 @@ (define load-compiled-path
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
+ (set-graft-reference-original graft-reference-original?)
(return (lowered-gexp sexp
`(,@(if (derivation? modules)
(list (derivation-input modules))
@@ -1108,6 +1118,8 @@ (define* (gexp->derivation name exp
(guile-for-build (%guile-for-build))
(effective-version "3.0")
(graft? (%graft?))
+ (graft-reference-original?
+ (%graft-reference-original?))
references-graphs
allowed-references disallowed-references
leaked-env-vars
@@ -1158,6 +1170,7 @@ (define* (gexp->derivation name exp
The other arguments are as for 'derivation'."
(define outputs (gexp-outputs exp))
(define requested-graft? graft?)
+ (define requested-graft-reference-original? graft-reference-original?)
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
@@ -1181,6 +1194,8 @@ (define (add-modules exp modules)
;; '%current-target-system' to be looked up at >>=
;; time.
(graft? (set-grafting graft?))
+ (graft-reference-original?
+ (set-graft-reference-original graft-reference-original?))
(system -> (or system (%current-system)))
(target -> (if (eq? target 'current)
@@ -1192,6 +1207,8 @@ (define (add-modules exp modules)
#:system system
#:target target
#:graft? requested-graft?
+ #:graft-reference-original?
+ requested-graft-reference-original?
#:guile-for-build
guile-for-build
#:effective-version
@@ -1220,6 +1237,7 @@ (define (add-modules exp modules)
(lowered-gexp-sexp lowered)))))
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
+ (set-graft-reference-original graft-reference-original?)
(raw-derivation name
(string-append (derivation-input-output-path guile)
"/bin/guile")
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 48f4c212f7..c232fd509d 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -44,6 +44,7 @@ (define-module (guix grafts)
%graft-with-utf8-locale?)
#:re-export (%graft? ;for backward compatibility
+ %graft-reference-original?
without-grafting
set-grafting
grafting?))
@@ -92,7 +93,8 @@ (define* (graft-derivation/shallow drv grafts
(name (derivation-name drv))
(outputs (derivation-output-names drv))
(guile (%guile-for-build))
- (system (%current-system)))
+ (system (%current-system))
+ (reference-original? #t))
"Return a derivation called NAME, which applies GRAFTS to the specified
OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS
are not recursively applied to dependencies of DRV."
@@ -144,7 +146,8 @@ (define %outputs
(cons (assoc-ref old-outputs name)
file)))
%outputs))))
- (graft old-outputs %outputs mapping)))))
+ (graft old-outputs %outputs mapping
+ #:reference-original? #$reference-original?)))))
(define properties
@@ -246,7 +249,8 @@ (define* (cumulative-grafts store drv grafts
#:key
(outputs (derivation-output-names drv))
(guile (%guile-for-build))
- (system (%current-system)))
+ (system (%current-system))
+ (reference-original? #t))
"Augment GRAFTS with additional grafts resulting from the application of
GRAFTS to the dependencies of DRV. Return the resulting list of grafts.
@@ -278,7 +282,9 @@ (define (dependency-grafts items)
(cumulative-grafts store drv grafts
#:outputs (list output)
#:guile guile
- #:system system)))))
+ #:system system
+ #:reference-original?
+ reference-original?)))))
(reference-origins drv items)))
(with-cache (list (derivation-file-name drv) outputs grafts)
@@ -300,7 +306,9 @@ (define (dependency-grafts items)
(let* ((new (graft-derivation/shallow* store drv applicable
#:outputs outputs
#:guile guile
- #:system system))
+ #:system system
+ #:reference-original?
+ reference-original?))
(grafts (append (map (lambda (output)
(graft
(origin drv)
@@ -315,7 +323,8 @@ (define* (graft-derivation store drv grafts
#:key
(guile (%guile-for-build))
(outputs (derivation-output-names drv))
- (system (%current-system)))
+ (system (%current-system))
+ (reference-original? #t))
"Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
DRV, and graft DRV itself to refer to those grafted dependencies."
@@ -323,7 +332,8 @@ (define* (graft-derivation store drv grafts
(run-with-state
(cumulative-grafts store drv grafts
#:outputs outputs
- #:guile guile #:system system)
+ #:guile guile #:system system
+ #:reference-original? reference-original?)
(store-connection-cache store %graft-cache))))
;; Save CACHE in STORE to benefit from it on the next call.
diff --git a/guix/packages.scm b/guix/packages.scm
index e2e82692ad..41dec95355 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1962,7 +1962,10 @@ (define graft-derivation*
(define* (package->derivation package
#:optional (system (%current-system))
- #:key (graft? (%graft?)))
+ #:key
+ (graft? (%graft?))
+ (graft-reference-original?
+ (%graft-reference-original?)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
@@ -1982,7 +1985,9 @@ (define* (package->derivation package
system #:graft? #f)))
(graft-derivation* drv grafts
#:system system
- #:guile guile)))))
+ #:guile guile
+ #:reference-original?
+ graft-reference-original?)))))
(return drv)))
package system #f graft?))
@@ -2005,7 +2010,9 @@ (define* (package->cross-derivation package target
system #:graft? #f)))
(graft-derivation* drv grafts
#:system system
- #:guile guile)))))
+ #:guile guile
+ #:reference-original?
+ graft-reference-original?)))))
(return drv)))
package system target graft?))
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 5d11ce7fe9..7f9e53b28f 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -197,13 +197,17 @@ (define* (build-package package
#:rest build-options)
"Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
Show what and how will/would be built."
- (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
+ (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad)))
+ (graft-reference-original?
+ ((lift0 %graft-reference-original? %store-monad))))
(apply set-build-options*
#:use-substitutes? use-substitutes?
(strip-keyword-arguments '(#:dry-run?) build-options))
(mlet %store-monad ((derivation (package->derivation
package #:graft? (and (not dry-run?)
- grafting?))))
+ grafting?)
+ #:graft-reference-original?
+ graft-reference-original?)))
(mbegin %store-monad
(maybe-build (list derivation)
#:use-substitutes? use-substitutes?
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 2b5a55a23f..34151d70b6 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -58,6 +58,7 @@ (define %default-options
(substitutes? . #t)
(offload? . #t)
(graft? . #t)
+ (graft-reference-original? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
@@ -377,7 +378,9 @@ (define (lines port)
(with-error-handling
(let ((opts (parse-command-line args %options (list %default-options))))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(cond ((assoc-ref opts 'generate-key)
=>
generate-key-pair)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 05f022a92e..c17d84bd20 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -170,6 +170,10 @@ (define (show-build-options-help)
fetch substitute from URLS if they are authorized"))
(display (G_ "
--no-grafts do not graft packages"))
+ (display (G_ "
+ --no-graft-reference-original
+ for grafted packages, do not reference the ungrafted
+ version"))
(display (G_ "
--no-offload do not attempt to offload builds"))
(display (G_ "
@@ -290,6 +294,13 @@ (define %standard-build-options
(alist-cons 'graft? #f
(alist-delete 'graft? result eq?))
rest)))
+ (option '("no-graft-reference-original") #f #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons
+ 'graft-reference-original? #f
+ (alist-delete 'graft-reference-original? result))
+ rest)))
(option '("no-offload" "no-build-hook") #f #f
(lambda (opt name arg result . rest)
(when (string=? name "no-build-hook")
@@ -418,6 +429,7 @@ (define %default-options
;; Alist of default option values.
`((build-mode . ,(build-mode normal))
(graft? . #t)
+ (graft-reference-original? . #t)
(substitutes? . #t)
(offload? . #t)
(print-build-trace? . #t)
@@ -633,6 +645,7 @@ (define package->derivation
(define src (assoc-ref opts 'source))
(define graft? (assoc-ref opts 'graft?))
+ (define graft-reference-original? (assoc-ref opts 'graft-reference-original?))
(define systems
(match (filter-map (match-lambda
(('system . system) system)
@@ -707,7 +720,8 @@ (define (compute-derivation obj system)
;; of user packages. Since 'guix build' is the primary tool for people
;; testing new packages, report such errors gracefully.
(with-unbound-variable-handling
- (parameterize ((%graft? graft?))
+ (parameterize ((%graft? graft?)
+ (%graft-reference-original? graft-reference-original?))
(append-map (lambda (system)
(concatenate
(map/accumulate-builds store
@@ -740,6 +754,9 @@ (define opts
(define graft?
(assoc-ref opts 'graft?))
+ (define graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?))
+
(with-error-handling
(with-status-verbosity (assoc-ref opts 'verbosity)
(with-store store
@@ -757,7 +774,8 @@ (define graft?
;; Set grafting upfront in case the user's input
;; depends on it (e.g., a manifest or code snippet that
;; calls 'gexp->derivation').
- (%graft? graft?))
+ (%graft? graft?)
+ (%graft-reference-original? graft-reference-original?))
(let* ((mode (assoc-ref opts 'build-mode))
(drv (options->derivations store opts))
(urls (map (cut string-append <> "/log")
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 6ae3b11e39..ef801522e4 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -171,6 +171,7 @@ (define %default-options
(symlinks . ())
(offload? . #t)
(graft? . #t)
+ (graft-reference-original? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
@@ -1100,7 +1101,9 @@ (define-syntax-rule (with-store/maybe store exp ...)
;; Evaluate EXP... with STORE bound to a connection, unless
;; STORE-NEEDED? is false, in which case STORE is bound to #f.
(let ((proc (lambda (store) exp ...)))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(if store-needed?
(with-store s
(set-build-options-from-command-line s opts)
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index b4c82d275f..8f47c7ab73 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -211,6 +211,7 @@ (define %options
(define %default-options
`((graft? . #t)
+ (graft-reference-original? . #t)
(substitutes? . #t)
(offload? . #t)
(print-build-trace? . #t)
@@ -694,7 +695,9 @@ (define (parse-args args)
(let* ((opts (parse-args args))
(args (option-arguments opts))
(command (assoc-ref opts 'action)))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(with-status-verbosity (verbosity-level opts)
(process-command command args opts))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index a489e06e73..d998b5c695 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -419,6 +419,7 @@ (define %default-options
`((verbosity . 1)
(debug . 0)
(graft? . #t)
+ (graft-reference-original? . #t)
(substitutes? . #t)
(offload? . #t)
(print-build-trace? . #t)
@@ -1084,7 +1085,9 @@ (define (guix-package* opts)
(with-error-handling
(or (process-query opts)
(parameterize ((%store (open-connection))
- (%graft? (assoc-ref opts 'graft?)))
+ (%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(with-status-verbosity (assoc-ref opts 'verbosity)
(set-build-options-from-command-line (%store) opts)
(with-build-handler (build-notifier #:use-substitutes?
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58d3cd7e83..f1f1702d18 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -74,6 +74,7 @@ (define %default-options
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
(graft? . #t)
+ (graft-reference-original? . #t)
(debug . 0)
(verbosity . 1)
(authenticate-channels? . #t)
@@ -859,7 +860,9 @@ (define (no-arguments arg _)
(with-store store
(with-status-verbosity (assoc-ref opts 'verbosity)
(parameterize ((%current-system (assoc-ref opts 'system))
- (%graft? (assoc-ref opts 'graft?)))
+ (%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(with-build-handler (build-notifier #:use-substitutes?
substitutes?
#:verbosity
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 10ea110fee..afa9eee48f 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -26,7 +26,7 @@ (define-module (guix scripts shell)
#:autoload (guix transformations) (options->transformation
transformation-option-key?
show-transformation-options-help)
- #:autoload (guix grafts) (%graft?)
+ #:autoload (guix grafts) (%graft? %graft-reference-original?)
#:use-module (guix scripts)
#:use-module (guix packages)
#:use-module (guix profiles)
@@ -355,7 +355,10 @@ (define (profile-file-cache-key file system)
;; be insufficient: <https://lwn.net/Articles/866582/>.
(sha256 (string->utf8
(string-append primary-key ":" system ":"
- (if (%graft?) "" "ungrafted:")
+ (if (%graft?)
+ (if (%graft-reference-original?)
+ "" "noreforig:")
+ "ungrafted:")
(number->string (stat:dev stat)) ":"
(number->string (stat:ino stat))))))))))
@@ -368,7 +371,10 @@ (define (profile-spec-cache-key specs system)
(bytevector->base32-string
(sha256 (string->utf8
(string-append primary-key ":" system ":"
- (if (%graft?) "" "ungrafted:")
+ (if (%graft?)
+ (if (%graft-reference-original?)
+ "" "noreforig:")
+ "ungrafted:")
(object->string specs))))))))
(define (profile-cached-gc-root opts)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f85b663d64..308dbaf813 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1166,6 +1166,7 @@ (define %default-options
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
(graft? . #t)
+ (graft-reference-original? . #t)
(debug . 0)
(verbosity . #f) ;default
(validate-reconfigure . ,ensure-forward-reconfigure)
@@ -1456,7 +1457,9 @@ (define (fail)
parse-sub-command))
(args (option-arguments opts))
(command (assoc-ref opts 'action)))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(with-status-verbosity (verbosity-level opts)
(process-command command args opts))))))
diff --git a/guix/store.scm b/guix/store.scm
index f8e77b2cd9..ba5a5dd3f2 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -181,9 +181,12 @@ (define-module (guix store)
interned-file-tree
%graft?
+ %graft-reference-original?
without-grafting
set-grafting
+ set-graft-reference-original
grafting?
+ graft-referencing-original?
%store-prefix
store-path
@@ -2183,6 +2186,9 @@ (define %graft?
;; Whether to honor package grafts by default.
(make-parameter #t))
+(define %graft-reference-original?
+ (make-parameter #t))
+
(define (call-without-grafting thunk)
(lambda (store)
(values (parameterize ((%graft? #f))
@@ -2200,11 +2206,23 @@ (define-inlinable (set-grafting enable?)
(lambda (store)
(values (%graft? enable?) store)))
+(define-inlinable (set-graft-reference-original enable?)
+ ;; This monadic procedure enables grafting when ENABLE? is true, and
+ ;; disables it otherwise. It returns the previous setting.
+ (lambda (store)
+ (values (%graft-reference-original? enable?) store)))
+
(define-inlinable (grafting?)
;; Return a Boolean indicating whether grafting is enabled.
(lambda (store)
(values (%graft?) store)))
+(define-inlinable (graft-referencing-original?)
+ ;; Return a Boolean indicating whether grafted packages should contain a
+ ;; symlink to the corresponding ungrafted package.
+ (lambda (store)
+ (values (%graft-reference-original?) store)))
+
;;;
;;; Store paths.
--
2.41.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.