diff options
Diffstat (limited to 'guix/ui.scm')
| -rw-r--r-- | guix/ui.scm | 111 |
1 files changed, 87 insertions, 24 deletions
diff --git a/guix/ui.scm b/guix/ui.scm index ea5f460865..45c8923c99 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -69,6 +69,11 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) + #:autoload (ice-9 popen) (open-pipe* close-pipe) + #:use-module ((ice-9 binary-ports) + #:select (make-custom-binary-output-port + put-bytevector)) + #:use-module (rnrs bytevectors) #:autoload (system base compile) (compile-file) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) @@ -1557,6 +1562,77 @@ score, the more relevant OBJ is to REGEXPS." zero means that PACKAGE does not match any of REGEXPS." (relevance package regexps %package-metrics)) +(define (paged-output-port port) + (define max-rows + (and (isatty?* port) (terminal-rows port))) + + (define lines 1) + (define pipe #f) + (define buffer '()) + (define pager (or (getenv "PAGER") "less")) + + (define (newline-count bv start count) + (define end (+ start count)) + (let loop ((index start) + (newlines 0)) + (if (< index end) + (loop (+ 1 index) + (match (bytevector-u8-ref bv index) + (10 (+ newlines 1)) + (_ newlines))) + newlines))) + + (define (flush) + (for-each (cut put-bytevector port <>) (reverse buffer)) + (set! buffer '())) + + (define (write! bv start count) + (cond (pipe + ;; Pager is running, write BV to it. + (if (zero? count) ;EOF + (begin + (close-pipe pipe) + (set! pipe #f) + 0) + (begin + (put-bytevector pipe bv start count) + count))) + ((zero? count) ;EOF, no pager + (flush) + 0) + ((<= lines max-rows) + ;; We're below the threshold, so buffer BV. + (set! lines (+ lines (newline-count bv start count))) + (set! buffer + (let ((copy (make-bytevector count))) + (bytevector-copy! bv start copy 0 count) + (cons copy buffer))) + count) + (else + ;; We've reached the threshold: spawn a pager and write to it. + (set! pipe (open-pipe* OPEN_WRITE pager)) + (flush) + (setvbuf pipe 'none) + (write! bv start count)))) + + (if max-rows + (let ((proxy (make-custom-binary-output-port "paged-output-port" + write! #f #f flush))) + (set-port-encoding! proxy (port-encoding port)) + proxy) + port)) + +(define (call-with-paged-output-port port proc) + (let* ((paged (paged-output-port port)) + (close (if (eq? paged port) (const #t) close-port))) + (dynamic-wind + (const #t) + (lambda () (proc paged)) + (lambda () (close paged))))) + +(define-syntax-rule (with-paged-output-port proxied port exp ...) + (call-with-paged-output-port proxied (lambda (port) exp ...))) + (define* (display-search-results matches port #:key (command "guix search") @@ -1573,30 +1649,17 @@ them. If PORT is a terminal, print at most a full screen of results." (define (line-count str) (string-count str #\newline)) - (let loop ((matches matches)) - (match matches - (((package . score) rest ...) - (let* ((links? (supports-hyperlinks? port)) - (text (call-with-output-string - (lambda (port) - (print package port - #:hyperlinks? links? - #:extra-fields - `((relevance . ,score))))))) - (if (and (not (getenv "INSIDE_EMACS")) - max-rows - (> (port-line port) first-line) ;print at least one result - (> (+ 4 (line-count text) (port-line port)) - max-rows)) - (unless (null? rest) - (display-hint (format #f (G_ "Run @code{~a ... | less} \ -to view all the results.") - command))) - (begin - (display text port) - (loop rest))))) - (() - #t)))) + (with-paged-output-port port paged + (let loop ((matches matches)) + (match matches + (((package . score) rest ...) + (let* ((links? (supports-hyperlinks? port))) + (print package paged + #:hyperlinks? links? + #:extra-fields `((relevance . ,score))) + (loop rest))) + (() + #t))))) (define (string->generations str) |