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