Commit | Line | Data |
3fea05b9 |
1 | package URI::_generic; |
2 | require URI; |
3 | require URI::_query; |
4 | @ISA=qw(URI URI::_query); |
5 | |
6 | use strict; |
7 | use URI::Escape qw(uri_unescape); |
8 | use Carp (); |
9 | |
10 | my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; |
11 | my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; |
12 | |
13 | sub _no_scheme_ok { 1 } |
14 | |
15 | sub authority |
16 | { |
17 | my $self = shift; |
18 | $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; |
19 | |
20 | if (@_) { |
21 | my $auth = shift; |
22 | $$self = $1; |
23 | my $rest = $3; |
24 | if (defined $auth) { |
25 | $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego; |
26 | $$self .= "//$auth"; |
27 | } |
28 | _check_path($rest, $$self); |
29 | $$self .= $rest; |
30 | } |
31 | $2; |
32 | } |
33 | |
34 | sub path |
35 | { |
36 | my $self = shift; |
37 | $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; |
38 | |
39 | if (@_) { |
40 | $$self = $1; |
41 | my $rest = $3; |
42 | my $new_path = shift; |
43 | $new_path = "" unless defined $new_path; |
44 | $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego; |
45 | _check_path($new_path, $$self); |
46 | $$self .= $new_path . $rest; |
47 | } |
48 | $2; |
49 | } |
50 | |
51 | sub path_query |
52 | { |
53 | my $self = shift; |
54 | $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; |
55 | |
56 | if (@_) { |
57 | $$self = $1; |
58 | my $rest = $3; |
59 | my $new_path = shift; |
60 | $new_path = "" unless defined $new_path; |
61 | $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; |
62 | _check_path($new_path, $$self); |
63 | $$self .= $new_path . $rest; |
64 | } |
65 | $2; |
66 | } |
67 | |
68 | sub _check_path |
69 | { |
70 | my($path, $pre) = @_; |
71 | my $prefix; |
72 | if ($pre =~ m,/,) { # authority present |
73 | $prefix = "/" if length($path) && $path !~ m,^[/?\#],; |
74 | } |
75 | else { |
76 | if ($path =~ m,^//,) { |
77 | Carp::carp("Path starting with double slash is confusing") |
78 | if $^W; |
79 | } |
80 | elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) { |
81 | Carp::carp("Path might look like scheme, './' prepended") |
82 | if $^W; |
83 | $prefix = "./"; |
84 | } |
85 | } |
86 | substr($_[0], 0, 0) = $prefix if defined $prefix; |
87 | } |
88 | |
89 | sub path_segments |
90 | { |
91 | my $self = shift; |
92 | my $path = $self->path; |
93 | if (@_) { |
94 | my @arg = @_; # make a copy |
95 | for (@arg) { |
96 | if (ref($_)) { |
97 | my @seg = @$_; |
98 | $seg[0] =~ s/%/%25/g; |
99 | for (@seg) { s/;/%3B/g; } |
100 | $_ = join(";", @seg); |
101 | } |
102 | else { |
103 | s/%/%25/g; s/;/%3B/g; |
104 | } |
105 | s,/,%2F,g; |
106 | } |
107 | $self->path(join("/", @arg)); |
108 | } |
109 | return $path unless wantarray; |
110 | map {/;/ ? $self->_split_segment($_) |
111 | : uri_unescape($_) } |
112 | split('/', $path, -1); |
113 | } |
114 | |
115 | |
116 | sub _split_segment |
117 | { |
118 | my $self = shift; |
119 | require URI::_segment; |
120 | URI::_segment->new(@_); |
121 | } |
122 | |
123 | |
124 | sub abs |
125 | { |
126 | my $self = shift; |
127 | my $base = shift || Carp::croak("Missing base argument"); |
128 | |
129 | if (my $scheme = $self->scheme) { |
130 | return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME; |
131 | $base = URI->new($base) unless ref $base; |
132 | return $self unless $scheme eq $base->scheme; |
133 | } |
134 | |
135 | $base = URI->new($base) unless ref $base; |
136 | my $abs = $self->clone; |
137 | $abs->scheme($base->scheme); |
138 | return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o; |
139 | $abs->authority($base->authority); |
140 | |
141 | my $path = $self->path; |
142 | return $abs if $path =~ m,^/,; |
143 | |
144 | if (!length($path)) { |
145 | my $abs = $base->clone; |
146 | my $query = $self->query; |
147 | $abs->query($query) if defined $query; |
148 | $abs->fragment($self->fragment); |
149 | return $abs; |
150 | } |
151 | |
152 | my $p = $base->path; |
153 | $p =~ s,[^/]+$,,; |
154 | $p .= $path; |
155 | my @p = split('/', $p, -1); |
156 | shift(@p) if @p && !length($p[0]); |
157 | my $i = 1; |
158 | while ($i < @p) { |
159 | #print "$i ", join("/", @p), " ($p[$i])\n"; |
160 | if ($p[$i-1] eq ".") { |
161 | splice(@p, $i-1, 1); |
162 | $i-- if $i > 1; |
163 | } |
164 | elsif ($p[$i] eq ".." && $p[$i-1] ne "..") { |
165 | splice(@p, $i-1, 2); |
166 | if ($i > 1) { |
167 | $i--; |
168 | push(@p, "") if $i == @p; |
169 | } |
170 | } |
171 | else { |
172 | $i++; |
173 | } |
174 | } |
175 | $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/." |
176 | if ($URI::ABS_REMOTE_LEADING_DOTS) { |
177 | shift @p while @p && $p[0] =~ /^\.\.?$/; |
178 | } |
179 | $abs->path("/" . join("/", @p)); |
180 | $abs; |
181 | } |
182 | |
183 | # The oposite of $url->abs. Return a URI which is as relative as possible |
184 | sub rel { |
185 | my $self = shift; |
186 | my $base = shift || Carp::croak("Missing base argument"); |
187 | my $rel = $self->clone; |
188 | $base = URI->new($base) unless ref $base; |
189 | |
190 | #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)}; |
191 | my $scheme = $rel->scheme; |
192 | my $auth = $rel->canonical->authority; |
193 | my $path = $rel->path; |
194 | |
195 | if (!defined($scheme) && !defined($auth)) { |
196 | # it is already relative |
197 | return $rel; |
198 | } |
199 | |
200 | #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)}; |
201 | my $bscheme = $base->scheme; |
202 | my $bauth = $base->canonical->authority; |
203 | my $bpath = $base->path; |
204 | |
205 | for ($bscheme, $bauth, $auth) { |
206 | $_ = '' unless defined |
207 | } |
208 | |
209 | unless ($scheme eq $bscheme && $auth eq $bauth) { |
210 | # different location, can't make it relative |
211 | return $rel; |
212 | } |
213 | |
214 | for ($path, $bpath) { $_ = "/$_" unless m,^/,; } |
215 | |
216 | # Make it relative by eliminating scheme and authority |
217 | $rel->scheme(undef); |
218 | $rel->authority(undef); |
219 | |
220 | # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>. |
221 | # First we calculate common initial path components length ($li). |
222 | my $li = 1; |
223 | while (1) { |
224 | my $i = index($path, '/', $li); |
225 | last if $i < 0 || |
226 | $i != index($bpath, '/', $li) || |
227 | substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li); |
228 | $li=$i+1; |
229 | } |
230 | # then we nuke it from both paths |
231 | substr($path, 0,$li) = ''; |
232 | substr($bpath,0,$li) = ''; |
233 | |
234 | if ($path eq $bpath && |
235 | defined($rel->fragment) && |
236 | !defined($rel->query)) { |
237 | $rel->path(""); |
238 | } |
239 | else { |
240 | # Add one "../" for each path component left in the base path |
241 | $path = ('../' x $bpath =~ tr|/|/|) . $path; |
242 | $path = "./" if $path eq ""; |
243 | $rel->path($path); |
244 | } |
245 | |
246 | $rel; |
247 | } |
248 | |
249 | 1; |