* 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
*/
+#include <accdef.h>
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
+#include <msgdef.h>
#include <prvdef.h>
#include <psldef.h>
#include <rms.h>
/* 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
{
static int primed = 0;
HV *seenhv = NULL, *envhv;
+ SV *sv = NULL;
char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
unsigned short int chan;
#ifndef CLI$M_TRUSTED
}
else {
start++;
- (void) hv_store(envhv,environ[j],start - environ[j] - 1,
- newSVpv(start,0),0);
+ sv = newSVpv(start,0);
+ SvTAINTED_on(sv);
+ (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
}
}
continue;
continue;
}
PERL_HASH(hash,key,keylen);
- hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
+ sv = newSVpvn(cp2,cp1 - cp2 + 1);
+ SvTAINTED_on(sv);
+ hv_store(envhv,key,keylen,sv,hash);
hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
}
if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
int trnlen, i;
for (i = 0; ppfs[i]; i++) {
trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
- hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
+ sv = newSVpv(eqv,trnlen);
+ SvTAINTED_on(sv);
+ hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
}
}
}
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;
/*
- first we try sending an EOF...ignore if doesn't work, make sure we
+ 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;
+ }
+
+ /*
+ 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
} /* end of my_pclose() */
-/* sort-of waitpid; use only with popen() */
+#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+ /* Roll our own prototype because we want this regardless of whether
+ * _VMS_WAIT is defined.
+ */
+ __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
+#endif
+/* sort-of waitpid; special handling of pipe clean-up for subprocesses
+ created with popen(); otherwise partially emulate waitpid() unless
+ we have a suitable one from the CRTL that came with VMS 7.2 and later.
+ Also check processes not considered by the CRTL waitpid().
+ */
/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
Pid_t
Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
{
pInfo info;
int done;
+ int sts;
+
+ if (statusp) *statusp = 0;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
if (!done) _ckvmssts(sys$waitfr(pipe_ef));
}
- *statusp = info->completion;
+ if (statusp) *statusp = info->completion;
return pid;
+
}
- else { /* we haven't heard of this child */
+ else { /* this child is not one of our own pipe children */
+
+#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+
+ /* waitpid() became available in the CRTL as of VMS 7.0, but only
+ * in 7.2 did we get a version that fills in the VMS completion
+ * status as Perl has always tried to do.
+ */
+
+ sts = __vms_waitpid( pid, statusp, flags );
+
+ if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
+ return sts;
+
+ /* If the real waitpid tells us the child does not exist, we
+ * fall through here to implement waiting for a child that
+ * was created by some means other than exec() (say, spawned
+ * from DCL) or to wait for a process that is not a subprocess
+ * of the current process.
+ */
+
+#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
+
$DESCRIPTOR(intdsc,"0 00:00:01");
- unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
- unsigned long int interval[2],sts;
+ unsigned long int ownercode = JPI$_OWNER, ownerpid;
+ unsigned long int pidcode = JPI$_PID, mypid;
+ unsigned long int interval[2];
+ int termination_mbu = 0;
+ unsigned short qio_iosb[4];
+ unsigned int jpi_iosb[2];
+ struct itmlst_3 jpilist[3] = {
+ {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
+ {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
+ { 0, 0, 0, 0}
+ };
+ char trmmbx[NAM$C_DVI+1];
+ $DESCRIPTOR(trmmbxdsc,trmmbx);
+ struct accdef trmmsg;
+ unsigned short int mbxchan;
+
+ if (pid <= 0) {
+ /* Sorry folks, we don't presently implement rooting around for
+ the first child we can find, and we definitely don't want to
+ pass a pid of -1 to $getjpi, where it is a wildcard operation.
+ */
+ set_errno(ENOTSUP);
+ return -1;
+ }
+
+ /* Get the owner of the child so I can warn if it's not mine, plus
+ * get the termination mailbox. If the process doesn't exist or I
+ * don't have the privs to look at it, I can go home early.
+ */
+ sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
+ if (sts & 1) sts = jpi_iosb[0];
+ if (!(sts & 1)) {
+ switch (sts) {
+ case SS$_NONEXPR:
+ set_errno(ECHILD);
+ break;
+ case SS$_NOPRIV:
+ set_errno(EACCES);
+ break;
+ default:
+ _ckvmssts(sts);
+ }
+ set_vaxc_errno(sts);
+ return -1;
+ }
if (ckWARN(WARN_EXEC)) {
- _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
- _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
+ /* remind folks they are asking for non-standard waitpid behavior */
+ _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
if (ownerpid != mypid)
- Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
+ Perl_warner(aTHX_ WARN_EXEC,
+ "waitpid: process %x is not a child of process %x",
+ pid,mypid);
}
- _ckvmssts(sys$bintim(&intdsc,interval));
- while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
- _ckvmssts(sys$schdwk(0,0,interval,0));
- _ckvmssts(sys$hiber());
+ /* It's possible to have a mailbox unit number but no actual mailbox; we
+ * check for this by assigning a channel to it, which we need anyway.
+ */
+ if (termination_mbu != 0) {
+ sprintf(trmmbx, "MBA%d:", termination_mbu);
+ trmmbxdsc.dsc$w_length = strlen(trmmbx);
+ sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
+ if (sts == SS$_NOSUCHDEV) {
+ termination_mbu = 0; /* set up to take "no mailbox" case */
+ sts = SS$_NORMAL;
+ }
+ _ckvmssts(sts);
}
- if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
- _ckvmssts(sts);
-
- /* There's no easy way to find the termination status a child we're
- * not aware of beforehand. If we're really interested in the future,
- * we can go looking for a termination mailbox, or chase after the
- * accounting record for the process.
+ /* If the process doesn't have a termination mailbox, then simply check
+ * on it once a second until it's not there anymore.
*/
- *statusp = 0;
+ if (termination_mbu == 0) {
+ _ckvmssts(sys$bintim(&intdsc,interval));
+ while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
+ _ckvmssts(sys$schdwk(0,0,interval,0));
+ _ckvmssts(sys$hiber());
+ }
+ if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
+ }
+ else {
+ /* If we do have a termination mailbox, post reads to it until we get a
+ * termination message, discarding messages of the wrong type or for other
+ * processes. If there is a place to put the final status, then do so.
+ */
+ sts = SS$_NORMAL;
+ while (sts & 1) {
+ memset((void *) &trmmsg, 0, sizeof(trmmsg));
+ sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
+ &trmmsg,ACC$K_TERMLEN,0,0,0,0);
+ if (sts & 1) sts = qio_iosb[0];
+
+ if ( sts & 1
+ && trmmsg.acc$w_msgtyp == MSG$_DELPROC
+ && trmmsg.acc$l_pid == pid ) {
+
+ if (statusp) *statusp = trmmsg.acc$l_finalsts;
+ sts = sys$dassgn(mbxchan);
+ break;
+ }
+ }
+ } /* termination_mbu ? */
+
+ _ckvmssts(sts);
return pid;
- }
+
+ } /* else one of our own pipe children */
} /* end of waitpid() */
/*}}}*/
dir[--dirlen] = '\0';
dir[dirlen-1] = ']';
}
+ if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
+ dir[--dirlen] = '\0';
+ dir[dirlen-1] = '>';
+ }
if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
/* If we've got an explicit filename, we can just shuffle the string. */
else if (ts) New(1312,retspec,retlen+16,char);
else retspec = __fileify_retbuf;
cp1 = strstr(esa,"][");
+ if (!cp1) cp1 = strstr(esa,"]<");
dirlen = cp1 - esa;
memcpy(retspec,esa,dirlen);
if (!strncmp(cp1+2,"000000]",7)) {
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++;
+ }
}
- cmddsc.dsc$a_pointer = subcmd;
- cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
+ } else {
+ if ((quote||tquote) && *q == '"') {
+ *p++ = '"';
+ l++;
+ }
+ *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));
}
}
# endif
dst = -1;
#ifndef RTL_USES_UTC
- if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
+ if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
when = whenutc - offset; /* pseudolocal time*/
}
# endif
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
+ if (!fspec) return retval;
strcpy(temp_fspec, fspec);
if (statbufp == (Stat_t *) &PL_statcache)
do_tovmsspec(temp_fspec,namecache,0);
}
void
+hushexit_fromperl(pTHX_ CV *cv)
+{
+ dXSARGS;
+
+ if (items > 0) {
+ VMSISH_HUSHED = SvTRUE(ST(0));
+ }
+ ST(0) = boolSV(VMSISH_HUSHED);
+ XSRETURN(1);
+}
+
+void
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
+ struct interp_intern *dst)
+{
+ memcpy(dst,src,sizeof(struct interp_intern));
+}
+
+void
+Perl_sys_intern_clear(pTHX)
+{
+}
+
+void
+Perl_sys_intern_init(pTHX)
+{
+ int ix = RAND_MAX;
+ float x;
+
+ VMSISH_HUSHED = 0;
+
+ 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()
{
dTHX;
newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
+ newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
store_pipelocs(aTHX);
projects / p5sagit/p5-mst-13.2.git / blobdiff