home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _68d189f7b89d949a20068fd248c6dd7f < prev    next >
Encoding:
Text File  |  2000-03-15  |  1.4 KB  |  71 lines
  1. package URI::file::Win32;
  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 extract_authority
  10. {
  11.     my $class = shift;
  12.     return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
  13.     return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
  14.  
  15.     if ($_[0] =~ s,^([a-zA-Z]:),,) {
  16.     my $auth = $1;
  17.     $auth .= "relative" if $_[0] !~ m,^[\\/],;
  18.     return $auth;
  19.     }
  20.     return;
  21. }
  22.  
  23. sub extract_path
  24. {
  25.     my($class, $path) = @_;
  26.     $path =~ s,\\,/,g;
  27.     $path =~ s,//+,/,g;
  28.     $path =~ s,(/\.)+/,/,g;
  29.     $path;
  30. }
  31.  
  32. sub file
  33. {
  34.     my $class = shift;
  35.     my $uri = shift;
  36.     my $auth = $uri->authority;
  37.     my $rel; # is filename relative to drive specified in authority
  38.     if (defined $auth) {
  39.         $auth = uri_unescape($auth);
  40.     if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
  41.         $auth = uc($1) . ":";
  42.         $rel++ if $2;
  43.     } elsif (lc($auth) eq "localhost") {
  44.         $auth = "";
  45.     } elsif (length $auth) {
  46.         $auth = "\\\\" . $auth;  # UNC
  47.     }
  48.     } else {
  49.     $auth = "";
  50.     }
  51.  
  52.     my @path = $uri->path_segments;
  53.     for (@path) {
  54.     return if /\0/;
  55.     return if /\//;
  56.     #return if /\\/;        # URLs with "\" is not uncommon
  57.     
  58.     }
  59.     return unless $class->fix_path(@path);
  60.  
  61.     my $path = join("\\", @path);
  62.     $path =~ s/^\\// if $rel;
  63.     $path = $auth . $path;
  64.     $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
  65.     $path;
  66. }
  67.  
  68. sub fix_path { 1; }
  69.  
  70. 1;
  71.