diff options
Diffstat (limited to 'pkg/vocl/exec.c')
| -rw-r--r-- | pkg/vocl/exec.c | 1400 |
1 files changed, 1400 insertions, 0 deletions
diff --git a/pkg/vocl/exec.c b/pkg/vocl/exec.c new file mode 100644 index 00000000..322a3cef --- /dev/null +++ b/pkg/vocl/exec.c @@ -0,0 +1,1400 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_xwhen +#include <iraf.h> + +#include "config.h" +#include "clmodes.h" +#include "mem.h" +#include "opcodes.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "grammar.h" +#include "proto.h" + + +/* + * EXEC -- Functions that prepare tasks for running, the actual runtime + * interpreter, and functions involved in wrapping up when a task dies. + */ + +extern int cldebug; +extern int cltrace; + +#define SZ_STARTUPMSG 4000 /* cmd sent to subprocess to run task */ +#define BINDIR "bin$" /* where installed executables go */ + +extern FILE *yyin; /* yyparse's input */ +extern int alldone; /* set when oneof pops firstask */ +extern int yeof; /* parser saw EOF */ +extern int gologout; /* user typed logout() */ +extern int loggingout; /* in the process of logging out */ +extern int currentline; /* current script line being executed */ +extern int in_iferr; /* currently in an iferr block */ + +extern ErrCom errcom; /* execution error recovery struct */ + + +long int run_level = 0; +int do_error = YES; +char *onerr_handler = NULL; + +char *findexe(); + + + +/* RUN -- Run the code beginning at pc until we run an EXEC instruction of + * something other than a builtin command or END instruction. + * The EXEC instruction means that a new task is being started and we should + * return to the parser in the main "parse/run" loop in main. If, however, + * the exec was for a builtin (or procedure, someday) then no parsing is to + * be done and we just continue on with the current code. + * Note that execing the bye builtin is not a special case since it does a + * restor() which resets the pc to the instruction immediately following the + * exec IN THE PARENT task and we continue on with it. + * Increment pc after each "fetch" cycle and before the "exec" cycle. + * If any if the instructions fail, they will call error(). this will do + * a longjmp(errenv,1), causing setjmp to return (in main) and an + * immediate retreat to the most recent terminaltask with unwind(). + */ +void +run (void) +{ + register struct codeentry *cp; + register int opcode; + char *task; + + if (cltrace) { + cp = coderef(pc); + currentline = cp->c_scriptln; + eprintf ("\t----- task %s - line %d (%s) -----\n", + currentask->t_ltp->lt_lname, + currentline, op2str(cp->c_opcode)); + } + if (cltrace > 1) eprintf ("start of run()\t\t\n"); + + do { + cp = coderef (pc); + opcode = cp->c_opcode; + + if (currentask->t_flags & T_SCRIPT) + currentline = cp->c_scriptln; + + currentask->t_callln = currentline; + + if (cltrace) + d_instr (stderr, "\t", pc); + if (cldebug) + eprintf("run: pc=%d, op=%s\n", pc, op2str(opcode), currentline); + + if (coderef(pc)->c_opcode == CALL) { + task = (char *)&(coderef(pc)->c_args); + + if (cltrace && run_level > 0) + eprintf ("%d: CALL %s\n", run_level, task); + + if (strncmp ("error", task, 5) != 0) + errcom.linenum = currentline; + + run_level++; + + } else if (coderef(pc)->c_opcode == END) + run_level--; + + pc += cp->c_length; + (*opcodetbl[opcode]) (&cp->c_args); + + } until ((opcode == EXEC && !(newtask->t_flags & T_BUILTIN)) || + opcode == END || alldone); + + if (cltrace > 1) eprintf ("end of run()\t\t\n"); +} + + +/* CALLNEWTASK -- Called from CALL instruction to push and setup a new task + * structure. If find a known ltask with given name create a new task on + * control stack, set up newtask and defaults for the pseudofiles. + * Pseudofiles may be effected by other instructions before it gets to exec. + * Make sure we have a pfile list; either try to read it if task is + * supposed to have a real one or manufacture the beginnings of one if it + * isn't and set PF_FAKE. New task runs with a copy of the pfile if it + * wasn't fake. Guard against making more than one copy. Also, don't dup + * the cl's params to maintain the meaning of "firstask". Things like mode, + * logfile and abbreviations should be global and permanent. + * Special case for package names essentially runs a cl but with a new curpack, + * the only real semantic intent of "running" a package. + * This lets a package name given as a command appear to change the current + * package and yet remain interactive. Since it really is a new task, state + * saving and restoring on error will work right and we also achieve an + * ability to have multiple package defn's in a script ltask. + * Any parameter references will refer to the cl's also. + */ +void +callnewtask (char *name) +{ + /* x1 and x2 are just place holders to call breakout(). + */ + char *x1, *pk, *t, *x2; + struct ltask *ltp; + int flags, ltflags; + + if (cldebug) + eprintf ("callnewtask: name=%s, currentask=%x\n", name, currentask); + + currentline = coderef(pc)->c_scriptln; + + /* Save current dictionary and stack pointers. They get restored when + * the new task dies normally and the current task is to continue. + * Save pc when get to the EXEC instruction so it continues from there. + */ + currentask->t_topos = topos; /* save these two just in case */ + currentask->t_basos = basos; /* something is left on the stk */ + currentask->t_topcs = topcs; /* save before adding newtask */ + currentask->t_topd = topd; /* save before adding pfile */ + currentask->t_curpack = curpack;/* save in case changing to a new one*/ + c_envmark (¤task->t_envp);/* save env stack pointer */ + currentask->t_pno = 0; /* set only if task defines pkg */ + currentask->t_callln = currentline; + + newtask = pushtask(); + flags = 0; + + /* Search for the command to run. A leading '$' signifies that + * execution is to be time but is not part of the name. Set ltp + * and newtask->t_pfp depending on whether we are running a task or + * a package. + */ + if (*name == '$') { + flags |= T_TIMEIT; + name++; + } + + breakout (name, &x1, &pk, &t, &x2); + ltp = cmdsrch (pk, t); + + if (ltp->lt_flags & LT_CL) { + /* Change curpack if LT_PACCL. (cmdsrch() set lt_pkp). Just + * changing packages; use cl's ltask and pfile. Push a new cl() + * on the control stack, with the T_PKGCL and T_CL flags set. + */ + if (ltp->lt_flags & LT_PACCL) { + flags |= T_PKGCL; + curpack = ltp->lt_pkp; + } else if (ltp->lt_flags & LT_CLEOF) + flags |= T_CLEOF; + + ltp = firstask->t_ltp; + newtask->t_pfp = firstask->t_pfp; + + /* Initialize the lexical analyzer (necessary to recognize BOL). + */ + lexinit(); + + } else { + if (ltp->lt_flags & LT_PFILE) { + register struct pfile *pfp; + + /* This task has a real pfile. read in if not already in + * core. Copy if not already one and not just cl. + */ + newtask->t_pfp = NULL; + if ((pfp = pfilefind (ltp)) == NULL) + pfp = pfileload (ltp); + if (!(pfp->pf_flags & PF_COPY) && ltp != firstask->t_ltp) + pfp = pfilecopy (pfp); + newtask->t_pfp = pfp; + + /* Also load any pset files associated with the main pfile. + * These are linked into a list with the main pfile at the + * head of the list, pointed to by the task descriptor. + */ + if (pfp->pf_flags & PF_PSETREF) { + register struct param *pp; + struct operand o; + char *pset; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if (!(pp->p_type & PT_PSET)) + continue; + o = pp->p_valo; + if (opundef(&o) || *(pset = o.o_val.v_s) == EOS) + pset = pp->p_name; + pfp = pfp->pf_npset = pfilecopy (pfilesrch (pset)); + pfp->pf_psetp = pp; + } + } + + } else { + /* This task does not have a real pfile so start a fake one. + */ + newtask->t_pfp = newpfile (ltp); + newtask->t_pfp->pf_flags = PF_FAKE; + } + } + + newtask->t_pfp->pf_n = 0; /* init number of command line args */ + newtask->t_ltp = ltp; + newtask->t_pid = -1; /* gets set if do a real exec */ + newtask->t_stdin = currentask->t_stdin; /* inherit files */ + newtask->t_stdout = currentask->t_stdout; + newtask->t_stderr = currentask->t_stderr; + newtask->t_stdgraph = currentask->t_stdgraph; + newtask->t_stdimage = currentask->t_stdimage; + newtask->t_stdplot = currentask->t_stdplot; + + /* Init i/o redirection for a foreign task. + */ + newtask->ft_in = newtask->ft_out = newtask->ft_err = NULL; + + /* Set up flags describing the kind of task we are about to run. the + * absence of any of these flags will imply a genuine executable task. + * the flags in t_flags are more of a convenience than anything since + * later tests could use the same tests used here. + */ + ltflags = ltp->lt_flags; + + if (ltflags & LT_PSET) { + flags = (T_SCRIPT|T_PSET); + } else if (ltflags & LT_SCRIPT) { + newtask->t_scriptln = 0; + flags = T_SCRIPT; + } else if (ltflags & LT_FOREIGN) { + flags = T_BUILTIN | T_FOREIGN; /* a type of builtin */ + } else if (ltflags & LT_BUILTIN) { + flags = T_BUILTIN; + } else if (ltflags & LT_CL) { + /* Or, not assign: preserve T_PKGCL and T_CLEOF flags if set. */ + flags |= T_CL; + } + + if (ltflags & LT_STDINB) + flags |= T_STDINB; + if (ltflags & LT_STDOUTB) + flags |= T_STDOUTB; + + newtask->t_flags = flags; +} + + +/* EXECNEWTASK -- Called from the EXEC instruction after all param and stdio + * processing for the new task is complete. Here we actually run the new task, + * either directly in the case of a builtin function, or as a new case for + * main()'s loop. Do not set newtask to NULL so that run() can tell what it + * exec'd. + */ +void +execnewtask (void) +{ + /* VMS C V2.1 cannot handle this (see below). + * register struct pfile *pfp; + */ + struct codeentry *cep; + static struct pfile *pfp; + + struct param *pp; + FILE *fopen(); + + if (newtask == NULL) + /* if this ever happens, i don't want to know about it. */ + return; + + currentask->t_pc = pc; /* instruction after EXEC */ + cep = coderef (pc); + currentline = cep->c_scriptln; + + + if (cldebug) + eprintf ("execnewtask: pc = %d (line %d)\n", pc, currentline); + + if (newtask->t_flags & T_BUILTIN) { + /* set yyin in case a builtin reads someday; none do now. + * unlink newtask's fake param file and reset top of dictionary + * to what it was before the fake param file was added; it is + * still there, however, for the builtin to use. this is done + * since some builtins (eg task) want to add things that are + * to stay on the dictionary and the tools all start at topd. + * the return is back to run(); it will continue since it will + * see that newtask was just a builtin. + * note that we do not reset pf_n, as with other fake pfiles, + * as this is the way builtins get their number of arguments + * (it's faster than building them a $nargs). + */ + yyin = newtask->t_in = currentask->t_in; /* inherit pipe */ + newtask->t_out = currentask->t_out; + newtask->t_modep = currentask->t_modep; /* inherit mode */ + + /* VMS C 2.1 Optimizer cannot handle this. + * parhead = dereference (reference (pfile, parhead)->pf_npf); + */ + pfp = reference (pfile, parhead); + parhead = dereference (pfp->pf_npf); + + topd = currentask->t_topd; + currentask = newtask; + newtask->t_flags |= T_RUNNING; + + if (cldebug) + eprintf ("execnewtask: calling new task@@%x\n", newtask); + if (cltrace) + eprintf ("\t----- exec %s %s : line %d -----\n", + (newtask->t_flags & T_FOREIGN) ? "foreign" : "builtin", + newtask->t_ltp->lt_lname, coderef(pc)->c_scriptln); + + (*newtask->t_ltp->lt_f)(); + oneof(); /* proceed as though this task saw eof */ + return; + } + + pfp = newtask->t_pfp; + + /* If the new task is a cl, we are not running in background and + * its t_in is stdin, it is interactive. Note that when a package + * is loaded by a script task rather than interactively by the user, + * the t_in of the cl() in the package script task will be reading + * from the calling script task rather than from the original stdin + * (the user terminal), hence is not interactive. If this task is + * flagged interactive, taskunwind() may elect to restart it on an + * error so save present state for restor(). + */ + if (newtask->t_flags & T_CL) { + if (cldebug) + eprintf ("execnewtask: new task is the CL\n"); + if (cltrace) + eprintf ("\t----- exec cl -----\n"); + + /* Call set_clio to set the command input and output streams + * t_in and t_out for a cl() or package_name() command. + */ + set_clio (newtask); + + /* This code is a temporary patch to allow packages to be + * loaded from within scripts regardless of whether there + * are enclosing brackets. If a CL statement is executed + * within a script which is itself called within another + * script, then we will do an implicit keep before the CL. + */ + if (topcs + 2*TASKSIZ <= STACKSIZ) + if ((strcmp (newtask->t_ltp->lt_lname, "cl") == 0) || + (strcmp (newtask->t_ltp->lt_lname, "clbye") == 0)) + if ((currentask->t_flags & T_SCRIPT) && + (prevtask->t_flags & T_SCRIPT)) + keep(prevtask); + + /* If newtask is cleof(), close the input stream of the current + * task (the task whose input contained the cleof), and reopen + * as the null file. + */ + if (newtask->t_flags & T_CLEOF) { + if (currentask->t_in != stdin) + fclose (currentask->t_in); + if (currentask != firstask) + currentask->t_in = fopen ("dev$null", "r"); + } + + if (!(firstask->t_flags & T_BATCH) && + (newtask->t_in == stdin) && (newtask->t_out == stdout)) { + newtask->t_flags |= T_INTERACTIVE; + newtask->t_topd = topd; + newtask->t_topos = topos; + newtask->t_topcs = topcs; + newtask->t_curpack = curpack; + } + } + + /* Standardize the pfile. + * Set (or create if necessary) `$nargs', number of command line args, + * based on pf_n which is set for each command line argument by + * posargset, et al. + * If this ltask had no paramfile and we built one up from the + * command line, then we need to add a `mode' param. If it did have + * a paramfile, then pfileload has already added it for us. + * Point t_modep to the mode param for newtask. + */ + pp = paramfind (pfp, "$nargs", 0, YES); + if (pp == NULL || (XINT)pp == ERR) { + char nabuf[FAKEPARAMLEN]; + sprintf (nabuf, "$nargs,i,h,%d\n", pfp->pf_n); + pp = addparam (pfp, nabuf, NULL); + pp->p_mode |= M_FAKE; /* never flush out $nargs */ + } else + pp->p_val.v_i = pfp->pf_n; + + if (pfp->pf_flags & PF_FAKE) { + newtask->t_modep = addparam (pfp, "mode,s,h,q\n", NULL); + /* pf_n will be used by paramsrch() to count positional arg + * matches; see it and param.h. + */ + pfp->pf_n = 0; + } else { + newtask->t_modep = paramfind (pfp, "mode", 0, YES); + } + + if (newtask->t_modep == NULL) + cl_error (E_IERR, "no mode param for task `%s'", + newtask->t_ltp->lt_lname); + + /* If task is being run in menu mode, call up eparam so that the user + * can edit/inspect the parameters. If eparam is exited with ctrl/c + * do not run the task or update the pfile. The parameter editor + * will make a copy of the task's pfile(s), edit it, and if necessary + * update the incore version created earlier by callnewtask(). + */ + if ((taskmode(newtask) & M_MENU) || (newtask->t_flags & T_PSET)) { + if (epset (newtask->t_ltp->lt_lname) == ERR) { + if (newtask->t_flags & T_PSET) + cl_error (E_UERR, "parameter file not updated"); + else + cl_error (E_UERR, "menu mode task execution aborted"); + } + } + + /* Set up bascode so new task has a good place to start building + * code. See how the pc is set up before each call to the parser in + * main() loop. + */ + newtask->t_bascode = topos + 1; + + /* Set up io paths. If the new task is cl(), it's command input + * and output streams are connected to those of the task which + * called currentask. If the currentask is the firstask, there + * was no caller (no prevtask), so we must watch out for that. + * In the case of a script, commands are read from the script. + * In the case of a process, commands are read from the process. + */ + if (newtask->t_flags & T_PSET) { + newtask->t_in = fopen ("dev$null", "r"); + newtask->t_out = newtask->t_stdout; + + } else if (newtask->t_flags & T_SCRIPT) { + if (cltrace) + eprintf ("\t----- exec script %s (%s) - line %d -----\n", + newtask->t_ltp->lt_lname, newtask->t_ltp->lt_pname, + coderef(pc)->c_scriptln); + + newtask->t_in = fopen (newtask->t_ltp->lt_pname, "r"); + if (newtask->t_in == NULL) + cl_error (E_UERR|E_P, "can not open script file `%s'", + newtask->t_ltp->lt_pname); + newtask->t_out = newtask->t_stdout; + + } else if (newtask->t_flags & T_CL) { + /* The command streams t_in and t_out have already been + * set up above by set_clio() in the test for T_INTERACTIVE. + */ + /* Do nothing */ + + } else { + char startup_msg[SZ_STARTUPMSG+1]; + int timeit; + + /* Connect to an executable process. + */ + mk_startupmsg (newtask, startup_msg, SZ_STARTUPMSG); + timeit = (newtask->t_flags & T_TIMEIT) != 0; + if (cltrace) + eprintf ("\t----- exec external task %s - line %d -----\n", + newtask->t_ltp->lt_lname, coderef(pc)->c_scriptln); + newtask->t_pid = pr_connect ( + findexe (newtask->t_ltp->lt_pkp, newtask->t_ltp->lt_pname), + startup_msg, + &newtask->t_in, &newtask->t_out, + newtask->t_stdin, newtask->t_stdout, newtask->t_stderr, + newtask->t_stdgraph, newtask->t_stdimage, newtask->t_stdplot, + timeit); + } + + yyin = newtask->t_in; /* set the input for the parser */ + + /* Tell parser what to expect. + */ + parse_state = PARSE_FREE; + if (newtask->t_flags & T_SCRIPT) { + proc_script = (newtask->t_flags & T_PSET) ? NO : procscript(yyin); + + if (proc_script) { + parse_state = PARSE_BODY; + /* Skip to the BEGIN statement */ + newtask->t_scriptln = skip_to (yyin, "begin"); + if (newtask->t_scriptln == ERR) + cl_error (E_UERR, "No BEGIN statement in procedure script"); + + /* Reset pointer here. + */ + proc_script = NO; + } + } + + /* Log a start message for script and executable tasks. + */ + if (keeplog() && log_trace()) + if (newtask->t_flags & T_SCRIPT || newtask->t_pid != -1) { + char logmsg[SZ_LINE]; + sprintf (logmsg, "Start (%s)", newtask->t_ltp->lt_pname); + putlog (newtask, logmsg); + } + + newtask->t_flags |= T_RUNNING; + currentask = newtask; /* continue as new the new task; at last. */ + + if (cldebug) + eprintf ("Returning from execnewtask.yyin, ct_in, nt_in:%d %d %d\n", + yyin, currentask->t_in, newtask->t_in); +} + + +/* MK_STARTUPMSG -- Format the command to be sent to the interpreter in the + * IRAF Main in the child to execute the indicated logical task. The format + * of this command is + * + * taskname redir_args paramset_args + * + * where "redir_args" are used to either inform the task that a stream has + * been redirected by the CL (file "$") or to actually redirect a stream, + * and where "paramset_args" are assignments of the form "param=value". + * For example, "4 > $" tells the task that its standard output (4 = integer + * value of STDOUT) has been redirected. Only parameters with static values, + * i.e., with predefined values that are not expected to change during task + * execution (no queries) may be passed on the command line. + */ +void +mk_startupmsg ( + struct task *tp, /* task being executed */ + char *cmd, /* receives formatted command */ + int maxch /* max chars out */ +) +{ + register char *ip, *op, *cp; + struct pfile *pfp; + struct operand o; + struct param *pp; + char redir[20]; + + /* Start with the task name. + * Task names which begin with an underscore are used to implement + * "invisible" commands which are not intended to be part of the + * user interface. The distinction between these and regular + * commands is restricted to the CL, hence the leading underscore + * is stripped from the task name sent to the process. + */ + ip = tp->t_ltp->lt_lname; + while (*ip == CH_INVIS) + ip++; + strcpy (cmd, ip); + + /* Add redirection information. We can omit the pseudofile stream + * codes for the standard input and output as the iraf main will + * assume those streams if no stream code is given, though we must + * be explicit for stderr and the graphics streams. + */ + if (tp->t_flags & (T_MYIN|T_MYOUT|T_MYERR)) { + if (tp->t_flags & T_MYIN) + strcat (cmd, " < $"); + if (tp->t_flags & T_MYOUT) + strcat (cmd, " > $"); + if (tp->t_flags & T_MYERR) { + sprintf (redir, " %d> $", STDERR); + strcat (cmd, redir); + } + } + if (tp->t_flags & (T_MYSTDGRAPH|T_MYSTDIMAGE|T_MYSTDPLOT)) { + if (tp->t_flags & T_MYSTDGRAPH) { + sprintf (redir, " %d> $", STDGRAPH); + strcat (cmd, redir); + } + if (tp->t_flags & T_MYSTDIMAGE) { + sprintf (redir, " %d> $", STDIMAGE); + strcat (cmd, redir); + } + if (tp->t_flags & T_MYSTDPLOT) { + sprintf (redir, " %d> $", STDPLOT); + strcat (cmd, redir); + } + } + + for (cp=cmd; *cp; cp++) + --maxch; + + /* Add parameter assignments for all non list-structured parameters + * whose access would not cause a query, i.e., those parameters which + * already have a legal value and which are either hidden or were set + * on the command line. Passing the values of these parameters on the + * command line speeds task startup by reducing the number of parameter + * requests that must be processed by handshaking over the IPC. + */ + for (pfp = tp->t_pfp; pfp; pfp = pfp->pf_npset) { + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + o = pp->p_valo; + + /* Do not cache parameters which have an undefined value or + * for which the value is indirect to another parameter. + * Also, array parameters can not be cached currently. + */ + if (o.o_type & OT_UNDEF) + continue; + if ((o.o_type & OT_BASIC) == OT_STRING && + (o.o_val.v_s[0] == PF_INDIRECT)) + continue; + + if (pp->p_type & PT_ARRAY) + continue; + + if (!(pp->p_type & PT_LIST) && !(effmode(pp) & M_QUERY)) { + char buf[SZ_LINE+1]; + char val[SZ_LINE+1]; + + /* First format the param=value string in buf. + */ + + /* Start with "param=" if main pfile, or "pset.param=" if + * pset-param pfile. + */ + if (pfp->pf_psetp != NULL) { + ip = pfp->pf_psetp->p_name; + for (op=buf; (*op = *ip++); op++) + ; + *op++ = '.'; + } else + op = buf; + + for (ip=pp->p_name; (*op = *ip++); op++) + ; + *op++ = '='; + + /* Add "value". If the parameter is string valued enclose + * the string in quotes and convert any newlines into \n. + */ + sprop (val, &pp->p_valo); + if ((pp->p_type & OT_BASIC) == OT_STRING) + *op++ = '"'; + + for (ip=val; (*op = *ip++); op++) + if (*op == '\n') { + *op++ = '\\'; + *op = 'n'; + } else if (*op == '"') { + *op++ = '\\'; + *op = '"'; + } + + if ((pp->p_type & OT_BASIC) == OT_STRING) + *op++ = '"'; + + *op = EOS; + + /* Now check to see if there is room in the output buffer. + * If not we can just quit, as the task will automatically + * query for any parameters not set on the command line. + * If there is room break the current line by appending \\n + * (an escaped newline) and append the new line. + */ + maxch -= (strlen(buf) + 2); + if (maxch <= 0) + break; + + *cp++ = '\\'; + *cp++ = '\n'; + + for (ip=buf; (*cp = *ip++); cp++) + ; + } + } + } + + /* Terminate the command line by appending an unescaped newline. + */ + *cp++ = '\n'; + *cp = EOS; + + if (cldebug) + eprintf ("CALL %s", cmd); +} + + +/* FINDEXE -- Search a set of standard places for an executable file to be + * run. Currently, we check first in the logical directory BIN for the + * "installed" version of the executable, and if that is not found, use + * the pathname given, which is the pathname specified in the TASK declaration. + */ +char * +findexe ( + struct package *pkg, /* package in which task resides */ + char *pkg_path /* pathname of exe file given in TASK statement */ +) +{ + static char bin_path[SZ_PATHNAME+1], loc_path[SZ_PATHNAME+1]; + char root[SZ_FNAME+1], root_path[SZ_PATHNAME+1]; + char bindir[SZ_FNAME+1], *ip = NULL, *arch = NULL; + char bin_root[SZ_PATHNAME+1]; + char *envget(); + + + memset (root, 0, SZ_FNAME); + memset (bindir, 0, SZ_FNAME); + memset (bin_path, 0, SZ_PATHNAME); + memset (loc_path, 0, SZ_PATHNAME); + memset (bin_root, 0, SZ_PATHNAME); + memset (root_path, 0, SZ_PATHNAME); + + c_fnroot (pkg_path, root, SZ_FNAME); + c_fpathname ((pkg ? pkg->pk_bin : BINDIR), root_path, SZ_PATHNAME); + sprintf (bin_path, "%s%s.e", pkg ? pkg->pk_bin : BINDIR, root); + sprintf (loc_path, "./%s.e", root); + arch = envget ("arch"); + + + if (c_access (bin_path, 0, 0) == YES) { + return (bin_path); + } else { + /* The binary wasn't found in the expected bin directory, but + * on certain platforms look for alternate binaries that may + * work. This supports backward compatability with older + * packages that may not have been upgraded to architecture + * conventions in this release but which may contain usable + * binaries (e.g. 32-bit 'linux' binaries on 64-bit systems + * or older 'redhat' binaries where the core arch is 'linux'). + */ + memset (bin_root, 0, SZ_PATHNAME); + strcpy (bin_root, root_path); + if ((ip = strstr (bin_root, arch))) + *ip = '\0'; + else { + int len = strlen (bin_root); + if (bin_root[len-1] == '/') + bin_root[len-1] = '\0'; + } + + if (strcmp (arch, ".linux64") == 0) { + /* On 64-bit Linux systems we can use either of the + * available 32-bit binaries if needed. In v2.15 and + * later, 'linux' is the preferred arch but look for + * 'redhat' in case it's a package that hasn't been + * updated. + */ + sprintf (bin_path, "%s.linux/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + sprintf (bin_path, "%s.redhat/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + } else if (strcmp (arch, ".linux") == 0) { + /* On 32-bit Linux systems, check for older 'redhat' binaries. + */ + sprintf (bin_path, "%s.redhat/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + } else if (strcmp (arch, ".macintel") == 0) { + /* On 64-bit Mac systems, check for older 32-bin binaries. + */ + sprintf (bin_path, "%s.macosx/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + } else if (strcmp (arch, ".macosx") == 0) { + /* On 32-bit Mac systems, check for older 'macintel' binaries. + */ + sprintf (bin_path, "%s.macintel/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + } + } + + if (c_access (pkg_path, 0, 0) == YES) + return (pkg_path); + else + return (loc_path); +} + + +/* SET_CLIO -- Set the command input and output for the new cl(). If the + * standard input or output has been redirected, use that, otherwise inherit + * the t_in, t_out of the task preceeding the most recent non-CL task that has + * the same t_in as the current task (this is not obvious, but permits packages + * to be called or loaded within scripts). In the case of a cl() type task + * used to change packages, change the current package and push a cl() on the + * control stack but continue reading from the current command stream. + */ +void +set_clio (register struct task *newtask) +{ + register struct task *tp; + + if ((newtask->t_stdin == currentask->t_stdin) && + (currentask->t_in != stdin)) { + newtask->t_in = NULL; + + if (newtask->t_flags & T_PKGCL) { /* package() */ + newtask->t_in = currentask->t_in; + tp = currentask; + } else { /* cl() */ + for (tp=currentask; tp != firstask; tp = next_task(tp)) + if (!(tp->t_flags & T_CL) && + (tp->t_in == currentask->t_in)) { + tp = next_task(tp); + newtask->t_in = tp->t_in; + break; + } + } + if (newtask->t_in == NULL) + cl_error (E_IERR, "Cannot find t_in for cl()"); + + } else { /* pk|cl < */ + tp = NULL; + newtask->t_in = newtask->t_stdin; + } + + if ((newtask->t_stdout == stdout) && (tp != NULL)) + newtask->t_out = tp->t_out; + else + newtask->t_out = newtask->t_stdout; /* pk|cl > */ +} + + +/* PPFIND -- Search the list of loaded psets for a task for the named + * parameter. If a taskname is given, search only the pset with that + * taskname, else search all the psets associated with the running task. + * This is called by the routines in opcodes.c to perform command line + * assignments to parameters. + */ +struct param * +ppfind ( + struct pfile *pfp, /* first pfile in chain */ + char *tn, /* psetname (taskname) or null */ + char *pn, /* parameter name */ + int pos, /* for paramfind */ + int abbrev /* for paramfind */ +) +{ + struct param *pp, *m_pp; + struct pfile *m_pfp = (struct pfile *) NULL; + int nchars; + + if (tn != NULL && *tn != EOS) { + /* Locate the named pset and search it. */ + for (nchars=strlen(tn), m_pp=NULL; pfp; pfp = pfp->pf_npset) + if ( (pp = pfp->pf_psetp) ) + if (strncmp (pp->p_name, tn, nchars) == 0) { + if (strlen (pp->p_name) == nchars) + return (paramfind (pfp, pn, pos, abbrev)); + else if (m_pp) + return ((struct param *)ERR); + else { + m_pp = pp; + m_pfp = pfp; + } + } + + /* Unique abbreviation for pset was given. */ + if (m_pp) + return (paramfind (m_pfp, pn, pos, abbrev)); + else + return (NULL); + + } else { + /* Search all psets. */ + for (; pfp; pfp = pfp->pf_npset) + if ((pp = paramfind (pfp, pn, pos, abbrev)) != NULL) + return (pp); + return (NULL); + } +} + + +/* PSETRELOAD -- Called when a pset parameter is assigned into by a command + * line argument. The previous value of the pset param will already have + * been used by callnewtask() to load a pset. We must replace the old pset + * by the new one. + */ +void +psetreload ( + struct pfile *main_pfp, /* main task pfile */ + struct param *psetp /* pset param */ +) +{ + struct pfile *o_pfp, *n_pfp, *prev_pfp; + struct pfile *next_pfp = (struct pfile *) NULL; + + if (cldebug) + eprintf ("psetreload, pset %s\n", psetp->p_name); + + /* Locate the old pfile in the list of psets off the main task pfile. + */ + prev_pfp = main_pfp; + for (o_pfp=prev_pfp->pf_npset; o_pfp; o_pfp = o_pfp->pf_npset) + if (o_pfp->pf_psetp == psetp) + break; + else + prev_pfp = o_pfp; + + if (o_pfp == NULL) + cl_error (E_IERR, "in psetreload: cannot find npset"); + else + next_pfp = o_pfp->pf_npset; + + /* Unlink the old pfile and its copy. This must be done before loading + * the new pfile, else pfilesrch will simply reference the old pfile. + */ + pfileunlink (o_pfp->pf_oldpfp); + pfileunlink (o_pfp); + + /* Load the new pfile. */ + n_pfp = pfilecopy (pfilesrch (psetp->p_name)); + + /* Link it into the pset list */ + prev_pfp->pf_npset = n_pfp; + n_pfp->pf_npset = next_pfp; + n_pfp->pf_psetp = o_pfp->pf_psetp; +} + + +/* IOFINISH -- Flush out and wrap up all pending io for given task. + * Called when the task is dying and it wants to close all files it opened. + * This includes a pipe if it used one, a file if it was a script and io + * redirections as indicated by the T_MYXXX flags. The T_MYXXX flags are + * set only when the redirections were done for this task, ie, they were + * not simply inherited. + * Just as a fail-safe measure, always check that a real stdio file is + * not being closed. + * Don't call error() because in trying to restor to an interactive task + * it might call us again and cause an inf. loop. + */ +void +iofinish (register struct task *tp) +{ + register FILE *fp; + int flags; + + flags = tp->t_flags; + + /* Make sure we do not close files more than once. + */ + if (flags & T_RUNNING) + tp->t_flags &= ~T_RUNNING; + else + return; + + if (cldebug) + eprintf ("flushing io for task `%s'\n", tp->t_ltp->lt_lname); + + if (flags & T_MYIN) { + fp = tp->t_stdin; + if (fp != stdin) + fclose (fp); + } + if (flags & T_MYOUT) { + fflush (fp = tp->t_stdout); + if (fp != stdout) + fclose (fp); + } + if (flags & T_MYERR) { + fflush (fp = tp->t_stderr); + if (fp != stderr) + fclose (fp); + } + + /* Close any redirected graphics output streams. + */ + if (flags & (T_MYSTDGRAPH|T_MYSTDIMAGE|T_MYSTDPLOT)) { + if (flags & T_MYSTDGRAPH) + if (tp->t_stdgraph != tp->t_stdimage && + tp->t_stdgraph != tp->t_stdplot) + fclose (tp->t_stdgraph); + if (flags & T_MYSTDIMAGE) + if (tp->t_stdimage != tp->t_stdplot) + fclose (tp->t_stdimage); + if (flags & T_MYSTDPLOT) + fclose (tp->t_stdplot); + } + + /* If task i/o is redirected to a subprocess send the done message. + */ + if (flags & T_IPCIO) + fputs (IPCDONEMSG, tp->t_out); + fflush (tp->t_out); + + /* Close files only for script task, not for a cl, a builtin, or + * a process. Do call disconnect if the task lives in a process. + */ + if (flags & T_SCRIPT) { + fp = tp->t_in; + if (fp != stdin) + fclose (fp); + } else if (flags & (T_CL|T_BUILTIN)) { + ; + } else if (tp->t_pid != -1) + pr_disconnect (tp->t_pid); + + /* Log a stop message for script and executable tasks. + */ + if (keeplog() && log_trace()) + if (tp->t_flags & T_SCRIPT || tp->t_pid != -1) + putlog (tp, "Stop"); +} + + +/* RESTOR -- Restor all global variables for the given task and insure the + * integrity of the dictionary and control stack. + * Go through the dictionary and properly disgard any packages, ltasks, + * pfiles, environments and params that may be above the new topd. + * Write out any pfiles that are not just working copies that have been + * updated before discarding them. + * Don't call error() because in trying to restor to an interactive task + * it might call us again and cause an inf. loop. Instead, issue fatal error + * which will kill the cl for good. This seems reasonable since we might + * as well die if we can't restor back to an interactive state. + * N.B. we assume that a pfile's params will either all lie above or all + * below tp->t_topd. If this can ever happen, must add a further check + * of each pfile below topd and lob off any params above topd. + * The way posargset, et al, and call/execnewtask are now, we are safe. + */ +void +restor (struct task *tp) +{ + memel *topdp; + register struct ltask *ltp; + register struct package *pkp; + register struct param *pp; + register struct pfile *pfp; + struct param *last_pp; + int n; + + if (cldebug) { + eprintf ("restoring task `%s', tp: %d\n", tp->t_ltp->lt_lname,tp); + eprintf (" topd %d/%d\n", topd, tp->t_topd); + } + + topd = tp->t_topd; + pc = tp->t_pc; + topos = tp->t_topos; + basos = tp->t_basos; + topcs = tp->t_topcs; + curpack = tp->t_curpack; + + yyin = tp->t_in; + parse_state = PARSE_FREE; + + topdp = daddr (topd); + + /* Set pachead to first package below new topd. Then lob off any ltasks + * all remaining packages might have above topd. It is sufficient to + * stop the ltask checks for a given package once find an ltask + * below topd since the dictionary always grows upward. + * (Recall that since new ltasks are always added at the top of the + * dictionary, and pkp->pk_ltp always points to the most recently + * added ltask, then the thread moves to lower and lower addrs.) + * Thus, work downward and throw out all ltasks until find one below + * the new topd. + */ + for (pkp = reference (package, pachead); pkp; pkp = pkp->pk_npk) + if ((memel)pkp < (memel)topdp) { + pachead = dereference (pkp); + break; + } + if (pkp == NULL) + cl_error (E_FERR, "package list broken"); + + for (; pkp; pkp = pkp->pk_npk) { + for (ltp = pkp->pk_ltp; ltp; ltp = ltp->lt_nlt) + if ((memel)ltp < (memel)topdp) { + pkp->pk_ltp = ltp; + break; + } + if ((memel)pkp->pk_ltp >= (memel)topdp) + /* All ltasks in this package were above topd */ + pkp->pk_ltp = NULL; + } + + /* Similarly for pfiles and their params; however, since new params + * are always added at the top of the dictionary and linked in at the + * END of the list (at pfp->pf_lastpp), the thread off pfp->pf_pp + * moves to higher and higher addrs. Thus, we work our way up and + * throw out all params above the new topd. Also, close off any open + * list files from discarded params along the way, if any. + * Also, see if any of the params were P_SET and set PF_UPDATE. + * This avoids having to set PF_UPDATE for each assignment when the + * is not always easily found. + * N.B. hope mode param that some t_modep is using is never disgarded.. + * Also, guard against writing out pfiles in background. + */ + for (pfp = reference (pfile, parhead); pfp; pfp = pfp->pf_npf) { + /* Lob off any pfiles above new topd. Go through their + * params, updating if necessary and closing any lists. + */ + if ((memel)pfp < (memel)topdp) { + parhead = dereference (pfp); + break; + } + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + /* Close if list file and enable flushing if P_SET. + */ + if (pp->p_type & PT_LIST) + closelist (pp); + if (pp->p_flags & P_SET) + pfp->pf_flags |= PF_UPDATE; + } + if (((pfp->pf_flags & (PF_UPDATE|PF_COPY)) == PF_UPDATE) && + !(firstask->t_flags & T_BATCH)) + pfileupdate (pfp); + } + + /* Discard any recently added parameters above topd, where the pfile + * itself is below topd. This happens when a new parameter is added + * to an existing incore pfile, e.g., in a declaration. + */ + for (; pfp; pfp = pfp->pf_npf) { + if ((memel)(pfp->pf_lastpp) < (memel)topdp) + continue; /* quick check */ + last_pp = NULL; + n = 0; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if ((memel)pp >= (memel)topdp) { + if (cldebug) + fprintf (stderr, "chop pfile for task %s at param %s\n", + pfp->pf_ltp->lt_lname, last_pp->p_name); + if (last_pp) + last_pp->p_np = NULL; + pfp->pf_lastpp = last_pp; + pfp->pf_n = n; + break; + } else { + last_pp = pp; + n++; + } + } + } + + /* Delete any SET environment statements processed since this task + * was spawned. If any redefs are uncovered the original values are + * reset in all connected subprocesses. + */ + if (tp->t_envp) + c_prenvfree (0, tp->t_envp); + + /* If the task being restored defined a package, dump all processes + * in the process cache spawned since the package was loaded. + */ + if (tp->t_pno) + pr_prunecache (tp->t_pno); +} + + +/* ONEOF -- "on eof" (not "one of"): + * The current task has issued eof, either directly or via the "bye" command. + * Flush out all pending io, copy working pfile back to original if have one, + * pop a state back to the previous state and restore its environment. + * Avoid calling effecmode() if called from a builtin task since builtins + * do not have the "mode" parameter. + * + * If currentask is the first cl or we are batch, then we are truely done. + * Return true to the caller (EXECUTE), causing a return to the main. + */ +void +oneof (void) +{ + register struct pfile *pfp; + register struct package *pkp; + register struct param *pp; + static int nerrs = 0; + int flags; + extern ErrCom errcom; + extern int err_clear; + + + if (cldebug) + eprintf ("received `%s' from `%s'\n", yeof ? "eof" : "bye", + currentask == firstask ? "root" : currentask->t_ltp->lt_lname); + + if (!(firstask->t_flags & T_BATCH)) + if (currentask == firstask && !gologout && !loggingout && + isatty (fileno (stdin)) && nerrs++ < 8) + cl_error (E_UERR, "use `logout' to log out of the CL"); + + flags = currentask->t_flags; + + /* Clear the error struct to indicate a successful run(). If + * the err_clear flag is not set .... + */ + if (err_clear) { + if ((do_error == YES || (do_error == NO && !errcom.errflag))) { + errcom.errcode = OK; + strcpy (errcom.errmsg, ""); + strcpy (errcom.task, currentask->t_ltp->lt_lname); + /*strcpy (errcom.task, "");*/ + + pp = paramfind (firstask->t_pfp, "$errno", 0, YES); + pp->p_val.v_i = errcom.errcode; + pp = paramfind (firstask->t_pfp, "$errmsg", 0, YES); + pp->p_val.v_s = errcom.errmsg; + pp = paramfind (firstask->t_pfp, "$errtask", 0, YES); + pp->p_val.v_s = errcom.task; + } + } + + + if (!(flags & (T_BUILTIN|T_CL|T_SCRIPT|T_BATCH))) + fflush (currentask->t_out); + iofinish (currentask); + + /* Copy back the main pfile and any pset-param files. If the task + * which has terminated is a package script task, fix up the pfile + * pointer in the package descriptor to point to the updated pset. + */ + if (currentask->t_ltp->lt_flags & LT_PFILE) { + pfcopyback (pfp = currentask->t_pfp); + if (currentask->t_ltp->lt_flags & LT_DEFPCK) + if ( (pkp = pacfind(currentask->t_ltp->lt_lname)) ) + if (pkp->pk_pfp == pfp) + pkp->pk_pfp = pfp->pf_oldpfp; + for (pfp = pfp->pf_npset; pfp != NULL; pfp = pfp->pf_npset) + pfcopyback (pfp); + } + + if (currentask == firstask) + alldone = 1; + else { + currentask = poptask(); + if (currentask->t_flags & T_BATCH) + alldone = 1; + } + + restor (currentask); /* restore environment */ +} + + +/* PRINTCALL -- Print the calling sequence for a task. Called by killtask() + * to print stack trace. + */ +void +printcall (FILE *fp, struct task *tp) +{ + register struct param *pp; + int notfirst = 0; + extern int unwind_level; + + + /* See whether we print a stack trace at all, and if so, whether + * we want the full trace. + */ + if (err_trace == NO || (err_full == NO && unwind_level > 0)) + return; + + /* Print the offending line. + */ + print_call_line (fp, tp->t_callln, tp->t_ltp->lt_pname, + tp->t_ltp->lt_flags); + + fprintf (fp, " called as: `%s (", tp->t_ltp->lt_lname); + + for (pp = tp->t_pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if (pp->p_flags & P_CLSET) { + if (notfirst) + fprintf (fp, ", "); + notfirst++; + if (!(tp->t_pfp->pf_flags & PF_FAKE) && !(pp->p_mode & M_FAKE)) + fprintf (fp, "%s=", pp->p_name); + + /* Use only low level routines to print the parameter value to + * avoid error recursion. In particular, parameter indirection + * is not resolved. + */ + if (!(pp->p_valo.o_type & OT_UNDEF)) + fprop (fp, &pp->p_valo); + else + fprintf (fp, "UNDEF"); + } + } + + fprintf (fp, ")'\n"); +} + + +/* PRINT_CALL_LINE -- Print the line of the file being called. + */ +void +print_call_line (FILE *out, int line, char *fname, int flags) +{ + register int i, len; + register FILE *fp; + char buf[SZ_LINE+1]; + extern int unwind_level; + + + len = strlen (fname); + if (strncmp (".cl", &fname[len-3], 3) == 0) { + + fp = fopen (fname, "r"); /* open the script */ + for (i=0; i < line; i++) { /* skip to line */ + if (fgets (buf, SZ_LINE, fp) == (char *)NULL) { + fclose (fp); + return; + } + } + + /* Skip leading whitespace and string trailing newline. */ + len = strlen (buf); + buf[len-1] = '\0'; + for (i=0; buf[i] == ' ' || buf[i] == '\t'; i++) + ; + + fprintf (out, " \"%.68s", &buf[i]); + if (strlen (&buf[i]) > 68) + fprintf (out, " ..."); + + if (flags & LT_INVIS) + fprintf (out, "\"\n line %d: %s (hidden task)\n", + line, fname); + else + fprintf (out, "\"\n line %d: %s\n", line, fname); + + fclose (fp); + } + + unwind_level++; +} + + +/* KILLTASK -- Abort the currently executing task. Only call this when a task + * is to be killed spontaneously, as from interrupt, not when it is just dying + * due to a "bye" or eof. + * Close all pipes and pseudofiles, being careful not to close any that + * are real stdio files. + * Note that our function is to kill an external task, not the process in which + * it resides. The process is left running in the cache in case it is needed + * again. + */ +void +killtask (register struct task *tp) +{ + char buf[128]; + + /* Print stack trace, with arguments. + if (!(tp->t_ltp->lt_flags<_INVIS) && !(firstask->t_flags&T_BATCH) && + !(strcmp (tp->t_ltp->lt_lname, "error") == 0)) + */ + if (!(firstask->t_flags&T_BATCH)) + printcall (currentask->t_stderr, tp); + + /* If task is running in a subprocess, interrupt it and read the ERROR + * message. Not certain there isn't some case where this could cause + * deadlock, but it does not seem so. Interrupts are disabled during + * process startup. If task issues ERROR then it is popped before + * we are called, without issuing the signal. + */ + if (tp->t_pid != -1) { + fflush (tp->t_out); + c_prsignal (tp->t_pid, X_INT); + fgets (buf, 128, tp->t_in); + } + + iofinish (tp); +} |