Add an as_uri method

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,23 +213,23 @@ 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 );
   }
 }
 
 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<URI::file> object.
+
 =back
 
 =head1 AUTHOR

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;

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<undef> otherwise.
 
+=item $uri = $file->as_uri();
+
+Returns a L<URI::file> object.
+
 =back
 
 =head1 AUTHOR

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;