Filename | /usr/share/perl5/URI.pm |
Statements | Executed 25 statements in 1.93ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 1.19ms | 1.22ms | BEGIN@22 | URI::
1 | 1 | 1 | 20µs | 78µs | BEGIN@24 | URI::
1 | 1 | 1 | 10µs | 25µs | BEGIN@3 | URI::
1 | 1 | 1 | 9µs | 48µs | BEGIN@7 | URI::
1 | 1 | 1 | 8µs | 36µs | BEGIN@4 | URI::
1 | 1 | 1 | 8µs | 28µs | BEGIN@128 | URI::
1 | 1 | 1 | 7µs | 57µs | BEGIN@13 | URI::
1 | 1 | 1 | 4µs | 4µs | BEGIN@21 | URI::
0 | 0 | 0 | 0s | 0s | STORABLE_freeze | URI::
0 | 0 | 0 | 0s | 0s | STORABLE_thaw | URI::
0 | 0 | 0 | 0s | 0s | __ANON__[:24] | URI::
0 | 0 | 0 | 0s | 0s | __ANON__[:25] | URI::
0 | 0 | 0 | 0s | 0s | __ANON__[:26] | URI::
0 | 0 | 0 | 0s | 0s | _init | URI::
0 | 0 | 0 | 0s | 0s | _init_implementor | URI::
0 | 0 | 0 | 0s | 0s | _no_scheme_ok | URI::
0 | 0 | 0 | 0s | 0s | _obj_eq | URI::
0 | 0 | 0 | 0s | 0s | _scheme | URI::
0 | 0 | 0 | 0s | 0s | _uric_escape | URI::
0 | 0 | 0 | 0s | 0s | abs | URI::
0 | 0 | 0 | 0s | 0s | as_iri | URI::
0 | 0 | 0 | 0s | 0s | as_string | URI::
0 | 0 | 0 | 0s | 0s | canonical | URI::
0 | 0 | 0 | 0s | 0s | clone | URI::
0 | 0 | 0 | 0s | 0s | eq | URI::
0 | 0 | 0 | 0s | 0s | fragment | URI::
0 | 0 | 0 | 0s | 0s | implementor | URI::
0 | 0 | 0 | 0s | 0s | new | URI::
0 | 0 | 0 | 0s | 0s | new_abs | URI::
0 | 0 | 0 | 0s | 0s | opaque | URI::
0 | 0 | 0 | 0s | 0s | rel | URI::
0 | 0 | 0 | 0s | 0s | scheme | URI::
0 | 0 | 0 | 0s | 0s | secure | URI::
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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
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 # 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__ |