X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=a498e16266cbb11ad4c013d323f7a8dddbfdb14f;hb=840301ab1fb53d14da54391384089aef70e2d8dd;hp=c80de0048d9208bf1b633ad8757e1350dafee860;hpb=aa779de11089a0113274275ef26a76ef1270014a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index c80de00..a498e16 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -2,7 +2,7 @@ * * 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 */ @@ -273,6 +273,8 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) idx = strtoul(cp2+1,NULL,0); lnm = uplnm; } + /* Impose security constraints only if tainting */ + if (sys) sys = PL_curinterp ? PL_tainting : will_taint; if (vmstrnenv(lnm,eqv,idx, sys ? fildev : NULL, #ifdef SECURE_INTERNAL_GETENV @@ -319,6 +321,8 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) idx = strtoul(cp2+1,NULL,0); lnm = buf; } + /* Impose security constraints only if tainting */ + if (sys) sys = PL_curinterp ? PL_tainting : will_taint; if ((*len = vmstrnenv(lnm,buf,idx, sys ? fildev : NULL, #ifdef SECURE_INTERNAL_GETENV @@ -612,6 +616,12 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) } 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); } } @@ -977,7 +987,10 @@ pipe_exit_routine() info = open_pipes; while (info) { - if (info->mode != 'r' && !info->done) { + _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; @@ -987,22 +1000,26 @@ pipe_exit_routine() 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; } @@ -1106,6 +1123,7 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) { 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; @@ -1119,15 +1137,20 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) /* 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; @@ -1592,13 +1615,14 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) /* 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))) { @@ -1614,6 +1638,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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; @@ -1626,6 +1652,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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) { @@ -1634,7 +1662,11 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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); @@ -1651,6 +1683,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) /* 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; @@ -1695,6 +1729,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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"); @@ -1847,6 +1883,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) 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; @@ -1859,6 +1897,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) 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; @@ -1878,6 +1918,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) 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); @@ -2117,16 +2159,12 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { 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')) { - if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ + else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */ + if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; else if (*(cp1-2) == '[') *(cp1-1) = '-'; - else { /* back up over previous directory name */ - cp1--; - while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; - if (*(cp1-1) == '[') { - memcpy(cp1,"000000.",7); - cp1 += 7; - } + else { +/* if (*(cp1-1) != '.') *(cp1++) = '.'; */ + *(cp1++) = '-'; } cp2 += 2; if (cp2 == dirend) break; @@ -4247,7 +4285,7 @@ int my_utime(char *file, struct utimbuf *utimes) /* 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); @@ -4293,6 +4331,8 @@ int my_utime(char *file, struct utimbuf *utimes) } 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); @@ -4305,6 +4345,8 @@ int my_utime(char *file, struct utimbuf *utimes) 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); @@ -4329,6 +4371,8 @@ int my_utime(char *file, struct utimbuf *utimes) 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)) {