diff --git a/lib/Path/Class/Dir.pm b/lib/Path/Class/Dir.pm index ee176a4..6eddfaf 100644 --- a/lib/Path/Class/Dir.pm +++ b/lib/Path/Class/Dir.pm @@ -26,12 +26,12 @@ sub new { return if @_==1 && !defined($_[0]); my $s = $self->_spec; - + my $first = (@_ == 0 ? $s->curdir : $_[0] eq '' ? (shift, $s->rootdir) : shift() ); - + $self->{dirs} = []; if ( Scalar::Util::blessed($first) && $first->isa("Path::Class::Dir") ) { $self->{volume} = $first->{volume}; @@ -63,7 +63,7 @@ sub as_foreign { local $self->{file_spec_class} = $self->_spec_class($type); $self->SUPER::new; }; - + # Clone internal structure $foreign->{volume} = $self->{volume}; my ($u, $fu) = ($self->_spec->updir, $foreign->_spec->updir); @@ -92,12 +92,12 @@ sub dir_list { my $self = shift; my $d = $self->{dirs}; return @$d unless @_; - + my $offset = shift; if ($offset < 0) { $offset = $#$d + $offset + 1 } - + return wantarray ? @$d[$offset .. $#$d] : $d->[$offset] unless @_; - + my $length = shift; if ($length < 0) { $length = $#$d + $length + 1 - $offset } return @$d[$offset .. $length + $offset - 1]; @@ -184,14 +184,14 @@ sub traverse_if { sub recurse { my $self = shift; my %opts = (preorder => 1, depthfirst => 0, @_); - + my $callback = $opts{callback} or Carp::croak( "Must provide a 'callback' parameter to recurse()" ); - + my @queue = ($self); - + my $visit_entry; - my $visit_dir = + my $visit_dir = $opts{depthfirst} && $opts{preorder} ? sub { my $dir = shift; @@ -213,13 +213,13 @@ sub recurse { $visit_entry->($_) foreach $dir->children; $callback->($dir); }; - + $visit_entry = sub { my $entry = shift; if ($entry->is_dir) { $visit_dir->($entry) } # Will call $callback else { $callback->($entry) } }; - + while (@queue) { $visit_entry->( shift @queue ); } @@ -227,9 +227,9 @@ sub recurse { sub children { my ($self, %opts) = @_; - + my $dh = $self->open or Carp::croak( "Can't open directory $self: $!" ); - + my @out; while (defined(my $entry = $dh->read)) { next if !$opts{all} && $self->_is_local_dot_dir($entry); @@ -252,14 +252,14 @@ sub next { unless ($self->{dh}) { $self->{dh} = $self->open or Carp::croak( "Can't open directory $self: $!" ); } - + my $next = $self->{dh}->read; unless (defined $next) { delete $self->{dh}; ## no critic return undef; } - + # Figure out whether it's a file or directory my $file = $self->file($next); $file = $self->subdir($next) if -d $file; @@ -269,10 +269,10 @@ sub next { sub subsumes { my ($self, $other) = @_; die "No second entity given to subsumes()" unless $other; - + $other = $self->new($other) unless UNIVERSAL::isa($other, "Path::Class::Entity"); $other = $other->dir unless $other->is_dir; - + if ($self->is_absolute) { $other = $other->absolute; } elsif ($other->is_absolute) { @@ -289,7 +289,7 @@ sub subsumes { # The root dir subsumes everything (but ignore the volume because # we've already checked that) return 1 if "@{$self->{dirs}}" eq "@{$self->new('')->{dirs}}"; - + my $i = 0; while ($i <= $#{ $self->{dirs} }) { return 0 if $i > $#{ $other->{dirs} }; @@ -319,30 +319,30 @@ Path::Class::Dir - Objects representing directories =head1 SYNOPSIS use Path::Class; # Exports dir() by default - + my $dir = dir('foo', 'bar'); # Path::Class::Dir object my $dir = Path::Class::Dir->new('foo', 'bar'); # Same thing - + # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc. print "dir: $dir\n"; - + if ($dir->is_absolute) { ... } if ($dir->is_relative) { ... } - + my $v = $dir->volume; # Could be 'C:' on Windows, empty string # on Unix, 'Macintosh HD:' on Mac OS - + $dir->cleanup; # Perform logical cleanup of pathname $dir->resolve; # Perform physical cleanup of pathname - + my $file = $dir->file('file.txt'); # A file in this directory my $subdir = $dir->subdir('george'); # A subdirectory my $parent = $dir->parent; # The parent directory, 'foo' - + my $abs = $dir->absolute; # Transform to absolute path my $rel = $abs->relative; # Transform to relative path my $rel = $abs->relative('/foo'); # Relative to /foo - + print $dir->as_foreign('Mac'); # :foo:bar: print $dir->as_foreign('Win32'); # foo\bar @@ -352,7 +352,7 @@ Path::Class::Dir - Objects representing directories $file = $dir->file($file); # Turn into Path::Class::File object ... } - + # Iterate with Path::Class methods: while (my $file = $dir->next) { # $file is a Path::Class::File or Path::Class::Dir object @@ -495,13 +495,13 @@ directories: print "Absolute: $dir\n"; $dir = $dir->parent; } - + $dir = dir('foo/bar'); for (1..6) { print "Relative: $dir\n"; $dir = $dir->parent; } - + ########### Output on Unix ################ Absolute: /foo/bar Absolute: /foo @@ -753,7 +753,7 @@ Canonical example: my ($child, $cont) = @_; # do something with $child return $cont->(); - }, + }, sub { my ($child) = @_; # Process only readable items @@ -810,6 +810,10 @@ Returns the class which should be used to create file objects. Generally overridden whenever this class is subclassed. +=item $uri = $dir->as_uri(); + +Returns a L object. + =back =head1 AUTHOR diff --git a/lib/Path/Class/Entity.pm b/lib/Path/Class/Entity.pm index 94585ec..61b37c8 100644 --- a/lib/Path/Class/Entity.pm +++ b/lib/Path/Class/Entity.pm @@ -6,6 +6,7 @@ use File::Spec 3.26; use File::stat (); use Cwd; use Carp(); +use URI::file; use overload ( @@ -43,11 +44,11 @@ sub new_foreign { sub _spec { (ref($_[0]) && $_[0]->{file_spec_class}) || 'File::Spec' } sub boolify { 1 } - -sub is_absolute { + +sub is_absolute { # 5.6.0 has a bug with regexes and stringification that's ticked by # file_name_is_absolute(). Help it along with an explicit stringify(). - $_[0]->_spec->file_name_is_absolute($_[0]->stringify) + $_[0]->_spec->file_name_is_absolute($_[0]->stringify) } sub is_relative { ! $_[0]->is_absolute } @@ -85,6 +86,12 @@ sub relative { sub stat { File::stat::stat("$_[0]") } sub lstat { File::stat::lstat("$_[0]") } +sub as_uri { + my $self = shift; + my $os = shift; + return URI::file->new( $self->stringify, $os || $^O ); +} + sub PRUNE { return \&PRUNE; } 1; diff --git a/lib/Path/Class/File.pm b/lib/Path/Class/File.pm index e097e1d..5dee5e1 100644 --- a/lib/Path/Class/File.pm +++ b/lib/Path/Class/File.pm @@ -493,6 +493,10 @@ Moves the C<$file> to C<$dest>, and updates C<$file> accordingly. It returns C<$file> is successful, C otherwise. +=item $uri = $file->as_uri(); + +Returns a L object. + =back =head1 AUTHOR diff --git a/t/08-as_uri.t b/t/08-as_uri.t new file mode 100644 index 0000000..8454adb --- /dev/null +++ b/t/08-as_uri.t @@ -0,0 +1,80 @@ +BEGIN { + $^O = 'Unix'; # Test in Unix mode +} + +use strict; + +use Path::Class; +use Test::More; + +my @tests = ( + { + line => __LINE__, + file => 'file.txt', + uri => 'file.txt', + }, + + { + line => __LINE__, + file => 'file.txt', + uri => 'file.txt', + os => 'win32', + }, + + { + line => __LINE__, + file => '/file.txt', + uri => 'file:///file.txt', + }, + + { + line => __LINE__, + file => '/file.txt', + uri => 'file:///file.txt', + os => 'win32', + }, + + { + line => __LINE__, + file => 'c:\file.txt', + uri => 'file:///c:/file.txt', + os => 'win32', + }, + + { + line => __LINE__, + file => '/foo/file.txt', + uri => 'file:///foo/file.txt', + }, + + { + line => __LINE__, + dir => '/foo/bar', + uri => 'file:///foo/bar', + }, + + { + line => __LINE__, + dir => '/foo/bar/', + uri => 'file:///foo/bar', + }, +); + +foreach my $test (@tests) { + + my $type = (exists $test->{file}) ? 'file' : 'dir'; + my $method = __PACKAGE__->can($type); + my $name = $test->{$type}; + + ok(my $obj = $method->($name), "${type}('${name}')"); + + can_ok($obj, 'as_uri'); + + my $uri = $obj->as_uri( $test->{os} ); + + isa_ok($uri, 'URI::file'); + + is($uri, $test->{uri}, "URI::file"); +} + +done_testing;