conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

applied patch from andreas rottmann for providing "process*" which 

is the kitchen sink of subprocess creation.
This commit is contained in:
Abdulaziz Ghuloum 2009-09-02 22:47:57 +03:00
parent f33e304606
commit 4ce666c8d6
4 changed files with 182 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
scheme/ikarus.io.ss
View File

@ -65,6 +65,7 @@
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
@ -2320,59 +2321,74 @@
(define (process cmd . args)
(define who 'process)
(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 arguments must be strings"))
(die who "all command arguments must be strings"))
(let ([r (foreign-call "ikrt_process"
(make-vector 4)
(vector search? stdin-fd stdout-fd stderr-fd)
(and env (map pair->env-utf8 env))
(string->utf8 cmd)
(map string->utf8 (cons cmd args)))])
(if (fixnum? r)
(io-error who cmd r)
(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)
'process))
(and (not stdout)
(fh->input-port (vector-ref r 2)
cmd input-file-buffer-size #f #t
'process)
'process))
(and (not stderr)
(fh->input-port (vector-ref r 3)
cmd input-file-buffer-size #f #t
'process)))))
'process))))))))
(define (process cmd . args)
(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)])

2
scheme/last-revision
View File

@ -1 +1 @@
1851
1852

1
scheme/makefile.ss
View File

@ -421,6 +421,7 @@
[pointer-value i]
[system i]
[process i]
[process* i]
[process-nonblocking i]
[waitpid i]
[wstatus-pid i]

116
src/ikarus-process.c
View File

@ -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 (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(infds[0]) == -1) exit(1);
if(dup(stdin_fd) == -1) exit(1);
}
if (stdout_fd != 1){
if(close(1)) exit(1);
if(dup(outfds[1]) == -1) exit(1);
if(dup(stdout_fd) == -1) exit(1);
}
if (stderr_fd != 2){
if(close(2)) exit(2);
if(dup(errfds[1]) == -1) exit(1);
execvp((char*)(long)(cmd+off_bytevector_data), list_to_vec(argv));
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);
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();