← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:04 2013

Filename/usr/share/perl5/URI.pm
StatementsExecuted 33 statements in 1.99ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11120µs27µsURI::::BEGIN@3URI::BEGIN@3
11119µs77µsURI::::BEGIN@24URI::BEGIN@24
11113µs35µsURI::::BEGIN@127URI::BEGIN@127
11111µs48µsURI::::BEGIN@4URI::BEGIN@4
11110µs74µsURI::::BEGIN@13URI::BEGIN@13
1119µs55µsURI::::BEGIN@7URI::BEGIN@7
1116µs6µsURI::::BEGIN@21URI::BEGIN@21
1114µs4µsURI::::BEGIN@22URI::BEGIN@22
0000s0sURI::::STORABLE_freezeURI::STORABLE_freeze
0000s0sURI::::STORABLE_thawURI::STORABLE_thaw
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::::implementorURI::implementor
0000s0sURI::::newURI::new
0000s0sURI::::new_absURI::new_abs
0000s0sURI::::opaqueURI::opaque
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
3336µs235µs
# spent 27µs (20+7) within URI::BEGIN@3 which was called: # once (20µs+7µs) by LWP::UserAgent::BEGIN@10 at line 3
use strict;
# spent 27µs making 1 call to URI::BEGIN@3 # spent 7µs making 1 call to strict::import
4344µs285µs
# spent 48µs (11+37) within URI::BEGIN@4 which was called: # once (11µs+37µs) by LWP::UserAgent::BEGIN@10 at line 4
use vars qw($VERSION);
# spent 48µs making 1 call to URI::BEGIN@4 # spent 37µs making 1 call to vars::import
511µs$VERSION = "1.54";
6
7341µs2101µs
# spent 55µs (9+46) within URI::BEGIN@7 which was called: # once (9µs+46µs) by LWP::UserAgent::BEGIN@10 at line 7
use vars qw($ABS_REMOTE_LEADING_DOTS $ABS_ALLOW_RELATIVE_SCHEME $DEFAULT_QUERY_FORM_DELIMITER);
# spent 55µs making 1 call to URI::BEGIN@7 # spent 46µs making 1 call to vars::import
8
91400nsmy %implements; # mapping from scheme to implementor class
10
11# Some "official" character classes
12
13367µs2139µs
# spent 74µs (10+65) within URI::BEGIN@13 which was called: # once (10µs+65µs) by LWP::UserAgent::BEGIN@10 at line 13
use vars qw($reserved $mark $unreserved $uric $scheme_re);
# spent 74µs making 1 call to URI::BEGIN@13 # spent 65µs making 1 call to vars::import
141300ns$reserved = q(;/?:@&=+$,[]);
151300ns$mark = q(-_.!~*'()); #'; emacs
1612µs$unreserved = "A-Za-z0-9\Q$mark\E";
1711µs$uric = quotemeta($reserved) . $unreserved . "%";
18
191500ns$scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
20
21322µs16µs
# spent 6µs within URI::BEGIN@21 which was called: # once (6µs+0s) by LWP::UserAgent::BEGIN@10 at line 21
use Carp ();
# spent 6µs making 1 call to URI::BEGIN@21
223147µs14µs
# spent 4µs within URI::BEGIN@22 which was called: # once (4µs+0s) by LWP::UserAgent::BEGIN@10 at line 22
use URI::Escape ();
# spent 4µs making 1 call to URI::BEGIN@22
23
24
# spent 77µs (19+57) within URI::BEGIN@24 which was called: # once (19µs+57µs) by LWP::UserAgent::BEGIN@10 at line 28
use overload ('""' => sub { ${$_[0]} },
25 '==' => sub { _obj_eq(@_) },
26 '!=' => sub { !_obj_eq(@_) },
27157µs fallback => 1,
# spent 57µs making 1 call to overload::import
283532µs177µs );
# spent 77µs making 1 call to URI::BEGIN@24
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 return $str;
94}
95
96
97sub implementor
98{
99 my($scheme, $impclass) = @_;
100 if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
101 require URI::_generic;
102 return "URI::_generic";
103 }
104
105 $scheme = lc($scheme);
106
107 if ($impclass) {
108 # Set the implementor class for a given scheme
109 my $old = $implements{$scheme};
110 $impclass->_init_implementor($scheme);
111 $implements{$scheme} = $impclass;
112 return $old;
113 }
114
115 my $ic = $implements{$scheme};
116 return $ic if $ic;
117
118 # scheme not yet known, look for internal or
119 # preloaded (with 'use') implementation
120 $ic = "URI::$scheme"; # default location
121
122 # turn scheme into a valid perl identifier by a simple transformation...
123 $ic =~ s/\+/_P/g;
124 $ic =~ s/\./_O/g;
125 $ic =~ s/\-/_/g;
126
12731.08ms258µs
# spent 35µs (13+23) within URI::BEGIN@127 which was called: # once (13µs+23µs) by LWP::UserAgent::BEGIN@10 at line 127
no strict 'refs';
# spent 35µs making 1 call to URI::BEGIN@127 # spent 23µs making 1 call to strict::unimport
128 # check we actually have one for the scheme:
129 unless (@{"${ic}::ISA"}) {
130 # Try to load it
131 eval "require $ic";
132 die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
133 return unless @{"${ic}::ISA"};
134 }
135
136 $ic->_init_implementor($scheme);
137 $implements{$scheme} = $ic;
138 $ic;
139}
140
141
142sub _init_implementor
143{
144 my($class, $scheme) = @_;
145 # Remember that one implementor class may actually
146 # serve to implement several URI schemes.
147}
148
149
150sub clone
151{
152 my $self = shift;
153 my $other = $$self;
154 bless \$other, ref $self;
155}
156
157
158sub _no_scheme_ok { 0 }
159
160sub _scheme
161{
162 my $self = shift;
163
164 unless (@_) {
165 return unless $$self =~ /^($scheme_re):/o;
166 return $1;
167 }
168
169 my $old;
170 my $new = shift;
171 if (defined($new) && length($new)) {
172 Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
173 $old = $1 if $$self =~ s/^($scheme_re)://o;
174 my $newself = URI->new("$new:$$self");
175 $$self = $$newself;
176 bless $self, ref($newself);
177 }
178 else {
179 if ($self->_no_scheme_ok) {
180 $old = $1 if $$self =~ s/^($scheme_re)://o;
181 Carp::carp("Oops, opaque part now look like scheme")
182 if $^W && $$self =~ m/^$scheme_re:/o
183 }
184 else {
185 $old = $1 if $$self =~ m/^($scheme_re):/o;
186 }
187 }
188
189 return $old;
190}
191
192sub scheme
193{
194 my $scheme = shift->_scheme(@_);
195 return unless defined $scheme;
196 lc($scheme);
197}
198
199
200sub opaque
201{
202 my $self = shift;
203
204 unless (@_) {
205 $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
206 return $1;
207 }
208
209 $$self =~ /^($scheme_re:)? # optional scheme
210 ([^\#]*) # opaque
211 (\#.*)? # optional fragment
212 $/sx or die;
213
214 my $old_scheme = $1;
215 my $old_opaque = $2;
216 my $old_frag = $3;
217
218 my $new_opaque = shift;
219 $new_opaque = "" unless defined $new_opaque;
220 $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
221
222 $$self = defined($old_scheme) ? $old_scheme : "";
223 $$self .= $new_opaque;
224 $$self .= $old_frag if defined $old_frag;
225
226 $old_opaque;
227}
228
22912µs*path = \&opaque; # alias
230
231
232sub fragment
233{
234 my $self = shift;
235 unless (@_) {
236 return unless $$self =~ /\#(.*)/s;
237 return $1;
238 }
239
240 my $old;
241 $old = $1 if $$self =~ s/\#(.*)//s;
242
243 my $new_frag = shift;
244 if (defined $new_frag) {
245 $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
246 $$self .= "#$new_frag";
247 }
248 $old;
249}
250
251
252sub as_string
253{
254 my $self = shift;
255 $$self;
256}
257
258
259sub as_iri
260{
261 my $self = shift;
262 my $str = $$self;
263 if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
264 # All this crap because the more obvious:
265 #
266 # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
267 #
268 # doesn't work before Encode 2.39. Wait for a standard release
269 # to bundle that version.
270
271 require Encode;
272 my $enc = Encode::find_encoding("UTF-8");
273 my $u = "";
274 while (length $str) {
275 $u .= $enc->decode($str, Encode::FB_QUIET());
276 if (length $str) {
277 # escape next char
278 $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
279 }
280 }
281 $str = $u;
282 }
283 return $str;
284}
285
286
287sub canonical
288{
289 # Make sure scheme is lowercased, that we don't escape unreserved chars,
290 # and that we use upcase escape sequences.
291
292 my $self = shift;
293 my $scheme = $self->_scheme || "";
294 my $uc_scheme = $scheme =~ /[A-Z]/;
295 my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
296 return $self unless $uc_scheme || $esc;
297
298 my $other = $self->clone;
299 if ($uc_scheme) {
300 $other->_scheme(lc $scheme);
301 }
302 if ($esc) {
303 $$other =~ s{%([0-9a-fA-F]{2})}
304 { my $a = chr(hex($1));
305 $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
306 }ge;
307 }
308 return $other;
309}
310
311# Compare two URIs, subclasses will provide a more correct implementation
312sub eq {
313 my($self, $other) = @_;
314 $self = URI->new($self, $other) unless ref $self;
315 $other = URI->new($other, $self) unless ref $other;
316 ref($self) eq ref($other) && # same class
317 $self->canonical->as_string eq $other->canonical->as_string;
318}
319
320# generic-URI transformation methods
321sub abs { $_[0]; }
322sub rel { $_[0]; }
323
324sub secure { 0 }
325
326# help out Storable
327sub STORABLE_freeze {
328 my($self, $cloning) = @_;
329 return $$self;
330}
331
332sub STORABLE_thaw {
333 my($self, $cloning, $str) = @_;
334 $$self = $str;
335}
336
33718µs1;
338
339__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.