Final installment for implementing symbolic links in Perl on VMS.
In vms.c expose vms_realpath() and vms_realname() routines to return the
real path of a file in VMS::Filespec
In vmsish.h, support for vms_realname()
In ext/vms/Filespec.pm update the POD documentation.
In cwd.pm, detect when the vms_realpath and vms_realname are available
and use them to return the true name of a file for abs_path. Make sure
that a VMS directory path is returned in a directory format.
In cwd.t:
A symbolic link needs to be created in Unix format to be valid on VMS.
Revert $want to be what the test used to be with one change, remove
leading '[' on VMS from $want for directory comparison.
Make comparison regex case insensitive.
I know this is late, but can we try to get this in 5.10 for completeness?
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /rsync_root/perl/vms/vms.c Thu Nov 15 14:54:01 2007
+++ vms/vms.c Thu Nov 15 23:22:58 2007
@@ -272,6 +272,7 @@
#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)
@@ -12903,7 +12904,6 @@
}
-#ifdef HAS_SYMLINK
static char *
mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
int *utf8_fl);
@@ -12932,6 +12932,35 @@
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 +12977,6 @@
#endif /* HAS_SYMLINK */
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
int do_vms_case_tolerant(void);
void
@@ -12958,7 +12986,6 @@
ST(0) = boolSV(do_vms_case_tolerant());
XSRETURN(1);
}
-#endif
void
Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
@@ -13010,21 +13037,16 @@
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, ...);
@@ -13064,14 +13086,14 @@
if (sts == 0) {
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
- (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
- if ($VMS_STATUS_SUCCESS(sts)) {
+ sts = lib$fid_to_name
+ (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
+ if ($VMS_STATUS_SUCCESS(sts)) {
outname[specdsc.dsc$w_length] = 0;
return 0;
}
@@ -13087,8 +13109,15 @@
{
char * rslt = NULL;
- if (decc_posix_compliant_pathnames)
- rslt = realpath(filespec, outbuf);
+#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;
@@ -13100,8 +13129,8 @@
Newx(vms_spec, VMS_MAXRSS + 1, char);
- sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
- if (sts == 0) {
+ sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
+ if (sts == 0) {
/* Now need to trim the version off */
@@ -13138,17 +13167,57 @@
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 +13230,7 @@
}
/*}}}*/
/* External entry points */
+#if __CRTL_VER >= 70301000 && !defined(__VAX)
int Perl_vms_case_tolerant(void)
{ return do_vms_case_tolerant(); }
#else
--- /rsync_root/perl/vms/vmsish.h Mon Oct 29 20:11:33 2007
+++ vms/vmsish.h Thu Nov 15 22:09:16 2007
@@ -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. */
--- /rsync_root/perl/vms/ext/Filespec.pm Tue Jun 13 14:29:35 2006
+++ vms/ext/Filespec.pm Thu Nov 15 23:00:18 2007
@@ -3,7 +3,7 @@
#
# Version: see $VERSION below
# Author: Charles Bailey [EMAIL PROTECTED]
-# Revised: 08-Mar-1995
+# Revised: 30-Oct-2007
=head1 NAME
@@ -20,6 +20,9 @@
$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 @@
as possible.) If an error occurs, returns C<undef> and sets C<$!>
and C<$^E>.
+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
+is not able to be converted or is already in VMS syntax, it will be
+passed through unchanged.
+
+The file specifications of C<.> and C<..> will be converted to be
+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 clear
+as 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
+is not able to be converted 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 if the last C<.> of a UNIX
+specification is delimiting a version, or 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 @@
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 if 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 for use.
+It will always return a Unix format specification.
+
+If the C<realpath> function is not available, or is unable to return the
+realpath ofthe 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 the Cwd.pm for the implementation of
+the abs_path function with support for symblic 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 the Cwd.pm for the implementation of
+the abs_path function with support for symblic 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 @@
@ISA = qw( Exporter );
@EXPORT = qw( &vmsify &unixify &pathify &fileify
- &vmspath &unixpath &candelete &rmsexpand );
+ &vmspath &unixpath &candelete &rmsexpand &vms_case_tolerant );
1;
@@ -348,4 +448,8 @@
return (-w fileify($parent));
}
else { return (-w '[-]'); }
+}
+
+sub vms_case_tolerant ($) {
+ return 0;
}
--- /rsync_root/perl/lib/Cwd.pm Sat Oct 6 13:32:05 2007
+++ lib/Cwd.pm Sun Nov 18 01:34:12 2007
@@ -171,7 +171,7 @@
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.25_01';
+$VERSION = '3.25_02';
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
@@ -644,20 +644,32 @@
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
- my $path = shift;
- if (-l $path) {
- my $link_target = readlink($path);
- die "Can't resolve link $path: $!" unless defined $link_target;
-
- return _vms_abs_path($link_target);
- }
+ if (defined &VMS::Filespec::vms_realpath) {
+ my $path = $_[0];
+ if ($path =~ m#(?<=\^)/# ) {
+ # Unix format
+ return VMS::Filespec::vms_realpath($path);
+ } else {
+ # VMS format
+
+ my $new_path = VMS::Filespec::vms_realname($path);
+
+ # Perl expects directories to be in directory format
+ $new_path = VMS::Filespec::pathify($new_path) if -d $path;
+ return $new_path;
+ }
+ } else {
- # may need to turn foo.dir into [.foo]
- my $pathified = VMS::Filespec::pathify($path);
- $path = $pathified if defined $pathified;
-
- return VMS::Filespec::rmsexpand($path);
+ # Fallback to older algorithm if correct ones are not
+ # available.
+
+ # may need to turn foo.dir into [.foo]
+ my $path = VMS::Filespec::pathify($_[0]);
+ $path = $_[0] unless defined $path;
+
+ return VMS::Filespec::rmsexpand($path);
+ }
}
sub _os2_cwd {
--- /rsync_root/perl/ext/Cwd/t/cwd.t Sat Oct 6 13:32:05 2007
+++ ext/Cwd/t/cwd.t Sun Nov 18 01:41:16 2007
@@ -169,15 +169,18 @@
skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless
$Config{d_symlink};
mkpath([$Test_Dir], 0, 0777);
+
+ # VMS require symbolic link targets to be in UNIX format
+ $Test_Dir = VMS::Filespec::unixify($Test_Dir) if $^O eq 'VMS';
+
symlink $Test_Dir, "linktest";
my $abs_path = Cwd::abs_path("linktest");
my $fast_abs_path = Cwd::fast_abs_path("linktest");
- my $want = quotemeta(
- File::Spec->rel2abs(
- $ENV{PERL_CORE} ? $Test_Dir :
File::Spec->catdir('t', $Test_Dir)
- )
- );
+ my $want = File::Spec->catdir("t", $Test_Dir);
+
+ # Need to remove start directory delimiters for path compares on VMS
+ $want =~ s/\[// if $^O eq 'VMS';
like($abs_path, qr|$want$|i);
like($fast_abs_path, qr|$want$|i);
