ok
Direktori : /proc/thread-self/root/proc/self/root/proc/self/root/usr/share/perl5/vendor_perl/LWP/ |
Current File : //proc/thread-self/root/proc/self/root/proc/self/root/usr/share/perl5/vendor_perl/LWP/ConnCache.pm |
package LWP::ConnCache; use strict; our $VERSION = '6.34'; our $DEBUG; sub new { my($class, %cnf) = @_; my $total_capacity = 1; if (exists $cnf{total_capacity}) { $total_capacity = delete $cnf{total_capacity}; } if (%cnf && $^W) { require Carp; Carp::carp("Unrecognised options: @{[sort keys %cnf]}") } my $self = bless { cc_conns => [] }, $class; $self->total_capacity($total_capacity); $self; } sub deposit { my($self, $type, $key, $conn) = @_; push(@{$self->{cc_conns}}, [$conn, $type, $key, time]); $self->enforce_limits($type); return; } sub withdraw { my($self, $type, $key) = @_; my $conns = $self->{cc_conns}; for my $i (0 .. @$conns - 1) { my $c = $conns->[$i]; next unless $c->[1] eq $type && $c->[2] eq $key; splice(@$conns, $i, 1); # remove it return $c->[0]; } return undef; } sub total_capacity { my $self = shift; my $old = $self->{cc_limit_total}; if (@_) { $self->{cc_limit_total} = shift; $self->enforce_limits; } $old; } sub capacity { my $self = shift; my $type = shift; my $old = $self->{cc_limit}{$type}; if (@_) { $self->{cc_limit}{$type} = shift; $self->enforce_limits($type); } $old; } sub enforce_limits { my($self, $type) = @_; my $conns = $self->{cc_conns}; my @types = $type ? ($type) : ($self->get_types); for $type (@types) { next unless $self->{cc_limit}; my $limit = $self->{cc_limit}{$type}; next unless defined $limit; for my $i (reverse 0 .. @$conns - 1) { next unless $conns->[$i][1] eq $type; if (--$limit < 0) { $self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded"); } } } if (defined(my $total = $self->{cc_limit_total})) { while (@$conns > $total) { $self->dropping(shift(@$conns), "Total capacity exceeded"); } } } sub dropping { my($self, $c, $reason) = @_; print "DROPPING @$c [$reason]\n" if $DEBUG; } sub drop { my($self, $checker, $reason) = @_; if (ref($checker) ne "CODE") { # make it so if (!defined $checker) { $checker = sub { 1 }; # drop all of them } elsif (_looks_like_number($checker)) { my $age_limit = $checker; my $time_limit = time - $age_limit; $reason ||= "older than $age_limit"; $checker = sub { $_[3] < $time_limit }; } else { my $type = $checker; $reason ||= "drop $type"; $checker = sub { $_[1] eq $type }; # match on type } } $reason ||= "drop"; local $SIG{__DIE__}; # don't interfere with eval below local $@; my @c; for (@{$self->{cc_conns}}) { my $drop; eval { if (&$checker(@$_)) { $self->dropping($_, $reason); $drop++; } }; push(@c, $_) unless $drop; } @{$self->{cc_conns}} = @c; } sub prune { my $self = shift; $self->drop(sub { !shift->ping }, "ping"); } sub get_types { my $self = shift; my %t; $t{$_->[1]}++ for @{$self->{cc_conns}}; return keys %t; } sub get_connections { my($self, $type) = @_; my @c; for (@{$self->{cc_conns}}) { push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]); } @c; } sub _looks_like_number { $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; } 1; __END__ =pod =head1 NAME LWP::ConnCache - Connection cache manager =head1 NOTE This module is experimental. Details of its interface is likely to change in the future. =head1 SYNOPSIS use LWP::ConnCache; my $cache = LWP::ConnCache->new; $cache->deposit($type, $key, $sock); $sock = $cache->withdraw($type, $key); =head1 DESCRIPTION The C<LWP::ConnCache> class is the standard connection cache manager for L<LWP::UserAgent>. =head1 METHODS The following basic methods are provided: =head2 new my $cache = LWP::ConnCache->new( %options ) This method constructs a new L<LWP::ConnCache> object. The only option currently accepted is C<total_capacity>. If specified it initialize the L<LWP::ConnCache/total_capacity> option. It defaults to C<1>. =head2 total_capacity my $cap = $cache->total_capacity; $cache->total_capacity(0); # drop all immediately $cache->total_capacity(undef); # no limit $cache->total_capacity($number); Get/sets the number of connection that will be cached. Connections will start to be dropped when this limit is reached. If set to C<0>, then all connections are immediately dropped. If set to C<undef>, then there is no limit. =head2 capacity my $http_capacity = $cache->capacity('http'); $cache->capacity('http', 2 ); Get/set a limit for the number of connections of the specified type that can be cached. The first parameter is a short string like "http" or "ftp". =head2 drop $cache->drop(); # Drop ALL connections # which is just a synonym for: $cache->drop(sub{1}); # Drop ALL connections # drop all connections older than 22 seconds and add a reason for it! $cache->drop(22, "Older than 22 secs dropped"); # which is just a synonym for: $cache->drop(sub { my ($conn, $type, $key, $deposit_time) = @_; if ($deposit_time < 22) { # true values drop the connection return 1; } # false values don't drop the connection return 0; }, "Older than 22 secs dropped" ); Drop connections by some criteria. The $checker argument is a subroutine that is called for each connection. If the routine returns a TRUE value then the connection is dropped. The routine is called with ($conn, $type, $key, $deposit_time) as arguments. Shortcuts: If the $checker argument is absent (or C<undef>) all cached connections are dropped. If the $checker is a number then all connections untouched that the given number of seconds or more are dropped. If $checker is a string then all connections of the given type are dropped. The C<reason> is passed on to the L<LWP::ConnCache/dropped> method. =head2 prune $cache->prune(); Calling this method will drop all connections that are dead. This is tested by calling the L<LWP::ConnCache/ping> method on the connections. If the L<LWP::ConnCache/ping> method exists and returns a false value, then the connection is dropped. =head2 get_types my @types = $cache->get_types(); This returns all the C<type> fields used for the currently cached connections. =head2 get_connections my @conns = $cache->get_connections(); # all connections my @conns = $cache->get_connections('http'); # connections for http This returns all connection objects of the specified type. If no type is specified then all connections are returned. In scalar context the number of cached connections of the specified type is returned. =head1 PROTOCOL METHODS The following methods are called by low-level protocol modules to try to save away connections and to get them back. =head2 deposit $cache->deposit($type, $key, $conn); This method adds a new connection to the cache. As a result, other already cached connections might be dropped. Multiple connections with the same type/key might be added. =head2 withdraw my $conn = $cache->withdraw($type, $key); This method tries to fetch back a connection that was previously deposited. If no cached connection with the specified $type/$key is found, then C<undef> is returned. There is not guarantee that a deposited connection can be withdrawn, as the cache manger is free to drop connections at any time. =head1 INTERNAL METHODS The following methods are called internally. Subclasses might want to override them. =head2 enforce_limits $conn->enforce_limits([$type]) This method is called with after a new connection is added (deposited) in the cache or capacity limits are adjusted. The default implementation drops connections until the specified capacity limits are not exceeded. =head2 dropping $conn->dropping($conn_record, $reason) This method is called when a connection is dropped. The record belonging to the dropped connection is passed as the first argument and a string describing the reason for the drop is passed as the second argument. The default implementation makes some noise if the C<$LWP::ConnCache::DEBUG> variable is set and nothing more. =head1 SUBCLASSING For specialized cache policy it makes sense to subclass C<LWP::ConnCache> and perhaps override the L<LWP::ConnCache/deposit>, L<LWP::ConnCache/enforce_limits>, and L<LWP::ConnCache/dropping> methods. The object itself is a hash. Keys prefixed with C<cc_> are reserved for the base class. =head1 SEE ALSO L<LWP::UserAgent> =head1 COPYRIGHT Copyright 2001 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut