From b11ecb94152bcf3ddda6281e59e76b81b599378f Mon Sep 17 00:00:00 2001 From: Robert Rothenberg Date: Thu, 30 Jan 2014 21:41:15 +0000 Subject: [PATCH 1/5] Added as_uri method --- lib/Path/Class/Entity.pm | 12 ++++++--- t/08-as_uri.t | 56 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+), 3 deletions(-) create mode 100644 t/08-as_uri.t diff --git a/lib/Path/Class/Entity.pm b/lib/Path/Class/Entity.pm index 94585ec..d784519 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,11 @@ sub relative { sub stat { File::stat::stat("$_[0]") } sub lstat { File::stat::lstat("$_[0]") } +sub as_uri { + my $self = shift; + return URI::file->new( $self->stringify ); +} + sub PRUNE { return \&PRUNE; } 1; diff --git a/t/08-as_uri.t b/t/08-as_uri.t new file mode 100644 index 0000000..a84f040 --- /dev/null +++ b/t/08-as_uri.t @@ -0,0 +1,56 @@ + +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:///file.txt', + }, + + { + 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; + + isa_ok($uri, 'URI::file'); + + is($uri, $test->{uri}, "URI::file"); +} + +done_testing; From 457376b305cbe6632e209d2292ff88958bda2a92 Mon Sep 17 00:00:00 2001 From: Robert Rothenberg Date: Thu, 30 Jan 2014 21:43:39 +0000 Subject: [PATCH 2/5] Ensure test mode treats OS as Unix --- t/08-as_uri.t | 3 +++ 1 file changed, 3 insertions(+) diff --git a/t/08-as_uri.t b/t/08-as_uri.t index a84f040..c3a2247 100644 --- a/t/08-as_uri.t +++ b/t/08-as_uri.t @@ -1,3 +1,6 @@ +BEGIN { + $^O = 'Unix'; # Test in Unix mode +} use strict; From b251b5d48ca7da29eddd4f9e66315470cd6002dc Mon Sep 17 00:00:00 2001 From: Robert Rothenberg Date: Mon, 3 Feb 2014 19:58:57 +0000 Subject: [PATCH 3/5] Added as_uri method to the POD - Added items for as_uri method to the POD. - Whitespace cleanup. --- lib/Path/Class/Dir.pm | 66 ++++++++++++++++++++++-------------------- lib/Path/Class/File.pm | 4 +++ 2 files changed, 39 insertions(+), 31 deletions(-) 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/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 From 8727cc6f2109bfb5585739f8b61085f075090d9f Mon Sep 17 00:00:00 2001 From: Robert Rothenberg Date: Mon, 3 Feb 2014 20:01:19 +0000 Subject: [PATCH 4/5] as_uri takes an OS parameter --- lib/Path/Class/Entity.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Path/Class/Entity.pm b/lib/Path/Class/Entity.pm index d784519..61b37c8 100644 --- a/lib/Path/Class/Entity.pm +++ b/lib/Path/Class/Entity.pm @@ -88,7 +88,8 @@ sub lstat { File::stat::lstat("$_[0]") } sub as_uri { my $self = shift; - return URI::file->new( $self->stringify ); + my $os = shift; + return URI::file->new( $self->stringify, $os || $^O ); } sub PRUNE { return \&PRUNE; } From c57b55c3f91edc5742bd2c26b6e322707af63479 Mon Sep 17 00:00:00 2001 From: Robert Rothenberg Date: Mon, 3 Feb 2014 20:04:26 +0000 Subject: [PATCH 5/5] Added tests for Win32 files --- t/08-as_uri.t | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/t/08-as_uri.t b/t/08-as_uri.t index c3a2247..8454adb 100644 --- a/t/08-as_uri.t +++ b/t/08-as_uri.t @@ -14,10 +14,31 @@ my @tests = ( 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', }, { @@ -49,7 +70,7 @@ foreach my $test (@tests) { can_ok($obj, 'as_uri'); - my $uri = $obj->as_uri; + my $uri = $obj->as_uri( $test->{os} ); isa_ok($uri, 'URI::file');