diff --git a/guix/ui.scm b/guix/ui.scm index 093de1b4ab..d1f92ce7be 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -124,6 +124,7 @@ (define-module (guix ui) file-hyperlink location->hyperlink + pager-wrapped-port with-paginated-output-port relevance package-relevance @@ -1665,6 +1666,20 @@ (define (package-relevance package regexps) zero means that PACKAGE does not match any of REGEXPS." (relevance package regexps %package-metrics)) +(define pager-port-mapping + ;; If a pager is being used, via 'with-paginated-output-port', this maps the + ;; pager port (pipe) to the underlying output port. + (make-parameter #f)) + +(define* (pager-wrapped-port #:optional (port (current-output-port))) + "If PORT is a pipe to a pager created by 'with-paginated-output-port', +return the underlying port. Otherwise return #f." + (match (pager-port-mapping) + ((pager . wrapped) + (and (eq? pager port) wrapped)) + (_ + #f))) + (define* (call-with-paginated-output-port proc #:key (less-options "FrX")) (let ((pager-command-line (or (getenv "GUIX_PAGER") @@ -1691,7 +1706,10 @@ (define* (call-with-paginated-output-port proc char-set:whitespace)))))) (dynamic-wind (const #t) - (lambda () (proc pager)) + (lambda () + (parameterize ((pager-port-mapping + (cons pager (current-output-port)))) + (proc pager))) (lambda () (close-pipe pager)))) (proc (current-output-port)))))