← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 01.HTTP.t
  Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:20 2010

File /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm
Statements Executed 153
Statement Execution Time 1.69ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
311265µs1.43msHTTP::Config::::matchingHTTP::Config::matching
311119µs492µsHTTP::Config::::__ANON__[:152]HTTP::Config::__ANON__[:152]
11113µs16µsHTTP::Config::::BEGIN@3HTTP::Config::BEGIN@3
11112µs12µsHTTP::Config::::BEGIN@4HTTP::Config::BEGIN@4
122210µs10µsHTTP::Config::::CORE:substHTTP::Config::CORE:subst (opcode)
1119µs9µsHTTP::Config::::newHTTP::Config::new
1117µs34µsHTTP::Config::::BEGIN@5HTTP::Config::BEGIN@5
3126µs6µsHTTP::Config::::CORE:sortHTTP::Config::CORE:sort (opcode)
1115µs5µsHTTP::Config::::addHTTP::Config::add
0000s0sHTTP::Config::::__ANON__[:100]HTTP::Config::__ANON__[:100]
0000s0sHTTP::Config::::__ANON__[:105]HTTP::Config::__ANON__[:105]
0000s0sHTTP::Config::::__ANON__[:116]HTTP::Config::__ANON__[:116]
0000s0sHTTP::Config::::__ANON__[:121]HTTP::Config::__ANON__[:121]
0000s0sHTTP::Config::::__ANON__[:127]HTTP::Config::__ANON__[:127]
0000s0sHTTP::Config::::__ANON__[:131]HTTP::Config::__ANON__[:131]
0000s0sHTTP::Config::::__ANON__[:135]HTTP::Config::__ANON__[:135]
0000s0sHTTP::Config::::__ANON__[:141]HTTP::Config::__ANON__[:141]
0000s0sHTTP::Config::::__ANON__[:159]HTTP::Config::__ANON__[:159]
0000s0sHTTP::Config::::__ANON__[:167]HTTP::Config::__ANON__[:167]
0000s0sHTTP::Config::::__ANON__[:71]HTTP::Config::__ANON__[:71]
0000s0sHTTP::Config::::__ANON__[:76]HTTP::Config::__ANON__[:76]
0000s0sHTTP::Config::::__ANON__[:81]HTTP::Config::__ANON__[:81]
0000s0sHTTP::Config::::__ANON__[:86]HTTP::Config::__ANON__[:86]
0000s0sHTTP::Config::::__ANON__[:91]HTTP::Config::__ANON__[:91]
0000s0sHTTP::Config::::add_itemHTTP::Config::add_item
0000s0sHTTP::Config::::emptyHTTP::Config::empty
0000s0sHTTP::Config::::entriesHTTP::Config::entries
0000s0sHTTP::Config::::findHTTP::Config::find
0000s0sHTTP::Config::::find2HTTP::Config::find2
0000s0sHTTP::Config::::matching_itemsHTTP::Config::matching_items
0000s0sHTTP::Config::::removeHTTP::Config::remove
0000s0sHTTP::Config::::remove_itemsHTTP::Config::remove_items
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package HTTP::Config;
2
3329µs219µs
# spent 16µs (13+3) within HTTP::Config::BEGIN@3 which was called # once (13µs+3µs) by LWP::UserAgent::add_handler at line 3
use strict;
# spent 16µs making 1 call to HTTP::Config::BEGIN@3 # spent 3µs making 1 call to strict::import
4322µs112µs
# spent 12µs within HTTP::Config::BEGIN@4 which was called # once (12µs+0s) by LWP::UserAgent::add_handler at line 4
use URI;
# spent 12µs making 1 call to HTTP::Config::BEGIN@4
531.20ms261µs
# spent 34µs (7+27) within HTTP::Config::BEGIN@5 which was called # once (7µs+27µs) by LWP::UserAgent::add_handler at line 5
use vars qw($VERSION);
# spent 34µs making 1 call to HTTP::Config::BEGIN@5 # spent 27µs making 1 call to vars::import
6
71700ns$VERSION = "5.815";
8
9
# spent 9µs within HTTP::Config::new which was called # once (9µs+0s) by LWP::UserAgent::add_handler at line 700 of LWP/UserAgent.pm
sub new {
101700ns my $class = shift;
11112µs return bless [], $class;
12}
13
14sub entries {
15 my $self = shift;
16 @$self;
17}
18
19sub empty {
20 my $self = shift;
21 not @$self;
22}
23
24
# spent 5µs within HTTP::Config::add which was called # once (5µs+0s) by LWP::UserAgent::add_handler at line 702 of LWP/UserAgent.pm
sub add {
251400ns if (@_ == 2) {
26 my $self = shift;
27 push(@$self, shift);
28 return;
29 }
3012µs my($self, %spec) = @_;
311600ns push(@$self, \%spec);
3213µs return;
33}
34
35sub find2 {
36 my($self, %spec) = @_;
37 my @found;
38 my @rest;
39 ITEM:
40 for my $item (@$self) {
41 for my $k (keys %spec) {
42 if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
43 push(@rest, $item);
44 next ITEM;
45 }
46 }
47 push(@found, $item);
48 }
49 return \@found unless wantarray;
50 return \@found, \@rest;
51}
52
53sub find {
54 my $self = shift;
55 my $f = $self->find2(@_);
56 return @$f if wantarray;
57 return $f->[0];
58}
59
60sub remove {
61 my($self, %spec) = @_;
62 my($removed, $rest) = $self->find2(%spec);
63 @$self = @$rest if @$removed;
64 return @$removed;
65}
66
67my %MATCH = (
68 m_scheme => sub {
69 my($v, $uri) = @_;
70 return $uri->_scheme eq $v; # URI known to be canonical
71 },
72 m_secure => sub {
73 my($v, $uri) = @_;
74 my $secure = $uri->_scheme eq "https";
75 return $secure == !!$v;
76 },
77 m_host_port => sub {
78 my($v, $uri) = @_;
79 return unless $uri->can("host_port");
80 return $uri->host_port eq $v, 7;
81 },
82 m_host => sub {
83 my($v, $uri) = @_;
84 return unless $uri->can("host");
85 return $uri->host eq $v, 6;
86 },
87 m_port => sub {
88 my($v, $uri) = @_;
89 return unless $uri->can("port");
90 return $uri->port eq $v;
91 },
92 m_domain => sub {
93 my($v, $uri) = @_;
94 return unless $uri->can("host");
95 my $h = $uri->host;
96 $h = "$h.local" unless $h =~ /\./;
97 $v = ".$v" unless $v =~ /^\./;
98 return length($v), 5 if substr($h, -length($v)) eq $v;
99 return 0;
100 },
101 m_path => sub {
102 my($v, $uri) = @_;
103 return unless $uri->can("path");
104 return $uri->path eq $v, 4;
105 },
106 m_path_prefix => sub {
107 my($v, $uri) = @_;
108 return unless $uri->can("path");
109 my $path = $uri->path;
110 my $len = length($v);
111 return $len, 3 if $path eq $v;
112 return 0 if length($path) <= $len;
113 $v .= "/" unless $v =~ m,/\z,,;
114 return $len, 3 if substr($path, 0, length($v)) eq $v;
115 return 0;
116 },
117 m_path_match => sub {
118 my($v, $uri) = @_;
119 return unless $uri->can("path");
120 return $uri->path =~ $v;
121 },
122 m_uri__ => sub {
123 my($v, $k, $uri) = @_;
124 return unless $uri->can($k);
125 return 1 unless defined $v;
126 return $uri->$k eq $v;
127 },
128 m_method => sub {
129 my($v, $uri, $request) = @_;
130 return $request && $request->method eq $v;
131 },
132 m_proxy => sub {
133 my($v, $uri, $request) = @_;
134 return $request && ($request->{proxy} || "") eq $v;
135 },
136 m_code => sub {
137 my($v, $uri, $request, $response) = @_;
138 $v =~ s/xx\z//;
139 return unless $response;
140 return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
141 },
142
# spent 492µs (119+373) within HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] which was called 3 times, avg 164µs/call: # 3 times (119µs+373µs) by HTTP::Config::matching at line 200, avg 164µs/call
m_media_type => sub { # for request too??
14336µs my($v, $uri, $request, $response) = @_;
14431µs return unless $response;
14531µs return 1, 1 if $v eq "*/*";
146315µs399µs my $ct = $response->content_type;
# spent 99µs making 3 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 33µs/call
147313µs32µs return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
# spent 2µs making 3 calls to HTTP::Config::CORE:subst, avg 633ns/call
148317µs3119µs return 3, 1 if $v eq "html" && $response->content_is_html;
# spent 105µs making 2 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 53µs/call # spent 13µs making 1 call to HTTP::Message::AUTOLOAD
149317µs367µs return 4, 1 if $v eq "html" && $response->content_is_xhtml;
# spent 56µs making 2 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 28µs/call # spent 12µs making 1 call to HTTP::Message::AUTOLOAD
15032µs return 10, 1 if $v eq $ct;
151314µs return 0;
152 },
153 m_header__ => sub {
154 my($v, $k, $uri, $request, $response) = @_;
155 return unless $request;
156 return 1 if $request->header($k) eq $v;
157 return 1 if $response && $response->header($k) eq $v;
158 return 0;
159 },
160 m_response_attr__ => sub {
161 my($v, $k, $uri, $request, $response) = @_;
162 return unless $response;
163 return 1 if !defined($v) && exists $response->{$k};
164 return 0 unless exists $response->{$k};
165 return 1 if $response->{$k} eq $v;
166 return 0;
167 },
168138µs);
169
170
# spent 1.43ms (265µs+1.16) within HTTP::Config::matching which was called 3 times, avg 475µs/call: # 3 times (265µs+1.16ms) by LWP::UserAgent::handlers at line 762 of LWP/UserAgent.pm, avg 475µs/call
sub matching {
17132µs my $self = shift;
17234µs if (@_ == 1) {
173336µs37µs if ($_[0]->can("request")) {
# spent 7µs making 3 calls to UNIVERSAL::can, avg 2µs/call
174311µs326µs unshift(@_, $_[0]->request);
# spent 26µs making 3 calls to HTTP::Response::request, avg 9µs/call
17532µs unshift(@_, undef) unless defined $_[0];
176 }
177338µs6622µs unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
# spent 616µs making 3 calls to HTTP::Request::uri_canonical, avg 205µs/call # spent 6µs making 3 calls to UNIVERSAL::can, avg 2µs/call
178 }
17935µs my($uri, $request, $response) = @_;
18033µs $uri = URI->new($uri) unless ref($uri);
181
1823800ns my @m;
183 ITEM:
18437µs for my $item (@$self) {
1853800ns my $order;
186313µs for my $ikey (keys %$item) {
18794µs my $mkey = $ikey;
18892µs my $k;
189941µs98µs $k = $1 if $mkey =~ s/__(.*)/__/;
# spent 8µs making 9 calls to HTTP::Config::CORE:subst, avg 867ns/call
190914µs if (my $m = $MATCH{$mkey}) {
191 #print "$ikey $mkey\n";
19233µs my($c, $o);
19336µs my @arg = (
194 defined($k) ? $k : (),
195 $uri, $request, $response
196 );
19734µs my $v = $item->{$ikey};
19836µs $v = [$v] unless ref($v) eq "ARRAY";
19935µs for (@$v) {
200317µs3492µs ($c, $o) = $m->($_, @arg);
# spent 492µs making 3 calls to HTTP::Config::__ANON__[HTTP/Config.pm:152], avg 164µs/call
201 #print " - $_ ==> $c $o\n";
20234µs last if $c;
203 }
204310µs next ITEM unless $c;
205 $order->[$o || 0] += $c;
206 }
207 }
208 $order->[7] ||= 0;
209 $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
210 push(@m, $item);
211 }
212321µs36µs @m = sort { $b->{_order} cmp $a->{_order} } @m;
# spent 6µs making 3 calls to HTTP::Config::CORE:sort, avg 2µs/call
21365µs delete $_->{_order} for @m;
214317µs return @m if wantarray;
215 return $m[0];
216}
217
218sub add_item {
219 my $self = shift;
220 my $item = shift;
221 return $self->add(item => $item, @_);
222}
223
224sub remove_items {
225 my $self = shift;
226 return map $_->{item}, $self->remove(@_);
227}
228
229sub matching_items {
230 my $self = shift;
231 return map $_->{item}, $self->matching(@_);
232}
233
234115µs1;
235
236__END__
237
238=head1 NAME
239
240HTTP::Config - Configuration for request and response objects
241
242=head1 SYNOPSIS
243
244 use HTTP::Config;
245 my $c = HTTP::Config->new;
246 $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
247
248 use HTTP::Request;
249 my $request = HTTP::Request->new(GET => "http://www.example.com");
250
251 if (my @m = $c->matching($request)) {
252 print "Yadayada\n" if $m[0]->{verbose};
253 }
254
255=head1 DESCRIPTION
256
257An C<HTTP::Config> object is a list of entries that
258can be matched against request or request/response pairs. Its
259purpose is to hold configuration data that can be looked up given a
260request or response object.
261
262Each configuration entry is a hash. Some keys specify matching to
263occur against attributes of request/response objects. Other keys can
264be used to hold user data.
265
266The following methods are provided:
267
268=over 4
269
270=item $conf = HTTP::Config->new
271
272Constructs a new empty C<HTTP::Config> object and returns it.
273
274=item $conf->entries
275
276Returns the list of entries in the configuration object.
277In scalar context returns the number of entries.
278
279=item $conf->empty
280
281Return true if there are no entries in the configuration object.
282This is just a shorthand for C<< not $conf->entries >>.
283
284=item $conf->add( %matchspec, %other )
285
286=item $conf->add( \%entry )
287
288Adds a new entry to the configuration.
289You can either pass separate key/value pairs or a hash reference.
290
291=item $conf->remove( %spec )
292
293Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
294If %spec is empty this will match all entries; so it will empty the configuation object.
295
296=item $conf->matching( $uri, $request, $response )
297
298=item $conf->matching( $uri )
299
300=item $conf->matching( $request )
301
302=item $conf->matching( $response )
303
304Returns the entries that match the given $uri, $request and $response triplet.
305
306If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
307If called with a single $response object, then the request object is obtained by calling its 'request' method;
308and then the $uri is obtained as if a single $request was provided.
309
310The entries are returned with the most specific matches first.
311In scalar context returns the most specific match or C<undef> in none match.
312
313=item $conf->add_item( $item, %matchspec )
314
315=item $conf->remove_items( %spec )
316
317=item $conf->matching_items( $uri, $request, $response )
318
319Wrappers that hides the entries themselves.
320
321=back
322
323=head2 Matching
324
325The following keys on a configuration entry specify matching. For all
326of these you can provide an array of values instead of a single value.
327The entry matches if at least one of the values in the array matches.
328
329Entries that require match against a response object attribute will never match
330unless a response object was provided.
331
332=over
333
334=item m_scheme => $scheme
335
336Matches if the URI uses the specified scheme; e.g. "http".
337
338=item m_secure => $bool
339
340If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
341is FALSE; matches if the URI does not use a secure scheme. An example
342of a secure scheme is "https".
343
344=item m_host_port => "$hostname:$port"
345
346Matches if the URI's host_port method return the specified value.
347
348=item m_host => $hostname
349
350Matches if the URI's host method returns the specified value.
351
352=item m_port => $port
353
354Matches if the URI's port method returns the specified value.
355
356=item m_domain => ".$domain"
357
358Matches if the URI's host method return a value that within the given
359domain. The hostname "www.example.com" will for instance match the
360domain ".com".
361
362=item m_path => $path
363
364Matches if the URI's path method returns the specified value.
365
366=item m_path_prefix => $path
367
368Matches if the URI's path is the specified path or has the specified
369path as prefix.
370
371=item m_path_match => $Regexp
372
373Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
374
375=item m_method => $method
376
377Matches if the request method matches the specified value. Eg. "GET" or "POST".
378
379=item m_code => $digit
380
381=item m_code => $status_code
382
383Matches if the response status code matches. If a single digit is
384specified; matches for all response status codes beginning with that digit.
385
386=item m_proxy => $url
387
388Matches if the request is to be sent to the given Proxy server.
389
390=item m_media_type => "*/*"
391
392=item m_media_type => "text/*"
393
394=item m_media_type => "html"
395
396=item m_media_type => "xhtml"
397
398=item m_media_type => "text/html"
399
400Matches if the response media type matches.
401
402With a value of "html" matches if $response->content_is_html returns TRUE.
403With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
404
405=item m_uri__I<$method> => undef
406
407Matches if the URI object provide the method
408
409=item m_uri__I<$method> => $string
410
411Matches if the URI's $method method returns the given value.
412
413=item m_header__I<$field> => $string
414
415Matches if either the request or the response have a header $field with the given value.
416
417=item m_response_attr__I<$key> => undef
418
419=item m_response_attr__I<$key> => $string
420
421Matches if the response object has a that key; or the entry has the given value.
422
423=back
424
425=head1 SEE ALSO
426
427L<URI>, L<HTTP::Request>, L<HTTP::Response>
428
429=head1 COPYRIGHT
430
431Copyright 2008, Gisle Aas
432
433This library is free software; you can redistribute it and/or
434modify it under the same terms as Perl itself.
435
436=cut
# spent 6µs within HTTP::Config::CORE:sort which was called 3 times, avg 2µs/call: # 3 times (6µs+0s) by HTTP::Config::matching at line 212 of HTTP/Config.pm, avg 2µs/call
sub HTTP::Config::CORE:sort; # xsub
# spent 10µs within HTTP::Config::CORE:subst which was called 12 times, avg 808ns/call: # 9 times (8µs+0s) by HTTP::Config::matching at line 189 of HTTP/Config.pm, avg 867ns/call # 3 times (2µs+0s) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] at line 147 of HTTP/Config.pm, avg 633ns/call
sub HTTP::Config::CORE:subst; # xsub