POE-Component-IKC-0.2305/0000755000076400007640000000000012157370557012724 5ustar filfilPOE-Component-IKC-0.2305/IKC.pod0000644000076400007640000001551111625750335014034 0ustar filfill=head1 NAME POE::Component::IKC -- POE Inter-Kernel Communication =head1 SYNOPSIS =head2 IKC server use POE::Component::IKC::Server; # create all your sessions POE::Component::IKC::Server->spawn( port=>30, name=>'Server' ); # more options are available $poe_kernel->run(); =head2 IKC client use POE::Component::IKC::Client; POE::Component::IKC::Client->spawn( host=>name, port=>30, name=>'Client', on_connect=>\&build); $poe_kernel->run(); sub build { # create sessions that depend on the foreign kernel. } =head2 Post a state on a foreign kernel $kernel->post('IKC', 'post', "poe://Server/session/state", $ONE_arg); =head2 The IKC is peer-to-peer. Server can post to client. $kernel->post('IKC', 'post', 'poe://Client/session/state', $ONE_arg); =head2 Call a state on a remote kernel Call semantics are impossible, because they would cause POE to block. IKC call is a bit different. It is a 'post', but with an extra RSVP parameter. $kernel->post('IKC', 'call', 'poe://Server/hello/world', $ONE_arg, 'poe:callback'); This will cause the returned value of the foreign state to be sent to state 'callback' in the current session. You may want the callback to be in another session, but I don't think this is a good idea. $kernel->post('IKC', 'call', 'poe://Server/hello/world', $ONE_arg, 'poe:/elsewhere/hi'); Note : if you use ->call('IKC'), it will return the number of foreign kernels the state was sent to. This is a handy way to find out if you are still connected to a foreign kernel. =head2 A little magic If a state is posted by a foreign kernel, $_[SENDER] is only valid during that state. However, you will be able to post back to it. $kernel->post($_[SENDER], 'something', 'the answer is foo'); The remote caller MUST have published states for them to be callable, eh? =head2 Publish / Subscribe You must publish a session's interface for it to be available to remote kernels. If you subscribe to a remote session, you may access it as if it was a local session. First, a session publishes its interfaces: $kernel->post('IKC', 'publish', 'session_alias', [qw(state1 state2 state3 state4)], ); Then a foreign kernel subscribes to it: # Look for a session on all known foreign kernels $kernel->post('IKC', 'subscribe', [qw(poe://*/session_alias/)]); # Look for a session on a specific foreign kernel $kernel->post('IKC', 'subscribe', [qw(poe://Pulse/timeserver)]); # Make sure the session has a given state $kernel->post('IKC', 'subscribe', [qw(poe://*/timeserver/connect)]); After subscription, a proxy session is created that can be accessed like any old session, though ->call() acts the same as ->post() for obvious reasons: $kernel->post('poe:/Pulse/timeserver', 'state', $arg1, $arg2...); Currently, the session alias used by post to the proxy session must be the same one as used when subscribing. Because kernels have multiple names, if you are using '*' as the kernel name when subscribing, the session alias might not be what you think it is. See L for details. Of course, attempting to post to a proxy session before it is created will be problematic. To be alerted when the proxy session is created, a callback state may be specified, $kernel->post('IKC', 'subscribe', [qw(poe://*/timeserver)], 'timeserver_subscribed'); The callback will be called with a list of all the sessions that it managed to subscribe to. You should check this list before continuing. Better yet, you could use the IKC monitor (see below). One can also let POE::Component::IKC::Client->spawn deal with all the details. POE::Component::IKC::Client->spawn( port=>31337, name=>$name, subscribe=>[qw(poe://*/timeserver)], on_connect=>\&create_me, ); 'on_connect' is only called when all the subscriptions have either been accepted. If a subscription was refused, create_ikc_client will give up. If multiple foreign kernels where quieried for a session (as is the case above), subscription is deemed to succeed if at least one foreign kernel accepts the subscription. To undo things : $kernel->post(IKC=>'retract', 'session_alias'=>[qw(states)]); $kernel->post(IKC=>'unsubscribe', [qw(poe://Pulse/timeserver)]); =head2 Monitor Say you wanted to monitor all remote kernels that connect to you: $kernel->post(IKC=>'monitor', '*'=>{register=>'some_event'}); sub some_event { my($name, $real)=@_[ARG1, ARG2]; print "- Remote kernel ", ($real ? '' : "alias "), "$name connected\n"; } Later, you want to know when a given remote session disconnects: $kernel->post(IKC=>'monitor', some_kernel=>{unregister=>'bye_bye'}); Or maybe you think a session should clean up and leave whenever IKC does. $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'other_event'}); sub other_event { # kill wheels, alarms, selects and aliases here } See L for more details. =head2 Shutdown When you feel the time is right and you want to get rid of all IKC-related sessions, just do the following: $kernel->post(IKC=>'shutdown'); And they should all disapear. At worst, some will still have registered alises, but this won't prevent the kernel from exiting. =head2 The local kernel You can post to the local kernel as if it was remote: $kernel->post(IKC=>'post', "poe://$kernel->ID/session/state'=>$ONE_arg); However, you can't currently subscribe to local sessions. I don't know how I'm going to resolve this. =head1 DESCRIPTION This is Inter-Kernel Communication for POE. It is used to get events from one POE kernel to another =head1 SEE ALSO L -- Heart of the system L -- Create a process that listens for other kernels. L -- Create a process that connects to other kernels. L -- Light weight IKC implementation for places you can't use POE, such as mod_perl. L -- Handle communcation with other kernels. L -- Proxy session that is created when you subscribe to a remote session. L -- Pure-Perl serialization method. L -- Helper routines for parsing IKC specifiers. =head1 AUTHOR Philip Gwyn =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut POE-Component-IKC-0.2305/ikc-architecture.txt0000644000076400007640000000660611625744674016727 0ustar filfilAn IKC client is a session that initiates the connection. An IKC server is a session that listens for new connections. A given kernel can have both client and server sessions. Each kernel is it's own process. This gets confusing. I tend to use remote and local kernel to designate which process i'm talking about. The client and server are nearly identical. IKC is more of a peer-to-peer protocol then a client/server protocol. After negociation, either kernel can send an event request to the other kernel. Connection flow-chart (roughly) : IKC::Server IKC::Client | | Wheel::SocketFactory | | | +--------------------------------------------+ | (when connected) | IKC::Channel::create_ikc_channel | Wheel::ReadWrite (w/ Filter::Line) | IKC::Channel does negociation | Set filter to Filter::Reference | create_ikc_responder() | Register foreign kernels | +-------------------(IKC::Client) -----------+ | | Done on_connect sub ref called | Done Data flow after Client <-> Server connection is established : Driver::SysRW Driver::SysRW Driver::SysRW Driver::SysRW | | | | Filter::Reference Filter::Reference Filter::Reference Filter::Reference | | | | Wheel::ReadWrite Wheel::ReadWrite Wheel::ReadWrite Wheel::ReadWrite | | | | IKC::Channel IKC::Channel IKC::Channel IKC::Channel | | | | +------------------+--------+---------+------------------+ | IKC::Responder | All other Sessions Channel negociation (IKC) Server Client --<-- HELLO --<-- -->-- IAM KernelName1 -->-- --<-- OK --<-- -->-- IAM OtherName1 -->-- --<-- OK --<-- ....(more kernel names).... -->-- DONE -->-- --<-- IAM KernelName2 --<-- -->-- OK -->-- --<-- IAM OtherName2 --<-- -->-- OK -->-- ....(more kernel names).... --<-- DONE --<-- --<-- FREEZER XML::Storable --<-- ... negociating what type of reference serialisation we should use -->-- NOT -->-- .... server refused --<-- FREEZER Storable --<-- -->-- OK -->-- .... server accepted --<-- WORLD --<-- -->-- UP -->-- Negociation is now over and both sides switch to Filter::Reference. NOTE : last message *has* to come from server Channel negociation (IKC0) Server Client --<-- SETUP KernelName1,KernelName2,...;FREEZER Storable --<-- -->-- SETUP KernelName1,KernelName2,...;FREEZER Storable -->-- Negociation is now over and both sides switch to Filter::Reference. POE-Component-IKC-0.2305/dev/0000755000076400007640000000000012157370557013502 5ustar filfilPOE-Component-IKC-0.2305/dev/t_specifier0000755000076400007640000000126511457365554015733 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use Data::Dumper; use POE::Component::IKC::Specifier; my($t, $d); foreach my $foo (qw(poe:kernel/session/state poe:/session/state poe:*/session poe://kernel/session/state poe://kernel/session poe:///session/state poe://host:303/session/state poe://kernel poe:state poe:/session)) { print "======== $foo\n"; $t=specifier_parse($foo); if($t) { $d=Dumper $t; $d=~s/\s+/ /g; print "$d\n"; $t=specifier_name($t); print "$t\n"; } else { print "Invalid\n"; } print "\n"; }POE-Component-IKC-0.2305/dev/client20000755000076400007640000000411411457365554014773 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Client; my $name="Client$$"; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } ### Called when we connect to the time server sub create_me { print "Creating session...\n"; POE::Session->new( _start=>sub { my($kernel)=$_[KERNEL]; $kernel->sig('USR1', 'hup'); $kernel->alias_set('me'); $kernel->post('poe://*/timeserver', 'connect', "poe://$name/me/pulse"); $kernel->yield('time'); $kernel->post('IKC', 'publish', 'me', [qw(pulse)]); }, hup=>sub { my($kernel)=$_[KERNEL]; print "Got USR1\n"; $kernel->post('poe://Pulse/timeserver', 'disconnect', "poe://$name/me/pulse"); return 1; }, # output a . when the pulse is sent # output a + if it took longer then a second to get from # the timerserver pulse=>sub { print ($_[ARG0] eq localtime() ? '.' : '+'); }, 'time'=>sub { my($kernel, $time)=@_[KERNEL, ARG0]; if($time) { print "\n------ Foreign time is $time\n"; $kernel->delay('time', 60); } else { unless($kernel->call('IKC', 'call', 'poe://*/timeserver/time', '', 'poe:/me/time')) { print "Unable to get time, exiting\n"; # $kernel->alias_remove('me'); } } }, ); } $|++; create_ikc_client( port=>31337, name=>$name, # subscribe=>[qw(poe://*/foo)], on_connect=>sub { create_ikc_client( on_connect=>\&create_me, port=>31337, name=>$name, subscribe=>[qw(poe://*/timeserver)] ); } ); print "Running client...\n"; $poe_kernel->run(); POE-Component-IKC-0.2305/dev/shut-server0000755000076400007640000000227011457365554015723 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); # BEGIN {sub POE::Kernel::TRACE_GARBAGE () { 1 }} use POE; use POE::Session; use POE::Component::IKC::Server; use POE::Component::IKC::Specifier; # Very simple server. all it does is shutdown when 'goaway' is posted create_ikc_server( unix=>($ENV{TMPDIR}||$ENV{TEMP}||'/tmp').'/userver', name=>'shut-server'); POE::Session->create( inline_states => { _start=>\&time_start, goaway=>\&goaway, _stop=>\&time_stop, } ); print "Running server for 60 seconds at most...\n"; $poe_kernel->run(); print "Server exited...\n"; ############################################# sub time_start { my($kernel, $heap, $session)=@_[KERNEL, HEAP, SESSION]; $kernel->delay('goaway', 60); $kernel->alias_set('Goaway'); $kernel->call(IKC=>'publish', Goaway=>[qw(goaway)]); } ############################################# sub goaway { my($kernel, $heap)=@_[KERNEL, HEAP]; warn "Now it's time to say good night, sleep tight\n"; $kernel->post('IKC', 'shutdown'); $kernel->delay('goaway'); } sub time_stop { warn "Time to _stop\n"; } POE-Component-IKC-0.2305/dev/client50000755000076400007640000000255111457365554015001 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Client; my $name="Client$$"; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } ### Called when we connect to the time server sub create_me { print "Creating session...\n"; POE::Session->new( _start=>sub { my($kernel)=$_[KERNEL]; warn "_start"; $kernel->sig('USR1', 'hup'); $kernel->alias_set('me'); $kernel->post('poe://*/timeserver', 'connect', "poe://$name/me/pulse"); $kernel->post('IKC', 'publish', 'me', [qw(pulse)]); }, hup=>sub { my($kernel)=$_[KERNEL]; print "Got USR1\n"; $kernel->post('poe://Pulse/timeserver', 'disconnect', "poe://$name/me/pulse"); return 1; }, # output a . when the pulse is sent # output a + if it took longer then a second to get from # the timerserver pulse=>sub { print ($_[ARG0] eq localtime() ? '.' : '+'); }, ); } $|++; create_ikc_client( port=>31337, name=>$name, subscribe=>[qw(poe://*/timeserver)], on_connect=>\&create_me, ); print "Running client...\n"; $poe_kernel->run(); POE-Component-IKC-0.2305/dev/inc-client0000755000076400007640000000306211457365554015461 0ustar filfil#!/usr/bin/perl -w use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::CATCH_EXCEPTIONS () { 1 } sub POE::Session::ASSERT_STATES () { 0 } use POE; use POE::Component::IKC::Client; use POE::Component::IKC::Responder; POE::Component::IKC::Responder->spawn; POE::Component::IKC::Client->spawn( ip => '127.0.0.1', port => 12345, name => "Client$$", on_connect => \&start_session, ); sub start_session { POE::Session->create( inline_states => { _start => sub { my ($kernel) = $_[KERNEL]; $kernel->alias_set('IncrementorClient'); $kernel->yield('start_ikc'); $kernel->delay( 'kill_everyone', 1 ); }, start_ikc => sub { my ($kernel) = $_[KERNEL]; $kernel->post( 'IKC', 'call', 'poe://Server/Incrementor/inc', undef, 'poe:get_result' ); }, get_result => sub { my ( $kernel, $heap, $arg ) = @_[ KERNEL, HEAP, ARG0 ]; print "Result: $arg\n"; unless( $heap->{shutdown} ) { $kernel->post( 'IKC', 'call', 'poe://Server/Incrementor/inc', undef, 'poe:get_result' ); } }, kill_everyone => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{shutdown} = 1; $kernel->post( IKC => 'shutdown' ); }, _stop => sub { print "Finished...\n"; exit(0) }, } ); } POE::Kernel->run(); POE-Component-IKC-0.2305/dev/server20000755000076400007640000000374211457365554015031 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Server; use POE::Component::IKC::Specifier; # Very simple time pulse session # Foreign sessions connect to it via 'connect' events and # disconect with 'disconnect'. # Every 10 seconds, a 'pulse' event is sent to connected sessions. create_ikc_server( port=>31336, # elite-- name=>'Pulse2'); POE::Session->new ( _start=>\&time_start, # _stop=>\&time_stop, 'connect'=>\&time_connect, 'disconnect'=>\&time_disconnect, 'pulse'=>\&time_pulse, ); print "Running server...\n"; $poe_kernel->run(); print "Server exited...\n"; ############################################# sub time_start { my($kernel, $session, $heap)=@_[KERNEL, SESSION, HEAP]; $heap->{listeners}={}; $kernel->alias_set('timeserver'); $kernel->delay('pulse', 10-(time%10)); $kernel->call('IKC', 'publish', 'timeserver', [qw(connect disconnect)]); # $session->option(default=>1); } ############################################# sub time_stop { my($heap)=$_[HEAP]; $heap->{listeners}={}; } ############################################# sub time_connect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "Connected $name\n"; $heap->{listeners}->{$name}=$dest; } ############################################# sub time_disconnect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "Disconnected $name\n"; delete $heap->{listeners}->{$name}; } ############################################# sub time_pulse { my($kernel, $heap)=@_[KERNEL, HEAP]; my $now=localtime; $kernel->delay('pulse', 10-(time%10)); while(my($name, $dest)=each %{$heap->{listeners}}) { print "$name -- $now\n"; $kernel->call('IKC', 'post', $dest, $now) or $kernel->yield('disconnect', $dest); } return; } POE-Component-IKC-0.2305/dev/server30000755000076400007640000000426411457365554015032 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Server; use POE::Component::IKC::Specifier; # Very simple time pulse session # Foreign sessions connect to it via 'connect' events and # disconect with 'disconnect'. # Every 10 seconds, a 'pulse' event is sent to connected sessions. create_ikc_server( port=>31337, name=>'Pulse', processes=>5, babysit=>30, verbose=>1, connections=>3); POE::Session->new ( _start=>\&time_start, _stop=>\&time_stop, 'connect'=>\&time_connect, 'disconnect'=>\&time_disconnect, 'pulse'=>\&time_pulse, 'time'=>\&time_time, ); print "$$: Running server...\n"; $poe_kernel->run(); print "$$: Server exited...\n"; ############################################# sub time_start { my($kernel, $heap)=@_[KERNEL, HEAP]; $heap->{listeners}={}; $kernel->alias_set('timeserver'); $kernel->delay('pulse', 10-(time%10)); $kernel->call('IKC', 'publish', 'timeserver', [qw(connect disconnect time)]); } ############################################# sub time_stop { my($heap)=$_[HEAP]; # warn "$$: _stop"; $heap->{listeners}={}; } ############################################# sub time_connect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "$$: Connected $name\n"; $heap->{listeners}->{$name}=$dest; } ############################################# sub time_disconnect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "$$: Disconnected $name\n"; delete $heap->{listeners}->{$name}; } ############################################# sub time_pulse { my($kernel, $heap)=@_[KERNEL, HEAP]; my $now=localtime; $kernel->delay('pulse', 10-(time%10)); # warn "$$: pluse\n"; while(my($name, $dest)=each %{$heap->{listeners}}) { print "$$: $name -- $now\n"; $kernel->call('IKC', 'post', $dest, $now) or $kernel->yield('disconnect', $dest); } return; } ############################################# sub time_time { sleep 1; print "$$: Sending time...\n"; ''.localtime(); } POE-Component-IKC-0.2305/dev/client40000755000076400007640000000504211457365554014776 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Client; my $name="Client$$"; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } ### Called when we connect to the time server sub create_me { print "Creating session...\n"; POE::Session->new( _start=>sub { my($kernel)=$_[KERNEL]; $kernel->sig('USR1', 'hup'); $kernel->alias_set('me'); $kernel->post('poe://*/timeserver', 'connect', "poe://$name/me/pulse"); $kernel->yield('pinger'); $kernel->yield('time'); $kernel->post('IKC', 'publish', 'me', [qw(pulse)]); }, hup=>sub { my($kernel)=$_[KERNEL]; print "Got USR1\n"; $kernel->post('poe://Pulse/timeserver', 'disconnect', "poe://$name/me/pulse"); return 1; }, # output a . when the pulse is sent # output a + if it took longer then a second to get from # the timerserver pulse=>sub { print ($_[ARG0] eq localtime() ? '.' : '+'); }, 'time'=>sub { my($kernel, $time)=@_[KERNEL, ARG0]; if($time) { print "\n------ Foreign time is $time\n"; $kernel->delay('time', 60); } else { print "hello\n"; unless($kernel->call('IKC', 'call', 'poe://*/timeserver/time', '', 'poe:/me/time')) { print "Unable to get time, exiting\n"; } } }, 'pinger'=>sub { my($kernel, $ret)=@_[KERNEL, ARG0]; if($ret) { print "\nping response $ret\n"; $kernel->delay('pinger', 10); } else { print "\nsending ping\n"; unless($kernel->call('IKC', 'call', 'poe://localhost:31337/IKC/ping', 'PING', 'poe:/me/pinger')) { print "Can't ping!\n"; # $kernel->delay('pinger', 1); } } } ); } $|++; create_ikc_client( ip=>'localhost', port=>31336, name=>$name, subscribe=>[qw(poe://*/timeserver)], on_connect=>\&create_me, ); print "Running client...\n"; $poe_kernel->run(); POE-Component-IKC-0.2305/dev/inc-server0000755000076400007640000000157011457365554015513 0ustar filfil#!/usr/bin/perl -w use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::CATCH_EXCEPTIONS () { 1 } sub POE::Session::ASSERT_STATES () { 1 } use POE; use POE::Component::IKC::Server; POE::Component::IKC::Server->spawn( port => 12345, name => 'Server', ); POE::Session->create( inline_states => { _start => sub { my ( $kernel, $heap ) = @_[ KERNEL, HEAP ]; my $service_name = 'Incrementor'; $kernel->alias_set($service_name); $heap->{num} = 0; $kernel->post( IKC => publish => $service_name, ['inc'] ); }, inc => sub { my ($heap) = $_[HEAP]; $heap->{num}++; print "Someone called! New value: $heap->{num}\n"; return $heap->{num}; }, _stop => sub { print "Stopping $0\n"; }, } ); POE::Kernel->run(); POE-Component-IKC-0.2305/dev/client0000755000076400007640000000605611457365554014720 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); # BEGIN { sub POE::Kernel::TRACE_EVENTS () { 1 };} use POE qw(Session); use POE::Component::IKC::Client; use POE::Component::IKC::Responder; my $NAME="Client$$"; my $first=1; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } $|++; print "Creating sessions...\n"; create_ikc_client( port=>31337, name=>$NAME, subscribe=>[qw(poe://*/timeserver)], ); POE::Session->new( _start=>sub { my($kernel)=$_[KERNEL]; $kernel->sig('USR1', 'hup'); $kernel->alias_set('me'); create_ikc_responder(); # make sure the Responder exists $kernel->post('IKC', 'publish', 'me', [qw(pulse)]); $kernel->post('IKC', 'monitor', '*', {register=>'remote_register', unregister=>'remote_unregister', subscribe=>'remote_subscribe'}); }, ### Called when we connect to the time server remote_register=>sub { my($kernel, $name, $real_name, $real)=@_[KERNEL, ARG0, ARG1, ARG2]; warn "* connection to $real_name", ($real ? '' : ' (alias)'), "\n"; return unless $real_name eq 'Pulse'; print "***** Connected to $name ($real_name)\n"; $kernel->yield('time'); }, ### Called when we connect to the time server remote_subscribe=>sub { my($kernel, $name, $real_name, $what)=@_[KERNEL, ARG0, ARG1, ARG4]; return unless $real_name eq 'Pulse'; $kernel->post('poe://*/timeserver', 'connect', "poe://$NAME/me/pulse"); print "***** Subscribed to things on $real_name\n"; }, ### Called when we disconnect to the time server remote_unregister=>sub { my($kernel, $name, $real_name, $real)=@_[KERNEL, ARG0, ARG1, ARG2]; warn "* disconnection from $real_name", ($real ? '' : ' (alias)'), "\n"; return unless $real_name eq 'Pulse'; die "****** Disconnected from $real_name\n"; }, hup=>sub { my($kernel)=$_[KERNEL]; print "Got USR1\n"; $kernel->post('poe://Pulse/timeserver', 'disconnect', "poe://$NAME/me/pulse"); return 1; }, # output a . when the pulse is sent # output a + if it took longer then a second to get from # the timerserver pulse=>sub { print ($_[ARG0] eq localtime() ? '|' : '+'); }, 'time'=>sub { my($kernel, $time)=@_[KERNEL, ARG0]; if($time) { print "\n|||||| Foreign time is $time\n"; $kernel->delay('time', 60); } else { $kernel->call('IKC', 'call', 'poe://Pulse/timeserver/time', '', 'poe:/me/time'); } }, ); print "Running client...\n"; $poe_kernel->run(); POE-Component-IKC-0.2305/dev/shut-client0000755000076400007640000000170511457365554015675 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); # BEGIN { sub POE::Kernel::TRACE_EVENTS () { 1 };} # BEGIN { sub POE::Kernel::TRACE_GARBAGE () { 1 };} use POE qw(Session); use POE::Component::IKC::Client; use POE::Component::IKC::Responder; my $NAME="Client$$"; my $first=1; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } $|++; print "Creating sessions...\n"; create_ikc_client( unix=>($ENV{TMPDIR}||$ENV{TEMP}||'/tmp').'/userver', name=>$NAME, subscribe=>[qw(poe://shut-server/Goaway)], ); POE::Session->new( _start=>sub { my($kernel)=$_[KERNEL]; $kernel->delay(short_wait=>5); }, short_wait=>sub{ my($kernel)=$_[KERNEL]; warn "telling the foo' to go away\n"; $kernel->post(Goaway=>'goaway'); } ); print "Running client...\n"; $poe_kernel->run(); print "Client stopped\n"; POE-Component-IKC-0.2305/dev/lclient0000755000076400007640000000143711457365554015072 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE::Component::IKC::ClientLite; my $name="Client$$"; my $remote=create_ikc_client( port=>21510, name=>$name, timeout=>5, ); die $POE::Component::IKC::ClientLite::error unless $remote; print "Hello\n"; $remote->post('IKC/ping', 'PING') or die $POE::Component::IKC::ClientLite::error; print "world\n"; my $ret=$remote->call('IKC/ping', 'PING') or die $POE::Component::IKC::ClientLite::error; print "Simple $ret\n"; $|++; for(my $q=0; $q<10; $q++) { print "(((($q "; $ret=$remote->call('IKC/ping', 'PING') or print '-', $POE::Component::IKC::ClientLite::error; print $ret if $ret; print "))))\n"; sleep(1); } print "\n"; POE-Component-IKC-0.2305/dev/lclient20000755000076400007640000000113711457365554015151 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE::Component::IKC::ClientLite; $|++; my @connections; my $name=$ARGV[0]||0; print "$$: Connecting $name\n"; my $remote=create_ikc_client( port=>31337, name=>"lclient2-$$-$name", timeout=>5, ); die "--$POE::Component::IKC::ClientLite::error" unless $remote; for (0..3) { my $ret; $ret=$remote->call('timeserver/time', 'PING') or print '-'.$remote->name().$POE::Component::IKC::ClientLite::error; print '(', $remote->name(), " $ret $name)\n" if $ret; } POE-Component-IKC-0.2305/dev/client30000755000076400007640000000256511457365554015004 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Client; my $name="Client$$"; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } ### Called when we connect to the time server sub create_me { print "Creating session...\n"; POE::Session->new( _start=>sub { warn "_start"; my($kernel)=$_[KERNEL]; $kernel->sig('USR1', 'hup'); $kernel->alias_set('me'); $kernel->post('poe://*/timeserver', 'connect', "poe://$name/me/pulse"); $kernel->post('IKC', 'publish', 'me', [qw(pulse)]); }, hup=>sub { my($kernel)=$_[KERNEL]; print "Got USR1\n"; $kernel->post('poe://Pulse/timeserver', 'disconnect', "poe://$name/me/pulse"); return 1; }, # output a . when the pulse is sent # output a + if it took longer then a second to get from # the timerserver pulse=>sub { print ($_[ARG0] eq localtime() ? '.' : '+'); }, ); } $|++; create_ikc_client( port=>31337, name=>$name, subscribe=>[qw(poe://*/timeserver)], on_connect=>\&create_me, ); print "Running client...\n"; $poe_kernel->run(); POE-Component-IKC-0.2305/dev/userver0000755000076400007640000000612411457365554015131 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Server; use POE::Component::IKC::Specifier; # Very simple time pulse session # Foreign sessions connect to it via 'connect' events and # disconect with 'disconnect'. # Every 10 seconds, a 'pulse' event is sent to connected sessions. create_ikc_server( unix=>($ENV{TMPDIR}||$ENV{TEMP}||'/tmp').'/userver', name=>'Pulse'); POE::Session->new ( _start=>\&time_start, # _stop=>\&time_stop, 'connect'=>\&time_connect, 'disconnect'=>\&time_disconnect, 'pulse'=>\&time_pulse, 'time'=>\&time_time, 'kernel_unregister'=>\&kernel_unregister, 'debug_register'=>\&debug_register, 'debug_unregister'=>\&debug_unregister, ); print "Running server...\n"; $poe_kernel->run(); print "Server exited...\n"; ############################################# sub time_start { my($kernel, $heap)=@_[KERNEL, HEAP]; $heap->{listeners}={}; $kernel->alias_set('timeserver'); $kernel->delay('pulse', 10-(time%10)); $kernel->call('IKC', 'publish', 'timeserver', [qw(connect disconnect time)]); $kernel->call('IKC', 'monitor', '*', { register=>'debug_register', unregister=>'debug_unregister'}); } ############################################# sub time_stop { my($heap)=$_[HEAP]; $heap->{listeners}={}; } ############################################# sub time_connect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "Connected $name ($dest)\n"; $heap->{listeners}->{$name}=$dest; $kernel->call('IKC', 'monitor', $name, { unregister=>'kernel_unregister'}); } ############################################# sub time_disconnect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "Disconnected $name\n"; delete $heap->{listeners}->{$name}; $kernel->post('IKC', 'monitor', $name); } ############################################# sub kernel_unregister { my($heap, $name, $real_name)=@_[HEAP, ARG0, ARG1]; print "$real_name went away. *snif*\n"; delete $heap->{listeners}{$name}; } ############################################# sub debug_unregister { my($heap, $name, $real)=@_[HEAP, ARG1, ARG2]; print "- Remote kernel ", ($real ? '' : "alias "), "$name went bye-bye\n"; } ############################################# sub debug_register { my($heap, $name, $real)=@_[HEAP, ARG1, ARG2]; print "- Remote kernel ", ($real ? '' : 'alias '), "$name went HELLO!\n"; } ############################################# sub time_pulse { my($kernel, $heap)=@_[KERNEL, HEAP]; my $now=localtime; $kernel->delay('pulse', 10-(time%10)); while(my($name, $dest)=each %{$heap->{listeners}}) { print "$name -- $now\n"; $kernel->call('IKC', 'post', $dest, $now) or $kernel->yield('disconnect', $dest); } return; } ############################################# sub time_time { print "Sending time...\n"; return ''.localtime(); } POE-Component-IKC-0.2305/dev/test_delete0000644000076400007640000000155011457365554015732 0ustar filfil#!/usr/bin/perl -w use strict; use POE qw(Session); my $foo=new POE::Session ( _start=>sub { print "foo start\n"; # $_[KERNEL]->alias_set('foo'); }, _stop=>sub {print "foo stop\n"; }, 'delete'=>sub { # $_[KERNEL]->alias_remove(); print "foo delete\n"; $_[KERNEL]->post($_[SENDER], 'hello'); }, ); new POE::Session ( _start=>sub { print "bar start\n"; $_[KERNEL]->alias_set('bar'); $_[KERNEL]->post($foo, 'delete')}, _stop=>sub {print "bar stop\n"; }, hello=>sub {print "bar: Hello world\n"; $_[KERNEL]->post('biff', 'hello'); } ); new POE::Session ( _start=>sub { print "biff start\n"; $_[KERNEL]->alias_set('biff');}, _stop=>sub {print "biff stop\n"; }, hello=>sub {print "biff: Hello world\n" } ); $poe_kernel->run();POE-Component-IKC-0.2305/dev/server0000755000076400007640000000615711457365554014752 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); use POE qw(Session); use POE::Component::IKC::Server; use POE::Component::IKC::Specifier; # Very simple time pulse session # Foreign sessions connect to it via 'connect' events and # disconect with 'disconnect'. # Every 10 seconds, a 'pulse' event is sent to connected sessions. create_ikc_server( port=>31337, # elite-- name=>'Pulse'); POE::Session->new ( _start=>\&time_start, # _stop=>\&time_stop, 'connect'=>\&time_connect, 'disconnect'=>\&time_disconnect, 'pulse'=>\&time_pulse, 'time'=>\&time_time, 'kernel_unregister'=>\&kernel_unregister, 'debug_register'=>\&debug_register, 'debug_unregister'=>\&debug_unregister, ); print "Running server...\n"; $poe_kernel->run(); print "Server exited...\n"; ############################################# sub time_start { my($kernel, $heap)=@_[KERNEL, HEAP]; $heap->{listeners}={}; $kernel->alias_set('timeserver'); $kernel->delay('pulse', 10-(time%10)); $kernel->call('IKC', 'publish', 'timeserver', [qw(connect disconnect time)]); $kernel->call('IKC', 'monitor', '*', { register=>'debug_register', unregister=>'debug_unregister'}); } ############################################# sub time_stop { my($heap)=$_[HEAP]; $heap->{listeners}={}; } ############################################# sub time_connect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "Connected $name ($dest)\n"; $heap->{listeners}->{$name}=$dest; $kernel->call('IKC', 'monitor', $name, { unregister=>'kernel_unregister'}); } ############################################# sub time_disconnect { my($kernel, $heap, $dest)=@_[KERNEL, HEAP, ARG0]; my $name=specifier_name($dest); print "Disconnected $name\n"; delete $heap->{listeners}->{$name}; $kernel->post('IKC', 'monitor', $name); } ############################################# sub kernel_unregister { my($heap, $name, $real_name)=@_[HEAP, ARG0, ARG1]; warn "$name == $real_name\n"; print "Remote kernel $real_name went bye-bye *snif*\n"; delete $heap->{listeners}{$name}; } ############################################# sub debug_unregister { my($heap, $name, $real)=@_[HEAP, ARG1, ARG2]; print "Remote kernel ", ($real ? '' : "alias "), "$name went bye-bye\n"; } ############################################# sub debug_register { my($heap, $name, $real)=@_[HEAP, ARG1, ARG2]; print "Remote kernel ", ($real ? '' : 'alias '), "$name went HELLO!\n"; } ############################################# sub time_pulse { my($kernel, $heap)=@_[KERNEL, HEAP]; my $now=localtime; $kernel->delay('pulse', 10-(time%10)); while(my($name, $dest)=each %{$heap->{listeners}}) { print "$name -- $now\n"; $kernel->call('IKC', 'post', $dest, $now) or $kernel->yield('disconnect', $dest); } return; } ############################################# sub time_time { print "Sending time...\n"; return ''.localtime(); } POE-Component-IKC-0.2305/dev/uclient0000755000076400007640000000610211457365554015075 0ustar filfil#!/usr/bin/perl -w use strict; use lib qw(blib/lib blib/arch); # BEGIN { sub POE::Kernel::TRACE_EVENTS () { 1 };} use POE qw(Session); use POE::Component::IKC::Client; use POE::Component::IKC::Responder; my $NAME="Client$$"; my $first=1; ### Send a request to the time-server sub server_io { my($kernel, $msg)=@_; } $|++; print "Creating sessions...\n"; create_ikc_client( unix=>($ENV{TMPDIR}||$ENV{TEMP}||'/tmp').'/userver', name=>$NAME, subscribe=>[qw(poe://*/timeserver)], ); POE::Session->new( _start=>sub { my($kernel)=$_[KERNEL]; $kernel->sig('USR1', 'hup'); $kernel->alias_set('me'); create_ikc_responder(); # make sure the Responder exists $kernel->post('IKC', 'publish', 'me', [qw(pulse)]); $kernel->post('IKC', 'monitor', '*', {register=>'remote_register', unregister=>'remote_unregister', subscribe=>'remote_subscribe'}); }, ### Called when we connect to the time server remote_register=>sub { my($kernel, $name, $real_name, $real)=@_[KERNEL, ARG0, ARG1, ARG2]; warn "* connection to $real_name", ($real ? '' : ' (alias)'), "\n"; return unless $real_name eq 'Pulse'; print "***** Connected to $name ($real_name)\n"; $kernel->yield('time'); }, ### Called when we connect to the time server remote_subscribe=>sub { my($kernel, $name, $real_name, $what)=@_[KERNEL, ARG0, ARG1, ARG4]; return unless $real_name eq 'Pulse'; $kernel->post('poe://*/timeserver', 'connect', "poe://$NAME/me/pulse"); print "***** Subscribed to things on $real_name\n"; }, ### Called when we disconnect to the time server remote_unregister=>sub { my($kernel, $name, $real_name, $real)=@_[KERNEL, ARG0, ARG1, ARG2]; warn "* disconnection from $real_name", ($real ? '' : ' (alias)'), "\n"; return unless $real_name eq 'Pulse'; die "****** Disconnected from $real_name\n"; }, hup=>sub { my($kernel)=$_[KERNEL]; print "Got USR1\n"; $kernel->post('poe://Pulse/timeserver', 'disconnect', "poe://$NAME/me/pulse"); return 1; }, # output a . when the pulse is sent # output a + if it took longer then a second to get from # the timerserver pulse=>sub { print ($_[ARG0] eq localtime() ? '|' : '+'); }, 'time'=>sub { my($kernel, $time)=@_[KERNEL, ARG0]; if($time) { print "\n|||||| Foreign time is $time\n"; $kernel->delay('time', 60); } else { $kernel->call('IKC', 'call', 'poe://Pulse/timeserver/time', '', 'poe:/me/time'); } }, ); print "Running client...\n"; $poe_kernel->run(); POE-Component-IKC-0.2305/README0000644000076400007640000000151711457365554013613 0ustar filfilThis a first draft if Inter-Kernel Communication for POE. It is intended as a point of reference for discusion of issues involved. As "Mythical Man Month" says : Plan to throw one away. You will need the latest version of POE. IKC has a sneaky way of discovering bugs and lacunae in POE :) Quick test : perl Makefile.PL make ./server & ./client ... and wait Better yet, run ./server and ./client in seperate windows. ./client should output a . every 10 seconds. Running many clients will give you an idea of the overhead :) STABILITY I use IKC full time on my sites (for example, http://www.camelot.ca/) so I'd say it is "stable enough if you know what you're doing", even if it doesn't implement my full original vision. I use IKC::ClientLite in mod_perl to talk to POE-based "application servers". -Philip Gwyn, POE-Component-IKC-0.2305/test-lite0000755000076400007640000000167311516115120014550 0ustar filfil#!/usr/bin/perl -w use strict; sub DEBUG () {0} use POE::Component::IKC::ClientLite; my $port = shift || 1337; my $name = shift || 'LiteClient'; my $norecon = shift || 0; DEBUG and warn "$$: Connect\n"; my $poe=create_ikc_client( port=>$port, name=>$name, protocol=>'IKC0' ); die $POE::Component::IKC::ClientLite::error unless $poe; DEBUG and warn "$$: call\n"; my $n=$poe->call('test/fetchQ') or die $poe->error; DEBUG and warn "$$: post_respond\n"; $n=$poe->post_respond('test/add_1'=>$n) or die $poe->error; unless( $norecon ) { DEBUG and warn "$$: disconnect\n"; $poe->{remote}{socket}->close; # test autoreconnect $poe->{protocol} = 'IKC'; # test fallback } else { sleep 1; } DEBUG and warn "$$: post\n"; $poe->post('test/here'=>$n) or die $poe->error; DEBUG and warn "$$: disconnect\n"; $poe->disconnect; # for real DEBUG and warn "$$: Client exiting\n"; POE-Component-IKC-0.2305/MANIFEST0000644000076400007640000000157112157370557014061 0ustar filfilChanges IKC/Channel.pm IKC/Client.pm IKC/ClientLite.pm IKC/Proxy.pm IKC/Responder.pm IKC/Server.pm IKC/Specifier.pm IKC/Freezer.pm IKC/LocalKernel.pm IKC/Timing.pm IKC/Protocol.pm IKC.pod IKC.pm MANIFEST Makefile.PL README TODO FUTUR ikc-architecture.txt test-client test-lite test-thunk t/00_compile.t t/00_info.t t/01_pod.t t/02_pod_coverage.t t/05_perl_freezer.t t/05_specifier.t t/10_server_client.t t/20_clientlite.t t/30_local.t t/31_concurrency.t t/32_thunk.t t/33_thunklite.t dev/client dev/client2 dev/client3 dev/client4 dev/client5 dev/lclient dev/lclient2 dev/server dev/server2 dev/server3 dev/shut-client dev/shut-server dev/inc-client dev/inc-server dev/t_specifier dev/test_delete dev/uclient dev/userver META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) POE-Component-IKC-0.2305/t/0000755000076400007640000000000012157370557013167 5ustar filfilPOE-Component-IKC-0.2305/t/30_local.t0000755000076400007640000000715311457365554014764 0ustar filfil#!/usr/bin/perl -w use strict; # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..6\n"; } use POE::Component::IKC::Server; use POE::Component::IKC::Channel; use POE::Component::IKC::Client; use POE qw(Kernel); my $loaded = 1; END {print "not ok 1\n" unless $loaded;} print "ok 1\n"; ######################### End of black magic. my $Q=2; sub DEBUG () {0} POE::Component::IKC::Server->spawn( port=>1338, name=>'Inet', aliases=>[qw(Ikc)], ); Test::Server->spawn(); Test::Client->spawn(); $poe_kernel->run(); ok(6); ########################################################### sub ok { my($n, $ok, $reason)=@_; my $not=(not defined($ok) or $ok) ? '' : "not "; if(defined $n) { if($n < $Q) { $not="not "; } elsif($n > $Q) { foreach my $i ($Q .. ($n-1)) { print "not ok $i\n"; } $Q=$n; } } my $skip=''; $skip=" # skipped: $reason" if $reason; print "${not}ok $Q$skip\n"; $Q++; } ############################################################################ package Test::Server; use strict; use POE::Session; BEGIN { *ok=\&::ok; *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package)=@_; POE::Session->create( # args=>[$qref], package_states=>[ $package=>[qw(_start _stop called shutdown)], ], ); } ########################################################### sub _start { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _start\n"; ok(2); $kernel->alias_set('test'); $kernel->call(IKC=>'publish', test=>[qw(called)]); $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'shutdown'}); } ########################################################### sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; # POE::Component::IKC::Server::__peek( 1 ); DEBUG and warn "Server: _stop\n"; } ########################################################### sub called { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _stop\n"; ok(3); return 4; } ########################################################### sub shutdown { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: shutdown\n"; $kernel->alias_remove('test'); ok(5); } ############################################################################ package Test::Client; use strict; use POE::Session; BEGIN { *ok=\&::ok; *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package)=@_; POE::Session->create( package_states=>[ $package=>[qw(_start callback)], ], ); } ########################################################### sub _start { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Client: _start\n"; $kernel->alias_set('TC'); $kernel->post(IKC=>'call', "poe://Inet/test/called", '', "poe:callback"); } ########################################################### sub callback { my($kernel, $heap, $n)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Client: callback\n"; ok($n); $kernel->alias_remove('TC'); $kernel->post(IKC=>'shutdown'); } POE-Component-IKC-0.2305/t/05_perl_freezer.t0000755000076400007640000000133611457365554016355 0ustar filfil#!/usr/bin/perl -w use strict; use Test::More tests => 8; use POE::Component::IKC::Freezer qw(freeze thaw dclone); pass( "Loaded" ); ######################### End of black magic. my $data={foo=>"bar", biff=>[qw(hello world)]}; my $str=freeze($data); ok( $str, "freeze" ); my $data2=thaw($str); ok( $data2, "thaw" ); is_deeply( $data, $data2, "Round trip" ); $data2=dclone($data); is_deeply($data, $data2, "dclone"); $data->{biffle}=$data->{biff}; $data2=dclone($data); is( $data->{biffle}, $data->{biff}, "Both" ); is_deeply($data, $data2, "dclone"); # circular reference $data->{flap}=$data->{biffle}; push @{$data->{biffle}}, $data->{flap}; $data2=dclone($data); is( $data->{biffle}[-1], $data->{biffle}, "Deeply" ); POE-Component-IKC-0.2305/t/31_concurrency.t0000755000076400007640000001634511457365554016230 0ustar filfil#!/usr/bin/perl -w use strict; use warnings; use Test::More; sub POE::Kernel::ASSERT_EVENTS { 1 } my $N = 10; plan tests => 4+5*$N; use POE::Component::IKC::Server; use POE::Component::IKC::Channel; use POE::Component::IKC::Client; use POE::Wheel::Run; use POE qw(Kernel); pass( "loaded" ); sub DEBUG () { 0 } DEBUG and print "Starting servers...\n"; my $port = POE::Component::IKC::Server->spawn( port => 0, name => 'Inet', aliases => [qw(Ikc)], concurrency => 4 ); Test::Runner->spawn( $port, $N ); $poe_kernel->run(); pass( "Sane shutdown" ); ############################################################################ package Test::Runner; use strict; use Config; use POE::Session; BEGIN { *ok=\&::ok; *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package, $port, $N)=@_; POE::Session->create( args=>[$port, $N], package_states=>[ $package=>[qw(_start _stop posted called method lite_register lite_unregister done shutdown do_child timeout fetchQ add_1 add_n here child_stdout child_stderr sig_child )], ], ); } ########################################################### sub _start { my($kernel, $heap, $port, $N)=@_[KERNEL, HEAP, ARG0, ARG1]; DEBUG and warn "Server: _start\n"; ::pass( '_start' ); $kernel->alias_set('test'); $kernel->call(IKC=>'publish', test=>[qw(posted called method done fetchQ add_1 add_n here )]); $heap->{port} = $port; $heap->{N} = $N; $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'shutdown'}); # ::diag( "Launch $N clients" ); foreach ( 1 .. $N ) { $kernel->call( $_[SESSION], do_child=>'lite'); } } ########################################################### sub do_child { my($kernel, $heap, $type)=@_[KERNEL, HEAP, ARG0]; my $wheel = POE::Wheel::Run->new( Program => sub { t::ChildLite->run( $heap->{port}, $type ) }, StdoutEvent => 'child_stdout', StderrEvent => 'child_stderr' ); my $pid = $wheel->PID; my $name = "\u$type${pid}Client"; $kernel->sig_child( $pid => 'sig_child' ); $kernel->delay(timeout=>60); $kernel->post(IKC=>'monitor', $name=>{ register=>'lite_register', unregister=>'lite_unregister' }); $heap->{W}{$wheel->ID} = $wheel; return; } sub sig_child { my( $heap, $pid ) = @_[ HEAP, ARG0 ]; delete $heap->{W}{$pid}; return; } sub child_stdout { my( $heap, $input, $wid ) = @_[ HEAP, ARG0, ARG1 ]; print "$input\n"; } sub child_stderr { my( $heap, $input, $wid ) = @_[ HEAP, ARG0, ARG1 ]; print STDERR "$input\n"; } ########################################################### sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _stop ($$)\n"; # ::pass('_stop'); } ########################################################### sub posted { my($kernel, $heap, $type)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: posted $heap->{q}\n"; ::is($type, 'posted', 'posted'); } ########################################################### sub called { my($kernel, $heap, $type)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: called $heap->{q}\n"; ::is($type, 'called', 'called'); } ########################################################### sub method { my($kernel, $heap, $sender, $type)=@_[KERNEL, HEAP, SENDER, ARG0]; $type = $type->{type} if ref $type; DEBUG and warn "Server: method type=$type q=$heap->{q}\n"; ::is($type, 'method', 'method'); $kernel->post($sender, 'YOW'); } ########################################################### sub done { my($kernel, $heap)=@_[KERNEL, HEAP]; DEBUG and warn "Server: done\n"; ::pass( 'done' ); } ########################################################### sub fetchQ { my($kernel, $heap)=@_[KERNEL, HEAP]; ::pass( 'fetchQ' ); return 6+1; } ########################################################### sub add_1 { my($kernel, $heap, $args)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "$$: add_1"; my($n, $pb)=@$args; DEBUG and warn "$$: foo $n"; ::is($n, 7, "Good call"); $kernel->yield('add_n', $n, 1, $pb); } ########################################################### sub add_n { my($kernel, $n, $q, $pb)=@_[KERNEL, ARG0, ARG1, ARG2]; DEBUG and warn "$$: add_n $n+$q"; $kernel->post(IKC=>'post', $pb=>$n+$q); } ########################################################### sub here { my($kernel, $n)=@_[KERNEL, ARG0]; DEBUG and warn "$$: here $n"; ::is( $n, 8, "Nice" ); } ########################################################### sub lite_register { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $heap->{connected}++; ok( ($heap->{connected} <= 4), "Max 4 concurrent connections ($heap->{connected})" ); DEBUG and warn "Server: lite_register\n"; # ::is($name, 'InetClient'); } ########################################################### sub lite_unregister { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $heap->{connected}--; DEBUG and warn "Server: lite_unregister ($name)"; ok( ( $heap->{connected} >= 0 ), "Never less then zero ($heap->{connected})" ); $kernel->delay('timeout'); $heap->{connections}++; if( $heap->{connections} == $heap->{N} ) { delete $heap->{W}; $kernel->post( IKC=>"shutdown" ); } } ########################################################### sub shutdown { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $kernel->alias_remove('test'); DEBUG and warn "Server: shutdown\n"; ::pass('shutdown'); } ########################################################### sub timeout { my($kernel)=$_[KERNEL]; die "Server: Timedout waiting for child process.\n"; $kernel->post(IKC=>'shutdown'); } ############################################################################### package t::ChildLite; use strict; use warnings; sub DEBUG () {0} use POE::Component::IKC::ClientLite; sub run { my( $package, $port, $type ) = @_; $port ||= 1337; $type ||= 'lite'; my $name = "\u$type$$".'Client'; DEBUG and warn "$$: Connect\n"; my $poe=create_ikc_client( port=>$port, name=>$name, ); die $POE::Component::IKC::ClientLite::error unless $poe; DEBUG and warn "$$: call\n"; my $n=$poe->call('test/fetchQ') or die $poe->error; DEBUG and warn "$$: post_respond\n"; $n=$poe->post_respond('test/add_1'=>$n) or die $poe->error; DEBUG and warn "$$: post\n"; $poe->post('test/here'=>$n) or die $poe->error; DEBUG and warn "$$: disconnect\n"; $poe->disconnect; # for real DEBUG and warn "$$: Client exiting\n"; } __END__ POE-Component-IKC-0.2305/t/05_specifier.t0000755000076400007640000000545411457365554015647 0ustar filfil#!/usr/bin/perl -w # $Id$ use strict; use Test::More ( tests => 18 ); use POE::Component::IKC::Specifier; my @tests = ( [ 'session/state', { kernel => '', session => 'session', state => 'state' } ], [ 'state', { kernel => '', session => '', state => 'state' } ], [ '//kernel/session/state', { kernel => 'kernel', session => 'session', state => 'state' } ], [ '//*/session/state', { kernel => '*', session => 'session', state => 'state' } ], [ 'poe://kernel/session/state', { kernel => 'kernel', session => 'session', state => 'state', } ], [ 'poe://kernel/session', { kernel => 'kernel', session => 'session', state => '' } ], [ 'poe://kernel', { kernel => 'kernel', session => '', state => '' } ], [ 'poe:/session/state', { kernel => '', session => 'session', state => 'state' } ], [ 'poe:state', { kernel => '', session => '', state => 'state' } ], [ 'poe://*/session/state', { kernel => '*', session => 'session', state => 'state' } ], [ 'session/state?args', { kernel => '', session => 'session', state => 'state', args => 'args', } ], [ 'state?args', { kernel => '', session => '', state => 'state', args => 'args' } ], [ '//kernel/session/state?args', { kernel => 'kernel', session => 'session', state => 'state', args => 'args' } ], [ '//*/session/state?args', { kernel => '*', session => 'session', state => 'state', args => 'args' } ], [ 'poe://kernel/session/state?args', { kernel => 'kernel', session => 'session', state => 'state', args => 'args' } ], [ 'poe:/session/state?args', { kernel => '', session => 'session', state => 'state', args => 'args' } ], [ 'poe:state?args', { kernel => '', session => '', state => 'state', args => 'args' } ], [ 'poe://*/session/state?args', { kernel => '*', session => 'session', state => 'state', args => 'args' } ], ); foreach my $test ( @tests ) { my $out = specifier_parse( $test->[0] ); is_deeply( $out, $test->[1] ); } POE-Component-IKC-0.2305/t/00_compile.t0000644000076400007640000000103111622264324015264 0ustar filfil#!/usr/bin/perl use strict; use Test::More tests => 11; use_ok( 'POE::Component::IKC' ); use_ok( 'POE::Component::IKC::Specifier' ); use_ok( 'POE::Component::IKC::ClientLite' ); use_ok( 'POE::Component::IKC::Freezer' ); use_ok( 'POE::Component::IKC::Proxy' ); use_ok( 'POE::Component::IKC::Channel' ); use_ok( 'POE::Component::IKC::LocalKernel' ); use_ok( 'POE::Component::IKC::Responder' ); use_ok( 'POE::Component::IKC::Server' ); use_ok( 'POE::Component::IKC::Timing' ); package other; ::use_ok( 'POE::Component::IKC::Client' ); POE-Component-IKC-0.2305/t/00_info.t0000644000076400007640000000051711625745210014600 0ustar filfil#!/usr/bin/perl use strict; use warnings; use Test::More tests => 1; use_ok('POE'); eval "use POE::Test::Loops"; $POE::Test::Loops::VERSION = "doesn't seem to be installed" if $@; # idea from Test::Harness, thanks! diag( "POE $POE::VERSION, ", "POE::Test::Loops $POE::Test::Loops::VERSION, ", "Perl $], ", "$^X on $^O" ); POE-Component-IKC-0.2305/t/02_pod_coverage.t0000755000076400007640000000246611457365554016330 0ustar filfil#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; plan tests => 4; pod_coverage_ok( "POE::Component::IKC::Responder", { also_private => [ qr/^(DEBUG|do_you_have|inform_monitors|post2|raw_message|register_channel|remote_error|request|sig_INT)$/ ], }, "POE::Component::IKC::Responder, ignoring private functions", ); pod_coverage_ok( "POE::Component::IKC::Client", { also_private => [ qr/^(DEBUG|connected|error|shutdown)$/ ], }, "POE::Component::IKC::Client, ignoring private functions", ); pod_coverage_ok( "POE::Component::IKC::Server", { also_private => [ qr/^(sig|DEBUG)_.+$/, qr/^(DEBUG|WSAEAFNOSUPPORT|accept|check_kernel|error|fork|retry|rogues|waste_time)$/ ], }, "POE::Component::IKC::Server, ignoring private functions", ); pod_coverage_ok( "POE::Component::IKC::ClientLite", { also_private => [ qr/^(DEBUG|spawn)$/ ], }, "POE::Component::IKC::ClientLite, ignoring private functions", ); POE-Component-IKC-0.2305/t/33_thunklite.t0000755000076400007640000001701311457365554015700 0ustar filfil#!/usr/bin/perl -w # # Test the new reused thunks # use strict; use warnings; use Test::More; sub POE::Kernel::ASSERT_EVENTS { 1 } sub POE::Component::IKC::OLD_PROXY_SENDER { 0 } my $N = 1; plan tests => 5+5*$N; use POE::Component::IKC::Server; use POE::Component::IKC::Channel; use POE::Component::IKC::Client; use POE::Wheel::Run; use POE qw(Kernel); pass( "loaded" ); sub DEBUG () { 0 } DEBUG and print "Starting servers...\n"; my $port = POE::Component::IKC::Server->spawn( port => 0, name => 'Inet', aliases => [qw(Ikc)] ); Test::Runner->spawn( $port, $N ); $poe_kernel->run(); pass( "Sane shutdown" ); ############################################################################ package Test::Runner; use strict; use Config; use POE::Session; BEGIN { *ok=\&::ok; *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package, $port, $N)=@_; POE::Session->create( args=>[$port, $N], package_states=>[ $package=>[qw(_start _stop other_register other_unregister done shutdown do_child timeout post1 post2 post2b post3 done child_stdout child_stderr sig_child )], ], ); } ########################################################### sub _start { my($kernel, $heap, $port, $N)=@_[KERNEL, HEAP, ARG0, ARG1]; DEBUG and warn "Server: _start\n"; ::pass( '_start' ); $kernel->alias_set('test'); $kernel->call(IKC=>'publish', test=>[qw( post1 post2 post2b post3 done )] ); $heap->{port} = $port; $heap->{N} = $N; $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'shutdown'}); # ::diag( "Launch $N clients" ); foreach ( 1 .. $N ) { $kernel->call( $_[SESSION], do_child=>'thunk'); } } ########################################################### sub do_child { my($kernel, $heap, $type)=@_[KERNEL, HEAP, ARG0]; my $wheel = POE::Wheel::Run->new( Program => sub { t::ChildThunk->run( $heap->{port}, $type ) }, StdoutEvent => 'child_stdout', StderrEvent => 'child_stderr' ); my $pid = $wheel->PID; my $name = "\u$type${pid}Client"; $kernel->sig_child( $pid => 'sig_child' ); $kernel->delay(timeout=>60); $kernel->post(IKC=>'monitor', $name=>{ register=>'other_register', unregister=>'other_unregister' }); $heap->{W}{$wheel->ID} = $wheel; $heap->{P}{$wheel->PID} = $wheel->ID; return; } sub sig_child { my( $heap, $sig, $pid ) = @_[ HEAP, ARG0, ARG1 ]; DEBUG and warn "sig_child $pid"; my $wid = delete $heap->{P}{$pid}; delete $heap->{W}{$wid}; return; } sub child_stdout { my( $heap, $input, $wid ) = @_[ HEAP, ARG0, ARG1 ]; print "$input\n"; } sub child_stderr { my( $heap, $input, $wid ) = @_[ HEAP, ARG0, ARG1 ]; print STDERR "$input\n"; } ########################################################### sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _stop ($$)\n"; # ::pass('_stop'); } ########################################################### sub other_register { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $heap->{connected}++; DEBUG and warn "Server: other_register\n"; # ::is($name, 'InetClient'); } ########################################################### sub other_unregister { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $heap->{connected}--; DEBUG and warn "Server: other_unregister ($name)"; ok( ( $heap->{connected} >= 0 ), "Never less then zero ($heap->{connected})" ); $kernel->delay('timeout'); $heap->{connections}++; if( $heap->{connections} == $heap->{N} ) { # delete $heap->{W}; $kernel->post( IKC=>"shutdown" ); } } ########################################################### sub shutdown { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $kernel->alias_remove('test'); DEBUG and warn "Server: shutdown\n"; ::pass('shutdown'); } ########################################################### sub timeout { my($kernel)=$_[KERNEL]; die "Server: Timedout waiting for child process.\n"; $kernel->post(IKC=>'shutdown'); } ########################################################### sub post1 { my($kernel, $heap, $arg)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: post1 $arg\n"; $heap->{sender} = $_[SENDER]->ID; $kernel->post( $_[SENDER], resp1 => $arg ); } ########################################################### sub post2 { my($kernel, $sender, $heap, $arg)=@_[KERNEL, SENDER, HEAP, ARG0]; DEBUG and warn "Server: post2 $arg\n"; ::is( $sender->ID, $heap->{sender}, "Same thunk" ); $kernel->refcount_increment( $sender->ID, "hold on" ); $kernel->yield( 'post2b', $arg ); } ########################################################### sub post2b { my( $kernel, $heap, $arg ) = @_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: post2b $arg\n"; $kernel->post( $heap->{sender}, resp2 => $arg ); } ########################################################### sub post3 { my($kernel, $heap, $sender, $arg)=@_[KERNEL, HEAP, SENDER, ARG0]; ::isnt( $sender->ID, $heap->{sender}, "New thunk" ); $heap->{sender2} = $sender->ID; $kernel->post($sender, resp3 => $arg); } ########################################################### sub done { my($kernel, $heap, $sender)=@_[KERNEL, HEAP, SENDER]; ::isnt( $sender->ID, $heap->{sender}, "Not first thunk" ); ::is( $sender->ID, $heap->{sender2}, "2nd thunk" ); $kernel->refcount_decrement( $heap->{sender}, "hold on" ); DEBUG and warn "Server: done\n"; ::pass( 'done' ); } ############################################################################### package t::ChildThunk; use strict; use warnings; sub DEBUG () {0} use POE::Component::IKC::ClientLite; sub run { my( $package, $port, $type ) = @_; $port ||= 1337; $type ||= 'thunk'; my $name = "\u$type$$".'Client'; DEBUG and warn "$$: Connect\n"; my $poe=create_ikc_client( port=>$port, name=>$name, ); die $POE::Component::IKC::ClientLite::error unless $poe; DEBUG and warn "$$: post1\n"; $poe->post('test/post1', "the") or die $poe->error; DEBUG and warn "$$: resp1\n"; my( $n ) = $poe->responded( 'resp1' ); defined( $n ) or die $poe->error; $n eq 'the' or die "No! n=$n"; DEBUG and warn "$$: post2\n"; $poe->post('test/post2', "wizard") or die $poe->error; DEBUG and warn "$$: resp2\n"; ( $n ) = $poe->responded( 'resp2' ); defined( $n ) or die $poe->error; $n eq 'wizard' or die "No! n=$n"; DEBUG and warn "$$: post3\n"; $poe->post('test/post3', "walks bye") or die $poe->error; DEBUG and warn "$$: resp3\n"; ( $n ) = $poe->responded( 'resp3' ); defined( $n ) or die $poe->error; $n eq 'walks bye' or die "No! n=$n"; DEBUG and warn "$$: done\n"; $poe->post('test/done', "walks bye") or die $poe->error; DEBUG and warn "$$: disconnect\n"; $poe->disconnect; # for real DEBUG and warn "$$: Client exiting\n"; } __END__ POE-Component-IKC-0.2305/t/01_pod.t0000755000076400007640000000025611457365554014447 0ustar filfil#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); POE-Component-IKC-0.2305/t/20_clientlite.t0000755000076400007640000001150111516115216015775 0ustar filfil#!/usr/bin/perl -w use strict; # sub POE::Kernel::ASSERT_EVENTS { 1 } # sub POE::Kernel::TRACE_REFCNT { 1 } use Test::More tests => 11; use POE::Component::IKC::ClientLite; use POE::Component::IKC::Server; use POE::Component::IKC::Responder; use Data::Dumper; use POE qw(Kernel); pass( 'loaded' ); ######################### End of black magic. sub DEBUG () {0} # try finding a freezer my $p= POE::Component::IKC::ClientLite::_default_freezer(); ok($p, "Default freezer"); # try loading freezer my($f, $t)= POE::Component::IKC::ClientLite::_get_freezer('POE::Component::IKC::Freezer'); ok(($f and $t), "Loaded a freezer"); POE::Component::IKC::Responder->spawn; my $port = POE::Component::IKC::Server->spawn( protocol=>'IKC0', port=>0, name=>'Inet', aliases=>[qw(Ikc)], ); DEBUG and print "Test server $$\n"; Test::Server->spawn( $port ); $poe_kernel->run(); pass( "Sane shutdown" ); ############################################################################ package Test::Server; use strict; use Config; use POE::Session; BEGIN { *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package, $port)=@_; POE::Session->create( args=>[$port], package_states=>[ $package=>[qw(_start _stop fetchQ add_1 add_n here lite_register lite_unregister shutdown do_child timeout sig_child )], ], ); } ########################################################### sub _start { my($kernel, $heap, $port)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Test server: _start\n"; ::pass('_start'); $kernel->alias_set('test'); $kernel->call(IKC=>'publish', test=>[qw(fetchQ add_1 here)]); $kernel->post(IKC=>'monitor', 'LiteClient'=>{ register=>'lite_register', unregister=>'lite_unregister' }); $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'shutdown'}); $kernel->delay(do_child=>1, 'lite', $port); } ########################################################### sub do_child { my($kernel, $type, $port)=@_[KERNEL, ARG0, ARG1]; my $pid=fork(); die "Can't fork: $!\n" unless defined $pid; if($pid) { # parent $kernel->sig_child( $pid => 'sig_child' ); $kernel->delay(timeout=>60); return; } my $exec="$Config{perlpath} -I./blib/arch -I./blib/lib -I$Config{archlib} -I$Config{privlib} test-$type $port"; # warn $exec; exec $exec; die "Couldn't exec $exec: $!\n"; } sub sig_child { return; } ########################################################### sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Test server: _stop\n"; ::pass("_stop"); } ########################################################### my $count=0; sub lite_register { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Test server: lite_register\n"; return if $count++; ::is($name, 'LiteClient', 'LiteClient'); } ########################################################### sub lite_unregister { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Test server: lite_unregister count=$count\n"; return if $count==1; ::is($name, 'LiteClient', 'LiteClient'); $kernel->delay('timeout'); # set in do_child $kernel->post(IKC=>'shutdown'); } ########################################################### sub shutdown { my($kernel)=$_[KERNEL]; $kernel->alias_remove('test'); DEBUG and warn "Test server: shutdown\n"; # use YAML qw(Dump); # use Data::Dumper; # warn Dumper $kernel; } ########################################################### sub fetchQ { my($kernel, $heap)=@_[KERNEL, HEAP]; ::pass( 'fetchQ' ); return 6+1; } ########################################################### sub add_1 { my($kernel, $heap, $args)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "$$: add_1"; my($n, $pb)=@$args; DEBUG and warn "$$: foo $n"; ::is($n, 7, "Good call"); # 7 $kernel->yield('add_n', $n, 1, $pb); } ########################################################### sub add_n { my($kernel, $n, $q, $pb)=@_[KERNEL, ARG0, ARG1, ARG2]; DEBUG and warn "$$: add_n $n+$q"; $kernel->post(IKC=>'post', $pb=>$n+$q); } ########################################################### sub here { my($kernel, $n)=@_[KERNEL, ARG0]; DEBUG and warn "$$: here $n"; ::is( $n, 8, "Nice" ); # 8 } ########################################################### sub timeout { my($kernel)=$_[KERNEL]; warn "Test server: Timedout waiting for child process.\n"; $kernel->post(IKC=>'shutdown'); } POE-Component-IKC-0.2305/t/32_thunk.t0000755000076400007640000001222511625742424015011 0ustar filfil#!/usr/bin/perl -w # # Test the new reused thunks # use strict; use warnings; use Test::More; sub POE::Kernel::ASSERT_EVENTS { 1 } sub POE::Component::IKC::OLD_PROXY_SENDER { 0 } my $N = 1; plan tests => 4+5*$N; use POE::Component::IKC::Server; use POE::Component::IKC::Channel; use POE::Component::IKC::Client; use POE::Wheel::Run; use POE qw(Kernel); pass( "loaded" ); sub DEBUG () { 0 } DEBUG and print "Starting servers...\n"; my $port = POE::Component::IKC::Server->spawn( port => 0, name => 'Inet', aliases => [qw(Ikc)] ); Test::Runner->spawn( $port, $N ); $poe_kernel->run(); pass( "Sane shutdown" ); ############################################################################ package Test::Runner; use strict; use Config; use POE::Session; BEGIN { *ok=\&::ok; *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package, $port, $N)=@_; POE::Session->create( args=>[$port, $N], package_states=>[ $package=>[qw(_start _stop done shutdown do_child timeout post1 post2 post2b post3 done child_stdout child_stderr sig_child )], ], ); } ########################################################### sub _start { my($kernel, $heap, $port, $N)=@_[KERNEL, HEAP, ARG0, ARG1]; DEBUG and warn "Server: _start\n"; ::pass( '_start' ); $kernel->alias_set('test'); $kernel->call(IKC=>'publish', test=>[qw( post1 post2 post2b post3 done )] ); $heap->{port} = $port; $heap->{N} = $N; $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'shutdown'}); # ::diag( "Launch $N clients" ); foreach ( 1 .. $N ) { $kernel->call( $_[SESSION], do_child=>'thunk'); } } ########################################################### sub do_child { my($kernel, $heap, $type)=@_[KERNEL, HEAP, ARG0]; my $exec="$Config{perlpath} -I./blib/arch -I./blib/lib -I$Config{archlib} -I$Config{privlib} " . "test-$type $type $heap->{port}"; my $wheel = POE::Wheel::Run->new( Program => $exec, StdoutEvent => 'child_stdout', StderrEvent => 'child_stderr' ); my $pid = $wheel->PID; $kernel->sig_child( $pid => 'sig_child' ); $kernel->delay(timeout=>60); $heap->{W}{$wheel->ID} = $wheel; $heap->{P}{$wheel->PID} = $wheel->ID; return; } sub sig_child { my( $heap, $sig, $pid ) = @_[ HEAP, ARG0, ARG1 ]; DEBUG and warn "sig_child $pid"; my $wid = delete $heap->{P}{$pid}; delete $heap->{W}{$wid}; return; } sub child_stdout { my( $heap, $input, $wid ) = @_[ HEAP, ARG0, ARG1 ]; print "$input\n"; } sub child_stderr { my( $heap, $input, $wid ) = @_[ HEAP, ARG0, ARG1 ]; print STDERR "$input\n"; } ########################################################### sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _stop ($$)\n"; } ########################################################### sub shutdown { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $kernel->alias_remove('test'); DEBUG and warn "Server: shutdown\n"; ::pass('shutdown'); $kernel->delay('timeout'); } ########################################################### sub timeout { my($kernel)=$_[KERNEL]; die "Server: Timedout waiting for child process.\n"; $kernel->post(IKC=>'shutdown'); $kernel->delay('timeout'); } ########################################################### sub post1 { my($kernel, $heap, $arg)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: post1 $arg\n"; $heap->{sender} = $_[SENDER]->ID; $kernel->post( $_[SENDER], resp1 => $arg ); } ########################################################### sub post2 { my($kernel, $sender, $heap, $arg)=@_[KERNEL, SENDER, HEAP, ARG0]; DEBUG and warn "Server: post2 $arg\n"; ::is( $sender->ID, $heap->{sender}, "Same thunk" ); $kernel->refcount_increment( $sender->ID, "hold on" ); $kernel->yield( 'post2b', $arg ); } ########################################################### sub post2b { my( $kernel, $heap, $arg ) = @_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: post2b $arg\n"; $kernel->post( $heap->{sender}, resp2 => @$arg ); } ########################################################### sub post3 { my($kernel, $heap, $sender, $arg)=@_[KERNEL, HEAP, SENDER, ARG0]; ::isnt( $sender->ID, $heap->{sender}, "New thunk" ); $heap->{sender2} = $sender->ID; $kernel->post($sender, resp3 => $arg); } ########################################################### sub done { my($kernel, $heap, $sender)=@_[KERNEL, HEAP, SENDER]; ::isnt( $sender->ID, $heap->{sender}, "Not first thunk" ); ::is( $sender->ID, $heap->{sender2}, "2nd thunk" ); $kernel->refcount_decrement( $heap->{sender}, "hold on" ); DEBUG and warn "Server: done\n"; ::pass( 'done' ); $kernel->post(IKC=>'shutdown'); } __END__ POE-Component-IKC-0.2305/t/10_server_client.t0000755000076400007640000001774511625742303016530 0ustar filfil#!/usr/bin/perl -w use strict; use Test::More tests => 44; sub POE::Kernel::ASSERT_EVENTS { 1 } use POE::Component::IKC::Server; use POE::Component::IKC::Channel; use POE::Component::IKC::Client; use POE qw(Kernel); pass( "loaded $$" ); sub DEBUG () { 0 } my $Q=2; my %OK; my $WIN32=1 if $^O eq 'MSWin32'; DEBUG and print "Starting servers...\n"; # Note : IKC0 for Unix test and IKC for Inet test means we can test # the fallback mechanism. unless($WIN32) { POE::Component::IKC::Server->spawn( unix=>($ENV{TMPDIR}||$ENV{TEMP}||'/tmp').'/IKC-test.pl', name=>'Unix', protocol=>'IKC0' ); } my $port = POE::Component::IKC::Server->spawn( port=>0, name=>'Inet', aliases=>[qw(Ikc)], protocol=>'IKC' ); ok( $port, "Got the port number" ) or die; Test::Server->spawn( $port ); $poe_kernel->run(); pass( "Sane shutdown" ); ############################################################################ package Test::Server; use strict; use Config; use POE::Session; BEGIN { *DEBUG=\&::DEBUG; } ########################################################### sub spawn { my($package, $port )=@_; POE::Session->create( args=>[$port], package_states=>[ $package=>[qw(_start _stop posted called method unix_register unix_unregister inet_register inet_unregister ikc_register ikc_unregister done shutdown do_child timeout sig_child )], ], ); } ########################################################### sub _start { my($kernel, $heap, $port)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _start\n"; ::pass( '_start' ); $kernel->alias_set('test'); $kernel->call(IKC=>'publish', test=>[qw(posted called method done)]); $heap->{port} = $port; my $published=$kernel->call(IKC=>'published', 'test'); # die Denter $published; ::ok( (ref $published eq 'ARRAY' and @$published==4), "Published 4 events" ); $published=$kernel->call(IKC=>'published'); ::ok((ref $published eq 'HASH' and 2==keys %$published), "2 sessions published something"); unless($WIN32) { $kernel->post(IKC=>'monitor', 'UnixClient'=>{ register=>'unix_register', unregister=>'unix_unregister' }); $kernel->post(IKC=>'monitor', 'Unix0Client'=>{ register=>'unix_register', unregister=>'unix_unregister' }); } $kernel->post(IKC=>'monitor', 'InetClient'=>{ register=>'inet_register', unregister=>'inet_unregister' }); $kernel->post(IKC=>'monitor', 'Inet0Client'=>{ register=>'inet_register', unregister=>'inet_unregister' }); $kernel->post(IKC=>'monitor', 'IkcClient'=>{ register=>'ikc_register', unregister=>'ikc_unregister' }); $kernel->post(IKC=>'monitor', 'Ikc0Client'=>{ register=>'ikc_register', unregister=>'ikc_unregister' }); $kernel->post(IKC=>'monitor', '*'=>{shutdown=>'shutdown'}); my @todo; unless($WIN32) { push @todo, qw( unix unix0 ); } else { SKIP: { ::skip( "win32 doesn't have UNIX domain sockets", 12 ); } } push @todo, qw( inet inet0 ), qw( ikc ikc0 ); $heap->{todo} = \@todo; $kernel->yield('do_child'); } ########################################################### sub do_child { my($kernel, $heap)=@_[KERNEL, HEAP]; my $type = shift @{ $heap->{todo} }; unless( $type ) { DEBUG and warn "Nothing more todo"; $kernel->delay('timeout'); $kernel->post(IKC=>'shutdown'); return; } my $pid=fork(); die "Can't fork: $!\n" unless defined $pid; if($pid) { # parent $kernel->sig_child( $pid => 'sig_child' ); $kernel->delay(timeout=>60); return; } $kernel->has_forked if $kernel->can( 'has_forked' ); my $exec="$Config{perlpath} -I./blib/arch -I./blib/lib -I$Config{archlib} -I$Config{privlib} test-client $type $heap->{port}"; DEBUG and warn "Running $exec"; exec $exec; die "Couldn't exec $exec: $!\n"; } sub sig_child { return; } ########################################################### sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: _stop ($$)\n"; ::pass('_stop'); } ########################################################### sub posted { my($kernel, $heap)=@_[KERNEL, HEAP]; my($type, $remote)=@{ $_[ARG0] }; DEBUG and warn "Server: posted $heap->{q}\n"; # 6, 12, 18 ::is($type, 'posted', "posted $remote"); } ########################################################### sub called { my($kernel, $heap, $type)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Server: called $heap->{q}\n"; # 7, 13, 19 ::is($type, 'called', 'called'); } ########################################################### sub method { my($kernel, $heap, $sender, $type)=@_[KERNEL, HEAP, SENDER, ARG0]; $type = $type->{type} if ref $type; DEBUG and warn "Server: method type=$type q=$heap->{q}\n"; # 8, 14, 20 ::is($type, 'method', 'method'); $kernel->post($sender, 'YOW'); } ########################################################### sub done { my($kernel, $heap)=@_[KERNEL, HEAP]; # 9, 15, 21 DEBUG and warn "Server: done\n"; ::pass( 'done' ); } ########################################################### sub unix_register { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: unix_register\n"; _is_client( 'Unix', $name, 'Register' ); } sub _is_client { my( $type, $name, $action ) = @_; my $want = $type; $want .= '0' if $name =~ /0/; $want .= 'Client'; ::is($name, $want, "$action $want" ); } ########################################################### sub unix_unregister { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: unix_unregister\n"; _is_client( 'Unix', $name, 'Unregister' ); $kernel->yield('do_child' ); } ########################################################### sub inet_register { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: inet_register\n"; _is_client( 'Inet', $name, 'Register' ); } ########################################################### sub inet_unregister { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: inet_unregister ($name)\n"; _is_client( 'Inet', $name, 'Unregister' ); $kernel->delay('timeout'); $kernel->yield('do_child'); } ########################################################### sub ikc_register { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: ikc_register\n"; _is_client( 'Ikc', $name, 'Register' ); } ########################################################### sub ikc_unregister { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Server: ikc_unregister ($name)\n"; _is_client( 'Ikc', $name, "Unregister" ); $kernel->yield('do_child'); } ########################################################### sub shutdown { my($kernel, $heap, $name, $alias, $is_alias, )=@_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $kernel->alias_remove('test'); DEBUG and warn "Server: shutdown\n"; ::pass('shutdown'); } ########################################################### sub timeout { my($kernel)=$_[KERNEL]; warn "Server: Timedout waiting for child process.\n"; $kernel->post(IKC=>'shutdown'); } POE-Component-IKC-0.2305/Changes0000644000076400007640000002277212106077166014223 0ustar filfilRevision history for Perl extension POE::Component::IKC. 0.2305 10 Feb 2013 - Forgot Devel::Size in PREREQs 0.2303 16 Jan 2013 - Cleaned up cookie crumbs - Removed erroneous call to _select_define in Server::accept Thank you rbhardwaj (rt82685) 0.2302 26 Aug 2011 - Forgot IKC::Protocol GAH! Thank you Gregor Herrmann 0.2301 26 Aug 2011 - Bump copyright year 0.2300 26 Aug 2011 - Fixed thunk checking for 1.311 - Added IKC::Timing, temporarily - Created a new, faster protocol (IKC0) which sends all info on one line as opposed to multiple lines as before (IKC) - Channel session will detach itself from Client session 0.2200 08 May 2009 - Better concurrency handling - We now have a reusable thunk session - Added test cases for above - Reworked t/30_concurrency.t Seems it was failing on Win32 - Added ClientLite->responded() 0.2102 06 May 2009 - IKC::Channel uses presence of IKC alias, not {shutdown}, to unregister - Added a _child to shut up POE::Session - Changed the DEPRECATED messages that fluster everybody into pointers to IKC/monitor. I'm not going to remove on_connect nor on_error. - Allow IKC::Server port=0 0.2101 01 May 2009 - IKC::Channel stops work during shutdown Fixes http://rt.cpan.org/Public/Bug/Display.html?id=44104 Thank you, acferen [...] yahoo.com 0.2100 01 May 2009 - LICENSE in Makefile.PL - Added concurrency to IKC::Server - Moved all tests to Test::More - Added POD tests - Updated copyright year - Cleanup dist - Removed checks for ancient versions of POE - Require POE 1.000 0.2003 03 April 2009 - IKC::Channel->spawn returns session ID - Only keep channel IDs in IKC::Responder - Several changes to improve shutdown behaviour : - Register channels with the IKC::Responder before they negociate - Shutdown a IKC::Client when its Channel closes, so that IKC shutdown will also shutdown the channels - Give Clients aliases to help debuging - Shutdown IKC::Server when the last channel goes away and there's no wheel 0.2002 26 November 2008 - Added call to $kernel->_data_sig_initialize, otherwise child processes will never exit 0.2001 16 January 2008 - Added copyright and license notices to all POD, as requested by Ernesto Hernandez-Novich. 0.2000 29 November 2007 - FreezeThaw::thaw has started to return an array. We only want the first element... Thank you Faiz Kazi - Better timeout handling in IKC::ClientLite. - Documented the above 0.1905 8 August 2007 - It was possible for a IKC::Server child process to inherit some delay()s, clear those also. - Clear all delay()s at the least provocation (INT, TERM, errors, etc) - Created IKC::Server::_delete_wheel - Use POE::Component::Daemon->peek 0.1904 16 November 2006 - Channel now reacts better to IKC1 connections 0.1903 16 November 2006 - Added t/01_specifier.t - Fixed callback example in IKC.pod - Allow 'poe:'-less specifiers 0.1902 1 November 2006 - Forgot $VERSION in IKC.pm 0.1901 3 October 2006 - Tweak the POD - Forgot IKC.pm in MANIFEST 0.1900 3 October 2006 - The memory leaks (big and small) are now verified as gone with POE 0.37 and perl 5.8.8. (Thank you dw for test case.) - Remove Channel aliases. DUH! 0.1804 29 August 2006 - Added IKC.pm - Check the POE leak 0.1803 2 November 2005 - Use Scalar::Util - Better debug messages 0.18 21 June 2005 - ClientLite was looking for freeze before nfreeze, which broke cross-platform usage (Thank you Philip Dobranski) - Channels weren't being shut down properly after X connections - Channels couldn't be shut down from a Client 0.16 - 0.17 Internal releases 0.1501 23 Mar 2005 - Fixup some of the DEBUG messages - Changed from use of internal {pending} to wheel->get_driver_out_octets - Added WORK AROUND for wheel leak issue - LocalKernel now removes it's alias, to be tidy - Removed myself element of Responder's heap. What was it going to be used for? - Responder's {monitors} wasn't being cleaned up, fixed - Server _select_define now uses {pause,resume}_select, which is better behaved then the internal hackery previous - Slight reworking of pre-forking code - All tests pass 0.15 26 May 2004 - Added on_error, which is automatically deprecated for the monitor stuff - Fixed some of the test 13 May 2004 - Moved to signal_handled 0.14 17 Oct 2002 - Nothing changed 0.14pre3 18 Oct 2002 - Uses sig_handled() where appropriate 0.14pre2 16 Oct 2002 - Now uses *Event rather then *State 0.14pre1 2 may 2002 - inform_monitor is now an event - IKC::Proxy post()s to inform_monitor in _start - IKC::Proxy call()s inform_monitor in _stop - Merged up alias listing in publish/retract 0.1303 26 Oct 2001 - IKC::Responder->spawn returns true on success - IKC::Responder->spawn documented - Checking to make sure a publishing session has an alias. if not, use ID - First babysitting happens at startup, doesn't wait - check_kernel brought in line w/ new kernel internals 0.1302 6 Sept 2001 - Meaningless version change 0.1301 24 July 2001 - unix domain paths in kernel names now have / and \ turned into _ - Local kernel gets many names - Make sure sockets are open before syswrite during neg phase of ClientLite, allowing better error handling - IKC::Responder::spawn now checks that only one responder exists - alias_list is only supported after 0.15 - Added win32 support (WSAEAFNOSUPPORT) - IKC::Responder has better state dumping - Better specifier matching - Added test for ClientLite 0.13 13 July 2001 - Added and repaired serializer selection for clients - Added doco for ClientLite - Sungo is happy with this release... onto CPAN it goes. 0.13pre9 5 July 2001 - Doco fixes 0.13pre8 4 July 2001 - Fixed the deprecated use of defined(@array) in IKC/Responder.pm - Added doco about SENDER - create_ikc_channel now takes an arrayref of aliases, so that IKC::Client and IKC::Server can accept a longer list of pre-defined names. - IKC/post2 now expects SENDER to come before [state, args] - Added doco to the effect that callback states are temporarily published - Updated code that turned off the socket_factory... Dngor had changed SocketFactory's implementation on me! This is what you get for doing bad stuff. 0.13pre7 20 June 2001 - Added IKC/published, for sungo - Fixed doco a bit - Added a prereq for POE 0.1403 0.13pre6 6 June 2001 - ADDED TESTS! Woot woot! Now make test verifies something meaningful. - No longer thunking sessions that don't publish any states - Finally did unsubscribe... turns out retract was available all along - Added IKC::{Client,Proxy,Responder,Server}->spawn method, to be used in favour of create_ikc_*mumble* - Added IKC/post2 .... internal use only - Added FlushedState handler to IKC::Channel. This way, wheel isn't destroyed until all data is flushed. This means you can post events to remote kernels and then IKC/shutdown right away. I hope. 0.13pre5 4 June 2001 - Added IKC/shutdown and attendant bouffonery (see shut-{server,client}) - IKC::Proxy for 'poe://somekernel/somesession' is now also aliased as 'somesession' - Added unix-domain sockets... don't know if i've got this right see u{server,client} 0.13pre2-4 May 2001 - Fixed doco and monitor stuff 0.13pre1 19 Apr 2001 - Added the IKC/monitor stuff - Added some doco - ikc-use.txt is now IKC.pod 0.12 March 2001 - Updated Changes, README. Added FUTUR - Improved warning messages - IKC::ClientLite::disconnect no longer calls IKC/unregister to remote (doing it was unneed, server does it automatically when socket dies) 0.11 Nov 16 2000 - IKC/ClientLite now sets $/ and $\ to "\r\n" - wantarray() now gets propagated... is this tested? - babysitting now knows of "defunct" children - children now turn off SIGCHLD and SIGINT... dunce :) - check_kernel debuging subroutine 0.10 May 26 2000 - Added $$ to all the warnings to help isolate problems - Converted IKC::Server to package methods - Split signals into sig_INT, sig_CHLD... - Improved babysitting code (rogues) 0.09 24 May 2000 - Fixed things that POE 0.0906 broke - Added more babysitting code to pre-forking server. Will document soon. 0.08 24 Jan 2000 - Fixed non-forking server code :) - 0.0808 changed Wheel::SocketFactory internals 0.07 Dec 1999 - Added pre-forking server - Added IKC::ClientLite::post_respond 0.06 Saturday Dec 18 1999 - Fixed some warning conditions 0.05 Saturday Nov 06 1999 - Chanels are now being closed when a remote kernel unregisters (this was a TODO, but previously only EPIPE or socket errors would cause this to happen and it was leaking ram) - Small cosmetic changes 0.04 Sep 23 1999 - IKC::ClientLite - Some changes :) 0.03 Thr May 20 22:32 1999 - Added the object interface - Documented the publish/subscribe - Added access restrictions so that only published states may be posted 0.02 Wed May 19 xxxx 1999 - Added publish/subscribe 0.01 Tue May 11 21:18:04 1999 - original version; created by h2xs 1.18 POE-Component-IKC-0.2305/IKC/0000755000076400007640000000000012157370557013332 5ustar filfilPOE-Component-IKC-0.2305/IKC/LocalKernel.pm0000644000076400007640000000503111625750356016060 0ustar filfilpackage POE::Component::IKC::LocalKernel; ############################################################ # $Id: LocalKernel.pm 801 2011-08-26 15:14:24Z fil $ # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use POE::Session; use POE::Component::IKC::Responder; sub DEBUG () { 0 } #---------------------------------------------------- sub spawn { my $package=shift; # my %params=@_; POE::Component::IKC::Responder->spawn(); POE::Session->create( package_states=>[ $package=>[qw(_start _default shutdown send sig_INT _stop)], ], # heap=>{%params}, ); } #---------------------------------------------------- sub _start { my($kernel, $heap, $session)=@_[KERNEL, HEAP, SESSION]; $kernel->sig(INT=>'sig_INT'); $kernel->alias_set('-- Local Kernel IKC Channel --'); $heap->{ref}=1; } #---------------------------------------------------- # sub _default { my($event)=$_[STATE]; DEBUG && warn "Unknown event $event posted to IKC::LocalKernel\n" if $event !~ /^_/; return; } #---------------------------------------------------- sub _stop { # my($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; DEBUG && warn "$$: Local kernel _stop\n"; } #---------------------------------------------------- sub shutdown { my($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; DEBUG && warn "$$: Local kernel channel will shutdown.\n"; return unless $heap->{ref}; delete $heap->{ref}; $kernel->alias_remove('-- Local Kernel IKC Channel --'); } #---------------------------------------------------- sub send { my($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0]; DEBUG && warn "$$: Sending data...\n"; $request->{rsvp}->{kernel}||=$kernel->ID if ref($request) and $request->{rsvp}; DEBUG && warn "$$: Recieved data...\n"; $request->{errors_to}={ kernel=>$kernel->ID, session=>'IKC', state=>'remote_error', }; $request->{call}->{kernel}||=$heap->{kernel_name}; $kernel->call('IKC', 'request', $request); return 1; } #---------------------------------------------------- sub sig_INT { my($kernel, $heap) = @_[KERNEL, HEAP]; DEBUG && warn "$$: sig_INT\n"; $kernel->yield('shutdown'); } 1; POE-Component-IKC-0.2305/IKC/Freezer.pm0000644000076400007640000000354512106220560015257 0ustar filfilpackage POE::Component::IKC::Freezer; ############################################################ # $Id: Freezer.pm 1077 2013-02-11 16:50:56Z fil $ # Copyright 2001-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. use strict; use Data::Dumper; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(freeze thaw dclone); $VERSION = '0.2305'; sub DEBUG { 0 } ############################################################ sub freeze { my($data)=@_; local $Data::Dumper::Purity = 1; local $Data::Dumper::Indent = 0; local $Data::Dumper::Varname = __PACKAGE__."::VAR"; return Dumper $data; } ############################################################ sub thaw { my($string)=@_; local $POE::Component::IKC::Freezer::VAR1; eval $string; return $POE::Component::IKC::Freezer::VAR1; } ############################################################ sub dclone { thaw(freeze($_[0])); } 1; __END__ # Below is the stub of documentation for your module. You better edit it! =head1 NAME POE::Component::IKC::Freezer - Pure-Perl serialization method. =head1 SYNOPSIS =head1 DESCRIPTION This serializer uses L and C to get the deed done. There is an obvious security problem here. However, it has the advantage of being pure Perl and all modules come with the core Perl distribution. =head1 BUGS =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 2001-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L. =cut POE-Component-IKC-0.2305/IKC/Timing.pm0000644000076400007640000000612712111205637015107 0ustar filfilpackage POE::Component::IKC::Timing; ############################################################ # $Id$ # Copyright 2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. package # Hide from the CPAN indexer T; use strict; use warnings; use POSIX qw( strftime ); use Time::HiRes qw( gettimeofday tv_interval ); use Carp; sub TIMING { 0 } our %PARTS; our $fh = *STDERR; ####################################### sub open { my( $package, $file ) = @_; return unless TIMING; my $t = IO::File->new( ">> $file" ); croak "Unable to open $file: $!" unless $t; $fh = $t; $fh->print( strftime( "$$: %H:%M%S.0000 +0 OPEN\n", localtime ) ); return; } ####################################### sub start { my( $package, $part ) = @_; return unless TIMING; if( $PARTS{$part} ) { $package->point( $part, '+++' ); $PARTS{ $part }{start} = $PARTS{ $part }{'last'}; return; } my $now = [ gettimeofday ]; $PARTS{ $part } = { start=>$now, last=>$now }; $package->point( $part, '{{{' ); return; } ####################################### sub point { my( $package, $part, $msg ) = @_; return unless TIMING; unless( $PARTS{ $part } ) { # carp "Timing part $part doesn't exist"; return; } my $time = strftime( "%H:%M:%S" , localtime ); my $now = [ gettimeofday ]; $time .= sprintf ".%04i", int $now->[1]/100; my $last = $PARTS{ $part }{'last'}; $time .= __delta( $last, $now ); $PARTS{ $part }{'last'} = $now; $fh->print("$$: $time [$part] $msg\n"); return; } sub __delta { my( $last, $now ) = @_; my $el = tv_interval( $last, $now ); if( int($el*1000) == 0 ) { return " +0"; } elsif( $el > 1 ) { return sprintf( " +%.3fs", $el); } else { $el *= 1000; # microseconds -> milliseconds if( $el > 10 ) { return sprintf( " +%ims", int $el); } else { return sprintf( " +%.1fms", $el); } } return ''; } ####################################### sub end { my( $package, $part ) = @_; return unless TIMING; unless( $PARTS{ $part } ) { carp "Timing part $part doesn't exist"; return; } my $now = [ gettimeofday ]; my $last = $PARTS{ $part }{start}; my $elapsed = __delta( $last, $now ); $elapsed =~ s/ \+//; $package->point( $part, "}}} total=$elapsed" ); delete $PARTS{ $part }; } 1; __END__ =head1 NAME POE::Component::IKC::Timing - POE Inter-kernel Communication timing helper =head1 SYNOPSIS use POE::Component::IKC::Timing; T->start( 'part' ) T->point( part => $msg ); T->end( 'part' ); =head1 DESCRIPTION This module provides a crude form of application profiling. It is not currently stable enough to be documented nor used. In fact, it will probably become its own module at some point. =head1 SEE ALSO L =cut POE-Component-IKC-0.2305/IKC/Responder.pm0000644000076400007640000017257112106220560015624 0ustar filfilpackage POE::Component::IKC::Responder; ############################################################ # $Id: Responder.pm 1077 2013-02-11 16:50:56Z fil $ # Based on tests/refserver.perl # Contributed by Artur Bergman # Revised for 0.06 by Rocco Caputo # Turned into a module by Philp Gwyn # # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $ikc); use Carp; use Data::Dumper; use POE qw(Session); use POE::Component::IKC::Specifier; use POE::Component::IKC::Timing; use Scalar::Util qw(reftype); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(create_ikc_responder $ikc); $VERSION = '0.2305'; sub DEBUG { 0 } ############################################################################## #---------------------------------------------------- # This is just a convenient way to create only one responder. sub create_ikc_responder { __PACKAGE__->spawn(); } sub spawn { my($package)=@_; return 1 if $ikc; POE::Session->create( package_states => [ $package, [qw( _start _stop _child request post call raw_message post2 remote_error register unregister register_local register_channel default publish retract subscribe unsubscribe published monitor inform_monitors shutdown do_you_have ping sig_INT )] ]); return 1; } #---------------------------------------------------- # Accept POE's standard _start message, and start the responder. sub _start { my($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION]; DEBUG and warn "$$: Responder started.\n"; $kernel->alias_set('IKC'); # allow it to be called by name # $kernel->signal(INT=>'sig_INT'); # sig_INT is empty, so don't bother $ikc=POE::Component::IKC::Responder::Object->new($kernel, $session); $heap->{self}=$ikc; } sub _stop { DEBUG and warn "$$: $_[HEAP] responder _stop\n"; # use YAML qw(Dump); # use Data::Denter; # warn Denter $poe_kernel; } sub _child { my( $heap, $reason, $session, $ret ) = @_[ HEAP, ARG0, ARG1, ARG2 ]; DEBUG and warn "$$: $_[HEAP] responder _child $reason, $session\n"; } #---------------------------------------------------- # Shutdown everything IKC related that we know about sub shutdown { my($kernel, $heap)=@_[KERNEL, HEAP]; $heap->{self}->shutdown($kernel); } #---------------------------------------------------- # Foreign kernel called something here sub request { my($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0]; $heap->{self}->request($request); } #---------------------------------------------------- # Register foreign kernels so that we can send states to them sub register { my($heap, $channel, $rid, $aliases, $pid) = @_[HEAP, SENDER, ARG0..$#_]; # warn "pid=$pid" if $pid; $heap->{self}->register($channel, $rid, $aliases, $pid); } #---------------------------------------------------- # Register new aliases for local kernel sub register_local { my($heap, $aliases) = @_[HEAP, ARG0]; $heap->{self}->register_local($aliases); } #---------------------------------------------------- # Unregister foreign kernels when this disconnect (say) sub unregister { my($kernel, $heap, $channel, $rid, $aliases) = @_[KERNEL, HEAP, SENDER, ARG0, ARG1]; $heap->{self}->unregister($channel, $rid, $aliases); } #---------------------------------------------------- # Set a default foreign channel to send messages to sub default { my($heap, $name) = @_[HEAP, ARG0]; $heap->{self}->default($name); } #---------------------------------------------------- # Register a channel. So we can tell it to shutdown before it finishes # negociating sub register_channel { my($heap, $channel) = @_[HEAP, SENDER]; $heap->{self}->register_channel($channel); } ############################################################################## ## This state allows sessions to monitor a remote kernel #---------------------------------------------------- # Watch any activity regarding a foreign kernel sub monitor { my($heap, $name, $states, $sender) = @_[HEAP, ARG0, ARG1, SENDER]; $heap->{self}->monitor($sender, $name, $states); return } ############################################################################## ## These are the 4 states that interact with the foreign kernel #---------------------------------------------------- # Send a request to the foreign kernel sub post { my($heap, $to, $params, $sender) = @_[HEAP, ARG0, ARG1, SENDER]; $heap->{self}->post($to, $params, $sender); } #---------------------------------------------------- # Send a request to the foreign kernel sub post2 { my($heap, $to, $sender, $params) = @_[HEAP, ARG0, ARG1, ARG2]; # use Data::Dumper; # warn "post2 params=", Dumper $params; $heap->{self}->post($to, $params, $sender); } #---------------------------------------------------- # Send a request to the foreign kernel and ask it to provide # the state's return value back sub call { my($kernel, $heap, $sender, $to, $params, $rsvp) = @_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2]; $heap->{self}->call($to, $params, $rsvp, $sender); return; } #---------------------------------------------------- # Send a raw message over. use at your own risk :) # This is useful for sending errors to remote ClientLite sub raw_message { my($heap, $msg, $sender) = @_[HEAP, ARG0, ARG1]; $heap->{self}->send_msg($msg, $sender); } #---------------------------------------------------- # Remote kernel had an error sub remote_error { my($heap, $msg) = @_[HEAP, ARG0]; warn "$$: Remote error: $msg\n"; } ############################################################################## # publish/retract/subscribe mechanism of setting up foreign sessions #---------------------------------------------------- sub publish { my($kernel, $heap, $sender, $session, $states)= @_[KERNEL, HEAP, SENDER, ARG0, ARG1]; $session||=$sender; $heap->{self}->publish($session, $states); } #---------------------------------------------------- sub published { my($kernel, $heap, $which)=@_[KERNEL, HEAP, ARG0]; $heap->{self}->published($which); } #---------------------------------------------------- sub retract { my($heap, $sender, $session, $states)= @_[HEAP, SENDER, ARG0, ARG1]; $session||=$sender; $heap->{self}->retract($session, $states); } #---------------------------------------------------- sub subscribe { my($kernel, $heap, $sender, $sessions, $callback)= @_[KERNEL, HEAP, SENDER, ARG0, ARG1]; $sessions=[$sessions] unless ref $sessions; return unless @$sessions; if($callback and 'CODE' ne ref $callback) { $sender = $sender->ID if ref $sender; my $state=$callback; $callback=sub { DEBUG and warn "Subscription callback to '$state'\n"; $kernel->post($sender, $state, @_); }; } $heap->{self}->subscribe($sessions, $callback, $sender->ID); } # Called by a foreign IKC session # We respond with the session, or with "NOT $specifier"; sub do_you_have { my($kernel, $heap, $param)=@_[KERNEL, HEAP, ARG0]; my $ses=specifier_parse($param->[0]); die "Bad state $param->[0]\n" unless $ses; my $self=$heap->{self}; DEBUG and warn "Wants to subscribe to ", specifier_name($ses), "\n"; if(exists $self->{'local'}{$ses->{session}} and (not $ses->{state} or exists $self->{'local'}{$ses->{session}}{$ses->{state}} )) { $ses->{kernel}||=$kernel->ID; # make sure we uniquely identify DEBUG and warn "Allowed (we are $ses->{kernel})\n"; return [$ses, $kernel->ID]; # this session } else { DEBUG and warn specifier_name($ses), " is not published in this kernel\n"; return "NOT ".specifier_name($ses); } } #---------------------------------------------------- sub unsubscribe { my($kernel, $heap, $sessions)=@_[KERNEL, HEAP, ARG0]; $heap->{self}->unsubscribe($sessions); } #---------------------------------------------------- sub ping { "PONG"; } #---------------------------------------------------- # User wants to kill process / kernel sub sig_INT { my ($heap, $kernel)=@_[HEAP, KERNEL]; DEBUG && warn "$$: Responder::sig_INT\n"; $kernel->sig_handled(); return; } #---------------------------------------------------- # User wants to kill process / kernel sub inform_monitors { my ($heap)=$_[HEAP]; $heap->{self}->inform_monitors(@_[ARG0..$#_]); } ############################################################################## ############################################################################## # Here is the object interface package POE::Component::IKC::Responder::Object; use strict; use Carp; use POE::Component::IKC::Specifier; use POE::Component::IKC::Proxy; use POE::Component::IKC::LocalKernel; use POE qw(Session); use Data::Dumper; sub DEBUG { 0 } sub DEBUG2 { 0 } sub DEBUGM { DEBUG or 0 } sub new { my($package, $kernel, $session)=@_; my $self=bless { 'local'=>{IKC=>{remote_error=>1, # these states are auto-published do_you_have=>1, ping=>1, }, }, remote=>{}, rsvp=>{}, kernel=>{}, channel=>{}, channel_startup=>{}, default=>{}, monitors=>{}, poe_kernel=>$kernel, # myself=>$session->ID, }, $package; } #---------------------------------------------------- # shutdown sub shutdown { my($self, $kernel)=@_; DEBUG and warn "$$: Some one wants us to go away... off we go\n"; # kill our alias $kernel->alias_remove('IKC'); # tell every channel to shutdown while(my($rid, $c)=each %{$self->{channel}}) { DEBUG and warn "$$: Posting shutdown to $rid (id=$c)\n"; $kernel->post($c, 'shutdown'); } $self->{channel} = {}; # even the channels that haven't negociated yet foreach my $c ( keys %{ $self->{channel_startup} } ) { DEBUG and warn "$$: Posting shutdown to channel (id=$c)\n"; $kernel->post( $c, 'shutdown' ); } $self->{channel_startup} = {}; # tell monitors to shutdown $self->inform_monitors('*', 'shutdown'); # kill pending subscription states foreach my $uevent (keys %{$self->{pending_subscription}}) { $self->_remove_state($uevent); } # use YAML qw(Dump); # warn Dump $kernel; } #---------------------------------------------------- # Foreign kernel called something here sub request { my($self, $request)=@_;; my($kernel)=@{$self}{qw(poe_kernel)}; DEBUG2 and warn "IKC request=", Dumper $request; # We ignore the kernel for now, but we should really use it to decide # weither we should run the request or not my $to=specifier_parse($request->{event}); eval { die "$request->{event} isn't a valid specifier" unless $to; my $args=$request->{params}; ### allow proxied states to have multiple ARGs if($to->{state} eq 'IKC:proxy') { $to->{state}=$args->[0]; $args=$args->[1]; DEBUG and warn "IKC proxied request for ", specifier_name($to), "\n"; } else { DEBUG and warn "IKC request for ", specifier_name($to), "\n"; $args=[$args]; } # this is where we'd catch a disconnect message # 2001/07 : eh? # find out if the state we want to get at has been published if(exists $self->{rsvp}{$to->{session}} and exists $self->{rsvp}{$to->{session}}{$to->{state}} and $self->{rsvp}{$to->{session}}{$to->{state}} ) { $self->{rsvp}{$to->{session}}{$to->{state}}--; DEBUG and warn "Allow $to->{session}/$to->{state} is now $self->{rsvp}{$to->{session}}{$to->{state}}\n"; } elsif(not exists $self->{'local'}{$to->{session}}) { my $p=$self->published; die "Session '$to->{session}' is not available for remote kernels:", join "\n", '', map({ " $_=>[" . join(', ', @{$p->{$_}}) . "]"} keys %$p), ''; } elsif(not exists $self->{'local'}{$to->{session}}{$to->{state}}) { die "Session '$to->{session}' has not published state '", $to->{state}, "'\n"; } # maybe caller specified #arg? This got into $msg->{rsvp}, which # went to the remote side, then came back here as $to if(exists $to->{args}) { push @$args, $to->{args}; # it goes on the end } my $session=$kernel->alias_resolve($to->{session}); die "Unknown session '$to->{session}'\n" unless $session; # warn "No FROM" unless $request->{from}; _thunked_post($request->{rsvp}, ["$session", $to->{state}, @$args], $request->{from}, $request->{wantarray}); }; # Error handling consists of posting a "remote_error" state to # the foreign kernel. # $request->{errors_to} is set by the local IKC::Channel if($@) { chomp($@); my $err=$@.' ['.specifier_name($to).']'; $err.=' sent by ['.specifier_name($request->{from}).']' if $request->{from}; warn "$err\n"; DEBUG && warn "$$: Error in request: $err\n"; unless($request->{is_error}) # don't send an error message back { # if this was an error itself $self->send_msg({ event=>$request->{errors_to}, params=>$err, is_error=>1, }); } else { warn $$, Dumper $request; } } } #---------------------------------------------------- # Register foreign kernels so that we can send states to them sub register { my($self, $channel, $rid, $aliases, $pid)=@_; $aliases=[$aliases] if not ref $aliases; my($kernel)=@{$self}{qw(poe_kernel)}; $channel = $channel->ID; delete $self->{channel_startup}{ $channel }; if($self->{channel}{$rid}) { warn "$$: Remote kernel '$rid' already exists\n"; return; } else { DEBUG and warn "$$: Registered remote kernel '$rid' (id=$channel)\n"; $self->{channel}{$rid}=$channel; $self->{remote}{$rid}=[]; # list of proxy sessions $self->{alias}{$rid}=$aliases; $self->{default}||=$rid; } foreach my $name (@$aliases) { unless(defined $name) { warn "$$: attempt to register undefined remote kernel alias\n"; next; } if($self->{kernel}{$name}) { DEBUG and warn "$$: Remote alias '$name' already exists\n"; next; } DEBUG and warn "$$: Registered alias '$name'\n"; $self->{kernel}{$name}=$rid; # find real remote ID $self->{remote}{$name}||=[]; # list of proxy sessions } # warn "pid=$pid" if $pid; $self->inform_monitors($rid, 'register', $pid); return 1; } #---------------------------------------------------- # Register a new alias for the local kernel sub register_local { my($self, $aliases)=@_; $aliases=[$aliases] if not ref $aliases; my($kernel)=@{$self}{qw(poe_kernel)}; my $rid=$kernel->ID; DEBUG and warn "$$: Registering local kernel '$rid'\n"; $self->{local_channel}||=POE::Component::IKC::LocalKernel->spawn->ID; my $channel=$self->{local_channel}; $self->{channel}{$rid}||=$channel; $self->{remote}{$rid}||=[]; # list of proxy sessions $self->{alias}{$rid}||=[]; # use Data::Dumper; # die Dumper $aliases; foreach my $name (@$aliases) { unless(defined $name) { DEBUG and warn "$$: attempt to register undefined local kernel alias\n"; next; } if($self->{kernel}{$name}) { DEBUG and warn "$$: Local kernel alias '$name' already exists\n"; next; } DEBUG and warn "$$: Registered local alias '$name'\n"; $self->{kernel}{$name}=$rid; # find real remote ID $self->{remote}{$name}||=[]; # list of proxy sessions push @{$self->{alias}{$rid}}, $name; } return 1; } #---------------------------------------------------- # Register a starting channel sub register_channel { my( $self, $channel ) = @_; $channel = $channel->ID; DEBUG and warn "$$: Registered channel (id=$channel)\n"; $self->{channel_startup}{ $channel } = 1; return; } #---------------------------------------------------- sub default { my($self, $name) = @_; if(exists $self->{kernel}{$name}) { $self->{default}=$self->{kernel}{$name}; } elsif(exists $self->{channel}{$name}) { $self->{default}=$name; } else { carp "We do not know the kernel $name.\n"; return; } DEBUG and warn "Default kernel is on channel $name.\n"; } #---------------------------------------------------- # Unregister foreign kernels when they disconnect (say) sub unregister { my($self, $channel, $rid, $aliases)=@_; my($kernel)=@{$self}{qw(poe_kernel)}; return unless $rid; $channel = $channel->ID; unless($aliases) { unless($self->{channel}{$rid}) { # unregister one alias only $aliases=[$rid]; undef $rid; } } elsif(not ref $aliases) { $aliases=[$aliases]; } my @todo; if($rid) { if($self->{channel}{$rid}) { # this is in fact the real name DEBUG and warn "Unregistered kernel '$rid'.\n"; $self->inform_monitors($rid, 'unregister'); $self->{'default'}='' if $self->{'default'} eq $rid; $kernel->post($self->{channel}{$rid}, 'close'); delete $self->{channel}{$rid}; # delete $self->{monitors}{$rid}; $aliases||=delete $self->{alias}{$rid}; push @todo, $rid; } else { warn "$rid isn't a channel???\n"; } } foreach my $name (@$aliases) { next unless defined $name; # delete $self->{monitors}{$name}; if($self->{kernel}{$name}) { DEBUG and warn "Unregistered kernel alias '$name'.\n"; delete $self->{kernel}{$name}; $self->{'default'}='' if $self->{'default'} eq $name; push @todo, $name; } else { DEBUG and warn "Already done: $name\n"; next; } } # tell the proxies they are no longer needed foreach my $name (@todo) { if($name) { foreach my $alias (@{$self->{remote}{$name}}) { $self->{poe_kernel}->post($alias, '_delete'); } delete $self->{remote}{$name}; } } return 1; } #---------------------------------------------------- # Internal function that does all the work of preparing a request to be sent sub send_msg { my($self, $msg, $sender)=@_; my($kernel)=@{$self}{qw(poe_kernel)}; my $e=$msg->{rsvp} ? 'call' : 'post'; my $to=specifier_parse($msg->{event}); unless($to) { die "Bad state ", Dumper $msg; } unless($to) { warn "Bad or missing 'event' parameter '$msg->{event}' to IKC/$e\n"; return; } unless($to->{session}) { warn "Need a session name for IKC/$e\n", Dumper $to; return; } unless($to->{state}) { warn "Need a state name for IKC/$e\n", Dumper $to; return; } my $name=$to->{kernel}||$self->{'default'}; unless($name) { warn "Unable to decide which kernel to send state '$to->{state}' to."; return; } DEBUG and warn "send_msg poe://IKC/$e to '", specifier_name($to), "'\n"; # This way the thunk session will proxy a request back to us if($sender and not $msg->{from} and # Leolo: question. doesnt .13 require bleadPOE? # sungo : i can put the offending code into a conditional # if you want $self->{poe_kernel}->can('alias_list')) { my $sid=$sender; $sid = $sender->ID if ref $sender; foreach my $a ($self->{poe_kernel}->alias_list($sender)) { $sid .= " ($a)"; if($self->{'local'}{$a}) { # SENDER published something $msg->{from}={ kernel=>$self->{poe_kernel}->ID, session=>$a, state=>'IKC:proxy', }; last; } } DEBUG2 and do { unless($msg->{from}) { warn "Session $sid didn't publish anything SENDER isn't set";#, Denter $self->{'local'}, $sender; } else { warn "Session $sid will be thunked"; } } } # This is where we should recurse $msg->{params} to turn anything # extravagant like a subref, $poe_kernel, session etc into a call back to # us. # $msg->{params}=$self->marshall($msg->{params}); # Get a list of channels to send the message to my @channels=$self->channel_list( $name ); unless(@channels) { warn "$$: MSG TO ", Dumper $to; warn (($name eq '*') ? "$$: Not connected to any foreign kernels.\n" : "$$: Unknown kernel '$name'.\n"); warn "$$: Known kernels: ". $self->channel_names; return 0; } # now send the message over the wire # hmmm.... i wonder if this could be stream-lined into a direct call my $count=0; my $rsvp; $rsvp=$msg->{rsvp} if exists $msg->{rsvp}; foreach my $channel (@channels) { # We need to be able to access this state w/out forcing folks # to use publish if($rsvp) { DEBUG and warn "Allow $rsvp->{session}/$rsvp->{state} once\n"; $self->{rsvp}{$rsvp->{session}}{$rsvp->{state}}++; } DEBUG2 and warn "Sending to '$channel'..."; if($kernel->call($channel, 'send', $msg)) { $count++; DEBUG2 and warn " done.\n"; } else { DEBUG2 and warn " failed.\n"; $self->{rsvp}{$rsvp->{session}}{$rsvp->{state}}-- if $rsvp; } } DEBUG2 and warn specifier_name($to), " sent to $count kernel(s).\n"; DEBUG and do {warn "$$: send_msg failed!\n" unless $count}; return $count; } #---------------------------------------------------- sub _true_type { my($self, $data, $can)=@_; my $r=ref $data; return unless $r; return reftype( $data ); } #---------------------------------------------------- sub marshall { my($self, $data)=@_; my $r=$self->_true_type($data, 'ikc_marshall'); return $data unless $r; if($r eq 'HASH') { foreach my $q (values %$data) { $data->{$q}=$self->marshall($data->{$q}) if ref $data->{$q}; } } elsif($r eq 'ARRAY') { foreach my $q (@$data) { $q=$self->marshall($q) if ref $q; } } elsif($r eq 'SCALAR') { $$data=$self->marshall($$data) if ref $$data; } elsif($r eq 'CODE') { my $q=Devel::Peek::CvGV($data); if($q=~/__ANON__$/) { warn "Can't marshall anonymous code ref $q\n"; return; } return "-IKC-CODEREF-$q"; } else { warn "Marshalling $r wouldn't be meaningful\n"; return; } return $data; } #---------------------------------------------------- sub demarshall { my($self, $data)=@_; my $r=$self->_true_type($data, 'ikc_demarshall'); unless($r) { if($r=~/^-IKC-CODEREF-(.+)-(\*[:\w]+)$/) { my $func=$2; my $rk=$1; die "need to call $func in $rk"; $data=sub {$poe_kernel->post(IKC=>'post', "poe://$rk/IKC/coderef"=>$func)}; } return $data; } if($r eq 'HASH') { foreach my $q (values %$data) { $data->{$q}=$self->demarshall($data->{$q}) if ref $data->{$q}; } } elsif($r eq 'ARRAY') { foreach my $q (@$data) { $q=$self->demarshall($q) if ref $q; } } elsif($r eq 'SCALAR') { $$data=$self->demarshall($$data) if ref $$data; } return $data; } #---------------------------------------------------- ## Turn a kernel name or alias into a list of possible channels sub channel_list { my($self, $name)=@_; if($name eq '*') { # all kernels return values %{$self->{channel}}; } if(exists $self->{kernel}{$name}) { # kernel alias my $t=$self->{kernel}{$name}; unless(exists $self->{channel}{$t}) { die "What happened to channel $t!"; } return ($self->{channel}{$t}) } if(exists $self->{channel}{$name}) { # kernel ID return ($self->{channel}{$name}) } return (); } #---------------------------------------------------- ## Get a list of all the channel names (for debugging) sub channel_names { my($self, $name) = @_; if( $name and $name ne '*' ) { return "$name (".join(', ', grep { $self->{kernel}{$_} eq $name } keys %{ $self->{kernel} } ) .")"; } my @ret; foreach $name ( keys %{ $self->{channel} } ) { push @ret, $self->channel_names( $name ); } return @ret if wantarray; return join ', ', @ret; } #---------------------------------------------------- # Send a request to the foreign kernel sub post { my($self, $to, $params, $sender) = @_; $to="poe://$to" unless ref $to or $to=~/^poe:/; # use Data::Dumper; # warn "params=", Dumper $params; $self->send_msg({params=>$params, 'event'=>$to}, $sender); } #---------------------------------------------------- # Send a request to the foreign kernel and ask it to provide # the state's return value back sub call { my($self, $to, $params, $rsvp, $sender)=@_; $to="poe://$to" if $to and not ref $to and $to!~/^poe:/; $rsvp="poe://$rsvp" if $rsvp and not ref $rsvp and $rsvp!~/^poe:/; unless($rsvp) { warn "$$: Missing 'rsvp' parameter in poe:IKC/call\n"; return; } my $t=specifier_parse($rsvp); unless($t) { warn "$$: Bad 'rsvp' parameter '$rsvp' in poe:IKC/call\n"; return; } $rsvp=$t; unless($rsvp->{state}) { DEBUG and warn Dumper $rsvp; warn "$$: rsvp state not set in poe:IKC/call\n"; return; } # Question : should $rsvp->{session} be forced to be the sender? # or will we allow people to point callbacks to other poe:kernel/sessions $rsvp->{session}||=$sender->ID if ref $sender; # maybe a session ID? if(not $rsvp->{session}) # no session alias { die "IKC call requires session IDs, please patch your version of POE\n"; } DEBUG2 and warn "RSVP is ", specifier_name($rsvp), "\n"; # use Data::Dumper; # warn "params=", Dumper $params; $self->send_msg({params=>$params, 'event'=>$to, rsvp=>$rsvp }, $sender ); } ############################################################################## # publish/retract/subscribe mechanism of setting up foreign sessions sub _aliases { my($kernel, $session)=@_; return $session unless ref $session; # make sure it's an object if($kernel->can('alias_list')) { # post-0.15 we register as all aliases for session my @a=$kernel->alias_list($session->ID); return @a if @a; } # pre-0.15 means that we register as session ID... which is less # then useful return $session->ID; } #---------------------------------------------------- sub publish { my($self, $session, $states)=@_; unless($session) { carp "You must specify the session that publishes these states"; return 0; } my @aliases =_aliases($self->{poe_kernel}, $session); foreach my $alias (@aliases) { $self->{'local'}{$alias}||={}; my $p=$self->{'local'}{$alias}; die "\$states isn't an array ref" unless ref($states) eq 'ARRAY'; foreach my $q (@$states) { DEBUG and print STDERR "Published poe:$alias/$q\n"; $p->{$q}=1; } } return 1; } #---------------------------------------------------- sub published { my($self, $session)=@_; if($session) { my $sid=$session; if(not ref $session) { $sid||=$self->{poe_kernel}->ID_lookup($session); } return [keys %{$self->{'local'}{$sid}}]; } my %ret; foreach my $sid (keys %{$self->{'local'}}) { $ret{$sid}=[keys %{$self->{'local'}{$sid}}]; } return \%ret; } #---------------------------------------------------- sub retract { my($self, $session, $states)=@_; unless($session) { warn "You must specify the session that publishes these states"; return 0; } my @aliases=_aliases($self->{poe_kernel}, $session); foreach my $alias (@aliases) { unless($self->{'local'}{$alias}) { warn "Session '$session' ($alias) didn't publish anything, can't retract"; return 0; } if($states) { my $p=$self->{'local'}{$alias}; foreach my $q (@$states) { delete $p->{$q}; } delete $self->{'local'}{$alias} unless keys %$p; } else { delete $self->{'local'}{$alias}; } } return 1; } #---------------------------------------------------- # Subscribing is in two phases # 1- we call a IKC/do_you_have to the foreign kernels # 2- the foreign responds with the session-specifier (if it has published it) # # We create a unique state for the callback for each subscription request # from the user session. It keeps count of how many subscription receipts # it receives and when they are all subscribed, it localy posts the callback # event. # # If more then one kernel sends a subscription receipt, first one is used. sub subscribe { my($self, $sessions, $callback, $s_id)=@_; my($kernel)=@{$self}{qw(poe_kernel)}; $s_id||=join '-', caller; my($ses, $s, $fiddle); # unique identifier for this request $callback||=''; my $unique="IKC:receipt $s_id $callback"; my $id=$kernel->ID; my $count; foreach my $spec (@$sessions) { $ses=specifier_parse($spec); # Session specifier # Create the subscription receipt state $kernel->state($unique.$spec, sub { _subscribe_receipt($self, $unique, $spec, $_[ARG0]) }); $kernel->delay($unique.$spec, 60); # timeout $self->{pending_subscription}{$unique.$spec}=1; if($ses->{kernel}) { $count=$self->send_msg( {event=>{kernel=>$ses->{kernel}, session=>'IKC', state=>'do_you_have' }, params=>[$ses, $id], from=>{kernel=>$id, session=>'IKC'}, rsvp=>{kernel=>$id, session=>'IKC', state=>$unique.$spec}, }, ); # TODO What if this post failed? Session that posted this would # surely want to know } else { # Bleh. User shouldn't be that dumb die "You can't subscribe to a session within the current kernel."; } if($callback) # We need to keep some information around { # for when the subscription receipt comes in $self->{subscription_callback}{$unique}||= { callback=>$callback, sessions=>{}, yes=>[], count=>0, states=>{}, }; $fiddle=$self->{subscription_callback}{$unique}; $fiddle->{states}{$unique.$spec}=$count; $fiddle->{count}+=($count||0); $fiddle->{sessions}->{$spec}=1; if(not $count) { $fiddle->{count}++; $kernel->yield($unique.$spec); } else { DEBUG and warn "Sent $count subscription requests for [$spec]\n"; } } } return 1; } #---------------------------------------------------- # Subscription receipt # All foreign kernel's that have published the desired session # will send back a receipt. # Others will send a "NOT". # This will cause problems when the Proxy session creates an alias :( # # Callback is called we are "done". But what is "done"? When at least # one remote kernel has allowed us to subscribe to each session we are # waiting for. However, at some point we should give up. # # Scenarios : # one foreign kernel says 'yes', one 'no'. # - 'yes' creates a proxy # - 'no' decrements wait count # ... callback is called with session specifier # 2 foreign kernels says 'yes' # - first 'yes' creates a proxy # - 2nd 'yes' should also create a proxy! alias conflict (for now) # ... callback is called with session specifier # one foreign kernel says 'no', and after, another says no # - first 'no' decrements wait count # - second 'no' decrements wait count # ... Subscription failed! callback is called with specifier empty # no answers ever came... # - we wait forever :( sub _subscribe_receipt { my($self, $unique, $spec, $resp)=@_; my $accepted=1; my($ses, $rid)=@$resp if $resp and ref $resp and @$resp; my $del; if(not $ses or not ref $ses) { # REFUSED warn "$$: Refused to subscribe to $spec"; warn "$$: $resp" if $resp; $accepted=0; $del=$unique.$spec; } else { # accepted $ses=specifier_parse($ses); die "Bad state" unless $ses; my($kernel)=@{$self}{qw(poe_kernel)}; DEBUG and warn "Create proxy for ", specifier_name($ses), "\n"; my $proxy=POE::Component::IKC::Proxy->spawn( $ses->{kernel}, $ses->{session}, sub { $kernel->post(IKC=>'inform_monitors', $rid, 'subscribe', $ses)}, # 2002/04 monitor_stop is called in _stop, but we can't # can't post() from _stop, so we call() ourself sub { $kernel->call(IKC=>'inform_monitors', $rid, 'unsubscribe', $ses)}, ); push @{$self->{remote}{$ses->{kernel}}}, $proxy; } # cleanup the subscription request if(exists $self->{subscription_callback}{$unique}) { DEBUG and warn "Subscription [$unique] callback... "; my $fiddle=$self->{subscription_callback}{$unique}; if($fiddle->{sessions}->{$spec} and $accepted) { delete $fiddle->{sessions}->{$spec}; push @{$fiddle->{yes}}, $spec; } $fiddle->{count}-- if $fiddle->{count}; if(0==$fiddle->{count}) { DEBUG and warn "yes."; delete $self->{subscription_callback}{$unique}; # use Data::Denter; # warn "Fiddle =", Denter $fiddle; $fiddle->{callback}->($fiddle->{yes}); } else { DEBUG and warn "no, $fiddle->{count} left."; } $fiddle->{states}{$unique.$spec}--; if($fiddle->{states}{$unique.$spec}<=0) { # this state is no longer needed $del=$unique.$spec; } } else { # this state is no longer needed $del=$unique.$spec; } $self->_remove_state($del) if $del; } # clean-up sub _remove_state { my($self, $del)=@_; return unless $self->{pending_subscription}{$del}; my $kernel=$self->{poe_kernel}; $kernel->delay($del); $kernel->state($del); delete $self->{states}{$del}; delete $self->{pending_subscription}{$del}; } #---------------------------------------------------- sub unsubscribe { my($self, $sessions)=@_; $sessions=[$sessions] unless ref $sessions; return unless @$sessions; foreach my $ses (@$sessions) { $self->{poe_kernel}->post($ses, '_shutdown'); } } #---------------------------------------------------- sub ping { "PONG"; } #------------------------------------------------------------------ sub monitor { my($self, $sender, $name, $states)=@_; # dngor : also, if i keep a ref to $_[SENDER], does this mess # up stuff? # yeah, it will mess stuff up. take its ID instead; you can # post to an ID $sender=$sender->ID if ref $sender; my $spec=$name; $spec=specifier_part($spec, 'kernel') unless $spec eq '*'; undef($states) unless ref $states and keys %$states; if($states) { $states->{__name}=$name; DEBUGM and warn "$$: Session $sender is monitoring $spec\n"; $self->{monitors}{$spec} ||= {}; $self->{monitors}{$spec}{$sender}=$states; } else { DEBUGM and warn "$$: Session $sender is neglecting $spec\n"; delete $self->{monitors}{$spec}{$sender}; delete $self->{monitors}{$spec} if 0==keys %{$self->{monitors}{$spec}}; } return; } #---------------------------------------------------- # Tell monitors about something in foreign kernel # $rid == kernel name (in which case we ALSO inform about aliases) or alias # or * (tell every monitor about something... future use) # $event == name of event we are informing about # @params == other stuff # NB : inform_monitors *MUST* post or call the monitors before exiting # because unregister will delete {monitors}{$rid} right after sub inform_monitors { my($self, $rid, $event, @params)=@_; my($kernel)=@{$self}{qw(poe_kernel)}; $rid=specifier_part($rid, 'kernel') unless $rid eq '*'; croak "$$: No kernel in $_[1]!" unless $rid; my $real=1 if $self->{channel}{$rid}; DEBUGM and do { warn "$$: inform $event $rid"; warn "$$: $rid is", ($real ? '' : "n't"), " real\n"; }; # got to be a better way of doing this... my @todo=($rid); push @todo, '*' unless $rid eq '*'; foreach my $n (@todo) { next unless $n; my $ms=$self->{monitors}{$n}; unless($ms and %$ms) { DEBUGM and warn "$$: No sessions care about $event $n\n"; next; } foreach my $sender (keys %$ms) { my $states=$ms->{$sender}; my $e=$states->{$event}; next unless $e; DEBUGM and warn "$$: Informing Session $sender/$e about $n/$event\n"; # ARG0 = what Session called the kernel # ARG1 = what kernel calls the kernel # ARG2 = true if kernel is name, false if alias # ARG3 = $states->{data} # ARG4.... = per-message info $kernel->post($sender, $e, $states->{__name}, $rid, $real, $states->{data}, @params); } } # $rid might be an alias to something else, inform about those as well if($self->{channel}{$rid}) { foreach my $ra (@{$self->{alias}{$rid}}) { $self->inform_monitors($ra, $event, @params); } } } ############################################################################## # These are Thunks used to post the actual state on behalf of the foreign # kernel. Currently, the thunks are used as a "proof of concept" and # to accur extra over head. :) # # On the first request, a thunk is created. It is kept alive with an alias. # On the next request, we check to see if the extref_count is zero. If it # is, we reuse the same request. If not, we create a new thunk and continue # using that. What's more, we tell the thunk that it is active, so it should # clear its alias. This way, when the user code decrements the extref_count # back to zero, the thunk they reserved can be cleared. # # Export thunk the quick way. *_thunked_post=\&POE::Component::IKC::Responder::Thunk::thunk; package POE::Component::IKC::Responder::Thunk; use strict; use Carp; use Data::Dumper; use POE::Component::IKC; use POE::Session; use POE; sub DEBUG { 0 } sub DEBUG2 { 0 } #---------------------------------------------------- { my $NAME=__PACKAGE__.'00000000'; $NAME=~s/\W+//g; my $current_thunk; #------------------------------ sub thunk { # my($rsvp, $call, $from, $wantarray)=@_; unless( __active_thunk() ) { __create_thunk(); } # we use call to make sure no other call to us could # happen between _start and __thunk $poe_kernel->call( $current_thunk => '__thunk', @_ ); } #------------------------------ sub __create_thunk { my $thunk = POE::Session->create( package_states => [ __PACKAGE__, [ qw(_start _stop _default __thunk __active ) ] ], args => [++$NAME] ); $current_thunk = $thunk->ID; } #------------------------------ sub __active_thunk { return unless $current_thunk; # 2009/05 - These next 2 lines call undocumented internal methods of # the kernel. If the kernel changes, they will break. # If they break, please contact gwyn-at-cpan.org. # 2011/08 - These have been changed for 1.311 if( $poe_kernel->_data_ses_exists( $current_thunk ) ) { my $count = $poe_kernel->_data_extref_count_ses( $current_thunk ); if( 0==$count ) { DEBUG and warn "$$: $NAME reuse\n"; return 1; } DEBUG and warn "$$: thunk count=$count\n"; $poe_kernel->call( $current_thunk => '__active' ); } undef( $current_thunk ); return; } } #---------------------------------------------------- sub _start { my($kernel, $heap, $name )= @_[KERNEL, HEAP, ARG0]; $heap->{alias} = $heap->{name} = $name; DEBUG and warn "$$: $name create\n"; $kernel->alias_set( $heap->{alias} ); } #---------------------------------------------------- sub __active { my($kernel, $heap) = @_[KERNEL, HEAP]; DEBUG and warn "$$: $heap->{name} active\n"; $kernel->alias_set( delete $heap->{alias} ) if $heap->{alias}; return 1; } #---------------------------------------------------- sub _stop { DEBUG and warn "$$: $_[HEAP]->{name} delete\n"; } #---------------------------------------------------- sub __thunk { my($kernel, $heap, $rsvp, $call, $from, $wantarray)= @_[KERNEL, HEAP, ARG0, ARG1, ARG2, ARG3]; $heap->{from} = $from; # warn "no FROM" unless $from; if($rsvp) { # foreign session wants returned value DEBUG2 and warn "Calling ", Dumper $call; DEBUG2 and do { warn "Wants an array" if $wantarray}; my(@ret, $yes); if($wantarray) { @ret=$kernel->call(@$call); $yes = 0<@ret; } else { $ret[0]=$kernel->call(@$call); $yes = defined $ret[0]; } if($yes) { DEBUG2 and do { local $"=', '; warn "Posted response '@ret' to ", Dumper $rsvp; }; # This is the POSTBACK $POE::Component::IKC::Responder::ikc->send_msg( {params=>($wantarray ? \@ret : $ret[0]), event=>$rsvp}, $call->[0]); } } else { # 2009/05 - use ->call() so that {from} can't be modified # before refcount_increment is called DEBUG2 and warn "Posting ", Dumper $call; $kernel->call(@$call); } } #---------------------------------------------------- sub _default { my($kernel, $heap, $sender, $state, $args)= @_[KERNEL, HEAP, SENDER, ARG0, ARG1]; return if $state =~ /^_/; unless($heap->{from}) { warn "$$: Attempt to respond to an anonymous foreign post with '$state'\n"; return; } if( not $heap->{from}{state} ) { my $event = { %{$heap->{from}} }; $event->{state} = $state; $POE::Component::IKC::Responder::ikc->send_msg( {params=>$args, event=>$event}, $sender ); } else { $POE::Component::IKC::Responder::ikc->send_msg( {params=>[$state, $args], event=>$heap->{from}}, $sender ); } } 1; __END__ =head1 NAME POE::Component::IKC::Responder - POE IKC state handler =head1 SYNOPSIS use POE; use POE::Component::IKC::Responder; create_ikc_responder(); ... $kernel->post('IKC', 'post', $to_state, $state); $ikc->publish('my_name', [qw(state1 state2 state3)]); =head1 DESCRIPTION This module implements POE IKC state handling. The responder handles posting states to foreign kernels and calling states in the local kernel at the request of foreign kernels. There are 2 interfaces to the responder. Either by sending states to the 'IKC' session or the object interface. While the latter is faster, the better behaved, because POE is a cooperative system. =head1 STATES/METHODS =head2 C POE::Component::IKC::Responder->spawn(); This function creates the Responder session and object. Normally, L or L does this for you. But in some applications you want to make sure that the Responder is up and running before then. =head2 C Sends an state request to a foreign kernel. Returns logical true if the state was sent and logical false if it was unable to send the request to the foreign kernel. This does not mean that the foreign kernel was able to post the state, however. Parameters are as follows : =over 2 =item C Specifier for the foreign state. See L. =item C A reference to anything you want the foreign state to get as ARG0. If you want to specify several parameters, use an array ref and have the foreign state dereference it. $kernel->post('IKC', 'post', {kernel=>'Syslog', session=>'logger', state=>'log'}, [$faculty, $priority, $message]; or $ikc->post('poe://Syslog/logger/log', [$faculty, $priority, $message]); This logs an state with a hypothetical logger. =back See the L below. =head2 C This is identical to C, except it has a 3rd parameter that describes what state should receive the return value from the foreign kernel. $kernel->post('IKC', 'call', 'poe://Pulse/timeserver/time', '', 'poe:get_time'); or $ikc->call({kernel=>'Pulse', session=>'timeserver', state=>'time'}, '', 'poe://me/get_time'); This asks the foreign kernel 'Pulse' for the time. 'get_time' state in the current session is posted with whatever the foreign state returned. You do not have to publish callback messages, because they are temporarily published. How temporary? They can be posted from a remote kernel ONCE only. This, of course, is a problem because someone else could get in a post before the callback. Such is life. =over 3 =item C Identical to the C C parameter. =item C Identical to the C C parameter. =item C Event identification for the callback. That is, this state is called with the return value of the foreign state. Can be a C specifier or simply the name of an state in the current session. =back $kernel->call('IKC', 'post', {kernel=>'e-comm', session=>'CC', state=>'check'}, {CC=>$cc, expiry=>$expiry}, folder=>$holder}, 'is_valid'); # or $ikc->call('poe://e-comm/CC/check', {CC=>$cc, expiry=>$expiry}, folder=>$holder}, 'poe://me/is_valid'); This asks the e-comm server to check if a credit card number is "well formed". Yes, this would probably be massive overkill. The C state does not need to be published. IKC keeps track of the rsvp state and will allow the foreign kernel to post to it. See the L below. =head2 C Sets the default foreign kernel. You must be connected to the foreign kernel first. Unique parameter is the name of the foreign kernel kernel. Returns logical true on success. =head2 C Registers foreign kernel names with the responder. This is done during the negociation phase of IKC and is normaly handled by C. Will define the default kernel if no previous default kernel exists. First parameter is either a single kernel name. Second optional parameter is an array ref of kernel aliases to be registered. =head2 C Unregisters one or more foreign kernel names with the responder. This is done when the foreign kernel disconnects by L. If this is the default kernel, there is no more default kernel. First parameter is either a single kernel name or a kernel alias. Second optional parameter is an array ref of kernel aliases to be unregistered. This second parameter is a tad silly, because if you unregister a remote kernel, it goes without saying that all it's aliases get unregistered also. =head2 C Registers new aliases for local kernel with the responder. This is done internally by L and L. Will NOT define the default kernel. First and only parameter is an array ref of kernel aliases to be registered. =head2 C Tell IKC that some states in the current session are available for use by foreign sessions. =over 2 =item C A session alias by which the foreign kernels will call it. The alias must already have been registered with the local kernel. =item C Arrayref of states that foreign kernels may post. $kernel->post('IKC', 'publish', 'me', [qw(foo bar baz)]); # or $ikc->publish('me', [qw(foo bar baz)]); =back =head2 C Tell IKC that some states should no longer be available for use by foreign sessions. You do not have to retract all published states. =over 2 =item C Same as in C =item C Same as in C. If not supplied, *all* published states are retracted. $kernel->post('IKC', 'retract', 'me', [qw(foo mibble dot)]); # or $ikc->retract('me', [qw(foo)]); =back =head2 C $list=$kernel->call(IKC=>'published', $session); Returns a list of all the published states. $hash=$kernel->call(IKC=>'published'); Returns a hashref, keyed on session IDs. Values are arrayref of states published by that session. =over 2 =item C A session alias that you wish the list of states for. =back =head2 C Subscribe to foreign sessions or states. When you have subscribed to a foreign session, a proxy session is created on the local kernel that will allow you to post to it like any other local session. =over 3 =item C An arrayref of the session or state specifiers you wish to subscribe to. While the wildcard '*' kernel may be used, only the first kernel that acknowledges the subscription will be proxied. =item C Either a state (for the state interface) or a coderef (for the object interface) that is posted (or called) when all subscription requests have either been replied to, or have timed out. When called, it has a single parameter, an arrayref of all the specifiers that IKC was able to subscribe to. It is up to you to see if you have enough of the foreign sessions or states to get the job done, or if you should give up. While C isn't required, it makes a lot of sense to use it because it is only way to find out when the proxy sessions become available. Example : $ikc->subscribe([qw(poe://Pulse/timeserver)], sub { $kernel->post('poe://Pulse/timeserver', 'connect') }); (OK, that's a bad example because we don't check if we actually managed to subscribe or not.) $kernel->post('IKC', 'subscribe', [qw(poe://e-comm/CC poe://TouchNet/validation poe://Cantax/JDE poe://Informatrix/JDE) ], 'poe:subscribed', ); # and in state 'subscribed' sub subscribed { my($kernel, $specs)=@_[KERNEL, ARG0]; if(@$specs != 4) { die "Unable to find all the foreign sessions needed"; } $kernel->post('poe://Cantax/JDE', 'write', {...somevalues...}); } This is a bit of a mess. You might want to use the C parameter to L instead. Subscription receipt timeout is currently set to 120 seconds. =back =head2 C Reverse of the L method. However, it is currently not documented well. =head2 C Responds with 'PONG'. This is auto-published, so it can be called from remote kernels to see if the local kernel is still around. In fact, I don't see any other use for this. $kernel->post('poe://remote/IKC', 'ping', 'some_state'); $kernel->delay('some_state', 60); # timeout sub some_state { my($pong)=$_[ARG0]; return if $pong; # all is cool # YOW! Remote kernel timed out. RUN AROUND SCREAMING! } =head2 C Hopefully causes IKC and all peripheral sessions to dissapear in a puff of smoke. At the very least, any sessions left will be either not related to IKC or barely breathing (that is, only have aliases keeping them from GC). This should allow you to sanely shut down your process. =head2 C Allows a session to monitor the state of remote kernels. Currently, a session is informed when a remote kernel is registered, unregistered, subscribed to or unsubscribed from. One should make sure that the IKC alias exists before trying to monitor. Do this by calling L->spawn or in an C callback. $kernel->post('IKC', 'monitor', $remote_kernel_id, $states); =over 3 =item C<$remote_kernel_id> Name or alias or IKC specifier of the remote kernel you wish to monitor. You can also specify C<*> to monitor ALL remote kernels. If you do, your monitor will be called several times for a given kernel. This is because a kernel has one name and many aliases. For example, a remote kernel will have a unique ID within the local kernel, a name (passed to or generated by create_ikc_{kernel,client}) and a globaly unique ID assigned by the remote kernel via $kernel->ID. This suprises some people, but see the short note after the explanation of the callback parameters. Note: An effort has been made to insure that when monitoring C<*>, L is first called with the remote kernel's unique ID, and subsequent calls are aliases. This can't be guaranteed at this time, however. =item C<$states> Hashref that specifies what callback states are called when something interesting happens. If $state is empty or undef, the session will no longer monitor the given remote kernel. =back =head2 Callback states The following states can be monitored: =over 6 =item C Called when a remote kernel or alias is registered. This is equivalent to when the connection phase is finished. =item C Called when a remote kernel or alias is unregistered. This is equivalent to when the remote kernel disconnects. =item C Called when IKC succeeds in subscribing to a remote session. ARG3 is an IKC::Specifier of what was subscribed to. Use this for posting to the proxy session. =item C Called when IKC succeeds in unsubscribing from a remote session. =item C You are informed whenever someone tries to do a sane shutdown of IKC and all peripheral sessions. This will called only once, after somebody posts an IKC/shutdown event. =item C Little bit of data (can be scalar or reference) that is passed to the callback. This allows you to more magic. =back The callback states are called the following parameters : =over 6 =item C Name of the kernel that was passed to poe://*/IKC/monitor =item C ID or alias of remote kernel from IKC's point of view. =item C A flag. If this is true, then ARG1 is the remote kernel unique ID, if false, then ARG1 is an alias. This is mostly useful when monitoring C<*> and is in fact a bit bloatful. =item C C<$state-E{data}> ie any data you want. =item C ... C Callback-specific parameters. See above. =back Most of the time, ARG0 and ARG1 will be the same. Exceptions are if you are monitoring C<*> or if you supplied a full IKC event specifier to IKC/monitor rather then just a plain kernel name. =head2 Short note about monitoring all kernels with C<*> There are 2 reasons circonstances in which you will be monitoring all remote kernels : names known in advance and names unknown in advance. If you know kernel names in advance, you might be better off monitoring a given kernel name. However, you might prefer doing a case-like compare on ARG1 (with regexes, say). This would be useful for clustering, where various redundant kernels could follow a naming convention like [application]-[host], so you could compare C with C to find out if you want to set up specific things for that kernel. Not knowing the name of a kernel in advance, you could be doing some sort of autodiscovery or maybe just monitoring for debuging, logging or book-keeping purposes. You obviously don't want to do autodiscovery for every alias of every kernel, only for the "cannonical name", hence the need for ARG2. =head2 Short note the second You are more then allowed (in fact, you are encouraged) to use the same callback states when monitoring multiple kernels. In this case, you will find ARG0 useful for telling them apart. $kernel->post('IKC', 'monitor', '*', {register=>'remote_register', unregister=>'remote_unregister', subscribe=>'remote_subscribe', unsubscribe=>'remote_unsubscribe', data=>'magic box'}); Now remote_{register,unregister,subscribe,unsubscribe} is called for any remote kernel. $kernel->post('IKC', 'monitor', 'Pulse', {register=>'pulse_connected'}); C will be called in current session when you succeed in connecting to a kernel called 'Pulse'. $kernel->post('IKC', 'monitor', '*'); Session is no longer monitoring all kernels, only 'Pulse'. $kernel->post('IKC', 'monitor', 'Pulse', {}); Now we aren't even interested in 'Pulse'; =head1 EXPORTED FUNCTIONS =head2 C This function creates the Responder session and object. However, you don't need to call this directly, because L or L does this for you. Deprecated, use L. =head1 PROXY SENDER Event handlers invoked via IKC will have a proxy SENDER session. You may use it to post back to the remote session. $poe_kernel->post( $_[SENDER], 'response', @args ); Normally this proxy session is available during the invocation of the event handler. You may claim it for longer by setting an external reference: $heap->{remote} = $_[SENDER]->ID; $poe_kernel->refcount_increment( $heap->{remote}, 'MINE' ); POE::Component::IKC will detect this and create a new proxy session for future calls. It will then be UP TO YOU to free the session: $poe_kernel->refcount_decrement( $heap->{remote}, 'MINE' ); Note that you will have to publish any events that will be posted back. =head1 BUGS Sending session references and coderefs to a foreign kernel is a bad idea. At some point it would be desirable to recurse through the paramerters and and turn any session references into state specifiers. The C state in call is a bit problematic. IKC allows it to be posted to once, but doesn't check to see if the foreign kernel is the right one. C does not currently tell foreign kernels that have subscribed to a session/state about the retraction. Cing a state in a proxied foreign session doesn't work, for obvious reasons. =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L, L, L, L, L, L, L. =cut POE-Component-IKC-0.2305/IKC/Server.pm0000644000076400007640000010354112106220560015120 0ustar filfilpackage POE::Component::IKC::Server; ############################################################ # $Id: Server.pm 1077 2013-02-11 16:50:56Z fil $ # Based on refserver.perl and preforkedserver.perl # Contributed by Artur Bergman # Revised for 0.06 by Rocco Caputo # Turned into a module by Philp Gwyn # # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use Socket; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use POE qw(Wheel::ListenAccept Wheel::SocketFactory); use POE::Component::IKC::Channel; use POE::Component::IKC::Responder; use POSIX qw(:errno_h); use POSIX qw(ECHILD EAGAIN WNOHANG); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(create_ikc_server); $VERSION = '0.2305'; sub DEBUG { 0 } sub DEBUG_USR2 { 1 } BEGIN { # http://support.microsoft.com/support/kb/articles/Q150/5/37.asp eval '*WSAEAFNOSUPPORT = sub { 10047};'; if($^O eq 'MSWin32') { eval '*EADDRINUSE = sub { 10048 };'; } } ############################################################################### #---------------------------------------------------- # This is just a convenient way to create servers. To be useful in # multi-server situations, it probably should accept a bind address # and port. sub spawn { my($package, %params)=@_; $params{package} ||= $package; unless($params{unix}) { $params{ip}||='0.0.0.0'; # INET_ANY $params{port} = 603 # POE! (almost :) unless defined $params{port}; } $params{protocol} ||= 'IKC0'; # Make sure one is available POE::Component::IKC::Responder->spawn(); my $session = POE::Session->create( package_states => [ $params{package} => [qw( _start _stop error _child accept fork retry waste_time babysit rogues shutdown sig_CHLD sig_INT sig_USR2 sig_USR1 sig_TERM )], ], args=>[\%params], ); my $heap = $session->get_heap; return $heap->{wheel_port}; } sub create_ikc_server { my( %params )=@_; $params{package} ||= __PACKAGE__; return $params{package}->spawn( %params ); } #---------------------------------------------------- sub _select_define { my($heap, $on)=@_; return unless $heap->{wheel}; $on||=0; DEBUG and warn "_select_define (on=$on)"; if($on) { $heap->{wheel}->resume_accept } else { $heap->{wheel}->pause_accept } return; } #---------------------------------------------------- # Drop the wheel sub _delete_wheel { my( $heap ) = @_; return unless $heap->{wheel}; my $w = delete $heap->{wheel}; $w->DESTROY; return; } #---------------------------------------------------- # sub _concurrency_up { my( $heap ) = @_; $heap->{concur_connections}++; DEBUG and warn "$$: $heap->{concur_connections} concurrent connections (max $heap->{concurrency})"; return unless $heap->{concurrency} > 0; if( $heap->{concur_connections} >= $heap->{concurrency} ) { DEBUG and warn "$$: Blocking more concurrency"; $heap->{blocked} = 1; _select_define( $heap, 0 ); } } sub _concurrency_down { my( $heap ) = @_; $heap->{concur_connections}--; DEBUG and warn "$$: $heap->{concur_connections} concurrent connections"; return unless $heap->{concurrency} > 0; if( $heap->{concur_connections} < $heap->{concurrency} and delete $heap->{blocked} ) { DEBUG and warn "$$: Unblocking concurrency"; _select_define( $heap, 1 ); } } #---------------------------------------------------- # Delete all delays sub _delete_delays { $poe_kernel->delay('rogues'); $poe_kernel->delay('waste_time'); $poe_kernel->delay('babysit'); $poe_kernel->delay( 'retry' ); return; } #---------------------------------------------------- # Accept POE's standard _start event, and set up the listening socket # factory. sub _start { my($heap, $params, $kernel) = @_[HEAP, ARG0, KERNEL]; my $ret; # monitor for shutdown events. # this is the best way to get IKC::Responder to tell us about the # shutdown $kernel->post(IKC=>'monitor', '*', {shutdown=>'shutdown'}); my $alias='unknown'; my %wheel_p=( Reuse => 'yes', # and allow immediate reuse of the port SuccessEvent => 'accept', # generating this event on connection FailureEvent => 'error' # generating this event on error ); if($params->{unix}) { $alias="unix:$params->{unix}"; $wheel_p{SocketDomain}=AF_UNIX; $wheel_p{BindAddress}=$params->{unix}; $heap->{unix}=$params->{unix}; unlink $heap->{unix}; # blindly do this ? } else { $alias="$params->{ip}:$params->{port}"; $wheel_p{BindPort} = $params->{port}; $wheel_p{BindAddress}= $params->{ip}; } DEBUG && warn "$$: Server starting $alias.\n"; $heap->{name}=$params->{name}; $heap->{kernel_aliases}=$params->{aliases}; $heap->{concurrency}=$params->{concurrency} || 0; $heap->{protocol}=$params->{protocol}; # create a socket factory $heap->{wheel} = new POE::Wheel::SocketFactory (%wheel_p); if( $heap->{wheel} and not $params->{unix} and not $params->{port} ) { $heap->{wheel_port} = $ret = ( sockaddr_in( $heap->{wheel}->getsockname() ) )[0]; $alias="$params->{ip}:$ret"; DEBUG && warn "$$: Server listening on $alias.\n"; } $heap->{wheel_address}=$alias; $heap->{connections} = 0; # +GC $kernel->alias_set("IKC Server $alias"); # set up local names for kernel my @names=($heap->{name}); if($heap->{kernel_aliases}) { if(ref $heap->{kernel_aliases}) { push @names, @{$heap->{kernel_aliases}}; } else { push @names, $heap->{kernel_aliases}; } } $kernel->post(IKC=>'register_local', \@names); # pre-load the default serialisers foreach my $ft ( qw(Storable FreezeThaw POE::Component::IKC::Freezer) ) { eval { local $SIG{__WARN__} = sub {1}; local $SIG{__DIE__} = 'DEFAULT'; POE::Filter::Reference->new( $ft ); }; warn "$ft: $@" if DEBUG and $@; } return $ret unless $params->{processes}; # Delete the SocketFactory's read select in the parent # We don't ever want the parent to accept a connection # Children put the state back in place after the fork _select_define($heap, 0); $kernel->sig(CHLD => 'sig_CHLD'); $kernel->sig(TERM => 'sig_TERM'); $kernel->sig(INT => 'sig_INT'); DEBUG_USR2 and $kernel->sig('USR2', 'sig_USR2'); DEBUG_USR2 and $kernel->sig('USR1', 'sig_USR1'); # keep track of children $heap->{children} = {}; $heap->{'failed forks'} = 0; $heap->{verbose}=$params->{verbose}||0; $heap->{"max connections"}=$params->{connections}||1; $heap->{'is a child'} = 0; # change behavior for children my $children=0; foreach (2..$params->{processes}) { # fork the initial set of children $kernel->yield('fork', ($_ == $params->{processes})); $children++; } $kernel->yield('waste_time', 60) unless $children; if($params->{babysit}) { $heap->{babysit}=$params->{babysit}; delete($heap->{"proctable"}); eval { require Proc::ProcessTable; $heap->{"proctable"}=new Proc::ProcessTable; }; DEBUG and do { print "Unable to load Proc::ProcessTable: $@\n" if $@; }; $kernel->yield('babysit'); } return $ret; } #------------------------------------------------------------------------------ sub _child { my( $heap, $kernel, $op, $child, $ret ) = @_[ HEAP, KERNEL, ARG0, ARG1, ARG2 ]; $ret ||= ''; DEBUG and warn "$$: _child op=$op child=$child ret=$ret"; unless( $ret eq "channel-$child" ) { if( $op eq 'create' ) { DEBUG and warn "$$: Detatching child session $child"; $kernel->detach_child( $child ); } return; } if( $op eq 'lose' ) { DB::disable_profile() if $INC{'Devel/NYTProf.pm'}; $heap->{child_sessions}--; if( $heap->{child_sessions} > 0 ) { DEBUG and warn "$$: still have a child session"; } _concurrency_down($heap); } else { $heap->{child_sessions}++; return; } unless( $heap->{wheel} ) { # no wheel == GAME OVER ( DEBUG and not $INC{'Test/More.pm'} ) and warn "$$: }}}}}}}}}}}}}}} Game over\n"; # XXX: Using shutdown is a stop-gap measure. Maybe the daemon # wants to stay alive even if IKC was shutdown... # XXX: more to the point, maybe there are still requests that are # hanging around ! $kernel->call( IKC => 'shutdown' ); } } #------------------------------------------------------------------------------ # This event keeps this POE kernel alive sub waste_time { my($kernel, $heap)=@_[KERNEL, HEAP]; return if $heap->{'is a child'}; unless($heap->{'been told we are parent'}) { $heap->{verbose} and warn "$$: Telling everyone we are the parent\n"; $heap->{'been told we are parent'}=1; $kernel->signal($kernel, '__parent'); } if($heap->{'die'}) { DEBUG and warn "$$: Orderly shutdown\n"; } else { $kernel->delay('waste_time', 60); } return; } #------------------------------------------------------------------------------ # Babysit the child processes sub babysit { my($kernel, $heap)=@_[KERNEL, HEAP]; return if $heap->{'die'} or # don't scan if we are dieing $heap->{'is a child'}; # or if we are a child my @children=keys %{$heap->{children}}; $heap->{verbose} and warn "$$: Babysiting ", scalar(@children), " children ", join(", ", sort @children), "\n"; my %table; if($heap->{proctable}) { my $table=$heap->{proctable}->table; %table=map {($_->pid, $_)} @$table } my(%missing, $state, $time, %rogues, %ok); foreach my $pid (@children) { if($table{$pid}) { $state=$table{$pid}->state; if($state eq 'zombie') { my $t=waitpid($pid, POSIX::WNOHANG()); if($t==$pid) { # process was reaped, now fake a SIGCHLD DEBUG and warn "$$: Faking a CHLD for $pid\n"; $kernel->yield('sig_CHLD', 'CHLD', $pid, $?, 1); $ok{$pid}=1; } else { $heap->{verbose} and warn "$$: $pid is a $state and couldn't be reaped.\n"; $missing{$pid}=1; } } elsif($state eq 'run') { $time=eval{$table{$pid}->utime + $table{$pid}->stime}; warn $@ if $@; # utime and stime are Linux-only :( $time /= 1_000_000 if $time; # micro-seconds -> seconds if($time and $time > 1200) { # arbitrary limit of 20 minutes $rogues{$pid}=$table{$pid}; warn "$$: $pid has gone rogue, time=$time s\n"; } else { DEBUG and warn "$$: child $pid has utime+stime=$time s\n" if $time > 1; $ok{$pid}=1; } } elsif($state eq 'sleep' or $state eq 'defunct') { $ok{$pid}=1; # do nothing } else { $heap->{verbose} and warn "$$: $pid has unknown state '$state'\n"; $ok{$pid}=1; } } elsif($heap->{proctable}) { $heap->{verbose} and warn "$$: $pid isn't in proctable!\n"; $missing{$pid}=1; } else { # try another means.... :/ if(-d "/proc" and not -d "/proc/$pid") { DEBUG and warn "$$: Unable to stat /proc/$pid! Is the child missing\n"; $missing{$pid}=1; } elsif(not $missing{$pid}) { $ok{$pid}=1; } } } # if a process is MIA, we fake a death, and spawn a new child foreach my $pid (keys %missing) { $kernel->yield('sig_CHLD', 'CHLD', $pid, 0, 1); $heap->{verbose} and warn "$$: Faking a CHLD for $pid MIA\n"; } # we could do the same thing for rogue processes, but instead we # give them time to calm down if($heap->{rogues}) { # processes that are %ok are now removed # from the list of rogues delete @{$heap->{rogues}}{keys %ok} if %ok; } if(%rogues) { $kernel->yield('rogues') if not $heap->{rogues}; $heap->{rogues}||={}; foreach my $pid (keys %rogues) { if($heap->{rogues}{$pid}) { $heap->{rogues}{$pid}{proc}=$rogues{$pid}; } else { $heap->{rogues}{$pid}={proc=>$rogues{$pid}, tries=>0}; } } } $kernel->delay('babysit', $heap->{babysit}); return; } #------------------------------------------------------------------------------ # Deal with rogue child processes sub rogues { my($kernel, $heap)=@_[KERNEL, HEAP]; return if $heap->{'die'} or # don't scan if we are dieing $heap->{'is a child'}; # or if we are a child # make sure we have some real work return unless $heap->{rogues}; eval { if(ref($heap->{rogues}) ne 'HASH' or not keys %{$heap->{rogues}}) { delete $heap->{rogues}; return; } my $signal; while(my($pid, $rogue)=each %{$heap->{rogues}}) { $signal=0; if($rogue->{tries} < 1) { $signal=2; } elsif($rogue->{tries} < 2) { $signal=15; } elsif($rogue->{tries} < 3) { $signal=9; } if($signal) { DEBUG and warn "$$: Sending signal $signal to rogue $pid\n"; unless($rogue->{proc}->kill($signal)) { warn "$$: Error sending signal $signal to $pid: $!\n"; delete $heap->{rogues}{$pid}; } } else { # if SIGKILL didn't work, it's beyond hope! $kernel->yield('sig_CHLD', 'CHLD', $pid, 0, 1); delete $heap->{rogues}{$pid}; $heap->{verbose} and warn "$$: Faking a CHLD for rogue $pid\n"; } $rogue->{tries}++; } $kernel->delay('rogues', 2*$heap->{babysit}); }; warn "$$: $@" if $@; } #------------------------------------------------------------------------------ # Accept POE's standard _stop event, and stop all the children, too. # The 'children' hash is maintained in the 'fork' and 'sig_CHLD' # handlers. It's empty for children. sub _stop { my($kernel, $heap) = @_[KERNEL, HEAP]; # kill the child servers if($heap->{children}) { foreach (keys %{$heap->{children}}) { DEBUG && print "$$: server is killing child $_ ...\n"; kill 2, $_ or warn "$$: $_ $!\n"; } } if($heap->{unix}) { unlink $heap->{unix}; } DEBUG && warn "$$: Server $heap->{name} _stop\n"; # DEBUG_USR2 and check_kernel($kernel, $heap->{'is a child'}, 1); # __peek( 1 ); } #------------------------------------------------------------------------------ sub shutdown { my($kernel, $heap)=@_[KERNEL, HEAP]; DEBUG and warn "$$: Server $heap->{name} shutdown\n"; _delete_wheel( $heap ); # close socket _delete_delays(); # get it OVER with # -GC # $kernel->alias_remove("IKC Server $heap->{wheel_address}"); $heap->{'die'}=1; # prevent race conditions } #---------------------------------------------------- # Log server errors, but don't stop listening for connections. If the # error occurs while initializing the factory's listening socket, it # will exit anyway. sub error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; warn __PACKAGE__, " $$: encountered $operation error $errnum: $errstr\n"; my $ignore; if($errnum==EADDRINUSE) { # EADDRINUSE warn "$$: IKC Address $heap->{wheel_address} in use\n"; $heap->{'die'}=1; _delete_wheel( $heap ); $ignore=1; } elsif($errnum==WSAEAFNOSUPPORT) { # Address family not supported by protocol family. # we get this error, yet nothing bad happens... oh well $ignore=1; } unless($ignore) { # TODO : post to monitors warn __PACKAGE__, " $$: encountered $operation error $errnum: $errstr\n"; } } #---------------------------------------------------- # The socket factory invokes this state to take care of accepted # connections. sub accept { my ($heap, $kernel, $handle, $peer_host, $peer_port) = @_[HEAP, KERNEL, ARG0, ARG1, ARG2]; T->start( 'IKC' ); if(DEBUG) { if($peer_port) { warn "$$: Server connection from ", inet_ntoa($peer_host), ":$peer_port", ($heap->{'is a child'} ? " (Connection $heap->{connections})\n" : "\n"); } else { warn "$$: Server connection over $heap->{unix}", ($heap->{'is a child'} ? " (Connection $heap->{connections})\n" : "\n"); } } if($heap->{children} and not $heap->{'is a child'}) { warn "$$: Parent process received a connection: THIS SUCKS\n"; return; } DB::enable_profile() if $INC{'Devel/NYTProf.pm'}; DEBUG and warn "$$: Server kernel_aliases=", join ',', @{$heap->{kernel_aliases}||[]}; # give the connection to a channel POE::Component::IKC::Channel->spawn( handle=>$handle, name=>$heap->{name}, unix=>$heap->{unix}, aliases=>[@{$heap->{kernel_aliases}||[]}], protocol=>$heap->{protocol} ); _concurrency_up($heap); return unless $heap->{children}; if (--$heap->{connections} < 1) { DEBUG and warn "$$: {{{{{{{{{{{{{{{ Game over\n"; $kernel->delay('waste_time'); _delete_wheel( $heap ); $::TRACE_REFCNT = 1; } else { DEBUG and warn "$$: $heap->{connections} connections left\n"; } } #------------------------------------------------------------------------------ # The server has been requested to fork, so fork already. sub fork { my ($kernel, $heap, $last) = @_[KERNEL, HEAP, ARG0]; # children should not honor this event # Note that the forked POE kernel might have these events in it already # this is unavoidable if($heap->{'is a child'} or not $heap->{children} or $heap->{'die'}) { DEBUG and warn "$$: We are a child, why are we forking?\n"; return; } my $parent=$$; DEBUG and warn "$$: Forking a child"; my $pid = fork(); # try to fork unless (defined($pid)) { # did the fork fail? # try again later, if a temporary error if (($! == EAGAIN) || ($! == ECHILD)) { DEBUG and warn "$$: Recoverable forking problem"; $heap->{'failed forks'}++; $kernel->delay('retry', 1); } # fail permanently, if fatal else { warn "Can't fork: $!\n"; $kernel->yield('_stop'); } return; } # successful fork; parent keeps track if ($pid) { $heap->{children}->{$pid} = 1; DEBUG && print( "$$: master server forked a new child. children: (", join(' ', sort keys %{$heap->{children}}), ")\n" ); $kernel->yield('waste_time') if $last; } # child becomes a child server else { $heap->{verbose} and warn "$$: Created ", scalar localtime, "\n"; # This resets some kernel data that was preventing the child process's # kernel from becoming IDLE if( $kernel->can( 'has_forked' ) ) { $kernel->has_forked; } else { $kernel->_data_sig_initialize; } # Clean out stuff that the parent needs but not the children $heap->{'is a child'} = 1; # don't allow fork $heap->{'failed forks'} = 0; $heap->{children}={}; # don't kill child processes # limit sessions, then die off $heap->{connections} = $heap->{"max connections"}; # These signals are no longer our problem $kernel->sig('CHLD'); $kernel->sig('INT'); # remove any waits that might be around _delete_delays(); # get it OVER with delete @{$heap}{qw(rogues proctable)}; # Tell everyone we are now a child $kernel->signal($kernel, '__child'); # Create a select for the children, so that SocketFactory can # do it's thing _select_define($heap, 1); DEBUG && print "$$: child server has been forked\n"; } # remove the call return; } #------------------------------------------------------------------------------ # Retry failed forks. This is invoked (after a brief delay) if the # 'fork' state encountered a temporary error. sub retry { my ($kernel, $heap) = @_[KERNEL, HEAP]; if($heap->{'is a child'} or not $heap->{children}) { warn "$$: We are a child, why are we forking?\n"; return; } # Multiplex the delayed 'retry' event into enough 'fork' events to # make up for the temporary fork errors. for (1 .. $heap->{'failed forks'}) { $kernel->yield('fork'); } # reset the failed forks counter $heap->{'failed forks'} = 0; return; } #------------------------------------------------------------------------------ # SIGCHLD causes this session to fork off a replacement for the lost child. sub sig_CHLD { my ($kernel, $heap, $signal, $pid, $status, $fake) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2, ARG3]; return if $heap->{"is a child"}; if($heap->{children}) { # if it was one of ours; fork another if (delete $heap->{children}->{$pid}) { DEBUG && print( "$$: master caught SIGCHLD for $pid. children: (", join(' ', sort keys %{$heap->{children}}), ")\n" ); $heap->{verbose} and warn "$$: Child $pid ", ($fake?'is gone':'exited normaly'), ".\n"; $kernel->yield('fork') unless $heap->{'die'}; } elsif($fake) { warn "$$: Needless fake CHLD for $pid\n"; } else { warn "$$: CHLD for $pid child of someone else.\n"; } } # don't handle terminal signals return; } #------------------------------------------------------------------------------ # Terminal signals aren't handled, so the session will stop on SIGINT. # The _stop event handler takes care of cleanup. sub sig_INT { my ($kernel, $heap, $signal, $pid, $status) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2]; return 0 if $heap->{"is a child"}; if($heap->{children}) { $heap->{verbose} and warn "$$ SIGINT\n"; $heap->{'die'}=1; # kill all events _delete_delays(); # get it OVER with } else { _delete_wheel( $heap ); } $kernel->post( IKC => 'shutdown' ); $kernel->sig_handled(); # INT is terminal return; } #------------------------------------------------------------------------------ # daemontool's svc -d sends a TERM # The _stop event handler takes care of cleanup. sub sig_TERM { my ($kernel, $heap, $signal, $pid, $status) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2]; $heap->{verbose} and warn "$$ SIGTERM\n"; $heap->{'die'}=1; _delete_wheel( $heap ); _delete_delays(); # get it OVER with $kernel->post( IKC => 'shutdown' ); $kernel->sig_handled(); # TERM is terminal return; } ############################################################ sub check_kernel { my($kernel, $child, $signal)=@_; if(ref $kernel) { # 2 = KR_HANDLES # 7 = KR_EVENTS # 8 = KR_ALARMS (NO MORE!) # 12 = KR_EXTRA_REFS # 0 = HND_HANDLE warn( "$$: ,----- Kernel Activity -----\n", "$$: | States : ", scalar(@{$kernel->[7]}), " ", join( ', ', map {$_->[0]->ID."/$_->[2]"} @{$kernel->[7]}), "\n", # "$$: | Alarms : ", scalar(@{$kernel->[8]}), "\n", "$$: | Files : ", scalar(keys(%{$kernel->[2]})), "\n", "$$: | `--> : ", join( ', ', sort { $a <=> $b } map { fileno($_->[0]) } values(%{$kernel->[2]}) ), "\n", "$$: | Extra : ${$kernel->[12]}\n", "$$: `---------------------------\n", ); # if($child) { # foreach my $q (@{$kernel->[8]}) { # warn "************ Alarm for ", join '/', @{$q->[0][2]{$q->[2]}}; # } # } } else { warn "$kernel isn't a reference"; } } ############################################################ sub __peek { my($verbose)=@_; eval { require POE::Component::Daemon; }; unless( $@ ) { my $ret = Daemon->peek( $verbose ); $ret =~ s/\n/\n$$: /g; warn "$$: $ret"; return 1; } eval { require POE::API::Peek; }; if($@) { DEBUG and warn "Failed to load POE::API::Peek: $@"; return; } my $api=POE::API::Peek->new(); my @queue = $api->event_queue_dump(); my $ret = "Event Queue:\n"; my $events = {}; foreach my $item (@queue) { $ret .= "\t* ID: ". $item->{ID}." - Index: ".$item->{index}."\n"; $ret .= "\t\tPriority: ".$item->{priority}."\n"; $ret .= "\t\tEvent: ".$item->{event}."\n"; if($verbose) { $events->{ $item->{source}->ID }{source} ++; $ret .= "\t\tSource: ". $api->session_id_loggable($item->{source}). "\n"; $ret .= "\t\tDestination: ". $api->session_id_loggable($item->{destination}). "\n"; $ret .= "\t\tType: ".$item->{type}."\n"; $ret .= "\n"; } } if($api->session_count) { $ret.="Keepalive " unless $verbose; $ret.="Sessions: \n"; my $ses; foreach my $session ( sort { $a->ID <=> $b->ID } $api->session_list) { my $ref=0; $ses=''; $ses.="\tSession ".$api->session_id_loggable($session)." ($session)"; my $refcount=$api->get_session_refcount($session); $ses.="\n\t\tref count: $refcount\n"; my $q1=$api->get_session_extref_count($session); $ref += $q1; $ses.="\t\textref count: $q1 [keepalive]\n" if $q1; my $hc=$api->session_handle_count($session); $ref += $hc; $ses.="\t\thandle count: $q1 [keepalive]\n" if $hc; my @aliases=$api->session_alias_list($session); $ref += @aliases; $q1=join ',', @aliases; $ses.="\t\tAliases: $q1\n" if $q1; my @children = $api->get_session_children($session); if(@children) { $ref += @children; $q1 = join ',', map {$api->session_id_loggable($_)} @children; $ses.="\t\tChildren: $q1\n"; } $q1 = $events->{ $session->ID }{source}; if( $q1 ) { $ret.="\t\tEvent source count: $q1 (Stay alive)\n"; $ref += $q1; } $q1 = $events->{ $session->ID }{destination}; if( $q1 ) { $ret.="\t\tEvent destination count: $q1 (Stay alive)\n"; $ref += $q1; } if($refcount != $ref) { $ses.="\t\tReference: refcount=$refcount counted=$ref [keepalive]\n"; } if($hc or $verbose or $refcount != $ref) { $ret.=$ses; } } } $ret.="\n"; warn "$$: $ret"; return 1; } sub sig_USR2 { # return unless DEBUG; my ($kernel, $heap, $signal, $pid) = @_[KERNEL, HEAP, ARG0, ARG1]; $pid||=''; warn "$$: signal $signal $pid\n"; unless(__peek(1)) { check_kernel($kernel, $heap->{'is a child'}, 1); } $kernel->sig_handled(); return; } sub sig_USR1 { # return unless DEBUG; my ($kernel, $heap, $signal, $pid) = @_[KERNEL, HEAP, ARG0, ARG1]; $pid||=''; warn "$$: signal $signal $pid\n"; unless(__peek(0)) { check_kernel($kernel, $heap->{'is a child'}, 0); } $kernel->sig_handled(); return; } 1; __END__ # Below is the stub of documentation for your module. You better edit it! =head1 NAME POE::Component::IKC::Server - POE Inter-kernel Communication server =head1 SYNOPSIS use POE; use POE::Component::IKC::Server; POE::Component::IKC::Server->spawn( ip=>$ip, port=>$port, name=>'Server'); ... $poe_kernel->run(); =head1 DESCRIPTION This module implements a POE IKC server. A IKC server listens for incoming connections from IKC clients. When a client connects, it negociates certain connection parameters. After this, the POE server and client are pretty much identical. =head1 EXPORTED FUNCTIONS =head2 C Syntatic sugar for POE::Component::IKC::Server->spawn. =head1 CLASS METHODS =head2 C This methods initiates all the work of building the IKC server. Parameters are : =over 3 =item C Address to listen on. Can be a doted-quad ('127.0.0.1') or a host name ('foo.pied.nu'). Defaults to '0.0.0.0', aka INADDR_ANY. =item C Port to listen on. Can be numeric (80) or a service ('http'). If undefined, will default to 603. If you set the port to 0, a random port will be chosen and C will return the port number. my $port = POE::Component::IKC::Server->spawn( port => 0 ); warn "Listeing on port $port"; =item C Path to the unix-socket to listen on. Note: this path is unlinked before socket is attempted! Buyer beware. =item C Local kernel name. This is how we shall "advertise" ourself to foreign kernels. It acts as a "kernel alias". This parameter is temporary, pending the addition of true kernel names in the POE core. This name, and all aliases will be registered with the responder so that you can post to them as if they were remote. =item C Arrayref of even more aliases for this kernel. Fun Fun Fun! =item C Print extra information to STDERR if true. This allows you to see what is going on and potentially trace down problems and stuff. =item C Activates the pre-forking server code. If set to a positive value, IKC will fork processes-1 children. IKC requests are only serviced by the children. Default is 1 (ie, no forking). =item C Time, in seconds, between invocations of the babysitter event. =item C Number of connections a child will accept before exiting. Currently, connections are serviced concurrently, because there's no way to know when we have finished a request. Defaults to 1 (ie, one connection per child). =item C Number of simultaneous connected clients allowed. Defaults to 0 (unlimited). Note that this is per-IKC::Server instance; if you have several ways of connecting to a give IKC server (for example, both an TCP/IP port and unix pipe), they will not share the conncurrent connection count. =item C Which IKC negociation protocol to use. The original protocol (C) was synchronous and slow. The new protocol (C) sends all information at once. IKC0 will degrade gracefully to IKC, if the client and server don't match. Default is IKC0. =back C returns C, unless you specify a L=0, in which case, C returns the port that was chosen. =head1 EVENTS =head2 shutdown This event causes the server to close it's socket, clean up the shop and head home. Normally it is only posted from IKC::Responder. =head1 BUGS Preforking is something of a hack. In particular, you must make sure that your sessions will permit children exiting. This means, if you have a delay()-loop, or event loop, children will not exit. Once POE gets multicast events, I'll change this behaviour. =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L =cut POE-Component-IKC-0.2305/IKC/Specifier.pm0000644000076400007640000001245112106220560015562 0ustar filfilpackage POE::Component::IKC::Specifier; ############################################################ # $Id: Specifier.pm 1077 2013-02-11 16:50:56Z fil $ # # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw( specifier_parse specifier_name specifier_part); $VERSION = '0.2305'; sub DEBUG { 0 } #---------------------------------------------------- # Turn an specifier into a hash ref sub specifier_parse ($) { my($specifier)=@_; return if not $specifier; my $kernelRE = q((?:\*) | (?:[-. \w]+) | (?:[a-zA-Z0-9][-.a-zA-Z0-9]+:\d+) | (?:unix:[-.\w]+(?::\d+-\d+)?) ); unless(ref $specifier) { if($specifier=~m(^poe: (?: (//) ($kernelRE)? )? (?: (/) ([- \w]+) )? (?: (/)? ([- \w]*) )? (?: \x3f (\w+) )? $)x) { $specifier={kernel=>$2, session=>$4, state=>$6}; $specifier->{args}=$7 if $7; } elsif( $specifier =~ m(^ (?:(?://)($kernelRE)/)? (?:([- \w]+)/)? (?:([- \w]+))? (?: \x3f (\w+) )? $)x ) { $specifier = { kernel=>$1, session=>$2, state=>$3 }; $specifier->{args} = $4 if $4; } else { return; } } elsif('HASH' ne ref $specifier) { # carp "Why is specifier a ", ref $specifier; return; } $specifier->{kernel}||=''; $specifier->{session}||=''; $specifier->{state}||=''; return $specifier; } sub specifier_part ($$) { my($specifier, $part)=@_; return if not $specifier; $specifier="poe://$specifier" unless ref $specifier or $specifier=~/^poe:/; $specifier=specifier_parse $specifier; return if not $specifier; return $specifier->{$part}; } #---------------------------------------------------- # Turn an specifier into a string sub specifier_name ($) { my($specifier)=@_; return $specifier unless(ref $specifier); if(ref($specifier) eq 'ARRAY') { $specifier={kernel=>'', session=>$specifier->[0], state=>$specifier->[1], }; } my $name='poe:'; if($specifier->{kernel}) { $name.='//'; $name.=$specifier->{kernel}; } if($specifier->{session}) { $name.='/'.$specifier->{session}; } $name.="/$specifier->{state}" if $specifier->{state}; return $name; } 1; __END__ =head1 NAME POE::Component::IKC::Specifier - IKC event specifer =head1 SYNOPSIS use POE; use POE::Component::IKC::Specifier; $state=specifier_parse('poe://*/timeserver/connect'); print 'The foreign state is '.specifier_name($state); =head1 DESCRIPTION This is a helper module that encapsulates POE IKC specifiers. An IKC specifier is a way of designating either a kernel, a session or a state within a IKC cluster. IKC specifiers have the folloing format : poe:://kernel/session/state B may a kernel name, a kernel ID, blank (for local kernel), a '*' (all known foreign kernels) or host:port (not currently supported). B may be any session alias that has been published by the foreign kernel. B is a state that has been published by a foreign session. Examples : =over 4 =item C State 'connect' in session 'timeserver' on kernel 'Pulse'. =item C State 'connect' in session 'timeserver' on the local kernel. =item C State 'connect' in session 'timeserver' on any known foreign kernel. =item C Session 'bob' on foreign kernel 'Billy'. =back =head1 EXPORTED FUNCTIONS =head2 C Turn a specifier into the internal representation (hash ref). Returns B if the specifier wasn't valid. print Dumper specifer_parse('poe://Pulse/timeserver/time'); would print $VAR1 = { kernel => 'Pulse', session => 'timeserver', state => 'time', }; B : the internal representation might very well change some day. =head2 C Turns a specifier into a string. =head1 BUGS =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L =cut POE-Component-IKC-0.2305/IKC/Proxy.pm0000644000076400007640000001036012106220560014767 0ustar filfil# $Id: Proxy.pm 1077 2013-02-11 16:50:56Z fil $ package POE::Component::IKC::Proxy; ############################################################################## # $Id: Proxy.pm 1077 2013-02-11 16:50:56Z fil $ # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $ikc_kernel); use Carp; use Data::Dumper; use POE qw(Session); use POE::Component::IKC::Specifier; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(create_ikc_proxy); $VERSION = '0.2305'; sub DEBUG { 0 } sub create_ikc_proxy { __PACKAGE__->spawn(@_); } sub spawn { my($package, $r_kernel, $r_session, $monitor_start, $monitor_stop)=@_; my $name=specifier_name({kernel=>$r_kernel, session=>$r_session}); my $t=$poe_kernel->alias_resolve($name); if($t) { # why is this commented out? # $poe_kernel->call($t, '_add_callback', $r_kernel, $r_session); } else { POE::Session->create( package_states => [ $package => [qw( _start _stop _delete _default _shutdown _add_callback )], ], args=> [$name, $r_kernel, $r_session, $monitor_start, $monitor_stop] ); } } sub _start { my($kernel, $heap, $name, $r_kernel, $r_session, $monitor_start, $monitor_stop)= @_[KERNEL, HEAP, ARG0, ARG1, ARG2, ARG3, ARG4]; $heap->{name}=$name; $heap->{monitor_stop}=$monitor_stop; $heap->{callback}=[]; _add_callback($heap, $r_kernel, $r_session); DEBUG && warn "Proxy for $name ($r_session) created\n"; $kernel->alias_set($name); $kernel->alias_set($r_session); # monitor for shutdown events. # this is the best way to get IKC::Responder to tell us about the # shutdown $kernel->post(IKC=>'monitor', '*', {shutdown=>'_shutdown'}); &$monitor_start; } sub _shutdown { my($kernel, $heap)=@_[KERNEL, HEAP]; $kernel->alias_remove($heap->{name}); my $spec=specifier_parse($heap->{name}); $kernel->alias_remove($spec->{session}) if $spec; } sub _add_callback { my($heap, $r_k, $r_s)=@_[HEAP, ARG0, ARG1]; ($heap, $r_k, $r_s)=@_ if not $heap; push @{$heap->{callback}}, { kernel=>$r_k, session=>$r_s, state=>'IKC:proxy' }; } sub _delete { my($kernel, $heap)=@_[KERNEL, HEAP]; $kernel->alias_remove($heap->{name}); } sub _stop { my($kernel, $heap)=@_[KERNEL, HEAP]; DEBUG && warn "Proxy for $heap->{name} deleted\n"; &{$heap->{monitor_stop}}; } sub _default { my($kernel, $heap, $state, $args, $sender)= @_[KERNEL, HEAP, ARG0, ARG1, SENDER]; return if $state =~ /^_/; # use Data::Dumper; # warn "_default args=", Dumper $args; if(not $heap->{callback}) { warn "Attempt to respond to a callback with $state\n"; return; } DEBUG && warn "Proxy $heap->{name}/$state posted.\n"; # use Data::Dumper; # warn "_default args=", Dumper $args; my $ARG = [$state, [@$args]]; foreach my $r_state (@{$heap->{callback}}) { # warn "_default ARG=", Dumper $ARG; $kernel->call('IKC', 'post2', $r_state, $sender, $ARG); } return; } 1; __END__ =head1 NAME POE::Component::IKC::Proxy - POE IKC proxy session =head1 SYNOPSIS =head1 DESCRIPTION Used by IKC::Responder to create proxy sessions when you subscribe to a remote session. You probably don't want to use it directly. =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L =cut POE-Component-IKC-0.2305/IKC/Client.pm0000644000076400007640000002706312106220560015074 0ustar filfilpackage POE::Component::IKC::Client; ############################################################ # $Id: Client.pm 1077 2013-02-11 16:50:56Z fil $ # Based on refserver.perl # Contributed by Artur Bergman # Revised for 0.06 by Rocco Caputo # Turned into a module by Philp Gwyn # # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use Socket; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use POE qw(Wheel::ListenAccept Wheel::SocketFactory); use POE::Component::IKC::Channel; use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(create_ikc_client); $VERSION = '0.2305'; sub DEBUG { 0 } ############################################################################### #---------------------------------------------------- # This is just a convenient way to create servers. To be useful in # multi-server situations, it probably should accept a bind address # and port. sub create_ikc_client { my(%parms)=@_; $parms{package}||=__PACKAGE__; $parms{package}->spawn( %parms ); } sub spawn { T->start( 'IKC' ); my( $package, %parms ) = @_; $parms{package} ||= $package; $parms{on_connect}||=sub{}; # would be silly for this to be blank # 2001/04 not any more if($parms{unix}) { } else { $parms{ip}||='localhost'; $parms{port}||=903; # POE! (almost :) } $parms{name}||="Client$$"; $parms{subscribe}||=[]; $parms{protocol}||='IKC0'; my $defaults; if($parms{serializers}) { # use ones provided # make sure it's an arrayref $parms{serializers}=[$parms{serializers}] unless ref $parms{serializers}; } else { # use default ones $defaults=1; # but don't gripe $parms{serializers}=[qw(Storable FreezeThaw POE::Component::IKC::Freezer)]; } # make sure the serializers are real my @keep; foreach my $p (@{$parms{serializers}}) { unless(_package_exists($p)) { my $q=$p; $q=~s(::)(/)g; DEBUG and warn "Trying to load $p ($q)\n"; eval {require "$q.pm"; import $p ();}; warn $@ if not $defaults and $@; } next unless _package_exists($p); push @keep, $p; DEBUG and warn "Using $p as a serializer\n"; } $parms{serializers}=\@keep; return POE::Session->create( package_states => [ $parms{package} => [qw(_start _stop _child error shutdown connected)]], args => [\%parms] )->ID; } sub _package_exists { my($package)=@_; my $symtable=$::{"main::"}; foreach my $p (split /::/, $package) { return unless exists $symtable->{"$p\::"}; $symtable=$symtable->{"$p\::"}; } return 1; } #---------------------------------------------------- # Accept POE's standard _start event, and set up the listening socket # factory. sub _start { my($kernel, $heap, $parms) = @_[KERNEL, HEAP, ARG0]; DEBUG and warn "Client starting.\n"; my %wheel_p=( SuccessEvent => 'connected', # generating this event on connection FailureEvent => 'error' # generating this event on error ); # create a socket factory if($parms->{unix}) { $wheel_p{SocketDomain}=AF_UNIX; $wheel_p{RemoteAddress}=$parms->{unix}; # $heap->{remote_name}="unix:$parms->{unix}"; # $heap->{remote_name}=~s/[^-:.\w]+/_/g; $heap->{unix}=$parms->{unix}; } else { $wheel_p{RemotePort}=$parms->{port}; $wheel_p{RemoteAddress}=$parms->{ip}; $heap->{remote_name}="$parms->{ip}:$parms->{port}"; } $heap->{wheel} = new POE::Wheel::SocketFactory(%wheel_p); $heap->{on_connect}=$parms->{on_connect}; $heap->{on_error}=$parms->{on_error}; $heap->{name}=$parms->{name}; $heap->{alias} = "IKC Client $heap->{name}"; $kernel->alias_set( $heap->{alias} ); $heap->{subscribe}=$parms->{subscribe}; $heap->{aliases}=$parms->{aliases}; $heap->{serializers}=$parms->{serializers}; $heap->{protocol}=$parms->{protocol}; # set up local names for kernel my @names=($heap->{name}); if(exists $heap->{aliases}) { if(ref $heap->{aliases}) { push @names, @{$heap->{aliases}}; } else { push @names, $heap->{aliases}; } } $kernel->post(IKC=>'register_local', \@names); } #---------------------------------------------------- # Log server errors, but don't stop listening for connections. If the # error occurs while initializing the factory's listening socket, it # will exit anyway. sub error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Client encountered $operation error $errnum: $errstr\n"; my $w=delete $heap->{wheel}; # WORK AROUND # $w->DESTROY; if($heap->{on_error}) { $heap->{on_error}->($operation, $errnum, $errstr); } } #---------------------------------------------------- # The socket factory invokes this state to take care of accepted # connections. sub connected { my ($heap, $handle, $addr, $port) = @_[HEAP, ARG0, ARG1, ARG2]; DEBUG and warn "Client connected\n"; T->point( IKC => 'connected' ); # give the connection to a Channel my %p = ( handle=>$handle, addr=>$addr, port=>$port, client=>1 ); my @list = qw(name on_connect subscribe remote_name wheel aliases unix serializers protocol); @p{@list} = @{$heap}{@list}; $p{rname} = delete $p{remote_name}; $heap->{channel} = POE::Component::IKC::Channel->spawn( %p ); return; } sub shutdown { my ($heap, $kernel) = @_[HEAP, KERNEL]; DEBUG and warn "$heap Client shutdown"; if( $heap->{channel} ) { $kernel->call( delete $heap->{channel} => 'shutdown' ); } if( $heap->{alias} ) { $kernel->alias_remove( delete $heap->{alias} ); } } sub _stop { DEBUG and warn "$_[HEAP] client _stop\n"; } sub _child { my( $heap, $reason, $child ) = @_[ HEAP, ARG0, ARG1 ]; $child = $child->ID; DEBUG and warn "$heap $reason #$child"; return unless defined $heap->{channel}; if( $child eq $heap->{channel} and $reason eq 'lose' ) { delete $heap->{channel}; $poe_kernel->yield( 'shutdown' ); } } 1; __END__ # Below is the stub of documentation for your module. You better edit it! =head1 NAME POE::Component::IKC::Client - POE Inter-Kernel Communication client =head1 SYNOPSIS use POE; use POE::Component::IKC::Client; POE::Component::IKC::Client->spawn( ip=>$ip, port=>$port, name=>"Client$$", subscribe=>[qw(poe:/*/timserver)] ); ... $poe_kernel->run(); =head1 DESCRIPTION This module implements an POE IKC client. An IKC client attempts to connect to a IKC server. If successful, it negociates certain connection parameters. After this, the POE server and client are pretty much identical. =head1 EXPORTED FUNCTIONS =head2 create_ikc_client Syntatic sugar for POE::Component::IKC::Client->spawn. =head1 CLASS METHODS =head2 spawn This methods initiates all the work of connecting to an IKC server. Parameters are : =over 4 =item C Address to connect to. Can be a doted-quad ('127.0.0.1') or a host name ('foo.pied.nu'). Defaults to '127.0.0.1', aka INADDR_LOOPBACK. =item C Port to connect to. Can be numeric (80) or a service ('http'). =item C Path to unix-domain socket that the server is listening on. =item C Local kernel name. This is how we shall "advertise" ourself to foreign kernels. It acts as a "kernel alias". This parameter is temporary, pending the addition of true kernel names in the POE core. This name, and all aliases will be registered with the responder so that you can post to them as if they were remote. =item C Arrayref of even more aliases for this kernel. Fun Fun Fun! =item C Coderef that is called when the connection has been made to the foreign kernel. Normaly, you would use this to start the sessions that post events to foreign kernels. Note, also, that the coderef will be executed from within an IKC channel session, NOT within your own session. This means that things like $poe_kernel->delay_set() won't do what you think they should. It does, however, mean that you can get the session ID of the IKC channel for this connection. POE::Component::IKC::Client->spawn( .... on_connect=>sub { $heap->{channel} = $poe_kernel->get_active_session()->ID; }, .... ); However, IKC/monitor provides a more powerful mechanism for detecting connections. See L. =item C Coderef that is called for all connection errors. You could use this to restart the connection attempt. Parameters are C<$operation, $errnum and $errstr>, which correspond to POE::Wheel::SocketFactory's FailureEvent, which q.v. However, IKC/monitor provides a more powerful mechanism for detecting errors. See L. Note, also, that the coderef will be executed from within an IKC session, NOT within your own session. This means that things like $poe_kernel->delay_set() won't do what you think they should. =item C Array ref of specifiers (either foreign sessions, or foreign states) that you want to subscribe to. on_connect will only be called when IKC has managed to subscribe to all specifiers. If it can't, it will die(). YOW that sucks. C will save us all. =item C Arrayref or scalar of the packages that you want to use for data serialization. First IKC tries to load each package. Then, when connecting to a server, it asks the server about each one until the server agrees to a serializer that works on its side. A serializer package requires 2 functions : freeze (or nfreeze) and thaw. See C. The default is C<[qw(Storable FreezeThaw POE::Component::IKC::Freezer)]>. C and C are modules in C on CPAN. They are much much much faster then IKC's built-in serializer C. This serializer uses C and C to get the deed done. There is an obvious security problem here. However, it has the advantage of being pure Perl and all modules come with the core Perl distribution. It should be noted that you should have the same version of C on both sides, because some versions aren't mutually compatible. =item C Which IKC negociation protocol to use. The original protocol (C) was synchronous and slow. The new protocol (C) sends all information at once. IKC0 will degrade gracefully to IKC, if the client and server don't match. Default is IKC0. =back =head1 BUGS =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L, L. =cut POE-Component-IKC-0.2305/IKC/Protocol.pm0000644000076400007640000000261511630205236015457 0ustar filfilpackage POE::Component::IKC::Protocol; ############################################################ # $Id$ # Copyright 2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use Socket; sub __build_setup { my( $aliases, $freezers ) = @_; return 'SETUP '.join ';', 'KERNEL='.join( ',', @$aliases ), 'FREEZER='.join( ',', @$freezers ), "PID=$$"; } sub __neg_setup { my( $setup ) = @_; my $neg = { kernel => [], freezer => [], bad => 0, pid => 0 }; foreach my $bit ( split ';', $1 ) { if( $bit =~ m/KERNEL=(.+)/ ) { push @{ $neg->{kernel} }, split ',', $1; } elsif( $bit =~ m/FREEZER=(.+)/ ) { push @{ $neg->{freezer} }, split ',', $1; } elsif( $bit =~ m/PID=(\d+)/ ) { # warn "pid=$1"; $neg->{pid} = $1; } else { warn "Server sent unknown setup '$bit' during negociation\n"; $neg->{bad}++; } } unless( @{ $neg->{kernel} } ) { warn "Server didn't send KERNEL in $setup\n"; $neg->{bad}++; } return $neg; } 1; POE-Component-IKC-0.2305/IKC/Channel.pm0000644000076400007640000007651012106220560015227 0ustar filfilpackage POE::Component::IKC::Channel; ############################################################ # $Id: Channel.pm 1077 2013-02-11 16:50:56Z fil $ # Based on tests/refserver.perl # Contributed by Artur Bergman # Revised for 0.06 by Rocco Caputo # Turned into a module by Philp Gwyn # # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use Socket; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use POE qw(Wheel::ListenAccept Wheel::ReadWrite Wheel::SocketFactory Driver::SysRW Filter::Reference Filter::Line ); use POE::Component::IKC::Responder; use POE::Component::IKC::Protocol; use Data::Dumper; use Devel::Size qw( total_size ); # use Net::Gen (); use Time::HiRes qw( gettimeofday tv_interval ); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(create_ikc_channel); $VERSION = "0.2305"; sub DEBUG () { 0 } BEGIN { no strict 'refs'; unless( defined &TIMING ) { if( $ENV{IKC_TIMING} ) { *TIMING = sub () { 1 } } else { *TIMING = sub () { 0 } } } unless( defined &PROTOCOL ) { if( $ENV{IKC_PROTOCOL} ) { *PROTOCOL = sub () { 1 } } else { *PROTOCOL = sub () { 0 } } } } ############################################################################### # Channel instances are created by the listening session to handle # connections. They receive one or more thawed references, and pass # them to the running Responder session for processing. #---------------------------------------------------- # This is just a convenient way to create channels. sub create_ikc_channel { my %p; @p{qw(handle name on_connect subscribe rname unix aliases serializers protocol)} = @_; return __PACKAGE__->spawn(%p); } sub spawn { my $package=shift; my %params=@_; return POE::Session->create( inline_states => { _start => \&channel_start, _stop => \&channel_stop, _default => \&channel_default, error => \&channel_error, shutdown =>\&channel_close, receive => \&channel_receive, 'send' => \&channel_send, 'flushed' => \&channel_flushed, 'done' => \&channel_done, 'close' => \&channel_close, server_000 => \&server_000, server_001 => \&negociate_001, server_002 => \&server_002, server_003 => \&server_003, server_010 => \&server_010, client_000 => \&client_000, client_001 => \&negociate_001, client_002 => \&client_002, client_003 => \&client_003, client_010 => \&client_010, 'sig_INT' => \&sig_INT }, args => [\%params] )->ID; } #---------------------------------------------------- # Accept POE's standard _start event, and begin processing data. sub channel_start { my ($kernel, $heap, $session, $p) = @_[KERNEL, HEAP, SESSION, ARG0]; if( TIMING ) { $heap->{start_time} = [ gettimeofday ]; delete $heap->{last_time}; } my @names; push @names, $p->{name} if $p->{name}; push @names, @{$p->{aliases}} if $p->{aliases}; # $name is blank if create_ikc_{server,client} wasn't called with a name # OR if we are a kernel that was connected to (2001/05 huh?) # +GC my $alias = 0+$session; $alias = "Channel $alias"; $kernel->alias_set($alias); $heap->{session_alias} = $alias; # all clients have $on_connect defined, even if sub {} $heap->{is_server} = not $p->{client}; DEBUG and warn "$$: We are a ".($heap->{is_server} ? 'server' : 'client')."\n"; if($p->{unix}) { $p->{unix}=~s/[^-:.\w]+/_/g; push @names, "unix:$p->{unix}"; unless($heap->{is_server}) { $names[-1].=":$$-".fileno($p->{handle}); } } else { my @name=unpack_sockaddr_in(getsockname($p->{handle})); $name[1]=inet_ntoa($name[1]); push @names, join ':', @name[1,0]; } DEBUG and warn "$$: Names: ", join ',', @names; $heap->{kernel_name}=shift @names; $heap->{kernel_aliases}=\@names; # remote_kernel is only needed for DEBUG messages only # remote_aliases, however, is important # remote_ID is set when negociations are finished # it should be cannonical name according to remote side # temp_remote_kernel is a local sanity alias. (ie, if we connect to # something:port, it should have that name as an alias) if($p->{rname}) { # we are a server $heap->{remote_kernel}=$p->{rname}; $heap->{temp_remote_kernel}=$p->{rname}; } elsif($p->{unix}) { # we are a client my $n=$p->{unix}; $n=~tr(/\\)(--); $heap->{remote_kernel}="unix:$n:$$:". fileno($p->{handle}); $heap->{temp_remote_kernel}="unix:n" unless $heap->{is_server}; # we need to have unique aliases for remote kernels # so, only the server gets a default name, clients don't } else { my @name=unpack_sockaddr_in(getpeername($p->{handle})); $name[1]=inet_ntoa($name[1]); $heap->{temp_remote_kernel}= $heap->{remote_kernel}=join ':', @name[1,0]; } DEBUG && warn "Channel session $heap->{kernel_name}<->$heap->{remote_kernel} created.\n"; # start reading and writing $heap->{wheel_client} = new POE::Wheel::ReadWrite ( Handle => $p->{handle}, # on this handle Driver => new POE::Driver::SysRW, # using sysread and syswrite InputEvent => 'none', Filter => POE::Filter::Line->new(), # use a line filter for negociations ErrorEvent => 'error', # generate this event on error ); $session->option(default=>1); $heap->{on_connect}=$p->{on_connect} if ref($p->{on_connect}); $heap->{subscribe}=$p->{subscribe} if ref($p->{subscribe}) and @{$p->{subscribe}}; unless($heap->{is_server}) { if(ref($p->{serializers}) and @{$p->{serializers}}) { $heap->{serializers}=$p->{serializers}; # } else { # $heap->{serializers}=$p->{serializers}; } DEBUG and warn __PACKAGE__, " Serializers: ", join(', ', @{$heap->{serializers}||[]}), "\n"; } # Setup negociation $p->{protocol} ||= 'IKC'; if( $p->{protocol} eq 'IKC0' ) { PROTOCOL and warn "$$: Using protocol IKC0\n"; _set_phase($kernel, $heap, '010'); } else { PROTOCOL and warn "$$: Using protocol IKC\n"; _set_phase($kernel, $heap, '000'); } # Register this channel my $ikc = eval { $kernel->alias_resolve( 'IKC' ) }; if( $ikc ) { $kernel->call( $ikc, 'register_channel' ); } else { warn __PACKAGE__, " has no IKC responder."; $kernel->yield( 'shutdown' ); } return "channel-$session"; } #---------------------------------------------------- sub _negociation_done { my($kernel, $heap)=@_; DEBUG and warn "$$: Negociation done ($heap->{kernel_name}<->$heap->{remote_kernel}).\n"; # generate this event on input $heap->{'wheel_client'}->event(InputEvent => 'receive', FlushedEvent => 'flushed'); unless($heap->{filter}) { DEBUG and warn "$$: We didn't negociate a freezer, using defaults\n"; $heap->{filter}=POE::Filter::Reference->new(); } # parsing I/O as references my $ft = $heap->{filter}; DEBUG and warn "$$: Filter is now $ft"; $heap->{wheel_client}->set_filter($ft); delete $heap->{filter}; create_ikc_responder(); # Register the foreign kernel with the responder my $aliases=delete $heap->{remote_aliases}; push @$aliases, $heap->{temp_remote_kernel} if $heap->{temp_remote_kernel} and not grep {$_ eq $heap->{temp_remote_kernel}} @$aliases; DEBUG and warn "$$: Register remote as ", join ', ', @$aliases; # we need a globaly unique ID $heap->{remote_ID}=shift @$aliases; # delete $heap->{remote_kernel}; $kernel->call('IKC', 'register', $heap->{remote_ID}, $aliases, $heap->{remote_pid}); TIMING and channel_log( $heap, "negociated" ); T->point( 'IKC', 'nego done' ); # Now that we're set up properly if($heap->{subscribe}) { # subscribe to wanted sessions $kernel->call('IKC', 'subscribe', $heap->{subscribe}, 'done'); } else { # "fake" a completed subscription $kernel->yield('done'); } return; } #---------------------------------------------------- # This is the subscription callback sub channel_done { my($heap, $subscribed)=@_[HEAP, ARG0]; if($heap->{subscribe}) { my %count; foreach my $spec (@$subscribed, @{$heap->{subscribe}}) { $count{$spec}++; } my @missing=grep { $count{$_} != 2 } keys %count; if(@missing) { die "Unable to subscribe to ".join(', ', @missing)."\n"; } delete $heap->{subscribe}; DEBUG and warn "$$: Subscriptions are completed\n"; } if($heap->{on_connect}) # or call the on_connect { DEBUG and warn "$$: On connect\n"; $heap->{on_connect}->(); delete $heap->{on_connect}; } # Detach from parent session unless( $heap->{is_server} ) { # Only if we are a client. Server uses 'lose' to detect disconnects # for concurrency. $_[KERNEL]->detach_myself; } TIMING and channel_log( $heap, "subscribed" ); # wait until everything is sane before registering this # $kernel->signal(INT=>'sig_INT'); # sig_INT() is in fact empty } #---------------------------------------------------- #### DEAL WITH NEGOCIATION PHASE sub _set_phase { my($kernel, $heap, $phase, $line)=@_; if($phase eq 'ZZZ') { _negociation_done($kernel, $heap); return; } my $neg = $heap->{is_server} ? 'server_' : 'client_'; # generate this event on input $heap->{'wheel_client'}->event(InputEvent => $neg.$phase); DEBUG && warn "Negociation phase $neg$phase.\n"; $kernel->yield($neg.$phase, $line); # Start the negociation phase return; } # First server state is sub server_000 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { # wait for client to send HELLO } elsif( $line =~ /^HELLO IKC\d$/ ) { # compatible with IKC1 $heap->{'wheel_client'}->put( 'NOT' ); } elsif( $line =~ /^SETUP/ ) { # compatible with IKC0 $heap->{'wheel_client'}->put( 'NOT' ); } elsif( $line eq 'HELLO' ) { $heap->{'wheel_client'}->put('IAM '.$kernel->ID()); # put other server aliases here $heap->{aliases001}=[$heap->{kernel_name}, @{$heap->{kernel_aliases}}]; DEBUG and warn "$$: Server we are going to tell remote that aliases001=", join ',', @{$heap->{aliases001}}; _set_phase($kernel, $heap, '001'); } else { # wait for client to say something coherrent :) warn "Client sent '$line' during phase 000\n"; } return; } # We tell who we are sub negociate_001 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { # far side must talk now (we sent "IAM kernel") } elsif($line eq 'OK') { my $a=pop @{$heap->{aliases001}}; if($a) { $heap->{'wheel_client'}->put("IAM $a"); } else { delete $heap->{aliases001}; $heap->{'wheel_client'}->put('DONE'); _set_phase($kernel, $heap, '002'); } } else { warn "Received '$line' during phase 001\n"; # prod far side into saying something coherrent $heap->{wheel_client}->put('NOT') unless $line eq 'NOT'; } return; } # We find out who the client is sub server_002 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { # far side must respond to the "DONE" } elsif($line eq 'DONE') { _set_phase($kernel, $heap, '003'); } elsif($line =~ /^IAM\s+([-:.\w]+)$/) { # Register this kernel alias with the responder push @{$heap->{remote_aliases}}, $1; $heap->{'wheel_client'}->put('OK'); } else { warn "Client sent '$line' during phase 002\n"; # prod far side into saying something coherrent $heap->{wheel_client}->put('NOT') unless $line eq 'NOT'; } return; } # We find out what type of serialisation the client wants sub server_003 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { # wait for client to send FREEZER after last IAM } elsif($line =~ /^FREEZER\s+([-:\w]+)$/) { my $package=$1; eval { DEBUG and warn "Going to use $package as serializer\n"; $heap->{filter}=POE::Filter::Reference->new($package); }; if($heap->{filter}) { DEBUG && warn "$$: Using $package\n"; $heap->{wheel_client}->put('OK'); } else { DEBUG && warn "Client wanted $package, but we can't : $@"; $heap->{wheel_client}->put('NOT'); } } elsif($line =~ /^FREEZER\s+(.+)$/) { warn "Client sent invalid package $1 as a serializer, refused\n"; $heap->{wheel_client}->put('NOT'); } elsif($line eq 'WORLD') { # last bit of the dialog has to come from us :( $heap->{wheel_client}->put('UP'); _set_phase($kernel, $heap, 'ZZZ'); } else { warn "Client sent '$line' during phase 003\n"; $heap->{wheel_client}->put('NOT') unless $line eq 'NOT'; } return; } #---------------------------------------------------- # These states is invoked for each line during the negociation phase on # the client's side ## Start negociation and listen to who the server is sub client_000 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { $heap->{wheel_client}->put('HELLO'); } elsif($line =~ /^IAM\s+([-:.\w]+)$/) { # Register this kernel alias with the responder DEBUG and warn "$$: Remote server is called $1\n"; push @{$heap->{remote_aliases}}, $1; $heap->{wheel_client}->put('OK'); } elsif($line eq 'DONE') { $heap->{'wheel_client'}->put('IAM '.$poe_kernel->ID()); $heap->{aliases001}=[$heap->{kernel_name}, @{$heap->{kernel_aliases}}]; _set_phase($kernel, $heap, '001'); } else { warn "Server sent '$line' during negociation phase 000\n"; # prod far side into saying something coherrent $heap->{wheel_client}->put('NOT') unless $line eq 'NOT'; } return; } # try to negociate a serialization method sub client_002 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { $heap->{serial002}=$heap->{serializers}; $line=$heap->{serial002} ? 'NOT' : 'OK'; # NOT= pretend that we already sent a FREEZER # OK= use default freezers } if($line eq 'NOT') { delete $heap->{filter}; my $ft; while(@{$heap->{serial002}}) { $ft=shift @{$heap->{serial002}}; DEBUG and warn "$$: Trying serializer $ft\n"; $heap->{filter}=eval { POE::Filter::Reference->new($ft); }; last if $heap->{filter}; DEBUG and warn $@; } if($ft) { $heap->{'wheel_client'}->put('FREEZER '.$ft); } else { DEBUG and warn "Server doesn't like our list of serializers ", join ', ', @{$heap->{serializers}}; delete $heap->{serial002}; _set_phase($kernel, $heap, '003'); } } elsif($line eq 'OK') { delete $heap->{serial002}; _set_phase($kernel, $heap, '003'); } else { warn "Server sent '$line' during negociation phase 002\n"; # prod far side into saying something coherrent $heap->{wheel_client}->put('NOT') unless $line eq 'NOT'; } } # Game over sub client_003 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; unless(defined $line) { $heap->{'wheel_client'}->put('WORLD'); } elsif($line eq 'UP') { _set_phase($kernel, $heap, 'ZZZ'); } else { warn "Server sent '$line' during phase 003\n"; # prod far side into saying something coherrent $heap->{wheel_client}->put('NOT') unless $line eq 'NOT'; } return; } ############################################################################## sub client_010 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; DEBUG and $line and warn "Client010: $line"; unless(defined $line) { # TODO : make sure all serializers load # T->point( 'IKC', 'first line' ); my $setup = __build_setup( $heap, $heap->{serializers} ); # T->point( 'IKC', 'build_setup' ); DEBUG and warn "Client010: sending $setup"; $heap->{wheel_client}->put( $setup ); } elsif( $line eq 'NOT' ) { PROTOCOL and warn "$$: Using protocol IKC (fallback)\n"; _set_phase( $kernel, $heap, '000' ); } elsif($line =~ /^SETUP (.+)$/) { # T->point( IKC => 'got SETUP' ); DEBUG and warn "$$: Remote server setup as $1\n"; my $neg = __neg_setup( $1 ); unless( 1==@{ $neg->{freezer} } ) { warn "Server didn't send one freezer in $line\n"; $neg->{bad}++; } if( $neg->{bad} ) { $heap->{wheel_client}->put( 'NOT' ); return; } # Register these kernel alias with the responder $heap->{remote_aliases} = $neg->{kernel}; $heap->{remote_pid} = $neg->{pid}; # Build the filter we shall use later $heap->{filter} = eval { POE::Filter::Reference->new( $neg->{freezer}[0] ) }; die "Unable to build filter: $@" if $@; die "Unable to build filter $neg->{freezer}[0]" unless $heap->{filter}; # T->point( IKC => 'got SETUP' ); _set_phase( $kernel, $heap, 'ZZZ' ); } else { warn "Server sent '$line' during negociation phase 002\n"; $heap->{wheel_client}->put('NOT'); } } sub server_010 { my ($heap, $kernel, $line)=@_[HEAP, KERNEL, ARG0]; DEBUG and $line and warn "Server010: $line"; unless(defined $line) { # wait for client } elsif( $line =~ /^HELLO IKC\d$/ ) { # compatible with IKC1 $heap->{'wheel_client'}->put( 'NOT' ); } elsif( $line eq 'HELLO' ) { PROTOCOL and warn "$$: Using protocol IKC (fallback)\n"; _set_phase( $kernel, $heap, '000', $line ); return; } elsif( $line =~ /^SETUP (.+)$/ ) { DEBUG and warn "$$: Remote client setup as $1\n"; my $neg = __neg_setup( $1 ); my $filter; if( not $neg->{bad} ) { # Build the filter we shall use later foreach my $ft ( @{ $neg->{freezer} } ) { $filter = $ft; $heap->{filter} = eval { POE::Filter::Reference->new( $ft ) }; last if $heap->{filter}; DEBUG and warn "Client wanted $ft, but we can't: $@"; } } unless( $heap->{filter} ) { warn "None of the filters the client wants are OK: ", join ', ', @{ $neg->{freezer} }; $neg->{bad}++; } if( $neg->{bad} ) { $heap->{wheel_client}->put( 'NOT' ); return; } # Register these kernel alias with the responder $heap->{remote_aliases} = $neg->{kernel}; $heap->{remote_pid} = $neg->{pid}; # Send our SETUP back my @freezers = ( $filter ); my $setup = __build_setup( $heap, [$filter] ); DEBUG and warn "Server010: sending $setup"; $heap->{wheel_client}->put( $setup ); # Move to next phase _set_phase( $kernel, $heap, 'ZZZ' ); } } sub __build_setup { my( $heap, $freezers ) = @_; my $aliases = [ $poe_kernel->ID, $heap->{kernel_name}, @{$heap->{kernel_aliases}} ]; return POE::Component::IKC::Protocol::__build_setup( $aliases, $freezers ); } sub __neg_setup { return POE::Component::IKC::Protocol::__neg_setup( $_[0] ); } #---------------------------------------------------- # This state is invoked for each error encountered by the session's # ReadWrite wheel. sub channel_error { my ($heap, $kernel, $operation, $errnum, $errstr) = @_[HEAP, KERNEL, ARG0, ARG1, ARG2]; if ($errnum) { DEBUG && warn "$$: Channel encountered $operation error $errnum: $errstr\n"; } else { DEBUG && warn "$$: The channel's client closed its connection ($heap->{kernel_name}<->$heap->{remote_kernel})\n"; } # warn "ERROR $heap->{remote_ID}"; _close_channel($heap, 1); # either way, shut down } #---------------------------------------------------- sub _channel_unregister { my($heap)=@_; if($heap->{remote_ID}) { DEBUG and warn <{remote_ID} ------------------------------------------ WARN # 2005/06 Tell IKC we closed the connection my $ikc = eval { $poe_kernel->alias_resolve( 'IKC' ) }; if( $ikc ) { $poe_kernel->call( $ikc, 'unregister', $heap->{remote_ID}); } delete $heap->{remote_ID}; } # either way, shut down } #---------------------------------------------------- sub _close_channel { my($heap, $force)=@_; # tell responder right away that this channel isn't to be used _channel_unregister($heap); return unless $heap->{wheel_client}; if(not $force and $heap->{wheel_client}->get_driver_out_octets) { DEBUG and warn "************ Defering wheel close"; $heap->{go_away}=1; # wait until next Flushed return; } DEBUG and warn "Deleting wheel session = ", $poe_kernel->get_active_session->ID; my $x=delete $heap->{wheel_client}; # WORK AROUND # $x->DESTROY; # sig_INT is empty # $kernel->sig( 'INT' ); if( $heap->{session_alias} ) { $poe_kernel->alias_remove( delete $heap->{session_alias} ); } if( TIMING ) { channel_log( $heap, "close" ); delete $heap->{start_time}; delete $heap->{last_time}; } T->point( 'IKC', 'close' ); return; } #---------------------------------------------------- # sub channel_default { my($event)=$_[STATE]; DEBUG && warn "Unknown event $event posted to IKC::Channel\n" if $event !~ /^_/; return; } #---------------------------------------------------- # Process POE's standard _stop event by shutting down. sub channel_stop { my $heap = $_[HEAP]; DEBUG && warn "$$: *** Channel will shut down.\n"; _close_channel($heap); T->end( 'IKC' ); return "channel-$_[SESSION]"; } ########################################################################### ## Next two events forward messages between Wheel::ReadWrite and the ## Responder ## Because the Responder know which foreign kernel sent a request, ## these events fill in some of the details. #---------------------------------------------------- # Foreign kernel sent us a request sub channel_receive { my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0]; T->point( 'IKC', 'receive' ); TIMING and channel_log( $heap, "receive" ); DEBUG && warn "$$: Received data...\n"; return if $heap->{shutdown}; # we won't trust the other end to set this properly $request->{errors_to}={ kernel=>$heap->{remote_ID}, session=>'IKC', state=>'remote_error', }; # just in case $request->{call}->{kernel}||=$heap->{kernel_name}; # call the Responder channel to process # hmmm.... i wonder if this could be stream-lined into a direct call $kernel->call('IKC', 'request', $request); return; } #---------------------------------------------------- # Local kernel is sending a request to a foreign kernel sub channel_send { my ($heap, $request)=@_[HEAP, ARG0]; TIMING and channel_log( $heap, "send" ); my $size = total_size $request; if( $size > 100*1024*1024 ) { die "$$ Channel sending WAY too much data ($size bytes)"; } DEBUG && warn "$$: Sending data...\n"; # add our name so the foreign channel can find us # TODO should we do this? or should the other end do this? $request->{rsvp}->{kernel}||=$heap->{kernel_name} if ref($request) and $request->{rsvp}; if($heap->{'wheel_client'}) { # use Data::Dumper; # warn "Sending ", Dumper $request; $heap->{'wheel_client'}->put($request); } else { my $what={event => $request->{event}, from => $request->{from}}; $what->{action} = $request->{params}[0] if $what->{event}{state} eq 'IKC:proxy' and 'ARRAY' eq ref $request->{params}; my $type = "missing"; $type = "shutdown" if $heap->{shutdown}; warn "$$: Attempting to put to a $type channel! ". Dumper $what; } T->point( 'IKC', 'send' ); return 1; } #---------------------------------------------------- sub channel_flushed { my($heap, $wheel)=@_[HEAP, ARG0]; DEBUG && warn "$$: Flushed data...\n"; if($heap->{go_away}) { _close_channel($heap); } return; } #---------------------------------------------------- # Local kernel thinks it's time to close down the channel sub channel_close { my ($heap, $sender)=@_[HEAP, SENDER]; unless( $heap->{shutdown} ) { DEBUG && warn "$$: channel_close *****************************************\n"; $heap->{shutdown}=1; } _close_channel( $heap ); } #---------------------------------------------------- # User wants to kill process / kernel sub sig_INT { my ($heap, $kernel)=@_[HEAP, KERNEL]; DEBUG && warn "$$: Channel::sig_INT\n"; $kernel->sig_handled(); return; } #---------------------------------------------------- sub channel_log { my( $heap, $when ) = @_; return unless $heap->{start_time}; my $now = [ gettimeofday ]; my $el = tv_interval( $heap->{start_time}, $now ); my $time = _delta_time( $el ); if( $heap->{last_time} ) { $el = tv_interval( $heap->{last_time}, $now ); $time .= " +"._delta_time( $el ); } $heap->{last_time} = $now; print STDERR "$$: CHANNEL $time $when\n"; } sub _delta_time { my( $el ) = @_; if( $el > 1 ) { return sprintf( "%.3fs", $el); } $el *= 1000; # microseconds -> milliseconds if( $el > 10 ) { return sprintf( "%ims", int $el); } return sprintf( "%.1gms", $el); } ########################################################################### 1; __END__ =head1 NAME POE::Component::IKC::Channel - POE Inter-Kernel Communication I/O session =head1 SYNOPSIS use POE; use POE::Component::IKC::Channel; create_ikc_channel($handle, $name, $on_connect, $subscribe, $rname, $unix); =head1 DESCRIPTION This module implements an POE IKC I/O. When a new connection is established, C and C create an C to handle the I/O. IKC communication happens in 2 phases : negociation phase and normal phase. The negociation phase uses C and is used to exchange various parameters between kernels (example : kernel names, what type of freeze/thaw to use, etc). After negociation, C switches to a C and creates a C, if needed. After this, the channel forwards reads and writes between C and the Responder. C is also in charge of cleaning up kernel names when the foreign kernel disconnects. =head1 EXPORTED FUNCTIONS =head2 create_ikc_channel This function initiates all the work of connecting to a IKC connection channel. It is a wrapper around C. =head1 METHODS =head2 spawn POE::Component::IKC::Channel->spawn(%param); Creates a new IKC channel to handle the negociations then the actual data. Parameters are keyed as follows: =over 4 =item handle The perl handle we should hand to C. =item kernel_name The name of the local kernel. B. =item on_connect Code ref that is called when the negociation phase has terminated. Normaly, you would use this to start the sessions that post events to foreign kernels. =item subscribe Array ref of specifiers (either foreign sessions, or foreign states) that you want to subscribe to. $on_connect will only be called if you can subscribe to all those specifiers. If it can't, it will die(). =item unix A flag indicating that the handle is a Unix domain socket or not. =item aliases Arrayref of aliases for the local kernel. =item serializers Arrayref or scalar of the packages that you want to use for data serialization. A serializer package requires 2 functions : freeze (or nfreeze) and thaw. See C. =item C Which IKC negociation protocol to use. The original protocol (C) was synchronous and slow. The new protocol (C) sends all information at once. IKC0 will degrade gracefully to IKC, if the client and server don't match. Default currently IKC but will move to IKC0 when I'm confident in the new protocol. =back =head1 EVENTS =head2 shutdown This event causes the server to close it's socket and skiddadle on down the road. Normally it is only posted from IKC::Responder. If you want to post this event yourself, you can get the channel's session ID from IKC::Client's on_connect: POE::Component::IKC::Client->spawn( .... on_connect=>sub { $heap->{channel} = $poe_kernel->get_active_session()->ID; }, .... ); Then, when it becomes time to disconnect: $poe_kernel->call($heap->{channel} => 'shutdown'); Yes, this is a hack. A cleaner machanism needs to be provided. =head1 BUGS =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L, L, L =cut POE-Component-IKC-0.2305/IKC/ClientLite.pm0000644000076400007640000005435512106220560015716 0ustar filfilpackage POE::Component::IKC::ClientLite; ############################################################ # $Id: ClientLite.pm 1077 2013-02-11 16:50:56Z fil $ # By Philp Gwyn # # Copyright 1999-2011 Philip Gwyn. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Contributed portions of IKC may be copyright by their respective # contributors. use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $error $request); use Socket; use IO::Socket; use IO::Select; use POE::Component::IKC::Specifier; use POE::Component::IKC::Protocol; use Data::Dumper; use POSIX qw(:errno_h); use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(create_ikc_client); $VERSION = '0.2305'; sub DEBUG { 0 } $request=0; ############################################################################### #---------------------------------------------------- # This is just a convenient way to create servers. To be useful in # multi-server situations, it probably should accept a bind address # and port. sub create_ikc_client { my $package; $package = (scalar(@_) & 1 ? shift(@_) : __PACKAGE__); my(%parms)=@_; # $parms{on_connect}||=sub{}; # would be silly for this to be blank $parms{ip}||='localhost'; $parms{port}||=603; # POE! (almost :) $parms{name}||="Client$$"; $parms{connect_timeout} ||= $parms{timeout} || 30; $parms{timeout}||=30; $parms{serialiser}||=_default_freezer(); $parms{block_size} ||= 65535; $parms{protocol} ||= 'IKC0'; my %self; @self{qw(ip port name serialiser timeout connect_timeout block_size protocol)}= @parms{qw(ip port name serialiser timeout connect_timeout block_size protocol)}; eval { @{$self{remote}}{qw(freeze thaw)}=_get_freezer($self{serialiser}); }; if($@) { $self{error}=$error=$@; return; } my $self=bless \%self, $package; $self->{remote}{aliases}={}; $self->{remote}{name}="$self->{ip}:$self->{port}"; $self->connect and return $self; return; } *spawn=\&create_ikc_client; sub name { $_[0]->{name}; } #---------------------------------------------------- sub connect { my($self)=@_; return 1 if($self->{remote}{connected} and $self->{remote}{socket} and $self->ping); # are we already connected? my $remote=$self->{remote}; delete $remote->{socket}; delete $remote->{connected}; my $name=$remote->{name}; DEBUG && print "Connecting to $name...\n"; my( $sock, $resp ); my $DONE = 0; eval { local $SIG{__DIE__}='DEFAULT'; local $SIG{__WARN__}; local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required $sock=IO::Socket::INET->new( PeerAddr=>$self->{ip}, PeerPort=>$self->{port}, # Proto=>'tcp', Timeout=>$self->{connect_timeout} ); die "Unable to connect to $name: $!\n" unless $sock; $sock->autoflush(1); local $/="\cM\cJ"; local $\="\cM\cJ"; # Attempt IKC0 protocol if( $self->{protocol} eq 'IKC0' ) { if( $self->_protocol_IKC0( $sock ) ) { $DONE = 1; return; } } # Fallback to IKC protocol $sock->print('HELLO'); my $resp; alarm( $self->{connect_timeout} ); while (defined($resp=$sock->getline)) # phase 000 { chomp($resp); last if $resp eq 'DONE'; die "Invalid IAM response from $name: $resp\n" unless $resp=~/^IAM\s+([-:.\w]+)$/; $remote->{name}||=$1; $self->{ping}||="poe://$1/IKC/ping"; $remote->{aliases}->{$1}=1; $sock->print('OK'); } die "Phase 000: $!\n" unless defined $resp; alarm( $self->{connect_timeout} ); $sock->print("IAM $self->{name}"); # phase 001 chomp($resp=$sock->getline); die "Phase 001: $!\n" unless defined $resp; die "Didn't get OK from $name\n" unless $resp eq 'OK'; $sock->print("DONE"); alarm( $self->{connect_timeout} ); $sock->print("FREEZER $self->{serialiser}");# phase 002 chomp($resp=$sock->getline); die "Phase 002: $!\n" unless defined $resp; die "$name refused $self->{serialiser}\n" unless $resp eq 'OK'; alarm( $self->{connect_timeout} ); $sock->print('WORLD'); # phase 003 chomp($resp=$sock->getline); die "Phase 003: $!\n" unless defined $resp; die "Didn't get UP from $name\n" unless $resp eq 'UP'; $DONE = 1; }; alarm( 0 ); if($@) { $self->{error}=$error=$@; if( $error eq "alarm\n" ) { $self->{error}=$error="Timeout connecting to $self->{ip}:$self->{port}"; } return; } $remote->{socket}=$sock; $remote->{connected}=1; return 1; } #---------------------------------------------------- sub _protocol_IKC0 { my( $self, $sock ) = @_; my $remote=$self->{remote}; my $name=$remote->{name}; my $resp; my $setup = POE::Component::IKC::Protocol::__build_setup( [ $self->{name} ], [ $self->{serialiser} ] ); $sock->print( $setup ); alarm( $self->{connect_timeout} ); while (defined($resp=$sock->getline)) # phase 010 { chomp($resp); return if $resp eq 'NOT'; # move to phase 000 die "Phase 010: Invalid response from $name: $resp\n" unless $resp =~ /^SETUP (.+)$/; my $neg = POE::Component::IKC::Protocol::__neg_setup( $1 ); if( $neg->{bad} ) { $sock->print( 'NOT' ); next; } die "Phase 010: Refused $self->{serialiser}, wants $neg->{freezer}[0]" unless $neg->{freezer}[0] eq $self->{serialiser}; $remote->{name} = $neg->{kernel}[0]; foreach my $a ( @{ $neg->{kernel} } ) { $remote->{aliases}{$a} = 1; } return 1; } } #---------------------------------------------------- sub error { return $_[0]->{error} if @_==1; return $error; } #---------------------------------------------------- sub ping { my($self)=@_; my $ret=eval { my $rsvp={kernel=>$self->{name}, session=>'IKC', state=>'pong' }; my $r=$self->_send_msg({event=>$self->{ping}, params=>'PING', rsvp=>$rsvp}); return unless $r; my $pong=$self->_response($rsvp); return 1 if $pong and $pong eq 'PONG'; }; $self->{error}=$error=$@ if $@; $self->{remote}{connected}=$ret; return $ret; } #---------------------------------------------------- sub disconnect { my($self)=@_; # 2001/01 why did we try to unregister ourselves? unregister wouldn't # be safe for remote kernels anyway # $self->call('IKC/unregister', $self->{name}) if $self->{remote}; delete @{$self->{remote}}{qw(socket connected name aliases)}; $self->{remote}={}; } sub DESTROY { my($self)=@_; $self->disconnect; } sub END { DEBUG and print "end\n"; } #---------------------------------------------------- # Post an event, maybe waits for a response and throws it away # sub post { my($self, $spec, $params)=@_; unless(ref $spec or $spec=~m(^poe:)) { unless($self->{remote}{name}) { $self->{error}=$error="Attempting to post $spec to unknown kernel"; # carp $error; return; } $spec="poe://$self->{remote}{name}/$spec"; } my $ret=eval { return 0 if(0==$self->_try_send({event=>$spec, params=>$params})); 1; }; if($@) { $self->{error}=$error=$@; return; } return $ret; } #---------------------------------------------------- # posts an event, waits for the response, returns the response sub call { my($self, $spec, $params)=@_; $spec="poe://$self->{remote}{name}/$spec" unless ref $spec or $spec=~m(^poe:); my $rsvp={kernel=>$self->{name}, session=>'IKCLite', state=>'response'.$request++}; my $req={event=>$spec, params=>$params, rsvp=>$rsvp, 'wantarray'=>wantarray(), }; my @ret=eval { return unless $self->_try_send($req); DEBUG && print "Waiting for response...\n"; return $self->_response($rsvp, $req->{wantarray}); }; if($@) { $self->{error}=$error=$@; return; } return @ret if $req->{wantarray}; return $ret[0]; } #---------------------------------------------------- # posts an event, waits for the response, returns the response # this differs from call() in that the foreign server may # need many states before getting a response sub post_respond { my($self, $spec, $params)=@_; $spec="poe://$self->{remote}{name}/$spec" unless ref $spec or $spec=~m(^poe:); my $ret; my $rsvp={kernel=>$self->{name}, session=>'IKCLite', state=>'response'.$request++}; $ret=eval { return unless $self->_try_send({event=>$spec, params=>[$params, $rsvp], }); DEBUG && print "Waiting for response...\n"; return $self->_response($rsvp); }; if($@) { $self->{error}=$error=$@; return; } return $ret; } #---------------------------------------------------- sub responded { my( $self, $state ) = @_; my $wantarray = wantarray; my $rsvp = { kernel=>$self->{name}, session=>'IKCLite', state=>$state }; my @ret = eval { DEBUG && print "Waiting for response...\n"; return $self->_response($rsvp, $wantarray); }; if($@) { $self->{error}=$error=$@; return; } return @ret if wantarray; return $ret[0]; } #---------------------------------------------------- sub _from { my( $self ) = @_; return { kernel => $self->{name}, session => 'IKCLite', # state => 'IKC:lite' } } #---------------------------------------------------- sub _try_send { my($self, $msg)=@_; return unless $self->{remote}{connected} or $self->connect(); $msg->{from} ||= $self->_from; my $ret=$self->_send_msg($msg); DEBUG && print "Sending message...\n"; if(defined $ret and $ret==0) { return 0 unless $self->connect(); DEBUG && print "Retry message...\n"; $ret=$self->_send_msg($msg); } return $ret; } #---------------------------------------------------- sub _send_msg { my($self, $msg)=@_; my $e=$msg->{rsvp} ? 'call' : 'post'; my $to=specifier_parse($msg->{event}); unless($to) { croak "Bad message ", Dumper $msg; } unless($to) { warn "Bad or missing 'to' parameter '$msg->{event}' to poe:/IKC/$e\n"; return; } unless($to->{session}) { warn "Need a session name in poe:/IKC/$e"; return; } unless($to->{state}) { carp "Need a state name in poe:IKC/$e"; return; } my $frozen = $self->{remote}{freeze}->($msg); my $raw=length($frozen) . "\0" . $frozen; unless($self->{remote}{socket}->opened()) { $self->{connected}=0; $self->{error}=$error="Socket not open"; return 0; } unless($self->{remote}{socket}->syswrite($raw, length $raw)) { $self->{connected}=0; return 0 if($!==EPIPE); $self->{error}=$error="Error writing: $!\n"; return 0; } return 1; } #---------------------------------------------------- sub _response { my($self, $rsvp, $wantarray)=@_; $rsvp=specifier_parse($rsvp); my $remote=$self->{remote}; my $start = time; my $stopon = $start + $self->{timeout}; my $select=IO::Select->new() or die $!; # create the select object $select->add($remote->{socket}); my(@ready, $s, $raw, $frozen, $ret, $l, $need); $raw=''; my $blocks = 0; do {{ my $timeout = $stopon-time; if( $timeout <= 0 ) { $timeout = 1; } # Torture::my_warn( "timeout=$timeout" ); @ready=$select->can_read( $timeout ); # this is the select unless( @ready ) { # nothing ready == timeout # Torture::my_warn( 'select hates me' ); last; } foreach $s (@ready) # let's see what's ready... { die "Hey! $s isn't $remote->{socket}" unless $s eq $remote->{socket}; } DEBUG && print "Got something...\n"; # read in another chunk $l = $remote->{socket}->sysread($raw, $self->{block_size}, length($raw)); unless(defined $l) { # disconnect, maybe? $remote->{connected}=0 if $!==EPIPE; die "Error reading: $!\n"; } $blocks ++; if(not $need and $raw=~s/(\d+)\0//s) { # look for a marker? $need=$1 ; DEBUG && print "Need $need bytes...\n"; } next unless $need; # still looking... if(length($raw) >= $need) # do we have all we want? { # Torture::my_warn( 'Got it all' ); DEBUG && print "Got it all...\n"; $frozen=substr($raw, 0, $need); # seems so... substr($raw, 0, $need)=''; my $msg=$self->{remote}{thaw}->($frozen); # thaw the message DEBUG && print "msg=", Dumper $msg; my $to=specifier_parse($msg->{event}); die "$msg->{params}\n" if($msg->{is_error}); # throw an error out DEBUG && print "Not an error...\n"; # make sure it's what we're waiting for... if($to->{session} ne 'IKC' and $to->{session} ne 'IKCLite') { warn "Unknown session $to->{session}\n"; DEBUG && print "Not for us! ($to->{session})...\n"; next; } if($to->{session} ne $rsvp->{session} or $to->{state} ne $rsvp->{state}) { warn specifier_name($to). " received, expecting " . specifier_name($rsvp). "\n"; DEBUG && print "Not for us! ($to->{session}/$to->{state})...\n"; next; } DEBUG and print "wantarray=$wantarray\n"; if( $wantarray ) { DEBUG and print "Wanted an array\n"; return @{$msg->{params}} if ref $msg->{params} eq 'ARRAY'; } return $msg->{params}; # finaly! } # Torture::my_warn( "blocks=$blocks l=$l need=$need, got=", length $raw ); }} while ($stopon >= time) ; # do it until time's up $remote->{connected}=0; confess "Timed out waiting for response ", specifier_name( $rsvp ); # die "Timed out waiting for response ", specifier_name( $rsvp ), "\n", # "start=$start stopon=$stopon now=", time; return; } #------------------------------------------------------------------------------ # Try to require one of the default freeze/thaw packages. sub _default_freezer { local $SIG{'__DIE__'} = 'DEFAULT'; my $ret; foreach my $p (qw(Storable FreezeThaw POE::Component::IKC::Freezer)) { my $q=$p; $q=~s(::)(/)g; eval { require "$q.pm"; import $p ();}; DEBUG and warn $@ if $@; return $p if $@ eq ''; } die __PACKAGE__." requires Storable or FreezeThaw or POE::Component::IKC::Freezer\n"; } sub _get_freezer { my($freezer)=@_; unless(ref $freezer) { my $symtable=$::{"main::"}; my $loaded=1; # find out of the package was loaded foreach my $p (split /::/, $freezer) { unless(exists $symtable->{"$p\::"}) { $loaded=0; last; } $symtable=$symtable->{"$p\::"}; } unless($loaded) { my $q=$freezer; $q=~s(::)(/)g; eval {require "$q.pm"; import $freezer ();}; croak $@ if $@; } } # Now get the methodes we want my $freeze=$freezer->can('nfreeze') || $freezer->can('freeze'); carp "$freezer doesn't have a freeze method" unless $freeze; my $thaw=$freezer->can('thaw'); carp "$freezer doesn't have a thaw method" unless $thaw; # If it's an object, we use closures to create a $self->method() my $tf=$freeze; my $tt=$thaw; if(ref $freezer) { $tf=sub { return $freeze->($freezer, @_) }; $tt=sub { return ($thaw->($freezer, @_))[0] }; } else { # FreezeThaw::thaw returns an array now! We only want the first # element. $tt=sub { return ($thaw->( @_ ))[0] }; } return($tf, $tt); } 1; __END__ =head1 NAME POE::Component::IKC::ClientLite - Small client for IKC =head1 SYNOPSIS use POE::Component::IKC::ClientLite; $poe=create_ikc_client(port=>1337); die POE::Component::IKC::ClientLite::error() unless $poe; $poe->post("Session/event", $param) or die $poe->error; # bad way of getting a return value my $foo=$poe->call("Session/other_event", $param) or die $poe->error; # better way of getting a return value my $ret=$poe->post_respond("Session/other_event", $param) or die $poe->error; # make sure connectin is aliave $poe->ping() or $poe->disconnect; =head1 DESCRIPTION ClientLite is a small, pure-Perl IKC client implementation. It is very basic because it is intented to be used in places where POE wouldn't fit, like mod_perl. It handles automatic reconnection. When you post an event, ClientLite will try to send the packet over the wire. If this fails, it tries to reconnect. If it can't it returns an error. If it can, it will send he packet again. If *this* fails, well, tough luck. =head1 METHODS =head2 create_ikc_client Creates a new PoCo::IKC::ClientLite object. Parameters are supposedly compatible with PoCo::IKC::Client, but unix sockets aren't handled yet... What's more, there are 3 additional parameters: =over 4 =item block_size Size, in octets (8 bit bytes), of each block that is read from the socket at a time. Defaults to C<65535>. =item timeout Time, in seconds, that C and C will wait for a response. Defaults to 30 seconds. =item connect_timeout Time, in seconds, to wait for a phase of the connection negotiation to complete. Defaults to C. There are 4 phases of negotiation, so a the default C of 30 seconds means it could potentialy take 2 minutes to connect. =item protocol Which IKC negociation protocol to use. The original protocol (C) was synchronous and slow. The new protocol (C) sends all information at once. IKC0 will degrade gracefully to IKC, if the client and server don't match. Default is IKC0. =back =head2 connect $poe->connect or die $poe->error; Connects to the remote kernel if we aren't already. You can use this method to make sure that the connection is open before trying anything. Returns true if connection was successful, false if not. You can check L to see what the problem was. =head2 disconnect Disconnects from remote IKC server. =head2 error my $error=POE::Component::IKC::ClientLite::error(); $error=$poe->error(); Returns last error. Can be called as a object method, or as a global function. =head2 post $poe->post($specifier, $data); Posts the event specified by C<$specifier> to the remote kernel. C<$data> is any parameters you want to send along with the event. It will return 1 on success (ie, data could be sent... not that the event was received) and undef() if we couldn't connect or reconnect to remote kernel. =head2 post_respond my $ret=$poe->post_respond($specifier, $data); Posts the event specified by C<$specifier> to the remote kernel. C<$data> is any parameters you want to send along with the event. It waits until the remote kernel sends a message back and returns it's payload. Waiting timesout after whatever you value you gave to L->spawn. Events on the far side have to be aware of post_respond. In particular, ARG0 is not C<$data> as you would expect, but an arrayref that contains C<$data> followed by a specifier that should be used to post back. sub my_event { my($kernel, $heap, $args)=@_[KERNEL, HEAP, ARG0]; my $p=$args->[0]; $heap->{rsvp}=$args->[1]; # .... do lotsa stuff here } # eventually, we are finished sub finished { my($kernel, $heap, $return)=@_[KERNEL, HEAP, ARG0]; $kernel->post(IKC=>'post', $heap->{rsvp}, $return); } =head2 responded my $ret = $poe->responded( $state ); my @ret = $poe->responded( $state ); Waits for $state from the remote kernel. C<$state> must be a simple state name. Any requests from the remotre kernel for other states are rejected. A remote handler would respond by using the L. =head2 call my $ret=$poe->call($specifier, $data); This is the bad way to get information back from the a remote event. Follows the expected semantics from standard POE. It works better then post_respond, however, because it doesn't require you to change your interface or write a wrapper. =head2 ping unless($poe->ping) { # connection is down! connection is down! } Find out if we are still connected to the remote kernel. This method will NOT try to reconnect to the remote server =head2 name Returns our local name. This is what the remote kernel thinks we are called. I can't really say this is the local kernel name, because, well, this isn't really a kernel. But hey. =head1 AUTHOR Philip Gwyn, =head1 COPYRIGHT AND LICENSE Copyright 1999-2011 by Philip Gwyn. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =head1 SEE ALSO L, L =cut POE-Component-IKC-0.2305/FUTUR0000644000076400007640000000377411457365554013572 0ustar filfilIKC developement is sort of stalled right now, for 2 reasons : it does everything I currently need (and I don't have the time to add the extra features) AND I'm spending some time thinking about how to improve the design. I've come to realise that IKC is 3 things : - Dealing with a pre-forking POE server and babysitting the children processes This should be factored out into a standalone component. - Protocol and implementation for sending events between kernels. I want to rework the current protocol (which uses 3 states and is slightly fragile if either end misbehaves) and add XML-RPC (and maybe SOAP) support. And add other IPC options (unix sockets). And clean up event parameter handling. The currently version has no access control mechanisms. This was a deliberate choice. I think access control should be layered on top of IKC. This will have to be dealt with if I decide to expose XML-RPC interfaces. - Dealing with "clusters" of kernels I call these "clouds of kernels". I would like IKC to be able to automagically fall-over to other kernels that publish the same sessions/states when a foreign kernels become unavaible. This means IKC has to be able to automatically find/register remote kernels and stuff. Currently, I've only implemented auto-reconnect and proxy sessions. The latter I would like to extend to proxy-objects (object methods get converted into calls to remote kernels). And, off in the far future, I would like to add transaction processing and crash recovery. (This might not be a distant future, because I'm going to be reimplement an e-commerce application that does credit card validation this spring and transactions would make this much funner). Ancillary stuff : a distributed application framework (interfaces, "scripting", error handling) built on top of IKC. I'm going to be working on this in the next few months. (Why do I get the feeling I'm reimplementing CORBA? :) So that's roughly the state of IKC at this moment. You have been warned. POE-Component-IKC-0.2305/test-client0000644000076400007640000000741211465446317015105 0ustar filfil#!/usr/bin/perl $^W=1; use strict; # sub POE::Kernel::TRACE_EVENTS () {1} # sub POE::Kernel::TRACE_RETURNS () {1} use POE::Kernel; eval { POE::Component::IKC::Responder->spawn(); Test::Client->spawn(@ARGV); $poe_kernel->run(); }; warn $@ if $@; ################################################################ package Test::Client; use strict; use POE::Component::IKC::Client; use POE::Component::IKC::Responder; use POE::Session; sub DEBUG { 0 } sub spawn { my($package, $type, $port)=@_; $port ||= 1338; POE::Session->create( args=>[$type, $port], package_states=>[ $package=>[qw(_start posting calling callback _stop subscribing subscribed unsubscribed YOW registered)], ] ); } sub _start { DEBUG and warn "Client: _start\n"; my($kernel, $heap, $type, $port)=@_[KERNEL, HEAP, ARG0, ARG1]; $kernel->alias_set('Client'); my %args; DEBUG and warn "$$: type=$type"; if( $type =~ m/0$/ ) { $args{protocol} = 'IKC0'; } my $rname=$heap->{name}=ucfirst $type; $rname =~ s/\d+$//; $heap->{rname} = $rname; if($type =~ /^ikc/) { $args{serializer}='POE::Component::IKC::Freezer'; # $kernel->post(IKC=>'monitor', 'Inet'=>{register=>'registered'}); # } else { } DEBUG and warn "$$: Looking for $rname"; $kernel->post(IKC=>'monitor', $rname=>{register=>'registered'}); $args{name} = "$heap->{name}Client"; if($type =~ /^unix/) { $args{unix}=($ENV{TMPDIR}||$ENV{TEMP}||'/tmp').'/IKC-test.pl'; } else { # ikc AND inet $args{port}=$port; } POE::Component::IKC::Client->spawn(%args); } sub _stop { DEBUG and warn "Client: _stop\n"; } sub registered { DEBUG and warn "Client: registered\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; sleep(0); $kernel->yield('posting'); } ######################################################## sub posting { DEBUG and warn "Client: posting\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; $kernel->post(IKC=>'post', "poe://$heap->{rname}/test/posted"=> ['posted', $heap->{name}]); sleep(0); $kernel->yield('calling'); } ######################################################## sub calling { DEBUG and warn "Client: calling\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; sleep(0); $kernel->call( IKC=>'call', "poe://$heap->{rname}/test/called"=>'called', 'poe:callback' ); } sub callback { DEBUG and warn "Client: callback\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; sleep(0); $kernel->yield('subscribing'); } ######################################################## sub subscribing { DEBUG and warn "Client: subscribing ($$)\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; $kernel->post(IKC=>'monitor', $heap->{rname}=>{ subscribe=>'subscribed', unsubscribe=>'unsubscribed' }); $kernel->post(IKC=>'publish', Client=>[qw(YOW)]); $kernel->post(IKC=>'subscribe', "poe://$heap->{rname}/test"); } sub subscribed { DEBUG and warn "Client: subscribed\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; # warn "$INC{'POE/Component/IKC/Proxy.pm'}"; $kernel->post("poe://$heap->{rname}/test" => 'method', {type => 'method'}); } sub YOW { DEBUG and warn "Client: YOW\nClient: unsubscribing\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; $kernel->post(IKC=>'retract', Client=>[qw(YOW)]); $kernel->post(IKC=>'unsubscribe', "poe://$heap->{rname}/test"); } sub unsubscribed { DEBUG and warn "Client: unsubscribed\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; $kernel->call(IKC=>'post', "poe://$heap->{rname}/test/done"); $kernel->post(IKC=>'shutdown'); } POE-Component-IKC-0.2305/test-thunk0000755000076400007640000000517411457365554014772 0ustar filfil#!/usr/bin/perl $^W=1; use strict; # sub POE::Kernel::TRACE_EVENTS () {1} # sub POE::Kernel::TRACE_RETURNS () {1} use POE::Kernel; eval { Test::Client->spawn(@ARGV); $poe_kernel->run(); }; warn $@ if $@; ################################################################ package Test::Client; use strict; use POE::Component::IKC::Client; use POE::Component::IKC::Responder; use POE::Session; use Data::Dumper; sub DEBUG { 0 } sub spawn { my($package, $type, $port)=@_; $type .= $$; $port ||= 1338; POE::Session->create( args=>[$type, $port], package_states=>[ $package=>[qw(_start _stop registered first resp1 resp2 resp3 )], ] ); } sub _start { DEBUG and warn "Client: _start\n"; my($kernel, $heap, $type, $port)=@_[KERNEL, HEAP, ARG0, ARG1]; $kernel->alias_set('Client'); POE::Component::IKC::Responder->spawn(); $heap->{name}=ucfirst $type; my %args=(name=>"$heap->{name}Client"); DEBUG and warn "Client: $args{name}"; $kernel->post(IKC=>'monitor', Ikc=>{register=>'registered'}); $kernel->post(IKC=>'publish', Client=>[qw(resp1 resp2 resp3)]); $args{port}=$port; POE::Component::IKC::Client->spawn(%args); } sub _stop { DEBUG and warn "Client: _stop\n"; } sub registered { DEBUG and warn "Client: registered\n"; my($kernel, $heap)=@_[KERNEL, HEAP]; sleep(0); $kernel->yield('first'); } ######################################################## sub first { my($kernel, $heap)=@_[KERNEL, HEAP]; DEBUG and warn "Client: resp1\n"; $kernel->post(IKC=>'post', "poe://Ikc/test/post1" => 'I am'); } ######################################################## sub resp1 { my($kernel, $heap, $ret)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Client: resp1\n"; unless( $ret eq 'I am' ) { die "resp1 got $ret"; } $kernel->post( IKC=>'post', "poe://Ikc/test/post2" => [ qw( IRON MAN )] ); } ######################################################## sub resp2 { my($kernel, $heap, $iron, $man)=@_[KERNEL, HEAP, ARG0, ARG1]; DEBUG and warn "Client: resp2\n"; unless( $iron eq 'IRON' and $man eq 'MAN' ) { die "resp2 got '$iron', '$man'"; } $kernel->post( IKC=>'post', "poe://Ikc/test/post3" => [] ); } ######################################################## sub resp3 { my($kernel, $heap, $ret)=@_[KERNEL, HEAP, ARG0]; DEBUG and warn "Client: resp3\n"; unless( 'ARRAY' eq ref $ret and 0==@$ret ) { die "resp3 got ", Dumper $ret; } $kernel->post( IKC=>'post', "poe://Ikc/test/done" ); } __END__ POE-Component-IKC-0.2305/IKC.pm0000644000076400007640000000027012106220560013645 0ustar filfilpackage POE::Component::IKC; # $Id: IKC.pm 1077 2013-02-11 16:50:56Z fil $ use strict; use vars qw( $VERSION ); $VERSION='0.2305'; # Force CPAN to see this sub DEBUG () { 0 } 1; POE-Component-IKC-0.2305/META.yml0000664000076400007640000000107212157370557014177 0ustar filfil--- abstract: 'Inter-Kernel Communication for POE' author: - 'Philip Gwyn ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: POE-Component-IKC no_index: directory: - t - inc requires: Data::Dump: 1 Devel::Size: 0.77 POE: 1.311 Scalar::Util: 1 Test::More: 0.6 version: 0.2305 POE-Component-IKC-0.2305/META.json0000664000076400007640000000177212157370557014356 0ustar filfil{ "abstract" : "Inter-Kernel Communication for POE", "author" : [ "Philip Gwyn " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "POE-Component-IKC", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "runtime" : { "requires" : { "Data::Dump" : "1", "Devel::Size" : "0.77", "POE" : "1.311", "Scalar::Util" : "1", "Test::More" : "0.6" } } }, "release_status" : "stable", "version" : "0.2305" } POE-Component-IKC-0.2305/Makefile.PL0000644000076400007640000000102312157370551014664 0ustar filfiluse ExtUtils::MakeMaker; WriteMakefile( AUTHOR => 'Philip Gwyn ', NAME => 'POE::Component::IKC', VERSION_FROM => 'IKC.pm', # finds $VERSION DISTNAME => 'POE-Component-IKC', dist=>{COMPRESS=>'gzip -9f', EXT=>'gz'}, PREREQ_PM =>{ POE => 1.311, Scalar::Util => 1, Test::More => 0.6, Data::Dump => 1, Devel::Size => 0.77 }, ABSTRACT => 'Inter-Kernel Communication for POE', LICENSE => 'perl' ); POE-Component-IKC-0.2305/TODO0000644000076400007640000000470211457365554013422 0ustar filfil- extend the monitor stuff - socket errors - remote_subscribe/remote_unsubscribe - Other IPC then just INET and UNIX domain sockets (IPC, Pipes, FIFOs) - Global event naming scheme This will also make documentation and discussions easier. - Access restrictions Currently all a foreign kernel can post events to any session w/in a local kernel. A much better idea would be to have sessions register the events they want foreign kernels to get access. - Proxy sessions During negociation phase, a kernel will tell the foreign kernel about all the sessions that have "exposed" events. The local kernel will create proxy sessions locally of thses sessions. These sessions will "die" when the kernel disconnects. (Hey, why not have these proxy sessions attempt to reconnect also?) This will mean $_[SENDER] will always make sense. However, the negociation phase could rapidly become overly tedious if a foreign kernel knows about 100 Sessions, but the local kernel is only going to use one of them. - Lazy Proxy creation When someone does a $kernel->alias_resolve(), the kernel could query foreign kernels if they have the given session alias. Looking wider : - POE::Carp AKA MONITORING POE needs a general exception handling mechanism. This will allow us to send better diagnostic messages back to foreign kernels. Maybe something along the lines of the monitor stuff. - IKC clouds I envision a multiply connected network of IKC servers, one per host. A IKC server would need to be able to find at least one other IKC server. After connecting, they would send each other all the kernels they know about, and how to connect to each of them. A kernel that wants to expose sessions and events to foreign kernels (let's call it a IKC module) would only connect to the nearest IKC server, which would take care of propogating the information to the other servers in the cluster). This will allow us to implement load balancing, rollover, high-availablility and other buzz-words. And remote CONFIGS! See next item - Automagical IKC /etc/poe.conf or ~/.poe.conf could have all the params needed for connecting to the IKC cluster. Cf Stem: it has a nice config-driven way of doing things (local config, ARGS config and even remote config). This is similar, but better, then the POE::Interface (a la IDL) idea I had at the begining.