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

package Cache::Memcached::Managed;

# Make sure we have version info for this module

$VERSION= '0.24';

# Make sure we're as strict as possible
# With as much feedback that we can get

use strict;
use warnings;

# Use the external modules that we need

use Scalar::Util qw(blessed reftype);

# Initialize default expiration
# Initialize the hash with specific expirations
# Initialize the delimiter to be used
# Initialize the counter for unique ID's
# Initialize the seconds to wait after a delete of a directory key is done
# Initialize the default timeout for ping
# Initialize number of values to be fetched from memcached at a time
# Initialize the server we're running on

my $expiration = '1D';
my %expiration;
my $default_del = '#';
my $unique = 0;
my $deadtime = 0;
my $pingtime = 10;
my $atatime  = 256;
my $server = eval { `uname -n` } || 'unknown'; chomp $server;
my $_oneline;

# At compile time
#  Create simple accessors

BEGIN {
    eval "sub $_ { shift->{'$_'} }" foreach qw(
 data
 delimiter
 directory
 expiration
 flush_interval
 namespace
     );
} #BEGIN

# Satisfy -require-

1;

#---------------------------------------------------------------------------
#
# Class methods
#
#---------------------------------------------------------------------------
# new
#
# Return instantiated object
#
#  IN: 1 class
#      2..N hash with parameters
# OUT: 1 instantiated object

sub new {
    my $class = shift;
    my %self = @_ < 2 ? (data => (shift || '127.0.0.1:11211')) : @_;

    # want to force an inactive object
    if (delete $self{'inactive'}) {
        require Cache::Memcached::Managed::Inactive;
        return Cache::Memcached::Managed::Inactive->new;
    }

    # set defaults
    $self{expiration} = $expiration  if !$self{expiration};
    $self{delimiter}  = $default_del if !length( $self{delimiter} || '' );
    $self{namespace}  = $>           if !defined $self{namespace};

    # set group names
    $self{group_names}  =
      [ $self{group_names} ? sort @{ $self{group_names} } : 'group' ];
    $self{_group_names} = { map { $_ => undef } @{ $self{group_names} } };

    # obtain client class
    my $memcached_class = $self{memcached_class} ||= 'Cache::Memcached';
    die $@ if !eval "require $memcached_class; 1";

    # check both backends
    my @all_servers;
  BACKEND:
    foreach ( qw( data directory ) ) {

        # nothing to do
        my $spec = $self{$_};
        next BACKEND if !$spec;

        # giving an existing object
        if ( blessed $spec ) {

            # unfortunately, there does not seem to be an API for this
            if ( my $servers = $spec->{servers} ) {
                push @all_servers, @{$servers};
                next BACKEND;
            }
        }

        # assume a single server spec
        my $parameters;
        my $type = reftype $spec;
        if ( !$type ) {
            my @servers = split ',', $spec;
            push @all_servers, @servers;
            $parameters = { servers => \@servers };
        }

        # list ref of servers
        elsif ( $type eq 'ARRAY' ) {
            push @all_servers, @{$spec};
            $parameters = { servers => $spec };
        }

        # ready made parameter hash
        elsif ( $type eq 'HASH' ) {
            $parameters = $spec;

            # attempt to find server spec in there
            $spec = $parameters->{servers};
            $type = reftype $spec;

            # also need to fixup config
            if ( !$type ) {
                my @servers = split ',', $spec;
                push @all_servers, @servers;
                $parameters->{servers} = \@servers;
            }

            # regular array spec already
            elsif ( $type eq 'ARRAY' ) {
                push @all_servers, @{$spec};
            }

            # huh?
            else {
                undef $parameters;
            }
        }

        # huh?
        die "Don't know how to handle '$spec' as server specification"
          if !$parameters;

        # create the object for the backend
        $self{$_} = $memcached_class->new($parameters);
    }

    # huh?
    die "No valid data server specification found" if !blessed $self{data};

    # set directory server as data server if there was no data server
    $self{directory} = $self{data} if !blessed $self{directory};

    # remember the pid for fork checking
    $self{_last_pid} = $$;

    # set server specification
    $self{servers} = [ sort @all_servers ];

    return bless \%self,$class;
} #new

#---------------------------------------------------------------------------
#
# Instance methods
#
#---------------------------------------------------------------------------
# add
#
# Add ID + value, only done if not yet in the cache
#
#  IN: 1 instantiated object
#      2 value
#      3 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 true if successful

sub add { shift->_do( 'add',@_ ) } #add

#---------------------------------------------------------------------------
# dead
#
# Cycles through all of the available memcached servers and checks whether
# they are alive or not.  Returns all of the memcached servers that seem to
# be inactive.
#
#  IN: 1 instantiated object
#      2 timeout to apply (default: 10 seconds)
# OUT: 1..N memcached servers that did not reply (in time)
#
#  or:
#
# OUT: 1 hash ref with dead servers

sub dead {

# Obtain the class
# Obtain the timeout
# Create key to be used
# Create value to be used

    my $self = shift;
    my $timeout = shift || $pingtime;
    my $key = $self->_unique_key;
    my $value = time;

# Initialize list of problem servers
# For all of the servers to be checked (in alphabetical order)
#  Create new memcached server object for this server only
#  Obtain value from which
#   Makes sure alarm() will do a die()
#   Set the alarm
#   Set the value in the server
#   Attempt to get it back
#   Delete the key
#   Return the value obtained

    my @dead;
    foreach ($self->servers) {
        my $server = $self->{memcached_class}->new( {servers => [$_]} );
        my $fetched = eval {
            local $SIG{ALRM} = sub { die "timed out\n" };
            alarm $timeout;
            $server->set( $key,$value );
            my $result = $server->get( $key );
            $server->delete( $key ) if $result;
            $result;
        } || 0;

#  Reset the alarm
#  Mark server as problem if value obtained not equal to value stored

        alarm 0;
        push @dead,$_ if $fetched != $value;
    }

# Return list of problem servers (sorted) or as a hash ref

    return wantarray ? @dead : {map {$_ => undef} @dead};
} #dead

#---------------------------------------------------------------------------
# decr
#
# Decrement an existing ID, only done if not yet in the cache
#
#  IN: 1 instantiated object
#      2 value
#      3 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 true if successful

sub decr { shift->_do( 'decr',@_ ) } #decr

#---------------------------------------------------------------------------
# delete
#
# Delete an existing ID
#
#  IN: 1 instantiated object
#      2 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 true if successful

sub delete {

# Obtain the object
# Check the socket

    my $self = shift;
    return unless $self->_check_socket;

# Obtain the parameters
# Perform the delete

    my %param = @_ == 1 ? (id => shift) : @_;
    $self->data->delete(
     $self->_data_key( @param{qw(id key namespace version)} ) );
} #delete

#---------------------------------------------------------------------------
# delete_group
#
# Delete all information about a group, given by group name and ID
#
#  IN: 1 instantiated object
#      2..N hash with group names and ID's to delete info of
# OUT: 1 number of items deleted

sub delete_group {

# Obtain the object
# Obtain the parameter hash
# Obtain local copies of stuff we need fast access to here
# Obtain the namespace

    my $self = shift;
    my %param = @_;
    my ($data,$directory) = map {$self->$_} qw(data directory);
    my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );

# Initialize number of items deleted
# Obtain reference to the group names
# While there are group name / id pairs to process
#  Obtain groupname and ID
#  Make sure group name is fully qualified
#  Reloop if not a valid group name

    my $deleted = 0;
    my $group_names = $self->{'_group_names'};
    while (my ($group_name,$group_id) = each %param) {
        $self->_group_id( $group_name );
        die "'$group_name' is not a valid group name"
         unless exists $group_names->{$group_name};

#  Obtain the directory key
#  Obtain the index keys
#  Obtain the backend keys for these index keys

        my $directory_key =
         $self->_directory_key( $namespace,$group_name,$group_id );
        my @index_key = $self->_index_keys( $directory_key );
        my @data_key = $self->_data_keys( $directory_key,0,@index_key );

#  Delete the lowest index key
#  Delete the directory key
#  Delete all of the index keys
#  Delete all of the backend keys
#  Add the number of entries deleted

        $directory->delete( $self->_lowest_index_key($directory_key),$deadtime);
        $directory->delete( $directory_key,$deadtime );
        $directory->delete( $_ ) foreach @index_key;
        $data->delete( $_ ) foreach @data_key;
        $deleted += @data_key;
    }

# Return the result

    $deleted;
} #delete_group

#---------------------------------------------------------------------------
# errors
#
# Cycles through all of the available memcached servers and returns the
# number of errors recorded.
#
#  IN: 1 instantiated object
#      2 flag: reset error counters
# OUT: 1 reference to hash with number of errors for each server

sub errors {

# Obtain the parameters
# Return with error counters if we don't want to reset the error counters

   my ($self,$reset) = @_;
   return $self->directory->get_multi( $self->servers ) unless $reset;

# Obtain the directory backend
# Obtain the error counters
# Delete all the error counters that were returned
# Return the hash ref with errors

   my $directory = $self->directory;
   my $errors = $directory->get_multi( $self->servers );
   $directory->delete( $_ ) foreach keys %{$errors};
   $errors;
} #errors

#---------------------------------------------------------------------------
# flush_all
#
# Flush the contents of all servers (without rebooting them)
#
#  IN: 1 instantiated object
#      2 number of seconds between flushes (default: flush_interval)
# OUT: 1 number of servers successfully flushed

sub flush_all {

# Obtain the object
# Obtain the data server
# Obtain the servers

    my ($self,$interval) = @_;
    my $data = $self->data;
    my @server = $self->servers;

# Use default interval if none specified
# Initialize number of servers flushed
# Initialize amount of time to wait

    $interval = $self->flush_interval unless defined $interval;
    my $flushed = 0;
    my $time    = 0;

# For all of the servers minus the directory server
#  Create the action
#  Increment flushed if flush was successful
#  Increment time if we need to

    foreach (0..$#server) {
        my $action = $interval ? "flush_all $time" : "flush_all";
        $flushed++ if $self->_oneline( $data,$action,$_,"OK" );
        $time += $interval if $interval;
    }

# Return whether all servers successfully flushed

    $flushed = @server;
} #flush_all

#---------------------------------------------------------------------------
# get
#
# Get a single value from the cache
#
#  IN: 1 instantiated object
#      2 id
# OUT: 1 value if found or undef
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 value if found or undef

sub get {

# Obtain the object
# Check the socket

    my $self  = shift;
    return unless $self->_check_socket;

# Obtain the parameters
# Perform the actual getting of the value

    my %param = @_ == 1 ? (id => shift) : @_;
    my $data_key = $self->_data_key( @param{qw(id key namespace version)} );
    $self->data->get( $data_key );
} #get

#---------------------------------------------------------------------------
# get_group
#
# Return the contents of the group, optionally deleting it
#
#  IN: 1 instantiated object
#      2..N parameter hash (group / delete / namespace)
# OUT: 1 hash reference with result
#
# The structure of the hash is:
#
# $result
#  |--- key
#        |-- version
#            |-- id
#                |-- value

sub get_group {

# Obtain the object
# Obtain the parameters
# Obtain local copies of stuff we need

    my $self = shift;
    my %param = @_;
    my ($data,$delimiter,$directory) =
     map {$self->$_} qw(data delimiter directory);

# Obtain delete flag
# Obtain namespace to be used

    my $delete = delete $param{'delete'};
    my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );

# Quit now if more than 1 group specified
# Obtain group name and ID
# Make sure groupname is fully qualified
# Die now if not a valid group

    die "Can only fetch one group at a time" if keys %param > 1;
    my ($group_name,$group_id) = each %param;
    $self->_group_id( $group_name,!!$delete );
    die "'$group_name' is not a valid group name"
     unless exists $self->{'_group_names'}->{$group_name};

# Obtain the directory key
# Obtain the index keys
# Obtain the data keys for these index keys

    my $directory_key =
     $self->_directory_key( $namespace,$group_name,$group_id );
    my @index_key = $self->_index_keys( $directory_key );
    my @data_key = $self->_data_keys( $directory_key,$delete,@index_key );

# If we're deleting
#  Delete the lowest index key
#  Delete the directory key
#  Delete all of the index keys

    if ($delete) {
        $directory->delete( $self->_lowest_index_key($directory_key),$deadtime);
        $directory->delete( $directory_key,$deadtime );
        $directory->delete( $_ ) foreach @index_key;
    }

# Initialize result hash
# Obtain all of the data in one fell swoop
# For all of the backend keys for this group
#  Split out uid, version, key and ID
#  Remove the entry from the cache if deleting
#  Move the value out of the gotten hash into the result hash if right namespace

    my %result;
    while (my @todo = splice @data_key,0,$atatime) {
        my $gotten = $data->get_multi( @todo );
        foreach my $data_key (keys %{$gotten}) {
            my (undef,$version,$key,$id) = split $delimiter,$data_key,4;
            $data->delete( $data_key ) if $delete;
            $result{$key}->{$version}->{$id||''} = delete $gotten->{$data_key};
        }
    }

# Return the result as a hash ref if in scalar context
# Return only the values if in list context

    return \%result unless wantarray;
    map {values %{$_}} map {values %{$_}} values %result;
} #get_group

#---------------------------------------------------------------------------
# get_multi
#
# Get a multiple values from the cache, sharing the same key, version and
# namespace
#
#  IN: 1 instantiated object
#      2 reference to list of ID's
# OUT: 1 hash ref of ID's and values found
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 hash ref of ID's and values found

sub get_multi {

# Obtain the object
# Check the socket

    my $self  = shift;
    return {} unless $self->_check_socket;

# Obtain the parameters
# Obtain the key
# Obtain the version
# Obtain the namespace

    my %param = @_ == 1 ? (id => shift) : @_;
    my $key = $self->_create_key( $param{'key'} );
    my $version = $param{'version'};
    my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );

# Obtain the data keys
# Create result hash

    my @data_key =
     map {$self->_data_key( $_,$key,$namespace,$version )} @{$param{'id'}};
    my %result;

# Obtain the data server backend
# Make sure we use the right delimiter
# While we have a batch of data to fetch
#  Perform the actual getting of the values
#  For all of the values obtained this time
#   Move the value to the result hash with just the ID as the key

    my $data = $self->data;
    my $delimiter = $self->delimiter;
    while (my @todo = splice @data_key,0,$atatime) {
        my $hash = $data->get_multi( @todo );
        foreach (keys %{$hash}) {
            $result{(split $delimiter,$_,4)[3]} = delete $hash->{$_};
        }
    }

# Return the reference to the resulting hash

    \%result;
} #get_multi

#---------------------------------------------------------------------------
# grab_group
#
#  IN: 1 instantiated object
#      2..N parameter hash (group / namespace)
# OUT: 1 hash reference with result
#
# The structure of the hash is:
#
# $result
#  |--- key
#        |-- version
#            |-- id
#                |-- value

sub grab_group { shift->get_group( delete => 1,@_ ) } #grab_group

#---------------------------------------------------------------------------
# group
#
# Return the ID's of a group, ordered by key.
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 hash reference with result
#
# The structure of the hash is:
#
# $result
#  |--- key
#        |--- [id1,id2..idN]

sub group {

# Obtain the parameters
# Check the socket

    my $self = shift;
    return {} unless $self->_check_socket;

# Obtain the parameter hash
# Obtain the namespace
# Quit now if more than one group specified

    my %param = @_;
    my ($namespace) = $self->_lexicalize( \%param,qw(namespace) );
    die "Can only fetch one group at a time" if keys %param > 1;

# Obtain the group name and group ID
# Make sure group name is fully qualified
# Return now if not a valid group

    my ($group_name,$group_id) = each %param;
    $self->_group_id( $group_name );
    return {} unless exists $self->{'_group_names'}->{$group_name};

# Initialize result hash
# Make sure we use the right delimiter
# For all of the backend keys for this group
#  Split out the parts
#  Save the ID in the list for the key

    my %result;
    my $delimiter = $self->delimiter;
    foreach ($self->_data_keys(
     $self->_directory_key( $namespace,$group_name,$group_id ) )) {
        my ($key,$id) = (split $delimiter)[2,3];
        push @{$result{$key}},$id;
    }

# Make sure the ID's are listed in order
# Return the result

    $_ = [sort @$_] foreach values %result;
    \%result;
} #group

#---------------------------------------------------------------------------
# group_names
#
# Return the specifications of all groups defined in alphabetical order in
# list context, or as a hash ref in scalar context
#
#  IN: 1 instantiated object
# OUT: 1..N group names specifications in alphabetical order
#
#  or:
#
# OUT: 1 hash ref with group names

sub group_names {

# Obtain the object
# Return the group names sorted or as a hash ref

    my $self = shift;
    return wantarray ? @{$self->{'group_names'}} : $self->{'_group_names'};
} #group_names

#---------------------------------------------------------------------------
# inactive
#
#  IN: 1 instantiated object
# OUT: 1 false

sub inactive { undef } #inactive

#---------------------------------------------------------------------------
# incr
#
# Decrement an existing ID
#
#  IN: 1 instantiated object
#      2 value
#      3 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 true if successful

sub incr { shift->_do( 'incr',@_ ) } #incr

#---------------------------------------------------------------------------
# replace
#
# Replace an existing ID
#
#  IN: 1 instantiated object
#      2 value
#      3 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 true if successful

sub replace { shift->_do( 'replace',@_ ) } #replace

#---------------------------------------------------------------------------
# reset
#
# Reset the client side of the cache system
#
#  IN: 1 instantiated object
# OUT: 1 returns true

sub reset {
    my $self = shift;

    # obtain local copy of data and directory object
    my ( $data, $directory ) = ( $self->data, $self->directory );

    # all of the Cache::Memcached objects we need to handle
    foreach ( $data == $directory ? ($data) : ( $data, $directory ) ) {

        # disconnect all sockets
        $_->disconnect_all    if $_->can('disconnect_all');;

        # kickstart connection logic
        $_->forget_dead_hosts if $_->can('forget_dead_hosts');
    }

    # make sure we try to connect again
    $self->_mark_connected;

    # set last pid used flag
    $self->{'_last_pid'} = $$;

    return 1;
} #reset

#---------------------------------------------------------------------------
# set
#
# Set an ID, create if doesn't exist yet
#
#  IN: 1 instantiated object
#      2 value
#      3 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2..N parameter hash
# OUT: 1 true if successful

sub set { shift->_do( 'set',@_ ) } #set

#---------------------------------------------------------------------------
# servers
#
# Return the specifications of all memcached servers being used in
# alphabetical order in list context, or as a hash ref in scalar context
#
#  IN: 1 instantiated object
# OUT: 1..N server specifications in alphabetical order
#
#  or:
#
# OUT: 1 hash ref with server configs

sub servers {

    return wantarray
      ? @{ shift->{servers} }
      : { map { $_ => undef } @{ shift->{servers} } };
} #servers

#---------------------------------------------------------------------------
# start
#
# Start the indicated memcached backend servers
#
#  IN: 1 instantiated object
#      2..N config of memcached servers to start (default: all)
# OUT: 1 whether all indicated memcached servers started

sub start {

# Obtain the object
# Obtain the servers to start

    my $self = shift;
    @_ = $self->servers unless @_;

# Initialize started counter
# For all of the servers to start
#  Obtain IP and port
#  Increment counter if start was successful

    my $started = 0;
    foreach (@_) {
        my ($ip,$port) = split ':';
        $started++ unless system 'memcached',
         '-d','-u',(scalar getpwuid $>),'-l',$ip,'-p',$port;
    }

# Return whether all servers started

    $started == @_;
} #start

#---------------------------------------------------------------------------
# stats
#
# Return a hash ref with simple statistics for each server
#
#  IN: 1 instantiated object
#      2..N config specifications of servers (default: all)
# OUT: 1 hash reference
#
# $stats
#   |-- server
#        |-- key
#             |-- value

sub stats {

# Obtain the object
# Return now if no active servers anymore

    my $self = shift;
    return {} unless $self->_check_socket;

# Create hash with configs to be done
# Initialize the result ref
# For all of the objects that we have
#  For all of the servers we want to do this
#   Reloop if not to be done
#   Obtain STATS info

    my %todo = @_ ? map {$_ => undef} @_ : %{$self->servers};
    my %result;
    foreach my $cache ($self->data,$self->directory) {
        foreach my $host ( $self->servers ) {
            next unless exists $todo{$host} and not exists $result{$host};
            $result{$host} = {
             map {s#^STAT ##; split m#\s+#}
             $self->_morelines( $cache,$host,"stats" )
            };
        }
    }

# Return the result hash as a ref

    \%result;
} #stats

#---------------------------------------------------------------------------
# stop
#
# Stop the indicated memcached backend servers
#
#  IN: 1 instantiated object
#      2..N config of memcached servers to stop (default: all)
# OUT: 1 whether all indicated memcached servers stopped

sub stop {

# Obtain the object
# Obtain the pid's to kill
# Return whether all were killed

    my $self = shift;
    my @pid = map {$_->{'pid'}} grep {$_->{'pid'}} values %{$self->stats( @_ )};
    @pid == kill 15,@pid;
} #stop

#---------------------------------------------------------------------------
# version
#
# Return version information of running memcached backend servers
#
#  IN: 1 instantiated object
#      2..N config of memcached servers to obtain version of (default: all)
# OUT: 1 hash ref with version info, keyed to config

sub version {

# Obtain the object
# Obtain the basic info to work with
# Normalize to version information

    my $self = shift;
    my $stats = $self->stats( @_ );
    $_ = $_->{'version'} foreach values %{$stats};

# Return the resulting hash reference

    $stats;
} #version

#---------------------------------------------------------------------------
#
# Internal methods
#
#---------------------------------------------------------------------------
# _data_key
#
# Expand the given id
#
#  IN: 1 instantiated object
#      2 id to expand (default: none)
#      3 key to use (default: caller sub)
#      4 namespace to use (default: object->namespace)
#      5 version to use (default: key's $package::VERSION)
#      6 number of levels to go back in caller stack (default: 2 )
# OUT: 1 expanded key

sub _data_key {

# Obtain the parameters
# Obtain key
# Obtain the delimiter

    my ($self,$id,$key,$namespace,$version,$levels) = @_;
    $key = $self->_create_key( $key,($levels ||= 2) + 1 );
    my $delimiter = $self->delimiter;

# If we don't have a version yet
#  Allow for non strict references
#  Adapt the version information
# Make sure we have a namespace
# Prefix the version information

    unless ($version) {
        no strict 'refs';
        $version = ($key =~ m#^(.*)::# ? ${$1.'::VERSION'} : '') ||
                   ($key =~ m#^/# ? $main::VERSION : '') ||
                   $Cache::Memcached::Managed::VERSION;
    }
    $namespace = $self->namespace unless defined $namespace;
    $key = $namespace.$delimiter.$version.$delimiter.$key;

# If some type of ref was specified for the ID
#  If it was a list ref
#   Join the elements
#  Elseif it was a hash ref
#   Join the sorted key/value pairs
#  Elseif it was a scalar ref
#   Just deref it

    if (my $type = ref $id) {
        if ($type eq 'ARRAY') {
            $id = join $delimiter,@{$id};
        } elsif ($type eq 'HASH') {
            $id = join $delimiter,map {$_ => $id->{$_}} sort keys %{$id};
        } elsif ($type eq 'SCALAR') {
            $id = $$id;

#  Else (unexpected type of ref)
#   Let the world know we didn't expect this

        } else {
            die "Don't know how to handle key of type '$type': $id";
        }
    }

# Expand the ID as appropriate and return the result

    $self->{'_data_key'} =
     $key.(defined $id and length $id ? $delimiter.$id : '');
} #_data_key

#---------------------------------------------------------------------------
# _data_keys
#
# Return the backend keys for a given directory_key
#
#  IN: 1 instantiated object (ignored)
#      2 directory key
#      3 flag: don't perform cleanup (default: perform cleanup)
#      4..N index keys, highest first (default: _index_keys)
# OUT: 1..N unordered list with backend keys

sub _data_keys {

# Obtain the main parameters
# Make sure we have index keys
# Obtain backend keys

    my ($self,$directory_key,$nocleanup) = splice @_,0,3;
    @_ = $self->_index_keys( $directory_key ) unless @_;

# Obtain shortcut to the directory backend
# Initialize lowest index number found
# Initialize list of index keys with duplicate backend keys found
# Initialize backend key hash

    my $directory = $self->directory;
    my $lowest = 1;
    my @double;
    my %data_key;

# While there are data keys to be fetched
#  If successful in obtaining next slice of the backend keys
#   Copy them into the final result hash
#   If we don't want to cleanup
#    Just put all of the values as keys

    while (@_) {
        if (my $result = $directory->get_multi( splice @_,0,$atatime )) {
            if ($nocleanup) {
                $data_key{$_} = undef foreach values %{$result};

#**************************************************************************
# Note that we're using the side effect of Perl taking the digits at the
# start of a string as the numerical value: this allows us to quickly
# check the index number of the index keys, and to calculate the lowest
# possible free index number that should be checked later.  That's why
# we're switching off warnings for this section here.
#**************************************************************************

#   Else (we want to cleanup)
#    For all of the index keys obtained
#     If this backend key was already found
#      Mark this index key as double
#     Else
#      Set this backend key
#      Save this as the lowest value

            } else {
                no warnings;
                foreach (sort {$b <=> $a} keys %{$result}) {
                    my $data_key = $result->{$_};
                    if (exists $data_key{$data_key}) {
                        push @double,$_;
                    } else {
                        $data_key{$data_key} = undef;
                        $lowest = $_;
                    }
                }
            }

#  Else (failed,the directory backend has died: this is REALLY bad)
#   Invalidate all backend servers
#   Invalidate all cache access for this process from now on
#   Return emptyhanded

        } else {
            $self->flush_all( $self->flush_interval );
            $self->_mark_disconnected;
            return;
        }
    }

# If we want to cleanup
#  Remove the index keys that we don't need anymore
#  Make sure we're silent about numifying the lowest key
#  Set the lowest index to be checked later if lowest was found

    unless ($nocleanup) {
        $directory->delete( $_ ) foreach @double;
        no warnings;
        $directory->set( $self->_lowest_index_key( $directory_key ),0+$lowest );
    }

# Return the result

    keys %data_key;
} #_data_keys

#---------------------------------------------------------------------------
# _check_socket
#
# Check whether the socket has been used in this process, disconnect if not
# yet used in this process
#
#  IN: 1 class or object (ignored)
# OUT: 1 whether successful

sub _check_socket {

# Quickest way out in the most common case

    return 1 if $$ == $_[0]->{'_last_pid'} and !exists $_[0]->{'_disconnected'};

# Obtain the object
# Return result of reset if we're in a different process now

    my $self = shift;
    return $self->reset if $$ != $self->{'_last_pid'};

# Mark object as connected if waited long enough
# Return (possibly changed) status

    $self->_mark_connected
     if $self->{'_disconnected'} and time > $self->{'_disconnected'};
    return !$self->{'_disconnected'};
} #_check_socket;

#---------------------------------------------------------------------------
# _create_key
#
# Expand the given key
#
#  IN: 1 instantiated object
#      2 key to expand (default: caller sub)
#      3 number of levels to go back in caller stack (default: 2 )
# OUT: 1 fully qualified key

sub _create_key {

# Obtain the parameters
# Return now if we already have a fully qualified key

    my ($self,$key,$levels) = @_;
    return $key if $key and ($key =~ m#.+::# or $key =~ m#^/#);

# Set levels if not set yet
# Obtain caller info

    $levels ||= 2;
    my $caller = (caller($levels))[3] ||
     ($0 =~ m#^/# ? $0 : do {my $pwd = `pwd`; chomp $pwd; $pwd}."/$0");

# Set the default key if no key specified yet
# If we have a package relative key, removing prefix on the fly
#  Remove caller info's relative part
#  Prefix the caller info
# Return the resulting key

    $key ||= $caller;
    if ($key =~ s#^::##) {
        $caller =~ s#[^:]+$##;
        $key = $caller.$key;
    }
    $key;
} #_create_key

#---------------------------------------------------------------------------
# _directory_key
#
# Return the directory key for a given group name, ID and namespace
#
#  IN: 1 instantiated object
#      2 namespace
#      3 group name
#      4 ID

sub _directory_key {

# Obtain the delimiter (lose the object on the fly
# Create key and return that

    my $delimiter = shift->delimiter;
    __PACKAGE__.$delimiter.(join $delimiter,@_);
} #_directory_key

#---------------------------------------------------------------------------
# _do
#
# Perform one of the basic cache actions
#
#  IN: 1 instantiated object
#      2 method name
#      3 value
#      4 id
# OUT: 1 true if successful
#
# or:
#
#  IN: 1 instantiated object
#      2 method name
#      3..N parameter hash
# OUT: 1 true if successful

sub _do {

# Obtain object and method
# Check the socket

    my ($self,$method) = splice @_,0,2;
    return undef unless $self->_check_socket;

# Obtain the parameter hash
# Create the key, removing key specification on the fly

    my %param = @_ > 3
      ? @_
      :  ( value => shift, id => shift, expiration => shift );
    my $key = $self->_create_key( delete( $param{'key'} ),3 );

# Obtain the ID, removing it on the fly
# Set unique ID if so requested
# Obtain the value, removing it on the fly
# Make sure there is a valid value for increment and decrement
# Obtain the lexicals for parameters
# Convert the expiration to seconds

    my $id = delete $param{'id'};
    $id = $self->_unique_key if $id and $id eq ':unique';
    my $value = delete $param{'value'};
    $value = 1 if !defined $value and $method =~ m#(?:decr|incr)$#;
    my ($expiration,$namespace) =
     $self->_lexicalize( \%param,qw(expiration namespace) );
    $expiration = $self->_expiration2seconds( $expiration );

# Obtain the data server
# Obtain the data key, remove version from parameter hash on the fly
# Perform the named method

    my $data = $self->data;
    my $data_key =
     $self->_data_key( $id,$key,$namespace,delete $param{'version'} );
    my $result = $data->$method( $data_key,$value,$expiration );

# If action was successful
#  Return now if replace, decr or incr (assume always same groups)
# Elseif we're trying to increment (and action failed)
#  Add an entry with the indicated value or 1
# Elsif we're not doing a set (so: add|decr|replace and failed)
#  Just return with whatever we got

    if ($result) {
        return $result if $method =~ m#^(?:decr|incr|replace)$#;
    } elsif ($method eq 'incr') {
        $result = $data->add( $data_key,$value || 1,$expiration);
    } elsif ($method ne 'set') {
        return $result;
    }

    # still don't have a good result
    my $directory = $self->directory;
    if ( !$result ) {

        # can get the bucket
        if ( $data->can('get_sock') ) {
            if ( my $bucket = $data->get_sock($data_key) ) {

                # can lose prefix, increment error on server
                if ( $bucket =~ s#^Sock_## ) {
                    $directory->add( $bucket, 1 )
                      if !$directory->incr($bucket);
                }
            }
        }

        # block all access for this process
        $self->{'_disconnected'} = 1;

        # return indicating error
        return undef;
    }

# Obtain hash ref to valid group names
# For all group name links to be set (remaining pairs in parameter hash)
#  Normalize group ID if necessary
#  Obtain directory key
#  Obtain an index

    my $group_names = $self->{'_group_names'};
    while (my ($group_name,$group_id) = each %param) {
        $group_id =~ s#^:key#$key#;
        my $directory_key =
         $self->_directory_key( $namespace,$group_name,$group_id );
	my $index = $directory->incr( $directory_key );

#  If we don't have a valid index
#   If not successful in initializing the directory key
#    Block all access for this process
#    Return indicating error

        unless (defined $index) {
            unless (defined $directory->add( $directory_key,$index = 1 )) {
                $self->{'_disconnected'} = 1;
                return undef;
            }
        }

#  If not successful in storing the data key
#   Block all access for this process
#   Return indicating error

        unless ($directory->set(
         $self->_index_key( $directory_key,$index ),$data_key,$expiration )) {
            $self->{'_disconnected'} = 1;
            return undef;
        }
    }

# Return the original result

    $result;
} #_do

#---------------------------------------------------------------------------
# _expiration2seconds
#
# Convert given expiration to number of seconds
#
#  IN: 1 instantiated object (ignored)
#      2 expiration
# OUT: 1 number of seconds

sub _expiration2seconds {

# Obtain the initial expiration
# Return now if nothing to check
# Return now if invalid characters found

    my $expiration = $_[1];
    return if !defined $expiration;
    return if $expiration !~ m#^[sSmMhHdDwW\d]+$#;

# Just a second specification

    return $expiration if $expiration !~ m#\D#;

# Convert seconds into seconds
# Convert minutes into seconds
# Convert hours into seconds
# Convert days into seconds
# Convert weeks into seconds

    my $seconds = 0;
    $seconds += $1 if $expiration =~ m#(\d+)[sS]#;
    $seconds += (60 * $1) if $expiration =~ m#(\d+)[mM]#;
    $seconds += (3600 * $1) if $expiration =~ m#(\+?\d+)[hH]#;
    $seconds += (86400 * $1) if $expiration =~ m#(\+?\d+)[dD]#;
    $seconds += (604800 * $1) if $expiration =~ m#(\+?\d+)[wW]#;

# Return the resulting sum

    $seconds;
} #_expiration2seconds

#---------------------------------------------------------------------------
# _index_key
#
# Return the index key for a given directory_key and ordinal number
#
#  IN: 1 instantiated object (ignored)
#      2 directory key
#      3 ordinal number
# OUT: 1 index key

sub _index_key { $_[2].$_[0]->delimiter.$_[1] } #_index_key

#---------------------------------------------------------------------------
# _index_keys
#
# Return the index keys for a given directory_key
#
#  IN: 1 instantiated object (ignored)
#      2 directory key
# OUT: 1 list with index keys (highest first)

sub _index_keys {

# Obtain the parameters
# Return emtyhanded if no index keys available

    my ($self,$directory_key) = @_;
    return unless my $found = $self->directory->get( $directory_key );

# Obtain the lowest possible index
# Create the index keys and return them

    my $lowest =
     $self->directory->get( $self->_lowest_index_key( $directory_key ) ) || 1;
    reverse map {$self->_index_key( $directory_key,$_ )} $lowest..$found;
} #_index_keys

#---------------------------------------------------------------------------
# _group_id
#
# Fully qualify a group name if relative name indicated
#
#  IN: 1 instantiated object (ignored)
#      2 group name to check (directly updated, must be left value)
#      3 number of extra levels to go up

sub _group_id {

# Prefix package name of relative group name indicated

    $_[1] = (caller(1 + ($_[2] || 0)))[0].$_[1] if $_[1] =~ m#^::#;
} #_group_id

#---------------------------------------------------------------------------
# _lexicalize
#
# Return values associated with the given method names, allowing for
# overrides from a parameter hash.  Removes these values from the parameter
# hash.
#
#  IN: 1 instantiated object
#      2 reference to parameter hash
#      3..N method names to check
# OUT: 1..N values associated with method names

sub _lexicalize {

# Obtain object and parameter hash
# Create temporary value holder
# Map the method names to the appropriate value

    my ($self,$param) = splice @_,0,2;
    my $v;
    map {$v = delete $param->{$_}; defined $v ? $v : $self->$_ } @_;
} #_lexicalize

#---------------------------------------------------------------------------
# _lowest_index_key
#
# Return the index key for the lowest possible index
#
#  IN: 1 instantiated object (ignored)
#      2 directory key
# OUT: 1 index key of lowest index

sub _lowest_index_key { $_[1].$_[0]->delimiter.'_lowest' } #_lowest_index_key

#---------------------------------------------------------------------------
# _mark_connected
#
# Mark the object as connected
#
#  IN: 1 instantiated object

sub _mark_connected { delete $_[0]->{'_disconnected'} } #_mark_connected

#---------------------------------------------------------------------------
# _mark_disconnected
#
# Mark the object as disconnected: all actions will fail for a random
# amount of time.
#
#  IN: 1 instantiated object
#      2 amount of time to mark as disconnected (default: 20..30)

sub _mark_disconnected {

# Mark the object as disconnected

    $_[0]->{'_disconnected'} = time + ($_[1] || 20 + int rand 10)
} #_mark_disconnected

#---------------------------------------------------------------------------
# _morelines
#
# Handle non-API request that returns multiple lines
#
#  IN: 1 instantiated object (ignored)
#      2 Cache::Memcached object
#      3 host to send to
#      4 line to send (no newline, default: just return next response)
#      5 bucket (default: 0)
# OUT: 1..N response lines

sub _morelines {
    my ( $self, $cache, $host, $send, $bucket ) = @_;

    # don't have any sock to host mapping, so quit
    return if !$cache->can('sock_to_host');

    # couldn't get a socket for given host
    return unless my $socket = $cache->sock_to_host($host);

    return map {
     s#[\r\n]+$##; m#^(?:END|ERROR)# ? () : ($_)
    } $cache->run_command( $socket, $send. "\r\n" );
} #_morelines

#---------------------------------------------------------------------------
# _oneline
#
#  IN: 1 instantiated object (ignored)
#      2 Cache::Memcached object
#      3 line to send (no newline, default: just return next response)
#      4 bucket (default: 0)
#      5 response string to check with (no newline, default: return response)
# OUT: 1 response or whether expected response returned

sub _oneline {
    my ( $self, $cache, $send, $bucket, $expect ) = @_;

    # can't get any socket, so quit
    return if !$cache->can('get_sock');

    # couldn't get a socket for the indicated bucket
    return unless my $socket = $cache->get_sock( [$bucket || 0,0] );

    # make sure we can call a "_oneline" compatible method
    $_oneline ||=
      $cache->can( '_oneline' ) ||
      $cache->can( '_write_and_read' )
      or die "Unsupported version of " . ( blessed $cache ) . "\n";

    # obtain response
    my $response = defined $send
     ? $_oneline->( $cache, $socket, $send . "\r\n" )
     : $_oneline->( $cache, $socket );

    # nothing to check against, just give back what we got
    return $response if !defined $expect;

    return ( $response and $expect."\r\n" eq $response );
} #_oneline

#---------------------------------------------------------------------------
# _unique_key
#
# Return a unique key
#
#  IN: 1 class or object (ignored)
# OUT: 1 guaranteed unique key

sub _unique_key {

# Create unique key and return that

    join $_[0]->delimiter,$server,$$,time,++$unique;
} #_unique_key

#---------------------------------------------------------------------------
# _spec2servers
#
# Converts server spec to list ref of servers
#
#  IN: 1 server spec
#      2 recursing flag (only used internally)
# OUT: 1 list ref of servers

sub _spec2servers {
    my ( $spec, $recursing ) = @_;

    # assume scalar definition if not a ref
    my $type = reftype $spec;
    if ( !defined $type ) {
        return [ split ',', $spec ];
    }

    # list ref of servers
    elsif ( $type eq 'ARRAY' ) {
        return $spec;
    }

    # huh?
    die "Don't know how to handle '$spec' as server specification";
}    #_spec2servers

#---------------------------------------------------------------------------

__END__