*
* VMS-specific routines for perl5
*
- * Last revised: 24-Feb-2000 by Charles Bailey bailey@newman.upenn.edu
+ * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
* Version: 5.5.60
*/
# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
#endif
+#if defined(NEED_AN_H_ERRNO)
+dEXT int h_errno;
+#endif
struct itmlst_3 {
unsigned short int buflen;
vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
struct dsc$descriptor_s **tabvec, unsigned long int flags)
{
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
unsigned long int retsts, attr = LNM$M_CASE_BLIND;
unsigned char acmode;
}
lnmdsc.dsc$w_length = cp1 - lnm;
lnmdsc.dsc$a_pointer = uplnm;
+ uplnm[lnmdsc.dsc$w_length] = '\0';
secure = flags & PERL__TRNENV_SECURE;
acmode = secure ? PSL$C_EXEC : PSL$C_USER;
if (!tabvec || !*tabvec) tabvec = env_tables;
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
if (retsts == SS$_NOLOGNAM) continue;
+ /* PPFs have a prefix */
+ if (
+#if INTSIZE == 4
+ *((int *)uplnm) == *((int *)"SYS$") &&
+#endif
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
+ (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
+ (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
+ (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
+ memcpy(eqv,eqv+4,eqvlen-4);
+ eqvlen -= 4;
+ }
break;
}
}
}
else {
if (!*eqv) eqvdsc.dsc$w_length = 1;
+ if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
+ eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
+ if (ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+ }
+ }
retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
}
info = open_pipes;
while (info) {
- if (info->mode != 'r' && !info->done) {
+ int need_eof;
+ _ckvmssts(sys$setast(0));
+ need_eof = info->mode != 'r' && !info->done;
+ _ckvmssts(sys$setast(1));
+ if (need_eof) {
if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
}
info = info->next;
did_stuff = 0;
info = open_pipes;
while (info) {
+ _ckvmssts(sys$setast(0));
if (!info->done) { /* Tap them gently on the shoulder . . .*/
sts = sys$forcex(&info->pid,0,&abort);
if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
did_stuff = 1;
}
+ _ckvmssts(sys$setast(1));
info = info->next;
}
if (did_stuff) sleep(1); /* wait for them to respond */
info = open_pipes;
while (info) {
+ _ckvmssts(sys$setast(0));
if (!info->done) { /* We tried to be nice . . . */
sts = sys$delprc(&info->pid,0);
if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
info->done = 1; /* so my_pclose doesn't try to write EOF */
}
+ _ckvmssts(sys$setast(1));
info = info->next;
}
{
struct pipe_details *info, *last = NULL;
unsigned long int retsts;
+ int need_eof;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
/* If we were writing to a subprocess, insure that someone reading from
* the mailbox gets an EOF. It looks like a simple fclose() doesn't
* produce an EOF record in the mailbox. */
- if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
+ _ckvmssts(sys$setast(0));
+ need_eof = info->mode != 'r' && !info->done;
+ _ckvmssts(sys$setast(1));
+ if (need_eof) pipe_eof(info->fp,0);
PerlIO_close(info->fp);
if (info->done) retsts = info->completion;
else waitpid(info->pid,(int *) &retsts,0);
/* remove from list of open pipes */
+ _ckvmssts(sys$setast(0));
if (last) last->next = info->next;
else open_pipes = info->next;
+ _ckvmssts(sys$setast(1));
Safefree(info);
return retsts;
/* Yes; fake the fnb bits so we'll check type below */
dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
}
- else {
- if (dirfab.fab$l_sts != RMS$_FNF) {
- set_errno(EVMSERR);
- set_vaxc_errno(dirfab.fab$l_sts);
+ else { /* No; just work with potential name */
+ if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
+ else {
+ set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
return NULL;
}
- dirnam = savnam; /* No; just work with potential name */
}
}
if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
else retspec = __fileify_retbuf;
strcpy(retspec,esa);
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
return retspec;
}
if ((cp1 = strstr(esa,".][000000]")) != NULL) {
dirnam.nam$b_esl -= 9;
}
if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
- if (cp1 == NULL) return NULL; /* should never happen */
+ if (cp1 == NULL) { /* should never happen */
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
+ return NULL;
+ }
term = *cp1;
*cp1 = '\0';
retlen = strlen(esa);
/* Go back and expand rooted logical name */
dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
if (!(sys$parse(&dirfab) & 1)) {
+ dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
strcpy(cp2+9,cp1);
}
}
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
/* We've set up the string up through the filename. Add the
type and version, and we're done. */
strcat(retspec,".DIR;1");
savnam = dirnam;
if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
if (dirfab.fab$l_sts != RMS$_FNF) {
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
else if (ts) New(1314,retpath,retlen,char);
else retpath = __pathify_retbuf;
strcpy(retpath,esa);
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
/* $PARSE may have upcased filespec, so convert output to lower
* case if input contained any lowercase characters. */
if (haslower) __mystrtolower(retpath);
else if (!infront && *cp2 == '.') {
if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
- else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
- if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-';
+ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+ if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
else if (*(cp1-2) == '[') *(cp1-1) = '-';
- else {
-/* if (*(cp1-1) != '.') *(cp1++) = '.'; */
- *(cp1++) = '-';
+ else { /* back up over previous directory name */
+ cp1--;
+ while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
+ if (*(cp1-1) == '[') {
+ memcpy(cp1,"000000.",7);
+ cp1 += 7;
+ }
}
cp2 += 2;
if (cp2 == dirend) break;
exit(vaxc$errno);
}
if (err != NULL) {
+ if (strcmp(err,"&1") == 0) {
+ dup2(fileno(stdout), fileno(Perl_debug_log));
+ } else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
exit(vaxc$errno);
}
}
+ }
#ifdef ARGPROC_DEBUG
PerlIO_printf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
+ $DESCRIPTOR(defdsc2,".");
$DESCRIPTOR(resdsc,resspec);
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
imgdsc.dsc$a_pointer = s;
imgdsc.dsc$w_length = wordbreak - s;
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+ if (!(retsts&1)) {
+ _ckvmssts(lib$find_file_end(&cxt));
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
if (!(retsts & 1) && *s == '$') {
+ _ckvmssts(lib$find_file_end(&cxt));
imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+ if (!(retsts&1)) {
_ckvmssts(lib$find_file_end(&cxt));
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+ }
+ }
}
+ _ckvmssts(lib$find_file_end(&cxt));
+
if (retsts & 1) {
+ FILE *fp;
s = resspec;
while (*s && !isspace(*s)) s++;
*s = '\0';
+
+ /* check that it's really not DCL with no file extension */
+ fp = fopen(resspec,"r","ctx=bin,shr=get");
+ if (fp) {
+ char b[4] = {0,0,0,0};
+ read(fileno(fp),b,4);
+ isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
+ fclose(fp);
+ }
+ 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);
+ if (!isdcl) {
strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+ } else {
+ strcpy(VMScmd.dsc$a_pointer,"@");
+ }
strcat(VMScmd.dsc$a_pointer,resspec);
if (rest) strcat(VMScmd.dsc$a_pointer,rest);
VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
/* If input was UTC; convert to local for sys svc */
if (!VMSISH_TIME) unixtime = _toloc(unixtime);
# endif
- unixtime >> 1; secscale << 1;
+ unixtime >>= 1; secscale <<= 1;
retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
if (!(retsts & 1)) {
set_errno(EVMSERR);
}
retsts = sys$search(&myfab,0,0);
if (!(retsts & 1)) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
+ myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
else if (retsts == RMS$_FNF) set_errno(ENOENT);
retsts = sys$assign(&devdsc,&chan,0,0);
if (!(retsts & 1)) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
+ myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
set_vaxc_errno(retsts);
if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
else if (retsts == SS$_NOPRIV) set_errno(EACCES);
myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
#endif
retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+ mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
+ myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
_ckvmssts(sys$dassgn(chan));
if (retsts & 1) retsts = iosb[0];
if (!(retsts & 1)) {
https://perl5.git.perl.org / perl5.git / blobdiff