#!/usr/bin/perl -w # Aliases were originally called Names. # Sessions with aliases will remain active even if they have nothing # to do. They still get SIGZOMBIE when all the other sessions run out # of things to do, so programs with aliased sessions won't run # forever. Aliases are mainly useful for creating "daemon" sessions # that can be called upon by other sessions. # This example is kind of obsolete. Session postbacks have been # created in the meantime, allowing it to totally avoid the kludgey # timer loops. use strict; use lib '../lib'; use POE; #============================================================================== # The LockDaemon package defines a session that provides simple # resource locking. This is only available within the current # process. package LockDaemon; use strict; use POE::Session; #------------------------------------------------------------------------------ # Create the LockDaemon. This illustrates non-POE objects that # register themselves with POE during construction. sub new { my $type = shift; my $self = bless { }, $type; # hello, world! print "> $self created\n"; # give this object to POE POE::Session->create( object_states => [ $self, [ qw(_start _stop lock unlock sighandler) ] ] ); # Don't let the caller have a reference. It's not very nice, but it # also prevents the caller from holding onto the reference and # possibly leaking memory. undef; } #------------------------------------------------------------------------------ # Destroy the server. This will happen after its POE::Session stops # and lets go of the object reference. sub DESTROY { my $self = shift; print "< $self destroyed\n"; } #------------------------------------------------------------------------------ # This method handles POE's standard _start message. It registers an # alias for the session, sets up signal handlers, and tells the world # what it has done. sub _start { my $kernel = $_[KERNEL]; # Set the alias. This really should check alias_set's return value, # but it's being lame. $kernel->alias_set('lockd'); # register signal handlers $kernel->sig('INT', 'sighandler'); $kernel->sig('IDLE', 'sighandler'); $kernel->sig('ZOMBIE', 'sighandler'); # hello, world! print "+ lockd started.\n"; } #------------------------------------------------------------------------------ # This method handles signals. It really only acknowledges that a # signal has been received. sub sighandler { my $signal_name = $_[ARG0]; print "@ lockd caught and handled SIG$signal_name\n"; # Returning a boolean true value indicates to the kernel that the # signal was handled. This usually means that the session will not # be stopped. return 1; } #------------------------------------------------------------------------------ # This method handles POE's standard _stop event. It cleans up after # the session by removing its alias. sub _stop { my ($object, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; $kernel->alias_remove('lockd'); print "- lockd stopped.\n"; } #------------------------------------------------------------------------------ # Attempt to acquire a lock. This implements a very basic callback # protocol. If the lock can be acquired, the caller's $success state # is invoked. If the lock fails, the caller's $failure state is # invoked. It's up to the caller to keep itself alive, most likely # with a timeout event. sub lock { my ($kernel, $heap, $sender, $lock_name, $success, $failure) = @_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2]; # if the lock already exists... if (exists $heap->{$lock_name}) { # ... check the current lock my ($owner, $time) = @{$heap->{$lock_name}}; # ... same owner? if ($owner eq $sender) { # ... ... refresh lock & succeed $heap->{$lock_name}->[1] = time(); $kernel->post($sender, $success); return 0; } # ... different owner? fail! $kernel->post($sender, $failure); return 0; } # no pre-existing lock; so acquire ok $heap->{$lock_name} = [ $sender, time() ]; $kernel->post($sender, $success); } #------------------------------------------------------------------------------ # Attempt to release a lock. This implements a very basic callback # protocol, similar to lock's. sub unlock { my ($kernel, $heap, $sender, $lock_name, $success, $failure) = @_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2]; # if the lock exists... if (exists $heap->{$lock_name}) { # ... check the existing lock my ($owner, $time) = @{$heap->{$lock_name}}; # ... same owner? if ($owner eq $sender) { # ... ... release the lock & succeed delete $heap->{$lock_name}; $kernel->post($sender, $success); return 0; } } # no lock by that name; fail $kernel->post($sender, $failure); return 0; } #============================================================================== # The LockClient package defines a session that wants to do some # things to a resource that it must hold a lock for, and some other # things when it doesn't need to hold a lock. package LockClient; use strict; use POE::Session; #------------------------------------------------------------------------------ # Create the LockClient. This also illustrates non-POE objects that # register themselves with POE during construction. The LockDaemon # constructor is better documented, though. sub new { my ($type, $name) = @_; my $self = bless { 'name' => $name }, $type; # hello, world! print "> $self created\n"; # give this object to POE POE::Session->create( object_states => [ $self, [ qw(_start _stop acquire_lock retry_acquire release_lock retry_release perform_locked_operation perform_unlocked_operation ) ], ] ); # it will manage itself, thank you undef; } #------------------------------------------------------------------------------ # Destroy the client. This will happen after its POE::Session stops # and lets go of the object reference. sub DESTROY { my $self = shift; print "< $self destroyed\n"; } #------------------------------------------------------------------------------ # This method handles POE's standard _start message. It starts the # client's main loop by first performing an operation without holding # a lock. sub _start { my ($kernel, $session, $object) = @_[KERNEL, SESSION, OBJECT]; # display some impressive output :) print "+ client $object->{'name'} started\n"; # move to the next state in the cycle $kernel->post($session, 'perform_unlocked_operation'); } #------------------------------------------------------------------------------ # This method handles POE's standard _stop message. Normally it would # clean up any resources it has allocated, but this test doesn't care. sub _stop { my $object = $_[OBJECT]; print "+ client $object->{'name'} stopped\n"; } #------------------------------------------------------------------------------ # This is a cheezy hack to keep the session alive while it waits for # the lock daemon to respond. All it does is wake up every ten # seconds and set another alarm. sub timer_loop { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "*** client $object->{'name'} alarm rang\n"; $kernel->delay('timer_loop', 10); } #------------------------------------------------------------------------------ # Attempt to acquire a lock. sub acquire_lock { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "??? client $object->{'name'} attempting to acquire lock...\n"; # retry after waiting a little while $kernel->delay('acquire_lock', 10); # uses the lock daemon's protocol $kernel->post('lockd', 'lock', 'lock name', 'perform_locked_operation', 'retry_acquire' ); } #------------------------------------------------------------------------------ # Acquire failed. Wait one second and retry. sub retry_acquire { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "--- client $object->{'name'} acquire failed... retrying...\n"; $kernel->delay('acquire_lock', 1); } #------------------------------------------------------------------------------ # Attempt to release a held lock. sub release_lock { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "??? client $object->{'name'} attempting to release lock...\n"; # retry after waiting a little while $kernel->delay('release_lock', 10); $kernel->post('lockd', 'unlock', 'lock name', 'perform_unlocked_operation', 'retry_release' ); } #------------------------------------------------------------------------------ # Release failed. Wait one second and retry. sub retry_release { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "--- client $object->{'name'} release failed... retrying...\n"; $kernel->delay('release_lock', 1); } #------------------------------------------------------------------------------ # Do something while holding the lock. sub perform_locked_operation { my ($object, $kernel) = @_[OBJECT, KERNEL]; # clear the alarm! $kernel->delay('acquire_lock'); print "+++ client $object->{'name'} acquired lock... processing...\n"; $kernel->delay('release_lock', 1); } #------------------------------------------------------------------------------ # Do something while not holding the lock. sub perform_unlocked_operation { my ($object, $kernel) = @_[OBJECT, KERNEL]; # clear the alarm! $kernel->delay('release_lock'); print "+++ client $object->{'name'} released lock... processing...\n"; $kernel->delay('acquire_lock', 1); } #============================================================================== # Create the lock daemon and five clients. Run them until someone # sends a SIGINT. package main; # start the lock daemon LockDaemon->new(); # start the clients foreach (1..5) { LockClient->new($_); } # run until it's time to stop $poe_kernel->run(); exit;