/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127
+#define MAX_DCL_LINE_LENGTH 255
+
static char *__mystrtolower(char *str)
{
if (str) for (; *str; ++str) *str= tolower(*str);
/* munching */
static int no_translate_barewords;
-/* Temp for subprocess commands */
-static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
-
#ifndef RTL_USES_UTC
static int tz_updated = 1;
#endif
struct pipe_details
{
pInfo next;
- PerlIO *fp; /* stdio file pointer to pipe mailbox */
+ PerlIO *fp; /* file pointer to pipe mailbox */
+ int useFILE; /* using stdio, not perlio */
int pid; /* PID of subprocess */
int mode; /* == 'r' if pipe open for reading */
int done; /* subprocess has completed */
+ int waiting; /* waiting for completion/closure */
int closing; /* my_pclose is closing this pipe */
unsigned long completion; /* termination status of subprocess */
pPipe in; /* pipe in to sub */
static pInfo open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");
+#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
+
+
static unsigned long int
pipe_exit_routine(pTHX)
{
pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
- int sts, did_stuff, need_eof;
+ int sts, did_stuff, need_eof, j;
+
+ /*
+ flush any pending i/o
+ */
+ info = open_pipes;
+ while (info) {
+ if (info->fp) {
+ if (!info->useFILE)
+ PerlIO_flush(info->fp); /* first, flush data */
+ else
+ fflush((FILE *)info->fp);
+ }
+ info = info->next;
+ }
/*
- first we try sending an EOF...ignore if doesn't work, make sure we
+ next we try sending an EOF...ignore if doesn't work, make sure we
don't hang
*/
did_stuff = 0;
if (info->in && !info->in->shut_on_empty) {
_ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
0, 0, 0, 0, 0, 0));
+ info->waiting = 1;
did_stuff = 1;
}
_ckvmssts(sys$setast(1));
info = info->next;
}
- if (did_stuff) sleep(1); /* wait for EOF to have an effect */
+
+ /* wait for EOF to have effect, up to ~ 30 sec [default] */
+
+ for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
+ int nwait = 0;
+
+ info = open_pipes;
+ while (info) {
+ _ckvmssts(sys$setast(0));
+ if (info->waiting && info->done)
+ info->waiting = 0;
+ nwait += info->waiting;
+ _ckvmssts(sys$setast(1));
+ info = info->next;
+ }
+ if (!nwait) break;
+ sleep(1);
+ }
did_stuff = 0;
info = open_pipes;
_ckvmssts(sys$setast(1));
info = info->next;
}
- if (did_stuff) sleep(1); /* wait for them to respond */
+
+ /* again, wait for effect */
+
+ for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
+ int nwait = 0;
+
+ info = open_pipes;
+ while (info) {
+ _ckvmssts(sys$setast(0));
+ if (info->waiting && info->done)
+ info->waiting = 0;
+ nwait += info->waiting;
+ _ckvmssts(sys$setast(1));
+ info = info->next;
+ }
+ if (!nwait) break;
+ sleep(1);
+ }
info = open_pipes;
while (info) {
}
-static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
+static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
static void vms_execfree(pTHX);
/*
free_pipelocs(pTHX_ void *head)
{
pPLOC p, pnext;
+ pPLOC *pHead = (pPLOC *)head;
- p = (pPLOC) head;
+ p = *pHead;
while (p) {
pnext = p->next;
Safefree(p);
p = pnext;
}
+ *pHead = 0;
}
static void
{
int i;
pPLOC p;
- AV *av = GvAVn(PL_incgv);
+ AV *av = 0;
SV *dirsv;
GV *gv;
char *dir, *x;
char temp[NAM$C_MAXRSS+1];
STRLEN n_a;
+ if (head_PLOC)
+ free_pipelocs(&head_PLOC);
+
/* the . directory from @INC comes last */
New(1370,p,1,PLOC);
/* reverse order of @INC entries, skip "." since entered above */
- for (i = 0; i <= AvFILL(av); i++) {
+ if (PL_incgv) av = GvAVn(PL_incgv);
+
+ for (i = 0; av && i <= AvFILL(av); i++) {
dirsv = *av_fetch(av,i,TRUE);
if (SvROK(dirsv)) continue;
p->dir[NAM$C_MAXRSS] = '\0';
}
#endif
- Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
+ Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
}
static PerlIO *
-safe_popen(pTHX_ char *cmd, char *mode)
+safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
{
static int handler_set_up = FALSE;
unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
unsigned int table = LIB$K_CLI_GLOBAL_SYM;
- char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
+ int wait = 0;
+ char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
char in[512], out[512], err[512], mbx[512];
FILE *tpipe = 0;
char tfilebuf[NAM$C_MAXRSS+1];
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
- sts = setup_cmddsc(aTHX_ cmd,0);
+ sts = setup_cmddsc(aTHX_ cmd,0,0);
if (!(sts & 1)) {
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
set_errno(EVMSERR);
}
set_vaxc_errno(sts);
- if (ckWARN(WARN_PIPE)) {
+ if (*mode != 'n' && ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
}
+ *psts = sts;
return Nullfp;
}
New(1301,info,1,Info);
+ strcpy(mode,in_mode);
info->mode = *mode;
info->done = FALSE;
info->completion = 0;
info->in = 0;
info->out = 0;
info->err = 0;
+ info->fp = Nullfp;
+ info->useFILE = 0;
+ info->waiting = 0;
info->in_done = TRUE;
info->out_done = TRUE;
info->err_done = TRUE;
in[0] = out[0] = err[0] = '\0';
+ if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
+ info->useFILE = 1;
+ strcpy(p,p+1);
+ }
+ if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
+ wait = 1;
+ strcpy(p,p+1);
+ }
+
if (*mode == 'r') { /* piping from subroutine */
info->out = pipe_infromchild_setup(aTHX_ mbx,out);
info->out_done = FALSE;
info->out->info = info;
}
+ if (!info->useFILE) {
info->fp = PerlIO_open(mbx, mode);
+ } else {
+ info->fp = (PerlIO *) freopen(mbx, mode, stdin);
+ Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
+ }
+
if (!info->fp && info->out) {
sys$cancel(info->out->chan_out);
if (info->out->buf) Safefree(info->out->buf);
Safefree(info->out);
Safefree(info);
+ *psts = RMS$_FNF;
return Nullfp;
}
info->err->info = info;
}
- } else { /* piping to subroutine , mode=w*/
+ } else if (*mode == 'w') { /* piping to subroutine */
+
+ info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
+ if (info->out) {
+ info->out->pipe_done = &info->out_done;
+ info->out_done = FALSE;
+ info->out->info = info;
+ }
+
+ info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
+ if (info->err) {
+ info->err->pipe_done = &info->err_done;
+ info->err_done = FALSE;
+ info->err->info = info;
+ }
info->in = pipe_tochild_setup(aTHX_ in,mbx);
+ if (!info->useFILE) {
info->fp = PerlIO_open(mbx, mode);
+ } else {
+ info->fp = (PerlIO *) freopen(mbx, mode, stdout);
+ Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
+ }
+
if (info->in) {
info->in->pipe_done = &info->in_done;
info->in_done = FALSE;
if (info->in->buf) Safefree(info->in->buf);
Safefree(info->in);
Safefree(info);
+ *psts = RMS$_FNF;
return Nullfp;
}
+ } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
if (info->out) {
info->out->pipe_done = &info->out_done;
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
- p = VMScmd.dsc$a_pointer;
+ p = VMSCMD.dsc$a_pointer;
while (*p && *p != '\n') p++;
*p = '\0'; /* truncate on \n */
- p = VMScmd.dsc$a_pointer;
+ p = VMSCMD.dsc$a_pointer;
while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
if (*p == '$') p++; /* remove leading $ */
while (*p == ' ' || *p == '\t') p++;
if (tpipe) fclose(tpipe);
- /* once the subprocess is spawned, its copied the symbols and
+ /* once the subprocess is spawned, it has copied the symbols and
we can get rid of ours */
_ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
vms_execfree(aTHX);
PL_forkprocess = info->pid;
+ if (wait) {
+ int done = 0;
+ while (!done) {
+ _ckvmssts(sys$setast(0));
+ done = info->done;
+ if (!done) _ckvmssts(sys$clref(pipe_ef));
+ _ckvmssts(sys$setast(1));
+ if (!done) _ckvmssts(sys$waitfr(pipe_ef));
+ }
+ *psts = info->completion;
+ my_pclose(info->fp);
+ } else {
+ *psts = SS$_NORMAL;
+ }
return info->fp;
} /* end of safe_popen */
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
+ int sts;
TAINT_ENV();
TAINT_PROPER("popen");
PERL_FLUSHALL_FOR_CHILD;
- return safe_popen(aTHX_ cmd,mode);
+ return safe_popen(aTHX_ cmd,mode,&sts);
}
/*}}}*/
* well, at least sometimes it *does*, so we have to watch out for
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
-
+ if (info->fp) {
+ if (!info->useFILE)
PerlIO_flush(info->fp); /* first, flush data */
+ else
+ fflush((FILE *)info->fp);
+ }
_ckvmssts(sys$setast(0));
info->closing = TRUE;
_ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
0, 0, 0, 0, 0, 0));
_ckvmssts(sys$setast(1));
+ if (info->fp) {
+ if (!info->useFILE)
PerlIO_close(info->fp);
-
+ else
+ fclose((FILE *)info->fp);
+ }
/*
we have to wait until subprocess completes, but ALSO wait until all
the i/o completes...otherwise we'll be freeing the "info" structure
0
};
-static void pipe_and_fork(pTHX_ char **cmargv)
+static void
+pipe_and_fork(pTHX_ char **cmargv)
{
- char subcmd[2048];
- $DESCRIPTOR(cmddsc, "");
- static char mbxname[64];
- $DESCRIPTOR(mbxdsc, mbxname);
- int pid, j;
- unsigned long int zero = 0, one = 1;
-
- strcpy(subcmd, cmargv[0]);
- for (j = 1; NULL != cmargv[j]; ++j)
- {
- strcat(subcmd, " \"");
- strcat(subcmd, cmargv[j]);
- strcat(subcmd, "\"");
+ PerlIO *fp;
+ char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
+ int sts, j, l, ismcr, quote, tquote = 0;
+
+ sts = setup_cmddsc(cmargv[0],0,"e);
+
+ j = l = 0;
+ p = subcmd;
+ q = cmargv[0];
+ ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
+ && toupper(*(q+2)) == 'R' && !*(q+3);
+
+ while (q && l < MAX_DCL_LINE_LENGTH) {
+ if (!*q) {
+ if (j > 0 && quote) {
+ *p++ = '"';
+ l++;
+ }
+ q = cmargv[++j];
+ if (q) {
+ if (ismcr && j > 1) quote = 1;
+ tquote = (strchr(q,' ')) != NULL || *q == '\0';
+ *p++ = ' ';
+ l++;
+ if (quote || tquote) {
+ *p++ = '"';
+ l++;
+ }
+ }
+ } else {
+ if ((quote||tquote) && *q == '"') {
+ *p++ = '"';
+ l++;
}
- cmddsc.dsc$a_pointer = subcmd;
- cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
+ *p++ = *q++;
+ l++;
+ }
+ }
+ *p = '\0';
- create_mbx(aTHX_ &child_chan,&mbxdsc);
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
- PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
-#endif
- _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
- 0, &pid, child_st, &zero, sig_child,
- &child_chan));
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
-#endif
- sys$dclexh(&exit_block);
- if (NULL == freopen(mbxname, "wb", stdout))
- {
- PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
+ store_pipelocs(); /* gets redone later */
+ fp = safe_popen(subcmd,"wbF",&sts);
+ if (fp == Nullfp) {
+ PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
}
}
static void
vms_execfree(pTHX) {
if (PL_Cmd) {
- if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
+ if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
PL_Cmd = Nullch;
}
- if (VMScmd.dsc$a_pointer) {
- Safefree(VMScmd.dsc$a_pointer);
- VMScmd.dsc$w_length = 0;
- VMScmd.dsc$a_pointer = Nullch;
+ if (VMSCMD.dsc$a_pointer) {
+ Safefree(VMSCMD.dsc$a_pointer);
+ VMSCMD.dsc$w_length = 0;
+ VMSCMD.dsc$a_pointer = Nullch;
}
}
} /* end of setup_argstr() */
-#define MAX_DCL_LINE_LENGTH 255
static unsigned long int
-setup_cmddsc(pTHX_ char *cmd, int check_img)
+setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
register char *s, *rest, *cp, *wordbreak;
register int isdcl;
+ if (suggest_quote) *suggest_quote = 0;
+
if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
return CLI$_BUFOVF; /* continuation lines currently unsupported */
s = cmd;
* - if it doesn't, caller tells us whether to default to a DCL
* command, or to a local image unless told it's DCL (by leading '$')
*/
- if (*s == '@') isdcl = 1;
- else {
+ if (*s == '@') {
+ isdcl = 1;
+ if (suggest_quote) *suggest_quote = 1;
+ } else {
register char *filespec = strpbrk(s,":<[.;");
rest = wordbreak = strpbrk(s," \"\t/");
if (!wordbreak) wordbreak = s + strlen(s);
if (check_img && isdcl) return RMS$_FNF;
if (cando_by_name(S_IXUSR,0,resspec)) {
- New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+ New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
if (!isdcl) {
- strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+ strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
+ if (suggest_quote) *suggest_quote = 1;
} else {
- strcpy(VMScmd.dsc$a_pointer,"@");
+ strcpy(VMSCMD.dsc$a_pointer,"@");
+ if (suggest_quote) *suggest_quote = 1;
}
- strcat(VMScmd.dsc$a_pointer,resspec);
- if (rest) strcat(VMScmd.dsc$a_pointer,rest);
- VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
- return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ strcat(VMSCMD.dsc$a_pointer,resspec);
+ if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
+ VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
+ return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
}
else retsts = RMS$_PRV;
}
}
/* It's either a DCL command or we couldn't find a suitable image */
- VMScmd.dsc$w_length = strlen(cmd);
- if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
- else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
+ VMSCMD.dsc$w_length = strlen(cmd);
+ if (cmd == PL_Cmd) {
+ VMSCMD.dsc$a_pointer = PL_Cmd;
+ if (suggest_quote) *suggest_quote = 1;
+ }
+ else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
+
+ /* check if it's a symbol (for quoting purposes) */
+ if (suggest_quote && !*suggest_quote) {
+ int iss;
+ char equiv[LNM$C_NAMLENGTH];
+ struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ eqvdsc.dsc$a_pointer = equiv;
+
+ iss = lib$get_symbol(&VMSCMD,&eqvdsc);
+ if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
+ }
if (!(retsts & 1)) {
/* just hand off status values likely to be due to user error */
if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
else { _ckvmssts(retsts); }
}
- return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
} /* end of setup_cmddsc() */
TAINT_ENV();
TAINT_PROPER("exec");
- if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
- retsts = lib$do_command(&VMScmd);
+ if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
+ retsts = lib$do_command(&VMSCMD);
switch (retsts) {
case RMS$_FNF: case RMS$_DNF:
set_vaxc_errno(retsts);
if (ckWARN(WARN_EXEC)) {
Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
- VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
+ VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
}
vms_execfree(aTHX);
}
sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
else {
- sts = setup_cmddsc(aTHX_ cmd,0);
- if (sts & 1) {
- sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
- } else {
- substs = sts; /* didn't spawn, use command setup failure for return */
- }
+ (void) safe_popen(cmd, "nW", (int *)&sts);
+ substs = sts;
}
if (!(sts & 1)) {
}
set_vaxc_errno(sts);
if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
- hadcmd ? VMScmd.dsc$w_length : 0,
- hadcmd ? VMScmd.dsc$a_pointer : "",
+ Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
+ hadcmd ? cmd : "",
Strerror(errno));
}
}
x = (float)ix;
MY_INV_RAND_MAX = 1./x;
-}
-
+ VMSCMD.dsc$a_pointer = NULL;
+ VMSCMD.dsc$w_length = 0;
+ VMSCMD.dsc$b_dtype = DSC$K_DTYPE_T;
+ VMSCMD.dsc$b_class = DSC$K_CLASS_S;
+}
void
init_os_extras()
projects / p5sagit/p5-mst-13.2.git / commitdiff