"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/lib/LWP/ConnCache.pm" (26 Nov 2019, 8739 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "ConnCache.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 6.42_vs_6.43.

    1 package LWP::ConnCache;
    2 
    3 use strict;
    4 
    5 our $VERSION = '6.43';
    6 our $DEBUG;
    7 
    8 sub new {
    9     my($class, %cnf) = @_;
   10 
   11     my $total_capacity = 1;
   12     if (exists $cnf{total_capacity}) {
   13         $total_capacity = delete $cnf{total_capacity};
   14     }
   15     if (%cnf && $^W) {
   16     require Carp;
   17     Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
   18     }
   19     my $self = bless { cc_conns => [] }, $class;
   20     $self->total_capacity($total_capacity);
   21     $self;
   22 }
   23 
   24 
   25 sub deposit {
   26     my($self, $type, $key, $conn) = @_;
   27     push(@{$self->{cc_conns}}, [$conn, $type, $key, time]);
   28     $self->enforce_limits($type);
   29     return;
   30 }
   31 
   32 
   33 sub withdraw {
   34     my($self, $type, $key) = @_;
   35     my $conns = $self->{cc_conns};
   36     for my $i (0 .. @$conns - 1) {
   37     my $c = $conns->[$i];
   38     next unless $c->[1] eq $type && $c->[2] eq $key;
   39     splice(@$conns, $i, 1);  # remove it
   40     return $c->[0];
   41     }
   42     return undef;
   43 }
   44 
   45 
   46 sub total_capacity {
   47     my $self = shift;
   48     my $old = $self->{cc_limit_total};
   49     if (@_) {
   50     $self->{cc_limit_total} = shift;
   51     $self->enforce_limits;
   52     }
   53     $old;
   54 }
   55 
   56 
   57 sub capacity {
   58     my $self = shift;
   59     my $type = shift;
   60     my $old = $self->{cc_limit}{$type};
   61     if (@_) {
   62     $self->{cc_limit}{$type} = shift;
   63     $self->enforce_limits($type);
   64     }
   65     $old;
   66 }
   67 
   68 
   69 sub enforce_limits {
   70     my($self, $type) = @_;
   71     my $conns = $self->{cc_conns};
   72 
   73     my @types = $type ? ($type) : ($self->get_types);
   74     for $type (@types) {
   75     next unless $self->{cc_limit};
   76     my $limit = $self->{cc_limit}{$type};
   77     next unless defined $limit;
   78     for my $i (reverse 0 .. @$conns - 1) {
   79         next unless $conns->[$i][1] eq $type;
   80         if (--$limit < 0) {
   81         $self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded");
   82         }
   83     }
   84     }
   85 
   86     if (defined(my $total = $self->{cc_limit_total})) {
   87     while (@$conns > $total) {
   88         $self->dropping(shift(@$conns), "Total capacity exceeded");
   89     }
   90     }
   91 }
   92 
   93 
   94 sub dropping {
   95     my($self, $c, $reason) = @_;
   96     print "DROPPING @$c [$reason]\n" if $DEBUG;
   97 }
   98 
   99 
  100 sub drop {
  101     my($self, $checker, $reason) = @_;
  102     if (ref($checker) ne "CODE") {
  103     # make it so
  104     if (!defined $checker) {
  105         $checker = sub { 1 };  # drop all of them
  106     }
  107     elsif (_looks_like_number($checker)) {
  108         my $age_limit = $checker;
  109         my $time_limit = time - $age_limit;
  110         $reason ||= "older than $age_limit";
  111         $checker = sub { $_[3] < $time_limit };
  112     }
  113     else {
  114         my $type = $checker;
  115         $reason ||= "drop $type";
  116         $checker = sub { $_[1] eq $type };  # match on type
  117     }
  118     }
  119     $reason ||= "drop";
  120 
  121     local $SIG{__DIE__};  # don't interfere with eval below
  122     local $@;
  123     my @c;
  124     for (@{$self->{cc_conns}}) {
  125     my $drop;
  126     eval {
  127         if (&$checker(@$_)) {
  128         $self->dropping($_, $reason);
  129         $drop++;
  130         }
  131     };
  132     push(@c, $_) unless $drop;
  133     }
  134     @{$self->{cc_conns}} = @c;
  135 }
  136 
  137 
  138 sub prune {
  139     my $self = shift;
  140     $self->drop(sub { !shift->ping }, "ping");
  141 }
  142 
  143 
  144 sub get_types {
  145     my $self = shift;
  146     my %t;
  147     $t{$_->[1]}++ for @{$self->{cc_conns}};
  148     return keys %t;
  149 }
  150 
  151 
  152 sub get_connections {
  153     my($self, $type) = @_;
  154     my @c;
  155     for (@{$self->{cc_conns}}) {
  156     push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]);
  157     }
  158     @c;
  159 }
  160 
  161 
  162 sub _looks_like_number {
  163     $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
  164 }
  165 
  166 1;
  167 
  168 
  169 __END__
  170 
  171 =pod
  172 
  173 =head1 NAME
  174 
  175 LWP::ConnCache - Connection cache manager
  176 
  177 =head1 NOTE
  178 
  179 This module is experimental.  Details of its interface is likely to
  180 change in the future.
  181 
  182 =head1 SYNOPSIS
  183 
  184  use LWP::ConnCache;
  185  my $cache = LWP::ConnCache->new;
  186  $cache->deposit($type, $key, $sock);
  187  $sock = $cache->withdraw($type, $key);
  188 
  189 =head1 DESCRIPTION
  190 
  191 The C<LWP::ConnCache> class is the standard connection cache manager
  192 for L<LWP::UserAgent>.
  193 
  194 =head1 METHODS
  195 
  196 The following basic methods are provided:
  197 
  198 =head2 new
  199 
  200     my $cache = LWP::ConnCache->new( %options )
  201 
  202 This method constructs a new L<LWP::ConnCache> object.  The only
  203 option currently accepted is C<total_capacity>.  If specified it
  204 initializes the L<LWP::ConnCache/total_capacity> option. It defaults to C<1>.
  205 
  206 =head2 total_capacity
  207 
  208     my $cap = $cache->total_capacity;
  209     $cache->total_capacity(0); # drop all immediately
  210     $cache->total_capacity(undef); # no limit
  211     $cache->total_capacity($number);
  212 
  213 Get/sets the number of connection that will be cached.  Connections
  214 will start to be dropped when this limit is reached.  If set to C<0>,
  215 then all connections are immediately dropped.  If set to C<undef>,
  216 then there is no limit.
  217 
  218 =head2 capacity
  219 
  220     my $http_capacity = $cache->capacity('http');
  221     $cache->capacity('http', 2 );
  222 
  223 Get/set a limit for the number of connections of the specified type
  224 that can be cached.  The first parameter is a short string like
  225 "http" or "ftp".
  226 
  227 =head2 drop
  228 
  229     $cache->drop(); # Drop ALL connections
  230     # which is just a synonym for:
  231     $cache->drop(sub{1}); # Drop ALL connections
  232     # drop all connections older than 22 seconds and add a reason for it!
  233     $cache->drop(22, "Older than 22 secs dropped");
  234     # which is just a synonym for:
  235     $cache->drop(sub {
  236         my ($conn, $type, $key, $deposit_time) = @_;
  237         if ($deposit_time < 22) {
  238             # true values drop the connection
  239             return 1;
  240         }
  241         # false values don't drop the connection
  242         return 0;
  243     }, "Older than 22 secs dropped" );
  244 
  245 Drop connections by some criteria.  The $checker argument is a
  246 subroutine that is called for each connection.  If the routine returns
  247 a TRUE value then the connection is dropped.  The routine is called
  248 with ($conn, $type, $key, $deposit_time) as arguments.
  249 
  250 Shortcuts: If the $checker argument is absent (or C<undef>) all cached
  251 connections are dropped.  If the $checker is a number then all
  252 connections untouched that the given number of seconds or more are
  253 dropped.  If $checker is a string then all connections of the given
  254 type are dropped.
  255 
  256 The C<reason> is passed on to the L<LWP::ConnCache/dropped> method.
  257 
  258 =head2 prune
  259 
  260     $cache->prune();
  261 
  262 Calling this method will drop all connections that are dead.  This is
  263 tested by calling the L<LWP::ConnCache/ping> method on the connections. If
  264 the L<LWP::ConnCache/ping> method exists and returns a false value, then the
  265 connection is dropped.
  266 
  267 =head2 get_types
  268 
  269     my @types = $cache->get_types();
  270 
  271 This returns all the C<type> fields used for the currently cached
  272 connections.
  273 
  274 =head2 get_connections
  275 
  276     my @conns = $cache->get_connections(); # all connections
  277     my @conns = $cache->get_connections('http'); # connections for http
  278 
  279 This returns all connection objects of the specified type.  If no type
  280 is specified then all connections are returned.  In scalar context the
  281 number of cached connections of the specified type is returned.
  282 
  283 =head1 PROTOCOL METHODS
  284 
  285 The following methods are called by low-level protocol modules to
  286 try to save away connections and to get them back.
  287 
  288 =head2 deposit
  289 
  290     $cache->deposit($type, $key, $conn);
  291 
  292 This method adds a new connection to the cache.  As a result, other
  293 already cached connections might be dropped.  Multiple connections with
  294 the same type/key might be added.
  295 
  296 =head2 withdraw
  297 
  298     my $conn = $cache->withdraw($type, $key);
  299 
  300 This method tries to fetch back a connection that was previously
  301 deposited.  If no cached connection with the specified $type/$key is
  302 found, then C<undef> is returned.  There is not guarantee that a
  303 deposited connection can be withdrawn, as the cache manger is free to
  304 drop connections at any time.
  305 
  306 =head1 INTERNAL METHODS
  307 
  308 The following methods are called internally.  Subclasses might want to
  309 override them.
  310 
  311 =head2 enforce_limits
  312 
  313     $conn->enforce_limits([$type])
  314 
  315 This method is called with after a new connection is added (deposited)
  316 in the cache or capacity limits are adjusted.  The default
  317 implementation drops connections until the specified capacity limits
  318 are not exceeded.
  319 
  320 =head2 dropping
  321 
  322     $conn->dropping($conn_record, $reason)
  323 
  324 This method is called when a connection is dropped.  The record
  325 belonging to the dropped connection is passed as the first argument
  326 and a string describing the reason for the drop is passed as the
  327 second argument.  The default implementation makes some noise if the
  328 C<$LWP::ConnCache::DEBUG> variable is set and nothing more.
  329 
  330 =head1 SUBCLASSING
  331 
  332 For specialized cache policy it makes sense to subclass
  333 C<LWP::ConnCache> and perhaps override the L<LWP::ConnCache/deposit>,
  334 L<LWP::ConnCache/enforce_limits>, and L<LWP::ConnCache/dropping> methods.
  335 
  336 The object itself is a hash.  Keys prefixed with C<cc_> are reserved
  337 for the base class.
  338 
  339 =head1 SEE ALSO
  340 
  341 L<LWP::UserAgent>
  342 
  343 =head1 COPYRIGHT
  344 
  345 Copyright 2001 Gisle Aas.
  346 
  347 This library is free software; you can redistribute it and/or
  348 modify it under the same terms as Perl itself.
  349 
  350 =cut