local-lib5/lib/perl5/URI/file/Mac.pm

   1 package URI::file::Mac;
   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
  10
  11 sub _file_extract_path
  12 {
  13     my $class = shift;
  14     my $path = shift;
  15
  16     my @pre;
  17     if ($path =~ s/^(:+)//) {
  18         if (length($1) == 1) {
  19             @pre = (".") unless length($path);
  20         } else {
  21             @pre = ("..") x (length($1) - 1);
  22         }
  23     } else { #absolute
  24         $pre[0] = "";
  25     }
  26
  27     my $isdir = ($path =~ s/:$//);
  28     $path =~ s,([%/;]), URI::Escape::escape_char($1),eg;
  29
  30     my @path = split(/:/, $path, -1);
  31     for (@path) {
  32         if ($_ eq "." || $_ eq "..") {
  33             $_ = "%2E" x length($_);
  34         }
  35         $_ = ".." unless length($_);
  36     }
  37     push (@path,"") if $isdir;
  38     (join("/", @pre, @path), 1);
  39 }
  40
  41
  42 sub file
  43 {
  44     my $class = shift;
  45     my $uri = shift;
  46     my @path;
  47
  48     my $auth = $uri->authority;
  49     if (defined $auth) {
  50         if (lc($auth) ne "localhost" && $auth ne "") {
  51             my $u_auth = uri_unescape($auth);
  52             if (!$class->_file_is_localhost($u_auth)) {
  53                 # some other host (use it as volume name)
  54                 @path = ("", $auth);
  55                 # XXX or just return to make it illegal;
  56             }
  57         }
  58     }
  59     my @ps = split("/", $uri->path, -1);
  60     shift @ps if @path;
  61     push(@path, @ps);
  62
  63     my $pre = "";
  64     if (!@path) {
  65         return;  # empty path; XXX return ":" instead?
  66     } elsif ($path[0] eq "") {
  67         # absolute
  68         shift(@path);
  69         if (@path == 1) {
  70             return if $path[0] eq "";  # not root directory
  71             push(@path, "");           # volume only, effectively append ":"
  72         }
  73         @ps = @path;
  74         @path = ();
  75         my $part;
  76         for (@ps) {  #fix up "." and "..", including interior, in relatives
  77             next if $_ eq ".";
  78             $part = $_ eq ".." ? "" : $_;
  79             push(@path,$part);
  80         }
  81         if ($ps[-1] eq "..") {  #if this happens, we need another :
  82             push(@path,"");
  83         }
  84
  85     } else {
  86         $pre = ":";
  87         @ps = @path;
  88         @path = ();
  89         my $part;
  90         for (@ps) {  #fix up "." and "..", including interior, in relatives
  91             next if $_ eq ".";
  92             $part = $_ eq ".." ? "" : $_;
  93             push(@path,$part);
  94         }
  95         if ($ps[-1] eq "..") {  #if this happens, we need another :
  96             push(@path,"");
  97         }
  98
  99     }
 100     return unless $pre || @path;
 101     for (@path) {
 102         s/;.*//;  # get rid of parameters
 103         #return unless length; # XXX
 104         $_ = uri_unescape($_);
 105         return if /\0/;
 106         return if /:/;  # Should we?
 107     }
 108     $pre . join(":", @path);
 109 }
 110
 111 sub dir
 112 {
 113     my $class = shift;
 114     my $path = $class->file(@_);
 115     return unless defined $path;
 116     $path .= ":" unless $path =~ /:$/;
 117     $path;
 118 }
 119
 120 1;