using-open-pipe.scm 2.6 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091
  1. (import
  2. (except (rnrs base) let-values)
  3. (only (guile)
  4. lambda* λ
  5. display
  6. simple-format)
  7. ;; pipes
  8. (ice-9 popen))
  9. ;; `path-as-string->list` is copied from GNU Guix. Some
  10. ;; comments added. See:
  11. ;; https://git.savannah.gnu.org/cgit/guix.git/tree/guix/build/utils.scm?id=c0bc08d82c73e464a419f213d5ae5545bc67e2bf#n573.
  12. (define* (path-as-string->list path #:optional (separator #\:))
  13. (if separator
  14. (string-tokenize path
  15. ;; Match everything except the
  16. ;; separator.
  17. (char-set-complement
  18. (char-set separator)))
  19. ;; Otherwise simply return a list containing the path
  20. ;; to be sure to always return a list.
  21. (list path)))
  22. ;; `find-executable-on-path` is adapted from GNU Guix's
  23. ;; `which` procedure. See:
  24. ;; https://git.savannah.gnu.org/cgit/guix.git/tree/guix/build/utils.scm?id=c0bc08d82c73e464a419f213d5ae5545bc67e2bf#n617
  25. (define (find-executable-on-path executable)
  26. "Return the complete file name for EXECUTABLE as found in
  27. ${PATH}, or #f if EXECUTABLE could not be found."
  28. ;; search-path is a procedure defined in GNU Guile
  29. (search-path
  30. ;; Check the PATH for the executable.
  31. (path-as-string->list (getenv "PATH"))
  32. executable))
  33. (define find-pager
  34. (λ ()
  35. (or (getenv "PAGER")
  36. (find-executable-on-path "more")
  37. (find-executable-on-path "less"))))
  38. ;;; Now onto the actual matter of using open-pipe ...
  39. (define open-output-pipe*
  40. (λ (command . args)
  41. (open-output-pipe
  42. (string-join (cons command args) " "))))
  43. (define string-repeat
  44. (λ (str n)
  45. (define (iter port str n)
  46. (when (> n 0)
  47. (display str port)
  48. (iter port str (- n 1))))
  49. (call-with-output-string
  50. (λ (port)
  51. (iter port str n)))))
  52. (define long-string
  53. (string-repeat "lines\n1\n2\n3\n" 100))
  54. (define output-paginated
  55. (λ (message)
  56. (let ([pager-pipe
  57. ;; Execute the pager command in a subprocess with its
  58. ;; arguments and return an output pipe to the pager.
  59. (open-output-pipe* (find-pager)
  60. ;; Here we assume, that the
  61. ;; pager will support an
  62. ;; argument "-4". This might
  63. ;; not always be true.
  64. "-4")])
  65. (display (simple-format #f "~a\n" message)
  66. pager-pipe)
  67. ;; Ultimately close pipe after being done with writing to
  68. ;; it.
  69. (close-pipe pager-pipe))))
  70. (output-paginated long-string)
  71. ;;; Usage for example: PAGER=more guile -L . using-open-pipe.scm