From 7ffcee1937671cbb318491076164fba4ef0b109c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Feb 2022 22:21:58 +0100 Subject: ui: 'with-paginated-output-port' gives access to the wrapped port. * guix/ui.scm (pager-port-mapping): New variable. (pager-wrapped-port): New procedure. (call-with-paginated-output-port): Parameterize 'pager-port-mapping'. --- guix/ui.scm | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) 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 @@ file-hyperlink location->hyperlink + pager-wrapped-port with-paginated-output-port relevance package-relevance @@ -1665,6 +1666,20 @@ score, the more relevant OBJ is to 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 @@ zero means that PACKAGE does not match any of REGEXPS." 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))))) -- cgit v1.2.3