From: John E. Malmberg <wb8tyw@qsl.net>
Date: Sun, 30 Sep 2007 09:13:09 +0000 (-0500)
Subject: [patch@31998] Fix M:B: tilde.t tests on VMS
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3776488a91c6ecae36acc5af47fc83f9a8e61fc9;p=p5sagit%2Fp5-mst-13.2.git

[patch@31998] Fix M:B: tilde.t tests on VMS
From: "John E. Malmberg" <wb8tyw@qsl.net>
Message-id: <46FFAEF5.1060702@qsl.net>

p4raw-id: //depot/perl@31999
---

diff --git a/lib/Module/Build/Base.pm b/lib/Module/Build/Base.pm
index 519fe00..58d7539 100644
--- a/lib/Module/Build/Base.pm
+++ b/lib/Module/Build/Base.pm
@@ -1651,7 +1651,7 @@ sub read_args {
   # De-tilde-ify any path parameters
   for my $key (qw(prefix install_base destdir)) {
     next if !defined $args{$key};
-    $args{$key} = _detildefy($args{$key});
+    $args{$key} = $self->_detildefy($args{$key});
   }
 
   for my $key (qw(install_path)) {
@@ -1659,7 +1659,7 @@ sub read_args {
 
     for my $subkey (keys %{$args{$key}}) {
       next if !defined $args{$key}{$subkey};
-      my $subkey_ext = _detildefy($args{$key}{$subkey});
+      my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
       if ( $subkey eq 'html' ) { # translate for compatability
 	$args{$key}{binhtml} = $subkey_ext;
 	$args{$key}{libhtml} = $subkey_ext;
@@ -1681,7 +1681,7 @@ sub read_args {
 # (bash shell won't expand tildes mid-word: "--foo=~/thing")
 # TODO: handle ~user/foo
 sub _detildefy {
-    my $arg = shift;
+    my ($self, $arg) = @_;
 
     return $arg =~ /^~/ ? (glob $arg)[0] : $arg;
 }
diff --git a/lib/Module/Build/Platform/VMS.pm b/lib/Module/Build/Platform/VMS.pm
index 31408ed..989f0de 100644
--- a/lib/Module/Build/Platform/VMS.pm
+++ b/lib/Module/Build/Platform/VMS.pm
@@ -271,6 +271,78 @@ sub expand_test_dir {
   return @reldirs;
 }
 
+=item _detildefy
+
+The home-grown glob() does not currently handle tildes, so provide limited support
+here.  Expect only UNIX format file specifications for now.
+
+=cut
+
+sub _detildefy {
+    my ($self, $arg) = @_;
+
+    # Apparently double ~ are not translated.
+    return $arg if ($arg =~ /^~~/);
+
+    # Apparently ~ followed by whitespace are not translated.
+    return $arg if ($arg =~ /^~ /);
+
+    if ($arg =~ /^~/) {
+        my $spec = $arg;
+
+        # Remove the tilde
+        $spec =~ s/^~//;
+
+        # Remove any slash folloing the tilde if present.
+        $spec =~ s#^/##;
+
+        # break up the paths for the merge
+        my $home = VMS::Filespec::unixify($ENV{HOME});
+
+        # Trivial case of just ~ by it self
+        if ($spec eq '') {
+            return $home;
+        }
+
+        my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
+        if ($hdir eq '') {
+             # Someone has tampered with $ENV{HOME}
+             # So hfile is probably the directory since this should be
+             # a path.
+             $hdir = $hfile;
+        }
+
+        my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
+
+        my @hdirs = File::Spec::Unix->splitdir($hdir);
+        my @dirs = File::Spec::Unix->splitdir($dir);
+
+        my $newdirs;
+
+        # Two cases of tilde handling
+        if ($arg =~ m#^~/#) {
+
+            # Simple case, just merge together
+            $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
+
+        } else {
+
+            # Complex case, need to add an updir - No delimiters
+            my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
+
+            $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
+
+        }
+        
+        # Now put the two cases back together
+        $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
+
+    } else {
+        return $arg;
+    }
+
+}
+
 =back
 
 =head1 AUTHOR