VMS stat fixes:
1. Allow null thread context.
2. First use VMS syntax for files and directories then fall back to Unix
syntax with EFS enabled.
3. When Unix syntax with EFS is used, EFS must also be used to store the
resultant filename.
4. fid_to_name() needs to use the same algorithm as stat() for consistency.
5. fid_to_name() followed by a flex_stat/flex_lstat call to see if this
is a directory is a waste of cycles.
Still more to come.
-John
wb8...@gmail.com
Personal Opinion Only
--- /ref1_root/perl/vms/vms.c Mon Jan 26 08:39:10 2009
+++ vms/vms.c Mon Jan 26 21:58:28 2009
@@ -2064,6 +2064,44 @@
} /* end of kill_file() */
/*}}}*/
+/* stat() and lstat() have some serious bugs that prevent them from */
+/* being directly called by perl in most cases. The flex_stat_int() */
+/* wrapper knows how to work around these bugs, bug requires a perl */
+/* context on a threaded perl, and we need to call it from places */
+/* with out a perl context */
+
+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)
+
+
+/* Version of flex_stat for internal use with out a Perl context */
+int
+int_flex_stat(const char *fspec, Stat_t *statbufp)
+{
+#if defined(PERL_IMPLICIT_CONTEXT)
+ pTHX;
+ aTHX = NULL;
+#endif
+ return flex_stat_int(fspec, statbufp, 0);
+}
+
+/* Version of flex_lstat for internal use with out a Perl context */
+int
+int_flex_lstat(const char *fspec, Stat_t *statbufp)
+{
+#if defined(PERL_IMPLICIT_CONTEXT)
+ pTHX;
+ aTHX = NULL;
+#endif
+ return flex_stat_int(fspec, statbufp, 1);
+}
+
+
+
+int vms_fid_to_name(char * outname, int outlen,
+ const char * name, int lstat_flag, mode_t * mode);
+
/*{{{int do_rmdir(char *name)*/
int
@@ -10361,7 +10399,7 @@
Stat_t statbuf;
int ret_sts;
- ret_sts = stat(buff, (stat_t *)&statbuf);
+ ret_sts = stat(buff, &statbuf.crtl_stat);
if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
e_len = 0;
e_spec[0] = 0;
@@ -12467,7 +12505,7 @@
if (vmsname[retlen-1] == ']'
|| vmsname[retlen-1] == '>'
|| vmsname[retlen-1] == ':'
- || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
+ || (!stat(vmsname, &st.crtl_stat) && S_ISDIR(st.st_mode))) {
if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
PerlMem_free(fileified);
@@ -12599,7 +12637,7 @@
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);
@@ -12669,24 +12707,39 @@
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;
statbufp->st_uid = 0x00010001;
statbufp->st_gid = 0x0001;
- time((time_t *)&statbufp->st_mtime);
+#if defined(PERL_IMPLICIT_CONTEXT)
+ /* If the context is null, this will access violate */
+ /* and stat() has so many issues we will may need to use this */
+ /* routine in places where we do not have a thread context */
+ /* In those cases we usually do not care about the time stamps */
+ if (aTHX != NULL) {
+#endif
+ time((time_t *)&statbufp->st_mtime);
+#if defined(PERL_IMPLICIT_CONTEXT)
+ } else {
+ statbufp->st_mtime = 0;
+ }
+#endif
statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
return 0;
}
@@ -12703,59 +12756,85 @@
* If we are in Posix filespec mode, accept the filename as is.
*/
+ 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);
-#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
+ 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
@@ -12774,13 +12853,35 @@
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;
VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
VMS_DEVICE_ENCODE
(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
+#if defined(PERL_IMPLICIT_CONTEXT)
+ /* If the context is null, this will access violate */
+ /* and stat() has so many issues we will may need to use this */
+ /* routine in places where we do not have a thread context */
+ /* In those cases we usually do not care about the time stamps */
+ if (aTHX != NULL) {
+#endif
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
@@ -12800,9 +12901,14 @@
statbufp->st_ctime = _toutc(statbufp->st_ctime);
}
# endif
+#if defined(PERL_IMPLICIT_CONTEXT)
+ }
+#endif
}
/* If we were successful, leave errno where we found it */
if (retval == 0) RESTORE_ERRNO;
+ PerlMem_free(fileified);
+ PerlMem_free(temp_fspec);
return retval;
} /* end of flex_stat_int() */
@@ -13994,6 +14100,7 @@
/* Hack, use old stat() as fastest way of getting ino_t and device */
int decc$stat(const char *name, void * statbuf);
+int decc$lstat(const char *name, void * statbuf);
/* Realpath is fragile. In 8.3 it does not work if the feature
@@ -14004,31 +14111,112 @@
* 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 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);
+ }
+ }
+ }
+
+ /* and then because the CRTL Unix to VMS conversion is not perfect */
+ /* Specifically the CRTL removes spaces and other illegal ODS-2 */
+ /* characters from filenames */
+ /* and sometimes names with illegal characters for ODS-2 volumes */
+ /* miss being converted, we need to try it as-is */
+ if (sts) {
+ /* 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
+ 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
+ }
- 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;
}
}
@@ -14058,12 +14246,13 @@
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) {
@@ -14088,11 +14277,26 @@
int haslower = 0;
const char *cp;
+ /* The result is expected to be in UNIX format */
+
/* Trim off the version */
int file_len = v_len + r_len + d_len + n_len + e_len;
vms_spec[file_len] = 0;
- /* The result is expected to be in UNIX format */
+ /* 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';
+ }
+
rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
/* Downcase if input had any lower case letters and
@@ -14182,7 +14386,7 @@
/* 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.
@@ -14215,7 +14419,7 @@
/* 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;
}
