Apache::SharedMem - Share data between Apache children processes through the shared memory

    use Apache::SharedMem qw(:lock :status);

    my $share = new Apache::SharedMem || die($Apache::SharedMem::ERROR);

    $share->set(key => 'some data');

    # ...maybe in another apache child
    my $var = $share->get(key);

    $share->delete(key);

    # delete all keys if the total size is larger than $max_size
    $share->clear if($share->size > $max_size);

    # using an exclusive blocking lock, but with a timeout
    my $lock_timeout = 40; # seconds
    if($share->lock(LOCK_EX, $lock_timeout))
    {
        my $data =...
        ...some traitement...

        $share->set(key => $data); # the implicite lock is not overrided
        warn('failed to store data in shared memory') if($share->status & FAILURE);

        $share->unlock;
    }

    $share->release;

    # must be a valid path
    PerlAddVar PROJECT_DOCUMENT_ROOT /path/to/your/projects/root

    use Apache::SharedMem;

    PerlAddVar PROJECT_ID 10

    # is last method failed ?
    if($object->status & FAILURE) {something to do on failure}

    # is last method don't succed ?
    if($object->status ^ SUCCESS) {something to do on failure}

    use Apache::SharedMem qw(:status);

package Apache::SharedMem;
#$Id: SharedMem.pm,v 1.61 2001/10/04 12:15:22 rs Exp $

BEGIN
{
    use strict;
    use 5.005;
    use Carp;
    use IPC::SysV qw();
    use IPC::ShareLite qw(:lock);
    use Storable qw(freeze thaw);

    use base qw(Exporter);

    %Apache::SharedMem::EXPORT_TAGS = 
    (
        'all'   => [qw(
                       LOCK_EX LOCK_SH LOCK_UN LOCK_NB
                       WAIT NOWAIT
                       SUCCESS FAILURE
                   )],
        'lock'  => [qw(LOCK_EX LOCK_SH LOCK_UN LOCK_NB)], 
        'wait'  => [qw(WAIT NOWAIT)],
        'status'=> [qw(SUCCESS FAILURE)],
    );
    @Apache::SharedMem::EXPORT_OK   = @{$Apache::SharedMem::EXPORT_TAGS{'all'}};

    use constant WAIT       => 1;
    use constant NOWAIT     => 0;
    use constant SUCCESS    => 1;
    use constant FAILURE    => 2;

    # default values
    use constant IPC_MODE   => 0600; 
    use constant IPC_SEGSIZE=> 65_536;

    $Apache::SharedMem::VERSION  = '0.09';
}

# main
{
    if(exists $ENV{'GATEWAY_INTERFACE'} && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/ 
        && defined $Apache::Server::Starting && $Apache::Server::Starting)
    {
        # we are under startup.pl
        if($Apache::SharedMem::ROOTKEY = _get_rootkey())
        {
            Apache->server->register_cleanup(\&Apache::SharedMem::_cleanup);
        }
        else
        {
            print(STDERR "Apache::SharedMem: can't determine the global root key, have you put 'PerlAddVar PROJECT_DOCUMENT_ROOT /path/to/your/project/root/' in your httpd.conf ?\n");
        }
    }
}

sub new 
{
    my $pkg = shift;
    my $self = bless({}, ref($pkg) || $pkg);

    my $options = $self->{options} =
    {
        rootname            => undef, # obsolete, use rootkey instead
        rootkey             => undef, # if not spécified, take the rootname value if exists or _get_rootkey()
        namespace           => (caller())[0],
        ipc_mode            => IPC_MODE,
        ipc_segment_size    => IPC_SEGSIZE,
        readonly            => 0,
        debug               => 0,
    };

    croak("odd number of arguments for object construction")
      if(@_ % 2);
    for(my $x = 0; $x <= $#_; $x += 2)
    {
        croak("Unknown parameter $_[$x] in $pkg object creation")
          unless(exists($options->{lc($_[$x])}));
        $options->{lc($_[$x])} = $_[($x + 1)];
    }

    _init_dumper() if($options->{debug});

    if($options->{rootname})
    {
        carp('obsolete parameter: rootname');
        # delete rootname parameter and if rootkey is undefined, copy the old rootname value in it.
        (defined $options->{rootkey} ? my $devnull : $options->{rootkey}) = delete($options->{rootname});
    }

    $options->{rootkey} = defined($options->{rootkey}) ? $options->{rootkey} : $self->_get_rootkey;

    foreach my $name (qw(namespace rootkey))
    {
        croak("$pkg object creation missing $name parameter.")
          unless(defined($options->{$name}) && $options->{$name} ne '');
    }

    $self->_debug("create Apache::SharedMem instence. options: ", join(', ', map("$_ => " . (defined($options->{$_}) ? $options->{$_} : 'UNDEF'), keys %$options)))
      if($options->{debug});

    $self->_init_namespace || $options->{readonly} || return undef;

    return $self;
}

sub get
{
    my $self    = shift || croak('invalide method call');
    my $key     = defined($_[0]) && $_[0] ne '' ? shift : croak(defined($_[0]) ? 'Not enough arguments for get method' : 'Invalid argument "" for get method');
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for get method') if(@_);
    $self->_unset_error;
    
    $self->_debug("$key ", $wait ? '(wait)' : '(no wait)');

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_SH : LOCK_SH|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get shared lock for "get" method');
        $self->_set_status(FAILURE);
        return(undef());
    }

    # extract datas from the shared memory
    my $share = $self->_get_namespace;

    $self->lock($out_lock, $timeout);

    if(exists $share->{$key})
    {
        $self->_set_status(SUCCESS);
        return($share->{$key}); # can be undef() !
    }
    else
    {
        $self->_set_status(FAILURE);
        $self->_set_error("can't get key $key, it doesn't exists");
        return(undef());
    }
}

sub set
{
    my $self    = shift || croak('invalid method call');
    my $key     = defined($_[0]) && $_[0] ne '' ? shift : croak(defined($_[0]) ? 'Not enough arguments for set method' : 'Invalid argument "" for set method');
    my $value   = defined($_[0]) ? shift : croak('Not enough arguments for set method');
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for set method') if(@_);
    $self->_unset_error;
    
    $self->_debug("$key $value ", $wait ? '(wait)' : '(no wait)');

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_EX : LOCK_EX|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get exclusive lock for "set" method');
        $self->_set_status(FAILURE);
        return(undef());
    }

    my $share = $self->_get_namespace;
    $share->{$key} = $value;
    $self->_store_namespace($share);

    $self->lock($out_lock, $timeout);

    $self->_set_status(SUCCESS);
    # return value, like a common assigment
    return($value);
}

sub delete
{
    my $self    = shift;
    my $key     = defined($_[0]) ? shift : croak('Not enough arguments for delete method');
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for delete method') if(@_);
    $self->_unset_error;

    $self->_debug("$key ", $wait ? '(wait)' : '(no wait)');

    my $exists = $self->exists($key, $wait, $timeout);
    if(!defined $exists)
    {
        $self->_set_error("can\'t delete key '$key': ", $self->error);
        $self->_set_status(FAILURE);
        return(undef());
    }
    elsif(!$exists)
    {
        $self->_debug("DELETE[$$]: key '$key' wasn't exists");
        $self->_set_status(FAILURE);
        return(undef());
    }

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_EX : LOCK_EX|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get exclusive lock for "delete" method');
        $self->_set_status(FAILURE);
        return(undef());
    }


    my $share = $self->_get_namespace;
    my $rv    = delete($share->{$key});
    $self->_store_namespace($share);
   
    $self->lock($out_lock, $timeout);

    $self->_set_status(SUCCESS);
    # like a real delete
    return($rv);
}

sub exists
{
    my $self    = shift;
    my $key     = defined($_[0]) ? shift : croak('Not enough arguments for exists method');
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for exists method') if(@_);
    $self->_unset_error;

    $self->_debug("key: $key");

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_SH : LOCK_SH|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get shared lock for "exists" method');
        $self->_set_status(FAILURE);
        return(undef());
    }

    my $share = $self->_get_namespace;

    $self->lock($out_lock, $timeout);

    $self->_set_status(SUCCESS);
    return(exists $share->{$key});
}

sub firstkey
{
    my $self    = shift;
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for firstkey method') if(@_);
    $self->_unset_error;

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_SH : LOCK_SH|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get shared lock for "firstkey" method');
        $self->_set_status(FAILURE);
        return(undef());
    }

    my $share = $self->_get_namespace;

    $self->lock($out_lock, $timeout);
    
    my $firstkey = (keys(%$share))[0];
    $self->_set_status(SUCCESS);
    return($firstkey, $share->{$firstkey});
}

sub nextkey
{
    my $self    = shift;
    my $lastkey = defined($_[0]) ? shift : croak('Not enough arguments for nextkey method');
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for nextkey method') if(@_);
    $self->_unset_error;

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_SH : LOCK_SH|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get shared lock for "nextkey" method');
        $self->_set_status(FAILURE);
        return(undef());
    }

    my $share = $self->_get_namespace;

    $self->lock($out_lock, $timeout);
    
    $self->_set_status(SUCCESS);
    my @keys = keys %share;
    for(my $x = 0; $x < $#keys; $x++)
    {
        return($share->{$keys[$x+1]}) if($share->{$keys[$x]} eq $lastkey);
    }
    return(undef());
}

sub clear
{
    my $self    = shift;
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for clear method') if(@_);
    $self->_unset_error;

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_EX : LOCK_EX|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get shared lock for "clear" method');
        $self->_set_status(FAILURE);
        return(0);
    }

    $self->_store_namespace({});

    $self->lock($out_lock, $timeout);
    
    $self->_set_status(SUCCESS);
    return(undef());
}

sub release
{
    my $self        = shift;
    my $options     = $self->{options};
    my $namespace   = defined $_[0] ? shift : $options->{namespace};
    $self->_unset_error;

    $self->_debug($namespace);

    if($options->{readonly})
    {
        $self->_set_error('can\'t call release namespace on readonly mode');
        $self->_set_status(FAILURE);
        return undef;
    }

    $self->_root_lock(LOCK_EX);
    my $root = $self->_get_root;

    unless(exists $root->{'map'}->{$namespace})
    {
        $self->_set_error("Apache::SharedMem: namespace '$namespace' doesn't exists in the map");
        $self->_set_status(FAILURE);
        return(undef());
    }

    my $properties = delete($root->{'map'}->{$namespace});

    $self->_store_root($root);
    $self->_root_unlock;

    delete($self->{namespace});

    my $share = new IPC::ShareLite
    (
        -key     => $properties->{key},
        -size    => $properties->{size},
        -mode    => $properties->{mode},
        -create  => 0,
        -destroy => 1,
    );
    unless(defined $share)
    {
        $self->_set_error("Apache::SharedMem: unable to get shared cache block: $!");
        $self->_set_status(FAILURE);
        return(undef());
    }

    unless(keys %{$root->{'map'}})
    {
        # map is empty, destroy it
        $self->_debug("root map is empty, delete it");
        undef($self->{root});
        my $rm = new IPC::ShareLite
        (
            -key     => $options->{rootkey}, 
            -size    => $options->{ipc_segsize},
            -mode    => $options->{ipc_mode},
            -create  => 0,
            -destroy => 1
        );
        unless(defined $rm)
        {
            $self->_set_status(FAILURE);
            $self->_set_error("can't delete empty root map: $!");
        }
        undef $rm; # call DESTROY method explicitly
    }

    $self->_set_status(SUCCESS);
    return(1);
}

sub destroy
{
    my $self    = shift;

    $self->_root_lock(LOCK_SH);
    my $root = $self->_get_root;
    $self->_root_unlock;

    my @ns_list = keys(%{$root->{'map'}});
    $self->_debug('segment\'s list for deletion : ', join(', ', @ns_list));
    my $err = 0;
    foreach $ns (@ns_list)
    {
        $self->_debug("release namespace: $ns");
        $self->release($ns);
        $err++ unless($self->status & SUCCESS);
    }
    $self->_set_status($err ? FAILURE : SUCCESS);
}

sub size
{
    my $self    = shift;
    my $wait    = defined($_[0]) ? shift : (shift, 1);
    my $timeout = shift;
    croak('Too many arguments for size method') if(@_);
    $self->_unset_error;

    my($lock_success, $out_lock) = $self->_smart_lock(($wait ? LOCK_SH : LOCK_SH|LOCK_NB), $timeout);
    unless($lock_success)
    {
        $self->_set_error('can\'t get shared lock for "size" method');
        $self->_set_status(FAILURE);
        return(undef());
    }

    my $serialized;
    eval { $serialized = $self->{namespace}->fetch(); };
    confess("Apache::SharedMem: Problem fetching segment. IPC::ShareLite error: $@") if $@;
    confess("Apache::SharedMem: Problem fetching segment. IPC::ShareLite error: $!") unless(defined $serialized);

    $self->lock($out_lock, $timeout);

    $self->_set_status(SUCCESS);
    return(length $serialized);
}

sub namespaces
{
    my $self    = shift;
    my $record  = $self->_get_root;
    return(keys %{$record->{'map'}});
}

sub dump_map
{
    my $self    = shift;

    _init_dumper();
    my $root_record = $self->_get_root || return undef;
    return Data::Dumper::Dumper($root_record);
}

sub dump
{
    my $self        = shift;
    my $namespace   = defined $_[0] ? shift : croak('too few arguments');

    _init_dumper();
    if(my $ns_obj = $self->_get_namespace_ipcobj($self->_get_root, $namespace))
    {
        return Data::Dumper::Dumper($self->_get_record($ns_obj));
    }
    else
    {
        carp("can't read namespace $namespace: ", $self->error);
        return undef;
    }
}

sub lock
{
    my($self, $type, $timeout) = @_;
    $self->_debug("type ", (defined $type ? $type : 'default'), defined $timeout ? ", timeout $timeout" : '');
    my $rv = $self->_lock($type, $timeout, $self->{namespace});
    # we keep a trace of the actual lock status for smart lock mecanisme
    $self->{_lock_status} = $type if($self->status eq SUCCESS);
    return($rv);
}

sub _root_lock  { $_[0]->_debug("type $_[1]", defined $_[2] ? ", timeout $_[2]" : ''); $_[0]->_lock($_[1], $_[2], $_[0]->{root}) }

sub _lock
{
    confess('Apache::SharedMem: Not enough arguments for lock method') if(@_ < 3);
    my($self, $type, $timeout, $ipc_obj) = @_;
    $self->_unset_error;

    $timeout = 0 if(!defined $timeout || $timeout =~ /\D/ || $timeout < 0);
    return($self->unlock) if(defined $type && $type eq LOCK_UN); # strang bug, LOCK_UN, seem not to be same as unlock for IPC::ShareLite... 

    # get a lock
    my $rv;
    eval
    {
        local $SIG{ALRM} = sub {die "timeout"};
        alarm $timeout;
        $rv = $ipc_obj->lock(defined $type ? $type : LOCK_EX);
        alarm 0;
    };
    if($@ || !$rv)
    {
        $self->_set_error("Can\'t lock get lock: $!$@");
        $self->_set_status(FAILURE);
        return(undef());
    };
    $self->_set_status(SUCCESS);
    return(1);
}

sub unlock
{
    my $self = shift;
    $self->_debug;
    my $rv = $self->_unlock($self->{namespace});
    $self->{_lock_status} = LOCK_UN if($rv);
    return($rv);
}
sub _root_unlock { $_[0]->_debug; $_[0]->_unlock($_[0]->{root}) }

sub _unlock
{
    my($self, $ipc_obj) = @_;
    $self->_unset_error;

    $ipc_obj->unlock or
    do
    { 
        $self->_set_error("Can't unlock segment"); 
        $self->_set_status(FAILURE);
        return(undef());
    };
    $self->_set_status(SUCCESS);
    return(1);
}

sub error  { return($_[0]->{__last_error__}); }

sub status { return($_[0]->{__status__}); }

sub _smart_lock
{
    # this method try to implement a smart fashion to manage locks.
    # problem is when user place manually a lock before a get, set,... call. the
    # methode handle his own lock, and in this code :
    #   $share->lock(LOCK_EX);
    #   my $var = $share->get(key);
    #   ...make traitement on $var
    #   $share->set(key=>$var);
    #   $share->unlock;
    #
    # in this example, the first "get" call, change the lock for a share lock, and free
    # the lock at the return.
    # 
    my($self, $type, $timeout) = @_;
    
    if(!defined($self->{_lock_status}) || $self->{_lock_status} & LOCK_UN)
    {
        # no lock have been set, act like a normal lock
        $self->_debug("locking type $type, return LOCK_UN");
        return($self->lock($type, $timeout), LOCK_UN);
    }
    elsif(($self->{_lock_status} & LOCK_SH) && ($type & LOCK_EX))
    {
        # the current lock is powerless than targeted lock type
        my $old_lock = $self->{_lock_status};
        $self->_debug("locking type $type, return $old_lock");
        return($self->lock($type, $timeout), $old_lock);
    }

    $self->_debug("live lock untouch, return $self->{_lock_status}");
    return(1, $self->{_lock_status});
}

sub _init_root
{
    my $self    = shift;
    my $options = $self->{options};
    my $record;

    $self->_debug;
    # try to get a handle on an existing root for this namespace
    my $root = new IPC::ShareLite
    (
        -key        => $options->{rootkey},
        -mode       => $options->{ipc_mode},
        -size       => $options->{ipc_segment_size},
        -create     => 0,
        -destroy    => 0,
    );

    if(defined $root)
    {
        # we have found an existing root
        $self->{root} = $root;
        $self->_root_lock(LOCK_SH);
        $record = $self->_get_root;
        $self->_root_unlock;
        unless(ref $record && ref($record) eq 'HASH' && exists $record->{'map'})
        {
            $self->_debug("map dump: ", $record, Data::Dumper::Dumper($record)) if($options->{debug});
            confess("Apache::SharedMem object initialization: wrong root map type")
        }

        # checking map version
        unless(exists $record->{'version'} && $record->{'version'} >= 2)
        {
            # old map style, we ne upgrade it
            $self->_root_lock(LOCK_EX);
            foreach my $namespace (keys %{$record->{'map'}})
            {
                $namespace = 
                {
                    key     => $namespace,
                    mode    => $options->{ipc_mode},
                    size    => $options->{ipc_segment_size},
                }
            }
            $self->_store_root($record);
            $self->_root_unlock;
        }

        return($record);
    }

    $self->_debug('root map first initalisation');

    if($options->{readonly})
    {
        $self->_set_error("root map ($options->{rootkey}) doesn't exists, can't create one in readonly mode");
        $self->_set_status(FAILURE);
        return(undef);
    }

    # prepare empty root record for new root creation
    $record = 
    {
        'map'       => {},
        'last_key'  => $options->{rootkey},
        'version'   => 2, # map version
    };

    $root = new IPC::ShareLite
    (
        -key        => $options->{rootkey},
        -mode       => $options->{ipc_mode},
        -size       => $options->{ipc_segment_size},
        -create     => 1,
        -exclusive  => 1,
        -destroy    => 0,
    );
    confess("Apache::SharedMem object initialization: Unable to initialize root ipc shared memory segment ($options->{rootkey}): $!")
      unless(defined $root);

    $self->{root} = $root;
    $self->_root_lock(LOCK_EX);
    $self->_store_root($record);
    $self->_root_unlock;

    return($record);
}

sub _get_namespace_ipcobj
{
    my($self, $rootrecord, $namespace) = @_;

    if(my $properties = $rootrecord->{'map'}->{$namespace})
    {
        $self->_debug('namespace exists');
        # namespace already exists
        $share = new IPC::ShareLite
        (   
            -key            => $properties->{key},
            -mode           => $properties->{mode},
            -size           => $properties->{size},
            -create         => 0,
            -destroy        => 0,
        );
        confess("Apache::SharedMem: Unable to get shared cache block ($namespace=$properties->{key}): $!") unless(defined $share);
        $self->_set_status(SUCCESS);
        return $share;
    }
    else
    {
        $self->_set_status(FAILURE);
        $self->_set_error("no such namespace: '$namespace'");
        return undef();
    }
}

sub _init_namespace
{
    my $self        = shift;
    my $options     = $self->{options};
    my $namespace   = $options->{namespace};

    $self->_debug;
    my $rootrecord  = $self->_init_root || return undef;

    my $share;
    if(exists $rootrecord->{'map'}->{$namespace})
    {
        $share = $self->_get_namespace_ipcobj($rootrecord, $namespace);
    }
    else
    {
        if($options->{readonly})
        {
            $self->_set_error("namespace '$namespace' doesn't exists, can't create one in readonly mode");
            $self->_set_status(FAILURE);
            return(undef);
        }

        $self->_debug('namespace doesn\'t exists, creating...');
        # otherwise we need to find a new segment
        my $ipc_key  = $rootrecord->{'last_key'}+1;
        my $ipc_mode = $options->{ipc_mode};
        my $ipc_size = $options->{ipc_segment_size};
        for(my $end = $ipc_key + 10_000; $ipc_key != $end; $ipc_key++)
        {
            $share = new IPC::ShareLite
            (
                -key        => $ipc_key,
                -mode       => $ipc_mode,
                -size       => $ipc_size,
                -create     => 1,
                -exclusive  => 1,
                -destroy    => 0,
            );
            last if(defined $share);
        }
        croak("Apache::SharedMem: searched through 10,000 consecutive locations for a free shared memory segment, giving up: $!")
          unless(defined $share);

        # update the root record
        $self->_root_lock(LOCK_EX);
        $rootrecord->{'map'}->{$namespace} =
        {
            key     => $ipc_key,
            mode    => $ipc_mode,
            size    => $ipc_size,
        };
        $rootrecord->{'last_key'} = $ipc_key;
        $self->_store_record({}, $share); # init contents, to avoid root map's corruption in certain circumstances
        $self->_store_root($rootrecord);
        $self->_root_unlock;
    }

    return($self->{namespace} = $share);
}

# return a most hase possible, unique IPC identifier
sub _get_rootkey
{
    my $self = shift;
    my($ipckey, $docroot, $uid);

    if(exists $ENV{'GATEWAY_INTERFACE'} && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)
    {
        # we are under mod_perl
        if(defined $Apache::SharedMem::ROOTKEY)
        {
            $ipckey = $Apache::SharedMem::ROOTKEY; # look at import() for more details
        }
        else
        {
            require Apache;
            if(defined $Apache::Server::Starting && $Apache::Server::Starting)
            {
                # we are in the startup.pl
                my $s    = Apache->server;
                $docroot = $s->dir_config->get('PROJECT_DOCUMENT_ROOT')
                    ? ($s->dir_config->get('PROJECT_DOCUMENT_ROOT'))[-1] : return undef;
                $uid     = $s->dir_config->get('PROJECT_ID')
                    ? ($s->dir_config->get('PROJECT_ID'))[-1] : $s->uid;
            }
            else
            {
                my $r    = Apache->request;
                my $s    = $r->server;
                $docroot = $r->document_root;
                $uid     = $s->uid;
            }
        }
    }
    elsif(exists $ENV{'DOCUMENT_ROOT'})
    {
        # we are under mod_cgi
        $docroot = $ENV{DOCUMENT_ROOT};
        $uid     = $<;
    }
    else
    {
        # we are in an undefined environment
        $docroot = $ENV{PWD};
        $uid     = $<;
    }

    unless(defined $ipckey)
    {
        confess("PROJECT_DOCUMENT_ROOT doesn't exists or can't be accessed: " . (defined $docroot ? $docroot : '[undefined]'))
          if(not defined $docroot || $docroot eq '' || not -e $docroot || not -r $docroot);
        confess("PROJECT_ID is not numeric: " . (defined $uid ? $uid : '[undefined]')) 
          if(not defined $uid || $uid =~ /[^\d\-]/);
        $ipckey = IPC::SysV::ftok($docroot, $uid);
    }

    $self->_debug("document_root=$docroot, uid=$uid, rootkey=$ipckey") if(defined $self);
    return($ipckey);
}

sub _get_namespace { $_[0]->_debug; $_[0]->_get_record($_[0]->{namespace}) }
sub _get_root      { $_[0]->_debug; $_[0]->_get_record($_[0]->{root}) }

sub _get_record
{
    my($self, $ipc_obj) = @_;

    return undef unless(defined $ipc_obj);

    my($serialized, $record);

    # fetch the shared block
    eval { $serialized = $ipc_obj->fetch(); };
    confess("Apache::SharedMem: Problem fetching segment. IPC::ShareLite error: $@") if $@;
    confess("Apache::SharedMem: Problem fetching segment. IPC::ShareLite error: $!") unless(defined $serialized);

    $self->_debug(4, 'storable src: ', $serialized);

    if($serialized ne '')
    {
        # thaw the shared block
        eval { $record = thaw($serialized) };
        confess("Apache::SharedMem: Invalid share block recieved from shared memory. Storable error: $@") if $@;
        confess("Apache::SharedMem: Invalid share block recieved from shared memory.") unless(ref($record) eq 'HASH');
    }
    else
    {
        # record not initialized
        $record = {};
    }

    $self->_debug(4, 'dump: ', Data::Dumper::Dumper($record)) if($self->{options}->{debug});

    return($record);
}

sub _store_namespace { $_[0]->_debug; $_[0]->_store_record($_[1], $_[0]->{namespace}) }
sub _store_root      { $_[0]->_debug; $_[0]->_store_record($_[1], $_[0]->{root}) }

sub _store_record
{
    my $self    = shift;
    my $share   = defined($_[0]) ? (ref($_[0]) eq 'HASH' ? shift() : croak('Apache::SharedMem: unexpected error, wrong data type')) : croak('Apache::SharedMem; unexpected error, missing argument');
    my $ipc_obj = defined $_[0] ? shift : return undef;

    if($self->{options}->{readonly})
    {
        $self->_set_error('can\'t store any data in readonly mode');
        $self->_set_status(FAILURE);
        return undef;
    }

    $self->_debug(4, 'dump: ', Data::Dumper::Dumper($share)) if($self->{options}->{debug});

    my $serialized;

    # freeze the shared block
    eval { $serialized = freeze($share) };
    confess("Apache::SharedMem: Problem while the serialization of shared data. Storable error: $@") if $@;
    confess("Apache::SahredMem: Problem while the serialization of shared data.") unless(defined $serialized && $serialized ne '');

    $self->_debug(4, 'storable src: ', $serialized);

    # store the serialized data
    eval { $ipc_obj->store($serialized) };
    confess("Apache::SharedMem: Problem storing share segment. IPC::ShareLite error: $@") if $@;

    return($share);
}

sub _debug
{
    return() unless($_[0]->{options}->{debug});
    my $self  = shift;
    my $dblvl = defined($_[0]) && $_[0] =~ /^\d$/ ? shift : 1;
    printf(STDERR "### DEBUG %s method(%s) pid[%s]: %s\n", (caller())[0], (split(/::/, (caller(1))[3]))[-1], $$, join('', @_)) if($self->{options}->{debug} >= $dblvl);
}

sub _set_error
{
    my $self = shift;
    $self->_debug($Apache::SharedMem::ERROR = $self->{__last_error__} = join('', @_));
}

sub _unset_error
{
    my $self = shift;
    $Apache::SharedMem::ERROR = $self->{__last_error__} = '';
}

sub _set_status
{
    my $self = shift;
    $self->{__status__} = defined($_[0]) ? $_[0] : '';
    $self->_debug("setting status to $_[0]");
}

sub _init_dumper
{
    require Data::Dumper;
    $Data::Dumper::Indent    = 2;
    $Data::Dumper::Terse     = 1;
    $Data::Dumper::Quotekeys = 0;
}

sub _cleanup
{
    if(defined $Apache::SharedMem::ROOTKEY)
    {
        my $share = new Apache::SharedMem;
        $share->destroy if(defined $share)
    }
}

DESTROY
{
    # auto unlock on destroy, it seem to work under mod_perl with Apache::Registry, not tested yet under mod_perl handlers
    $_[0]->unlock 
      if(defined $_[0]->{_lock_status} && ($_[0]->{_lock_status} & LOCK_SH || $_[0]->{_lock_status} & LOCK_EX));
}

1;