← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:07 2021

Filename/usr/local/lib/perl5/site_perl/URI.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sURI::::BEGIN@129URI::BEGIN@129
0000s0sURI::::BEGIN@21URI::BEGIN@21
0000s0sURI::::BEGIN@22URI::BEGIN@22
0000s0sURI::::BEGIN@24URI::BEGIN@24
0000s0sURI::::BEGIN@3URI::BEGIN@3
0000s0sURI::::BEGIN@4URI::BEGIN@4
0000s0sURI::::STORABLE_freezeURI::STORABLE_freeze
0000s0sURI::::STORABLE_thawURI::STORABLE_thaw
0000s0sURI::::TO_JSONURI::TO_JSON
0000s0sURI::::__ANON__[:24]URI::__ANON__[:24]
0000s0sURI::::__ANON__[:25]URI::__ANON__[:25]
0000s0sURI::::__ANON__[:26]URI::__ANON__[:26]
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
3use strict;
4use warnings;
5
6our $VERSION = '5.09';
7
8our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER);
9
10my %implements; # mapping from scheme to implementor class
11
12# Some "official" character classes
13
14our $reserved = q(;/?:@&=+$,[]);
15our $mark = q(-_.!~*'()); #'; emacs
16our $unreserved = "A-Za-z0-9\Q$mark\E";
17our $uric = quotemeta($reserved) . $unreserved . "%";
18
19our $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
20
21use Carp ();
22use URI::Escape ();
23
24use overload ('""' => sub { ${$_[0]} },
25 '==' => sub { _obj_eq(@_) },
26 '!=' => sub { !_obj_eq(@_) },
27 fallback => 1,
28 );
29
30# Check if two objects are the same object
31sub _obj_eq {
32 return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
33}
34
35sub new
36{
37 my($class, $uri, $scheme) = @_;
38
39 $uri = defined ($uri) ? "$uri" : ""; # stringify
40 # Get rid of potential wrapping
41 $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
42 $uri =~ s/^"(.*)"$/$1/;
43 $uri =~ s/^\s+//;
44 $uri =~ s/\s+$//;
45
46 my $impclass;
47 if ($uri =~ m/^($scheme_re):/so) {
48 $scheme = $1;
49 }
50 else {
51 if (($impclass = ref($scheme))) {
52 $scheme = $scheme->scheme;
53 }
54 elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
55 $scheme = $1;
56 }
57 }
58 $impclass ||= implementor($scheme) ||
59 do {
60 require URI::_foreign;
61 $impclass = 'URI::_foreign';
62 };
63
64 return $impclass->_init($uri, $scheme);
65}
66
67
68sub new_abs
69{
70 my($class, $uri, $base) = @_;
71 $uri = $class->new($uri, $base);
72 $uri->abs($base);
73}
74
75
76sub _init
77{
78 my $class = shift;
79 my($str, $scheme) = @_;
80 # find all funny characters and encode the bytes.
81 $str = $class->_uric_escape($str);
82 $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
83 $class->_no_scheme_ok;
84 my $self = bless \$str, $class;
85 $self;
86}
87
88
89sub _uric_escape
90{
91 my($class, $str) = @_;
92 $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
93 utf8::downgrade($str);
94 return $str;
95}
96
97my %require_attempted;
98
99sub implementor
100{
101 my($scheme, $impclass) = @_;
102 if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
103 require URI::_generic;
104 return "URI::_generic";
105 }
106
107 $scheme = lc($scheme);
108
109 if ($impclass) {
110 # Set the implementor class for a given scheme
111 my $old = $implements{$scheme};
112 $impclass->_init_implementor($scheme);
113 $implements{$scheme} = $impclass;
114 return $old;
115 }
116
117 my $ic = $implements{$scheme};
118 return $ic if $ic;
119
120 # scheme not yet known, look for internal or
121 # preloaded (with 'use') implementation
122 $ic = "URI::$scheme"; # default location
123
124 # turn scheme into a valid perl identifier by a simple transformation...
125 $ic =~ s/\+/_P/g;
126 $ic =~ s/\./_O/g;
127 $ic =~ s/\-/_/g;
128
129 no strict 'refs';
130 # check we actually have one for the scheme:
131 unless (@{"${ic}::ISA"}) {
132 if (not exists $require_attempted{$ic}) {
133 # Try to load it
134 my $_old_error = $@;
135 eval "require $ic";
136 die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
137 $@ = $_old_error;
138 }
139 return undef unless @{"${ic}::ISA"};
140 }
141
142 $ic->_init_implementor($scheme);
143 $implements{$scheme} = $ic;
144 $ic;
145}
146
147
148sub _init_implementor
149{
150 my($class, $scheme) = @_;
151 # Remember that one implementor class may actually
152 # serve to implement several URI schemes.
153}
154
155
156sub clone
157{
158 my $self = shift;
159 my $other = $$self;
160 bless \$other, ref $self;
161}
162
163sub TO_JSON { ${$_[0]} }
164
165sub _no_scheme_ok { 0 }
166
167sub _scheme
168{
169 my $self = shift;
170
171 unless (@_) {
172 return undef unless $$self =~ /^($scheme_re):/o;
173 return $1;
174 }
175
176 my $old;
177 my $new = shift;
178 if (defined($new) && length($new)) {
179 Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
180 $old = $1 if $$self =~ s/^($scheme_re)://o;
181 my $newself = URI->new("$new:$$self");
182 $$self = $$newself;
183 bless $self, ref($newself);
184 }
185 else {
186 if ($self->_no_scheme_ok) {
187 $old = $1 if $$self =~ s/^($scheme_re)://o;
188 Carp::carp("Oops, opaque part now look like scheme")
189 if $^W && $$self =~ m/^$scheme_re:/o
190 }
191 else {
192 $old = $1 if $$self =~ m/^($scheme_re):/o;
193 }
194 }
195
196 return $old;
197}
198
199sub scheme
200{
201 my $scheme = shift->_scheme(@_);
202 return undef unless defined $scheme;
203 lc($scheme);
204}
205
206sub has_recognized_scheme {
207 my $self = shift;
208 return ref($self) !~ /^URI::_(?:foreign|generic)\z/;
209}
210
211sub opaque
212{
213 my $self = shift;
214
215 unless (@_) {
216 $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
217 return $1;
218 }
219
220 $$self =~ /^($scheme_re:)? # optional scheme
221 ([^\#]*) # opaque
222 (\#.*)? # optional fragment
223 $/sx or die;
224
225 my $old_scheme = $1;
226 my $old_opaque = $2;
227 my $old_frag = $3;
228
229 my $new_opaque = shift;
230 $new_opaque = "" unless defined $new_opaque;
231 $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
232 utf8::downgrade($new_opaque);
233
234 $$self = defined($old_scheme) ? $old_scheme : "";
235 $$self .= $new_opaque;
236 $$self .= $old_frag if defined $old_frag;
237
238 $old_opaque;
239}
240
241sub path { goto &opaque } # alias
242
243
244sub fragment
245{
246 my $self = shift;
247 unless (@_) {
248 return undef unless $$self =~ /\#(.*)/s;
249 return $1;
250 }
251
252 my $old;
253 $old = $1 if $$self =~ s/\#(.*)//s;
254
255 my $new_frag = shift;
256 if (defined $new_frag) {
257 $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
258 utf8::downgrade($new_frag);
259 $$self .= "#$new_frag";
260 }
261 $old;
262}
263
264
265sub as_string
266{
267 my $self = shift;
268 $$self;
269}
270
271
272sub as_iri
273{
274 my $self = shift;
275 my $str = $$self;
276 if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
277 # All this crap because the more obvious:
278 #
279 # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
280 #
281 # doesn't work before Encode 2.39. Wait for a standard release
282 # to bundle that version.
283
284 require Encode;
285 my $enc = Encode::find_encoding("UTF-8");
286 my $u = "";
287 while (length $str) {
288 $u .= $enc->decode($str, Encode::FB_QUIET());
289 if (length $str) {
290 # escape next char
291 $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
292 }
293 }
294 $str = $u;
295 }
296 return $str;
297}
298
299
300sub canonical
301{
302 # Make sure scheme is lowercased, that we don't escape unreserved chars,
303 # and that we use upcase escape sequences.
304
305 my $self = shift;
306 my $scheme = $self->_scheme || "";
307 my $uc_scheme = $scheme =~ /[A-Z]/;
308 my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
309 return $self unless $uc_scheme || $esc;
310
311 my $other = $self->clone;
312 if ($uc_scheme) {
313 $other->_scheme(lc $scheme);
314 }
315 if ($esc) {
316 $$other =~ s{%([0-9a-fA-F]{2})}
317 { my $a = chr(hex($1));
318 $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
319 }ge;
320 }
321 return $other;
322}
323
324# Compare two URIs, subclasses will provide a more correct implementation
325sub eq {
326 my($self, $other) = @_;
327 $self = URI->new($self, $other) unless ref $self;
328 $other = URI->new($other, $self) unless ref $other;
329 ref($self) eq ref($other) && # same class
330 $self->canonical->as_string eq $other->canonical->as_string;
331}
332
333# generic-URI transformation methods
334sub abs { $_[0]; }
335sub rel { $_[0]; }
336
337sub secure { 0 }
338
339# help out Storable
340sub STORABLE_freeze {
341 my($self, $cloning) = @_;
342 return $$self;
343}
344
345sub STORABLE_thaw {
346 my($self, $cloning, $str) = @_;
347 $$self = $str;
348}
349
3501;
351
352__END__