Revert "Remove MacOS classic support from File::Basename."

This reverts commit e713b73750eb9e684a6d14dcca1a22d55ce2226d.

See [perl #87704].

2 files changed, 47 insertions, 5 deletions

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index f928e323d7..486eba1bbf 100644
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -54,7 +54,7 @@ our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-$VERSION = "2.81";
+$VERSION = "2.82";
 
 fileparse_set_fstype($^O);
 
@@ -131,6 +131,10 @@ sub fileparse {
     $dirpath = './' unless $dirpath;	# Can't be 0
     $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
   }
+  elsif ($type eq "MacOS") {
+    ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
+    $dirpath = ':' unless $dirpath;
+  }
   elsif ($type eq "AmigaOS") {
     ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
     $dirpath = './' unless $dirpath;
@@ -292,6 +296,13 @@ sub dirname {
     if ($type eq 'VMS') { 
         $dirname ||= $ENV{DEFAULT};
     }
+    elsif ($type eq 'MacOS') {
+	if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
+            _strip_trailing_sep($dirname);
+	    ($basename,$dirname) = fileparse $dirname;
+	}
+	$dirname .= ":" unless $dirname =~ /:\z/;
+    }
     elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
         _strip_trailing_sep($dirname);
         unless( length($basename) ) {
@@ -320,7 +331,10 @@ sub dirname {
 sub _strip_trailing_sep  {
     my $type = $Fileparse_fstype;
 
-    if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
+    if ($type eq 'MacOS') {
+        $_[0] =~ s/([^:]):\z/$1/s;
+    }
+    elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
         $_[0] =~ s/([^:])[\\\/]*\z/$1/;
     }
     else {
@@ -339,7 +353,7 @@ 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", "AmigaOS", "OS2", "RISCOS",
+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.
@@ -356,7 +370,7 @@ call only.
 
 BEGIN {
 
-my @Ignore_Case = qw(VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
+my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
 my @Types = (@Ignore_Case, qw(Unix));
 
 sub fileparse_set_fstype {
diff --git a/lib/File/Basename.t b/lib/File/Basename.t
index 627d2f4726..0d3b633669 100644
--- a/lib/File/Basename.t
+++ b/lib/File/Basename.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-use Test::More tests => 49;
+use Test::More tests => 64;
 
 BEGIN { use_ok 'File::Basename' }
 
@@ -76,6 +76,34 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
     is( dirname("\\foo\\bar\\baz"), "\\foo\\bar" );
 }
 
+
+### Testing MacOS
+{
+    is(fileparse_set_fstype('MacOS'), 'MSDOS', 'set fstype to MacOS');
+
+    my($base,$path,$type) = fileparse('virgil:aeneid:draft.book7',
+                                      '\.book\d+');
+    is($base, 'draft');
+    is($path, 'virgil:aeneid:');
+    is($type, '.book7');
+
+    is(basename(':arma:virumque:cano.trojae'), 'cano.trojae');
+    is(dirname(':arma:virumque:cano.trojae'),  ':arma:virumque:');
+    is(dirname(':arma:virumque:'), ':arma:');
+    is(dirname(':arma:virumque'), ':arma:');
+    is(dirname(':arma:'), ':');
+    is(dirname(':arma'),  ':');
+    is(dirname('arma:'), 'arma:');
+    is(dirname('arma'), ':');
+    is(dirname(':'), ':');
+
+
+    # Check quoting of metacharacters in suffix arg by basename()
+    is(basename(':arma:virumque:cano.trojae','.trojae'), 'cano');
+    is(basename(':arma:virumque:cano_trojae','.trojae'), 'cano_trojae');
+}
+
+
 ### extra tests for a few specific bugs
 {
     fileparse_set_fstype 'DOS';