Commit | Line | Data |
3fea05b9 |
1 | package URI::file::Mac; |
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 | |
10 | |
11 | sub _file_extract_path |
12 | { |
13 | my $class = shift; |
14 | my $path = shift; |
15 | |
16 | my @pre; |
17 | if ($path =~ s/^(:+)//) { |
18 | if (length($1) == 1) { |
19 | @pre = (".") unless length($path); |
20 | } else { |
21 | @pre = ("..") x (length($1) - 1); |
22 | } |
23 | } else { #absolute |
24 | $pre[0] = ""; |
25 | } |
26 | |
27 | my $isdir = ($path =~ s/:$//); |
28 | $path =~ s,([%/;]), URI::Escape::escape_char($1),eg; |
29 | |
30 | my @path = split(/:/, $path, -1); |
31 | for (@path) { |
32 | if ($_ eq "." || $_ eq "..") { |
33 | $_ = "%2E" x length($_); |
34 | } |
35 | $_ = ".." unless length($_); |
36 | } |
37 | push (@path,"") if $isdir; |
38 | (join("/", @pre, @path), 1); |
39 | } |
40 | |
41 | |
42 | sub file |
43 | { |
44 | my $class = shift; |
45 | my $uri = shift; |
46 | my @path; |
47 | |
48 | my $auth = $uri->authority; |
49 | if (defined $auth) { |
50 | if (lc($auth) ne "localhost" && $auth ne "") { |
51 | my $u_auth = uri_unescape($auth); |
52 | if (!$class->_file_is_localhost($u_auth)) { |
53 | # some other host (use it as volume name) |
54 | @path = ("", $auth); |
55 | # XXX or just return to make it illegal; |
56 | } |
57 | } |
58 | } |
59 | my @ps = split("/", $uri->path, -1); |
60 | shift @ps if @path; |
61 | push(@path, @ps); |
62 | |
63 | my $pre = ""; |
64 | if (!@path) { |
65 | return; # empty path; XXX return ":" instead? |
66 | } elsif ($path[0] eq "") { |
67 | # absolute |
68 | shift(@path); |
69 | if (@path == 1) { |
70 | return if $path[0] eq ""; # not root directory |
71 | push(@path, ""); # volume only, effectively append ":" |
72 | } |
73 | @ps = @path; |
74 | @path = (); |
75 | my $part; |
76 | for (@ps) { #fix up "." and "..", including interior, in relatives |
77 | next if $_ eq "."; |
78 | $part = $_ eq ".." ? "" : $_; |
79 | push(@path,$part); |
80 | } |
81 | if ($ps[-1] eq "..") { #if this happens, we need another : |
82 | push(@path,""); |
83 | } |
84 | |
85 | } else { |
86 | $pre = ":"; |
87 | @ps = @path; |
88 | @path = (); |
89 | my $part; |
90 | for (@ps) { #fix up "." and "..", including interior, in relatives |
91 | next if $_ eq "."; |
92 | $part = $_ eq ".." ? "" : $_; |
93 | push(@path,$part); |
94 | } |
95 | if ($ps[-1] eq "..") { #if this happens, we need another : |
96 | push(@path,""); |
97 | } |
98 | |
99 | } |
100 | return unless $pre || @path; |
101 | for (@path) { |
102 | s/;.*//; # get rid of parameters |
103 | #return unless length; # XXX |
104 | $_ = uri_unescape($_); |
105 | return if /\0/; |
106 | return if /:/; # Should we? |
107 | } |
108 | $pre . join(":", @path); |
109 | } |
110 | |
111 | sub dir |
112 | { |
113 | my $class = shift; |
114 | my $path = $class->file(@_); |
115 | return unless defined $path; |
116 | $path .= ":" unless $path =~ /:$/; |
117 | $path; |
118 | } |
119 | |
120 | 1; |