local-lib5/lib/perl5/HTTP/Config.pm

   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