← 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 17:10:45 2013
Reported on Tue Oct 15 17:12:29 2013

Filename/usr/share/perl5/LWP/Protocol.pm
StatementsExecuted 20 statements in 1.61ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11122µs50µsLWP::Protocol::::BEGIN@62LWP::Protocol::BEGIN@62
11119µs23µsLWP::Protocol::::BEGIN@10LWP::Protocol::BEGIN@10
11117µs22µsLWP::Protocol::::BEGIN@7LWP::Protocol::BEGIN@7
1115µs5µsLWP::Protocol::::BEGIN@8LWP::Protocol::BEGIN@8
1114µs4µsLWP::Protocol::::BEGIN@9LWP::Protocol::BEGIN@9
0000s0sLWP::Protocol::::__ANON__[:111]LWP::Protocol::__ANON__[:111]
0000s0sLWP::Protocol::::__ANON__[:117]LWP::Protocol::__ANON__[:117]
0000s0sLWP::Protocol::::__ANON__[:125]LWP::Protocol::__ANON__[:125]
0000s0sLWP::Protocol::::__ANON__[:139]LWP::Protocol::__ANON__[:139]
0000s0sLWP::Protocol::::__ANON__[:186]LWP::Protocol::__ANON__[:186]
0000s0sLWP::Protocol::::collectLWP::Protocol::collect
0000s0sLWP::Protocol::::collect_onceLWP::Protocol::collect_once
0000s0sLWP::Protocol::::createLWP::Protocol::create
0000s0sLWP::Protocol::::implementorLWP::Protocol::implementor
0000s0sLWP::Protocol::::max_sizeLWP::Protocol::max_size
0000s0sLWP::Protocol::::newLWP::Protocol::new
0000s0sLWP::Protocol::::requestLWP::Protocol::request
0000s0sLWP::Protocol::::timeoutLWP::Protocol::timeout
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package LWP::Protocol;
2
31117µsrequire LWP::MemberMixin;
4110µs@ISA = qw(LWP::MemberMixin);
51600ns$VERSION = "5.829";
6
7327µs226µs
# spent 22µs (17+5) within LWP::Protocol::BEGIN@7 which was called: # once (17µs+5µs) by LWP::UserAgent::BEGIN@15 at line 7
use strict;
# spent 22µs making 1 call to LWP::Protocol::BEGIN@7 # spent 4µs making 1 call to strict::import
8321µs15µs
# spent 5µs within LWP::Protocol::BEGIN@8 which was called: # once (5µs+0s) by LWP::UserAgent::BEGIN@15 at line 8
use Carp ();
# spent 5µs making 1 call to LWP::Protocol::BEGIN@8
9322µs14µs
# spent 4µs within LWP::Protocol::BEGIN@9 which was called: # once (4µs+0s) by LWP::UserAgent::BEGIN@15 at line 9
use HTTP::Status ();
# spent 4µs making 1 call to LWP::Protocol::BEGIN@9
103317µs226µs
# spent 23µs (19+4) within LWP::Protocol::BEGIN@10 which was called: # once (19µs+4µs) by LWP::UserAgent::BEGIN@15 at line 10
use HTTP::Response;
# spent 23µs making 1 call to LWP::Protocol::BEGIN@10 # spent 4µs making 1 call to UNIVERSAL::import
11
121700nsmy %ImplementedBy = (); # scheme => classname
13
- -
16sub new
17{
18 my($class, $scheme, $ua) = @_;
19
20 my $self = bless {
21 scheme => $scheme,
22 ua => $ua,
23
24 # historical/redundant
25 max_size => $ua->{max_size},
26 }, $class;
27
28 $self;
29}
30
31
32sub create
33{
34 my($scheme, $ua) = @_;
35 my $impclass = LWP::Protocol::implementor($scheme) or
36 Carp::croak("Protocol scheme '$scheme' is not supported");
37
38 # hand-off to scheme specific implementation sub-class
39 my $protocol = $impclass->new($scheme, $ua);
40
41 return $protocol;
42}
43
44
45sub implementor
46{
47 my($scheme, $impclass) = @_;
48
49 if ($impclass) {
50 $ImplementedBy{$scheme} = $impclass;
51 }
52 my $ic = $ImplementedBy{$scheme};
53 return $ic if $ic;
54
55 return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes
56 $scheme = $1; # untaint
57 $scheme =~ s/[.+\-]/_/g; # make it a legal module name
58
59 # scheme not yet known, look for a 'use'd implementation
60 $ic = "LWP::Protocol::$scheme"; # default location
61 $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
6231.09ms279µs
# spent 50µs (22+28) within LWP::Protocol::BEGIN@62 which was called: # once (22µs+28µs) by LWP::UserAgent::BEGIN@15 at line 62
no strict 'refs';
# spent 50µs making 1 call to LWP::Protocol::BEGIN@62 # spent 28µs making 1 call to strict::unimport
63 # check we actually have one for the scheme:
64 unless (@{"${ic}::ISA"}) {
65 # try to autoload it
66 eval "require $ic";
67 if ($@) {
68 if ($@ =~ /Can't locate/) { #' #emacs get confused by '
69 $ic = '';
70 }
71 else {
72 die "$@\n";
73 }
74 }
75 }
76 $ImplementedBy{$scheme} = $ic if $ic;
77 $ic;
78}
79
80
81sub request
82{
83 my($self, $request, $proxy, $arg, $size, $timeout) = @_;
84 Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
85}
86
87
88# legacy
89sub timeout { shift->_elem('timeout', @_); }
90sub max_size { shift->_elem('max_size', @_); }
91
92
93sub collect
94{
95 my ($self, $arg, $response, $collector) = @_;
96 my $content;
97 my($ua, $max_size) = @{$self}{qw(ua max_size)};
98
99 eval {
100 local $\; # protect the print below from surprises
101 if (!defined($arg) || !$response->is_success) {
102 $response->{default_add_content} = 1;
103 }
104 elsif (!ref($arg) && length($arg)) {
105 open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
106 binmode($fh);
107 push(@{$response->{handlers}{response_data}}, {
108 callback => sub {
109 print $fh $_[3] or die "Can't write to '$arg': $!";
110 1;
111 },
112 });
113 push(@{$response->{handlers}{response_done}}, {
114 callback => sub {
115 close($fh) or die "Can't write to '$arg': $!";
116 undef($fh);
117 },
118 });
119 }
120 elsif (ref($arg) eq 'CODE') {
121 push(@{$response->{handlers}{response_data}}, {
122 callback => sub {
123 &$arg($_[3], $_[0], $self);
124 1;
125 },
126 });
127 }
128 else {
129 die "Unexpected collect argument '$arg'";
130 }
131
132 $ua->run_handlers("response_header", $response);
133
134 if (delete $response->{default_add_content}) {
135 push(@{$response->{handlers}{response_data}}, {
136 callback => sub {
137 $_[0]->add_content($_[3]);
138 1;
139 },
140 });
141 }
142
143
144 my $content_size = 0;
145 my $length = $response->content_length;
146 my %skip_h;
147
148 while ($content = &$collector, length $$content) {
149 for my $h ($ua->handlers("response_data", $response)) {
150 next if $skip_h{$h};
151 unless ($h->{callback}->($response, $ua, $h, $$content)) {
152 # XXX remove from $response->{handlers}{response_data} if present
153 $skip_h{$h}++;
154 }
155 }
156 $content_size += length($$content);
157 $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
158 if (defined($max_size) && $content_size > $max_size) {
159 $response->push_header("Client-Aborted", "max_size");
160 last;
161 }
162 }
163 };
164 my $err = $@;
165 delete $response->{handlers}{response_data};
166 delete $response->{handlers} unless %{$response->{handlers}};
167 if ($err) {
168 chomp($err);
169 $response->push_header('X-Died' => $err);
170 $response->push_header("Client-Aborted", "die");
171 return $response;
172 }
173
174 return $response;
175}
176
177
178sub collect_once
179{
180 my($self, $arg, $response) = @_;
181 my $content = \ $_[3];
182 my $first = 1;
183 $self->collect($arg, $response, sub {
184 return $content if $first--;
185 return \ "";
186 });
187}
188
18915µs1;
190
191
192__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.