POE-1.368/000755 001751 001751 00000000000 13615550107 012767 5ustar00bingosbingos000000 000000 POE-1.368/lib/000755 001751 001751 00000000000 13615550107 013535 5ustar00bingosbingos000000 000000 POE-1.368/t/000755 001751 001751 00000000000 13615550107 013232 5ustar00bingosbingos000000 000000 POE-1.368/CHANGES000644 001751 001751 00000004454 13615550112 013765 0ustar00bingosbingos000000 000000 ================================ 2020-02-01 16:22:28 +0000 v1_368 ================================ commit 0f954072fe361ad48861202c43aec3c0b5129e4a Author: Chris 'BinGOs' Williams Date: Sat Feb 1 16:22:28 2020 +0000 Version bump for release. commit b9971dfd392ac3098ef3bfaf6e1fbce2fcb48b01 Author: Chris 'BinGOs' Williams Date: Sat Feb 1 12:40:44 2020 +0000 Fix leolo-filter-httpd test when HTTP::Status is missing commit 209890407b501a86ee322b07e9170ad8054c7bf1 Author: Michael Brantley Date: Tue Feb 20 07:12:06 2018 -0500 Update broken Pod links in lib/POE/Filter/HTTPD.pm Update Pod links to refer only to the utf8 module and not its methods, fix a mis-capitalized internal reference, and convert the dangling "MaxContent" link into a code reference. Resolves bug: https://rt.cpan.org/Public/Bug/Display.html?id=124496 commit 1d088d3755f770397a27852f95925564d4c3f134 Author: Michael Brantley Date: Tue Feb 20 07:07:22 2018 -0500 Update old URLs referenced in Pod Remove mention of old URLs, replace mention of canonical SVN repo with the new git-based one at github.com. Resolves bug: https://rt.cpan.org/Public/Bug/Display.html?id=124495 commit 92c2cfb55ae87ecdb4a89ad5fac65315052a3d15 Author: Mohammad S Anwar Date: Fri Jul 20 18:22:44 2018 +0100 Fixed minor typo in the pod. commit cf5b772fa54e0cda0e447c33ce351f1e6c074d42 Author: Chris 'BinGOs' Williams Date: Tue Oct 29 10:09:52 2019 +0000 Corrected previous commit as per tonyc's suggestion commit ad8639840383ea1b166ff0090afabc954dffba27 Author: Chris 'BinGOs' Williams Date: Fri Oct 25 15:21:25 2019 +0100 RT#130664 test failures with v5.31.5 As per perldelta entry for v5.31.5 https://metacpan.org/pod/release/SHAY/perl-5.31.5/pod/perldelta.pod#I ncompatible-Changes commit 1c0dccd41b8fc1fd2bbfd4ea6a0e94255cd747fc Author: Rocco Caputo Date: Mon Feb 29 17:54:58 2016 -0500 Modernize the SYNOPSIS by replacing perl -w with "use warnings". Thanks, mauke @ irc.perl.org #perl! ============== End of Excerpt ============== POE-1.368/examples/000755 001751 001751 00000000000 13615550107 014605 5ustar00bingosbingos000000 000000 POE-1.368/mylib/000755 001751 001751 00000000000 13615550107 014103 5ustar00bingosbingos000000 000000 POE-1.368/MANIFEST000644 001751 001751 00000012225 13615550107 014122 0ustar00bingosbingos000000 000000 CHANGES HISTORY MANIFEST This list of files MANIFEST.SKIP Makefile.PL README TODO examples/README.samples examples/create.perl examples/fakelogin.perl examples/forkbomb.perl examples/names.perl examples/objmaps.perl examples/objsessions.perl examples/packagesessions.perl examples/queue.perl examples/selects.perl examples/sessions.perl examples/signals.perl examples/tcp_watermarks.perl examples/thrash.perl examples/watermarks.perl examples/wheels2.perl lib/POE.pm lib/POE/Component.pm lib/POE/Component/Client/TCP.pm lib/POE/Component/Server/TCP.pm lib/POE/Driver.pm lib/POE/Driver/SysRW.pm lib/POE/Filter.pm lib/POE/Filter/Block.pm lib/POE/Filter/Grep.pm lib/POE/Filter/HTTPD.pm lib/POE/Filter/Line.pm lib/POE/Filter/Map.pm lib/POE/Filter/RecordBlock.pm lib/POE/Filter/Reference.pm lib/POE/Filter/Stackable.pm lib/POE/Filter/Stream.pm lib/POE/Kernel.pm lib/POE/Loop.pm lib/POE/Loop/IO_Poll.pm lib/POE/Loop/PerlSignals.pm lib/POE/Loop/Select.pm lib/POE/NFA.pm lib/POE/Pipe.pm lib/POE/Pipe/OneWay.pm lib/POE/Pipe/TwoWay.pm lib/POE/Queue.pm lib/POE/Queue/Array.pm lib/POE/Resource.pm lib/POE/Resource/Aliases.pm lib/POE/Resource/Clock.pm lib/POE/Resource/Events.pm lib/POE/Resource/Extrefs.pm lib/POE/Resource/FileHandles.pm lib/POE/Resource/SIDs.pm lib/POE/Resource/Sessions.pm lib/POE/Resource/Signals.pm lib/POE/Resources.pm lib/POE/Session.pm lib/POE/Test/Sequence.pm lib/POE/Wheel.pm lib/POE/Wheel/Curses.pm lib/POE/Wheel/FollowTail.pm lib/POE/Wheel/ListenAccept.pm lib/POE/Wheel/ReadLine.pm lib/POE/Wheel/ReadWrite.pm lib/POE/Wheel/Run.pm lib/POE/Wheel/SocketFactory.pm mylib/Devel/Null.pm mylib/ForkingDaemon.pm mylib/MyOtherFreezer.pm mylib/PoeBuildInfo.pm mylib/coverage.perl mylib/cpan-test.perl mylib/events_per_second.pl mylib/gen-tests.perl mylib/svn-log.perl t/00_info.t t/10_units/01_pod/01_pod.t t/10_units/01_pod/02_pod_coverage.t t/10_units/01_pod/03_pod_no404s.t t/10_units/01_pod/04_pod_linkcheck.t t/10_units/02_pipes/01_base.t t/10_units/02_pipes/02_oneway.t t/10_units/02_pipes/03_twoway.t t/10_units/03_base/01_poe.t t/10_units/03_base/03_component.t t/10_units/03_base/04_driver.t t/10_units/03_base/05_filter.t t/10_units/03_base/06_loop.t t/10_units/03_base/07_queue.t t/10_units/03_base/08_resource.t t/10_units/03_base/09_resources.t t/10_units/03_base/10_wheel.t t/10_units/03_base/11_assert_usage.t t/10_units/03_base/12_assert_retval.t t/10_units/03_base/13_assert_data.t t/10_units/03_base/14_kernel.t t/10_units/03_base/15_kernel_internal.t t/10_units/03_base/16_nfa_usage.t t/10_units/03_base/17_detach_start.t t/10_units/04_drivers/01_sysrw.t t/10_units/05_filters/01_block.t t/10_units/05_filters/02_grep.t t/10_units/05_filters/03_http.t t/10_units/05_filters/04_line.t t/10_units/05_filters/05_map.t t/10_units/05_filters/06_recordblock.t t/10_units/05_filters/07_reference.t t/10_units/05_filters/08_stream.t t/10_units/05_filters/50_stackable.t t/10_units/05_filters/51_reference_die.t t/10_units/05_filters/99_filterchange.t t/10_units/05_filters/TestFilter.pm t/10_units/06_queues/01_array.t t/10_units/07_exceptions/01_normal.t t/10_units/07_exceptions/02_turn_off.t t/10_units/07_exceptions/03_not_handled.t t/10_units/08_loops/01_explicit_loop.t t/10_units/08_loops/02_explicit_loop_fail.t t/10_units/08_loops/03_explicit_loop_poll.t t/10_units/08_loops/04_explicit_loop_envvar.t t/10_units/08_loops/05_kernel_loop.t t/10_units/08_loops/06_kernel_loop_poll.t t/10_units/08_loops/07_kernel_loop_fail.t t/10_units/08_loops/08_kernel_loop_search_poll.t t/10_units/08_loops/09_naive_loop_load.t t/10_units/08_loops/10_naive_loop_load_poll.t t/10_units/08_loops/11_double_loop.t t/20_resources/00_base/aliases.pm t/20_resources/00_base/caller_state.pm t/20_resources/00_base/events.pm t/20_resources/00_base/extrefs.pm t/20_resources/00_base/extrefs_gc.pm t/20_resources/00_base/filehandles.pm t/20_resources/00_base/sessions.pm t/20_resources/00_base/sids.pm t/20_resources/00_base/signals.pm t/90_regression/agaran-filter-httpd.t t/90_regression/averell-callback-ret.t t/90_regression/bingos-followtail.t t/90_regression/broeren-win32-nbio.t t/90_regression/cfedde-filter-httpd.t t/90_regression/ferrari-server-unix.t t/90_regression/grinnz-die-in-die.t t/90_regression/hinrik-wheel-run-die.t t/90_regression/kjeldahl-stop-start-polling.t t/90_regression/kjeldahl-stop-start-sig-nopipe.t t/90_regression/kjeldahl-stop-start-sig-pipe.t t/90_regression/leolo-sig-die.t t/90_regression/meh-startstop-return.t t/90_regression/neyuki_detach.t t/90_regression/pipe-followtail.t t/90_regression/prumike-win32-stat.t t/90_regression/rt14444-arg1.t t/90_regression/rt1648-tied-stderr.t t/90_regression/rt19908-merlyn-stop.t t/90_regression/rt23181-sigchld-rc.t t/90_regression/rt47966-sigchld.t t/90_regression/rt56417-wheel-run.t t/90_regression/rt65460-forking.t t/90_regression/socketfactory-timeout.t t/90_regression/somni-poco-server-tcp.t t/90_regression/steinert-passed-wheel.t t/90_regression/suzman_windows.t t/90_regression/ton-stop-corruption.t t/90_regression/tracing-sane-exit.t t/90_regression/whelan-dieprop.t t/90_regression/whjackson-followtail.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) POE-1.368/TODO000644 001751 001751 00000001124 12143730315 013451 0ustar00bingosbingos000000 000000 $Id$ ------------------ Where Did This Go? ------------------ The contents of this file have moved to the 'web. You can find them at . POE's web site is live editable by nearly everyone. Readers can quickly patch errors or omissions on the site rather than wait for their comments to percolate through e-mail and a maintainer's schedule. Please see for information on acquiring an account on the site and setting your editing and viewing preferences. --------------------------- EOF: Thank you for reading. --------------------------- POE-1.368/Makefile.PL000644 001751 001751 00000013404 12500601177 014737 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # rocco // vim: ts=2 sw=2 expandtab # Note to Dist::Zilla fans - This is NOT a standard Makefile.PL by ANY # stretch of the imagination. If you want to port it to Dist::Zilla, # you'll have a number of challenges ahead of you: # # - Custom Makefile.PL code. # # - Dynamic dependencies varying by $^O (see mylib/PoeBuildInfo.pm) # and by $] (see IPv6 dependencies below). # # - Dynamically generated tests. See PREOP in WriteMakefile(), below. # # - Custom Makefile target "coverage". See MY::postamble, below. # # I have tried using Dist::Zilla::Plugin::Makemaker::Awesome, but the # need to break encapsulation in order to make it work turned me away. # # People who love Dist::Zilla are welcome to replace this perfectly # fine Makefile.PL, but you should be aware of some requirements # before I'll accept the change: # # - Reproduce or improve upon all current Makefile.PL features. It's # all there for one reason or another. The reasons are still largely # pertinent. When in doubt, ask. # # - Limit your changes to replacing Makefile.PL and $VERSION. I'd # rather be able to rely on error message line numbers than to add # more moving parts to my build and test workflows. use strict; use ExtUtils::MakeMaker; use Config; use File::Spec; # Switch to default behavior if STDIN isn't a tty. unless (-t STDIN) { warn( "\n", "=============================================\n\n", "STDIN is not a terminal. Assuming --default.\n\n", "=============================================\n\n", ); push @ARGV, "--default"; } # Remind the user she can use --default. unless (grep /^--default$/, @ARGV) { warn( "\n", "=============================================\n\n", "Prompts may be bypassed by running:\n", " $^X $0 --default\n\n", "=============================================\n\n", ); } # Should we skip the network tests? my $prompt = ( "Some of POE's tests require a functional network.\n" . "You can skip these tests if you'd like.\n\n" . "Would you like to skip the network tests?" ); my $ret = "n"; if (grep /^--default$/, @ARGV) { print $prompt, " [$ret] $ret\n\n"; } else { $ret = prompt($prompt, "n"); } my $marker = 'run_network_tests'; unlink $marker; unless ($ret =~ /^Y$/i) { open(TOUCH,"+>$marker") and close TOUCH; } print "\n"; use lib qw(./mylib); use PoeBuildInfo qw( TEST_FILES CLEAN_FILES CORE_REQUIREMENTS DIST_ABSTRACT DIST_AUTHOR CONFIG_REQUIREMENTS HOMEPAGE REPOSITORY ); ### Touch files that will be generated at "make dist" time. ### ExtUtils::MakeMaker will complain about them if ### they aren't present now. open(TOUCH, ">>CHANGES") and close TOUCH; ### Touch gen-tests.perl so it always triggers. utime(time(), time(), "mylib/gen-tests.perl"); ### Some advisory dependency testing. sub check_for_modules { my ($dep_type, @modules) = @_; my @failures; while (@modules) { my $module = shift @modules; my $target = shift @modules; my $version = eval "use $module (); return \$$module\::VERSION"; if ($@) { push( @failures, "*** $module $target could not be loaded.\n" ); } elsif ($version < $target) { push( @failures, "*** $module $target is $dep_type, " . "but version $version is installed.\n" ); } } if (@failures) { warn( "*** Some $dep_type features may not be available:\n", @failures, ); } } check_for_modules("required", CORE_REQUIREMENTS); check_for_modules( "optional", "Compress::Zlib" => 1.33, "Curses" => 1.08, "IO::Poll" => 0.01, "IO::Pty" => 1.02, "LWP" => 5.79, "Term::Cap" => 1.10, "Term::ReadKey" => 2.21, "URI" => 1.30, ); # check for optional IPv6 stuff { # under perl-5.6.2 the warning "leaks" from the eval, while newer versions don't... # it's due to Exporter.pm behaving differently, so we have to shut it up no warnings 'redefine'; require Carp; local *Carp::carp = sub { die @_ }; # On perl-5.14.0 Socket.pm provides getaddrinfo # otherwise we need to use Socket::GetAddrInfo eval { require Socket; Socket->import("getaddrinfo") }; if ($@) { check_for_modules( "optional", "Socket::GetAddrInfo" => "0.20", ); } # On perl-5.14.0 Socket.pm provides the needed IPv6 constants # otherwise we need to use Socket6 eval { Socket->import( qw(AF_INET6 PF_INET6) ) }; if ($@) { check_for_modules( "optional", "Socket6" => "0.23", ); } } ### Generate Makefile.PL. sub MY::postamble { my $cov = File::Spec->catfile(mylib => 'coverage.perl'); return < 'POE', AUTHOR => DIST_AUTHOR, ABSTRACT => DIST_ABSTRACT, LICENSE => 'perl', CONFIGURE_REQUIRES => { CONFIG_REQUIREMENTS }, BUILD_REQUIRES => { CONFIG_REQUIREMENTS }, VERSION_FROM => 'lib/POE.pm', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', PREOP => ( 'git-log.pl | ' . '/usr/bin/tee ./$(DISTNAME)-$(VERSION)/CHANGES > ./CHANGES; ' ), }, clean => { FILES => CLEAN_FILES }, test => { TESTS => TEST_FILES }, # Not executed on "make test". PL_FILES => { File::Spec->catfile(mylib => 'gen-tests.perl') => [ 'lib/POE.pm' ] }, PREREQ_PM => { CORE_REQUIREMENTS }, META_MERGE => { no_index => { directory => [ 'mylib' ], }, resources => { homepage => HOMEPAGE, license => 'http://dev.perl.org/licenses/', repository => REPOSITORY, }, }, # TODO - ExtUtils::MakeMaker doesn't generate 'provides'. # Module::Build did, but we're not using it anymore. ); 1; POE-1.368/HISTORY000644 001751 001751 00000037051 12143730317 014057 0ustar00bingosbingos000000 000000 $Id$ A brief, pointless history of POE's evolution. ------------------------------------------------------------------------------- Received: from sinistar.idle.com (sinistar.idle.com [198.109.160.36]) by anshar.shadow.net (8.7.3/8.7.3) with ESMTP id JAA05315 for ; Fri, 7 Feb 1997 09:59:05 -0500 (EST) Received: (from slist@localhost) by sinistar.idle.com (8.7.5/8.7.3) id JAA12501; Fri, 7 Feb 1997 09:00:15 -0500 (EST) Resent-Date: Fri, 7 Feb 1997 09:00:15 -0500 (EST) Message-Id: <199702071400.JAA00295@anshar.shadow.net> From: "Rocco Caputo" To: "Felix Gallo" , "perl5-porters@perl.org" Date: Fri, 07 Feb 97 08:54:23 -0400 Reply-To: "Rocco Caputo" Priority: Normal Subject: portable multithreading Resent-Message-ID: <"O2kshC.A.W5C.lTz-y"@sinistar> Resent-From: perl5-porters@perl.org X-Mailing-List: archive/latest/135 X-Loop: perl5-porters@perl.org Precedence: list Resent-Sender: perl5-porters-request@perl.org Content-Type: text Content-Length: 3989 Status: On Thu, 06 Feb 1997 12:52:56 +0000, Felix Gallo wrote: >Felix's Perl-related Metaproblems: > >1. Perl is not event-driven, so programs which wish >to make objects available to the network must manually >interrupt their control flow to determine if a remote >object transaction request is pending. I'm writing a MUD in perl. The object language faces some of the same issues as perl, but I think there are ways around them (in the MUD language and in perl). In the MUD server, objects' methods must be compiled into perl bytecode. They must be multitasked/multithreaded so that bad code won't hang the server, and object authors usually should not have to think about events. For example, this "bad" MUD code will be legal. Don't worry, I move on to perl in just a minute. count = 10000000 while count-- say "hello, world! enter some text: " getline some_text if some_text eq 'quit' last endif endwhile say "\ngoodbye, world!\n" This needs to be compiled to perl bytecode at runtime. The MUD bytecode compiler first parses and syntax checks an object's source. If everything passes, it builds a perl sub definition in a string. This sub-in-a-string is treated as an assembly language for perl bytecode. The server runs eval() to assemble the string-o-perl into bytecodes, and then the resulting sub can be called over and over without additional eval() overhead. (Thanks, Silmaril!) Making that bad loop work in an event-driven server is a little harder than making bytecodes. The MUD compiler will build perl assembly as event-driven state machines. It can do this by noting the locations of branch destinations and returns from blocking calls. Each of these locations starts a new atomic "state", and an "instruction pointer" determines which state to run next. Here's the event-driven perl "assembly" for that sample MUD code. It's not very efficient, but it serves for illustration. sub aaaaa { # assumes the existence of a tasking/event kernel my $task = shift; my $namespace = $task->{"namespace"}; my $ip = $task->{'instruction pointer'}; # state # initial entry point if ($ip == 0) { $namespace->{'count'} = 10000000 ; $task->{'instruction pointer'} = 1; } # top of while loop elsif ($ip == 1) { if ( $namespace->{'count'} -- ) { $task->say( qq(hello, world! enter some text: ) ) ; # soft block on 'getline' $task->{'blocking'} = 'getline'; $task->{'instruction pointer'} = 2; } else { $task->{'instruction pointer'} = 3; } } # "return" from getline elsif ($ip == 2) { $namespace->{'some_text'} = $task->getline(); if ( $namespace->{'some_text'} eq q(quit) ) { $task->{'instruction pointer'} = 3; } else { $task->{'instruction pointer'} = 1; } } # after endwhile elsif ($ip == 3) { $task->say( qq(\ngoodbye, world!\n) ) ; $task->{'instruction pointer'} = -1; # signals end } } The main select/event loop would have some code to run tasks round-robin. Something like this, but probably including code to deal with priorities. if ($next = shift(@task_queue)) { if (($next->{'blocking'}) || ($next->run() != -1)) { push(@task_queue, $next); } else { undef $next; } } And starting a new task might look like this: $task = new Task($tasking_kernel, "count = ... world!\n"); if ($task->has_errors()) { $task->display_errors(); undef $task; } # otherwise the task has been compiled and registered # with the $tasking_kernel Anyway, that's how I'm writing portable multitasking for a syntactically simple MUD language. To make this work for perl, there would be a standard tasking package, and perl's bytecode compiler would need to modify its output to work with the package. Sort of like how the perl debugger works. Just some ideas to ponder. Rocco ------------------------------------------------------------------------------- Received: from sinistar.idle.com ([198.109.160.36]) by anshar.shadow.net (8.8.5/8.7.3) with ESMTP id VAA13861 for ; Mon, 14 Apr 1997 21:04:07 -0400 (EDT) Received: (from slist@localhost) by sinistar.idle.com (8.7.5/8.7.3) id UAA24149; Mon, 14 Apr 1997 20:37:16 -0400 (EDT) Resent-Date: Mon, 14 Apr 1997 20:37:16 -0400 (EDT) Message-Id: <199704150040.UAA11517@anshar.shadow.net> From: "Rocco Caputo" To: "Gary Howland" , "Tom Christiansen" Cc: "Gary Howland" , "Hugo van der Sanden" , "hv@tyree.iii.co.uk" , "perl5-porters@perl.org" Date: Mon, 14 Apr 97 20:34:01 -0500 Reply-To: "Rocco Caputo" Priority: Normal MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: Re: Perl5.005 wish list (event loop) Resent-Message-ID: <"99mWD.A.PzF.i0sUz"@sinistar> Resent-From: perl5-porters@idle.com X-Mailing-List: archive/latest/6171 X-Loop: perl5-porters@idle.com Precedence: list Resent-Sender: perl5-porters-request@idle.com Content-Type: text/plain; charset="iso-8859-1" Content-Length: 1119 Status: Gary, et al, Almost a year ago, I quietly announced something called "Serv + Face". Maybe my announcement was a little too quiet. Serv is a fork-less, select-based framework of event server classes. It provides a high level interface to select(), and a very high level interface to TCP client and server socket operations. It does not fork. Face is the start of a curses-based UI framework that can run alone or use Serv as its main loop. The code and a rough draft of the documentation are available from . If this code is useful to anyone, I'd sure like to know. Rocco On Tue, 15 Apr 1997 01:36:35 +0200, Gary Howland wrote: > >Select is fine. What we (the "event evangelists") want is a "level above" >select. When we have a chunk of data to send to x streams, we don't want to >have to call select, see which stream is ready for writing, work out how >many bytes we can send, send those bytes, shorten our buffers by that amount >of bytes, and loop back to select. We just want to send the data. And we >want to do this without forking. ------------------------------------------------------------------------------- Received: from sinistar.idle.com (sinistar.idle.com [198.109.160.36]) by anshar.shadow.net (8.7.3/8.7.3) with ESMTP id JAA04948 for ; Fri, 7 Feb 1997 09:54:31 -0500 (EST) Received: (from slist@localhost) by sinistar.idle.com (8.7.5/8.7.3) id JAA12519; Fri, 7 Feb 1997 09:00:19 -0500 (EST) Resent-Date: Fri, 7 Feb 1997 09:00:19 -0500 (EST) Message-Id: <199702071400.JAA00339@anshar.shadow.net> From: "Rocco Caputo" To: "Felix Gallo" , "perl5-porters@perl.org" Date: Fri, 07 Feb 97 08:54:31 -0400 Reply-To: "Rocco Caputo" Priority: Normal Subject: polytheistic perl references Resent-Message-ID: <"1y3hHB.A.w5C.sTz-y"@sinistar> Resent-From: perl5-porters@perl.org X-Mailing-List: archive/latest/136 X-Loop: perl5-porters@perl.org Precedence: list Resent-Sender: perl5-porters-request@perl.org Content-Type: text Content-Length: 1502 Status: On Thu, 06 Feb 1997 12:52:56 +0000, Felix Gallo wrote: >Felix's Perl-related Metaproblems: > >3. Perl references are monotheistic. One fancies that saying >$x = \{ http://perl.com/myperlobject }; would do the right thing, >but the established structure of Perl seems to make this difficult. There are tied hash packages that implement object naming and message passing between named objects within the same process. The packages allow invocations like: $msg{'desktop,paint'} = 1; $msg{'name entry,value'} = 'J. K. Cohen'; $active_flag = $msg{'active checkbox,value'}; The packages also do broadcasting to subsets of the object dictionary. Hash stores and fetches are sent to or taken from all the objects that match the supplied name. So to clear the value of all objects that have 'entry' in their names: $msg{'entry,value'} = ''; That clears 'name entry' and 'age entry' and 'salary entry' and .... Anyway, the names could be extended to work across sockets in the presence of a standard select/event loop: $gnats_queue = $msg{'//somewhere.com:4242/stickynote/gnat?count'}; print "gnat has $gnats_queue unread sticky notes.\n"; $message = 'hello, world!'; $msg{'//somewhere.org:4242/stickynote/merlyn?queue'} = $message; Man pages for ObjDict::Names and ObjDict::Messages are on-line at . The code is inside a larger package, Serv+Face, at . Just some ideas to ponder. Rocco ------------------------------------------------------------------------------- This is a header from a program I was writing before I discovered Perl. // ========================================================================= // UBERSYS.H // UberSys definitions and classes. // ========================================================================= #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include // ------------------------------------------------------------------------- // Constants, limits, and the like. #define SIZE_UID 9 // including NULL terminator #define SIZE_PWD 26 // including NULL terminator #define SIZE_MAXSTR 0x1000 // 4k string sizes (max) #define SIZE_MAXPATH 0x0050 // 160 chars for max path #define SIZE_MAXLINE 0x00A0 // 160 characters per line #define COUNT_LINES 0x0200 // 512 editor lines #define USREV 0x0200 // version 02.00 #define DRV "D:" // drive it runs on // ------------------------------------------------------------------------- // Helper macros. // build a 20-bit address from segoff #define A20(x) (((ULI)FP_SEG(x)<<4)+(ULI)FP_OFF(x)) // make a normalized pointer from A20 #define A32(x) MK_FP((UINT)((x)>>4), (UINT)((x)&0x0F)) // normalize a far pointer using A20 #define NORM(x) A32(A20(x)) // maximum of two values template T max(T x, T y) { return((x>y)?x:y); }; // minimum of two values template T min(T x, T y) { return((x install POE Or % cpan -i POE http://poe.perl.org/?Where_to_Get_POE explains other options for obtaining POE, including anonymous Subversion access. ------------ Test Results ------------ The CPAN Testers are a group of volunteers who test new CPAN distributions on a number of platforms. You can see their test results at: http://testers.cpan.org/search?request=dist&dist=POE POE's ongoing improvement relies on your feedback. You file bug reports, feature requests, and even success stories by e-mailing . ------------- Test Coverage ------------- POE's tests cover a significant portion of the distribution. A thumbnail sketch of POE's test coverage is available, but do not use it as an accurate gauge of quality. http://poe.perl.org/?POE's_test_coverage_report ---------------- Full Change Logs ---------------- Thanks to the magic of distributed version control, POE is hosted at three locations for redundancy. You can browse the source at any one of: https://github.com/rcaputo/poe https://gitorious.org/poe http://poe.git.sourceforge.net/git/gitweb-index.cgi Complete change logs can also be browsed at those sites. They all provide RSS news feeds for those who want to follow development in near-realtime. ----------- What POE Is ----------- POE is an event-driven networking and multitasking framework for Perl. It has been in active development since 1996, with its first open release in 1998. O'Reilly's "The Perl Conference" (now OSCON's Perl track) named POE "Best New Module" in 1999. POE has been used in mission-critical systems such as internetworked financial markets, file systems, commerce and application servers. It has been used in projects ranging from a few lines of code to tens of thousands. POE is compatible with perl versions as old as 5.005_03. This may change as it becomes harder to support old versions of Perl over time. POE includes an evolving component framework. Components are high-level, modular, reusable pieces of programs. Several components have been published on the CPAN, and more are listed on POE's web site. See: http://search.cpan.org/search?query=POE&mode=dist POE includes components and libraries for making quick work of network clients, servers, and peers. A simple stand-alone web application takes about 30 lines of code, most of which is your own custom logic. ---- Bye! ---- Thanks for reading! -- Rocco Caputo / rcaputo@cpan.org / http://poe.perl.org/ POE-1.368/META.yml000644 001751 001751 00000001716 13615550107 014245 0ustar00bingosbingos000000 000000 --- abstract: 'Portable, event-loop agnostic eventy networking and multitasking.' author: - 'Rocco Caputo ' build_requires: POE::Test::Loops: '1.360' configure_requires: POE::Test::Loops: '1.360' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: POE no_index: directory: - t - inc - mylib requires: Carp: '0' Errno: '1.09' Exporter: '0' File::Spec: '0.87' IO: '1.24' IO::Handle: '1.27' IO::Pipely: '0.005' IO::Tty: '1.08' POE::Test::Loops: '1.360' POSIX: '1.02' Socket: '1.7' Storable: '2.16' Test::Harness: '2.26' Time::HiRes: '1.59' resources: homepage: http://poe.perl.org/ license: http://dev.perl.org/licenses/ repository: https://github.com/rcaputo/poe version: '1.368' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' POE-1.368/META.json000644 001751 001751 00000003131 13615550107 014406 0ustar00bingosbingos000000 000000 { "abstract" : "Portable, event-loop agnostic eventy networking and multitasking.", "author" : [ "Rocco Caputo " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "POE", "no_index" : { "directory" : [ "t", "inc", "mylib" ] }, "prereqs" : { "build" : { "requires" : { "POE::Test::Loops" : "1.360" } }, "configure" : { "requires" : { "POE::Test::Loops" : "1.360" } }, "runtime" : { "requires" : { "Carp" : "0", "Errno" : "1.09", "Exporter" : "0", "File::Spec" : "0.87", "IO" : "1.24", "IO::Handle" : "1.27", "IO::Pipely" : "0.005", "IO::Tty" : "1.08", "POE::Test::Loops" : "1.360", "POSIX" : "1.02", "Socket" : "1.7", "Storable" : "2.16", "Test::Harness" : "2.26", "Time::HiRes" : "1.59" } } }, "release_status" : "stable", "resources" : { "homepage" : "http://poe.perl.org/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/rcaputo/poe" } }, "version" : "1.368", "x_serialization_backend" : "JSON::PP version 4.04" } POE-1.368/mylib/cpan-test.perl000644 001751 001751 00000007551 12143730314 016670 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # Fetch and test all the /^POE::/ distributions on CPAN. use strict; use CPANPLUS::Configure; use CPANPLUS::Backend; use Cwd; use Digest::MD5; ### Local configuration. Do everything out of the current directory, ### which is usually (always?) the main POE development directory. my $cwd = cwd; sub DIR_MAIN () { $cwd . "/comptest" } sub DIR_CPANPLUS () { DIR_MAIN . "/cpanplus" } sub DIR_TARBALLS () { DIR_MAIN . "/tarballs" } sub DIR_TESTING () { DIR_CPANPLUS . "/build" } ### Create directories as necessary. unless (-e DIR_MAIN) { mkdir DIR_MAIN, 0777 or die $!; } unless (-e DIR_CPANPLUS) { mkdir DIR_CPANPLUS, 0777 or die $!; } unless (-e DIR_TARBALLS) { mkdir DIR_TARBALLS, 0777 or die $!; } ### Grab CPANPLUS' configuration, and locally redirect its base ### directory to our own location. my $cc = CPANPLUS::Configure->new(); $cc->set_conf( base => DIR_CPANPLUS ); ### Gather a list of POE components that aren't distributed with POE. print "Searching CPAN for POE distributions...\n"; my $cp = CPANPLUS::Backend->new($cc); my @search = $cp->search( type => "module", allow => [ qr/^POE::/ ], ); my %package; foreach my $obj (sort @search) { my $package = $obj->package(); my ($pkg, $ver) = ($package =~ /^(.*?)-([0-9\.\_]+)\.tar\.gz$/); # Skip things indigenous to POE. unless (defined $pkg) { warn "Skipping $package (can't parse package name)...\n"; next; } next if $pkg eq "POE"; $package{$package} = $obj; } ### Fetch distributions. This caches them in DIR_TARBALLS, avoiding ### redundant downloads. print "Fetching distributions...\n"; foreach my $package (sort keys %package) { my $existing_file = DIR_TARBALLS . "/$package"; print "Got ", $package{$package}->fetch( fetchdir => DIR_TARBALLS ), "\n"; } ### Remove unsuccessful downloads. Also remove older versions of ### updated distributions. my %ver; opendir(TB, DIR_TARBALLS) or die $!; foreach (readdir(TB)) { my $full_path = DIR_TARBALLS . "/$_"; next unless -f $full_path; if (/-\d+$/) { print "Unlinked stale temporary $full_path\n"; unlink $full_path; next; } my ($mod, $ver) = (/^(.*?)-([0-9\.\_]+)\.tar\.gz$/); die "Can't parse $_ into dist/version" unless defined $mod and defined $ver; if (exists $ver{$mod}) { push @{$ver{$mod}}, $full_path; } else { $ver{$mod} = [$full_path]; } } closedir TB; foreach my $mod (sort keys %ver) { next unless @{$ver{$mod}} > 1; my @files = sort { (-M $a) <=> (-M $b) } @{$ver{$mod}}; while (@files > 1) { my $dead = pop @files; print "Unlinking older $dead...\n"; unlink $dead; } } ### Test them! # Trap SIGINT and exit gracefully, so the END block below gets a # chance to run. $SIG{INT} = sub { exit }; # Add my cvspoe directory to the include path. if (exists $ENV{PERL5LIB}) { $ENV{PERL5LIB} .= ":/home/troc/perl/poe"; } else { $ENV{PERL5LIB} = "/home/troc/perl/poe"; } opendir(TB, DIR_TARBALLS) or die $!; my @tarballs = grep { -f } map { DIR_TARBALLS . "/$_" } readdir TB; close TB; my %results; foreach my $tarball (@tarballs) { # Temporarily skip some modules that hang during testing. if ($tarball =~ /(rrdtool|onjoin|player)/i) { warn "Skipping $tarball...\n"; next; } warn "Testing $tarball...\n"; system("/bin/rm -rf " . DIR_TESTING); mkdir DIR_TESTING, 0777 or die $!; $cp->extract(files => [ $tarball ]); my $mod = $tarball; $mod =~ s/^.*\///; $mod =~ s/\.tar.gz$//; my $full_dir = DIR_TESTING . "/$mod"; warn $full_dir; my $local_results = $cp->make( target => "test", dirs => [ $full_dir ], ); while (my ($dir, $stat) = each %$local_results) { $results{$dir} = $stat; } } ### Print summary of results. END{ foreach my $dir (sort keys %results) { my $mod = $dir; $mod =~ s/^.*\///; print( $results{$dir}, " = ", ($results{$dir}) ? " " : "NOT" ); print " OK $mod\n"; } } POE-1.368/mylib/coverage.perl000644 001751 001751 00000005502 12143730314 016557 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # rocco // vim: ts=2 sw=2 expandtab # Runs "make test" with Devel::Cover to check POE's test coverage. # Generates a quite fine HTML report in the db_cover directory. use strict; use Cwd; use Getopt::Long; use Config; use File::Spec; # HARNESS_PERL_SWITCHES=$(perl mylib/coverage.perl --coverflags) prove -br t/10_units/ my ($opt_coverflags, $opt_prove, $opt_noclean); my ($cover, $prove, $make) = ( File::Spec->catfile($Config{bin}, "/cover"), File::Spec->catfile($Config{bin}, "prove"), $Config{make} ); GetOptions( 'coverflags' => \$opt_coverflags, 'prove' => sub { $opt_prove = 1; die "!FINISH" }, 'noclean' => \$opt_noclean, 'path-cover=s' => \$cover, 'path-prove=s' => \$prove, 'path-make=s' => \$make, ) or die "$0: usage\n"; my $output_dir = cwd() . "/cover_db"; my $hps = $ENV{HARNESS_PERL_SWITCHES} || ""; $hps =~ s/~/$ENV{HOME}/g; my @includes = ("mylib", $hps =~ /-I\s*(\S+)/g); $hps =~ s/(?<=-I)\s+//g; my $ignores = join( ",", map("+inc,$_", @includes), "+ignore,^t/", "+ignore,POE/Test/Loop", ); warn "*** Ignores: $ignores"; my $cover_options = "-MDevel::Cover"; $cover_options .= "=$ignores" if $ignores; if ($opt_coverflags) { print $cover_options, "\n"; exit 0; } # preparation/cleaning steps unless ($opt_noclean) { system( $make, "distclean" ); system( $^X, "Makefile.PL", "--default" ) and exit($? >> 8); system( $make ) and exit($? >> 8); if (-e $output_dir) { system( $^X, $cover, "-delete", $output_dir ) and exit($? >> 8); } } # run the test suite in the coverage environment { my $harness_switches = "$hps $cover_options"; $harness_switches =~ s/^\s+//; $harness_switches =~ s/\s+$//; warn "*** HARNESS_PERL_SWITCHES = $harness_switches"; local $ENV{HARNESS_PERL_SWITCHES} = $harness_switches; if ($opt_prove) { warn "*** proving: $prove @ARGV"; system( $prove, @ARGV ) and exit($? >> 8); } elsif (@ARGV) { # it might be more useful to punt to prove(1), but prove isn't always # available, maybe a --prove flag foreach my $test (@ARGV) { warn "*** running: $^X $harness_switches $test"; system( $^X, $harness_switches, $test ) and exit($? >> 8); } } else { system( $make, "test" ) and exit($? >> 8); } } # coverage report system( $^X, $cover, $output_dir ) and exit($? >> 8); warn "*** used ".((times)[2] + (times)[3])." seconds of CPU"; exit; __END__ =head1 NAME coverage.perl -- A command-line tool for producing coverage reports of POE =head1 SYNOPSIS coverage.perl [options] [tests] Options: --coverflags Print out the -MDevel::Cover option that would have been used, then exit. --noclean Do not clean and rebuild source tree or cover_db --prove Run the prove utility with the rest of the command line POE-1.368/mylib/Devel/000755 001751 001751 00000000000 13615550107 015142 5ustar00bingosbingos000000 000000 POE-1.368/mylib/PoeBuildInfo.pm000644 001751 001751 00000004270 12472121170 016755 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab # Build information for POE. Moved into a library so it can be # required by Makefile.PL and gen-meta.perl. package PoeBuildInfo; use strict; use Exporter; use vars qw(@ISA @EXPORT_OK); push @ISA, qw(Exporter); @EXPORT_OK = qw( TEST_FILES CLEAN_FILES CORE_REQUIREMENTS DIST_ABSTRACT DIST_AUTHOR CONFIG_REQUIREMENTS REPOSITORY HOMEPAGE ); sub CONFIG_REQUIREMENTS () { ( "POE::Test::Loops" => '1.360', ); } sub CORE_REQUIREMENTS () { my @core_requirements = ( "Carp" => 0, "Errno" => 1.09, "Exporter" => 0, "File::Spec" => 0.87, "IO" => 1.24, # MSWin32 blocking(0) "IO::Handle" => 1.27, "IO::Pipely" => 0.005, "POSIX" => 1.02, "Socket" => 1.7, "Storable" => 2.16, "Test::Harness" => 2.26, "Time::HiRes" => 1.59, CONFIG_REQUIREMENTS, ); if ($^O eq "MSWin32") { push @core_requirements, ( "Win32::Console" => 0.031, "Win32API::File" => 0.05, "Win32::Job" => 0.03, "Win32::Process" => 0, "Win32" => 0, ); } elsif ($^O eq 'cygwin') { # Skip IO::Tty. It has trouble building as of this writing. } else { push @core_requirements, ( "IO::Tty" => 1.08, # avoids crashes on fbsd ); } return @core_requirements; } sub DIST_AUTHOR () { ( 'Rocco Caputo ' ) } sub DIST_ABSTRACT () { ( 'Portable, event-loop agnostic eventy networking and multitasking.' ) } sub CLEAN_FILES () { my @clean_files = qw( */*/*/*/*~ */*/*/*~ */*/*/*~ */*/*~ */*~ *~ META.yml Makefile.old bingos-followtail coverage.report poe_report.xml run_network_tests t/20_resources/10_perl t/20_resources/10_perl/* t/20_resources/20_xs t/20_resources/20_xs/* t/30_loops t/30_loops/* t/30_loops/*/* test-output.err ); "@clean_files"; } sub TEST_FILES () { my @test_files = qw( t/*.t t/*/*.t t/*/*/*.t ); "@test_files"; } sub REPOSITORY () { 'https://github.com/rcaputo/poe' } sub HOMEPAGE () { 'http://poe.perl.org/' } 1; POE-1.368/mylib/svn-log.perl000644 001751 001751 00000017433 12276766765 016411 0ustar00bingosbingos000000 000000 #!/usr/bin/env perl # This program is Copyright 2005-2013 by Rocco Caputo. All rights are # reserved. This program is free software. It may be modified, used, # and redistributed under the same terms as Perl itself. # Generate a nice looking change log from the subversion logs for a # Perl project. The log is also easy for machines to parse. use warnings; use strict; use Getopt::Long; use Text::Wrap qw(wrap fill $columns $huge); use POSIX qw(strftime); use XML::Parser; use XML::LibXML; use constant DEBUG => 1; my %month = qw( Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06 Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12 ); $Text::Wrap::huge = "wrap"; $Text::Wrap::columns = 74; my $days_back = 365; # Go back a year by default. my $send_help = 0; # Display help and exit. my $svn_repo; # Where to log from. my $tag_pattern = "^v\\d+_"; use constant LOG_REV => 0; use constant LOG_DATE => 1; use constant LOG_WHO => 2; use constant LOG_MESSAGE => 3; use constant LOG_PATHS => 4; use constant PATH_PATH => 0; use constant PATH_ACTION => 1; use constant PATH_CPF_PATH => 2; use constant PATH_CPF_REV => 3; use constant TAG_REV => 0; use constant TAG_TAG => 1; use constant TAG_LOG => 2; use constant MAX_TIMESTAMP => "9999-99-99 99:99:99.999999Z"; GetOptions( "age=s" => \$days_back, "repo=s" => \$svn_repo, "help" => \$send_help, "tags=s" => \$tag_pattern, ) or exit; # Find the trunk for the current repository if one isn't specified. unless (defined $svn_repo) { $svn_repo = `svn info . | grep '^URL: '`; if (length $svn_repo) { chomp $svn_repo; $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1}; } else { $send_help = 1; } } die( "$0 usage:\n", " --repo URL where to find the repository\n", " [--age DAYS] limit report to DAYS in the past (default: 365)\n", " [--tags REGEXP] report on tags matching REGEXP (default: ^v\\d+_)\n", "\n", "REPOSITORY must have a trunk subdirectory and a tags directory where\n", "release tags are kept.\n", ) if $send_help; my $earliest_date = strftime( "%FT%T.000000Z", gmtime(time() - $days_back * 86400) ); DEBUG and warn "earliest date = $earliest_date\n"; ### 1. Gather a list of tags for the repository, their revisions and ### dates. my %tag; my $parser = XML::LibXML->new(); my $doc = $parser->parse_string(scalar `svn --xml list $svn_repo/tags`); sub get_value_of_element { my $element = shift; return "" unless defined $element; my $child = $element->getFirstChild(); return "" unless defined $child; my $value = $child->getData(); return "" unless defined $value; $value =~ s/\s+/ /g; $value =~ s/^\s//; $value =~ s/\s$//; return $value; } # # docs-wiki-start # # rcaputo # 2006-03-20T02:54:27.572888Z # # foreach my $entry ($doc->getElementsByTagName("entry")) { next unless $entry->getAttribute("kind") eq "dir"; my $tag = get_value_of_element(($entry->getChildrenByTagName("name"))[0]); my ($rev, $author, $date); foreach my $commit ($entry->getElementsByTagName("commit")) { $rev = $commit->getAttribute("revision"); $author = get_value_of_element( ($commit->getChildrenByTagName("author"))[0] ); $date = get_value_of_element( ($commit->getChildrenByTagName("date"))[0] ); } next unless $tag =~ /$tag_pattern/o; DEBUG and warn "rev($rev) date($date) tag($tag)\n"; $tag{$date} = [ $rev, # TAG_REV $tag, # TAG_TAG [ ], # TAG_LOG ]; } # Fictitious "HEAD" tag for revisions that came after the last tag. $tag{+MAX_TIMESTAMP} = [ "HEAD", # TAG_REV "(untagged)", # TAG_TAG undef, # TAG_LOG ]; ### 2. Gather the log for the current directory. Store log entries ### under their proper tags. my @tag_dates = sort keys %tag; while (my $date = pop(@tag_dates)) { # We're done if this date's before our earliest date. if ($date lt $earliest_date) { delete $tag{$date}; next; } my $tag = $tag{$date}[TAG_TAG]; DEBUG and warn "Gathering information for tag $tag...\n"; my $this_rev = $tag{$date}[TAG_REV]; my $prev_rev; if (@tag_dates) { $prev_rev = $tag{$tag_dates[-1]}[TAG_REV]; } else { $prev_rev = 0; } DEBUG and warn "$this_rev:$prev_rev"; my @log = gather_log(".", "-r", "$this_rev:$prev_rev"); $tag{$date}[TAG_LOG] = \@log; } ### 3. PROFIT! No, wait... generate the nice log file. foreach my $timestamp (sort { $b cmp $a } keys %tag) { last if $timestamp lt $earliest_date; my $tag_rec = $tag{$timestamp}; # Skip this tag if there are no log entries. next unless @{$tag_rec->[TAG_LOG]}; my $tag_line = "$timestamp $tag_rec->[TAG_TAG]"; my $tag_bar = "=" x length($tag_line); print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n"; foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) { my @paths = @{$log_rec->[LOG_PATHS]}; if (@paths > 1) { @paths = grep { $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M" } @paths; } my $time_line = wrap( " ", " ", join( "; ", "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]", map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths ) ); if ($time_line =~ /\n/) { $time_line = wrap( " ", " ", "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n" ) . wrap( " ", " ", join( "; ", map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths ) ); } print $time_line, "\n\n"; # Blank lines should have the indent level of whitespace. This # makes it easier for other utilities to parse them. my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE]; foreach my $paragraph (@paragraphs) { # Trim off identical leading space from every line. my ($whitespace) = $paragraph =~ /^(\s*)/; if (length $whitespace) { $paragraph =~ s/^$whitespace//mg; } # Re-flow the paragraph if it isn't indented from the norm. # This should preserve indented quoted text, wiki-style. unless ($paragraph =~ /^\s/) { $paragraph = fill(" ", " ", $paragraph); } } print join("\n \n", @paragraphs), "\n\n"; } } print( "==============\n", "End of Excerpt\n", "==============\n", ); ### Z. Helper functions. sub gather_log { my ($url, @flags) = @_; my (@log, @stack); my $parser = XML::Parser->new( Handlers => { Start => sub { my ($self, $tag, %att) = @_; push @stack, [ $tag, \%att ]; if ($tag eq "logentry") { push @log, [ ]; $log[-1][LOG_WHO] = "(nobody)"; } }, Char => sub { my ($self, $text) = @_; $stack[-1][1]{0} .= $text; }, End => sub { my ($self, $tag) = @_; die "close $tag w/out open" unless @stack; my ($pop_tag, $att) = @{pop @stack}; die "$tag ne $pop_tag" if $tag ne $pop_tag; if ($tag eq "date") { my $timestamp = $att->{0}; my ($date, $time) = split /[T.]/, $timestamp; $log[-1][LOG_DATE] = "$date $time"; return; } if ($tag eq "logentry") { $log[-1][LOG_REV] = $att->{revision}; return; } if ($tag eq "msg") { $log[-1][LOG_MESSAGE] = $att->{0}; return; } if ($tag eq "author") { $log[-1][LOG_WHO] = $att->{0}; return; } if ($tag eq "path") { my $path = $att->{0}; $path =~ s{^/trunk/}{}; push( @{$log[-1][LOG_PATHS]}, [ $path, # PATH_PATH $att->{action}, # PATH_ACTION ] ); $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if ( exists $att->{"copyfrom-path"} ); $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if ( exists $att->{"copyfrom-rev"} ); return; } } } ); my $cmd = "svn -v --xml @flags log $url"; DEBUG and warn "Command: $cmd\n"; open(LOG, "$cmd|") or die $!; $parser->parse(*LOG); close LOG; return @log; } POE-1.368/mylib/MyOtherFreezer.pm000644 001751 001751 00000001466 12143730314 017355 0ustar00bingosbingos000000 000000 # A sample external freezer for POE::Filter::Reference testing. package MyOtherFreezer; use strict; sub new { my $type = shift; return bless [ ], $type; } sub freeze { my $thing = shift; $thing = shift if ref($thing) eq 'MyOtherFreezer'; if (ref($thing) eq 'SCALAR') { return reverse(join "\0", ref($thing), $$thing); } elsif (ref($thing) eq 'Package') { return reverse(join "\0", ref($thing), @$thing); } die "can't freeze things of type ", ref($thing); } sub thaw { my $thing = shift; $thing = shift if ref($thing) eq 'MyOtherFreezer'; my ($type, @stuff) = split /\0/, reverse($thing); if ($type eq 'SCALAR') { my $scalar = $stuff[0]; return \$scalar; } elsif ($type eq 'Package') { return bless \@stuff, $type; } die "can't thaw things of type $type"; } 1; POE-1.368/mylib/ForkingDaemon.pm000644 001751 001751 00000016452 12143730314 017167 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use warnings; # companion to t/90_regression/rt65460-forking.t use POE::Filter::Reference; use IO::Handle; use POSIX; use Carp; my $debug = 0; main(); # basically ripped off from SimpleDBI::SubProcess sub main { # Autoflush to avoid weirdness $|++; # set binmode, thanks RT #43442 binmode( STDIN ); binmode( STDOUT ); my $filter = POE::Filter::Reference->new(); # Okay, now we listen for commands from our parent :) while ( sysread( STDIN, my $buffer = '', 1024 ) ) { # Feed the line into the filter my $data = $filter->get( [ $buffer ] ); # Process each data structure foreach my $input ( @$data ) { # should be hashref with data if ( $input->{debug} ) { $debug = 1; # enable tracing/asserts eval "sub POE::Kernel::TRACE_DEFAULT () { 1 };sub POE::Kernel::ASSERT_DEFAULT () { 1 };"; die $@ if $@; } do_test( $input->{file}, $input->{timing}, $input->{forked}, $input->{type} ); CORE::exit( 0 ); } } } sub do_test { my ($file,$timing,$forked,$type) = @_; my $oldpid = $$; # hook into warnings/die my $handler = sub { my $l = $_[0]; $l =~ s/(?:\r|\n)+$//; open my $fh, '>>', $file or die "Unable to open $file: $!"; $fh->autoflush( 1 ); print $fh "$l\n"; close $fh; return; }; $SIG{'__WARN__'} = $handler; $SIG{'__DIE__'} = $handler; # Load POE before daemonizing or after? if ( $timing eq 'before' ) { eval "use POE; use POE::Session;"; die $@ if $@; } # Okay, we daemonize before running POE do_daemonize( $type ); if ( $timing eq 'after' ) { eval "use POE; use POE::Session;"; die $@ if $@; } # Now we inform our test harness the PID open my $fh, '>>', $file or die "Unable to open $file: $!"; $fh->autoflush( 1 ); print $fh "OLDPID $oldpid\n"; print $fh "PID $$\n"; # start POE and do the test! POE::Kernel->has_forked if $forked eq 'has_fork'; start_poe(); # POE finished running, inform our test harness print $fh "DONE\n"; close $fh; return; } sub do_daemonize { my $type = shift; eval { if ( $type eq 'nsd' ) { nsd_daemonize(); } elsif ( $type eq 'dd' ) { dd_daemonize(); } elsif ( $type eq 'mxd' ) { mxd_daemonize(); } else { die "Unknown daemonization method: $type"; } }; die $@ if $@; return; } sub start_poe { # start POE with a basic test to see if it handled the daemonization POE::Session->create( inline_states => { _start => sub { warn "STARTING TEST" if $debug; $POE::Kernel::poe_kernel->yield( "do_test" ); return; }, do_test => sub { warn "STARTING DELAY" if $debug; $POE::Kernel::poe_kernel->delay( "done" => 1 ); return; }, done => sub { warn "DONE WITH DELAY" if $debug; return; }, }, ); POE::Kernel->run; return; } # the rest of the code in this file is # ripped off from Net::Server::Daemonize v0.05 as it does single-fork # Removed some unnecessary code like pidfile/uid/gid/chdir stuff ### routine to protect process during fork sub safe_fork () { ### block signal for fork my $sigset = POSIX::SigSet->new(SIGINT); POSIX::sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: [$!]\n"; ### fork off a child my $pid = fork; unless( defined $pid ){ die "Couldn't fork: [$!]\n"; } ### make SIGINT kill us as it did before $SIG{INT} = 'DEFAULT'; ### put back to normal POSIX::sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: [$!]\n"; return $pid; } ### routine to completely dissociate from ### terminal process. sub nsd_daemonize { my $pid = safe_fork(); ### parent process should do the pid file and exit if( $pid ){ $pid && CORE::exit(0); ### child process will continue on }else{ ### close all input/output and separate ### from the parent process group open STDIN, '/dev/null' or die "Can't open STDOUT to /dev/null: [$!]\n"; open STDERR, '>&STDOUT' or die "Can't open STDERR to STDOUT: [$!]\n"; ### Turn process into session leader, and ensure no controlling terminal POSIX::setsid(); return 1; } } # the rest of the code in this file is # ripped off from Daemon::Daemonize v0.0052 as it does double-fork # Removed some unnecessary code like pidfile/chdir stuff sub _fork_or_die { my $pid = fork; confess "Unable to fork" unless defined $pid; return $pid; } sub superclose { my $from = shift || 0; my $openmax = POSIX::sysconf( &POSIX::_SC_OPEN_MAX ); $openmax = 64 if ! defined( $openmax ) || $openmax < 0; return unless $from < $openmax; POSIX::close( $_ ) foreach ($from .. $openmax - 1); } sub dd_daemonize { my $close = 1; # Fork once to go into the background { if ( my $pid = _fork_or_die() ) { CORE::exit 0; } } # Create new session (POSIX::setsid) || confess "Cannot detach from controlling process"; # Fork again to ensure that daemon never reacquires a control terminal _fork_or_die() && CORE::exit 0; # Clear the file creation mask umask 0; if ( $close eq 1 || $close eq '!std' ) { # Close any open file descriptors superclose( $close eq '!std' ? 3 : 0 ); } if ( $close eq 1 || $close eq 'std' ) { # Re-open STDIN, STDOUT, STDERR to /dev/null open( STDIN, "+>/dev/null" ) or confess "Could not redirect STDIN to /dev/null"; open( STDOUT, "+>&STDIN" ) or confess "Could not redirect STDOUT to /dev/null"; open( STDERR, "+>&STDIN" ) or confess "Could not redirect STDERR to /dev/null"; # Avoid 'stdin reopened for output' warning (taken from MooseX::Daemonize) local *_NIL; open( _NIL, '/dev/null' ); <_NIL> if 0; } return 1; } # the rest of the code in this file is # ripped off from MooseX::Daemonize::Core v0.12 as it does some weird things ;) # Removed some unnecessary code like Moose stuff sub daemon_fork { if (my $pid = fork) { CORE::exit( 0 ); } else { # now in the daemon return; } } sub daemon_detach { (POSIX::setsid) # set session id || confess "Cannot detach from controlling process"; { $SIG{'HUP'} = 'IGNORE'; fork && CORE::exit; } umask 0; # clear the file creation mask # get the max numnber of possible file descriptors my $openmax = POSIX::sysconf( &POSIX::_SC_OPEN_MAX ); $openmax = 64 if !defined($openmax) || $openmax < 0; # close them all POSIX::close($_) foreach (0 .. $openmax); # fixup STDIN ... open(STDIN, "+>/dev/null") or confess "Could not redirect STDOUT to /dev/null"; # fixup STDOUT ... open(STDOUT, "+>&STDIN") or confess "Could not redirect STDOUT to /dev/null"; # fixup STDERR ... open(STDERR, "+>&STDIN") or confess "Could not redirect STDERR to /dev/null"; ; # do a little house cleaning ... # Avoid 'stdin reopened for output' # warning with newer perls open( NULLFH, '/dev/null' ); if (0); # return success return 1; } sub mxd_daemonize { daemon_fork(); daemon_detach(); } POE-1.368/mylib/gen-tests.perl000644 001751 001751 00000005503 13615547740 016714 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # rocco // vim: ts=2 sw=2 expandtab use strict; use File::Spec; use File::Path; BEGIN { eval "require POE::Test::Loops"; if ($@) { warn "Could not load POE::Test::Loops. Skipping loop tests"; exit; } } my $test_base = "t"; ### Resources, and their perl and XS implementations. { my $base_dir = File::Spec->catfile($test_base, "20_resources"); my $base_lib = File::Spec->catfile($base_dir, "00_base"); my %derived_conf = ( "10_perl" => { implementation => "perl" }, # TODO - Enable when an XS implementation arrives. # "20_xs" => { implementation => "xs" }, ); my $source = ( "#!/usr/bin/perl -w\n" . "\n" . "use strict;\n" . "use lib qw(--base_lib--);\n" . "use Test::More;\n" . "\n" . "\$ENV{POE_IMPLEMENTATION} = '--implementation--';\n" . "\n" . "require '--base_file--';\n" . "\n" . "CORE::exit 0;\n" ); derive_files( base_dir => $base_dir, base_lib => $base_lib, derived_conf => \%derived_conf, src_template => $source, ); } ### Event loops and the tests that love them. { my $base_dir = File::Spec->catfile($test_base, "30_loops"); my @loops = qw(Select IO::Poll); POE::Test::Loops::generate($base_dir, \@loops); } exit 0; sub derive_files { my %conf = @_; my $base_dir = $conf{base_dir}; # Gather the list of base files. Each will be used to generate a # real test file. opendir BASE, $conf{base_lib} or die $!; my @base_files = grep /\.pm$/, readdir(BASE); closedir BASE; # Generate a set of test files for each configuration. foreach my $dst_dir (keys %{$conf{derived_conf}}) { my $full_dst = File::Spec->catfile($base_dir, $dst_dir); $full_dst =~ tr[/][/]s; $full_dst =~ s{/+$}{}; my %template_conf = %{$conf{derived_conf}{$dst_dir}}; # Blow away any previously generated test files. rmtree($full_dst); mkpath($full_dst, 0, 0755); # For each base file, generate a corresponding one in the # configured destination directory. Expand various bits to # customize the test. foreach my $base_file (@base_files) { my $full_file = File::Spec->catfile($full_dst, $base_file); $full_file =~ s/\.pm$/.t/; # These hardcoded expansions are for the base file to be # required, and the base library directory where it'll be found. my $expanded_src = $conf{src_template}; $expanded_src =~ s/--base_file--/$base_file/g; $expanded_src =~ s/--base_lib--/$conf{base_lib}/g; # The others are plugged in from the directory configuration. while (my ($key, $val) = each %template_conf) { $expanded_src =~ s/--\Q$key\E--/$val/g; } # Write with lots of error checking. open EXPANDED, ">$full_file" or die $!; print EXPANDED $expanded_src; close EXPANDED or die $!; } } } POE-1.368/mylib/events_per_second.pl000644 001751 001751 00000003626 12143730314 020147 0ustar00bingosbingos000000 000000 #!/usr/bin/perl use strict; use vars qw($NUM_OF_EVENTS $USE_EVENT $USE_IO_POLL); use Time::HiRes qw(gettimeofday tv_interval); sub die_usage { my $usage = "\n"; if(my $msg = shift) { $usage .= "ERROR: $msg\n\n"; } $usage .= < < --use-event > < --use-io-poll > Options: --help : this help text --events=NUM : the number of events to run. defaults to 10000 --use-event : use Event.pm's internal event loop --use-io-poll : use IO::Poll.pm's internal event loop if --use-event or --use-io-poll are not chosen, POE's native event loop will be used. EOU my_die($usage); } sub my_die ($) { print STDERR $_[0]."\n"; exit 1; } sub late_use ($) { my $module = shift; eval "use $module;"; my_die($@) if ($@); } BEGIN { use Getopt::Long; $USE_EVENT = 0; $USE_IO_POLL = 0; my $help = 0; $NUM_OF_EVENTS = 10000; GetOptions( 'events=i' => \$NUM_OF_EVENTS, 'use-event+' => \$USE_EVENT, 'use-io-poll+' => \$USE_IO_POLL, 'help+' => \$help, ); die_usage() if $help; die_usage('Both use-event and use-io-poll are selected. Only one loop type may be chosen.') if($USE_EVENT + $USE_IO_POLL > 1); if($USE_EVENT) { late_use('Event'); } elsif ($USE_IO_POLL) { late_use('IO::Poll'); } late_use('POE'); } my($tr_start, $tr_stop); POE::Session->create( inline_states => { _start => sub { $tr_start = [gettimeofday]; $_[KERNEL]->yield('iterate', 0) }, _stop => sub { $tr_stop = [gettimeofday] }, iterate => sub { $_[KERNEL]->yield('iterate', ++$_[ARG0]) unless $_[ARG0] > $NUM_OF_EVENTS; } } ); $POE::Kernel::poe_kernel->run(); my $elapsed = tv_interval($tr_start, $tr_stop); my $event_avg = int($NUM_OF_EVENTS/$elapsed); print "Events per second: $event_avg\n"; POE-1.368/mylib/Devel/Null.pm000644 001751 001751 00000001543 12143730314 016410 0ustar00bingosbingos000000 000000 # This `perl -d` debugging module is an ad-hoc custom debugger. It's # optional, and it may not even work. use strict; package Null; # satisfies 'use' package DB; use vars qw($sub); use Carp; # This bit traces execution immediately before a given condition. # It's used to find out where in hell something went wrong. my @trace = ("no step") x 16; sub DB { my ($package, $file, $line) = caller; my $discard = shift @trace; push @trace, "step @ $file:$line: "; if ( defined($POE::Kernel::poe_kernel) and @{$POE::Kernel::poe_kernel->[8]} and $POE::Kernel::poe_kernel->[8]->[0]->[2] =~ /\-\sig('INT', 'signal'); $kernel->sig('PIPE', 'signal'); # remember things for later $heap->{'host'} = $peer_host; $heap->{'port'} = $peer_port; $heap->{'char'} = 32; # start watching the socket $kernel->select($socket_handle, 'read', 'write'); # return something interesting return gmtime(); } #------------------------------------------------------------------------------ # Stop the session. sub connection_stop { my $heap = $_[HEAP]; # goodbye, world! my $peer_host = $heap->{'host'}; my $peer_port = $heap->{'port'}; print "Stopped chargen connection with $peer_host:$peer_port\n"; } #------------------------------------------------------------------------------ # Events that arrive without a corresponding handler are rerouted to # _default. This _default handler just displays the nature of the # unknown event. It exists in this program mainly for debugging. sub connection_default { my ($state, $params) = @_[ARG0, ARG1]; print "The chargen connection has received a _default event.\n"; print "The original event was $state, with the following parameters:", join('; ', @$params), "\n"; # returns 0 in case it was a signal return 0; } #------------------------------------------------------------------------------ # The client is sending some information. Read and discard it. sub connection_read { my $handle = $_[ARG0]; 1 while (sysread($handle, my $buffer = '', 32000)); } #------------------------------------------------------------------------------ # The client connection can accept more information. Write a line of # generated characters to it. sub connection_write { my ($kernel, $heap, $handle) = @_[KERNEL, HEAP, ARG0]; # create a chargen line my $output_string = join('', map { chr } ($heap->{'char'} .. ($heap->{'char'}+71)) ) . "\x0D\x0A"; $output_string =~ tr[\x7F-\xDD][\x20-\x7E]; # increment the line's start character $heap->{'char'} = 32 if (++$heap->{'char'} > 126); # write the line (blocks!) my ($offset, $to_write) = (0, length($output_string)); while ($to_write) { my $sub_wrote = syswrite($handle, $output_string, $to_write, $offset); if ($sub_wrote) { $offset += $sub_wrote; $to_write -= $sub_wrote; } elsif ($!) { # close session on error print( "The chargen connection has encountered write error ", ($!+0), ": $!\n" ); $kernel->select($handle); last; } } } #------------------------------------------------------------------------------ # The session received a signal. Display the signal, and tell the # kernel that it can stop the session. sub connection_signal { my $signal_name = $_[ARG0]; print "The chargen connection received SIG$signal_name\n"; } #============================================================================== # This is a basic chargen server, as rendered in POE states. The # original example had the subs as inlined anonymous references, but # it's been pulled apart for clarity. #------------------------------------------------------------------------------ # Handle POE's standard _start event. This creates and begins # listening on a TCP server socket. sub server_start { my $kernel = $_[KERNEL]; # hello, world! print "The chargen server is starting on port $chargen_port ...\n"; # Watch for signals. Note: SIGPIPE is not considered to be a # terminal signal. The session will not be stopped if SIGPIPE is # unhandled. The signal handler is registered for SIGPIPE just so # we can see it occur. $kernel->sig('INT', 'signal'); $kernel->sig('PIPE', 'signal'); # create the listening socket my $listener = IO::Socket::INET->new( LocalPort => $chargen_port, Listen => 5, Proto => 'tcp', Reuse => 'yes', ); # move to 'accept' when read-okay if ($listener) { $kernel->select_read($listener, 'accept'); } else { print "The chargen server could not listen on $chargen_port: $!\n"; } } #------------------------------------------------------------------------------ # Stop the server when POE's standard _stop event arrives. Normally # this would garbage-collect the session's heap, but this simple # session doesn't need it. sub server_stop { print "The chargen server has stopped.\n"; } #------------------------------------------------------------------------------ # Take note when chargen connection come and go. my %english = ( gain => 'gained', lose => 'lost', create => 'created' ); sub server_child { my ($direction, $child, $return) = @_[ARG0, ARG1, ARG2]; print "The chargen server has $english{$direction} a child session.\n"; if ($direction eq 'create') { print "The child session's _start state returned: $return\n"; } } #------------------------------------------------------------------------------ # Events that arrive without a corresponding handler are rerouted to # _default. This _default handler just displays the nature of the # unknown event. It exists in this program mainly for debugging. sub server_default { my ($state, $params) = @_[ARG0, ARG1]; print "The chargen server has received a _default event.\n"; print "The original event was $state, with the following parameters:", join('; ', @$params), "\n"; # returns 0 in case it was a signal return 0; } #------------------------------------------------------------------------------ # This event handler is called when the listening socket becomes ready # for reading. It accepts the incoming connection, gathers some # information about it, and spawns a new session to handle I/O. sub server_accept { my ($kernel, $session, $handle) = @_[KERNEL, SESSION, ARG0]; print "The chargen server detected an incoming connection.\n"; # accept the handle my $connection = $handle->accept(); if ($connection) { # gather information about the socket my $peer_host = $connection->peerhost(); my $peer_port = $connection->peerport(); # create a session to handle I/O my $new = POE::Session->create( inline_states => { _start => \&connection_start, _stop => \&connection_stop, _default => \&connection_default, 'read' => \&connection_read, 'write' => \&connection_write, signal => \&connection_signal, }, # ARG0, ARG1 and ARG2 args => [ $connection, $peer_host, $peer_port ] ); } else { if ($! == EAGAIN) { print "Incoming chargen server connection not ready... try again!\n"; $kernel->yield('accept', $handle); } else { print "Incoming chargen server connection failed: $!\n"; } } } #------------------------------------------------------------------------------ # This sub is called whenever an "important" signal arrives. It just # displays details about the signals it receives. sub server_signal { my $signal_name = $_[ARG0]; print "The chargen server received SIG$signal_name\n"; return 0; } #============================================================================== # This is a basic line-based client, as rendered in POE states. The # original example had the subs as inlined anonymous references, but # it's been pulled apart for clarity. #------------------------------------------------------------------------------ # Start the client. It registers signal handlers and tries to # establish a connection. sub client_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; print "The chargen client is connecting to port $chargen_port ...\n"; # register SIGINT and SIGPIPE handlers $kernel->sig('INT', 'signal'); $kernel->sig('PIPE', 'signal'); # so it knows when to stop $heap->{'lines read'} = 0; # try to make a connection my $socket = IO::Socket::INET->new( PeerHost => 'localhost', PeerPort => $chargen_port, Proto => 'tcp', Reuse => 'yes', ); # start reading if connected if ($socket) { print "The chargen client has connected to port $chargen_port.\n"; $kernel->select_read($socket, 'read'); } else { print "The chargen client could not connect to $chargen_port: $!\n"; } } #------------------------------------------------------------------------------ # Handle POE's standard _stop event. sub client_stop { print "\nThe chargen client has stopped.\n"; } #------------------------------------------------------------------------------ # Events that arrive without a corresponding handler are rerouted to # _default. This _default handler just displays the nature of the # unknown event. It exists in this program mainly for debugging. sub client_default { my ($state, $params) = @_[ARG0, ARG1]; print "The chargen client has received a _default event.\n"; print "The original event was $state, with the following parameters:", join('; ', @$params), "\n"; # returns 0 in case it was a signal return 0; } #------------------------------------------------------------------------------ # This handler is called when the client can read. It displays # whatever was read, exiting when either a few lines have displayed or # an error has occurred. sub client_read { my ($kernel, $heap, $handle) = @_[KERNEL, HEAP, ARG0]; # read a chunk of input my $read_count = sysread($handle, my $buffer = '', 512); # display it if ($read_count) { print $buffer; # count lines; exit if 5 or more $heap->{'lines read'} += ($buffer =~ s/(\x0D\x0A)/$1/g); if ($heap->{'lines read'} > 5) { # The read select is the only part of this session that # generates events. When it is removed, the session runs out of # things to do and stops. $kernel->select($handle); } } # stop if there was trouble reading else { $kernel->select($handle); } } #------------------------------------------------------------------------------ # This sub is called whenever an "important" signal arrives. It just # displays details about the signals it receives. sub client_signal { my $signal_name = $_[ARG0]; print "The chargen client received SIG$signal_name\n"; return 0; } #============================================================================== # Start a server and a client, and run indefinitely. POE::Session->create( inline_states => { _start => \&server_start, _stop => \&server_stop, _default => \&server_default, _child => \&server_child, 'accept' => \&server_accept, signal => \&server_signal, }, ); POE::Session->create( inline_states => { _start => \&client_start, _stop => \&client_stop, _default => \&client_default, 'read' => \&client_read, signal => \&client_signal, }, ); POE::Kernel->run(); exit; POE-1.368/examples/packagesessions.perl000644 001751 001751 00000007737 12143730314 020664 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w -I.. # This is a simple test of "package sessions". These are similar to # object sessions, but they work with packages instead of objects. It # is also a simpler test than sessions.perl. use strict; use lib '../lib'; use POE; #============================================================================== # Counter is a package composed of event handler functions. It is # never instantiated as an object here. package Counter; use strict; use POE::Session; # stupid scope trick, part 1 of 3 $Counter::name = ''; #------------------------------------------------------------------------------ # This is a normal subroutine, not an object method. It sets up the # session's variables and sets the session in motion. sub _start { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; # register a signal handler $kernel->sig('INT', 'sigint'); # initialize the counter $heap->{'counter'} = 0; # stupid scope trick, part 2 of 3 $heap->{'name'} = $Counter::name; # hello, world! print "Session $heap->{'name'} started.\n"; # start things moving $kernel->post($session, 'increment'); } #------------------------------------------------------------------------------ # This is a normal subroutine, not an object method. It cleans up # after receiving POE's standard _stop event. sub _stop { my $heap = $_[HEAP]; print "Session $heap->{'name'} stopped after $heap->{'counter'} loops.\n"; } #------------------------------------------------------------------------------ # This is a normal subroutine, and not an object method. It will be # registered as a SIGINT handler so that the session can acknowledge # the signal. sub sigint { my ($heap, $from, $signal_name) = @_[HEAP, SENDER, ARG0]; print "$heap->{'name'} caught SIG$signal_name from $from\n"; # did not handle the signal return 0; } #------------------------------------------------------------------------------ # This is a normal subroutine, and not an object method. It does most # of the counting work. It loops by posting events back to itself. # The session exits when there is nothing left to do; this event # handler causes that condition when it stops posting events. sub increment { my ($package, $kernel, $session, $heap) = @_[OBJECT, KERNEL, SESSION, HEAP]; $heap->{'counter'}++; if ($heap->{counter} % 2) { $kernel->state('runtime_state', $package); } else { $kernel->state('runtime_state'); } print "Session $heap->{'name'}, iteration $heap->{'counter'}.\n"; if ($heap->{'counter'} < 5) { $kernel->post($session, 'increment'); $kernel->yield('runtime_state', $heap->{counter}); } else { # no more events. since there is nothing left to do, the session exits. } } #------------------------------------------------------------------------------ # This state is added on every even count. It's removed on every odd # one. Every count posts an event here. sub runtime_state { my ($session, $heap, $iteration) = @_[SESSION, HEAP, ARG0]; print( 'Session ', $heap->{name}, ' received a runtime_state event during iteration ', $iteration, "\n" ); } #============================================================================== # Create ten Counter sessions, all sharing the subs in package # Counter. In a way, POE's sessions provide a simple form of object # instantiation. package main; foreach my $name (qw(one two three four five six seven eight nine ten)) { # stupid scope trick, part 3 of 3 $Counter::name = $name; # create the session POE::Session->create( package_states => [ Counter => [ qw(_start _stop increment sigint) ] ] ); } $poe_kernel->run(); exit; POE-1.368/examples/objsessions.perl000644 001751 001751 00000010447 12143730314 020033 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This is another simple functionality test. It tests sessions that # are composed of objects (also called "object sessions"). It is # simpler than sessions.perl in many ways. use strict; use lib '../lib'; use POE; #============================================================================== # Counter is an object that roughly approximates "child" sessions from # the sessions.perl test. It counts for a little while, then stops. package Counter; use strict; use POE::Session; #------------------------------------------------------------------------------ # This is a normal Perl object method. It creates a new Counter # instance and returns a reference to it. It's also possible for the # object to wrap itself in a Session within the constructor. # Self-wrapping objects are explored in other examples. sub new { my ($type, $name) = @_; print "Session ${name}'s object created.\n"; bless { 'name' => $name }, $type; } #------------------------------------------------------------------------------ # This is a normal Perl object method. It destroys a Counter object, # doing any late cleanup on the object. This is different than the # _stop event handler, which handles late cleanup on the object's # Session. sub DESTROY { my $self = shift; print "Session $self->{name}'s object destroyed.\n"; } #------------------------------------------------------------------------------ # This method is an event handler. It sets the session in motion # after POE sends the standard _start event. sub _start { my ($object, $session, $heap, $kernel) = @_[OBJECT, SESSION, HEAP, KERNEL]; # register a signal handler $kernel->sig('INT', 'sigint'); # initialize the counter $heap->{'counter'} = 0; # hello, world! print "Session $object->{'name'} started.\n"; $kernel->post($session, 'increment'); } #------------------------------------------------------------------------------ # This method is an event handler, too. It cleans up after receiving # POE's standard _stop event. sub _stop { my ($object, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; print "Session $object->{'name'} stopped after $heap->{'counter'} loops.\n"; } #------------------------------------------------------------------------------ # This method is an event handler. It will be registered as a SIGINT # handler so that the session can acknowledge the signal. sub sigint { my ($object, $from, $signal_name) = @_[OBJECT, SENDER, ARG0]; print "$object->{'name'} caught SIG$signal_name from $from\n"; # did not handle the signal return 0; } #------------------------------------------------------------------------------ # This method is an event handler. It does most of counting work. It # loops by posting events back to itself. The session exits when # there is nothing left to do; this event handler causes that # condition when it stops posting events. sub increment { my ($object, $kernel, $session, $heap) = @_[OBJECT, KERNEL, SESSION, HEAP]; $heap->{'counter'}++; if ($heap->{counter} % 2) { $kernel->state('runtime_state', $object); } else { $kernel->state('runtime_state'); } print "Session $object->{'name'}, iteration $heap->{'counter'}.\n"; if ($heap->{'counter'} < 5) { $kernel->post($session, 'increment'); $kernel->yield('runtime_state', $heap->{counter}); } else { # no more events. since there is nothing left to do, the session exits. } } #------------------------------------------------------------------------------ # This state is added on every even count. It's removed on every odd # one. Every count posts an event here. sub runtime_state { my ($self, $iteration) = @_[OBJECT, ARG0]; print( 'Session ', $self->{name}, ' received a runtime_state event during iteration ', $iteration, "\n" ); } #============================================================================== # Create ten Counter objects, and wrap them in sessions. package main; foreach my $name (qw(one two three four five six seven eight nine ten)) { POE::Session->create( object_states => [ Counter->new($name) => [ qw(_start _stop increment sigint) ] ], ); } $poe_kernel->run(); exit; POE-1.368/examples/objmaps.perl000644 001751 001751 00000011003 12143730314 017112 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This is another simple functionality test. It tests sessions that # are composed of objects (also called "object sessions"). The # difference between this and objsessions.perl is that the object # method names do not match their state names. use strict; use lib '../lib'; use POE; #============================================================================== # Counter is an object that roughly approximates "child" sessions from # the sessions.perl test. It counts for a little while, then stops. package Counter; use strict; use POE::Session; #------------------------------------------------------------------------------ # This is a normal Perl object method. It creates a new Counter # instance and returns a reference to it. It's also possible for the # object to wrap itself in a Session within the constructor. # Self-wrapping objects are explored in other examples. sub new { my ($type, $name) = @_; print "Session ${name}'s object created.\n"; bless { 'name' => $name }, $type; } #------------------------------------------------------------------------------ # This is a normal Perl object method. It destroys a Counter object, # doing any late cleanup on the object. This is different than the # _stop event handler, which handles late cleanup on the object's # Session. sub DESTROY { my $self = shift; print "Session $self->{name}'s object destroyed.\n"; } #------------------------------------------------------------------------------ # This method is an event handler. It sets the session in motion # after POE sends the standard _start event. sub poe_start { my ($object, $session, $heap, $kernel) = @_[OBJECT, SESSION, HEAP, KERNEL]; # register a signal handler $kernel->sig('INT', 'sigint'); # initialize the counter $heap->{'counter'} = 0; # hello, world! print "Session $object->{'name'} started.\n"; $kernel->post($session, 'increment'); } #------------------------------------------------------------------------------ # This method is an event handler, too. It cleans up after receiving # POE's standard _stop event. sub poe_stop { my ($object, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; print "Session $object->{'name'} stopped after $heap->{'counter'} loops.\n"; } #------------------------------------------------------------------------------ # This method is an event handler. It will be registered as a SIGINT # handler so that the session can acknowledge the signal. sub poe_sigint { my ($object, $from, $signal_name) = @_[OBJECT, SENDER, ARG0]; print "$object->{'name'} caught SIG$signal_name from $from\n"; # did not handle the signal return 0; } #------------------------------------------------------------------------------ # This method is an event handler. It does most of counting work. It # loops by posting events back to itself. The session exits when # there is nothing left to do; this event handler causes that # condition when it stops posting events. sub poe_increment { my ($object, $kernel, $session, $heap) = @_[OBJECT, KERNEL, SESSION, HEAP]; $heap->{'counter'}++; if ($heap->{counter} % 2) { $kernel->state('runtime_state', $object, 'poe_runtime_state'); } else { $kernel->state('runtime_state'); } print "Session $object->{'name'}, iteration $heap->{'counter'}.\n"; if ($heap->{'counter'} < 5) { $kernel->post($session, 'increment'); $kernel->yield('runtime_state', $heap->{counter}); } else { # no more events. since there is nothing left to do, the session exits. } } #------------------------------------------------------------------------------ # This state is added on every even count. It's removed on every odd # one. Every count posts an event here. sub poe_runtime_state { my ($self, $iteration) = @_[OBJECT, ARG0]; print( 'Session ', $self->{name}, ' received a runtime_state event during iteration ', $iteration, "\n" ); } #============================================================================== # Create ten Counter objects, and wrap them in sessions. package main; foreach my $name (qw(one two three four five six seven eight nine ten)) { POE::Session->create( object_states => [ Counter->new($name) => { _start => 'poe_start', _stop => 'poe_stop', increment => 'poe_increment', sigint => 'poe_sigint', }, ], ); } $poe_kernel->run(); exit; POE-1.368/examples/thrash.perl000644 001751 001751 00000041661 12143730314 016765 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This program creates a server session and an infinitude of clients # that connect to it, all in the same process. It's mainly used to # test for memory leaks, but it's also something of a benchmark. # It is possible to split this program into two separate processes: # Change $server_addr to something appropriate. # Make a second copy of this program. # In the "server" copy, comment out the call to &pool_create(); # In the "client" copy, comment out th ecall to &server_create(); use strict; use lib '../lib'; use Socket; #sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE qw(Wheel::ListenAccept Wheel::ReadWrite Driver::SysRW Filter::Line Wheel::SocketFactory ); sub MAX_SIMULTANEOUS_CLIENTS () { 5 } # make 1 to enable output sub DEBUG () { 0 } # address and port the server binds to my $server_addr = '127.0.0.1'; my $server_port = 32100; ############################################################################### # This is a single client session. It uses two separator wheels: a # SocketFactory to establish a connection, and a ReadWrite to process # data once the connection is made #------------------------------------------------------------------------------ # This is regular Perl sub that helps create new clients. It's not an # event handler. sub client_create { my $serial_number = shift; # create the session POE::Session->create( inline_states => { _start => \&client_start, _stop => \&client_stop, receive => \&client_receive, error => \&client_error, connected => \&client_connected, signals => \&client_signals, _parent => sub {}, }, # ARG0 args => [ $serial_number ] ); } #------------------------------------------------------------------------------ # Accept POE's standard _start event, and create a non-blocking client # socket. sub client_start { my ($kernel, $heap, $serial) = @_[KERNEL, HEAP, ARG0]; DEBUG && print "Client $serial is starting.\n"; # remember this client's serial number $heap->{'serial'} = $serial; # watch for SIGINT $kernel->sig('INT', 'signals'); # create a socket factory $heap->{'wheel'} = POE::Wheel::SocketFactory->new( RemoteAddress => $server_addr, # connecting to address $server_addr RemotePort => $server_port, # connecting to port $server_port SuccessEvent => 'connected', # generating this event when connected FailureEvent => 'error', # generating this event upon an error ); } #------------------------------------------------------------------------------ # Accept POE's standard _stop event. This normally would clean up the # session, but this program doesn't keep anything in the heap that # needs to be cleaned up. sub client_stop { my $heap = $_[HEAP]; DEBUG && print "Client $heap->{'serial'} has stopped.\n"; } #------------------------------------------------------------------------------ # This event handler/state is invoked when a connection has been # established successfully. It replaces the SocketFactory wheel with # a ReadWrite wheel. The new wheel generates different events. sub client_connected { my ($heap, $socket) = @_[HEAP, ARG0]; die "possible filehandle leak" if fileno($socket) > 63; DEBUG && print "Client $heap->{'serial'} is connected.\n"; # switch to read/write behavior $heap->{'wheel'} = POE::Wheel::ReadWrite->new( Handle => $socket, # read and write on this socket Driver => POE::Driver::SysRW->new, # using sysread and syswrite Filter => POE::Filter::Line->new, # and parsing I/O as lines InputEvent => 'receive', # generating this event on input ErrorEvent => 'error', # generating this event on error ); shutdown($socket, 1); } #------------------------------------------------------------------------------ # This state is invoked by the ReadWrite wheel to process complete # chunks of input. sub client_receive { my ($heap, $line) = @_[HEAP, ARG0]; DEBUG && print "Client $heap->{'serial'} received: $line\n"; } #------------------------------------------------------------------------------ # This state is invoked by both the SocketFactory and the ReadWrite # wheels when an error occurs. sub client_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; if (DEBUG) { if ($errnum) { print( "Client $heap->{'serial'} encountered ", "$operation error $errnum: $errstr\n" ); } else { print "Client $heap->{'serial'} the server closed the connection.\n"; } } # removing the wheel stops the session delete $heap->{'wheel'}; } #------------------------------------------------------------------------------ # Catch and log signals. Never handle them. sub client_signals { my ($heap, $signal_name) = @_[HEAP, ARG0]; DEBUG && print "Client $heap->{'serial'} caught SIG$signal_name\n"; # doesn't handle SIGINT, so it can stop return 0; } ############################################################################### # This is a client pool session. It ensures that at least five # clients are interacting with the server at any given time. # Actually, there are brief periods where only four clients are # connected. #------------------------------------------------------------------------------ # This is a regular Perl sub that helps create new client pools. It's # not an event handler. sub pool_create { # create the server POE::Session->create( inline_states => { _start => \&pool_start, _stop => \&pool_stop, signals => \&pool_signals, _child => \&pool_child, _parent => sub {}, }, ); } #------------------------------------------------------------------------------ # Accept POE's standard _start event. Initialize benchmark # accumulators, and start the first five clients. sub pool_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; DEBUG && print "Pool starting.\n"; # watch for SIGINT $kernel->sig('INT', 'signals'); # keep track of children $heap->{'children'} = 0; $heap->{'client serial'} = 0; $heap->{'state'} = 'running'; # benchmark accumulators $heap->{'bench start'} = time(); $heap->{'bench count'} = 0; # Start five clients. NOTE: This would not work if clients used # IO::Socket to connect to the server, because IO::Socket's connect # blocks. It would wait for the server to accept a connection # before continuing, which would never happen since this loop is # holding up the event queue. The program can only get away with # this loop because SocketFactory connections do not block. for (my $i = 0; $i < MAX_SIMULTANEOUS_CLIENTS; $i++) { &client_create(++$heap->{'client serial'}); } } #------------------------------------------------------------------------------ # Accept POE's standard stop event. Also stop the server. sub pool_stop { my $kernel = $_[KERNEL]; # send SIGQUIT to the server $kernel->signal('server', 'QUIT'); DEBUG && print "Pool has stopped.\n"; } #------------------------------------------------------------------------------ # Catch and log signals, but never handle them. sub pool_signals { my ($heap, $signal_name) = @_[HEAP, ARG0]; DEBUG && print "Pool caught SIG$signal_name\n"; # doesn't handle SIGINT, so it can stop return 0; } #------------------------------------------------------------------------------ # Keep track of child sessions, starting new ones to replace old ones # that are being lost. If debugging, and a time limit has been # reached, stop creating new clients. my %english = ( create => 'created', lose => 'lost', gain => 'gained' ); sub pool_child { my ($heap, $direction, $child) = @_[HEAP, ARG0, ARG1]; # lost a client if ($direction eq 'lose') { $heap->{'children'}--; # create a new one if still running if ($heap->{'state'} eq 'running') { &client_create(++$heap->{'client serial'}); } } # gained a client; keep track of it else { $heap->{'children'}++; $heap->{'bench count'}++; } DEBUG && print( "Pool $english{$direction} a child session ", "(now has $heap->{'children'}).\n" ); # track clients/second for benchmark my $elapsed = time() - $heap->{'bench start'}; if ($elapsed >= 10) { print "bench: ", $heap->{'bench count'}, ' / ', $elapsed, ' = ', $heap->{'bench count'} / $elapsed, "\n"; $heap->{'bench count'} = 0; $heap->{'bench start'} = time(); # limit run to 60 seconds if debugging if (DEBUG && (time() - $^T >= 60.0)) { $heap->{'state'} = 'quitting'; } } } ############################################################################### # This is a single server session. It is spawned by the daytime # server to handle incoming connections. #------------------------------------------------------------------------------ # This is a regular Perl sub that helps create new sessions. It's not # an event handler. sub session_create { my ($handle, $peer_host, $peer_port) = @_; # create the session POE::Session->create( inline_states => { _start => \&session_start, _stop => \&session_stop, receive => \&session_receive, flushed => \&session_flushed, error => \&session_error, signals => \&session_signals, _child => sub {}, _parent => sub {}, }, # ARG0, ARG1, ARG2 args => [ $handle, $peer_host, $peer_port ] ); } #------------------------------------------------------------------------------ # Accept POE's standard _start event, and start transacting with the # client. sub session_start { my ($kernel, $heap, $handle, $peer_host, $peer_port) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2]; # make the address printable $peer_host = inet_ntoa($peer_host); DEBUG && print "Session with $peer_host $peer_port is starting.\n"; # watch for SIGINT $kernel->sig('INT', 'signals'); # record the client info for later $heap->{'host'} = $peer_host; $heap->{'port'} = $peer_port; # start reading and writing $heap->{'wheel'} = POE::Wheel::ReadWrite->new( Handle => $handle, # on the client's socket Driver => POE::Driver::SysRW->new, # using sysread and syswrite Filter => POE::Filter::Line->new, # and parsing I/O as lines InputEvent => 'receive', # generating this event on input ErrorEvent => 'error', # generating this event on error FlushedEvent => 'flushed', # generating this event on flush ); # give the client the time of day $heap->{'wheel'}->put( "Hi, $peer_host $peer_port! The time is: " . gmtime() . " GMT" ); } #------------------------------------------------------------------------------ # Accept POE's standard _stop event. This normally would clean up the # session, but this program doesn't keep anything in the heap that # needs to be cleaned up. sub session_stop { my $heap = $_[HEAP]; DEBUG && print "Session with $heap->{'host'} $heap->{'port'} has stopped.\n"; } #------------------------------------------------------------------------------ # This state is invoked by the ReadWrite wheel whenever a complete # request has been received. sub session_receive { my ($heap, $line) = @_[HEAP, ARG0]; DEBUG && print "Received from $heap->{'host'} $heap->{'port'}: $line\n"; } #------------------------------------------------------------------------------ # This state is invoked when the ReadWrite wheel encounters an error. sub session_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; DEBUG && print( "Session with $heap->{'host'} $heap->{'port'} ", "encountered $operation error $errnum: $errstr\n" ); delete $heap->{'wheel'}; } #------------------------------------------------------------------------------ # This state is invoked when the ReadWrite wheel's output buffer # becomes empty. For a daytime server session, a flushed buffer means # it's okay to close the connection. sub session_flushed { my $heap = $_[HEAP]; DEBUG && print "Output to $heap->{'host'} $heap->{'port'} has flushed.\n"; # removing the wheel stops the session delete $heap->{'wheel'}; } #------------------------------------------------------------------------------ # Catch and log signals, but never handle them. sub session_signals { my ($heap, $signal_name) = @_[HEAP, ARG0]; DEBUG && print( "Session with $heap->{'host'} $heap->{'port'} ", "has received a SIG$signal_name\n" ); # doesn't handle SIGINT, so it can stop return 0; } ############################################################################### # This is a generic daytime server. Its only purpose is to listen on # a socket, accept connections, and spawn daytime sessions to handle # the connections. #------------------------------------------------------------------------------ # This is a regular Perl sub that helps create new servers. It's not # an event handler. sub server_create { # create the server POE::Session->create( inline_states => { _start => \&server_start, _stop => \&server_stop, accept_success => \&server_accept, accept_error => \&server_error, signals => \&server_signals, _child => sub {}, _parent => sub {}, } ); } #------------------------------------------------------------------------------ # Accept POE's standard _start event. Create a non-blocking server. sub server_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; DEBUG && print "Daytime server is starting.\n"; # set an alias so pool_stop can signal $kernel->alias_set('server'); # watch for SIGINT and SIGQUIT $kernel->sig('INT', 'signals'); $kernel->sig('QUIT', 'signals'); # create a socket factory $heap->{'wheel'} = POE::Wheel::SocketFactory->new( BindAddress => $server_addr, # bind the listener to this address BindPort => $server_port, # bind the listener to this port Reuse => 'yes', # and reuse the socket right away SuccessEvent => 'accept_success', # generate this event for connections FailureEvent => 'accept_error', # generate this event for errors ); } #------------------------------------------------------------------------------ # Accept POE's standard _stop event. This normally would clean up the # session, but this program doesn't keep anything in the heap that # needs to be cleaned up. sub server_stop { my $heap = $_[HEAP]; DEBUG && print "Daytime server has stopped.\n"; } #------------------------------------------------------------------------------ # This state is invoked by the SocketFactory when an error occurs. sub server_error { my ($operation, $errnum, $errstr) = @_[ARG0, ARG1, ARG2]; DEBUG && print "Daytime server encountered $operation error $errnum: $errstr\n"; } #------------------------------------------------------------------------------ # The SocketFactory invokes this state when a new client connection # has been accepted. The parameters include the client socket, # address and port. sub server_accept { my ($handle, $host, $port) = @_[ARG0, ARG1, ARG2]; # spawn a server session die "possible filehandle leak" if fileno($handle) > 63; &session_create($handle, $host, $port); } #------------------------------------------------------------------------------ # Catch and log signals, but never handle them. sub server_signals { my $signal_name = $_[ARG0]; DEBUG && print "Daytime server caught SIG$signal_name\n"; # doesn't handle SIGINT, so it can stop return 0; } ############################################################################### # Start the daytime server and a pool of clients to transact with it. &server_create(); &pool_create(); $poe_kernel->run(); exit; POE-1.368/examples/wheels2.perl000644 001751 001751 00000011472 12143730314 017042 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # A simple socket client that uses a two-handle wheel to pipe between # a socket and the console. It's hardcoded to talk with wheels.perl's # rot13 server on localhost port 32100. use strict; use lib '../lib'; use POSIX; BEGIN { die "This example uses the console, but $^O doesn't support select() on console handles, sorry." if $^O eq "MSWin32"; } use POE qw(Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW Filter::Stream); my $rot13_port = 32100; #============================================================================== # A client socket session that pipes between a connected socket and # the console. It has two phases of operation: Connect phase, and # Interact phase. #------------------------------------------------------------------------------ # Start the session by trying to connect to a server. Create a # SocketFactory, then sit back until something occurs. sub session_start { my ($kernel, $heap, $connected_socket) = @_[KERNEL, HEAP, ARG0]; print "Connecting...\n"; $heap->{connector} = POE::Wheel::SocketFactory->new( RemoteAddress => '127.0.0.1', RemotePort => $rot13_port, SuccessEvent => 'connect_success', FailureEvent => 'connect_failure', ); } #------------------------------------------------------------------------------ # The connection succeeded. Discard the spent SocketFactory, and # start two ReadWrite wheels to pipe data back and forth. NOTE: This # doesn't do terminal characteristic games, so I/O may be choppy or # otherwise icky. sub session_connect_success { my ($heap, $kernel, $connected_socket) = @_[HEAP, KERNEL, ARG0]; delete $heap->{connector}; $heap->{console_wheel} = POE::Wheel::ReadWrite->new( InputHandle => \*STDIN, OutputHandle => \*STDOUT, Driver => POE::Driver::SysRW->new, Filter => POE::Filter::Stream->new, InputEvent => 'console_input', ErrorEvent => 'console_error', ); $heap->{socket_wheel} = POE::Wheel::ReadWrite->new( Handle => $connected_socket, Driver => POE::Driver::SysRW->new, Filter => POE::Filter::Stream->new, InputEvent => 'socket_input', ErrorEvent => 'socket_error', ); $heap->{console_wheel}->put("Begun terminal session."); } #------------------------------------------------------------------------------ # The connection failed. Close down everything so that POE will reap # the session and exit. sub session_connect_failure { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; if ($errnum) { print "!!! Connecting: $operation error $errnum: $errstr\n"; } delete $heap->{connector}; delete $heap->{console_wheel}; delete $heap->{socket_wheel}; } #------------------------------------------------------------------------------ # The session has stopped. Delete the wheels once again, just for # redundancy's sake. sub session_stop { my $heap = $_[HEAP]; delete $heap->{connector}; delete $heap->{console_wheel}; delete $heap->{socket_wheel}; } #------------------------------------------------------------------------------ # Console input has arrived. Send it to the socket. sub session_console_input { $_[HEAP]->{socket_wheel}->put($_[ARG0]); } #------------------------------------------------------------------------------ # There has been an error on one of the console filehandles. Close # down everything so that POE will reap the session and exit. sub session_console_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; if ($errnum) { print "!!! Console: $operation error $errnum: $errstr\n"; } delete $heap->{console_wheel}; delete $heap->{socket_wheel}; } #------------------------------------------------------------------------------ # Socket input has arrived. Send it to the console. sub session_socket_input { $_[HEAP]->{console_wheel}->put($_[ARG0]); } #------------------------------------------------------------------------------ # A socket error has occurred. Close down everything so that POE will # reap the session and exit. sub session_socket_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2]; if ($errnum) { print "!!! Socket: $operation error $errnum: $errstr\n"; } delete $heap->{console_wheel}; delete $heap->{socket_wheel}; } #============================================================================== # Start the Session, which will fire off the _start event and begin # the connection. POE::Session->create( inline_states => { _start => \&session_start, _stop => \&session_stop, connect_success => \&session_connect_success, connect_failure => \&session_connect_failure, console_input => \&session_console_input, console_error => \&session_console_error, socket_input => \&session_socket_input, socket_error => \&session_socket_error, }, ); $poe_kernel->run(); exit; POE-1.368/examples/signals.perl000644 001751 001751 00000010526 12276766765 017162 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This program tests signals. It tests OS signals (such as SIGINT), # soft signals to sessions, and soft signals to kernels. Soft # signals, by the way, are ones generated with the Kernel::signal() # function. They don't involve the underlying OS, and so can send # arbitrarily named signals. use strict; use lib '../lib'; use POE; #============================================================================== # This is a pathological example of an inline session. It defines the # subs for each event handler within the POE::Session constructor's # parameters. It's not bad for quick hacks. # # Anyway, this session registers handlers for SIGINT and two # fictitious signals (SIGFOO and SIGQUUX). The session then starts an # alarm loop that signals FOO to itself once a second. POE::Session->create( inline_states => { ### _start the session '_start' => sub{ my $kernel = $_[KERNEL]; # register signal handlers $kernel->sig('INT', 'signal handler'); $kernel->sig('FOO', 'signal handler'); $kernel->sig('QUUX', 'signal handler'); # hello, world! print "First session started... send SIGINT to stop.\n"; # start the alarm loop $kernel->delay('set an alarm', 1); }, ### _stop the session '_stop' => sub { print "First session stopped.\n"; }, ### alarm handler 'set an alarm' => sub { my ($kernel, $session) = @_[KERNEL, SESSION]; print "First session's alarm rang. Sending SIGFOO to itself...\n"; # send a signal to itself $kernel->signal($session, 'FOO'); # reset the alarm for 1s from now $kernel->delay('set an alarm', 1); }, ### signal handler 'signal handler' => sub { my ($kernel, $signal_name) = @_[KERNEL, ARG0]; print "First session caught SIG$signal_name\n"; # stop pending alarm on SIGINT if ($signal_name eq 'INT') { print "First session stopping...\n"; $kernel->delay('set an alarm'); } }, } ); #============================================================================== # This is another pathological inline session. This one registers # handlers for SIGINT and two fictitious signals (SIGBAZ and SIGQUUX). # The session then starts an alarm loop that signals QUUX to the # kernel twice a second. This propagates SIGQUUX to every session. POE::Session->create( inline_states => { ### _start the session '_start' => sub { my $kernel = $_[KERNEL]; # register signal handlers $kernel->sig('INT', 'signal handler'); $kernel->sig('BAZ', 'signal handler'); $kernel->sig('QUUX', 'signal handler'); # hello, world! print "Second session started... send SIGINT to stop.\n"; # start the alarm loop $kernel->delay('set an alarm', 0.5); }, ### _stop the session '_stop' => sub { print "Second session stopped.\n"; }, ### alarm handler 'set an alarm' => sub { my $kernel = $_[KERNEL]; print "Second session's alarm rang. Sending SIGQUUX to kernel...\n"; # signal the kernel $kernel->signal($kernel, 'QUUX'); # reset the alarm for 1/2s from now $kernel->delay('set an alarm', 0.5); }, ### signal handler 'signal handler' => sub { my ($kernel, $signal_name) = @_[KERNEL, ARG0]; print "Second session caught SIG$signal_name\n"; # stop pending alarm on SIGINT if ($signal_name eq 'INT') { print "Second session stopping...\n"; $kernel->delay('set an alarm'); } }, } ); #============================================================================== # Tell the kernel to run the sessions. $poe_kernel->run(); exit; POE-1.368/examples/sessions.perl000644 001751 001751 00000017075 12143730314 017344 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This is the first test program written for POE. It originally was # written to test POE's ability to dispatch events to inline sessions # (which was the only kind of sessions at the time). It was later # amended to test directly calling event handlers, delayed garbage # collection, and some other things that new developers probably don't # need to know. :) use strict; use lib '../lib'; # use POE always includes POE::Kernel and POE::Session, since they are # the fundamental POE classes and universally used. POE::Kernel # exports the $kernel global, a reference to the process' Kernel # instance. POE::Session exports a number of constants for event # handler parameter offsets. Some of the offsets are KERNEL, HEAP, # SESSION, and ARG0-ARG9. use POE; # stupid scope trick, part 1 of 3 parts my $session_name; #============================================================================== # This section defines the event handler (or state) subs for the # sessions that this program calls "child" sessions. Each sub does # just one thing, possibly passing execution to other event handlers # through one of the supported event-passing mechanisms. #------------------------------------------------------------------------------ # Newly created sessions are not ready to run until the kernel # registers them in its internal data structures. The kernel sends # every new session a _start event to tell them when they may begin. sub child_start { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; # stupid scope trick, part 2 of 3 parts $heap->{'name'} = $session_name; $kernel->sig('INT', 'sigint'); my $sid = $session->ID(); print "Session $heap->{'name'} (SID $sid) started.\n"; return "i am $heap->{'name'} (SID $sid)"; } #------------------------------------------------------------------------------ # Every session receives a _stop event just prior to being removed # from memory. This allows sessions to perform last-minute cleanup. sub child_stop { my ($session, $heap) = @_[SESSION, HEAP]; my $sid = $session->ID(); print "Session $heap->{'name'} (SID $sid) stopped.\n"; } #------------------------------------------------------------------------------ # This sub handles a developer-supplied event. It accepts a name and # a count, increments the count, and displays some information. If # the count is small enough, it feeds back on itself by posting # another "increment" message. sub child_increment { my ($kernel, $session, $name, $count) = @_[KERNEL, SESSION, ARG0, ARG1]; $count++; if ($count % 2) { $kernel->state('runtime_state', \&child_runtime_state); } else { $kernel->state('runtime_state'); } my $sid = $session->ID(); print "Session $name (SID $sid), iteration $count...\n"; my $ret = $kernel->call($session, 'display_one', $name, $count); print "\t(display one returns: $ret)\n"; $ret = $kernel->call($session, 'display_two', $name, $count); print "\t(display two returns: $ret)\n"; if ($count < 5) { $kernel->post($session, 'increment', $name, $count); $kernel->yield('runtime_state', $name, $count); } } #------------------------------------------------------------------------------ # This state is added on every even count. It's removed on every odd # one. Every count posts an event here. sub child_runtime_state { my ($name, $iteration) = @_[ARG0, ARG1]; print( "Session $name received a runtime_state event ", "during iteration $iteration\n" ); } #------------------------------------------------------------------------------ # This sub handles a developer-supplied event. It is called (not # posted) immediately by the "increment" event handler. It displays # some information about its parameters, and returns a value. It is # included to test that $kernel->call() works properly. sub child_display_one { my ($name, $count) = @_[ARG0, ARG1]; print "\t(display one, $name, iteration $count)\n"; return $count * 2; } #------------------------------------------------------------------------------ # This sub handles a developer-supplied event. It is called (not # posted) immediately by the "increment" event handler. It displays # some information about its parameters, and returns a value. It is # included to test that $kernel->call() works properly. sub child_display_two { my ($name, $count) = @_[ARG0, ARG1]; print "\t(display two, $name, iteration $count)\n"; return $count * 3; } #------------------------------------------------------------------------------ # This event handler is a helper for child sessions. It returns the # session's name. Parent sessions should call it directly. sub child_fetch_name { $_[HEAP]->{'name'}; } #============================================================================== # This section defines the event handler (or state) subs for the # sessions that this program calls "parent" sessions. Each sub does # just one thing, possibly passing execution to other event handlers # through one of the supported event-passing mechanisms. #------------------------------------------------------------------------------ # Newly created sessions are not ready to run until the kernel # registers them in its internal data structures. The kernel sends # every new session a _start event to tell them when they may begin. sub main_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # start ten child sessions foreach my $name (qw(one two three four five six seven eight nine ten)) { # stupid scope trick, part 3 of 3 parts $session_name = $name; my $session = POE::Session->create( inline_states => { _start => \&child_start, _stop => \&child_stop, increment => \&child_increment, display_one => \&child_display_one, display_two => \&child_display_two, fetch_name => \&child_fetch_name, } ); # Normally, sessions are stopped if they have nothing to do. The # only exception to this rule is newly created sessions. Their # garbage collection is delayed slightly, so that parent sessions # may send them "bootstrap" events. The following post() call is # such a bootstrap event. $kernel->post($session, 'increment', $name, 0); } } #------------------------------------------------------------------------------ # POE's _stop events are not mandatory. sub main_stop { print "*** Main session stopped.\n"; } #------------------------------------------------------------------------------ # POE sends a _child event whenever a child session is about to # receive a _stop event (or has received a _start event). The # direction argument is either 'gain', 'lose' or 'create', to signify # whether the child is being given to, taken away from, or created by # the session (respectively). sub main_child { my ($kernel, $session, $direction, $child, $return) = @_[KERNEL, SESSION, ARG0, ARG1, ARG2]; my $sid = $session->ID(); print( "*** Main session (SID $sid) ${direction}s child ", $kernel->call($child, 'fetch_name'), (($direction eq 'create') ? " (child returns: $return)" : ''), "\n" ); } #============================================================================== # Start the main (parent) session, and begin processing events. # Kernel::run() will continue until there is nothing left to do. POE::Session->create( inline_states => { _start => \&main_start, _stop => \&main_stop, _child => \&main_child, } ); $poe_kernel->run(); exit; POE-1.368/examples/names.perl000644 001751 001751 00000025476 12143730314 016605 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # Aliases were originally called Names. # Sessions with aliases will remain active even if they have nothing # to do. They still get SIGZOMBIE when all the other sessions run out # of things to do, so programs with aliased sessions won't run # forever. Aliases are mainly useful for creating "daemon" sessions # that can be called upon by other sessions. # This example is kind of obsolete. Session postbacks have been # created in the meantime, allowing it to totally avoid the kludgey # timer loops. use strict; use lib '../lib'; use POE; #============================================================================== # The LockDaemon package defines a session that provides simple # resource locking. This is only available within the current # process. package LockDaemon; use strict; use POE::Session; #------------------------------------------------------------------------------ # Create the LockDaemon. This illustrates non-POE objects that # register themselves with POE during construction. sub new { my $type = shift; my $self = bless { }, $type; # hello, world! print "> $self created\n"; # give this object to POE POE::Session->create( object_states => [ $self, [ qw(_start _stop lock unlock sighandler) ] ] ); # Don't let the caller have a reference. It's not very nice, but it # also prevents the caller from holding onto the reference and # possibly leaking memory. undef; } #------------------------------------------------------------------------------ # Destroy the server. This will happen after its POE::Session stops # and lets go of the object reference. sub DESTROY { my $self = shift; print "< $self destroyed\n"; } #------------------------------------------------------------------------------ # This method handles POE's standard _start message. It registers an # alias for the session, sets up signal handlers, and tells the world # what it has done. sub _start { my $kernel = $_[KERNEL]; # Set the alias. This really should check alias_set's return value, # but it's being lame. $kernel->alias_set('lockd'); # register signal handlers $kernel->sig('INT', 'sighandler'); $kernel->sig('IDLE', 'sighandler'); $kernel->sig('ZOMBIE', 'sighandler'); # hello, world! print "+ lockd started.\n"; } #------------------------------------------------------------------------------ # This method handles signals. It really only acknowledges that a # signal has been received. sub sighandler { my $signal_name = $_[ARG0]; print "@ lockd caught and handled SIG$signal_name\n"; # Returning a boolean true value indicates to the kernel that the # signal was handled. This usually means that the session will not # be stopped. return 1; } #------------------------------------------------------------------------------ # This method handles POE's standard _stop event. It cleans up after # the session by removing its alias. sub _stop { my ($object, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; $kernel->alias_remove('lockd'); print "- lockd stopped.\n"; } #------------------------------------------------------------------------------ # Attempt to acquire a lock. This implements a very basic callback # protocol. If the lock can be acquired, the caller's $success state # is invoked. If the lock fails, the caller's $failure state is # invoked. It's up to the caller to keep itself alive, most likely # with a timeout event. sub lock { my ($kernel, $heap, $sender, $lock_name, $success, $failure) = @_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2]; # if the lock already exists... if (exists $heap->{$lock_name}) { # ... check the current lock my ($owner, $time) = @{$heap->{$lock_name}}; # ... same owner? if ($owner eq $sender) { # ... ... refresh lock & succeed $heap->{$lock_name}->[1] = time(); $kernel->post($sender, $success); return 0; } # ... different owner? fail! $kernel->post($sender, $failure); return 0; } # no pre-existing lock; so acquire ok $heap->{$lock_name} = [ $sender, time() ]; $kernel->post($sender, $success); } #------------------------------------------------------------------------------ # Attempt to release a lock. This implements a very basic callback # protocol, similar to lock's. sub unlock { my ($kernel, $heap, $sender, $lock_name, $success, $failure) = @_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2]; # if the lock exists... if (exists $heap->{$lock_name}) { # ... check the existing lock my ($owner, $time) = @{$heap->{$lock_name}}; # ... same owner? if ($owner eq $sender) { # ... ... release the lock & succeed delete $heap->{$lock_name}; $kernel->post($sender, $success); return 0; } } # no lock by that name; fail $kernel->post($sender, $failure); return 0; } #============================================================================== # The LockClient package defines a session that wants to do some # things to a resource that it must hold a lock for, and some other # things when it doesn't need to hold a lock. package LockClient; use strict; use POE::Session; #------------------------------------------------------------------------------ # Create the LockClient. This also illustrates non-POE objects that # register themselves with POE during construction. The LockDaemon # constructor is better documented, though. sub new { my ($type, $name) = @_; my $self = bless { 'name' => $name }, $type; # hello, world! print "> $self created\n"; # give this object to POE POE::Session->create( object_states => [ $self, [ qw(_start _stop acquire_lock retry_acquire release_lock retry_release perform_locked_operation perform_unlocked_operation ) ], ] ); # it will manage itself, thank you undef; } #------------------------------------------------------------------------------ # Destroy the client. This will happen after its POE::Session stops # and lets go of the object reference. sub DESTROY { my $self = shift; print "< $self destroyed\n"; } #------------------------------------------------------------------------------ # This method handles POE's standard _start message. It starts the # client's main loop by first performing an operation without holding # a lock. sub _start { my ($kernel, $session, $object) = @_[KERNEL, SESSION, OBJECT]; # display some impressive output :) print "+ client $object->{'name'} started\n"; # move to the next state in the cycle $kernel->post($session, 'perform_unlocked_operation'); } #------------------------------------------------------------------------------ # This method handles POE's standard _stop message. Normally it would # clean up any resources it has allocated, but this test doesn't care. sub _stop { my $object = $_[OBJECT]; print "+ client $object->{'name'} stopped\n"; } #------------------------------------------------------------------------------ # This is a cheezy hack to keep the session alive while it waits for # the lock daemon to respond. All it does is wake up every ten # seconds and set another alarm. sub timer_loop { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "*** client $object->{'name'} alarm rang\n"; $kernel->delay('timer_loop', 10); } #------------------------------------------------------------------------------ # Attempt to acquire a lock. sub acquire_lock { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "??? client $object->{'name'} attempting to acquire lock...\n"; # retry after waiting a little while $kernel->delay('acquire_lock', 10); # uses the lock daemon's protocol $kernel->post('lockd', 'lock', 'lock name', 'perform_locked_operation', 'retry_acquire' ); } #------------------------------------------------------------------------------ # Acquire failed. Wait one second and retry. sub retry_acquire { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "--- client $object->{'name'} acquire failed... retrying...\n"; $kernel->delay('acquire_lock', 1); } #------------------------------------------------------------------------------ # Attempt to release a held lock. sub release_lock { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "??? client $object->{'name'} attempting to release lock...\n"; # retry after waiting a little while $kernel->delay('release_lock', 10); $kernel->post('lockd', 'unlock', 'lock name', 'perform_unlocked_operation', 'retry_release' ); } #------------------------------------------------------------------------------ # Release failed. Wait one second and retry. sub retry_release { my ($object, $kernel) = @_[OBJECT, KERNEL]; print "--- client $object->{'name'} release failed... retrying...\n"; $kernel->delay('release_lock', 1); } #------------------------------------------------------------------------------ # Do something while holding the lock. sub perform_locked_operation { my ($object, $kernel) = @_[OBJECT, KERNEL]; # clear the alarm! $kernel->delay('acquire_lock'); print "+++ client $object->{'name'} acquired lock... processing...\n"; $kernel->delay('release_lock', 1); } #------------------------------------------------------------------------------ # Do something while not holding the lock. sub perform_unlocked_operation { my ($object, $kernel) = @_[OBJECT, KERNEL]; # clear the alarm! $kernel->delay('release_lock'); print "+++ client $object->{'name'} released lock... processing...\n"; $kernel->delay('acquire_lock', 1); } #============================================================================== # Create the lock daemon and five clients. Run them until someone # sends a SIGINT. package main; # start the lock daemon LockDaemon->new(); # start the clients foreach (1..5) { LockClient->new($_); } # run until it's time to stop $poe_kernel->run(); exit; POE-1.368/examples/tcp_watermarks.perl000644 001751 001751 00000011602 12276766765 020544 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This program tests the high and low watermarks. It merges the # wheels from wheels.perl and the chargen service from selects.perl to # create a wheel-based chargen service. It differs from # watermarks.perl in that it uses a TCP server component. use strict; use lib '../lib'; use POE qw(Component::Server::TCP Wheel::ReadWrite Driver::SysRW Filter::Line); my $chargen_port = 32100; #============================================================================== # This is a simple chargen service. package Chargen::Connection; use POE::Session; # Create a new chargen session around a successfully accepted socket. sub new { my ($package, $socket) = @_; POE::Session->create ( inline_states => { _start => \&poe_start, wheel_got_flush => \&poe_got_flush, wheel_got_input => \&poe_got_input, wheel_got_error => \&poe_got_error, wheel_throttle => \&poe_throttle, wheel_resume => \&poe_resume, write_chunk => \&poe_write_chunk, }, args => [ $socket ], ); undef; } # The session was set up within POE::Kernel, so it's safe to begin # working. Wrap a ReadWrite wheel around the socket, set up some # persistent variables, and begin writing chunks. sub poe_start { $_[HEAP]->{wheel} = POE::Wheel::ReadWrite->new ( Handle => $_[ARG0], Driver => POE::Driver::SysRW->new(), Filter => POE::Filter::Line->new(), InputEvent => 'wheel_got_input', ErrorEvent => 'wheel_got_error', HighMark => 1024, LowMark => 128, HighEvent => 'wheel_throttle', LowEvent => 'wheel_resume', ); $_[HEAP]->{okay_to_send} = 1; $_[HEAP]->{start_character} = 32; $_[KERNEL]->yield('write_chunk'); } # The client sent us input. Rather than leaving it on the socket, # we've read it to ignore it. sub poe_got_input { warn "Chargen session ", $_[SESSION]->ID, " is ignoring some input.\n"; } # An error occurred. Log it and stop this session. If the parent # hasn't stopped, then it will continue running. sub poe_got_error { warn( "Chargen session ", $_[SESSION]->ID, " encountered ", $_[ARG0], " error $_[ARG1]: $_[ARG2]\n" ); $_[HEAP]->{okay_to_send} = 0; delete $_[HEAP]->{wheel}; } # Write a chunk of data to the client socket. sub poe_write_chunk { # Sometimes a write-chunk event comes in that ought not. This race # occurs because water-mark events are called synchronously, while # write-chunk events are posted asynchronously. So it may not be # okay to write a chunk when we get a write-chunk event. return unless $_[HEAP]->{okay_to_send}; # Enqueue chunks until ReadWrite->put() signals that its driver's # buffer has reached (or exceeded) its high-water mark. while (1) { # Create a chargen line. Build a 72-column line of consecutive # characters, starting with whatever character code we have # stored. Wrap characters beyond "~" around to " ". my $chargen_line = join( '', map { chr } ($_[HEAP]->{start_character} .. ($_[HEAP]->{start_character}+71)) ); $chargen_line =~ tr[\x7F-\xDD][\x20-\x7E]; # Increment the start character, wrapping \x7F to \x20. $_[HEAP]->{start_character} = 32 if ++$_[HEAP]->{start_character} > 126; # Enqueue the line for output. Stop enqueuing lines if the # buffer's high water mark is reached. last if $_[HEAP]->{wheel}->put($chargen_line); } warn "Chargen session ", $_[SESSION]->ID, " writes are paused.\n"; } # Be impressive. Log that the session has throttled, and set a flag # so spurious write-chunk events are ignored. sub poe_throttle { warn "Chargen session ", $_[SESSION]->ID, " is throttled.\n"; $_[HEAP]->{okay_to_send} = 0; } # Be impressive, part two. Log that the session has resumed sending, # and clear the stop-writing flag. Only bother doing this if there's # still a handle; that way it doesn't keep looping around after an # error or something. sub poe_resume { if (exists $_[HEAP]->{wheel}) { warn "Chargen session ", $_[SESSION]->ID, " is resuming.\n"; $_[HEAP]->{okay_to_send} = 1; $_[KERNEL]->yield('write_chunk'); } } #============================================================================== # Main loop. Create the server, and run it until something stops it. package main; print( "*** If all goes well, a watermarked (self-throttling) chargen\n", "*** service will be listening on localhost port $chargen_port.\n", "*** Watch it perform flow control by connecting to it over a slow\n", "*** connection or with a client you can pause. The server will\n", "*** throttle itself when its output buffer becomes too large, and\n", "*** it will resume output when the client receives enough data.\n", ); POE::Component::Server::TCP->new ( Port => $chargen_port, Acceptor => sub { Chargen::Connection->new($_[ARG0]); }, ); $poe_kernel->run(); exit; POE-1.368/examples/queue.perl000644 001751 001751 00000010156 12143730314 016613 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This is a simple job queue. use strict; use lib '../lib'; # sub POE::Kernel::TRACE_DEFAULT () { 1 } # sub POE::Kernel::TRACE_GARBAGE () { 1 } # sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE; ### Configuration section. # This is the maximum number of children permitted to be running at # any moment. my $child_max = 5; ### This is a "child" session. The "parent" session will ensure that ### $child_max of these are running at any given time. # The parent session needs to create children from two places. Define # a handy constructor rather than maintain duplicate copies of this # POE::Session->create call. sub create_a_child { POE::Session->create ( inline_states => { _start => \&child_start, _stop => \&child_stop, wake_up => \&child_awaken, }, ); } # The child session has started. Pretend to do something for a random # amount of time. sub child_start { my ($kernel, $session, $parent, $heap) = @_[KERNEL, SESSION, SENDER, HEAP]; # Remember the parent. $heap->{parent} = $parent; # Take a random amount of time to "do" the "job". my $delay = int rand 10; warn "Child ", $session->ID, " will take $delay seconds to run.\n"; $kernel->delay( wake_up => $delay ); } # The child has finished whatever it was supposed to do. Send the # result of its labor back to the parent. sub child_awaken { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; # Fabricate the hypothetical job's result. my $result = int rand 100; warn "Child ", $session->ID, " is done doing something. Result=$result\n"; # Post the result back to the parent. The child has nothing left to # do, and so it stops. $kernel->post($heap->{parent}, 'result', $session->ID, $result); } # The child has stopped. Display a message to help illustrate what's # going on. sub child_stop { my $session = $_[SESSION]; warn "Child ", $session->ID, " is stopped.\n"; } ### This is the "parent" session. One of these will ensure that ### $child_max children are running beneath it. It's possible to have ### several parent sessions; each will manage a separate pool of ### children. # The parent session is starting. Populate its pool with an initial # group of child sessions. sub parent_start { $_[HEAP]->{child_count} = 0; for (my $i=0; $i<$child_max; $i++) { &create_a_child; } } # The parent has either gained a new child or lost an existing one. # If a new child is gained, track it. If an existing child is lost, # then spawn a replacement. sub parent_child { my ($heap, $what, $child) = @_[HEAP, ARG0, ARG1]; # This child is arriving, either by being created or by being # abandoned by some other session. Count it as a child in our pool. if ($what eq 'create' or $what eq 'gain') { $heap->{child_count}++; warn( "Child ", $child->ID, " has appeared to parent ", $_[SESSION]->ID, " (", $heap->{child_count}, " active children now).\n" ); } # This child is departing. Remove it from our pool count; if we # have fewer children than $child_max, then spawn a new one to take # the departing child's place. elsif ($what eq 'lose') { $heap->{child_count}--; warn( "Child ", $child->ID, " has left parent ", $_[SESSION]->ID, " (", $heap->{child_count}, " active children now).\n" ); if ($heap->{child_count} < $child_max) { &create_a_child; } } } # Receive a child session's result. sub parent_result { my ($child, $result) = @_[ARG0, ARG1]; warn "Parent received result from session $child: $result\n"; } # Track when the parent leaves. sub parent_stop { warn "Parent ", $_[SESSION]->ID, " stopped.\n"; } ### Main loop. Start a parent session, which will, in turn, start its ### children. Run until everything is done; in this case, until the ### user presses Ctrl+C. Note: The children which are currently ### "working" will continue after Ctrl+C until they are "done". POE::Session->create ( inline_states => { _start => \&parent_start, _stop => \&parent_stop, _child => \&parent_child, result => \&parent_result, } ); $poe_kernel->run(); exit; POE-1.368/examples/fakelogin.perl000644 001751 001751 00000012342 12143730314 017425 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This is a fake login prompt I wrote after noticing that someone's # IRC 'bot was probing telnet whenever I joined a particular channel. # It wasn't originally going to be a POE test, but it turns out to be # a good exercise for wheel event renaming. use strict; use lib '../lib'; use IO::Socket; use POE qw( Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW Filter::Line Filter::Stream ); #============================================================================== # This is the login state group. #------------------------------------------------------------------------------ # Enter the "login" prompt state. Prompt user, and wait for input. sub login_login_start { my ($session, $heap) = @_[SESSION, HEAP]; print "Session ", $session->ID, " - entering login state\n"; # switch the output filter to stream $heap->{wheel}->set_output_filter( POE::Filter::Stream->new ); # switch the input event to login_input $heap->{wheel}->event( InputEvent => 'login_input' ); # display the prompt $heap->{wheel}->put('login: '); } sub login_login_input { my ($kernel, $session, $heap, $input) = @_[KERNEL, SESSION, HEAP, ARG0]; print "Session ", $session->ID, " - received login input\n"; if ($input ne '') { $kernel->yield('password_start'); } else { $kernel->yield('login_start'); } } #============================================================================== # This is the password state group. sub login_password_start { my ($session, $heap) = @_[SESSION, HEAP]; print "Session ", $session->ID, " - entering password state\n"; # switch output filter to stream $heap->{wheel}->set_output_filter( POE::Filter::Stream->new ); # switch input event to password_input $heap->{wheel}->event( InputEvent => 'password_input' ); # display the prompt $heap->{wheel}->put('Password: '); } sub login_password_input { my ($kernel, $session, $heap, $input) = @_[KERNEL, SESSION, HEAP, ARG0]; print "Session ", $session->ID, " - received password input\n"; # switch output filter to line $heap->{wheel}->set_output_filter( POE::Filter::Line->new ); # display the response $heap->{wheel}->put('Login incorrect'); # move to the login state $kernel->yield('login_start'); } sub login_error { my ($session, $heap, $operation, $errnum, $errstr) = @_[SESSION, HEAP, ARG0, ARG1, ARG2]; $errstr = 'Client closed connection' unless $errnum; print( "Session ", $session->ID, ": login: $operation error $errnum: $errstr\n" ); delete $heap->{wheel}; } #============================================================================== # This is the main entry point for the login session. sub login_session_start { my ($kernel, $session, $heap, $handle, $peer_addr, $peer_port) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1, ARG2]; print "Session ", $session->ID, " - received connection\n"; # start reading and writing $heap->{wheel} = POE::Wheel::ReadWrite->new( 'Handle' => $handle, 'Driver' => POE::Driver::SysRW->new, 'Filter' => POE::Filter::Line->new, 'ErrorEvent' => 'error', ); # hello, world!\n $heap->{wheel}->put('FreeBSD (localhost) (ttyp2)', '', ''); $kernel->yield('login_start'); } sub login_session_create { my ($handle, $peer_addr, $peer_port) = @_[ARG0, ARG1, ARG2]; POE::Session->create( inline_states => { _start => \&login_session_start, # general error handler error => \&login_error, # login prompt states login_start => \&login_login_start, login_input => \&login_login_input, # password prompt states password_start => \&login_password_start, password_input => \&login_password_input, }, # start parameters args => [ $handle, $peer_addr, $peer_port], ); undef; } #============================================================================== package main; my $port = shift; if (not defined $port) { print( "*** This program listens on port 23 by default. You can change\n", "*** the port by putting a new one on the command line. For\n", "*** example, to listen on port 10023:\n", "*** $0 10023\n", ); $port = 23; } POE::Session->create( inline_states => { '_start' => sub { my $heap = $_[HEAP]; $heap->{wheel} = POE::Wheel::SocketFactory->new( BindPort => $port, SuccessEvent => 'socket_ok', FailureEvent => 'socket_error', Reuse => 'yes', ); }, 'socket_error' => sub { my ($session, $heap, $operation, $errnum, $errstr) = @_[SESSION, HEAP, ARG0, ARG1, ARG2]; print( "Session ", $session->ID, ": listener: $operation error $errnum: $errstr\n" ); }, 'socket_ok' => \&login_session_create, }, ); $poe_kernel->run(); __END__ POE-1.368/examples/create.perl000644 001751 001751 00000017477 12143730314 016747 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This is a version of sessions.perl that uses the &Session::create # constructor. use strict; use lib '../lib'; # use POE always includes POE::Kernel and POE::Session, since they are # the fundamental POE classes and universally used. POE::Kernel # exports the $kernel global, a reference to the process' Kernel # instance. POE::Session exports a number of constants for event # handler parameter offsets. Some of the offsets are KERNEL, HEAP, # SESSION, and ARG0-ARG9. use POE; # stupid scope trick, part 1 of 3 parts my $session_name; #============================================================================== # This section defines the event handler (or state) subs for the # sessions that this program calls "child" sessions. Each sub does # just one thing, possibly passing execution to other event handlers # through one of the supported event-passing mechanisms. #------------------------------------------------------------------------------ # Newly created sessions are not ready to run until the kernel # registers them in its internal data structures. The kernel sends # every new session a _start event to tell them when they may begin. sub child_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # stupid scope trick, part 2 of 3 parts $heap->{'name'} = $session_name; $kernel->sig('INT', 'sigint'); print "Session $heap->{'name'} started.\n"; return "i am $heap->{'name'}"; } #------------------------------------------------------------------------------ # Every session receives a _stop event just prior to being removed # from memory. This allows sessions to perform last-minute cleanup. sub child_stop { my $heap = $_[HEAP]; print "Session ", $heap->{'name'}, " stopped.\n"; } #------------------------------------------------------------------------------ # This sub handles a developer-supplied event. It accepts a name and # a count, increments the count, and displays some information. If # the count is small enough, it feeds back on itself by posting # another "increment" message. sub child_increment { my ($kernel, $me, $name, $count) = @_[KERNEL, SESSION, ARG0, ARG1]; $count++; print "Session $name, iteration $count...\n"; my $ret = $kernel->call($me, 'display_one', $name, $count); print "\t(display one returns: $ret)\n"; $ret = $kernel->call($me, 'display_two', $name, $count); print "\t(display two returns: $ret)\n"; if ($count < 5) { $kernel->post($me, 'increment', $name, $count); } } #------------------------------------------------------------------------------ # This sub handles a developer-supplied event. It is called (not # posted) immediately by the "increment" event handler. It displays # some information about its parameters, and returns a value. It is # included to test that $kernel->call() works properly. sub child_display_one { my ($name, $count) = @_[ARG0, ARG1]; print "\t(display one, $name, iteration $count)\n"; return $count * 2; } #------------------------------------------------------------------------------ # This sub handles a developer-supplied event. It is called (not # posted) immediately by the "increment" event handler. It displays # some information about its parameters, and returns a value. It is # included to test that $kernel->call() works properly. sub child_display_two { my ($name, $count) = @_[ARG0, ARG1]; print "\t(display two, $name, iteration $count)\n"; return $count * 3; } #------------------------------------------------------------------------------ # This event handler is a helper for child sessions. It returns the # session's name. Parent sessions should call it directly. sub child_fetch_name { $_[HEAP]->{'name'}; } #============================================================================== # Define an object for object sessions. package Counter; sub new { my $type = shift; my $self = bless [], $type; $self; } sub _start { goto &main::child_start } sub _stop { goto &main::child_stop } sub increment { goto &main::child_increment } sub display_one { goto &main::child_display_one } sub display_two { goto &main::child_display_two } sub fetch_name { goto &main::child_fetch_name } #============================================================================== # This section defines the event handler (or state) subs for the # sessions that this program calls "parent" sessions. Each sub does # just one thing, possibly passing execution to other event handlers # through one of the supported event-passing mechanisms. package main; #------------------------------------------------------------------------------ # Newly created sessions are not ready to run until the kernel # registers them in its internal data structures. The kernel sends # every new session a _start event to tell them when they may begin. sub main_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # start ten child sessions foreach my $name (qw(one two three four five)) { # stupid scope trick, part 3 of 3 parts $session_name = $name; my $session = POE::Session->create ( inline_states => { _start => \&child_start, _stop => \&child_stop, increment => \&child_increment, display_one => \&child_display_one, display_two => \&child_display_two, fetch_name => \&child_fetch_name, } ); # Normally, sessions are stopped if they have nothing to do. The # only exception to this rule is newly created sessions. Their # garbage collection is delayed slightly, so that parent sessions # may send them "bootstrap" events. The following post() call is # such a bootstrap event. $kernel->post($session, 'increment', $name, 0); } foreach my $name (qw(six seven eight nine ten)) { # stupid scope trick, part 4 of 3 parts (that just shows you how # stupid it is) $session_name = $name; my $session = POE::Session->create ( object_states => [ new Counter, [ '_start', '_stop', 'increment', 'display_one', 'display_two', 'fetch_name', ], ], ); # Normally, sessions are stopped if they have nothing to do. The # only exception to this rule is newly created sessions. Their # garbage collection is delayed slightly, so that parent sessions # may send them "bootstrap" events. The following post() call is # such a bootstrap event. $kernel->post($session, 'increment', $name, 0); } } #------------------------------------------------------------------------------ # POE's _stop events are not mandatory. sub main_stop { print "*** Main session stopped.\n"; } #------------------------------------------------------------------------------ # POE sends a _child event whenever a child session is about to # receive a _stop event (or has received a _start event). The # direction argument is either 'gain', 'lose' or 'create', to signify # whether the child is being given to, taken away from, or created by # the session (respectively). sub main_child { my ($kernel, $me, $direction, $child, $return) = @_[KERNEL, SESSION, ARG0, ARG1, ARG2]; print( "*** Main session ${direction}s child ", $kernel->call($child, 'fetch_name'), (($direction eq 'create') ? " (child returns: $return)" : ''), "\n" ); } #============================================================================== # Start the main (parent) session, and begin processing events. # Kernel::run() will continue until there is nothing left to do. create POE::Session ( inline_states => { _start => \&main_start, _stop => \&main_stop, _child => \&main_child, } ); $poe_kernel->run(); exit; POE-1.368/examples/README.samples000644 001751 001751 00000000245 12143730314 017124 0ustar00bingosbingos000000 000000 Many of the samples that were once here are now available on the web. Please see http://poe.perl.org/?POE_Cookbook for the missing programs, plus a bunch of others. POE-1.368/examples/forkbomb.perl000644 001751 001751 00000013716 12143730314 017275 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w -I.. # This is another of the earlier test programs. It creates a single # session whose job is to create more of itself. There is a built-in # limit of 200 sessions, after which they all politely stop. # This program's main purpose in life is to test POE's parent/child # relationships, signal propagation and garbage collection. use strict; use lib '../lib'; sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE; #============================================================================== # These subs implement the guts of a forkbomb session. Its only # mission in life is to spawn more of itself until it dies. my $count = 0; # session counter for limiting runtime #------------------------------------------------------------------------------ # This sub handles POE's standard _start event. It initializes the # session. sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # assign the next count to this session $heap->{'id'} = ++$count; printf "%4d has started.\n", $heap->{'id'}; # register signal handlers $kernel->sig('INT', 'signal_handler'); $kernel->sig('ZOMBIE', 'signal_handler'); # start forking $kernel->yield('fork'); # return something interesting return "i am $heap->{'id'}"; } #------------------------------------------------------------------------------ # This sub handles POE's standard _stop event. It acknowledges that # the session is stopped. sub _stop { printf "%4d has stopped.\n", $_[HEAP]->{'id'}; } #------------------------------------------------------------------------------ # This sub handles POE's standard _child event. It acknowledges that # the session is gaining or losing a child session. my %english = ( lose => 'is losing', gain => 'is gaining', create => 'has created' ); sub _child { my ($kernel, $heap, $direction, $child, $return) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2]; printf( "%4d %s child %s%s\n", $heap->{'id'}, $english{$direction}, $kernel->call($child, 'fetch_id'), (($direction eq 'create') ? (" (child returned: $return)") : '') ); } #------------------------------------------------------------------------------ # This sub handles POE's standard _parent event. It acknowledges that # the child session's parent is changing. sub _parent { my ($kernel, $heap, $old_parent, $new_parent) = @_[KERNEL, HEAP, ARG0, ARG1]; printf( "%4d parent is changing from %d to %d\n", $heap->{'id'}, $kernel->call($old_parent, 'fetch_id'), $kernel->call($new_parent, 'fetch_id') ); } #------------------------------------------------------------------------------ # This sub acknowledges receipt of signals. It's registered as the # handler for SIGINT and SIGZOMBIE. It returns 0 to tell the kernel # that the signals were not handled. This causes the kernel to stop # the session for certain "terminal" signals (such as SIGINT). sub signal_handler { my ($heap, $signal_name) = @_[HEAP, ARG0]; printf( "%4d has received SIG%s\n", $heap->{'id'}, $signal_name); # tell Kernel that this wasn't handled return 0; } #------------------------------------------------------------------------------ # This is the main part of the test. This state uses the yield() # function to loop until certain conditions are met. my $max_sessions = 200; my $half_sessions = int($max_sessions / 2); sub fork { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Only consider continuing if the maximum number of sessions has not # yet been reached. if ($count < $max_sessions) { # flip a coin; heads == spawn if (rand() < 0.5) { printf "%4d is starting a new child...\n", $heap->{'id'}; &create_new_forkbomber(); } # tails == don't spawn else { printf "%4d is just spinning its wheels this time...\n", $heap->{'id'}; } # Randomly decide to die (or not) if half the sessions have been # reached. if (($count < $half_sessions) || (rand() < 0.05)) { $kernel->yield('fork'); } else { printf "%4d has decided to die. Bye!\n", $heap->{'id'}; # NOTE: Child sessions will keep a parent session alive. # Because of this, the program forces a stop by sending itself a # _stop event. This normally isn't necessary. # NOTE: The main session (#1) is allowed to linger. This # prevents strange things from happening when it exits # prematurely. if ($heap->{'id'} != 1) { $kernel->yield('_stop'); } } } else { printf "%4d notes that the session limit is met. Bye!\n", $heap->{'id'}; # Please see the two NOTEs above. if ($heap->{'id'} != 1) { $kernel->yield('_stop'); } } } #------------------------------------------------------------------------------ # This is a helper event handler. It is called directly by parents # and children to help identify the sessions being given or taken # away. It is just a public interface to the session's numeric ID. sub fetch_id { return $_[HEAP]->{'id'}; } #============================================================================== # This is a helper function that creates a new forkbomber session. sub create_new_forkbomber { POE::Session->create( inline_states => { '_start' => \&_start, '_stop' => \&_stop, '_child' => \&_child, '_parent' => \&_parent, 'signal_handler' => \&signal_handler, 'fork' => \&fork, 'fetch_id' => \&fetch_id, } ); } #============================================================================== # Create the initial forkbomber session, and run the kernel. &create_new_forkbomber(); $poe_kernel->run(); exit; POE-1.368/examples/watermarks.perl000644 001751 001751 00000013743 12276766765 017706 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # This program tests the high and low watermarks. It merges the # wheels from wheels.perl and the chargen service from selects.perl to # create a wheel-based chargen service. use strict; use lib '../lib'; use POE qw(Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW Filter::Line); my $chargen_port = 32100; #============================================================================== # This is a simple TCP server. It answers connections and passes them # to new chargen service sessions. package Chargen::Server; use POE::Session; # Create a new chargen server. This doesn't create a real object; it # just spawns a new session. OO purists will hate me for this. sub new { POE::Session->create ( inline_states => { _start => \&poe_start, accepted => \&poe_accepted, error => \&poe_error, } ); undef; } # The Session has been set up within POE::Kernel, so it's safe to # begin working. Create a socket factory to listen for new # connections. sub poe_start { $_[HEAP]->{listener} = POE::Wheel::SocketFactory->new ( SuccessEvent => 'accepted', FailureEvent => 'error', BindPort => $chargen_port, Reuse => 'yes', ); } # Start a session to handle successfully connected clients. sub poe_accepted { Chargen::Connection->new($_[ARG0]); } # Upon error, log the error and stop the server. Client sessions may # still be running, and the process will continue until they # gracefully exit. sub poe_error { warn "Chargen::Server encountered $_[ARG0] error $_[ARG1]: $_[ARG2]\n"; delete $_[HEAP]->{listener}; } #============================================================================== # This is a simple chargen service. package Chargen::Connection; use POE::Session; # Create a new chargen session around a successfully accepted socket. sub new { my ($package, $socket) = @_; POE::Session->create ( inline_states => { _start => \&poe_start, wheel_got_flush => \&poe_got_flush, wheel_got_input => \&poe_got_input, wheel_got_error => \&poe_got_error, wheel_throttle => \&poe_throttle, wheel_resume => \&poe_resume, write_chunk => \&poe_write_chunk, }, args => [ $socket ], ); undef; } # The session was set up within POE::Kernel, so it's safe to begin # working. Wrap a ReadWrite wheel around the socket, set up some # persistent variables, and begin writing chunks. sub poe_start { $_[HEAP]->{wheel} = POE::Wheel::ReadWrite->new ( Handle => $_[ARG0], Driver => POE::Driver::SysRW->new(), Filter => POE::Filter::Line->new(), InputEvent => 'wheel_got_input', ErrorEvent => 'wheel_got_error', HighMark => 256, LowMark => 128, HighEvent => 'wheel_throttle', LowEvent => 'wheel_resume', ); $_[HEAP]->{okay_to_send} = 1; $_[HEAP]->{start_character} = 32; $_[KERNEL]->yield('write_chunk'); } # The client sent us input. Rather than leaving it on the socket, # we've read it to ignore it. sub poe_got_input { warn "Chargen session ", $_[SESSION]->ID, " is ignoring some input.\n"; } # An error occurred. Log it and stop this session. If the parent # hasn't stopped, then it will continue running. sub poe_got_error { warn( "Chargen session ", $_[SESSION]->ID, " encountered ", $_[ARG0], " error $_[ARG1]: $_[ARG2]\n" ); $_[HEAP]->{okay_to_send} = 0; delete $_[HEAP]->{wheel}; } # Write a chunk of data to the client socket. sub poe_write_chunk { # Sometimes a write-chunk event comes in that ought not. This race # occurs because water-mark events are called synchronously, while # write-chunk events are posted asynchronously. So it may not be # okay to write a chunk when we get a write-chunk event. return unless $_[HEAP]->{okay_to_send}; # Enqueue chunks until ReadWrite->put() signals that its driver's # buffer has reached (or exceeded) its high-water mark. while (1) { # Create a chargen line. Build a 72-column line of consecutive # characters, starting with whatever character code we have # stored. Wrap characters beyond "~" around to " ". my $chargen_line = join( '', map { chr } ($_[HEAP]->{start_character} .. ($_[HEAP]->{start_character}+71)) ); $chargen_line =~ tr[\x7F-\xDD][\x20-\x7E]; # Increment the start character, wrapping \x7F to \x20. $_[HEAP]->{start_character} = 32 if (++$_[HEAP]->{start_character} > 126); # Enqueue the line for output. Stop enqueuing lines if the # buffer's high water mark is reached. last if $_[HEAP]->{wheel}->put($chargen_line); } warn "Chargen session ", $_[SESSION]->ID, " writes are paused.\n"; } # Be impressive. Log that the session has throttled, and set a flag # so spurious write-chunk events are ignored. sub poe_throttle { warn "Chargen session ", $_[SESSION]->ID, " is throttled.\n"; $_[HEAP]->{okay_to_send} = 0; } # Be impressive, part two. Log that the session has resumed sending, # and clear the stop-writing flag. Only bother doing this if there's # still a handle; that way it doesn't keep looping around after an # error or something. sub poe_resume { if (exists $_[HEAP]->{wheel}) { warn "Chargen session ", $_[SESSION]->ID, " is resuming.\n"; $_[HEAP]->{okay_to_send} = 1; $_[KERNEL]->yield('write_chunk'); } } #============================================================================== # Main loop. Create the server, and run it until something stops it. package main; print( "*** If all goes well, a watermarked (self-throttling) chargen\n", "*** service will be listening on localhost port $chargen_port.\n", "*** Watch it perform flow control by connecting to it over a slow\n", "*** connection or with a client you can pause. The server will\n", "*** throttle itself when its output buffer becomes too large, and\n", "*** it will resume output when the client receives enough data.\n", ); Chargen::Server->new; $poe_kernel->run(); exit; POE-1.368/t/90_regression/000755 001751 001751 00000000000 13615550107 015722 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/000755 001751 001751 00000000000 13615550107 014674 5ustar00bingosbingos000000 000000 POE-1.368/t/00_info.t000644 001751 001751 00000001056 12472121170 014645 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; 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( "Testing POE ", ($POE::VERSION || -1), ", ", "POE::Test::Loops ", ($POE::Test::Loops::VERSION || -1), ", ", "Perl $], ", "$^X on $^O" ); # Benchmark the device under test. my $done = 0; my $x = 0; $SIG{ALRM} = sub { diag "pogomips: $x"; $done = 1; }; alarm(1); ++$x until $done; POE-1.368/t/20_resources/000755 001751 001751 00000000000 13615550107 015545 5ustar00bingosbingos000000 000000 POE-1.368/t/20_resources/00_base/000755 001751 001751 00000000000 13615550107 016756 5ustar00bingosbingos000000 000000 POE-1.368/t/20_resources/00_base/extrefs_gc.pm000644 001751 001751 00000004725 12143730315 021451 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab # Test a case that Yuval Kogman ran into. Decrementing a reference # count would immediately trigger a GC test. During _start, that # means a session might be GC'd before _start's handler returned. # Fatal hilarity would ensue. use warnings; use strict; use Test::More tests => 5; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } use POE; my $sigidle = 0; # The "bystander" session is kept alive solely by its extra reference # count. It should be stopped when the "refcount" session destructs. # This is determined by comparing the _stop time vs. SIGIDLE delivery. # If _stop is first, then the bystander was reaped correctly. my $bystander_id = POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->refcount_increment( $_[SESSION]->ID, "just hold me"); }, _stop => sub { ok( !$sigidle, "bystander stopped before sigidle" ); }, }, )->ID; # The "sigidle" session watches for SIGIDLE and sets a flag. If the # bystander is reaped after SIGIDLE, it means that the refcount # session did not trigger its destruction. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->sig( IDLE => 'got_sigidle' ); $_[KERNEL]->alias_set("stayin_alive"); }, got_sigidle => sub { $sigidle++; pass("got sigidle"); }, _stop => sub { pass("sigidle session is allowed to stop"); }, }, ); # The "refcount" session attempts to trigger its own untimely # destruction by incrementing and decrementing a reference count. If # it succeeds in killing itself off early, then its "do_something" # event will cause a fatal runtime error when ASSERT_DEFAULT is on. # # As part of _stop, it decrements the extra reference on the bystander # session, triggering its destruction before SIGIDLE. If there's a # problem, SIGIDLE will arrive first---because POE::Kernel has a # refcount of 0 but the session still exists. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->refcount_increment($_[SESSION]->ID, "just hold me"); $_[KERNEL]->refcount_decrement($_[SESSION]->ID, "just hold me"); $_[KERNEL]->yield("do_something"); }, do_something => sub { pass("refcount session is allowed to run"); }, _stop => sub { pass("refcount session is allowed to stop"); $_[KERNEL]->refcount_decrement($bystander_id, "just hold me"); }, }, ); POE::Kernel->run(); 1; POE-1.368/t/20_resources/00_base/filehandles.pm000644 001751 001751 00000036726 12143730315 021604 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; use POE::Pipe::TwoWay; use IO::File; use Tie::Handle; # Bring in some constants to save us some typing. sub MODE_RD () { POE::Kernel::MODE_RD } sub MODE_WR () { POE::Kernel::MODE_WR } sub MODE_EX () { POE::Kernel::MODE_EX } sub HS_RUNNING () { POE::Kernel::HS_RUNNING } sub HS_PAUSED () { POE::Kernel::HS_PAUSED } sub HS_STOPPED () { POE::Kernel::HS_STOPPED } sub HSS_HANDLE () { POE::Kernel::HSS_HANDLE } sub HSS_SESSION () { POE::Kernel::HSS_SESSION } sub HSS_STATE () { POE::Kernel::HSS_STATE } sub HSS_ARGS () { POE::Kernel::HSS_ARGS } sub SH_HANDLE () { POE::Kernel::SH_HANDLE } sub SH_REFCOUNT () { POE::Kernel::SH_REFCOUNT } sub SH_MODECOUNT () { POE::Kernel::SH_MODECOUNT } use Test::More; unless (-f "run_network_tests") { plan skip_all => "Network access (and permission) required to run this test"; } plan tests => 132; ### Factored out common tests # 1 subtest sub verify_handle_structure { my ($name, $handle_info) = @_; my $expected_handles = { $poe_kernel->ID => do { my %h; for (@$handle_info) { my ($fh, $modes) = @$_; my $rd = $modes =~ /r/ ? 1 : 0; my $wr = $modes =~ /w/ ? 1 : 0; my $ex = $modes =~ /x/ ? 1 : 0; die "woops: $modes" if $modes =~ /[^rwx]/; $h{fileno($fh)} = [ $fh, # SH_HANDLE $rd + $wr + $ex, # SH_REFCOUNT [ # SH_MODECOUNT $rd, # MODE_RD $wr, # MODE_WR $ex, # MODE_EX ], ]; }; \%h; }, }; my %handles = $poe_kernel->_data_handle_handles(); is_deeply( \%handles, $expected_handles, "$name: session to handles map" ); } # 3 subtests sub verify_handle_sessions { my ($name, $fh, $read_event, $write_event, $exp_event) = @_; my $make_expected = sub { my ($event) = @_; return +{} unless defined $event; return +{ $poe_kernel->ID => { fileno($fh) => [ $fh, # HSS_HANDLE $poe_kernel, # HSS_SESSION $event, # HSS_STATE [ ], # HSS_ARGS ] } }; }; my ($ses_r, $ses_w, $ses_e) = $poe_kernel->_data_handle_fno_sessions(fileno($fh)); is_deeply( $ses_r, $make_expected->($read_event), "$name: fileno read session" ); is_deeply( $ses_w, $make_expected->($write_event), "$name: fileno write session" ); is_deeply( $ses_e, $make_expected->($exp_event), "$name: fileno expedite session" ); } # 7 subtests sub verify_handle_refcounts { my ($name, $fh, $modes) = @_; my $expected_rd = $modes =~ /r/ ? 1 : 0; my $expected_wr = $modes =~ /w/ ? 1 : 0; my $expected_ex = $modes =~ /x/ ? 1 : 0; die "woops: $modes" if $modes =~ /[^rwx]/; { my ($tot, $rd, $wr, $ex) = $poe_kernel->_data_handle_fno_refcounts( fileno($fh) ); is( $tot, $expected_rd + $expected_wr + $expected_ex, "$name: fd total refcount" ); is( $rd, $expected_rd, "$name: fd read refcount" ); is( $wr, $expected_wr, "$name: fd write refcount" ); is( $ex, $expected_ex, "$name: fd expedite refcount" ); } } # 6 subtests sub verify_handle_state { my ($name, $fh, $rd_str, $wr_str, $ex_str) = @_; # string format: 'AR', A - actual, R - requested my $parse_str = sub { my ($str) = @_; return [ map { +{ 's' => HS_STOPPED, 'p' => HS_PAUSED, 'r' => HS_RUNNING }->{$_} } split //, $str ]; }; my $rd = $parse_str->($rd_str); my $wr = $parse_str->($wr_str); my $ex = $parse_str->($ex_str); my ($r_act, $w_act, $e_act) = $poe_kernel->_data_handle_fno_states(fileno($fh)); ok( $r_act == $$rd[0], "$name: read actual state" ); ok( $w_act == $$wr[0], "$name: write actual state" ); ok( $e_act == $$ex[0], "$name: expedite actual state" ); } ### Tests # Get a baseline reference count for the session, to use as # comparison. my $base_refcount = $poe_kernel->_data_ses_refcount($poe_kernel->ID); # We need some file handles to work with. my ($a_read, $a_write, $b_read, $b_write) = POE::Pipe::TwoWay->new("inet"); ok(defined($a_read), "created a two-way pipe"); # Add a filehandle in read mode. $poe_kernel->_data_handle_add($a_read, MODE_RD, $poe_kernel, "event-rd", []); # Verify reference counts. ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 1, "first read add: session reference count" ); verify_handle_refcounts( "first read add", $a_read, "r" ); # Verify the handle's state. verify_handle_state( "first read add", $a_read, "rr", "pp", "pp" ); # Verify the handle's sessions. verify_handle_sessions( "first read add", $a_read, "event-rd", undef, undef ); # Verify the handle structure. verify_handle_structure( "first read add", [ [$a_read => 'r'] ], ); # Add a second handle in read mode. $poe_kernel->_data_handle_add($b_read, MODE_RD, $poe_kernel, "event-rd", []); # Verify reference counts. ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 2, "second read add: session reference count" ); verify_handle_refcounts( "second read add", $b_read, "r" ); # Verify the handle's state. verify_handle_state( "second read add", $b_read, "rr", "pp", "pp" ); # Verify the handle's sessions. verify_handle_sessions( "second read add", $b_read, "event-rd", undef, undef ); # Verify the handle structure. verify_handle_structure( "second read add", [ [$a_read => 'r'], [$b_read => 'r'] ], ); # Add a third filehandle in write mode. $poe_kernel->_data_handle_add($a_write, MODE_WR, $poe_kernel, "event-wr", []); # Verify reference counts. Total reference count doesn't go up # because this is a duplicate fileno of a previous one. # -><- May not be true on all systems! Argh! die "woops, we've assumed that write handles have same fileno as read handles" unless fileno($a_write) == fileno($a_read); ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 2, "third write add: session reference count" ); verify_handle_refcounts( "third write add", $a_write, "rw" ); # Verify the handle's state. verify_handle_state( "third write add", $a_write, "rr", "rr", "pp" ); # Verify the handle's sessions. verify_handle_sessions( "third write add", $a_write, "event-rd", "event-wr", undef ); # Verify the handle structure. verify_handle_structure( "third write add", [ [$a_read => 'rw'], [$b_read => 'r'] ], ); # Add a fourth filehandle in exception mode. $poe_kernel->_data_handle_add($b_write, MODE_EX, $poe_kernel, "event-ex", []); # Verify reference counts. ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 2, "fourth expedite add: session reference count" ); verify_handle_refcounts( "fourth expedite add", $b_write, "rx" ); # Verify the handle's state. verify_handle_state( "fourth expedite add", $b_write, "rr", "pp", "rr" ); # Verify the handle's sessions. verify_handle_sessions( "fourth expedite add", $b_write, "event-rd", undef, "event-ex" ); # Verify the handle structure. verify_handle_structure( "third write add", [ [$a_read => 'rw'], [$b_read => 'rx'] ], ); # Test various handles. ok( $poe_kernel->_data_handle_is_good($a_read, MODE_RD), "a_read in read mode" ); ok( $poe_kernel->_data_handle_is_good($a_read, MODE_WR), "a_read in write mode" ); ok( !$poe_kernel->_data_handle_is_good($a_read, MODE_EX), "a_read in expedite mode" ); ok( $poe_kernel->_data_handle_is_good($a_write, MODE_RD), "a_write in read mode" ); ok( $poe_kernel->_data_handle_is_good($a_write, MODE_WR), "a_write in write mode" ); ok( !$poe_kernel->_data_handle_is_good($a_write, MODE_EX), "a_write in expedite mode" ); ok( $poe_kernel->_data_handle_is_good($b_read, MODE_RD), "b_read in read mode" ); ok( !$poe_kernel->_data_handle_is_good($b_read, MODE_WR), "b_read in write mode" ); ok( $poe_kernel->_data_handle_is_good($b_read, MODE_EX), "b_read in expedite mode" ); ok( $poe_kernel->_data_handle_is_good($b_write, MODE_RD), "b_write in read mode" ); ok( !$poe_kernel->_data_handle_is_good($b_write, MODE_WR), "b_write in write mode" ); ok( $poe_kernel->_data_handle_is_good($b_write, MODE_EX), "b_write in expedite mode" ); # Verify a proper result for an untracked filehandle. ok( !$poe_kernel->_data_handle_is_good(\*STDIN, MODE_RD), "untracked handle in read mode" ); ok( !$poe_kernel->_data_handle_is_good(\*STDIN, MODE_WR), "untracked handle in write mode" ); ok( !$poe_kernel->_data_handle_is_good(\*STDIN, MODE_EX), "untracked handle in expedite mode" ); # Enqueue events for ready filenos. $poe_kernel->_data_handle_enqueue_ready(MODE_RD, fileno($a_read)); $poe_kernel->_data_handle_enqueue_ready(MODE_WR, fileno($a_read)); # Events are dispatched right away, so the handles need not be paused. verify_handle_state( "dequeue one", $a_read, "rr", "rr", "pp" ); # Base refcount is not increased, because the event is actually # dispatched right away. is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 2, "dequeue one: session reference count" ); # Pause a handle. This will prevent it from becoming "running" after # events are dispatched. $poe_kernel->_data_handle_pause($a_read, MODE_RD); verify_handle_state( "pause one", $a_read, "pp", "rr", "pp" ); # Dispatch the event, and verify the session's status. The sleep() # call is to simulate slow systems, which always dispatch the events # because they've taken so long to get here. sleep(1); $poe_kernel->_data_ev_dispatch_due(); verify_handle_state( "dispatch one", $a_read, "pp", "rr", "pp" ); # Resume a handle, and verify its status. Since there are no # outstanding events for the handle, change both the requested and # actual flags. $poe_kernel->_data_handle_resume($a_read, MODE_RD); verify_handle_state( "resume one", $a_read, "rr", "rr", "pp" ); # Try out some other handle methods. ok( $poe_kernel->_data_handle_count() == 2, "number of handles tracked" ); ok( $poe_kernel->_data_handle_count_ses($poe_kernel->ID) == 2, "number of sessions tracking" ); ok( $poe_kernel->_data_handle_count_ses("nonexistent") == 0, "number of handles tracked by a nonexistent session" ); # Remove a filehandle and verify the structures. $poe_kernel->_data_handle_remove($a_read, MODE_RD, $poe_kernel->ID); # Verify reference counts. ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 2, "first remove: session reference count" ); verify_handle_refcounts( "first remove", $a_read, "w" ); # Verify the handle's state. verify_handle_state( "first remove", $a_read, "ss", "rr", "pp" ); # Verify the handle's sessions. verify_handle_sessions( "first remove", $a_read, undef, "event-wr", undef ); # Verify the handle structure. verify_handle_structure( "third write add", [ [$a_read => 'w'], [$b_read => 'rx'] ], ); # Remove a filehandle and verify the structures. $poe_kernel->_data_handle_remove($a_write, MODE_WR, $poe_kernel->ID); # Verify reference counts. ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 1, "second remove: session reference count" ); ok( !$poe_kernel->_data_handle_is_good($a_write, MODE_WR), "second remove: handle removed fully" ); # Remove a nonexistent filehandle and verify the structures. We just # make sure the reference count matches the previous one. $poe_kernel->_data_handle_remove(\*STDIN, MODE_RD, $poe_kernel->ID); ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 1, "nonexistent remove: session reference count" ); # Now test some special cases # regular file filehandle { my $fh = IO::File->new($0, "r+"); $poe_kernel->_data_handle_add($fh, MODE_RD, $poe_kernel, "event-rd", []); $poe_kernel->_data_handle_add($fh, MODE_WR, $poe_kernel, "event-wr", []); verify_handle_refcounts("regular file", $fh, "rw"); verify_handle_state("regular file", $fh, "rr", "rr", "pp"); verify_handle_sessions("regular file", $fh, "event-rd", "event-wr", undef); verify_handle_structure("regular file", [ [$fh => 'rw'], [$b_read => 'rx'] ]); # now pause the handle, check it's paused, # then add it again, and check that this resumes it $poe_kernel->_data_handle_pause($fh, MODE_RD); verify_handle_state("regular file - paused", $fh, "pp", "rr", "pp"); $poe_kernel->_data_handle_add($fh, MODE_RD, $poe_kernel, "event-rd", []); verify_handle_state("regular file - resumed", $fh, "rr", "rr", "pp"); # get a new handle for the same FD, and try to add it # --- this should fail { my $dup_fh = IO::Handle->new_from_fd(fileno($fh), "r"); eval { $poe_kernel->_data_handle_add($dup_fh, MODE_RD, $poe_kernel, "event-rd", []); }; TODO: { local $TODO = "Rekeyed file watchers on descriptors for iThread safety"; ok($@ ne '', "failure when adding different handle but same FD"); }; } $poe_kernel->_data_handle_remove($fh, MODE_RD, $poe_kernel->ID); $poe_kernel->_data_handle_remove($fh, MODE_WR, $poe_kernel->ID); ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 1, "regular file: session reference count" ); ok( !$poe_kernel->_data_handle_is_good($fh, MODE_WR) && !$poe_kernel->_data_handle_is_good($fh, MODE_RD), "regular file: handle removed fully" ); } # tied filehandle SKIP: { BEGIN { package My::TiedHandle; use vars qw(@ISA); @ISA = qw( Tie::StdHandle IO::Handle ); } my $fh = IO::Handle->new; tie *$fh, 'My::TiedHandle'; open *$fh, "+<$0" or skip("couldn't open tied handle: $!", 19); $poe_kernel->_data_handle_add($fh, MODE_WR, $poe_kernel, "event-wr", []); $poe_kernel->_data_handle_add($fh, MODE_EX, $poe_kernel, "event-ex", []); verify_handle_refcounts("tied fh", $fh, "wx"); verify_handle_state("tied fh", $fh, "pp", "rr", "rr"); verify_handle_sessions("tied fh", $fh, undef, "event-wr", "event-ex"); verify_handle_structure("tied fh", [ [$fh => 'wx'], [$b_read => 'rx'] ]); $poe_kernel->_data_handle_remove($fh, MODE_WR, $poe_kernel->ID); $poe_kernel->_data_handle_remove($fh, MODE_EX, $poe_kernel->ID); ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount + 1, "tied fh: session reference count" ); ok( !$poe_kernel->_data_handle_is_good($fh, MODE_WR) && !$poe_kernel->_data_handle_is_good($fh, MODE_EX), "tied fh: handle removed fully" ); } { # Enqueue an event for a handle that we're about to remove $poe_kernel->_data_handle_enqueue_ready(MODE_RD, fileno($b_write)); my @verify = ( [ $b_read => 'rx' ] ); # Add back a write handle. Can't select on non-sockets on # MSWin32, so we skip this check on that platform. if ($^O ne "MSWin32") { $poe_kernel->_data_handle_add( \*STDOUT, MODE_WR, $poe_kernel, "event-wr", [] ); push @verify, [ \*STDOUT => 'w' ]; } verify_handle_structure("before final remove all", \@verify); } # Remove all handles for the session. And verify the structures. $poe_kernel->_data_handle_clear_session($poe_kernel->ID); ok( !$poe_kernel->_data_handle_is_good($b_write, MODE_EX), "final remove all: session reference count" ); # Check again that all handles are gone ok( $poe_kernel->_data_ses_refcount($poe_kernel->ID) == $base_refcount, "session reference count is back to base count" ); # Make sure everything shuts down cleanly. ok( $poe_kernel->_data_handle_finalize(), "filehandle subsystem finalization" ); 1; POE-1.368/t/20_resources/00_base/caller_state.pm000644 001751 001751 00000004621 12143730315 021755 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Test that caller_state returnes expected results use strict; use lib qw(./mylib ../mylib); use Test::More tests => 6; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } BEGIN { use_ok("POE") } # 1 BEGIN { $^W = 1 }; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->post($_[SESSION],'check_1'); # set our callback and postback $_[HEAP]->{postback} = $_[SESSION]->postback("check_4"); $_[HEAP]->{callback} = $_[SESSION]->callback("check_5"); }, check_1 => sub { if ($_[CALLER_STATE] eq '_start') { pass("called from _start"); # 2 } else { diag("post failed: caller state is $_[CALLER_STATE] (should be _start)"); fail("called from _start"); delete $_[HEAP]->{callback}; delete $_[HEAP]->{postback}; return; } $_[KERNEL]->yield("check_2"); }, check_2 => sub { if ($_[CALLER_STATE] eq 'check_1') { pass("called from check_1"); # 3 } else { diag("yield failed: caller state is $_[CALLER_STATE] (should be check_1)"); fail("called from check_1"); delete $_[HEAP]->{callback}; delete $_[HEAP]->{postback}; return; } # since we are calling check_3, and the postback calls check_4 # the callback there will see it as if this session called it $_[KERNEL]->call($_[SESSION], "check_3"); }, check_3 => sub { if ($_[CALLER_STATE] eq 'check_2') { pass("called from check_2"); # 4 } else { diag("call failed: caller state is $_[CALLER_STATE] (should be check_2)"); fail("called from check_2"); return; } my $postback = delete $_[HEAP]->{postback}; $postback->(); }, check_4 => sub { # this _should_ look like it comes from check_2 because of the call() if ($_[CALLER_STATE] eq 'check_2') { pass("called from check_2 (again)"); # 5 } else { diag("postback failed: caller state is $_[CALLER_STATE] (should be check_2)"); fail("called from check_2"); } my $callback = delete $_[HEAP]->{callback}; $callback->(); }, check_5 => sub { if ($_[CALLER_STATE] eq 'check_4') { pass("called from check_4"); # 6 } else { diag("callback failed: caller state is $_[CALLER_STATE] (should be check_4)"); fail("called from check_4"); } }, _stop => sub { } } ); POE::Kernel->run(); 1; POE-1.368/t/20_resources/00_base/signals.pm000644 001751 001751 00000024660 12143730315 020760 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Test::More tests => 46; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # Verify that we have safe signals. # # We only verify that at least one signal is "safe". Matching a # larger set is HARD because the set of supported signals probably # varies like crazy. { my @safe_signals = $poe_kernel->_data_sig_get_safe_signals(); ok( grep(/^INT$/, @safe_signals), "at least SIGINT is available" ); } # What happens if signals are initialized more than once? $poe_kernel->_data_sig_initialize(); # Create some sessions for testing. sub create_session { my $session = bless [ ], "POE::Session"; my $sid = $poe_kernel->_data_sid_allocate(); $session->_set_id($sid); $poe_kernel->_data_ses_allocate( $session, # session $sid, # sid $poe_kernel->ID, # parent ); return($session, $sid); } # Add some signals for testing. my ($ses_1, $sid_1) = create_session(); $poe_kernel->_data_sig_add($ses_1, "signal-1", "event-1", [ 1, 2, 3 ]); $poe_kernel->_data_sig_add($ses_1, "signal-2", "event-2", [ 4, 5, 6 ]); my ($ses_2, $sid_2) = create_session(); $poe_kernel->_data_sig_add($ses_2, "signal-2", "event-3"); # Verify that the signals were added, and also that nonexistent signal # watchers don't cause false positives in this test. ok( $poe_kernel->_data_sig_explicitly_watched("signal-1"), "signal-1 is explicitly watched" ); ok( $poe_kernel->_data_sig_explicitly_watched("signal-2"), "signal-2 is explicitly watched" ); ok( !$poe_kernel->_data_sig_explicitly_watched("signal-0"), "signal-0 is not explicitly watched" ); # More detailed checks. Test that each signal is watched by its # proper session. ok( $poe_kernel->_data_sig_is_watched_by_session("signal-1", $ses_1->ID), "session 1 watches signal-1" ); ok( $poe_kernel->_data_sig_is_watched_by_session("signal-2", $ses_1->ID), "session 1 watches signal-2" ); ok( !$poe_kernel->_data_sig_is_watched_by_session("signal-1", $ses_2->ID), "session 2 does not watch signal-1" ); # Make sure we can determine watchers for each signal. # Single watcher test... { my %watchers = $poe_kernel->_data_sig_watchers("signal-1"); ok( eq_hash(\%watchers, { $ses_1->ID => [ "event-1", [ 1, 2, 3 ], $ses_1 ] }), "signal-1 maps to session 1 and event-1" ); } # Multiple watcher test... { my %watchers = $poe_kernel->_data_sig_watchers("signal-2"); ok( eq_hash( \%watchers, { $ses_1->ID => [ "event-2", [ 4, 5, 6 ], $ses_1 ], $ses_2->ID => [ "event-3", [ ], $ses_2 ], } ), "signal-2 maps to session 1 and event-2; session 2 and event-3" ); } # Remove one of the multiple signals, and verify that the remaining # ones are correct. $poe_kernel->_data_sig_remove($ses_1->ID, "signal-2"); # Single watcher test... { my %watchers = $poe_kernel->_data_sig_watchers("signal-1"); ok( eq_hash(\%watchers, { $ses_1->ID => [ "event-1", [ 1, 2, 3 ], $ses_1 ] }), "signal-1 still maps to session 1 and event-1" ); } # Multiple watcher test... { my %watchers = $poe_kernel->_data_sig_watchers("signal-2"); ok( eq_hash(\%watchers, { $ses_2->ID => [ "event-3", [ ], $ses_2 ] }), "signal-2 still maps to session 2 and event-3" ); } # Ad some more signals for one of the sessions, then clear all the # signals for that session. Verify that they're all added and cleaned # up correctly. $poe_kernel->_data_sig_add($ses_1, "signal-3", "event-3"); $poe_kernel->_data_sig_add($ses_1, "signal-4", "event-3"); $poe_kernel->_data_sig_add($ses_1, "signal-5", "event-3"); $poe_kernel->_data_sig_add($ses_1, "signal-6", "event-3"); { my %watchers = $poe_kernel->_data_sig_watched_by_session($ses_1->ID); ok( eq_hash( \%watchers, { "signal-1", [ "event-1", [ 1, 2, 3 ], $ses_1 ], "signal-3", [ "event-3", [ ], $ses_1 ], "signal-4", [ "event-3", [ ], $ses_1 ], "signal-5", [ "event-3", [ ], $ses_1 ], "signal-6", [ "event-3", [ ], $ses_1 ], } ), "several signal watchers were added correctly" ); } $poe_kernel->_data_sig_clear_session($ses_1->ID); { my %watchers = $poe_kernel->_data_sig_watchers("signal-2"); ok( eq_hash(\%watchers, { $ses_2->ID => [ "event-3", [ ], $ses_2 ] }), "cleared session isn't watching signal-2" ); } # Check signal types. ok( $poe_kernel->_data_sig_type("QUIT") == POE::Kernel::SIGTYPE_TERMINAL, "SIGQUIT is terminal" ); ok( $poe_kernel->_data_sig_type("nonexistent") == POE::Kernel::SIGTYPE_BENIGN, "nonexistent signal is benign" ); # Test the signal handling flag things. $poe_kernel->_data_sig_reset_handled("QUIT"); { my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok(!defined($tot), "SIGQUIT handled by zero sessions"); ok($type == POE::Kernel::SIGTYPE_TERMINAL, "SIGQUIT is terminal"); ok( eq_array($ses, []), "no sessions touched by SIGQUIT" ); } # Touch a session with the signal. $poe_kernel->_data_sig_touched_session($ses_2); { my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok(!defined($tot), "SIGQUIT handled by zero sessions"); ok($type == POE::Kernel::SIGTYPE_TERMINAL, "SIGQUIT is terminal"); ok( eq_array($ses, [ $ses_2 ]), "SIGQUIT touched correct session" ); } $poe_kernel->_data_sig_handled(); { my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok($tot == 1, "SIGQUIT handled by one session"); ok($type == POE::Kernel::SIGTYPE_TERMINAL, "SIGQUIT is terminal"); ok( eq_array($ses, [ $ses_2 ]), "SIGQUIT touched correct session" ); } { my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok($tot == 1, "SIGQUIT handled by one session"); ok($type == POE::Kernel::SIGTYPE_TERMINAL, "SIGQUIT is terminal"); ok( eq_array($ses, [ $ses_2 ]), "SIGQUIT touched correct session" ); } $poe_kernel->_data_sig_reset_handled("nonexistent"); { my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok(!defined($tot), "reset signal status = handled by zero sessions"); ok( $type == POE::Kernel::SIGTYPE_BENIGN, "reset signal status = benign" ); ok( eq_array($ses, []), "reset signal status = no sessions touched" ); } # Benign signal the test session. It doesn't handle the signal. Try # to free it. Make sure it's not freed. # # -><- Currently the deprecated behavior is to free everything that # has _data_sig_touched_session() called on it. We can enable this # test properly once the deprecated behavior is removed. # # -><- This test is itself not properly tested. TODO: { my ($session, $sid) = create_session(); $poe_kernel->_data_sig_reset_handled("nonexistent"); # Clear the implicit handling. $poe_kernel->_data_sig_reset_handled("nonexistent"); # Touch it again, but don't handle it. $poe_kernel->_data_sig_touched_session($session); my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok(!defined($tot), "nonexistent signal handled by zero sessions"); ok( $type == POE::Kernel::SIGTYPE_BENIGN, "nonexistent signal is benign" ); ok( eq_array($ses, [ $session ]), "nonexistent signal touched target session" ); # Free a benignly-handled session. $poe_kernel->_data_sig_free_terminated_sessions(); # TODO - Enable this test when the signal behavior changes. todo_skip "benign signal free test is for future behavior", 1; ok( $poe_kernel->_data_ses_exists($session->ID), "unhandled benign signal does not free session" ); } # Terminal signal the test session. It handles the signal. Try to # free it. Make sure it's not freed. # # -><- Also tests future behavior. Enable when _signal is removed. TODO: { $poe_kernel->_data_sig_reset_handled("QUIT"); $poe_kernel->_data_sig_touched_session($ses_2); $poe_kernel->_data_sig_handled(); # What happens if the session is handled explicitly and implicitly? # Well, the implicit deprecation warning should not be triggered. $poe_kernel->_data_sig_touched_session($ses_2); # Now see if the session's freed. $poe_kernel->_data_sig_free_terminated_sessions(); # TODO - Enable the following test when signal deprecations are # done. todo_skip "terminal signal free test is for future behavior", 1; ok( $poe_kernel->_data_ses_exists($ses_2->ID), "handled terminal signal does not free session" ); } # Terminal signal the test session. It does not handle the signal. # Try to free it. Make sure it is freed. $poe_kernel->_data_sig_reset_handled("QUIT"); $poe_kernel->_data_sig_touched_session($ses_2); { my ($tot, $type, $ses) = $poe_kernel->_data_sig_handled_status(); ok(!defined($tot), "SIGQUIT handled by zero sessions"); ok($type == POE::Kernel::SIGTYPE_TERMINAL, "SIGQUIT is terminal"); ok( eq_array($ses, [ $ses_2 ]), "SIGQUIT touched session 2" ); } $poe_kernel->_data_sig_free_terminated_sessions(); ok( !$poe_kernel->_data_ses_exists($ses_2->ID), "unhandled terminal signal freed session 2" ); # Nonmaskable signals terminate sessions no matter what. { my $ses = bless [ ], "POE::Session"; my $sid = $poe_kernel->_data_sid_allocate(); $ses->_set_id($sid); $poe_kernel->_data_ses_allocate( $ses, # session $sid, # sid $poe_kernel->ID, # parent ); $poe_kernel->_data_sig_reset_handled("UIDESTROY"); $poe_kernel->_data_sig_touched_session($ses); $poe_kernel->_data_sig_handled(); my ($tot, $type, $touched_ses) = $poe_kernel->_data_sig_handled_status(); ok($tot == 1, "SIGUIDESTROY handled by zero sessions"); ok( $type == POE::Kernel::SIGTYPE_NONMASKABLE, "SIGUIDESTROY is not maskable" ); ok( eq_array([ $ses ], $touched_ses), "SIGUIDESTROY touched session correct session" ); $poe_kernel->_data_sig_free_terminated_sessions(); ok( !$poe_kernel->_data_ses_exists($ses->ID), "handled SIGUIDESTROY freed target session anyway" ); } # It's ok to clear signals from a nonexistent session, because not all # sessions watch signals. This exercises a branch not usually taken # in the tests. $poe_kernel->_data_sig_clear_session("nonexistent"); # Check whether anybody's watching a bogus signal. This exercises a # branch that's not normally taken in the tests. ok( !$poe_kernel->_data_sig_is_watched_by_session("nonexistent", $ses_2->ID), "session 2 isn't watching for a nonexistent signal" ); # Ensure the data structures are clean when we're done. ok($poe_kernel->_data_sig_finalize(), "POE::Resource::Signals finalized ok"); 1; POE-1.368/t/20_resources/00_base/extrefs.pm000644 001751 001751 00000012502 12143730315 020770 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Test::More tests => 31; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # Base reference count. my $base_refcount = 0; # Increment an extra reference count, and verify its value. my $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-1"); is($refcnt, 1, "tag-1 incremented to 1"); $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-1"); is($refcnt, 2, "tag-1 incremented to 2"); # Baseline plus one reference: tag-1. (No matter how many times you # increment a single tag, it only counts as one session reference. # This may change if the utility of the reference counts adding up # outweighs the overhead of managing the session reference more.) is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 1, "POE::Kernel properly counts tag-1 extra reference" ); # Attempt to remove some strange tag. eval { $poe_kernel->_data_extref_remove($poe_kernel->ID, "nonexistent") }; ok( $@ && $@ =~ /removing extref for nonexistent tag/, "can't remove nonexistent tag from a session" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 1, "POE::Kernel reference count unchanged" ); # Remove it entirely, and verify that it's 1 again after incrementing # again. $poe_kernel->_data_extref_remove($poe_kernel->ID, "tag-1"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 0, "clear reset reference count to baseline" ); $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-1"); is($refcnt, 1, "tag-1 count cleared/incremented to 1"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 1, "increment after clear" ); # Set a second reference count, then verify that both are reset. $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-2"); is($refcnt, 1, "tag-2 incremented to 1"); # Setting a second tag increments the master reference count. is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 2, "POE::Kernel reference count incremented with new tag" ); # Clear all the extra references for the session, and verify that the # master reference count is back to the baseline. $poe_kernel->_data_extref_clear_session($poe_kernel->ID); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount, "clearing all extrefs brings count to baseline" ); eval { $poe_kernel->_data_extref_remove($poe_kernel->ID, "nonexistent") }; ok( $@ && $@ =~ /removing extref from session without any/, "can't remove tag from a session without any" ); $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-1"); is($refcnt, 1, "tag-1 incremented back to 1"); $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-2"); is($refcnt, 1, "tag-2 incremented back to 1"); $refcnt = $poe_kernel->_data_extref_inc($poe_kernel->ID, "tag-2"); is($refcnt, 2, "tag-2 incremented back to 2"); # Only one session has an extra reference count. is( $poe_kernel->_data_extref_count(), 1, "only one session has extra references" ); # Extra references for the kernel should be two. A nonexistent # session should have none. is( $poe_kernel->_data_extref_count_ses($poe_kernel->ID), 2, "POE::Kernel has two extra references" ); is( $poe_kernel->_data_extref_count_ses("nothing"), 0, "nonexistent session has no extra references" ); # What happens if decrementing an extra reference for a tag that # doesn't exist? eval { $poe_kernel->_data_extref_dec($poe_kernel->ID, "nonexistent") }; ok( $@ && $@ =~ /decrementing extref for nonexistent tag/, "can't decrement an extref if a session doesn't have it" ); # Clear the references, and make sure the subsystem shuts down # cleanly. { is( $poe_kernel->_data_extref_dec($poe_kernel->ID, "tag-1"), 0, "tag-1 decremented to 0" ); is( $poe_kernel->_data_extref_count_ses($poe_kernel->ID), 1, "POE::Kernel has one extra reference" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 1, "POE::Kernel reference count decremented along with tag" ); } { is( $poe_kernel->_data_extref_dec($poe_kernel->ID, "tag-2"), 1, "tag-2 decremented to 1" ); is( $poe_kernel->_data_extref_count_ses($poe_kernel->ID), 1, "POE::Kernel still has one extra reference" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 1, "POE::Kernel reference count not decremented yet" ); } { is( $poe_kernel->_data_extref_dec($poe_kernel->ID, "tag-2"), 0, "tag-2 decremented to 0" ); is( $poe_kernel->_data_extref_count_ses($poe_kernel->ID), 0, "POE::Kernel has no extra references" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount, "POE::Kernel reference count decremented again" ); } # Catch some errors. eval { $poe_kernel->_data_extref_dec($poe_kernel->ID, "nonexistent") }; ok( $@ && $@ =~ /decrementing extref for session without any/, "can't decrement an extref if a session doesn't have any" ); # Clear the session again, to exercise some code that otherwise # wouldn't be. $poe_kernel->_data_extref_clear_session($poe_kernel->ID); # Ensure the subsystem shuts down ok. ok( $poe_kernel->_data_extref_finalize(), "POE::Resource::Extrefs finalized ok" ); 1; POE-1.368/t/20_resources/00_base/sessions.pm000644 001751 001751 00000025714 12143730315 021167 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Test::More tests => 58; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # POE::Kernel is used as a parent session. Gather a baseline # reference count for it. Its value will be used for other tests. my $base_kernel_refcount = $poe_kernel->_data_ses_refcount($poe_kernel->ID); is($poe_kernel->_data_ses_count(), 1, "only POE::Kernel exists"); # Allocate a dummy session for testing. my $child = bless [ ], "POE::Session"; my $child_sid = $poe_kernel->_data_sid_allocate(); $child->_set_id($child_sid); $poe_kernel->_data_ses_allocate( $child, # session $child_sid, # sid $poe_kernel->ID, # parent ); my $base_child_refcount = $poe_kernel->_data_ses_refcount($child_sid); # Play a brief game with reference counts. Make sure negative ones # cause errors. eval { $poe_kernel->_data_ses_refcount_dec($child_sid) }; ok( $@ && $@ =~ /reference count went below zero/, "trap on negative reference count" ); is( $poe_kernel->_data_ses_refcount($child_sid), $base_child_refcount - 1, "negative reference count" ); $poe_kernel->_data_ses_refcount_inc($child_sid); is( $poe_kernel->_data_ses_refcount($child_sid), $base_child_refcount, "incremented reference count is back to base" ); # Ensure that the session's ID was set. is( $poe_kernel->_data_sid_resolve($child_sid), $child, "child session's ID is correct" ); # Ensure parent/child referential integrity. { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); is_deeply( \@children, [ $child ], "POE::Kernel has only the child session" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount + 1, "POE::Kernel's refcount incremented by child" ); my $parent = $poe_kernel->_data_ses_get_parent($child_sid); is($parent, $poe_kernel, "child's parent is POE::Kernel"); ok( $poe_kernel->_data_ses_is_child($poe_kernel->ID, $child_sid), "child is child of POE::Kernel" ); is($poe_kernel->_data_ses_count(), 2, "two sessions now"); } # Try to free POE::Kernel while it has a child session. eval { $poe_kernel->_data_ses_free($poe_kernel->ID) }; ok( $@ && $@ =~ /no parent to give children to/, "can't free POE::Kernel while it has children" ); # A variety of session resolution tests. is( $poe_kernel->_data_ses_resolve("$child"), $child, "stringified reference resolves to blessed one" ); ok( !defined($poe_kernel->_data_ses_resolve("nonexistent")), "nonexistent stringy reference doesn't resolve" ); is( $poe_kernel->_data_ses_resolve_to_id($child), $child_sid, "session reference $child resolves to ID" ); ok( !defined($poe_kernel->_data_ses_resolve_to_id("nonexistent")), "nonexistent session reference doesn't resolve" ); # Create a grandchild session (child of child). Verify that its place # in the grand scheme of things is secure. my $grand = bless [ ], "POE::Session"; my $grand_id = $poe_kernel->_data_sid_allocate(); $grand->_set_id($grand_id); $poe_kernel->_data_ses_allocate( $grand, # session $grand_id, # sid $child_sid, # parent ); my $base_grand_refcount = $poe_kernel->_data_ses_refcount($grand_id); { my @children = $poe_kernel->_data_ses_get_children($child_sid); is_deeply( \@children, [ $grand ], "child has only the grandchild session" ); is( $poe_kernel->_data_ses_refcount($child_sid), $base_child_refcount + 1, "child refcount incremented by the grandchild" ); my $parent = $poe_kernel->_data_ses_get_parent($grand_id); is($parent, $child, "grandchild's parent is child"); ok( $poe_kernel->_data_ses_is_child($child_sid, $grand_id), "grandchild is child of child" ); is($poe_kernel->_data_ses_count(), 3, "three sessions now"); } { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); is_deeply( \@children, [ $child ], "POE::Kernel children untouched by grandchild" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount + 1, "POE::Kernel's refcount untouched by grandchild" ); } # Create a great-grandchild session (child of grandchild). Verify # that its place in the grand scheme of things is secure. my $great = bless [ ], "POE::Session"; my $great_id = $poe_kernel->_data_sid_allocate(); $great->_set_id($great_id); $poe_kernel->_data_ses_allocate( $great, # session $great_id, # sid $grand_id, # parent ); my $base_great_refcount = $poe_kernel->_data_ses_refcount($great_id); { my @children = $poe_kernel->_data_ses_get_children($grand_id); is_deeply( \@children, [ $great ], "grandchild has only the great-grandchild session" ); is( $poe_kernel->_data_ses_refcount($grand_id), $base_grand_refcount + 1, "grandchild refcount incremented by the great-grandchild" ); my $parent = $poe_kernel->_data_ses_get_parent($great_id); is($parent, $grand, "great-grandchild's parent is grandchild"); ok( $poe_kernel->_data_ses_is_child($child_sid, $grand_id), "great-grandchild is child of grandchild" ); } { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); is_deeply( \@children, [ $child ], "POE::Kernel children untouched by great-grandchild" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount + 1, "POE::Kernel's refcount untouched by great-grandchild" ); } { my @children = $poe_kernel->_data_ses_get_children($child_sid); is_deeply( \@children, [ $grand ], "child children untouched by great-grandchild" ); is( $poe_kernel->_data_ses_refcount($child_sid), $base_child_refcount + 1, "child's refcount untouched by great-grandchild" ); } { my @children = $poe_kernel->_data_ses_get_children($great_id); is(scalar(@children), 0, "no great-great-grandchildren"); } # Move the grandchild to just under POE::Kernel. This makes child and # grandchild siblings. $poe_kernel->_data_ses_move_child($grand_id, $poe_kernel->ID); is( $poe_kernel->_data_ses_get_parent($child_sid), $poe_kernel, "child's parent is POE::Kernel" ); is( $poe_kernel->_data_ses_get_parent($grand_id), $poe_kernel, "grandchild's parent is POE::Kernel" ); { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); my %kids = map {($_=>1)} @children; ok(exists($kids{$child}), "POE::Kernel owns child"); ok(exists $kids{$grand}, "POE::Kernel owns grandchild"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount + 2, "POE::Kernel refcount increased since inheriting grandchild" ); } { my @children = $poe_kernel->_data_ses_get_children($child_sid); is_deeply( \@children, [ ], "child has no children" ); is( $poe_kernel->_data_ses_refcount($child_sid), $base_child_refcount, "child's refcount decreased since losing grandchild" ); } # Free the childless child. Make sure POE::Kernel/child data # structures cross-reference. $poe_kernel->_data_ses_free($child_sid); { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); is_deeply( \@children, [ $grand ], "POE::Kernel only has grandchild now" ); my $parent = $poe_kernel->_data_ses_get_parent($grand_id); is($parent, $poe_kernel, "grandchild's parent is POE::Kernel"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount + 1, "POE::Kernel's refcount decremented on child loss" ); eval { my $parent = $poe_kernel->_data_ses_get_parent($child_sid) }; ok( $@ && $@ =~ /retrieving parent of a nonexistent session/, "can't get parent of nonexistent session" ); eval { my $parent = $poe_kernel->_data_ses_get_children($child_sid) }; ok( $@ && $@ =~ /retrieving children of a nonexistent session/, "can't get children of nonexistent session" ); eval { my $parent = $poe_kernel->_data_ses_is_child($child_sid, $child_sid) }; ok( $@ && $@ =~ /testing is-child of a nonexistent parent session/, "can't test is-child of nonexistent session" ); } # Stop the grandchild. The great-grandchild will be inherited by # POE::Kernel after this. $poe_kernel->_data_ses_stop($grand_id); { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); is_deeply( \@children, [ $great ], "POE::Kernel only has great-grandchild now" ); my $parent = $poe_kernel->_data_ses_get_parent($great_id); is($parent, $poe_kernel, "great-grandchild's parent is POE::Kernel"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount + 1, "POE::Kernel's refcount conserved" ); } # Try garbage collection on a session that can use stopping. $poe_kernel->_data_ses_collect_garbage($great_id); { my @children = $poe_kernel->_data_ses_get_children($poe_kernel->ID); is_deeply( \@children, [ ], "POE::Kernel has no children anymore" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_kernel_refcount, "POE::Kernel's refcount back to basics" ); } # Test traps for dealing with nonexistent sessions. eval { $poe_kernel->_data_ses_refcount_inc("nonexistent") }; ok( $@ && $@ =~ /incrementing refcount for nonexistent session/, "can't increment refcount for nonexistent session" ); eval { $poe_kernel->_data_ses_refcount_dec("nonexistent") }; ok( $@ && $@ =~ /decrementing refcount of a nonexistent session/, "can't decrement refcount for nonexistent session" ); eval { $poe_kernel->_data_ses_stop("nonexistent") }; ok( $@ && $@ =~ /stopping a nonexistent session/, "can't stop a nonexistent session" ); # Attempt to allocate a session for a nonexistent parent. my $bogus = bless [ ], "POE::Session"; my $bogus_sid = $poe_kernel->_data_sid_allocate(); $bogus->_set_id($bogus_sid); eval { $poe_kernel->_data_ses_allocate( $bogus, # session $bogus_sid, # sid "nonexistent", # parent ) }; ok( $@ && $@ =~ /parent session nonexistent does not exist/, "can't allocate a session for an unknown parent" ); # Attempt to allocate a session that already exists. eval { $poe_kernel->_data_ses_allocate( $poe_kernel, # session $poe_kernel->ID, # sid $poe_kernel->ID, # parent ) }; ok( $@ && $@ =~ /session .*? is already allocated/, "can't allocate a session that's already allocated" ); # Attempt to move nonexistent sessions around. eval { $poe_kernel->_data_ses_move_child("nonexistent", $poe_kernel->ID) }; ok( $@ && $@ =~ /moving nonexistent child to another parent/, "can't move nonexistent child to another parent" ); eval { $poe_kernel->_data_ses_move_child($poe_kernel->ID, "nonexistent") }; ok( $@ && $@ =~ /moving child to a nonexistent parent/, "can't move a session to a nonexistent parent" ); # Free the last session, and finalize the subsystem. Freeing it is # necessary because the original refcount includes some events that # would otherwise count as leakage during finalization. $poe_kernel->_data_ses_stop($poe_kernel->ID); ok($poe_kernel->_data_ses_finalize(), "finalized POE::Resource::Sessions"); 1; POE-1.368/t/20_resources/00_base/sids.pm000644 001751 001751 00000003056 12143730315 020256 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Test::More tests => 7; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # Allocate a session ID. It starts at 2 because POE::Kernel's virtual # session has already been allocated. my $sid = $poe_kernel->_data_sid_allocate(); ok($sid == 1, "first user SID is expected (got $sid)"); # Set an ID for a session. $poe_kernel->_data_sid_set($sid, "session"); # Ensure that the session ID resolves. my $resolved_session = $poe_kernel->_data_sid_resolve($sid); ok($resolved_session eq "session", "session ID resolves correctly"); # Remove the ID from the session. This relies on a side effect of the # remove function that returns the removed value. That may change in # the future. my $removed = $poe_kernel->_data_sid_clear($sid); ok($removed eq "session", "session ID $sid removes $removed correctly"); # What happens if a session doesn't exist? eval { $poe_kernel->_data_sid_clear("session") }; ok( $@ && $@ =~ /unknown SID/, "can't clear a sid for a nonexistent session" ); # POE::Kernel itself has allocated a SID. Remove that. This also # relies on undocumented side effects that can change at any time. $removed = $poe_kernel->_data_sid_clear($poe_kernel->ID); ok($removed eq $poe_kernel, "successfully removed POE::Kernel's SID"); # Finalize the subsystem and ensure it shut down cleanly. ok($poe_kernel->_data_sid_finalize(), "POE::Resource::SIDs finalized ok"); 1; POE-1.368/t/20_resources/00_base/events.pm000644 001751 001751 00000021362 12143730315 020620 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Test::More tests => 38; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } sub BOGUS_SESSION () { 31415 } my $baseline_event = 0; my $baseline_refcount = 0; # This subsystem is still very closely tied to POE::Kernel, so we # can't call initialize ourselves. TODO Separate it, if possible, # enough to make this feasible. { # Create a new event, and verify that it's good. my $event_id = $poe_kernel->_data_ev_enqueue( $poe_kernel, # session $poe_kernel, # source_session "event", # event POE::Kernel::ET_ALARM, # event type [], # etc __FILE__, # file __LINE__, # line "called_from",# caller state 0, # time (beginning thereof) ); # Event 1 is the kernel's performance poll timer. is( $event_id, $baseline_event + 1, "first user created event has correct ID" ); # Kernel should therefore have one events due. # A nonexistent session should have zero. is( $poe_kernel->_data_ev_get_count_from($poe_kernel->ID), $baseline_event, "POE::Kernel has enqueued correct number of events" ); is( $poe_kernel->_data_ev_get_count_to($poe_kernel->ID), $baseline_event + 1, "POE::Kernel has three events enqueued for it" ); is( $poe_kernel->_data_ev_get_count_from("nothing"), 0, "unknown session has enqueued no events" ); is( $poe_kernel->_data_ev_get_count_to("nothing"), 0, "unknown session has no events enqueued for it" ); # Performance timer only counts once now. is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $baseline_refcount + 1, "POE::Kernel's timer count is correct" ); } { # Dispatch due events, and stuff. $poe_kernel->_data_ev_dispatch_due(); check_references( $poe_kernel, 0, 0, 0, "after due events are dispatched" ); } # Test timer maintenance functions. Add some alarms: Three with # identical names, and one with another name. Remember the ID of one # of them, so we can remove it explicitly. The other three should # remain. Remove them by name, and both the remaining ones with the # same name should disappear. The final alarm will be removed by # clearing alarms for the session. my @ids; for (1..4) { my $timer_name = "timer"; $timer_name = "other-timer" if $_ == 4; push( @ids, $poe_kernel->_data_ev_enqueue( $poe_kernel, # session $poe_kernel, # source_session $timer_name, # event POE::Kernel::ET_ALARM, # event type [], # etc __FILE__, # file __LINE__, # line undef, # called from state $_, # time ) ); } # The from and to counts should add up to the reference count. check_references( $poe_kernel, 0, 0, 4, "after some timers are enqueued" ); { # Remove one of the alarms by its ID. my ($time, $event) = $poe_kernel->_data_ev_clear_alarm_by_id( $poe_kernel->ID(), $ids[1] ); is($time, 2, "removed event has the expected due time"); is( $event->[POE::Kernel::EV_NAME], "timer", "removed event has the expected name" ); check_references( $poe_kernel, 0, 0, 3, "after a single named event is removed" ); } { # Try to remove a nonexistent alarm by the ID it would have if it # did exist, except it doesn't. my ($time, $event) = $poe_kernel->_data_ev_clear_alarm_by_id( $poe_kernel->ID(), 8675309 ); ok(!defined($time), "can't clear bogus alarm by nonexistent ID"); check_references( $poe_kernel, 0, 0, 3, "after trying to clear a bogus alarm" ); } # Remove an alarm by name, except that this is for a nonexistent # session. $poe_kernel->_data_ev_clear_alarm_by_name(BOGUS_SESSION, "timer"); check_references( $poe_kernel, 0, 0, 3, "after removing timers from a bogus session" ); is( $poe_kernel->_data_ev_get_count_from(BOGUS_SESSION), 0, "bogus session has created no events" ); is( $poe_kernel->_data_ev_get_count_to(BOGUS_SESSION), 0, "bogus session has no events enqueued for it" ); # Remove the alarm by name, for real. We should be down to one timer # (the original poll thing). $poe_kernel->_data_ev_clear_alarm_by_name($poe_kernel->ID(), "timer"); check_references( $poe_kernel, 0, 0, 1, "after removing 'timer' by name" ); { # Try to remove timers from some other (nonexistent should be ok) # session. my @removed = $poe_kernel->_data_ev_clear_alarm_by_session(8675309); is(@removed, 0, "didn't remove alarm from nonexistent session"); } { # Remove the last of the timers. The Kernel session is the only # reference left for it. my @removed = $poe_kernel->_data_ev_clear_alarm_by_session($poe_kernel->ID()); is(@removed, 1, "removed the last alarm successfully"); # Verify that the removed timer is the correct one. We still have # the signal polling timer around there somewhere. my ($removed_name, $removed_time, $removed_args) = @{$removed[0]}; is($removed_name, "other-timer", "last alarm had the corrent name"); is($removed_time, 4, "last alarm had the corrent due time"); check_references( $poe_kernel, 0, 0, 0, "after clearing all alarms for a session" ); } # Remove all events for the kernel session. Now it should be able to # finalize cleanly. $poe_kernel->_data_ev_clear_session($poe_kernel); { # Catch a trap when enqueuing an event for a nonexistent session. eval { $poe_kernel->_data_ev_enqueue( "moo", # dest session "moo", # source session "event", # event name POE::Kernel::ET_ALARM, # event type [], # etc __FILE__, # file __LINE__, # line undef, # called from state 1, # due time ); }; ok( $@ && $@ =~ /Can't locate object method "ID"/, "trap while enqueuing event for non-existent session" ); } { # Exercise _data_ev_clear_session when events are sent from one # session to another. my $session = POE::Session->create( inline_states => { _start => sub { }, _stop => sub { }, } ); $poe_kernel->_data_ev_enqueue( $session, # dest session $poe_kernel, # source session "event-1", # event name POE::Kernel::ET_POST, # event type [], # etc __FILE__, # file __LINE__, # line undef, # called from state 1, # due time ); $poe_kernel->_data_ev_enqueue( $poe_kernel, # dest session $session, # source session "event-2", # event name POE::Kernel::ET_POST, # event type [], # etc __FILE__, # file __LINE__, # line undef, # called from state 2, # due time ); check_references( $poe_kernel, 1, 1, 1, "after creating inter-session messages" ); $poe_kernel->_data_ev_clear_session($session->ID()); check_references( $poe_kernel, 1, 0, 0, "after clearing inter-session messages" ); $poe_kernel->_data_ev_clear_session($poe_kernel->ID()); check_references( $poe_kernel, 1, 0, 0, "after clearing kernel messages" ); } # A final test. ok( $poe_kernel->_data_ev_finalize(), "POE::Resource::Events finalized cleanly" ); # END OF EXECUTION HERE, BUT I CAN'T USE EXIT # Every time we cross-check a session for events and reference counts, # there should be twice as many references as events. This is because # each event counts twice: once because the session sent the event, # and again because the event was due for the session. Check that the # from- and to counts add up to the reference count, and that they are # equal. # # The "base" references are ones from sources other than events. In # later tests, they're from the addition of another session. sub check_references { my ($session, $base_ref, $expected_from, $expected_to, $when) = @_; my $from_count = $poe_kernel->_data_ev_get_count_from($session->ID); my $to_count = $poe_kernel->_data_ev_get_count_to($session->ID); # Reference count stopped being simply the from + to + base counts. #my $ref_count = $poe_kernel->_data_ses_refcount($session->ID); #my $check_sum = $from_count + $to_count + $base_ref; #is($check_sum, $ref_count, "refcnts $ref_count == $check_sum $when"); is( $from_count, $expected_from, "from evcount $from_count == $expected_from $when" ); is( $to_count, $expected_to, "to evcount $to_count == $expected_to $when" ); } # We created a session, so run it. POE::Kernel->run(); 1; POE-1.368/t/20_resources/00_base/aliases.pm000644 001751 001751 00000005574 12143730315 020744 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Test::More tests => 14; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } sub POE::Kernel::USE_SIGCHLD () { 0 } BEGIN { use_ok("POE") } # Base reference count. my $base_refcount = 0; # Set an alias and verify that it can be retrieved. Also verify the # loggable version of it. { $poe_kernel->_data_alias_add($poe_kernel, "alias-1"); my $session = $poe_kernel->_data_alias_resolve("alias-1"); is($session, $poe_kernel, "alias resolves to original reference"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 1, "session reference count is to be expected" ); my $kernel_id = $poe_kernel->ID; my $loggable = $poe_kernel->_data_alias_loggable($kernel_id); ok( $loggable =~ /^session \Q$kernel_id\E \(alias-1\)$/, "loggable version of session is valid" ); } # Remove the alias and verify that it is gone. { $poe_kernel->_data_alias_remove($poe_kernel, "alias-1"); my $session = $poe_kernel->_data_alias_resolve("alias-1"); ok(!defined($session), "removed alias does not resolve"); # Should be 2. See the rationale above. is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount, "session reference count reduced correctly" ); } # Set multiple aliases and verify that they exist. my @multi_aliases = qw( alias-1 alias-2 alias-3 ); { foreach (@multi_aliases) { $poe_kernel->_data_alias_add($poe_kernel, $_); } is( $poe_kernel->_data_alias_count_ses($poe_kernel->ID), @multi_aliases, "correct number of aliases were recorded" ); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount + 3, "correct number of references were recorded" ); my @retrieved = $poe_kernel->_data_alias_list($poe_kernel->ID); is_deeply( \@retrieved, \@multi_aliases, "the aliases were retrieved correctly" ); } # Clear all the aliases for the session, and make sure they're gone. { $poe_kernel->_data_alias_clear_session($poe_kernel->ID); my @retrieved = $poe_kernel->_data_alias_list($poe_kernel->ID); is(scalar(@retrieved), 0, "aliases were cleared successfully"); is( $poe_kernel->_data_ses_refcount($poe_kernel->ID), $base_refcount, "proper number of references after alias clear" ); } # Some tests and testless instrumentation on nonexistent sessions. { is( $poe_kernel->_data_alias_count_ses("nothing"), 0, "unknown session has no aliases" ); $poe_kernel->_data_alias_clear_session("nothing"); ok( !defined($poe_kernel->_data_alias_resolve("nothing")), "unused alias does not resolve to anything" ); } # Finalize the subsystem. Returns true if everything shut down # cleanly, or false if it didn't. ok( $poe_kernel->_data_alias_finalize(), "POE::Resource::Aliases finalizes cleanly" ); 1; POE-1.368/t/10_units/03_base/000755 001751 001751 00000000000 13615550107 016110 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/05_filters/000755 001751 001751 00000000000 13615550107 016650 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/08_loops/000755 001751 001751 00000000000 13615550107 016337 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/02_pipes/000755 001751 001751 00000000000 13615550107 016315 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/01_pod/000755 001751 001751 00000000000 13615550107 015756 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/06_queues/000755 001751 001751 00000000000 13615550107 016510 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/07_exceptions/000755 001751 001751 00000000000 13615550107 017363 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/04_drivers/000755 001751 001751 00000000000 13615550107 016655 5ustar00bingosbingos000000 000000 POE-1.368/t/10_units/04_drivers/01_sysrw.t000644 001751 001751 00000014061 12276766765 020560 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 17; use POE::Pipe::OneWay; BEGIN { use_ok("POE::Driver::SysRW") } # Start with some errors. eval { my $d = POE::Driver::SysRW->new( BlockSize => 0 ) }; ok( $@ && $@ =~ /BlockSize must be greater than 0/, "disallow zero or negative block sizes" ); eval { my $d = POE::Driver::SysRW->new( 0 ) }; ok( $@ && $@ =~ /requires an even number of parameters/, "disallow zero or negative block sizes" ); eval { my $d = POE::Driver::SysRW->new( Booga => 1 ) }; ok( $@ && $@ =~ /unknown parameter.*Booga/, "disallow unknown parameters" ); # This block of tests also exercises the driver with its default # constructor parameters. { my $d = POE::Driver::SysRW->new(); use Symbol qw(gensym); my $fh = gensym(); open $fh, ">deleteme.now" or die $!; $! = 0; open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; my $get_ret = $d->get($fh); ok(!defined($get_ret), "get() returns undef on error"); ok($!, "get() sets \$! on error ($!)"); open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; close $fh; unlink "deleteme.now"; } my $d = POE::Driver::SysRW->new( BlockSize => 1024 ); # Empty put(). { my $octets_left = $d->put([ ]); ok( $octets_left == 0, "buffered 0 octets on empty put()" ); } ok( $d->get_out_messages_buffered() == 0, "no messages buffered" ); # The number of octets we expect in the driver's put() buffer. my $expected = 0; # Put() returns the correct number of octets. { my $string_to_put = "test" x 10; my $length_to_put = length($string_to_put); $expected += $length_to_put; my $octets_left = $d->put([ $string_to_put ]); ok( $octets_left == $expected, "first put: buffer contains $octets_left octets (should be $expected)" ); } # Only one message buffered. ok( $d->get_out_messages_buffered() == 1, "one message buffered" ); # Put() returns the correct number of octets on a subsequent call. { my $string_to_put = "more test" x 5; my $length_to_put = length($string_to_put); $expected += $length_to_put; my $octets_left = $d->put([ $string_to_put ]); ok( $octets_left == $expected, "second put: buffer contains $octets_left octets (should be $expected)" ); } # Remaining tests require some live handles. my ($r, $w) = POE::Pipe::OneWay->new(); die "can't open a pipe: $!" unless $r; nonblocking($w); nonblocking($r); # Number of flushed octets == number of read octets. { my ($flushed_count, $full) = write_until_pipe_is_full($d, $w); my ($read_count) = read_until_pipe_is_empty($d, $r); ok( $flushed_count == $read_count, "flushed $flushed_count octets == read $read_count octets" ); } # Flush the buffer and the pipe. while (flush_remaining_buffer($d, $w)) { read_until_pipe_is_empty($d, $r); } { my $out_messages = $d->get_out_messages_buffered(); ok($out_messages == 0, "buffer exhausted (got $out_messages wanted 0)"); } # Get() returns undef ($! == 0) on EOF. { write_until_pipe_is_full($d, $w); close($w); open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; while (1) { $! = 1; last unless defined $d->get($r); } pass("driver returns undef on eof"); ok($! == 0, "\$! is clear on eof"); open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; } # Flush() returns the number of octets remaining, and sets $! to # nonzero on major error. { open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; # Make sure $w is closed. Sometimes, like on Cygwin, it isn't. close $w; $! = 0; my $error_left = $d->flush($w); ok($error_left, "put() returns octets left on error"); ok($!, "put() sets \$! nonzero on error"); open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; } exit 0; # Buffer data, and flush it, until the pipe refuses to hold more data. # This should also cause the driver to experience an EAGAIN or # EWOULDBLOCK on write. sub write_until_pipe_is_full { my ($driver, $handle) = @_; # Hopefully bigger than any system buffer ever. my $big_chunk = "*" x (1024 * 1024); my $flushed = 0; my $full = 0; while (1) { # Put a big chunk into the buffer. my $buffered = $driver->put([ $big_chunk ]); # Try to flush it. my $after_flush = $driver->flush($handle); # How much was flushed? $flushed += $buffered - $after_flush; # If there's data left, then this flush failed. last if $after_flush; } if (wantarray) { return ($flushed, $full); } return $flushed; } # Assume the driven has buffered data. This makes sure it's flushed, # or at least the pipe is clogged. Combine it with # read_until_pipe_is_empty() to flush the driver and the pipe. sub flush_remaining_buffer { my ($driver, $handle) = @_; my $before_flush = $driver->get_out_messages_buffered(); $driver->flush($handle); return $before_flush; } # Read until there's nothing left to read from the pipe. This should # exercise the driver's EAGAIN/EWOULDBLOCK code on the read side. sub read_until_pipe_is_empty { my ($driver, $handle) = @_; my $read_octets = 0; # SunOS catalogue1 5.11 snv_101b i86pc i386 i86pc # Sometimes returns "empty" when there's data in the pipe. # Looping again seems to fetch the remaining data, though. for (1..3) { while (1) { my $data = $driver->get($handle); last unless defined($data) and @$data; $read_octets += length() foreach @$data; } } return $read_octets; } # Portable nonblocking sub. blocking(0) doesn't do it all the time, # everywhere, and it sucks. # # This sub sucks, too. The code is lifted almost verbatim from # POE::Resource::FileHandles. That code should probably be made a # library function, but where should it go? sub nonblocking { my $handle = shift; # For DOSISH systems like OS/2. Wrapped in eval{} in case it's a # tied handle that doesn't support binmode. eval { binmode *$handle }; # Turn off blocking. eval { $handle->blocking(0); $handle->blocking(); }; # Turn off buffering. CORE::select((CORE::select($handle), $| = 1)[0]); } POE-1.368/t/10_units/07_exceptions/03_not_handled.t000644 001751 001751 00000001661 12472121170 022327 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 filetype=perl expandtab use Test::More tests => 8; use POE; POE::Session->create( inline_states => { _start => sub { pass("Session started"); $_[KERNEL]->sig('DIE' => 'mock_death'); $_[KERNEL]->yield('death'); }, _stop => sub { pass("Session stopping"); }, death => sub { die "OMG THEY CANCELLED FRIENDS"; }, mock_death => sub { is($_[ARG0], 'DIE', "DIE signal sent"); }, }, ); POE::Session->create( inline_states => { _start => sub { pass("Other session started"); $_[KERNEL]->delay('last_breath' => 0.5); }, _stop => sub { pass("Other session stopping"); }, last_breath => sub { fail("POE environment survived uncaught exception"); }, }, ); eval { POE::Kernel->run(); }; ok(length $@, "unhandled exception was propagated"); like($@, qr/OMG THEY CANCELLED FRIENDS/, '$@contains the correct error message'); pass("POE environment shut down"); POE-1.368/t/10_units/07_exceptions/01_normal.t000644 001751 001751 00000001641 12143730314 021335 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 filetype=perl expandtab use Test::More tests => 7; use POE; POE::Session->create( inline_states => { _start => sub { pass("Session started"); $_[KERNEL]->sig('DIE' => 'avoid_death'); $_[KERNEL]->yield('death'); $_[KERNEL]->delay('party' => 0.5); }, _stop => sub { pass("Session stopping"); }, death => sub { die "OMG THEY CANCELLED FRIENDS"; }, avoid_death => sub { my $signal = $_[ARG0]; my $data = $_[ARG1]; is($signal, 'DIE', 'Caught DIE signal'); is($data->{from_state}, '_start', 'Signal came from the correct state'); like($data->{error_str}, qr/OMG THEY CANCELLED FRIENDS/, 'error_str contains correct value'); $_[KERNEL]->sig(DIE => undef); $_[KERNEL]->sig_handled(); }, party => sub { pass("Environment survived exception attempt"); }, }, ); POE::Kernel->run(); pass("POE environment shut down"); POE-1.368/t/10_units/07_exceptions/02_turn_off.t000644 001751 001751 00000001046 12472121170 021666 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 filetype=perl expandtab use Test::More tests => 4; sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } use POE; eval { POE::Session->create( inline_states => { _start => sub { pass("Session started"); $_[KERNEL]->yield('death'); }, _stop => sub { pass("Session stopping"); }, death => sub { die "OMG THEY CANCELLED FRIENDS"; }, }, ); POE::Kernel->run(); }; ok(length $@, "die caused normal exception"); like($@, qr/OMG THEY CANCELLED FRIENDS/, '$@ contains correct error message'); POE-1.368/t/10_units/06_queues/01_array.t000644 001751 001751 00000014452 12472121170 020313 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Tests basic queue operations. use strict; use lib qw(./mylib); use Test::More tests => 2047; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POSIX qw(EPERM ESRCH); BEGIN { use_ok("POE::Queue::Array") } my $q = POE::Queue::Array->new(); ok($q->get_item_count == 0, "queue begins empty"); ok(!defined($q->dequeue_next), "can't dequeue from empty queue"); ok($q->enqueue(1, "one") == 1, "first enqueue has id 1"); ok($q->enqueue(3, "tre") == 2, "second enqueue has id 2"); ok($q->enqueue(2, "two") == 3, "third enqueue has id 3"); ok( eq_array( [$q->dequeue_next()], [1, 1, "one"] ), "event one dequeued correctly" ); ok( eq_array( [$q->dequeue_next()], [2, 3, "two"] ), "event two dequeued correctly" ); ok( eq_array( [$q->dequeue_next()], [3, 2, "tre"] ), "event three dequeued correctly" ); ok( eq_array( [$q->dequeue_next()], [] ), "empty queue marker dequeued correctly" ); { my @events = ( [ a => 1 ], [ c => 3 ], [ e => 5 ], [ b => 2 ], [ d => 4 ], ); my $base_event_id = 4; enqueue_events(\@events, $base_event_id); } # Not constants. sub always_ok { 1 } sub never_ok { 0 } ok( eq_array( [$q->remove_item(7, \&always_ok)], [2, 7, "b"] ), "removed event b by its ID" ); ok( eq_array( [$q->remove_item(5, \&always_ok)], [3, 5, "c"] ), "removed event c by its ID" ); ok( eq_array( [$q->remove_item(8, \&always_ok)], [4, 8, "d"] ), "removed event d by its ID" ); $! = 0; ok( ( eq_array( [$q->remove_item(6, \&never_ok )], [] ) && $! == EPERM ), "didn't have permission to remove event e" ); $! = 0; ok( ( eq_array( [$q->remove_item(8, \&always_ok)], [] ) && $! == ESRCH ), "couldn't remove nonexistent event d" ); ok( eq_array( [$q->dequeue_next()], [1, 4, "a"] ), "dequeued event a correctly" ); ok( eq_array( [$q->dequeue_next()], [5, 6, "e"] ), "dequeued event e correctly" ); ok( eq_array( [$q->dequeue_next()], [] ), "empty queue marker dequeued correctly" ); { my @events = ( [ a => 1 ], [ c => 3 ], [ e => 5 ], [ b => 2 ], [ d => 4 ], [ f => 6 ], ); my $base_event_id = 9; enqueue_events(\@events, $base_event_id); } ok($q->get_item_count() == 6, "queue contains six events"); sub odd_letters { $_[0] =~ /[ace]/ } sub even_letters { $_[0] =~ /[bdf]/ } { my @items = $q->remove_items(\&odd_letters, 3); my @target = ( [ 1, 9, "a" ], [ 3, 10, "c" ], [ 5, 11, "e" ], ); ok(eq_array(\@items, \@target), "removed odd letters from queue"); ok($q->get_item_count() == 3, "leaving three events"); } { my @items = $q->remove_items(\&odd_letters, 3); my @target; ok(eq_array(\@items, \@target), "no more odd letters to remove"); } { my @items = $q->remove_items(\&even_letters, 3); my @target = ( [ 2, 12, "b" ], [ 4, 13, "d" ], [ 6, 14, "f" ], ); ok(eq_array(\@items, \@target), "removed even letters from queue"); ok($q->get_item_count() == 0, "leaving the queue empty"); } { my @events = ( [ a => 10 ], [ b => 20 ], [ c => 30 ], [ d => 40 ], [ e => 50 ], [ f => 60 ], ); my $base_event_id = 15; enqueue_events(\@events, $base_event_id); } ok($q->get_item_count() == 6, "leaving six events in the queue"); { my @items = $q->peek_items(\&even_letters); my @target = ( [ 20, 16, "b" ], [ 40, 18, "d" ], [ 60, 20, "f" ], ); ok(eq_array(\@items, \@target), "found even letters in queue"); } ok( $q->adjust_priority(19, \&always_ok, -15) == 35, "adjusted event e priority by -15" ); ok( $q->adjust_priority(16, \&always_ok, +15) == 35, "adjusted event b priority by +15" ); { my @items = $q->remove_items(\&always_ok); my @target = ( [ 10, 15, "a" ], [ 30, 17, "c" ], [ 35, 19, "e" ], # e got there first [ 35, 16, "b" ], # b got there second [ 40, 18, "d" ], [ 60, 20, "f" ], ); ok(eq_array(\@items, \@target), "colliding priorities are FIFO"); } ok($q->get_item_count() == 0, "full queue removal leaves zero events"); ### Large Queue Tests. The only functions that use large queues are ### enqueue(), adjust_priority(), and set_priority(). Large queues ### are over ~500 elements. # Generate a list of events in random priority order. sub shuffled_list { my $limit = shift() - 1; my @list = (0..$limit); my $i = @list; while (--$i) { my $j = int rand($i+1); @list[$i,$j] = @list[$j,$i]; } @list; } sub is_even { !($_[0] % 2) } sub is_odd { $_[0] % 2 } sub verify_queue { my $target_diff = shift; my $low_priority = -999999; while (my ($pri, $id, $item) = $q->dequeue_next()) { my $diff; if ($pri < 0) { $diff = $item - $pri; } else { $diff = $pri - $item; } ok( ($pri > $low_priority) && ($diff == $target_diff), "$item - $pri == $diff (should be $target_diff)" ); $low_priority = $pri; } } # Enqueue all the events, then adjust their priorities. The # even-numbered events have their priorities reduced by 1000; the odd # ones have their priorities increased by 1000. { my @ids; for my $major (shuffled_list(10)) { for my $minor (shuffled_list(100)) { my $priority = sprintf("%2d%02d", $major, $minor); push @ids, $q->enqueue($priority, $priority); } } foreach my $id (@ids) { $q->adjust_priority($id, \&is_even, -1000); } foreach my $id (@ids) { $q->adjust_priority($id, \&is_odd, 1000); } } # Verify that the queue remains in order, and that the adjusted # priorities are correct. verify_queue(1000); # Now set priorities to absolute values. The values are { my @id_recs; for my $major (shuffled_list(10)) { for my $minor (shuffled_list(100)) { my $priority = sprintf("%2d%02d", $major, $minor); push @id_recs, [ $q->enqueue($priority, $priority), $priority ]; } } foreach my $id_rec (@id_recs) { my ($id, $pri) = @$id_rec; $q->set_priority($id, \&is_even, $pri + 500); } foreach my $id_rec (@id_recs) { my ($id, $pri) = @$id_rec; $q->set_priority($id, \&is_odd, $pri + 500); } verify_queue(500); } ### Helper functions. sub enqueue_events { my ($events, $id) = @_; foreach (@$events) { my ($ev, $prio) = @$_; ok($q->enqueue($prio, $ev) == $id++, "enqueued event $ev correctly"); } } POE-1.368/t/10_units/01_pod/02_pod_coverage.t000644 001751 001751 00000004426 12356754444 021122 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 filetype=perl expandtab # This testcase loads all POE modules. Some of them may define # alternative methods with the same full-qualified names. Disable the # inevitable warnings. BEGIN { $^W = 0 } use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan skip_all => 'enable by setting RELEASE_TESTING'; } eval "use Test::Pod::Coverage 1.08"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@; # These are the default Pod::Coverage options. my $default_opts = { also_private => [ qr/^[A-Z0-9_]+$/, # Constant subroutines. ], }; # Special case modules. Only define modules here if you want to skip # (0) or apply different Pod::Coverage options ({}). These options # clobber $default_opts above, so be sure to duplicate the default # options you want to keep. my %special = ( 'POE::Wheel::ReadLine' => { also_private => [ qr/^[A-Z0-9_]+$/, # Constants subs. qr/^rl_/, # Keystroke callbacks. # Deprecated names. qw( Attribs GetHistory ReadHistory WriteHistory addhistory ), ], coverage_class => 'Pod::Coverage::CountParents', }, 'POE::Kernel' => { %$default_opts, trustme => [ qr/^loop_/ ], # mixed in from POE::Loop }, 'POE::Pipe::OneWay' => { %$default_opts, trustme => [ qr/^new$/ ], }, 'POE::Pipe::TwoWay' => { %$default_opts, trustme => [ qr/^new$/ ], }, 'POE::Filter::HTTPD' => { %$default_opts, trustme => [ qw( headers_as_string encode_value get_one get_one_start get_pending put ) ] }, ); # Get the list of modules my @modules = all_modules(); plan tests => scalar @modules; foreach my $module ( @modules ) { my $opts = $default_opts; # Modules that inherit documentation from their parents. if ( $module =~ /^POE::(Loop|Driver|Filter|Wheel|Queue)::/ ) { $opts = { %$default_opts, coverage_class => 'Pod::Coverage::CountParents', }; } SKIP: { if ( exists $special{$module} ) { skip "$module", 1 unless $special{$module}; $opts = $special{$module} if ref $special{$module} eq 'HASH'; } # Skip modules that can't load for some reason. eval "require $module"; skip "Not checking $module ...", 1 if $@; # Finally! pod_coverage_ok( $module, $opts ); } } POE-1.368/t/10_units/01_pod/04_pod_linkcheck.t000644 001751 001751 00000000645 12143730314 021243 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Tests POD for invalid links use strict; use Test::More; BEGIN { unless ( $ENV{RELEASE_TESTING} ) { plan skip_all => 'enable by setting RELEASE_TESTING'; } foreach my $req (qw(Test::Pod::LinkCheck)) { eval "use $req"; if ($@) { plan skip_all => "$req is needed for these tests."; } } } Test::Pod::LinkCheck->new->all_pod_ok; POE-1.368/t/10_units/01_pod/01_pod.t000644 001751 001751 00000000412 12143730314 017215 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 filetype=perl expandtab use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan skip_all => 'enable by setting RELEASE_TESTING'; } eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); POE-1.368/t/10_units/01_pod/03_pod_no404s.t000644 001751 001751 00000001001 12143730314 020321 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Tests POD for 404 links use strict; use Test::More; BEGIN { unless (-f 'run_network_tests') { plan skip_all => 'Need network access (and permission) for these tests'; } unless ( $ENV{RELEASE_TESTING} ) { plan skip_all => 'enable by setting RELEASE_TESTING'; } foreach my $req (qw(Test::Pod::No404s)) { eval "use $req"; if ($@) { plan skip_all => "$req is needed for these tests."; } } } all_pod_files_ok(); POE-1.368/t/10_units/02_pipes/02_oneway.t000644 001751 001751 00000002634 12143730314 020305 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 3; use POE::Pipe::OneWay; use POE::Pipe::TwoWay; ### Test one-way pipe() pipe. SKIP: { my ($uni_read, $uni_write) = POE::Pipe::OneWay->new('pipe'); skip "$^O does not support one-way pipe()", 1 unless defined $uni_read and defined $uni_write; print $uni_write "whee pipe\n"; my $uni_input = <$uni_read>; chomp $uni_input; ok($uni_input eq "whee pipe", "one-way pipe passed data unscathed"); } ### Test one-way socketpair() pipe. SKIP: { my ($uni_read, $uni_write) = POE::Pipe::OneWay->new('socketpair'); skip "$^O does not support one-way socketpair()", 1 unless defined $uni_read and defined $uni_write; print $uni_write "whee socketpair\n"; my $uni_input = <$uni_read>; chomp $uni_input; ok( $uni_input eq 'whee socketpair', "one-way socketpair passed data unscathed" ); } ### Test one-way pair of inet sockets. SKIP: { unless (-f "run_network_tests") { skip "Network access (and permission) required to run inet test.", 1; } my ($uni_read, $uni_write) = POE::Pipe::OneWay->new('inet'); skip "$^O does not support one-way inet sockets.", 1 unless defined $uni_read and defined $uni_write; print $uni_write "whee inet\n"; my $uni_input = <$uni_read>; chomp $uni_input; ok( $uni_input eq 'whee inet', "one-way inet pipe passed data unscathed" ); } exit 0; POE-1.368/t/10_units/02_pipes/03_twoway.t000644 001751 001751 00000003717 12143730314 020341 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 6; use POE::Pipe::OneWay; use POE::Pipe::TwoWay; ### Test two-way pipe. SKIP: { my ($a_rd, $a_wr, $b_rd, $b_wr) = POE::Pipe::TwoWay->new('pipe'); skip "$^O does not support two-way pipe()", 2 unless defined $a_rd and defined $a_wr and defined $b_rd and defined $b_wr; print $a_wr "a wr inet\n"; my $b_input = <$b_rd>; chomp $b_input; ok( $b_input eq 'a wr inet', "two-way pipe passed data from a -> b unscathed" ); print $b_wr "b wr inet\n"; my $a_input = <$a_rd>; chomp $a_input; ok( $a_input eq 'b wr inet', "two-way pipe passed data from b -> a unscathed" ); } ### Test two-way socketpair. SKIP: { my ($a_rd, $a_wr, $b_rd, $b_wr) = POE::Pipe::TwoWay->new('socketpair'); skip "$^O does not support two-way socketpair", 2 unless defined $a_rd and defined $a_wr and defined $b_rd and defined $b_wr; print $a_wr "a wr inet\n"; my $b_input = <$b_rd>; chomp $b_input; ok( $b_input eq 'a wr inet', "two-way socketpair passed data from a -> b unscathed" ); print $b_wr "b wr inet\n"; my $a_input = <$a_rd>; chomp $a_input; ok( $a_input eq 'b wr inet', "two-way socketpair passed data from b -> a unscathed" ); } ### Test two-way inet sockets. SKIP: { unless (-f "run_network_tests") { skip "Network access (and permission) required to run inet test.", 2; } my ($a_rd, $a_wr, $b_rd, $b_wr) = POE::Pipe::TwoWay->new('inet'); skip "$^O does not support two-way inet pipes", 2 unless defined $a_rd and defined $a_wr and defined $b_rd and defined $b_wr; print $a_wr "a wr inet\n"; my $b_input = <$b_rd>; chomp $b_input; ok( $b_input eq 'a wr inet', "two-way inet pipe passed data from a -> b unscathed" ); print $b_wr "b wr inet\n"; my $a_input = <$a_rd>; chomp $a_input; ok( $a_input eq 'b wr inet', "two-way inet pipe passed data from b -> a unscathed" ); } exit 0; POE-1.368/t/10_units/02_pipes/01_base.t000644 001751 001751 00000000217 12143730314 017707 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More; print "1..0 # SKIP not implemented yet\n"; exit 0; POE-1.368/t/10_units/08_loops/11_double_loop.t000644 001751 001751 00000001121 12143730315 021317 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } TODO: { local $TODO = 'This needs to be investigated someday...'; # Hide warnings. { local $SIG{__WARN__} = sub { undef }; # This relies on the assumption that loading POE defaults to PoLo::Select! eval "use POE; use POE::Kernel { loop => 'IO_Poll' };"; } ok($@, "loading a loop throws an error if a loop was already loaded"); } POE-1.368/t/10_units/08_loops/01_explicit_loop.t000644 001751 001751 00000000562 12143730315 021675 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE", "Loop::Select") } is( $poe_kernel->poe_kernel_loop(), 'POE::Loop::Select', "POE loaded the right loop" ); POE-1.368/t/10_units/08_loops/10_naive_loop_load_poll.t000644 001751 001751 00000001401 12143730315 023174 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } TODO: { local $TODO = 'This feature is not implemented yet'; # Hide warnings. { local $SIG{__WARN__} = sub { undef }; eval "use POE::Loop::IO_Poll; use POE"; } ok(! $@, "Loading a loop the naive way doesn't explode"); # Hide warnings. my $loop_loaded; { local $SIG{__WARN__} = sub { undef }; eval '$loop_loaded = $poe_kernel->poe_kernel_loop()'; } if ( ! $@ ) { is( $loop_loaded, 'POE::Loop::IO_Poll', "POE loaded the right loop" ); } else { ok( 0, "Dummy test for TODO" ); } } POE-1.368/t/10_units/08_loops/09_naive_loop_load.t000644 001751 001751 00000001377 12143730315 022172 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } TODO: { local $TODO = 'This feature is not implemented yet'; # Hide warnings. { local $SIG{__WARN__} = sub { undef }; eval "use POE::Loop::Select; use POE"; } ok(! $@, "Loading a loop the naive way doesn't explode"); # Hide warnings. my $loop_loaded; { local $SIG{__WARN__} = sub { undef }; eval '$loop_loaded = $poe_kernel->poe_kernel_loop()'; } if ( ! $@ ) { is( $loop_loaded, 'POE::Loop::Select', "POE loaded the right loop" ); } else { ok( 0, "Dummy test for TODO" ); } } POE-1.368/t/10_units/08_loops/02_explicit_loop_fail.t000644 001751 001751 00000000622 12143730315 022666 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } # Hide warnings. { local $SIG{__WARN__} = sub { undef }; eval "use POE qw(Loop::NightMooseDontExist)"; } ok($@, "loading a nonexistent loop throws an error"); POE-1.368/t/10_units/08_loops/08_kernel_loop_search_poll.t000644 001751 001751 00000000600 12143730315 023707 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 3; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("IO::Poll") } BEGIN { use_ok("POE") } is( $poe_kernel->poe_kernel_loop(), 'POE::Loop::IO_Poll', "POE found the right loop" ); POE-1.368/t/10_units/08_loops/05_kernel_loop.t000644 001751 001751 00000000554 12143730315 021341 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE::Kernel") } is( $poe_kernel->poe_kernel_loop(), 'POE::Loop::Select', "POE loaded the default loop" ); POE-1.368/t/10_units/08_loops/07_kernel_loop_fail.t000644 001751 001751 00000000637 12143730315 022340 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } # Hide warnings. { local $SIG{__WARN__} = sub { undef }; eval "use POE::Kernel { loop => 'NightMooseDontExist' }"; } ok($@, "loading a nonexistent loop throws an error"); POE-1.368/t/10_units/08_loops/06_kernel_loop_poll.t000644 001751 001751 00000000603 12143730315 022363 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE::Kernel", { loop => 'IO_Poll' } ) } is( $poe_kernel->poe_kernel_loop(), 'POE::Loop::IO_Poll', "POE loaded the right loop" ); POE-1.368/t/10_units/08_loops/03_explicit_loop_poll.t000644 001751 001751 00000000564 12143730315 022727 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE", "Loop::IO_Poll") } is( $poe_kernel->poe_kernel_loop(), 'POE::Loop::IO_Poll', "POE loaded the right loop" ); POE-1.368/t/10_units/08_loops/04_explicit_loop_envvar.t000644 001751 001751 00000000632 12143730315 023257 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { $ENV{POE_EVENT_LOOP} = "POE::Loop::IO_Poll" } BEGIN { use_ok("POE") } is( $poe_kernel->poe_kernel_loop(), 'POE::Loop::IO_Poll', "POE loaded the right loop" ); POE-1.368/t/10_units/05_filters/04_line.t000644 001751 001751 00000014413 12356754444 020305 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Line without the rest of POE. use strict; use lib qw(./mylib ../mylib); use lib qw(t/10_units/05_filters); sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use TestFilter; use Test::More tests => 28 + $COUNT_FILTER_INTERFACE + 2*$COUNT_FILTER_STANDARD; use_ok("POE::Filter::Line"); test_filter_interface("POE::Filter::Line"); test_new("new(): even number of args", "one", "two", "odd"); test_new("new(): empty Literal", Literal => ""); # What is Regexp? I see InputRegexp, but not Regexp test_new("new(): Literal and Regexp", Regexp => "\r", Literal => "\n"); test_new("new(): Literal and InputRegexp", InputRegexp => "\r", Literal => "\n"); test_new("new(): Literal and InputLiteral", InputLiteral => "\r", Literal => "\n"); test_new("new(): Literal and OutputLiteral", OutputLiteral => "\r", Literal => "\n"); test_new("new(): InputLiteral and InputRegexp", InputRegexp => "\r", InputLiteral => "\n"); sub test_new { my ($name, @args) = @_; eval { POE::Filter::Line->new(@args); }; ok(!(!$@), $name); } # Test the line filter in default mode. { my $filter = POE::Filter::Line->new(); isa_ok($filter, 'POE::Filter::Line'); test_filter_standard( $filter, [ "a\x0D", "b\x0A", "c\x0D\x0A", "d\x0A\x0D" ], [ "a", "b", "c", "d" ], [ "a\x0D\x0A", "b\x0D\x0A", "c\x0D\x0A", "d\x0D\x0A" ], ); } # Test the line filter in literal mode. { my $filter = POE::Filter::Line->new( Literal => 'x' ); test_filter_standard( $filter, [ "axa", "bxb", "cxc", "dxd" ], [ "a", "ab", "bc", "cd" ], [ "ax", "abx", "bcx", "cdx" ], ); } # Test the line filter with different input and output literals. { my $filter = POE::Filter::Line->new( InputLiteral => 'x', OutputLiteral => 'y', ); my $received = $filter->get( [ "axa", "bxb", "cxc", "dxd" ] ); is_deeply( $received, [ "a", "ab", "bc", "cd" ], "different literals parsed input", ); my $sent = $filter->put( $received ); is_deeply( $sent, [ "ay", "aby", "bcy", "cdy" ], "different literals serialized output" ); } # Test the line filter with an input string regexp and an output # literal. { my $filter = POE::Filter::Line->new( InputRegexp => '[xy]', OutputLiteral => '!', ); my $received = $filter->get( [ "axa", "byb", "cxc", "dyd" ] ); is_deeply( $received, [ "a", "ab", "bc", "cd" ], "regexp parser parsed input" ); my $sent = $filter->put( $received ); is_deeply( $sent, [ "a!", "ab!", "bc!", "cd!" ], "regexp parser serialized output" ); } # Test the line filter with an input compiled regexp and an output # literal. SKIP: { skip("Perl $] doesn't support qr//", 2) if $] < 5.005; my $compiled_regexp = eval "qr/[xy]/"; my $filter = POE::Filter::Line->new( InputRegexp => $compiled_regexp, OutputLiteral => '!', ); my $received = $filter->get( [ "axa", "byb", "cxc", "dyd" ] ); is_deeply( $received, [ "a", "ab", "bc", "cd" ], "compiled regexp parser parsed input" ); my $sent = $filter->put( $received ); is_deeply( $sent, [ "a!", "ab!", "bc!", "cd!" ], "compiled regexp parser serialized output" ); } # Test newline autodetection. \x0D\x0A split between lines. { my $filter = POE::Filter::Line->new( InputLiteral => undef, OutputLiteral => '!', ); my @received; foreach ("a\x0d", "\x0Ab\x0D\x0A", "c\x0A\x0D", "\x0A") { my $local_received = $filter->get( [ $_ ] ); if (defined $local_received and @$local_received) { push @received, @$local_received; } } my $sent = $filter->put( \@received ); is_deeply( $sent, [ "a!", "b!", "c\x0A!" ], "autodetected MacOS newlines parsed and reserialized", ); } # Test newline autodetection. \x0A\x0D on first line. { my $filter = POE::Filter::Line->new( InputLiteral => undef, OutputLiteral => '!', ); # autodetect my @received; foreach ("a\x0A\x0D", "\x0Db\x0A\x0D", "c\x0D", "\x0A\x0D") { my $local_received = $filter->get( [ $_ ] ); if (defined $local_received and @$local_received) { push @received, @$local_received; } } my $sent = $filter->put( \@received ); is_deeply( $sent, [ "a!", "\x0Db!", "c\x0D!" ], "autodetected network newline parsed and reserialized" ); } # Test newline autodetection. \x0A by itself, with suspicion. { my $filter = POE::Filter::Line->new( InputLiteral => undef, OutputLiteral => '!', ); # autodetect my @received; foreach ("a\x0A", "b\x0D\x0A", "c\x0D", "\x0A") { my $local_received = $filter->get( [ $_ ] ); if (defined $local_received and @$local_received) { push @received, @$local_received; } } my $sent = $filter->put( \@received ); is_deeply( $sent, [ "a!", "b\x0D!", "c\x0D!" ], "autodetected Unix newlines parsed and reserialized" ); } # Test param constraints { my $filter = eval { new POE::Filter::Line( MaxLength => 10, MaxBuffer => 5 ); }; ok( $@, "MaxLength must not exceed MaxBuffer" ); ok( !$filter, "No object on error" ); $filter = eval { new POE::Filter::Line( MaxLength => -1 ) }; ok( $@, "MaxLength must be positive" ); $filter = eval { new POE::Filter::Line( MaxLength => 'something' ) }; ok( $@, "MaxLength must be a number" ); $filter = eval { new POE::Filter::Line( MaxBuffer => 0 ) }; ok( $@, "MaxBuffer must be positive" ); $filter = eval { new POE::Filter::Line( MaxBuffer => 'something' ) }; ok( $@, "MaxBuffer must be a number" ); } # Test MaxLength { my $filter = new POE::Filter::Line( MaxLength => 10 ); isa_ok( $filter, 'POE::Filter::Line' ); my $data = "This line is going to be to long for our filter\n"; my $blocks = eval { $filter->get( [ $data ] ) }; like( $@, qr/line exceeds/, "Line is to large" ); } # Test MaxBuffer { my $filter = new POE::Filter::Line( MaxBuffer => 10, MaxLength => 5 ); isa_ok( $filter, 'POE::Filter::Line' ); my $data = "This line is going to be to long for our filter\n"; my $blocks = eval { $filter->get( [ $data ] ) }; like( $@, qr/buffer exceeds/, "buffer grew to large" ); } POE-1.368/t/10_units/05_filters/01_block.t000644 001751 001751 00000012561 12356754444 020447 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Block without the rest of POE. Suddenly things # are looking a lot easier. use strict; use lib qw(./mylib ../mylib); use lib qw(t/10_units/05_filters); use TestFilter; use Test::More tests => 34 + $COUNT_FILTER_INTERFACE; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use_ok("POE::Filter::Block"); test_filter_interface("POE::Filter::Block"); # Test block filter in fixed-length mode. { my $filter = new POE::Filter::Block( BlockSize => 4 ); isa_ok( $filter, 'POE::Filter::Block' ); my $raw = $filter->put( [ "12345678" ] ); my $cooked = $filter->get( $raw ); is_deeply($cooked, [ "1234", "5678" ], "get() parses blocks"); my $reraw = $filter->put( $cooked ); is_deeply($reraw, [ "12345678" ], "put() serializes blocks"); } # Test block filter with get_one() functions. { my $filter = new POE::Filter::Block( BlockSize => 4 ); isa_ok( $filter, 'POE::Filter::Block' ); my $raw = $filter->put( [ "12345678" ] ); $filter->get_one_start( $raw ); my $cooked = $filter->get_one(); is_deeply($cooked, [ "1234" ], "get_one() parsed one block"); my $reraw = $filter->put( $cooked ); is_deeply($reraw, [ "1234" ], "put() serialized one block"); } # Test block filter in variable-length mode, without a custom codec. { my $filter = new POE::Filter::Block( ); isa_ok( $filter, 'POE::Filter::Block' ); my $raw = $filter->put([ "a", "bc", "def", "ghij" ]); my $cooked = $filter->get( $raw ); is_deeply( $cooked, [ "a", "bc", "def", "ghij" ], "get() parsed variable blocks" ); $cooked = $filter->get( [ "1" ] ); ok(!@$cooked, "get() doesn't return for partial input 1"); $cooked = $filter->get( [ "0" ] ); ok(!@$cooked, "get() doesn't return for partial input 0"); $cooked = $filter->get( [ "\0" ] ); ok(!@$cooked, "get() doesn't return for partial input end-of-header"); $cooked = $filter->get( [ "klmno" ] ); ok(!@$cooked, "get() doesn't return for partial input payload"); $cooked = $filter->get( [ "pqrst" ] ); is_deeply($cooked, [ "klmnopqrst" ], "get() returns payload"); my $raw_two = $filter->put( [ qw(a bc def ghij) ] ); is_deeply( $raw_two, [ "1\0a", "2\0bc", "3\0def", "4\0ghij" ], "variable length put() serializes multiple blocks" ); } # Test block filter in variable-length mode, with a custom codec. { sub encoder { my $stuff = shift; substr($$stuff, 0, 0) = pack("N", length($$stuff)); undef; } sub decoder { my $stuff = shift; return unless length $$stuff >= 4; my $packed = substr($$stuff, 0, 4); substr($$stuff, 0, 4) = ""; return unpack("N", $packed); } my $filter = new POE::Filter::Block( LengthCodec => [ \&encoder, \&decoder ], ); isa_ok( $filter, 'POE::Filter::Block' ); my $raw = $filter->put([ "a", "bc", "def", "ghij" ]); my $cooked = $filter->get( $raw ); is_deeply( $cooked, [ "a", "bc", "def", "ghij" ], "customi serializer parsed its own serialized data" ); $cooked = $filter->get( [ "\x00" ] ); ok(!@$cooked, "custom serializer did not parse partial header 1/4"); $cooked = $filter->get( [ "\x00" ] ); ok(!@$cooked, "custom serializer did not parse partial header 2/4"); $cooked = $filter->get( [ "\x00" ] ); ok(!@$cooked, "custom serializer did not parse partial header 3/4"); $cooked = $filter->get( [ "\x0a" ] ); ok(!@$cooked, "custom serializer did not parse partial header 4/4"); $cooked = $filter->get( [ "klmno" ] ); ok(!@$cooked, "custom serializer did not parse partial payload"); $cooked = $filter->get( [ "pqrst" ] ); is_deeply( $cooked, [ "klmnopqrst" ], "custom serializer parsed full payload" ); my $raw_two = $filter->put( [ qw(a bc def ghij) ] ); is_deeply( $raw_two, [ "\x00\x00\x00\x01a", "\x00\x00\x00\x02bc", "\x00\x00\x00\x03def", "\x00\x00\x00\x04ghij", ], "custom serializer serialized multiple payloads" ); } # Test param constraints { my $filter = eval { new POE::Filter::Block( MaxLength => 10, MaxBuffer => 5 ); }; ok( $@, "MaxLength must not exceed MaxBuffer" ); ok( !$filter, "No object on error" ); $filter = eval { new POE::Filter::Block( MaxLength => -1 ) }; ok( $@, "MaxLength must be positive" ); $filter = eval { new POE::Filter::Block( MaxLength => 'something' ) }; ok( $@, "MaxLength must be a number" ); $filter = eval { new POE::Filter::Block( MaxBuffer => 0 ) }; ok( $@, "MaxBuffer must be positive" ); $filter = eval { new POE::Filter::Block( MaxBuffer => 'something' ) }; ok( $@, "MaxBuffer must be a number" ); } # Test MaxLength { my $filter = new POE::Filter::Block( MaxLength => 10 ); isa_ok( $filter, 'POE::Filter::Block' ); my $data = "134\0a bunch of data here"; # partial block my $blocks = eval { $filter->get( [ $data ] ) }; like( $@, qr/block exceeds/, "Block is to large" ); } # Test MaxBuffer { my $filter = new POE::Filter::Block( MaxBuffer => 10, MaxLength => 5 ); isa_ok( $filter, 'POE::Filter::Block' ); my $data = "134\0a bunch of data here"; # partial block my $blocks = eval { $filter->get( [ $data ] ) }; like( $@, qr/buffer exceeds/, "buffer grew to large" ); } exit; POE-1.368/t/10_units/05_filters/50_stackable.t000644 001751 001751 00000011442 12143730314 021267 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Stack (and friends) without the rest of POE. use strict; use lib qw(./mylib ../mylib); sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More tests => 29; use_ok('POE::Filter::Stackable'); use_ok('POE::Filter::Grep'); use_ok('POE::Filter::Map'); use_ok('POE::Filter::RecordBlock'); use_ok('POE::Filter::Line'); # Create a filter stack to test. my $filter_stack = POE::Filter::Stackable->new( Filters => [ POE::Filter::Line->new( Literal => "!" ), # The next Map filter translates Put data from RecordBlock # (arrayrefs) into scalars for Line. On the Get side, it just # wraps parens around whatever Line returns. POE::Filter::Map->new( Put => sub { @$_ }, # scalarify puts Get => sub { "((($_)))" }, # transform gets ), POE::Filter::Grep->new( Put => sub { 1 }, # always put Get => sub { /1/ }, # only get /1/ ), # RecordBlock puts arrayrefs. They pass through Grep->Put # without change. RecordBlock receives whatever-- lines in this # case, but only ones that match /1/ from Grep->Get. POE::Filter::RecordBlock->new( BlockSize => 2 ), ] ); ok(defined($filter_stack), "filter stack created"); my $block = $filter_stack->get( [ "test one (1)!test two (2)!" ] ); ok(!@$block, "partial get returned nothing"); my $pending = $filter_stack->get_pending(); is_deeply( $pending, [ "(((test one (1))))" ], "filter stack has correct get_pending" ); $block = $filter_stack->get( [ "test three (3)!test four (100)!" ] ); is_deeply( $block, [ [ "(((test one (1))))", "(((test four (100))))" ] ], "filter stack returned correct data" ); # Make a copy of the block. Bad things happen when both blocks have # the same reference because we're passing by reference a lot. my $stream = $filter_stack->put( [ $block, $block ] ); is_deeply( $stream, [ "(((test one (1))))!", "(((test four (100))))!", "(((test one (1))))!", "(((test four (100))))!", ], "filter stack serialized correct data" ); # Test some of the discrete stackable filters by themselves. my @test_list = (1, 1, 2, 3, 5); # Map my $map = POE::Filter::Map->new( Code => sub { "((($_)))" } ); $map->get_one_start( [ @test_list ] ); my $map_pending = join '', @{$map->get_pending()}; ok($map_pending eq "11235", "map filter's parser buffer verifies"); foreach my $compare (@test_list) { my $next = $map->get_one(); is_deeply( $next, [ "((($compare)))" ], "map filter get_one() returns ((($compare)))" ); } my $map_next = $map->get_one(); ok(!@$map_next, "nothing left to get from map filter"); ### Go back and test more of Stackable. { my @filters_should_be = qw( POE::Filter::Line POE::Filter::Map POE::Filter::Grep POE::Filter::RecordBlock ); my @filters_are = $filter_stack->filter_types(); is_deeply(\@filters_are, \@filters_should_be, "filter types stacked correctly"); } # test pushing and popping { my @filters_strlist = map { "$_" } $filter_stack->filters(); my $filter_pop = $filter_stack->pop(); ok( ref($filter_pop) eq "POE::Filter::RecordBlock", "popped the correct filter" ); my $filter_shift = $filter_stack->shift(); ok( ref($filter_shift) eq 'POE::Filter::Line', "shifted the correct filter" ); $filter_stack->push( $filter_pop ); $filter_stack->unshift( $filter_shift ); my @filters_strlist_end = map { "$_" } $filter_stack->filters(); is_deeply(\@filters_strlist_end, \@filters_strlist, "repushed, reshifted filters are in original order"); } # push error checking { my @filters_strlist = map { "$_" } $filter_stack->filters(); eval { $filter_stack->push(undef) }; ok(!!$@, "undef is not a filter"); eval { $filter_stack->push(['i am not a filter']) }; ok(!!$@, "bare references are not filters"); eval { $filter_stack->push(bless(['i am not a filter'], "foo$$")) }; ok(!!$@, "random blessed references are not filters"); # not blessed into a package that ISA POE::Filter eval { $filter_stack->push(123, "two not-filter things") }; ok(!!$@, "multiple non-filters are not filters"); my @filters_strlist_end = map { "$_" } $filter_stack->filters(); is_deeply(\@filters_strlist_end, \@filters_strlist, "filters unchanged despite errors"); } # test cloning { my @filters_strlist = map { "$_" } $filter_stack->filters(); my @filter_types = $filter_stack->filter_types(); my $new_stack = $filter_stack->clone(); isnt("$new_stack", "$filter_stack", "cloned stack is different"); isnt(join('---', @filters_strlist), join('---', $new_stack->filters()), "filters are different"); is_deeply(\@filter_types, [$new_stack->filter_types()], "but types are the same"); } exit 0; POE-1.368/t/10_units/05_filters/99_filterchange.t000644 001751 001751 00000035574 12143730314 022022 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises filter changing. A lot of this code comes from Philip # Gwyn's filterchange.perl sample. use strict; use lib qw(./mylib ../mylib); use Test::More; use MyOtherFreezer; sub DEBUG () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw( Wheel::ReadWrite Driver::SysRW Filter::Block Filter::Line Filter::Reference Filter::Stream Pipe::OneWay Pipe::TwoWay ); # Showstopper here. Try to build a pair of file handles. This will # try a pair of pipe()s and socketpair(). If neither succeeds, then # all tests are skipped. Try socketpair() first, so that both methods # will be tested on my test platforms. # Socketpair. Read and write handles are the same. my ($master_read, $master_write, $slave_read, $slave_write) = ( POE::Pipe::TwoWay->new() ); unless (defined $master_read) { plan skip_all => "Could not create a pipe in any form." } # Set up tests, and go. plan tests => 41; ### Skim down to PARTIAL BUFFER TESTS to find the partial buffer ### get_pending tests. Those tests can run stand-alone without the ### event loop. ### Script for the master session. This is a send/expect thing, but ### the expected responses are implied by the commands that are sent. ### Normal master operation is: (1) send the command; (2) get ### response; (3) switch our filter if we sent a "do". Normal slave ### operation is: (1) get a command; (2) send response; (3) switch our ### filter if we got "do". # Tests: # (lin -> lin) (lin -> str) (lin -> ref) (lin -> blo) # (str -> lin) (str -> str) (str -> ref) (str -> blo) # (ref -> lin) (ref -> str) (ref -> ref) (ref -> blo) # (blo -> lin) (blo -> str) (blo -> ref) (blo -> blo) # Symbolic constants for mode names, so we don't make typos. sub LINE () { 'line' } sub STREAM () { 'stream' } sub REFERENCE () { 'reference' } sub BLOCK () { 'block' } # Commands to switch modes. sub DL () { 'do ' . LINE } sub DS () { 'do ' . STREAM } sub DR () { 'do ' . REFERENCE } sub DB () { 'do ' . BLOCK } # Script that drives the master session. my @master_script = ( DL, # line -> line 'rot13 1 kyriel', DS, # line -> stream 'rot13 2 addi', DS, # stream -> stream 'rot13 3 attyz', DL, # stream -> line 'rot13 4 crimson', DR, # line -> reference 'rot13 5 crysflame', DR, # reference -> reference 'rot13 6 dngor', DL, # reference -> line 'rot13 7 freeside', DB, # line -> block 'rot13 8 halfjack', DB, # block -> block 'rot13 9 lenzo', DS, # block -> stream 'rot13 10 mendel', DR, # stream -> reference 'rot13 11 purl', DB, # reference -> block 'rot13 12 roderick', DR, # block -> reference 'rot13 13 shizukesa', DS, # reference -> stream 'rot13 14 simon', DB, # stream -> block 'rot13 15 sky', DL, # o/` and that brings us back to line o/` 'rot13 16 stimps', 'done', ); ### Helpers to wrap payloads in mode-specific envelopes. Stream and ### line modes don't need envelopes. sub wrap_payload { my ($mode, $payload) = @_; if ($mode eq REFERENCE) { my $copy = $payload; $payload = \$copy; } return $payload; } sub unwrap_payload { my ($mode, $payload) = @_; $payload = $$payload if $mode eq REFERENCE; return $payload; } ### Slave session. This session is controlled by the master session. ### It's also the server, in the client/server context. sub slave_start { my $heap = $_[HEAP]; $heap->{wheel} = POE::Wheel::ReadWrite->new( InputHandle => $slave_read, OutputHandle => $slave_write, Filter => POE::Filter::Line->new(), Driver => POE::Driver::SysRW->new(), InputEvent => 'got_input', FlushedEvent => 'got_flush', ErrorEvent => 'got_error', ); $heap->{current_mode} = LINE; $heap->{shutting_down} = 0; DEBUG and warn "S: started\n"; } sub slave_stop { DEBUG and warn "S: stopped\n"; } sub slave_input { my ($heap, $input) = @_[HEAP, ARG0]; my $mode = $heap->{current_mode}; $input = unwrap_payload( $mode, $input ); DEBUG and warn "S: got $mode input: $input\n"; # Asking us to switch modes. Whee! if ($input =~ /^do (.+)$/) { my $response = "will $1"; if ($1 eq LINE) { $heap->{wheel}->put( wrap_payload( $mode, $response ) ); $heap->{wheel}->set_filter( POE::Filter::Line->new() ); $heap->{current_mode} = $1; } elsif ($1 eq STREAM) { $heap->{wheel}->put( wrap_payload( $mode, $response ) ); $heap->{wheel}->set_filter( POE::Filter::Stream->new() ); $heap->{current_mode} = $1; } elsif ($1 eq REFERENCE) { $heap->{wheel}->put( wrap_payload( $mode, $response ) ); $heap->{wheel}->set_filter( POE::Filter::Reference->new('MyOtherFreezer') ); $heap->{current_mode} = $1; } elsif ($1 eq BLOCK) { $heap->{wheel}->put( wrap_payload( $mode, $response ) ); $heap->{wheel}->set_filter( POE::Filter::Block->new() ); $heap->{current_mode} = $1; } # Don't know; don't care; why bother? else { $heap->{wheel}->put( wrap_payload( $mode, "wont $response" ) ); } DEBUG and warn "S: switched to $1 filter\n"; return; } # Asking us to respond in the current mode. Whee! if ($input =~ /^rot13\s+(\d+)\s+(.+)$/) { my ($test_number, $query, $response) = ($1, $2, $2); $response =~ tr[a-zA-Z][n-za-mN-ZA-M]; $heap->{wheel}->put( wrap_payload( $mode, "rot13 $test_number $query=$response" ) ); return; } # Telling us we're done. if ($input eq 'done') { DEBUG and warn "S: shutting down upon request\n"; $heap->{wheel}->put( wrap_payload( $mode, 'done' ) ); $heap->{shutting_down} = 1; return; } if ($input eq 'oops') { DEBUG and warn "S: got oops... shutting down\n"; delete $heap->{wheel}; } else { $heap->{wheel}->put( wrap_payload( $mode, 'oops' ) ); $heap->{shutting_down} = 1; } } sub slave_flush { my $heap = $_[HEAP]; if ($heap->{shutting_down}) { DEBUG and warn "S: shut down...\n"; delete $heap->{wheel}; } } sub slave_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; DEBUG and do { warn "S: got $operation error $errnum: $errstr\n"; warn "S: shutting down...\n"; }; delete $heap->{wheel}; } ### Master session. This session controls the tests. It's also the ### client, if you look at things from a client/server perspective. sub master_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{wheel} = POE::Wheel::ReadWrite->new( InputHandle => $master_read, OutputHandle => $master_write, Filter => POE::Filter::Line->new(), Driver => POE::Driver::SysRW->new(), InputEvent => 'got_input', FlushedEvent => 'got_flush', ErrorEvent => 'got_error', ); $heap->{current_mode} = LINE; $heap->{script_step} = 0; $heap->{shutting_down} = 0; $kernel->yield( 'do_cmd' ); DEBUG and warn "M: started\n"; } sub master_stop { DEBUG and warn "M: stopped\n"; } sub master_input { my ($kernel, $heap, $input) = @_[KERNEL, HEAP, ARG0]; my $mode = $heap->{current_mode}; $input = unwrap_payload( $mode, $input ); DEBUG and warn "M: got $mode input: $input\n"; # Telling us they've switched modes. Whee! if ($input =~ /^will (.+)$/) { if ($1 eq LINE) { $heap->{wheel}->set_filter( POE::Filter::Line->new() ); $heap->{current_mode} = $1; } elsif ($1 eq STREAM) { $heap->{wheel}->set_filter( POE::Filter::Stream->new() ); $heap->{current_mode} = $1; } elsif ($1 eq REFERENCE) { $heap->{wheel}->set_filter( POE::Filter::Reference->new('MyOtherFreezer') ); $heap->{current_mode} = $1; } elsif ($1 eq BLOCK) { $heap->{wheel}->set_filter( POE::Filter::Block->new() ); $heap->{current_mode} = $1; } # Don't know; don't care; why bother? else { die "dunno what $input means in real filter switching context"; } DEBUG and warn "M: switched to $1 filter\n"; $kernel->yield( 'do_cmd' ); return; } # Telling us a response in the current mode. if ($input =~ /^rot13\s+(\d+)\s+(.*?)=(.*?)$/) { my ($test_number, $query, $response) = ($1, $2, $3); $query =~ tr[a-zA-Z][n-za-mN-ZA-M]; ok( $query eq $response, "got rot13 response $response" ); $kernel->yield( 'do_cmd' ); return; } if ($input eq 'done') { DEBUG and warn "M: got done ACK; shutting down\n"; delete $heap->{wheel}; return; } if ($input eq 'oops') { DEBUG and warn "M: got oops... shutting down\n"; delete $heap->{wheel}; } else { $heap->{wheel}->put( wrap_payload( $mode, 'oops' ) ); $heap->{shutting_down} = 1; } } sub master_do_next_command { my ($kernel, $heap) = @_[KERNEL, HEAP]; my $script_step = $heap->{script_step}++; if ($script_step < @master_script) { DEBUG and warn( "M: is sending cmd $script_step: $master_script[$script_step]\n" ); $heap->{wheel}->put( wrap_payload( $heap->{current_mode}, $master_script[$script_step] ) ); } else { DEBUG and warn "M: is done sending commands...\n"; } } sub master_flush { my $heap = $_[HEAP]; if ($heap->{shutting_down}) { DEBUG and warn "S: shut down...\n"; delete $heap->{wheel}; } } sub master_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; DEBUG and do { warn "M: got $operation error $errnum: $errstr\n"; warn "M: shutting down...\n"; }; delete $heap->{wheel}; } ### Streamed session does just about everything together. # Streamed tests: # (lin -> lin) (lin -> ref) (lin -> blo) # (ref -> lin) (ref -> ref) (ref -> blo) # -blo -> lin) (blo -> ref) (blo -> blo) # Script that drives the streamed test session. It must be different # because "stream" eats everything all at once, ruining the data # beyond it. That's okay with handshaking (above), but not here. my @streamed_script = ( DL, # line -> line 'kyriel', DR, # line -> reference 'coral', DR, # reference -> reference 'drforr', DB, # reference -> block 'fimmtiu', DB, # block -> block 'sungo', DR, # block -> reference 'dynweb', DL, # reference -> line 'sky', DB, # line -> block 'braderuna', DL, # o/` and that brings us back to line o/` 'fletch', 'done', ); sub streamed_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; my ($read, $write) = POE::Pipe::OneWay->new(); die $! unless defined $read; $heap->{stream} = POE::Wheel::ReadWrite->new( InputHandle => $read, OutputHandle => $write, Filter => POE::Filter::Line->new(), Driver => POE::Driver::SysRW->new(), InputEvent => 'got_input', ErrorEvent => 'got_error', ); # Start in line mode. my $current_mode = $heap->{current_mode} = LINE; $heap->{errors} = $heap->{current_step} = 0; # Stream it all at once. Whee! foreach my $step (@streamed_script) { # Send whatever it is in the current mode. $heap->{stream}->put( wrap_payload( $current_mode, $step ) ); # Switch to the next mode if we should. if ($step =~ /^do (\S+)/) { $current_mode = $1; if ($current_mode eq LINE) { $heap->{stream}->set_output_filter( POE::Filter::Line->new() ), } elsif ($current_mode eq REFERENCE) { $heap->{stream}->set_output_filter( POE::Filter::Reference->new('MyOtherFreezer') ); } elsif ($current_mode eq BLOCK) { $heap->{stream}->set_output_filter( POE::Filter::Block->new() ), } else { die; } } } } sub streamed_input { my ($kernel, $heap, $wrapped_input) = @_[KERNEL, HEAP, ARG0]; my $input = unwrap_payload( $heap->{current_mode}, $wrapped_input ); ok( $input eq $streamed_script[$heap->{current_step}++], "unwrapped payload ($input) matches expectation" ); if ($input =~ /^do (\S+)/) { my $current_mode = $heap->{current_mode} = $1; if ($current_mode eq LINE) { $heap->{stream}->set_input_filter( POE::Filter::Line->new() ), } elsif ($current_mode eq REFERENCE) { $heap->{stream}->set_input_filter( POE::Filter::Reference->new('MyOtherFreezer') ); } elsif ($current_mode eq BLOCK) { $heap->{stream}->set_input_filter( POE::Filter::Block->new() ), } else { die; } return; } delete $heap->{stream} if $input eq 'done'; } ### Handshaking tests. # Start the slave/server session first. POE::Session->create( inline_states => { _start => \&slave_start, _stop => \&slave_stop, got_input => \&slave_input, got_flush => \&slave_flush, got_error => \&slave_error, } ); # Start the master/client session last. POE::Session->create( inline_states => { _start => \&master_start, _stop => \&master_stop, got_input => \&master_input, got_flush => \&master_flush, got_error => \&master_error, do_cmd => \&master_do_next_command, } ); ### Streamed filter transition tests. These are all run together. ### The object is to figure out how to unglom things. POE::Session->create( inline_states => { _start => \&streamed_start, _stop => sub { }, # placeholder for stricture test got_input => \&streamed_input, } ); # Begin the handshaking and streaming tests. I think this is an # improvement over forking. POE::Kernel->run(); ### PARTIAL BUFFER TESTS. (1) Create each test filter; (2) stuff each ### filter with a whole message and a part of one; (3) check that one ### whole message comes out; (4) check that get_pending returns the ### incomplete message; (5) check that get_pending again returns ### undef. # Line filter. { my $filter = POE::Filter::Line->new(); my $return = $filter->get( [ "whole line\x0D\x0A", "partial line" ] ); is_deeply( $return, [ "whole line" ], "parsed only whole line from input" ); my $pending = $filter->get_pending(); is_deeply( $pending, [ "partial line" ], "partial line is waiting in buffer" ); } # Block filter. { my $filter = POE::Filter::Block->new( BlockSize => 64 ); my $return = $filter->get( [ pack('A64', "whole block"), "partial block" ] ); is_deeply( $return, [ pack("A64", "whole block") ], "parsed only whole block from input" ); my $pending = $filter->get_pending(); is_deeply( $pending, [ "partial block" ], "partial block is waiting in buffer" ); } # Reference filter. { my $filter = POE::Filter::Reference->new(); my $original_reference = \"whole_reference"; my $serialized_reference = $filter->put( [ $original_reference ] ); my $return = $filter->get( [ $serialized_reference->[0], "100\0partial reference" ] ); is_deeply( $return, [ $original_reference ], "parsed only whole reference from input" ); my $pending = $filter->get_pending(); is_deeply( $pending, [ "100\0partial reference" ], "partial reference is waiting in buffer" ); } exit; POE-1.368/t/10_units/05_filters/08_stream.t000644 001751 001751 00000003213 12143730314 020631 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Stream without the rest of POE. use strict; use lib qw(./mylib ../mylib); use lib qw(t/10_units/05_filters); use TestFilter; use Test::More tests => 9 + $COUNT_FILTER_INTERFACE + $COUNT_FILTER_STANDARD; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use_ok("POE::Filter::Stream"); test_filter_interface("POE::Filter::Stream"); my $filter = POE::Filter::Stream->new; isa_ok($filter, 'POE::Filter::Stream'); my @test_fodder = qw(a bc def ghij klmno); # General test test_filter_standard( $filter, [qw(a bc def ghij klmno)], [qw(abcdefghijklmno)], [qw(abcdefghijklmno)], ); # Specific tests for stream filter { my $received = $filter->get( \@test_fodder ); ok( eq_array($received, [ 'abcdefghijklmno' ]), "received combined test items" ); } { my $sent = $filter->put( \@test_fodder ); ok( eq_array($sent, \@test_fodder), "sent each item discretely" ); } { $filter->get_one_start( \@test_fodder ); pass("get_one_start didn't die or anything"); } { my $pending = $filter->get_pending(); ok( eq_array($pending, [ 'abcdefghijklmno' ]), "pending data is correct" ); } { my $received = $filter->get_one(); ok( eq_array($received, [ 'abcdefghijklmno' ]), "get_one() got the right one, baby, uh-huh" ); } { my $received = $filter->get_one(); ok( eq_array($received, [ ]), "get_one() returned an empty array on empty buffer" ); } { my $pending = $filter->get_pending(); ok(!defined($pending), "pending data is empty"); } exit; POE-1.368/t/10_units/05_filters/07_reference.t000644 001751 001751 00000012276 12356754444 021324 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Reference without the rest of POE. use strict; use lib qw(./mylib ../mylib); use lib qw(t/10_units/05_filters); sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use TestFilter; use Test::More; use Symbol qw(delete_package); use POE::Filter::Reference; # Determine whether we can run these tests. BEGIN { local $SIG{__WARN__} = sub { }; my $reference = eval { POE::Filter::Reference->new(); }; if (length $@) { if ($@ =~ /requires Storable/) { plan skip_all => "These tests require Storable, FreezeThaw, or YAML."; } $@ =~ s/ at .*$//s; plan skip_all => $@; } } BEGIN { plan tests => 26 + $COUNT_FILTER_INTERFACE; } test_filter_interface('POE::Filter::Reference'); # A trivial, special-case serializer and reconstitutor. sub MyFreezer::freeze { my $thing = shift; return reverse(join "\0", ref($thing), $$thing) if ref($thing) eq 'SCALAR'; return reverse(join "\0", ref($thing), @$thing) if ref($thing) eq 'Package'; die; } sub MyFreezer::thaw { my $thing = reverse(shift); my ($type, @stuff) = split /\0/, $thing; if ($type eq 'SCALAR') { my $scalar = $stuff[0]; return \$scalar; } if ($type eq 'Package') { return bless \@stuff, $type; } die; } # Run some tests under a certain set of conditions. sub test_freeze_and_thaw { my ($freezer, $compression) = @_; my $scalar = 'this is a test'; my $scalar_ref = \$scalar; my $object_ref = bless [ 1, 1, 2, 3, 5 ], 'Package'; my $filter; eval { # Hide warnings. local $SIG{__WARN__} = sub { }; $filter = POE::Filter::Reference->new( Serializer=>$freezer, Compession=>$compression ); die "filter not created with freezer=$freezer" unless $filter; }; SKIP: { if (length $@) { $@ =~ s/[^\n]\n.*$//; skip $@, 1; } my $put = $filter->put( [ $scalar_ref, $object_ref ] ); my $got = $filter->get( $put ); $freezer = "undefined" unless defined $freezer; is_deeply( $got, [ $scalar_ref, $object_ref ], "$freezer successfully froze and thawed" ); } } # Test each combination of things. test_freeze_and_thaw(undef, undef); test_freeze_and_thaw(undef, 9 ); test_freeze_and_thaw('MyFreezer', undef); test_freeze_and_thaw('MyFreezer', 9 ); test_freeze_and_thaw('MyOtherFreezer', undef); test_freeze_and_thaw('MyOtherFreezer', 9 ); my $freezer = MyOtherFreezer->new(); test_freeze_and_thaw($freezer, undef); test_freeze_and_thaw($freezer, 9 ); # Test get_pending. my $pending_filter = POE::Filter::Reference->new(); my $frozen_thing = $pending_filter->put( [ [ 2, 4, 6 ] ] ); $pending_filter->get_one_start($frozen_thing); my $pending_thing = $pending_filter->get($pending_filter->get_pending()); is_deeply( $pending_thing, [ [ 2, 4, 6 ], [ 2, 4, 6 ] ], "filter reports proper pending data" ); # Drop MyOtherFreezer from the symbol table. delete_package('MyOtherFreezer'); # Create some "pretend" entries in the symbol table, to ensure that # POE::Filter::Reference loads the entire module if all needed methods # are not present. eval q{ sub never_called { return MyOtherFreezer::thaw(MyOtherFreezer::freeze(@_)); } }; die if $@; # Test each combination of things. test_freeze_and_thaw('MyOtherFreezer', undef); test_freeze_and_thaw('MyOtherFreezer', 9 ); # Test old constructor syntax { my $F1 = POE::Filter::Reference->new( 'Storable' ); isa_ok( $F1, "POE::Filter::Reference" ); my $F2 = POE::Filter::Reference->new( 'Storable', 1 ); isa_ok( $F2, "POE::Filter::Reference" ); my $d1 = $F1->put( [ ['honk honk honk honk'] ] )->[0]; my $d2 = $F2->put( [ ['honk honk honk honk'] ] )->[0]; isnt( $d1, $d2, "Different outputs with Compression on" ); ok( length( $d1 ) > length( $d2 ), "Compressed is (obviously) shorter" ); $F1 = POE::Filter::Reference->new( undef ); isa_ok( $F1, "POE::Filter::Reference" ); $F2 = POE::Filter::Reference->new( undef, undef, undef ); isa_ok( $F2, "POE::Filter::Reference" ); $d1 = $F1->put( [ ['honk honk honk honk'] ] )->[0]; $d2 = $F2->put( [ ['honk honk honk honk'] ] )->[0]; is( $d1, $d2, "Outputs are the same" ); $F1 = POE::Filter::Reference->new( undef, undef ); isa_ok( $F1, "POE::Filter::Reference" ); $F2 = POE::Filter::Reference->new( undef, undef, 1 ); isa_ok( $F2, "POE::Filter::Reference" ); $d1 = $F1->put( [ ['honk honk honk honk'] ] )->[0]; $d2 = $F2->put( [ ['honk honk honk honk'] ] )->[0]; is( $d1, $d2, "Outputs are the same" ); } # Test NoFatal { my $F1 = POE::Filter::Reference->new( NoFatals => 1 ); isa_ok( $F1, "POE::Filter::Reference" ); my $raw = "12\x00123456789012"; my $d = eval { $F1->get( [ $raw ] )->[0] }; ok( !$@, "Obvious error didn't explode" ); ok( !ref $d, "Instead it returned an error string" ); $F1 = POE::Filter::Reference->new( NoFatals => 1, MaxBuffer => 10 ); $d = eval { $F1->get( [ $raw ] )->[0] }; ok( !$@, "Buffer error didn't explode" ); like( $d, qr/buffer exceeds/, "Instead it returned an error string" ); } exit; POE-1.368/t/10_units/05_filters/06_recordblock.t000644 001751 001751 00000005620 12143730314 021631 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises POE::Filter::RecordBlock without the rest of POE use strict; use lib qw(t/10_units/05_filters); use TestFilter; use Test::More tests => 21 + $COUNT_FILTER_INTERFACE + $COUNT_FILTER_STANDARD; use_ok("POE::Filter::RecordBlock"); test_filter_interface("POE::Filter::RecordBlock"); # standard tests and blocksize { my $filter = POE::Filter::RecordBlock->new( BlockSize => 4 ); test_filter_standard( $filter, [qw/1 2 3 4 5 6 7 8 9 10/], [[qw/1 2 3 4/], [qw/5 6 7 8/]], [qw/1 2 3 4 5 6 7 8/], ); is($filter->blocksize(), 4, "blocksize() returns blocksize"); $filter->blocksize(2); is($filter->blocksize(), 2, "blocksize() can be changed"); eval { $filter->blocksize(undef) }; eval { local $^W = 0; $filter->blocksize("elephant") }; eval { $filter->blocksize(-50) }; eval { $filter->blocksize(0) }; is($filter->blocksize(), 2, "blocksize() rejects invalid sizes"); } # new() error checking { eval { POE::Filter::RecordBlock->new( BlockSize => 0 ) }; ok(!!$@, "BlockSize == 0 fails"); eval { POE::Filter::RecordBlock->new( ) }; ok(!!$@, "BlockSize must be given"); eval { local $^W = 0; POE::Filter::RecordBlock->new( BlockSize => "elephant" ) }; ok(!!$@, "BlockSize must not be an elephant"); eval { POE::Filter::RecordBlock->new( "one", "two", "odd number" ) }; ok(!!$@, "odd number of named parameters is invalid"); } # test checkput { my $filter = POE::Filter::RecordBlock->new( BlockSize => 3, CheckPut => 1 ); is_deeply( $filter->put( [[qw/1 2/], [qw/3 A/]] ), [qw/1 2 3/], "check put on: short blocks" ); is_deeply( $filter->put_pending(), [qw/A/], " put_pending" ); is_deeply( $filter->put( [[qw/2 3 1 2 3/], [qw/1 2 3 B/]] ), [qw/A 2 3 1 2 3 1 2 3/], "check put on: long blocks" ); is_deeply( $filter->put_pending(), [qw/B/], " put_pending" ); is_deeply( $filter->put( [[qw/2 3 1 2/], [qw/3 1/], [qw/2 3 1/], [qw/2 3/]] ), [qw/B 2 3 1 2 3 1 2 3 1 2 3/], "check put on: mixed blocks" ); ok(!defined($filter->put_pending()), " put_pending"); ok($filter->checkput(), "checkput() returns CheckPut flag"); $filter->checkput(0); ok(!$filter->checkput(), "checkput() can be changed"); } # test checkput can be turned off! { my $filter = POE::Filter::RecordBlock->new( BlockSize => 3 ); ok(!$filter->checkput(), "checkput() returns CheckPut flag"); is_deeply( $filter->put( [[qw/1 2/], [qw/1 2/]] ), [qw/1 2 1 2/], "check put off: short blocks" ); ok(!defined($filter->put_pending()), " put_pending is empty"); is_deeply( $filter->put( [[qw/1 2 3 4 5/], [qw/1 2 3 4/]] ), [qw/1 2 3 4 5 1 2 3 4/], "check put off: long blocks" ); is_deeply( $filter->put( [[qw/1 2 3 4/], [qw/1 2/], [qw/1 2 3/], [qw/1 2/]] ), [qw/1 2 3 4 1 2 1 2 3 1 2/], "check put off: mixed blocks" ); } POE-1.368/t/10_units/05_filters/TestFilter.pm000644 001751 001751 00000004272 12143730314 021273 0ustar00bingosbingos000000 000000 # filter testing utility functions package TestFilter; use strict; use Exporter; use vars qw(@ISA @EXPORT $COUNT_FILTER_INTERFACE $COUNT_FILTER_STANDARD); use Test::More; @ISA = qw/Exporter/; @EXPORT = qw/ $COUNT_FILTER_INTERFACE test_filter_interface $COUNT_FILTER_STANDARD test_filter_standard /; ## each of these needs the number of subtests documented ## export this in a variable # check interface exists $COUNT_FILTER_INTERFACE = 8; sub test_filter_interface { my $class = ref $_[0] || $_[0]; ok(UNIVERSAL::isa($class, 'POE::Filter'), '$class isa POE::Filter'); can_ok($class, 'new'); can_ok($class, 'get'); can_ok($class, 'get_one_start'); can_ok($class, 'get_one'); can_ok($class, 'put'); can_ok($class, 'get_pending'); can_ok($class, 'clone'); } # given a input, and the expected output run it through the filter in a few ways $COUNT_FILTER_STANDARD = 7; sub test_filter_standard { my ($filter, $in, $out, $put) = @_; { # first using get() my $records = $filter->get($in); is_deeply($records, $out, "get [standard test]"); } # now clone the filter which will clear the buffer { my $type = ref($filter); $filter = $filter->clone; ok(!defined($filter->get_pending()), "clone() clears buffer [standard test]"); is(ref($filter), $type, "clone() doesn't change filter type [standard test]"); } { # second using get_one() $filter->get_one_start($in); { my $pending = $filter->get_pending(); unless (ref($pending) eq 'ARRAY') { fail("get_pending() didn't return array"); } else { is(join('', @$pending), join('', @$in), "get_one_start() only loads buffer [standard test]"); } } my @records; my $ret_arrayref = 1; GET_ONE: while (my $r = $filter->get_one()) { unless (ref($r) eq 'ARRAY') { $ret_arrayref = 0; last GET_ONE; } last GET_ONE unless @{$r}; push @records, @{$r}; } ok($ret_arrayref, "get_one returns arrayref [standard test]"); is_deeply(\@records, $out, "get_one [standard test]"); } { # third using put() my $chunks = $filter->put($out); is_deeply($chunks, $put, "put [standard test]"); } } 1; POE-1.368/t/10_units/05_filters/03_http.t000644 001751 001751 00000046562 12472121170 020325 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Test Filter::HTTPD by itself # See other (forthcoming) for more complex interactions use strict; use lib qw(./mylib ../mylib); use Test::More; BEGIN { unless (-f 'run_network_tests') { plan skip_all => 'Need network access (and permission) for these tests'; } foreach my $req (qw(HTTP::Request HTTP::Request::Common HTTP::Status)) { eval "use $req"; if ($@) { plan skip_all => "$req is needed for these tests."; } } } BEGIN { plan tests => 137; } use_ok('POE::Filter::HTTPD'); # takes a object, and a hash { method_name => expected_value }, # and an optional name for the test # uses is(), so values are simple scalars sub check_fields { my ($object, $expected, $name) = @_; $name = $name ? "$name: " : ""; while (my ($method, $expected_value) = each %$expected) { is($object->$method, $expected_value, "$name$method"); } } sub check_error_response { my ($data, $code, $label) = @_; ok( (ref($data) eq 'ARRAY') && (scalar(@$data) == 1) && ($$data[0]->code == $code), $label ); } { # simple get {{{ my $filter = POE::Filter::HTTPD->new(); isa_ok($filter, 'POE::Filter::HTTPD'); my $get_request = HTTP::Request->new('GET', 'http://localhost/pie.mhtml'); my $records = $filter->get([ $get_request->as_string ]); is(ref($records), 'ARRAY', 'simple get: get() returns list of requests'); is(scalar(@$records), 1, 'simple get: get() returned single request'); my ($req) = @$records; isa_ok($req, 'HTTP::Request', 'simple get'); check_fields($req, { method => $get_request->method, url => $get_request->url, content => $get_request->content, }, "simple get"); } # }}} { # More complex get {{{ my $filter = POE::Filter::HTTPD->new(); my $get_data = q|GET /foo.html HTTP/1.0 User-Agent: Wget/1.8.2 Host: localhost:8080 Accept: */* Connection: Keep-Alive |; my $data = $filter->get([ $get_data ]); is(ref $data, 'ARRAY', 'HTTP 1.0 get: get() returns list of requests'); is(scalar @$data, 1, 'HTTP 1.0 get: get() returned single request'); my ($req) = @$data; isa_ok($req, 'HTTP::Request', 'HTTP 1.0 get'); check_fields($req, { method => 'GET', url => '/foo.html', content => '', }, "HTTP 1.0 get"); my %headers = ( 'User-Agent' => 'Wget/1.8.2', 'Host' => 'localhost:8080', 'Accept' => '*/*', 'Connection' => 'Keep-Alive', ); while (my ($k, $v) = each %headers) { is($req->header($k), $v, "HTTP 1.0 get: $k header"); } } # }}} { # simple post {{{ my $post_request = POST 'http://localhost/foo.mhtml', [ 'I' => 'like', 'tasty' => 'pie' ]; $post_request->protocol('HTTP/1.0'); my $filter = POE::Filter::HTTPD->new(); my $data = $filter->get([ $post_request->as_string ]); is(ref $data, 'ARRAY', 'simple post: get() returns list of requests'); is(scalar @$data, 1, 'simple post: get() returned single request'); my ($req) = @$data; isa_ok($req, 'HTTP::Request', 'simple post: get() returns HTTP::Request object'); check_fields($req, { method => 'POST', url => 'http://localhost/foo.mhtml', protocol => 'HTTP/1.0', }, "simple post"); # The HTTP::Request bundled with ActivePerl 5.6.1 causes a test # failure here. The one included in ActivePerl 5.8.3 works fine. # It was suggested by an anonymous bug reporter to test against # HTTP::Request's version rather than Perl's, so we're doing that # here. Theoretically we shouldn't get this far. The Makefile # magic should strongly suggest HTTP::Request 1.34. But people # install (or fail to) the darnedest things, so I thought it was # safe to check here rather than fail the test due to operator # error. SKIP: { my $required_http_request_version = 1.34; skip("simple post: Please upgrade HTTP::Request to $required_http_request_version or later", 1) if $^O eq "MSWin32" and $HTTP::Request::VERSION < $required_http_request_version; is($req->content, "I=like&tasty=pie", 'simple post: HTTP::Request object contains proper content'); is( length($req->content), $req->header('Content-Length'), 'simple post: Content is the right length'); } is($req->header('Content-Type'), 'application/x-www-form-urlencoded', 'simple post: HTTP::Request object contains proper Content-Type header'); } # }}} { # simple head {{{ my $head_request = HEAD 'http://localhost/foo.mhtml'; my $filter = POE::Filter::HTTPD->new(); my $data = $filter->get([ $head_request->as_string ]); is(ref $data, 'ARRAY', 'simple head: get() returns list of requests'); is(scalar @$data, 1, 'simple head: get() returned single request'); my ($req) = @$data; isa_ok($req, 'HTTP::Request', 'simple head: get() returns HTTP::Request object'); check_fields($req, { method => 'HEAD', url => 'http://localhost/foo.mhtml', }, "simple head"); } # }}} SKIP: { # simple put {{{ skip "PUT not supported yet", 5; my $put_request = PUT 'http://localhost/foo.mhtml'; my $filter = POE::Filter::HTTPD->new(); my $data = $filter->get([ $put_request->as_string ]); is(ref $data, 'ARRAY', 'simple put: get() returns list of requests'); is(scalar @$data, 1, 'simple put: get() returned single request'); my ($req) = @$data; isa_ok($req, 'HTTP::Request', 'simple put: get() returns HTTP::Request object'); check_fields($req, { method => 'PUT', url => 'http://localhost/foo.mhtml', }, "simple put"); } # }}} { # multipart form data post {{{ my $request = POST( 'http://localhost/foo.mhtml', Content_Type => 'form-data', content => [ 'I' => 'like', 'tasty' => 'pie', file => [ $0 ] ] ); $request->protocol('HTTP/1.0'); my $filter = POE::Filter::HTTPD->new(); my $data = $filter->get([ $request->as_string ]); is( ref($data), 'ARRAY', 'multipart form data: get() returns list of requests' ); is( scalar(@$data), 1, 'multipart form data: get() returned single request' ); my ($req) = @$data; isa_ok( $req, 'HTTP::Request', 'multipart form data: get() returns HTTP::Request object' ); check_fields($req, { method => 'POST', url => 'http://localhost/foo.mhtml', protocol => 'HTTP/1.0', }, "multipart form data"); if($] >= '5.006') { eval " like(\$req->header('Content-Type'), qr#multipart/form-data#, 'multipart form data: HTTP::Request object contains proper Content-Type header'); like(\$req->content, qr#&results;.*?exit;#s, 'multipart form data: content seems to contain all data sent'); "; } else { ok($req->header('Content-Type') =~ m{multipart/form-data}, "multipart form data: HTTP::Request object contains proper Content-Type header"); ok($req->content =~ m{&results;.*?exit;}s, 'multipart form data: content seems to contain all data sent'); } } # }}} { # options request {{{ my $request = HTTP::Request->new('OPTIONS', '*'); $request->protocol('HTTP/1.0'); my $filter = POE::Filter::HTTPD->new(); my $data = $filter->get([ $request->as_string ]); is(ref $data, 'ARRAY', 'options: get() returns list of requests'); is(scalar @$data, 1, 'options: get() returned single request'); my ($req) = @$data; isa_ok($req, 'HTTP::Request', 'options: get() returns HTTP::Request object'); check_fields($req, { method => 'OPTIONS', url => '*', protocol => 'HTTP/1.0', }, 'options'); } # }}} { # unless specified, version defaults to HTTP/0.9 in get {{{ my $req_str = <<'END'; GET / END my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ $req_str ]); my ($req) = @$data; isa_ok($req, 'HTTP::Request', 'HTTP/0.9 defaulting: get gives HTTP::Request'); check_fields($req, { method => 'GET', url => '/', protocol => 'HTTP/0.9', }, 'HTTP/0.9 defaulting'); } # }}} { # reconstruction from lots of fragments {{{ my $req = POST 'http://localhost:1234/foobar.html', [ 'I' => 'like', 'honey' => 'with peas' ]; $req->protocol('HTTP/1.1'); my $req_as_string = $req->as_string(); my @req_frags = ($req_as_string =~ m/(..)/sg); my $filter = POE::Filter::HTTPD->new; #my $pending_ok = 0; my $req_too_early; my @records; while (@req_frags) { my $data = $filter->get([ splice(@req_frags, 0, 2) ]); #$pending_ok++ if $filter->get_pending(); if (@req_frags) { $req_too_early++ if @$data; } push @records, @$data; } #ok($pending_ok, 'fragments: get_pending() non-empty at some point'); #is($filter->get_pending(), undef, 'fragments: get_pending() empty at end'); ok(!$req_too_early, "fragments: get() returning nothing until end"); is(scalar(@records), 1, 'fragments: only one request returned'); isa_ok($records[0], 'HTTP::Request', 'fragments: request isa HTTP::Request'); check_fields($req, { method => 'POST', url => 'http://localhost:1234/foobar.html', content => $req->content, }, 'fragments'); } # }}} { # trailing content on request {{{ my $req = HTTP::Request->new('GET', 'http://localhost:1234/foobar.html'); # request + trailing whitespace in one block == just request { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ $req->as_string . "\r\n \r\n\n" ]); is(ref($data), 'ARRAY', 'trailing: whitespace in block: ref'); is(scalar(@$data), 1, 'trailing: whitespace in block: one req'); isa_ok($$data[0], 'HTTP::Request', 'trailing: whitespace in block: HTTP::Request'); check_fields($req, { method => 'GET', url => 'http://localhost:1234/foobar.html' }, 'trailing: whitespace in block'); } # request + garbage together == request { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ $req->as_string . "GARBAGE!" ]); is(ref($data), 'ARRAY', 'trailing: garbage in block: ref'); is(scalar(@$data), 1, 'trailing: garbage in block: one req'); isa_ok($$data[0], 'HTTP::Request', 'trailing: garbage in block: HTTP::Request'); check_fields($req, { method => 'GET', url => 'http://localhost:1234/foobar.html' }, 'trailing: garbage in block'); } # request + trailing whitespace in separate block == just request { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ $req->as_string, "\r\n \r\n\n" ]); is(ref($data), 'ARRAY', 'trailing: extra whitespace packet: ref'); is(scalar(@$data), 1, 'trailing: extra whitespace packet: one req'); isa_ok($$data[0], 'HTTP::Request', 'trailing: extra whitespace packet: HTTP::Request'); check_fields($req, { method => 'GET', url => 'http://localhost:1234/foobar.html' }, 'trailing: extra whitespace packet'); } # request + trailing whitespace in separate get == just request { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ $req->as_string, "\r\n \r\n\n" ]); is(ref($data), 'ARRAY', 'trailing: extra whitespace get: ref'); is(scalar(@$data), 1, 'trailing: extra whitespace get: only one response'); $data = $filter->get([ "\r\n \r\n\n" ]); is(ref($data), 'ARRAY', 'trailing: whitespace by itself: ref'); is(scalar(@$data), 0, 'trailing: whitespace by itself: no req'); } # request + garbage in separate get == error { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ $req->as_string, "GARBAGE!\r\n\r\n" ]); is(ref($data), 'ARRAY', 'trailing: whitespace by itself: ref'); is(scalar(@$data), 2, 'trailing: whitespace by itself: no req'); isa_ok($data->[0], 'HTTP::Request'); isa_ok($data->[1], 'HTTP::Response'); } } # }}} SKIP: { # wishlist for supporting get_pending! {{{ local $TODO = 'add get_pending support'; skip $TODO, 1; my $filter = POE::Filter::HTTPD->new; eval { $filter->get_pending() }; ok(!$@, 'get_pending supported!'); } # }}} { # basic checkout of put {{{ my $res = HTTP::Response->new("404", "Not found"); my $filter = POE::Filter::HTTPD->new; use Carp; $SIG{__DIE__} = \&Carp::croak; my $chunks = $filter->put([$res]); is(ref($chunks), 'ARRAY', 'put: returns arrayref'); } # }}} SKIP: { # make sure the headers are encoded {{{ eval "use utf8"; skip "Don't have utf8", 5 if $@; my $utf8 = "En \xE9t\xE9"; utf8::upgrade( $utf8 ); ok( utf8::is_utf8( $utf8 ), "Make sure this is utf8" ); my $resp = HTTP::Response->new( "200", "OK" ); $resp->header( "X-Subject", $utf8 ); $resp->content( "\x00\xC3\xE7\xFF\x00" ); my $filter = POE::Filter::HTTPD->new; my $chunks = $filter->put([$resp]); is(ref($chunks), 'ARRAY', 'put: returns arrayref'); is( $#$chunks, 0, "One chunk" ); ok( !utf8::is_utf8( $chunks->[0] ), "Header was converted to iso-latin-1" ); like( $chunks->[0], qr/\x00\xC3\xE7\xFF\x00/, "Content wasn't corrupted" ); } # }}} { # really, really garbage requests get rejected, but goofy ones accepted {{{ { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ "ELEPHANT\n\r\n" ]); check_error_response($data, RC_BAD_REQUEST, 'garbage request line: bad request'); } { my $filter = POE::Filter::HTTPD->new; my $data = $filter->get([ "GET\t/elephant.gif\n\n" ]); isa_ok($$data[0], 'HTTP::Request', 'goofy request accepted'); check_fields($$data[0], { protocol => 'HTTP/0.9', method => 'GET', uri => '/elephant.gif', }, 'goofy request'); } } # }}} { # unsupported method {{{ { # bad request -- 0.9 so no length required my $filter = POE::Filter::HTTPD->new; my $req = HTTP::Request->new('ELEPHANT', '/'); my $data = $filter->get([ $req->as_string ]); check_fields($$data[0], { protocol => 'HTTP/0.9', method => 'ELEPHANT', uri => '/', }, 'strange method'); } { # bad request -- 1.1+Content-Encoding implies a body so length required my $filter = POE::Filter::HTTPD->new; my $req = HTTP::Request->new('ELEPHANT', 'http://localhost/'); $req->header( 'Content-Encoding' => 'mussa' ); $req->protocol('HTTP/1.1'); my $data = $filter->get([ $req->as_string ]); check_error_response($data, RC_LENGTH_REQUIRED, 'body indicated, not included: length required'); $req = $data->[0]->request; ok( $req, "body indicated, not included: got request" ); check_fields( $req, { protocol => 'HTTP/1.1', method => 'ELEPHANT', uri => 'http://localhost/' }, 'body indicated, not included' ); } } # }}} { # strange method {{{ my $filter = POE::Filter::HTTPD->new; my $req = HTTP::Request->new("GEt", "/"); my $parsed_req = $filter->get([ $req->as_string ])->[0]; check_fields( $parsed_req, { protocol => 'HTTP/0.9', method => 'GEt', uri => '/', }, "mixed case method" ); } # }}} { # strange request: GET with a body {{{ my $filter = POE::Filter::HTTPD->new; my $trap = HTTP::Request->new( "POST", "/trap.html" ); # IT'S A TRAP $trap->protocol('HTTP/1.1'); $trap->header( 'Content-Type' => 'text/plain' ); $trap->header( 'Content-Length' => 10 ); $trap->content( "HONK HONK\n" ); my $req = HTTP::Request->new("GET", "/"); $req->protocol('HTTP/1.1'); my $body = $trap->as_string; $req->header( 'Content-Length' => length $body ); $req->header( 'Content-Type' => 'text/plain' ); # include a HTTP::Request as body, to make sure we find only one request, # not 2 $req->content( $body ); my $data = $filter->get([ $req->as_string ]); is( 1, 0+@$data, "GET with body: one request" ); ok( ($data->[0]->content =~ /POST.+HONK HONK\n/s), "GET with body: content" ); check_fields( $data->[0], { protocol => 'HTTP/1.1', method => 'GET', uri => '/', }, "GET with body" ); # Same again with HEAD $req->method( 'HEAD' ); $data = $filter->get([ $req->as_string ]); is( 1, 0+@$data, "HEAD with body: one request" ); ok( ($data->[0]->content =~ /POST.+HONK HONK\n/s), "HEAD with body: content" ); check_fields( $data->[0], { protocol => 'HTTP/1.1', method => 'HEAD', uri => '/', }, "HEAD with body" ); } # }}} { # bad request: POST with a content-length {{{ my $filter = POE::Filter::HTTPD->new; # default 1 mb max my $req = HTTP::Request->new("POST", "/"); $req->protocol('HTTP/1.1'); $req->header( 'Content-Length' => 1024*1024*1024 ); # 1 GB $req->header( 'Content-Type' => 'text/plain' ); $req->content( "Nothing much" ); # but don't put a real 1 GB into content # (yes, the Content-Length is a lie!) my $data = $filter->get( [ $req->as_string ] ); isa_ok( $data->[0], 'HTTP::Response' ); ok( !$data->[0]->is_success, "Failed" ); is( $data->[0]->code, 413, "Content to big" ); # now try setting a different max size $filter = POE::Filter::HTTPD->new( MaxContent => 10 ); # make sure it stuck $req->header( 'Content-Length' => 5 ); $req->content( "honk\x0a" ); $data = $filter->get( [ $req->as_string ] ); isa_ok( $data->[0], 'HTTP::Request' ); is( $data->[0]->content, "honk\x0a", "Correct content" ); # make sure it fails $req->header( 'Content-Length' => 15 ); # doesn't take much to go over $req->content( "honk honk honk\x0a" ); $data = $filter->get( [ $req->as_string ] ); isa_ok( $data->[0], 'HTTP::Response' ); is( $data->[0]->code, 413, "Content to big" ); # now we play with a bad content-length $req->header( 'Content-Length' => 'fifteen' ); $data = $filter->get( [ $req->as_string ] ); isa_ok( $data->[0], 'HTTP::Response' ); is( $data->[0]->code, 400, "Bad request" ); } # }}} { # Streaming content upload {{{ my $filter = POE::Filter::HTTPD->new( Streaming=>1 ); # default 1 mb max my $req = HTTP::Request->new("POST", "/"); $req->protocol('HTTP/1.1'); $req->header( 'Content-Length' => 13 ); $req->header( 'Content-Type' => 'text/plain' ); $req->content( "Nothing much\n" ); my $data = $filter->get( [ $req->as_string ] ); isa_ok( $data->[0], 'HTTP::Request' ); is( $data->[0]->content, "", "No content" ); is( $data->[1], "Nothing much\n", "The content comes next" ); } # }}} # Test param constraints { my $filter = eval { new POE::Filter::HTTPD( MaxLength => 10, MaxBuffer => 5 ); }; ok( $@, "MaxContent must not exceed MaxBuffer" ); ok( !$filter, "No object on error" ); $filter = eval { new POE::Filter::HTTPD( MaxContent => -1 ) }; ok( $@, "MaxContent must be positive" ); $filter = eval { new POE::Filter::HTTPD( MaxContent => 'something' ) }; ok( $@, "MaxContent must be a number" ); $filter = eval { new POE::Filter::HTTPD( MaxBuffer => 0 ) }; ok( $@, "MaxBuffer must be positive" ); $filter = eval { new POE::Filter::HTTPD( MaxBuffer => 'something' ) }; ok( $@, "MaxBuffer must be a number" ); } # Test MaxBuffer { my $filter = new POE::Filter::HTTPD( MaxBuffer => 10, MaxContent => 5 ); isa_ok( $filter, 'POE::Filter::HTTPD' ); my $data = "This line is going to be to long for our filter\n"; my $blocks = eval { $filter->get( [ $data ] ) }; like( $@, qr/buffer exceeds/, "buffer grew to large" ); } POE-1.368/t/10_units/05_filters/51_reference_die.t000644 001751 001751 00000004446 12715047633 022136 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 expandtab use warnings; use strict; use POE::Filter::Reference; use Test::More; BEGIN { eval 'use YAML'; if ($@) { plan skip_all => 'YAML module not available'; } else { plan tests => 5; } } # Create a YAML stream a la Perl. # Baseline. Verify the basic YAML is liked. my $test_data = { test => 1, foo => [1, 2], bar => int(rand(999)), }; my $basic_yaml = YAML::Dump($test_data); # Baseline test. Make sure the Perl YAML can be decoded. ok( doesnt_die($basic_yaml), "basic yaml doesn't die" ); # Some YAML producers don't include newlines. # This reportedly causes problems for Perl's YAML parser. { my $no_newline_yaml = $basic_yaml; chomp $no_newline_yaml; SKIP: { skip 'Missing newlines are allowed since YAML 1.15', 2 if $YAML::VERSION >= 1.15; ok( dies_when_allowed($no_newline_yaml), "yaml without newlines dies when allowed" ); ok( exception_caught($no_newline_yaml), "yaml without newlines returns error when caught" ); } } # YAML supports a "...\n" record terminator. # Perl's YAML is reported to dislike this. { my $terminated_yaml = $basic_yaml . "...\n"; ok( dies_when_allowed($terminated_yaml), "terminated_yaml dies when allowed" ); ok( exception_caught($terminated_yaml), "terminated_yaml returns error when caught" ); } exit; sub doesnt_die { my $yaml = shift(); my $pfr = POE::Filter::Reference->new('YAML', 0, 0); my $encoded = length($yaml) . "\0" . $yaml; my $decoded = $pfr->get([ $encoded ]); return( defined($decoded) && (ref($decoded) eq 'ARRAY') && (@$decoded == 1) && (ref($decoded->[0]) eq 'HASH') ); } sub dies_when_allowed { my $yaml = shift(); my $pfr = POE::Filter::Reference->new('YAML', 0, 0); my $encoded = length($yaml) . "\0" . $yaml; $@ = undef; my $decoded = eval { $pfr->get([ $encoded ]); }; return !!$@; } sub exception_caught { my $yaml = shift(); my $pfr = POE::Filter::Reference->new('YAML', 0, 1); my $encoded = length($yaml) . "\0" . $yaml; my $decoded = eval { $pfr->get([ $encoded ]); }; return( defined($decoded) && (ref($decoded) eq 'ARRAY') && (@$decoded == 1) && (ref($decoded->[0]) eq '') ); } POE-1.368/t/10_units/05_filters/05_map.t000644 001751 001751 00000004146 12143730314 020116 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Map without POE use strict; use lib qw(./mylib ../mylib); use lib qw(t/10_units/05_filters); use TestFilter; use Test::More tests => 19 + $COUNT_FILTER_INTERFACE; use_ok('POE::Filter::Map'); test_filter_interface('POE::Filter::Map'); # Test erroneous new() args test_new("No Args"); test_new("Odd number of args", "one", "two", "odd"); test_new("Non code CODE ref", Code => [ ]); test_new("Single Get ref", Get => sub { }); test_new("Single Put ref", Put => sub { }); test_new("Non CODE Get", Get => [ ], Put => sub { }); test_new("Non CODE Put", Get => sub { }, Put => [ ]); sub test_new { my $name = shift; my @args = @_; my $filter; eval { $filter = POE::Filter::Map->new(@args); }; ok($@ ne '', $name); } my $filter; # Test actual mapping of Get, Put, and Code $filter = POE::Filter::Map->new( Get => sub { uc }, Put => sub { lc } ); is_deeply($filter->put([qw/A B C/]), [qw/a b c/], "Test Put"); is_deeply($filter->get([qw/a b c/]), [qw/A B C/], "Test Get"); $filter = POE::Filter::Map->new(Code => sub { uc }); is_deeply($filter->put([qw/a b c/]), [qw/A B C/], "Test Put (as Code)"); is_deeply($filter->get([qw/a b c/]), [qw/A B C/], "Test Get (as Code)"); $filter = POE::Filter::Map->new( Get => sub { 'GET' }, Put => sub { 'PUT' } ); # Test erroneous modification TODO: { local $TODO = "modify() carps rather than dieing"; local $SIG{__WARN__} = sub { }; test_modify("Modify Get not CODE ref", $filter, Get => [ ]); test_modify("Modify Put not CODE ref", $filter, Put => [ ]); test_modify("Modify Code not CODE ref", $filter, Code => [ ]); } sub test_modify { my ($name, $filter, @args) = @_; eval { $filter->modify(@args); }; ok($@ ne '', $name); } $filter->modify(Get => sub { 'NGet' }); is_deeply($filter->get(['a']), ['NGet'], "Modify Get"); $filter->modify(Put => sub { 'NPut' }); is_deeply($filter->put(['a']), ['NPut'], "Modify Put"); $filter->modify(Code => sub { 'NCode' }); is_deeply($filter->put(['a']), ['NCode'], "Modify Code "); is_deeply($filter->get(['a']), ['NCode'], "Modify Code "); POE-1.368/t/10_units/05_filters/02_grep.t000644 001751 001751 00000006337 12143730314 020277 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Exercises Filter::Grep without POE use strict; use lib qw(./mylib ../mylib); use lib qw(t/10_units/05_filters); use Data::Dumper; $Data::Dumper::Indent=1; use TestFilter; use Test::More tests => 26 + $COUNT_FILTER_INTERFACE + 2*$COUNT_FILTER_STANDARD; use_ok("POE::Filter::Grep"); test_filter_interface("POE::Filter::Grep"); # Test erroneous new() args test_new("No Args"); test_new("even", "one", "two", "odd"); test_new("Non code CODE ref", Code => [ ]); test_new("Single Get ref", Get => sub { }); test_new("Single Put ref", Put => sub { }); test_new("Non CODE Get", Get => [ ], Put => sub { }); test_new("Non CODE Put", Get => sub { }, Put => [ ]); sub test_new { my $name = shift; my @args = @_; my $filter; eval { $filter = POE::Filter::Grep->new(@args); }; ok(!(!$@), $name); } # Test actual mapping of Get, Put, and Code { # Test Get and Put my $filter = POE::Filter::Grep->new( Get => sub { /\d/ }, Put => sub { /[a-zA-Z]/ } ); is_deeply($filter->put([qw/A B C 1 2 3/]), [qw/A B C/], "Test Put"); is_deeply($filter->get([qw/a b c 1 2 3/]), [qw/1 2 3/], "Test Get"); test_filter_standard( $filter, [qw/a b c 1 2 3/], [qw/1 2 3/], [qw//], ); } { # Test Code my $filter = POE::Filter::Grep->new(Code => sub { /(\w)/ }); is_deeply($filter->put([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Test Put (as Code)"); is_deeply($filter->get([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Test Get (as Code)"); test_filter_standard( $filter, [qw/a b c 1 2 3 ! @/], [qw/a b c 1 2 3/], [qw/a b c 1 2 3/], ); } { my $filter = POE::Filter::Grep->new( Get => sub { /1/ }, Put => sub { /1/ } ); # Test erroneous modification test_modify("Modify Get not CODE ref", $filter, Get => [ ]); test_modify("Modify Put not CODE ref", $filter, Put => [ ]); test_modify("Modify Code not CODE ref", $filter, Code => [ ]); test_modify("Modify with invalid key", $filter, Elephant => sub { }); sub test_modify { my ($name, $filter, @args) = @_; local $SIG{__WARN__} = sub { }; eval { $filter->modify(@args); }; ok(defined $@, $name); } $filter->modify(Get => sub { /\d/ }); is_deeply($filter->get([qw/a b c 1 2 3/]), [qw/1 2 3/], "Modify Get"); $filter->modify(Put => sub { /[a-zA-Z]/ }); is_deeply($filter->put([qw/A B C 1 2 3/]), [qw/A B C/], "Modify Put"); $filter->modify(Code => sub { /(\w)/ }); is_deeply($filter->put([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Modify Put (as Code)"); is_deeply($filter->get([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Modify Get (as Code)"); } # Grep (from stackable's tests) -- testing get_pending { my @test_list = (1, 1, 2, 3, 5); my $grep = POE::Filter::Grep->new( Code => sub { $_ & 1 } ); $grep->get_one_start( [ @test_list ] ); my $grep_pending = join '', @{$grep->get_pending()}; ok($grep_pending eq '11235', "grep filter's parser buffer verifies"); foreach my $compare (@test_list) { next unless $compare & 1; my $next = $grep->get_one(); is_deeply($next, [ $compare ], "grep filter get_one() returns [$compare]"); } my $grep_next = $grep->get_one(); ok(!@$grep_next, "nothing left to get from grep filter"); } POE-1.368/t/10_units/03_base/01_poe.t000644 001751 001751 00000001365 12143730315 017361 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 4; BEGIN { eval "use POE"; ok(!$@, "you just saved a kitten"); } # Start with errors. eval { POE->import( qw( NFA Session ) ) }; ok( $@ && $@ =~ /export conflicting constants/, "don't import POE::NFA and POE::Session together" ); open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; eval { POE->import( qw( nonexistent ) ) }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok( $@ && $@ =~ /could not import qw\(nonexistent\)/, "don't import nonexistent modules" ); eval {POE->import( qw( Loop::Foo Loop::Bar) ) }; ok( $@ && $@ =~ /multiple event loops/, "don't load more than one event loop" ); exit 0; POE-1.368/t/10_units/03_base/07_queue.t000644 001751 001751 00000000412 12143730315 017720 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; BEGIN { use_ok("POE::Queue") } eval { my $x = POE::Queue->new() }; ok( $@ && $@ =~ /not meant to be used directly/, "don't instantiate POE::Queue" ); exit 0; POE-1.368/t/10_units/03_base/09_resources.t000644 001751 001751 00000005236 12143730314 020620 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 7; use_ok('POE::Resources'); { my $failure_happened; my %requires; local *CORE::GLOBAL::require = sub { my $name = shift; my ($resource) = $name =~ m{Resource(?:/|::)(\w+)}; my $xs = $name =~ m{(?:/|::)XS(?:/|::)}; # a state machine my $state = $requires{$resource}; my $visible_state = $state || "undef"; $requires{$resource} = "test bug: no new state! (from: $visible_state)"; unless (defined $state) { # should be looking for XS version first if ($xs) { if (keys(%requires) % 2) { $requires{$resource} = "use non XS"; die "Can't locate $name in \@INC (this is a fake error)\n"; } else { $requires{$resource} = "ok: using XS"; } } else { # woops! a bug! $requires{$resource} = "bug: XS load wasn't first: $name"; } } elsif ($state eq 'use non XS') { if (not $xs) { $requires{$resource} = "ok: using non XS"; # test that errors propagate out of initialize properly if (keys(%requires) > 6) { $failure_happened = "happened"; die "Can't locate $name in \@INC (this is a fake error #2)\n"; } } else { $requires{$resource} = "bug: multiple XS loads"; } } }; eval { POE::Resources->load(); }; if ($@ =~ /fake error #2/) { $failure_happened = "seen"; } elsif ($@) { die $@ } # analyse the final state and produce test results my @requires = map [$_, $requires{$_}], keys %requires; ok( 0 < grep($_->[1] =~ /^ok: using XS/, @requires), "can use XS versions" ); ok( 0 < grep($_->[1] =~ /^ok: using non XS/, @requires), "can use non-XS versions" ); { my @fails = grep($_->[1] !~ /^ok:/, @requires); diag("$_->[0]: $_->[1]") for @fails; ok( 0 == @fails, "all module loads successful" ); } SKIP: { skip "Resources didn't try to load enough resources to trigger this test", 1 unless defined $failure_happened; is( $failure_happened, 'seen', 'initialized rethrows loading errors'); } } { my $failure_happened; local *CORE::GLOBAL::require = sub { unless (defined $failure_happened) { $failure_happened = "happened"; die "really bad error (this is fake error #3)\n"; } else { $failure_happened = "require called more than once!"; } }; eval { POE::Resources->load(); }; if ($@ =~ /fake error #3/) { $failure_happened = "seen"; } elsif ($@) { die $@ } ok( defined $failure_happened, 'initialize ran and encountered error' ); is( $failure_happened, 'seen', 'caught error' ); } exit 0; POE-1.368/t/10_units/03_base/03_component.t000644 001751 001751 00000000222 12143730314 020570 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 1; BEGIN { use_ok("POE::Component") } exit 0; POE-1.368/t/10_units/03_base/14_kernel.t000644 001751 001751 00000001362 12143730314 020056 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # This file contains tests for the _public_ POE::Kernel interface use strict; use Test::More tests => 6; use vars qw($poe_kernel); BEGIN { use_ok("POE::Kernel"); } # Start with errors. eval { POE::Kernel->import( 'foo' ) }; ok( $@ && $@ =~ /expects its arguments/, "fails without a hash ref" ); eval { POE::Kernel->import( { foo => "bar" } ) }; ok( $@ && $@ =~ /import arguments/, "fails with bogus hash ref" ); eval { POE::Kernel->import( { loop => "Loop::Select" } ) }; ok( !$@, "specifying which loop to load works" ); ok( defined($poe_kernel), "POE::Kernel exports $poe_kernel" ); ok( UNIVERSAL::isa($poe_kernel, "POE::Kernel"), " which contains a kernel" ); exit 0; POE-1.368/t/10_units/03_base/17_detach_start.t000644 001751 001751 00000003410 12143730314 021242 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 sts=2 ft=perl expandtab use strict; $| = 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More tests => 14; use POE; my $seq = 0; my $_child_fired = 0; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set('Parent'); is(++$seq, 1, "_start Parent"); POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set('Child'); is(++$seq, 2, "_start Child"); }, _stop => sub { is(++$seq, 6, "_stop Child"); }, }, ); POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set('Detached'); is(++$seq, 4, "_start Detached"); #diag "Detaching session 'Detached' from its parent"; $_[KERNEL]->detach_myself; }, _parent => sub { is(++$seq, 5, "_parent Detached"); ok($_[ARG1]->isa("POE::Kernel"), "child parent is POE::Kernel"); }, _stop => sub { $seq++; ok($seq == 8 || $seq == 9, "_stop Detached"); }, }, ); }, _child => sub { $seq++; ok($seq == 3 || $seq == 7, "_child Parent"); $_child_fired++; ok( $_[KERNEL]->alias_list($_[ARG1]) ne 'Detached', "$_[STATE]($_[ARG0]) fired for " . $_[KERNEL]->alias_list($_[ARG1]->ID) ); }, _stop => sub { $seq++; ok($seq == 8 || $seq == 9, "_stop Parent"); }, }, ); POE::Kernel->run(); pass "_child not fired for session detached in _start" unless ( $_child_fired != 2 ); pass "Stopped"; POE-1.368/t/10_units/03_base/06_loop.t000644 001751 001751 00000000215 12143730314 017544 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 1; BEGIN { use_ok("POE::Loop") } exit 0; POE-1.368/t/10_units/03_base/16_nfa_usage.t000644 001751 001751 00000003070 12143730314 020526 0ustar00bingosbingos000000 000000 use strict; # vim: ts=2 sw=2 filetype=perl expandtab package main; use Test::More tests => 11; use POE::NFA; my $nfa; eval { POE::NFA->spawn('foo') }; like($@, qr/odd number/, 'NFA treats its params as a hash'); eval { POE::NFA->spawn(inline_states => {initial => { start => sub { 0 } } }) }; like($@, qr/requires a working Kernel/, 'NFA needs a working kernel'); eval "use POE::Kernel"; eval { POE::NFA->spawn(crap => 'foo'); }; like($@, qr/constructor requires at least one of/, 'need states'); eval { $nfa = POE::NFA->spawn(inline_states => {initial => { start => sub { 0 } } }) }; isa_ok($nfa, 'POE::NFA', 'most basic machine'); eval { POE::NFA->spawn(inline_states => {initial => { start => sub { 0 } } }, crap => 'foo') }; like($@, qr/constructor does not recognize/, 'unknown parameter'); eval { POE::NFA->spawn(package_states => {initial => 'foo'}); }; like($@, qr/the data for state/, 'bad state data'); eval { POE::NFA->spawn(package_states => {initial => ['Foo']}); }; like($@, qr/the array for state/, 'bad state data'); eval { POE::NFA->spawn(package_states => {initial => ['Foo' => 'bar']}); }; like($@, qr/need to be a hash or array ref/, 'bad event data'); eval { $nfa = POE::NFA->spawn(package_states => {initial => ['Foo' => [qw(foo bar)]]}); }; isa_ok($nfa, 'POE::NFA', 'spawn with package_states'); eval { $nfa = POE::NFA->spawn(package_states => {initial => ['Foo' => [qw(foo bar)]]}, runstate => [ ] ); }; isa_ok($nfa, 'POE::NFA', 'spawn with package_states'); is( ref $nfa->[0], 'ARRAY', 'RUNSTATE is an ARRAYREF' ); POE::Kernel->run; POE-1.368/t/10_units/03_base/11_assert_usage.t000644 001751 001751 00000026214 12276766765 021315 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Test the ASSERT_USAGE code in POE::Kernel. This involves a lot of # dying. use strict; use lib qw(./mylib); use Test::More tests => 76; use Symbol qw(gensym); BEGIN { delete $ENV{POE_ASSERT_USAGE}; } sub POE::Kernel::ASSERT_USAGE () { 1 } #sub POE::Kernel::TRACE_REFCNT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # Disable any "didn't call run" warnings. We create a bunch of # sessions, but we're not testing whether they run. Furthermore, they # may leave alarms or filehandles selected, which could cause the # program to hang if we DO try to run it. POE::Kernel->run(); # Test usage outside a running session. foreach my $method ( qw( alarm alarm_add alarm_adjust alarm_remove alarm_remove_all alarm_set delay delay_add delay_adjust delay_set detach_child detach_myself select select_expedite select_pause_read select_pause_write select_read select_resume_read select_resume_write select_write sig state yield ) ) { my $message = "must call $method() from a running session"; eval { $poe_kernel->$method() }; ok( $@ && $@ =~ /\Q$message/, $message ); } # Signal functions. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->sig(undef) }; ok($@ && $@ =~ /undefined signal in sig/, "undefined signal assertion"); eval { $poe_kernel->signal(undef) }; ok( $@ && $@ =~ /undefined destination in signal/, "undefined destination in signal" ); eval { $poe_kernel->signal($poe_kernel, undef) }; ok( $@ && $@ =~ /undefined signal in signal/, "undefined signal in signal" ); } } ); # Internal _dispatch_event() function. # TODO - Determine whether it needs ASSERT_USAGE checks. # Post, yield, call. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->post(undef) }; ok( $@ && $@ =~ /destination is undefined in post/, "destination undefined in post" ); eval { $poe_kernel->post($poe_kernel, undef) }; ok( $@ && $@ =~ /event is undefined in post/, "event undefined in post" ); eval { $poe_kernel->yield(undef) }; ok( $@ && $@ =~ /event name is undefined in yield/, "event undefined in yield" ); eval { $poe_kernel->call(undef) }; ok( $@ && $@ =~ /destination is undefined in call/, "destination undefined in call" ); eval { $poe_kernel->call($poe_kernel, undef) }; ok( $@ && $@ =~ /event is undefined in call/, "event undefined in call" ); } } ); # Classic alarms. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->alarm(undef) }; ok( $@ && $@ =~ /event name is undefined in alarm/, "event undefined in alarm" ); eval { $poe_kernel->alarm_add(undef) }; ok( $@ && $@ =~ /undefined event name in alarm_add/, "event undefined in alarm_add" ); eval { $poe_kernel->alarm_add(moo => undef) }; ok( $@ && $@ =~ /undefined time in alarm_add/, "time undefined in alarm_add" ); eval { $poe_kernel->delay(undef) }; ok( $@ && $@ =~ /undefined event name in delay/, "event undefined in delay" ); eval { $poe_kernel->delay_add(undef) }; ok( $@ && $@ =~ /undefined event name in delay_add/, "event undefined in delay_add" ); eval { $poe_kernel->delay_add(moo => undef) }; ok( $@ && $@ =~ /undefined time in delay_add/, "time undefined in delay_add" ); } } ); # New alarms. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->alarm_set(undef) }; ok( $@ && $@ =~ /undefined event name in alarm_set/, "event undefined in alarm_set" ); eval { $poe_kernel->alarm_set(moo => undef) }; ok( $@ && $@ =~ /undefined time in alarm_set/, "time undefined in alarm_set" ); eval { $poe_kernel->alarm_remove(undef) }; ok( $@ && $@ =~ /undefined alarm id in alarm_remove/, "alarm ID undefined in alarm_remove" ); eval { $poe_kernel->alarm_adjust(undef) }; ok( $@ && $@ =~ /undefined alarm id in alarm_adjust/, "alarm ID undefined in alarm_adjust" ); eval { $poe_kernel->alarm_adjust(moo => undef) }; ok( $@ && $@ =~ /undefined alarm delta in alarm_adjust/, "alarm time undefined in alarm_adjust" ); eval { $poe_kernel->delay_set(undef) }; ok( $@ && $@ =~ /undefined event name in delay_set/, "event name undefined in delay_set" ); eval { $poe_kernel->delay_set(moo => undef) }; ok( $@ && $@ =~ /undefined seconds in delay_set/, "seconds undefined in delay_set" ); eval { $poe_kernel->delay_adjust(undef) }; ok( $@ && $@ =~ /undefined delay id in delay_adjust/, "delay ID undefined in delay_adjust" ); eval { $poe_kernel->delay_adjust(moo => undef) }; ok( $@ && $@ =~ /undefined delay seconds in delay_adjust/, "delay seconds undefined in delay_adjust" ); } } ); POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("moo"); } } ); POE::Session->create( inline_states => { _start => sub { eval { $_[KERNEL]->alias_set("moo") }; ok( $@ && $@ =~ /alias 'moo' is in use by another session/, "alias already in use" ); eval { $_[KERNEL]->alias_remove("moo") }; ok( $@ && $@ =~ /alias 'moo' does not belong to current session/, "alias belongs to another session" ); } } ); POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->alias_remove("narf") }; ok( $@ && $@ =~ /alias 'narf' does not exist/, "alias does not exist" ); } } ); # Filehandle I/O. POE::Session->create( inline_states => { _start => sub { my $fh = gensym(); eval { $poe_kernel->select(undef) }; ok( $@ && $@ =~ /undefined filehandle in select/, "filehandle undefined in select" ); eval { $poe_kernel->select($fh) }; ok( $@ && $@ =~ /invalid filehandle in select/, "filehandle closed in select" ); eval { $poe_kernel->select_read(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_read/, "filehandle undefined in select_read" ); eval { $poe_kernel->select_read($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_read/, "filehandle closed in select_read" ); eval { $poe_kernel->select_write(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_write/, "filehandle undefined in select_write" ); eval { $poe_kernel->select_write($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_write/, "filehandle closed in select_write" ); eval { $poe_kernel->select_expedite(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_expedite/, "filehandle undefined in select_expedite" ); eval { $poe_kernel->select_expedite($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_expedite/, "filehandle closed in select_expedite" ); eval { $poe_kernel->select_pause_write(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_pause_write/, "filehandle undefined in select_pause_write" ); eval { $poe_kernel->select_pause_write($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_pause_write/, "filehandle closed in select_pause_write" ); eval { $poe_kernel->select_resume_write(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_resume_write/, "filehandle undefined in select_resume_write" ); eval { $poe_kernel->select_resume_write($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_resume_write/, "filehandle closed in select_resume_write" ); eval { $poe_kernel->select_pause_read(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_pause_read/, "filehandle undefined in select_pause_read" ); eval { $poe_kernel->select_pause_read($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_pause_read/, "filehandle closed in select_pause_read" ); eval { $poe_kernel->select_resume_read(undef) }; ok( $@ && $@ =~ /undefined filehandle in select_resume_read/, "filehandle undefined in select_resume_read" ); eval { $poe_kernel->select_resume_read($fh) }; ok( $@ && $@ =~ /invalid filehandle in select_resume_read/, "filehandle closed in select_resume_read" ); } } ); # Aliases. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->alias_set(undef) }; ok( $@ && $@ =~ /undefined alias in alias_set/, "undefined alias in alias_set" ); eval { $poe_kernel->alias_remove(undef) }; ok( $@ && $@ =~ /undefined alias in alias_remove/, "undefined alias in alias_remove" ); eval { $poe_kernel->alias_resolve(undef) }; ok( $@ && $@ =~ /undefined alias in alias_resolve/, "undefined alias in alias_resolve" ); } } ); # Kernel and session IDs. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->ID_id_to_session(undef) }; ok( $@ && $@ =~ /undefined ID in ID_id_to_session/, "undefined ID in ID_id_to_session" ); eval { $poe_kernel->ID_session_to_id(undef) }; ok( $@ && $@ =~ /undefined session in ID_session_to_id/, "undefined session in ID_session_to_id" ); } } ); # Extra references. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->refcount_increment(undef) }; ok( $@ && $@ =~ /undefined session ID in refcount_increment/, "undefined session ID in refcount_increment" ); eval { $poe_kernel->refcount_increment("moo", undef) }; ok( $@ && $@ =~ /undefined reference count tag in refcount_increment/, "undefined tag in refcount_increment" ); eval { $poe_kernel->refcount_decrement(undef) }; ok( $@ && $@ =~ /undefined session ID in refcount_decrement/, "undefined session ID in refcount_decrement" ); eval { $poe_kernel->refcount_decrement("moo", undef) }; ok( $@ && $@ =~ /undefined reference count tag in refcount_decrement/, "undefined tag in refcount_decrement" ); } } ); # Event handlers. POE::Session->create( inline_states => { _start => sub { eval { $poe_kernel->state(undef) }; ok( $@ && $@ =~ /undefined event name in state/, "undefined event name in state" ); } } ); exit 0; POE-1.368/t/10_units/03_base/10_wheel.t000644 001751 001751 00000001462 12143730314 017677 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 7; BEGIN { use_ok("POE::Wheel") } eval { my $x = POE::Wheel->new() }; ok( $@ && $@ =~ /not meant to be used directly/, "don't instantiate POE::Wheel" ); my $id = POE::Wheel::allocate_wheel_id(); ok($id == 1, "first wheel ID == 1"); POE::Wheel::_test_set_wheel_id(0); my $new_id = POE::Wheel::allocate_wheel_id(); ok($new_id == 2, "second wheel ID == 1"); my $old_id = POE::Wheel::free_wheel_id($id); ok($old_id == 1, "removed first wheel id"); POE::Wheel::_test_set_wheel_id(0); my $third = POE::Wheel::allocate_wheel_id(); ok($third == 1, "third wheel reclaims unused ID 1"); POE::Wheel::_test_set_wheel_id(0); my $fourth = POE::Wheel::allocate_wheel_id(); ok($fourth == 3, "fourth wheel ID == 3"); exit 0; POE-1.368/t/10_units/03_base/15_kernel_internal.t000644 001751 001751 00000006365 12143730314 021763 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # This file contains tests for the _internal_ POE::Kernel interface # i.e. the interface exposed to POE::Session, POE::Resources::* etc use strict; # We manipulate internals directly, so consistency is not always # assured. sub POE::Kernel::ASSERT_DEFAULT () { 0 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } # Tests _trap_death and _release_death indirectly (as well as directly when we # test _croak etc) by checking that POE doesn't leave $SIG{__WARN__} # and $SIG{__DIE__} altered. my ($initial__die__, $initial__warn__, $last_exception); BEGIN { *CORE::GLOBAL::die = sub { $last_exception = "die: @_"; CORE::die(@_); }; *CORE::GLOBAL::warn = sub { $last_exception = "warn: @_"; CORE::warn(@_); }; # reload Carp so it sees the CORE::GLOBAL overrides delete $INC{"Carp.pm"}; require Symbol; Symbol::delete_package("Carp"); require Carp; } use Test::More tests => 12; BEGIN { use_ok("POE::Kernel"); } # The expected size of the queue when the kernel is idle (without any # user generated/requested events) { my $base_size = $poe_kernel->_idle_queue_size(); $poe_kernel->_idle_queue_grow(); is( $poe_kernel->_idle_queue_size(), $base_size + 1, "growing idle queue"); $poe_kernel->_idle_queue_grow(); is( $poe_kernel->_idle_queue_size(), $base_size + 2, "growing idle queue (2)"); $poe_kernel->_idle_queue_shrink(); is( $poe_kernel->_idle_queue_size(), $base_size + 1, "shrinking idle queue"); $poe_kernel->_idle_queue_shrink(); is( $poe_kernel->_idle_queue_size(), $base_size, "shrinking idle queue (2)"); } { $last_exception = ''; eval { POE::Kernel::_trap("testing _trap") }; ok($last_exception =~ /^die:/, "_trap confessed"); } { $last_exception = ''; open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; eval { POE::Kernel::_croak("testing _croak") }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok($last_exception =~ /^die:/, "_croak croaked"); } { $last_exception = ''; open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; eval { POE::Kernel::_confess("testing _confess") }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok($last_exception =~ /^die:/, "_confess confessed"); } { $last_exception = ''; open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; eval { POE::Kernel::_cluck("testing _cluck") }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok($last_exception =~ /^warn:/, "_cluck clucked"); } { $last_exception = ''; open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; eval { POE::Kernel::_carp("testing _carp") }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok($last_exception =~ /^warn:/, "_carp carped"); } { $last_exception = ''; open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; eval { POE::Kernel::_warn("testing _warn") }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok($last_exception =~ /^warn:/, "_warn warned"); } { $last_exception = ''; eval { POE::Kernel::_die("testing _die") }; ok($last_exception =~ /^die:/, "_die died"); } exit 0; POE-1.368/t/10_units/03_base/12_assert_retval.t000644 001751 001751 00000007144 12276766765 021510 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Test the ASSERT_USAGE code in POE::Kernel. This involves a lot of # dying. use strict; use lib qw(./mylib); use Test::More tests => 22; BEGIN { delete $ENV{POE_ASSERT_USAGE}; } sub POE::Kernel::ASSERT_RETVALS () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # Disable any "didn't call run" warnings. POE::Kernel->run(); # Strange return values. eval { $poe_kernel->alarm(undef) }; ok( $@ && $@ =~ /invalid parameter to alarm/, "alarm with undefined event name" ); eval { $poe_kernel->alarm_add(undef) }; ok( $@ && $@ =~ /invalid parameter to alarm_add/, "alarm_add with undefined event name" ); eval { $poe_kernel->delay(undef) }; ok( $@ && $@ =~ /invalid parameter to delay/, "delay with undefined event name" ); eval { $poe_kernel->delay_add(undef) }; ok( $@ && $@ =~ /invalid parameter to delay_add/, "delay_add with undefined event name" ); eval { $poe_kernel->ID_id_to_session(999) }; ok( $@ && $@ =~ /ID does not exist/, "ID_id_to_session with unknown ID" ); eval { $poe_kernel->ID_session_to_id(999) }; ok( $@ && $@ =~ /session \(999\) does not exist/, "ID_session_to_id with unknown session" ); eval { $poe_kernel->refcount_increment(999) }; ok( $@ && $@ =~ /session id 999 does not exist/, "refcount_increment with unknown session ID" ); eval { $poe_kernel->refcount_decrement(999) }; ok( $@ && $@ =~ /session id 999 does not exist/, "refcount_decrement with unknown session ID" ); eval { $poe_kernel->state(moo => sub { } ) }; ok( $@ && $@ =~ /session \(.*?\) does not exist/, "state with nonexistent active session" ); # Strange usage. eval { $poe_kernel->alarm_set(undef) }; ok( $@ && $@ =~ /undefined event name in alarm_set/, "event undefined in alarm_set" ); eval { $poe_kernel->alarm_set(moo => undef) }; ok( $@ && $@ =~ /undefined time in alarm_set/, "time undefined in alarm_set" ); eval { $poe_kernel->alarm_remove(undef) }; ok( $@ && $@ =~ /undefined alarm id in alarm_remove/, "alarm ID undefined in alarm_remove" ); eval { $poe_kernel->alarm_adjust(undef) }; ok( $@ && $@ =~ /undefined alarm id in alarm_adjust/, "alarm ID undefined in alarm_adjust" ); eval { $poe_kernel->alarm_adjust(moo => undef) }; ok( $@ && $@ =~ /undefined alarm delta in alarm_adjust/, "alarm time undefined in alarm_adjust" ); eval { $poe_kernel->delay_set(undef) }; ok( $@ && $@ =~ /undefined event name in delay_set/, "event name undefined in delay_set" ); eval { $poe_kernel->delay_set(moo => undef) }; ok( $@ && $@ =~ /undefined seconds in delay_set/, "seconds undefined in delay_set" ); eval { $poe_kernel->delay_adjust(undef) }; ok( $@ && $@ =~ /undefined delay id in delay_adjust/, "delay ID undefined in delay_adjust" ); eval { $poe_kernel->delay_adjust(moo => undef) }; ok( $@ && $@ =~ /undefined delay seconds in delay_adjust/, "delay seconds undefined in delay_adjust" ); POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("moo"); } } ); POE::Session->create( inline_states => { _start => sub { eval { $_[KERNEL]->alias_set("moo") }; ok( $@ && $@ =~ /alias 'moo' is in use by another session/, "alias already in use" ); eval { $_[KERNEL]->alias_remove("moo") }; ok( $@ && $@ =~ /alias 'moo' does not belong to current session/, "alias belongs to another session" ); } } ); eval { $poe_kernel->alias_remove("narf") }; ok( $@ && $@ =~ /alias 'narf' does not exist/, "alias does not exist" ); exit 0; POE-1.368/t/10_units/03_base/08_resource.t000644 001751 001751 00000000221 12143730314 020421 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 1; BEGIN { use_ok("POE::Resource") } exit 0; POE-1.368/t/10_units/03_base/05_filter.t000644 001751 001751 00000000415 12143730314 020061 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; BEGIN { use_ok("POE::Filter") } eval { my $x = POE::Filter->new() }; ok( $@ && $@ =~ /not meant to be used directly/, "don't instantiate POE::Filter" ); exit 0; POE-1.368/t/10_units/03_base/13_assert_data.t000644 001751 001751 00000003122 12143730314 021063 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Test the ASSERT_DATA code in POE::Kernel. This involves a lot of # dying. use strict; use lib qw(./mylib); # _explain_resolve_failure # session_alloc use Test::More tests => 7; BEGIN { delete $ENV{POE_ASSERT_USAGE}; } sub POE::Kernel::ASSERT_DATA () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } # Disable any "didn't call run" warnings. POE::Kernel->run(); # Session resolution. eval { $poe_kernel->signal(moo => "signal") }; ok( $@ && $@ =~ /Cannot resolve ``moo'' into a session reference/, "unresolvable session in signal" ); eval { $poe_kernel->detach_child("moo") }; ok( $@ && $@ =~ /Cannot resolve ``moo'' into a session reference/, "unresolvable session in detach_child" ); eval { $poe_kernel->post(moo => "bar") }; ok( $@ && $@ =~ /Cannot resolve ``moo'' into a session reference/, "unresolvable session in post" ); eval { $poe_kernel->call(moo => "bar") }; ok( $@ && $@ =~ /Cannot resolve ``moo'' into a session reference/, "unresolvable session in call" ); # Double session allocation. eval { $poe_kernel->session_alloc($poe_kernel) }; ok( $@ && $@ =~ /session .*? already allocated/s, "double session_alloc" ); # Free POE::Kernel to catch some bizarre errors. Requires us to force # POE::Kernel's instance to go away. $poe_kernel->_data_ses_free($poe_kernel->ID); eval { $poe_kernel->alarm_remove_all() }; ok( $@ && $@ =~ /unknown session in alarm_remove_all call/, "removing alarms from unknown session" ); exit 0; POE-1.368/t/10_units/03_base/04_driver.t000644 001751 001751 00000000415 12143730314 020066 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use Test::More tests => 2; BEGIN { use_ok("POE::Driver") } eval { my $x = POE::Driver->new() }; ok( $@ && $@ =~ /not meant to be used directly/, "don't instantiate POE::Driver" ); exit 0; POE-1.368/t/90_regression/steinert-passed-wheel.t000644 001751 001751 00000002025 12143730315 022316 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Passing a POE::Wheel or something into an event handler will cause # that thing's destruction to be delayed until outside the session's # event handler. The result is a hard error. use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; use POE::Wheel::ReadWrite; use POE::Pipe::OneWay; use Test::More tests => 1; POE::Session->create( inline_states => { _start => \&setup, got_input => sub { }, destructo => \&die_die_die, _stop => \&shutdown, } ); POE::Kernel->run(); exit; sub setup { my ($r, $w) = POE::Pipe::OneWay->new(); my $wheel = POE::Wheel::ReadWrite->new( InputHandle => $r, OutputHandle => $w, InputEvent => "got_input", ); $_[KERNEL]->yield(destructo => $wheel); return; } sub die_die_die { return @_; # What the heck, return it too just for perversity. } sub shutdown { pass("normal shutdown"); } POE-1.368/t/90_regression/rt19908-merlyn-stop.t000644 001751 001751 00000001451 12143730315 021433 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Randal Schwartz reported that die() within _stop causes an infinite # loop. He's right. This tests rt.cpan.org ticket 19908. # perl-5.6.x on Win32 does not support alarm() BEGIN { if ( $^O eq 'MSWin32' and $] < 5.008 ) { print "1..0 # Skip perl-5.6.x on $^O does not support alarm()"; exit(); } } use POE; use Test::More tests => 3; $SIG{ALRM} = sub { exit }; alarm(5); my $stop_count = 0; POE::Session->create( inline_states => { _start => sub { pass("started"); }, _stop => sub { $stop_count++; die "stop\n"; }, } ); eval { POE::Kernel->run() }; $SIG{ALRM} = "IGNORE"; ok($@ eq "stop\n", "stopped due to a 'stop' exception (in _stop)"); ok($stop_count == 1, "stopped after one _stop"); POE-1.368/t/90_regression/bingos-followtail.t000644 001751 001751 00000004240 12472121170 021534 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Make sure that the default behavior for POE::Wheel::FollowTail is to # skip to the end of the file when it first starts. use warnings; use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } use IO::Handle; use POE qw(Wheel::FollowTail Filter::Line); use Test::More tests => 2; my $filename = 'bingos-followtail'; # Using "!" as a newline to avoid differences in opinion about "\n". open FH, ">$filename" or die "$!\n"; FH->autoflush(1); print FH "moocow - this line should be skipped!"; POE::Session->create( package_states => [ 'main' => [qw(_start _input _error _shutdown _file_is_idle)], ], inline_states => { _stop => sub { undef }, }, heap => { filename => $filename, }, ); $poe_kernel->run(); exit 0; sub _start { my ($kernel,$heap) = @_[KERNEL,HEAP]; $heap->{wheel} = POE::Wheel::FollowTail->new( Filter => POE::Filter::Line->new( Literal => "!" ), Filename => $heap->{filename}, InputEvent => '_input', ErrorEvent => '_error', IdleEvent => '_file_is_idle', ); $heap->{running} = 1; $heap->{counter} = 0; print FH "Cows go moo, yes they do!"; close FH; return; } sub _shutdown { delete $_[HEAP]->{wheel}; return; } sub _input { my ($kernel,$heap,$input) = @_[KERNEL,HEAP,ARG0]; # Make sure we got the right line. is($input, 'Cows go moo, yes they do', 'Got the right line'); ok( ++$heap->{counter} == 1, 'Cows went moo' ); POE::Kernel->delay( _shutdown => 5 ); return; } sub _error { my ($heap,$operation, $errnum, $errstr, $wheel_id) = @_[HEAP,ARG0..ARG3]; diag("Wheel $wheel_id generated $operation error $errnum: $errstr\n"); POE::Kernel->delay( _shutdown => 0.01 ); return; } sub _file_is_idle { return unless $_[HEAP]{counter}; # At first I thought just a delay( _shutdown => 1 ) would be nice # here, but there's a slight chance that the POE::Wheel::FollowTail # polling interval could refresh this indefinitely. # # So I took the slightly more awkward course of turning off the # shutdown timer and triggering shutdown immediately. POE::Kernel->delay(_shutdown => undef); POE::Kernel->yield("_shutdown"); } POE-1.368/t/90_regression/ton-stop-corruption.t000644 001751 001751 00000002037 12472121170 022070 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Test that stop() does not result in a double garbage collection on # the session that called it. This test case provided by Ton Hospel. use strict; use Test::More tests => 5; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } BEGIN { use_ok("POE::Pipe::OneWay") } BEGIN { $^W = 1 }; my ($rd, $wr) = POE::Pipe::OneWay->new(); ok(defined($rd), "created a pipe for testing ($!)"); my $stop_was_called = 0; POE::Session->create( inline_states => { _start => sub { $poe_kernel->select_read($rd, "readable"); }, readable => sub { pass("got readable callback; calling stop"); $poe_kernel->select_read($rd); $poe_kernel->stop(); }, _stop => sub { $stop_was_called++ }, _parent => sub { }, _child => sub { }, } ); close $wr; POE::Kernel->run(); is( $stop_was_called, 1, "stop was only called once" ); exit; POE-1.368/t/90_regression/kjeldahl-stop-start-sig-pipe.t000644 001751 001751 00000010467 12143730315 023522 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } sub POE::Kernel::USE_SIGCHLD () { 1 } sub POE::Kernel::USE_SIGNAL_PIPE () { 1 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } use POE; use POE::Wheel::Run; use Test::More; sub DEBUG () { 0 } my $child_process_limit = 3; my $seconds_children_sleep = 1; # Each child process: # child sent done # child flushed # child exited # Each spawn # All children exited # Whole program # Sane exit my $test_count = 3 * $child_process_limit + 1 + 1; plan tests => $test_count; SKIP: { skip("$^O handles fork/call poorly", $test_count) if ( $^O eq "MSWin32" and not $ENV{POE_DANTIC} ); diag "This test can take up to ", $seconds_children_sleep*10, " seconds"; Work->spawn( $child_process_limit, $seconds_children_sleep ); $poe_kernel->run; pass( "Sane exit" ); } ############################################################################ package Work; use strict; use warnings; use POE; use Test::More; BEGIN { *DEBUG = \&::DEBUG; } sub spawn { my( $package, $count, $sleep ) = @_; POE::Session->create( inline_states => { _start => sub { my ($heap) = @_[HEAP, ARG0..$#_]; $poe_kernel->sig(CHLD => 'sig_CHLD'); foreach my $n (1 .. $count) { DEBUG and diag "$$: Launch child $n"; my $w = POE::Wheel::Run->new( Program => \&spawn_child, ProgramArgs => [ $sleep ], StdoutEvent => 'chld_stdout', StderrEvent => 'chld_stderr', CloseEvent => 'chld_close' ); $heap->{PID2W}{$w->PID} = {ID => $w->ID, N => $n, flushed=>0}; $heap->{W}{$w->ID} = $w; } $heap->{TID} = $poe_kernel->delay_set(timeout => $sleep*10); }, chld_stdout => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; $line =~ s/\s+//g; is( $line, 'DONE', "stdout from $wid" ); if( $line eq 'DONE' ) { my $data = $heap->{PID2W}{ $wheel->PID }; $data->{flushed} = 1; } }, chld_stderr => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; if (DEBUG) { diag "CHILD " . $wheel->PID . " STDERR: $line"; } else { fail "stderr from $wid: $line"; } }, say_goodbye => sub { DEBUG and diag "$$: saying goodbye"; foreach my $wheel (values %{$_[HEAP]{W}}) { $wheel->put("die\n"); } DEBUG and diag "$$: said my goodbyes"; }, timeout => sub { fail "Timed out waiting for children to exit"; $poe_kernel->stop(); }, sig_CHLD => sub { my ($heap, $signal, $pid) = @_[HEAP, ARG0, ARG1]; DEBUG and diag "$$: CHLD $pid"; my $data = $heap->{PID2W}{$pid}; die "Unknown wheel PID=$pid" unless defined $data; close_on( 'CHLD', $heap, $data->{ID} ); }, chld_close => sub { my ($heap, $wid) = @_[HEAP, ARG0]; DEBUG and diag "$$: close $wid"; close_on( 'close', $heap, $wid ); }, _stop => sub { }, # Pacify ASSERT_DEFAULT. } ); } sub close_on { my( $why, $heap, $wid ) = @_; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; my $data = $heap->{PID2W}{ $wheel->PID }; $data->{$why}++; return unless $data->{CHLD} and $data->{close}; is( $data->{flushed}, 1, "expected child flush" ); delete $heap->{PID2W}{$wheel->PID}; delete $heap->{W}{$data->{ID}}; pass("Child $data->{ID} exit detected."); unless (keys %{$heap->{W}}) { pass "all children have exited"; $poe_kernel->alarm_remove(delete $heap->{TID}); } } sub spawn_child { my( $sleep ) = @_; DEBUG and diag "$$: child sleep=$sleep"; POE::Kernel->stop; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->delay( done => $sleep ); }, _stop => sub { DEBUG and diag "$$: child _stop"; }, done => sub { DEBUG and diag "$$: child done"; print "DONE\n"; }, } ); POE::Kernel->run; } POE-1.368/t/90_regression/suzman_windows.t000644 001751 001751 00000003013 12143730315 021167 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Tests various signals using POE's stock signal handlers. These are # plain Perl signals, so mileage may vary. use strict; use lib qw(./mylib ../mylib); use Test::More; BEGIN { plan(skip_all => "Windows tests aren't necessary on $^O") if $^O eq "MacOS"; }; plan tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; # POE::Kernel in version 0.19 assumed that SIGCHLD on Windows would # always return negative PIDs. This was only true for pseudo # processes created by fork(). Ted Suzman pointed out that real # processes, such as those created by open("foo|"), have positive # PIDs, so the internal inconsistency checks in POE were bogus. This # test generates a positive PID and ensures that it's not treated as # an error. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->sig(CHLD => "child_handler"); $_[KERNEL]->delay(timeout => 5); open(FOO, "echo foo > nul:|") or die $!; open(FOO, "echo foo > nul:|") or die $!; my @x = ; }, child_handler => sub { pass("handled real SIGCHLD"); $_[KERNEL]->delay(timeout => undef); $_[KERNEL]->sig(CHLD => undef); }, _stop => sub { }, timeout => sub { fail("handled real SIGCHLD"); $_[KERNEL]->sig(CHLD => undef); }, } ); POE::Kernel->run(); close FOO; unlink "nul:"; pass("run() returned successfully"); POE-1.368/t/90_regression/whelan-dieprop.t000644 001751 001751 00000001666 12143730315 021032 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use strict; use warnings; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More tests => 2; use POE; POE::Session->create( inline_states => { _start => sub { $poe_kernel->sig(DIE => 'parent_exception'); POE::Session->create( inline_states => { _start => sub { $poe_kernel->sig(DIE => 'child_exception'); $poe_kernel->yield("throw_exception"); }, throw_exception => sub { die "goodbye sweet world" }, child_exception => sub { pass("child got exception") }, _stop => sub { }, }, ) }, parent_exception => sub { pass("parent got exception"); $poe_kernel->sig_handled(); }, _stop => sub { }, _child => sub { }, }, ); POE::Kernel->run(); exit; POE-1.368/t/90_regression/rt23181-sigchld-rc.t000644 001751 001751 00000001102 12143730315 021136 0ustar00bingosbingos000000 000000 #!perl # vim: ts=2 sw=2 filetype=perl expandtab # Calling sig_child($pid) without a prior sig_child($pid, $event) # would drop the session's reference count below zero. use warnings; use strict; use Test::More tests => 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield("test") }, test => sub { $_[KERNEL]->sig_child(12) }, _stop => sub { pass("didn't die") }, } ); POE::Kernel->run(); POE-1.368/t/90_regression/rt1648-tied-stderr.t000644 001751 001751 00000005527 12143730315 021310 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab # Scott Beck reported that tied STDERR breaks POE::Wheel::Run. He # suggested untying STDOUT and STDERR in the child process. This test # makes sure the bad behavior does not come back. use strict; # Skip these tests if fork() is unavailable. BEGIN { my $error; if ($^O eq "MacOS") { $error = "$^O does not support fork"; } elsif ($^O eq "MSWin32") { eval "use Win32::Console"; if ($@) { $error = "Win32::Console is required on $^O."; } elsif ($] < 5.010000) { $error = "$^O ver. $] doesn't fork/exec properly. Consider upgrading."; } } if ($error) { print "1..0 # Skip $error\n"; exit(); } } sub DEBUG () { 0 } use Test::More tests => 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw/Wheel::Run Session/; tie *STDERR, 'Test::Tie::Handle'; POE::Session->create( inline_states => { _start => sub { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; $_[KERNEL]->sig( 'CHLD', 'sigchld' ); $_[KERNEL]->refcount_increment( $session->ID, "teapot" ); DEBUG and diag( "Installing CHLD signal Handler" ); my $wheel = POE::Wheel::Run->new( Program => [ $^X, '-e', 'warn "OK"' ], StderrEvent => 'stderr' ); $heap->{wheel} = $wheel; $heap->{pid} = $wheel->PID; $kernel->delay(shutdown => 3); $heap->{got_stderr} = 0; }, stderr => sub { delete $_[HEAP]->{wheel}; $_[HEAP]->{got_stderr}++; $_[KERNEL]->delay(shutdown => undef); }, shutdown => sub { delete $_[HEAP]->{wheel}; }, sigchld => sub { DEBUG and diag( "Got SIGCHLD for PID $_[ARG1]" ); if ($_[ARG1] == $_[HEAP]->{pid}) { DEBUG and diag( "PID Matches, removing CHLD handler" ); $_[KERNEL]->sig( 'CHLD' ); $_[KERNEL]->refcount_decrement( $_[SESSION]->ID, "teapot" ); } }, _stop => sub { ok($_[HEAP]->{got_stderr}, "should receive STDERR even when tied"); }, }, ); $poe_kernel->run; BEGIN { package Test::Tie::Handle; use Tie::Handle; use vars qw(@ISA); @ISA = 'Tie::Handle'; use Symbol qw(gensym); sub TIEHANDLE { my $class = shift; my $fh = gensym(); bless $fh, $class; $fh->OPEN(@_) if (@_); return $fh; } sub EOF { eof($_[0]) } sub TELL { tell($_[0]) } sub FILENO { fileno($_[0]) } sub SEEK { seek($_[0],$_[1],$_[2]) } sub CLOSE { close($_[0]) } sub BINMODE { binmode($_[0]) } sub OPEN { $_[0]->CLOSE if defined($_[0]->FILENO); open(@_); } sub READ { read($_[0],$_[1],$_[2]) } sub READLINE { my $fh = $_[0]; <$fh> } sub GETC { getc($_[0]) } my $out; sub WRITE { my $fh = $_[0]; $out .= substr($_[1],0,$_[2]); } } POE-1.368/t/90_regression/rt47966-sigchld.t000644 001751 001751 00000004716 12143730315 020573 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; use POE; use POE::Wheel::Run; use Test::More; sub DEBUG () { 0 } unless ( $ENV{RELEASE_TESTING} ) { plan skip_all => 'enable by setting RELEASE_TESTING'; } my $N = 60; diag "This test can take up to about ", int($N / 3), " seconds"; plan tests => $N + 2; POE::Session->create( inline_states => { _start => sub { my ($heap, $count) = @_[HEAP, ARG0]; $poe_kernel->sig(CHLD => 'sig_CHLD'); foreach my $n (1 .. $N) { DEBUG and diag "$$: Launch child $n"; my $w = POE::Wheel::Run->new( Program => sub { DEBUG and warn "$$: waiting for input"; ; exit 0; }, StdoutEvent => 'chld_stdout', StderrEvent => 'chld_stdin', ); $heap->{PID2W}{$w->PID} = {ID => $w->ID, N => $n}; $heap->{W}{$w->ID} = $w; } DEBUG and warn "$$: waiting 1 sec for things to settle"; $_[KERNEL]->delay(say_goodbye => 1); }, chld_stdout => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $W = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $W; fail "stdout from $wid: $line"; }, chld_stderr => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $W = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $W; if (DEBUG) { diag $line; } else { fail "stderr from $wid: $line"; } }, say_goodbye => sub { DEBUG and warn "$$: saying goodbye"; foreach my $wheel (values %{$_[HEAP]{W}}) { $wheel->put("die\n"); } $_[HEAP]{TID} = $poe_kernel->delay_set(timeout => $N); DEBUG and warn "$$: said my goodbyes"; }, timeout => sub { fail "Timed out waiting for children to exit"; $poe_kernel->stop; }, sig_CHLD => sub { my ($heap, $signal, $pid) = @_[HEAP, ARG0, ARG1]; DEBUG and diag "$$: CHLD $pid"; my $data = $heap->{PID2W}{$pid}; die "Unknown wheel PID=$pid" unless defined $data; my $W = $heap->{W}{$data->{ID}}; die "Unknown wheel $data->{ID}" unless $W; delete $heap->{PID2W}{$pid}; delete $heap->{W}{$data->{ID}}; pass("Child $data->{ID} exit detected."); unless (keys %{$heap->{W}}) { pass "all children have exited"; $poe_kernel->alarm_remove(delete $heap->{TID}); } } } ); $poe_kernel->run; pass("Sane exit"); POE-1.368/t/90_regression/cfedde-filter-httpd.t000644 001751 001751 00000004037 12472121170 021723 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; BEGIN { unless (-f 'run_network_tests') { print "1..0 # skip - Network access (and permission) required to run this test\n"; exit; } eval "use HTTP::Request"; if ($@) { print "1..0 # skip - HTTP::Request needed to test POE::Filter::HTTPD\n"; exit; } } use Test::More tests => 3; my $port; use POE qw( Component::Client::TCP Component::Server::TCP Filter::HTTPD ); # # handler # POE::Component::Server::TCP->new( Alias => 's0', Port => 0, Address => '127.0.0.1', ClientFilter => 'POE::Filter::HTTPD', Started => sub { use Socket qw(sockaddr_in); $port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, Stopped => sub { note "server s0 stopped"; }, ClientInput => sub { # Shutdown step 1: Close client c1's connection after receiving input. my ( $kernel, $heap, $request ) = @_[ KERNEL, HEAP, ARG0 ]; isa_ok( $request, 'HTTP::Message', "server s0 request $request"); POE::Kernel->yield( 'shutdown' ); }, ); POE::Component::Client::TCP->new ( Alias => 'c0', RemoteAddress => '127.0.0.1', RemotePort => $port, ServerInput => sub { fail("client c0 got input from server s0: $_[ARG0]") }, Connected => sub { note "client c0 connected"; }, Disconnected => sub { ok( 3, "client c0 disconnected" ); POE::Kernel->post( c0 => 'shutdown' ); }, # Silence errors. ServerError => sub { undef }, ); POE::Component::Client::TCP->new ( Alias => 'c1', RemoteAddress => '127.0.0.1', RemotePort => $port, ServerInput => sub { fail("client c1 got input from server s0: $_[ARG0]") }, Connected => sub { ok 1, 'client c1 connected'; $_[HEAP]->{server}->put( "GET / 1.0\015\012\015\012"); }, Disconnected => sub { # Shutdown step 2: Kill the server and all remaining connections note "client c1 disconnected"; POE::Kernel->signal( s0 => 'KILL' ); }, # Silence errors. ServerError => sub { undef }, ); $poe_kernel->run(); exit 0; POE-1.368/t/90_regression/rt14444-arg1.t000644 001751 001751 00000001746 12143730315 017771 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; use POE; use Test::More tests => 3; my $test_state = "some_random_state"; my @test_args = qw(some random args); POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield($test_state, @test_args); }, _default => sub { my ($orig_state, $orig_args) = @_[ARG0,ARG1]; if ($orig_state eq $test_state) { is_deeply(\@test_args, $orig_args, "test args passed okay"); } $_[KERNEL]->yield( check_ref => $_[ARG1] ); $_[KERNEL]->yield( check_copy => [@{$_[ARG1]}] ); }, check_ref => sub { my $test_args = $_[ARG0]; is_deeply( \@test_args, $test_args, "args preserved in pass by reference", ); }, check_copy => sub { my $test_args = $_[ARG0]; is_deeply( \@test_args, $test_args, "args preserved in pass by copy", ); } } ); POE::Kernel->run; exit 0; POE-1.368/t/90_regression/somni-poco-server-tcp.t000644 001751 001751 00000014712 12143730315 022263 0ustar00bingosbingos000000 000000 # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; BEGIN { my $error; unless (-f 'run_network_tests') { $error = "Network access (and permission) required to run this test"; } if ($error) { print "1..0 # Skip $error\n"; exit; } } use POE; use POE::Component::Server::TCP; use POE::Component::Client::TCP; use Socket qw(sockaddr_in inet_ntoa); use List::Util qw(first); use Test::More tests => 43; { my @state = run(); ok_state_top(\@state, 'server started'); ok_state_top(\@state, 'client started'); ok_state_top(\@state, 'client connected to server'); ok_state_top(\@state, 'client connected'); ok_state_top(\@state, 'client flushed'); ok_state_any(\@state, 'received from server: I will be serving you today!'); ok_state_any(\@state, 'received from client: I am your new client!'); ok_state_top(\@state, 'received from server: Go away.'); ok_state_top(\@state, 'client disconnected'); ok_state_empty(\@state); } { my @state = run( Port => 0 ); ok_state_top(\@state, 'server started'); ok_state_top(\@state, 'client started'); ok_state_top(\@state, 'client connected to server'); ok_state_top(\@state, 'client connected'); ok_state_top(\@state, 'client flushed'); ok_state_any(\@state, 'received from server: I will be serving you today!'); ok_state_any(\@state, 'received from client: I am your new client!'); ok_state_top(\@state, 'received from server: Go away.'); ok_state_top(\@state, 'client disconnected'); ok_state_empty(\@state); } { my @state = run( ClientArgs => [ '', \"", {}, [] ], ListenerArgs => [ [], {}, \"", '' ], ); ok_state_top(\@state, 'server started: ARRAY HASH SCALAR none'); ok_state_top(\@state, 'client started'); ok_state_top(\@state, 'client connected to server: none SCALAR HASH ARRAY'); ok_state_top(\@state, 'client connected'); ok_state_top(\@state, 'client flushed'); ok_state_any(\@state, 'received from server: I will be serving you today!'); ok_state_any(\@state, 'received from client: I am your new client!'); ok_state_top(\@state, 'received from server: Go away.'); ok_state_top(\@state, 'client disconnected'); ok_state_empty(\@state); } { my @state = run( InlineStates => { InlineStates_test => \&InlineStates_test }, ObjectStates => [ bless({}, 'ObjectStates_test') => { ObjectStates_test => 'test' } ], PackageStates => [ 'PackageStates_test' => { PackageStates_test => 'test' }, ], ); ok_state_top(\@state, 'server started'); ok_state_top(\@state, 'client started'); ok_state_top(\@state, 'client connected to server'); ok_state_top(\@state, 'client connected'); ok_state_top(\@state, 'InlineStates test: from server_client_connected'); ok_state_top(\@state, 'ObjectStates test: from server_client_connected'); ok_state_top(\@state, 'PackageStates test: from server_client_connected'); ok_state_top(\@state, 'client flushed'); ok_state_any(\@state, 'received from server: I will be serving you today!'); ok_state_any(\@state, 'received from client: I am your new client!'); ok_state_top(\@state, 'received from server: Go away.'); ok_state_top(\@state, 'client disconnected'); ok_state_empty(\@state); } ### TESTING SUBROUTINES ### sub ok_state_empty { ok((not @{ $_[0] }), 'state is empty') } sub ok_state_top { my($state, $value) = @_; is($state->[0], $value, $value); shift @$state if $state->[0] eq $value; } sub ok_state_any { my($state, $value) = @_; foreach my $i (0 .. $#$state) { if ($state->[$i] eq $value) { is($state->[$i], $value, $value); splice(@$state, $i, 1); return; } } fail($value); } ### UTILITY SUBROUTINES ### sub run { my %args = @_; our @state; local @state; POE::Component::Server::TCP->new( Address => '127.0.0.1', Alias => 'server', Started => \&server_started, ClientConnected => \&server_client_connected, ClientDisconnected => \&server_client_disconnected, ClientInput => \&server_client_input, %args, ); POE::Kernel->run(); return @state; } sub arginfo { my @args = @_[ARG0 .. $#_]; return '' unless @args; return ': ' . join(" ", map { ref or 'none' } @_[ARG0 .. $#_]); } ### CALLBACK SUBROUTINES ### sub ObjectStates_test::test { state("ObjectStates test: $_[ARG0]") } sub PackageStates_test::test { state("PackageStates test: $_[ARG0]") } sub InlineStates_test { state("InlineStates test: $_[ARG0]") } sub server_started { my($kernel, $heap) = @_[KERNEL,HEAP]; my($port, $address) = sockaddr_in($heap->{'listener'}->getsockname); state('server started', arginfo(@_)); POE::Component::Client::TCP->new( RemoteAddress => inet_ntoa($address), RemotePort => $port, Started => \&client_started, Connected => \&client_connected, ServerInput => \&client_input, ServerFlushed => \&client_flushed, ); $kernel->yield( 'InlineStates_test' => 'from server_started' ); $kernel->yield( 'ObjectStates_test' => 'from server_started' ); $kernel->yield( 'PackageStates_test' => 'from server_started' ); } sub server_client_connected { my($kernel, $heap) = @_[KERNEL,HEAP]; state('client connected to server', arginfo(@_)); $heap->{'client'}->put('I will be serving you today!'); $kernel->yield( 'InlineStates_test' => 'from server_client_connected' ); $kernel->yield( 'ObjectStates_test' => 'from server_client_connected' ); $kernel->yield( 'PackageStates_test' => 'from server_client_connected' ); } sub client_connected { state('client connected'); $_[HEAP]{'server'}->put('I am your new client!'); } sub server_client_disconnected { state('client disconnected'); $_[KERNEL]->post( server => 'shutdown' ); } sub client_input { my($msg) = $_[ARG0]; state("received from server: $msg"); $_[KERNEL]->yield('shutdown') if $msg eq 'Go away.'; } sub server_client_input { state("received from client: $_[ARG0]"); $_[HEAP]{'client'}->put('Go away.'); } sub client_flushed { state('client flushed') } sub client_started { state('client started') } sub state { push our @state, join("", @_) } POE-1.368/t/90_regression/rt56417-wheel-run.t000644 001751 001751 00000004040 12143730315 021041 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use strict; use warnings; use Test::More; use File::Spec; use POE qw( Wheel::Run ); plan tests => 4; foreach my $t ( qw( real fake ) ) { my_spawn( $t ); } $poe_kernel->run(); exit 0; sub my_spawn { POE::Session->create( package_states => [ 'main' => [qw(_start _stop _timeout _wheel_stdout _wheel_stderr _wheel_closed _wheel_child)], ], 'args' => [ $_[0] ], ); } sub _start { my ($kernel,$heap,$type) = @_[KERNEL,HEAP,ARG0]; $heap->{type} = $type; my $perl; if ( $type eq 'fake' ) { my @path = qw(COMPLETELY MADE UP PATH TO PERL); unshift @path, 'C:' if $^O eq 'MSWin32'; $perl = File::Spec->catfile( @path ); } elsif ( $type eq 'real' ) { $perl = $^X; } my $program = [ $perl, '-e', 1 ]; $heap->{wheel} = POE::Wheel::Run->new( Program => $program, StdoutEvent => '_wheel_stdout', StderrEvent => '_wheel_stderr', ErrorEvent => '_wheel_error', CloseEvent => '_wheel_closed', ); $kernel->sig_child( $heap->{wheel}->PID, '_wheel_child' ); $kernel->delay( '_timeout', 60 ); return; } sub _wheel_stdout { return; } sub _wheel_stderr { return; } sub _wheel_closed { delete $_[HEAP]->{wheel}; return; } sub _wheel_child { my $exitval = $_[ARG2]; if ( $_[HEAP]->{type} eq 'real' ) { is( $exitval, 0, "Set proper exitval for '" . $_[HEAP]->{type} . "'" ); } else { # TODO win32 boxes wildly vary on their support for this # On XP + Vista it works, on win7 it doesn't? Need to verify this 110% TODO: { local $TODO = ( "MSWin32 is unreliable in regards to exit value for invalid binaries" ) if $^O eq 'MSWin32'; diag( "Received exitval($exitval) for fake binary" ) if $^O eq 'MSWin32'; cmp_ok( $exitval, '>', 0, "Set proper exitval for '" . $_[HEAP]->{type} . "'" ); } } $poe_kernel->sig_handled(); $poe_kernel->delay( '_timeout' ); return; } sub _stop { pass("we sanely died (" . $_[HEAP]->{type} . ")"); return; } sub _timeout { die "Something went seriously wrong"; return; } POE-1.368/t/90_regression/neyuki_detach.t000644 001751 001751 00000004125 12276766765 020752 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use lib qw(./mylib ../mylib); $| = 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; use Test::More tests => 8; my $seq = 0; POE::Session->create( inline_states => { _start => sub { is(++$seq, 1, "starting parent in sequence"); $_[KERNEL]->yield('parent'); }, _stop => sub { # is(++$seq, 8, "stopping parent in sequence"); undef; }, _parent => sub { fail("parent received unexpected _parent"); }, _child => sub { if ($_[ARG0] eq "create") { is(++$seq, 4, "parent received _child create in sequence"); return; } if ($_[ARG0] eq "lose") { is(++$seq, 6, "parent received _child lose in sequence"); return; } fail("parent received unexpected _child $_[ARG0]"); }, done => sub { # is(++$seq, 8, "parent done in sequence"); undef; }, parent => sub { is(++$seq, 2, "parent spawning child in sequence"); POE::Session->create( inline_states => { _start => sub { is(++$seq, 3, "child started in sequence"); $_[KERNEL]->yield('child'); }, _stop => sub { # is(++$seq, 9, "child stopped in sequence"); undef; }, _parent => sub { is(++$seq, 7, "child received _parent in sequence"); ok($_[ARG1]->isa("POE::Kernel"), "child parent is POE::Kernel"); }, _child => sub { fail("child received unexpected _child"); }, child => sub { is(++$seq, 5, "child detached itself in sequence"); $_[KERNEL]->detach_myself; $_[KERNEL]->yield("done"); }, done => sub { # is(++$seq, 10, "child is done in sequence"); undef; }, } ); $_[KERNEL]->yield("done"); } # parent } # inline_states ); POE::Kernel->run(); POE-1.368/t/90_regression/whjackson-followtail.t000644 001751 001751 00000006062 12472121170 022246 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab # This regression test verifies what happens when the following # happens in between two polls of a log file: # # 1. A log file is rolled by being renamed out of the way. # 2. The new log is created by appending to the original file location. # # The desired result is the first log lines are fetched to completion # before the new log is opened. No data is lost in this case. use strict; use warnings; sub POE::Kernel::ASSERT_DEFAULT () { 1 } use Test::More; use POE qw(Wheel::FollowTail); use POE::Test::Sequence; use constant LOG => 'test_log'; use constant OLD_LOG => 'test_log.1'; # TODO - Perhaps POE::Wheel::FollowTail should close its file at the # end of a poll and reopen it at the start of the next? At least on # silly systems like DOS^H^H^HWindows? { open my $fh, '>>', LOG or die "open failed: $!"; unless (rename LOG, OLD_LOG) { plan skip_all => "$^O cannot rename files that are open"; } close $fh; unlink LOG, OLD_LOG; } my $sequence = POE::Test::Sequence->new( sequence => [ [ got_start_event => 0, sub { $_[HEAP]{wheel} = POE::Wheel::FollowTail->new( InputEvent => 'input_event', ResetEvent => 'reset_event', IdleEvent => 'idle_event', Filename => LOG, PollInterval => 1, ); } ], [ got_idle_event => 0, sub { append_to_log("a") } ], [ did_log_append => "a", undef ], [ got_reset_event => 0, undef ], # Initial open is a reset. [ got_input_event => "a", undef ], [ got_idle_event => 0, sub { append_to_log("b"); roll_log(); append_to_log("c"); } ], [ did_log_append => "b", undef ], [ did_log_roll => 0, undef ], [ did_log_append => "c", undef ], [ got_input_event => "b", undef ], [ got_reset_event => 0, undef ], [ got_input_event => "c", sub { append_to_log("d") } ], [ did_log_append => "d", undef ], [ got_input_event => "d", sub { delete $_[HEAP]{wheel} } ], [ got_stop_event => 0, sub { # Clean up test log files, if we can. unlink LOG or die "unlink failed: $!"; unlink OLD_LOG or die "unlink failed: $!"; } ], ], ); plan tests => $sequence->test_count(); POE::Session->create( inline_states => { _start => sub { goto $sequence->next("got_start_event", 0) }, _stop => sub { goto $sequence->next("got_stop_event", 0) }, input_event => sub { goto $sequence->next("got_input_event", $_[ARG0]) }, reset_event => sub { goto $sequence->next("got_reset_event", 0) }, idle_event => sub { goto $sequence->next("got_idle_event", 0) }, } ); POE::Kernel->run(); exit; # Helpers. sub roll_log { $sequence->next("did_log_roll", 0); rename LOG, OLD_LOG or die "rename failed: $!"; return; } sub append_to_log { my ($line) = @_; $sequence->next("did_log_append", $line); open my $fh, '>>', LOG or die "open failed: $!"; print {$fh} "$line\n"; close $fh or die "close failed: $!"; return; } 1; POE-1.368/t/90_regression/prumike-win32-stat.t000644 001751 001751 00000003176 12276766765 021530 0ustar00bingosbingos000000 000000 #!/usr/bin/env perl # stat() on Windows reports different device IDs for a file depending # whether it was stat()ed via name or opened handle. If used # inconsistently, stat() will always report differences. Discovered by # "pru-mike" at blogs.perl.org/users/pru-mike/2013/06/creepy-perl-stat-functions-on-windows.html use strict; use warnings; use POE qw/Wheel::FollowTail/; use Time::HiRes qw(time); use Test::More; $| = 1; BEGIN { if ($^O ne "MSWin32") { plan skip_all => "This test examines Strawberry/ActiveState Perl behavior."; } eval 'use Win32::Console'; if ($@) { plan skip_all => "Win32::Console is required on $^O - try ActivePerl"; } } plan tests => 1; my $filename = 'poe-stat-test.tmp'; die "File $filename exists!\n" if -f $filename; POE::Session->create( inline_states => { _start => \&start, got_line => sub { $_[HEAP]->{lines}++ }, got_error => sub { warn "$_[ARG0]\n" }, tick => \&check_file, }, ); $poe_kernel->run(); unlink $filename or die "$!"; exit(0); sub start { $_[HEAP]->{wheel} = POE::Wheel::FollowTail->new( Filename => $filename, InputEvent => 'got_line', ErrorEvent => 'got_error', SeekBack => 0, PollInterval => 1, ); $_[KERNEL]->delay(tick => 1); } sub check_file { if ( ! $_[HEAP]->{lines} ){ #recreate test file open my $fh, '>', $filename or die "$!"; print $fh "There is more than one way to skin a cat.\n"; close $fh; }else { ok($_[HEAP]->{lines} == 1,"Check number of lines" ) or diag ("Oops! Got $_[HEAP]->{lines} lines, possibly we have infinity loop\n"); $poe_kernel->stop(); } $_[KERNEL]->delay(tick => 1); } POE-1.368/t/90_regression/pipe-followtail.t000644 001751 001751 00000003140 12715047633 021221 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use strict; use warnings; use POE qw(Wheel::FollowTail); use POSIX qw(mkfifo); use Test::More; if ($^O eq 'MSWin32') { plan skip_all => 'Windows does not support mkfifo'; } else { plan tests => 3; } my $PIPENAME = 'testpipe'; my @EXPECTED = qw(foo bar); POE::Session->create( inline_states => { _start => \&_start_handler, done => \&done, input_event => \&input_handler, } ); POE::Kernel->run(); exit; #------------------------------------------------------------------------------ sub _start_handler { my ($kernel, $heap) = @_[KERNEL, HEAP]; mkfifo($PIPENAME, 0600) unless -p $PIPENAME; $heap->{wheel} = POE::Wheel::FollowTail->new( InputEvent => 'input_event', Filename => $PIPENAME, ); open my $fh, '>', $PIPENAME or die "open failed: $!"; $fh->autoflush(1); print $fh "foo\nbar\n"; # rt.cpan.org 96039: Save the filehandle so it remains open. $heap->{write_fh} = $fh; $kernel->delay('done', 3); return; } sub input_handler { my ($kernel, $line) = @_[KERNEL, ARG0]; my $next = shift @EXPECTED; is($line, $next); $kernel->delay('done', 1); return; } sub done { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Cleanup the test pipe file. # Must be closed for the unlink() to work on Windows. my $write_fh = delete $heap->{write_fh}; close $write_fh or die "close failed: $!"; unlink $PIPENAME or die "unlink failed: $!"; # delete the wheel so the POE session can end delete $heap->{wheel}; # @expected should be empty is_deeply(\@EXPECTED, []); return; } 1; POE-1.368/t/90_regression/hinrik-wheel-run-die.t000644 001751 001751 00000004462 12276766765 022071 0ustar00bingosbingos000000 000000 #!/usr/bin/env perl # vim: ts=2 sw=2 filetype=perl expandtab use strict; use warnings; use POE; use Test::More tests => 1; POE::Session->create( package_states => [ (__PACKAGE__) => [ qw( _start exit timeout) ], ], ); POE::Kernel->run; sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{quickie} = WheelWrapper->new( Program => sub { die }, ExitEvent => 'exit', ); # The delay goes after creating WheelWrapper. Starting a process # takes a little over 5sec on some Windows systems, and I don't know # why. This pretty much guarantees the timeout occurs. $kernel->delay('timeout', 5); } sub exit { my ($kernel, $heap, $status) = @_[KERNEL, HEAP, ARG0]; isnt(($status >> 8), 0, 'Got exit status'); $kernel->delay('timeout'); $heap->{quickie}->shutdown(); } sub timeout { fail('Timed out'); $_[KERNEL]->signal($_[KERNEL], "DIE"); } package WheelWrapper; use strict; use warnings; use POE; use POE::Wheel::Run; sub new { my ($package, %args) = @_; my $self = bless \%args, $package; $self->{parent_id} = POE::Kernel->get_active_session->ID; POE::Session->create( object_states => [ $self => [ qw( _start _delete_wheel _child_signal _child_closed _shutdown ) ], ], ); return $self; } sub _start { my ($kernel, $session, $self) = @_[KERNEL, SESSION, OBJECT]; my $session_id = $session->ID; $self->{session_id} = $session_id; $kernel->refcount_increment($session_id, __PACKAGE__); my $wheel; eval { $wheel = POE::Wheel::Run->new( CloseEvent => '_child_closed', StdoutEvent => 'dummy', Program => $self->{Program}, ); }; if ($@) { chomp $@; warn $@, "\n"; return; } $self->{wheel} = $wheel; $self->{alive} = 2; $kernel->sig_child($wheel->PID, '_child_signal'); } sub _child_signal { my ($kernel, $self, $pid, $status) = @_[KERNEL, OBJECT, ARG1, ARG2]; my $id = $self->{wheel}->PID; $kernel->post($self->{parent_id}, $self->{ExitEvent}, $status); $kernel->yield('_delete_wheel', $id); } sub _child_closed { $_[KERNEL]->yield('_delete_wheel'); } sub _delete_wheel { $_[OBJECT]->{alive}--; delete $_[OBJECT]->{wheel} if $_[OBJECT]->{alive} == 0; } sub shutdown { $poe_kernel->call($_[0]->{session_id}, '_shutdown'); } sub _shutdown { $_[KERNEL]->refcount_decrement($_[OBJECT]->{session_id}, __PACKAGE__); } POE-1.368/t/90_regression/leolo-sig-die.t000644 001751 001751 00000004650 12472121170 020537 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; use Test::More tests => 11; BEGIN { $ENV{POE_CATCH_EXCEPTIONS} = 0; } use POE; use POE::Session; use POE::Kernel; our $WANT; sub my_die { my( $err ) = @_; chomp $err; is( $err, $WANT, "error $WANT" ); die "$err\nmore\n"; } my $poe_dummy_sigdie = \&POE::Kernel::_dummy_sigdie_handler; POE::Session->create( inline_states => { _start => sub { is($SIG{__DIE__}, $poe_dummy_sigdie, '_start'); # Move to step2 with the default __DIE__ handler. $poe_kernel->yield( 'step2' ); }, ##### step2 => sub { # Make sure we have the default __DIE__ at the outset. is($SIG{__DIE__}, $poe_dummy_sigdie, 'step2'); my $ret = $poe_kernel->call( $_[SESSION], 'scalar_ctx' ); is( $ret, 42, 'scalar_ctx return value' ); my @ret = $poe_kernel->call( $_[SESSION], 'array_ctx' ); is_deeply( \@ret, [ 1..17 ], 'array_ctx return value' ); # Move to step3 with a custom __DIE__ handler. $SIG{__DIE__} = \&my_die; $poe_kernel->post( $_[SESSION], 'step3' ); }, scalar_ctx => sub { # Nobody changed the default here. is($SIG{__DIE__}, $poe_dummy_sigdie, 'scalar_ctx'); return 42; }, array_ctx => sub { # Nobody changed the default here either. is($SIG{__DIE__}, $poe_dummy_sigdie, 'array_ctx'); return ( 1..17 ); }, ##### step3 => sub { # Make sure the globally set custom __DIE__ handler survived. is($SIG{__DIE__}, \&my_die, 'step3'); my $ret = $poe_kernel->call( $_[SESSION], 'scalar_ctx3' ); is( $ret, 42, 'scalar_ctx3 return value' ); # Undefine SIGDIE handler to cause a hard death. # Really setting it to an empty string for compatibility reasons. $SIG{__DIE__} = ''; my @ret = $poe_kernel->call( $_[SESSION], 'array_ctx3' ); fail( 'array_ctx3 returned unexpectedly' ); }, scalar_ctx3 => sub { # Custom handler survived call(). is($SIG{__DIE__}, \&my_die, 'scalar_ctx3'); return 42; }, array_ctx3 => sub { # now we throw an execption up to our __DIE__ handler is($SIG{__DIE__}, '', 'array_ctx3'); $WANT = "array_ctx3"; die "$WANT\nmore\n"; return ( 1..17 ); }, } ); eval { $poe_kernel->run }; # make sure we caught the execption thrown in array_ctx3 is($@, "array_ctx3\nmore\n", 'exited when expected'); POE-1.368/t/90_regression/meh-startstop-return.t000644 001751 001751 00000001617 12143730315 022237 0ustar00bingosbingos000000 000000 #!/usr/bin/env perl # set ts=2 sw=2 expandtab filetype=perl # Ensure that _start and _stop handlers return values as documented. use warnings; use strict; use Test::More tests => 1; sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE; my @results; { package Fubar; use POE; sub new { my ($class) = @_; my $self = {}; bless $self, $class; return $self; } sub createsession { my $self = shift; POE::Session->create(object_states => [$self => [qw( _start _stop )]]); } sub _start { return '_start'; } sub _stop { return '_stop'; } } POE::Session->create( inline_states => { _start => sub { Fubar->new()->createsession(); }, _child => sub { push @results, [ $_[ARG0], $_[ARG2] ]; }, _stop => sub { undef }, } ); $poe_kernel->run; is_deeply( \@results, [ [qw( create _start ) ], [qw( lose _stop ) ], ] ); POE-1.368/t/90_regression/averell-callback-ret.t000644 001751 001751 00000001703 12143730315 022060 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Callback must pass on it's return value as per documentation. use strict; use Test::More tests => 2; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { use_ok("POE") } #1 BEGIN { $^W = 1 }; POE::Session->create( inline_states => { _start => sub { $_[HEAP]->{callback} = $_[SESSION]->callback("callback_event"); $_[KERNEL]->yield('try_callback'); }, try_callback => sub { my $callback = delete $_[HEAP]->{callback}; my $retval = $callback->(); if ($retval == 42) { pass("Callback returns correct value"); #2 } else { diag("Callback returned $retval (should be 42)"); fail("Callback returns correct value"); } }, callback_event => sub { return 42 }, _stop => sub {}, } ); POE::Kernel->run(); exit; POE-1.368/t/90_regression/socketfactory-timeout.t000644 001751 001751 00000001563 12143730315 022454 0ustar00bingosbingos000000 000000 #!/usr/bin/env perl use strict; use warnings; use POE qw(Wheel::SocketFactory); use Test::More tests => 1; POE::Session->create( package_states => [ main => [qw(_start sock_up sock_down timeout)], ], ); $poe_kernel->run(); sub _start { $_[HEAP]->{socket} = POE::Wheel::SocketFactory->new( SocketProtocol => 'tcp', RemoteAddress => 'localhost', RemotePort => 0, SuccessEvent => 'sock_up', FailureEvent => 'sock_down', ); $_[KERNEL]->delay('timeout', 5); } sub sock_up { fail("Successful connection to an unused port?"), delete $_[HEAP]->{socket}; $_[KERNEL]->delay('timeout'); } sub sock_down { pass("Failed to connect as expected"); delete $_[HEAP]->{socket}; $_[KERNEL]->delay('timeout'); } sub timeout { fail("Timed out before getting SuccessEvent or FailureEvent"); } POE-1.368/t/90_regression/rt65460-forking.t000644 001751 001751 00000010555 12143730315 020600 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # POE::Kernel should be able to handle daemonization with no issues # enable this to get debugging output sub DEBUG () { 0 } BEGIN { my $error; if ($^O eq "MSWin32") { $error = "$^O does not support fork()"; } elsif ( ! $ENV{RELEASE_TESTING} && ! $ENV{AUTOMATED_TESTING} ) { $error = "enable by setting (AUTOMATED|RELEASE)_TESTING"; } if ($error) { print "1..0 # Skip $error\n"; exit; } } use strict; use lib qw(./mylib ../mylib); use POE; use POE::Wheel::Run; use POE::Wheel::FollowTail; use POE::Filter::Reference; use POE::Filter::Line; use File::Temp qw( tempfile ); # 3 sets of daemonization methods * 2 timing of daemonization * run has_forked() or not? use Test::More tests => 12; my @tests; foreach my $t ( qw( nsd dd mxd ) ) { # nsd = Net::Server::Daemonize ( single-fork ) # dd = Daemon::Daemonize ( double-fork ) # mxd = MooseX::Daemonize ( single-fork with some extra stuff ) foreach my $timing ( qw( before after ) ) { foreach my $forked ( qw( has_fork no_fork ) ) { push( @tests, [ $t, $timing, $forked ] ); } } } my_spawn( @{ pop @tests } ); sub my_spawn { POE::Session->create( package_states => [ 'main' => [qw(_start _stop _timeout _wheel_stdout _wheel_stderr _wheel_closed _wheel_child _daemon_input _child)], ], 'args' => [ @_ ], ); } POE::Kernel->run(); sub _child { return; } sub _start { my ($kernel,$heap,$type,$timing,$forked) = @_[KERNEL,HEAP,ARG0 .. ARG2]; $heap->{type} = $type; $heap->{timing} = $timing; $heap->{forked} = $forked; # Create a tempfile to communicate with the daemon my ($fh,$filename) = tempfile( UNLINK => 1 ); $heap->{follow} = POE::Wheel::FollowTail->new( Handle => $fh, InputEvent => '_daemon_input', ); my $program = [ $^X, '-e', 'use lib qw(./mylib ../mylib); require "ForkingDaemon.pm";' ]; $heap->{wheel} = POE::Wheel::Run->new( Program => $program, StdoutEvent => '_wheel_stdout', StdinFilter => POE::Filter::Reference->new, StderrEvent => '_wheel_stderr', StdoutFilter => POE::Filter::Line->new, ErrorEvent => '_wheel_error', CloseEvent => '_wheel_closed', ); # tell the daemon to go do it's stuff and communicate with us via the tempfile $heap->{wheel}->put( { file => $filename, timing => $timing, type => $type, forked => $forked, debug => DEBUG(), } ); $kernel->sig_child( $heap->{wheel}->PID, '_wheel_child' ); $kernel->delay( '_timeout', 10 ); return; } sub _daemon_input { my ($kernel,$heap,$input) = @_[KERNEL,HEAP,ARG0]; if ( $input eq 'DONE' ) { # we are done testing! pass( "POE ($heap->{type}|$heap->{timing}|$heap->{forked}) successfully exited" ); # cleanup undef $heap->{wheel}; undef $heap->{follow}; $kernel->delay( '_timeout' ); # process the next test combination! my_spawn( @{ pop @tests } ) if @tests; } elsif ( $input =~ /^OLDPID\s+(.+)$/ ) { # got the PID before daemonization warn "Got OLDPID($heap->{type}|$heap->{timing}|$heap->{forked}): $1" if DEBUG; $heap->{daemon} = $1; } elsif ( $input =~ /^PID\s+(.+)$/ ) { # got the PID of the daemonized process my $pid = $1; warn "Got PID($heap->{type}|$heap->{timing}|$heap->{forked}): $pid" if DEBUG; if ( $heap->{daemon} == $pid ) { die "Failed to fork!"; } $heap->{daemon} = $pid; } else { warn "daemon($heap->{type}|$heap->{timing}|$heap->{forked}): $input\n" if DEBUG; } return; } sub _wheel_stdout { my ($heap) = $_[HEAP]; warn "daemon($heap->{type}|$heap->{timing}|$heap->{forked}) STDOUT: " . $_[ARG0] if DEBUG; return; } sub _wheel_stderr { my ($heap) = $_[HEAP]; warn "daemon($heap->{type}|$heap->{timing}|$heap->{forked}) STDERR: " . $_[ARG0] if DEBUG; return; } sub _wheel_closed { undef $_[HEAP]->{wheel}; return; } sub _wheel_child { $poe_kernel->sig_handled(); return; } sub _stop { return; } sub _timeout { my $heap = $_[HEAP]; # argh, we have to kill the daemonized process if ( exists $heap->{daemon} ) { CORE::kill( 9, $heap->{daemon} ); } else { die "Something went seriously wrong"; } fail( "POE ($heap->{type}|$heap->{timing}|$heap->{forked}) successfully exited" ); # cleanup undef $heap->{wheel}; undef $heap->{follow}; # process the next test combination! my_spawn( @{ pop @tests } ) if @tests; return; } POE-1.368/t/90_regression/kjeldahl-stop-start-polling.t000644 001751 001751 00000010560 12143730315 023443 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } sub POE::Kernel::USE_SIGCHLD () { 0 } sub POE::Kernel::USE_SIGNAL_PIPE () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } use POE; use POE::Wheel::Run; use Test::More; sub DEBUG () { 0 } my $child_process_limit = 3; my $seconds_children_sleep = 1; # Each child process: # child sent done # child flushed # child exited # Each spawn # All children exited # Whole program # Sane exit my $test_count = 3 * $child_process_limit + 1 + 1; plan tests => $test_count; SKIP: { skip("$^O handles fork/call poorly", $test_count) if ( $^O eq "MSWin32" and not $ENV{POE_DANTIC} ); diag "This test can take up to ", $seconds_children_sleep*10, " seconds"; Work->spawn( $child_process_limit, $seconds_children_sleep ); $poe_kernel->run; pass( "Sane exit" ); } ############################################################################ package Work; use strict; use warnings; use POE; use Test::More; BEGIN { *DEBUG = \&::DEBUG; } sub spawn { my( $package, $count, $sleep ) = @_; POE::Session->create( inline_states => { _start => sub { my ($heap) = @_[HEAP, ARG0..$#_]; $poe_kernel->sig(CHLD => 'sig_CHLD'); foreach my $n (1 .. $count) { DEBUG and diag "$$: Launch child $n"; my $w = POE::Wheel::Run->new( Program => \&spawn_child, ProgramArgs => [ $sleep ], StdoutEvent => 'chld_stdout', StderrEvent => 'chld_stderr', CloseEvent => 'chld_close' ); $heap->{PID2W}{$w->PID} = {ID => $w->ID, N => $n, flushed=>0}; $heap->{W}{$w->ID} = $w; } $heap->{TID} = $poe_kernel->delay_set(timeout => $sleep*10); }, chld_stdout => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; $line =~ s/\s+//g; is( $line, 'DONE', "stdout from $wid" ); if( $line eq 'DONE' ) { my $data = $heap->{PID2W}{ $wheel->PID }; $data->{flushed} = 1; } }, chld_stderr => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; if (DEBUG) { diag "CHILD " . $wheel->PID . " STDERR: $line"; } else { fail "stderr from $wid: $line"; } }, say_goodbye => sub { DEBUG and diag "$$: saying goodbye"; foreach my $wheel (values %{$_[HEAP]{W}}) { $wheel->put("die\n"); } DEBUG and diag "$$: said my goodbyes"; }, timeout => sub { fail "Timed out waiting for children to exit"; $poe_kernel->stop(); }, sig_CHLD => sub { my ($heap, $signal, $pid) = @_[HEAP, ARG0, ARG1]; DEBUG and diag "$$: CHLD $pid"; my $data = $heap->{PID2W}{$pid}; die "Unknown wheel PID=$pid" unless defined $data; close_on( 'CHLD', $heap, $data->{ID} ); }, chld_close => sub { my ($heap, $wid) = @_[HEAP, ARG0]; DEBUG and diag "$$: close $wid"; close_on( 'close', $heap, $wid ); }, _stop => sub { }, # Pacify ASSERT_DEFAULT. } ); } sub close_on { my( $why, $heap, $wid ) = @_; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; my $data = $heap->{PID2W}{ $wheel->PID }; $data->{$why}++; return unless $data->{CHLD} and $data->{close}; is( $data->{flushed}, 1, "expected child flush" ); delete $heap->{PID2W}{$wheel->PID}; delete $heap->{W}{$data->{ID}}; pass("Child $data->{ID} exit detected."); unless (keys %{$heap->{W}}) { pass "all children have exited"; $poe_kernel->alarm_remove(delete $heap->{TID}); } } sub spawn_child { my( $sleep ) = @_; #close STDERR; #open STDERR, ">", "child-err.$$"; DEBUG and diag "$$: child sleep=$sleep"; POE::Kernel->stop; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->delay( done => $sleep ); }, _stop => sub { DEBUG and diag "$$: child _stop"; }, done => sub { DEBUG and diag "$$: child done"; print "DONE\n"; }, } ); POE::Kernel->run; } POE-1.368/t/90_regression/tracing-sane-exit.t000644 001751 001751 00000002306 12143730315 021426 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # While Apocalypse was debugging RT#65460 he noticed that POE took a long # time to exit if TRACE_STATISTICS was enabled. It messed up the select # timeout, and causing the internals to go boom! We've removed TRACE_STATISTICS # but this test will remain here in case we screw up in the future :) BEGIN { # perl-5.6.x on Win32 does not support alarm() if ( $^O eq 'MSWin32' and $] < 5.008 ) { print "1..0 # Skip perl-5.6.x on $^O does not support alarm()"; exit(); } # enable full tracing/asserts sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } # make sure tracing don't show up in STDOUT $SIG{'__WARN__'} = sub { return }; } use POE; use Test::More tests => 1; POE::Session->create( inline_states => { _start => sub { $poe_kernel->yield( "do_test" ); return; }, do_test => sub { $poe_kernel->delay( "done" => 1 ); return; }, done => sub { return; }, }, ); $SIG{ALRM} = sub { die 'timeout' }; alarm(10); # set to 10 for slow VMs, lower at your own peril :) eval { POE::Kernel->run }; $SIG{ALRM} = "IGNORE"; ok( ! $@, "POE exited in time" ); POE-1.368/t/90_regression/agaran-filter-httpd.t000644 001751 001751 00000003261 12472121170 021740 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; BEGIN { eval "use HTTP::Request"; if ($@) { print "1..0 # skip - HTTP::Request needed to test POE::Filter::HTTPD\n"; exit; } } use Test::More tests => 3; my $port; use POE qw( Component::Client::TCP Component::Server::TCP Filter::HTTPD ); # # handler # POE::Component::Server::TCP->new( Alias => 's0', Address => '127.0.0.1', Port => 0, ClientFilter => 'POE::Filter::HTTPD', Started => sub { use Socket qw(sockaddr_in); $port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, ClientInput => sub { my ( $kernel, $heap, $request ) = @_[ KERNEL, HEAP, ARG0 ]; isa_ok( $request, 'HTTP::Message', $request); ok( $request->uri() eq '/foo/bar', 'Double striped' ); POE::Kernel->yield('shutdown'); }, ); POE::Component::Client::TCP->new ( Alias => 'c0', RemoteAddress => '127.0.0.1', RemotePort => $port, ServerInput => sub { fail("client c0 got input from server: $_[ARG0]"); }, # Silence errors. ServerError => sub { undef }, ); POE::Component::Client::TCP->new ( Alias => 'c1', RemoteAddress => '127.0.0.1', RemotePort => $port, Connected => sub { ok 1, 'client connected'; $_[HEAP]->{server}->put( "GET //foo/bar 1.0\015\012\015\012"); }, Disconnected => sub { # Shutdown step 2: Kill the server and all remaining connections note "client c1 disconnected"; POE::Kernel->signal( s0 => 'KILL' ); }, ServerInput => sub { fail("client c1 got input from server: $_[ARG0]"); }, # Silence errors. ServerError => sub { undef }, ); $poe_kernel->run(); exit 0; POE-1.368/t/90_regression/grinnz-die-in-die.t000644 001751 001751 00000001355 12472121170 021316 0ustar00bingosbingos000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 3; use POE; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->sig(DIE => 'sig_DIE'); die 'original error'; }, sig_DIE => sub { my $exception = $_[ARG1]; my $event = $exception->{'event'}; my $error = $exception->{'error_str'}; chomp $error; is($event, '_start', "die in $event caught"); die 'error in error handler'; # The die() above bypasses this call. POE::Kernel->sig_handled(); }, } ); eval { POE::Kernel->run(); }; like( $@, qr/original error/, "run() rethrown exception contains original error" ); like( $@, qr/error in error handler/, "run() rethrown exception contains error in error handler" ); POE-1.368/t/90_regression/kjeldahl-stop-start-sig-nopipe.t000644 001751 001751 00000010467 12143730315 024057 0ustar00bingosbingos000000 000000 #!/usr/bin/perl # vim: ts=2 sw=2 filetype=perl expandtab use warnings; use strict; sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } sub POE::Kernel::USE_SIGCHLD () { 1 } sub POE::Kernel::USE_SIGNAL_PIPE () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } use POE; use POE::Wheel::Run; use Test::More; sub DEBUG () { 0 } my $child_process_limit = 3; my $seconds_children_sleep = 1; # Each child process: # child sent done # child flushed # child exited # Each spawn # All children exited # Whole program # Sane exit my $test_count = 3 * $child_process_limit + 1 + 1; plan tests => $test_count; SKIP: { skip("$^O handles fork/call poorly", $test_count) if ( $^O eq "MSWin32" and not $ENV{POE_DANTIC} ); diag "This test can take up to ", $seconds_children_sleep*10, " seconds"; Work->spawn( $child_process_limit, $seconds_children_sleep ); $poe_kernel->run; pass( "Sane exit" ); } ############################################################################ package Work; use strict; use warnings; use POE; use Test::More; BEGIN { *DEBUG = \&::DEBUG; } sub spawn { my( $package, $count, $sleep ) = @_; POE::Session->create( inline_states => { _start => sub { my ($heap) = @_[HEAP, ARG0..$#_]; $poe_kernel->sig(CHLD => 'sig_CHLD'); foreach my $n (1 .. $count) { DEBUG and diag "$$: Launch child $n"; my $w = POE::Wheel::Run->new( Program => \&spawn_child, ProgramArgs => [ $sleep ], StdoutEvent => 'chld_stdout', StderrEvent => 'chld_stderr', CloseEvent => 'chld_close' ); $heap->{PID2W}{$w->PID} = {ID => $w->ID, N => $n, flushed=>0}; $heap->{W}{$w->ID} = $w; } $heap->{TID} = $poe_kernel->delay_set(timeout => $sleep*10); }, chld_stdout => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; $line =~ s/\s+//g; is( $line, 'DONE', "stdout from $wid" ); if( $line eq 'DONE' ) { my $data = $heap->{PID2W}{ $wheel->PID }; $data->{flushed} = 1; } }, chld_stderr => sub { my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1]; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; if (DEBUG) { diag "CHILD " . $wheel->PID . " STDERR: $line"; } else { fail "stderr from $wid: $line"; } }, say_goodbye => sub { DEBUG and diag "$$: saying goodbye"; foreach my $wheel (values %{$_[HEAP]{W}}) { $wheel->put("die\n"); } DEBUG and diag "$$: said my goodbyes"; }, timeout => sub { fail "Timed out waiting for children to exit"; $poe_kernel->stop(); }, sig_CHLD => sub { my ($heap, $signal, $pid) = @_[HEAP, ARG0, ARG1]; DEBUG and diag "$$: CHLD $pid"; my $data = $heap->{PID2W}{$pid}; die "Unknown wheel PID=$pid" unless defined $data; close_on( 'CHLD', $heap, $data->{ID} ); }, chld_close => sub { my ($heap, $wid) = @_[HEAP, ARG0]; DEBUG and diag "$$: close $wid"; close_on( 'close', $heap, $wid ); }, _stop => sub { }, # Pacify ASSERT_DEFAULT. } ); } sub close_on { my( $why, $heap, $wid ) = @_; my $wheel = $heap->{W}{$wid}; die "Unknown wheel $wid" unless $wheel; my $data = $heap->{PID2W}{ $wheel->PID }; $data->{$why}++; return unless $data->{CHLD} and $data->{close}; is( $data->{flushed}, 1, "expected child flush" ); delete $heap->{PID2W}{$wheel->PID}; delete $heap->{W}{$data->{ID}}; pass("Child $data->{ID} exit detected."); unless (keys %{$heap->{W}}) { pass "all children have exited"; $poe_kernel->alarm_remove(delete $heap->{TID}); } } sub spawn_child { my( $sleep ) = @_; DEBUG and diag "$$: child sleep=$sleep"; POE::Kernel->stop; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->delay( done => $sleep ); }, _stop => sub { DEBUG and diag "$$: child _stop"; }, done => sub { DEBUG and diag "$$: child done"; print "DONE\n"; }, } ); POE::Kernel->run; } POE-1.368/t/90_regression/broeren-win32-nbio.t000644 001751 001751 00000005006 12143730315 021425 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab use strict; use POE; use Test::More; BEGIN { if ($^O ne "MSWin32") { plan skip_all => "This test examines ActiveState Perl behavior."; } eval 'use Win32::Console'; if ($@) { plan skip_all => "Win32::Console is required on $^O - try ActivePerl"; } } plan tests => 2; my $obj = new MyDebug; POE::Session->create( object_states => [ $obj => [ '_start', 'next', 'reaper', 'output' ] ] ); POE::Kernel->run; exit(0); # ------------------------------------------------ # Now define our class which does all of the work. # ------------------------------------------------ package MyDebug; use strict; use POE; use POE::Wheel::Run; use Test::More; # Just adding POE::Wheel::SocketFactory breaks the program, the child # will die prematurely use POE::Wheel::SocketFactory; use IO::Handle; use File::Spec; use POSIX qw(dup); sub new { my $class = shift; return bless {}; } sub _start { my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL]; $kernel->sig(CHLD => 'reaper'); $self->{subprocess} = POE::Wheel::Run->new( Program => sub { my $buffer = ""; my $input_stream = IO::Handle::->new_from_fd(dup(fileno(STDIN)), "r"); my $output_stream = IO::Handle::->new_from_fd(dup(fileno(STDOUT)), "w"); my $devnull = File::Spec->devnull(); open(STDIN, "$devnull"); open(STDOUT, ">$devnull"); open(STDERR, ">$devnull"); while (sysread($input_stream, $buffer, 1024 * 32)) { last if $buffer =~ /kill/; my $l = "child [$$] read: $buffer"; syswrite($output_stream,$l,length($l)); } }, StdoutEvent => 'output' ); ok($self->{subprocess}, "we have a subprocess"); $heap->{counter} = 3; $kernel->delay_set('next', 1); } sub output { my ($self, $output) = @_[OBJECT, ARG0]; chomp $output; diag "received data from subprocess: [$output]\n"; } sub reaper { my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; ok(!$heap->{counter}, "child has exited when the counter ran out"); $self->{subprocess} = undef; $kernel->sig_handled; $kernel->sig(CHLD => undef); } sub next { my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; diag "next [$heap->{counter}]\n"; if ($self->{subprocess}) { $self->{subprocess}->put("Can you hear me $heap->{counter}"); } if (--$heap->{counter}) { $kernel->delay_set('next', 1) } elsif ($self->{subprocess}) { diag "Trying to kill [" . $self->{subprocess}->PID . "]\n"; $self->{subprocess}->put("kill"); } } POE-1.368/t/90_regression/ferrari-server-unix.t000644 001751 001751 00000002152 12143730315 022022 0ustar00bingosbingos000000 000000 #!/usr/bin/perl -w # vim: ts=2 sw=2 filetype=perl expandtab # Test case supplied by Martin Ferrari as part of rt.cpan.org bug # 11262 (Debian bug 292526). Ensures that a previous warning will not # be thrown when using UNIX sockets with Server::TCP. use strict; BEGIN { my $error; unless (-f 'run_network_tests') { $error = "Network access (and permission) required to run this test"; } elsif ($^O eq "MSWin32" or $^O eq "MacOS") { $error = "$^O does not support UNIX sockets"; } if ($error) { print "1..0 # Skip $error\n"; exit; } } use POE; use POE::Component::Server::TCP; use Socket qw/AF_UNIX/; use Test::More tests => 1; unless($ARGV[0] && $ARGV[0] eq "test") { my $out = `$^X "$0" test 2>&1 >/dev/null`; chomp($out); isnt($out, "UNIX socket should not throw a warning"); exit; } my $sock = "./testsocket.$$"; unlink($sock); POE::Component::Server::TCP->new( Port => 0, Address => $sock, Domain => AF_UNIX, ClientInput => sub {}, Alias => "testserver", ); POE::Kernel->post(testserver => "shutdown"); POE::Kernel->run(); unlink($sock); exit; POE-1.368/lib/POE.pm000644 001751 001751 00000063540 13615322623 014526 0ustar00bingosbingos000000 000000 # Copyrights and documentation are after __END__. package POE; use strict; use Carp qw( croak ); use vars qw($VERSION); $VERSION = '1.368'; # NOTE - Should be #.### (three decimal places) use POE::Resource::Clock qw( monotime time walltime sleep mono2wall wall2mono ); sub import { my $self = shift; my @loops = grep(/^(?:XS::)?Loop::/, @_); my @sessions = grep(/^(Session|NFA)$/, @_); my @modules = grep(!/^(Kernel|Session|NFA|(?:XS::)?Loop::[\w:]+)$/, @_); croak "can't use multiple event loops at once" if (@loops > 1); croak "POE::Session and POE::NFA export conflicting constants" if scalar @sessions > 1; # If a session was specified, use that. Otherwise use Session. if (@sessions) { unshift @modules, @sessions; } else { unshift @modules, 'Session'; } my $package = caller(); my @failed; # Load POE::Kernel in the caller's package. This is separate # because we need to push POE::Loop classes through POE::Kernel's # import(). { my $loop = ""; if (@loops) { $loop = "{ loop => '" . shift (@loops) . "' }"; } my $code = "package $package; use POE::Kernel $loop;"; # warn $code; eval $code; if ($@) { warn $@; push @failed, "Kernel" } } # Load all the others. foreach my $module (@modules) { my $code = "package $package; use POE::$module;"; # warn $code; eval($code); if ($@) { warn $@; push(@failed, $module); } } @failed and croak "could not import qw(" . join(' ', @failed) . ")"; } 1; __END__ =head1 NAME POE - portable multitasking and networking framework for any event loop =head1 SYNOPSIS #!/usr/bin/perl use warnings; use strict; use POE; # Auto-includes POE::Kernel and POE::Session. sub handler_start { my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION]; print "Session ", $session->ID, " has started.\n"; $heap->{count} = 0; $kernel->yield('increment'); } sub handler_increment { my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION]; print "Session ", $session->ID, " counted to ", ++$heap->{count}, ".\n"; $kernel->yield('increment') if $heap->{count} < 10; } sub handler_stop { print "Session ", $_[SESSION]->ID, " has stopped.\n"; } for (1..10) { POE::Session->create( inline_states => { _start => \&handler_start, increment => \&handler_increment, _stop => \&handler_stop, } ); } POE::Kernel->run(); exit; =head1 DESCRIPTION POE is a framework for cooperative, event driven multitasking and networking in Perl. Other languages have similar frameworks. Python has Twisted. TCL has "the event loop". POE provides a unified interface for several other event loops, including select(), L, L, L, L, L, and L. Many of these event loop interfaces were written by others, with the help of POE::Test::Loops. They may be found on the CPAN. POE achieves its high degree of portability to different operating systems and Perl versions by being written entirely in Perl. CPAN hosts optional XS modules for POE if speed is more desirable than portability. POE is designed in layers. Each layer builds atop the lower level ones. Programs are free to use POE at any level of abstraction, and different levels can be mixed and matched seamlessly within a single program. Remember, though, that higher-level abstractions often require more resources than lower-level ones. The conveniences they provide are not free. POE's bundled abstraction layers are the tip of a growing iceberg. L, L, and other CPAN distributions build upon this work. You're encouraged to look around. No matter how high you go, though, it all boils down to calls to L. So your down-to-earth code can easily cooperate with stratospheric systems. =head2 Layer 1: Kernel and Sessions The lowest public layer is comprised of L, L, and other session types. L does most of the heavy lifting. It provides a portable interface for filehandle activity detection, multiple alarms and other timers, signal handling, and other less-common features. L and derived classes encapsulate the notion of an event driven task. They also customize event dispatch to a particular calling convention. L, for example, is more of a proper state machine. The CPAN has several other kinds of sessions. Everything ultimately builds on these classes or the concepts they implement. If you're short on time, the things to read besides this are L and L. =head2 Layer 2: Wheels, Filters, and Drivers POE::Wheel objects are dynamic mix-ins for POE::Session instances. These "wheels" perform very common, generic tasks in a highly reusable and customizable way. L, for example, implements non-blocking buffered I/O. Nearly everybody needs this, so why require people to reinvent it all the time? L objects customize wheels in a modular way. Filters act as I/O layers, turning raw streams into structured data, and serializing structures into something suitable for streams. The CPAN also has several of these. Drivers are where the wheels meet the road. In this case, the road is some type of file handle. Drivers do the actual reading and writing in a standard way so wheels don't need to know the difference between send() and syswrite(). L objects get relatively short shrift because very few are needed. The most common driver, L is ubiquitous and also the default, so most people will never need to specify one. =head2 Layer 3: Components L classes are essentially Perl classes that use POE to perform tasks in a non-blocking or cooperative way. This is a very broad definition, and POE components are all over the abstraction map. Many components, such as L, encapsulate the generic details of an entire application. Others perform rather narrow tasks, such as L. POE components are often just plain Perl objects. The previously mentioned L uses L. Other object and meta-object frameworks are compatible. Also of interest is L, which allows you to create a POE component from nearly any blocking module. There are quite a lot of components on the CPAN. L =head2 Layer 4 and Beyond: Frameworks and Object Metaphors It's possible to abstract POE entirely behind a different framework. In fact we encourage people to write domain-specific abstractions that entirely hide POE if necessary. The nice thing here is that even at these high levels of abstraction, things will continue to interoperate all the way down to layer 1. Two examples of ultra-high level abstraction are L, a networking framework that does its own thing, and L, which is POE's creator's attempt to formalize and standardize POE components. It is also possible to communicate between POE processes. This is called IKC, for I. There are a few IKC components on the CPAN (L), notably L and L. =head2 Layer 0: POE's Internals POE's layered architecture continues below the surface. POE's guts are broken into specific L classes for each event loop it supports. Internals are divided up by type, giving L classes for Aliases, Controls, Events, Extrefs, FileHandles, SIDs, Sessions and Signals. POE::Kernel's APIs are extensible through POE::API mix-in classes. Some brave souls have even published new APIs on CPAN, such as L (which gives you access to some of the internal L methods). By design, it's possible to implement new L guts by creating another L class. One can then expose the functionality with a new POE::API mix-in. =head1 DOCUMENTATION ROADMAP You're reading the main POE documentation. It's the general entry point to the world of POE. You already know this, however, so let's talk about something more interesting. =head2 Basic Features POE's basic features are documented mainly in L and L. Methods are documented in the classes that implement them. Broader concepts are covered in the most appropriate class, and sometimes they are divided among classes that share in their implementation. =head2 Basic Usage Basic usage, even for POE.pm, is documented in L. That's where most of POE's work is done, and POE.pm is little more than a class loader. =head2 @_[KERNEL, HEAP, etc.] Event handler calling conventions, that weird C<@_[KERNEL, HEAP]> stuff, is documented in L. That's because POE::Session implements the calling convention, and other session types often do it differently. =head2 Base Classes Document Common Features The L, L, L, and L base classes describe what's common among each class. It's a good idea to at least skim the base class documentation since the subclasses tend not to rehash the common things. L, L, and L document the concepts and sometimes the standard interfaces behind multiple subclasses. You're encouraged to have a look. =head2 Helper Classes POE includes some helper classes for portability. L, and its subclasses L and L are portable pipes. =head2 Event Loop Bridges L documents and specifies the interface for all of POE's event loop bridges. The individual classes may document specific details, but generally they adhere to the spec strongly enough that they don't need to. Many of the existing L bridges provided in POE's base distribution will move out to separate distributions shortly. The documentation will probably remain the same, however. =head2 POE::Queue and POE::Queue::Array POE's event queue is basically a priority heap implemented as an ordered array. L documents the standard interface for POE event queues, and L implements the ordered array queue. Tony Cook has released L, which is a drop-in C replacement for L. You might give it a try if you need more performance. POE's event queue is some of the hottest code in the system. =head2 This Section Isn't Complete Help organize the documentation. Obviously we can't think of everything. We're well aware of this and welcome audience participation. =head2 See SEE ALSO Wherever possible, the SEE ALSO section will cross-reference one module to related ones. =head2 Don't Forget the Web Finally, there are many POE resources on the web. The CPAN contains a growing number of POE modules. L hosts POE's wiki, which includes tutorials, an extensive set of examples, documentation, and more. Plus it's a wiki, so you can trivially pitch in your two cents. =head1 SYSTEM REQUIREMENTS POE's basic requirements are rather light. Most are included with modern versions of Perl, and the rest (if any) should be generally portable by now. L is highly recommended, even for older Perls that don't include it. POE will work without it, but alarms and other features will be much more accurate if it's included. L will use Time::HiRes automatically if it's available. L needs a module to serialize data for transporting it across a network. It will use L, L, L, or some other package with freeze() and thaw() methods. It can also use L to conserve bandwidth and reduce latency over slow links, but it's not required. If you want to write web servers, you'll need to install libwww-perl, which requires libnet. This is a small world of modules that includes L, L, L, and L. They are generally good to have, and modern versions of Perl even include them. Programs that use L will of course require the L module, which in turn requires some sort of curses library. If you're using POE with Tk, you'll need L installed. And other obvious things. Let us know if we've overlooked a non-obvious detail. =head1 COMPATIBILITY ISSUES One of POE's design goals is to be as portable as possible. That's why it's written in "Plain Perl". XS versions of POE modules are available as third-party distributions. Parts of POE that require nonstandard libraries are optional, and not having those libraries should not prevent POE from installing. Despite Chris Williams' efforts, we can't test POE everywhere. Please see the GETTING HELP section if you run into a problem. POE is expected to work on most forms of UNIX, including FreeBSD, MacOS X, Linux, Solaris. Maybe even AIX and QNX, but we're not sure. POE is also tested on Windows XP, using the latest version of ActiveState, Strawberry and Cygwin Perl. POE is fully supported with Strawberry Perl, as it's included in the Strawberry distribution. OS/2 and MacOS 9 have been reported to work in the past, but nobody seems to be testing there anymore. Reports and patches are still welcome. Past versions of POE have been tested with Perl versions as far back as 5.6.2 and as recent as "blead", today's development build. We can no longer guarantee each release will work everywhere, but we will be happy to work with you if you need special support for a really old system. You can always use older POE releases that works on your version, please check L. POE's quality is due in large part to the fine work of Chris Williams and the other CPAN testers. They have dedicated resources towards ensuring CPAN distributions pass their own tests, and we watch their reports religiously. You can, too. The latest POE test reports can be found at L. Thanks also go out to Benjamin Smith and the 2006 Google Summer of Code. Ben was awarded a grant to improve POE's test suite, which he did admirably. =head2 Windows Issues POE seems to work very nicely with Perl compiled for Cygwin. If you must use ActiveState Perl, please use the absolute latest version. ActiveState Perl's compatibility fluctuates from one build to another, so we tend not to support older releases. Windows and ActiveState Perl are considered an esoteric platform due to the complex interactions between various versions. POE therefore relies on user feedback and support here. A number of people have helped bring POE's Windows support this far, through contributions of time, patches, and other resources. Some of them are: Sean Puckett, Douglas Couch, Andrew Chen, Uhlarik Ondoej, Nick Williams, and Chris Williams (no relation). =head2 Linux/Unix Issues =head3 pty woes Some distributions chose to not completely setup the pseudo-tty support. This is needed for L to interact with the subprocess. If you see something like this while running C please look at your distribution's documentation on how to fix it. For example, on Debian-based systems the solution was to execute "sudo apt-get install udev". t/30_loops/io_poll/wheel_run.t ..................... 1/99 pty_allocate(nonfatal): posix_openpt(): No such file or directory at /usr/local/lib/perl/5.10.0/IO/Pty.pm line 24. ... Cannot open a pty at /home/apoc/poe/blib/lib/POE/Wheel/Run.pm line 251 Compilation failed in require at t/30_loops/io_poll/wheel_run.t line 24. # Looks like you planned 99 tests but ran 5. # Looks like your test exited with 22 just after 5. t/30_loops/io_poll/wheel_run.t ..................... Dubious, test returned 22 (wstat 5632, 0x1600) =head2 Other Compatibility Issues None currently known. See GETTING HELP below if you've run into something. =head1 GETTING HELP POE's developers take pride in its quality. If you encounter a problem, please let us know. =head2 POE's Request Tracker You're welcome to e-mail questions and bug reports to . This is not a realtime support channel, though. If you need a more immediate response, try one of the methods below. =head2 POE's Mailing List POE has a dedicated mailing list where developers and users discuss the software and its use. You're welcome to join us. Send an e-mail to for subscription instructions. The subject and message body are ignored. =head2 POE's Web Site contains recent information, tutorials, and examples. It's also a wiki, so people are invited to share tips and code snippets there as well. =head2 POE's Source Code The following command will fetch the most current version of POE into the "poe" subdirectory: git clone https://github.com/rcaputo/poe.git =head2 SourceForge http://sourceforge.net/projects/poe/ is POE's project page. =head2 Internet Relay Chat (IRC) irc.perl.org channel #poe is an informal place to waste some time and maybe even discuss Perl and POE. Consider an SSH relay if your workplace frowns on IRC. But only if they won't fire you if you're caught. =head2 Personal Support Unfortunately we don't have resources to provide free one-on-one personal support anymore. We'll do it for a fee, though. Send Rocco an e-mail via his CPAN address. =head1 SEE ALSO Broken down by abstraction layer. =head2 Layer 1 L, L, L =head2 Layer 2 L, L, L, L, L, L, L, L L, L L, L, L, L, L, L, L, L, L, L =head2 Layer 3 L, L, L =head2 Layer 0 L, L, L, L, L, L L, L L, L, L, L, L, L, L, L =head2 Helpers L, L, L =head2 Home Page http://poe.perl.org/ =head2 Bug Tracker https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=POE =head2 Repositories and Changes You can browse the POE source and complete change logs at https://github.com/rcaputo/poe. It also provides an RSS news feed for those who want to follow development in near-realtime. =head2 Other Resources https://metacpan.org/module/POE http://search.cpan.org/dist/POE =head1 AUTHORS & COPYRIGHT POE is the combined effort of quite a lot of people. This is an incomplete list of some early contributors. A more complete list can be found in POE's change log. =over 2 =item Ann Barcomb Ann Barcomb is , aka C. Ann contributed large portions of POE::Simple and the code that became the ReadWrite support in POE::Component::Server::TCP. Her ideas also inspired Client::TCP component, introduced in version 0.1702. =item Artur Bergman Artur Bergman is . He contributed many hours' work into POE and quite a lot of ideas. Years later, I decide he's right and actually implement them. Artur is the author of Filter::HTTPD and Filter::Reference, as well as bits and pieces throughout POE. His feedback, testing, design and inspiration have been instrumental in making POE what it is today. Artur is investing his time heavily into perl 5's iThreads and PONIE at the moment. This project has far-reaching implications for POE's future. =item Jos Boumans Jos Boumans is , aka C. Jos is a major driving force behind the POE::Simple movement and has helped inspire the POE::Components for TCP clients and servers. =item Matt Cashner Matt Cashner is , aka C. Matt is one of POE's core developers. He's spearheaded the movement to simplify POE for new users, flattening the learning curve and making the system more accessible to everyone. He uses the system in mission critical applications, folding feedback and features back into the distribution for everyone's enjoyment. =item Andrew Chen Andrew Chen is . Andrew is the resident POE/Windows guru. He contributes much needed testing for Solaris on the SPARC and Windows on various Intel platforms. =item Douglas Couch Douglas Couch is . Douglas helped port and maintain POE for Windows early on. =item Jeffrey Goff Jeffrey Goff is . Jeffrey is the author of several POE modules, including a tokenizing filter and a component for managing user information, PoCo::UserBase. He's also co-author of "A Beginner's Introduction to POE" at www.perl.com. =item Philip Gwyn Philip Gwyn is . He extended the Wheels I/O abstraction to support hot-swappable filters, and he eventually convinced Rocco that unique session and kernel IDs were a good thing. Philip also enhanced L to support different serialization methods. He has also improved POE's quality by finding and fixing several bugs. He provided POE a much needed code review around version 0.06. Lately, Philip tracked down the race condition in signal handling and fixed it with the signal pipe. =item Arnar M. Hrafnkelsson Arnar is . Addi tested POE and L on Windows, finding bugs and testing fixes. He appears throughout the Changes file. He has also written "cpoe", which is a POE-like library for C. =item Dave Paris Dave Paris is . Dave tested and benchmarked POE around version 0.05, discovering some subtle (and not so subtle) timing problems. The pre-forking server sample was his idea. Versions 0.06 and later scaled to higher loads because of his work. He has contributed a lot of testing and feedback, much of which is tagged in the Changes file as a-mused. The man is scarily good at testing and troubleshooting. =item Dieter Pearcey Dieter Pearcey is . He goes by several Japanese nicknames. Dieter's current area of expertise is in Wheels and Filters. He greatly improved L, and his Filter contributions include the basic Block filter, as well as Stackable, RecordBlock, Grep and Map. =item Plixer International Plixer International is at L. Their sponsorship has helped POE 1.300 and beyond be significantly more robust using iThreads, especially when using fork() in Windows. =item Robert Seifer Robert Seifer is . He rotates IRC nicknames regularly. Robert contributed entirely too much time, both his own and his computers, towards the detection and eradication of a memory corruption bug that POE tickled in earlier Perl versions. In the end, his work produced a simple compile-time hack that worked around a problem relating to anonymous subs, scope and @{} processing. =item Matt Sergeant Matt contributed C, a more efficient way to watch multiple files than select(). It's since been moved to L. =item Richard Soderberg Richard Soderberg is , aka C. Richard is a collaborator on several side projects involving POE. His work provides valuable testing and feedback from a user's point of view. =item Dennis Taylor Dennis Taylor is . Dennis has been testing, debugging and patching bits here and there, such as Filter::Line which he improved by leaps in 0.1102. He's also the author of L, the widely popular POE-based successor to his wildly popular L library. =item David Davis David Davis, aka Xantus is . David contributed patches to the HTTPD filter, and added CALLER_STATE to L. He is the author of L, a networking framework built on POE. =item Others? Please contact the author if you've been forgotten and would like to be included here. =for comment TODO - This section has fallen into disrepair. A POE historian needs to cull the CHANGES for the names of major contributors. =back =head2 Author =over 2 =item Rocco Caputo Rocco Caputo is . POE is his brainchild. He wishes to thank you for your interest, and he has more thanks than he can count for all the people who have contributed. POE would not be nearly as cool without you. Except where otherwise noted, POE is Copyright 1998-2013 Rocco Caputo. All rights reserved. POE is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =back Thank you for reading! =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.368/lib/POE/000755 001751 001751 00000000000 13615550107 014160 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Filter/000755 001751 001751 00000000000 13615550107 015405 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Kernel.pm000644 001751 001751 00000525244 13615322623 015752 0ustar00bingosbingos000000 000000 package POE::Kernel; use strict; use vars qw($VERSION); $VERSION = '1.368'; # NOTE - Should be #.### (three decimal places) use POE::Resource::Clock qw( monotime sleep mono2wall wall2mono walltime time ); use POSIX qw(uname); use Errno qw(ESRCH EINTR ECHILD EPERM EINVAL EEXIST EAGAIN EWOULDBLOCK); use Carp qw(carp croak confess cluck); use Sys::Hostname qw(hostname); use IO::Handle (); use File::Spec (); #use Time::HiRes qw(time sleep); # People expect these to be lexical. use vars qw($poe_kernel $poe_main_window); #------------------------------------------------------------------------------ # A cheezy exporter to avoid using Exporter. my $queue_class; BEGIN { eval { require POE::XS::Queue::Array; POE::XS::Queue::Array->import(); $queue_class = "POE::XS::Queue::Array"; }; unless ($queue_class) { require POE::Queue::Array; POE::Queue::Array->import(); $queue_class = "POE::Queue::Array"; } } sub import { my ($class, $args) = ($poe_kernel, @_[1..$#_]); my $package = caller(); croak "POE::Kernel expects its arguments in a hash ref" if ($args && ref($args) ne 'HASH'); { no strict 'refs'; *{ $package . '::poe_kernel' } = \$poe_kernel; *{ $package . '::poe_main_window' } = \$poe_main_window; } # Extract the import arguments we're interested in here. my $loop = delete $args->{loop} || $ENV{POE_EVENT_LOOP}; # Don't accept unknown/mistyped arguments. my @unknown = sort keys %$args; croak "Unknown POE::Kernel import arguments: @unknown" if @unknown; # Now do things with them. unless (UNIVERSAL::can('POE::Kernel', 'poe_kernel_loop')) { if (defined $loop) { $loop =~ s/^(POE::)?(XS::)?(Loop::)?//; if (defined $2) { $loop = "POE::XS::Loop::$loop"; } else { $loop = "POE::Loop::$loop"; } } _test_loop($loop); # Bootstrap the kernel. This is inherited from a time when multiple # kernels could be present in the same Perl process. POE::Kernel->new() if UNIVERSAL::can('POE::Kernel', 'poe_kernel_loop'); } } #------------------------------------------------------------------------------ # Perform some optional setup. BEGIN { local $SIG{'__DIE__'} = 'DEFAULT'; { no strict 'refs'; if ($^O eq 'MSWin32') { *{ __PACKAGE__ . '::RUNNING_IN_HELL' } = sub { 1 }; } else { *{ __PACKAGE__ . '::RUNNING_IN_HELL' } = sub { 0 }; } } } BEGIN { # The entire BEGIN block is a no-strict-refs zone. no strict 'refs'; # Set up a constant that lets the user deactivate automatic # exception handling. unless (defined &CATCH_EXCEPTIONS) { my $catch_exceptions = ( (exists $ENV{POE_CATCH_EXCEPTIONS}) ? $ENV{POE_CATCH_EXCEPTIONS} : 1 ); if ($catch_exceptions) { *CATCH_EXCEPTIONS = sub () { 1 }; } else { *CATCH_EXCEPTIONS = sub () { 0 }; } } unless (defined &CHILD_POLLING_INTERVAL) { # That's one second, not a true value. *CHILD_POLLING_INTERVAL = sub () { 1 }; } unless (defined &USE_SIGCHLD) { # Perl >= 5.7.3 has safe signals support # perlipc.pod#Deferred_Signals_(Safe_Signals) # We decided to target 5.8.1 just to be safe :) if ( $] >= 5.008001 and not RUNNING_IN_HELL ) { *USE_SIGCHLD = sub () { 1 }; } else { *USE_SIGCHLD = sub () { 0 }; } } unless (defined &USE_SIGNAL_PIPE) { my $use_signal_pipe; if ( exists $ENV{POE_USE_SIGNAL_PIPE} ) { $use_signal_pipe = $ENV{POE_USE_SIGNAL_PIPE}; } if (RUNNING_IN_HELL) { if ($use_signal_pipe) { _warn( "Sorry, disabling USE_SIGNAL_PIPE on $^O.\n", "Programs are reported to hang when it's enabled.\n", ); } # Must be defined to supersede the default. $use_signal_pipe = 0; } if ($use_signal_pipe or not defined $use_signal_pipe) { *USE_SIGNAL_PIPE = sub () { 1 }; } else { *USE_SIGNAL_PIPE = sub () { 0 }; } } } #============================================================================== # Globals, or at least package-scoped things. Data structures were # moved into lexicals in 0.1201. # A reference to the currently active session. Used throughout the # functions that act on the current session. my $kr_active_session; my $kr_active_event; my $kr_active_event_type; # Needs to be lexical so that POE::Resource::Events can see it # change. TODO - Something better? Maybe we call a method in # POE::Resource::Events to trigger the exception there? use vars qw($kr_exception); # The Kernel's master queue. my $kr_queue; # The current PID, to detect when it changes my $kr_pid; # Filehandle activity modes. They are often used as list indexes. sub MODE_RD () { 0 } # read sub MODE_WR () { 1 } # write sub MODE_EX () { 2 } # exception/expedite #------------------------------------------------------------------------------ # Kernel structure. This is the root of a large data tree. Dumping # $poe_kernel with Data::Dumper or something will show most of the # data that POE keeps track of. The exceptions to this are private # storage in some of the leaf objects, such as POE::Wheel. All its # members are described in detail further on. my $kr_id_seq = 0; sub KR_SESSIONS () { 0 } # [ \%kr_sessions, sub KR_FILENOS () { 1 } # \%kr_filenos, sub KR_SIGNALS () { 2 } # \%kr_signals, sub KR_ALIASES () { 3 } # \%kr_aliases, sub KR_ACTIVE_SESSION () { 4 } # \$kr_active_session, sub KR_QUEUE () { 5 } # \$kr_queue, sub KR_ID () { 6 } # $unique_kernel_id, sub KR_SESSION_IDS () { 7 } # \%kr_session_ids, sub KR_SID_SEQ () { 8 } # \$kr_sid_seq, sub KR_EXTRA_REFS () { 9 } # \$kr_extra_refs, sub KR_SIZE () { 10 } # XXX UNUSED ??? sub KR_RUN () { 11 } # \$kr_run_warning sub KR_ACTIVE_EVENT () { 12 } # \$kr_active_event sub KR_PIDS () { 13 } # \%kr_pids_to_events sub KR_ACTIVE_EVENT_TYPE () { 14 } # \$kr_active_event_type # ] # This flag indicates that POE::Kernel's run() method was called. # It's used to warn about forgetting $poe_kernel->run(). sub KR_RUN_CALLED () { 0x01 } # $kernel->run() called sub KR_RUN_SESSION () { 0x02 } # sessions created sub KR_RUN_DONE () { 0x04 } # run returned my $kr_run_warning = 0; #------------------------------------------------------------------------------ # Events themselves. sub EV_SESSION () { 0 } # [ $destination_session, sub EV_SOURCE () { 1 } # $sender_session, sub EV_NAME () { 2 } # $event_name, sub EV_TYPE () { 3 } # $event_type, sub EV_ARGS () { 4 } # \@event_parameters_arg0_etc, # # (These fields go towards the end # because they are optional in some # cases. TODO: Is this still true?) # sub EV_OWNER_FILE () { 5 } # $caller_filename_where_enqueued, sub EV_OWNER_LINE () { 6 } # $caller_line_where_enqueued, sub EV_FROMSTATE () { 7 } # $fromstate sub EV_SEQ () { 8 } # Maintained by POE::Queue (unique event ID) sub EV_WALLTIME () { 9 } # Walltime when event was created (for alarms) sub EV_DELTA () { 10 } # Seconds past walltime for event (for alarms) # ] # These are the names of POE's internal events. They're in constants # so we don't mistype them again. sub EN_CHILD () { '_child' } sub EN_GC () { '_garbage_collect' } sub EN_PARENT () { '_parent' } sub EN_SCPOLL () { '_sigchld_poll' } sub EN_SIGNAL () { '_signal' } sub EN_START () { '_start' } sub EN_STOP () { '_stop' } # These are POE's event classes (types). They often shadow the event # names themselves, but they can encompass a large group of events. # For example, ET_ALARM describes anything enqueued as by an alarm # call. Types are preferred over names because bitmask tests are # faster than string equality tests. sub ET_POST () { 0x0001 } # User events (posted, yielded). sub ET_CALL () { 0x0002 } # User events that weren't enqueued. sub ET_START () { 0x0004 } # _start sub ET_STOP () { 0x0008 } # _stop sub ET_SIGNAL () { 0x0010 } # _signal sub ET_GC () { 0x0020 } # _garbage_collect sub ET_PARENT () { 0x0040 } # _parent sub ET_CHILD () { 0x0080 } # _child sub ET_SCPOLL () { 0x0100 } # _sigchild_poll sub ET_ALARM () { 0x0200 } # Alarm events. sub ET_SELECT () { 0x0400 } # File activity events. sub ET_SIGCLD () { 0x0800 } # sig_child() events. sub ET_SIGDIE () { 0x1000 } # SIGDIE exception events. # A mask for all events generated by/for users. sub ET_MASK_USER () { ~(ET_GC | ET_SCPOLL) } # A mask for all events that are delayed by a dispatch time. sub ET_MASK_DELAYED () { ET_ALARM | ET_SCPOLL } # Temporary signal subtypes, used during signal dispatch semantics # deprecation and reformation. sub ET_SIGNAL_RECURSIVE () { 0x2000 } # Explicitly requested signal. # A hash of reserved names. It's used to test whether someone is # trying to use an internal event directly. my %poes_own_events = ( +EN_CHILD => 1, +EN_GC => 1, +EN_PARENT => 1, +EN_SCPOLL => 1, +EN_SIGNAL => 1, +EN_START => 1, +EN_STOP => 1, +EN_STAT => 1, ); # These are ways a child may come or go. # TODO - It would be useful to split 'lose' into two types. One to # indicate that the child has stopped, and one to indicate that it was # given away. sub CHILD_GAIN () { 'gain' } # The session was inherited from another. sub CHILD_LOSE () { 'lose' } # The session is no longer this one's child. sub CHILD_CREATE () { 'create' } # The session was created as a child of this. # Argument offsets for different types of internally generated events. # TODO Exporting (EXPORT_OK) these would let people stop depending on # positions for them. sub EA_SEL_HANDLE () { 0 } sub EA_SEL_MODE () { 1 } sub EA_SEL_ARGS () { 2 } #------------------------------------------------------------------------------ # Debugging and configuration constants. # Shorthand for defining a trace constant. sub _define_trace { no strict 'refs'; foreach my $name (@_) { next if defined *{"TRACE_$name"}{CODE}; my $trace_value = &TRACE_DEFAULT; my $trace_name = "TRACE_$name"; *$trace_name = sub () { $trace_value }; } } # Debugging flags for subsystems. They're done as double evals here # so that someone may define them before using POE::Kernel (or POE), # and the pre-defined value will take precedence over the defaults # here. my $trace_file_handle; BEGIN { # Shorthand for defining an assert constant. sub _define_assert { no strict 'refs'; foreach my $name (@_) { next if defined *{"ASSERT_$name"}{CODE}; my $assert_value = &ASSERT_DEFAULT; my $assert_name = "ASSERT_$name"; *$assert_name = sub () { $assert_value }; } } # Assimilate POE_TRACE_* and POE_ASSERT_* environment variables. # Environment variables override everything else. while (my ($var, $val) = each %ENV) { next unless $var =~ /^POE_([A-Z_]+)$/; my $const = $1; next unless $const =~ /^(?:TRACE|ASSERT)_/ or do { no strict 'refs'; defined &$const }; # Copy so we don't hurt our environment. my $value = $val; ($value) = ($value =~ /^([-\@\w.]+)$/); # Untaint per rt.cpan.org 81550 $value =~ tr['"][]d; $value = 0 + $value if $value =~ /^\s*-?\d+(?:\.\d+)?\s*$/; no strict 'refs'; local $^W = 0; local $SIG{__WARN__} = sub { }; # redefine my $tmp = $value; *$const = sub () { $tmp }; } # TRACE_FILENAME is special. { no strict 'refs'; my $trace_filename = TRACE_FILENAME() if defined &TRACE_FILENAME; if (defined $trace_filename) { open $trace_file_handle, ">$trace_filename" or die "can't open trace file `$trace_filename': $!"; CORE::select((CORE::select($trace_file_handle), $| = 1)[0]); } } # TRACE_DEFAULT changes the default value for other TRACE_* # constants. Since define_trace() uses TRACE_DEFAULT internally, it # can't be used to define TRACE_DEFAULT itself. defined &TRACE_DEFAULT or *TRACE_DEFAULT = sub () { 0 }; _define_trace qw( EVENTS FILES PROFILE REFCNT RETVALS SESSIONS SIGNALS STATISTICS ); # See the notes for TRACE_DEFAULT, except read ASSERT and assert # where you see TRACE and trace. defined &ASSERT_DEFAULT or *ASSERT_DEFAULT = sub () { 0 }; _define_assert qw(DATA EVENTS FILES RETVALS USAGE); } # An "idle" POE::Kernel may still have events enqueued. These events # regulate polling for signals, profiling, and perhaps other aspects of # POE::Kernel's internal workings. # # XXX - There must be a better mechanism. # my $idle_queue_size; sub _idle_queue_grow { $idle_queue_size++; } sub _idle_queue_shrink { $idle_queue_size--; } sub _idle_queue_size { $idle_queue_size; } sub _idle_queue_reset { $idle_queue_size = 0; } #------------------------------------------------------------------------------ # Helpers to carp, croak, confess, cluck, warn and die with whatever # trace file we're using today. _trap is reserved for internal # errors. sub _trap { local $Carp::CarpLevel = $Carp::CarpLevel + 1; local *STDERR = $trace_file_handle || *STDERR; confess( "=== $$ === Please address any warnings or errors above this message,\n", "=== $$ === and try again. If there are no previous messages, or they\n", "=== $$ === are from within POE, then please mail them along with the\n", "=== $$ === following information to bug-POE\@rt.cpan.org:\n", "---\n@_\n-----\n" ); } sub _croak { local $Carp::CarpLevel = $Carp::CarpLevel + 1; local *STDERR = $trace_file_handle || *STDERR; my $message = join("", @_); $message =~ s/^/=== $$ === /mg; croak $message; } sub _confess { local $Carp::CarpLevel = $Carp::CarpLevel + 1; local *STDERR = $trace_file_handle || *STDERR; my $message = join("", @_); $message =~ s/^/=== $$ === /mg; confess $message; } sub _cluck { local $Carp::CarpLevel = $Carp::CarpLevel + 1; local *STDERR = $trace_file_handle || *STDERR; my $message = join("", @_); $message =~ s/^/=== $$ === /mg; cluck $message; } sub _carp { local $Carp::CarpLevel = $Carp::CarpLevel + 1; local *STDERR = $trace_file_handle || *STDERR; my $message = join("", @_); $message =~ s/^/=== $$ === /mg; carp $message; } sub _warn { my ($package, $file, $line) = caller(); my $message = join("", @_); $message .= " at $file line $line\n" unless $message =~ /\n$/; $message =~ s/^/=== $$ === /mg; warn $message; } sub _die { my ($package, $file, $line) = caller(); my $message = join("", @_); $message .= " at $file line $line\n" unless $message =~ /\n$/; $message =~ s/^/=== $$ === /mg; local *STDERR = $trace_file_handle || *STDERR; die $message; } #------------------------------------------------------------------------------ # Adapt POE::Kernel's personality to whichever event loop is present. my @has_poe_loop; sub _find_loop { my ($mod) = @_; # Turns O(M*N) into O(M+N). I've seen the old way take over 30 # seconds according to Devel::NYTProf, with egregiously long @INCs. unless (@has_poe_loop) { @has_poe_loop = ( grep { (-d "$_/POE/Loop") || (-d "$_/POE/XS/Loop") } @INC ); } foreach my $dir (@has_poe_loop) { return 1 if (-r "$dir/$mod"); } return 0; } sub _load_loop { my $loop = shift; *poe_kernel_loop = sub { return "$loop" }; # Modules can die with "not really dying" if they've loaded # something else. This exception prevents the rest of the # originally used module from being parsed, so the module it's # handed off to takes over. eval "require $loop"; if ($@ and $@ !~ /not really dying/) { die( "*\n", "* POE can't use $loop:\n", "* $@\n", "*\n", ); } } sub _test_loop { my $used_first = shift; local $SIG{__DIE__}; # First see if someone wants to load a POE::Loop or XS version # explicitly. if (defined $used_first) { _load_loop($used_first); return; } foreach my $file (keys %INC) { next if (substr ($file, -3) ne '.pm'); my @split_dirs = File::Spec->splitdir($file); # Create a module name by replacing the path separators with # underscores and removing ".pm" my $module = join("_", @split_dirs); substr($module, -3) = ""; # Skip the module name if it isn't legal. next if $module =~ /[^\w\.]/; # Try for the XS version first. If it fails, try the plain # version. If that fails, we're up a creek. $module = "POE/XS/Loop/$module.pm"; unless (_find_loop($module)) { $module =~ s|XS/||; next unless (_find_loop($module)); } if (defined $used_first and $used_first ne $module) { die( "*\n", "* POE can't use multiple event loops at once.\n", "* You used $used_first and $module.\n", "* Specify the loop you want as an argument to POE\n", "* use POE qw(Loop::Select);\n", "* or;\n", "* use POE::Kernel { loop => 'Select' };\n", "*\n", ); } $used_first = $module; } # No loop found. Default to our internal select() loop. unless (defined $used_first) { $used_first = "POE/XS/Loop/Select.pm"; unless (_find_loop($used_first)) { $used_first =~ s/XS\///; } } substr($used_first, -3) = ""; $used_first =~ s|/|::|g; _load_loop($used_first); } #------------------------------------------------------------------------------ # Include resource modules here. Later, when we have the option of XS # versions, we'll adapt this to include them if they're available. use POE::Resources; ############################################################################### # Helpers. ### Resolve $whatever into a session reference, trying every method we ### can until something succeeds. sub _resolve_session { my ($self, $whatever) = @_; my $session; # Resolve against sessions. $session = $self->_data_ses_resolve($whatever); return $session if defined $session; # Resolve against IDs. $session = $self->_data_sid_resolve($whatever); return $session if defined $session; # Resolve against aliases. $session = $self->_data_alias_resolve($whatever); return $session if defined $session; # Resolve against the Kernel itself. Use "eq" instead of "==" here # because $whatever is often a string. return $whatever if $whatever eq $self; # We don't know what it is. return undef; } ### Test whether POE has become idle. sub _test_if_kernel_is_idle { my $self = shift; if (TRACE_REFCNT) { _warn( " ,----- Kernel Activity -----\n", " | Events : ", $kr_queue->get_item_count(), " (vs. idle size = ", $idle_queue_size, ")\n", " | Files : ", $self->_data_handle_count(), "\n", " | Extra : ", $self->_data_extref_count(), "\n", " | Procs : ", $self->_data_sig_kernel_awaits_pids(), "\n", " | Sess : ", $self->_data_ses_count(), "\n", " `---------------------------\n", " ..." ); } if( ASSERT_DATA ) { if( $kr_pid != $$ ) { _trap( "New process detected. " . "You must call ->has_forked() in the child process." ); } } # Not yet idle, or SO idle that there's nothing to receive the # event. Try to order these from most to least likely to be true so # that the tests short-circuit quickly. return if ( $kr_queue->get_item_count() > $idle_queue_size or $self->_data_handle_count() or $self->_data_extref_count() or $self->_data_sig_kernel_awaits_pids() or !$self->_data_ses_count() ); $self->_data_ev_enqueue( $self, $self, EN_SIGNAL, ET_SIGNAL, [ 'IDLE' ], __FILE__, __LINE__, undef ); } ### Explain why a session could not be resolved. sub _explain_resolve_failure { my ($self, $whatever, $nonfatal) = @_; local $Carp::CarpLevel = 2; if (ASSERT_DATA and !$nonfatal) { _trap "
Cannot resolve ``$whatever'' into a session reference"; } $! = ESRCH; TRACE_RETVALS and _carp " session not resolved: $!"; ASSERT_RETVALS and _carp " session not resolved: $!"; } ### Explain why a function is returning unsuccessfully. sub _explain_return { my ($self, $message) = @_; local $Carp::CarpLevel = 2; ASSERT_RETVALS and _confess " $message"; TRACE_RETVALS and _carp " $message"; } ### Explain how the user made a mistake calling a function. sub _explain_usage { my ($self, $message) = @_; local $Carp::CarpLevel = 2; ASSERT_USAGE and _confess " $message"; ASSERT_RETVALS and _confess " $message"; TRACE_RETVALS and _carp " $message"; } #============================================================================== # SIGNALS #============================================================================== #------------------------------------------------------------------------------ # Register or remove signals. # Public interface for adding or removing signal handlers. sub sig { my ($self, $signal, $event_name, @args) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call sig() from a running session" if $kr_active_session == $self; _confess " undefined signal in sig()" unless defined $signal; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved assigning it to a signal" ) if defined($event_name) and exists($poes_own_events{$event_name}); }; if (defined $event_name) { $self->_data_sig_add($kr_active_session, $signal, $event_name, \@args); } else { $self->_data_sig_remove($kr_active_session->ID, $signal); } } # Public interface for posting signal events. # TODO - Like post(), signal() should return sub signal { my ($self, $dest_session, $signal, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined destination in signal()" unless defined $dest_session; _confess " undefined signal in signal()" unless defined $signal; }; my $session = $self->_resolve_session($dest_session); unless (defined $session) { $self->_explain_resolve_failure($dest_session); return; } $self->_data_ev_enqueue( $session, $kr_active_session, EN_SIGNAL, ET_SIGNAL, [ $signal, @etc ], (caller)[1,2], $kr_active_event ); return 1; } # Public interface for flagging signals as handled. This will replace # the handlers' return values as an implicit flag. Returns undef so # it may be used as the last function in an event handler. sub sig_handled { my $self = $poe_kernel; $self->_data_sig_handled(); if ($kr_active_event eq EN_SIGNAL) { _die( ",----- DEPRECATION ERROR -----\n", "| ", $self->_data_alias_loggable($kr_active_session->ID), ":\n", "| handled a _signal event. You must register a handler with sig().\n", "`-----------------------------\n", ); } } # Attach a window or widget's destroy/closure to the UIDESTROY signal. sub signal_ui_destroy { my ($self, $window) = @_; $self->loop_attach_uidestroy($window); } # Handle child PIDs being reaped. Added 2006-09-15. sub sig_child { my ($self, $pid, $event_name, @args) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call sig_chld() from a running session" if $kr_active_session == $self; _confess " undefined process ID in sig_chld()" unless defined $pid; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved assigning it to a signal" ) if defined($event_name) and exists($poes_own_events{$event_name}); }; if (defined $event_name) { $self->_data_sig_pid_watch($kr_active_session, $pid, $event_name, \@args); } elsif ($self->_data_sig_pids_is_ses_watching($kr_active_session->ID, $pid)) { $self->_data_sig_pid_ignore($kr_active_session->ID, $pid); } } #============================================================================== # KERNEL #============================================================================== sub new { my $type = shift; # Prevent multiple instances, no matter how many times it's called. # This is a backward-compatibility enhancement for programs that # have used versions prior to 0.06. It also provides a convenient # single entry point into the entirety of POE's state: point a # Dumper module at it, and you'll see a hideous tree of knowledge. # Be careful, though. Its apples bite back. unless (defined $poe_kernel) { # Create our master queue. $kr_queue = $queue_class->new(); # Remember the PID $kr_pid = $$; # TODO - Should KR_ACTIVE_SESSIONS and KR_ACTIVE_EVENT be handled # by POE::Resource::Sessions? # TODO - Should the subsystems be split off into separate real # objects, such as KR_QUEUE is? my $self = $poe_kernel = bless [ undef, # KR_SESSIONS - from POE::Resource::Sessions undef, # KR_FILENOS - from POE::Resource::FileHandles undef, # KR_SIGNALS - from POE::Resource::Signals undef, # KR_ALIASES - from POE::Resource::Aliases \$kr_active_session, # KR_ACTIVE_SESSION $kr_queue, # KR_QUEUE - reference to an object undef, # KR_ID undef, # KR_SESSION_IDS - from POE::Resource::SIDS undef, # KR_SID_SEQ - from POE::Resource::SIDS undef, # KR_EXTRA_REFS undef, # KR_SIZE \$kr_run_warning, # KR_RUN \$kr_active_event, # KR_ACTIVE_EVENT undef, # KR_PIDS \$kr_active_event_type, # KR_ACTIVE_EVENT_TYPE ], $type; POE::Resources->load(); $self->_recalc_id(); $self->_data_sid_set($self->[KR_ID], $self); # Initialize subsystems. The order is important. # We need events before sessions, and the kernel's session before # it can start polling for signals. $self->_data_ev_initialize($kr_queue); $self->_initialize_kernel_session(); $self->_data_sig_initialize(); $self->_data_alias_initialize(); # These other subsystems don't have strange interactions. $self->_data_handle_initialize($kr_queue); _idle_queue_reset(); } # Return the global instance. $poe_kernel; } sub CLONE { _data_ses_clone(); } #------------------------------------------------------------------------------ # Send an event to a session right now. Used by _disp_select to # expedite select() events, and used by run() to deliver posted events # from the queue. # Dispatch an event to its session. A lot of work goes on here. sub _dummy_sigdie_handler { 1 } sub _dispatch_signal_event { my ( $self, $session, $source_session, $event, $type, $etc, $file, $line, $fromstate, $priority, $seq ) = @_; # TODO - Regrettably, duplicate checking code in: # _dispatch_signal_event(), _dispatch_event(). if (ASSERT_EVENTS) { _confess " undefined dest session" unless defined $session; _confess " undefined source session" unless defined $source_session; }; if (TRACE_EVENTS) { my $log_session = $session; $log_session = $self->_data_alias_loggable($session->ID) unless ( $type & ET_START ); my $string_etc = join(" ", map { defined() ? $_ : "(undef)" } @$etc); _warn( " Dispatching event $seq ``$event'' ($string_etc) from ", $self->_data_alias_loggable($source_session->ID), " to $log_session" ); } my $signal = $etc->[0]; if (TRACE_SIGNALS) { _warn( " dispatching ET_SIGNAL ($signal) to ", $self->_data_alias_loggable($session->ID) ); } # Step 1a: Reset the handled-signal flags. local @POE::Kernel::kr_signaled_sessions; local $POE::Kernel::kr_signal_total_handled; local $POE::Kernel::kr_signal_type; $self->_data_sig_reset_handled($signal); # Step 1b: Collect a list of sessions to receive the signal. my @touched_sessions = ($session); my $touched_index = 0; while ($touched_index < @touched_sessions) { my $next_target = $touched_sessions[$touched_index]->ID; push @touched_sessions, $self->_data_ses_get_children($next_target); $touched_index++; } # Step 1c: The DIE signal propagates up through parents, too. if ($signal eq "DIE") { my $next_target = $self->_data_ses_get_parent($session->ID); while (defined($next_target) and $next_target != $self) { unshift @touched_sessions, $next_target; $next_target = $self->_data_ses_get_parent($next_target->ID); } } # Step 2: Propagate the signal to the explicit watchers in the # child tree. Ensure the full tree is touched regardless # whether there are explicit watchers. if ($self->_data_sig_explicitly_watched($signal)) { my %signal_watchers = $self->_data_sig_watchers($signal); $touched_index = @touched_sessions; while ($touched_index--) { my $target_session = $touched_sessions[$touched_index]; $self->_data_sig_touched_session($target_session); my $target_sid = $target_session->ID; next unless exists $signal_watchers{$target_sid}; my ($target_event, $target_etc) = @{$signal_watchers{$target_sid}}; if (TRACE_SIGNALS) { _warn( " propagating explicit signal $target_event ($signal) ", "(@$target_etc) to ", $self->_data_alias_loggable($target_sid) ); } # ET_SIGNAL_RECURSIVE is used here to avoid repropagating # the signal ad nauseam. $self->_dispatch_event( $target_session, $self, $target_event, ET_SIGNAL_RECURSIVE | $type, [ @$etc, @$target_etc ], $file, $line, $fromstate, monotime(), -__LINE__ ); } } else { $touched_index = @touched_sessions; while ($touched_index--) { $self->_data_sig_touched_session($touched_sessions[$touched_index]); } } # Step 3: Check to see if the signal was handled. $self->_data_sig_free_terminated_sessions(); # If the signal was SIGDIE, then propagate the exception. my $handled_session_count = (_data_sig_handled_status())[0]; if ($signal eq "DIE" and !$handled_session_count) { $kr_exception = $etc->[1]{error_str} . ( (defined $kr_exception) ? "Additional error thrown in handler for previous error:\n$kr_exception" : '' ); } # Signal completely dispatched. Thanks for flying! return; } sub _dispatch_event { my ( $self, $session, $source_session, $event, $type, $etc, $file, $line, $fromstate, $priority, $seq ) = @_; if (ASSERT_EVENTS) { _confess " undefined dest session" unless defined $session; _confess " undefined source session" unless defined $source_session; }; if (TRACE_EVENTS) { my $log_session = $session; $log_session = $self->_data_alias_loggable($session->ID) unless ( $type & ET_START ); my $string_etc = join(" ", map { defined() ? $_ : "(undef)" } @$etc); _warn( " Dispatching event $seq ``$event'' ($string_etc) from ", $self->_data_alias_loggable($source_session->ID), " to $log_session" ); } ### Pre-dispatch processing. # Some sessions don't do anything in _start and expect their # creators to provide a start-up event. This means we can't # &_collect_garbage at _start time. Instead, an ET_GC event is # posted as part of session allocation. Simply dispatching it # will trigger a GC sweep. return 0 if $type & ET_GC; # Preprocess signals. This is where _signal is translated into # its registered handler's event name, if there is one. if (TRACE_EVENTS) { _warn( " dispatching event $seq ``$event'' to ", $self->_data_alias_loggable($session->ID) ); if ($event eq EN_SIGNAL) { _warn(" signal($etc->[0])"); } } # Prepare to call the appropriate handler. Push the current active # session on Perl's call stack. my ($hold_active_session, $hold_active_event, $hold_active_event_type) = ( $kr_active_session, $kr_active_event, $kr_active_event_type ); ( $kr_active_session, $kr_active_event, $kr_active_event_type ) = ($session, $event, $type); # We only care about the return value and calling context if it's # ET_CALL. my $return; my $wantarray = wantarray(); confess 'please report this stacktrace to bug-poe@rt.cpan.org' unless ( defined $session ); # Quiet SIGDIE if it's DEFAULT. If it's something special, then # someone had better know what they're doing. # 'DEFAULT', undef and '' are all the same. my $old_sig_die = $SIG{__DIE__}; $SIG{__DIE__} = \&_dummy_sigdie_handler if ( not defined $old_sig_die or $old_sig_die eq 'DEFAULT' or $old_sig_die eq '' ); eval { if ($wantarray) { $return = [ $session->_invoke_state( $source_session, $event, $etc, $file, $line, $fromstate ) ]; } elsif (defined $wantarray) { $return = $session->_invoke_state( $source_session, $event, $etc, $file, $line, $fromstate ); } else { $session->_invoke_state( $source_session, $event, $etc, $file, $line, $fromstate ); } }; # An exception happened? # It was intially thrown under the $SIG{__DIE__} conditions that the # user wanted. Any formatting, logging, etc. is already done. if (ref($@) or $@ ne '') { if (CATCH_EXCEPTIONS) { if (TRACE_EVENTS) { _warn( " exception occurred in $event when invoked on ", $self->_data_alias_loggable($session->ID) ); } # Exceptions in _stop are rethrown unconditionally. # We can't enqueue them--the session is about to go away. # Also if the active session has been forced back to $self via # POE::Kernel->stop(). if ($type & (ET_STOP | ET_SIGDIE) or $kr_active_session eq $self) { # Propagate the exception up to the safe rethrow point. $kr_exception = $@; } else { $self->_data_ev_enqueue( $session, $self, EN_SIGNAL, ET_SIGDIE, [ 'DIE' => { source_session => $source_session, dest_session => $session, event => $event, file => $file, line => $line, from_state => $fromstate, error_str => $@, }, ], __FILE__, __LINE__, undef ); } } else { # Propagate the exception up to the safe rethrow point. $kr_exception = $@; } } # Global $sig{__DIE__} changed? For shame! # TODO - This warning is only needed if a SIGDIE handler is active. # TODO - Likewise, setting a SIGDIE with a __DIE__ handler in play # will be tricky or impossible. There should be some message. if ( (not defined $old_sig_die or $old_sig_die eq 'DEFAULT') and $SIG{__DIE__} ne \&_dummy_sigdie_handler ) { _warn( " Event handler redefined global __DIE__ signal handler.\n", " This may conflict with CATCH_EXCEPTIONS handling.\n", " If global redefinition is necessary, do it in global code.\n", ); $SIG{__DIE__} = $old_sig_die; } # Clear out the event arguments list, in case there are POE-ish # things in it. This allows them to destruct happily before we set # the current session back. @$etc = ( ); # Stringify the handler's return value if it belongs in the POE # namespace. $return's scope exists beyond the post-dispatch # processing, which includes POE's garbage collection. The scope # bleed was known to break determinism in surprising ways. if (defined $return and substr(ref($return), 0, 5) eq 'POE::') { $return = "$return"; } # Pop the active session and event, now that they're no longer # active. ($kr_active_session, $kr_active_event, $kr_active_event_type) = ( $hold_active_session, $hold_active_event, $hold_active_event_type ); if (TRACE_EVENTS) { my $string_ret = $return; $string_ret = "undef" unless defined $string_ret; _warn(" event $seq ``$event'' returns ($string_ret)\n"); } # Return doesn't matter unless ET_CALL, ET_START or ET_STOP. return unless $type & (ET_CALL | ET_START | ET_STOP); # Return what the handler did. This is used for call(). return( $wantarray ? @$return : $return ); } #------------------------------------------------------------------------------ # POE's main loop! Now with Tk and Event support! # Do pre-run start-up. Initialize the event loop, and allocate a # session structure to represent the Kernel. sub _initialize_kernel_session { my $self = shift; $self->loop_initialize(); $kr_exception = undef; $kr_active_session = $self; $self->_data_ses_allocate($self, $self->[KR_ID], undef); } # Do post-run cleanup. sub _finalize_kernel { my $self = shift; # Disable signal watching since there's now no place for them to go. foreach ($self->_data_sig_get_safe_signals()) { $self->loop_ignore_signal($_); } # Remove the kernel session's signal watcher. $self->_data_sig_remove($self->ID, "IDLE"); # The main loop is done, no matter which event library ran it. # sig before loop so that it clears the signal_pipe file handler $self->_data_sig_finalize(); $self->loop_finalize(); $self->_data_extref_finalize(); $self->_data_sid_finalize(); $self->_data_alias_finalize(); $self->_data_handle_finalize(); $self->_data_ev_finalize(); $self->_data_ses_finalize(); } sub run_while { my ($self, $scalar_ref) = ($poe_kernel, @_[1..$#_]); 1 while $$scalar_ref and $self->run_one_timeslice(); } sub run_one_timeslice { my $self = $poe_kernel; unless ($self->_data_ses_count()) { $self->_finalize_kernel(); $kr_run_warning |= KR_RUN_DONE; $kr_exception and $self->_rethrow_kr_exception(); return; } $self->loop_do_timeslice(); $kr_exception and $self->_rethrow_kr_exception(); return 1; } sub run { # So run() can be called as a class method. POE::Kernel->new unless defined $poe_kernel; my $self = $poe_kernel; # Flag that run() was called. $kr_run_warning |= KR_RUN_CALLED; # TODO is this check expensive? ( do people run() more than 1 time? ) if( $kr_pid != $$ ) { if ( ASSERT_USAGE ) { _warn "Detected a fork, automatically calling ->has_forked()"; } $self->has_forked; } # Don't run the loop if we have no sessions. # Loop::Event will blow up, so we're doing this sanity check. # It may never trigger, however: See rt.cpan.org 101227. if ( $self->_data_ses_count() == 0 ) { # Emit noise only if we are under debug mode if ( ASSERT_DATA ) { _warn("Not running the event loop because we have no sessions!\n"); } } else { # All signals must be explicitly watched now. We do it here because # it's too early in initialize_kernel_session. $self->_data_sig_add($self, "IDLE", EN_SIGNAL); # Run the loop! $self->loop_run(); # Cleanup $self->_finalize_kernel(); } # Clean up afterwards. $kr_run_warning |= KR_RUN_DONE; $kr_exception and $self->_rethrow_kr_exception(); } sub _rethrow_kr_exception { my $self = shift; # It's quite common to see people wrap POE::Kernel->run() in an eval # block and start things again if an exception is caught. # # This little lexical dance is actually important. It allows # $kr_exception to be cleared if the die() is caught. my $exception = $kr_exception; $kr_exception = undef; # The die is cast. die $exception; } # Stops the kernel cold. XXX Experimental! # No events happen as a result of this, all structures are cleaned up # except the kernel's. Even the current session and POE::Kernel are # cleaned up, which may introduce inconsistencies in the current # session... as _dispatch_event() attempts to clean up for a defunct # session. sub stop { # So stop() can be called as a class method. my $self = $poe_kernel; # May be called when the kernel's already stopped. Avoid problems # trying to find child sessions when the kernel isn't registered. if ($self->_data_ses_exists($self->ID)) { my @children = ($self); foreach my $session (@children) { push @children, $self->_data_ses_get_children($session->ID); } # Don't stop believin'. Nor the POE::Kernel singleton. shift @children; # Walk backwards to avoid inconsistency errors. foreach my $session (reverse @children) { $self->_data_ses_stop($session->ID); } } # Roll back whether sessions were started. $kr_run_warning &= ~KR_RUN_SESSION; # So new sessions will not be child of the current defunct session. $kr_active_session = $self; # The GC mark list may prevent sessions from DESTROYing. # Clean it up. $self->_data_ses_gc_sweep(); # Running stop() is recommended in a POE::Wheel::Run coderef # Program, before setting up for the next POE::Kernel->run(). When # the PID has changed, imply _data_sig_has_forked() during stop(). $poe_kernel->has_forked() if $kr_pid != $$; # TODO - If we're polling for signals, then the reset gets it wrong. # The reset doesn't count sigchld polling. If we must put this # back, it MUST account for all internal events currently in play, # or the child process will stall if it reruns POE::Kernel's loop. #_idle_queue_reset(); return; } # Less invasive form of ->stop() + ->run() sub has_forked { if( $kr_pid == $$ ) { if ( ASSERT_USAGE ) { _warn "You should only call ->has_forked() from the child process."; } return; } # So has_forked() can be called as a class method. my $self = $poe_kernel; $kr_pid = $$; $self->_recalc_id(); # reset some stuff for the signals $poe_kernel->_data_sig_has_forked; } #------------------------------------------------------------------------------ sub DESTROY { my $self = shift; # Warn that a session never had the opportunity to run if one was # created but run() was never called. unless ($kr_run_warning & KR_RUN_CALLED) { if ($kr_run_warning & KR_RUN_SESSION) { _warn( "Sessions were started, but POE::Kernel's run() method was never\n", "called to execute them. This usually happens because an error\n", "occurred before POE::Kernel->run() could be called. Please fix\n", "any errors above this notice, and be sure that POE::Kernel->run()\n", "is called. See documentation for POE::Kernel's run() method for\n", "another way to disable this warning.\n", ); } } } #------------------------------------------------------------------------------ # _invoke_state is what _dispatch_event calls to dispatch a transition # event. This is the kernel's _invoke_state so it can receive events. # These are mostly signals, which are propagated down in # _dispatch_event. sub _invoke_state { my ($self, $source_session, $event, $etc) = @_; # This is an event loop to poll for child processes without needing # to catch SIGCHLD. if ($event eq EN_SCPOLL) { $self->_data_sig_handle_poll_event($etc->[0]); } # A signal was posted. Because signals propagate depth-first, this # _invoke_state is called last in the dispatch. If the signal was # SIGIDLE, then post a SIGZOMBIE if the main queue is still idle. elsif ($event eq EN_SIGNAL) { if ($etc->[0] eq 'IDLE') { unless ( $kr_queue->get_item_count() > $idle_queue_size or $self->_data_handle_count() ) { $self->_data_ev_enqueue( $self, $self, EN_SIGNAL, ET_SIGNAL, [ 'ZOMBIE' ], __FILE__, __LINE__, undef ); } } } return 0; } #============================================================================== # SESSIONS #============================================================================== # Dispatch _start to a session, allocating it in the kernel's data # structures as a side effect. sub session_alloc { my ($self, $session, @args) = ($poe_kernel, @_[1..$#_]); # If we already returned, then we must reinitialize. This is so # $poe_kernel->run() will work correctly more than once. if ($kr_run_warning & KR_RUN_DONE) { $kr_run_warning &= ~KR_RUN_DONE; $self->_initialize_kernel_session(); $self->_data_sig_initialize(); } if (ASSERT_DATA) { if (defined $session->ID) { _trap( " ", $self->_data_alias_loggable($session->ID), " already allocated\a" ); } } # Register that a session was created. $kr_run_warning |= KR_RUN_SESSION; # Allocate the session's data structure. This must be done before # we dispatch anything regarding the new session. my $new_sid = $self->_data_sid_allocate(); $session->_set_id($new_sid); $self->_data_ses_allocate($session, $new_sid, $kr_active_session->ID); my $loggable = $self->_data_alias_loggable($new_sid); # Tell the new session that it has been created. Catch the _start # state's return value so we can pass it to the parent with the # _child create. # # TODO - Void the context if the parent has no _child handler? my $return = $self->_dispatch_event( $session, $kr_active_session, EN_START, ET_START, \@args, __FILE__, __LINE__, undef, monotime(), -__LINE__ ); unless($self->_data_ses_exists($new_sid)) { if(TRACE_SESSIONS) { _warn(" ", $loggable, " disappeared during ", EN_START); } return $return; } # If the child has not detached itself---that is, if its parent is # the currently active session---then notify the parent with a # _child create event. Otherwise skip it, since we'd otherwise # throw a create without a lose. $self->_dispatch_event( $self->_data_ses_get_parent($session->ID), $self, EN_CHILD, ET_CHILD, [ CHILD_CREATE, $session, $return ], __FILE__, __LINE__, undef, monotime(), -__LINE__ ); unless ($self->_data_ses_exists($new_sid)) { if (TRACE_SESSIONS) { _warn(" ", $loggable, " disappeared during ", EN_CHILD, " dispatch"); } return $return; } # Enqueue a delayed garbage-collection event so the session has time # to do its thing before it goes. $self->_data_ev_enqueue( $session, $session, EN_GC, ET_GC, [], __FILE__, __LINE__, undef ); } # Detach a session from its parent. This breaks the parent/child # relationship between the current session and its parent. Basically, # the current session is given to the Kernel session. Unlike with # _stop, the current session's children follow their parent. sub detach_myself { my $self = $poe_kernel; if (ASSERT_USAGE) { _confess " must call detach_myself() from a running session" if $kr_active_session == $self; } # Can't detach from the kernel. if ($self->_data_ses_get_parent($kr_active_session->ID) == $self) { $! = EPERM; return; } my $old_parent = $self->_data_ses_get_parent($kr_active_session->ID); # Tell the old parent session that the child is departing. # But not if the active event is ET_START, since that would generate # a CHILD_LOSE without a CHILD_CREATE. $self->_dispatch_event( $old_parent, $self, EN_CHILD, ET_CHILD, [ CHILD_LOSE, $kr_active_session, undef ], (caller)[1,2], undef, monotime(), -__LINE__ ) unless $kr_active_event_type & ET_START; # Tell the new parent (kernel) that it's gaining a child. # (Actually it doesn't care, so we don't do that here, but this is # where the code would go if it ever does in the future.) # Tell the current session that its parentage is changing. $self->_dispatch_event( $kr_active_session, $self, EN_PARENT, ET_PARENT, [ $old_parent, $self ], (caller)[1,2], undef, monotime(), -__LINE__ ); $self->_data_ses_move_child($kr_active_session->ID, $self->ID); # Success! return 1; } # Detach a child from this, the parent. The session being detached # must be a child of the current session. sub detach_child { my ($self, $child) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call detach_child() from a running session" if $kr_active_session == $self; } my $child_session = $self->_resolve_session($child); unless (defined $child_session) { $self->_explain_resolve_failure($child); return; } # Can't detach if it belongs to the kernel. TODO We shouldn't need # to check for this. if ($kr_active_session == $self) { $! = EPERM; return; } # Can't detach if it's not a child of the current session. unless ( $self->_data_ses_is_child($kr_active_session->ID, $child_session->ID) ) { $! = EPERM; return; } # Tell the current session that the child is departing. $self->_dispatch_event( $kr_active_session, $self, EN_CHILD, ET_CHILD, [ CHILD_LOSE, $child_session, undef ], (caller)[1,2], undef, monotime(), -__LINE__ ); # Tell the new parent (kernel) that it's gaining a child. # (Actually it doesn't care, so we don't do that here, but this is # where the code would go if it ever does in the future.) # Tell the child session that its parentage is changing. $self->_dispatch_event( $child_session, $self, EN_PARENT, ET_PARENT, [ $kr_active_session, $self ], (caller)[1,2], undef, monotime(), -__LINE__ ); $self->_data_ses_move_child($child_session->ID, $self->ID); # Success! return 1; } ### Helpful accessors. sub get_active_session { return $kr_active_session; } sub get_active_event { return $kr_active_event; } # FIXME - Should this exist? sub get_event_count { return $kr_queue->get_item_count(); } # FIXME - Should this exist? sub get_next_event_time { return $kr_queue->get_next_priority(); } #============================================================================== # EVENTS #============================================================================== #------------------------------------------------------------------------------ # Post an event to the queue. sub post { my ($self, $dest_session, $event_name, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " destination is undefined in post()" unless defined $dest_session; _confess " event is undefined in post()" unless defined $event_name; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by posting it" ) if exists $poes_own_events{$event_name}; }; # Attempt to resolve the destination session reference against # various things. my $session = $self->_resolve_session($dest_session); unless (defined $session) { $self->_explain_resolve_failure($dest_session); return; } # Enqueue the event for "now", which simulates FIFO in our # time-ordered queue. $self->_data_ev_enqueue( $session, $kr_active_session, $event_name, ET_POST, \@etc, (caller)[1,2], $kr_active_event ); return 1; } #------------------------------------------------------------------------------ # Post an event to the queue for the current session. sub yield { my ($self, $event_name, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call yield() from a running session" if $kr_active_session == $self; _confess " event name is undefined in yield()" unless defined $event_name; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by yielding it" ) if exists $poes_own_events{$event_name}; }; $self->_data_ev_enqueue( $kr_active_session, $kr_active_session, $event_name, ET_POST, \@etc, (caller)[1,2], $kr_active_event ); undef; } #------------------------------------------------------------------------------ # Call an event handler directly. sub call { my ($self, $dest_session, $event_name, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " destination is undefined in call()" unless defined $dest_session; _confess " event is undefined in call()" unless defined $event_name; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by calling it" ) if exists $poes_own_events{$event_name}; }; # Attempt to resolve the destination session reference against # various things. my $session = $self->_resolve_session($dest_session); unless (defined $session) { $self->_explain_resolve_failure($dest_session); return; } # Dispatch the event right now, bypassing the queue altogether. # This tends to be a Bad Thing to Do. # TODO The difference between synchronous and asynchronous events # should be made more clear in the documentation, so that people # have a tendency not to abuse them. I discovered in xws that # mixing the two types makes it harder than necessary to write # deterministic programs, but the difficulty can be ameliorated if # programmers set some base rules and stick to them. if (wantarray) { my @return_value = ( ($session == $kr_active_session) ? $session->_invoke_state( $session, $event_name, \@etc, (caller)[1,2], $kr_active_event ) : $self->_dispatch_event( $session, $kr_active_session, $event_name, ET_CALL, \@etc, (caller)[1,2], $kr_active_event, monotime(), -__LINE__ ) ); $kr_exception and $self->_rethrow_kr_exception(); $! = 0; return @return_value; } if (defined wantarray) { my $return_value = ( $session == $kr_active_session ? $session->_invoke_state( $session, $event_name, \@etc, (caller)[1,2], $kr_active_event ) : $self->_dispatch_event( $session, $kr_active_session, $event_name, ET_CALL, \@etc, (caller)[1,2], $kr_active_event, monotime(), -__LINE__ ) ); $kr_exception and $self->_rethrow_kr_exception(); $! = 0; return $return_value; } if ($session == $kr_active_session) { $session->_invoke_state( $session, $event_name, \@etc, (caller)[1,2], $kr_active_event ); } else { $self->_dispatch_event( $session, $kr_active_session, $event_name, ET_CALL, \@etc, (caller)[1,2], $kr_active_event, monotime(), -__LINE__ ); } $kr_exception and $self->_rethrow_kr_exception(); $! = 0; return; } #============================================================================== # DELAYED EVENTS #============================================================================== sub alarm { my ($self, $event_name, $time, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call alarm() from a running session" if $kr_active_session == $self; _confess " event name is undefined in alarm()" unless defined $event_name; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting an alarm for it" ) if exists $poes_own_events{$event_name}; }; unless (defined $event_name) { $self->_explain_return("invalid parameter to alarm() call"); return EINVAL; } $self->_data_ev_clear_alarm_by_name($kr_active_session->ID(), $event_name); # Add the new alarm if it includes a time. Calling _data_ev_enqueue # directly is faster than calling alarm_set to enqueue it. if (defined $time) { $self->_data_ev_enqueue ( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], (caller)[1,2], $kr_active_event, $time, ); } else { # The event queue has become empty? Stop the time watcher. $self->loop_pause_time_watcher() unless $kr_queue->get_item_count(); } return 0; } # Add an alarm without clobbering previous alarms of the same name. sub alarm_add { my ($self, $event_name, $time, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call alarm_add() from a running session" if $kr_active_session == $self; _confess " undefined event name in alarm_add()" unless defined $event_name; _confess " undefined time in alarm_add()" unless defined $time; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by adding an alarm for it" ) if exists $poes_own_events{$event_name}; }; unless (defined $event_name and defined $time) { $self->_explain_return("invalid parameter to alarm_add() call"); return EINVAL; } $self->_data_ev_enqueue ( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], (caller)[1,2], $kr_active_event, $time, ); return 0; } # Add a delay, which is like an alarm relative to the current time. sub delay { my ($self, $event_name, $delay, @etc) = ($poe_kernel, @_[1..$#_]); my $pri = monotime(); if (ASSERT_USAGE) { _confess " must call delay() from a running session" if $kr_active_session == $self; _confess " undefined event name in delay()" unless defined $event_name; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting a delay for it" ) if exists $poes_own_events{$event_name}; }; unless (defined $event_name) { $self->_explain_return("invalid parameter to delay() call"); return EINVAL; } if (defined $delay) { $self->_data_ev_clear_alarm_by_name($kr_active_session->ID(), $event_name); # Add the new alarm if it includes a time. Calling _data_ev_enqueue # directly is faster than calling alarm_set to enqueue it. $self->_data_ev_enqueue ( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], (caller)[1,2], $kr_active_event, undef, $delay, $pri+$delay ); } else { $self->alarm($event_name); } return 0; } # Add a delay without clobbering previous delays of the same name. sub delay_add { my ($self, $event_name, $delay, @etc) = ($poe_kernel, @_[1..$#_]); my $pri = monotime(); if (ASSERT_USAGE) { _confess " must call delay_add() from a running session" if $kr_active_session == $self; _confess " undefined event name in delay_add()" unless defined $event_name; _confess " undefined time in delay_add()" unless defined $delay; _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by adding a delay for it" ) if exists $poes_own_events{$event_name}; }; unless (defined $event_name and defined $delay) { $self->_explain_return("invalid parameter to delay_add() call"); return EINVAL; } $self->_data_ev_enqueue ( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], (caller)[1,2], $kr_active_event, undef, $delay, $pri+$delay ); return 0; } #------------------------------------------------------------------------------ # New style alarms. # Set an alarm. This does more *and* less than plain alarm(). It # only sets alarms (that's the less part), but it also returns an # alarm ID (that's the more part). sub alarm_set { my ($self, $event_name, $time, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call alarm_set() from a running session" if $kr_active_session == $self; } unless (defined $event_name) { $self->_explain_usage("undefined event name in alarm_set()"); $! = EINVAL; return; } unless (defined $time) { $self->_explain_usage("undefined time in alarm_set()"); $! = EINVAL; return; } if (ASSERT_USAGE) { _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting an alarm for it" ) if exists $poes_own_events{$event_name}; } return $self->_data_ev_enqueue ( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], (caller)[1,2], $kr_active_event, $time, ); } # Remove an alarm by its ID. TODO Now that alarms and events have # been recombined, this will remove an event by its ID. However, # nothing returns an event ID, so nobody knows what to remove. sub alarm_remove { my ($self, $alarm_id) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call alarm_remove() from a running session" if $kr_active_session == $self; } unless (defined $alarm_id) { $self->_explain_usage("undefined alarm id in alarm_remove()"); $! = EINVAL; return; } my ($time, $event) = $self->_data_ev_clear_alarm_by_id($kr_active_session->ID(), $alarm_id); return unless defined $time; # In a list context, return the alarm that was removed. In a scalar # context, return a reference to the alarm that was removed. In a # void context, return nothing. Either way this returns a defined # value when someone needs something useful from it. return unless defined wantarray; return ( $event->[EV_NAME], $time, $event->[EV_ARGS] ) if wantarray; return [ $event->[EV_NAME], $time, $event->[EV_ARGS] ]; } # Move an alarm to a new time. This virtually removes the alarm and # re-adds it somewhere else. In reality, adjust_priority() is # optimized for this sort of thing. sub alarm_adjust { my ($self, $alarm_id, $delta) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call alarm_adjust() from a running session" if $kr_active_session == $self; } unless (defined $alarm_id) { $self->_explain_usage("undefined alarm id in alarm_adjust()"); $! = EINVAL; return; } unless (defined $delta) { $self->_explain_usage("undefined alarm delta in alarm_adjust()"); $! = EINVAL; return; } my $my_alarm = sub { $_[0]->[EV_SESSION] == $kr_active_session; }; return $self->_data_ev_adjust( $alarm_id, $my_alarm, undef, $delta ); } # A convenient function for setting alarms relative to now. It also # uses whichever time() POE::Kernel can find, which may be # Time::HiRes'. sub delay_set { # Always always always grab time() ASAP, so that the eventual # time we set the delay for is as close as possible to the time # at which they ASKED for the delay, not when we actually set it. my $t = walltime(); my $pri = monotime(); # And now continue as normal my ($self, $event_name, $seconds, @etc) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call delay_set() from a running session" if $kr_active_session == $self; } unless (defined $event_name) { $self->_explain_usage("undefined event name in delay_set()"); $! = EINVAL; return; } if (ASSERT_USAGE) { _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting a delay for it" ) if exists $poes_own_events{$event_name}; } unless (defined $seconds) { $self->_explain_usage("undefined seconds in delay_set()"); $! = EINVAL; return; } return $self->_data_ev_enqueue ( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], (caller)[1,2], $kr_active_event, $t, $seconds, $pri+$seconds ); } # Move a delay to a new offset from time(). As with alarm_adjust(), # this is optimized internally for this sort of activity. sub delay_adjust { # Always always always grab time() ASAP, so that the eventual # time we set the delay for is as close as possible to the time # at which they ASKED for the delay, not when we actually set it. my $t = walltime(); my $pri = monotime(); # And now continue as normal my ($self, $alarm_id, $seconds) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call delay_adjust() from a running session" if $kr_active_session == $self; } unless (defined $alarm_id) { $self->_explain_usage("undefined delay id in delay_adjust()"); $! = EINVAL; return; } unless (defined $seconds) { $self->_explain_usage("undefined delay seconds in delay_adjust()"); $! = EINVAL; return; } my $my_delay = sub { $_[0]->[EV_SESSION] == $kr_active_session; }; if (TRACE_EVENTS) { _warn(" adjusted event $alarm_id by $seconds seconds from $t"); } return $self->_data_ev_set($alarm_id, $my_delay, $t, $pri, $seconds ); } # Remove all alarms for the current session. sub alarm_remove_all { my $self = $poe_kernel; if (ASSERT_USAGE) { _confess " must call alarm_remove_all() from a running session" if $kr_active_session == $self; } # This should never happen, actually. _trap "unknown session in alarm_remove_all call" unless ( $self->_data_ses_exists($kr_active_session->ID) ); # Free every alarm owned by the session. This code is ripped off # from the _stop code to flush everything. my @removed = $self->_data_ev_clear_alarm_by_session( $kr_active_session->ID() ); return unless defined wantarray; return @removed if wantarray; return \@removed; } #============================================================================== # SELECTS #============================================================================== sub _internal_select { my ($self, $session, $handle, $event_name, $mode, $args) = @_; # If an event is included, then we're defining a filehandle watcher. if ($event_name) { $self->_data_handle_add($handle, $mode, $session, $event_name, $args); } else { $self->_data_handle_remove($handle, $mode, $session->ID); } } # A higher-level select() that manipulates read, write and expedite # selects together. sub select { my ($self, $handle, $event_r, $event_w, $event_e, @args) = ( $poe_kernel, @_[1..$#_] ); if (ASSERT_USAGE) { _confess " must call select() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select()" unless defined $handle; _confess " invalid filehandle in select()" unless defined fileno($handle); foreach ($event_r, $event_w, $event_e) { next unless defined $_; _carp( " The '$_' event is one of POE's own. Its " . "effect cannot be achieved by setting a file watcher to it" ) if exists($poes_own_events{$_}); } } $self->_internal_select( $kr_active_session, $handle, $event_r, MODE_RD, \@args ); $self->_internal_select( $kr_active_session, $handle, $event_w, MODE_WR, \@args ); $self->_internal_select( $kr_active_session, $handle, $event_e, MODE_EX, \@args ); return 0; } # Only manipulate the read select. sub select_read { my ($self, $handle, $event_name, @args) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_read() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_read()" unless defined $handle; _confess " invalid filehandle in select_read()" unless defined fileno($handle); _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting a file watcher to it" ) if defined($event_name) and exists($poes_own_events{$event_name}); }; $self->_internal_select( $kr_active_session, $handle, $event_name, MODE_RD, \@args ); return 0; } # Only manipulate the write select. sub select_write { my ($self, $handle, $event_name, @args) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_write() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_write()" unless defined $handle; _confess " invalid filehandle in select_write()" unless defined fileno($handle); _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting a file watcher to it" ) if defined($event_name) and exists($poes_own_events{$event_name}); }; $self->_internal_select( $kr_active_session, $handle, $event_name, MODE_WR, \@args ); return 0; } # Only manipulate the expedite select. sub select_expedite { my ($self, $handle, $event_name, @args) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_expedite() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_expedite()" unless defined $handle; _confess " invalid filehandle in select_expedite()" unless defined fileno($handle); _carp( " The '$event_name' event is one of POE's own. Its " . "effect cannot be achieved by setting a file watcher to it" ) if defined($event_name) and exists($poes_own_events{$event_name}); }; $self->_internal_select( $kr_active_session, $handle, $event_name, MODE_EX, \@args ); return 0; } # Turn off a handle's write mode bit without doing # garbage-collection things. sub select_pause_write { my ($self, $handle) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_pause_write() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_pause_write()" unless defined $handle; _confess " invalid filehandle in select_pause_write()" unless defined fileno($handle); }; return 0 unless $self->_data_handle_is_good($handle, MODE_WR); $self->_data_handle_pause($handle, MODE_WR); return 1; } # Turn on a handle's write mode bit without doing garbage-collection # things. sub select_resume_write { my ($self, $handle) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_resume_write() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_resume_write()" unless defined $handle; _confess " invalid filehandle in select_resume_write()" unless defined fileno($handle); }; return 0 unless $self->_data_handle_is_good($handle, MODE_WR); $self->_data_handle_resume($handle, MODE_WR); return 1; } # Turn off a handle's read mode bit without doing garbage-collection # things. sub select_pause_read { my ($self, $handle) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_pause_read() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_pause_read()" unless defined $handle; _confess " invalid filehandle in select_pause_read()" unless defined fileno($handle); }; return 0 unless $self->_data_handle_is_good($handle, MODE_RD); $self->_data_handle_pause($handle, MODE_RD); return 1; } # Turn on a handle's read mode bit without doing garbage-collection # things. sub select_resume_read { my ($self, $handle) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " must call select_resume_read() from a running session" if $kr_active_session == $self; _confess " undefined filehandle in select_resume_read()" unless defined $handle; _confess " invalid filehandle in select_resume_read()" unless defined fileno($handle); }; return 0 unless $self->_data_handle_is_good($handle, MODE_RD); $self->_data_handle_resume($handle, MODE_RD); return 1; } #============================================================================== # Aliases: These functions expose the internal alias accessors with # extra fun parameter/return value checking. #============================================================================== ### Set an alias in the current session. sub alias_set { my ($self, $name) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined alias in alias_set()" unless defined $name; }; # Don't overwrite another session's alias. my $existing_session = $self->_data_alias_resolve($name); if (defined $existing_session) { if ($existing_session != $kr_active_session) { $self->_explain_usage("alias '$name' is in use by another session"); return EEXIST; } return 0; } $self->_data_alias_add($kr_active_session, $name); return 0; } ### Remove an alias from the current session. sub alias_remove { my ($self, $name) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined alias in alias_remove()" unless defined $name; }; my $existing_session = $self->_data_alias_resolve($name); unless (defined $existing_session) { $self->_explain_usage("alias '$name' does not exist"); return ESRCH; } if ($existing_session != $kr_active_session) { $self->_explain_usage("alias '$name' does not belong to current session"); return EPERM; } $self->_data_alias_remove($kr_active_session, $name); return 0; } ### Resolve an alias into a session. sub alias_resolve { my ($self, $name) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined alias in alias_resolve()" unless defined $name; }; return $self->_resolve_session($name); } ### List the aliases for a given session. sub alias_list { my ($self, $search_session) = ($poe_kernel, @_[1..$#_]); my $session = $self->_resolve_session($search_session || $kr_active_session); unless (defined $session) { $self->_explain_resolve_failure($search_session, "nonfatal"); return; } # Return whatever can be found. my @alias_list = $self->_data_alias_list($session->ID); return wantarray() ? @alias_list : $alias_list[0]; } #============================================================================== # Kernel and Session IDs #============================================================================== # Return the Kernel's "unique" ID. There's only so much uniqueness # available; machines on separate private 10/8 networks may have # identical kernel IDs. The chances of a collision are vanishingly # small. # The Kernel and Session IDs are based on Philip Gwyn's code. I hope # he still can recognize it. sub _recalc_id { my $self = shift; my $old_id = $self->[KR_ID]; my $hostname = eval { (uname)[1] }; $hostname = hostname() unless defined $hostname; my $new_id = $self->[KR_ID] = join( "-", $hostname, map { unpack "H*", $_ } map { pack "N", $_ } (monotime(), $$, ++$kr_id_seq) ); if (defined $old_id) { $self->_data_sig_relocate_kernel_id($old_id, $new_id); $self->_data_ses_relocate_kernel_id($old_id, $new_id); $self->_data_sid_relocate_kernel_id($old_id, $new_id); $self->_data_handle_relocate_kernel_id($old_id, $new_id); $self->_data_ev_relocate_kernel_id($old_id, $new_id); $self->_data_alias_relocate_kernel_id($old_id, $new_id); } } sub ID { $poe_kernel->[KR_ID] } # Resolve an ID to a session reference. This function is virtually # moot now that _resolve_session does it too. This explicit call will # be faster, though, so it's kept for things that can benefit from it. sub ID_id_to_session { my ($self, $id) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined ID in ID_id_to_session()" unless defined $id; }; my $session = $self->_data_sid_resolve($id); return $session if defined $session; $self->_explain_return("ID does not exist"); $! = ESRCH; return; } # Resolve a session reference to its corresponding ID. sub ID_session_to_id { my ($self, $session) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined session in ID_session_to_id()" unless defined $session; }; my $id = $self->_data_ses_resolve_to_id($session); if (defined $id) { $! = 0; return $id; } $self->_explain_return("session ($session) does not exist"); $! = ESRCH; return; } #============================================================================== # Extra reference counts, to keep sessions alive when things occur. # They take session IDs because they may be called from resources at # times where the session reference is otherwise unknown. #============================================================================== sub refcount_increment { my ($self, $session_id, $tag) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined session ID in refcount_increment()" unless defined $session_id; _confess " undefined reference count tag in refcount_increment()" unless defined $tag; }; unless ($self->_data_ses_exists($session_id)) { $self->_explain_return("session id $session_id does not exist"); $! = ESRCH; return; } my $refcount = $self->_data_extref_inc($session_id, $tag); # TODO trace it here return $refcount; } sub refcount_decrement { my ($self, $session_id, $tag) = ($poe_kernel, @_[1..$#_]); if (ASSERT_USAGE) { _confess " undefined session ID in refcount_decrement()" unless defined $session_id; _confess " undefined reference count tag in refcount_decrement()" unless defined $tag; }; unless ($self->_data_ses_exists($session_id)) { $self->_explain_return("session id $session_id does not exist"); $! = ESRCH; return; } my $refcount = $self->_data_extref_dec($session_id, $tag); # TODO trace it here return $refcount; } #============================================================================== # HANDLERS #============================================================================== # Add or remove event handlers from sessions. sub state { my ($self, $event, $state_code, $state_alias) = ($poe_kernel, @_[1..$#_]); $state_alias = $event unless defined $state_alias; if (ASSERT_USAGE) { _confess " must call state() from a running session" if $kr_active_session == $self; _confess " undefined event name in state()" unless defined $event; _confess " can't call state() outside a session" if ( $kr_active_session == $self ); }; if ( (ref($kr_active_session) ne '') && (ref($kr_active_session) ne 'POE::Kernel') ) { $kr_active_session->_register_state($event, $state_code, $state_alias); return 0; } # TODO A terminal signal (such as UIDESTROY) kills a session. The # Kernel deallocates the session, which cascades destruction to its # HEAP. That triggers a Wheel's destruction, which calls # $kernel->state() to remove a state from the session. The session, # though, is already gone. If TRACE_RETVALS and/or ASSERT_RETVALS # is set, this causes a warning or fatal error. $self->_explain_return("session ($kr_active_session) does not exist"); return ESRCH; } 1; __END__ =head1 NAME POE::Kernel - an event-based application kernel in Perl =head1 SYNOPSIS use POE; # auto-includes POE::Kernel and POE::Session POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield("next") }, next => sub { print "tick...\n"; $_[KERNEL]->delay(next => 1); }, }, ); POE::Kernel->run(); exit; In the spirit of Perl, there are a lot of other ways to use POE. =head1 DESCRIPTION POE::Kernel is the heart of POE. It provides the lowest-level features: non-blocking multiplexed I/O, timers, and signal watchers are the most significant. Everything else is built upon this foundation. POE::Kernel is not an event loop in itself. For that it uses one of several available POE::Loop interface modules. See CPAN for modules in the POE::Loop namespace. POE's documentation assumes the reader understands the @_ offset constants (KERNEL, HEAP, ARG0, etc.). The curious or confused reader will find more detailed explanation in L. =head1 USING POE =head2 Literally Using POE POE.pm is little more than a class loader. It implements some magic to cut down on the setup work. Parameters to C are not treated as normal imports. Rather, they're abbreviated modules to be included along with POE. use POE qw(Component::Client::TCP). As you can see, the leading "POE::" can be omitted this way. POE.pm also includes POE::Kernel and POE::Session by default. These two modules are used by nearly all POE-based programs. So the above example is actually the equivalent of: use POE; use POE::Kernel; use POE::Session; use POE::Component::Client::TCP; =head2 Using POE::Kernel POE::Kernel needs to know which event loop you want to use. This is supported in three different ways: The first way is to use an event loop module before using POE::Kernel (or POE, which loads POE::Kernel for you): use Tk; # or one of several others use POE::Kernel. POE::Kernel scans the list of modules already loaded, and it loads an appropriate POE::Loop adapter if it finds a known event loop. The next way is to explicitly load the POE::Loop class you want: use POE qw(Loop::Gtk); Finally POE::Kernel's C supports more programmer-friendly configuration: use POE::Kernel { loop => "Gtk" }; use POE::Session; =head2 Anatomy of a POE-Based Application Programs using POE work like any other. They load required modules, perform some setup, run some code, and eventually exit. Halting Problem notwithstanding. A POE-based application loads some modules, sets up one or more sessions, runs the code in those sessions, and eventually exits. use POE; POE::Session->create( ... map events to code here ... ); POE::Kernel->run(); exit; =head2 POE::Kernel singleton The POE::Kernel is a singleton object; there can be only one POE::Kernel instance within a process. This allows many object methods to also be package methods. =head2 Sessions POE implements isolated compartments called I. Sessions play the role of tasks or threads within POE. POE::Kernel acts as POE's task scheduler, doling out timeslices to each session by invoking callbacks within them. Callbacks are not preemptive. As long as one is running, no others will be dispatched. This is known as I multitasking. Each session must cooperate by returning to the central dispatching kernel. Cooperative multitasking vastly simplifies data sharing, since no two pieces of code may alter data at once. A session may also take exclusive control of a program's time, if necessary, by simply not returning in a timely fashion. It's even possible to write completely blocking programs that use POE as a state machine rather than a cooperative dispatcher. Every POE-based application needs at least one session. Code cannot run I without being a part of some session. Likewise, a threaded program always has a "thread zero". Sessions in POE::Kernel should not be confused with L even though the two are inextricably associated. POE::Session adapts POE::Kernel's dispatcher to a particular calling convention. Other POE::Session classes exist on the CPAN. Some radically alter the way event handlers are called. L. =head2 Resources Resources are events and things which may create new events, such as timers, I/O watchers, and even other sessions. POE::Kernel tracks resources on behalf of its active sessions. It generates events corresponding to these resources' activity, notifying sessions when it's time to do things. The conversation goes something like this: Session: Be a dear, Kernel, and let me know when someone clicks on this widget. Thanks so much! [TIME PASSES] [SFX: MOUSE CLICK] Kernel: Right, then. Someone's clicked on your widget. Here you go. Furthermore, since the Kernel keeps track of everything sessions do, it knows when a session has run out of tasks to perform. When this happens, the Kernel emits a C<_stop> event at the dead session so it can clean up and shutdown. Kernel: Please switch off the lights and lock up; it's time to go. Likewise, if a session stops on its own and there still are opened resource watchers, the Kernel knows about them and cleans them up on the session's behalf. POE excels at long-running services because it so meticulously tracks and cleans up resources. POE::Resources and the POE::Resource classes implement each kind of resource, which are summarized here and covered in greater detail later. =over 2 =item Events. An event is a message to a sessions. Posting an event keeps both the sender and the receiver alive until after the event has been dispatched. This is only guaranteed if both the sender and receiver are in the same process. Inter-Kernel message passing add-ons may have other guarantees. Please see their documentation for details. The rationale is that the event is in play, so the receiver must remain active for it to be dispatched. The sender remains alive in case the receiver would like to send back a response. Posted events cannot be preemptively canceled. They tend to be short-lived in practice, so this generally isn't an issue. =item Timers. Timers allow an application to send a message to the future. Once set, a timer will keep the destination session active until it goes off and the resulting event is dispatched. =item Aliases. Session aliases are an application-controlled way of addressing a session. Aliases act as passive event watchers. As long as a session has an alias, some other session may send events to that session by that name. Aliases keep sessions alive as long as a process has active sessions. If the only sessions remaining are being kept alive solely by their aliases, POE::Kernel will send them a terminal L signal. In most cases this will terminate the remaining sessions and allow the program to exit. If the sessions remain in memory without waking up on the C signal, POE::Kernel sends them a non-maskable L signal. They are then forcibly removed, and the program will finally exit. =item I/O watchers. A session will remain active as long as a session is paying attention to some external data source or sink. See L and L. =item Child sessions. A session acting as a parent of one or more other sessions will remain active until all the child sessions stop. This may be bypassed by detaching the children from the parent. =item Child processes. Child process are watched by sig_child(). The sig_child() watcher will keep the watching session active until the child process has been reaped by POE::Kernel and the resulting event has been dispatched. All other signal watchers, including using L to watch for C, do not keep their sessions active. If you need a session to remain active when it's only watching for signals, have it set an alias or one of its own public reference counters. =item Public reference counters. A session will remain active as long as it has one or more nonzero public (or external) reference counter. =back =head2 Session Lifespans "Session" as a term is somewhat overloaded. There are two related concepts that share the name. First there is the class POE::Session, and objects created with it or related classes. Second there is a data structure within POE::Kernel that tracks the POE::Session objects in play and the various resources owned by each. The way POE's garbage collector works is that a session object gives itself to POE::Kernel at creation time. The Kernel then holds onto that object as long as resources exist that require the session to remain alive. When all of these resources are destroyed or released, the session object has nothing left to trigger activity. POE::Kernel notifies the object it's through, and cleans up its internal session context. The session object is released, and self-destructs in the normal Perlish fashion. Sessions may be stopped even if they have active resources. For example, a session may fail to handle a terminal signal. In this case, POE::Kernel forces the session to stop, and all resources associated with the session are preemptively released. =head2 Events An event is a message that is sent from one part of the POE application to another. An event consists of the event's name, optional event-specific parameters and OOB information. An event may be sent from the kernel, from a wheel or from a session. An application creates an event with L, L, L or even L. POE::Kernel creates events in response external stimulus (signals, select, etc). =head3 Event Handlers An event is handled by a function called an I, which is some code that is designated to be called when a particular event is dispatched. See L and L. The term I is often used in place of I, especially when treating sessions as event driven state machines. Handlers are always called in scalar context for asynchronous events (i.e. via post()). Synchronous events, invoked with call(), are handled in the same context that call() was called. Event handlers may not directly return references to objects in the "POE" namespace. POE::Kernel will stringify these references to prevent timing issues with certain objects' destruction. For example, this error handler would cause errors because a deleted wheel would not be destructed when one might think: sub handle_error { warn "Got an error"; delete $_[HEAP]{wheel}; } The delete() call returns the deleted wheel member, which is then returned implicitly by handle_error(). =head2 Using POE with Other Event Loops POE::Kernel supports any number of event loops. Two are included in the base distribution. Historically, POE included other loops but they were moved into a separate distribution. You can find them and other loops on the CPAN. POE's public interfaces remain the same regardless of the event loop being used. Since most graphical toolkits include some form of event loop, back-end code should be portable to all of them. POE's cooperation with other event loops lets POE be embedded into other software. The common underlying event loop drives both the application and POE. For example, by using POE::Loop::Glib, one can embed POE into Vim, irssi, and so on. Application scripts can then take advantage of POE::Component::Client::HTTP (and everything else) to do large-scale work without blocking the rest of the program. Because this is Perl, there are multiple ways to load an alternate event loop. The simplest way is to load the event loop before loading POE::Kernel. use Gtk; use POE; Remember that POE loads POE::Kernel internally. POE::Kernel examines the modules loaded before it and detects that L has been loaded. If L is available, POE loads and hooks it into POE::Kernel automatically. It's less mysterious to load the appropriate L class directly. Their names follow the format C, where C<$loop_module_name> is the name of the event loop module after each C<::> has been substituted with an underscore. It can be abbreviated using POE's loader magic. use POE qw( Loop::Event_Lib ); POE also recognizes XS loops, they reside in the C namespace. Using them may give you a performance improvement on your platform, as the eventloop are some of the hottest code in the system. As always, benchmark your application against various loops to see which one is best for your workload and platform. use POE qw( XS::Loop::EPoll ); Please don't load the loop modules directly, because POE will not have a chance to initialize it's internal structures yet. Code written like this will throw errors on startup. It might look like a bug in POE, but it's just the way POE is designed. use POE::Loop::IO_Poll; use POE; POE::Kernel also supports configuration directives on its own C line. A loop explicitly specified this way will override the search logic. use POE::Kernel { loop => "Glib" }; Finally, one may specify the loop class by setting the POE::Loop or POE::XS:Loop class name in the POE_EVENT_LOOP environment variable. This mechanism was added for tests that need to specify the loop from a distance. BEGIN { $ENV{POE_EVENT_LOOP} = "POE::XS::Loop::Poll" } use POE; Of course this may also be set from your shell: % export POE_EVENT_LOOP='POE::XS::Loop::Poll' % make test Many external event loops support their own callback mechanisms. L's L<"postback()"|POE::Session/postback> and L<"callback()"|POE::Session/callback> methods return plain Perl code references that will generate POE events when called. Applications can pass these code references to event loops for use as callbacks. POE's distribution includes two event loop interfaces. CPAN holds several more: =head3 POE::Loop::Select (bundled) By default POE uses its select() based loop to drive its event system. This is perhaps the least efficient loop, but it is also the most portable. POE optimizes for correctness above all. =head3 POE::Loop::IO_Poll (bundled) The L event loop provides an alternative that theoretically scales better than select(). =head3 POE::Loop::Event (separate distribution) This event loop provides interoperability with other modules that use L. It may also provide a performance boost because L is written in a compiled language. Unfortunately, this makes L less portable than Perl's built-in select(). =head3 POE::Loop::Gtk (separate distribution) This event loop allows programs to work under the L graphical toolkit. =head3 POE::Loop::Tk (separate distribution) This event loop allows programs to work under the L graphical toolkit. Tk has some restrictions that require POE to behave oddly. Tk's event loop will not run unless one or more widgets are created. POE must therefore create such a widget before it can run. POE::Kernel exports $poe_main_window so that the application developer may use the widget (which is a L), since POE doesn't need it other than for dispatching events. Creating and using a different MainWindow often has an undesired outcome. =head3 POE::Loop::EV (separate distribution) L allows POE-based programs to use the EV event library with little or no change. =head3 POE::Loop::Glib (separate distribution) L allows POE-based programs to use Glib with little or no change. It also supports embedding POE-based programs into applications that already use Glib. For example, we have heard that POE has successfully embedded into vim, irssi and xchat via this loop. =head3 POE::Loop::Kqueue (separate distribution) L allows POE-based programs to transparently use the BSD kqueue event library on operating systems that support it. =head3 POE::Loop::Prima (separate distribution) L allows POE-based programs to use Prima's event loop with little or no change. It allows POE libraries to be used within Prima applications. =head3 POE::Loop::Wx (separate distribution) L allows POE-based programs to use Wx's event loop with little or no change. It allows POE libraries to be used within Wx applications, such as Padre. =head3 POE::XS::Loop::EPoll (separate distribution) L allows POE components to transparently use the EPoll event library on operating systems that support it. =head3 POE::XS::Loop::Poll (separate distribution) L is a higher-performance C-based libpoll event loop. It replaces some of POE's hot Perl code with C for better performance. =head3 Other Event Loops (separate distributions) POE may be extended to handle other event loops. Developers are invited to work with us to support their favorite loops. =head1 PUBLIC METHODS POE::Kernel encapsulates a lot of features. The documentation for each set of features is grouped by purpose. =head2 Kernel Management and Accessors =head3 ID ID() currently returns POE::Kernel's unique identifier. Every Kernel instance is assigned a globally unique ID at birth. has_forked() alters the ID so that each forked process has a unique one, too. % perl -wl -MPOE -e 'print $poe_kernel->ID' macbookpoe.local-4d5305de-0000e6b8-00000001 The content of these IDs may change from time to time. Your code should not depend upon the current format. B Your code should not depend upon ID() remaining unique. The uniqueness will be removed in a future release of POE. If you require unique IDs, please see one of the fine GUID and/or UUID modules on the CPAN: http://search.cpan.org/search?query=GUID&mode=dist http://search.cpan.org/search?query=UUID&mode=dist POE doesn't require globally or universally unique kernel IDs. The creation and maintenance of these IDs adds overhead to POE::Kernel's has_forked() method. Other modules do it better, upon demand, without incurring overhead for those who don't need them. =head3 run run() runs POE::Kernel's event dispatcher. It will not return until all sessions have ended. run() is a class method so a POE::Kernel reference is not needed to start a program's execution. use POE; POE::Session->create( ... ); # one or more POE::Kernel->run(); # set them all running exit; POE implements the Reactor pattern at its core. Events are dispatched to functions and methods through callbacks. The code behind run() waits for and dispatches events. run() will not return until every session has ended. This includes sessions that were created while run() was running. POE::Kernel will print a strong message if a program creates sessions but fails to call run(). Prior to this warning, we received tons of bug reports along the lines of "my POE program isn't doing anything". It turned out that people forgot to start an event dispatcher, so events were never dispatched. If the lack of a run() call is deliberate, perhaps because some other event loop already has control, you can avoid the message by calling it before creating a session. run() at that point will initialize POE and return immediately. POE::Kernel will be satisfied that run() was called, although POE will not have actually taken control of the event loop. use POE; POE::Kernel->run(); # silence the warning POE::Session->create( ... ); exit; Note, however, that this varies from one event loop to another. If a particular POE::Loop implementation doesn't support it, that's probably a bug. Please file a bug report with the owner of the relevant POE::Loop module. =head3 run_one_timeslice run_one_timeslice() dispatches any events that are due to be delivered. These events include timers that are due, asynchronous messages that need to be delivered, signals that require handling, and notifications for files with pending I/O. Do not rely too much on event ordering. run_one_timeslice() is defined by the underlying event loop, and its timing may vary. run() is implemented similar to run_one_timeslice() while $session_count > 0; run_one_timeslice() can be used to keep running POE::Kernel's dispatcher while emulating blocking behavior. The pattern is implemented with a flag that is set when some asynchronous event occurs. A loop calls run_one_timeslice() until that flag is set. For example: my $done = 0; sub handle_some_event { $done = 1; } $kernel->run_one_timeslice() while not $done; Do be careful. The above example will spin if POE::Kernel is done but $done is never set. The loop will never be done, even though there's nothing left that will set $done. =head3 run_while SCALAR_REF run_while() is an B version of run_one_timeslice() that will only return when there are no more active sessions, or the value of the referenced scalar becomes false. Here's a version of the run_one_timeslice() example using run_while() instead: my $job_count = 3; sub handle_some_event { $job_count--; } $kernel->run_while(\$job_count); =head3 has_forked my $pid = fork(); die "Unable to fork" unless defined $pid; unless( $pid ) { $poe_kernel->has_forked; } Inform the kernel that it is now running in a new process. This allows the kernel to reset some internal data to adjust to the new situation. has_forked() must be called in the child process if you wish to run the same kernel. However, if you want the child process to have new kernel, you must call L instead. B POE's internals will detect if a fork occurred before C and will call C automatically. If you are unsure whether you need to call it or not, please enable L and POE will emit a warning if it's necessary. =head3 stop stop() causes POE::Kernel->run() to return early. It does this by emptying the event queue, freeing all used resources, and stopping every active session. stop() is not meant to be used lightly. Proceed with caution. Caveats: The session that calls stop() will not be fully DESTROYed until it returns. Invoking an event handler in the session requires a reference to that session, and weak references are prohibited in POE for backward compatibility reasons, so it makes sense that the last session won't be garbage collected right away. Sessions are not notified about their destruction. If anything relies on _stop being delivered, it will break and/or leak memory. stop() is still considered experimental. It was added to improve fork() support for L. If it proves unfixably problematic, it will be removed without much notice. stop() is advanced magic. Programmers who think they need it are invited to become familiar with its source. See L for an example of how to use this facility. =head2 Asynchronous Messages (FIFO Events) Asynchronous messages are events that are dispatched in the order in which they were enqueued (the first one in is the first one out, otherwise known as first-in/first-out, or FIFO order). These methods enqueue new messages for delivery. The act of enqueuing a message keeps the sender alive at least until the message is delivered. =head3 post DESTINATION, EVENT_NAME [, PARAMETER_LIST] post() enqueues a message to be dispatched to a particular DESTINATION session. The message will be handled by the code associated with EVENT_NAME. If a PARAMETER_LIST is included, its values will also be passed along. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->post( $_[SESSION], "event_name", 0 ); }, event_name => sub { print "$_[ARG0]\n"; $_[KERNEL]->post( $_[SESSION], "event_name", $_[ARG0] + 1 ); }, } ); post() returns a Boolean value indicating whether the message was successfully enqueued. If post() returns false, $! is set to explain the failure: ESRCH ("No such process") - The DESTINATION session did not exist at the time post() was called. =head3 yield EVENT_NAME [, PARAMETER_LIST] yield() is a shortcut for post() where the destination session is the same as the sender. This example is equivalent to the one for post(): POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield( "event_name", 0 ); }, event_name => sub { print "$_[ARG0]\n"; $_[KERNEL]->yield( "event_name", $_[ARG0] + 1 ); }, } ); As with post(), yield() returns right away, and the enqueued EVENT_NAME is dispatched later. This may be confusing if you're already familiar with threading. yield() should always succeed, so it does not return a meaningful value. =head2 Synchronous Messages It is sometimes necessary for code to be invoked right away. For example, some resources must be serviced right away, or they'll faithfully continue reporting their readiness. These reports would appear as a stream of duplicate events. Synchronous events can also prevent data from going stale between the time an event is enqueued and the time it's delivered. Synchronous event handlers preempt POE's event queue, so they should perform simple tasks of limited duration. Synchronous events that need to do more than just service a resource should pass the resource's information to an asynchronous handler. Otherwise synchronous operations will occur out of order in relation to asynchronous events. It's very easy to have race conditions or break causality this way, so try to avoid it unless you're okay with the consequences. POE provides these ways to call message handlers right away. =head3 call DESTINATION, EVENT_NAME [, PARAMETER_LIST] call()'s semantics are nearly identical to post()'s. call() invokes a DESTINATION's handler associated with an EVENT_NAME. An optional PARAMETER_LIST will be passed along to the message's handler. The difference, however, is that the handler will be invoked immediately, even before call() returns. call() returns the value returned by the EVENT_NAME handler. It can do this because the handler is invoked before call() returns. call() can therefore be used as an accessor, although there are better ways to accomplish simple accessor behavior. POE::Session->create( inline_states => { _start => sub { print "Got: ", $_[KERNEL]->call($_[SESSION], "do_now"), "\n"; }, do_now => sub { return "some value"; } } ); The L classes uses call() to synchronously deliver I/O notifications. This avoids a host of race conditions. call() may fail in the same way and for the same reasons as post(). On failure, $! is set to some nonzero value indicating why. Since call() may return undef as a matter of course, it's recommended that $! be checked for the error condition as well as the explanation. ESRCH ("No such process") - The DESTINATION session did not exist at the time post() was called. =head2 Timer Events (Delayed Messages) It's often useful to wait for a certain time or until a certain amount of time has passed. POE supports this with events that are deferred until either an absolute time ("alarms") or until a certain duration of time has elapsed ("delays"). Timer interfaces are further divided into two groups. One group identifies timers by the names of their associated events. Another group identifies timers by a unique identifier returned by the timer constructors. Technically, the two are both name-based, but the "identifier-based" timers provide a second, more specific handle to identify individual timers. Timers may only be set up for the current session. This design was modeled after alarm() and SIGALRM, which only affect the current UNIX process. Each session has a separate namespace for timer names. Timer methods called in one session cannot affect the timers in another. As you may have noticed, quite a lot of POE's API is designed to prevent sessions from interfering with each other. The best way to simulate deferred inter-session messages is to send an immediate message that causes the destination to set a timer. The destination's timer then defers the action requested of it. This way is preferred because the time spent communicating the request between sessions may not be trivial, especially if the sessions are separated by a network. The destination can determine how much time remains on the requested timer and adjust its wait time accordingly. =head3 Name-Based Timers Name-based timers are identified by the event names used to set them. It is possible for different sessions to use the same timer event names, since each session is a separate compartment with its own timer namespace. It is possible for a session to have multiple timers for a given event, but results may be surprising. Be careful to use the right timer methods. The name-based timer methods are alarm(), alarm_add(), delay(), and delay_add(). =head4 alarm EVENT_NAME [, EPOCH_TIME [, PARAMETER_LIST] ] alarm() clears all existing timers in the current session with the same EVENT_NAME. It then sets a new timer, named EVENT_NAME, that will fire EVENT_NAME at the current session when EPOCH_TIME has been reached. An optional PARAMETER_LIST may be passed along to the timer's handler. Omitting the EPOCH_TIME and subsequent parameters causes alarm() to clear the EVENT_NAME timers in the current session without setting a new one. EPOCH_TIME is the UNIX epoch time. You know, seconds since midnight, 1970-01-01. POE uses Time::HiRes::time(), which allows EPOCH_TIME to be (or include) fractional seconds. POE supports fractional seconds, but accuracy falls off steeply after 1/100 second. Mileage will vary depending on your CPU speed and your OS time resolution. Be sure to use Time::HiRes::time() rather than Perl's built-in time() if sub-second accuracy matters at all. The built-in time() returns floor(Time::HiRes::time()), which is nearly always some fraction of a second in the past. For example the high-resolution time might be 1200941422.89996. At that same instant, time() would be 1200941422. An alarm for time() + 0.5 would be 0.39996 seconds in the past, so it would be dispatched immediately (if not sooner). POE's event queue is time-ordered, so a timer due before time() will be delivered ahead of other events but not before timers with even earlier due times. Therefore an alarm() with an EPOCH_TIME before time() jumps ahead of the queue. All timers are implemented identically internally, regardless of how they are set. alarm() will therefore blithely clear timers set by other means. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alarm( tick => time() + 1, 0 ); }, tick => sub { print "tick $_[ARG0]\n"; $_[KERNEL]->alarm( tock => time() + 1, $_[ARG0] + 1 ); }, tock => sub { print "tock $_[ARG0]\n"; $_[KERNEL]->alarm( tick => time() + 1, $_[ARG0] + 1 ); }, } ); alarm() returns 0 on success or a true value on failure. Usually EINVAL to signal an invalid parameter, such as an undefined EVENT_NAME. =head4 alarm_add EVENT_NAME, EPOCH_TIME [, PARAMETER_LIST] alarm_add() is used to add a new alarm timer named EVENT_NAME without clearing existing timers. EPOCH_TIME is a required parameter. Otherwise the semantics are identical to alarm(). A program may use alarm_add() without first using alarm(). POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alarm_add( tick => time() + 1.0, 1_000_000 ); $_[KERNEL]->alarm_add( tick => time() + 1.5, 2_000_000 ); }, tick => sub { print "tick $_[ARG0]\n"; $_[KERNEL]->alarm_add( tock => time() + 1, $_[ARG0] + 1 ); }, tock => sub { print "tock $_[ARG0]\n"; $_[KERNEL]->alarm_add( tick => time() + 1, $_[ARG0] + 1 ); }, } ); alarm_add() returns 0 on success or EINVAL if EVENT_NAME or EPOCH_TIME is undefined. =head4 delay EVENT_NAME [, DURATION_SECONDS [, PARAMETER_LIST] ] delay() clears all existing timers in the current session with the same EVENT_NAME. It then sets a new timer, named EVENT_NAME, that will fire EVENT_NAME at the current session when DURATION_SECONDS have elapsed from "now". An optional PARAMETER_LIST may be passed along to the timer's handler. Omitting the DURATION_SECONDS and subsequent parameters causes delay() to clear the EVENT_NAME timers in the current session without setting a new one. DURATION_SECONDS may be or include fractional seconds. As with all of POE's timers, accuracy falls off steeply after 1/100 second. Mileage will vary depending on your CPU speed and your OS time resolution. POE's event queue is time-ordered, so a timer due before time() will be delivered ahead of other events but not before timers with even earlier due times. Therefore a delay () with a zero or negative DURATION_SECONDS jumps ahead of the queue. delay() may be considered a shorthand form of alarm(), but there are subtle differences in timing issues. This code is roughly equivalent to the alarm() example. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->delay( tick => 1, 0 ); }, tick => sub { print "tick $_[ARG0]\n"; $_[KERNEL]->delay( tock => 1, $_[ARG0] + 1 ); }, tock => sub { print "tock $_[ARG0]\n"; $_[KERNEL]->delay( tick => 1, $_[ARG0] + 1 ); }, } ); delay() returns 0 on success or a reason for failure: EINVAL if EVENT_NAME is undefined. =head4 delay_add EVENT_NAME, DURATION_SECONDS [, PARAMETER_LIST] delay_add() is used to add a new delay timer named EVENT_NAME without clearing existing timers. DURATION_SECONDS is a required parameter. Otherwise the semantics are identical to delay(). A program may use delay_add() without first using delay(). POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->delay_add( tick => 1.0, 1_000_000 ); $_[KERNEL]->delay_add( tick => 1.5, 2_000_000 ); }, tick => sub { print "tick $_[ARG0]\n"; $_[KERNEL]->delay_add( tock => 1, $_[ARG0] + 1 ); }, tock => sub { print "tock $_[ARG0]\n"; $_[KERNEL]->delay_add( tick => 1, $_[ARG0] + 1 ); }, } ); delay_add() returns 0 on success or EINVAL if EVENT_NAME or EPOCH_TIME is undefined. =head3 Identifier-Based Timers A second way to manage timers is through identifiers. Setting an alarm or delay with the "identifier" methods allows a program to manipulate several timers with the same name in the same session. As covered in alarm() and delay() however, it's possible to mix named and identified timer calls, but the consequences may not always be expected. =head4 alarm_set EVENT_NAME, EPOCH_TIME [, PARAMETER_LIST] alarm_set() sets an alarm, returning a unique identifier that can be used to adjust or remove the alarm later. Unlike alarm(), it does not first clear existing timers with the same EVENT_NAME. Otherwise the semantics are identical to alarm(). POE::Session->create( inline_states => { _start => sub { $_[HEAP]{alarm_id} = $_[KERNEL]->alarm_set( party => time() + 1999 ); $_[KERNEL]->delay(raid => 1); }, raid => sub { $_[KERNEL]->alarm_remove( delete $_[HEAP]{alarm_id} ); }, } ); alarm_set() returns false if it fails and sets $! with the explanation. $! will be EINVAL if EVENT_NAME or TIME is undefined. =head4 alarm_adjust ALARM_ID, DELTA_SECONDS alarm_adjust() adjusts an existing timer's due time by DELTA_SECONDS, which may be positive or negative. It may even be zero, but that's not as useful. On success, it returns the timer's new due time since the start of the UNIX epoch. It's possible to alarm_adjust() timers created by delay_set() as well as alarm_set(). This example moves an alarm's due time ten seconds earlier. use POSIX qw(strftime); POE::Session->create( inline_states => { _start => sub { $_[HEAP]{alarm_id} = $_[KERNEL]->alarm_set( party => time() + 1999 ); $_[KERNEL]->delay(postpone => 1); }, postpone => sub { my $new_time = $_[KERNEL]->alarm_adjust( $_[HEAP]{alarm_id}, -10 ); print( "Now we're gonna party like it's ", strftime("%F %T", gmtime($new_time)), "\n" ); }, } ); alarm_adjust() returns Boolean false if it fails, setting $! to the reason why. $! may be EINVAL if ALARM_ID or DELTA_SECONDS are undefined. It may be ESRCH if ALARM_ID no longer refers to a pending timer. $! may also contain EPERM if ALARM_ID is valid but belongs to a different session. =head4 alarm_remove ALARM_ID alarm_remove() removes the alarm identified by ALARM_ID. ALARM_ID comes from a previous alarm_set() or delay_set() call. Upon success, alarm_remove() returns something true based on its context. In a list context, it returns three things: The removed alarm's event name, the UNIX time it was due to go off, and a reference to the PARAMETER_LIST (if any) assigned to the timer when it was created. If necessary, the timer can be re-set with this information. POE::Session->create( inline_states => { _start => sub { $_[HEAP]{alarm_id} = $_[KERNEL]->alarm_set( party => time() + 1999 ); $_[KERNEL]->delay(raid => 1); }, raid => sub { my ($name, $time, $param) = $_[KERNEL]->alarm_remove( $_[HEAP]{alarm_id} ); print( "Removed alarm for event $name due at $time with @$param\n" ); # Or reset it, if you'd like. Possibly after modification. $_[KERNEL]->alarm_set($name, $time, @$param); }, } ); In a scalar context, it returns a reference to a list of the three things above. # Remove and reset an alarm. my $alarm_info = $_[KERNEL]->alarm_remove( $alarm_id ); my $new_id = $_[KERNEL]->alarm_set( $alarm_info[0], $alarm_info[1], @{$alarm_info[2]} ); Upon failure, however, alarm_remove() returns a Boolean false value and sets $! with the reason why the call failed: EINVAL ("Invalid argument") indicates a problem with one or more parameters, usually an undefined ALARM_ID. ESRCH ("No such process") indicates that ALARM_ID did not refer to a pending alarm. EPERM ("Operation not permitted"). A session cannot remove an alarm it does not own. =head4 alarm_remove_all alarm_remove_all() removes all the pending timers for the current session, regardless of creation method or type. This method takes no arguments. It returns information about the alarms that were removed, either as a list of alarms or a list reference depending whether alarm_remove_all() is called in scalar or list context. Each removed alarm's information is identical to the format explained in alarm_remove(). sub some_event_handler { my @removed_alarms = $_[KERNEL]->alarm_remove_all(); foreach my $alarm (@removed_alarms) { my ($name, $time, $param) = @$alarm; ...; } } =head4 delay_set EVENT_NAME, DURATION_SECONDS [, PARAMETER_LIST] delay_set() sets a timer for DURATION_SECONDS in the future. The timer will be dispatched to the code associated with EVENT_NAME in the current session. An optional PARAMETER_LIST will be passed through to the handler. It returns the same sort of things that alarm_set() does. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->delay_set("later", 5, "hello", "world"); }, later => sub { print "@_[ARG0..#$_]\n"; } } ); =head4 delay_adjust ALARM_ID, SECONDS_FROM_NOW delay_adjust() changes a timer's due time to be SECONDS_FROM_NOW. It's useful for refreshing watchdog- or timeout-style timers. On success it returns the new absolute UNIX time the timer will be due. It's possible for delay_adjust() to adjust timers created by alarm_set() as well as delay_set(). use POSIX qw(strftime); POE::Session->create( inline_states => { # Setup. # ... omitted. got_input => sub { my $new_time = $_[KERNEL]->delay_adjust( $_[HEAP]{input_timeout}, 60 ); print( "Refreshed the input timeout. Next may occur at ", strftime("%F %T", gmtime($new_time)), "\n" ); }, } ); On failure it returns Boolean false and sets $! to a reason for the failure. See the explanation of $! for alarm_adjust(). =head4 delay_remove is not needed There is no delay_remove(). Timers are all identical internally, so alarm_remove() will work with timer IDs returned by delay_set(). =head4 delay_remove_all is not needed There is no delay_remove_all(). Timers are all identical internally, so alarm_remove_all() clears them all regardless how they were created. =head3 Comparison Below is a table to help compare the various delayed message-sending methods +-----------+------------------+---------------------+------------+ | | time argument | clears other events | returns on | | method | passed to method | of the same name | success | +-----------+------------------+---------------------+------------+ | delay_set | seconds from now | N | alarm_id | | delay | seconds from now | Y | 0 (false) | | alarm_set | unix epoch time | N | alarm_id | | alarm | unix epoch time | Y | 0 (false) | +-----------+------------------+---------------------+------------+ =head2 Session Identifiers (IDs and Aliases) A session may be referred to by its object references (either blessed or stringified), a session ID, or one or more symbolic names we call aliases. Every session is represented by an object, so session references are fairly straightforward. POE::Kernel may reference these objects. For instance, post() may use $_[SENDER] as a destination: POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("echoer") }, ping => sub { $_[KERNEL]->post( $_[SENDER], "pong", @_[ARG0..$#_] ); } } ); POE also recognized stringified Session objects for convenience and as a form of weak reference. Here $_[SENDER] is wrapped in quotes to stringify it: POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("echoer") }, ping => sub { $_[KERNEL]->post( "$_[SENDER]", "pong", @_[ARG0..$#_] ); } } ); Every session is assigned a unique ID at creation time. No two active sessions will have the same ID, but IDs may be reused over time. The combination of a kernel ID and a session ID should be sufficient as a global unique identifier. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("echoer") }, ping => sub { $_[KERNEL]->delay( pong_later => rand(5), $_[SENDER]->ID, @_[ARG0..$#_] ); }, pong_later => sub { $_[KERNEL]->post( $_[ARG0], "pong", @_[ARG1..$#_] ); } } ); Kernels also maintain a global session namespace or dictionary from which may be used to map a symbolic aliases to a session. Once an alias is mapping has been created, that alias may be used to refer to the session wherever a session may be specified. In the previous examples, each echoer service has set an "echoer" alias. Another session can post a ping request to the echoer session by using that alias rather than a session object or ID. For example: POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->post(echoer => ping => "whee!" ) }, pong => sub { print "@_[ARG0..$#_]\n" } } ); A session with an alias will not stop until all other activity has stopped. Aliases are treated as a kind of event watcher. Events come from active sessions. Aliases therefore become useless when there are no active sessions left. Rather than leaving the program running in a "zombie" state, POE detects this deadlock condition and triggers a cleanup. See L for more information. =head3 alias_set ALIAS alias_set() maps an ALIAS in POE::Kernel's dictionary to the current session. The ALIAS may then be used nearly everywhere a session reference, stringified reference, or ID is expected. Sessions may have more than one alias. Each alias must be defined in a separate alias_set() call. A single alias may not refer to more than one session. Multiple alias examples are above. alias_set() returns 0 on success, or a nonzero failure indicator: EEXIST ("File exists") indicates that the alias is already assigned to to a different session. =head3 alias_remove ALIAS alias_remove() removes an ALIAS for the current session from POE::Kernel's dictionary. The ALIAS will no longer refer to the current session. This does not negatively affect events already posted to POE's queue. Alias resolution occurs at post() time, not at delivery time. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("short_window"); $_[KERNEL]->delay(close_window => 1); }, close_window => { $_[KERNEL]->alias_remove("short_window"); } } ); alias_remove() returns 0 on success or a nonzero failure code: ESRCH ("No such process") indicates that the ALIAS is not currently in POE::Kernel's dictionary. EPERM ("Operation not permitted") means that the current session may not remove the ALIAS because it is in use by some other session. =head3 alias_resolve ALIAS alias_resolve() returns a session reference corresponding to a given ALIAS. Actually, the ALIAS may be a stringified session reference, a session ID, or an alias previously registered by alias_set(). One use for alias_resolve() is to detect whether another session has gone away: unless (defined $_[KERNEL]->alias_resolve("Elvis")) { print "Elvis has left the building.\n"; } As previously mentioned, alias_resolve() returns a session reference or undef on failure. Failure also sets $! to ESRCH ("No such process") when the ALIAS is not currently in POE::Kernel's. =head3 alias_list [SESSION_REFERENCE] alias_list() returns a list of aliases associated with a specific SESSION, or with the current session if SESSION is omitted. alias_list() returns an empty list if the requested SESSION has no aliases. SESSION may be a session reference (blessed or stringified), a session ID, or a session alias. POE::Session->create( inline_states => { $_[KERNEL]->alias_set("mi"); print( "The names I call myself: ", join(", ", $_[KERNEL]->alias_list()), "\n" ); } ); =head3 ID_id_to_session SESSION_ID ID_id_to_session() translates a session ID into a session reference. It's a special-purpose subset of alias_resolve(), so it's a little faster and somewhat less flexible. unless (defined $_[KERNEL]->ID_id_to_session($session_id)) { print "Session $session_id doesn't exist.\n"; } ID_id_to_session() returns undef if a lookup failed. $! will be set to ESRCH ("No such process"). =head3 ID_session_to_id SESSION_REFERENCE ID_session_to_id() converts a blessed or stringified SESSION_REFERENCE into a session ID. It's more practical for stringified references, as programs can call the POE::Session ID() method on the blessed ones. These statements are equivalent: $id = $_[SENDER]->ID(); $id = $_[KERNEL]->ID_session_to_id($_[SENDER]); $id = $_[KERNEL]->ID_session_to_id("$_[SENDER]"); As with other POE::Kernel lookup methods, ID_session_to_id() returns undef on failure, setting $! to ESRCH ("No such process"). =head2 I/O Watchers (Selects) No event system would be complete without the ability to asynchronously watch for I/O events. POE::Kernel implements the lowest level watchers, which are called "selects" because they were historically implemented using Perl's built-in select(2) function. Applications handle I/O readiness events by performing some activity on the underlying filehandle. Read-readiness might be handled by reading from the handle. Write-readiness by writing to it. All I/O watcher events include two parameters. C contains the handle that is ready for work. C contains an integer describing what's ready. sub handle_io { my ($handle, $mode) = @_[ARG0, ARG1]; print "File $handle is ready for "; if ($mode == 0) { print "reading"; } elsif ($mode == 1) { print "writing"; } elsif ($mode == 2) { print "out-of-band reading"; } else { die "unknown mode $mode"; } print "\n"; # ... do something here } The remaining parameters, C<@_[ARG2..$%_]>, contain additional parameters that were passed to the POE::Kernel method that created the watcher. POE::Kernel conditions filehandles to be 8-bit clean and non-blocking. Programs that need them conditioned differently should set them up after starting POE I/O watchers. If you are running a Perl older than 5.8.1 and is using tied filehandles, you need to set non-blocking mode yourself as L does not work well. See L for more info. I/O watchers will prevent sessions from stopping. =head3 select_read FILE_HANDLE [, EVENT_NAME [, ADDITIONAL_PARAMETERS] ] select_read() starts or stops the current session from watching for incoming data on a given FILE_HANDLE. The watcher is started if EVENT_NAME is specified, or stopped if it's not. ADDITIONAL_PARAMETERS, if specified, will be passed to the EVENT_NAME handler as C<@_[ARG2..$#_]>. POE::Session->create( inline_states => { _start => sub { $_[HEAP]{socket} = IO::Socket::INET->new( PeerAddr => "localhost", PeerPort => 25, ); $_[KERNEL]->select_read( $_[HEAP]{socket}, "got_input" ); $_[KERNEL]->delay(timed_out => 1); }, got_input => sub { my $socket = $_[ARG0]; while (sysread($socket, my $buf = "", 8192)) { print $buf; } }, timed_out => sub { $_[KERNEL]->select_read( delete $_[HEAP]{socket} ); }, } ); select_read() does not return anything significant. =head3 select_write FILE_HANDLE [, EVENT_NAME [, ADDITIONAL_PARAMETERS] ] select_write() follows the same semantics as select_read(), but it starts or stops a watcher that looks for write-readiness. That is, when EVENT_NAME is delivered, it means that FILE_HANDLE is ready to be written to. select_write() does not return anything significant. =head3 select_expedite FILE_HANDLE [, EVENT_NAME [, ADDITIONAL_PARAMETERS] ] select_expedite() does the same sort of thing as select_read() and select_write(), but it watches a FILE_HANDLE for out-of-band data ready to be input from a FILE_HANDLE. Hardly anybody uses this, but it exists for completeness' sake. An EVENT_NAME event will be delivered whenever the FILE_HANDLE can be read from out-of-band. Out-of-band data is considered "expedited" because it is often ahead of a socket's normal data. select_expedite() does not return anything significant. =head3 select_pause_read FILE_HANDLE select_pause_read() is a lightweight way to pause a FILE_HANDLE input watcher without performing all the bookkeeping of a select_read(). It's used with select_resume_read() to implement input flow control. Input that occurs on FILE_HANDLE will backlog in the operating system buffers until select_resume_read() is called. A side effect of bypassing the select_read() bookkeeping is that a paused FILE_HANDLE will not prematurely stop the current session. select_pause_read() does not return anything significant. =head3 select_resume_read FILE_HANDLE select_resume_read() resumes a FILE_HANDLE input watcher that was previously paused by select_pause_read(). See select_pause_read() for more discussion on lightweight input flow control. Data backlogged in the operating system due to a select_pause_read() call will become available after select_resume_read() is called. select_resume_read() does not return anything significant. =head3 select_pause_write FILE_HANDLE select_pause_write() pauses a FILE_HANDLE output watcher the same way select_pause_read() does for input. Please see select_pause_read() for further discussion. =head3 select_resume_write FILE_HANDLE select_resume_write() resumes a FILE_HANDLE output watcher the same way that select_resume_read() does for input. See select_resume_read() for further discussion. =head3 select FILE_HANDLE [, EV_READ [, EV_WRITE [, EV_EXPEDITE [, ARGS] ] ] ] POE::Kernel's select() method sets or clears a FILE_HANDLE's read, write and expedite watchers at once. It's a little more expensive than calling select_read(), select_write() and select_expedite() manually, but it's significantly more convenient. Defined event names enable their corresponding watchers, and undefined event names disable them. This turns off all the watchers for a FILE_HANDLE: sub stop_io { $_[KERNEL]->select( $_[HEAP]{file_handle} ); } This statement: $_[KERNEL]->select( $file_handle, undef, "write_event", undef, @stuff ); is equivalent to: $_[KERNEL]->select_read( $file_handle ); $_[KERNEL]->select_write( $file_handle, "write_event", @stuff ); $_[KERNEL]->select_expedite( $file_handle ); POE::Kernel's select() should not be confused with Perl's built-in select() function. As with the other I/O watcher methods, select() does not return a meaningful value. =head2 Session Management Sessions are dynamic. They may be created and destroyed during a program's lifespan. When a session is created, it becomes the "child" of the current session. The creator -- the current session -- becomes its "parent" session. This is loosely modeled after UNIX processes. The most common session management is done by creating new sessions and allowing them to eventually stop. Every session has a parent, even the very first session created. Sessions without obvious parents are children of the program's POE::Kernel instance. Child sessions will keep their parents active. See L for more about why sessions stay alive. The parent/child relationship tree also governs the way many signals are dispatched. See L for more information on that. =head3 Session Management Events (_start, _stop, _parent, _child) POE::Kernel provides four session management events: _start, _stop, _parent and _child. They are invoked synchronously whenever a session is newly created or just about to be destroyed. =over 2 =item _start _start should be familiar by now. POE dispatches the _start event to initialize a session after it has been registered under POE::Kernel. What is not readily apparent, however, is that it is invoked before the L constructor returns. Within the _start handler, the event's sender is the session that created the new session. Otherwise known as the new session's I. Sessions created before POE::Kernel->run() is called will be descendents of the program's POE::Kernel singleton. The _start handler's return value is passed to the parent session in a _child event, along with the notification that the parent's new child was created successfully. See the discussion of _child for more details. POE::Session->create( inline_states => { _start=> \&_start }, args => [ $some, $args ] ); sub _start { my ( $some, $args ) = @_[ ARG0, ARG1 ]; # .... } =item _stop _stop is a little more mysterious. POE calls a _stop handler when a session is irrevocably about to be destroyed. Part of session destruction is the forcible reclamation of its resources (events, timers, message events, etc.) so it's not possible to post() a message from _stop's handler. A program is free to try, but the event will be destroyed before it has a chance to be dispatched. the _stop handler's return value is passed to the parent's _child event. See _child for more details. _stop is usually invoked when a session has no further reason to live, although signals may cause them to stop sooner. The corresponding _child handler is invoked synchronously just after _stop returns. =item _parent _parent is used to notify a child session when its parent has changed. This usually happens when a session is first created. It can also happen when a child session is detached from its parent. See L and L. _parent's ARG0 contains the session's previous parent, and ARG1 contains its new parent. sub _parent { my ( $old_parent, $new_parent ) = @_[ ARG0, ARG1 ]; print( "Session ", $_[SESSION]->ID, " parent changed from session ", $old_parent->ID, " to session ", $new_parent->ID, "\n" ); } =item _child _child notifies one session when a child session has been created, destroyed, or reassigned to or from another parent. It's usually dispatched when sessions are created or destroyed. It can also happen when a session is detached from its parent. _child includes some information in the "arguments" portion of @_. Typically ARG0, ARG1 and ARG2, but these may be overridden by a different POE::Session class: ARG0 contains a string describing what has happened to the child. The string may be 'create' (the child session has been created), 'gain' (the child has been given by another session), or 'lose' (the child session has stopped or been given away). In all cases, ARG1 contains a reference to the child session. In the 'create' case, ARG2 holds the value returned by the child session's _start handler. Likewise, ARG2 holds the _stop handler's return value for the 'lose' case. sub _child { my( $reason, $child ) = @_[ ARG0, ARG1 ]; if( $reason eq 'create' ) { my $retval = $_[ ARG2 ]; } # ... } =back The events are delivered in specific orders. =head4 When a new session is created: =over 4 =item 1 The session's constructor is called. =item 2 The session is put into play. That is, POE::Kernel enters the session into its bookkeeping. =item 3 The new session receives _start. =item 4 The parent session receives _child ('create'), the new session reference, and the new session's _start's return value. =item 5 The session's constructor returns. =back =head4 When an old session stops: =over 4 =item 1 If the session has children of its own, they are given to the session's parent. This triggers one or more _child ('gain') events in the parent, and a _parent in each child. =item 2 Once divested of its children, the stopping session receives a _stop event. =item 3 The stopped session's parent receives a _child ('lose') event with the departing child's reference and _stop handler's return value. =item 4 The stopped session is removed from play, as are all its remaining resources. =item 5 The parent session is checked for idleness. If so, garbage collection will commence on it, and it too will be stopped =back =head4 When a session is detached from its parent: =over 4 =item 1 The parent session of the session being detached is notified with a _child ('lose') event. The _stop handler's return value is undef since the child is not actually stopping. =item 2 The detached session is notified with a _parent event that its new parent is POE::Kernel itself. =item 3 POE::Kernel's bookkeeping data is adjusted to reflect the change of parentage. =item 4 The old parent session is checked for idleness. If so, garbage collection will commence on it, and it too will be stopped =back =head3 Session Management Methods These methods allow sessions to be detached from their parents in the rare cases where the parent/child relationship gets in the way. =head4 detach_child CHILD_SESSION detach_child() detaches a particular CHILD_SESSION from the current session. On success, the CHILD_SESSION will become a child of the POE::Kernel instance, and detach_child() will return true. On failure however, detach_child() returns false and sets $! to explain the nature of the failure: =over 4 =item ESRCH ("No such process"). The CHILD_SESSION is not a valid session. =item EPERM ("Operation not permitted"). The CHILD_SESSION exists, but it is not a child of the current session. =back detach_child() will generate L and/or L events to the appropriate sessions. See L for a detailed explanation of these events. See L for the order the events are generated. =head4 detach_myself detach_myself() detaches the current session from its current parent. The new parent will be the running POE::Kernel instance. It returns true on success. On failure it returns false and sets C<$!> to explain the nature of the failure: =over 4 =item EPERM ("Operation not permitted"). The current session is already a child of POE::Kernel, so it may not be detached. =back detach_child() will generate L and/or L events to the appropriate sessions. See L for a detailed explanation of these events. See L for the order the events are generated. =head2 Signals POE::Kernel provides methods through which a program can register interest in signals that come along, can deliver its own signals without resorting to system calls, and can indicate that signals have been handled so that default behaviors are not necessary. Signals are I by nature, and their implementation requires widespread synchronization between sessions (and reentrancy in the dispatcher, but that's an implementation detail). Perfecting the semantics has proven difficult, but POE tries to do the Right Thing whenever possible. POE does not register %SIG handlers for signals until sig() is called to watch for them. Therefore a signal's default behavior occurs for unhandled signals. That is, SIGINT will gracelessly stop a program, SIGWINCH will do nothing, SIGTSTP will pause a program, and so on. =head3 Signal Classes There are three signal classes. Each class defines a default behavior for the signal and whether the default can be overridden. They are: =head4 Benign, advisory, or informative signals These are three names for the same signal class. Signals in this class notify a session of an event but do not terminate the session if they are not handled. It is possible for an application to create its own benign signals. See L below. =head4 Terminal signals Terminal signals will kill sessions if they are not handled by a L() call. The OS signals that usually kill or dump a process are considered terminal in POE, but they never trigger a coredump. These are: HUP, INT, QUIT and TERM. There are two terminal signals created by and used within POE: =over =item DIE C notifies sessions that a Perl exception has occurred. See L for details. =item IDLE The C signal is used to notify leftover sessions that a program has run out of things to do. =back =head4 Nonmaskable signals Nonmaskable signals are terminal regardless whether sig_handled() is called. The term comes from "NMI", the non-maskable CPU interrupt usually generated by an unrecoverable hardware exception. Sessions that receive a non-maskable signal will unavoidably stop. POE implements two non-maskable signals: =over =item ZOMBIE This non-maskable signal is fired if a program has received an C signal but neither restarted nor exited. The program has become a zombie (that is, it's neither dead nor alive, and only exists to consume braaaains ...er... memory). The C signal acts like a cricket bat to the head, bringing the zombie down, for good. =item UIDESTROY This non-maskable signal indicates that a program's user interface has been closed, and the program should take the user's hint and buzz off as well. It's usually generated when a particular GUI widget is closed. =back =head3 Common Signal Dispatching Most signals are not dispatched to a single session. POE's session lineage (parents and children) form a sort of family tree. When a signal is sent to a session, it first passes through any children (and grandchildren, and so on) that are also interested in the signal. In the case of terminal signals, if any of the sessions a signal passes through calls L(), then the signal is considered taken care of. However if none of them do, then the entire session tree rooted at the destination session is terminated. For example, consider this tree of sessions: POE::Kernel Session 2 Session 4 Session 5 Session 3 Session 6 Session 7 POE::Kernel is the parent of sessions 2 and 3. Session 2 is the parent of sessions 4 and 5. And session 3 is the parent of 6 and 7. A signal sent to Session 2 may also be dispatched to session 4 and 5 because they are 2's children. Sessions 4 and 5 will only receive the signal if they have registered the appropriate watcher. If the signal is terminal, and none of the signal watchers in sessions 2, 4 and 5 called C, all 3 sessions will be terminated. The program's POE::Kernel instance is considered to be a session for the purpose of signal dispatch. So any signal sent to POE::Kernel will propagate through every interested session in the entire program. This is in fact how OS signals are handled: A global signal handler is registered to forward the signal to POE::Kernel. =head3 Signal Semantics All signals come with the signal name in ARG0. The signal name is as it appears in %SIG, with one exception: Child process signals are always "CHLD" even if the current operating system recognizes them as "CLD". Certain signals have special semantics: =head4 SIGCHLD =head4 SIGCLD Both C and C indicate that a child process has exited or been terminated by some signal. The actual signal name varies between operating systems, but POE uses C regardless. Interest in C is registered using the L method. The L() method also works, but it's not as nice. The C event includes three parameters: =over =item ARG0 C contains the string 'CHLD' (even if the OS calls it SIGCLD, SIGMONKEY, or something else). =item ARG1 C contains the process ID of the finished child process. =item ARG2 And C holds the value of C<$?> for the finished process. =back Example: sub sig_CHLD { my( $name, $PID, $exit_val ) = @_[ ARG0, ARG1, ARG2 ]; # ... } =head4 SIGPIPE SIGPIPE is rarely used since POE provides events that do the same thing. Nevertheless SIGPIPE is supported if you need it. Unlike most events, however, SIGPIPE is dispatched directly to the active session when it's caught. Barring race conditions, the active session should be the one that caused the OS to send the signal in the first place. The SIGPIPE signal will still propagate to child sessions. ARG0 is "PIPE". There is no other information associated with this signal. =head4 SIGWINCH Window resizes can generate a large number of signals very quickly. This may not be a problem when using perl 5.8.0 or later, but earlier versions may not take kindly to such abuse. You have been warned. ARG0 is "WINCH". There is no other information associated with this signal. =head3 Exception Handling POE::Kernel provides only one form of exception handling: the C signal. When exception handling is enabled (the default), POE::Kernel wraps state invocation in C. If the event handler raises an exception, generally with C, POE::Kernel will dispatch a C signal to the event's destination session. C is the signal name, C. C is a hashref describing the exception: =over =item error_str The text of the exception. In other words, C<$@>. =item dest_session Session object of the state that the raised the exception. In other words, C<$_[SESSION]> in the function that died. =item event Name of the event that died. =item source_session Session object that sent the original event. That is, C<$_[SENDER]> in the function that died. =item from_state State from which the original event was sent. That is, C<$_[CALLER_STATE]> in the function that died. =item file Name of the file the event was sent from. That is, C<$_[CALLER_FILE]> in the function that died. =item line Line number the event was sent from. That is, C<$_[CALLER_LINE]> in the function that died. =back I's call semantics.> Note that the C signal is sent to the session that raised the exception, not the session that sent the event that caused the exception to be raised. sub _start { $poe_kernel->sig( DIE => 'sig_DIE' ); $poe_kernel->yield( 'some_event' ); } sub some_event { die "I didn't like that!"; } sub sig_DIE { my( $sig, $ex ) = @_[ ARG0, ARG1 ]; # $sig is 'DIE' # $ex is the exception hash warn "$$: error in $ex->{event}: $ex->{error_str}"; $poe_kernel->sig_handled(); # Send the signal to session that sent the original event. if( $ex->{source_session} ne $_[SESSION] ) { $poe_kernel->signal( $ex->{source_session}, 'DIE', $sig, $ex ); } } POE::Kernel's built-in exception handling can be disabled by setting the C constant to zero. As with other compile-time configuration constants, it must be set before POE::Kernel is compiled: BEGIN { package POE::Kernel; use constant CATCH_EXCEPTIONS => 0; } use POE; or sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } use POE; =head2 Signal Watcher Methods And finally the methods themselves. =head3 sig SIGNAL_NAME [, EVENT_NAME [, LIST] ] sig() registers or unregisters an EVENT_NAME event for a particular SIGNAL_NAME, with an optional LIST of parameters that will be passed to the signal's handler---after any data that comes wit the signal. If EVENT_NAME is defined, the signal handler is registered. Otherwise it's unregistered. Each session can register only one handler per SIGNAL_NAME. Subsequent registrations will replace previous ones. Multiple sessions may however watch the same signal. SIGNAL_NAMEs are generally the same as members of C<%SIG>, with two exceptions. First, C is an alias for C (although see L). And second, it's possible to send and handle signals created by the application and have no basis in the operating system. sub handle_start { $_[KERNEL]->sig( INT => "event_ui_shutdown" ); $_[KERNEL]->sig( bat => "holy_searchlight_batman" ); $_[KERNEL]->sig( signal => "main_screen_turn_on" ); } The operating system may never be able to generate the last two signals, but a POE session can by using POE::Kernel's L() method. Later on the session may decide not to handle the signals: sub handle_ui_shutdown { $_[KERNEL]->sig( "INT" ); $_[KERNEL]->sig( "bat" ); $_[KERNEL]->sig( "signal" ); } More than one session may register interest in the same signal, and a session may clear its own signal watchers without affecting those in other sessions. sig() does not return a meaningful value. =head3 sig_child PROCESS_ID [, EVENT_NAME [, LIST] ] sig_child() is a convenient way to deliver an EVENT_NAME event when a particular PROCESS_ID has exited. An optional LIST of parameters will be passed to the signal handler after the waitpid() information. The watcher can be cleared at any time by calling sig_child() with just the PROCESS_ID. A session may register as many sig_child() handlers as necessary, but a session may only have one per PROCESS_ID. sig_child() watchers are one-shot. They automatically unregister themselves once the EVENT_NAME has been delivered. There's no point in continuing to watch for a signal that will never come again. Other signal handlers persist until they are cleared. sig_child() watchers keep a session alive for as long as they are active. This is unique among POE's signal watchers. Programs that wish to reliably reap child processes should be sure to call sig_child() before returning from the event handler that forked the process. Otherwise POE::Kernel may have an opportunity to call waitpid() before an appropriate event watcher has been registered. Programs that reap processes with waitpid() must clear POE's watchers for the same process IDs, otherwise POE will wait indefinitely for processes that never send signals. sig_child() does not return a meaningful value. sub forked_parent { my( $heap, $pid, $details ) = @_[ HEAP, ARG0, ARG1 ]; $poe_kernel->sig_child( $pid, 'sig_child', $details ); } sub sig_child { my( $heap, $sig, $pid, $exit_val, $details ) = @_[ HEAP, ARG0..ARG3 ]; my $details = delete $heap->{ $pid }; warn "$$: Child $pid exited" # .... also, $details has been passed from forked_parent() # through sig_child() } =head3 sig_handled sig_handled() informs POE::Kernel that the currently dispatched signal has been handled by the currently active session. If the signal is terminal, the sig_handled() call prevents POE::Kernel from stopping the sessions that received the signal. A single signal may be dispatched to several sessions. Only one needs to call sig_handled() to prevent the entire group from being stopped. If none of them call it, however, then they are all stopped together. sig_handled() does not return a meaningful value. sub _start { $_[KERNEL]->sig( INT => 'sig_INT' ); } sub sig_INT { warn "$$ SIGINT"; $_[KERNEL]->sig_handled(); } =head3 signal SESSION, SIGNAL_NAME [, ARGS_LIST] signal() posts a SIGNAL_NAME signal to a specific SESSION with an optional ARGS_LIST that will be passed to every interested handler. As mentioned elsewhere, the signal may be delivered to SESSION's children, grandchildren, and so on. And if SESSION is the POE::Kernel itself, then all interested sessions will receive the signal. It is possible to send a signal in POE that doesn't exist in the operating system. signal() places the signal directly into POE's event queue as if they came from the operating system, but they are not limited to signals recognized by kill(). POE uses a few of these fictitious signals for its own global notifications. For example: sub some_event_handler { # Turn on all main screens. $_[KERNEL]->signal( $_[KERNEL], "signal" ); } signal() returns true on success. On failure, it returns false after setting $! to explain the nature of the failure: =over =item ESRCH ("No such process") The SESSION does not exist. =back Because all sessions are a child of POE::Kernel, sending a signal to the kernel will propagate the signal to all sessions. This is a cheap form of I. $_[KERNEL]->signal( $_[KERNEL], 'shutdown' ); =head3 signal_ui_destroy WIDGET_OBJECT signal_ui_destroy() associates the destruction of a particular WIDGET_OBJECT with the complete destruction of the program's user interface. When the WIDGET_OBJECT destructs, POE::Kernel issues the non-maskable UIDESTROY signal, which quickly triggers mass destruction of all active sessions. POE::Kernel->run() returns shortly thereafter. sub setup_ui { $_[HEAP]{main_widget} = Gtk->new("toplevel"); # ... populate the main widget here ... $_[KERNEL]->signal_ui_destroy( $_[HEAP]{main_widget} ); } Detecting widget destruction is specific to each toolkit. =head2 Event Handler Management Event handler management methods let sessions hot swap their event handlers at run time. For example, the L objects use state() to dynamically mix their own event handlers into the sessions that create them. These methods only affect the current session; it would be rude to change another session's handlers. There is only one method in this group. Since it may be called in several different ways, it may be easier to understand if each is documented separately. =head3 state EVENT_NAME [, CODE_REFERNCE] state() sets or removes a handler for EVENT_NAME in the current session. The function referred to by CODE_REFERENCE will be called whenever EVENT_NAME events are dispatched to the current session. If CODE_REFERENCE is omitted, the handler for EVENT_NAME will be removed. A session may only have one handler for a given EVENT_NAME. Subsequent attempts to set an EVENT_NAME handler will replace earlier handlers with the same name. # Stop paying attention to input. Say goodbye, and # trigger a socket close when the message is sent. sub send_final_response { $_[HEAP]{wheel}->put("KTHXBYE"); $_[KERNEL]->state( 'on_client_input' ); $_[KERNEL]->state( on_flush => \&close_connection ); } =head3 state EVENT_NAME [, OBJECT_REFERENCE [, OBJECT_METHOD_NAME] ] Set or remove a handler for EVENT_NAME in the current session. If an OBJECT_REFERENCE is given, that object will handle the event. An optional OBJECT_METHOD_NAME may be provided. If the method name is not given, POE will look for a method matching the EVENT_NAME instead. If the OBJECT_REFERENCE is omitted, the handler for EVENT_NAME will be removed. A session may only have one handler for a given EVENT_NAME. Subsequent attempts to set an EVENT_NAME handler will replace earlier handlers with the same name. $_[KERNEL]->state( 'some_event', $self ); $_[KERNEL]->state( 'other_event', $self, 'other_method' ); =head3 state EVENT_NAME [, CLASS_NAME [, CLASS_METHOD_NAME] ] This form of state() call is virtually identical to that of the object form. Set or remove a handler for EVENT_NAME in the current session. If an CLASS_NAME is given, that class will handle the event. An optional CLASS_METHOD_NAME may be provided. If the method name is not given, POE will look for a method matching the EVENT_NAME instead. If the CLASS_NAME is omitted, the handler for EVENT_NAME will be removed. A session may only have one handler for a given EVENT_NAME. Subsequent attempts to set an EVENT_NAME handler will replace earlier handlers with the same name. $_[KERNEL]->state( 'some_event', __PACKAGE__ ); $_[KERNEL]->state( 'other_event', __PACKAGE__, 'other_method' ); =head2 Public Reference Counters The methods in this section manipulate reference counters on the current session or another session. Each session has a namespace for user-manipulated reference counters. These namespaces are associated with the target SESSION_ID for the reference counter methods, not the caller. Nothing currently prevents one session from decrementing a reference counter that was incremented by another, but this behavior is not guaranteed to remain. For now, it's up to the users of these methods to choose obscure counter names to avoid conflicts. Reference counting is a big part of POE's magic. Various objects (mainly event watchers and components) hold references to the sessions that own them. L explains the concept in more detail. The ability to keep a session alive is sometimes useful in an application or library. For example, a component may hold a public reference to another session while it processes a request from that session. In doing so, the component guarantees that the requester is still around when a response is eventually ready. Keeping a reference to the session's object is not enough. POE::Kernel has its own internal reference counting mechanism. =head3 refcount_increment SESSION_ID, COUNTER_NAME refcount_increment() increases the value of the COUNTER_NAME reference counter for the session identified by a SESSION_ID. To discourage the use of session references, the refcount_increment() target session must be specified by its session ID. The target session will not stop until the value of any and all of its COUNTER_NAME reference counters are zero. (Actually, it may stop in some cases, such as failing to handle a terminal signal.) Negative reference counters are legal. They still must be incremented back to zero before a session is eligible for stopping. sub handle_request { # Among other things, hold a reference count on the sender. $_[KERNEL]->refcount_increment( $_[SENDER]->ID, "pending request"); $_[HEAP]{requesters}{$request_id} = $_[SENDER]->ID; } For this to work, the session needs a way to remember the $_[SENDER]->ID for a given request. Customarily the session generates a request ID and uses that to track the request until it is fulfilled. refcount_increment() returns the resulting reference count (which may be zero) on success. On failure, it returns undef and sets $! to be the reason for the error. ESRCH: The SESSION_ID does not refer to a currently active session. =head3 refcount_decrement SESSION_ID, COUNTER_NAME refcount_decrement() reduces the value of the COUNTER_NAME reference counter for the session identified by a SESSION_ID. It is the counterpoint for refcount_increment(). Please see refcount_increment() for more context. sub finally_send_response { # Among other things, release the reference count for the # requester. my $requester_id = delete $_[HEAP]{requesters}{$request_id}; $_[KERNEL]->refcount_decrement( $requester_id, "pending request"); } The requester's $_[SENDER]->ID is remembered and removed from the heap (lest there be memory leaks). It's used to decrement the reference counter that was incremented at the start of the request. refcount_decrement() returns the resulting reference count (which may be zero) on success. On failure, it returns undef, and $! will be set to the reason for the failure: ESRCH: The SESSION_ID does not refer to a currently active session. It is not possible to discover currently active public references. See L. =head2 Kernel State Accessors POE::Kernel provides a few accessors into its massive brain so that library developers may have convenient access to necessary data without relying on their callers to provide it. These accessors expose ways to break session encapsulation. Please use them sparingly and carefully. =head3 get_active_session get_active_session() returns a reference to the session that is currently running, or a reference to the program's POE::Kernel instance if no session is running at that moment. The value is equivalent to L's C<$_[SESSION]>. This method was added for libraries that need C<$_[SESSION]> but don't want to include it as a parameter in their APIs. sub some_housekeeping { my( $self ) = @_; my $session = $poe_kernel->get_active_session; # do some housekeeping on $session } =head3 get_active_event get_active_event() returns the name of the event currently being dispatched. It returns an empty string when called outside event dispatch. The value is equivalent to L's C<$_[STATE]>. sub waypoint { my( $message ) = @_; my $event = $poe_kernel->get_active_event; print STDERR "$$:$event:$mesage\n"; } =head3 get_event_count get_event_count() returns the number of events pending in POE's event queue. It is exposed for L class authors. It may be deprecated in the future. =head3 get_next_event_time get_next_event_time() returns the time the next event is due, in a form compatible with the UNIX time() function. It is exposed for L class authors. It may be deprecated in the future. =head3 poe_kernel_loop poe_kernel_loop() returns the name of the POE::Loop class that is used to detect and dispatch events. =head2 Session Helper Methods The methods in this group expose features for L class authors. =head3 session_alloc SESSION_OBJECT [, START_ARGS] session_alloc() allocates a session context within POE::Kernel for a newly created SESSION_OBJECT. A list of optional START_ARGS will be passed to the session as part of the L event. The SESSION_OBJECT is expected to follow a subset of POE::Session's interface. There is no session_free(). POE::Kernel determines when the session should stop and performs the necessary cleanup after dispatching _stop to the session. =head2 Miscellaneous Methods We don't know where to classify the methods in this section. =head3 new It is not necessary to call POE::Kernel's new() method. Doing so will return the program's singleton POE::Kernel object, however. =head1 PUBLIC EXPORTED VARIABLES POE::Kernel exports two variables for your coding enjoyment: C<$poe_kernel> and C<$poe_main_window>. POE::Kernel is implicitly used by POE itself, so using POE gets you POE::Kernel (and its exports) for free. In more detail: =head2 $poe_kernel C<$poe_kernel> contains a reference to the process' POE::Kernel singleton instance. It's mainly used for accessing POE::Kernel methods from places where C<$_[KERNEL]> is not available. It's most commonly used in helper libraries. =head2 $poe_main_window $poe_main_window is used by graphical toolkits that require at least one widget to be created before their event loops are usable. This is currently only Tk. L creates a main window to satisfy Tk's event loop. The window is given to the application since POE has no other use for it. C<$poe_main_window> is undefined in toolkits that don't require a widget to dispatch events. On a related note, POE will shut down if the widget in C<$poe_main_window> is destroyed. This can be changed with POE::Kernel's L method. =head1 DEBUGGING POE AND PROGRAMS USING IT POE includes quite a lot of debugging code, in the form of both fatal assertions and run-time traces. They may be enabled at compile time, but there is no way to toggle them at run-time. This was done to avoid run-time penalties in programs where debugging is not necessary. That is, in most production cases. Traces are verbose reminders of what's going on within POE. Each is prefixed with a four-character field describing the POE subsystem that generated it. Assertions (asserts) are quiet but deadly, both in performance (they cause a significant run-time performance hit) and because they cause fatal errors when triggered. The assertions and traces are useful for developing programs with POE, but they were originally added to debug POE itself. Each assertion and tracing group is enabled by setting a constant in the POE::Kernel namespace to a true value. BEGIN { package POE::Kernel; use constant ASSERT_DEFAULT => 1; } use POE; Or the old-fashioned (and more concise) "constant subroutine" method. This doesn't need the C block since subroutine definitions are done at compile time. sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE; The switches must be defined as constants before POE::Kernel is first loaded. Otherwise Perl's compiler will not see the constants when first compiling POE::Kernel, and the features will not be properly enabled. Assertions and traces may also be enabled by setting shell environment variables. The environment variables are named after the POE::Kernel constants with a "POE_" prefix. POE_ASSERT_DEFAULT=1 POE_TRACE_DEFAULT=1 ./my_poe_program In alphabetical order: =head2 ASSERT_DATA ASSERT_DATA enables run-time data integrity checks within POE::Kernel and the classes that mix into it. POE::Kernel tracks a lot of cross-referenced data, and this group of assertions ensures that it's consistent. Prefix:
Environment variable: POE_ASSERT_DATA =head2 ASSERT_DEFAULT ASSERT_DEFAULT specifies the default value for assertions that are not explicitly enabled or disabled. This is a quick and reliable way to make sure all assertions are on. No assertion uses ASSERT_DEFAULT directly, and this assertion flag has no corresponding output prefix. Turn on all assertions except ASSERT_EVENTS: sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::ASSERT_EVENTS () { 0 } use POE::Kernel; Prefix: (none) Environment variable: POE_ASSERT_DEFAULT =head2 ASSERT_EVENTS ASSERT_EVENTS mainly checks for attempts to dispatch events to sessions that don't exist. This assertion can assist in the debugging of strange, silent cases where event handlers are not called. Prefix: Environment variable: POE_ASSERT_EVENTS =head2 ASSERT_FILES ASSERT_FILES enables some run-time checks in POE's filehandle watchers and the code that manages them. Prefix: Environment variable: POE_ASSERT_FILES =head2 ASSERT_RETVALS ASSERT_RETVALS upgrades failure codes from POE::Kernel's methods from advisory return values to fatal errors. Most programmers don't check the values these methods return, so ASSERT_RETVALS is a quick way to validate one's assumption that all is correct. Prefix: Environment variable: POE_ASSERT_RETVALS =head2 ASSERT_USAGE ASSERT_USAGE is the counterpoint to ASSERT_RETVALS. It enables run-time checks that the parameters to POE::Kernel's methods are correct. It's a quick (but not foolproof) way to verify a program's use of POE. Prefix: Environment variable: POE_ASSERT_USAGE =head2 TRACE_DEFAULT TRACE_DEFAULT specifies the default value for traces that are not explicitly enabled or disabled. This is a quick and reliable way to ensure your program generates copious output on the file named in TRACE_FILENAME or STDERR by default. To enable all traces except a few noisier ones: sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::TRACE_EVENTS () { 0 } use POE::Kernel; Prefix: (none) Environment variable: POE_TRACE_DEFAULT =head2 TRACE_DESTROY TRACE_DESTROY causes every POE::Session object to dump the contents of its C<$_[HEAP]> when Perl destroys it. This trace was added to help developers find memory leaks in their programs. Prefix: A line that reads "----- Session $self Leak Check -----". Environment variable: POE_TRACE_DESTROY =head2 TRACE_EVENTS TRACE_EVENTS enables messages pertaining to POE's event queue's activities: when events are enqueued, dispatched or discarded, and more. It's great for determining where events go and when. Understandably this is one of POE's more verbose traces. Prefix: Environment variable: POE_TRACE_EVENTS =head2 TRACE_FILENAME TRACE_FILENAME specifies the name of a file where POE's tracing and assertion messages should go. It's useful if you want the messages but have other plans for STDERR, which is where the messages go by default. POE's tests use this so the trace and assertion code can be instrumented during testing without spewing all over the terminal. Prefix: (none) Environment variable: POE_TRACE_FILENAME =head2 TRACE_FILES TRACE_FILES enables or disables traces in POE's filehandle watchers and the L class that implements the lowest-level filehandle multiplexing. This may be useful when tracking down strange behavior related to filehandles. Prefix: Environment variable: POE_TRACE_FILES =head2 TRACE_REFCNT TRACE_REFCNT governs whether POE::Kernel will trace sessions' reference counts. As discussed in L, POE does a lot of reference counting, and the current state of a session's reference counts determines whether the session lives or dies. It's common for developers to wonder why a session stops too early or remains active too long. TRACE_REFCNT can help explain why. Prefix: Environment variable: POE_TRACE_REFCNT =head2 TRACE_RETVALS TRACE_RETVALS can enable carping whenever a POE::Kernel method is about to fail. It's a non-fatal but noisier form of ASSERT_RETVALS. Prefix: Environment variable: POE_TRACE_RETVALS =head2 TRACE_SESSIONS TRACE_SESSIONS enables trace messages that pertain to session management. Notice will be given when sessions are created or destroyed, and when the parent or child status of a session changes. Prefix: Environment variable: POE_TRACE_SESSIONS =head2 TRACE_SIGNALS TRACE_SIGNALS turns on (or off) traces in POE's signal handling subsystem. Signal dispatch is one of POE's more complex parts, and the trace messages may help application developers understand signal propagation and timing. Prefix: Environment variable: POE_TRACE_SIGNALS =head2 USE_SIGCHLD Whether to use C<$SIG{CHLD}> or to poll at an interval. This flag is enabled by default on Perl >= 5.8.1 as it has support for "safe signals". Please see L for the gory details. You might want to disable this if you are running a version of Perl that is known to have bad signal handling, or if anything hijacks C<$SIG{CHLD}>. One module that is known to do this is L. Enabling this flag will cause child reaping to happen almost immediately, as opposed to once per L. =head2 CHILD_POLLING_INTERVAL The interval at which C is called to determine if child processes need to be reaped and the C signal emulated. Defaults to 1 second. =head2 USE_SIGNAL_PIPE The only safe way to handle signals is to implement a shared-nothing model. POE builds a I that communicates between the signal handlers and the POE kernel loop in a safe and atomic manner. The signal pipe is implemented with L, using a C conduit on Unix. Unfortunately, the signal pipe is not compatible with Windows and is not used on that platform. If you wish to revert to the previous unsafe signal behaviour, you must set C to 0, or the environment variable C. =head2 CATCH_EXCEPTIONS Whether or not POE should run event handler code in an eval { } and deliver the C signal on errors. See L. =head1 ENVIRONMENT VARIABLES FOR TESTING POE's tests are lovely, dark and deep. These environment variables allow testers to take roads less traveled. =head2 POE_DANTIC Windows and Perls built for it tend to be poor at doing UNIXy things, although they do try. POE being very UNIXy itself must skip a lot of Windows tests. The POE_DANTIC environment variable will, when true, enable all these tests. It's intended to be used from time to time to see whether Windows has improved in some area. =head1 SEE ALSO The SEE ALSO section in L contains a table of contents covering the entire POE distribution. =head1 BUGS =over =item * There is no mechanism in place to prevent external reference count names from clashing. =item * There is no mechanism to catch exceptions generated in another session. =back =head1 AUTHORS & COPYRIGHTS Please see L for more information about authors and contributors. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - More practical examples. # TODO - Test the examples. # TODO - Edit. POE-1.368/lib/POE/Wheel/000755 001751 001751 00000000000 13615550107 015224 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Pipe/000755 001751 001751 00000000000 13615550107 015055 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Component/000755 001751 001751 00000000000 13615550107 016122 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Resource/000755 001751 001751 00000000000 13615550107 015747 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Resources.pm000644 001751 001751 00000004065 13615322623 016475 0ustar00bingosbingos000000 000000 package POE::Resources; use strict; use vars qw($VERSION); $VERSION = '1.368'; # NOTE - Should be #.### (three decimal places) my @resources = qw( POE::XS::Resource::Aliases POE::XS::Resource::Events POE::XS::Resource::Extrefs POE::XS::Resource::FileHandles POE::XS::Resource::SIDs POE::XS::Resource::Sessions POE::XS::Resource::Signals ); sub load { my $package = (caller())[0]; foreach my $resource (@resources) { eval "package $package; use $resource"; if ($@) { # Retry the resource, removing XS:: if it couldn't be loaded. # If there's no XS:: to be removed, fall through and die. redo if $@ =~ /Can't locate.*?in \@INC/ and $resource =~ s/::XS::/::/; die; } } } 1; __END__ =head1 NAME POE::Resources - loader of POE resources =head1 SYNOPSIS # Intended for internal use by POE::Kernel. use POE::Resources; POE::Resources->load(); =head1 DESCRIPTION POE::Kernel is internally split into different resources that are separately managed by individual mix-in classes. POE::Resources is designed as a high-level macro manager for POE::Resource classes. Currently it implements a single method, load(), which loads all the POE::Resource classes. =head1 METHODS POE::Resources has a public interface, but it is intended to be used internally by POE::Kernel. Application programmers should never need to use POE::Resources directly. =head2 load POE::Kernel calls load() to loads all the known POE::Resource modules. Each resource may be handled by a pure perl module, or by an XS module. For each resource class, load() first tries to load the C version of the module. If that fails, load() falls back to C. =head1 SEE ALSO See L for public information about POE resources. See L for general discussion about resources and the classes that manage them. =head1 AUTHORS & LICENSING Please see L for more information about its authors, contributors, and POE's licensing. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.368/lib/POE/Filter.pm000644 001751 001751 00000025207 13615322623 015751 0ustar00bingosbingos000000 000000 package POE::Filter; use strict; use vars qw($VERSION); $VERSION = '1.368'; # NOTE - Should be #.### (three decimal places) use Carp qw(croak); #------------------------------------------------------------------------------ sub new { my $type = shift; croak "$type is not meant to be used directly"; } # Return all the messages possible to parse in the current input # buffer. This uses the newer get_one_start() and get_one(), which is # implementation dependent. sub get { my ($self, $stream) = @_; my @return; $self->get_one_start($stream); while (1) { my $next = $self->get_one(); last unless @$next; push @return, @$next; } return \@return; } sub clone { my $self = shift; my $buf = (ref($self->[0]) eq 'ARRAY') ? [ ] : ''; my $nself = bless [ $buf, # BUFFER @$self[1..$#$self], # everything else ], ref $self; return $nself; } sub __param_max { my( $type, $name, $default, $params ) = @_; return $default # 512 MB unless defined $params->{$name}; my $ret = $params->{$name}; croak "$name must be a number" unless $ret =~ /^\d+$/; croak "$name must greater then 0" unless $ret > 0; return $ret; } 1; __END__ =head1 NAME POE::Filter - protocol abstractions for POE::Wheel and standalone use =head1 SYNOPSIS To use with POE::Wheel classes, pass a POE::Filter object to one of the "...Filter" constructor parameters: #!perl use POE qw(Filter::Line Wheel::FollowTail); POE::Session->create( inline_states => { _start => sub { $_[HEAP]{tailor} = POE::Wheel::FollowTail->new( Filename => "/var/log/system.log", InputEvent => "got_log_line", Filter => POE::Filter::Line->new(), ); }, got_log_line => sub { print "Log: $_[ARG0]\n"; } } ); POE::Kernel->run(); exit; Standalone use without POE: #!perl use warnings; use strict; use POE::Filter::Line; my $filter = POE::Filter::Line->new( Literal => "\n" ); # Prints three lines: one, two three. $filter->get_one_start(["one\ntwo\nthr", "ee\nfour"]); while (1) { my $line = $filter->get_one(); last unless @$line; print $line->[0], "\n"; } # Prints two lines: four, five. $filter->get_one_start(["\nfive\n"]); while (1) { my $line = $filter->get_one(); last unless @$line; print $line->[0], "\n"; } =head1 DESCRIPTION POE::Filter objects plug into the wheels and define how the data will be serialized for writing and parsed after reading. POE::Wheel objects are responsible for moving data, and POE::Filter objects define how the data should look. POE::Filter objects are simple by design. They do not use POE internally, so they are limited to serialization and parsing. This may complicate implementation of certain protocols (like HTTP 1.x), but it allows filters to be used in stand-alone programs. Stand-alone use is very important. It allows application developers to create lightweight blocking libraries that may be used as simple clients for POE servers. POE::Component::IKC::ClientLite is a notable example. This lightweight, blocking event-passing client supports thin clients for gridded POE applications. The canonical use case is to inject events into an IKC application or grid from CGI interfaces, which require lightweight resource use. POE filters and drivers pass data in array references. This is slightly awkward, but it minimizes the amount of data that must be copied on Perl's stack. =head1 PUBLIC INTERFACE All POE::Filter classes must support the minimal interface, defined here. Specific filters may implement and document additional methods. =head2 new PARAMETERS new() creates and initializes a new filter. Constructor parameters vary from one POE::Filter subclass to the next, so please consult the documentation for your desired filter. =head2 clone clone() creates and initializes a new filter based on the constructor parameters of the existing one. The new filter is a near-identical copy, except that its buffers are empty. Certain components, such as POE::Component::Server::TCP, use clone(). These components accept a master or template filter at creation time, then clone() that filter for each new connection. my $new_filter = $old_filter->clone(); =head2 get_one_start ARRAYREF get_one_start() accepts an array reference containing unprocessed stream chunks. The chunks are added to the filter's internal buffer for parsing by get_one(). The L shows get_one_start() in use. =head2 get_one get_one() parses zero or one complete item from the filter's internal buffer. The data is returned as an ARRAYREF suitable for passing to another filter or a POE::Wheel object. Filters will return empty ARRAYREFs if they don't have enough raw data to build a complete item. get_one() is the lazy form of get(). It only parses only one item at a time from the filter's buffer. This is vital for applications that may switch filters in mid-stream, as it ensures that the right filter is in use at any given time. The L shows get_one() in use. Note how it assumes the return is always an ARRAYREF, and it implicitly handles empty ones. =head2 get ARRAYREF get() is the greedy form of get_one(). It accepts an array reference containing unprocessed stream chunks, and it adds that data to the filter's internal buffer. It then parses as many full items as possible from the buffer and returns them in another array reference. Any unprocessed data remains in the filter's buffer for the next call. As with get_one(), get() will return an empty array reference if the filter doesn't contain enough raw data to build a complete item. In fact, get() is implemented in POE::Filter in terms of get_one_start() and get_one(). Here's the get() form of the SYNOPSIS stand-alone example: #!perl use warnings; use strict; use POE::Filter::Line; my $filter = POE::Filter::Line->new( Literal => "\n" ); # Prints three lines: one, two three. my $lines = $filter->get(["one\ntwo\nthr", "ee\nfour"]); foreach my $line (@$lines) { print "$line\n"; } # Prints two lines: four, five. $lines = $filter->get(["\nfive\n"]); foreach my $line (@$lines) { print "$line\n"; } get() should not be used with wheels that support filter switching. Its greedy nature means that it often parses streams well in advance of a wheel's events. By the time an application changes the wheel's filter, it's too late: The old filter has already parsed the rest of the received data. Consider a stream of letters, numbers, and periods. The periods signal when to switch filters from one that parses letters to one that parses numbers. In our hypothetical application, letters must be handled one at a time, but numbers may be handled in chunks. We'll use POE::Filter::Block with a BlockSize of 1 to parse letters, and POE::FIlter::Line with a Literal terminator of "." to handle numbers. Here's the sample stream: abcdefg.1234567.hijklmnop.890.q We'll start with a ReadWrite wheel configured to parse characters. $_[HEAP]{wheel} = POE::Wheel::ReadWrite->new( Filter => POE::Filter::Block->new( BlockSize => 1 ), Handle => $socket, InputEvent => "got_letter", ); The "got_letter" handler will be called 8 times. One for each letter from a through g, and once for the period following g. Upon receiving the period, it will switch the wheel into number mode. sub handle_letter { my $letter = $_[ARG0]; if ($letter eq ".") { $_[HEAP]{wheel}->set_filter( POE::Filter::Line->new( Literal => "." ) ); $_[HEAP]{wheel}->event( InputEvent => "got_number" ); } else { print "Got letter: $letter\n"; } } If the greedy get() were used, the entire input stream would have been parsed as characters in advance of the first handle_letter() call. The set_filter() call would have been moot, since there would be no data left to be parsed. The "got_number" handler receives contiguous runs of digits as period-terminated lines. The greedy get() would cause a similar problem as above. sub handle_numbers { my $numbers = $_[ARG0]; print "Got number(s): $numbers\n"; $_[HEAP]->{wheel}->set_filter( POE::Filter::Block->new( BlockSize => 1 ) ); $_[HEAP]->{wheel}->event( InputEvent => "got_letter" ); } So don't do it! =head2 put ARRAYREF put() serializes items into a stream of octets that may be written to a file or sent across a socket. It accepts a reference to a list of items, and it returns a reference to a list of marshalled stream chunks. The number of output chunks is not necessarily related to the number of input items. In stand-alone use, put()'s output may be sent directly: my $line_filter = POE::Filter::Line->new(); my $lines = $line_filter->put(\@list_of_things); foreach my $line (@$lines) { print $line; } The list reference it returns may be passed directly to a driver or filter. Drivers and filters deliberately share the same put() interface so that things like this are possible: $driver->put( $transfer_encoding_filter->put( $content_encoding_filter->put( \@items ) ) ); 1 while $driver->flush(\*STDOUT); =head2 get_pending get_pending() returns any data remaining in a filter's input buffer. The filter's input buffer is not cleared, however. get_pending() returns a list reference if there's any data, or undef if the filter was empty. POE::Wheel objects use get_pending() during filter switching. Unprocessed data is fetched from the old filter with get_pending() and injected into the new filter with get_one_start(). use POE::Filter::Line; use POE::Filter::Stream; my $line_filter = POE::Filter::Line->new(); $line_filter->get_one_start([ "not a complete line" ]); my $stream_filter = POE::Filter::Stream->new(); my $line_buffer = $line_filter->get_pending(); $stream_filter->get_one_start($line_buffer) if $line_buffer; print "Stream: $_\n" foreach (@{ $stream_filter->get_one }); Full items are serialized whole, so there is no corresponding "put" buffer or accessor. =head1 SEE ALSO The SEE ALSO section in L contains a table of contents covering the entire POE distribution. POE is bundled with the following filters: L L L L L L L L L =head1 BUGS In theory, filters should be interchangeable. In practice, stream and block protocols tend to be incompatible. =head1 AUTHORS & COPYRIGHTS Please see L for more information about authors and contributors. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.368/lib/POE/Driver/000755 001751 001751 00000000000 13615550107 015413 5ustar00bingosbingos000000 000000 POE-1.368/lib/POE/Session.pm000644 001751 001751 00000155346 13615322623 016157 0ustar00bingosbingos000000 000000 package POE::Session; use strict; use vars qw($VERSION); $VERSION = '1.368'; # NOTE - Should be #.### (three decimal places) use Carp qw(carp croak); use Errno; sub SE_NAMESPACE () { 0 } sub SE_OPTIONS () { 1 } sub SE_STATES () { 2 } sub SE_ID () { 3 } sub CREATE_ARGS () { 'args' } sub CREATE_OPTIONS () { 'options' } sub CREATE_INLINES () { 'inline_states' } sub CREATE_PACKAGES () { 'package_states' } sub CREATE_OBJECTS () { 'object_states' } sub CREATE_HEAP () { 'heap' } sub OPT_TRACE () { 'trace' } sub OPT_DEBUG () { 'debug' } sub OPT_DEFAULT () { 'default' } sub EN_START () { '_start' } sub EN_DEFAULT () { '_default' } sub EN_SIGNAL () { '_signal' } #------------------------------------------------------------------------------ # Debugging flags for subsystems. They're done as double evals here # so that someone may define them before using POE::Session (or POE), # and the pre-defined value will take precedence over the defaults # here. # Shorthand for defining an assert constant. sub _define_assert { no strict 'refs'; foreach my $name (@_) { local $^W = 0; next if defined *{"ASSERT_$name"}{CODE}; if (defined *{"POE::Kernel::ASSERT_$name"}{CODE}) { eval( "sub ASSERT_$name () { " . *{"POE::Kernel::ASSERT_$name"}{CODE}->() . "}" ); die if $@; } else { eval "sub ASSERT_$name () { ASSERT_DEFAULT }"; die if $@; } } } # Shorthand for defining a trace constant. sub _define_trace { no strict 'refs'; local $^W = 0; foreach my $name (@_) { next if defined *{"TRACE_$name"}{CODE}; if (defined *{"POE::Kernel::TRACE_$name"}{CODE}) { eval( "sub TRACE_$name () { " . *{"POE::Kernel::TRACE_$name"}{CODE}->() . "}" ); die if $@; } else { eval "sub TRACE_$name () { TRACE_DEFAULT }"; die if $@; } } } BEGIN { # ASSERT_DEFAULT changes the default value for other ASSERT_* # constants. It inherits POE::Kernel's ASSERT_DEFAULT value, if # it's present. unless (defined &ASSERT_DEFAULT) { if (defined &POE::Kernel::ASSERT_DEFAULT) { eval( "sub ASSERT_DEFAULT () { " . &POE::Kernel::ASSERT_DEFAULT . " }" ); } else { eval 'sub ASSERT_DEFAULT () { 0 }'; } }; # TRACE_DEFAULT changes the default value for other TRACE_* # constants. It inherits POE::Kernel's TRACE_DEFAULT value, if # it's present. unless (defined &TRACE_DEFAULT) { if (defined &POE::Kernel::TRACE_DEFAULT) { eval( "sub TRACE_DEFAULT () { " . &POE::Kernel::TRACE_DEFAULT . " }" ); } else { eval 'sub TRACE_DEFAULT () { 0 }'; } }; _define_assert("STATES"); _define_trace("DESTROY"); } #------------------------------------------------------------------------------ # Export constants into calling packages. This is evil; perhaps # EXPORT_OK instead? The parameters NFA has in common with SESSION # (and other sessions) must be kept at the same offsets as each-other. sub OBJECT () { 0 } # TODO - deprecate and replace with SELF sub SESSION () { 1 } sub KERNEL () { 2 } sub HEAP () { 3 } sub STATE () { 4 } # TODO - deprecate and replace with EVENT sub SENDER () { 5 } # NFA keeps its state in 6. unused in session so that args match up. sub CALLER_FILE () { 7 } sub CALLER_LINE () { 8 } sub CALLER_STATE () { 9 } # TODO - deprecate and replace with CALLER_EVENT sub ARG0 () { 10 } sub ARG1 () { 11 } sub ARG2 () { 12 } sub ARG3 () { 13 } sub ARG4 () { 14 } sub ARG5 () { 15 } sub ARG6 () { 16 } sub ARG7 () { 17 } sub ARG8 () { 18 } sub ARG9 () { 19 } sub import { my $package = caller(); no strict 'refs'; *{ $package . '::OBJECT' } = \&OBJECT; *{ $package . '::SESSION' } = \&SESSION; *{ $package . '::KERNEL' } = \&KERNEL; *{ $package . '::HEAP' } = \&HEAP; *{ $package . '::STATE' } = \&STATE; *{ $package . '::SENDER' } = \&SENDER; *{ $package . '::ARG0' } = \&ARG0; *{ $package . '::ARG1' } = \&ARG1; *{ $package . '::ARG2' } = \&ARG2; *{ $package . '::ARG3' } = \&ARG3; *{ $package . '::ARG4' } = \&ARG4; *{ $package . '::ARG5' } = \&ARG5; *{ $package . '::ARG6' } = \&ARG6; *{ $package . '::ARG7' } = \&ARG7; *{ $package . '::ARG8' } = \&ARG8; *{ $package . '::ARG9' } = \&ARG9; *{ $package . '::CALLER_FILE' } = \&CALLER_FILE; *{ $package . '::CALLER_LINE' } = \&CALLER_LINE; *{ $package . '::CALLER_STATE' } = \&CALLER_STATE; } sub instantiate { my $type = shift; croak "$type requires a working Kernel" unless defined $POE::Kernel::poe_kernel; my $self = bless [ { }, # SE_NAMESPACE { }, # SE_OPTIONS { }, # SE_STATES ], $type; if (ASSERT_STATES) { $self->[SE_OPTIONS]->{+OPT_DEFAULT} = 1; } return $self; } sub try_alloc { my ($self, @args) = @_; # Verify that the session has a special start state, otherwise how # do we know what to do? Don't even bother registering the session # if the start state doesn't exist. if (exists $self->[SE_STATES]->{+EN_START}) { $POE::Kernel::poe_kernel->session_alloc($self, @args); } else { carp( "discarding session ", $POE::Kernel::poe_kernel->ID_session_to_id($self), " - no '_start' state" ); $self = undef; } $self; } #------------------------------------------------------------------------------ # New style constructor. This uses less DWIM and more DWIS, and it's # more comfortable for some folks; especially the ones who don't quite # know WTM. sub create { my ($type, @params) = @_; my @args; # We treat the parameter list strictly as a hash. Rather than dying # here with a Perl error, we'll catch it and blame it on the user. if (@params & 1) { croak "odd number of events/handlers (missing one or the other?)"; } my %params = @params; my $self = $type->instantiate(\%params); # Process _start arguments. We try to do the right things with what # we're given. If the arguments are a list reference, map its items # to ARG0..ARGn; otherwise make whatever the heck it is be ARG0. if (exists $params{+CREATE_ARGS}) { if (ref($params{+CREATE_ARGS}) eq 'ARRAY') { push @args, @{$params{+CREATE_ARGS}}; } else { push @args, $params{+CREATE_ARGS}; } delete $params{+CREATE_ARGS}; } # Process session options here. Several options may be set. if (exists $params{+CREATE_OPTIONS}) { if (ref($params{+CREATE_OPTIONS}) eq 'HASH') { $self->[SE_OPTIONS] = $params{+CREATE_OPTIONS}; } else { croak "options for $type constructor is expected to be a HASH reference"; } delete $params{+CREATE_OPTIONS}; } # Get down to the business of defining states. while (my ($param_name, $param_value) = each %params) { # Inline states are expected to be state-name/coderef pairs. if ($param_name eq CREATE_INLINES) { croak "$param_name does not refer to a hash" unless (ref($param_value) eq 'HASH'); while (my ($state, $handler) = each(%$param_value)) { croak "inline state for '$state' needs a CODE reference" unless (ref($handler) eq 'CODE'); $self->_register_state($state, $handler); } } # Package states are expected to be package-name/list-or-hashref # pairs. If the second part of the pair is a arrayref, then the # package methods are expected to be named after the states # they'll handle. If it's a hashref, then the keys are state # names and the values are package methods that implement them. elsif ($param_name eq CREATE_PACKAGES) { croak "$param_name does not refer to an array" unless (ref($param_value) eq 'ARRAY'); croak "the array for $param_name has an odd number of elements" if (@$param_value & 1); # Copy the parameters so they aren't destroyed. my @param_value = @$param_value; while (my ($package, $handlers) = splice(@param_value, 0, 2)) { # TODO What do we do if the package name has some sort of # blessing? Do we use the blessed thingy's package, or do we # maybe complain because the user might have wanted to make # object states instead? # An array of handlers. The array's items are passed through # as both state names and package method names. if (ref($handlers) eq 'ARRAY') { foreach my $method (@$handlers) { $self->_register_state($method, $package, $method); } } # A hash of handlers. Hash keys are state names; values are # package methods to implement them. elsif (ref($handlers) eq 'HASH') { while (my ($state, $method) = each %$handlers) { $self->_register_state($state, $package, $method); } } else { croak( "states for package '$package' " . "need to be a hash or array ref" ); } } } # Object states are expected to be object-reference/ # list-or-hashref pairs. They must be passed to &create in a list # reference instead of a hash reference because making object # references into hash keys loses their blessings. elsif ($param_name eq CREATE_OBJECTS) { croak "$param_name does not refer to an array" unless (ref($param_value) eq 'ARRAY'); croak "the array for $param_name has an odd number of elements" if (@$param_value & 1); # Copy the parameters so they aren't destroyed. my @param_value = @$param_value; while (@param_value) { my ($object, $handlers) = splice(@param_value, 0, 2); # Verify that the object is an object. This may catch simple # mistakes; or it may be overkill since it already checks that # $param_value is a arrayref. carp "'$object' is not an object" unless ref($object); # An array of handlers. The array's items are passed through # as both state names and object method names. if (ref($handlers) eq 'ARRAY') { foreach my $method (@$handlers) { $self->_register_state($method, $object, $method); } } # A hash of handlers. Hash keys are state names; values are # package methods to implement them. elsif (ref($handlers) eq 'HASH') { while (my ($state, $method) = each %$handlers) { $self->_register_state($state, $object, $method); } } else { croak "states for object '$object' need to be a hash or array ref"; } } } # Import an external heap. This is a convenience, since it # eliminates the need to connect _start options to heap values. elsif ($param_name eq CREATE_HEAP) { $self->[SE_NAMESPACE] = $param_value; } else { croak "unknown $type parameter: $param_name"; } } return $self->try_alloc(@args); } #------------------------------------------------------------------------------ sub DESTROY { my $self = shift; # Session's data structures are destroyed through Perl's usual # garbage collection. TRACE_DESTROY here just shows what's in the # session before the destruction finishes. TRACE_DESTROY and do { require Data::Dumper; POE::Kernel::_warn( "----- Session $self Leak Check -----\n", "-- Namespace (HEAP):\n", Data::Dumper::Dumper($self->[SE_NAMESPACE]), "-- Options:\n", ); foreach (sort keys (%{$self->[SE_OPTIONS]})) { POE::Kernel::_warn(" $_ = ", $self->[SE_OPTIONS]->{$_}, "\n"); } POE::Kernel::_warn("-- States:\n"); foreach (sort keys (%{$self->[SE_STATES]})) { POE::Kernel::_warn(" $_ = ", $self->[SE_STATES]->{$_}, "\n"); } }; } #------------------------------------------------------------------------------ sub _invoke_state { my ($self, $source_session, $state, $etc, $file, $line, $fromstate) = @_; # Trace the state invocation if tracing is enabled. if ($self->[SE_OPTIONS]->{+OPT_TRACE}) { POE::Kernel::_warn( $POE::Kernel::poe_kernel->ID_session_to_id($self), " -> $state (from $file at $line)\n" ); } # The desired destination state doesn't exist in this session. # Attempt to redirect the state transition to _default. unless (exists $self->[SE_STATES]->{$state}) { # There's no _default either; redirection's not happening today. # Drop the state transition event on the floor, and optionally # make some noise about it. unless (exists $self->[SE_STATES]->{+EN_DEFAULT}) { $! = exists &Errno::ENOSYS ? &Errno::ENOSYS : &Errno::EIO; if ($self->[SE_OPTIONS]->{+OPT_DEFAULT} and $state ne EN_SIGNAL) { my $loggable_self = $POE::Kernel::poe_kernel->_data_alias_loggable($self->ID); POE::Kernel::_warn( "a '$state' event was sent from $file at $line to $loggable_self ", "but $loggable_self has neither a handler for it ", "nor one for _default\n" ); } return undef; } # If we get this far, then there's a _default state to redirect # the transition to. Trace the redirection. if ($self->[SE_OPTIONS]->{+OPT_TRACE}) { POE::Kernel::_warn( $POE::Kernel::poe_kernel->ID_session_to_id($self), " -> $state redirected to _default\n" ); } # Transmogrify the original state transition into a corresponding # _default invocation. ARG1 is copied from $etc so it can't be # altered from a distance. $etc = [ $state, [@$etc] ]; $state = EN_DEFAULT; } # If we get this far, then the state can be invoked. So invoke it # already! # Inline states are invoked this way. if (ref($self->[SE_STATES]->{$state}) eq 'CODE') { return $self->[SE_STATES]->{$state}-> ( undef, # object $self, # session $POE::Kernel::poe_kernel, # kernel $self->[SE_NAMESPACE], # heap $state, # state $source_session, # sender undef, # unused #6 $file, # caller file name $line, # caller file line $fromstate, # caller state @$etc # args ); } # Package and object states are invoked this way. my ($object, $method) = @{$self->[SE_STATES]->{$state}}; return $object->$method # package/object (implied) ( $self, # session $POE::Kernel::poe_kernel, # kernel $self->[SE_NAMESPACE], # heap $state, # state $source_session, # sender undef, # unused #6 $file, # caller file name $line, # caller file line $fromstate, # caller state @$etc # args ); } #------------------------------------------------------------------------------ # Add, remove or replace states in the session. sub _register_state { my ($self, $name, $handler, $method) = @_; $method = $name unless defined $method; # Deprecate _signal. # RC 2004-09-07 - Decided to leave this in because it blames # problems with _signal on the user for using it. It should # probably go away after a little while, but not during the other # deprecations. if ($name eq EN_SIGNAL) { # Report the problem outside POE. my $caller_level = 0; local $Carp::CarpLevel = 1; while ( (caller $caller_level)[0] =~ /^POE::/ ) { $caller_level++; $Carp::CarpLevel++; } croak( ",----- DEPRECATION ERROR -----\n", "| The _signal event is deprecated. Please use sig() to register\n", "| an explicit signal handler instead.\n", "`-----------------------------\n", ); } # There is a handler, so try to define the state. This replaces an # existing state. if ($handler) { # Coderef handlers are inline states. if (ref($handler) eq 'CODE') { carp( "redefining handler for event($name) for session(", $POE::Kernel::poe_kernel->ID_session_to_id($self), ")" ) if ( $self->[SE_OPTIONS]->{+OPT_DEBUG} && (exists $self->[SE_STATES]->{$name}) ); $self->[SE_STATES]->{$name} = $handler; } # Non-coderef handlers may be package or object states. See if # the method belongs to the handler. elsif ($handler->can($method)) { carp( "redefining handler for event($name) for session(", $POE::Kernel::poe_kernel->ID_session_to_id($self), ")" ) if ( $self->[SE_OPTIONS]->{+OPT_DEBUG} && (exists $self->[SE_STATES]->{$name}) ); $self->[SE_STATES]->{$name} = [ $handler, $method ]; } # Something's wrong. This code also seems wrong, since # ref($handler) can't be 'CODE'. else { if ( (ref($handler) eq 'CODE') and $self->[SE_OPTIONS]->{+OPT_TRACE} ) { carp( $POE::Kernel::poe_kernel->ID_session_to_id($self), " : handler for event($name) is not a proper ref - not registered" ) } else { unless ($handler->can($method)) { if (length ref($handler)) { croak "object $handler does not have a '$method' method" } else { croak "package $handler does not have a '$method' method"; } } } } } # No handler. Delete the state! else { delete $self->[SE_STATES]->{$name}; } } #------------------------------------------------------------------------------ # Return the session's ID. This is a thunk into POE::Kernel, where # the session ID really lies. sub _set_id { my ($self, $id) = @_; $self->[SE_ID] = $id; } sub ID { return shift()->[SE_ID]; } #------------------------------------------------------------------------------ # Set or fetch session options. sub option { my $self = shift; my %return_values; # Options are set in pairs. while (@_ >= 2) { my ($flag, $value) = splice(@_, 0, 2); $flag = lc($flag); # If the value is defined, then set the option. if (defined $value) { # Change some handy values into boolean representations. This # clobbers the user's original values for the sake of DWIM-ism. ($value = 1) if ($value =~ /^(on|yes|true)$/i); ($value = 0) if ($value =~ /^(no|off|false)$/i); $return_values{$flag} = $self->[SE_OPTIONS]->{$flag}; $self->[SE_OPTIONS]->{$flag} = $value; } # Remove the option if the value is undefined. else { $return_values{$flag} = delete $self->[SE_OPTIONS]->{$flag}; } } # If only one option is left, then there's no value to set, so we # fetch its value. if (@_) { my $flag = lc(shift); $return_values{$flag} = ( exists($self->[SE_OPTIONS]->{$flag}) ? $self->[SE_OPTIONS]->{$flag} : undef ); } # If only one option was set or fetched, then return it as a scalar. # Otherwise return it as a hash of option names and values. my @return_keys = keys(%return_values); if (@return_keys == 1) { return $return_values{$return_keys[0]}; } else { return \%return_values; } } # Fetch the session's heap. In rare cases, libraries may need to # break encapsulation this way, probably also using # $kernel->get_current_session as an accessory to the crime. sub get_heap { my $self = shift; return $self->[SE_NAMESPACE]; } #------------------------------------------------------------------------------ # Create an anonymous sub that, when called, posts an event back to a # session. This maps postback references (stringified; blessing, and # thus refcount, removed) to parent session IDs. Members are set when # postbacks are created, and postbacks' DESTROY methods use it to # perform the necessary cleanup when they go away. Thanks to njt for # steering me right on this one. my %anonevent_parent_id; my %anonevent_weakened; # I assume that when the postback owner loses all reference to it, # they are done posting things back to us. That's when the postback's # DESTROY is triggered, and referential integrity is maintained. sub POE::Session::AnonEvent::DESTROY { my $self = shift; my $parent_id = delete $anonevent_parent_id{$self}; unless (delete $anonevent_weakened{$self}) { $POE::Kernel::poe_kernel->refcount_decrement( $parent_id, 'anon_event' ); } } sub POE::Session::AnonEvent::weaken { my $self = shift; unless ($anonevent_weakened{$self}) { my $parent_id = $anonevent_parent_id{$self}; $POE::Kernel::poe_kernel->refcount_decrement( $parent_id, 'anon_event' ); $anonevent_weakened{$self} = 1; } return $self; } # Tune postbacks depending on variations in toolkit behavior. BEGIN { # Tk blesses its callbacks internally, so we need to wrap our # blessed callbacks in unblessed ones. Otherwise our postback's # DESTROY method probably won't be called. if (exists $INC{'Tk.pm'}) { eval 'sub USING_TK () { 1 }'; } else { eval 'sub USING_TK () { 0 }'; } }; # Create a postback closure, maintaining referential integrity in the # process. The next step is to give it to something that expects to # be handed a callback. sub postback { my ($self, $event, @etc) = @_; my $id = $POE::Kernel::poe_kernel->ID_session_to_id($self); my $postback = bless sub { $POE::Kernel::poe_kernel->post( $id, $event, [ @etc ], [ @_ ] ); return 0; }, 'POE::Session::AnonEvent'; $anonevent_parent_id{$postback} = $id; $POE::Kernel::poe_kernel->refcount_increment( $id, 'anon_event' ); # Tk blesses its callbacks, so we must present one that isn't # blessed. Otherwise Tk's blessing would divert our DESTROY call to # its own, and that's not right. return sub { $postback->(@_) } if USING_TK; return $postback; } # Create a synchronous callback closure. The return value will be # passed to whatever is handed the callback. sub callback { my ($self, $event, @etc) = @_; my $id = $POE::Kernel::poe_kernel->ID_session_to_id($self); my $callback = bless sub { $POE::Kernel::poe_kernel->call( $id, $event, [ @etc ], [ @_ ] ); }, 'POE::Session::AnonEvent'; $anonevent_parent_id{$callback} = $id; $POE::Kernel::poe_kernel->refcount_increment( $id, 'anon_event' ); # Tk blesses its callbacks, so we must present one that isn't # blessed. Otherwise Tk's blessing would divert our DESTROY call to # its own, and that's not right. return sub { $callback->(@_) } if USING_TK; return $callback; } 1; __END__ =head1 NAME POE::Session - a generic event-driven task =head1 SYNOPSIS use POE; # auto-includes POE::Kernel and POE::Session POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield("next") }, next => sub { print "tick...\n"; $_[KERNEL]->delay(next => 1); }, }, ); POE::Kernel->run(); exit; POE::Session can also dispatch to object and class methods through L and L callbacks. =head1 DESCRIPTION POE::Session and its subclasses translate events from POE::Kernel's generic dispatcher into the particular calling conventions suitable for application code. In design pattern parlance, POE::Session classes are adapters between L and application code. The L that POE::Kernel manages are more like generic task structures. Unfortunately these two disparate concepts have virtually identical names. =head2 A note on nomenclature This documentation will refer to event handlers as "states" in certain unavoidable situations. Sessions were originally meant to be event-driven state machines, but their purposes evolved over time. Some of the legacy vocabulary lives on in the API for backward compatibility, however. Confusingly, L is a class for implementing actual event-driven state machines. Its documentation uses "state" in the proper sense. =head1 USING POE::Session POE::Session has two main purposes. First, it maps event names to the code that will handle them. Second, it maps a consistent event dispatch interface to those handlers. Consider the L for example. A POE::Session instance is created with two C, each mapping an event name ("_start" and "next") to an inline subroutine. POE::Session ensures that L and so on are meaningful within an event handler. Event handlers may also be object or class methods, using L and L respectively. The create() syntax is different than for C, but the calling convention is nearly identical. Notice that the created POE::Session object has not been saved to a variable. The new POE::Session object gives itself to POE::Kernel, which then manages it and all the resources it uses. It's possible to keep references to new POE::Session objects, but it's not usually necessary. If an application is not careful about cleaning up these references you will create circular references, which will leak memory when POE::Kernel would normally destroy the POE::Session object. It is recommended that you keep the session's L instead. =head2 POE::Session's Calling Convention The biggest syntactical hurdle most people have with POE is POE::Session's unconventional calling convention. For example: sub handle_event { my ($kernel, $heap, $parameter) = @_[KERNEL, HEAP, ARG0]; ...; } Or the use of C<$_[KERNEL]>, C<$_[HEAP]> and C<$_[ARG0]> inline, as is done in most examples. What's going on here is rather basic. Perl passes parameters into subroutines or methods using the @_ array. C, C, C and others are constants exported by POE::Session (which is included for free when a program uses POE). So C<$_[KERNEL]> is an event handler's KERNELth parameter. C<@_[HEAP, ARG0]> is a slice of @_ containing the HEAPth and ARG0th parameters. While this looks odd, it's perfectly plain and legal Perl syntax. POE uses it for a few reasons: =over 4 =item 1 In the common case, passing parameters in C<@_> is faster than passing hash or array references and then dereferencing them in the handler. =item 2 Typos in hash-based parameter lists are either subtle run-time errors or requires constant run-time checking. Constants are either known at compile time, or are clear compile-time errors. =item 3 Referencing C<@_> offsets by constants allows parameters to move in the future without breaking application code. =item 4 Most event handlers don't need all of C<@_>. Slices allow handlers to use only the parameters they're interested in. =back =head2 POE::Session Parameters Event handlers receive most of their run-time context in up to nine callback parameters. POE::Kernel provides many of them. =head3 $_[OBJECT] C<$_[OBJECT]> is $self for event handlers that are an object method. It is the class (package) name for class-based event handlers. It is undef for plain coderef callbacks, which have no special C<$self>-ish value. C is always zero, since C<$_[0]> is always C<$self> or C<$class> in object and class methods. Coderef handlers are called with an C placeholder in C<$_[0]> so that the other offsets remain valid. It's often useful for method-based event handlers to call other methods in the same object. C<$_[OBJECT]> helps this happen. sub ui_update_everything { my $self = $_[OBJECT]; $self->update_menu(); $self->update_main_window(); $self->update_status_line(); } You may also use method inheritance. Here we invoke $self->a_method(@_). Since Perl's C<< -> >> operator unshifts $self onto the beginning of @_, we must first shift a copy off to maintain POE's parameter offsets: sub a_method { my $self = shift; $self->SUPER::a_method( @_ ); # ... more work ... } =head3 $_[SESSION] C<$_[SESSION]> is a reference to the current session object. This lets event handlers access their session's methods. Programs may also compare C<$_[SESSION]> to C<$_[SENDER]> to verify that intra-session events did not come from other sessions. C<$_[SESSION]> may also be used as the destination for intra-session L and L. L is marginally more convenient and efficient than C however. It is bad form to access another session directly. The recommended approach is to manipulate a session through an event handler. sub enable_trace { my $previous_trace = $_[SESSION]->option( trace => 1 ); my $id = $_[SESSION]->ID; if ($previous_trace) { print "Session $id: dispatch trace is still on.\n"; } else { print "Session $id: dispatch trace has been enabled.\n"; } } =head3 $_[KERNEL] The KERNELth parameter is always a reference to the application's singleton L instance. It is most often used to call POE::Kernel methods from event handlers. # Set a 10-second timer. $_[KERNEL]->delay( time_is_up => 10 ); =head3 $_[HEAP] Every POE::Session object contains its own variable namespace known as the session's C. It is modeled and named after process memory heaps (not priority heaps). Heaps are by default anonymous hash references, but they may be initialized in L to be almost anything. POE::Session itself never uses C<$_[HEAP]>, although some POE components do. Heaps do not overlap between sessions, although create()'s "heap" parameter can be used to make this happen. These two handlers time the lifespan of a session: sub _start_handler { $_[HEAP]{ts_start} = time(); } sub _stop_handler { my $time_elapsed = time() - $_[HEAP]{ts_start}; print "Session ", $_[SESSION]->ID, " elapsed seconds: $elapsed\n"; } =head3 $_[STATE] The STATEth handler parameter contains the name of the event being dispatched in the current callback. This can be important since the event and handler names may significantly differ. Also, a single handler may be assigned to more than one event. POE::Session->create( inline_states => { one => \&some_handler, two => \&some_handler, six => \&some_handler, ten => \&some_handler, _start => sub { $_[KERNEL]->yield($_) for qw(one two six ten); } } ); sub some_handler { print( "Session ", $_[SESSION]->ID, ": some_handler() handled event $_[STATE]\n" ); } It should be noted however that having event names and handlers names match will make your code easier to navigate. =head3 $_[SENDER] Events must come from somewhere. C<$_[SENDER]> contains the currently dispatched event's source. C<$_[SENDER]> is commonly used as a return address for responses. It may also be compared against C<$_[KERNEL]> to verify that timers and other POE::Kernel-generated events were not spoofed. This C responds to the sender with an "echo" event that contains all the parameters it received. It avoids a feedback loop by ensuring the sender session and event (STATE) are not identical to the current ones. sub echo_handler { return if $_[SENDER] == $_[SESSION] and $_[STATE] eq "echo"; $_[KERNEL]->post( $_[SENDER], "echo", @_[ARG0..$#_] ); } =for comment TODO - Document which events should have $_[SENDER] == $_[KERNEL]. Probably in POE::Kernel.> =head3 $_[CALLER_FILE], $_[CALLER_LINE] and $_[CALLER_STATE] These parameters are a form of caller(), but they describe where the currently dispatched event originated. CALLER_FILE and CALLER_LINE are fairly plain. CALLER_STATE contains the name of the event that was being handled when the event was created, or when the event watcher that ultimately created the event was registered. =for comment TODO - Rename SENDER_FILE, SENDER_LINE, SENDER_STATE? =head3 @_[ARG0..ARG9] or @_[ARG0..$#_] Parameters $_[ARG0] through the end of @_ contain parameters provided by application code, event watchers, or higher-level libraries. These parameters are guaranteed to be at the end of @_ so that @_[ARG0..$#_] will always catch them all. $#_ is the index of the last value in @_. Blame Perl if it looks odd. It's merely the $#array syntax where the array name is an underscore. Consider $_[KERNEL]->yield( ev_whatever => qw( zero one two three ) ); The handler for ev_whatever will be called with "zero" in $_[ARG0], "one" in $_[ARG1], and so on. @_[ARG0..$#_] will contain all four words. sub ev_whatever { $_[OBJECT]->whatever( @_[ARG0..$#_] ); } =head2 Using POE::Session With Objects One session may handle events across many objects. Or looking at it the other way, multiple objects can be combined into one session. And what the heck---go ahead and mix in some inline code as well. POE::Session->create( object_states => [ $object_1 => { event_1a => "method_1a" }, $object_2 => { event_2a => "method_2a" }, ], inline_states => { event_3 => \&piece_of_code, }, ); However only one handler may be assigned to a given event name. Duplicates will overwrite earlier ones. event_1a is handled by calling C<< $object_1->method_1a(...) >>. C<$_[OBJECT]> is C<$object_1> in this case. C<$_[HEAP]> belongs to the session, which means anything stored there will be available to any other event handler regardless of the object. event_2a is handled by calling C<< $object_2->method_2a(...) >>. In this case C<$_[OBJECT]> is $object_2. C<$_[HEAP]> is the same anonymous hashref that was passed to the event_1a handler, though. The methods are resolved when the event is handled (late-binding). event_3 is handled by calling C. C<$_[OBJECT]> is C here because there's no object. And once again, C<$_[HEAP]> is the same shared hashref that the handlers for event_1a and event_2a saw. Interestingly, there's no technical reason that a single object can't handle events from more than one session: for (1..2) { POE::Session->create( object_states => [ $object_4 => { event_4 => "method_4" }, ] ); } Now C<< $object_4->method_4(...) >> may be called to handle events from one of two sessions. In both cases, C<$_[OBJECT]> will be C<$object_4>, but C<$_[HEAP]> will hold data for a particular session. The same goes for inline states. One subroutine may handle events from many sessions. C<$_[SESSION]> and C<$_[HEAP]> can be used within the handler to easily access the context of the session in which the event is being handled. =head1 PUBLIC METHODS POE::Session has just a few public methods. =head2 create LOTS_OF_STUFF C starts a new session running. It returns a new POE::Session object upon success, but most applications won't need to save it. C invokes the newly started session's _start event handler before returning. C also passes the new POE::Session object to L. POE's kernel holds onto the object in order to dispatch events to it. POE::Kernel will release the object when it detects the object has become moribund. This should cause Perl to destroy the object if application code has not saved a copy of it. C accepts several named parameters, most of which are optional. Note however that the parameters are not part of a hashref. =for comment Is it time to bring new() back as a synonym for create()? PG - NO! IMHO ->new implies simply creating the object, and that you have to hold onto the object. ->create implies other actions are happening, and that you don't want to hold on to it. =for comment TODO - Provide forward-compatible "handler" options and methods as synonyms for the "state" versions currently supported? PG - No, that's for 1.01 =for comment TODO - Add a "class_handlers" as a synonym for "package_handlers"? PG - Maybe. However, to many synonyms can be a pain for an API. =for comment TODO - The above TODOs may be summarized: "deprecate old language"? PG - Oh, you are thinking of deprecating the old language... erm... no? =for comment TODO PG - I notice these =head3 are in alphabetical order. I think TODO all the *_states options should be together. Followed by heap, args, TODO options =head3 args => ARRAYREF The C parameter accepts a reference to a list of parameters that will be passed to the session's _start event handler in C<@_> positions C through C<$#_> (the end of C<@_>). This example would print "arg0 arg1 etc.": POE::Session->create( inline_states => { _start => sub { print "Session started with arguments: @_[ARG0..$#_]\n"; }, }, args => [ 'arg0', 'arg1', 'etc.' ], ); =head3 heap => ANYTHING The C parameter allows a session's heap to be initialized differently at instantiation time. Heaps are usually anonymous hashrefs, but C may set them to be array references or even objects. This example prints "tree": POE::Session->create( inline_states => { _start => sub { print "Slot 0 = $_[HEAP][0]\n"; }, }, heap => [ 'tree', 'bear' ], ); Be careful when initializing the heap to be something that doesn't behave like a hashref. Some libraries assume hashref heap semantics, and they will fail if the heap doesn't work that way. =head3 inline_states => HASHREF C maps events names to the subroutines that will handle them. Its value is a hashref that maps event names to the coderefs of their corresponding handlers: POE::Session->create( inline_states => { _start => sub { print "arg0=$_[ARG0], arg1=$_[ARG1], etc.=$_[ARG2]\n"; }, _stop => \&stop_handler, }, args => [qw( arg0 arg1 etc. )], ); The term "inline" comes from the fact that coderefs can be inlined anonymous subroutines. Be very careful with closures, however. L. =head3 object_states => ARRAYREF C associates one or more objects to a session and maps event names to the object methods that will handle them. It's value is an C; C would stringify the objects, ruining them for method invocation. Here _start is handled by C<< $object->_session_start() >> and _stop triggers C<< $object->_session_stop() >>: POE::Session->create( object_states => [ $object => { _start => '_session_start', _stop => '_session_stop', } ] ); POE::Session also supports a short form where the event and method names are identical. Here _start invokes $object->_start(), and _stop triggers $object->_stop(): POE::Session->create( object_states => [ $object => [ '_start', '_stop' ], ] ); Methods are verified when the session is created, but also resolved when the handler is called (late binding). Most of the time, a method won't change. But in some circumstance, such as dynamic inheritance, a method could resolve to a different subroutine. =head3 options => HASHREF POE::Session sessions support a small number of options, which may be initially set with the C