home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _deec4d6fc4b911130f008a032a388fde < prev    next >
Encoding:
Text File  |  2000-03-15  |  2.5 KB  |  121 lines
  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 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::escapes{$1},g;
  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") {
  51.         my $u_auth = uri_unescape($auth);
  52.         if (!$class->is_this_host($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;
  121.