X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=f1f62bd6eb6903b8c3fb64619b470463d13ccd68;hb=c93fa8177be816b728baa070d16f5574403845f6;hp=ab240001530b0325ea086a65bdd4fdddead20df6;hpb=5bc28da93666e223bb56098f72517273bc8bcbf9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index ab24000..f1f62bd 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -2,7 +2,7 @@ * * VMS-specific routines for perl5 * - * Last revised: 15-Aug-1999 by Charles Bailey bailey@newman.upenn.edu + * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu * Version: 5.5.60 */ @@ -95,9 +95,8 @@ static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */ /* munching */ static int no_translate_barewords; -/* True if we shouldn't treat barewords as logicals during directory */ -/* 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}; /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ int @@ -274,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 @@ -320,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 @@ -613,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); } } @@ -978,7 +987,11 @@ pipe_exit_routine() 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; @@ -988,22 +1001,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; } @@ -1029,13 +1046,16 @@ popen_completion_ast(struct pipe_details *thispipe) } } +static unsigned long int setup_cmddsc(char *cmd, int check_img); +static void vms_execfree(); + static PerlIO * safe_popen(char *cmd, char *mode) { static int handler_set_up = FALSE; char mbxname[64]; unsigned short int chan; - unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */ + unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */ dTHX; struct pipe_details *info; struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T, @@ -1044,13 +1064,7 @@ safe_popen(char *cmd, char *mode) DSC$K_CLASS_S, 0}; - cmddsc.dsc$w_length=strlen(cmd); - cmddsc.dsc$a_pointer=cmd; - if (cmddsc.dsc$w_length > 255) { - set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF); - return Nullfp; - } - + if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } New(1301,info,1,struct pipe_details); /* create mailbox */ @@ -1070,16 +1084,17 @@ safe_popen(char *cmd, char *mode) info->completion=0; if (*mode == 'r') { - _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags, + _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags, 0 /* name */, &info->pid, &info->completion, 0, popen_completion_ast,info,0,0,0)); } else { - _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags, + _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags, 0 /* name */, &info->pid, &info->completion, 0, popen_completion_ast,info,0,0,0)); } + vms_execfree(); if (!handler_set_up) { _ckvmssts(sys$dclexh(&pipe_exitblock)); handler_set_up = TRUE; @@ -1109,6 +1124,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; @@ -1122,15 +1138,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; @@ -1595,13 +1616,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))) { @@ -1617,6 +1639,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; @@ -1629,6 +1653,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) { @@ -1637,7 +1663,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); @@ -1654,6 +1684,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; @@ -1698,6 +1730,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"); @@ -1850,6 +1884,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; @@ -1862,6 +1898,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; @@ -1881,6 +1919,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); @@ -2120,16 +2160,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; @@ -2483,6 +2519,9 @@ getredirection(int *ac, char ***av) 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"))) { @@ -2495,6 +2534,7 @@ getredirection(int *ac, char ***av) exit(vaxc$errno); } } + } #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "Arglist:\n"); for (j = 0; j < *ac; ++j) @@ -3290,12 +3330,10 @@ my_vfork() /*}}}*/ -static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch}; - static void vms_execfree() { if (PL_Cmd) { - Safefree(PL_Cmd); + if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd); PL_Cmd = Nullch; } if (VMScmd.dsc$a_pointer) { @@ -3353,44 +3391,102 @@ setup_argstr(SV *really, SV **mark, SV **sp) static unsigned long int setup_cmddsc(char *cmd, int check_img) { - char resspec[NAM$C_MAXRSS+1]; + 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; - register char *s, *rest, *cp; - register int isdcl = 0; + register char *s, *rest, *cp, *wordbreak; + register int isdcl; dTHX; + if (strlen(cmd) > + (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec))) + return LIB$_INVARG; s = cmd; while (*s && isspace(*s)) s++; - if (check_img) { - if (*s == '$') { /* Check whether this is a DCL command: leading $ and */ - isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */ - for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) { - if (*cp == ':' || *cp == '[' || *cp == '<') { - isdcl = 0; - break; - } + + if (*s == '@' || *s == '$') { + vmsspec[0] = *s; rest = s + 1; + for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest; + } + else { cp = vmsspec; rest = s; } + if (*rest == '.' || *rest == '/') { + char *cp2; + for (cp2 = resspec; + *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec; + rest++, cp2++) *cp2 = *rest; + *cp2 = '\0'; + if (do_tovmsspec(resspec,cp,0)) { + s = vmsspec; + if (*rest) { + for (cp2 = vmsspec + strlen(vmsspec); + *rest && cp2 - vmsspec < sizeof vmsspec; + rest++, cp2++) *cp2 = *rest; + *cp2 = '\0'; } } } - else isdcl = 1; + /* Intuit whether verb (first word of cmd) is a DCL command: + * - if first nonspace char is '@', it's a DCL indirection + * otherwise + * - if verb contains a filespec separator, it's not a DCL command + * - 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 { + register char *filespec = strpbrk(s,":<[.;"); + rest = wordbreak = strpbrk(s," \"\t/"); + if (!wordbreak) wordbreak = s + strlen(s); + if (*s == '$') check_img = 0; + if (filespec && (filespec < wordbreak)) isdcl = 0; + else isdcl = !check_img; + } + if (!isdcl) { - cmd = s; - while (*s && !isspace(*s)) s++; - rest = *s ? s : 0; - imgdsc.dsc$a_pointer = cmd; - imgdsc.dsc$w_length = s - cmd; + 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) { + 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); @@ -3401,10 +3497,7 @@ setup_cmddsc(char *cmd, int check_img) } /* 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; - PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */ - } + if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd; else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); if (!(retsts & 1)) { /* just hand off status values likely to be due to user error */ @@ -3975,6 +4068,27 @@ static long int utc_offset_secs; # define RTL_USES_UTC 1 #endif +/* + * DEC C previous to 6.0 corrupts the behavior of the /prefix + * qualifier with the extern prefix pragma. This provisional + * hack circumvents this prefix pragma problem in previous + * precompilers. + */ +#if defined(__VMS_VER) && __VMS_VER >= 70000000 +# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000) +# pragma __extern_prefix save +# pragma __extern_prefix "" /* set to empty to prevent prefixing */ +# define gmtime decc$__utctz_gmtime +# define localtime decc$__utctz_localtime +# define time decc$__utc_time +# pragma __extern_prefix restore + + struct tm *gmtime(), *localtime(); + +# endif +#endif + + static time_t toutc_dst(time_t loc) { struct tm *rsltmp; @@ -3983,7 +4097,7 @@ static time_t toutc_dst(time_t loc) { if (rsltmp->tm_isdst) loc -= 3600; return loc; } -#define _toutc(secs) ((secs) == -1 ? -1 : \ +#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ ((gmtime_emulation_type || my_time(NULL)), \ (gmtime_emulation_type == 1 ? toutc_dst(secs) : \ ((secs) - utc_offset_secs)))) @@ -3996,7 +4110,7 @@ static time_t toloc_dst(time_t utc) { if (rsltmp->tm_isdst) utc += 3600; return utc; } -#define _toloc(secs) ((secs) == -1 ? -1 : \ +#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ ((gmtime_emulation_type || my_time(NULL)), \ (gmtime_emulation_type == 1 ? toloc_dst(secs) : \ ((secs) + utc_offset_secs)))) @@ -4203,7 +4317,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); @@ -4249,6 +4363,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); @@ -4261,6 +4377,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); @@ -4285,6 +4403,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)) { @@ -4405,9 +4525,8 @@ is_null_device(name) /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a * subset of the applicable information. */ -/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/ -I32 -Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp) +bool +Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) { if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache); else { @@ -4440,9 +4559,9 @@ Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp) /*}}}*/ -/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/ +/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/ I32 -cando_by_name(I32 bit, I32 effective, char *fname) +cando_by_name(I32 bit, Uid_t effective, char *fname) { static char usrname[L_cuserid]; static struct dsc$descriptor_s usrdsc =