[bug#40911] ‘guix search’ and $PAGER

[Ludovic Courtès]

Hello Guix!

There seems to be consensus on getting ‘guix search’ to automatically
invoke $PAGER (I don’t think there’s a bug report, though).

Below is a first stab at it that’s (almost) functional but raises
questions:

  1. This patch arranges to invoke the pager only if we output a
     screenful of text.  However, that means that the
     ‘supports-hyperlinks?’ call is passed the wrong port, typically the
     actual stdout (a terminal) instead of the pager.  Pagers typically
     don’t support hyperlinks, it seems.

     Is there another way to do that?  Should we just invoke the pager
     unconditionally?

  2. What if ‘less’ or $PAGER doesn’t exists or exits with non-zero?
     What do others do?

Feedback & alternative patches more than welcome!

Ludo’.

diff --git a/.dir-locals.el b/.dir-locals.el
index ce305602f2..2f5d31f632 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -96,6 +96,8 @@
    (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1))
    (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2))
 
+   (eval . (put 'with-paged-output-port 'scheme-indent-function 2))
+
    ;; This notably allows '(' in Paredit to not insert a space when the
    ;; preceding symbol is one of these.
    (eval . (modify-syntax-entry ?~ "'"))
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)