File | /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm |
Statements Executed | 153 |
Statement Execution Time | 1.69ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
3 | 1 | 1 | 265µs | 1.43ms | matching | HTTP::Config::
3 | 1 | 1 | 119µs | 492µs | __ANON__[:152] | HTTP::Config::
1 | 1 | 1 | 13µs | 16µs | BEGIN@3 | HTTP::Config::
1 | 1 | 1 | 12µs | 12µs | BEGIN@4 | HTTP::Config::
12 | 2 | 2 | 10µs | 10µs | CORE:subst (opcode) | HTTP::Config::
1 | 1 | 1 | 9µs | 9µs | new | HTTP::Config::
1 | 1 | 1 | 7µs | 34µs | BEGIN@5 | HTTP::Config::
3 | 1 | 2 | 6µs | 6µs | CORE:sort (opcode) | HTTP::Config::
1 | 1 | 1 | 5µs | 5µs | add | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:100] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:105] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:116] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:121] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:127] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:131] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:135] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:141] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:159] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:167] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:71] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:76] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:81] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:86] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | __ANON__[:91] | HTTP::Config::
0 | 0 | 0 | 0s | 0s | add_item | HTTP::Config::
0 | 0 | 0 | 0s | 0s | empty | HTTP::Config::
0 | 0 | 0 | 0s | 0s | entries | HTTP::Config::
0 | 0 | 0 | 0s | 0s | find | HTTP::Config::
0 | 0 | 0 | 0s | 0s | find2 | HTTP::Config::
0 | 0 | 0 | 0s | 0s | matching_items | HTTP::Config::
0 | 0 | 0 | 0s | 0s | remove | HTTP::Config::
0 | 0 | 0 | 0s | 0s | remove_items | HTTP::Config::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package HTTP::Config; | ||||
2 | |||||
3 | 3 | 29µs | 2 | 19µ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 # spent 16µs making 1 call to HTTP::Config::BEGIN@3
# spent 3µs making 1 call to strict::import |
4 | 3 | 22µs | 1 | 12µs | # spent 12µs within HTTP::Config::BEGIN@4 which was called
# once (12µs+0s) by LWP::UserAgent::add_handler at line 4 # spent 12µs making 1 call to HTTP::Config::BEGIN@4 |
5 | 3 | 1.20ms | 2 | 61µ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 # spent 34µs making 1 call to HTTP::Config::BEGIN@5
# spent 27µs making 1 call to vars::import |
6 | |||||
7 | 1 | 700ns | $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 | ||||
10 | 2 | 13µs | my $class = shift; | ||
11 | return bless [], $class; | ||||
12 | } | ||||
13 | |||||
14 | sub entries { | ||||
15 | my $self = shift; | ||||
16 | @$self; | ||||
17 | } | ||||
18 | |||||
19 | sub 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 | ||||
25 | 4 | 6µs | if (@_ == 2) { | ||
26 | my $self = shift; | ||||
27 | push(@$self, shift); | ||||
28 | return; | ||||
29 | } | ||||
30 | my($self, %spec) = @_; | ||||
31 | push(@$self, \%spec); | ||||
32 | return; | ||||
33 | } | ||||
34 | |||||
35 | sub 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 | |||||
53 | sub find { | ||||
54 | my $self = shift; | ||||
55 | my $f = $self->find2(@_); | ||||
56 | return @$f if wantarray; | ||||
57 | return $f->[0]; | ||||
58 | } | ||||
59 | |||||
60 | sub remove { | ||||
61 | my($self, %spec) = @_; | ||||
62 | my($removed, $rest) = $self->find2(%spec); | ||||
63 | @$self = @$rest if @$removed; | ||||
64 | return @$removed; | ||||
65 | } | ||||
66 | |||||
67 | my %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 | ||||
143 | 27 | 86µs | my($v, $uri, $request, $response) = @_; | ||
144 | return unless $response; | ||||
145 | return 1, 1 if $v eq "*/*"; | ||||
146 | my $ct = $response->content_type; # spent 99µs making 3 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 33µs/call | ||||
147 | 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 | ||||
148 | 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 | ||||
149 | 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 | ||||
150 | return 10, 1 if $v eq $ct; | ||||
151 | 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 | }, | ||||
168 | 1 | 38µ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 | ||||
171 | 108 | 280µs | my $self = shift; | ||
172 | if (@_ == 1) { | ||||
173 | if ($_[0]->can("request")) { # spent 7µs making 3 calls to UNIVERSAL::can, avg 2µs/call | ||||
174 | unshift(@_, $_[0]->request); # spent 26µs making 3 calls to HTTP::Response::request, avg 9µs/call | ||||
175 | unshift(@_, undef) unless defined $_[0]; | ||||
176 | } | ||||
177 | 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 | } | ||||
179 | my($uri, $request, $response) = @_; | ||||
180 | $uri = URI->new($uri) unless ref($uri); | ||||
181 | |||||
182 | my @m; | ||||
183 | ITEM: | ||||
184 | for my $item (@$self) { | ||||
185 | my $order; | ||||
186 | for my $ikey (keys %$item) { | ||||
187 | my $mkey = $ikey; | ||||
188 | my $k; | ||||
189 | $k = $1 if $mkey =~ s/__(.*)/__/; # spent 8µs making 9 calls to HTTP::Config::CORE:subst, avg 867ns/call | ||||
190 | if (my $m = $MATCH{$mkey}) { | ||||
191 | #print "$ikey $mkey\n"; | ||||
192 | my($c, $o); | ||||
193 | my @arg = ( | ||||
194 | defined($k) ? $k : (), | ||||
195 | $uri, $request, $response | ||||
196 | ); | ||||
197 | my $v = $item->{$ikey}; | ||||
198 | $v = [$v] unless ref($v) eq "ARRAY"; | ||||
199 | for (@$v) { | ||||
200 | ($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"; | ||||
202 | last if $c; | ||||
203 | } | ||||
204 | 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 | } | ||||
212 | @m = sort { $b->{_order} cmp $a->{_order} } @m; # spent 6µs making 3 calls to HTTP::Config::CORE:sort, avg 2µs/call | ||||
213 | delete $_->{_order} for @m; | ||||
214 | return @m if wantarray; | ||||
215 | return $m[0]; | ||||
216 | } | ||||
217 | |||||
218 | sub add_item { | ||||
219 | my $self = shift; | ||||
220 | my $item = shift; | ||||
221 | return $self->add(item => $item, @_); | ||||
222 | } | ||||
223 | |||||
224 | sub remove_items { | ||||
225 | my $self = shift; | ||||
226 | return map $_->{item}, $self->remove(@_); | ||||
227 | } | ||||
228 | |||||
229 | sub matching_items { | ||||
230 | my $self = shift; | ||||
231 | return map $_->{item}, $self->matching(@_); | ||||
232 | } | ||||
233 | |||||
234 | 1 | 15µs | 1; | ||
235 | |||||
236 | __END__ | ||||
237 | |||||
238 | =head1 NAME | ||||
239 | |||||
240 | HTTP::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 | |||||
257 | An C<HTTP::Config> object is a list of entries that | ||||
258 | can be matched against request or request/response pairs. Its | ||||
259 | purpose is to hold configuration data that can be looked up given a | ||||
260 | request or response object. | ||||
261 | |||||
262 | Each configuration entry is a hash. Some keys specify matching to | ||||
263 | occur against attributes of request/response objects. Other keys can | ||||
264 | be used to hold user data. | ||||
265 | |||||
266 | The following methods are provided: | ||||
267 | |||||
268 | =over 4 | ||||
269 | |||||
270 | =item $conf = HTTP::Config->new | ||||
271 | |||||
272 | Constructs a new empty C<HTTP::Config> object and returns it. | ||||
273 | |||||
274 | =item $conf->entries | ||||
275 | |||||
276 | Returns the list of entries in the configuration object. | ||||
277 | In scalar context returns the number of entries. | ||||
278 | |||||
279 | =item $conf->empty | ||||
280 | |||||
281 | Return true if there are no entries in the configuration object. | ||||
282 | This is just a shorthand for C<< not $conf->entries >>. | ||||
283 | |||||
284 | =item $conf->add( %matchspec, %other ) | ||||
285 | |||||
286 | =item $conf->add( \%entry ) | ||||
287 | |||||
288 | Adds a new entry to the configuration. | ||||
289 | You can either pass separate key/value pairs or a hash reference. | ||||
290 | |||||
291 | =item $conf->remove( %spec ) | ||||
292 | |||||
293 | Removes (and returns) the entries that have matches for all the key/value pairs in %spec. | ||||
294 | If %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 | |||||
304 | Returns the entries that match the given $uri, $request and $response triplet. | ||||
305 | |||||
306 | If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method. | ||||
307 | If called with a single $response object, then the request object is obtained by calling its 'request' method; | ||||
308 | and then the $uri is obtained as if a single $request was provided. | ||||
309 | |||||
310 | The entries are returned with the most specific matches first. | ||||
311 | In 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 | |||||
319 | Wrappers that hides the entries themselves. | ||||
320 | |||||
321 | =back | ||||
322 | |||||
323 | =head2 Matching | ||||
324 | |||||
325 | The following keys on a configuration entry specify matching. For all | ||||
326 | of these you can provide an array of values instead of a single value. | ||||
327 | The entry matches if at least one of the values in the array matches. | ||||
328 | |||||
329 | Entries that require match against a response object attribute will never match | ||||
330 | unless a response object was provided. | ||||
331 | |||||
332 | =over | ||||
333 | |||||
334 | =item m_scheme => $scheme | ||||
335 | |||||
336 | Matches if the URI uses the specified scheme; e.g. "http". | ||||
337 | |||||
338 | =item m_secure => $bool | ||||
339 | |||||
340 | If $bool is TRUE; matches if the URI uses a secure scheme. If $bool | ||||
341 | is FALSE; matches if the URI does not use a secure scheme. An example | ||||
342 | of a secure scheme is "https". | ||||
343 | |||||
344 | =item m_host_port => "$hostname:$port" | ||||
345 | |||||
346 | Matches if the URI's host_port method return the specified value. | ||||
347 | |||||
348 | =item m_host => $hostname | ||||
349 | |||||
350 | Matches if the URI's host method returns the specified value. | ||||
351 | |||||
352 | =item m_port => $port | ||||
353 | |||||
354 | Matches if the URI's port method returns the specified value. | ||||
355 | |||||
356 | =item m_domain => ".$domain" | ||||
357 | |||||
358 | Matches if the URI's host method return a value that within the given | ||||
359 | domain. The hostname "www.example.com" will for instance match the | ||||
360 | domain ".com". | ||||
361 | |||||
362 | =item m_path => $path | ||||
363 | |||||
364 | Matches if the URI's path method returns the specified value. | ||||
365 | |||||
366 | =item m_path_prefix => $path | ||||
367 | |||||
368 | Matches if the URI's path is the specified path or has the specified | ||||
369 | path as prefix. | ||||
370 | |||||
371 | =item m_path_match => $Regexp | ||||
372 | |||||
373 | Matches if the regular expression matches the URI's path. Eg. qr/\.html$/. | ||||
374 | |||||
375 | =item m_method => $method | ||||
376 | |||||
377 | Matches 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 | |||||
383 | Matches if the response status code matches. If a single digit is | ||||
384 | specified; matches for all response status codes beginning with that digit. | ||||
385 | |||||
386 | =item m_proxy => $url | ||||
387 | |||||
388 | Matches 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 | |||||
400 | Matches if the response media type matches. | ||||
401 | |||||
402 | With a value of "html" matches if $response->content_is_html returns TRUE. | ||||
403 | With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE. | ||||
404 | |||||
405 | =item m_uri__I<$method> => undef | ||||
406 | |||||
407 | Matches if the URI object provide the method | ||||
408 | |||||
409 | =item m_uri__I<$method> => $string | ||||
410 | |||||
411 | Matches if the URI's $method method returns the given value. | ||||
412 | |||||
413 | =item m_header__I<$field> => $string | ||||
414 | |||||
415 | Matches 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 | |||||
421 | Matches if the response object has a that key; or the entry has the given value. | ||||
422 | |||||
423 | =back | ||||
424 | |||||
425 | =head1 SEE ALSO | ||||
426 | |||||
427 | L<URI>, L<HTTP::Request>, L<HTTP::Response> | ||||
428 | |||||
429 | =head1 COPYRIGHT | ||||
430 | |||||
431 | Copyright 2008, Gisle Aas | ||||
432 | |||||
433 | This library is free software; you can redistribute it and/or | ||||
434 | modify 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 | |||||
# 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 |