File Coverage

blib/lib/HTTP/Config.pm
Criterion Covered Total %
statement 83 83 100.0
branch 34 34 100.0
condition 12 12 100.0
subroutine 15 15 100.0
pod 9 11 81.8
total 153 155 98.7


line stmt bran cond sub pod time code
1             package HTTP::Config;
2              
3 1     1   68729 use strict;
  1         10  
  1         32  
4 1     1   6 use warnings;
  1         2  
  1         39  
5              
6             our $VERSION = '6.43';
7              
8 1     1   548 use URI;
  1         6969  
  1         181  
9              
10             sub new {
11 3     3 1 1761 my $class = shift;
12 3         16 return bless [], $class;
13             }
14              
15             sub entries {
16 3     3 1 6 my $self = shift;
17 3         11 @$self;
18             }
19              
20             sub empty {
21 3     3 1 14 my $self = shift;
22 3         18 not @$self;
23             }
24              
25             sub add {
26 18 100   18 1 45 if (@_ == 2) {
27 1         3 my $self = shift;
28 1         3 push(@$self, shift);
29 1         3 return;
30             }
31 17         48 my($self, %spec) = @_;
32 17         32 push(@$self, \%spec);
33 17         36 return;
34             }
35              
36             sub find2 {
37 8     8 0 16 my($self, %spec) = @_;
38 8         15 my @found;
39             my @rest;
40             ITEM:
41 8         16 for my $item (@$self) {
42 44         70 for my $k (keys %spec) {
43 1     1   8 no warnings 'uninitialized';
  1         2  
  1         1894  
44 36 100 100     90 if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
45 31         43 push(@rest, $item);
46 31         47 next ITEM;
47             }
48             }
49 13         25 push(@found, $item);
50             }
51 8 100       21 return \@found unless wantarray;
52 6         20 return \@found, \@rest;
53             }
54              
55             sub find {
56 2     2 0 8 my $self = shift;
57 2         4 my $f = $self->find2(@_);
58 2 100       8 return @$f if wantarray;
59 1         5 return $f->[0];
60             }
61              
62             sub remove {
63 6     6 1 18 my($self, %spec) = @_;
64 6         17 my($removed, $rest) = $self->find2(%spec);
65 6 100       18 @$self = @$rest if @$removed;
66 6         33 return @$removed;
67             }
68              
69             my %MATCH = (
70             m_scheme => sub {
71             my($v, $uri) = @_;
72             return $uri->_scheme eq $v; # URI known to be canonical
73             },
74             m_secure => sub {
75             my($v, $uri) = @_;
76             my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
77             return $secure == !!$v;
78             },
79             m_host_port => sub {
80             my($v, $uri) = @_;
81             return unless $uri->can("host_port");
82             return $uri->host_port eq $v, 7;
83             },
84             m_host => sub {
85             my($v, $uri) = @_;
86             return unless $uri->can("host");
87             return $uri->host eq $v, 6;
88             },
89             m_port => sub {
90             my($v, $uri) = @_;
91             return unless $uri->can("port");
92             return $uri->port eq $v;
93             },
94             m_domain => sub {
95             my($v, $uri) = @_;
96             return unless $uri->can("host");
97             my $h = $uri->host;
98             $h = "$h.local" unless $h =~ /\./;
99             $v = ".$v" unless $v =~ /^\./;
100             return length($v), 5 if substr($h, -length($v)) eq $v;
101             return 0;
102             },
103             m_path => sub {
104             my($v, $uri) = @_;
105             return unless $uri->can("path");
106             return $uri->path eq $v, 4;
107             },
108             m_path_prefix => sub {
109             my($v, $uri) = @_;
110             return unless $uri->can("path");
111             my $path = $uri->path;
112             my $len = length($v);
113             return $len, 3 if $path eq $v;
114             return 0 if length($path) <= $len;
115             $v .= "/" unless $v =~ m,/\z,,;
116             return $len, 3 if substr($path, 0, length($v)) eq $v;
117             return 0;
118             },
119             m_path_match => sub {
120             my($v, $uri) = @_;
121             return unless $uri->can("path");
122             return $uri->path =~ $v;
123             },
124             m_uri__ => sub {
125             my($v, $k, $uri) = @_;
126             return unless $uri->can($k);
127             return 1 unless defined $v;
128             return $uri->$k eq $v;
129             },
130             m_method => sub {
131             my($v, $uri, $request) = @_;
132             return $request && $request->method eq $v;
133             },
134             m_proxy => sub {
135             my($v, $uri, $request) = @_;
136             return $request && ($request->{proxy} || "") eq $v;
137             },
138             m_code => sub {
139             my($v, $uri, $request, $response) = @_;
140             $v =~ s/xx\z//;
141             return unless $response;
142             return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
143             },
144             m_media_type => sub { # for request too??
145             my($v, $uri, $request, $response) = @_;
146             return unless $response;
147             return 1, 1 if $v eq "*/*";
148             my $ct = $response->content_type;
149             return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
150             return 3, 1 if $v eq "html" && $response->content_is_html;
151             return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
152             return 10, 1 if $v eq $ct;
153             return 0;
154             },
155             m_header__ => sub {
156             my($v, $k, $uri, $request, $response) = @_;
157             return unless $request;
158             my $req_header = $request->header($k);
159             return 1 if defined($req_header) && $req_header eq $v;
160             if ($response) {
161             my $res_header = $response->header($k);
162             return 1 if defined($res_header) && $res_header eq $v;
163             }
164             return 0;
165             },
166             m_response_attr__ => sub {
167             my($v, $k, $uri, $request, $response) = @_;
168             return unless $response;
169             return 1 if !defined($v) && exists $response->{$k};
170             return 0 unless exists $response->{$k};
171             return 1 if $response->{$k} eq $v;
172             return 0;
173             },
174             );
175              
176             sub matching {
177 17     17 1 535 my $self = shift;
178 17 100       41 if (@_ == 1) {
179 16 100       79 if ($_[0]->can("request")) {
180 7         17 unshift(@_, $_[0]->request);
181 7 100       19 unshift(@_, undef) unless defined $_[0];
182             }
183 16 100 100     73 unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
184             }
185 17         512 my($uri, $request, $response) = @_;
186 17 100       55 $uri = URI->new($uri) unless ref($uri);
187              
188 17         7626 my @m;
189             ITEM:
190 17         38 for my $item (@$self) {
191 68         93 my $order;
192 68         148 for my $ikey (keys %$item) {
193 114         152 my $mkey = $ikey;
194 114         150 my $k;
195 114 100       243 $k = $1 if $mkey =~ s/__(.*)/__/;
196 114 100       241 if (my $m = $MATCH{$mkey}) {
197             #print "$ikey $mkey\n";
198 67         92 my($c, $o);
199 67 100       162 my @arg = (
200             defined($k) ? $k : (),
201             $uri, $request, $response
202             );
203 67         99 my $v = $item->{$ikey};
204 67 100       155 $v = [$v] unless ref($v) eq "ARRAY";
205 67         120 for (@$v) {
206 72         125 ($c, $o) = $m->($_, @arg);
207             #print " - $_ ==> $c $o\n";
208 72 100       582 last if $c;
209             }
210 67 100       167 next ITEM unless $c;
211 34   100     156 $order->[$o || 0] += $c;
212             }
213             }
214 35   100     150 $order->[7] ||= 0;
215 35   100     534 $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
216 35         113 push(@m, $item);
217             }
218 17         52 @m = sort { $b->{_order} cmp $a->{_order} } @m;
  36         69  
219 17         42 delete $_->{_order} for @m;
220 17 100       137 return @m if wantarray;
221 1         4 return $m[0];
222             }
223              
224             sub add_item {
225 16     16 1 581 my $self = shift;
226 16         23 my $item = shift;
227 16         35 return $self->add(item => $item, @_);
228             }
229              
230             sub remove_items {
231 5     5 1 2244 my $self = shift;
232 5         14 return map $_->{item}, $self->remove(@_);
233             }
234              
235             sub matching_items {
236 16     16 1 1110 my $self = shift;
237 16         39 return map $_->{item}, $self->matching(@_);
238             }
239              
240             1;
241              
242             =pod
243              
244             =encoding UTF-8
245              
246             =head1 NAME
247              
248             HTTP::Config - Configuration for request and response objects
249              
250             =head1 VERSION
251              
252             version 6.43
253              
254             =head1 SYNOPSIS
255              
256             use HTTP::Config;
257             my $c = HTTP::Config->new;
258             $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
259            
260             use HTTP::Request;
261             my $request = HTTP::Request->new(GET => "http://www.example.com");
262            
263             if (my @m = $c->matching($request)) {
264             print "Yadayada\n" if $m[0]->{verbose};
265             }
266              
267             =head1 DESCRIPTION
268              
269             An C object is a list of entries that
270             can be matched against request or request/response pairs. Its
271             purpose is to hold configuration data that can be looked up given a
272             request or response object.
273              
274             Each configuration entry is a hash. Some keys specify matching to
275             occur against attributes of request/response objects. Other keys can
276             be used to hold user data.
277              
278             The following methods are provided:
279              
280             =over 4
281              
282             =item $conf = HTTP::Config->new
283              
284             Constructs a new empty C object and returns it.
285              
286             =item $conf->entries
287              
288             Returns the list of entries in the configuration object.
289             In scalar context returns the number of entries.
290              
291             =item $conf->empty
292              
293             Return true if there are no entries in the configuration object.
294             This is just a shorthand for C<< not $conf->entries >>.
295              
296             =item $conf->add( %matchspec, %other )
297              
298             =item $conf->add( \%entry )
299              
300             Adds a new entry to the configuration.
301             You can either pass separate key/value pairs or a hash reference.
302              
303             =item $conf->remove( %spec )
304              
305             Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
306             If %spec is empty this will match all entries; so it will empty the configuration object.
307              
308             =item $conf->matching( $uri, $request, $response )
309              
310             =item $conf->matching( $uri )
311              
312             =item $conf->matching( $request )
313              
314             =item $conf->matching( $response )
315              
316             Returns the entries that match the given $uri, $request and $response triplet.
317              
318             If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
319             If called with a single $response object, then the request object is obtained by calling its 'request' method;
320             and then the $uri is obtained as if a single $request was provided.
321              
322             The entries are returned with the most specific matches first.
323             In scalar context returns the most specific match or C in none match.
324              
325             =item $conf->add_item( $item, %matchspec )
326              
327             =item $conf->remove_items( %spec )
328              
329             =item $conf->matching_items( $uri, $request, $response )
330              
331             Wrappers that hides the entries themselves.
332              
333             =back
334              
335             =head2 Matching
336              
337             The following keys on a configuration entry specify matching. For all
338             of these you can provide an array of values instead of a single value.
339             The entry matches if at least one of the values in the array matches.
340              
341             Entries that require match against a response object attribute will never match
342             unless a response object was provided.
343              
344             =over
345              
346             =item m_scheme => $scheme
347              
348             Matches if the URI uses the specified scheme; e.g. "http".
349              
350             =item m_secure => $bool
351              
352             If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
353             is FALSE; matches if the URI does not use a secure scheme. An example
354             of a secure scheme is "https".
355              
356             =item m_host_port => "$hostname:$port"
357              
358             Matches if the URI's host_port method return the specified value.
359              
360             =item m_host => $hostname
361              
362             Matches if the URI's host method returns the specified value.
363              
364             =item m_port => $port
365              
366             Matches if the URI's port method returns the specified value.
367              
368             =item m_domain => ".$domain"
369              
370             Matches if the URI's host method return a value that within the given
371             domain. The hostname "www.example.com" will for instance match the
372             domain ".com".
373              
374             =item m_path => $path
375              
376             Matches if the URI's path method returns the specified value.
377              
378             =item m_path_prefix => $path
379              
380             Matches if the URI's path is the specified path or has the specified
381             path as prefix.
382              
383             =item m_path_match => $Regexp
384              
385             Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
386              
387             =item m_method => $method
388              
389             Matches if the request method matches the specified value. Eg. "GET" or "POST".
390              
391             =item m_code => $digit
392              
393             =item m_code => $status_code
394              
395             Matches if the response status code matches. If a single digit is
396             specified; matches for all response status codes beginning with that digit.
397              
398             =item m_proxy => $url
399              
400             Matches if the request is to be sent to the given Proxy server.
401              
402             =item m_media_type => "*/*"
403              
404             =item m_media_type => "text/*"
405              
406             =item m_media_type => "html"
407              
408             =item m_media_type => "xhtml"
409              
410             =item m_media_type => "text/html"
411              
412             Matches if the response media type matches.
413              
414             With a value of "html" matches if $response->content_is_html returns TRUE.
415             With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
416              
417             =item m_uri__I<$method> => undef
418              
419             Matches if the URI object provides the method.
420              
421             =item m_uri__I<$method> => $string
422              
423             Matches if the URI's $method method returns the given value.
424              
425             =item m_header__I<$field> => $string
426              
427             Matches if either the request or the response have a header $field with the given value.
428              
429             =item m_response_attr__I<$key> => undef
430              
431             =item m_response_attr__I<$key> => $string
432              
433             Matches if the response object has that key, or the entry has the given value.
434              
435             =back
436              
437             =head1 SEE ALSO
438              
439             L, L, L
440              
441             =head1 AUTHOR
442              
443             Gisle Aas
444              
445             =head1 COPYRIGHT AND LICENSE
446              
447             This software is copyright (c) 1994 by Gisle Aas.
448              
449             This is free software; you can redistribute it and/or modify it under
450             the same terms as the Perl 5 programming language system itself.
451              
452             =cut
453              
454             __END__