This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Further lies in the File::Basename docs
authorMichael G. Schwern <schwern@pobox.com>
Wed, 6 Jul 2005 09:22:32 +0000 (02:22 -0700)
committerSteve Hay <SteveHay@planit.com>
Thu, 7 Jul 2005 09:22:48 +0000 (09:22 +0000)
Message-ID: <20050706162232.GA14495@windhund.schwern.org>

(plus some minor POD changes and a bug fix)

p4raw-id: //depot/perl@25089

lib/File/Basename.pm
lib/File/Basename.t

index e6b16e7..21008da 100644 (file)
@@ -80,10 +80,9 @@ portion is removed and becomes the $suffix.
      # On Unix returns ("baz", "/foo/bar", ".txt")
      fileparse("/foo/bar/baz", qr/\.[^.]*/);
 
-If type is one of "VMS", "MSDOS", "MacOS", "AmigaOS", "OS2", "MSWin32"
-or "RISCOS" (see C<fileparse_set_fstype()>) then the pattern matching
-for suffix removal is performed case-insensitively, since those
-systems are not case-sensitive when opening existing files.
+If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern
+matching for suffix removal is performed case-insensitively, since
+those systems are not case-sensitive when opening existing files.
 
 You are guaranteed that C<$directories . $filename . $suffix> will
 denote the same location as the original $path.
@@ -93,41 +92,49 @@ denote the same location as the original $path.
 
 sub fileparse {
   my($fullname,@suffices) = @_;
+
   unless (defined $fullname) {
       require Carp;
       Carp::croak("fileparse(): need a valid pathname");
   }
-  my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
-  my($dirpath,$tail,$suffix,$basename);
+
+  my $orig_type = '';
+  my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
+
   my($taint) = substr($fullname,0,0);  # Is $fullname tainted?
 
-  if ($fstype =~ /^VMS/i) {
-    if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
-    else {
-      ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
-      $dirpath ||= '';  # should always be defined
-    }
+  if ($type eq "VMS" and $fullname =~ m{/} ) {
+    # We're doing Unix emulation
+    $orig_type = $type;
+    $type = 'Unix';
   }
-  if ($fstype =~ /^MS(DOS|Win32)|epoc/i) {
+
+  my($dirpath, $basename);
+
+  if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
     ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
     $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
   }
-  elsif ($fstype =~ /^os2/i) {
+  elsif ($type eq "OS2") {
     ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
     $dirpath = './' unless $dirpath;   # Can't be 0
     $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
   }
-  elsif ($fstype =~ /^MacOS/si) {
+  elsif ($type eq "MacOS") {
     ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
     $dirpath = ':' unless $dirpath;
   }
-  elsif ($fstype =~ /^AmigaOS/i) {
+  elsif ($type eq "AmigaOS") {
     ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
     $dirpath = './' unless $dirpath;
   }
-  elsif ($fstype !~ /^VMS/i) {  # default to Unix
+  elsif ($type eq 'VMS' ) {
+    ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
+    $dirpath ||= '';  # should always be defined
+  }
+  else { # Default to Unix semantics.
     ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
-    if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
+    if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
       # dev:[000000] is top of VMS tree, similar to Unix '/'
       # so strip it off and treat the rest as "normal"
       my $devspec  = $1;
@@ -138,7 +145,9 @@ sub fileparse {
     }
     $dirpath = './' unless $dirpath;
   }
+      
 
+  my($tail, $suffix);
   if (@suffices) {
     $tail = '';
     foreach $suffix (@suffices) {
@@ -191,14 +200,13 @@ its name it does B<NOT> always return the directory name as you might
 expect.  To be safe, if you want the directory name of a path use
 C<fileparse()>.
 
-    # On all but Unix and MSDOS
-    my $directories = dirname($path);
-
-On all system types but Unix and MSDOS this works just like
-C<fileparse($path)> but returning just the $directories.
+Only on VMS (where there is no ambiguity between the file and directory
+portions of a path) and AmigaOS (possibly due to an implementation quirk in
+this module) does C<dirname()> work like C<fileparse($path)>, returning just the
+$directories.
 
-    # On Unix and MSDOS
-    my $path_one_level_up = dirname($path);
+    # On VMS and AmigaOS
+    my $directories = dirname($path);
 
 When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
 which is subtly different from how C<fileparse()> works.  It returns all but
@@ -226,34 +234,36 @@ current default device and directory is used.
 
 
 sub dirname {
-    my($fstype) = $Fileparse_fstype;
+    my $path = shift;
 
-    if( $fstype =~ /VMS/i and $_[0] =~ m{/} ) {
+    my($type) = $Fileparse_fstype;
+
+    if( $type eq 'VMS' and $path =~ m{/} ) {
         # Parse as Unix
         local($File::Basename::Fileparse_fstype) = '';
-        return dirname(@_);
+        return dirname($path);
     }
 
-    my($basename,$dirname) = fileparse($_[0]);
+    my($basename, $dirname) = fileparse($path);
 
-    if ($fstype =~ /VMS/i) { 
+    if ($type eq 'VMS') { 
         $dirname ||= $ENV{DEFAULT};
     }
-    elsif ($fstype =~ /MacOS/i) {
+    elsif ($type eq 'MacOS') {
        if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
            $dirname =~ s/([^:]):\z/$1/s;
            ($basename,$dirname) = fileparse $dirname;
        }
        $dirname .= ":" unless $dirname =~ /:\z/;
     }
-    elsif ($fstype =~ /MS(DOS|Win32)|os2/i) { 
+    elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
         $dirname =~ s/([^:])[\\\/]*\z/$1/;
         unless( length($basename) ) {
            ($basename,$dirname) = fileparse $dirname;
            $dirname =~ s/([^:])[\\\/]*\z/$1/;
        }
     }
-    elsif ($fstype =~ /AmigaOS/i) {
+    elsif ($type eq 'AmigaOS') {
         if ( $dirname =~ /:\z/) { return $dirname }
         chop $dirname;
         $dirname =~ s#[^:/]+\z## unless length($basename);
@@ -272,15 +282,17 @@ sub dirname {
 
 =item C<fileparse_set_fstype>
 
-  my $previous_fstype = fileparse_set_fstype($type);
+  my $type = fileparse_set_fstype();
+  my $previous_type = fileparse_set_fstype($type);
 
 Normally File::Basename will assume a file path type native to your current
 operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
 With this function you can override that assumption.
 
-Valid $types are "VMS", "MSDOS", "MacOS", "AmigaOS", "OS2", "RISCOS",
-"MSWin32" and "Unix" (case-insensitive).  If an unrecognized $type is
-given Unix semantics will be assumed.
+Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
+"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
+"Epoc" and "Unix" (all case-insensitive).  If an unrecognized $type is
+given "Unix" will be assumed.
 
 If you've selected VMS syntax, and the file specification you pass to
 one of these routines contains a "/", they assume you are using Unix
@@ -292,13 +304,29 @@ call only.
 =cut
 
 
+BEGIN {
+
+my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
+my @Types = (@Ignore_Case, qw(Unix));
+
 sub fileparse_set_fstype {
-  my @old = ($Fileparse_fstype, $Fileparse_igncase);
-  if (@_) {
-    $Fileparse_fstype = $_[0];
-    $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i);
-  }
-  wantarray ? @old : $old[0];
+    my $old = $Fileparse_fstype;
+
+    if (@_) {
+        my $new_type = shift;
+
+        $Fileparse_fstype = 'Unix';  # default
+        foreach my $type (@Types) {
+            $Fileparse_fstype = $type if $new_type =~ /^$type/i;
+        }
+
+        $Fileparse_igncase = 
+          (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
+    }
+
+    return $old;
+}
+
 }
 
 
index b1719af..8e15900 100755 (executable)
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-use Test::More 'no_plan';
+use Test::More tests => 53;
 
 BEGIN { use_ok 'File::Basename' }
 
@@ -15,6 +15,7 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
 ### Testing Unix
 {
     ok length fileparse_set_fstype('unix'), 'set fstype to unix';
+    is( fileparse_set_fstype(), 'Unix',     'get fstype' );
 
     my($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
                                       qr'\.book\d+');
@@ -31,7 +32,7 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
 
 ### Testing VMS
 {
-    is(fileparse_set_fstype('VMS'), 'unix', 'set fstype to VMS');
+    is(fileparse_set_fstype('VMS'), 'Unix', 'set fstype to VMS');
 
     my($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7',
                                       qr{\.book\d+});
@@ -52,9 +53,9 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
 }
 
 
-### Testing MSDOS
+### Testing DOS
 {
-    is(fileparse_set_fstype('MSDOS'), 'VMS', 'set fstype to MSDOS');
+    is(fileparse_set_fstype('DOS'), 'VMS', 'set fstype to DOS');
 
     my($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7',
                                       '\.book\d+');
@@ -67,8 +68,13 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
     is(dirname('A:\\'), 'A:\\');
     is(dirname('arma\\'), '.');
 
-    # Yes "/" is a legal path separator under MSDOS
+    # Yes "/" is a legal path separator under DOS
     is(basename("lib/File/Basename.pm"), "Basename.pm");
+
+    # $^O for DOS is "dos" not "MSDOS" but "MSDOS" is left in for
+    # backward bug compat.
+    is(fileparse_set_fstype('MSDOS'), 'DOS');
+    is( dirname("\\foo\\bar\\baz"), "\\foo\\bar" );
 }
 
 
@@ -101,7 +107,7 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
 
 ### extra tests for a few specific bugs
 {
-    fileparse_set_fstype 'MSDOS';
+    fileparse_set_fstype 'DOS';
     # perl5.003_18 gives C:/perl/.\
     is((fileparse 'C:/perl/lib')[1], 'C:/perl/');
     # perl5.003_18 gives C:\perl\