home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / LWP / ConnCache.pm next >
Text File  |  2006-11-29  |  8KB  |  313 lines
  1. package LWP::ConnCache;
  2.  
  3. # $Id: ConnCache.pm 2397 2005-12-23 13:06:15Z kankri $
  4.  
  5. use strict;
  6. use vars qw($VERSION $DEBUG);
  7.  
  8. $VERSION = "0.01";
  9.  
  10.  
  11. sub new {
  12.     my($class, %cnf) = @_;
  13.     my $total_capacity = delete $cnf{total_capacity};
  14.     $total_capacity = 1 unless defined $total_capacity;
  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. =head1 NAME
  172.  
  173. LWP::ConnCache - Connection cache manager
  174.  
  175. =head1 NOTE
  176.  
  177. This module is experimental.  Details of its interface is likely to
  178. change in the future.
  179.  
  180. =head1 SYNOPSIS
  181.  
  182.  use LWP::ConnCache;
  183.  my $cache = LWP::ConnCache->new;
  184.  $cache->deposit($type, $key, $sock);
  185.  $sock = $cache->withdraw($type, $key);
  186.  
  187. =head1 DESCRIPTION
  188.  
  189. The C<LWP::ConnCache> class is the standard connection cache manager
  190. for LWP::UserAgent.
  191.  
  192. The following basic methods are provided:
  193.  
  194. =over
  195.  
  196. =item $cache = LWP::ConnCache->new( %options )
  197.  
  198. This method constructs a new C<LWP::ConnCache> object.  The only
  199. option currently accepted is 'total_capacity'.  If specified it
  200. initialize the total_capacity option.  It defaults to the value 1.
  201.  
  202. =item $cache->total_capacity( [$num_connections] )
  203.  
  204. Get/sets the number of connection that will be cached.  Connections
  205. will start to be dropped when this limit is reached.  If set to C<0>,
  206. then all connections are immediately dropped.  If set to C<undef>,
  207. then there is no limit.
  208.  
  209. =item $cache->capacity($type, [$num_connections] )
  210.  
  211. Get/set a limit for the number of connections of the specified type
  212. that can be cached.  The $type will typically be a short string like
  213. "http" or "ftp".
  214.  
  215. =item $cache->drop( [$checker, [$reason]] )
  216.  
  217. Drop connections by some criteria.  The $checker argument is a
  218. subroutine that is called for each connection.  If the routine returns
  219. a TRUE value then the connection is dropped.  The routine is called
  220. with ($conn, $type, $key, $deposit_time) as arguments.
  221.  
  222. Shortcuts: If the $checker argument is absent (or C<undef>) all cached
  223. connections are dropped.  If the $checker is a number then all
  224. connections untouched that the given number of seconds or more are
  225. dropped.  If $checker is a string then all connections of the given
  226. type are dropped.
  227.  
  228. The $reason argument is passed on to the dropped() method.
  229.  
  230. =item $cache->prune
  231.  
  232. Calling this method will drop all connections that are dead.  This is
  233. tested by calling the ping() method on the connections.  If the ping()
  234. method exists and returns a FALSE value, then the connection is
  235. dropped.
  236.  
  237. =item $cache->get_types
  238.  
  239. This returns all the 'type' fields used for the currently cached
  240. connections.
  241.  
  242. =item $cache->get_connections( [$type] )
  243.  
  244. This returns all connection objects of the specified type.  If no type
  245. is specified then all connections are returned.  In scalar context the
  246. number of cached connections of the specified type is returned.
  247.  
  248. =back
  249.  
  250.  
  251. The following methods are called by low-level protocol modules to
  252. try to save away connections and to get them back.
  253.  
  254. =over
  255.  
  256. =item $cache->deposit($type, $key, $conn)
  257.  
  258. This method adds a new connection to the cache.  As a result other
  259. already cached connections might be dropped.  Multiple connections with
  260. the same $type/$key might added.
  261.  
  262. =item $conn = $cache->withdraw($type, $key)
  263.  
  264. This method tries to fetch back a connection that was previously
  265. deposited.  If no cached connection with the specified $type/$key is
  266. found, then C<undef> is returned.  There is not guarantee that a
  267. deposited connection can be withdrawn, as the cache manger is free to
  268. drop connections at any time.
  269.  
  270. =back
  271.  
  272. The following methods are called internally.  Subclasses might want to
  273. override them.
  274.  
  275. =over
  276.  
  277. =item $conn->enforce_limits([$type])
  278.  
  279. This method is called with after a new connection is added (deposited)
  280. in the cache or capacity limits are adjusted.  The default
  281. implementation drops connections until the specified capacity limits
  282. are not exceeded.
  283.  
  284. =item $conn->dropping($conn_record, $reason)
  285.  
  286. This method is called when a connection is dropped.  The record
  287. belonging to the dropped connection is passed as the first argument
  288. and a string describing the reason for the drop is passed as the
  289. second argument.  The default implementation makes some noise if the
  290. $LWP::ConnCache::DEBUG variable is set and nothing more.
  291.  
  292. =back
  293.  
  294. =head1 SUBCLASSING
  295.  
  296. For specialized cache policy it makes sense to subclass
  297. C<LWP::ConnCache> and perhaps override the deposit(), enforce_limits()
  298. and dropping() methods.
  299.  
  300. The object itself is a hash.  Keys prefixed with C<cc_> are reserved
  301. for the base class.
  302.  
  303. =head1 SEE ALSO
  304.  
  305. L<LWP::UserAgent>
  306.  
  307. =head1 COPYRIGHT
  308.  
  309. Copyright 2001 Gisle Aas.
  310.  
  311. This library is free software; you can redistribute it and/or
  312. modify it under the same terms as Perl itself.
  313.