Commit | Line | Data |
3fea05b9 |
1 | package HTTP::Config; |
2 | |
3 | use strict; |
4 | use URI; |
5 | use vars qw($VERSION); |
6 | |
7 | $VERSION = "5.815"; |
8 | |
9 | sub new { |
10 | 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 | sub add { |
25 | 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 | m_media_type => sub { # for request too?? |
143 | my($v, $uri, $request, $response) = @_; |
144 | return unless $response; |
145 | return 1, 1 if $v eq "*/*"; |
146 | my $ct = $response->content_type; |
147 | return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; |
148 | return 3, 1 if $v eq "html" && $response->content_is_html; |
149 | return 4, 1 if $v eq "html" && $response->content_is_xhtml; |
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 | ); |
169 | |
170 | sub matching { |
171 | my $self = shift; |
172 | if (@_ == 1) { |
173 | if ($_[0]->can("request")) { |
174 | unshift(@_, $_[0]->request); |
175 | unshift(@_, undef) unless defined $_[0]; |
176 | } |
177 | unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical"); |
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/__(.*)/__/; |
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); |
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; |
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; |
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 |