applied patch from andreas rottmann for providing "process*" which
is the kitchen sink of subprocess creation.
This commit is contained in:
parent
f33e304606
commit
4ce666c8d6
|
@ -65,7 +65,8 @@
|
|||
input-port-byte-position
|
||||
input-port-column-number input-port-row-number
|
||||
process process-nonblocking
|
||||
|
||||
process*
|
||||
|
||||
tcp-connect tcp-connect-nonblocking
|
||||
udp-connect udp-connect-nonblocking
|
||||
tcp-server-socket tcp-server-socket-nonblocking
|
||||
|
@ -2320,59 +2321,74 @@
|
|||
|
||||
|
||||
|
||||
(define (pair->env-utf8 pair)
|
||||
(let* ((key-utf8 (string->utf8 (car pair)))
|
||||
(val-utf8 (string->utf8 (cdr pair)))
|
||||
(key-len (bytevector-length key-utf8))
|
||||
(val-len (bytevector-length val-utf8))
|
||||
(result (make-bytevector (+ key-len val-len 2))))
|
||||
(bytevector-copy! key-utf8 0 result 0 key-len)
|
||||
(bytevector-u8-set! result key-len (char->integer #\=))
|
||||
(bytevector-copy! val-utf8 0 result (+ key-len 1) val-len)
|
||||
(bytevector-u8-set! result (+ key-len val-len 1) 0)
|
||||
result))
|
||||
|
||||
(define (spawn-process who search? blocking? env stdin stdout stderr cmd args)
|
||||
(define (port->fd port port-pred arg-name port-type)
|
||||
(cond ((eqv? port #f) -1)
|
||||
((port-pred port)
|
||||
(let ((fd (cookie-dest ($port-cookie port))))
|
||||
(unless (fixnum? fd)
|
||||
(die who
|
||||
(string-append arg-name " is not a file-based port")
|
||||
stdin))
|
||||
fd))
|
||||
(else
|
||||
(die who
|
||||
(string-append arg-name " is neither false nor an " port-type)
|
||||
stdin))))
|
||||
(let ((stdin-fd (port->fd stdin input-port? "stdin" "input port"))
|
||||
(stdout-fd (port->fd stdout output-port? "stdout" "output port"))
|
||||
(stderr-fd (port->fd stderr output-port? "stderr" "output port")))
|
||||
(unless (string? cmd)
|
||||
(die who "command is not a string" cmd))
|
||||
(unless (andmap string? args)
|
||||
(die who "all command arguments must be strings"))
|
||||
(let ([r (foreign-call "ikrt_process"
|
||||
(vector search? stdin-fd stdout-fd stderr-fd)
|
||||
(and env (map pair->env-utf8 env))
|
||||
(string->utf8 cmd)
|
||||
(map string->utf8 (cons cmd args)))])
|
||||
(cond ((fixnum? r)
|
||||
(io-error who cmd r))
|
||||
(else
|
||||
(unless blocking?
|
||||
(or stdin (set-fd-nonblocking (vector-ref r 1) who cmd))
|
||||
(or stdout (set-fd-nonblocking (vector-ref r 2) who cmd))
|
||||
(or stderr (set-fd-nonblocking (vector-ref r 3) who cmd)))
|
||||
(values
|
||||
(vector-ref r 0) ; pid
|
||||
(and (not stdin)
|
||||
(fh->output-port (vector-ref r 1)
|
||||
cmd output-file-buffer-size #f #t
|
||||
'process))
|
||||
(and (not stdout)
|
||||
(fh->input-port (vector-ref r 2)
|
||||
cmd input-file-buffer-size #f #t
|
||||
'process))
|
||||
(and (not stderr)
|
||||
(fh->input-port (vector-ref r 3)
|
||||
cmd input-file-buffer-size #f #t
|
||||
'process))))))))
|
||||
|
||||
(define (process cmd . args)
|
||||
(define who 'process)
|
||||
(unless (string? cmd)
|
||||
(die who "command is not a string" cmd))
|
||||
(unless (andmap string? args)
|
||||
(die who "all arguments must be strings"))
|
||||
(let ([r (foreign-call "ikrt_process"
|
||||
(make-vector 4)
|
||||
(string->utf8 cmd)
|
||||
(map string->utf8 (cons cmd args)))])
|
||||
(if (fixnum? r)
|
||||
(io-error who cmd r)
|
||||
(values
|
||||
(vector-ref r 0) ; pid
|
||||
(fh->output-port (vector-ref r 1)
|
||||
cmd output-file-buffer-size #f #t
|
||||
'process)
|
||||
(fh->input-port (vector-ref r 2)
|
||||
cmd input-file-buffer-size #f #t
|
||||
'process)
|
||||
(fh->input-port (vector-ref r 3)
|
||||
cmd input-file-buffer-size #f #t
|
||||
'process)))))
|
||||
(spawn-process 'process #t #t #f #f #f #f cmd args))
|
||||
|
||||
(define (process* search? env stdin stdout stderr cmd . args)
|
||||
(spawn-process 'process* search? #t env stdin stdout stderr cmd args))
|
||||
|
||||
(define (process-nonblocking cmd . args)
|
||||
(define who 'process-nonblocking)
|
||||
(unless (string? cmd)
|
||||
(die who "command is not a string" cmd))
|
||||
(unless (andmap string? args)
|
||||
(die who "all arguments must be strings"))
|
||||
(let ([r (foreign-call "ikrt_process"
|
||||
(make-vector 4)
|
||||
(string->utf8 cmd)
|
||||
(map string->utf8 (cons cmd args)))])
|
||||
(if (fixnum? r)
|
||||
(io-error who cmd r)
|
||||
(begin
|
||||
(set-fd-nonblocking (vector-ref r 1) who cmd)
|
||||
(set-fd-nonblocking (vector-ref r 2) who cmd)
|
||||
(set-fd-nonblocking (vector-ref r 3) who cmd)
|
||||
(values
|
||||
(vector-ref r 0) ; pid
|
||||
(fh->output-port (vector-ref r 1)
|
||||
cmd output-file-buffer-size #f #t
|
||||
'process)
|
||||
(fh->input-port (vector-ref r 2)
|
||||
cmd input-file-buffer-size #f #t
|
||||
'process)
|
||||
(fh->input-port (vector-ref r 3)
|
||||
cmd input-file-buffer-size #f #t
|
||||
'process))))))
|
||||
|
||||
(spawn-process 'process-nonblocking #t #f #f #f #f cmd args))
|
||||
|
||||
(define (set-fd-nonblocking fd who id)
|
||||
(let ([rv (foreign-call "ikrt_make_fd_nonblocking" fd)])
|
||||
|
|
|
@ -1 +1 @@
|
|||
1851
|
||||
1852
|
||||
|
|
|
@ -421,6 +421,7 @@
|
|||
[pointer-value i]
|
||||
[system i]
|
||||
[process i]
|
||||
[process* i]
|
||||
[process-nonblocking i]
|
||||
[waitpid i]
|
||||
[wstatus-pid i]
|
||||
|
|
|
@ -52,40 +52,134 @@ list_to_vec(ikptr x){
|
|||
return vec;
|
||||
}
|
||||
|
||||
static int
|
||||
execvpe_(const char *cmd, char *const *argv, char *const *envp){
|
||||
char *path = NULL;
|
||||
const char *searchpath;
|
||||
const char *sep;
|
||||
size_t cmd_len;
|
||||
|
||||
if (cmd[0] == '/')
|
||||
execve(cmd, argv, envp);
|
||||
|
||||
searchpath = getenv("PATH");
|
||||
if (searchpath == NULL)
|
||||
searchpath = "/bin:/usr/bin";
|
||||
|
||||
cmd_len = strlen(cmd);
|
||||
|
||||
sep = NULL;
|
||||
do {
|
||||
size_t prefix_len, path_len;
|
||||
|
||||
sep = strchr(searchpath, ':');
|
||||
if (sep == NULL) {
|
||||
sep = searchpath + strlen(searchpath);
|
||||
}
|
||||
|
||||
prefix_len = (sep - searchpath);
|
||||
path_len = prefix_len + cmd_len + 2;
|
||||
path = realloc(path, path_len);
|
||||
if (path == NULL) {
|
||||
errno = ENOMEM;
|
||||
return -1;
|
||||
}
|
||||
memcpy(path, searchpath, prefix_len);
|
||||
if (prefix_len == 0 || searchpath[prefix_len - 1] == '/') {
|
||||
memcpy(path + prefix_len, cmd, cmd_len + 1);
|
||||
} else {
|
||||
path[prefix_len] = '/';
|
||||
memcpy(path + prefix_len + 1, cmd, cmd_len + 1);
|
||||
}
|
||||
|
||||
execve(path, argv, envp);
|
||||
switch (errno) {
|
||||
case E2BIG:
|
||||
case ENOEXEC:
|
||||
case ENOMEM:
|
||||
case ETXTBSY:
|
||||
break; /* these are treated as error, abort search */
|
||||
}
|
||||
|
||||
searchpath = sep + 1;
|
||||
} while (sep[0] != '\0');
|
||||
|
||||
if (path) free(path);
|
||||
|
||||
return -1;
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_process(ikptr rvec, ikptr cmd, ikptr argv /*, ikpcb* pcb */){
|
||||
ikrt_process(ikptr rvec, ikptr env, ikptr cmd, ikptr argv /*, ikpcb* pcb */){
|
||||
int infds[2];
|
||||
int outfds[2];
|
||||
int errfds[2];
|
||||
if(pipe(infds)) return ik_errno_to_code();
|
||||
if(pipe(outfds)) return ik_errno_to_code();
|
||||
if(pipe(errfds)) return ik_errno_to_code();
|
||||
int search_p = ref(rvec, off_vector_data+0*wordsize) != false_object;
|
||||
int stdin_fd = unfix(ref(rvec, off_vector_data+1*wordsize));
|
||||
int stdout_fd = unfix(ref(rvec, off_vector_data+2*wordsize));
|
||||
int stderr_fd = unfix(ref(rvec, off_vector_data+3*wordsize));
|
||||
|
||||
if(stdin_fd < 0 && pipe(infds)) return ik_errno_to_code();
|
||||
if(stdout_fd < 0 && pipe(outfds)) return ik_errno_to_code();
|
||||
if(stderr_fd < 0 && pipe(errfds)) return ik_errno_to_code();
|
||||
pid_t pid = fork();
|
||||
if(pid == 0){
|
||||
/* child */
|
||||
if(close(infds[1])) exit(1);
|
||||
if(close(outfds[0])) exit(1);
|
||||
if(close(errfds[0])) exit(1);
|
||||
if(close(0)) exit(1);
|
||||
if(dup(infds[0]) == -1) exit(1);
|
||||
if(close(1)) exit(1);
|
||||
if(dup(outfds[1]) == -1) exit(1);
|
||||
if(close(2)) exit(2);
|
||||
if(dup(errfds[1]) == -1) exit(1);
|
||||
execvp((char*)(long)(cmd+off_bytevector_data), list_to_vec(argv));
|
||||
if (stdin_fd < 0){
|
||||
if(close(infds[1])) exit(1);
|
||||
stdin_fd = infds[0];
|
||||
}
|
||||
if (stdout_fd < 0){
|
||||
if(close(outfds[0])) exit(1);
|
||||
stdout_fd = outfds[1];
|
||||
}
|
||||
if (stderr_fd < 0){
|
||||
if(close(errfds[0])) exit(1);
|
||||
stderr_fd = errfds[1];
|
||||
}
|
||||
if (stdin_fd != 0){
|
||||
if(close(0)) exit(1);
|
||||
if(dup(stdin_fd) == -1) exit(1);
|
||||
}
|
||||
if (stdout_fd != 1){
|
||||
if(close(1)) exit(1);
|
||||
if(dup(stdout_fd) == -1) exit(1);
|
||||
}
|
||||
if (stderr_fd != 2){
|
||||
if(close(2)) exit(2);
|
||||
if(dup(stderr_fd) == -1) exit(1);
|
||||
}
|
||||
char *cmd_str = (char*)(long)(cmd+off_bytevector_data);
|
||||
char **env_strs = env == false_object ? 0 : list_to_vec(env);
|
||||
char **argv_strs = list_to_vec(argv);
|
||||
if (env_strs && search_p)
|
||||
execvpe_(cmd_str, argv_strs, env_strs);
|
||||
else if (env_strs)
|
||||
execve(cmd_str, argv_strs, env_strs);
|
||||
else if (search_p)
|
||||
execvp(cmd_str, argv_strs);
|
||||
else
|
||||
execv(cmd_str, argv_strs);
|
||||
fprintf(stderr, "failed to exec %s: %s\n",
|
||||
(char*)(long)(cmd+off_bytevector_data),
|
||||
strerror(errno));
|
||||
exit(-1);
|
||||
} else if(pid > 0){
|
||||
/* parent */
|
||||
close(infds[0]); /* ignore errors */
|
||||
close(outfds[1]);
|
||||
close(errfds[1]);
|
||||
ref(rvec,off_vector_data+0*wordsize) = fix(pid);
|
||||
ref(rvec,off_vector_data+1*wordsize) = fix(infds[1]);
|
||||
ref(rvec,off_vector_data+2*wordsize) = fix(outfds[0]);
|
||||
ref(rvec,off_vector_data+3*wordsize) = fix(errfds[0]);
|
||||
|
||||
if (stdin_fd < 0) {
|
||||
close(infds[0]); /* ignore errors */
|
||||
ref(rvec,off_vector_data+1*wordsize) = fix(infds[1]);
|
||||
}
|
||||
if (stdout_fd < 0) {
|
||||
close(outfds[1]);
|
||||
ref(rvec,off_vector_data+2*wordsize) = fix(outfds[0]);
|
||||
}
|
||||
if (stderr_fd < 0) {
|
||||
close(errfds[1]);
|
||||
ref(rvec,off_vector_data+3*wordsize) = fix(errfds[0]);
|
||||
}
|
||||
return rvec;
|
||||
} else {
|
||||
return ik_errno_to_code();
|
||||
|
|
Loading…
Reference in New Issue