(library (swank os)
(export getpid make-server-socket accept local-port close-socket)
(import (rnrs)
(primitives foreign-procedure
ffi/handle->address
ffi/string->asciiz
sizeof:pointer
sizeof:int
%set-pointer
%get-int))
(define getpid (foreign-procedure "getpid" '() 'int))
(define fork (foreign-procedure "fork" '() 'int))
(define close (foreign-procedure "close" '(int) 'int))
(define dup2 (foreign-procedure "dup2" '(int int) 'int))
(define bytevector-content-offset$ sizeof:pointer)
(define execvp% (foreign-procedure "execvp" '(string boxed) 'int))
(define (execvp file . args)
(let* ((nargs (length args))
(argv (make-bytevector (* (+ nargs 1)
sizeof:pointer))))
(do ((offset 0 (+ offset sizeof:pointer))
(as args (cdr as)))
((null? as))
(%set-pointer argv
offset
(+ (ffi/handle->address (ffi/string->asciiz (car as)))
bytevector-content-offset$)))
(%set-pointer argv (* nargs sizeof:pointer) 0)
(execvp% file argv)))
(define pipe% (foreign-procedure "pipe" '(boxed) 'int))
(define (pipe)
(let ((array (make-bytevector (* sizeof:int 2))))
(let ((r (pipe% array)))
(values r (%get-int array 0) (%get-int array sizeof:int)))))
(define (fork/exec file . args)
(let ((pid (fork)))
(cond ((= pid 0)
(apply execvp file args))
(#t pid))))
(define (start-process file . args)
(let-values (((r1 down-out down-in) (pipe))
((r2 up-out up-in) (pipe))
((r3 err-out err-in) (pipe)))
(assert (= 0 r1))
(assert (= 0 r2))
(assert (= 0 r3))
(let ((pid (fork)))
(case pid
((-1)
(error "Failed to fork a subprocess."))
((0)
(close up-out)
(close err-out)
(close down-in)
(dup2 down-out 0)
(dup2 up-in 1)
(dup2 err-in 2)
(apply execvp file args)
(exit 1))
(else
(close down-out)
(close up-in)
(close err-in)
(list pid
(make-fd-io-stream up-out down-in)
(make-fd-io-stream err-out err-out)))))))
(define (make-fd-io-stream in out)
(let ((write (lambda (bv start count) (fd-write out bv start count)))
(read (lambda (bv start count) (fd-read in bv start count)))
(closeit (lambda () (close in) (close out))))
(make-custom-binary-input/output-port
"fd-stream" read write #f #f closeit)))
(define write% (foreign-procedure "write" '(int ulong int) 'int))
(define (fd-write fd bytevector start count)
(write% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define read% (foreign-procedure "read" '(int ulong int) 'int))
(define (fd-read fd bytevector start count)
(read% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define (make-server-socket port)
(let* ((args `("/bin/bash" "bash"
"-c"
,(string-append
"netcat -s 127.0.0.1 -q 0 -l -v "
(if port
(string-append "-p " (number->string port))
""))))
(nc (apply start-process args))
(err (transcoded-port (list-ref nc 2)
(make-transcoder (latin-1-codec))))
(line (get-line err))
(pos (last-index-of line '#\])))
(cond (pos
(let* ((tail (substring line (+ pos 1) (string-length line)))
(port (get-datum (open-string-input-port tail))))
(list (car nc) (cadr nc) err port)))
(#t (error "netcat failed: " line)))))
(define (accept socket codec)
(let* ((line (get-line (caddr socket)))
(pos (last-index-of line #\])))
(cond (pos
(close-port (caddr socket))
(let ((stream (cadr socket)))
(let ((io (transcoded-port stream (make-transcoder codec))))
(values io io))))
(else (error "accept failed: " line)))))
(define (local-port socket)
(list-ref socket 3))
(define (last-index-of str chr)
(let loop ((i (string-length str)))
(cond ((<= i 0) #f)
(#t (let ((i (- i 1)))
(cond ((char=? (string-ref str i) chr)
i)
(#t
(loop i))))))))
(define (close-socket socket)
#f
)
)
(library (swank sys)
(export implementation-name eval-in-interaction-environment)
(import (rnrs)
(primitives system-features
aeryn-evaluator))
(define (implementation-name) "larceny")
(define (eval-in-interaction-environment form)
(aeryn-evaluator form))
)
(import (rnrs) (rnrs eval) (larceny load))
(load "swank-r6rs.scm")
(eval '(start-server #f) (environment '(swank)))
