futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ui: 'with-paginated-output-port' gives access to the wrapped port.

Browse Source 
* guix/ui.scm (pager-port-mapping): New variable.
(pager-wrapped-port): New procedure.
(call-with-paginated-output-port): Parameterize 'pager-port-mapping'.
This commit is contained in:
Ludovic Courtès 2022-02-09 22:21:58 +01:00
parent b9df2e2b4d
commit 7ffcee1937
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 19 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
guix/ui.scm
View File

@ -124,6 +124,7 @@
file-hyperlink file-hyperlink
location->hyperlink location->hyperlink
pager-wrapped-port
with-paginated-output-port with-paginated-output-port
relevance relevance
package-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." zero means that PACKAGE does not match any of REGEXPS."
(relevance package regexps %package-metrics)) (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 (define* (call-with-paginated-output-port proc
#:key (less-options "FrX")) #:key (less-options "FrX"))
(let ((pager-command-line (or (getenv "GUIX_PAGER") (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)))))) char-set:whitespace))))))
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (proc pager)) (lambda ()
(parameterize ((pager-port-mapping
(cons pager (current-output-port))))
(proc pager)))
(lambda () (close-pipe pager)))) (lambda () (close-pipe pager))))
(proc (current-output-port))))) (proc (current-output-port)))))