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