Commit | Line | Data |
3fea05b9 |
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; |