X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a979ce91b3156b6065490e91b716d497fcb52adb..2e05a54c0c3f7ee3e0363f0309bb362649aa71c4:/vms/vms.c diff --git a/vms/vms.c b/vms/vms.c index 6c91af4..c3af096 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -219,6 +219,17 @@ return 0; # define RTL_USES_UTC 1 #endif +#if !defined(__VAX) && __CRTL_VER >= 80200000 +#ifdef lstat +#undef lstat +#endif +#else +#ifdef lstat +#undef lstat +#endif +#define lstat(_x, _y) stat(_x, _y) +#endif + /* Routine to create a decterm for use with the Perl debugger */ /* No headers, this information was found in the Programming Concepts Manual */ @@ -304,6 +315,7 @@ static char *int_tovmsspec (const char *path, char *buf, int dir_flag, int * utf8_flag); static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl); static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl); +static char * int_tovmspath(const char *path, char *buf, int * utf8_fl); /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ #define PERL_LNM_MAX_ALLOWED_INDEX 127 @@ -1046,7 +1058,7 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, #if defined(PERL_IMPLICIT_CONTEXT) if (aTHX == NULL) { fprintf(stderr, - "%%PERL-W-VMS_INIT Can't read CRTL environ\n"); + "Can't read CRTL environ\n"); } else #endif Perl_warn(aTHX_ "Can't read CRTL environ\n"); @@ -1086,7 +1098,7 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, #if defined(PERL_IMPLICIT_CONTEXT) if (aTHX == NULL) { fprintf(stderr, - "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm); + "Value of CLI symbol \"%s\" too long",lnm); } else #endif if (ckWARN(WARN_MISC)) { @@ -1817,6 +1829,11 @@ Perl_my_setenv(pTHX_ const char *lnm, const char *eqv) /* vmssetuserlnm * sets a user-mode logical in the process logical name table * used for redirection of sys$error + * + * Fix-me: The pTHX is not needed for this routine, however doio.c + * is calling it with one instead of using a macro. + * A macro needs to be added to vmsish.h and doio.c updated to use it. + * */ void Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv) @@ -2072,23 +2089,48 @@ Perl_do_rmdir(pTHX_ const char *name) int retval; Stat_t st; - dirfile = PerlMem_malloc(VMS_MAXRSS + 1); - if (dirfile == NULL) - _ckvmssts(SS$_INSFMEM); + /* lstat returns a VMS fileified specification of the name */ + /* that is looked up, and also lets verifies that this is a directory */ - /* Force to a directory specification */ - if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) { - PerlMem_free(dirfile); - return -1; + retval = flex_lstat(name, &st); + if (retval != 0) { + char * ret_spec; + + /* Due to a historical feature, flex_stat/lstat can not see some */ + /* Unix format file names that the rest of the CRTL can see */ + /* Fixing that feature will cause some perl tests to fail */ + /* So try this one more time. */ + + retval = lstat(name, &st.crtl_stat); + if (retval != 0) + return -1; + + /* force it to a file spec for the kill file to work. */ + ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL); + if (ret_spec == NULL) { + errno = EIO; + return -1; + } } - if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) { + + if (!S_ISDIR(st.st_mode)) { errno = ENOTDIR; retval = -1; } - else + else { + dirfile = st.st_devnam; + + /* It may be possible for flex_stat to find a file and vmsify() to */ + /* fail with ODS-2 specifications. mp_do_kill_file can not deal */ + /* with that case, so fail it */ + if (dirfile[0] == 0) { + errno = EIO; + return -1; + } + retval = mp_do_kill_file(aTHX_ dirfile, 1); + } - PerlMem_free(dirfile); return retval; } /* end of do_rmdir */ @@ -2106,21 +2148,66 @@ Perl_do_rmdir(pTHX_ const char *name) int Perl_kill_file(pTHX_ const char *name) { - char rspec[NAM$C_MAXRSS+1]; - char *tspec; + char * vmsfile; Stat_t st; int rmsts; - /* Remove() is allowed to delete directories, according to the X/Open - * specifications. - * This may need special handling to work with the ACL hacks. + /* Convert the filename to VMS format and see if it is a directory */ + /* flex_lstat returns a vmsified file specification */ + rmsts = flex_lstat(name, &st); + if (rmsts != 0) { + + /* Due to a historical feature, flex_stat/lstat can not see some */ + /* Unix format file names that the rest of the CRTL can see when */ + /* ODS-2 file specifications are in use. */ + /* Fixing that feature will cause some perl tests to fail */ + /* [.lib.ExtUtils.t]Manifest.t is one of them */ + st.st_mode = 0; + vmsfile = (char *) name; /* cast ok */ + + } else { + vmsfile = st.st_devnam; + if (vmsfile[0] == 0) { + /* It may be possible for flex_stat to find a file and vmsify() */ + /* to fail with ODS-2 specifications. mp_do_kill_file can not */ + /* deal with that case, so fail it */ + errno = EIO; + return -1; + } + } + + /* Remove() is allowed to delete directories, according to the X/Open + * specifications. + * This may need special handling to work with the ACL hacks. */ - if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) { - rmsts = Perl_do_rmdir(aTHX_ name); - return rmsts; + if (S_ISDIR(st.st_mode)) { + rmsts = mp_do_kill_file(aTHX_ vmsfile, 1); + return rmsts; } - rmsts = mp_do_kill_file(aTHX_ name, 0); + rmsts = mp_do_kill_file(aTHX_ vmsfile, 0); + + /* Need to delete all versions ? */ + if ((rmsts == 0) && (vms_unlink_all_versions == 1)) { + int i = 0; + + /* Just use lstat() here as do not need st_dev */ + /* and we know that the file is in VMS format or that */ + /* because of a historical bug, flex_stat can not see the file */ + while (lstat(vmsfile, (stat_t *)&st) == 0) { + rmsts = mp_do_kill_file(aTHX_ vmsfile, 0); + if (rmsts != 0) + break; + i++; + + /* Make sure that we do not loop forever */ + if (i > 32767) { + errno = EIO; + rmsts = -1; + break; + } + } + } return rmsts; @@ -2176,13 +2263,19 @@ Perl_my_chdir(pTHX_ const char *dir) * null file name/type. However, it's commonplace under Unix, * so we'll allow it for a gain in portability. * - * - Preview- '/' will be valid soon on VMS + * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active. */ if ((dirlen > 1) && (dir1[dirlen-1] == '/')) { - char *newdir = savepvn(dir1,dirlen-1); - int ret = chdir(newdir); - Safefree(newdir); - return ret; + char *newdir; + int ret; + newdir = PerlMem_malloc(dirlen); + if (newdir ==NULL) + _ckvmssts_noperl(SS$_INSFMEM); + strncpy(newdir, dir1, dirlen-1); + newdir[dirlen-1] = '\0'; + ret = chdir(newdir); + PerlMem_free(newdir); + return ret; } else return chdir(dir1); } /* end of my_chdir */ @@ -2193,6 +2286,9 @@ Perl_my_chdir(pTHX_ const char *dir) int Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode) { + Stat_t st; + int ret = -1; + char * changefile; STRLEN speclen = strlen(file_spec); /* zero length string sometimes gives ACCVIO */ @@ -2205,41 +2301,26 @@ Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode) * Tests are showing that chmod() on VMS 8.3 is only accepting directories * in VMS file.dir notation. */ - if ((speclen > 1) && (file_spec[speclen-1] == '/')) { - char *vms_src, *vms_dir, *rslt; - int ret = -1; - errno = EIO; - - /* First convert this to a VMS format specification */ - vms_src = PerlMem_malloc(VMS_MAXRSS); - if (vms_src == NULL) - _ckvmssts_noperl(SS$_INSFMEM); + changefile = (char *) file_spec; /* cast ok */ + ret = flex_lstat(file_spec, &st); + if (ret != 0) { - rslt = do_tovmsspec(file_spec, vms_src, 0, NULL); - if (rslt == NULL) { - /* If we fail, then not a file specification */ - PerlMem_free(vms_src); - errno = EIO; - return -1; - } + /* Due to a historical feature, flex_stat/lstat can not see some */ + /* Unix format file names that the rest of the CRTL can see when */ + /* ODS-2 file specifications are in use. */ + /* Fixing that feature will cause some perl tests to fail */ + /* [.lib.ExtUtils.t]Manifest.t is one of them */ + st.st_mode = 0; - /* Now make it a directory spec so chmod is happy */ - vms_dir = PerlMem_malloc(VMS_MAXRSS + 1); - if (vms_dir == NULL) - _ckvmssts_noperl(SS$_INSFMEM); - rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL); - PerlMem_free(vms_src); - - /* Now do it */ - if (rslt != NULL) { - ret = chmod(vms_dir, mode); - } else { - errno = EIO; - } - PerlMem_free(vms_dir); - return ret; + } else { + /* It may be possible to get here with nothing in st_devname */ + /* chmod still may work though */ + if (st.st_devnam[0] != 0) { + changefile = st.st_devnam; + } } - else return chmod(file_spec, mode); + ret = chmod(changefile, mode); + return ret; } /* end of my_chmod */ /*}}}*/ @@ -3899,14 +3980,14 @@ vmspipe_tempfile(pTHX) fsync(fileno(fp)); fgetname(fp, file, 1); - fstat(fileno(fp), (struct stat *)&s0); + fstat(fileno(fp), &s0.crtl_stat); fclose(fp); if (decc_filename_unix_only) int_tounixspec(file, file, NULL); fp = fopen(file,"r","shr=get"); if (!fp) return 0; - fstat(fileno(fp), (struct stat *)&s1); + fstat(fileno(fp), &s1.crtl_stat); cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino); if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) { @@ -4219,6 +4300,12 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) if (*in_mode == 'r') { PerlIO * xterm_fd; +#if defined(PERL_IMPLICIT_CONTEXT) + /* Can not fork an xterm with a NULL context */ + /* This probably could never happen */ + xterm_fd = NULL; + if (aTHX != NULL) +#endif xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode); if (xterm_fd != NULL) return xterm_fd; @@ -4994,12 +5081,6 @@ static int rms_erase(const char * vmsname) rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */ rms_bind_fab_nam(myfab, mynam); - /* Are we removing all versions? */ - if (vms_unlink_all_versions == 1) { - const char * defspec = ";*"; - rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */ - } - #ifdef NAML$M_OPEN_SPECIAL rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL); #endif @@ -5196,6 +5277,11 @@ Stat_t dst_st; /* No source file or other problem */ return src_sts; } + if (src_st.st_devnam[0] == 0) { + /* This may be possible so fail if it is seen. */ + errno = EIO; + return -1; + } dst_sts = flex_lstat(dst, &dst_st); if (dst_sts == 0) { @@ -5241,7 +5327,28 @@ Stat_t dst_st; if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) { int d_sts; - d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode)); + d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, + S_ISDIR(dst_st.st_mode)); + + /* Need to delete all versions ? */ + if ((d_sts == 0) && (vms_unlink_all_versions == 1)) { + int i = 0; + + while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) { + d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0); + if (d_sts != 0) + break; + i++; + + /* Make sure that we do not loop forever */ + if (i > 32767) { + errno = EIO; + d_sts = -1; + break; + } + } + } + if (d_sts != 0) return d_sts; @@ -5262,7 +5369,6 @@ Stat_t dst_st; /* if the source is a directory, then need to fileify */ /* and dest must be a directory or non-existant. */ - char * vms_src; char * vms_dst; int sts; char * ret_str; @@ -5274,18 +5380,6 @@ Stat_t dst_st; * on if one or more of them are directories. */ - vms_src = PerlMem_malloc(VMS_MAXRSS); - if (vms_src == NULL) - _ckvmssts_noperl(SS$_INSFMEM); - - /* Source is always a VMS format file */ - ret_str = do_tovmsspec(src, vms_src, 0, NULL); - if (ret_str == NULL) { - PerlMem_free(vms_src); - errno = EIO; - return -1; - } - vms_dst = PerlMem_malloc(VMS_MAXRSS); if (vms_dst == NULL) _ckvmssts_noperl(SS$_INSFMEM); @@ -5298,24 +5392,11 @@ Stat_t dst_st; if (vms_dir_file == NULL) _ckvmssts_noperl(SS$_INSFMEM); - /* The source must be a file specification */ - ret_str = int_fileify_dirspec(vms_src, vms_dir_file, NULL); - if (ret_str == NULL) { - PerlMem_free(vms_src); - PerlMem_free(vms_dst); - PerlMem_free(vms_dir_file); - errno = EIO; - return -1; - } - PerlMem_free(vms_src); - vms_src = vms_dir_file; - /* If the dest is a directory, we must remove it if (dst_sts == 0) { int d_sts; - d_sts = mp_do_kill_file(aTHX_ dst, 1); + d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1); if (d_sts != 0) { - PerlMem_free(vms_src); PerlMem_free(vms_dst); errno = EIO; return sts; @@ -5327,7 +5408,6 @@ Stat_t dst_st; /* The dest must be a VMS file specification */ ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); if (ret_str == NULL) { - PerlMem_free(vms_src); PerlMem_free(vms_dst); errno = EIO; return -1; @@ -5340,7 +5420,6 @@ Stat_t dst_st; ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL); if (ret_str == NULL) { - PerlMem_free(vms_src); PerlMem_free(vms_dst); PerlMem_free(vms_dir_file); errno = EIO; @@ -5354,28 +5433,44 @@ Stat_t dst_st; if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) { /* VMS pathify a dir target */ - ret_str = do_tovmspath(dst, vms_dst, 0, NULL); + ret_str = int_tovmspath(dst, vms_dst, NULL); if (ret_str == NULL) { - PerlMem_free(vms_src); PerlMem_free(vms_dst); errno = EIO; return -1; } } else { + char * v_spec, * r_spec, * d_spec, * n_spec; + char * e_spec, * vs_spec; + int sts, v_len, r_len, d_len, n_len, e_len, vs_len; /* fileify a target VMS file specification */ ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); if (ret_str == NULL) { - PerlMem_free(vms_src); PerlMem_free(vms_dst); errno = EIO; return -1; } + + sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len, + &d_spec, &d_len, &n_spec, &n_len, &e_spec, + &e_len, &vs_spec, &vs_len); + if (sts == 0) { + if (e_len == 0) { + /* Get rid of the version */ + if (vs_len != 0) { + *vs_spec = '\0'; + } + /* Need to specify a '.' so that the extension */ + /* is not inherited */ + strcat(vms_dst,"."); + } + } } } - old_file_dsc.dsc$a_pointer = vms_src; - old_file_dsc.dsc$w_length = strlen(vms_src); + old_file_dsc.dsc$a_pointer = src_st.st_devnam; + old_file_dsc.dsc$w_length = strlen(src_st.st_devnam); old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; old_file_dsc.dsc$b_class = DSC$K_CLASS_S; @@ -5403,7 +5498,6 @@ Stat_t dst_st; sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags); } - PerlMem_free(vms_src); PerlMem_free(vms_dst); if (!$VMS_STATUS_SUCCESS(sts)) { errno = EIO; @@ -5416,10 +5510,25 @@ Stat_t dst_st; /* Now get rid of any previous versions of the source file that * might still exist */ - int save_errno; - save_errno = errno; - src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode)); - errno = save_errno; + int i = 0; + dSAVEDERRNO; + SAVE_ERRNO; + src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam, + S_ISDIR(src_st.st_mode)); + while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) { + src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam, + S_ISDIR(src_st.st_mode)); + if (src_sts != 0) + break; + i++; + + /* Make sure that we do not loop forever */ + if (i > 32767) { + src_sts = -1; + break; + } + } + RESTORE_ERRNO; } /* We deleted the destination, so must force the error to be EIO */ @@ -5516,6 +5625,8 @@ int_rmsexpand if ((opts & PERL_RMSEXPAND_M_VMS) == 0) #if !defined(__VAX) && defined(NAML$C_MAXRSS) opts |= PERL_RMSEXPAND_M_LONG; +#else + NOOP; #endif else isunix = 0; @@ -5641,6 +5752,7 @@ int_expanded: /* Is a long or a short name expected */ /*------------------------------------*/ spec_buf = NULL; +#if !defined(__VAX) && defined(NAML$C_MAXRSS) if ((opts & PERL_RMSEXPAND_M_LONG) != 0) { if (rms_nam_rsll(mynam)) { spec_buf = outbufl; @@ -5652,6 +5764,7 @@ int_expanded: } } else { +#endif if (rms_nam_rsl(mynam)) { spec_buf = outbuf; speclen = rms_nam_rsl(mynam); @@ -5660,7 +5773,9 @@ int_expanded: spec_buf = esa; /* Not esal */ speclen = rms_nam_esl(mynam); } +#if !defined(__VAX) && defined(NAML$C_MAXRSS) } +#endif spec_buf[speclen] = '\0'; /* Trim off null fields added by $PARSE @@ -6335,13 +6450,17 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) } /* Make sure we are using the right buffer */ +#if !defined(__VAX) && defined(NAML$C_MAXRSS) if (esal != NULL) { my_esa = esal; my_esa_len = rms_nam_esll(dirnam); } else { +#endif my_esa = esa; my_esa_len = rms_nam_esl(dirnam); +#if !defined(__VAX) && defined(NAML$C_MAXRSS) } +#endif my_esa[my_esa_len] = '\0'; if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) { cp1 = strchr(my_esa,']'); @@ -7227,7 +7346,7 @@ static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl) } if (*cp2 == ':') { *(cp1++) = '/'; - if (*(cp2+1) == '[') cp2++; + if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++; } else if (*cp2 == ']' || *cp2 == '>') { if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */ @@ -8112,7 +8231,7 @@ int sts, v_len, r_len, d_len, n_len, e_len, vs_len; * special device files. */ - if ((add_6zero == 0) && (*nextslash == '/') && + if (!islnm && (add_6zero == 0) && (*nextslash == '/') && (&nextslash[1] == unixend)) { /* No real directory present */ add_6zero = 1; @@ -8372,7 +8491,7 @@ int sts, v_len, r_len, d_len, n_len, e_len, vs_len; vmsptr2 = vmsptr - 1; if ((vmslen > 1) && (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') && - (*vmsptr2 != ')') && (*lastdot != '.')) { + (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) { *vmsptr++ = '.'; vmslen++; } @@ -8558,7 +8677,7 @@ static char *int_tovmsspec } } -/* If POSIX mode active, handle the conversion */ +/* If EFS charset mode active, handle the conversion */ #if __CRTL_VER >= 80200000 && !defined(__VAX) if (decc_efs_charset) { posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag); @@ -8935,6 +9054,33 @@ char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl) char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl) { return do_tovmsspec(path,buf,1,utf8_fl); } +/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/ +/* Internal routine for use with out an explict context present */ +static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) { + + char * ret_spec, *pathified; + + if (path == NULL) + return NULL; + + pathified = PerlMem_malloc(VMS_MAXRSS); + if (pathified == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + ret_spec = int_pathify_dirspec(path, pathified); + + if (ret_spec == NULL) { + PerlMem_free(pathified); + return NULL; + } + + ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl); + + PerlMem_free(pathified); + return ret_spec; + +} + /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/ static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) { static char __tovmspath_retbuf[VMS_MAXRSS]; @@ -9272,7 +9418,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) /* Input from a pipe, reopen it in binary mode to disable */ /* carriage control processing. */ - fgetname(stdin, mbxname); + fgetname(stdin, mbxname, 1); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); @@ -9650,6 +9796,7 @@ vms_image_init(int *argcp, char ***argvp) Perl_csighandler_init(); #endif +#if __CRTL_VER >= 70300000 && !defined(__VAX) /* This was moved from the pre-image init handler because on threaded */ /* Perl it was always returning 0 for the default value. */ status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH); @@ -9679,7 +9826,7 @@ vms_image_init(int *argcp, char ***argvp) } } } - +#endif _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); _ckvmssts_noperl(iosb[0]); @@ -10106,7 +10253,7 @@ Perl_opendir(pTHX_ const char *name) Stat_t sb; Newx(dir, VMS_MAXRSS, char); - if (do_tovmspath(name,dir,0,NULL) == NULL) { + if (int_tovmspath(name, dir, NULL) == NULL) { Safefree(dir); return NULL; } @@ -10326,18 +10473,14 @@ Perl_readdir(pTHX_ DIR *dd) /* In Unix report mode, remove the ".dir;1" from the name */ /* if it is a real directory. */ if (decc_filename_unix_report || decc_efs_charset) { - if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) { - if ((toupper(e_spec[1]) == 'D') && - (toupper(e_spec[2]) == 'I') && - (toupper(e_spec[3]) == 'R')) { - Stat_t statbuf; - int ret_sts; - - ret_sts = stat(buff, (stat_t *)&statbuf); - if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) { - e_len = 0; - e_spec[0] = 0; - } + if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) { + Stat_t statbuf; + int ret_sts; + + ret_sts = flex_lstat(buff, &statbuf); + if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) { + e_len = 0; + e_spec[0] = 0; } } } @@ -11106,7 +11249,7 @@ FILE *my_fdopen(int fd, const char *mode) memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize); sockflagsize = fdoff + 2; } - if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode)) + if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode)) sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int)); } return fp; @@ -11146,7 +11289,8 @@ int my_fclose(FILE *fp) { int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest) { - register char *cp, *end, *cpd, *data; + register char *cp, *end, *cpd; + char *data; register unsigned int fd = fileno(dest); register unsigned int fdoff = fd / sizeof(unsigned int); int retval; @@ -11203,6 +11347,34 @@ Perl_my_flush(pTHX_ FILE *fp) } /*}}}*/ +/* fgetname() is not returning the correct file specifications when + * decc_filename_unix_report mode is active. So we have to have it + * aways return filenames in VMS mode and convert it ourselves. + */ + +/*{{{ char * my_fgetname(FILE *fp, buf)*/ +char * +Perl_my_fgetname(FILE *fp, char * buf) { + char * retname; + char * vms_name; + + retname = fgetname(fp, buf, 1); + + /* If we are in VMS mode, then we are done */ + if (!decc_filename_unix_report || (retname == NULL)) { + return retname; + } + + /* Convert this to Unix format */ + vms_name = PerlMem_malloc(VMS_MAXRSS + 1); + strcpy(vms_name, retname); + retname = int_tounixspec(vms_name, buf, NULL); + PerlMem_free(vms_name); + + return retname; +} +/*}}}*/ + /* * Here are replacements for the following Unix routines in the VMS environment: * getpwuid Get information for a particular UIC or UID @@ -12376,6 +12548,10 @@ is_null_device(name) return (*name++ == ':') && (*name != ':'); } +static int +Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag); + +#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c) static I32 Perl_cando_by_name_int @@ -12431,15 +12607,15 @@ Perl_cando_by_name_int } /* sys$check_access needs a file spec, not a directory spec. - * Don't use flex_stat here, as that depends on thread context - * having been initialized, and we may get here during startup. + * flex_stat now will handle a null thread context during startup. */ retlen = namdsc.dsc$w_length = strlen(vmsname); if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' || vmsname[retlen-1] == ':' - || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) { + || (!flex_stat_int(vmsname, &st, 1) && + S_ISDIR(st.st_mode))) { if (!int_fileify_dirspec(vmsname, fileified, NULL)) { PerlMem_free(fileified); @@ -12571,7 +12747,7 @@ Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname) int Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) { - if (!fstat(fd,(stat_t *) statbufp)) { + if (!fstat(fd, &statbufp->crtl_stat)) { char *cptr; char *vms_filename; vms_filename = PerlMem_malloc(VMS_MAXRSS); @@ -12625,34 +12801,24 @@ Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) } /* end of flex_fstat() */ /*}}}*/ -#if !defined(__VAX) && __CRTL_VER >= 80200000 -#ifdef lstat -#undef lstat -#endif -#else -#ifdef lstat -#undef lstat -#endif -#define lstat(_x, _y) stat(_x, _y) -#endif - -#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c) - static int Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) { - char fileified[VMS_MAXRSS]; - char temp_fspec[VMS_MAXRSS]; - char *save_spec; + char *fileified; + char *temp_fspec; + const char *save_spec; + char *ret_spec; int retval = -1; + int efs_hack = 0; dSAVEDERRNO; - if (!fspec) return retval; - SAVE_ERRNO; - strcpy(temp_fspec, fspec); + if (!fspec) { + errno = EINVAL; + return retval; + } if (decc_bug_devnull != 0) { - if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */ + if (is_null_device(fspec)) { /* Fake a stat() for the null device */ memset(statbufp,0,sizeof *statbufp); VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0); statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; @@ -12676,58 +12842,86 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) */ -#if __CRTL_VER >= 70300000 && !defined(__VAX) - /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless - * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already. - */ - if (!decc_efs_charset) - decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1); -#endif + fileified = PerlMem_malloc(VMS_MAXRSS); + if (fileified == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + temp_fspec = PerlMem_malloc(VMS_MAXRSS); + if (temp_fspec == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + strcpy(temp_fspec, fspec); + + SAVE_ERRNO; #if __CRTL_VER >= 80200000 && !defined(__VAX) if (decc_posix_compliant_pathnames == 0) { #endif - if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) { - if (lstat_flag == 0) - retval = stat(fileified,(stat_t *) statbufp); - else - retval = lstat(fileified,(stat_t *) statbufp); - save_spec = fileified; + + /* We may be able to optimize this, but in order for fileify_dirspec to + * always return a usuable answer, we have to call vmspath first to + * make sure that it is in VMS directory format, as stat/lstat on 8.3 + * can not handle directories in unix format that it does not have read + * access to. Vmspath handles the case where a bare name which could be + * a logical name gets passed. + */ + ret_spec = int_tovmspath(fspec, temp_fspec, NULL); + if (ret_spec != NULL) { + ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL); + if (ret_spec != NULL) { + if (lstat_flag == 0) + retval = stat(fileified, &statbufp->crtl_stat); + else + retval = lstat(fileified, &statbufp->crtl_stat); + save_spec = fileified; + } } - if (retval) { - if (lstat_flag == 0) - retval = stat(temp_fspec,(stat_t *) statbufp); - else - retval = lstat(temp_fspec,(stat_t *) statbufp); - save_spec = temp_fspec; + + if (retval && vms_bug_stat_filename) { + + /* We should try again as a vmsified file specification */ + /* However Perl traditionally has not done this, which */ + /* causes problems with existing tests */ + + ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL); + if (ret_spec != NULL) { + if (lstat_flag == 0) + retval = stat(temp_fspec, &statbufp->crtl_stat); + else + retval = lstat(temp_fspec, &statbufp->crtl_stat); + save_spec = temp_fspec; + } } -/* - * In debugging, on 8.3 Alpha, I found a case where stat was returning a - * file not found error for a directory named foo:[bar.t] or /foo/bar/t - * and lstat was working correctly for the same file. - * The only syntax that was working for stat was "foo:[bar]t.dir". - * - * Other directories with the same syntax worked fine. - * So work around the problem when it shows up here. - */ + if (retval) { - int save_errno = errno; - if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) { - if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) { - retval = stat(fileified, (stat_t *) statbufp); - save_spec = fileified; - } - } - /* Restore the errno value if third stat does not succeed */ - if (retval != 0) - errno = save_errno; + /* Last chance - allow multiple dots with out EFS CHARSET */ + /* The CRTL stat() falls down hard on multi-dot filenames in unix + * format unless * DECC$EFS_CHARSET is in effect, so temporarily + * enable it if it isn't already. + */ +#if __CRTL_VER >= 70300000 && !defined(__VAX) + if (!decc_efs_charset && (decc_efs_charset_index > 0)) + decc$feature_set_value(decc_efs_charset_index, 1, 1); +#endif + if (lstat_flag == 0) + retval = stat(fspec, &statbufp->crtl_stat); + else + retval = lstat(fspec, &statbufp->crtl_stat); + save_spec = fspec; +#if __CRTL_VER >= 70300000 && !defined(__VAX) + if (!decc_efs_charset && (decc_efs_charset_index > 0)) { + decc$feature_set_value(decc_efs_charset_index, 1, 0); + efs_hack = 1; + } +#endif } + #if __CRTL_VER >= 80200000 && !defined(__VAX) } else { if (lstat_flag == 0) - retval = stat(temp_fspec,(stat_t *) statbufp); + retval = stat(temp_fspec, &statbufp->crtl_stat); else - retval = lstat(temp_fspec,(stat_t *) statbufp); + retval = lstat(temp_fspec, &statbufp->crtl_stat); save_spec = temp_fspec; } #endif @@ -12746,7 +12940,22 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) if (lstat_flag) rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK; +#if __CRTL_VER >= 70300000 && !defined(__VAX) + /* If we used the efs_hack above, we must also use it here for */ + /* perl_cando to work */ + if (efs_hack && (decc_efs_charset_index > 0)) { + decc$feature_set_value(decc_efs_charset_index, 1, 1); + } +#endif cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags); +#if __CRTL_VER >= 70300000 && !defined(__VAX) + if (efs_hack && (decc_efs_charset_index > 0)) { + decc$feature_set_value(decc_efs_charset, 1, 0); + } +#endif + + /* Fix me: If this is NULL then stat found a file, and we could */ + /* not convert the specification to VMS - Should never happen */ if (cptr == NULL) statbufp->st_devnam[0] = 0; @@ -13362,7 +13571,7 @@ rmscopy_fromperl(pTHX_ CV *cv) if (SvTYPE(mysv) == SVt_PVGV) { if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); - ST(0) = &PL_sv_no; + ST(0) = sv_2mortal(newSViv(0)); Safefree(inspec); XSRETURN(1); } @@ -13371,7 +13580,7 @@ rmscopy_fromperl(pTHX_ CV *cv) else { if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); - ST(0) = &PL_sv_no; + ST(0) = sv_2mortal(newSViv(0)); Safefree(inspec); XSRETURN(1); } @@ -13381,7 +13590,7 @@ rmscopy_fromperl(pTHX_ CV *cv) if (SvTYPE(mysv) == SVt_PVGV) { if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); - ST(0) = &PL_sv_no; + ST(0) = sv_2mortal(newSViv(0)); Safefree(inspec); Safefree(outspec); XSRETURN(1); @@ -13391,7 +13600,7 @@ rmscopy_fromperl(pTHX_ CV *cv) else { if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); - ST(0) = &PL_sv_no; + ST(0) = sv_2mortal(newSViv(0)); Safefree(inspec); Safefree(outspec); XSRETURN(1); @@ -13399,7 +13608,7 @@ rmscopy_fromperl(pTHX_ CV *cv) } date_flag = (items == 3) ? SvIV(ST(2)) : 0; - ST(0) = boolSV(rmscopy(inp,outp,date_flag)); + ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag))); Safefree(inspec); Safefree(outspec); XSRETURN(1); @@ -13862,7 +14071,7 @@ int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) { /* As symbolic links can hold things other than files, we will only do */ /* the conversion in in ODS-2 mode */ - Newx(utarget, VMS_MAXRSS + 1, char); + utarget = PerlMem_malloc(VMS_MAXRSS + 1); if (int_tounixspec(contents, utarget, NULL) == NULL) { /* This should not fail, as an untranslatable filename */ @@ -13870,7 +14079,7 @@ int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) { utarget = (char *)contents; } sts = symlink(utarget, link_name); - Safefree(utarget); + PerlMem_free(utarget); return sts; } @@ -13966,6 +14175,11 @@ char *realpath(const char *file_name, char * resolved_name, ...); /* Hack, use old stat() as fastest way of getting ino_t and device */ int decc$stat(const char *name, void * statbuf); +#if !defined(__VAX) && __CRTL_VER >= 80200000 +int decc$lstat(const char *name, void * statbuf); +#else +#define decc$lstat decc$stat +#endif /* Realpath is fragile. In 8.3 it does not work if the feature @@ -13976,31 +14190,119 @@ int decc$stat(const char *name, void * statbuf); * fall back to looking up the filename by the device name and FID. */ -int vms_fid_to_name(char * outname, int outlen, const char * name) +int vms_fid_to_name(char * outname, int outlen, + const char * name, int lstat_flag, mode_t * mode) { +#pragma message save +#pragma message disable MISALGNDSTRCT +#pragma message disable MISALGNDMEM +#pragma member_alignment save +#pragma nomember_alignment struct statbuf_t { char * st_dev; unsigned short st_ino[3]; - unsigned short padw; + unsigned short old_st_mode; unsigned long padl[30]; /* plenty of room */ } statbuf; -int sts; -struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; -struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; +#pragma message restore +#pragma member_alignment restore + + int sts; + struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + char *fileified; + char *temp_fspec; + char *ret_spec; + + /* Need to follow the mostly the same rules as flex_stat_int, or we may get + * unexpected answers + */ + + fileified = PerlMem_malloc(VMS_MAXRSS); + if (fileified == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + temp_fspec = PerlMem_malloc(VMS_MAXRSS); + if (temp_fspec == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + sts = -1; + /* First need to try as a directory */ + ret_spec = int_tovmspath(name, temp_fspec, NULL); + if (ret_spec != NULL) { + ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL); + if (ret_spec != NULL) { + if (lstat_flag == 0) + sts = decc$stat(fileified, &statbuf); + else + sts = decc$lstat(fileified, &statbuf); + } + } + + /* Then as a VMS file spec */ + if (sts != 0) { + ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL); + if (ret_spec != NULL) { + if (lstat_flag == 0) { + sts = decc$stat(temp_fspec, &statbuf); + } else { + sts = decc$lstat(temp_fspec, &statbuf); + } + } + } + + if (sts) { + /* Next try - allow multiple dots with out EFS CHARSET */ + /* The CRTL stat() falls down hard on multi-dot filenames in unix + * format unless * DECC$EFS_CHARSET is in effect, so temporarily + * enable it if it isn't already. + */ +#if __CRTL_VER >= 70300000 && !defined(__VAX) + if (!decc_efs_charset && (decc_efs_charset_index > 0)) + decc$feature_set_value(decc_efs_charset_index, 1, 1); +#endif + ret_spec = int_tovmspath(name, temp_fspec, NULL); + if (lstat_flag == 0) { + sts = decc$stat(name, &statbuf); + } else { + sts = decc$lstat(name, &statbuf); + } +#if __CRTL_VER >= 70300000 && !defined(__VAX) + if (!decc_efs_charset && (decc_efs_charset_index > 0)) + decc$feature_set_value(decc_efs_charset_index, 1, 0); +#endif + } + + + /* and then because the Perl Unix to VMS conversion is not perfect */ + /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */ + /* characters from filenames so we need to try it as-is */ + if (sts) { + if (lstat_flag == 0) { + sts = decc$stat(name, &statbuf); + } else { + sts = decc$lstat(name, &statbuf); + } + } - sts = decc$stat(name, &statbuf); if (sts == 0) { + int vms_sts; dvidsc.dsc$a_pointer=statbuf.st_dev; - dvidsc.dsc$w_length=strlen(statbuf.st_dev); + dvidsc.dsc$w_length=strlen(statbuf.st_dev); specdsc.dsc$a_pointer = outname; specdsc.dsc$w_length = outlen-1; - sts = lib$fid_to_name + vms_sts = lib$fid_to_name (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length); - if ($VMS_STATUS_SUCCESS(sts)) { + if ($VMS_STATUS_SUCCESS(vms_sts)) { outname[specdsc.dsc$w_length] = 0; + + /* Return the mode */ + if (mode) { + *mode = statbuf.old_st_mode; + } return 0; } } @@ -14030,12 +14332,13 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; int sts, v_len, r_len, d_len, n_len, e_len, vs_len; int file_len; + mode_t my_mode; /* Fall back to fid_to_name */ Newx(vms_spec, VMS_MAXRSS + 1, char); - sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec); + sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode); if (sts == 0) { @@ -14064,6 +14367,20 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int file_len = v_len + r_len + d_len + n_len + e_len; vms_spec[file_len] = 0; + /* Trim off the .DIR if this is a directory */ + if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) { + if (S_ISDIR(my_mode)) { + e_len = 0; + e_spec[0] = 0; + } + } + + /* Drop NULL extensions on UNIX file specification */ + if ((e_len == 1) && decc_readdir_dropdotnotype) { + e_len = 0; + e_spec[0] = '\0'; + } + /* The result is expected to be in UNIX format */ rslt = int_tounixspec(vms_spec, outbuf, utf8_fl); @@ -14154,7 +14471,7 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, /* Need realpath for the directory */ sts = vms_fid_to_name(vms_dir_name, VMS_MAXRSS + 1, - dir_name); + dir_name, 0, NULL); if (sts == 0) { /* Now need to pathify it. @@ -14187,7 +14504,7 @@ mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf, /* Fall back to fid_to_name */ - sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec); + sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL); if (sts != 0) { return NULL; }