lib/URI/file/Unix.pm

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