File Coverage

blib/lib/Pcore/Util/URI.pm
Criterion Covered Total %
statement 95 161 59.0
branch 47 72 65.2
condition 19 27 70.3
subroutine 11 24 45.8
pod 0 4 0.0
total 172 288 59.7


line stmt bran cond sub pod time code
1             package Pcore::Util::URI;
2              
3 5     5   30 use Pcore -class;
  5         8  
  5         39  
4              
5 5     5   37 use Pcore -class, -const;
  5         10  
  5         20  
6 5     5   1895 use Pcore::Util::URI::Path;
  5         12  
  5         118  
7 5     5   1372 use URI::Escape::XS qw[]; ## no critic qw[Modules::ProhibitEvilModules]
  5         9210  
  5         732  
8              
9             use overload #
10             q[""] => sub {
11 0     0   0 return $_[0]->to_string;
12             },
13             q[cmp] => sub {
14 0 0   0   0 return !$_[2] ? $_[0]->to_string cmp $_[1] : $_[1] cmp $_[0]->to_string;
15             },
16             q[bool] => sub {
17 99     99   267 return 1;
18             },
19 5     5   36 fallback => undef;
  5         9  
  5         46  
20              
21             has scheme => ( is => 'ro' ); # ASCII
22             has userinfo => ( is => 'ro' ); # escaped, ASCII
23             has host => ( is => 'ro' ); # object
24             has port => ( is => 'ro' ); # punycoded, ASCII
25             has path => ( is => 'ro' ); # object
26             has query => ( is => 'ro' ); # escaped, ASCII
27             has fragment => ( is => 'ro' ); # escaped, ASCII
28              
29             # TODO canon uri:
30             # - remove default port
31             # - uppercase escaped series
32             # - unescape all allowed symbols
33             # - sort query params
34              
35             has to_string => ( is => 'lazy', init_arg => undef );
36              
37             has authority => ( is => 'lazy', init_arg => undef ); # escaped, ASCII, punycoded host
38             has userinfo_b64 => ( is => 'lazy', init_arg => undef ); # ASCII
39             has username => ( is => 'lazy', init_arg => undef ); # unescaped, ASCII
40             has password => ( is => 'lazy', init_arg => undef ); # unescaped, ASCII
41             has hostport => ( is => 'lazy', init_arg => undef ); # punycoded, ASCII
42              
43             has scheme_is_valid => ( is => 'lazy', init_arg => undef );
44              
45             has is_http => ( is => 'lazy', default => 0, init_arg => undef );
46             has is_secure => ( is => 'lazy', default => 0, init_arg => undef );
47              
48             has default_port => ( is => 'lazy', default => 0, init_arg => undef );
49             has connect_port => ( is => 'lazy', init_arg => undef );
50             has connect => ( is => 'lazy', init_arg => undef );
51              
52             around new => sub ( $orig, $self, $uri, @ ) {
53             my %args = (
54             base => undef,
55             authority => undef,
56             splice @_, 3,
57             );
58              
59             my $uri_args = $self->_parse_uri_string( $uri, $args{authority} );
60              
61             my $scheme = $uri_args->{scheme};
62              
63             # parse base scheme
64             if ( $uri_args->{scheme} eq q[] && $args{base} ) {
65             $args{base} = $self->new( $args{base} ) if !ref $args{base};
66              
67             $scheme = $args{base}->{scheme};
68             }
69              
70             state $scheme_cache = { #
71             q[] => undef,
72             };
73              
74             if ( !exists $scheme_cache->{$scheme} ) {
75             if ( P->class->find( $scheme, ns => 'Pcore::Util::URI' ) ) {
76             $scheme_cache->{$scheme} = P->class->load( $scheme, ns => 'Pcore::Util::URI' );
77              
78             $scheme_cache->{$scheme} = undef if !$scheme_cache->{$scheme}->isa('Pcore::Util::URI');
79             }
80             else {
81             $scheme_cache->{$scheme} = undef;
82             }
83             }
84              
85             $self = $scheme_cache->{$scheme} if $scheme_cache->{$scheme};
86              
87             $self->_prepare_uri_args( $uri_args, \%args );
88              
89             return bless $uri_args, $self;
90             };
91              
92             # http://tools.ietf.org/html/rfc3986#section-2.2
93             const our $UNRESERVED => '0-9a-zA-Z' . quotemeta q[-._~];
94             const our $RESERVED_GEN_DELIMS => quotemeta q[:/?#[]@];
95             const our $RESERVED_SUB_DELIMS => quotemeta q[!$&'()*+,;=];
96             const our $ESCAPE_RE => qq[^${UNRESERVED}${RESERVED_GEN_DELIMS}${RESERVED_SUB_DELIMS}%];
97             const our $ESC_CHARS => { map { chr $_ => sprintf '%%%02X', $_ } ( 0 .. 255 ) };
98              
99 106     106   134 sub _parse_uri_string ( $self, $uri, $with_authority = 0 ) {
  106         128  
  106         133  
  106         132  
  106         117  
100 106         131 my %args;
101              
102 106 100       249 utf8::encode($uri) if utf8::is_utf8($uri);
103              
104 106         2004 $uri =~ s/([$ESCAPE_RE])/$ESC_CHARS->{$1}/smg;
105              
106 106 100 66     358 $uri = q[//] . $uri if $with_authority && index( $uri, q[//] ) == -1;
107              
108             # official regex from RFC 3986
109 106         457 $uri =~ m[^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)([?]([^#]*))?(#(.*))?]sm;
110              
111 106 100       431 $args{scheme} = defined $2 ? lc $2 : q[];
112              
113             # authority
114 106 100       251 $args{_has_authority} = defined $3 ? 1 : 0;
115              
116 106 100       205 if ( defined $4 ) {
117              
118             # parse userinfo, host, port
119 91         275 $4 =~ m[\A((.+)@)?([^:]+)?(:(.*))?]sm;
120              
121 91   100     344 $args{userinfo} = $2 // q[];
122              
123             # host
124 91 100       163 if ( defined $3 ) {
125 69         128 $args{host} = $3;
126             }
127             else {
128 22         42 $args{host} = q[];
129             }
130              
131 91   100     251 $args{port} = $5 // 0;
132             }
133             else {
134 15         24 $args{userinfo} = q[];
135              
136 15         24 $args{host} = q[];
137              
138 15         25 $args{port} = 0;
139             }
140              
141             # path
142 106   50     291 $args{path} = $5 // q[];
143              
144 106 100 100     352 $args{path} = q[/] if $args{_has_authority} && $args{path} eq q[];
145              
146             # query
147 106   100     316 $args{query} = $7 // q[];
148              
149             # fragment
150 106   100     360 $args{fragment} = $9 // q[];
151              
152 106         267 return \%args;
153             }
154              
155 106     106   138 sub _prepare_uri_args ( $self, $uri_args, $args ) {
  106         137  
  106         130  
  106         131  
  106         119  
156              
157             # https://tools.ietf.org/html/rfc3986#section-5
158             # if URI has no scheme and base URI is specified - merge with base URI
159 106 100 100     309 $self->_merge_uri_base( $uri_args, $args->{base} ) if $uri_args->{scheme} eq q[] && $args->{base};
160              
161 106 100       226 if ( !ref $uri_args->{host} ) {
162 94 100       225 if ( index( $uri_args->{host}, q[%] ) != -1 ) {
163 1         4 $uri_args->{host} = URI::Escape::XS::uri_unescape( $uri_args->{host} );
164              
165 1         19 utf8::decode( $uri_args->{host} );
166             }
167              
168 94         1652 $uri_args->{host} = P->host( $uri_args->{host} );
169             }
170              
171 106 100       1722 $uri_args->{path} = Pcore::Util::URI::Path->new( $uri_args->{path}, from_uri => 1 ) if !ref $uri_args->{path};
172              
173 106         200 delete $uri_args->{_has_authority};
174              
175 106         164 return;
176             }
177              
178 33     33   41 sub _merge_uri_base ( $self, $uri_args, $base ) {
  33         47  
  33         40  
  33         40  
  33         41  
179              
180             # parse base URI
181 33 50       66 $base = $self->new($base) if !ref $base;
182              
183             # https://tools.ietf.org/html/rfc3986#section-5.2.1
184             # base URI MUST contain scheme
185 33 50       69 if ( $base->{scheme} ne q[] ) {
186              
187             # https://tools.ietf.org/html/rfc3986#section-5.2.2
188             # inherit scheme from base URI
189 33         58 $uri_args->{scheme} = $base->{scheme};
190              
191             # inherit from the base URI only if has no own authority
192 33 100       68 if ( !$uri_args->{_has_authority} ) {
193              
194             # inherit authority
195 12         20 $uri_args->{userinfo} = $base->{userinfo};
196 12         22 $uri_args->{host} = $base->{host};
197 12         17 $uri_args->{port} = $base->{port};
198              
199 12 100       22 if ( $uri_args->{path} eq q[] ) {
200 3         6 $uri_args->{path} = $base->{path};
201              
202 3 100       6 $uri_args->{query} = $base->{query} if !$uri_args->{query};
203             }
204             else {
205 9         191 $uri_args->{path} = Pcore::Util::URI::Path->new( $uri_args->{path}, base => $base->{path}, from_uri => 1 );
206             }
207             }
208             }
209              
210 33         61 return;
211             }
212              
213             # BUILDERS
214 21     21   643 sub _build_to_string ($self) {
  21         27  
  21         24  
215              
216             # https://tools.ietf.org/html/rfc3986#section-5.3
217 21         29 my $uri = q[];
218              
219 21 100       62 $uri .= $self->{scheme} . q[:] if $self->{scheme} ne q[];
220              
221 21 100 66     293 if ( $self->authority ne q[] ) {
    100          
222 16         246 $uri .= q[//] . $self->authority;
223              
224 16 50       129 $uri .= q[/] if !$self->{path}->is_abs;
225             }
226             elsif ( $self->{scheme} eq q[] && $self->{path}->to_uri =~ m[\A[^/]*:]sm ) {
227              
228             # prepend path with "./" if uri has no scheme, has no authority, path is absolute and first path segment contains ":"
229             # pa:th/path -> ./pa:th/path
230 1         3 $uri .= q[./];
231             }
232              
233 21         307 $uri .= $self->{path}->to_uri;
234              
235 21 100       53 $uri .= q[?] . $self->{query} if $self->{query} ne q[];
236              
237 21 100       45 $uri .= q[#] . $self->{fragment} if $self->{fragment} ne q[];
238              
239 21         104 return $uri;
240             }
241              
242 21     21   131 sub _build_authority ($self) {
  21         27  
  21         21  
243 21         29 my $authority = q[];
244              
245 21 100       42 $authority .= $self->{userinfo} . q[@] if $self->{userinfo} ne q[];
246              
247 21 100       94 $authority .= $self->{host}->name if $self->{host} ne q[];
248              
249 21 100       51 $authority .= q[:] . $self->{port} if $self->{port};
250              
251 21         94 return $authority;
252             }
253              
254 0     0     sub _build_userinfo_b64 ($self) {
  0            
  0            
255 0 0         return q[] if $self->{userinfo} eq q[];
256              
257 0           return P->data->to_b64_url( URI::Escape::XS::decodeURIComponent( $self->{userinfo} ) );
258             }
259              
260 0     0     sub _build_username ($self) {
  0            
  0            
261 0 0         return q[] if $self->{userinfo} eq q[];
262              
263 0 0         if ( ( my $idx = index $self->{userinfo}, q[:] ) != -1 ) {
264 0           return URI::Escape::XS::decodeURIComponent( substr $self->{userinfo}, 0, $idx );
265             }
266             else {
267 0           return $self->{userinfo};
268             }
269             }
270              
271 0     0     sub _build_password ($self) {
  0            
  0            
272 0 0         return q[] if $self->{userinfo} eq q[];
273              
274 0 0         if ( ( my $idx = index $self->{userinfo}, q[:] ) != -1 ) {
275 0           return URI::Escape::XS::decodeURIComponent( substr $self->{userinfo}, $idx + 1 );
276             }
277             else {
278 0           return q[];
279             }
280             }
281              
282 0     0     sub _build_hostport ($self) {
  0            
  0            
283 0 0         return $self->host->name . ( $self->port ? q[:] . $self->port : q[] );
284             }
285              
286 0     0     sub _build_scheme_is_valid ($self) {
  0            
  0            
287 0 0         return !$self->scheme ? 1 : $self->scheme =~ /\A[[:lower:]][[:lower:][:digit:]+.-]*\z/sm;
288             }
289              
290 0     0     sub _build_connect_port ($self) {
  0            
  0            
291 0   0       return $self->port || $self->default_port;
292             }
293              
294 0     0     sub _build_connect ($self) {
  0            
  0            
295 0 0         my $scheme = $self->scheme eq q[] ? 'tcp' : $self->scheme;
296              
297 0           return [ $self->host->name, $self->connect_port, $scheme, $scheme . q[_] . $self->connect_port ];
298             }
299              
300             # UTIL
301 0     0 0   sub clear_fragment ($self) {
  0            
  0            
302 0           $self->{fragment} = q[];
303              
304 0           $self->{fragment_utf8} = q[];
305              
306 0           delete $self->{to_string};
307              
308 0           delete $self->{canon};
309              
310 0           return;
311             }
312              
313 0     0 0   sub query_params ($self) {
  0            
  0            
314 0           return P->data->from_uri_query( $self->query );
315             }
316              
317             # used to compose url for nginx proxy_pass directive
318 0     0 0   sub to_nginx ( $self, $scheme = 'http' ) {
  0            
  0            
  0            
319 0 0         if ( $self->scheme eq 'unix' ) {
320 0           return $scheme . q[://unix:] . $self->path;
321             }
322             else {
323 0 0 0       return $scheme . q[://] . ( $self->host || q[*] ) . ( $self->port ? q[:] . $self->port : q[] );
324             }
325             }
326              
327 0     0 0   sub TO_DUMP ( $self, $dumper, @ ) {
  0            
  0            
  0            
328 0           my %args = (
329             path => undef,
330             splice @_, 2,
331             );
332              
333 0           my $res;
334             my $tags;
335              
336 0           $res = qq[uri: "@{[$self->to_string]}"];
  0            
337              
338 0           return $res, $tags;
339             }
340              
341             1;
342             ## -----SOURCE FILTER LOG BEGIN-----
343             ##
344             ## PerlCritic profile "pcore-script" policy violations:
345             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
346             ## | Sev. | Lines | Policy |
347             ## |======+======================+================================================================================================================|
348             ## | 3 | 111, 114, 121, 131, | RegularExpressions::ProhibitCaptureWithoutTest - Capture variable used outside conditional |
349             ## | | 142, 147, 150 | |
350             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
351             ## | 1 | 95 | ValuesAndExpressions::RequireInterpolationOfMetachars - String *may* require interpolation |
352             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
353             ##
354             ## -----SOURCE FILTER LOG END-----
355             __END__
356             =pod
357              
358             =encoding utf8
359              
360             =head1 NAME
361              
362             Pcore::Util::URI
363              
364             =head1 SYNOPSIS
365              
366             =head1 DESCRIPTION
367              
368             =head1 ATTRIBUTES
369              
370             =head1 METHODS
371              
372             =head1 SEE ALSO
373              
374             =cut