File Coverage

blib/lib/URI/_generic.pm
Criterion Covered Total %
statement 171 177 96.6
branch 89 106 83.9
condition 35 44 79.5
subroutine 15 15 100.0
pod 6 6 100.0
total 316 348 90.8


line stmt bran cond sub pod time code
1             package URI::_generic;
2              
3 38     38   16213 use strict;
  38         84  
  38         1040  
4 38     38   171 use warnings;
  38         68  
  38         957  
5              
6 38     38   175 use parent qw(URI URI::_query);
  38         68  
  38         211  
7              
8 38     38   1983 use URI::Escape qw(uri_unescape);
  38         70  
  38         1604  
9 38     38   205 use Carp ();
  38         67  
  38         85452  
10              
11             our $VERSION = '5.20';
12              
13             my $ACHAR = URI::HAS_RESERVED_SQUARE_BRACKETS ? $URI::uric : $URI::uric4host; $ACHAR =~ s,\\[/?],,g;
14             my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
15              
16 353     353   1032 sub _no_scheme_ok { 1 }
17              
18             our $IPv6_re;
19              
20             sub _looks_like_raw_ip6_address {
21 319     319   478 my $addr = shift;
22              
23 319 100       675 if ( !$IPv6_re ) { #-- lazy / runs once / use Regexp::IPv6 if installed
24             eval {
25 21         3292 require Regexp::IPv6;
26 0         0 Regexp::IPv6->import( qw($IPv6_re) );
27 0         0 1;
28 21 50       45 } || do { $IPv6_re = qr/[:0-9a-f]{3,}/; }; #-- fallback: unambitious guess
  21         150  
29             }
30              
31 319 50       611 return 0 unless $addr;
32 319 100       1111 return 0 if $addr =~ tr/:/:/ < 2; #-- fallback must not create false positive for IPv4:Port = 0:0
33 26 100       339 return 1 if $addr =~ /^$IPv6_re$/i;
34 24         64 return 0;
35             }
36              
37              
38             sub authority
39             {
40 2351     2351 1 3220 my $self = shift;
41 2351 50       11449 $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
42              
43 2351 100       4555 if (@_) {
44 418         679 my $auth = shift;
45 418         787 $$self = $1;
46 418         681 my $rest = $3;
47 418 100       819 if (defined $auth) {
48 343         1056 $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
  7         17  
49 343 100       1630 if ( my ($user, $host) = $auth =~ /^(.*@)?([^@]+)$/ ) { #-- special escape userinfo part
50 319   100     1206 $user ||= '';
51 319         848 $user =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego;
  56         147  
52 319         584 $user =~ s/%40$/\@/; # recover final '@'
53 319 100       646 $host = "[$host]" if _looks_like_raw_ip6_address( $host );
54 319         636 $auth = $user . $host;
55             }
56 343         810 utf8::downgrade($auth);
57 343         726 $$self .= "//$auth";
58             }
59 418         922 _check_path($rest, $$self);
60 418         963 $$self .= $rest;
61             }
62 2351         6706 $2;
63             }
64              
65             sub path
66             {
67 1321     1321 1 1931 my $self = shift;
68 1321 50       5835 $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
69              
70 1321 100       2479 if (@_) {
71 301         646 $$self = $1;
72 301         474 my $rest = $3;
73 301         443 my $new_path = shift;
74 301 100       551 $new_path = "" unless defined $new_path;
75 301         842 $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
  191         368  
76 301         686 utf8::downgrade($new_path);
77 301         617 _check_path($new_path, $$self);
78 301         675 $$self .= $new_path . $rest;
79             }
80 1321         3332 $2;
81             }
82              
83             sub path_query
84             {
85 58     58 1 85 my $self = shift;
86 58 50       418 $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
87              
88 58 100       134 if (@_) {
89 3         6 $$self = $1;
90 3         7 my $rest = $3;
91 3         5 my $new_path = shift;
92 3 50       7 $new_path = "" unless defined $new_path;
93 3         38 $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
  1         4  
94 3         15 utf8::downgrade($new_path);
95 3         7 _check_path($new_path, $$self);
96 3         11 $$self .= $new_path . $rest;
97             }
98 58         184 $2;
99             }
100              
101             sub _check_path
102             {
103 722     722   1390 my($path, $pre) = @_;
104 722         885 my $prefix;
105 722 100       3292 if ($pre =~ m,/,) { # authority present
106 570 100 100     2366 $prefix = "/" if length($path) && $path !~ m,^[/?\#],;
107             }
108             else {
109 152 50 66     693 if ($path =~ m,^//,) {
    50          
110 0 0       0 Carp::carp("Path starting with double slash is confusing")
111             if $^W;
112             }
113             elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
114 0 0       0 Carp::carp("Path might look like scheme, './' prepended")
115             if $^W;
116 0         0 $prefix = "./";
117             }
118             }
119 722 100       2037 substr($_[0], 0, 0) = $prefix if defined $prefix;
120             }
121              
122             sub path_segments
123             {
124 90     90 1 682 my $self = shift;
125 90         176 my $path = $self->path;
126 90 100       198 if (@_) {
127 6         29 my @arg = @_; # make a copy
128 6         16 for (@arg) {
129 21 100       34 if (ref($_)) {
130 1         25 my @seg = @$_;
131 1         2 $seg[0] =~ s/%/%25/g;
132 1         2 for (@seg) { s/;/%3B/g; }
  3         5  
133 1         4 $_ = join(";", @seg);
134             }
135             else {
136 20         32 s/%/%25/g; s/;/%3B/g;
  20         26  
137             }
138 21         37 s,/,%2F,g;
139             }
140 6         23 $self->path(join("/", @arg));
141             }
142 90 100       200 return $path unless wantarray;
143 81 100       253 map {/;/ ? $self->_split_segment($_)
  194         576  
144             : uri_unescape($_) }
145             split('/', $path, -1);
146             }
147              
148              
149             sub _split_segment
150             {
151 4     4   9 my $self = shift;
152 4         921 require URI::_segment;
153 4         24 URI::_segment->new(@_);
154             }
155              
156              
157             sub abs
158             {
159 274     274 1 600 my $self = shift;
160 274   33     668 my $base = shift || Carp::croak("Missing base argument");
161              
162 274 100       659 if (my $scheme = $self->scheme) {
163 29 100       128 return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
164 10 50       36 $base = URI->new($base) unless ref $base;
165 10 100       28 return $self unless $scheme eq $base->scheme;
166             }
167              
168 252 100       672 $base = URI->new($base) unless ref $base;
169 252         573 my $abs = $self->clone;
170 252         518 $abs->scheme($base->scheme);
171 252 100       931 return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
172 241         570 $abs->authority($base->authority);
173              
174 241         528 my $path = $self->path;
175 241 100       599 return $abs if $path =~ m,^/,;
176              
177 222 100       434 if (!length($path)) {
178 26         79 my $abs = $base->clone;
179 26         147 my $query = $self->query;
180 26 100       76 $abs->query($query) if defined $query;
181 26         117 my $fragment = $self->fragment;
182 26 100       82 $abs->fragment($fragment) if defined $fragment;
183 26         167 return $abs;
184             }
185              
186 196         465 my $p = $base->path;
187 196         862 $p =~ s,[^/]+$,,;
188 196         375 $p .= $path;
189 196         682 my @p = split('/', $p, -1);
190 196 100 66     1000 shift(@p) if @p && !length($p[0]);
191 196         349 my $i = 1;
192 196         433 while ($i < @p) {
193             #print "$i ", join("/", @p), " ($p[$i])\n";
194 616 100 100     1700 if ($p[$i-1] eq ".") {
    100          
195 32         64 splice(@p, $i-1, 1);
196 32 50       86 $i-- if $i > 1;
197             }
198             elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
199 107         203 splice(@p, $i-1, 2);
200 107 100       218 if ($i > 1) {
201 77         100 $i--;
202 77 100       207 push(@p, "") if $i == @p;
203             }
204             }
205             else {
206 477         881 $i++;
207             }
208             }
209 196 100 100     687 $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/."
210 196 100       364 if ($URI::ABS_REMOTE_LEADING_DOTS) {
211 3   66     38 shift @p while @p && $p[0] =~ /^\.\.?$/;
212             }
213 196         763 $abs->path("/" . join("/", @p));
214 196         1021 $abs;
215             }
216              
217             # The opposite of $url->abs. Return a URI which is as relative as possible
218             sub rel {
219 67     67 1 114 my $self = shift;
220 67   33     141 my $base = shift || Carp::croak("Missing base argument");
221 67         146 my $rel = $self->clone;
222 67 50       197 $base = URI->new($base) unless ref $base;
223              
224             #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
225 67         157 my $scheme = $rel->scheme;
226 67         168 my $auth = $rel->canonical->authority;
227 67         136 my $path = $rel->path;
228              
229 67 0 33     138 if (!defined($scheme) && !defined($auth)) {
230             # it is already relative
231 0         0 return $rel;
232             }
233              
234             #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
235 67         147 my $bscheme = $base->scheme;
236 67         188 my $bauth = $base->canonical->authority;
237 67         137 my $bpath = $base->path;
238              
239 67         155 for ($bscheme, $bauth, $auth) {
240 201 100       376 $_ = '' unless defined
241             }
242              
243 67 100 100     262 unless ($scheme eq $bscheme && $auth eq $bauth) {
244             # different location, can't make it relative
245 5         27 return $rel;
246             }
247              
248 62 100       103 for ($path, $bpath) { $_ = "/$_" unless m,^/,; }
  124         338  
249              
250             # Make it relative by eliminating scheme and authority
251 62         210 $rel->scheme(undef);
252 62         145 $rel->authority(undef);
253              
254             # This loop is based on code from Nicolai Langfeldt .
255             # First we calculate common initial path components length ($li).
256 62         121 my $li = 1;
257 62         84 while (1) {
258 137         221 my $i = index($path, '/', $li);
259 137 100 100     550 last if $i < 0 ||
      100        
260             $i != index($bpath, '/', $li) ||
261             substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
262 75         109 $li=$i+1;
263             }
264             # then we nuke it from both paths
265 62         125 substr($path, 0,$li) = '';
266 62         97 substr($bpath,0,$li) = '';
267              
268 62 100 100     200 if ($path eq $bpath &&
      100        
269             defined($rel->fragment) &&
270             !defined($rel->query)) {
271 1         4 $rel->path("");
272             }
273             else {
274             # Add one "../" for each path component left in the base path
275 61         190 $path = ('../' x $bpath =~ tr|/|/|) . $path;
276 61 100       173 $path = "./" if $path eq "";
277 61         119 $rel->path($path);
278             }
279              
280 62         250 $rel;
281             }
282              
283             1;