package IO::Dir;
-use 5.003_26;
+use 5.6.0;
use strict;
use Carp;
our(@ISA, $VERSION, @EXPORT_OK);
use Tie::Hash;
use File::stat;
+use File::Spec;
@ISA = qw(Tie::Hash Exporter);
$VERSION = "1.03";
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;
}
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;
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};
use strict;
use warnings;
use Carp;
+use File::Spec;
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
sub copy;
sub syscopy;
# 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);
$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 {
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,
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;
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-$$";
+ }
}
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 <*>;
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 :-)
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
projects / p5sagit/p5-mst-13.2.git / commitdiff