1package URI::file::Win32; 2 3require URI::file::Base; 4@ISA=qw(URI::file::Base); 5 6use strict; 7use URI::Escape qw(uri_unescape); 8 9sub _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 27sub _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 41sub _file_is_absolute { 42 my($class, $path) = @_; 43 return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],; 44} 45 46sub 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 82sub fix_path { 1; } 83 841; 85