From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sat, 11 Mar 2000 16:59:48 +0000 (+0000)
Subject: File::Spec::VMS fixups, *not tested* on VMS (from Barrie Slaymaker)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d7bc03f01f7e3506a9d9bfd0b13c189fd76b4aa6;p=p5sagit%2Fp5-mst-13.2.git

File::Spec::VMS fixups, *not tested* on VMS (from Barrie Slaymaker)

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

diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm
index aecaada..d3f6018 100644
--- a/lib/File/Spec/VMS.pm
+++ b/lib/File/Spec/VMS.pm
@@ -133,21 +133,17 @@ Removes redundant portions of file specifications according to VMS syntax
 =cut
 
 sub canonpath {
-    my($self,$path,$reduce_ricochet) = @_;
+    my($self,$path) = @_;
 
     if ($path =~ m|/|) { # Fake Unix
       my $pathify = $path =~ m|/\z|;
-      $path = $self->SUPER::canonpath($path,$reduce_ricochet);
+      $path = $self->SUPER::canonpath($path);
       if ($pathify) { return vmspath($path); }
       else          { return vmsify($path);  }
     }
     else {
-      $path =~ s-\]\[--g;  $path =~ s/><//g;         # foo.][bar       ==> foo.bar
-      $path =~ s/([\[<])000000\./$1/;                # [000000.foo     ==> foo
-      if ($reduce_ricochet) { 
-        $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/g;
-        $path =~ s/([\[<\.])([^\[<\.]+)\.-\.?/$1/g;
-      }
+      $path =~ s-\]\[--g;  $path =~ s/><//g;    # foo.][bar       ==> foo.bar
+      $path =~ s/([\[<])000000\./$1/;           # [000000.foo     ==> foo
       return $path;
     }
 }
@@ -357,116 +353,6 @@ sub catpath {
     "$dev$dir$file";
 }
 
-=item splitpath
-
-    ($volume,$directories,$file) = File::Spec->splitpath( $path );
-    ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
-
-Splits a VMS path in to volume, directory, and filename portions.
-Ignores $no_file, if present, since VMS paths indicate the 'fileness' of a 
-file.
-
-The results can be passed to L</catpath()> to get back a path equivalent to
-(usually identical to) the original path.
-
-=cut
-
-sub splitpath {
-    my $self = shift ;
-    my ($path, $nofile) = @_;
-
-    my ($volume,$directory,$file) ;
-
-    if ( $path =~ m{/} ) {
-        $path =~ 
-            m{^ ( (?: /[^/]* )? )
-                ( (?: .*/(?:[^/]+\.dir)? )? )
-                (.*)
-             }xs;
-        $volume    = $1;
-        $directory = $2;
-        $file      = $3;
-    }
-    else {
-        $path =~ 
-            m{^ ( (?: (?: (?: [\w\$-]+ (?: "[^"]*")?:: )? [\w\$-]+: )? ) )
-                ( (?:\[.*\])? )
-                (.*)
-             }xs;
-        $volume    = $1;
-        $directory = $2;
-        $file      = $3;
-    }
-
-    $directory = $1
-        if $directory =~ /^\[(.*)\]\z/s ;
-
-    return ($volume,$directory,$file);
-}
-
-
-=item splitdir
-
-The opposite of L</catdir()>.
-
-    @dirs = File::Spec->splitdir( $directories );
-
-$directories must be only the directory portion of the path.
-
-'[' and ']' delimiters are optional. An empty string argument is
-equivalent to '[]': both return an array with no elements.
-
-=cut
-
-sub splitdir {
-    my $self = shift ;
-    my $directories = $_[0] ;
-
-    return File::Spec::Unix::splitdir( $self, @_ )
-        if ( $directories =~ m{/} ) ;
-
-    $directories =~ s/^\[(.*)\]\z/$1/s ;
-
-    #
-    # split() likes to forget about trailing null fields, so here we
-    # check to be sure that there will not be any before handling the
-    # simple case.
-    #
-    if ( $directories !~ m{\.\z} ) {
-        return split( m{\.}, $directories );
-    }
-    else {
-        #
-        # since there was a trailing separator, add a file name to the end, 
-        # then do the split, then replace it with ''.
-        #
-        my( @directories )= split( m{\.}, "${directories}dummy" ) ;
-        $directories[ $#directories ]= '' ;
-        return @directories ;
-    }
-}
-
-
-sub catpath {
-    my $self = shift;
-
-    return File::Spec::Unix::catpath( $self, @_ )
-        if ( join( '', @_ ) =~ m{/} ) ;
-
-    my ($volume,$directory,$file) = @_;
-
-    $volume .= ':'
-        if $volume =~ /[^:]\z/ ;
-
-    $directory = "[$directory"
-        if $directory =~ /^[^\[]/s ;
-
-    $directory .= ']'
-        if $directory =~ /[^\]]\z/ ;
-
-    return "$volume$directory$file" ;
-}
-
 
 sub abs2rel {
     my $self = shift;
diff --git a/t/lib/filespec.t b/t/lib/filespec.t
index aba0688..e44648a 100755
--- a/t/lib/filespec.t
+++ b/t/lib/filespec.t
@@ -207,7 +207,6 @@ BEGIN {
 [ "VMS->canonpath('')",                                    ''                        ],
 [ "VMS->canonpath('volume:[d1]file')",                     'volume:[d1]file'         ],
 [ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')",              'volume:[d1.-.d2.d3.d4.-]'  ],
-[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]',1)",              'volume:[d2.d3]'          ],
 [ "VMS->canonpath('volume:[000000.d1]d2.dir;1')",                 'volume:[d1]d2.dir;1'   ],
 
 [ "VMS->splitdir('')",            ''          ],
@@ -313,14 +312,17 @@ eval {
    require VMS::Filespec ;
 } ;
 
+my $skip_exception = "Install VMS::Filespec (from vms/ext)" ;
+
 if ( $@ ) {
    # Not pretty, but it allows testing of things not implemented soley
    # on VMS.  It might be better to change File::Spec::VMS to do this,
    # making it more usable when running on (say) Unix but working with
    # VMS paths.
    eval qq-
-      sub File::Spec::VMS::unixify { die "Install VMS::Filespec (from vms/ext)" } ;
-      sub File::Spec::VMS::vmspath { die "Install VMS::Filespec (from vms/ext)" } ;
+      sub File::Spec::VMS::vmsify  { die "$skip_exception" }
+      sub File::Spec::VMS::unixify { die "$skip_exception" }
+      sub File::Spec::VMS::vmspath { die "$skip_exception" }
    - ;
    $INC{"VMS/Filespec.pm"} = 1 ;
 }
@@ -366,8 +368,9 @@ sub tryfunc {
     }
 
     if ( $@ ) {
-	if ( $@ =~ /only provided on VMS/ ) {
-	    print "ok $current_test # skip $function \n" ;
+        if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) {
+	    chomp $@ ;
+	    print "ok $current_test # skip $function: $@\n" ;
 	}
 	else {
 	    chomp $@ ;