cvsuser 02/10/07 14:55:58
Modified: App-Context/lib/App Context.pm
App-Context/lib/App/Request CGI.pm
Added: App-Context/lib/App Authentication.pm Authorization.pm
CallDispatcher.pm MessageDispatcher.pm
ResourceLocker.pm
App-Context/lib/App/ResourceLocker IPCLocker.pm
IPCSemaphore.pm
Removed: App-Context/lib/App LogChannel.pm Messaging.pm Procedure.pm
Security.pm SharedResourceSet.pm
Log:
renamed and reorganized
Revision Changes Path
1.3 +47 -6 p5ee/App-Context/lib/App/Context.pm
Index: Context.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- Context.pm 18 Sep 2002 02:54:10 -0000 1.2
+++ Context.pm 7 Oct 2002 21:55:58 -0000 1.3
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Context.pm,v 1.2 2002/09/18 02:54:10 spadkins Exp $
+## $Id: Context.pm,v 1.3 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::Context;
@@ -771,6 +771,21 @@
my ($self, $name, $var, $default, $setdefault) = @_;
my ($perl, $value);
+ if (!defined $var || $var eq "") {
+ if ($name =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
+ $name = $1;
+ $var = $2;
+ }
+ elsif ($name =~ /^([a-zA-Z0-9_\.-]+)\.([a-zA-Z0-9_]+)$/) {
+ $name = $1;
+ $var = $2;
+ }
+ else {
+ $var = $name;
+ $name = "session";
+ }
+ }
+
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
$value = $self->{session}{cache}{Widget}{$name}{$var};
if (!defined $value && defined $default) {
@@ -800,10 +815,7 @@
if ($App::DEBUG && $self->dbg(3));
return $value;
} # match {
- elsif ($var =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
-
- $name = $1;
- $var = $2;
+ elsif ($var =~ /^[\{\}\[\]].*$/) {
$self->widget($name) if (!defined $self->{session}{cache}{Widget}{$name});
@@ -813,7 +825,7 @@
print STDERR "ERROR: Context->get($var): eval ($perl): $@\n" if ($@);
$self->dbgprint("Context->wget($name,$var) (indexed) = [$value]")
- if ($App::DEBUG && $self->dbg(3));
+ if ($P5EEx::Blue::DEBUG && $self->dbg(3));
}
return $value;
@@ -855,6 +867,21 @@
$self->dbgprint("Context->wset($name,$var,$value)")
if ($App::DEBUG && $self->dbg(3));
+ if (!defined $var || $var eq "") {
+ if ($name =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
+ $name = $1;
+ $var = $2;
+ }
+ elsif ($name =~ /^([a-zA-Z0-9_\.-]+)\.([a-zA-Z0-9_]+)$/) {
+ $name = $1;
+ $var = $2;
+ }
+ else {
+ $var = $name;
+ $name = "session";
+ }
+ }
+
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
$self->{session}{store}{Widget}{$name}{$var} = $value;
$self->{session}{cache}{Widget}{$name}{$var} = $value
@@ -916,6 +943,20 @@
$self->dbgprint("Context->wdelete($name,$var)")
if ($App::DEBUG && $self->dbg(3));
+
+ if (!defined $var || $var eq "") {
+ if ($name =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
+ $name = $1;
+ $var = $2;
+ }
+ elsif ($name =~ /^([a-zA-Z0-9_\.-]+)\.([a-zA-Z0-9_]+)$/) {
+ $name = $1;
+ $var = $2;
+ }
+ else {
+ return;
+ }
+ }
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
delete $self->{session}{store}{Widget}{$name}{$var};
1.1 p5ee/App-Context/lib/App/Authentication.pm
Index: Authentication.pm
===================================================================
#############################################################################
## $Id: Authentication.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::Security;
use App;
use App::Service;
@ISA = ( "App::Service" );
use strict;
=head1 NAME
App::Security - Interface for authentication and authorization
=head1 SYNOPSIS
use App;
$context = App->context();
$security = $context->service("Security"); # or ...
$security = $context->security();
... TBD ...
=head1 DESCRIPTION
A Security service is a means by which a user may be authenticated
and by which he may be authorized to perform specific operations.
=cut
#############################################################################
# CLASS GROUP
#############################################################################
=head1 Class Group: Security
The following classes might be a part of the Security Class Group.
=over
=item * Class: App::Security
=item * Class: App::Security::Htpasswd
=item * Class: App::Security::Passwd
=item * Class: App::Security::DBI
=item * Class: App::Security::Repository
=item * Class: App::Security::SMB
=item * Class: App::Security::LDAP
=item * Class: App::Security::Radius
=item * Class: App::Security::Kerberos
=item * Class: App::Security::SSL
=item * Class: App::Security::DCE
=back
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::Security
A Security service is a means by which a user may be authenticated
and by which he may be authorized to perform specific operations.
* Throws: App::Exception::Security
* Since: 0.01
=head2 Class Design
...
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# TBD()
#############################################################################
=head2 TBD()
* Signature: $tbd_return = $repository->tbd($tbd_param);
* Param: $tbd_param integer
* Return: $tbd_return integer
* Throws: App::Exception::Repository
* Since: 0.01
Sample Usage:
$tbd_return = $repository->tbd($tbd_param);
=cut
sub tbd {
my ($self) = @_;
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
=cut
#############################################################################
# Method: service_type()
#############################################################################
=head2 service_type()
Returns 'Security';
* Signature: $service_type = App::Security->service_type();
* Param: void
* Return: $service_type string
* Since: 0.01
$service_type = $widget->service_type();
=cut
sub service_type () { 'Security'; }
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
1.1 p5ee/App-Context/lib/App/Authorization.pm
Index: Authorization.pm
===================================================================
#############################################################################
## $Id: Authorization.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::LogChannel;
use App;
use App::Service;
@ISA = ( "App::Service" );
use strict;
=head1 NAME
App::LogChannel - Interface for logging
=head1 SYNOPSIS
use App;
$context = App->context();
$logchannel = $context->service("LogChannel"); # or ...
$logchannel = $context->logchannel();
=head1 DESCRIPTION
A LogChannel service is a means by which messages are logged through a
logging system. This perhaps ends up in a file, or perhaps it
ends up on someone's operator console screen somewhere.
=cut
#############################################################################
# CLASS GROUP
#############################################################################
=head1 Class Group: LogChannel
The following classes might be a part of the LogChannel Class Group.
=over
=item * Class: App::LogChannel
=item * Class: App::LogChannel::LogDispatch
=item * Class: App::LogChannel::NetDaemon
=back
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::LogChannel
A LogChannel service ...
* Throws: App::Exception::LogChannel
* Since: 0.01
=head2 Class Design
...
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# log()
#############################################################################
=head2 log()
* Signature: $logchannel->log(@text);
* Param: @text array[string]
* Return: void
* Throws: App::Exception::LogChannel
* Since: 0.01
Sample Usage:
$context = App->context();
$logchannel = $context->service("LogChannel"); # or ...
$logchannel->log("Error occurred");
=cut
sub log {
my ($self, @text) = @_;
print STDERR @text, "\n";
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
=cut
#############################################################################
# Method: service_type()
#############################################################################
=head2 service_type()
Returns 'LogChannel';
* Signature: $service_type = App::LogChannel->service_type();
* Param: void
* Return: $service_type string
* Since: 0.01
$service_type = $widget->service_type();
=cut
sub service_type () { 'LogChannel'; }
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
1.1 p5ee/App-Context/lib/App/CallDispatcher.pm
Index: CallDispatcher.pm
===================================================================
#############################################################################
## $Id: CallDispatcher.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::CallDispatcher;
use App;
use App::Service;
@ISA = ( "App::Service" );
use strict;
=head1 NAME
App::CallDispatcher - synchronous (potentially remote) procedure invocation
=head1 SYNOPSIS
use App;
$context = App->context();
$procedure = $context->service("CallDispatcher"); # or ...
$procedure = $context->procedure();
$procedure->execute($request, $response);
$response = $procedure->execute($request);
$response = $procedure->execute(%named);
=head1 DESCRIPTION
A CallDispatcher service is a means by which a function call (perhaps remote)
may be made synchronously.
=cut
#############################################################################
# CLASS GROUP
#############################################################################
=head1 Class Group: CallDispatcher
The following classes might be a part of the CallDispatcher Class Group.
=over
=item * Class: App::CallDispatcher
=item * Class: App::CallDispatcher::Local
=item * Class: App::CallDispatcher::SOAP
=item * Class: App::CallDispatcher::pRPC
=item * Class: App::CallDispatcher::PlRPC
=item * Class: App::CallDispatcher::Messaging
=back
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::CallDispatcher
A CallDispatcher service is a means by which a function call (perhaps remote)
may be made synchronously or asynchronously.
* Throws: App::Exception::CallDispatcher
* Since: 0.01
=head2 Class Design
...
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# execute()
#############################################################################
=head2 execute()
* Signature: $procedure->execute($request, $response);
* Signature: $response = $procedure->execute($request);
* Signature: $response = $procedure->execute(%named);
* Param: $request ref [in]
* Param: $response ref [out]
* Return: $response ref
* Throws: App::Exception::CallDispatcher
* Since: 0.01
Sample Usage:
$procedure->execute($request, $response);
$response = $procedure->execute($request);
$response = $procedure->execute(%named);
=cut
sub execute {
my $self = shift;
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
=cut
#############################################################################
# Method: service_type()
#############################################################################
=head2 service_type()
Returns 'CallDispatcher';
* Signature: $service_type = App::CallDispatcher->service_type();
* Param: void
* Return: $service_type string
* Since: 0.01
$service_type = $widget->service_type();
=cut
sub service_type () { 'CallDispatcher'; }
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
1.1 p5ee/App-Context/lib/App/MessageDispatcher.pm
Index: MessageDispatcher.pm
===================================================================
#############################################################################
## $Id: MessageDispatcher.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::MessageDispatcher;
use App;
use App::Service;
@ISA = ( "App::Service" );
use strict;
=head1 NAME
App::MessageDispatcher - Interface for sending/receiving (possibly) async messages
=head1 SYNOPSIS
use App;
$context = App->context();
$messaging = $context->service("MessageDispatcher"); # or ...
$messaging = $context->messaging();
($status, $ticket) = $messaging->send(
recipient => $recipient,
message => $message
);
$message = $messaging->receive();
$message = $messaging->receive(
sender => $sender,
);
$message = $messaging->receive(
ticket => $ticket,
);
=head1 DESCRIPTION
A MessageDispatcher service is a means by which data can be sent asynchronously
(or synchronously) to a recipient and responses can be received.
Because the possibility exists for the messaging channel to be asynchronous,
code that uses a MessageDispatcher service must code for the most complicated case
(asynchronous).
=cut
#############################################################################
# CLASS GROUP
#############################################################################
=head1 Class Group: MessageDispatcher
The following classes might be a part of the MessageDispatcher Class Group.
=over
=item * Class: App::MessageDispatcher
=item * Class: App::MessageDispatcher::Mail
=item * Class: App::MessageDispatcher::SOAP
=item * Class: App::MessageDispatcher::Stem
=item * Class: App::MessageDispatcher::Spread
=item * Class: App::MessageDispatcher::Jabber
=item * Class: App::MessageDispatcher::PVM
=item * Class: App::MessageDispatcher::MPI
=back
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::MessageDispatcher
A MessageDispatcher service is a means by which data can be sent synchronously
or asynchronously to a recipient and responses can be received.
* Throws: App::Exception::MessageDispatcher
* Since: 0.01
=head2 Class Design
...
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# send()
#############################################################################
=head2 send()
* Signature: ($status, $ticket) = $messaging->send(%named);
* Param: recipient string
* Param: message binary
* Return: $status integer
* Return: $ticket string
* Throws: App::Exception::MessageDispatcher
* Since: 0.01
Sample Usage:
($status, $ticket) = $messaging->send(
recipient => "stephen.adkins\@officevision.com",
message => "Hello.",
);
=cut
sub send {
my $self = shift;
my %args = @_;
my ($status, $ticket);
($status, $ticket);
}
#############################################################################
# receive()
#############################################################################
=head2 receive()
* Signature: $message = $messaging->receive();
* Signature: $message = $messaging->receive(%named);
* Param: sender string
* Param: ticket string
* Return: $message binary
* Throws: App::Exception::MessageDispatcher
* Since: 0.01
Sample Usage:
# receive next available message
$message = $messaging->receive();
# receive next message from sender
$message = $messaging->receive(
sender => "stephen.adkins\@officevision.com",
);
# receive message associated with ticket
$message = $messaging->receive(
ticket => "XP305-3jks37sl.f299d",
);
=cut
sub receive {
my $self = shift;
my %args = @_;
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
=cut
#############################################################################
# Method: service_type()
#############################################################################
=head2 service_type()
Returns 'MessageDispatcher'.
* Signature: $service_type = App::MessageDispatcher->service_type();
* Param: void
* Return: $service_type string
* Since: 0.01
$service_type = $widget->service_type();
=cut
sub service_type () { 'MessageDispatcher'; }
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
1.1 p5ee/App-Context/lib/App/ResourceLocker.pm
Index: ResourceLocker.pm
===================================================================
#############################################################################
## $Id: ResourceLocker.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::ResourceLocker;
use App;
use App::Service;
@ISA = ( "App::Service" );
use strict;
=head1 NAME
App::ResourceLocker - Interface for locking shared resources
=head1 SYNOPSIS
use App;
$context = App->context();
$srs = $context->service("ResourceLocker"); # or ...
$srs = $context->shared_resource_set();
=head1 DESCRIPTION
A ResourceLocker service represents a collection of "advisory" (or "cooperative")
resource locks.
=cut
#############################################################################
# CLASS GROUP
#############################################################################
=head1 Class Group: ResourceLocker
The following classes might be a part of the ResourceLocker Class Group.
=over
=item * Class: App::ResourceLocker
=item * Class: App::ResourceLocker::IPCLocker
=item * Class: App::ResourceLocker::IPCSemaphore
=item * Class: App::ResourceLocker::BerkeleyDB
=back
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::ResourceLocker
A ResourceLocker service represents a collection of "advisory" (or "cooperative")
resource locks. These can be used to synchronize access to and modification
of shared resources such as are stored in a SharedDatastore.
* Throws: App::Exception::ResourceLocker
* Since: 0.01
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# lock()
#############################################################################
=head2 lock()
* Signature: $resource_name = $srs->lock($resource_pool);
* Signature: $resource_name = $srs->lock($named);
* Param: $resource_pool string
* Param: resourcePool string
* Param: nonBlocking boolean
* Param: nonExclusive boolean
* Param: maxWaitTimeMS integer
* Return: $resource_name string
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$context = App->context();
$srs = $context->service("ResourceLocker");
$srs->lock("shmem01");
The lock() method on a ResourceLocker is for the purposes of cooperative
resource locking.
=cut
sub lock {
my ($self, $arg) = @_;
my ($resource_pool, $resource_name);
if (ref($arg) eq "HASH") {
$resource_pool = $arg->{resourcePool};
}
elsif (ref($arg) eq "") {
$resource_pool = $arg;
}
return undef if (! $resource_pool);
# this is a dummy implementation. it does no real locking.
# it returns a resource name which is the same as the resource pool
$resource_name = $resource_pool;
return ($resource_name);
}
#############################################################################
# unlock()
#############################################################################
=head2 unlock()
* Signature: $srs->unlock($resource_name);
* Param: $resource_name string
* Return: void
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$context = App->context();
$srs = $context->service("ResourceLocker");
$srs->unlock("shmem01");
=cut
sub unlock {
my ($self, $resource_name) = @_;
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
=cut
#############################################################################
# Method: service_type()
#############################################################################
=head2 service_type()
Returns 'ResourceLocker';
* Signature: $service_type = App::ResourceLocker->service_type();
* Param: void
* Return: $service_type string
* Since: 0.01
$service_type = $widget->service_type();
=cut
sub service_type () { 'ResourceLocker'; }
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
1.3 +35 -4 p5ee/App-Context/lib/App/Request/CGI.pm
Index: CGI.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Request/CGI.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- CGI.pm 18 Sep 2002 02:54:11 -0000 1.2
+++ CGI.pm 7 Oct 2002 21:55:58 -0000 1.3
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: CGI.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
+## $Id: CGI.pm,v 1.3 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::Request::CGI;
@@ -233,7 +233,7 @@
# 3. "wname{m}[1]" variable is a "multi-level hash key" under
$context->{widget}{$wname}
# 4. "wname" variable is a "multi-level hash key"
##########################################################
- my (@eventvars, $var, @values, $value, $mlhashkey, $name);
+ my (@eventvars, $var, @values, @tmp, $value, $mlhashkey, $name);
@eventvars = ();
foreach $var ($cgi->param()) {
if ($var =~ /^app\.event/) {
@@ -245,6 +245,21 @@
}
else {
@values = $cgi->param($var);
+ if ($#values > 0) {
+ @tmp = ();
+ foreach $value (@values) {
+ if ($value eq "{:delete:}") {
+ my $delvar = $var;
+ $delvar =~ s/\[\]$//;
+ $context->wdelete($name, $delvar);
+ }
+ else {
+ push(@tmp, $value);
+ }
+ }
+ @values = @tmp;
+ }
+
if ($var =~ s/\[\]$//) {
$value = [ @values ];
}
@@ -257,6 +272,7 @@
else {
$value = join(",",@values);
}
+
if ($var =~ /^([^\[\]\{\}]+)([\[\]\{\}].*)/) {
$context->wset($1, $2, $value);
}
@@ -281,7 +297,7 @@
}
}
- my ($key, $fullkey, $args, @args, $event, %x, %y, $x, $y);
+ my ($key, $fullkey, $args, $arg, @args, $event, %x, %y, $x, $y);
foreach $key (@eventvars) {
# These events come from <input type=submit> type controls
@@ -295,7 +311,22 @@
if ($key =~ /\((.*)\)/) { # look for anything inside
parentheses
$args = $1;
}
+ if ($args eq "") {
+ # do nothing, @args = ()
+ }
+ elsif ($args =~ /\{/) { # } balance
+ foreach $arg (split(/ *, */,$args)) {
+ if ($arg =~ /^\{(.*)\}$/) {
+ push(@args, $context->wget($1));
+ }
+ else {
+ push(@args, $arg);
+ }
+ }
+ }
+ else {
@args = split(/ *, */,$args) if ($args ne "");
+ }
# <input type=image name=joe> returns e.g. joe.x=20 joe.y=35
# these two variables get turned into one event with $x, $y added
to the end of the @args
1.1 p5ee/App-Context/lib/App/ResourceLocker/IPCLocker.pm
Index: IPCLocker.pm
===================================================================
#############################################################################
## $Id: IPCLocker.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::ResourceLocker::IPCLocker;
use App;
use App::ResourceLocker;
@ISA = ( "App::ResourceLocker" );
use IPC::::Locker;
use strict;
=head1 NAME
App::ResourceLocker::IPCLocker - locking shared resources using IPC::Locker
=head1 SYNOPSIS
use App;
$context = App->context();
$srs = $context->service("ResourceLocker"); # or ...
$srs = $context->shared_resource_set();
=head1 DESCRIPTION
A ResourceLocker service represents a collection of "advisory"
(or "cooperative")
resource locks. The IPCLocker implementation uses the IPC::Locker
distribution available on CPAN. Locking is implemented by a Locker Daemon
(lockerd), so that locking may be effectively achieved across an entire
network.
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::ResourceLocker::IPCLocker
A ResourceLocker service represents a collection of "advisory" (or "cooperative")
resource locks. These can be used to synchronize access to and modification
of shared resources such as are stored in a SharedDatastore.
* Throws: App::Exception::ResourceLocker
* Since: 0.01
The ResourceLocker may be configured with the following parameters, which govern
all locks accessed in the ResourceLocker (as per IPC::Locker).
family IPC (fifo) family to communicate with the lock server
INET: use TCP/IP networking
UNIX: use Unix named pipes (created with "mknod p /path/to/fifo")
default: INET
host default: localhost (only needed for INET family)
port default for INET: 1751 (or as defined in /etc/services for "lockerd")
default for UNIX: /var/locks/lockerd
timeout Time at which the server will release the lock if not explicitly
unlocked by then
default: 600 sec (10 min) (0 is "unlimited")
autounlock Allow the locker daemon to break the lock if the locking process
is no longer running. (Note that there is an implicit promise
that the locking process is running on the same server as the
locker daemon.)
random Lock a random resource from the pool when a pool is specified
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# lock()
#############################################################################
=head2 lock()
* Signature: $resource_name = $srs->lock($resource_pool);
* Signature: $resource_name = $srs->lock($resource_set);
* Signature: $resource_name = $srs->lock($named);
* Param: $resource_pool string
* Param: $resource_set []
* Param: resourcePool string
* Param: nonBlocking boolean
* Param: nonExclusive boolean
* Param: maxWaitTimeMS integer
* Return: $resource_name string
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$context = App->context();
$srs = $context->service("ResourceLocker");
$srs->lock("shmem01");
The lock() method on a ResourceLocker is for the purposes of cooperative
resource locking.
The "nonBlocking" option works in this implementation.
However, all locks are exclusive (the nonExclusive option is ignored).
The "maxWaitTimeMS" option is not yet implemented.
=cut
sub lock {
my ($self, $arg) = @_;
my ($resource_pool, $args);
if (ref($arg) eq "HASH") {
$resource_pool = $arg->{resourcePool};
$args = $arg;
}
elsif (ref($arg) eq "ARRAY") {
$resource_pool = $arg;
$args = {};
}
elsif (ref($arg) eq "") {
$resource_pool = $arg;
$args = {};
}
return undef if (! $resource_pool);
my (@params, $lock, $resource_names, $resource_name);
# substitute the list of items in the pool for the pool name
$resource_names = $resource_pool;
$resource_names = $self->{resourcePool}{$resource_pool}
if (defined $self->{resourcePool}{$resource_pool});
if ($self->{random} && ref($resource_names) eq "ARRAY") {
my (@resources, $idx, @lastresources);
@resources = @$resource_names;
$idx = $$ % ($#resources + 1);
if ($idx > 0) {
@lastresources = splice(@resources, 0, $idx);
push(@resources, @lastresources);
$resource_names = \@resources;
}
}
push(@params, "lock", $resource_names);
push(@params, "family", $self->{family}) if (defined $self->{family});
push(@params, "host", $self->{host}) if (defined $self->{host});
push(@params, "port", $self->{port}) if (defined $self->{port});
push(@params, "timeout", $self->{timeout}) if (defined $self->{timeout});
push(@params, "autounlock", $self->{autounlock}) if (defined
$self->{autounlock});
# I need to investigate more what IPC::Locker does with this name
# I may need to use "$user-$session_id"
# The default "name" is "$hostname-$pid" or something similar
#push(@params, "user", $self->{context}->user());
push(@params, "block", ($args->{nonBlocking} ? 0 : 1));
$lock = IPC::Locker->lock(@params);
$resource_name = $lock->lock_name();
if (defined $resource_name) {
$self->{lock}{$resource_name} = $lock; # save for later unlocking
}
return ($resource_name);
}
#############################################################################
# unlock()
#############################################################################
=head2 unlock()
* Signature: $srs->unlock($resource_name);
* Param: $resource_name string
* Return: void
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$context = App->context();
$srs = $context->service("ResourceLocker");
$srs->unlock("shmem01");
=cut
sub unlock {
my ($self, $resource_name) = @_;
my ($lock);
$lock = $self->{lock}{$resource_name};
if (defined $lock) {
$lock->unlock();
delete $self->{lock}{$resource_name};
}
}
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::ResourceLocker>|App::ResourceLocker>,
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
1.1 p5ee/App-Context/lib/App/ResourceLocker/IPCSemaphore.pm
Index: IPCSemaphore.pm
===================================================================
#############################################################################
## $Id: IPCSemaphore.pm,v 1.1 2002/10/07 21:55:58 spadkins Exp $
#############################################################################
package App::ResourceLocker::IPCSemaphore;
use App;
use App::ResourceLocker;
@ISA = ( "App::ResourceLocker" );
use IPC::SysV qw(IPC_PRIVATE IPC_CREAT IPC_EXCL IPC_NOWAIT SEM_UNDO);
use IPC::Semaphore;
use strict;
=head1 NAME
App::ResourceLocker::IPCSemaphore - locking shared resources using IPC::Locker
=head1 SYNOPSIS
use App;
$context = App->context();
$srs = $context->service("ResourceLocker"); # or ...
$srs = $context->shared_resource_set();
=head1 DESCRIPTION
A ResourceLocker service represents a collection of "advisory"
(or "cooperative")
resource locks. The IPCSemaphore implementation uses the IPC::Locker
distribution available on CPAN. Locking is implemented by a Locker Daemon
(lockerd), so that locking may be effectively achieved across an entire
network.
=cut
#############################################################################
# CLASS
#############################################################################
=head1 Class: App::ResourceLocker::IPCSemaphore
A ResourceLocker service represents a collection of "advisory"
(or "cooperative") resource locks.
These can be used to synchronize access to and modification
of shared resources such as are stored in a SharedDatastore.
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Generally speaking, this module only works on Unix platforms, because they
support the System V semaphore API on which the IPC::Semaphore module
is built.
The ResourceLocker may be configured with the following parameters, which
govern all locks accessed in the ResourceLocker (as per IPC::Semaphore).
semkey an 8-digit hex key (i.e. 0x1234FA78) uniquely identifying the
semaphore set (or may be "private", not shared with any other
processes, useful only for multi-threaded applications).
If the ResourceLocker needs more than one semaphore set,
it will allocation additional sets with keys incremented by
1 from this semkey.
default: 0x95EE10CC
nsems number of semaphores to get (limited by kernel settings)
in each semaphore set
default: 100
create boolean whether to create the semaphore set if it does not
exist already
default: 1
mode permissions mode with which to create the semaphore set
default: 0600
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The constructor is inherited from
L<C<App::Service>|App::Service/"new()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# lock()
#############################################################################
=head2 lock()
* Signature: $resource_name = $srs->lock($resource_pool);
* Signature: $resource_name = $srs->lock($resource_set);
* Signature: $resource_name = $srs->lock($named);
* Param: $resource_pool string
* Param: $resource_set []
* Param: resourcePool string
* Param: nonBlocking boolean
* Param: nonExclusive boolean
* Param: maxWaitTimeMS integer
* Return: $resource_name string
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$context = App->context();
$srs = $context->service("ResourceLocker");
$srs->lock("shmem01");
The lock() method on a ResourceLocker is for the purposes of cooperative
resource locking.
The "nonBlocking" option works in this implementation.
However, all locks are exclusive (the nonExclusive option is ignored).
The "maxWaitTimeMS" option is not yet implemented.
=cut
sub lock {
my ($self, $arg) = @_;
my ($resource_pool, $args);
if (ref($arg) eq "HASH") {
$resource_pool = $arg->{resourcePool};
$args = $arg;
}
elsif (ref($arg) eq "ARRAY") {
$resource_pool = $arg;
$args = {};
}
elsif (ref($arg) eq "") {
$resource_pool = $arg;
$args = {};
}
return undef if (! $resource_pool);
my (@params, $lock, $resource_names, $resource_name);
# substitute the list of items in the pool for the pool name
$resource_names = $resource_pool;
$resource_names = $self->{resourcePool}{$resource_pool}
if (defined $self->{resourcePool}{$resource_pool});
push(@params, "lock", $resource_names);
push(@params, "timeout", $self->{timeout}) if (defined $self->{timeout});
push(@params, "autounlock", $self->{autounlock}) if (defined
$self->{autounlock});
push(@params, "block", ($args->{nonBlocking} ? 0 : 1));
$lock = $self->_lock(@params);
$resource_name = $lock->lock_name();
if (defined $resource_name) {
$self->{lock}{$resource_name} = $lock; # save for later unlocking
}
return ($resource_name);
}
#############################################################################
# unlock()
#############################################################################
=head2 unlock()
* Signature: $srs->unlock($resource_name);
* Param: $resource_name string
* Return: void
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$context = App->context();
$srs = $context->service("ResourceLocker");
$srs->unlock("shmem01");
=cut
sub unlock {
my ($self, $resource_name) = @_;
my ($lock);
$lock = $self->{lock}{$resource_name};
if (defined $lock) {
$lock->unlock();
delete $self->{lock}{$resource_name};
}
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
=cut
#############################################################################
# init()
#############################################################################
=head2 init()
* Signature: $self->init();
* Param: void
* Return: void
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$self->init();
The init() method is called from within the constructor to allow the class
to customize itself.
=cut
sub init {
my ($self) = @_;
$self->{semset} = {};
$self->{semnum} = {};
$self->{semset_list} = [];
$self->{resource_name_grid} = [];
}
#############################################################################
# allocate()
#############################################################################
=head2 allocate()
* Signature: ($semset, $semnum) = $self->allocate($resource_name);
* Param: $resource_name string
* Return: $semset IPC::Semaphore
* Return: $semnum integer
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
($semset, $semnum) = $self->allocate($resource_name);
The allocate() method is called when $self->{semset}{$resource_name} is not
defined in order to allocate an appropriate ($semset, $semnum) pair for a
$resource_name.
=cut
sub allocate {
my ($self,$resource_name) = @_;
my ($semset, $semnum);
# check again to see if there is already a semaphore allocated
if (defined $self->{semset}{$resource_name}) {
$semset = $self->{semset}{$resource_name};
$semnum = $self->{semnum}{$resource_name};
return($semset, $semnum);
}
my ($semset_list, $resource_name_grid);
$semset_list = $self->{semset_list};
$resource_name_grid = $self->{resource_name_grid};
# find an available semaphore
my ($nsemset);
for ($nsemset = 0; $nsemset <= $#$semset_list; $nsemset++) {
for ($semnum = 0; $semnum <= $#$semset_list; $semnum++) {
if (!defined $resource_name_grid->[$nsemset][$semnum]) {
$resource_name_grid->[$nsemset][$semnum] = $resource_name;
$semset = $semset_list->[$nsemset];
$self->{semset}{$resource_name} = $semset;
$self->{semnum}{$resource_name} = $semnum;
return($semset, $semnum);
}
}
}
# allocate a new set of semaphores
my ($semkey, $nsems, $create, $exclusive, $mode);
$semkey = ($self->{semkey} || 0x95EE10CC);
$semkey = IPC_PRIVATE if ($semkey eq "private");
$nsems = ($self->{nsems} || 100);
$create = ($self->{create} || 1);
$exclusive = ($self->{exclusive} || 1);
$mode = ($self->{mode} || 0600);
$mode |= IPC_CREAT if ($create);
$mode |= IPC_EXCL if ($exclusive);
$semset = IPC::Semaphore->new($semkey, $nsems, $mode);
push(@$semset_list, $semset);
$nsemset = $#$semset_list;
$semnum = 0; # allocate the first one
$resource_name_grid->[$nsemset][$semnum] = $resource_name;
$self->{semset}{$resource_name} = $semset;
$self->{semnum}{$resource_name} = $semnum;
return($semset, $semnum);
}
#############################################################################
# free()
#############################################################################
=head2 free()
* Signature: $self->free($resource_name);
* Param: $resource_name string
* Return: void
* Throws: App::Exception::ResourceLocker
* Since: 0.01
Sample Usage:
$self->free($resource_name);
The free() method frees up a resource name so that its physical semaphore
may be reused for some other resource.
=cut
sub free {
my ($self, $resource_name) = @_;
}
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
L<C<App::ResourceLocker>|App::ResourceLocker>,
L<C<App::Context>|App::Context>,
L<C<App::Service>|App::Service>
=cut
1;
static int semid;
static struct sembuf lock_op, unlock_op;
int start_lib_lock()
{
int err, i, lastpid, semnum;
lock_op.sem_op = -1; /* Lock() decrements to 0 if sem value is 1 */
lock_op.sem_flg = 0; /* wait until semaphore available */
unlock_op.sem_op = 1; /* Unlock() increments sem value from 0 to 1 */
unlock_op.sem_flg = 0; /* ??? positive sem_op values never wait */
semid = semget(SEM_KEY,MAX_LOCKS,RWMODE);
if (semid == ERROR) {
semid = semget(SEM_KEY,MAX_LOCKS,RWMODE|IPC_CREAT);
if (semid == ERROR)
log(semid,"start_lib_lock():semget");
}
if (semid != ERROR) {
for (semnum=0; semnum < MAX_LOCKS; semnum++) {
lastpid = xsemctl(semid,semnum,GETPID);
if (xkill(lastpid,NULLSIG) == ERROR) {
if (xsemctl(semid,semnum,SETVAL,(char *) 1) == ERROR)
log_fcn("start_lib_lock(2):semctl",__FILE__);
}
}
}
return(semid);
}
Lock (locknum)
int locknum;
{
if (dbg(LOCK))
dbg_printf("%-5d Lock(%d)\n",getpid(),locknum);
lock_op.sem_num = locknum;
log(semop(semid,&lock_op,1),"Lock");
}
Unlock (locknum)
int locknum;
{
if (dbg(UNLOCK))
dbg_printf("%-5d Unlock(%d)\n",getpid(),locknum);
unlock_op.sem_num = locknum;
log(semop(semid,&unlock_op,1),"Unlock");
}
