home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / URI / file / Win32.pm < prev   
Encoding:
Perl POD Document  |  2004-09-07  |  1.7 KB  |  85 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 _file_extract_authority
  10. {
  11.     my $class = shift;
  12.  
  13.     return $class->SUPER::_file_extract_authority($_[0])
  14.     if defined $URI::file::DEFAULT_AUTHORITY;
  15.  
  16.     return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
  17.     return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
  18.  
  19.     if ($_[0] =~ s,^([a-zA-Z]:),,) {
  20.     my $auth = $1;
  21.     $auth .= "relative" if $_[0] !~ m,^[\\/],;
  22.     return $auth;
  23.     }
  24.     return undef;
  25. }
  26.  
  27. sub _file_extract_path
  28. {
  29.     my($class, $path) = @_;
  30.     $path =~ s,\\,/,g;
  31.     #$path =~ s,//+,/,g;
  32.     $path =~ s,(/\.)+/,/,g;
  33.  
  34.     if (defined $URI::file::DEFAULT_AUTHORITY) {
  35.     $path =~ s,^([a-zA-Z]:),/$1,;
  36.     }
  37.  
  38.     return $path;
  39. }
  40.  
  41. sub _file_is_absolute {
  42.     my($class, $path) = @_;
  43.     return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
  44. }
  45.  
  46. sub file
  47. {
  48.     my $class = shift;
  49.     my $uri = shift;
  50.     my $auth = $uri->authority;
  51.     my $rel; # is filename relative to drive specified in authority
  52.     if (defined $auth) {
  53.         $auth = uri_unescape($auth);
  54.     if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
  55.         $auth = uc($1) . ":";
  56.         $rel++ if $2;
  57.     } elsif (lc($auth) eq "localhost") {
  58.         $auth = "";
  59.     } elsif (length $auth) {
  60.         $auth = "\\\\" . $auth;  # UNC
  61.     }
  62.     } else {
  63.     $auth = "";
  64.     }
  65.  
  66.     my @path = $uri->path_segments;
  67.     for (@path) {
  68.     return undef if /\0/;
  69.     return undef if /\//;
  70.     #return undef if /\\/;        # URLs with "\" is not uncommon
  71.     }
  72.     return undef unless $class->fix_path(@path);
  73.  
  74.     my $path = join("\\", @path);
  75.     $path =~ s/^\\// if $rel;
  76.     $path = $auth . $path;
  77.     $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
  78.  
  79.     return $path;
  80. }
  81.  
  82. sub fix_path { 1; }
  83.  
  84. 1;
  85.