Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding call-with-process-io and other process utilities.

Browse source
This commit is contained in:
Alex Shinn 2012-01-11 00:06:36 +09:00
parent f77366f1ad
commit 087f2170f8
2 changed files with 130 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

125
lib/chibi/process.scm Normal file
View file

@ -0,0 +1,125 @@
(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 (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 (string-char-index str c . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
(let lp ((i start))
(cond
((= i end) #f)
((eq? c (string-ref str i)) i)
(else (lp (+ i 1)))))))
(define (string-split str ch)
(let ((len (string-length str)))
(let lp ((i 0) (res '()))
(let ((j (string-char-index str ch i)))
(if j
(lp (+ j 1) (cons (substring str i j) res))
(reverse (cons (substring str i len) res)))))))
(define (call-with-process-io command proc)
(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 (car in-pipe))
(close-file-descriptor (car out-pipe))
(close-file-descriptor (car err-pipe))
(duplicate-file-descriptor-to (cadr in-pipe) 0)
(duplicate-file-descriptor-to (cadr out-pipe) 1)
(duplicate-file-descriptor-to (cadr err-pipe) 2)
(close-file-descriptor (cadr 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))
(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 str)
(call-with-process-io
str
(lambda (pid in out err)
(close-output-port in)
(let ((res (port->string out)))
(waitpid pid 0)
res))))
(define (process->output+error str)
(call-with-process-io
str
(lambda (pid in out err)
(close-output-port in)
(let ((out (port->string out))
(err (port->string err)))
(waitpid pid 0)
(list out err)))))
(define (process->string-list str)
(call-with-process-io
str
(lambda (pid in out err)
(close-output-port in)
(let ((res (port->string-list out)))
(waitpid pid 0)
res))))

49
lib/chibi/process.sld
View file

@ -13,49 +13,10 @@
signal/alarm signal/term signal/user1
signal/user2 signal/child signal/continue
signal/stop signal/tty-stop signal/tty-input
signal/tty-output wait/no-hang)
(import (scheme))
signal/tty-output wait/no-hang
call-with-process-io
process->string process->string-list process->output+error)
(import (scheme) (chibi io) (chibi filesystem))
(cond-expand (threads (import (srfi 18))) (else #f))
(include-shared "process")
(body
(define (system cmd . args)
(let ((pid (fork)))
(if (zero? pid)
(execute cmd (cons cmd args))
(waitpid pid 0)))))
(cond-expand
(bsd
(body
(define (process-command-line pid)
(let ((res (%process-command-line pid)))
;; TODO: get command-line arguments
(if (string? res) (list res) res)))))
(else
(body
(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)))))))))))))))
(body
(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))))))))
(include "process.scm"))