guile-examples/shell/guile-shell/shell.scm

(library (shell)
  (export call
          cd
          cut
          list-dir
          ls
          pwd
          run-command
          shell)
  (import (except (rnrs base) error)
          (only (guile)
                lambda* λ
                ;; control flow
                when
                unless
                ;; ports
                current-output-port
                current-error-port
                with-output-to-port
                with-error-to-port
                close-port
                pipe
                ;; other
                setvbuf
                eof-object?
                ;; string formatting
                simple-format
                ;; basic shell procedures guile provides
                getcwd
                chdir
                ;; other
                error
                ;; strings
                string-split
                )
          (ice-9 exceptions)
          ;; pipes
          (ice-9 popen)
          (ice-9 textual-ports)
          (ice-9 binary-ports)
          (ice-9 receive)
          ;; ftw stands for file-tree-walk
          ;; for file-system-tree
          (ice-9 ftw)
          ;; for match-lambda
          (ice-9 match)
          ;; let-values
          (srfi srfi-11)
          ;; strings
          (srfi srfi-13)
          (prefix (file) file:)
          (alias)
          (list-helpers)
          (string-helpers))


  (define identity (λ (any) any))


  (define read-from-write-to
    (lambda* (in-port out-port #:key (bytes-count 1024))
      "Read from an IN-PORT and write to OUT-PORT, BYTES-COUNT
bytes at a time."
      (let loop ([bv (get-bytevector-n in-port bytes-count)])
        (unless (eof-object? bv)
          (put-bytevector out-port bv)
          (loop (get-bytevector-n in-port bytes-count))))))


  (define run-command
    (lambda* (cmd
              #:key
              (cmd-out-port (current-output-port))
              (err-out-port (current-error-port)))
      "Allow the user to give output port and error port to the
function."
      (with-output-to-port cmd-out-port
        (λ ()
          (with-error-to-port err-out-port
            (λ ()
              (let* (;; Run the actual command. If an error
                     ;; happens, it should write to the
                     ;; err-write port. Output of the command
                     ;; should be written to an output port,
                     ;; which corresponds to the input-port,
                     ;; which is returned by open-input-pipe.
                     [in-port (open-input-pipe cmd)]
                     ;; Read in block mode.
                     [_ignored (setvbuf in-port 'block)])
                ;; Write to caller given command output port.
                (read-from-write-to in-port cmd-out-port)
                ;; Get the exit code of the command.
                (close-pipe in-port))))))))


  (define shell
    (lambda* (command)
      "Run a shell COMMAND. Return 3 values: (1) exit code, (2)
command output, (3) error output."
      ;; Construct pairs of input and outout ports using
      ;; `pipe'. Whatever is written to the output port can
      ;; be read from the input port.
      (match-let ([(cmd-in . cmd-out) (pipe)]
                  [(err-in . err-out) (pipe)])
        (let ([exit-code
               (run-command command
                            ;; Write command output to the
                            ;; out port, so that it can be
                            ;; read from in port.
                            #:cmd-out-port cmd-out
                            ;; Write error output to the
                            ;; error out port, so that it
                            ;; can be read from the error in
                            ;; port.
                            #:err-out-port err-out)])
          ;; Do not forget to close the out port and error
          ;; out port.
          (close-port cmd-out)
          (close-port err-out)
          ;; Read the (error) output of the command and
          ;; return it.
          (let ([output-message (get-string-all cmd-in)]
                [error-message (get-string-all err-in)])
            (values exit-code
                    output-message
                    error-message))))))


  (define call
    (lambda* (command
              #:key
              (display-exit-code #f)
              (exit-code-formatter
               (λ (exit-code) (string-append (number->string exit-code) "\n")))
              (cmd-out-formatter identity)
              (err-out-formatter identity))
      "Like shell, but displays the results of running the shell
COMMAND, instead of returning them. How output is displayed
can be optionally specified via keyword arguments
EXIT-CODE-FORMATTER, CMD-OUT-FORMATTER,
ERR-OUT-FORMATTER. The keyword argument DISPLAY-EXIT-CODE is
a flag that enables or disables display of the exit code."
      (let-values ([(exit-code cmd-output err-output) (shell command)])
        (when display-exit-code
          (simple-format #t "~a" (exit-code-formatter exit-code)))
        (simple-format #t "~a" (cmd-out-formatter cmd-output))
        (simple-format #t "~a" (err-out-formatter err-output)))))


  ;; EXAMPLE CALLS:

  #;(with-output-to-file "test-output.log"
    (λ ()
      (call "ls -al" #:display-exit-code #t)))

  #;(with-output-to-file "test-output.log"
    (λ ()
      (with-input-from-file "test-input.log"
        (λ ()
          (call "cut -d ' ' -f 1-2" #:display-exit-code #t)))))


  ;; IDEA: Write a function which works like this: (direct function #:in #:out)


  (define pwd
    (lambda* (#:key (output-port (current-output-port)))
      "Return the current working directory."
      (getcwd)))


  (define cut
    (lambda* (input fields
              #:key
              (delimiter "\t")
              (output-delimiter #f)
              (complement #f))
      "Cuts INPUT into parts and selects the parts specified via
FIELDS. FIELDS can be a list of numbers or a pair of
numbers, representing a range."
      (let ([parts (string-split input (λ (c) (char=? c delimiter)))]
            [actual-output-delimiter (if output-delimiter
                                         output-delimiter
                                         (char->string delimiter))])
        (cond
         [(list? fields)
          (string-join (take-indices parts
                                     (map (λ (field) (- field 1))
                                          (unique fields #:eq-test = #:less <)))
                       actual-output-delimiter)]
         [(pair? fields)
          (string-join (take-range parts
                                   (- (car fields) 1)
                                   (- (cdr fields) 1))
                       actual-output-delimiter)]
         [(and (integer? fields)
               (positive? fields))
          (list-ref parts fields)]
         [else
          (raise-exception
           (make-exception
            (make-non-continuable-error)
            (make-exception-with-message "fields arguments not alist or a pair")
            (make-exception-with-irritants (list fields))
            (make-exception-with-origin 'cut)))]))))


  ;; EXAMPLE CALLS

  ;; (cut (pwd) '(1 . 3) #:delimiter #\/)
  ;; (cut (pwd) '(1 2 3) #:delimiter #\/)
  ;; (cut (pwd) '(1 2) #:delimiter #\/)
  ;; (cut (pwd) 2 #:delimiter #\/)


  (define cd
    (λ (filename)
      (chdir filename)))


  (define format-ls-flat-file-entry
    (λ (entry)
      (match entry
        [(name stat)
         (simple-format #f "~a\n" name)]
        [dir
         (error "called format-ls-flat-file-entry with dir")])))


  (define ls
    (lambda* (#:key
              (filename (pwd #:print #f))
              (output-port (current-output-port)))
      (let ([fs-tree (file-system-tree filename)])
        (match fs-tree
          ;; directory
          [(name stat children ...)
           (for-each (λ (formatted-entry)
                       (simple-format output-port "~a" formatted-entry))
                     (map format-ls-flat-file-entry
                          children))]
          ;; flat file
          [flat-file
           (format-ls-flat-file-entry flat-file)]))))


  ;; just an alias
  (alias list-dir ls))