*
* VMS-specific routines for perl5
*
- * Last revised: 9-Nov-1997 by Charles Bailey bailey@newman.upenn.edu
- * Version: 5.4.53a
+ * Last revised: 27-Feb-1998 by Charles Bailey bailey@newman.upenn.edu
+ * Version: 5.4.61
*/
#include <acedef.h>
#include <armdef.h>
#include <atrdef.h>
#include <chpdef.h>
+#include <clidef.h>
#include <climsgdef.h>
#include <descrip.h>
#include <dvidef.h>
} /* end of my_getenv() */
/*}}}*/
-static FILE *safe_popen(char *, char *);
+static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
+
+static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
/*{{{ void prime_env_iter() */
void
*/
{
dTHR;
- static int primed = 0; /* XXX Not thread-safe!!! */
+ static int primed = 0;
HV *envhv = GvHVn(envgv);
- FILE *sholog;
- char eqv[LNM$C_NAMLENGTH+1],*start,*end;
+ PerlIO *sholog;
+ char eqv[LNM$C_NAMLENGTH+1],mbxnam[LNM$C_NAMLENGTH+1],*start,*end;
+ unsigned short int chan;
+#ifndef CLI$M_TRUSTED
+# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
+#endif
+ unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
+ unsigned long int i, retsts, substs = 0, wakect = 0;
STRLEN eqvlen;
SV *oldrs, *linesv, *eqvsv;
+ $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:");
+ $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(tabdsc,"DCLTABLES");
+ $DESCRIPTOR(mbxdsc,mbxnam);
#ifdef USE_THREADS
- static perl_mutex primenv_mutex = PTHREAD_MUTEX_INITIALIZER;
+ static perl_mutex primenv_mutex;
+ MUTEX_INIT(&primenv_mutex);
#endif
if (primed) return;
MUTEX_LOCK(&primenv_mutex);
if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
/* Perform a dummy fetch as an lval to insure that the hash table is
- * set up. Otherwise, the hv_store() will turn into a nullop */
+ * set up. Otherwise, the hv_store() will turn into a nullop. */
(void) hv_fetch(envhv,"DEFAULT",7,TRUE);
- /* Also, set up the four "special" keys that the CRTL defines,
- * whether or not underlying logical names exist. */
- (void) hv_fetch(envhv,"HOME",4,TRUE);
- (void) hv_fetch(envhv,"TERM",4,TRUE);
- (void) hv_fetch(envhv,"PATH",4,TRUE);
- (void) hv_fetch(envhv,"USER",4,TRUE);
+ /* Also, set up any "special" keys that the CRTL defines,
+ * either by itself or becasue we were called from a C program
+ * using exec[lv]e() */
+ for (i = 0; environ[i]; i++) {
+ if (!(start = strchr(environ[i],'='))) {
+ warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]);
+ }
+ else {
+ start++;
+ (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0);
+ }
+ }
/* Now, go get the logical names */
- if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp) {
+ create_mbx(&chan,&mbxdsc);
+ if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
+ if ((retsts = sys$dassgn(chan)) & 1) {
+ /* Be certain that subprocess is using the CLI and command tables we
+ * expect, and don't pass symbols through so that we insure that
+ * "Show Logical" can't be subverted.
+ */
+ do {
+ retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
+ 0,&riseandshine,0,0,&clidsc,&tabdsc);
+ flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
+ } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
+ }
+ }
+ if (sholog == Nullfp || !(retsts & 1)) {
+ if (sholog != Nullfp) PerlIO_close(sholog);
MUTEX_UNLOCK(&primenv_mutex);
- _ckvmssts(vaxc$errno);
+ _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
}
- /* We use Perl's sv_gets to read from the pipe, since safe_popen is
+ /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
* tied to Perl's I/O layer, so it may not return a simple FILE * */
oldrs = rs;
rs = newSVpv("\n",1);
linesv = newSVpv("",0);
while (1) {
if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
- my_pclose(sholog);
+ PerlIO_close(sholog);
SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
primed = 1;
+ /* Wait for subprocess to clean up (we know subproc won't return 0) */
+ while (substs == 0) { sys$hiber(); wakect++;}
+ if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
+ _ckvmssts(substs);
MUTEX_UNLOCK(&primenv_mutex);
return;
}
}
}
-static FILE *
+static PerlIO *
safe_popen(char *cmd, char *mode)
{
static int handler_set_up = FALSE;
retsts = sys$parse(&myfab,0,0);
if (!(retsts & 1)) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK;
if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
retsts == RMS$_DEV || retsts == RMS$_DEV) {
- mynam.nam$b_nop |= NAM$M_SYNCHK;
retsts = sys$parse(&myfab,0,0);
if (retsts & 1) goto expanded;
}
+ mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
+ (void) sys$parse(&myfab,0,0); /* Free search context */
if (out) Safefree(out);
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
}
retsts = sys$search(&myfab,0,0);
if (!(retsts & 1) && retsts != RMS$_FNF) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
+ myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
if (out) Safefree(out);
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
(!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
speclen = mynam.nam$l_ver - out;
+ if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
+ (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' ||
+ defspec[myfab.fab$b_dns-2] == '.'))
+ speclen = mynam.nam$l_type - out;
/* If we just had a directory spec on input, $PARSE "helpfully"
* adds an empty name and type for us */
if (mynam.nam$l_name == mynam.nam$l_type &&
if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
strcpy(outbuf,tmpfspec);
}
+ mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
+ mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
+ myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
return outbuf;
}
/*}}}*/
if (*(cp1+2) == '.') cp1++;
if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
+ if (strchr(vmsdir,'/') != NULL) {
+ /* If do_tovmsspec() returned it, it must have VMS syntax
+ * delimiters in it, so it's a mixed VMS/Unix spec. We take
+ * the time to check this here only so we avoid a recursion
+ * loop; otherwise, gigo.
+ */
+ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
+ }
if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
return do_tounixspec(trndir,buf,ts);
}
cp1++;
} while ((cp1 = strstr(cp1,"/.")) != NULL);
+ lastdir = strrchr(dir,'/');
}
else if (!strcmp(&dir[dirlen-7],"/000000")) {
/* Ditto for specs that end in an MFD -- let the VMS code
*argcp++; argvp = newap;
}
getredirection(argcp,argvp);
+#if defined(USE_THREADS) && defined(__DECC)
+ {
+# include <reentrancy.h>
+ (void) decc$set_reentrancy(C$C_MULTITHREAD);
+ }
+#endif
return;
}
/*}}}*/
for (front = end ; front >= base; front--)
if (*front == '/' && !dirs--) { front++; break; }
}
- for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
+ for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
if (cp1 != '\0') return 0; /* Path too long. */
lcend = cp2;
s = resspec;
while (*s && !isspace(*s)) s++;
*s = '\0';
+ if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
strcat(VMScmd.dsc$a_pointer,resspec);
if ((retsts = setup_cmddsc(cmd,1)) & 1)
retsts = lib$do_command(&VMScmd);
- set_errno(EVMSERR);
+ switch (retsts) {
+ case RMS$_FNF:
+ set_errno(ENOENT); break;
+ case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
+ set_errno(ENOTDIR); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ case RMS$_SYN:
+ set_errno(EINVAL); break;
+ case CLI$_BUFOVF:
+ set_errno(E2BIG); break;
+ case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
+ _ckvmssts(retsts); /* fall through */
+ default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+ set_errno(EVMSERR);
+ }
set_vaxc_errno(retsts);
if (dowarn)
warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
unsigned long int
do_spawn(char *cmd)
{
- unsigned long int substs, hadcmd = 1;
+ unsigned long int sts, substs, hadcmd = 1;
TAINT_ENV();
TAINT_PROPER("spawn");
if (!cmd || !*cmd) {
hadcmd = 0;
- _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
+ sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
- else if ((substs = setup_cmddsc(cmd,0)) & 1) {
- _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
+ else if ((sts = setup_cmddsc(cmd,0)) & 1) {
+ sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
- if (!(substs&1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(substs);
+ if (!(sts & 1)) {
+ switch (sts) {
+ case RMS$_FNF:
+ set_errno(ENOENT); break;
+ case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
+ set_errno(ENOTDIR); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ case RMS$_SYN:
+ set_errno(EINVAL); break;
+ case CLI$_BUFOVF:
+ set_errno(E2BIG); break;
+ case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
+ _ckvmssts(sts); /* fall through */
+ default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(sts);
if (dowarn)
warn("Can't spawn \"%s\": %s",
hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
I32
cando(I32 bit, I32 effective, Stat_t *statbufp)
{
+ dTHR;
if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
else {
char fname[NAM$C_MAXRSS+1];
if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
return TRUE;
}
+ if (retsts == SS$_ACCONFLICT) {
+ return TRUE;
+ }
_ckvmssts(retsts);
return FALSE; /* Should never get here */
FILE *
my_binmode(FILE *fp, char iotype)
{
- char filespec[NAM$C_MAXRSS], *acmode;
+ char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
+ int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
fpos_t pos;
if (!fgetname(fp,filespec)) return NULL;
- if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
+ for (s = filespec; *s; s++) {
+ if (*s == ':') colon = s;
+ else if (*s == ']' || *s == '>') dirend = s;
+ }
+ /* Looks like a tmpfile, which will go away if reopened */
+ if (s == dirend + 3) return fp;
+ /* If we've got a non-file-structured device, clip off the trailing
+ * junk, and don't lose sleep if we can't get a stream position. */
+ if (dirend == Nullch) *(colon+1) = '\0';
+ if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
switch (iotype) {
case '<': case 'r': acmode = "rb"; break;
- case '>': case 'w':
+ case '>': case 'w': case '|':
/* use 'a' instead of 'w' to avoid creating new file;
fsetpos below will take care of restoring file position */
case 'a': acmode = "ab"; break;
- case '+': case '|': case 's': acmode = "rb+"; break;
+ case '+': case 's': acmode = "rb+"; break;
case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
+ /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
+ /* since we didn't really open them and can't really */
+ /* reopen them */
+ case 0: return NULL; break;
default:
- warn("Unrecognized iotype %c in my_binmode",iotype);
+ warn("Unrecognized iotype %x for %s in my_binmode",iotype, filespec);
acmode = "rb+";
}
if (freopen(filespec,acmode,fp) == NULL) return NULL;
- if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
+ if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
+ if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
return fp;
} /* end of my_binmode() */
/*}}}*/
newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
+
+#ifdef PRIME_ENV_AT_STARTUP
+ prime_env_iter();
+#endif
+
return;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff