1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889 |
- (library (paginated-output)
- (export output-paginated)
- (import (except (rnrs base) let-values)
- (only (guile)
- ;; lambdas
- lambda* λ
- ;; control structures
- when
- ;; display
- display
- simple-format
- ;; strings
- string-join
- string-append
- string-tokenize
- ;; characters
- char-set
- char-set-complement
- ;; environment variables
- getenv
- ;; path stuff
- search-path)
- ;; pipes
- (ice-9 popen))
- ;; `path-as-string->list`'s logic is copied from GNU
- ;; Guix. Some comments added. See:
- ;; https://git.savannah.gnu.org/cgit/guix.git/tree/guix/build/utils.scm?id=c0bc08d82c73e464a419f213d5ae5545bc67e2bf#n573.
- (define path-as-string->list
- (lambda* (path #:optional (separator #\:))
- (if separator
- (string-tokenize path
- ;; Match everything except the
- ;; separator.
- (char-set-complement
- (char-set separator)))
- ;; Otherwise simply return a list containing the
- ;; path to be sure to always return a list.
- (list path))))
- ;; `find-executable-on-path` is adapted from GNU Guix's
- ;; `which` procedure. See:
- ;; https://git.savannah.gnu.org/cgit/guix.git/tree/guix/build/utils.scm?id=c0bc08d82c73e464a419f213d5ae5545bc67e2bf#n617
- (define (find-executable-on-path executable)
- "Return the complete file name for EXECUTABLE as found in
- ${PATH}, or #f if EXECUTABLE could not be found."
- ;; search-path is a procedure defined in GNU Guile
- (search-path
- ;; Check the PATH for the executable.
- (path-as-string->list (getenv "PATH"))
- executable))
- (define find-pager
- (λ ()
- (or (getenv "PAGER")
- (find-executable-on-path "more")
- (find-executable-on-path "less"))))
- ;;; Now onto the actual matter of using open-pipe ...
- (define open-output-pipe*
- (λ (command . args)
- (open-output-pipe
- (string-join (cons command args) " "))))
- (define output-paginated
- (lambda* (message #:optional (lines-per-page #f))
- (let* ([pager-args
- (if lines-per-page
- ;; Here we assume, that the pager will support
- ;; an argument "-<number>". This might not always be
- ;; true.
- (list (string-append "-" (number->string lines-per-page)))
- '())]
- [pager-pipe
- ;; Execute the pager command in a subprocess
- ;; with its arguments and return an output
- ;; pipe to the pager.
- (apply open-output-pipe* (find-pager) pager-args)])
- (display (simple-format #f "~a\n" message)
- pager-pipe)
- ;; Ultimately close pipe after being done with
- ;; writing to it.
- (close-pipe pager-pipe)))))
|