← Index
NYTProf Performance Profile   « line view »
For t/bug-md-11.t
  Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/URI.pm
StatementsExecuted 27 statements in 1.58ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111728µs800µsURI::::BEGIN@41URI::BEGIN@41
11110µs11µsURI::::BEGIN@3URI::BEGIN@3
1117µs29µsURI::::BEGIN@43URI::BEGIN@43
1116µs11µsURI::::BEGIN@180URI::BEGIN@180
1114µs27µsURI::::BEGIN@9URI::BEGIN@9
1114µs20µsURI::::BEGIN@4URI::BEGIN@4
1112µs2µsURI::::BEGIN@40URI::BEGIN@40
0000s0sURI::::STORABLE_freezeURI::STORABLE_freeze
0000s0sURI::::STORABLE_thawURI::STORABLE_thaw
0000s0sURI::::TO_JSONURI::TO_JSON
0000s0sURI::::__ANON__[:43]URI::__ANON__[:43]
0000s0sURI::::__ANON__[:44]URI::__ANON__[:44]
0000s0sURI::::__ANON__[:45]URI::__ANON__[:45]
0000s0sURI::::_fix_uric_escape_for_host_partURI::_fix_uric_escape_for_host_part
0000s0sURI::::_initURI::_init
0000s0sURI::::_init_implementorURI::_init_implementor
0000s0sURI::::_no_scheme_okURI::_no_scheme_ok
0000s0sURI::::_obj_eqURI::_obj_eq
0000s0sURI::::_schemeURI::_scheme
0000s0sURI::::_uric_escapeURI::_uric_escape
0000s0sURI::::absURI::abs
0000s0sURI::::as_iriURI::as_iri
0000s0sURI::::as_stringURI::as_string
0000s0sURI::::canonicalURI::canonical
0000s0sURI::::cloneURI::clone
0000s0sURI::::eqURI::eq
0000s0sURI::::fragmentURI::fragment
0000s0sURI::::has_recognized_schemeURI::has_recognized_scheme
0000s0sURI::::implementorURI::implementor
0000s0sURI::::newURI::new
0000s0sURI::::new_absURI::new_abs
0000s0sURI::::opaqueURI::opaque
0000s0sURI::::pathURI::path
0000s0sURI::::relURI::rel
0000s0sURI::::schemeURI::scheme
0000s0sURI::::secureURI::secure
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package URI;
2
3224µs213µs
# spent 11µs (10+2) within URI::BEGIN@3 which was called: # once (10µs+2µs) by XML::Twig::_use at line 3
use strict;
# spent 11µs making 1 call to URI::BEGIN@3 # spent 2µs making 1 call to strict::import
4235µs236µs
# spent 20µs (4+16) within URI::BEGIN@4 which was called: # once (4µs+16µs) by XML::Twig::_use at line 4
use warnings;
# spent 20µs making 1 call to URI::BEGIN@4 # spent 16µs making 1 call to warnings::import
5
61300nsour $VERSION = '5.27';
7
8# 1=version 5.10 and earlier; 0=version 5.11 and later
9297µs250µs
# spent 27µs (4+23) within URI::BEGIN@9 which was called: # once (4µs+23µs) by XML::Twig::_use at line 9
use constant HAS_RESERVED_SQUARE_BRACKETS => $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} ? 1 : 0;
# spent 27µs making 1 call to URI::BEGIN@9 # spent 23µs making 1 call to constant::import
10
11our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER);
12
131200nsmy %implements; # mapping from scheme to implementor class
14
15# Some "official" character classes
16
171100nsour $reserved = HAS_RESERVED_SQUARE_BRACKETS ? q(;/?:@&=+$,[]) : q(;/?:@&=+$,);
181100nsour $mark = q(-_.!~*'()); #'; emacs
191700nsour $unreserved = "A-Za-z0-9\Q$mark\E";
201300nsour $uric = quotemeta($reserved) . $unreserved . "%";
211400nsour $uric4host = $uric . ( HAS_RESERVED_SQUARE_BRACKETS ? '' : quotemeta( q([]) ) );
221200nsour $uric4user = quotemeta( q{!$'()*,;:._~%-+=%&} ) . "A-Za-z0-9" . ( HAS_RESERVED_SQUARE_BRACKETS ? quotemeta( q([]) ) : '' ); # RFC-3987: iuserinfo w/o UTF
23
241100nsour $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
25
26# These schemes don't have an IPv6+ address part.
2710sour $schemes_without_host_part_re = 'data|ldapi|urn|sqlite|sqlite3';
28
29# These schemes can have an IPv6+ authority part:
30# file, ftp, gopher, http, https, ldap, ldaps, mms, news, nntp, nntps, pop, rlogin, rtsp, rtspu, rsync, sip, sips, snews,
31# telnet, tn3270, ssh, sftp
32# (all DB URIs, i.e. cassandra, couch, couchdb, etc.), except 'sqlite:', 'sqlite3:'. Others?
33#MAINT: URI has no test coverage for DB schemes
34#MAINT: decoupling - perhaps let each class decide itself by defining a member function 'scheme_has_authority_part()'?
35
36#MAINT: 'mailto:' needs special treatment for IPv* addresses / RFC 5321 (4.1.3). Until then: restore all '[', ']'
37# These schemes need fallback to previous (<= 5.10) encoding until a specific handler is available.
381100nsour $fallback_schemes_re = 'mailto';
39
40211µs12µs
# spent 2µs within URI::BEGIN@40 which was called: # once (2µs+0s) by XML::Twig::_use at line 40
use Carp ();
# spent 2µs making 1 call to URI::BEGIN@40
412112µs1800µs
# spent 800µs (728+72) within URI::BEGIN@41 which was called: # once (728µs+72µs) by XML::Twig::_use at line 41
use URI::Escape ();
# spent 800µs making 1 call to URI::BEGIN@41
42
43
# spent 29µs (7+22) within URI::BEGIN@43 which was called: # once (7µs+22µs) by XML::Twig::_use at line 47
use overload ('""' => sub { ${$_[0]} },
44 '==' => sub { _obj_eq(@_) },
45 '!=' => sub { !_obj_eq(@_) },
4615µs122µs fallback => 1,
# spent 22µs making 1 call to overload::import
471476µs129µs );
# spent 29µs making 1 call to URI::BEGIN@43
48
49# Check if two objects are the same object
50sub _obj_eq {
51 return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
52}
53
54sub new
55{
56 my($class, $uri, $scheme) = @_;
57
58 $uri = defined ($uri) ? "$uri" : ""; # stringify
59 # Get rid of potential wrapping
60 $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
61 $uri =~ s/^"(.*)"$/$1/;
62 $uri =~ s/^\s+//;
63 $uri =~ s/\s+$//;
64
65 my $impclass;
66 if ($uri =~ m/^($scheme_re):/so) {
67 $scheme = $1;
68 }
69 else {
70 if (($impclass = ref($scheme))) {
71 $scheme = $scheme->scheme;
72 }
73 elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
74 $scheme = $1;
75 }
76 }
77 $impclass ||= implementor($scheme) ||
78 do {
79 require URI::_foreign;
80 $impclass = 'URI::_foreign';
81 };
82
83 return $impclass->_init($uri, $scheme);
84}
85
86
87sub new_abs
88{
89 my($class, $uri, $base) = @_;
90 $uri = $class->new($uri, $base);
91 $uri->abs($base);
92}
93
94
95sub _init
96{
97 my $class = shift;
98 my($str, $scheme) = @_;
99 # find all funny characters and encode the bytes.
100 $str = $class->_uric_escape($str);
101 $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
102 $class->_no_scheme_ok;
103 my $self = bless \$str, $class;
104 $self;
105}
106
107
108#-- Version: 5.11+
109# Since the complete URI will be percent-encoded including '[' and ']',
110# we selectively unescape square brackets from the authority/host part of the URI.
111# Derived modules that implement _uric_escape() should take this into account
112# if they do not rely on URI::_uric_escape().
113# No unescaping is performed for the userinfo@ part of the authority part.
114sub _fix_uric_escape_for_host_part {
115 return if HAS_RESERVED_SQUARE_BRACKETS;
116 return if $_[0] !~ /%/;
117 return if $_[0] =~ m{^(?:$URI::schemes_without_host_part_re):}os;
118
119 # until a scheme specific handler is available, fall back to previous behavior of v5.10 (i.e. 'mailto:')
120 if ($_[0] =~ m{^(?:$URI::fallback_schemes_re):}os) {
121 $_[0] =~ s/\%5B/[/gi;
122 $_[0] =~ s/\%5D/]/gi;
123 return;
124 }
125
126 if ($_[0] =~ m{^((?:$URI::scheme_re:)?)//([^/?\#]+)(.*)$}os) {
127 my $orig = $2;
128 my ($user, $host) = $orig =~ /^(.*@)?([^@]*)$/;
129 $user ||= '';
130 my $port = $host =~ s/(:\d+)$// ? $1 : '';
131 #MAINT: die() here if scheme indicates TCP/UDP and port is out of range [0..65535] ?
132 $host =~ s/\%5B/[/gi;
133 $host =~ s/\%5D/]/gi;
134 $_[0] =~ s/\Q$orig\E/$user$host$port/;
135 }
136}
137
138
139sub _uric_escape
140{
141 my($class, $str) = @_;
142 $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
143 _fix_uric_escape_for_host_part( $str );
144 utf8::downgrade($str);
145 return $str;
146}
147
14810smy %require_attempted;
149
150sub implementor
151{
152 my($scheme, $impclass) = @_;
153 if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
154 require URI::_generic;
155 return "URI::_generic";
156 }
157
158 $scheme = lc($scheme);
159
160 if ($impclass) {
161 # Set the implementor class for a given scheme
162 my $old = $implements{$scheme};
163 $impclass->_init_implementor($scheme);
164 $implements{$scheme} = $impclass;
165 return $old;
166 }
167
168 my $ic = $implements{$scheme};
169 return $ic if $ic;
170
171 # scheme not yet known, look for internal or
172 # preloaded (with 'use') implementation
173 $ic = "URI::$scheme"; # default location
174
175 # turn scheme into a valid perl identifier by a simple transformation...
176 $ic =~ s/\+/_P/g;
177 $ic =~ s/\./_O/g;
178 $ic =~ s/\-/_/g;
179
1802811µs215µs
# spent 11µs (6+4) within URI::BEGIN@180 which was called: # once (6µs+4µs) by XML::Twig::_use at line 180
no strict 'refs';
# spent 11µs making 1 call to URI::BEGIN@180 # spent 4µs making 1 call to strict::unimport
181 # check we actually have one for the scheme:
182 unless (@{"${ic}::ISA"}) {
183 if (not exists $require_attempted{$ic}) {
184 $require_attempted{$ic} = 1;
185
186 # Try to load it
187 my $_old_error = $@;
188 eval "require $ic";
189 die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
190 $@ = $_old_error;
191 }
192 return undef unless @{"${ic}::ISA"};
193 }
194
195 $ic->_init_implementor($scheme);
196 $implements{$scheme} = $ic;
197 $ic;
198}
199
200
201sub _init_implementor
202{
203 my($class, $scheme) = @_;
204 # Remember that one implementor class may actually
205 # serve to implement several URI schemes.
206}
207
208
209sub clone
210{
211 my $self = shift;
212 my $other = $$self;
213 bless \$other, ref $self;
214}
215
216sub TO_JSON { ${$_[0]} }
217
218sub _no_scheme_ok { 0 }
219
220sub _scheme
221{
222 my $self = shift;
223
224 unless (@_) {
225 return undef unless $$self =~ /^($scheme_re):/o;
226 return $1;
227 }
228
229 my $old;
230 my $new = shift;
231 if (defined($new) && length($new)) {
232 Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
233 $old = $1 if $$self =~ s/^($scheme_re)://o;
234 my $newself = URI->new("$new:$$self");
235 $$self = $$newself;
236 bless $self, ref($newself);
237 }
238 else {
239 if ($self->_no_scheme_ok) {
240 $old = $1 if $$self =~ s/^($scheme_re)://o;
241 Carp::carp("Oops, opaque part now look like scheme")
242 if $^W && $$self =~ m/^$scheme_re:/o
243 }
244 else {
245 $old = $1 if $$self =~ m/^($scheme_re):/o;
246 }
247 }
248
249 return $old;
250}
251
252sub scheme
253{
254 my $scheme = shift->_scheme(@_);
255 return undef unless defined $scheme;
256 lc($scheme);
257}
258
259sub has_recognized_scheme {
260 my $self = shift;
261 return ref($self) !~ /^URI::_(?:foreign|generic)\z/;
262}
263
264sub opaque
265{
266 my $self = shift;
267
268 unless (@_) {
269 $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
270 return $1;
271 }
272
273 $$self =~ /^($scheme_re:)? # optional scheme
274 ([^\#]*) # opaque
275 (\#.*)? # optional fragment
276 $/sx or die;
277
278 my $old_scheme = $1;
279 my $old_opaque = $2;
280 my $old_frag = $3;
281
282 my $new_opaque = shift;
283 $new_opaque = "" unless defined $new_opaque;
284 $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
285 utf8::downgrade($new_opaque);
286
287 $$self = defined($old_scheme) ? $old_scheme : "";
288 $$self .= $new_opaque;
289 $$self .= $old_frag if defined $old_frag;
290
291 $old_opaque;
292}
293
294sub path { goto &opaque } # alias
295
296
297sub fragment
298{
299 my $self = shift;
300 unless (@_) {
301 return undef unless $$self =~ /\#(.*)/s;
302 return $1;
303 }
304
305 my $old;
306 $old = $1 if $$self =~ s/\#(.*)//s;
307
308 my $new_frag = shift;
309 if (defined $new_frag) {
310 $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
311 utf8::downgrade($new_frag);
312 $$self .= "#$new_frag";
313 }
314 $old;
315}
316
317
318sub as_string
319{
320 my $self = shift;
321 $$self;
322}
323
324
325sub as_iri
326{
327 my $self = shift;
328 my $str = $$self;
329 if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
330 # All this crap because the more obvious:
331 #
332 # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
333 #
334 # doesn't work before Encode 2.39. Wait for a standard release
335 # to bundle that version.
336
337 require Encode;
338 my $enc = Encode::find_encoding("UTF-8");
339 my $u = "";
340 while (length $str) {
341 $u .= $enc->decode($str, Encode::FB_QUIET());
342 if (length $str) {
343 # escape next char
344 $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
345 }
346 }
347 $str = $u;
348 }
349 return $str;
350}
351
352
353sub canonical
354{
355 # Make sure scheme is lowercased, that we don't escape unreserved chars,
356 # and that we use upcase escape sequences.
357
358 my $self = shift;
359 my $scheme = $self->_scheme || "";
360 my $uc_scheme = $scheme =~ /[A-Z]/;
361 my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
362 return $self unless $uc_scheme || $esc;
363
364 my $other = $self->clone;
365 if ($uc_scheme) {
366 $other->_scheme(lc $scheme);
367 }
368 if ($esc) {
369 $$other =~ s{%([0-9a-fA-F]{2})}
370 { my $a = chr(hex($1));
371 $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
372 }ge;
373 }
374 return $other;
375}
376
377# Compare two URIs, subclasses will provide a more correct implementation
378sub eq {
379 my($self, $other) = @_;
380 $self = URI->new($self, $other) unless ref $self;
381 $other = URI->new($other, $self) unless ref $other;
382 ref($self) eq ref($other) && # same class
383 $self->canonical->as_string eq $other->canonical->as_string;
384}
385
386# generic-URI transformation methods
387sub abs { $_[0]; }
388sub rel { $_[0]; }
389
390sub secure { 0 }
391
392# help out Storable
393sub STORABLE_freeze {
394 my($self, $cloning) = @_;
395 return $$self;
396}
397
398sub STORABLE_thaw {
399 my($self, $cloning, $str) = @_;
400 $$self = $str;
401}
402
40314µs1;
404
405__END__