Profile of URI.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/share/perl5/URI.pm
Statements | Executed 25 statements in 1.93ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 1.19ms | 1.22ms | URI::::BEGIN@22URI::BEGIN@22
1 | 1 | 1 | 20µs | 78µs | URI::::BEGIN@24URI::BEGIN@24
1 | 1 | 1 | 10µs | 25µs | URI::::BEGIN@3URI::BEGIN@3
1 | 1 | 1 | 9µs | 48µs | URI::::BEGIN@7URI::BEGIN@7
1 | 1 | 1 | 8µs | 36µs | URI::::BEGIN@4URI::BEGIN@4
1 | 1 | 1 | 8µs | 28µs | URI::::BEGIN@128URI::BEGIN@128
1 | 1 | 1 | 7µs | 57µs | URI::::BEGIN@13URI::BEGIN@13
1 | 1 | 1 | 4µs | 4µs | URI::::BEGIN@21URI::BEGIN@21
0 | 0 | 0 | 0s | 0s | URI::::STORABLE_freezeURI::STORABLE_freeze
0 | 0 | 0 | 0s | 0s | URI::::STORABLE_thawURI::STORABLE_thaw
0 | 0 | 0 | 0s | 0s | URI::::__ANON__[:24]URI::__ANON__[:24]
0 | 0 | 0 | 0s | 0s | URI::::__ANON__[:25]URI::__ANON__[:25]
0 | 0 | 0 | 0s | 0s | URI::::__ANON__[:26]URI::__ANON__[:26]
0 | 0 | 0 | 0s | 0s | URI::::_initURI::_init
0 | 0 | 0 | 0s | 0s | URI::::_init_implementorURI::_init_implementor
0 | 0 | 0 | 0s | 0s | URI::::_no_scheme_okURI::_no_scheme_ok
0 | 0 | 0 | 0s | 0s | URI::::_obj_eqURI::_obj_eq
0 | 0 | 0 | 0s | 0s | URI::::_schemeURI::_scheme
0 | 0 | 0 | 0s | 0s | URI::::_uric_escapeURI::_uric_escape
0 | 0 | 0 | 0s | 0s | URI::::absURI::abs
0 | 0 | 0 | 0s | 0s | URI::::as_iriURI::as_iri
0 | 0 | 0 | 0s | 0s | URI::::as_stringURI::as_string
0 | 0 | 0 | 0s | 0s | URI::::canonicalURI::canonical
0 | 0 | 0 | 0s | 0s | URI::::cloneURI::clone
0 | 0 | 0 | 0s | 0s | URI::::eqURI::eq
0 | 0 | 0 | 0s | 0s | URI::::fragmentURI::fragment
0 | 0 | 0 | 0s | 0s | URI::::implementorURI::implementor
0 | 0 | 0 | 0s | 0s | URI::::newURI::new
0 | 0 | 0 | 0s | 0s | URI::::new_absURI::new_abs
0 | 0 | 0 | 0s | 0s | URI::::opaqueURI::opaque
0 | 0 | 0 | 0s | 0s | URI::::relURI::rel
0 | 0 | 0 | 0s | 0s | URI::::schemeURI::scheme
0 | 0 | 0 | 0s | 0s | URI::::secureURI::secure

Call graph for these subroutines as a Graphviz dot language file.

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