[patch@32376] VMS symbolic links part 4 of 4 - Final part

	From: "John E. Malmberg" <wb8tyw@qsl.net>
	Message-id: <473FF49A.5000302@qsl.net>

[.vms...] parts with revisions to compile on older systems and some
POD clean-up.

p4raw-id: //depot/perl@32474

3 files changed, 202 insertions, 26 deletions

diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm
index e0a179b12d..842e7784fb 100644
--- a/vms/ext/Filespec.pm
+++ b/vms/ext/Filespec.pm
@@ -3,7 +3,7 @@
 #
 #   Version:  see $VERSION below
 #   Author:   Charles Bailey  bailey@newman.upenn.edu
-#   Revised:  08-Mar-1995
+#   Revised:  30-Oct-2007
 
 =head1 NAME
 
@@ -20,6 +20,9 @@ $dirfile = fileify('my:[VMS.or.Unix.directory.specification]');
 $vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir');
 $unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir');
 candelete('my:[VMS.or.Unix]file.specification');
+$case_tolerant = vms_case_tolerant;
+$unixspec = vms_realpath('file_specification');
+$vmsspec = vms_realname('file_specification');
 
 =head1 DESCRIPTION
 
@@ -72,13 +75,81 @@ file specification or the default specification passed to C<rmsexpand>.
 as possible.)  If an error occurs, returns C<undef> and sets C<$!>
 and C<$^E>.
 
+C<rmsexpand> on success will produce a name that fits in a 255 byte buffer,
+which is required for parameters passed to the DCL interpreter.
+
 =head2 vmsify
 
-Converts a file specification to VMS syntax.
+Converts a file specification to VMS syntax.  If the file specification
+cannot be converted to or is already in VMS syntax, it will be
+passed through unchanged.
+
+The file specifications of C<.> and C<..> will be converted to
+C<[]> and C<[-]>.
+
+If the file specification is already in a valid VMS syntax, it will
+be passed through unchanged, except that the UTF-8 flag will be cleared
+since VMS format file specifications are never in UTF-8.
+
+When Perl is running on an OpenVMS system, if the C<DECC$EFS_CHARSET>
+feature is not enabled, extra dots in the file specification will
+be converted to underscore characters, and the C<?> character will
+be converted to a C<%> character, if a conversion is done.
+
+When Perl is running on an OpenVMS system, if the C<DECC$EFS_CHARSET>
+feature is enabled, this implies that the UNIX pathname can not have
+a version, and that a path consisting of three dots, C<./.../>, will be
+converted to C<[.^.^.^.]>.
+
+UNIX style shell macros like C<$(abcd)> are passed through instead
+of being converted to C<$^(abcd^)> independent of the C<DECC$EFS_CHARSET>
+feature setting.  UNIX style shell macros should not use characters
+that are not in the ASCII character set, as the resulting specification
+may or may not be still in UTF8 format.
+
+The feature logical name C<PERL_VMS_VTF7_FILENAMES> controls if UNICODE
+characters in UNIX filenames are encoded in VTF-7 notation in the resulting
+OpenVMS file specification.  [Currently under development]
+
+C<unixify> on the resulting file specification may not result in the
+original UNIX file specification, so programs should not plan to convert
+a file specification from UNIX to VMS and then back to UNIX again after
+modification of the components.
 
 =head2 unixify
 
-Converts a file specification to Unix syntax.
+Converts a file specification to Unix syntax.  If the file specification
+cannot be converted to or is already in UNIX syntax, it will be passed
+through unchanged.
+
+When Perl is running on an OpenVMS system, the following C<DECC$> feature
+settings will control how the filename is converted:
+
+ C<decc$disable_to_vms_logname_translation:> default = C<ENABLE>
+ C<decc$disable_posix_root:>                 default = C<ENABLE>
+ C<decc$efs_charset:>                        default = C<DISABLE>
+ C<decc$filename_unix_no_version:>           default = C<DISABLE>
+ C<decc$readdir_dropdotnotype:>              default = C<ENABLE>
+
+When Perl is being run under a UNIX shell on OpenVMS, the defaults at
+a future time may be more appropriate for it.
+
+When Perl is running on an OpenVMS system with C<DECC$EFS_CHARSET> enabled,
+a wild card directory name of C<[...]> can not be translated to a valid
+UNIX file specification when a conversion is done.
+
+When Perl is running on an OpenVMS system with C<DECC$EFS_CHARSET> enabled,
+directory file specifications will have their implied ".dir;1" removed,
+and a trailing C<.> character indicating a null extension will be removed.
+
+Note that C<DECC$EFS_CHARSET> requires C<DECC$FILENAME_UNIX_NO_VERSION> because
+the conversion routine can not differentiate whether the last C<.> of a UNIX
+specification is delimiting a version, or is just part of a file specification.
+
+C<vmsify> on the resulting file specification may not result in the
+original VMS file specification, so programs should not plan to convert
+a file specification from VMS to UNIX and then back to VMS again after
+modification.
 
 =head2 pathify
 
@@ -119,16 +190,45 @@ it's a list operator, so you need to be careful about parentheses.  Both of
 these restrictions may be removed in the future if the functionality of
 C<candelete> becomes part of the Perl core.
 
+=head2 vms_case_tolerant
+
+This reports whether the VMS process has been set to a case tolerant state.
+It is intended for use by the File::Spec::VMS->case_tolerant method only, and
+it is recommended that you only use File::Spec->case_tolerant.
+
+=head2 vms_realpath
+
+This exposes the VMS C library C<realpath> function where available.
+It will always return a UNIX format specification.
+
+If the C<realpath> function is not available, or is unable to return the
+real path of the file, C<vms_realpath> will use the C<vms_realfile>
+function and convert the output to a UNIX format specification.
+
+This function is intended for use by Cwd.pm for the implementation of
+the abs_path function with support for symbolic links.  It is not available
+on non-VMS systems.
+
+head2 vms_realname
+
+This uses the VMS LIB$FID_TO_NAME function to find the name of the primary
+link to a file, and returns the filename in VMS format.
+
+This function is intended for use by Cwd.pm for the implementation of
+the abs_path function with support for symbolic links.  It is not available
+on non-VMS systems.
+
+
 =head1 REVISION
 
-This document was last revised 22-Feb-1996, for Perl 5.002.
+This document was last revised 15-Nov-2007, for Perl 5.10.0
 
 =cut
 
 package VMS::Filespec;
 require 5.002;
 
-our $VERSION = '1.11';
+our $VERSION = '1.12';
 
 # If you want to use this package on a non-VMS system,
 # uncomment the following line.
@@ -137,7 +237,7 @@ require Exporter;
 
 @ISA = qw( Exporter );
 @EXPORT = qw( &vmsify &unixify &pathify &fileify
-              &vmspath &unixpath &candelete &rmsexpand );
+              &vmspath &unixpath &candelete &rmsexpand &vms_case_tolerant );
 
 1;
 
@@ -349,3 +449,7 @@ sub candelete ($) {
   }
   else { return (-w '[-]'); }
 }
+
+sub vms_case_tolerant ($) {
+    return 0;
+}
diff --git a/vms/vms.c b/vms/vms.c
index 3a83b8e088..a45dee5662 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -272,6 +272,7 @@ struct vs_str_st {
 #define do_tovmspath(a,b,c,d)		mp_do_tovmspath(aTHX_ a,b,c,d)
 #define do_rmsexpand(a,b,c,d,e,f,g)	mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 #define do_vms_realpath(a,b,c)		mp_do_vms_realpath(aTHX_ a,b,c)
+#define do_vms_realname(a,b,c)		mp_do_vms_realname(aTHX_ a,b,c)
 #define do_tounixspec(a,b,c,d)		mp_do_tounixspec(aTHX_ a,b,c,d)
 #define do_tounixpath(a,b,c,d)		mp_do_tounixpath(aTHX_ a,b,c,d)
 #define do_vms_case_tolerant(a)		mp_do_vms_case_tolerant(a)
@@ -5343,13 +5344,14 @@ mp_do_rmsexpand
       /* Unless we are forcing to VMS format, a UNIX input means
        * UNIX output, and that requires long names to be used
        */
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
 	opts |= PERL_RMSEXPAND_M_LONG;
-      else {
+      else
+#endif
 	isunix = 0;
       }
     }
-  }
 
   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
   rms_bind_fab_nam(myfab, mynam);
@@ -12091,7 +12093,7 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates
       return 0;
     }
 
-    esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+    esa = PerlMem_malloc(VMS_MAXRSS);
     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
     esal = NULL;
 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
@@ -12106,7 +12108,7 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates
     rms_bind_fab_nam(fab_in, nam);
     fab_in.fab$l_xab = (void *) &xabdat;
 
-    rsa = PerlMem_malloc(NAML$C_MAXRSS);
+    rsa = PerlMem_malloc(VMS_MAXRSS);
     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
     rsal = NULL;
 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
@@ -12903,7 +12905,6 @@ Perl_vms_start_glob
 }
 
 
-#ifdef HAS_SYMLINK
 static char *
 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
 		   int *utf8_fl);
@@ -12932,6 +12933,35 @@ vms_realpath_fromperl(pTHX_ CV *cv)
 	XSRETURN(1);
 }
 
+static char *
+mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
+		   int *utf8_fl);
+
+void
+vms_realname_fromperl(pTHX_ CV *cv)
+{
+    dXSARGS;
+    char *fspec, *rslt_spec, *rslt;
+    STRLEN n_a;
+
+    if (!items || items != 1)
+	Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realname(spec)");
+
+    fspec = SvPV(ST(0),n_a);
+    if (!fspec || !*fspec) XSRETURN_UNDEF;
+
+    Newx(rslt_spec, VMS_MAXRSS + 1, char);
+    rslt = do_vms_realname(fspec, rslt_spec, NULL);
+
+    ST(0) = sv_newmortal();
+    if (rslt != NULL)
+	sv_usepvn(ST(0),rslt,strlen(rslt));
+    else
+	Safefree(rslt_spec);
+	XSRETURN(1);
+}
+
+#ifdef HAS_SYMLINK
 /*
  * A thin wrapper around decc$symlink to make sure we follow the 
  * standard and do not create a symlink with a zero-length name.
@@ -12948,7 +12978,6 @@ int my_symlink(const char *path1, const char *path2) {
 
 #endif /* HAS_SYMLINK */
 
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
 int do_vms_case_tolerant(void);
 
 void
@@ -12958,7 +12987,6 @@ vms_case_tolerant_fromperl(pTHX_ CV *cv)
   ST(0) = boolSV(do_vms_case_tolerant());
   XSRETURN(1);
 }
-#endif
 
 void  
 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, 
@@ -13010,21 +13038,16 @@ init_os_extras(void)
   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
-#ifdef HAS_SYMLINK
   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
-#endif
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
+  newXSproto("VMS::Filespec::vms_realname",vms_realname_fromperl,file,"$;$");
   newXSproto("VMS::Filepec::vms_case_tolerant",
              vms_case_tolerant_fromperl, file, "$");
-#endif
 
   store_pipelocs(aTHX);         /* will redo any earlier attempts */
 
   return;
 }
   
-#ifdef HAS_SYMLINK
-
 #if __CRTL_VER == 80200000
 /* This missed getting in to the DECC SDK for 8.2 */
 char *realpath(const char *file_name, char * resolved_name, ...);
@@ -13052,7 +13075,7 @@ int vms_fid_to_name(char * outname, int outlen, const char * name)
 {
 struct statbuf_t {
     char	   * st_dev;
-    __ino16_t	   st_ino[3];
+    unsigned short st_ino[3];
     unsigned short padw;
     unsigned long  padl[30];  /* plenty of room */
 } statbuf;
@@ -13087,8 +13110,15 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
 {
     char * rslt = NULL;
 
-    if (decc_posix_compliant_pathnames) 
+#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;
@@ -13138,17 +13168,57 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
     return rslt;
 }
 
+static char *
+mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
+		   int *utf8_fl)
+{
+    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;
+
+    /* Fall back to fid_to_name */
+
+    sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
+    if (sts == 0) {
+
+
+	/* Now need to trim the version off */
+	sts = vms_split_path
+		  (outbuf,
+		   &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 file_len;
+
+	/* Trim off the version */
+	file_len = v_len + r_len + d_len + n_len + e_len;
+	outbuf[file_len] = 0;
+	}
+    }
+    return outbuf;
+}
+
+
 /*}}}*/
 /* External entry points */
 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
-#else
-char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
-{ return NULL; }
-#endif
 
+char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+{ return do_vms_realname(filespec, outbuf, utf8_fl); }
 
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
 /* case_tolerant */
 
 /*{{{int do_vms_case_tolerant(void)*/
@@ -13161,6 +13231,7 @@ int do_vms_case_tolerant(void)
 }
 /*}}}*/
 /* External entry points */
+#if __CRTL_VER >= 70301000 && !defined(__VAX)
 int Perl_vms_case_tolerant(void)
 { return do_vms_case_tolerant(); }
 #else
diff --git a/vms/vmsish.h b/vms/vmsish.h
index f5622ba340..90311a06d0 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -280,6 +280,7 @@
 #endif
 #define init_os_extras		Perl_init_os_extras
 #define vms_realpath(a, b, c)	Perl_vms_realpath(aTHX_ a,b,c)
+#define vms_realname(a, b, c)	Perl_vms_realname(aTHX_ a,b,c)
 #define vms_case_tolerant(a)	Perl_vms_case_tolerant(a)
 
 /* Delete if at all possible, changing protections if necessary. */