conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Extensions/process.c

636 lines
17 KiB
C
Raw Blame History

/******************************************************************************
*
* Process extended type definition
*
******************************************************************************/
#include "stk.h"
#include <fcntl.h>
#include <errno.h>
#include <sys/param.h>
#include <sys/wait.h>
#include <sys/stat.h>
#include <unistd.h>
#include <signal.h>
static int tc_process; /* Process signature */
/*
* Data
*/
#define MAX_PROC_NUM 40 /* (simultaneous processes) enough? */
struct process_info {
int pid; /* Process id */
int index; /* index of process in the table of processes */
SCM stream[3]; /* Redirections for stdin stdout and stderr */
int exited; /* Process is terminated */
int exit_status; /* Exit status of the processus */
};
#define PROCESS(x) ((struct process_info *)((x)->storage_as.extension.data))
#define LPROCESS(x) ((x)->storage_as.extension.data)
#define PROCESSP(x) (TYPEP ((x), tc_process))
#define NPROCESSP(x) (NTYPEP ((x), tc_process))
#define PROCPID(x) (PROCESS(x)->pid)
static SCM proc_arr[MAX_PROC_NUM]; /* for registering processes */
static char *stdStreams[3] = {
"input",
"output",
"error",
};
static char key_inp[] = ":input";
static char key_out[] = ":output";
static char key_err[] = ":error";
static char key_wit[] = ":wait";
static char key_hst[] = ":host";
#if defined(SIGCHLD) && !defined(HPUX)
# define USE_SIGCHLD 1 /* What's the problem with HP? */
#endif
#ifdef USE_SIGCHLD
#define PURGE_PROCESS_TABLE() /* Nothing to do */
#else
#define PURGE_PROCESS_TABLE() process_terminate_handler(0) /* Simulate a SIGCHLD */
#endif
/******************************************************************************/
static void init_proc_table(void)
{
int i;
for(i = 0; i<MAX_PROC_NUM; i++) proc_arr[i] = Ntruth;
}
static int find_process(SCM prc)
{
int i;
for(i = 0; i<MAX_PROC_NUM; i++)
if(prc==proc_arr[i]) return i;
return (-1);
}
static int internal_process_alivep(SCM process)
{
int info, res;
if (PROCESS(process)->exited)
return FALSE;
else {
/* Use waitpid to gain the info. */
res = waitpid(PROCPID(process), &info, WNOHANG);
if (res == 0)
/* process is still running */
return TRUE;
else
if (res == PROCPID(process)) {
/* process has terminated and we must save this information */
PROCESS(process)->exited = TRUE;
PROCESS(process)->exit_status = info;
return FALSE;
}
else {
/* might not have found process because we've already waited for it */
/* if so, then status has already been updated */
return FALSE;
}
}
}
static void process_terminate_handler(int sig) /* called when a child dies */
{
register int i;
SCM proc;
#if defined(USE_SIGCHLD) && !defined(HAVE_SIGACTION)
static int in_handler = 0;
signal(SIGCHLD, process_terminate_handler); /* Necessary on System V */
if (in_handler++) /* Execution is re-entrant */ return;
do {
#endif
/* Find the process which is terminated
* Note that this loop can find:
* - nobody: if the process has been destroyed by GC
* - 1 process: This is the normal case
* - more than one process: This can arise when:
* - we use signal rather than sigaction
* - we don't have SIGCHLD and this function is called by
* PURGE_PROCESS_TABLE
* Sometimes I think that life is a little bit complicated....
*/
for(i = 0; i<MAX_PROC_NUM; i++) {
proc = proc_arr[i];
if (PROCESSP(proc) && !internal_process_alivep(proc))
/* This process has exited. We can delete it from the table */
proc_arr[i] = Ntruth;
}
#if defined(USE_SIGCHLD) && !defined(HAVE_SIGACTION)
/* Since we can be called recursively, we have perhaps forgot to delete
* some dead process from the table. So, we have perhaps to scan
* the process array another time
*/
} while (--in_handler > 0);
#endif
}
static SCM make_process(void)
{
int i;
SCM z;
PURGE_PROCESS_TABLE();
/* find slot */
i = find_process(Ntruth);
if (i < 0){
STk_gc_for_newcell();
i = find_process(Ntruth);
}
if (i < 0) Err("Too many processes", NIL);
NEWCELL(z, tc_process);
LPROCESS(z) = (struct process_info *) must_malloc(sizeof(struct process_info));
PROCESS(z)->index = i;
PROCESS(z)->stream[0] = PROCESS(z)->stream[1] = PROCESS(z)->stream[2] = Ntruth;
PROCESS(z)->exit_status = PROCESS(z)->exited = 0;
/* Enter this process in the process table */
proc_arr[i] = z;
return z;
}
static void cannot_run(int pipes[3][2], char **argv, char *msg, SCM obj)
{
int i;
for (i=0; i<3; i++) {
if (pipes[i][0] != -1) close(pipes[i][0]);
if (pipes[i][1] != -1) close(pipes[i][1]);
}
free(argv);
STk_procedure_error("run-process", msg, obj);
}
static PRIMITIVE run_process(SCM l, int len)
{
SCM proc, tmp, redirection[3];
int pid, i, argc, waiting, pipes[3][2];
struct process_info *info;
char host[100], msg[256], **argv, **argv_start;
/* Initializations */
argc = 0; waiting = FALSE;
argv_start = (char**)must_malloc((len+3)*sizeof(char *)); /* 3= NULL+rsh+host */
argv = argv_start + 2;
for (i = 0; i < 3; i++) {
redirection[i] = NIL;
pipes[i][0] = pipes[i][1] = -1;
}
/* Checking arguments and creating UNIX-style arguments list */
for ( ; NNULLP(l); l = CDR(l)) {
tmp = CAR(l);
if (KEYWORDP(tmp)) {
/* Manage :input, :output, :error and :no-wait keywords */
int i = -1;
if (NCONSP(CDR(l)))
cannot_run(pipes, argv_start,"no argument after keyword", tmp);
l = CDR(l); /* Go to next item */
if (STk_eqv(tmp, STk_makekey(key_hst)) == Truth) {
/* :host keyword processing */
if (NSTRINGP(CAR(l)))
cannot_run(pipes, argv_start, "string expected. It was", CAR(l));
strcpy(host, CHARS(CAR(l))); /* to avoid GC problems */
/* Shift argv to point the start of allocated zone. This avoid a copy
* of arguments already processed.
*/
argv = argv_start;
argc += 2;
argv[0] = "rsh";
argv[1] = host;
}
else {
if (STk_eqv(tmp, STk_makekey(key_wit)) == Truth) {
/* :wait option processing */
if (NBOOLEANP(CAR(l)))
cannot_run(pipes, argv_start, "boolean expected. It was", CAR(l));
waiting = (CAR(l) == Truth);
}
else {
/* :input, :output, :error option processing */
if (STk_eqv(tmp, STk_makekey(key_inp)) == Truth) i = 0; else
if (STk_eqv(tmp, STk_makekey(key_out)) == Truth) i = 1; else
if (STk_eqv(tmp, STk_makekey(key_err)) == Truth) i = 2;
if (i < 0) cannot_run(pipes, argv_start, "bad keyword", tmp);
redirection[i] = CAR(l);
if (STRINGP(redirection[i])) {
/* Redirection in a file */
int j;
/*
* First try to look if this redirecttion has not already done
* This can arise by doing
* :output "out" :error "out" which is correct
* :output "out" :input "out" which is obviously incorrect
*/
for (j = 0; j < 3; j++) {
if (j != i && STRINGP(redirection[j])) {
struct stat stat_i, stat_j;
/* Do a stat to see if we try to open the same file 2 times */
/* if stat == -1 this is probably because file doen't exist yet */
if (stat(CHARS(redirection[i]), &stat_i) == -1) continue;
if (stat(CHARS(redirection[j]), &stat_j) == -1) continue;
if (stat_i.st_dev==stat_j.st_dev && stat_i.st_ino==stat_j.st_ino) {
/* Same file was cited 2 times */
if (i == 0 || j == 0) {
sprintf(msg, "read/write on the same file: %s",
CHARS(redirection[i]));
cannot_run(pipes, argv_start, msg, NIL);
}
/* assert(i == 1 && j == 2 || i == 2 && j == 1); */
pipes[i][0] = dup(pipes[j][0]);
break;
}
}
}
/*
* Two cases are possible here:
* - We have stdout and stderr redirected on the same file (j != 3)
* - We have not found current file in list of redirections (j == 3)
*/
if (j == 3) {
pipes[i][0] = open(CHARS(redirection[i]),
i==0 ? O_RDONLY:(O_WRONLY|O_CREAT|O_TRUNC),
0666);
}
if(pipes[i][0] < 0) {
sprintf(msg, "can't redirect standard %s to file %s",
stdStreams[i], CHARS(redirection[i]));
cannot_run(pipes, argv_start, msg, NIL);
}
}
else
if (KEYWORDP(redirection[i])) {
/* Redirection in a pipe */
if (pipe(pipes[i]) < 0) {
sprintf(msg, "can't create stream for standard %s",
stdStreams[i]);
cannot_run(pipes, argv_start, msg, NIL);
}
}
}
}
}
else {
/* Normal arg. Put it in argv */
if (NSTRINGP(tmp))
cannot_run(pipes, argv_start, "bad string", tmp);
argv[argc++] = CHARS(tmp);
}
}
argv[argc] = NULL;
if (argc == 0) cannot_run(pipes, argv_start,"no command given", NIL);
/* Build a process object */
proc = make_process();
info = PROCESS(proc);
/* Fork another process */
switch (pid = fork()) {
case -1: cannot_run(pipes,argv,"can't create child process", NIL);
case 0: /* Child */
for(i = 0; i < 3; i++) {
if (STRINGP(redirection[i])) {
/* Redirection in a file */
close(i);
dup(pipes[i][0]);
close(pipes[i][0]);
}
else
if (KEYWORDP(redirection[i])) {
/* Redirection in a pipe */
close(i);
dup(pipes[i][i==0? 0 : 1]);
close(pipes[i][0]);
close(pipes[i][1]);
}
}
for(i = 3; i < NOFILE; i++) close(i);
/* And then, EXEC'ing... */
execvp(*argv, argv);
/* Cannot exec if we are here */
Fprintf(STk_curr_eport, "**** Cannot exec %s!\n", *argv);
exit(1);
default: /* Father */
info->pid = pid;
for(i = 0; i < 3; i++) {
if (STRINGP(redirection[i]))
/* Redirection in a file */
close(pipes[i][0]);
else
if (KEYWORDP(redirection[i])) {
/* Redirection in a pipe */
close(pipes[i][i == 0 ? 0 : 1]);
/* Make a new file descriptor to access the pipe */
{
char *s;
FILE *f;
f = (i == 0)? fdopen(pipes[i][1],"w"):fdopen(pipes[i][0],"r");
if (f == NULL)
cannot_run(pipes, argv, "cannot fdopen", proc);
sprintf(msg, "pipe-%s-%d", stdStreams[i], pid);
s = (char *) must_malloc(strlen(msg)+1);
strcpy(s, msg);
info->stream[i] = STk_Cfile2port(s,
f,
(i==0) ? tc_oport : tc_iport,
0);
}
}
}
if (waiting) {
waitpid(pid, &(info->exit_status), 0);
info->exited = TRUE;
}
}
free(argv_start);
return proc;
}
static PRIMITIVE processp(SCM process)
{
return PROCESSP(process) ? Truth : Ntruth;
}
static PRIMITIVE process_alivep(SCM process)
{
if (NPROCESSP(process)) Err("process-alive?: bad process", process);
return internal_process_alivep(process)? Truth: Ntruth;
}
static PRIMITIVE process_pid(SCM process)
{
if (NPROCESSP(process)) Err("process-pid: bad process", process);
return STk_makeinteger(PROCPID(process));
}
static PRIMITIVE process_list(void)
{
int i;
SCM lst = NIL;
PURGE_PROCESS_TABLE();
for(i = 0; i < MAX_PROC_NUM; i++)
if (proc_arr[i] != Ntruth)
lst = Cons(proc_arr[i], lst);
return lst;
}
static PRIMITIVE process_input(SCM process)
{
if(NPROCESSP(process)) Err("process-input: bad process", process);
return PROCESS(process)->stream[0];
}
static PRIMITIVE process_output(SCM process)
{
if(NPROCESSP(process)) Err("process-output: bad process", process);
return PROCESS(process)->stream[1];
}
static PRIMITIVE process_error(SCM process)
{
if(NPROCESSP(process)) Err("process-error: bad process", process);
return PROCESS(process)->stream[2];
}
static PRIMITIVE process_wait(SCM process)
{
PURGE_PROCESS_TABLE();
if(NPROCESSP(process)) Err("process-wait: bad process", process);
if (PROCESS(process)->exited) return Ntruth;
else {
int info, res;
res = waitpid(PROCPID(process), &info, 0);
if (res == PROCPID(process)) {
PROCESS(process)->exit_status = info;
PROCESS(process)->exited = TRUE;
return Truth;
}
else
return Ntruth;
}
}
static PRIMITIVE process_xstatus(SCM process)
{
int info, n, res;
PURGE_PROCESS_TABLE();
if (NPROCESSP(process)) Err("process-exit-status: bad process", process);
if (PROCESS(process)->exited)
n = WEXITSTATUS(PROCESS(process)->exit_status);
else {
res = waitpid(PROCPID(process), &info, WNOHANG);
if (res == 0) {
/* Process is still running */
return Ntruth;
}
else if (res == PROCPID(process)) {
/* Process is now terminated */
PROCESS(process)->exited = TRUE;
PROCESS(process)->exit_status = info;
n = WEXITSTATUS(info);
}
else
return Ntruth;
}
return STk_makeinteger((long) n);
}
static PRIMITIVE process_send_signal(SCM process, SCM signal)
{
ENTER_PRIMITIVE("process-send-signal");
PURGE_PROCESS_TABLE();
if (NPROCESSP(process)) Serror("bad process", process);
if (NINTEGERP(signal)) Serror("bad integer", signal);
kill(PROCPID(process), STk_integer_value(signal));
return UNDEFINED;
}
static PRIMITIVE process_kill(SCM process)
{
if (NPROCESSP(process)) Err("process-kill: bad process", process);
return process_send_signal(process, STk_makeinteger(SIGTERM));
}
#ifdef SIGSTOP
static PRIMITIVE process_stop(SCM process)
{
if (NPROCESSP(process)) Err("process-stop: bad process", process);
return process_send_signal(process, STk_makeinteger(SIGSTOP));
}
#endif
#ifdef SIGCONT
static PRIMITIVE process_continue(SCM process)
{
if (NPROCESSP(process)) Err("process-continue: bad process", process);
return process_send_signal(process, STk_makeinteger(SIGCONT));
}
#endif
/******************************************************************************/
static void mark_process(SCM process)
{
struct process_info *info;
info = PROCESS(process);
STk_gc_mark(info->stream[0]);
STk_gc_mark(info->stream[1]);
STk_gc_mark(info->stream[2]);
}
static void free_process(SCM process)
{
int i;
/* Kill process; close its associated file, delete it from the process table
* and free the memory it uses
*/
process_kill(process);
for(i = 0; i < 3; i++) {
SCM p = PROCESS(process)->stream[i];
if (IPORTP(p) || OPORTP(p)) STk_close_port(p);
}
proc_arr[PROCESS(process)->index] = Ntruth;
free(PROCESS(process));
}
static void process_display(SCM obj, SCM port, int mode)
{
sprintf(STk_tkbuffer, "#<process PID=%d>", PROCPID(obj));
Puts(STk_tkbuffer, port);
}
static STk_extended_scheme_type process_type = {
"process", /* name */
0, /* is_procp */
mark_process, /* gc_mark_fct */
free_process, /* gc_sweep_fct */
NULL, /* apply_fct */
process_display /* display_fct */
};
/******************************************************************************/
PRIMITIVE STk_init_process(void)
{
tc_process = STk_add_new_type(&process_type);
init_proc_table();
#ifdef USE_SIGCHLD
/*
* On systems which support SIGCHLD, the processes table is cleaned up
* as soon as a process terminate. On other systems this is done from time
* to time to avoid filling the table too fast
*/
# ifdef HAVE_SIGACTION
{
/* Use the secure Posix.1 way */
struct sigaction sigact;
sigemptyset(&(sigact.sa_mask));
sigact.sa_handler = process_terminate_handler;
sigact.sa_flags = SA_NOCLDSTOP; /* Ignore SIGCHLD generated by SIGSTOP */
# ifdef SA_RESTART
/* Thanks to Harvey J. Stein <hjstein@MATH.HUJI.AC.IL> for the fix */
sigact.sa_flags |= SA_RESTART;
# endif
sigaction(SIGCHLD, &sigact, NULL);
}
# else
/* Use "classical" way. (Only Solaris 2 seems to have problem with it */
signal(SIGCHLD, process_terminate_handler);
# endif
#endif
STk_add_new_primitive("run-process", tc_lsubr, run_process);
STk_add_new_primitive("process?", tc_subr_1, processp);
STk_add_new_primitive("process-alive?", tc_subr_1, process_alivep);
STk_add_new_primitive("process-pid", tc_subr_1, process_pid);
STk_add_new_primitive("process-list", tc_subr_0, process_list);
STk_add_new_primitive("process-input", tc_subr_1, process_input);
STk_add_new_primitive("process-output", tc_subr_1, process_output);
STk_add_new_primitive("process-error", tc_subr_1, process_error);
STk_add_new_primitive("process-wait", tc_subr_1, process_wait);
STk_add_new_primitive("process-exit-status", tc_subr_1, process_xstatus);
STk_add_new_primitive("process-send-signal", tc_subr_2, process_send_signal);
STk_add_new_primitive("process-kill", tc_subr_1, process_kill);
#ifdef SIGSTOP
STk_add_new_primitive("process-stop", tc_subr_1, process_stop);
#endif
#ifdef SIGCONT
STk_add_new_primitive("process-continue", tc_subr_1, process_continue);
#endif
return UNDEFINED;
}
Reference in New Issue View Git Blame Copy Permalink