mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
125 lines
4.2 KiB
Scheme
125 lines
4.2 KiB
Scheme
|
|
(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))))
|