view release on metacpan or  search on metacpan

lib/Apache/SharedMem.pm  view on Meta::CPAN

Process' UID and DOCUMENT_ROOT (or current working directory) are given to C<ftok> 
so as to guarantee an unique key as far as possible. 

Note, if you are using mod_perl, and you'v load mod_perl via startup.pl 
(see USAGE section for more details), the rootkey is generated once at the apache 
start, based on the supplied PROJECT_DOCUMENT_ROOT and Apache's uid.

=item *

C<namespace> optional, string

Setup manually the namespace. To share same datas, your program must use the same 
namespace. This namespace is set by default to the caller's package name. In most
cases the default value is a good choice. But you may setup manually this value if,
for example, you want to share the same datas between two or more modules. 

=item *

C<ipc_mode> optional, octal

Setup manually the segment mode (see L<IPC::ShareLite>) for more details (default: 0600).
Warning: this value _must_ be octal, see chmod documentation in perlfunc manpage for more details.

=item *

C<ipc_segment_size> optional, integer

Setup manually the segment size (see L<IPC::ShareLite>) for more details (default: 65_536).

=item *

C<debug> optional, boolean

Turn on/off the debug mode (default: 0)

=back

In most case, you don't need to give any arguments to the constructor.

C<ipc_mode> and C<ipc_segment_size> are used only on the first namespace
initialisation. Using different values on an existing key (in shared memory)
has no effect. 

Note that C<ipc_segment_size> is default value of IPC::ShareLite, see
L<IPC::ShareLite> 

On succes return an Apache::SharedMem object, on error, return undef().
You can get error string via $Apache::SharedMem::ERROR.

=cut

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;
}

=pod

=head2 get  (key, [wait, [timeout]])

my $var = $object->get('mykey', WAIT, 50);
if($object->status & FAILURE)
{
    die("can't get key 'mykey´: " . $object->error);
}

=over 4

=item *

C<key> required, string

This is the name of elemenet that you want get from the shared namespace. It can be any string that perl
support for hash's key.

=item *

lib/Apache/SharedMem.pm  view on Meta::CPAN

    $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;

=pod

=head1 EXPORTS

=head2 Default exports

None.

=head2 Available exports

Following constant is available for exports : LOCK_EX LOCK_SH LOCK_UN LOCK_NB
WAIT NOWAIT SUCCESS FAILURE