diff options
| -rw-r--r-- | ext/IO/lib/IO/Dir.pm | 14 | ||||
| -rw-r--r-- | lib/File/Copy.pm | 44 | ||||
| -rwxr-xr-x | t/lib/filecopy.t | 72 | ||||
| -rwxr-xr-x | t/lib/io_dir.t | 8 |
4 files changed, 110 insertions, 28 deletions
diff --git a/ext/IO/lib/IO/Dir.pm b/ext/IO/lib/IO/Dir.pm index 1fa07ed6b8..a2e3b5ef7f 100644 --- a/ext/IO/lib/IO/Dir.pm +++ b/ext/IO/lib/IO/Dir.pm @@ -6,7 +6,7 @@ package IO::Dir; -use 5.003_26; +use 5.6.0; use strict; use Carp; @@ -16,6 +16,7 @@ use IO::File; our(@ISA, $VERSION, @EXPORT_OK); use Tie::Hash; use File::stat; +use File::Spec; @ISA = qw(Tie::Hash Exporter); $VERSION = "1.03"; @@ -44,6 +45,9 @@ sub open { my ($dh, $dirname) = @_; return undef unless opendir($dh, $dirname); + # a dir name should always have a ":" in it; assume dirname is + # in current directory + $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) ); ${*$dh}{io_dir_path} = $dirname; 1; } @@ -103,18 +107,18 @@ sub NEXTKEY { sub EXISTS { my($dh,$key) = @_; - -e ${*$dh}{io_dir_path} . "/" . $key; + -e File::Spec->catfile(${*$dh}{io_dir_path}, $key); } sub FETCH { my($dh,$key) = @_; - &lstat(${*$dh}{io_dir_path} . "/" . $key); + &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key)); } sub STORE { my($dh,$key,$data) = @_; my($atime,$mtime) = ref($data) ? @$data : ($data,$data); - my $file = ${*$dh}{io_dir_path} . "/" . $key; + my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); unless(-e $file) { my $io = IO::File->new($file,O_CREAT | O_RDWR); $io->close if $io; @@ -125,7 +129,7 @@ sub STORE { sub DELETE { my($dh,$key) = @_; # Only unlink if unlink-ing is enabled - my $file = ${*$dh}{io_dir_path} . "/" . $key; + my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); return 0 unless ${*$dh}{io_dir_unlink}; diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 8757505b98..4a174713b2 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -11,6 +11,7 @@ use 5.6.0; use strict; use warnings; use Carp; +use File::Spec; our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); sub copy; sub syscopy; @@ -22,7 +23,7 @@ sub mv; # package has not yet been updated to work with Perl 5.004, and so it # would be a Bad Thing for the CPAN module to grab it and replace this # module. Therefore, we set this module's version higher than 2.0. -$VERSION = '2.03'; +$VERSION = '2.04'; require Exporter; @ISA = qw(Exporter); @@ -31,16 +32,19 @@ require Exporter; $Too_Big = 1024 * 1024 * 2; -sub _catname { # Will be replaced by File::Spec when it arrives +sub _catname { my($from, $to) = @_; if (not defined &basename) { require File::Basename; import File::Basename 'basename'; } - if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); } - elsif ($^O eq 'MacOS') { $to =~ s/^([^:]+)$/:$1/; $to .= ':' . basename($from); } - elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); } - else { $to .= '/' . basename($from); } + + if ($^O eq 'MacOS') { + # a partial dir name that's valid only in the cwd (e.g. 'tmp') + $to = ':' . $to if $to !~ /:/; + } + + return File::Spec->catfile($to, basename($from)); } sub copy { @@ -370,6 +374,34 @@ it sets C<$!>, deletes the output file, and returns 0. All functions return 1 on success, 0 on failure. $! will be set if an error was encountered. +=head1 NOTES + +=over 4 + +=item * + +On Mac OS (Classic), the path separator is ':', not '/', and the +current directory is denoted as ':', not '.'. You should be careful +about specifying relative pathnames. While a full path always begins +with a volume name, a relative pathname should always begin with a +':'. If specifying a volume name only, a trailing ':' is required. + +E.g. + + copy("file1", "tmp"); # creates the file 'tmp' in the current directory + copy("file1", ":tmp:"); # creates :tmp:file1 + copy("file1", ":tmp"); # same as above + copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do + # that, since it may cause confusion, see example #1) + copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume + copy("file1", ":tmp:file1"); # ok, partial path + copy("file1", "DataHD:"); # creates DataHD:file1 + + move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one + # volume to another + +=back + =head1 AUTHOR File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index 8412258a69..44b5827e72 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -3,12 +3,13 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + push @INC, "::lib:$MacPerl::Architecture" if $^O eq 'MacOS'; } $| = 1; my @pass = (0,1); -my $tests = 11; +my $tests = $^O eq 'MacOS' ? 14 : 11; printf "1..%d\n", $tests * scalar(@pass); use File::Copy; @@ -82,22 +83,65 @@ for my $pass (@pass) { print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; printf "ok %d\n", 9+$loopconst; - copy "file-$$", "lib"; - open(R, "lib/file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 10+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - move "file-$$", "lib"; - open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) - and not -e "file-$$";; - printf "ok %d\n", 11+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; + if ($^O eq 'MacOS') { + + copy "file-$$", "lib"; + open(R, ":lib:file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 10+$loopconst; + unlink ":lib:file-$$" or die "unlink: $!"; + + copy "file-$$", ":lib"; + open(R, ":lib:file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 11+$loopconst; + unlink ":lib:file-$$" or die "unlink: $!"; + + copy "file-$$", ":lib:"; + open(R, ":lib:file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 12+$loopconst; + unlink ":lib:file-$$" or die "unlink: $!"; + + unless (-e 'lib:') { # make sure there's no volume called 'lib' + undef $@; + eval { (copy "file-$$", "lib:") || die "'lib:' is not a volume name"; }; + print "# Died: $@"; + print "not " unless ( $@ =~ m|'lib:' is not a volume name| ); + } + printf "ok %d\n", 13+$loopconst; + + move "file-$$", ":lib:"; + open(R, ":lib:file-$$") or die "open :lib:file-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) + and not -e "file-$$";; + printf "ok %d\n", 14+$loopconst; + unlink ":lib:file-$$" or die "unlink: $!"; + + } else { + + copy "file-$$", "lib"; + open(R, "lib/file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 10+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + move "file-$$", "lib"; + open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) + and not -e "file-$$";; + printf "ok %d\n", 11+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + } } END { 1 while unlink "file-$$"; - 1 while unlink "lib/file-$$"; + if ($^O eq 'MacOS') { + 1 while unlink ":lib:file-$$"; + } else { + 1 while unlink "lib/file-$$"; + } } diff --git a/t/lib/io_dir.t b/t/lib/io_dir.t index 3689871555..6ec4e9f232 100755 --- a/t/lib/io_dir.t +++ b/t/lib/io_dir.t @@ -19,7 +19,9 @@ use IO::Dir qw(DIR_UNLINK); print "1..10\n"; -$dot = new IO::Dir "."; +my $DIR = $^O eq 'MacOS' ? ":" : "."; + +$dot = new IO::Dir $DIR; print defined($dot) ? "ok" : "not ok", " 1\n"; @a = sort <*>; @@ -41,7 +43,7 @@ open(FH,'>X') || die "Can't create x"; print FH "X"; close(FH); -tie %dir, IO::Dir, "."; +tie %dir, IO::Dir, $DIR; my @files = keys %dir; # I hope we do not have an empty dir :-) @@ -55,7 +57,7 @@ delete $dir{'X'}; print -f 'X' ? "ok" : "not ok", " 8\n"; -tie %dirx, IO::Dir, ".", DIR_UNLINK; +tie %dirx, IO::Dir, $DIR, DIR_UNLINK; my $statx = $dirx{'X'}; print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1 |