Commit | Line | Data |
3fea05b9 |
1 | package URI::file::Unix; |
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_path |
10 | { |
11 | my($class, $path) = @_; |
12 | |
13 | # tidy path |
14 | $path =~ s,//+,/,g; |
15 | $path =~ s,(/\.)+/,/,g; |
16 | $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" |
17 | |
18 | return $path; |
19 | } |
20 | |
21 | sub _file_is_absolute { |
22 | my($class, $path) = @_; |
23 | return $path =~ m,^/,; |
24 | } |
25 | |
26 | sub file |
27 | { |
28 | my $class = shift; |
29 | my $uri = shift; |
30 | my @path; |
31 | |
32 | my $auth = $uri->authority; |
33 | if (defined($auth)) { |
34 | if (lc($auth) ne "localhost" && $auth ne "") { |
35 | $auth = uri_unescape($auth); |
36 | unless ($class->_file_is_localhost($auth)) { |
37 | push(@path, "", "", $auth); |
38 | } |
39 | } |
40 | } |
41 | |
42 | my @ps = $uri->path_segments; |
43 | shift @ps if @path; |
44 | push(@path, @ps); |
45 | |
46 | for (@path) { |
47 | # Unix file/directory names are not allowed to contain '\0' or '/' |
48 | return undef if /\0/; |
49 | return undef if /\//; # should we really? |
50 | } |
51 | |
52 | return join("/", @path); |
53 | } |
54 | |
55 | 1; |