git.maemo.org Git - dh-make-perl/blob - dev/i386/liburi-perl/liburi-perl-1.35.dfsg.1/URI/file/Unix.pm

   1 package URI::file::Unix;
   2
   3 require URI::file::Base;
   4 @ISA=qw(URI::file::Base);
   5
   6 use strict;
   7 use URI::Escape qw(uri_unescape);
   8
   9 sub _file_extract_path
  10 {
  11     my($class, $path) = @_;
  12
  13     # tidy path
  14     $path =~ s,//+,/,g;
  15     $path =~ s,(/\.)+/,/,g;
  16     $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
  17
  18     return $path;
  19 }
  20
  21 sub _file_is_absolute {
  22     my($class, $path) = @_;
  23     return $path =~ m,^/,;
  24 }
  25
  26 sub file
  27 {
  28     my $class = shift;
  29     my $uri = shift;
  30     my @path;
  31
  32     my $auth = $uri->authority;
  33     if (defined($auth)) {
  34         if (lc($auth) ne "localhost" && $auth ne "") {
  35             $auth = uri_unescape($auth);
  36             unless ($class->_file_is_localhost($auth)) {
  37                 push(@path, "", "", $auth);
  38             }
  39         }
  40     }
  41
  42     my @ps = $uri->path_segments;
  43     shift @ps if @path;
  44     push(@path, @ps);
  45
  46     for (@path) {
  47         # Unix file/directory names are not allowed to contain '\0' or '/'
  48         return undef if /\0/;
  49         return undef if /\//;  # should we really?
  50     }
  51
  52     return join("/", @path);
  53 }
  54
  55 1;