+
+/* 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
+ * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
+ * links are implemented in RMS, not the CRTL. It also can fail if the
+ * user does not have read/execute access to some of the directories.
+ * So in order for Do What I Mean mode to work, if realpath() fails,
+ * 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 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 old_st_mode;
+ unsigned long padl[30]; /* plenty of room */
+} statbuf;
+#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);
+ }
+ }
+
+ if (sts == 0) {
+ int vms_sts;
+
+ dvidsc.dsc$a_pointer=statbuf.st_dev;
+ dvidsc.dsc$w_length=strlen(statbuf.st_dev);
+
+ specdsc.dsc$a_pointer = outname;
+ specdsc.dsc$w_length = outlen-1;
+
+ vms_sts = lib$fid_to_name
+ (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
+ if ($VMS_STATUS_SUCCESS(vms_sts)) {
+ outname[specdsc.dsc$w_length] = 0;
+
+ /* Return the mode */
+ if (mode) {
+ *mode = statbuf.old_st_mode;
+ }
+ return 0;
+ }
+ }
+ return sts;
+}
+
+
+
+static char *
+mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
+ int *utf8_fl)
+{
+ char * rslt = NULL;
+
+#ifdef HAS_SYMLINK
+ if (decc_posix_compliant_pathnames > 0 ) {
+ /* realpath currently only works if posix compliant pathnames are
+ * enabled. It may start working when they are not, but in that
+ * case we still want the fallback behavior for backwards compatibility
+ */
+ rslt = realpath(filespec, outbuf);
+ }
+#endif
+
+ if (rslt == NULL) {
+ char * vms_spec;
+ 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, 0, &my_mode);
+ if (sts == 0) {
+
+
+ /* Now need to trim the version off */
+ sts = vms_split_path
+ (vms_spec,
+ &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) {
+ int haslower = 0;
+ const char *cp;
+
+ /* Trim off the version */
+ 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);
+
+ /* Downcase if input had any lower case letters and
+ * case preservation is not in effect.
+ */
+ if (!decc_efs_case_preserve) {
+ for (cp = filespec; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
+
+ if (haslower) __mystrtolower(rslt);
+ }
+ }
+ } else {
+
+ /* Now for some hacks to deal with backwards and forward */
+ /* compatibilty */
+ if (!decc_efs_charset) {
+
+ /* 1. ODS-2 mode wants to do a syntax only translation */
+ rslt = int_rmsexpand(filespec, outbuf,
+ NULL, 0, NULL, utf8_fl);
+
+ } else {
+ if (decc_filename_unix_report) {
+ char * dir_name;
+ char * vms_dir_name;
+ char * file_name;
+
+ /* 2. ODS-5 / UNIX report mode should return a failure */
+ /* if the parent directory also does not exist */
+ /* Otherwise, get the real path for the parent */
+ /* and add the child to it.
+
+ /* basename / dirname only available for VMS 7.0+ */
+ /* So we may need to implement them as common routines */
+
+ Newx(dir_name, VMS_MAXRSS + 1, char);
+ Newx(vms_dir_name, VMS_MAXRSS + 1, char);
+ dir_name[0] = '\0';
+ file_name = NULL;
+
+ /* First try a VMS parse */
+ sts = vms_split_path
+ (filespec,
+ &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) {
+ /* This is VMS */
+
+ int dir_len = v_len + r_len + d_len + n_len;
+ if (dir_len > 0) {
+ strncpy(dir_name, filespec, dir_len);
+ dir_name[dir_len] = '\0';
+ file_name = (char *)&filespec[dir_len + 1];
+ }
+ } else {
+ /* This must be UNIX */
+ char * tchar;
+
+ tchar = strrchr(filespec, '/');
+
+ if (tchar != NULL) {
+ int dir_len = tchar - filespec;
+ strncpy(dir_name, filespec, dir_len);
+ dir_name[dir_len] = '\0';
+ file_name = (char *) &filespec[dir_len + 1];
+ }
+ }
+
+ /* Dir name is defaulted */
+ if (dir_name[0] == 0) {
+ dir_name[0] = '.';
+ dir_name[1] = '\0';
+ }
+
+ /* Need realpath for the directory */
+ sts = vms_fid_to_name(vms_dir_name,
+ VMS_MAXRSS + 1,
+ dir_name, 0, NULL);
+
+ if (sts == 0) {
+ /* Now need to pathify it.
+ char *tdir = int_pathify_dirspec(vms_dir_name,
+ outbuf);
+
+ /* And now add the original filespec to it */
+ if (file_name != NULL) {
+ strcat(outbuf, file_name);
+ }
+ return outbuf;
+ }
+ Safefree(vms_dir_name);
+ Safefree(dir_name);
+ }
+ }
+ }
+ Safefree(vms_spec);
+ }
+ return rslt;
+}
+