mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
8b5eb68238
They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket.
136 lines
4.4 KiB
Scheme
136 lines
4.4 KiB
Scheme
|
|
(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 (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 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->sexp str)
|
|
(call-with-input-string (process->string str) read))
|
|
|
|
(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))))
|