Apache-SharedMem
view release on metacpan or search on metacpan
lib/Apache/SharedMem.pm view on Meta::CPAN
$err++ unless($self->status & SUCCESS);
}
$self->_set_status($err ? FAILURE : SUCCESS);
}
=pod
=head2 size ([wait, [timeout]])
=cut
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);
}
=pod
=head2 namespaces
Debug method, return the list of all namespace in the root map.
(devel only)
=cut
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;
}
}
=pod
=head2 lock ([lock_type, [timeout]])
get a lock on the share segment. It returns C<undef()> if failed, 1 if successed.
=over 4
=item *
C<lock_type> optional
type of lock (LOCK_EX, LOCK_SH, LOCK_NB, LOCK_UN)
=item *
C<timeout> optional
time to wait for an exclusive lock before aborting
=back
return status: FAILURE SUCCESS
=cut
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"};
lib/Apache/SharedMem.pm view on Meta::CPAN
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);
}
lib/Apache/SharedMem.pm view on Meta::CPAN
}
}
}
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;
=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
=head2 Export tags defined
The tag ":all" will get all of the above exports.
Following tags are also available :
=over 4
=item
:status
Contents: SUCCESS FAILURE
This tag is really recommended to the importation all the time.
=item
:lock
Contents: LOCK_EX LOCK_SH LOCK_UN LOCK_NB
=item
:wait
WAIT NOWAIT
lib/Apache/SharedMem.pm view on Meta::CPAN
=head1 HISTORY
$Log: SharedMem.pm,v $
Revision 1.61 2001/10/04 12:15:22 rs
Very major bugfix that made module unable to work correctly under mod_perl !
New version 0.09 to CPAN immediatly
Revision 1.60 2001/10/02 09:40:32 rs
Bugfix in _get_rootkey private method: trap empty docroot or no read access
to docroot error.
Revision 1.59 2001/09/24 08:19:40 rs
status now return bitmask values
Revision 1.58 2001/09/21 14:45:30 rs
little doc fixes
Revision 1.57 2001/09/21 12:43:41 rs
Change copyright
Revision 1.56 2001/09/20 12:45:03 rs
Documentation update: adding an EXPORTS section
Revision 1.55 2001/09/19 14:19:41 rs
made a trace more verbose
Revision 1.54 2001/09/18 08:46:32 rs
Documentation upgrade
Revision 1.53 2001/09/17 14:56:41 rs
Suppression of ROOTKEYS global hash, obsolete.
Documentation update: USAGE => PROJECT_ID
Revision 1.52 2001/08/29 15:54:01 rs
little bug fix in _get_rootkey
Revision 1.51 2001/08/29 14:28:08 rs
add warning on no existing document_root in _get_rootkey
Revision 1.50 2001/08/29 12:59:02 rs
some documentation update.
get method now return undef() if value is undefined.
Revision 1.49 2001/08/29 08:30:32 rs
syntax bugfix
Revision 1.48 2001/08/29 08:27:13 rs
doc fix
Revision 1.47 2001/08/29 08:24:23 rs
meny documentation updates
Revision 1.46 2001/08/28 16:42:14 rs
adding better support of mod_perl with a cleanup method handled to Apache's
registry_cleanup.
Revision 1.45 2001/08/28 10:17:00 rs
little documentation fix
Revision 1.44 2001/08/28 08:45:12 rs
stop using autouse for Data::Dumper, mod_perl don't like it
add auto unlock on DESTROY, seem to work under mod_perl with Apache::Registry
TODO test with mod_perl handlers
Revision 1.43 2001/08/27 15:42:02 rs
bugfix in release method, on root map cleanup, ipc_mode must be defined
bugfix in _init_namespace method, if object was create without any "set" called,
the empty namespace won't be allocated.
Revision 1.42 2001/08/24 16:11:25 rs
- Implement a more efficient IPC key generation for the root segment, using
the system ftok() function provied by IPC::SysV module
- Pod documentation
- Default IPC mode is now 0600
- We now keep ipc_mode and ipc_segment_size in the root map for calling IPC::ShareLite
with same values.
- Add "readonly" parameter to constructor
- Feature enhancement, add "dump" and "dump_map" methods
- Data::Dumper is now autoused
- Feature enhancement, release method now release root map when it go empty
- Feature enhancement, add a "destroy" method, that call "release" method on all root-map's
namespaces. Usefull for cleaning shared memory on Apache shutdown.
- Misc bugfixes
Revision 1.41 2001/08/23 08:37:03 rs
major bug, _get_rootkey was call mod_perl method on a wrong object
Revision 1.40 2001/08/23 08:08:18 rs
little documentation update
Revision 1.39 2001/08/23 00:56:32 rs
vocabulary correction in POD documentation
Revision 1.38 2001/08/22 16:10:15 rs
- Pod documentation
- Default IPC mode is now 0600
- We now keep ipc_mode and ipc_segment_size in the root map for calling IPC::ShareLite
with same values.
- Bugfix, release now really clean segments (seem to be an IPC::ShareLite bug)
Revision 1.37 2001/08/21 13:17:35 rs
switch to version O.07
Revision 1.36 2001/08/21 13:17:02 rs
add method _get_rootkey. this method allow constructor to determine a more
uniq ipc key. key is generated with IPC::SysV::ftok() function, based on
ducument_root and user id.
Revision 1.35 2001/08/17 13:28:18 rs
make precedence more readable in "_set_status" method
some pod corrections
Revision 1.34 2001/08/08 14:15:07 rs
forcing default lock to LOCK_EX
Revision 1.33 2001/08/08 14:01:45 rs
grrr syntax error second part, it's not my day.
Revision 1.32 2001/08/08 13:59:01 rs
syntax error introdius with the last fix
Revision 1.31 2001/08/08 13:56:35 rs
Starting version 0.06
fixing an "undefined value" bug in lock methode
Revision 1.30 2001/07/04 08:41:11 rs
major documentation corrections
Revision 1.29 2001/07/03 15:24:19 rs
fix doc
Revision 1.28 2001/07/03 14:53:02 rs
make a real changes log
( run in 2.772 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )