chibi-scheme/lib/chibi/process.scm

(cond-expand
 (plan9
  (define (exit . o)
    (%exit (if (pair? o)
               (if (string? (car o))
                   (car o)
                   (if (eq? #t (car o)) "" "chibi error"))
               ""))))
 (else
  (define (exit . o)
    (%exit (if (pair? o)
               (if (integer? (car o)) (car o) (if (eq? #t (car o)) 0 1))
               0)))))

(cond-expand
 (bsd
  (define (process-command-line pid)
    (let ((res (%process-command-line pid)))
      ;; TODO: get command-line arguments
      (if (string? res) (list res) res))))
 (else
  (define (process-command-line pid)
    (call-with-current-continuation
     (lambda (return)
       (with-exception-handler
        (lambda (exn) (return #f))
        (lambda ()
          (let ((file (string-append "/proc/" (number->string pid) "/cmdline")))
            (call-with-input-file file
              (lambda (in)
                (let lp ((arg '()) (res '()))
                  (let ((ch (read-char in)))
                    (if (or (eof-object? ch) (eqv? (char->integer ch) 0))
                        (let ((res (cons (list->string (reverse arg)) res))
                              (ch2 (peek-char in)))
                          (if (or (eof-object? ch2)
                                  (eqv? (char->integer ch2) 0))
                              (reverse res)
                              (lp '() res)))
                        (lp (cons ch arg) res))))))))))))))

(define (process-running? pid . o)
  (let ((cmdline (process-command-line pid)))
    (and (pair? cmdline)
         (or (null? o)
             (not (car o))
             (equal? (car o) (car cmdline))))))

(define (execute cmd args)
  (define (->string x)
    (cond ((symbol? x) (symbol->string x))
          ((number? x) (number->string x))
          (else x)))
  (execvp (->string cmd) (map ->string args)))

(define (system cmd . args)
  (let ((pid (fork)))
    (cond
     ((zero? pid)
      (let* ((res (execute cmd (cons cmd args)))
             (err (current-error-port)))
        ;; we only arrive here if execute fails
        (cond
         ((output-port? err)
          (display "ERROR: couldn't execute: " (current-error-port))
          (write cmd (current-error-port))
          (newline (current-error-port))))
        (exit 1)))
     (else
      (waitpid pid 0)))))

(define (call-with-process-io command proc)
  (define (set-non-blocking! fd)
    (cond-expand
     (threads
      (set-file-descriptor-status!
       fd
       (bitwise-ior open/non-block (get-file-descriptor-status fd))))
     (else
      #f)))
  (let ((command-ls (if (string? command) (string-split command) command))
        (in-pipe (open-pipe))
        (out-pipe (open-pipe))
        (err-pipe (open-pipe)))
    (and in-pipe out-pipe err-pipe
         (let ((pid (fork)))
           (cond
            ((not pid)
             (error "couldn't fork"))
            ((zero? pid)  ;; child
             (close-file-descriptor (cadr in-pipe))
             (close-file-descriptor (car out-pipe))
             (close-file-descriptor (car err-pipe))
             (duplicate-file-descriptor-to (car in-pipe) 0)
             (duplicate-file-descriptor-to (cadr out-pipe) 1)
             (duplicate-file-descriptor-to (cadr err-pipe) 2)
             (close-file-descriptor (car in-pipe))
             (close-file-descriptor (cadr out-pipe))
             (close-file-descriptor (cadr err-pipe))
             (execute (car command-ls) command-ls))
            (else         ;; parent
             (close-file-descriptor (car in-pipe))
             (close-file-descriptor (cadr out-pipe))
             (close-file-descriptor (cadr err-pipe))
             (set-non-blocking! (cadr in-pipe))
             (set-non-blocking! (car out-pipe))
             (set-non-blocking! (car err-pipe))
             (proc pid
                   (open-output-file-descriptor (cadr in-pipe))
                   (open-input-file-descriptor (car out-pipe))
                   (open-input-file-descriptor (car err-pipe)))))))))

(define (process->string command)
  (call-with-process-io
   command
   (lambda (pid in out err)
     (close-output-port in)
     (let ((res (port->string out)))
       (waitpid pid 0)
       res))))

(define (process->sexp command)
  (call-with-input-string (process->string command) read))

(define (process->output+error+status command)
  (call-with-process-io
   command
   (lambda (pid in out err)
     (close-output-port in)
     (let* ((out (port->string out))
            (err (port->string err))
            (res (waitpid pid 0)))
       (list out err (cadr res))))))

(define (process->output+error command)
  (let ((res (process->output+error+status command)))
    (list (car res) (cadr res))))

(define (process->string-list command)
  (call-with-process-io
   command
   (lambda (pid in out err)
     (close-output-port in)
     (let ((res (port->string-list out)))
       (waitpid pid 0)
       res))))