diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/LWP/ConnCache.pm')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/ConnCache.pm | 350 |
1 files changed, 0 insertions, 350 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/LWP/ConnCache.pm b/Master/tlpkg/tlperl/site/lib/LWP/ConnCache.pm deleted file mode 100644 index 67dfff6f6c4..00000000000 --- a/Master/tlpkg/tlperl/site/lib/LWP/ConnCache.pm +++ /dev/null @@ -1,350 +0,0 @@ -package LWP::ConnCache; - -use strict; - -our $VERSION = '6.61'; -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 -initializes 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 -C<"http"> or C<"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 C<($conn, $type, $key, $deposit_time)> as arguments. - -Shortcuts: If the C<$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 |