Merge pull request #13 from labster/master

More refactoring, remove Epoc
FROGGS · Apr 13, 2013 · 7dd1db2 · 7dd1db2
2 parents 9e80d52 + 380f0c1
commit 7dd1db2
Show file tree

Hide file tree

Showing 9 changed files with 89 additions and 137 deletions.
diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm
@@ -4,11 +4,10 @@ my %module = (
 	'MacOS'   => 'Mac',
 	<MSWin32 os2 dos NetWare symbian> »=>» 'Win32',
 	'VMS'     => 'VMS',
-	'epoc'    => 'Epoc',
 	'cygwin'  => 'Cygwin',
 	# in case someone passes a module name instead of an OS string
 	#  map it to themselves
-	<Unix Mac Win32 Epoc Cygwin> »xx» 2
+	<Unix Mac Win32 Cygwin> »xx» 2
 );
 
 $module = "File::Spec::" ~ (%module{$*OS} // 'Unix');
@@ -20,7 +19,7 @@ method MODULE                            { $module; }  # for introspection
 #| Returns a copy of the module for the given OS string
 #| e.g. File::Spec.os('Win32') returns File::Spec::Win32
 method os (Str $OS = $*OS ) {
-	$module = "File::Spec::" ~ (%module{$OS} // 'Unix');
+	my $module = "File::Spec::" ~ (%module{$OS} // 'Unix');
 	require $module;
 	::($module);
 }

diff --git a/lib/File/Spec/Cygwin.pm b/lib/File/Spec/Cygwin.pm
@@ -5,40 +5,29 @@ class File::Spec::Cygwin is File::Spec::Unix;
 #| Any C<\> (backslashes) are converted to C</> (forward slashes),
 #| and then File::Spec::Unix.canonpath() is called on the result.
 method canonpath (Mu:D $path as Str is copy) {
-	$path ~~ s:g★\\★/★;   #::
+	$path.=subst(:g, '\\', '/');
 
 	# Handle network path names beginning with double slash
 	my $node = '';
 	if $path ~~ s★^ ('//' <-[/]>+) [ '/' | $ ]  ★/★ {
-	$node = ~$0;
+		$node = ~$0;
 	}
 	$node ~ File::Spec::Unix.canonpath($path);
 }
 
 #| Calls the Unix version, and additionally prevents
 #| accidentally creating a //network/path.
 method catdir ( *@paths ) {
-	# return unless @_;
-
 	my $result = File::Spec::Unix.catdir(@paths);
 
 	# Don't create something that looks like a //network/path
-	$result.subst(/ <[\\\/]> ** 2..*/, '/'); 	#/
-
-	# I think this P5 would probably still be wrong if ('', '/', 'foo') was passed :-\
-	#if (@paths[0] and (@paths[0] eq '/' or @paths[0] eq '\\')) {
-	#    shift;
-	#    return $self->SUPER::catdir('', @_);
-	#}
-	#$self->SUPER::catdir(@_);
+	$result.subst(/ <[\\\/]> ** 2..*/, '/');
 }
 
 
-#| True is returned if the file name begins with C<drive_letter:/>,
-#| and if not, File::Spec::Unix.file-name-is-absolute is called.
+#| Tests if the file name begins with C<drive_letter:/> or a slash.
 sub file-name-is-absolute ($file) {
-    return True if $file ~~ m★ ^ [<[A..Z a..z]>:]?  <[\\/]>★; # C:/test
-    File::Spec::Unix.file-name-is-absolute($file);
+    so $file ~~ m★ ^ [<[A..Z a..z]>:]?  <[\\/]>★; # C:/test
 }
 
 method tmpdir {
@@ -55,23 +44,8 @@ method tmpdir {
 
 
 #| Paths might have a volume, so we use Win32 splitpath and catpath instead
-method splitpath ( $path, $nofile = False )      { File::Spec::Win32.splitpath( $path, $nofile ) }
-method catpath (|c)           { File::Spec::Win32.catpath(|c).subst(:global, '\\', '/') }
-method split ($path)          { File::Spec::Win32.split($path)      }
+method splitpath (|c)         { File::Spec::Win32.splitpath(|c) }
+method catpath (|c)           { File::Spec::Win32.catpath(|c).subst(:global, '\\', '/')  }
+method split ($path)          { File::Spec::Win32.split($path)».subst(:global, '\\', '/')}
 method join (|c)              { File::Spec::Win32.join(|c).subst(:global, '\\', '/')     }
-
-#method catfile               { ::($module).catfile()               }
-#method curdir                { ::($module).curdir()                }
-#method devnull               { ::($module).devnull()               }
-#method rootdir               { ::($module).rootdir()               }
-#method updir                 { ::($module).updir()                 }
-#method no_upwards            { ::($module).no_upwards()            }
-#method case_tolerant         { ::($module).case_tolerant()         }
 method default-case-tolerant  { True                                }
-#method path                  { ::($module).path()                  }
-#method join                  { ::($module).join()                  }
-#method splitpath             { ::($module).splitpath()             }
-#method splitdir              { ::($module).splitdir()              }
-#method catpath               { ::($module).catpath()               }
-#method abs2rel               { ::($module).abs2rel()               }
-#method rel2abs               { ::($module).rel2abs()               }
diff --git a/lib/File/Spec/Epoc.pm b/lib/File/Spec/Epoc.pm
diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm
@@ -28,7 +28,7 @@ method curdir {	'.'  }
 method updir  { '..' }
 method rootdir { '/' }
 method devnull { '/dev/null' }
-method default-case-tolerant { $*OS eq 'darwin' }
+method default-case-tolerant { so $*OS eq 'darwin'|'epoc' }
 
 method _firsttmpdir( *@dirlist ) {
 	my $tmpdir = @dirlist.first: { .defined && .IO.d && .IO.w }

diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm
@@ -9,18 +9,18 @@ my $UNCpath     = regex { [<$slash> ** 2] <-[\\\/]>+  <$slash>  [<-[\\\/]>+ | $]
 my $volume_rx   = regex { $<driveletter>=<$driveletter> | $<UNCpath>=<$UNCpath> }
 
 
-method canonpath ($path)         { canon-cat($path)               }
+method canonpath ($path)     { canon-cat($path)    }
 
-method catdir(*@dirs)            {
+method catdir(*@dirs) {
 	return "" unless @dirs;
 	return canon-cat( "\\", |@dirs ) if @dirs[0] eq "";
 	canon-cat(|@dirs);
 }
-method splitdir($dir)        { $dir.split($slash)                  }
+method splitdir($dir)        { $dir.split($slash)  }
 
-method catfile(|c)           { self.catdir(|c)                     }
-method devnull               { 'nul'                               }
-method rootdir               { '\\'                                }
+method catfile(|c)           { self.catdir(|c)     }
+method devnull               { 'nul'               }
+method rootdir               { '\\'                }
 
 method tmpdir {
 	state $tmpdir;
@@ -46,7 +46,7 @@ method path {
 	return @path;
 }
 
-method default-case-tolerant     { True                                     }
+method default-case-tolerant  { True        }
 
 method file-name-is-absolute ($path) {
 	# As of right now, this returns 2 if the path is absolute with a
@@ -70,6 +70,11 @@ method split ($path as Str is copy) {
 	my ($volume, $directory, $file) = (~$0, ~$1, ~$2);
         $directory ~~ s/ <?after .> <$slash>+ $//;
 
+
+	if all($directory, $file) eq '' && $volume ne '' {
+		$directory = $volume ~~ /^<$driveletter>/
+		             ?? '.' !! '\\';
+	}
 	$file = '\\'      if $directory eq any('/', '\\') && $file eq '';
 	$directory = '.'  if $directory eq ''             && $file ne '';
 
@@ -136,10 +141,10 @@ method rel2abs ($path is copy, $base? is copy) {
 	}
 
 	if not defined $base {
-		# TODO: implement _getdcwd call ( Windows maintains separate CWD for each volume )
-		#$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
-		#$base = $*CWD unless defined $base ;
-		$base = $*CWD;
+	# TODO: implement _getdcwd call ( Windows maintains separate CWD for each volume )
+	# See: http://msdn.microsoft.com/en-us/library/1e5zwe0c%28v=vs.80%29.aspx
+		$base = Cwd::getdcwd( (self.splitpath: $path)[0] ) if defined &Cwd::getdcwd ;
+		$base //= $*CWD ;
 	}
 	elsif ( !self.file-name-is-absolute( $base ) ) {
 		$base = self.rel2abs( $base );
@@ -178,9 +183,8 @@ sub canon-cat ( $first is copy, *@rest ) {
 	if $volume ~~ /^<$driveletter>/ {
 		$volume.=uc;
 	}
-	else {
-		$volume ~~ /<-[\\\/]>$/ and $volume ~= '\\';
-		$volume ~~ /^<[\\\/]>$/ and $volume = '\\'; #::
+	elsif $volume.chars && $volume !~~ / '\\' $/ {
+		$volume ~= '\\';
 	}
 
 	my $path = join "\\", $first, @rest.flat;
@@ -189,7 +193,7 @@ sub canon-cat ( $first is copy, *@rest ) {
 
 	$path ~~ s:g/[ ^ | '\\']   '.'  '\\.'*  [ '\\' | $ ]/\\/;  #:: xx/././yy --> xx/yy
 
-	if $*OS ne "Win32" {
+	if $*OS ne "MSWin32" {
 		#netware or symbian ... -> ../..
 		#unknown if .... or higher is supported
 		$path ~~ s:g/ <?after ^ | '\\'> '...' <?before '\\' | $ > /..\\../; #::
@@ -218,7 +222,3 @@ sub canon-cat ( $first is copy, *@rest ) {
 
 	return $path ne "" || $volume ?? $volume ~ $path !! ".";
 }
-
-
-
-
diff --git a/t/01_cygwin.t b/t/01_cygwin.t
@@ -4,11 +4,10 @@ use Test;
 use File::Spec;
 use File::Spec::Cygwin;
 
-plan 74;
+plan 104;
 my $cygwin = File::Spec::Cygwin;
 
-say "# File::Spec::cygwin";
-say "# canonpath tests";
+say "# File::Spec::Cygwin";
 my @canonpath =
 	'///../../..//./././a//b/.././c/././',   '/a/b/../c',
 	'',                       '',
@@ -18,12 +17,13 @@ my @canonpath =
 	'/a/./',                  '/a',
 	'/a/.',                   '/a',
 	'/../../',                '/',
-	'/../..',                 '/';
+	'/../..',                 '/',
+        'a:\\b\\c',               'a:/b/c',
+	'c:a\\.\\b',              'c:a/b';
 for @canonpath -> $in, $out {
 	is $cygwin.canonpath($in), $out, "canonpath: '$in' -> '$out'";
 }
 
-say "# splitdir tests";
 my @splitdir =
 	'',           '',
 	'/d1/d2/d3/', ',d1,d2,d3,',
@@ -35,31 +35,69 @@ for @splitdir -> $in, $out {
 	is $cygwin.splitdir(|$in).join(','), $out, "splitdir: '$in' -> '$out'"
 }
 
-say "# catdir tests";
 is $cygwin.catdir(),                        '', "No argument returns empty string";
 my @catdir =
-	$( ),                   '',
+	$( ),                    '',
 	$('/'),                  '/',
 	$('','d1','d2','d3',''), '/d1/d2/d3',
 	$('d1','d2','d3',''),    'd1/d2/d3',
 	$('','d1','d2','d3'),    '/d1/d2/d3',
 	$('d1','d2','d3'),       'd1/d2/d3',
-	$('/','d2/d3'),     '/d2/d3';
+	$('/','d2/d3'),          '/d2/d3',
+        $('/','/d1/d2'),         '/d1/d2',
+        $('//notreally','/UNC'), '/notreally/UNC';
 for @catdir -> $in, $out {
 	is $cygwin.catdir(|$in), $out, "catdir: {$in.perl} -> '$out'";
 }
 
+my @split = 
+	'/',               ',/,/',
+	'.',               ',.,.',
+	'file',            ',.,file',
+	'/dir',            ',/,dir',
+	'/d1/d2/d3/',      ',/d1/d2,d3',
+	'd1/d2/d3/',       ',d1/d2,d3',
+	'/d1/d2/d3/.',     ',/d1/d2/d3,.',
+	'/d1/d2/d3/..',    ',/d1/d2/d3,..',
+	'/d1/d2/d3/.file', ',/d1/d2/d3,.file',
+	'd1/d2/d3/file',   ',d1/d2/d3,file',
+	'/../../d1/',      ',/../..,d1',
+	'/././d1/',        ',/./.,d1',
+	'c:/d1\\d2\\',    'c:,/d1,d2',
+        '//unc/share',     '//unc/share,/,/';
+for @split -> $in, $out {
+	is $cygwin.split(|$in).join(','), $out, "split: {$in.perl} -> '$out'"
+}
+
+say "# join tests";
+my @join = 
+	$('','','file'),            'file',
+	$('','/d1/d2/d3/',''),      '/d1/d2/d3/',
+	$('','d1/d2/d3/',''),       'd1/d2/d3/',
+	$('','/d1/d2/d3/.',''),     '/d1/d2/d3/.',
+	$('','/d1/d2/d3/..',''),    '/d1/d2/d3/..',
+	$('','/d1/d2/d3/','.file'), '/d1/d2/d3/.file',
+	$('','d1/d2/d3/','file'),   'd1/d2/d3/file',
+	$('','/../../d1/',''),      '/../../d1/',
+	$('','/././d1/',''),        '/././d1/',
+	$('d:','d2/d3/',''),        'd:d2/d3/',
+	$('d:/','d2','d3/'),        'd:/d2/d3/';
+for @join -> $in, $out {
+	is $cygwin.join(|$in), $out, "join: {$in.perl} -> '$out'"
+}
+
+
 say "# splitpath tests";
 my @splitpath = 
-	$('file'),            ',,file',
-	$('/d1/d2/d3/'),      ',/d1/d2/d3/,',
-	$('d1/d2/d3/'),       ',d1/d2/d3/,',
-	$('/d1/d2/d3/.'),     ',/d1/d2/d3/.,',
-	$('/d1/d2/d3/..'),    ',/d1/d2/d3/..,',
-	$('/d1/d2/d3/.file'), ',/d1/d2/d3/,.file',
-	$('d1/d2/d3/file'),   ',d1/d2/d3/,file',
-	$('/../../d1/'),      ',/../../d1/,',
-	$('/././d1/'),        ',/././d1/,';
+	'file',            ',,file',
+	'/d1/d2/d3/',      ',/d1/d2/d3/,',
+	'd1/d2/d3/',       ',d1/d2/d3/,',
+	'/d1/d2/d3/.',     ',/d1/d2/d3/.,',
+	'/d1/d2/d3/..',    ',/d1/d2/d3/..,',
+	'/d1/d2/d3/.file', ',/d1/d2/d3/,.file',
+	'd1/d2/d3/file',   ',d1/d2/d3/,file',
+	'/../../d1/',      ',/../../d1/,',
+	'/././d1/',        ',/././d1/,';
 for @splitpath -> $in, $out {
 	is $cygwin.splitpath(|$in).join(','), $out, "splitpath: {$in.perl} -> '$out'"
 }
@@ -103,7 +141,6 @@ my @abs2rel =
 	$('///','/t1/t2/t3'),                '../../..',
 	$('/.','/t1/t2/t3'),                 '../../..',
 	$('/./','/t1/t2/t3'),                '../../..',
-#	$('../t4','/t1/t2/t3'),              '../t4',
 	$('/t1/t2/t3', '/'),                 't1/t2/t3',
 	$('/t1/t2/t3', '/t1'),               't2/t3',
 	$('t1/t2/t3', 't1'),                 't2/t3',
@@ -137,14 +174,9 @@ if $*OS !~~ any(<cygwin>) {
 }
 else {
 	# double check a couple of things to see if File::Spec loaded correctly
-	#is File::Spec.devnull, '/dev/null', 'devnull is nul';
-	is File::Spec.rootdir, '\\',  'rootdir is "\\"';
-	#tmpdir
-	#no-upwards
+	is File::Spec.rootdir, '\\',  'File::Spec loads Cygwin';
+	ok {.IO.d && .IO.w}.(File::Spec.tmpdir), "tmpdir: {File::Spec.tmpdir} is a writable directory";
 	is File::Spec.case-tolerant, True, 'case-tolerant is True';
-
-	#join
-
 }
 
 done;
diff --git a/t/01_epoc.t b/t/01_epoc.t
diff --git a/t/01_unix.t b/t/01_unix.t
@@ -165,7 +165,7 @@ if $*OS ~~ any(<MacOS MSWin32 os2 VMS epoc NetWare symbian dos cygwin>) {
 else {
 	is File::Spec.MODULE, "File::Spec::Unix", "unix: loads correct module";
 	is File::Spec.rel2abs( File::Spec.curdir ), $*CWD, "rel2abs: \$*CWD test";
-	ok File::Spec.tmpdir.IO.d && File::Spec.tmpdir.IO.w, "tmpdir: {File::Spec.tmpdir} is a writable directory";
+	ok {.IO.d && .IO.w}.(File::Spec.tmpdir), "tmpdir: {File::Spec.tmpdir} is a writable directory";
 	#case-tolerant
 	if (cwd.IO ~~ :w) {
 		"casetol.tmp".IO.e or spurt "casetol.tmp", "temporary test file, delete after reading";