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;
|
---|