File Coverage

blib/lib/Cache/Memcached/Managed.pm
Criterion Covered Total %
statement 110 394 27.9
branch 52 206 25.2
condition 7 70 10.0
subroutine 17 56 30.3
pod 30 30 100.0
total 216 756 28.5


line stmt bran cond sub pod time code
1             package Cache::Memcached::Managed;
2              
3             # Make sure we have version info for this module
4              
5             $VERSION= '0.26';
6              
7             # Make sure we're as strict as possible
8             # With as much feedback that we can get
9              
10 6     6   161330 use strict;
  6         21  
  6         194  
11 6     6   34 use warnings;
  6         11  
  6         193  
12              
13             # Use the external modules that we need
14              
15 6     6   34 use Scalar::Util qw(blessed reftype);
  6         14  
  6         925  
16              
17             # Initialize default expiration
18             # Initialize the hash with specific expirations
19             # Initialize the delimiter to be used
20             # Initialize the counter for unique ID's
21             # Initialize the seconds to wait after a delete of a directory key is done
22             # Initialize the default timeout for ping
23             # Initialize number of values to be fetched from memcached at a time
24             # Initialize the server we're running on
25              
26             my $expiration = '1D';
27             my %expiration;
28             my $default_del = '#';
29             my $unique = 0;
30             my $deadtime = 0;
31             my $pingtime = 10;
32             my $atatime = 256;
33             my $server = eval { `uname -n` } || 'unknown'; chomp $server;
34             my $_oneline;
35              
36             # At compile time
37             # Create simple accessors
38              
39             BEGIN {
40 6     6 1 19987 eval "sub $_ { shift->{'$_'} }" foreach qw(
  3     3 1 119  
  0     0 1 0  
  3     3 1 45  
  0     0 1 0  
  0     0 1 0  
  0     0   0  
41             data
42             delimiter
43             directory
44             expiration
45             flush_interval
46             namespace
47             );
48             } #BEGIN
49              
50             # Satisfy -require-
51              
52             1;
53              
54             #---------------------------------------------------------------------------
55             #
56             # Class methods
57             #
58             #---------------------------------------------------------------------------
59             # new
60             #
61             # Return instantiated object
62             #
63             # IN: 1 class
64             # 2..N hash with parameters
65             # OUT: 1 instantiated object
66              
67             sub new {
68 10     10 1 8527 my $class = shift;
69 10 100 50     139 my %self = @_ < 2 ? (data => (shift || '127.0.0.1:11211')) : @_;
70              
71             # want to force an inactive object
72 10 100       70 if (delete $self{'inactive'}) {
73 1         7 require Cache::Memcached::Managed::Inactive;
74 1         13 return Cache::Memcached::Managed::Inactive->new;
75             }
76              
77             # set defaults
78 9 50       82 $self{expiration} = $expiration if !$self{expiration};
79 9 50 50     184 $self{delimiter} = $default_del if !length( $self{delimiter} || '' );
80 9 50       123 $self{namespace} = $> if !defined $self{namespace};
81              
82             # set group names
83             $self{group_names} =
84 9 50       62 [ $self{group_names} ? sort @{ $self{group_names} } : 'group' ];
  0         0  
85 9         25 $self{_group_names} = { map { $_ => undef } @{ $self{group_names} } };
  9         86  
  9         40  
86              
87             # obtain client class
88 9   100     66 my $memcached_class = $self{memcached_class} ||= 'Cache::Memcached';
89 9 50       1927 die $@ if !eval "require $memcached_class; 1";
90              
91             # check both backends
92 9         48 my @all_servers;
93             BACKEND:
94 9         38 foreach ( qw( data directory ) ) {
95              
96             # nothing to do
97 18         20024 my $spec = $self{$_};
98 18 100       75 next BACKEND if !$spec;
99            
100             # giving an existing object
101 9 100       90 if ( blessed $spec ) {
102              
103             # unfortunately, there does not seem to be an API for this
104 1 50       11 if ( my $servers = $spec->{servers} ) {
105 1         5 push @all_servers, @{$servers};
  1         14  
106 1         11 next BACKEND;
107             }
108             }
109              
110             # assume a single server spec
111 8         36 my $parameters;
112 8         55 my $type = reftype $spec;
113 8 100       70 if ( !$type ) {
    100          
    50          
114 5         33 my @servers = split ',', $spec;
115 5         16 push @all_servers, @servers;
116 5         21 $parameters = { servers => \@servers };
117             }
118              
119             # list ref of servers
120             elsif ( $type eq 'ARRAY' ) {
121 1         12 push @all_servers, @{$spec};
  1         67  
122 1         7 $parameters = { servers => $spec };
123             }
124              
125             # ready made parameter hash
126             elsif ( $type eq 'HASH' ) {
127 2         14 $parameters = $spec;
128              
129             # attempt to find server spec in there
130 2         16 $spec = $parameters->{servers};
131 2         18 $type = reftype $spec;
132              
133             # also need to fixup config
134 2 100       31 if ( !$type ) {
    50          
135 1         8 my @servers = split ',', $spec;
136 1         9 push @all_servers, @servers;
137 1         9 $parameters->{servers} = \@servers;
138             }
139              
140             # regular array spec already
141             elsif ( $type eq 'ARRAY' ) {
142 1         10 push @all_servers, @{$spec};
  1         10  
143             }
144              
145             # huh?
146             else {
147 0         0 undef $parameters;
148             }
149             }
150              
151             # huh?
152 8 50       35 die "Don't know how to handle '$spec' as server specification"
153             if !$parameters;
154              
155             # create the object for the backend
156 8         105 $self{$_} = $memcached_class->new($parameters);
157             }
158              
159             # huh?
160 9 50       86 die "No valid data server specification found" if !blessed $self{data};
161              
162             # set directory server as data server if there was no data server
163 9 50       106 $self{directory} = $self{data} if !blessed $self{directory};
164              
165             # remember the pid for fork checking
166 9         57 $self{_last_pid} = $$;
167              
168             # set server specification
169 9         55 $self{servers} = [ sort @all_servers ];
170              
171 9         60 return bless \%self,$class;
172             } #new
173              
174             #---------------------------------------------------------------------------
175             #
176             # Instance methods
177             #
178             #---------------------------------------------------------------------------
179             # add
180             #
181             # Add ID + value, only done if not yet in the cache
182             #
183             # IN: 1 instantiated object
184             # 2 value
185             # 3 id
186             # OUT: 1 true if successful
187             #
188             # or:
189             #
190             # IN: 1 instantiated object
191             # 2..N parameter hash
192             # OUT: 1 true if successful
193              
194 0     0 1 0 sub add { shift->_do( 'add',@_ ) } #add
195              
196             #---------------------------------------------------------------------------
197             # dead
198             #
199             # Cycles through all of the available memcached servers and checks whether
200             # they are alive or not. Returns all of the memcached servers that seem to
201             # be inactive.
202             #
203             # IN: 1 instantiated object
204             # 2 timeout to apply (default: 10 seconds)
205             # OUT: 1..N memcached servers that did not reply (in time)
206             #
207             # or:
208             #
209             # OUT: 1 hash ref with dead servers
210              
211             sub dead {
212              
213             # Obtain the class
214             # Obtain the timeout
215             # Create key to be used
216             # Create value to be used
217              
218 0     0 1 0 my $self = shift;
219 0   0     0 my $timeout = shift || $pingtime;
220 0         0 my $key = $self->_unique_key;
221 0         0 my $value = time;
222              
223             # Initialize list of problem servers
224             # For all of the servers to be checked (in alphabetical order)
225             # Create new memcached server object for this server only
226             # Obtain value from which
227             # Makes sure alarm() will do a die()
228             # Set the alarm
229             # Set the value in the server
230             # Attempt to get it back
231             # Delete the key
232             # Return the value obtained
233              
234 0         0 my @dead;
235 0         0 foreach ($self->servers) {
236 0         0 my $server = $self->{memcached_class}->new( {servers => [$_]} );
237 0   0     0 my $fetched = eval {
238 0     0   0 local $SIG{ALRM} = sub { die "timed out\n" };
239             alarm $timeout;
240             $server->set( $key,$value );
241             my $result = $server->get( $key );
242             $server->delete( $key ) if $result;
243             $result;
244             } || 0;
245              
246             # Reset the alarm
247             # Mark server as problem if value obtained not equal to value stored
248              
249 0         0 alarm 0;
250 0 0       0 push @dead,$_ if $fetched != $value;
251             }
252              
253             # Return list of problem servers (sorted) or as a hash ref
254              
255 0 0       0 return wantarray ? @dead : {map {$_ => undef} @dead};
  0         0  
256             } #dead
257              
258             #---------------------------------------------------------------------------
259             # decr
260             #
261             # Decrement an existing ID, only done if not yet in the cache
262             #
263             # IN: 1 instantiated object
264             # 2 value
265             # 3 id
266             # OUT: 1 true if successful
267             #
268             # or:
269             #
270             # IN: 1 instantiated object
271             # 2..N parameter hash
272             # OUT: 1 true if successful
273              
274 0     0 1 0 sub decr { shift->_do( 'decr',@_ ) } #decr
275              
276             #---------------------------------------------------------------------------
277             # delete
278             #
279             # Delete an existing ID
280             #
281             # IN: 1 instantiated object
282             # 2 id
283             # OUT: 1 true if successful
284             #
285             # or:
286             #
287             # IN: 1 instantiated object
288             # 2..N parameter hash
289             # OUT: 1 true if successful
290              
291             sub delete {
292              
293             # Obtain the object
294             # Check the socket
295              
296 0     0 1 0 my $self = shift;
297 0 0       0 return unless $self->_check_socket;
298              
299             # Obtain the parameters
300             # Perform the delete
301              
302 0 0       0 my %param = @_ == 1 ? (id => shift) : @_;
303             $self->data->delete(
304 0         0 $self->_data_key( @param{qw(id key namespace version)} ) );
305             } #delete
306              
307             #---------------------------------------------------------------------------
308             # delete_group
309             #
310             # Delete all information about a group, given by group name and ID
311             #
312             # IN: 1 instantiated object
313             # 2..N hash with group names and ID's to delete info of
314             # OUT: 1 number of items deleted
315              
316             sub delete_group {
317              
318             # Obtain the object
319             # Obtain the parameter hash
320             # Obtain local copies of stuff we need fast access to here
321             # Obtain the namespace
322              
323 0     0 1 0 my $self = shift;
324 0         0 my %param = @_;
325 0         0 my ($data,$directory) = map {$self->$_} qw(data directory);
  0         0  
326 0         0 my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );
327              
328             # Initialize number of items deleted
329             # Obtain reference to the group names
330             # While there are group name / id pairs to process
331             # Obtain groupname and ID
332             # Make sure group name is fully qualified
333             # Reloop if not a valid group name
334              
335 0         0 my $deleted = 0;
336 0         0 my $group_names = $self->{'_group_names'};
337 0         0 while (my ($group_name,$group_id) = each %param) {
338 0         0 $self->_group_id( $group_name );
339             die "'$group_name' is not a valid group name"
340 0 0       0 unless exists $group_names->{$group_name};
341              
342             # Obtain the directory key
343             # Obtain the index keys
344             # Obtain the backend keys for these index keys
345              
346 0         0 my $directory_key =
347             $self->_directory_key( $namespace,$group_name,$group_id );
348 0         0 my @index_key = $self->_index_keys( $directory_key );
349 0         0 my @data_key = $self->_data_keys( $directory_key,0,@index_key );
350              
351             # Delete the lowest index key
352             # Delete the directory key
353             # Delete all of the index keys
354             # Delete all of the backend keys
355             # Add the number of entries deleted
356              
357 0         0 $directory->delete( $self->_lowest_index_key($directory_key),$deadtime);
358 0         0 $directory->delete( $directory_key,$deadtime );
359 0         0 $directory->delete( $_ ) foreach @index_key;
360 0         0 $data->delete( $_ ) foreach @data_key;
361 0         0 $deleted += @data_key;
362             }
363              
364             # Return the result
365              
366 0         0 $deleted;
367             } #delete_group
368              
369             #---------------------------------------------------------------------------
370             # errors
371             #
372             # Cycles through all of the available memcached servers and returns the
373             # number of errors recorded.
374             #
375             # IN: 1 instantiated object
376             # 2 flag: reset error counters
377             # OUT: 1 reference to hash with number of errors for each server
378              
379             sub errors {
380              
381             # Obtain the parameters
382             # Return with error counters if we don't want to reset the error counters
383              
384 0     0 1 0 my ($self,$reset) = @_;
385 0 0       0 return $self->directory->get_multi( $self->servers ) unless $reset;
386              
387             # Obtain the directory backend
388             # Obtain the error counters
389             # Delete all the error counters that were returned
390             # Return the hash ref with errors
391              
392 0         0 my $directory = $self->directory;
393 0         0 my $errors = $directory->get_multi( $self->servers );
394 0         0 $directory->delete( $_ ) foreach keys %{$errors};
  0         0  
395 0         0 $errors;
396             } #errors
397              
398             #---------------------------------------------------------------------------
399             # flush_all
400             #
401             # Flush the contents of all servers (without rebooting them)
402             #
403             # IN: 1 instantiated object
404             # 2 number of seconds between flushes (default: flush_interval)
405             # OUT: 1 number of servers successfully flushed
406              
407             sub flush_all {
408              
409             # Obtain the object
410             # Obtain the data server
411             # Obtain the servers
412              
413 0     0 1 0 my ($self,$interval) = @_;
414 0         0 my $data = $self->data;
415 0         0 my @server = $self->servers;
416              
417             # Use default interval if none specified
418             # Initialize number of servers flushed
419             # Initialize amount of time to wait
420              
421 0 0       0 $interval = $self->flush_interval unless defined $interval;
422 0         0 my $flushed = 0;
423 0         0 my $time = 0;
424              
425             # For all of the servers minus the directory server
426             # Create the action
427             # Increment flushed if flush was successful
428             # Increment time if we need to
429              
430 0         0 foreach (0..$#server) {
431 0 0       0 my $action = $interval ? "flush_all $time" : "flush_all";
432 0 0       0 $flushed++ if $self->_oneline( $data,$action,$_,"OK" );
433 0 0       0 $time += $interval if $interval;
434             }
435              
436             # Return whether all servers successfully flushed
437              
438 0         0 $flushed = @server;
439             } #flush_all
440              
441             #---------------------------------------------------------------------------
442             # get
443             #
444             # Get a single value from the cache
445             #
446             # IN: 1 instantiated object
447             # 2 id
448             # OUT: 1 value if found or undef
449             #
450             # or:
451             #
452             # IN: 1 instantiated object
453             # 2..N parameter hash
454             # OUT: 1 value if found or undef
455              
456             sub get {
457              
458             # Obtain the object
459             # Check the socket
460              
461 0     0 1 0 my $self = shift;
462 0 0       0 return unless $self->_check_socket;
463              
464             # Obtain the parameters
465             # Perform the actual getting of the value
466              
467 0 0       0 my %param = @_ == 1 ? (id => shift) : @_;
468 0         0 my $data_key = $self->_data_key( @param{qw(id key namespace version)} );
469 0         0 $self->data->get( $data_key );
470             } #get
471              
472             #---------------------------------------------------------------------------
473             # get_group
474             #
475             # Return the contents of the group, optionally deleting it
476             #
477             # IN: 1 instantiated object
478             # 2..N parameter hash (group / delete / namespace)
479             # OUT: 1 hash reference with result
480             #
481             # The structure of the hash is:
482             #
483             # $result
484             # |--- key
485             # |-- version
486             # |-- id
487             # |-- value
488              
489             sub get_group {
490              
491             # Obtain the object
492             # Obtain the parameters
493             # Obtain local copies of stuff we need
494              
495 0     0 1 0 my $self = shift;
496 0         0 my %param = @_;
497             my ($data,$delimiter,$directory) =
498 0         0 map {$self->$_} qw(data delimiter directory);
  0         0  
499              
500             # Obtain delete flag
501             # Obtain namespace to be used
502              
503 0         0 my $delete = delete $param{'delete'};
504 0         0 my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );
505              
506             # Quit now if more than 1 group specified
507             # Obtain group name and ID
508             # Make sure groupname is fully qualified
509             # Die now if not a valid group
510              
511 0 0       0 die "Can only fetch one group at a time" if keys %param > 1;
512 0         0 my ($group_name,$group_id) = each %param;
513 0         0 $self->_group_id( $group_name,!!$delete );
514             die "'$group_name' is not a valid group name"
515 0 0       0 unless exists $self->{'_group_names'}->{$group_name};
516              
517             # Obtain the directory key
518             # Obtain the index keys
519             # Obtain the data keys for these index keys
520              
521 0         0 my $directory_key =
522             $self->_directory_key( $namespace,$group_name,$group_id );
523 0         0 my @index_key = $self->_index_keys( $directory_key );
524 0         0 my @data_key = $self->_data_keys( $directory_key,$delete,@index_key );
525              
526             # If we're deleting
527             # Delete the lowest index key
528             # Delete the directory key
529             # Delete all of the index keys
530              
531 0 0       0 if ($delete) {
532 0         0 $directory->delete( $self->_lowest_index_key($directory_key),$deadtime);
533 0         0 $directory->delete( $directory_key,$deadtime );
534 0         0 $directory->delete( $_ ) foreach @index_key;
535             }
536              
537             # Initialize result hash
538             # Obtain all of the data in one fell swoop
539             # For all of the backend keys for this group
540             # Split out uid, version, key and ID
541             # Remove the entry from the cache if deleting
542             # Move the value out of the gotten hash into the result hash if right namespace
543              
544 0         0 my %result;
545 0         0 while (my @todo = splice @data_key,0,$atatime) {
546 0         0 my $gotten = $data->get_multi( @todo );
547 0         0 foreach my $data_key (keys %{$gotten}) {
  0         0  
548 0         0 my (undef,$version,$key,$id) = split $delimiter,$data_key,4;
549 0 0       0 $data->delete( $data_key ) if $delete;
550 0   0     0 $result{$key}->{$version}->{$id||''} = delete $gotten->{$data_key};
551             }
552             }
553              
554             # Return the result as a hash ref if in scalar context
555             # Return only the values if in list context
556              
557 0 0       0 return \%result unless wantarray;
558 0         0 map {values %{$_}} map {values %{$_}} values %result;
  0         0  
  0         0  
  0         0  
  0         0  
559             } #get_group
560              
561             #---------------------------------------------------------------------------
562             # get_multi
563             #
564             # Get a multiple values from the cache, sharing the same key, version and
565             # namespace
566             #
567             # IN: 1 instantiated object
568             # 2 reference to list of ID's
569             # OUT: 1 hash ref of ID's and values found
570             #
571             # or:
572             #
573             # IN: 1 instantiated object
574             # 2..N parameter hash
575             # OUT: 1 hash ref of ID's and values found
576              
577             sub get_multi {
578              
579             # Obtain the object
580             # Check the socket
581              
582 0     0 1 0 my $self = shift;
583 0 0       0 return {} unless $self->_check_socket;
584              
585             # Obtain the parameters
586             # Obtain the key
587             # Obtain the version
588             # Obtain the namespace
589              
590 0 0       0 my %param = @_ == 1 ? (id => shift) : @_;
591 0         0 my $key = $self->_create_key( $param{'key'} );
592 0         0 my $version = $param{'version'};
593 0         0 my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );
594              
595             # Obtain the data keys
596             # Create result hash
597              
598             my @data_key =
599 0         0 map {$self->_data_key( $_,$key,$namespace,$version )} @{$param{'id'}};
  0         0  
  0         0  
600 0         0 my %result;
601              
602             # Obtain the data server backend
603             # Make sure we use the right delimiter
604             # While we have a batch of data to fetch
605             # Perform the actual getting of the values
606             # For all of the values obtained this time
607             # Move the value to the result hash with just the ID as the key
608              
609 0         0 my $data = $self->data;
610 0         0 my $delimiter = $self->delimiter;
611 0         0 while (my @todo = splice @data_key,0,$atatime) {
612 0         0 my $hash = $data->get_multi( @todo );
613 0         0 foreach (keys %{$hash}) {
  0         0  
614 0         0 $result{(split $delimiter,$_,4)[3]} = delete $hash->{$_};
615             }
616             }
617              
618             # Return the reference to the resulting hash
619              
620 0         0 \%result;
621             } #get_multi
622              
623             #---------------------------------------------------------------------------
624             # grab_group
625             #
626             # IN: 1 instantiated object
627             # 2..N parameter hash (group / namespace)
628             # OUT: 1 hash reference with result
629             #
630             # The structure of the hash is:
631             #
632             # $result
633             # |--- key
634             # |-- version
635             # |-- id
636             # |-- value
637              
638 0     0 1 0 sub grab_group { shift->get_group( delete => 1,@_ ) } #grab_group
639              
640             #---------------------------------------------------------------------------
641             # group
642             #
643             # Return the ID's of a group, ordered by key.
644             #
645             # IN: 1 instantiated object
646             # 2..N parameter hash
647             # OUT: 1 hash reference with result
648             #
649             # The structure of the hash is:
650             #
651             # $result
652             # |--- key
653             # |--- [id1,id2..idN]
654              
655             sub group {
656              
657             # Obtain the parameters
658             # Check the socket
659              
660 0     0 1 0 my $self = shift;
661 0 0       0 return {} unless $self->_check_socket;
662              
663             # Obtain the parameter hash
664             # Obtain the namespace
665             # Quit now if more than one group specified
666              
667 0         0 my %param = @_;
668 0         0 my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );
669 0 0       0 die "Can only fetch one group at a time" if keys %param > 1;
670              
671             # Obtain the group name and group ID
672             # Make sure group name is fully qualified
673             # Return now if not a valid group
674              
675 0         0 my ($group_name,$group_id) = each %param;
676 0         0 $self->_group_id( $group_name );
677 0 0       0 return {} unless exists $self->{'_group_names'}->{$group_name};
678              
679             # Initialize result hash
680             # Make sure we use the right delimiter
681             # For all of the backend keys for this group
682             # Split out the parts
683             # Save the ID in the list for the key
684              
685 0         0 my %result;
686 0         0 my $delimiter = $self->delimiter;
687 0         0 foreach ($self->_data_keys(
688             $self->_directory_key( $namespace,$group_name,$group_id ) )) {
689 0         0 my ($key,$id) = (split $delimiter)[2,3];
690 0         0 push @{$result{$key}},$id;
  0         0  
691             }
692              
693             # Make sure the ID's are listed in order
694             # Return the result
695              
696 0         0 $_ = [sort @$_] foreach values %result;
697 0         0 \%result;
698             } #group
699              
700             #---------------------------------------------------------------------------
701             # group_names
702             #
703             # Return the specifications of all groups defined in alphabetical order in
704             # list context, or as a hash ref in scalar context
705             #
706             # IN: 1 instantiated object
707             # OUT: 1..N group names specifications in alphabetical order
708             #
709             # or:
710             #
711             # OUT: 1 hash ref with group names
712              
713             sub group_names {
714              
715             # Obtain the object
716             # Return the group names sorted or as a hash ref
717              
718 0     0 1 0 my $self = shift;
719 0 0       0 return wantarray ? @{$self->{'group_names'}} : $self->{'_group_names'};
  0         0  
720             } #group_names
721              
722             #---------------------------------------------------------------------------
723             # inactive
724             #
725             # IN: 1 instantiated object
726             # OUT: 1 false
727              
728 0     0 1 0 sub inactive { undef } #inactive
729              
730             #---------------------------------------------------------------------------
731             # incr
732             #
733             # Decrement an existing ID
734             #
735             # IN: 1 instantiated object
736             # 2 value
737             # 3 id
738             # OUT: 1 true if successful
739             #
740             # or:
741             #
742             # IN: 1 instantiated object
743             # 2..N parameter hash
744             # OUT: 1 true if successful
745              
746 0     0 1 0 sub incr { shift->_do( 'incr',@_ ) } #incr
747              
748             #---------------------------------------------------------------------------
749             # replace
750             #
751             # Replace an existing ID
752             #
753             # IN: 1 instantiated object
754             # 2 value
755             # 3 id
756             # OUT: 1 true if successful
757             #
758             # or:
759             #
760             # IN: 1 instantiated object
761             # 2..N parameter hash
762             # OUT: 1 true if successful
763              
764 0     0 1 0 sub replace { shift->_do( 'replace',@_ ) } #replace
765              
766             #---------------------------------------------------------------------------
767             # reset
768             #
769             # Reset the client side of the cache system
770             #
771             # IN: 1 instantiated object
772             # OUT: 1 returns true
773              
774             sub reset {
775 0     0 1 0 my $self = shift;
776              
777             # obtain local copy of data and directory object
778 0         0 my ( $data, $directory ) = ( $self->data, $self->directory );
779              
780             # all of the Cache::Memcached objects we need to handle
781 0 0       0 foreach ( $data == $directory ? ($data) : ( $data, $directory ) ) {
782              
783             # disconnect all sockets
784 0 0       0 $_->disconnect_all if $_->can('disconnect_all');;
785              
786             # kickstart connection logic
787 0 0       0 $_->forget_dead_hosts if $_->can('forget_dead_hosts');
788             }
789              
790             # make sure we try to connect again
791 0         0 $self->_mark_connected;
792              
793             # set last pid used flag
794 0         0 $self->{'_last_pid'} = $$;
795              
796 0         0 return 1;
797             } #reset
798              
799             #---------------------------------------------------------------------------
800             # set
801             #
802             # Set an ID, create if doesn't exist yet
803             #
804             # IN: 1 instantiated object
805             # 2 value
806             # 3 id
807             # OUT: 1 true if successful
808             #
809             # or:
810             #
811             # IN: 1 instantiated object
812             # 2..N parameter hash
813             # OUT: 1 true if successful
814              
815 0     0 1 0 sub set { shift->_do( 'set',@_ ) } #set
816              
817             #---------------------------------------------------------------------------
818             # servers
819             #
820             # Return the specifications of all memcached servers being used in
821             # alphabetical order in list context, or as a hash ref in scalar context
822             #
823             # IN: 1 instantiated object
824             # OUT: 1..N server specifications in alphabetical order
825             #
826             # or:
827             #
828             # OUT: 1 hash ref with server configs
829              
830             sub servers {
831              
832             return wantarray
833 14         75 ? @{ shift->{servers} }
834 17 100   17 1 67 : { map { $_ => undef } @{ shift->{servers} } };
  3         65  
  3         20  
835             } #servers
836              
837             #---------------------------------------------------------------------------
838             # start
839             #
840             # Start the indicated memcached backend servers
841             #
842             # IN: 1 instantiated object
843             # 2..N config of memcached servers to start (default: all)
844             # OUT: 1 whether all indicated memcached servers started
845              
846             sub start {
847              
848             # Obtain the object
849             # Obtain the servers to start
850              
851 8     8 1 4968 my $self = shift;
852 8 50       76 @_ = $self->servers unless @_;
853              
854             # Initialize started counter
855             # For all of the servers to start
856             # Obtain IP and port
857             # Increment counter if start was successful
858            
859 8         20 my $started = 0;
860 8         25 foreach (@_) {
861 8         61 my ($ip,$port) = split ':';
862 8 50       22218 $started++ unless system 'memcached',
863             '-d','-u',(scalar getpwuid $>),'-l',$ip,'-p',$port;
864             }
865              
866             # Return whether all servers started
867              
868 8         338 $started == @_;
869             } #start
870              
871             #---------------------------------------------------------------------------
872             # stats
873             #
874             # Return a hash ref with simple statistics for each server
875             #
876             # IN: 1 instantiated object
877             # 2..N config specifications of servers (default: all)
878             # OUT: 1 hash reference
879             #
880             # $stats
881             # |-- server
882             # |-- key
883             # |-- value
884              
885             sub stats {
886              
887             # Obtain the object
888             # Return now if no active servers anymore
889              
890 3     3 1 35 my $self = shift;
891 3 50       71 return {} unless $self->_check_socket;
892              
893             # Create hash with configs to be done
894             # Initialize the result ref
895             # For all of the objects that we have
896             # For all of the servers we want to do this
897             # Reloop if not to be done
898             # Obtain STATS info
899              
900 3 50       30 my %todo = @_ ? map {$_ => undef} @_ : %{$self->servers};
  0         0  
  3         36  
901 3         18 my %result;
902 3         142 foreach my $cache ($self->data,$self->directory) {
903 6         2739 foreach my $host ( $self->servers ) {
904 6 100 66     81 next unless exists $todo{$host} and not exists $result{$host};
905             $result{$host} = {
906 3         62 map {s#^STAT ##; split m#\s+#}
  0         0  
  0         0  
907             $self->_morelines( $cache,$host,"stats" )
908             };
909             }
910             }
911              
912             # Return the result hash as a ref
913              
914 3         23 \%result;
915             } #stats
916              
917             #---------------------------------------------------------------------------
918             # stop
919             #
920             # Stop the indicated memcached backend servers
921             #
922             # IN: 1 instantiated object
923             # 2..N config of memcached servers to stop (default: all)
924             # OUT: 1 whether all indicated memcached servers stopped
925              
926             sub stop {
927              
928             # Obtain the object
929             # Obtain the pid's to kill
930             # Return whether all were killed
931              
932 3     3 1 12469639 my $self = shift;
933 3         39 my @pid = map {$_->{'pid'}} grep {$_->{'pid'}} values %{$self->stats( @_ )};
  0         0  
  3         17  
  3         51  
934 3         49 @pid == kill 15,@pid;
935             } #stop
936              
937             #---------------------------------------------------------------------------
938             # version
939             #
940             # Return version information of running memcached backend servers
941             #
942             # IN: 1 instantiated object
943             # 2..N config of memcached servers to obtain version of (default: all)
944             # OUT: 1 hash ref with version info, keyed to config
945              
946             sub version {
947              
948             # Obtain the object
949             # Obtain the basic info to work with
950             # Normalize to version information
951              
952 0     0 1 0 my $self = shift;
953 0         0 my $stats = $self->stats( @_ );
954 0         0 $_ = $_->{'version'} foreach values %{$stats};
  0         0  
955              
956             # Return the resulting hash reference
957              
958 0         0 $stats;
959             } #version
960              
961             #---------------------------------------------------------------------------
962             #
963             # Internal methods
964             #
965             #---------------------------------------------------------------------------
966             # _data_key
967             #
968             # Expand the given id
969             #
970             # IN: 1 instantiated object
971             # 2 id to expand (default: none)
972             # 3 key to use (default: caller sub)
973             # 4 namespace to use (default: object->namespace)
974             # 5 version to use (default: key's $package::VERSION)
975             # 6 number of levels to go back in caller stack (default: 2 )
976             # OUT: 1 expanded key
977              
978             sub _data_key {
979              
980             # Obtain the parameters
981             # Obtain key
982             # Obtain the delimiter
983              
984 0     0   0 my ($self,$id,$key,$namespace,$version,$levels) = @_;
985 0   0     0 $key = $self->_create_key( $key,($levels ||= 2) + 1 );
986 0         0 my $delimiter = $self->delimiter;
987              
988             # If we don't have a version yet
989             # Allow for non strict references
990             # Adapt the version information
991             # Make sure we have a namespace
992             # Prefix the version information
993              
994 0 0       0 unless ($version) {
995 6     6   53 no strict 'refs';
  6         24  
  6         2349  
996 0   0     0 $version = ($key =~ m#^(.*)::# ? ${$1.'::VERSION'} : '') ||
997             ($key =~ m#^/# ? $main::VERSION : '') ||
998             $Cache::Memcached::Managed::VERSION;
999             }
1000 0 0       0 $namespace = $self->namespace unless defined $namespace;
1001 0         0 $key = $namespace.$delimiter.$version.$delimiter.$key;
1002              
1003             # If some type of ref was specified for the ID
1004             # If it was a list ref
1005             # Join the elements
1006             # Elseif it was a hash ref
1007             # Join the sorted key/value pairs
1008             # Elseif it was a scalar ref
1009             # Just deref it
1010              
1011 0 0       0 if (my $type = ref $id) {
1012 0 0       0 if ($type eq 'ARRAY') {
    0          
    0          
1013 0         0 $id = join $delimiter,@{$id};
  0         0  
1014             } elsif ($type eq 'HASH') {
1015 0         0 $id = join $delimiter,map {$_ => $id->{$_}} sort keys %{$id};
  0         0  
  0         0  
1016             } elsif ($type eq 'SCALAR') {
1017 0         0 $id = $$id;
1018              
1019             # Else (unexpected type of ref)
1020             # Let the world know we didn't expect this
1021              
1022             } else {
1023 0         0 die "Don't know how to handle key of type '$type': $id";
1024             }
1025             }
1026              
1027             # Expand the ID as appropriate and return the result
1028              
1029 0   0     0 $self->{'_data_key'} =
1030             $key.(defined $id and length $id ? $delimiter.$id : '');
1031             } #_data_key
1032              
1033             #---------------------------------------------------------------------------
1034             # _data_keys
1035             #
1036             # Return the backend keys for a given directory_key
1037             #
1038             # IN: 1 instantiated object (ignored)
1039             # 2 directory key
1040             # 3 flag: don't perform cleanup (default: perform cleanup)
1041             # 4..N index keys, highest first (default: _index_keys)
1042             # OUT: 1..N unordered list with backend keys
1043              
1044             sub _data_keys {
1045              
1046             # Obtain the main parameters
1047             # Make sure we have index keys
1048             # Obtain backend keys
1049              
1050 0     0   0 my ($self,$directory_key,$nocleanup) = splice @_,0,3;
1051 0 0       0 @_ = $self->_index_keys( $directory_key ) unless @_;
1052              
1053             # Obtain shortcut to the directory backend
1054             # Initialize lowest index number found
1055             # Initialize list of index keys with duplicate backend keys found
1056             # Initialize backend key hash
1057              
1058 0         0 my $directory = $self->directory;
1059 0         0 my $lowest = 1;
1060 0         0 my @double;
1061             my %data_key;
1062              
1063             # While there are data keys to be fetched
1064             # If successful in obtaining next slice of the backend keys
1065             # Copy them into the final result hash
1066             # If we don't want to cleanup
1067             # Just put all of the values as keys
1068              
1069 0         0 while (@_) {
1070 0 0       0 if (my $result = $directory->get_multi( splice @_,0,$atatime )) {
1071 0 0       0 if ($nocleanup) {
1072 0         0 $data_key{$_} = undef foreach values %{$result};
  0         0  
1073              
1074             #**************************************************************************
1075             # Note that we're using the side effect of Perl taking the digits at the
1076             # start of a string as the numerical value: this allows us to quickly
1077             # check the index number of the index keys, and to calculate the lowest
1078             # possible free index number that should be checked later. That's why
1079             # we're switching off warnings for this section here.
1080             #**************************************************************************
1081              
1082             # Else (we want to cleanup)
1083             # For all of the index keys obtained
1084             # If this backend key was already found
1085             # Mark this index key as double
1086             # Else
1087             # Set this backend key
1088             # Save this as the lowest value
1089              
1090             } else {
1091 6     6   49 no warnings;
  6         16  
  6         931  
1092 0         0 foreach (sort {$b <=> $a} keys %{$result}) {
  0         0  
  0         0  
1093 0         0 my $data_key = $result->{$_};
1094 0 0       0 if (exists $data_key{$data_key}) {
1095 0         0 push @double,$_;
1096             } else {
1097 0         0 $data_key{$data_key} = undef;
1098 0         0 $lowest = $_;
1099             }
1100             }
1101             }
1102              
1103             # Else (failed,the directory backend has died: this is REALLY bad)
1104             # Invalidate all backend servers
1105             # Invalidate all cache access for this process from now on
1106             # Return emptyhanded
1107            
1108             } else {
1109 0         0 $self->flush_all( $self->flush_interval );
1110 0         0 $self->_mark_disconnected;
1111 0         0 return;
1112             }
1113             }
1114              
1115             # If we want to cleanup
1116             # Remove the index keys that we don't need anymore
1117             # Make sure we're silent about numifying the lowest key
1118             # Set the lowest index to be checked later if lowest was found
1119              
1120 0 0       0 unless ($nocleanup) {
1121 0         0 $directory->delete( $_ ) foreach @double;
1122 6     6   45 no warnings;
  6         15  
  6         12392  
1123 0         0 $directory->set( $self->_lowest_index_key( $directory_key ),0+$lowest );
1124             }
1125              
1126             # Return the result
1127              
1128 0         0 keys %data_key;
1129             } #_data_keys
1130              
1131             #---------------------------------------------------------------------------
1132             # _check_socket
1133             #
1134             # Check whether the socket has been used in this process, disconnect if not
1135             # yet used in this process
1136             #
1137             # IN: 1 class or object (ignored)
1138             # OUT: 1 whether successful
1139              
1140             sub _check_socket {
1141              
1142             # Quickest way out in the most common case
1143              
1144 3 50 33 3   97 return 1 if $$ == $_[0]->{'_last_pid'} and !exists $_[0]->{'_disconnected'};
1145              
1146             # Obtain the object
1147             # Return result of reset if we're in a different process now
1148              
1149 0         0 my $self = shift;
1150 0 0       0 return $self->reset if $$ != $self->{'_last_pid'};
1151              
1152             # Mark object as connected if waited long enough
1153             # Return (possibly changed) status
1154              
1155             $self->_mark_connected
1156 0 0 0     0 if $self->{'_disconnected'} and time > $self->{'_disconnected'};
1157 0         0 return !$self->{'_disconnected'};
1158             } #_check_socket;
1159              
1160             #---------------------------------------------------------------------------
1161             # _create_key
1162             #
1163             # Expand the given key
1164             #
1165             # IN: 1 instantiated object
1166             # 2 key to expand (default: caller sub)
1167             # 3 number of levels to go back in caller stack (default: 2 )
1168             # OUT: 1 fully qualified key
1169              
1170             sub _create_key {
1171              
1172             # Obtain the parameters
1173             # Return now if we already have a fully qualified key
1174              
1175 0     0   0 my ($self,$key,$levels) = @_;
1176 0 0 0     0 return $key if $key and ($key =~ m#.+::# or $key =~ m#^/#);
      0        
1177              
1178             # Set levels if not set yet
1179             # Obtain caller info
1180              
1181 0   0     0 $levels ||= 2;
1182             my $caller = (caller($levels))[3] ||
1183 0   0     0 ($0 =~ m#^/# ? $0 : do {my $pwd = `pwd`; chomp $pwd; $pwd}."/$0");
1184              
1185             # Set the default key if no key specified yet
1186             # If we have a package relative key, removing prefix on the fly
1187             # Remove caller info's relative part
1188             # Prefix the caller info
1189             # Return the resulting key
1190              
1191 0   0     0 $key ||= $caller;
1192 0 0       0 if ($key =~ s#^::##) {
1193 0         0 $caller =~ s#[^:]+$##;
1194 0         0 $key = $caller.$key;
1195             }
1196 0         0 $key;
1197             } #_create_key
1198              
1199             #---------------------------------------------------------------------------
1200             # _directory_key
1201             #
1202             # Return the directory key for a given group name, ID and namespace
1203             #
1204             # IN: 1 instantiated object
1205             # 2 namespace
1206             # 3 group name
1207             # 4 ID
1208              
1209             sub _directory_key {
1210              
1211             # Obtain the delimiter (lose the object on the fly
1212             # Create key and return that
1213              
1214 0     0   0 my $delimiter = shift->delimiter;
1215 0         0 __PACKAGE__.$delimiter.(join $delimiter,@_);
1216             } #_directory_key
1217              
1218             #---------------------------------------------------------------------------
1219             # _do
1220             #
1221             # Perform one of the basic cache actions
1222             #
1223             # IN: 1 instantiated object
1224             # 2 method name
1225             # 3 value
1226             # 4 id
1227             # OUT: 1 true if successful
1228             #
1229             # or:
1230             #
1231             # IN: 1 instantiated object
1232             # 2 method name
1233             # 3..N parameter hash
1234             # OUT: 1 true if successful
1235              
1236             sub _do {
1237              
1238             # Obtain object and method
1239             # Check the socket
1240              
1241 0     0   0 my ($self,$method) = splice @_,0,2;
1242 0 0       0 return undef unless $self->_check_socket;
1243              
1244             # Obtain the parameter hash
1245             # Create the key, removing key specification on the fly
1246              
1247 0 0       0 my %param = @_ > 3
1248             ? @_
1249             : ( value => shift, id => shift, expiration => shift );
1250 0         0 my $key = $self->_create_key( delete( $param{'key'} ),3 );
1251              
1252             # Obtain the ID, removing it on the fly
1253             # Set unique ID if so requested
1254             # Obtain the value, removing it on the fly
1255             # Make sure there is a valid value for increment and decrement
1256             # Obtain the lexicals for parameters
1257             # Convert the expiration to seconds
1258              
1259 0         0 my $id = delete $param{'id'};
1260 0 0 0     0 $id = $self->_unique_key if $id and $id eq ':unique';
1261 0         0 my $value = delete $param{'value'};
1262 0 0 0     0 $value = 1 if !defined $value and $method =~ m#(?:decr|incr)$#;
1263 0         0 my ($expiration,$namespace) =
1264             $self->_lexicalize( \%param,qw(expiration namespace) );
1265 0         0 $expiration = $self->_expiration2seconds( $expiration );
1266              
1267             # Obtain the data server
1268             # Obtain the data key, remove version from parameter hash on the fly
1269             # Perform the named method
1270              
1271 0         0 my $data = $self->data;
1272             my $data_key =
1273 0         0 $self->_data_key( $id,$key,$namespace,delete $param{'version'} );
1274 0         0 my $result = $data->$method( $data_key,$value,$expiration );
1275              
1276             # If action was successful
1277             # Return now if replace, decr or incr (assume always same groups)
1278             # Elseif we're trying to increment (and action failed)
1279             # Add an entry with the indicated value or 1
1280             # Elsif we're not doing a set (so: add|decr|replace and failed)
1281             # Just return with whatever we got
1282              
1283 0 0       0 if ($result) {
    0          
    0          
1284 0 0       0 return $result if $method =~ m#^(?:decr|incr|replace)$#;
1285             } elsif ($method eq 'incr') {
1286 0   0     0 $result = $data->add( $data_key,$value || 1,$expiration);
1287             } elsif ($method ne 'set') {
1288 0         0 return $result;
1289             }
1290              
1291             # still don't have a good result
1292 0         0 my $directory = $self->directory;
1293 0 0       0 if ( !$result ) {
1294              
1295             # can get the bucket
1296 0 0       0 if ( $data->can('get_sock') ) {
1297 0 0       0 if ( my $bucket = $data->get_sock($data_key) ) {
1298              
1299             # can lose prefix, increment error on server
1300 0 0       0 if ( $bucket =~ s#^Sock_## ) {
1301 0 0       0 $directory->add( $bucket, 1 )
1302             if !$directory->incr($bucket);
1303             }
1304             }
1305             }
1306              
1307             # block all access for this process
1308 0         0 $self->{'_disconnected'} = 1;
1309              
1310             # return indicating error
1311 0         0 return undef;
1312             }
1313              
1314             # Obtain hash ref to valid group names
1315             # For all group name links to be set (remaining pairs in parameter hash)
1316             # Normalize group ID if necessary
1317             # Obtain directory key
1318             # Obtain an index
1319              
1320 0         0 my $group_names = $self->{'_group_names'};
1321 0         0 while (my ($group_name,$group_id) = each %param) {
1322 0         0 $group_id =~ s#^:key#$key#;
1323 0         0 my $directory_key =
1324             $self->_directory_key( $namespace,$group_name,$group_id );
1325 0         0 my $index = $directory->incr( $directory_key );
1326              
1327             # If we don't have a valid index
1328             # If not successful in initializing the directory key
1329             # Block all access for this process
1330             # Return indicating error
1331              
1332 0 0       0 unless (defined $index) {
1333 0 0       0 unless (defined $directory->add( $directory_key,$index = 1 )) {
1334 0         0 $self->{'_disconnected'} = 1;
1335 0         0 return undef;
1336             }
1337             }
1338              
1339             # If not successful in storing the data key
1340             # Block all access for this process
1341             # Return indicating error
1342            
1343 0 0       0 unless ($directory->set(
1344             $self->_index_key( $directory_key,$index ),$data_key,$expiration )) {
1345 0         0 $self->{'_disconnected'} = 1;
1346 0         0 return undef;
1347             }
1348             }
1349              
1350             # Return the original result
1351              
1352 0         0 $result;
1353             } #_do
1354              
1355             #---------------------------------------------------------------------------
1356             # _expiration2seconds
1357             #
1358             # Convert given expiration to number of seconds
1359             #
1360             # IN: 1 instantiated object (ignored)
1361             # 2 expiration
1362             # OUT: 1 number of seconds
1363              
1364             sub _expiration2seconds {
1365              
1366             # Obtain the initial expiration
1367             # Return now if nothing to check
1368             # Return now if invalid characters found
1369              
1370 19     19   9567 my $expiration = $_[1];
1371 19 100       62 return if !defined $expiration;
1372 18 100       104 return if $expiration !~ m#^[sSmMhHdDwW\d]+$#;
1373              
1374             # Just a second specification
1375              
1376 17 100       61 return $expiration if $expiration !~ m#\D#;
1377              
1378             # Convert seconds into seconds
1379             # Convert minutes into seconds
1380             # Convert hours into seconds
1381             # Convert days into seconds
1382             # Convert weeks into seconds
1383              
1384 16         37 my $seconds = 0;
1385 16 100       62 $seconds += $1 if $expiration =~ m#(\d+)[sS]#;
1386 16 100       63 $seconds += (60 * $1) if $expiration =~ m#(\d+)[mM]#;
1387 16 100       58 $seconds += (3600 * $1) if $expiration =~ m#(\+?\d+)[hH]#;
1388 16 100       48 $seconds += (86400 * $1) if $expiration =~ m#(\+?\d+)[dD]#;
1389 16 100       44 $seconds += (604800 * $1) if $expiration =~ m#(\+?\d+)[wW]#;
1390              
1391             # Return the resulting sum
1392              
1393 16         62 $seconds;
1394             } #_expiration2seconds
1395              
1396             #---------------------------------------------------------------------------
1397             # _index_key
1398             #
1399             # Return the index key for a given directory_key and ordinal number
1400             #
1401             # IN: 1 instantiated object (ignored)
1402             # 2 directory key
1403             # 3 ordinal number
1404             # OUT: 1 index key
1405              
1406 0     0   0 sub _index_key { $_[2].$_[0]->delimiter.$_[1] } #_index_key
1407              
1408             #---------------------------------------------------------------------------
1409             # _index_keys
1410             #
1411             # Return the index keys for a given directory_key
1412             #
1413             # IN: 1 instantiated object (ignored)
1414             # 2 directory key
1415             # OUT: 1 list with index keys (highest first)
1416              
1417             sub _index_keys {
1418              
1419             # Obtain the parameters
1420             # Return emtyhanded if no index keys available
1421              
1422 0     0   0 my ($self,$directory_key) = @_;
1423 0 0       0 return unless my $found = $self->directory->get( $directory_key );
1424              
1425             # Obtain the lowest possible index
1426             # Create the index keys and return them
1427              
1428 0   0     0 my $lowest =
1429             $self->directory->get( $self->_lowest_index_key( $directory_key ) ) || 1;
1430 0         0 reverse map {$self->_index_key( $directory_key,$_ )} $lowest..$found;
  0         0  
1431             } #_index_keys
1432              
1433             #---------------------------------------------------------------------------
1434             # _group_id
1435             #
1436             # Fully qualify a group name if relative name indicated
1437             #
1438             # IN: 1 instantiated object (ignored)
1439             # 2 group name to check (directly updated, must be left value)
1440             # 3 number of extra levels to go up
1441              
1442             sub _group_id {
1443              
1444             # Prefix package name of relative group name indicated
1445              
1446 0 0 0 0   0 $_[1] = (caller(1 + ($_[2] || 0)))[0].$_[1] if $_[1] =~ m#^::#;
1447             } #_group_id
1448              
1449             #---------------------------------------------------------------------------
1450             # _lexicalize
1451             #
1452             # Return values associated with the given method names, allowing for
1453             # overrides from a parameter hash. Removes these values from the parameter
1454             # hash.
1455             #
1456             # IN: 1 instantiated object
1457             # 2 reference to parameter hash
1458             # 3..N method names to check
1459             # OUT: 1..N values associated with method names
1460              
1461             sub _lexicalize {
1462              
1463             # Obtain object and parameter hash
1464             # Create temporary value holder
1465             # Map the method names to the appropriate value
1466              
1467 0     0   0 my ($self,$param) = splice @_,0,2;
1468 0         0 my $v;
1469 0 0       0 map {$v = delete $param->{$_}; defined $v ? $v : $self->$_ } @_;
  0         0  
  0         0  
1470             } #_lexicalize
1471              
1472             #---------------------------------------------------------------------------
1473             # _lowest_index_key
1474             #
1475             # Return the index key for the lowest possible index
1476             #
1477             # IN: 1 instantiated object (ignored)
1478             # 2 directory key
1479             # OUT: 1 index key of lowest index
1480              
1481 0     0   0 sub _lowest_index_key { $_[1].$_[0]->delimiter.'_lowest' } #_lowest_index_key
1482              
1483             #---------------------------------------------------------------------------
1484             # _mark_connected
1485             #
1486             # Mark the object as connected
1487             #
1488             # IN: 1 instantiated object
1489              
1490 0     0   0 sub _mark_connected { delete $_[0]->{'_disconnected'} } #_mark_connected
1491              
1492             #---------------------------------------------------------------------------
1493             # _mark_disconnected
1494             #
1495             # Mark the object as disconnected: all actions will fail for a random
1496             # amount of time.
1497             #
1498             # IN: 1 instantiated object
1499             # 2 amount of time to mark as disconnected (default: 20..30)
1500              
1501             sub _mark_disconnected {
1502              
1503             # Mark the object as disconnected
1504              
1505 0   0 0   0 $_[0]->{'_disconnected'} = time + ($_[1] || 20 + int rand 10)
1506             } #_mark_disconnected
1507              
1508             #---------------------------------------------------------------------------
1509             # _morelines
1510             #
1511             # Handle non-API request that returns multiple lines
1512             #
1513             # IN: 1 instantiated object (ignored)
1514             # 2 Cache::Memcached object
1515             # 3 host to send to
1516             # 4 line to send (no newline, default: just return next response)
1517             # 5 bucket (default: 0)
1518             # OUT: 1..N response lines
1519              
1520             sub _morelines {
1521 3     3   103 my ( $self, $cache, $host, $send, $bucket ) = @_;
1522              
1523             # don't have any sock to host mapping, so quit
1524 3 50       173 return if !$cache->can('sock_to_host');
1525              
1526             # couldn't get a socket for given host
1527 3 50       65 return unless my $socket = $cache->sock_to_host($host);
1528              
1529             return map {
1530 0 0         s#[\r\n]+$##; m#^(?:END|ERROR)# ? () : ($_)
  0            
  0            
1531             } $cache->run_command( $socket, $send. "\r\n" );
1532             } #_morelines
1533              
1534             #---------------------------------------------------------------------------
1535             # _oneline
1536             #
1537             # IN: 1 instantiated object (ignored)
1538             # 2 Cache::Memcached object
1539             # 3 line to send (no newline, default: just return next response)
1540             # 4 bucket (default: 0)
1541             # 5 response string to check with (no newline, default: return response)
1542             # OUT: 1 response or whether expected response returned
1543              
1544             sub _oneline {
1545 0     0     my ( $self, $cache, $send, $bucket, $expect ) = @_;
1546              
1547             # can't get any socket, so quit
1548 0 0         return if !$cache->can('get_sock');
1549              
1550             # couldn't get a socket for the indicated bucket
1551 0 0 0       return unless my $socket = $cache->get_sock( [$bucket || 0,0] );
1552              
1553             # make sure we can call a "_oneline" compatible method
1554 0 0 0       $_oneline ||=
      0        
1555             $cache->can( '_oneline' ) ||
1556             $cache->can( '_write_and_read' )
1557             or die "Unsupported version of " . ( blessed $cache ) . "\n";
1558              
1559             # obtain response
1560 0 0         my $response = defined $send
1561             ? $_oneline->( $cache, $socket, $send . "\r\n" )
1562             : $_oneline->( $cache, $socket );
1563              
1564             # nothing to check against, just give back what we got
1565 0 0         return $response if !defined $expect;
1566              
1567 0   0       return ( $response and $expect."\r\n" eq $response );
1568             } #_oneline
1569              
1570             #---------------------------------------------------------------------------
1571             # _unique_key
1572             #
1573             # Return a unique key
1574             #
1575             # IN: 1 class or object (ignored)
1576             # OUT: 1 guaranteed unique key
1577              
1578             sub _unique_key {
1579              
1580             # Create unique key and return that
1581              
1582 0     0     join $_[0]->delimiter,$server,$$,time,++$unique;
1583             } #_unique_key
1584              
1585             #---------------------------------------------------------------------------
1586             # _spec2servers
1587             #
1588             # Converts server spec to list ref of servers
1589             #
1590             # IN: 1 server spec
1591             # 2 recursing flag (only used internally)
1592             # OUT: 1 list ref of servers
1593              
1594             sub _spec2servers {
1595 0     0     my ( $spec, $recursing ) = @_;
1596              
1597             # assume scalar definition if not a ref
1598 0           my $type = reftype $spec;
1599 0 0         if ( !defined $type ) {
    0          
1600 0           return [ split ',', $spec ];
1601             }
1602              
1603             # list ref of servers
1604             elsif ( $type eq 'ARRAY' ) {
1605 0           return $spec;
1606             }
1607              
1608             # huh?
1609 0           die "Don't know how to handle '$spec' as server specification";
1610             } #_spec2servers
1611              
1612             #---------------------------------------------------------------------------
1613              
1614             __END__