POE-1.367/000755 000765 000024 00000000000 12533606201 012265 5ustar00trocstaff000000 000000 POE-1.367/CHANGES000644 000765 000024 00000051010 12533606211 013256 0ustar00trocstaff000000 000000 ================================ 2015-06-03 10:10:18 -0400 v1_367 ================================ commit 4f2ef10e7039f96659757f9e5097c45fc57cace1 Author: Rocco Caputo Date: Wed Jun 3 10:10:18 2015 -0400 Version bump for release. commit 208a5bf377f6b8c2064e927efd4bd331ab2016c2 Merge: e9377b1 6e0f41e Author: Rocco Caputo Date: Tue Jun 2 15:17:24 2015 -0400 Merge pull request #22 from zhouzhen1/prchallenge Some trivial changes for the CPAN PR challenge. commit e9377b10c19c11ed1d3e5d34040b2dcf90227a51 Author: Rocco Caputo Date: Tue Jun 2 14:37:40 2015 -0400 rt.cpan.org 96039. Avoid close() on a FIFO until the reader is done. Cygwin seems to block on close() if a FIFO contains data. This test deadlocks because it expects the ability to read from the FIFO asynchronously later. commit 882a097209c2b6e02ccd31f3fb32c24bed73cdb6 Author: Sulev-Madis Silber (ketas) Date: Tue Jun 2 13:58:57 2015 -0400 rt.cpan.org 100499. Fix SuccessEvent values for AF_INET6. Applied ketas' micro patches, and updated an example in the docs. commit e60ea6c5b7c8ae1b50fefeed336393e18df9a474 Author: Rocco Caputo Date: Tue Jun 2 09:08:59 2015 -0400 rt.cpan.org 101227. Comment on an unused assertion. commit 3df9e01dbc658c46b254df59968eda2413f9c21b Author: Slaven Rezić Date: Tue Jun 2 08:18:28 2015 -0400 rt.cpan.org 103842. Skip YAML line ending test on contemporary YAML. commit 6e0f41e8e671915de594d1c841b52e4042a5f04d Author: zhouzhen1 Date: Sun May 17 10:52:18 2015 +0800 a couple of pod typo fix commit 13ad85f20a46adb5afd354c68f650878eee32a8b Author: zhouzhen1 Date: Sun May 17 10:51:09 2015 +0800 add 'use strict' to POE/Queue.pm and POE/Resource.pm commit a888ad45a0eef04fa2aa476e60c54a13a54fd668 Merge: 4feeb50 d6ac082 Author: Rocco Caputo Date: Mon Feb 23 15:09:52 2015 -0500 Merge pull request #20 from nanis/nanis-fix-for-nmake Hard coded Unix-style directory separator causes problems on Windows with nmake commit 2e4f77ac8a675453270bc7529ce9c8a4eb498a24 Author: Chris 'BinGOs' Williams Date: Sat Feb 21 15:45:21 2015 +0000 Enable bind for IN6ADDR_ANY commit d6ac082351191b359d33b92e731748d56b8014dc Author: A. Sinan Unur Date: Fri Dec 19 13:57:00 2014 -0500 Use File::Spec->catfile to compose certain paths Surrounding them with double quotes worked on Windows, but created problems on other systems. commit 36a15cfb9bd929c60f86089bbdab8a883a835cc5 Author: A. Sinan Unur Date: Fri Dec 19 13:41:38 2014 -0500 Quote paths to fix errors with nmake on Windows C:\...\POE-1.366> nmake test "C:\opt\perl-5.20.1\bin\perl.exe" mylib/gen-tests.perl lib/POE.pm Can't open perl script "mylib": Permission denied NMAKE : fatal error U1077: 'C:\opt\perl-5.20.1\bin\perl.exe' : return code '0xd' Stop. This happens because perl ends up seeing mylib and /gen-tests.perl as two separate thingies. It seemed to me that the most straightforward solution which I do not think should effect any other platforms is to quote the filename arguments. Hope this makes sense. commit ee3a45043e210fcbf51b6ba4c44b8cd618ca1a37 Author: Rocco Caputo Date: Mon Dec 15 19:38:14 2014 -0500 Make loop discovery O(M+N) instead of O(M*N) stat() operations. commit 61353ea4b552b4f4448daf60b06f0cb5f8fbc602 Author: Tobias Leich Date: Wed Nov 5 10:54:21 2014 +0100 fix typo ("Consier" => "Consider") ================================ 2014-11-03 13:39:18 -0500 v1_366 ================================ commit 63e55125e55b4220984cc51dc3eb68ae1eb9cb21 Author: Rocco Caputo Date: Mon Nov 3 13:39:18 2014 -0500 Bump versions and dependencies for release. commit b800fb63188ac415b9f706428289d89b9d90e32f Author: Rocco Caputo Date: Fri Oct 31 12:23:41 2014 -0400 Fall back to getprotobyname() if Socket doesn't export IPPROTO_TCP or IPPROTO_UDP. CPAN testers were failing POE because Socket didn't provide these on the full range of test machines. The common thread seems to be Perl prior to 5.9. While quite old, there's no compelling reason not to support it. This change also caches the protocol numbers at startup, rather than looking them up every time. It should be slightly faster as a result. commit 90d04a311e463749dfeb10f3032866a723e7ca82 Author: Philip Gwyn Date: Fri Oct 31 11:12:11 2014 -0400 [rt.cpan.org 91406] Use empty string instead of undef for __DIE__ handler. The rt.cpan.org bug alleges that the empty string is more compatible. It doesn't seem to make a difference for contemporary versions of Perl, so why not? commit c6f8e4f9dabbef51a75dbb043c01c92807fc604c Author: Rocco Caputo Date: Thu Oct 30 12:26:25 2014 -0400 Trigger POE::Session _stop handlers when POE::Kernel->stop() is called. commit ad6056b4bf5f928f87694fb274b7f30ae1534eb7 Author: Rocco Caputo Date: Thu Oct 30 12:18:00 2014 -0400 Remove Data::Dump. It's not used, but use() is FAILing tests. commit 4d3cc9fb8310050b4854a5f17ebb3821a870edae Author: Rocco Caputo Date: Thu Oct 2 16:12:42 2014 -0400 Clarify the "now running in a different process" warning. ================================ 2014-10-01 19:38:47 -0400 v1_365 ================================ commit ac32695a49330c0543eb985c7e7024f29b14ea28 Author: Rocco Caputo Date: Wed Oct 1 19:38:47 2014 -0400 Bump the version for release. commit 0ffe08ceb164a53003a28364b9a9e3012961ecbb Author: Rocco Caputo Date: Wed Oct 1 19:28:11 2014 -0400 Expose exceptions thrown from SIGDIE handlers. This change causes both the error that triggered a SIGDIE and the error within the SIGDIE handler to be rethrown together. commit 786a6080bf3df744ad91d0b108ea2e4143a59e07 Author: Rocco Caputo Date: Wed Oct 1 19:22:25 2014 -0400 Add a failing test case for reporting die() from within SIGDIE. Grinnz provided this test case on Freenode #perl. It shows that die() within a SIGDIE handler is not reported. Instead, the original error is thrown without any indication why it wasn't handled as intended. commit 2eacf6bb69ab0843ed02a842a58de676c1cde06e Author: Rocco Caputo Date: Mon Sep 29 08:58:50 2014 -0400 SeekBack of 0 is fine on special files. Problem found by coworkers at Plixer International. commit 1092eff5dfde3ebc9db1f7e0948e332d794b38a7 Author: Rocco Caputo Date: Fri Sep 12 13:57:31 2014 -0400 Import carp() into POE::Filter::HTTPD. Passing a bogus parameter to POE::Filter::HTTPD->new() caused a complaint that carp() wasn't defined, rather than the proper complaint the carp() call was making. Thanks go to gbjk for passing on an anonymous report in IRC. commit 3155fff17f189be2674fb7870c8fc9d289392c37 Author: Brian Fraser Date: Sun Jul 27 03:25:47 2014 +0200 Workaround for systems without getprotobyn* (e.g. android) ================================ 2014-07-12 18:24:36 -0400 v1_364 ================================ commit 7d8713c1fad195f6ad0bf9dc55855e3162cc4838 Author: Rocco Caputo Date: Sat Jul 12 18:24:36 2014 -0400 Version bump for release. commit e55f062ea7019c907f6503c55f3be39caf05d74a Author: Rocco Caputo Date: Sat Jul 12 14:35:28 2014 -0400 Stop loading Data::Dump. It wasn't even being used. Address http://www.cpantesters.org/cpan/report/15547962-09ee-11e4-941a-988245 14c1bc commit 95dfad133b07402744a0e9f77987b9c90d3e2177 Author: Rocco Caputo Date: Sat Jul 12 14:33:04 2014 -0400 Replace // with || for that CPAN smoke box running Perl 5.8.9. ================================ 2014-07-12 02:41:55 -0400 v1_363 ================================ commit a4fb23c2afebe1aba411dba2d3623ea25bf64d95 Author: Rocco Caputo Date: Sat Jul 12 02:41:55 2014 -0400 Bump version for release. commit d68983dbb5ef4ed6de27c7433ee31d09e4f2474c Author: Rocco Caputo Date: Sat Jul 12 02:02:30 2014 -0400 Take about 1sec off a regression test. commit d00cd369b9f12df5f2b59bf91807243a72fe189a Author: Rocco Caputo Date: Sat Jul 12 01:54:27 2014 -0400 Add POE::Test::Sequence::create_generic_session(). A generic session runs all the events it receives through the test sequence. It seems like something that might be common for simple tests. t/90_regression/leolo-alarm-adjust.t uses it as a proof of concept, a future documentation example, and to shave about 2sec off the test. commit 903492af7d00400a86dab68a574cc0510ec73cea Author: Rocco Caputo Date: Sat Jul 12 01:30:49 2014 -0400 Shave about 3sec off a regression test. commit ba28c4e87622035e0a80325d3a9f5026ed3cd333 Author: Rocco Caputo Date: Sat Jul 12 01:26:27 2014 -0400 Shave 2.5 seconds off a regression test. ================================ 2014-07-11 23:16:32 -0400 v1_362 ================================ commit 66e54c7933be4b571d20eb638aaafd4502a06c43 Author: Rocco Caputo Date: Fri Jul 11 23:16:32 2014 -0400 Bump version for release. commit ec6842f343367e2b49c5d21ae93df4fab99dd91e Author: Rocco Caputo Date: Fri Jul 11 22:56:04 2014 -0400 Reduce the time for another FollowTail test from ~5sec to ~0.2sec. commit 9e042d00f54896e735f425b90195ec00243d5552 Author: Rocco Caputo Date: Fri Jul 11 22:42:28 2014 -0400 Don't fire undefined FollowTail idle events. commit 31396d74dad0c1b552b8f468968f1a9fa976b169 Author: Rocco Caputo Date: Fri Jul 11 21:12:00 2014 -0400 Abstract the regression test sequence helper into POE::Test::Sequence. commit 65cf8fc77ce18a7d803a70f6fc9dd7a91f687aec Author: Rocco Caputo Date: Fri Jul 11 19:26:35 2014 -0400 Speed up a test by adding an idle event to POE::Wheel::FollowTail. Rather than wait for several seconds to elapse, tests can set a low PollInterval and use IdleEvent handlers to tell when it's ready to move on. As a proof of concept, this commit also removes about 8 seconds from a regression test using the new IdleEvent. commit d30f5b361699c00ef539499bac35c3f5cbd5ef66 Author: Rocco Caputo Date: Fri Jul 11 13:13:02 2014 -0400 Avoid uninitialized value warnings when testing in development. commit caaa3ad01136522e3f6a470d9e05d6c373fa1a81 Author: Rocco Caputo Date: Fri Jul 11 09:41:20 2014 -0400 Remove a harmless(?) debugging print() from a test. ================================ 2014-07-11 09:31:29 -0400 v1_361 ================================ commit 4d439d921fd0d8b0b7d40cf423c45e3a78e23fa6 Author: Rocco Caputo Date: Fri Jul 11 09:31:29 2014 -0400 Version bump for release. commit 3ab670538cb23ef4a4f6f003a63aae9ac708fd0e Author: Rocco Caputo Date: Fri Jul 11 09:25:45 2014 -0400 Fix a test hang on Windows. ================================ 2014-07-08 08:20:30 -0400 v1_360 ================================ commit b14098d84f61e3cfd24acaf77d3ed805eff20992 Author: Rocco Caputo Date: Tue Jul 8 08:20:30 2014 -0400 Version bump to trigger a new release with Chris' regression fix. commit 3f672f6fde0a70a560888c4691bb83f03ae38e6e Author: Rocco Caputo Date: Tue Jul 8 00:47:19 2014 -0400 Update POE::Test::Loops dependency. ================================ 2014-07-08 08:16:28 -0400 v1_359 ================================ commit 712e3905fbfe1b55ade59366d1c798964f38e6bd Author: Rocco Caputo Date: Mon Jul 7 23:07:28 2014 -0400 Version bump. commit 20b920f6fa6bb225cc91da0ec2c368bdca7aabd7 Author: Chris 'BinGOs' Williams Date: Tue Jul 8 12:44:48 2014 +0100 Fix regression in SocketFactory with getnameinfo() commit adaa221878dfa42c854adc498e3734021ab88b92 Author: Rocco Caputo Date: Mon Jul 7 22:47:36 2014 -0400 rt.cpan.org 91374. Clarify a warning when an optional dependency is needed but absent. commit 5e21f99ecabaab4b1dfe8ecf53488c30b2655999 Merge: 8c98157 f3e987d Author: Rocco Caputo Date: Mon Jul 7 20:38:14 2014 -0400 Merge remote-tracking branch 'remotes/gh/master' commit f3e987d634d98d28f73b38d72b2f1d0dfe268cf6 Author: Rocco Caputo Date: Mon Jul 7 16:25:22 2014 -0400 Windows reports local address 0 as 0.0.0.0, and then the test canot connect to itself. commit 8c98157d46d7839181456de2c283604bd20f57e5 Author: Philip Gwyn Date: Thu May 22 12:39:25 2014 -0400 Fixed the doco commit 8de5712496e49d07904ca61a16d369b25fd4cc7f Author: Rocco Caputo Date: Sun May 4 16:37:24 2014 -0400 Revert "Convert POE::Resource::SIDs into a proper class." This reverts commit 68089ffe81a2dd1e39c07288ba1723d74165523f. commit b8bc1e1fe916e31ac663e29af614553eb0aa5956 Author: Rocco Caputo Date: Sun May 4 16:37:15 2014 -0400 Revert "Convert POE::Resource::Extrefs into a proper class." This reverts commit 3ae646376bd89572e9a61ae1d10d0609d0cdc025. commit b1e052e77580d51e9f9879044d15c4c6bc682507 Author: Rocco Caputo Date: Sun May 4 16:37:04 2014 -0400 Revert "Convert POE::Resource::Aliases into a proper class." This reverts commit f8e8c694d00c3cecf50c2a4d120ee67d7024c42d. commit 9bb7c26ad0e11d182e51bc28ed5625c620c16c08 Author: Philip Gwyn Date: Thu Apr 10 13:56:32 2014 -0400 POE::Filter::HTTPD will use Email::MIME::RFC2047::Encoder to convert UTF-8 headers into MIME entities Documentation for above Tests for above Added exceptions to 02_pod_coverage.t for POE::Filter::HTTPD commit dc5cbb25c5ed91a1f1165062664ac9e3bebbea84 Author: Philip Gwyn Date: Wed Apr 9 15:21:22 2014 -0400 POE::Filter::Block->new complains about unknown params POE::Filter::Grep->new complains about unknown params POE::Filter::Map->new complains about unknown params Added POE::Filter::Map::FIRST_UNUSED Added POE::Filter::Stackable::FIRST_UNUSED commit c149a72e0f9c3cd3fa70760056d45209d197b7ba Author: Philip Gwyn Date: Wed Apr 9 15:08:30 2014 -0400 Added POE::Filter::BlockRecord::FIRST_UNUSED POE::Filter::BlockRecord->new now checks for unknown params commit b49ccba376012704149991a7bbad17ee6f2a9567 Author: Philip Gwyn Date: Wed Apr 9 14:07:04 2014 -0400 Added MaxBuffer support Created a constructor that takes named parameters. Above constructor will also accept the old syntax Documentation for above Test cases for above Added POE::Fitler::Reference::FIRST_UNUSED commit a9742150086d7a9bba7a0e7f9e96cb7b5588ad99 Author: Philip Gwyn Date: Wed Apr 9 14:01:33 2014 -0400 Added FIRST_UNUSED commit 489d8be032999de120dbcbb8379dabc59d90e539 Author: Philip Gwyn Date: Wed Apr 9 12:52:45 2014 -0400 Added MaxBuffer to POE::Filter::HTTPD Document above Tests for above POE::Filter::HTTPD->new now complain about unknown parameters Get MaxContent via POE::Filter->__param_max() Added POE::Filter::HTTPD::FIRST_UNUSED commit 3110b479e14d2a5a553a298454cffaee844ae389 Author: Philip Gwyn Date: Wed Apr 9 12:20:43 2014 -0400 Added DEBUG constant Used above to help me figure some crap for POEx::HTTP::Server commit 1472d98b7355f0356e293dac4282faec603b75d4 Author: Philip Gwyn Date: Wed Apr 9 12:19:50 2014 -0400 Added MaxLength and MaxBuffer to POE::Filter::Line Tests for above Documented above commit 036525b5c8906193d1596d6723ffa07af252301d Author: Philip Gwyn Date: Wed Apr 9 12:11:09 2014 -0400 Added MaxBuffer and MaxLength parameters to POE::Filter::Block Added POE::Filter->__param_max for above Added unit tests for MaxBuffer and MaxLength Document the above Added POE::Filter::Block::FIRST_UNUSED because there wasn't one commit 0fae143ab3d3c76a54ad9dd25eef27c2eccdb950 Merge: ff6d5f8 f8e8c69 Author: Philip Gwyn Date: Tue Apr 8 17:01:59 2014 -0400 Merge branch 'master' of ssh://git.code.sf.net/p/poe/poe commit ff6d5f8d48860b68647224a9005438a9afd9431e Author: Philip Gwyn Date: Tue Apr 8 16:59:40 2014 -0400 POE::Filter::HTTPD Streaming mode no longer requires switching filters t/90_regression/leolo-filter-httpd.t tests the above commit f8e8c694d00c3cecf50c2a4d120ee67d7024c42d Author: Rocco Caputo Date: Tue Apr 8 12:16:30 2014 -0400 Convert POE::Resource::Aliases into a proper class. commit 6434f8a8a97668d303e834038d0f23f801b90dd1 Author: Philip Gwyn Date: Mon Apr 7 16:11:20 2014 -0400 Added POE::Filter::HTTPD->get_pending Added tests for Streaming requests This time remember to commit the unit test commit b1e6ab1ae698acd21573adf81363731c40305df5 Author: Philip Gwyn Date: Mon Apr 7 16:03:19 2014 -0400 Make sure Content-Length is a number Added tests for Content-Length changes commit 2f9cb24ab7482b7357afb027f133aaa9bc36c901 Author: Philip Gwyn Date: Mon Apr 7 15:37:30 2014 -0400 Added Streaming and MaxContent to POE::Filter::HTTPD commit 3ae646376bd89572e9a61ae1d10d0609d0cdc025 Author: Rocco Caputo Date: Mon Apr 7 02:12:51 2014 -0400 Convert POE::Resource::Extrefs into a proper class. commit 68089ffe81a2dd1e39c07288ba1723d74165523f Author: Rocco Caputo Date: Sun Apr 6 21:21:52 2014 -0400 Convert POE::Resource::SIDs into a proper class. commit 32ff484caef4bbdea1b36b42b3cf59f9e86d0793 Author: Rocco Caputo Date: Sun Apr 6 17:32:25 2014 -0400 Add parens to method invocations. Comment some internal methods. commit a71ac22e55e0f4577bb90f3a18cb1e7500e56cc1 Author: Rocco Caputo Date: Sun Apr 6 15:47:48 2014 -0400 Crudely benchmark the machine under test. A lot of POE's tests work around slow machines by unconditionally delaying a lot. This makes the tests feel ponderous on fast systems, and it thwarts Continuous Integration. Benchmarking machines under test will help me tell how much the work-around is needed. It may eventually hint to other tests how long they need to wait. commit 4a97b6befde298936bfa6bedfb5e3f0a1afae0ad Author: Philip Gwyn Date: Fri Apr 4 14:34:03 2014 -0400 Fixed previous patch for delay_adjust( $id, 0 ), which means the delay happens now. commit 5d656bae46101c2fa74775960bbe084b9a597379 Author: Philip Gwyn Date: Fri Apr 4 14:13:11 2014 -0400 Fixed POE::Kernel->delay_adjust() Added POE::Resource::Events->_data_ev_set() for above Tweaked POE::Resource::Events->_data_ev_adjust() in case it is called with $time commit b3f89d3386fc685440a4193c46713cb5cbf7aeae Author: Philip Gwyn Date: Fri Apr 4 13:53:53 2014 -0400 Fixed my regression test commit 9c6a69289fea5f4a93f9464a4efea0011fd08804 Author: Philip Gwyn Date: Fri Apr 4 13:51:01 2014 -0400 Added leolo-alarm-adjust.t to test alarm_adjust() and delay_adjust() commit e3db9b7c0dff9e46811f200507f5307aee6b1b80 Author: Philip Gwyn Date: Thu Mar 27 12:09:54 2014 -0400 Calculate window pixel size from columns, lines. Doco changes for above. Don't complain about Winsize for pty-pipe conduit. commit 1f63f16144151c334b6ade0a12a02d58fa80387a Author: Rocco Caputo Date: Fri Feb 28 11:33:02 2014 -0500 Socket.pm supports unpack_sockaddr_in6() now. ============== End of Excerpt ============== POE-1.367/examples/000755 000765 000024 00000000000 12533606201 014103 5ustar00trocstaff000000 000000 POE-1.367/HISTORY000644 000765 000024 00000037051 11440561202 013354 0ustar00trocstaff000000 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$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.367/MANIFEST000644 000765 000024 00000012225 12533606201 013420 0ustar00trocstaff000000 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.367/MANIFEST.SKIP000644 000765 000024 00000000507 11440561202 014162 0ustar00trocstaff000000 000000 CVS \.\# \.bak$ \.cvsignore \.gz$ \.orig$ \.patch$ \.ppd$ \.rej$ \.rej$ \.svn \.swo$ \.swp$ ^Makefile$ ^Makefile\.old$ ^POE.ppd$ ^\. ^_Inline ^_build ^blib/ ^comptest ^cover_db ^coverage\.report$ ^docs ^pm_to_blib$ ^poe_report\.xml$ run_network_tests test-output\.err$ t/[23]0_.*\.t ~$ # Work in Progress ^lib/POE/Loader\.pm$ POE-1.367/META.json000644 000765 000024 00000003043 12533606201 013706 0ustar00trocstaff000000 000000 { "abstract" : "Portable, event-loop agnostic eventy networking and multitasking.", "author" : [ "Rocco Caputo " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240", "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.367" } POE-1.367/META.yml000644 000765 000024 00000001624 12533606201 013541 0ustar00trocstaff000000 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.04, CPAN::Meta::Converter version 2.143240' 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.367' POE-1.367/mylib/000755 000765 000024 00000000000 12533606201 013401 5ustar00trocstaff000000 000000 POE-1.367/README000644 000765 000024 00000006154 12533605262 013161 0ustar00trocstaff000000 000000 Version 1.367 -------------------- Detailed Information -------------------- POE is bigger than this README. Please see http://poe.perl.org/ for more information. --------------------- Documentation Roadmap --------------------- POE includes a lot of documentation. The main POE man page includes references to everything else. POE has been around for a while. The CHANGES file has been limited to changes in the past year to help keep the distribution size down. POE's web site includes a complete change history broken down by release. -------------- Installing POE -------------- POE can be installed through the CPAN or CPANPLUS shell in the usual manner. % perl -MCPAN -e shell cpan> 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.367/t/000755 000765 000024 00000000000 12533606200 012527 5ustar00trocstaff000000 000000 POE-1.367/TODO000644 000765 000024 00000001124 11557356776 013003 0ustar00trocstaff000000 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.367/t/00_info.t000644 000765 000024 00000001056 12360015422 014146 0ustar00trocstaff000000 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.367/t/10_units/000755 000765 000024 00000000000 12533606200 014171 5ustar00trocstaff000000 000000 POE-1.367/t/20_resources/000755 000765 000024 00000000000 12533606200 015042 5ustar00trocstaff000000 000000 POE-1.367/t/90_regression/000755 000765 000024 00000000000 12533606200 015217 5ustar00trocstaff000000 000000 POE-1.367/t/90_regression/agaran-filter-httpd.t000644 000765 000024 00000003261 12360143741 021247 0ustar00trocstaff000000 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.367/t/90_regression/averell-callback-ret.t000644 000765 000024 00000001703 11440561202 021357 0ustar00trocstaff000000 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.367/t/90_regression/bingos-followtail.t000644 000765 000024 00000004240 12360121673 021043 0ustar00trocstaff000000 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.367/t/90_regression/broeren-win32-nbio.t000644 000765 000024 00000005006 11440561202 020724 0ustar00trocstaff000000 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.367/t/90_regression/cfedde-filter-httpd.t000644 000765 000024 00000004037 12360143344 021231 0ustar00trocstaff000000 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.367/t/90_regression/ferrari-server-unix.t000644 000765 000024 00000002152 11440561202 021321 0ustar00trocstaff000000 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.367/t/90_regression/grinnz-die-in-die.t000644 000765 000024 00000001355 12413106001 020610 0ustar00trocstaff000000 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.367/t/90_regression/hinrik-wheel-run-die.t000644 000765 000024 00000004462 11707702255 021352 0ustar00trocstaff000000 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.367/t/90_regression/kjeldahl-stop-start-polling.t000644 000765 000024 00000010560 11440561202 022742 0ustar00trocstaff000000 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.367/t/90_regression/kjeldahl-stop-start-sig-nopipe.t000644 000765 000024 00000010467 11440561202 023356 0ustar00trocstaff000000 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.367/t/90_regression/kjeldahl-stop-start-sig-pipe.t000644 000765 000024 00000010467 11440561202 023021 0ustar00trocstaff000000 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.367/t/90_regression/leolo-sig-die.t000644 000765 000024 00000004650 12424722537 020055 0ustar00trocstaff000000 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.367/t/90_regression/meh-startstop-return.t000644 000765 000024 00000001617 11440561202 021536 0ustar00trocstaff000000 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.367/t/90_regression/neyuki_detach.t000644 000765 000024 00000004125 11740202327 020223 0ustar00trocstaff000000 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.367/t/90_regression/pipe-followtail.t000644 000765 000024 00000003140 12533373120 020513 0ustar00trocstaff000000 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.367/t/90_regression/prumike-win32-stat.t000644 000765 000024 00000003176 12166057310 021004 0ustar00trocstaff000000 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.367/t/90_regression/rt14444-arg1.t000644 000765 000024 00000001746 11440561202 017270 0ustar00trocstaff000000 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.367/t/90_regression/rt1648-tied-stderr.t000644 000765 000024 00000005527 11440561202 020607 0ustar00trocstaff000000 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.367/t/90_regression/rt19908-merlyn-stop.t000644 000765 000024 00000001451 11440561202 020732 0ustar00trocstaff000000 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.367/t/90_regression/rt23181-sigchld-rc.t000644 000765 000024 00000001102 11440561202 020435 0ustar00trocstaff000000 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.367/t/90_regression/rt47966-sigchld.t000644 000765 000024 00000004716 11440561202 020072 0ustar00trocstaff000000 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.367/t/90_regression/rt56417-wheel-run.t000644 000765 000024 00000004040 11520371304 020341 0ustar00trocstaff000000 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.367/t/90_regression/rt65460-forking.t000644 000765 000024 00000010555 11552221331 020077 0ustar00trocstaff000000 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.367/t/90_regression/socketfactory-timeout.t000644 000765 000024 00000001563 11552221634 021761 0ustar00trocstaff000000 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.367/t/90_regression/somni-poco-server-tcp.t000644 000765 000024 00000014712 11440561202 021562 0ustar00trocstaff000000 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.367/t/90_regression/steinert-passed-wheel.t000644 000765 000024 00000002025 11440561202 021615 0ustar00trocstaff000000 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.367/t/90_regression/suzman_windows.t000644 000765 000024 00000003013 11440561202 020466 0ustar00trocstaff000000 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.367/t/90_regression/ton-stop-corruption.t000644 000765 000024 00000002037 12424463150 021377 0ustar00trocstaff000000 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.367/t/90_regression/tracing-sane-exit.t000644 000765 000024 00000002306 12331522373 020733 0ustar00trocstaff000000 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.367/t/90_regression/whelan-dieprop.t000644 000765 000024 00000001666 11440561202 020331 0ustar00trocstaff000000 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.367/t/90_regression/whjackson-followtail.t000644 000765 000024 00000006062 12360074237 021560 0ustar00trocstaff000000 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.367/t/20_resources/00_base/000755 000765 000024 00000000000 12533606201 016254 5ustar00trocstaff000000 000000 POE-1.367/t/20_resources/00_base/aliases.pm000644 000765 000024 00000005574 12331522360 020245 0ustar00trocstaff000000 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.367/t/20_resources/00_base/caller_state.pm000644 000765 000024 00000004621 11440561202 021254 0ustar00trocstaff000000 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.367/t/20_resources/00_base/events.pm000644 000765 000024 00000021362 12331520605 020121 0ustar00trocstaff000000 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.367/t/20_resources/00_base/extrefs.pm000644 000765 000024 00000012502 12331522373 020275 0ustar00trocstaff000000 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.367/t/20_resources/00_base/extrefs_gc.pm000644 000765 000024 00000004725 11524415412 020754 0ustar00trocstaff000000 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.367/t/20_resources/00_base/filehandles.pm000644 000765 000024 00000036726 12331520605 021105 0ustar00trocstaff000000 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.367/t/20_resources/00_base/sessions.pm000644 000765 000024 00000025714 12331522404 020467 0ustar00trocstaff000000 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.367/t/20_resources/00_base/sids.pm000644 000765 000024 00000003056 12331522404 017556 0ustar00trocstaff000000 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.367/t/20_resources/00_base/signals.pm000644 000765 000024 00000024660 12331522404 020260 0ustar00trocstaff000000 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.367/t/10_units/01_pod/000755 000765 000024 00000000000 12533606200 015253 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/02_pipes/000755 000765 000024 00000000000 12533606200 015612 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/03_base/000755 000765 000024 00000000000 12533606201 015406 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/04_drivers/000755 000765 000024 00000000000 12533606200 016152 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/05_filters/000755 000765 000024 00000000000 12533606200 016145 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/06_queues/000755 000765 000024 00000000000 12533606200 016005 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/07_exceptions/000755 000765 000024 00000000000 12533606200 016660 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/08_loops/000755 000765 000024 00000000000 12533606200 015634 5ustar00trocstaff000000 000000 POE-1.367/t/10_units/08_loops/01_explicit_loop.t000644 000765 000024 00000000562 11440561202 021174 0ustar00trocstaff000000 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.367/t/10_units/08_loops/02_explicit_loop_fail.t000644 000765 000024 00000000622 11440561202 022165 0ustar00trocstaff000000 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.367/t/10_units/08_loops/03_explicit_loop_poll.t000644 000765 000024 00000000564 11440561202 022226 0ustar00trocstaff000000 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.367/t/10_units/08_loops/04_explicit_loop_envvar.t000644 000765 000024 00000000632 11440561202 022556 0ustar00trocstaff000000 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.367/t/10_units/08_loops/05_kernel_loop.t000644 000765 000024 00000000554 11440561202 020640 0ustar00trocstaff000000 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.367/t/10_units/08_loops/06_kernel_loop_poll.t000644 000765 000024 00000000603 11440561202 021662 0ustar00trocstaff000000 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.367/t/10_units/08_loops/07_kernel_loop_fail.t000644 000765 000024 00000000637 11440561202 021637 0ustar00trocstaff000000 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.367/t/10_units/08_loops/08_kernel_loop_search_poll.t000644 000765 000024 00000000600 11440561202 023206 0ustar00trocstaff000000 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.367/t/10_units/08_loops/09_naive_loop_load.t000644 000765 000024 00000001377 11440561202 021471 0ustar00trocstaff000000 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.367/t/10_units/08_loops/10_naive_loop_load_poll.t000644 000765 000024 00000001401 11440561202 022473 0ustar00trocstaff000000 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.367/t/10_units/08_loops/11_double_loop.t000644 000765 000024 00000001121 11440561202 020616 0ustar00trocstaff000000 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.367/t/10_units/07_exceptions/01_normal.t000644 000765 000024 00000001641 11440561202 020635 0ustar00trocstaff000000 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.367/t/10_units/07_exceptions/02_turn_off.t000644 000765 000024 00000001046 12424462661 021203 0ustar00trocstaff000000 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.367/t/10_units/07_exceptions/03_not_handled.t000644 000765 000024 00000001661 12424462771 021646 0ustar00trocstaff000000 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.367/t/10_units/06_queues/01_array.t000644 000765 000024 00000014452 12357764573 017644 0ustar00trocstaff000000 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.367/t/10_units/05_filters/01_block.t000644 000765 000024 00000012561 12324035630 017732 0ustar00trocstaff000000 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.367/t/10_units/05_filters/02_grep.t000644 000765 000024 00000006337 11440561202 017577 0ustar00trocstaff000000 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.367/t/10_units/05_filters/03_http.t000644 000765 000024 00000046562 12360277746 017651 0ustar00trocstaff000000 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.367/t/10_units/05_filters/04_line.t000644 000765 000024 00000014413 12324035630 017570 0ustar00trocstaff000000 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.367/t/10_units/05_filters/05_map.t000644 000765 000024 00000004146 11440561202 017416 0ustar00trocstaff000000 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.367/t/10_units/05_filters/06_recordblock.t000644 000765 000024 00000005620 11440561202 021131 0ustar00trocstaff000000 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.367/t/10_units/05_filters/07_reference.t000644 000765 000024 00000012276 12324035630 020607 0ustar00trocstaff000000 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.367/t/10_units/05_filters/08_stream.t000644 000765 000024 00000003213 11440561202 020131 0ustar00trocstaff000000 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.367/t/10_units/05_filters/50_stackable.t000644 000765 000024 00000011442 11440561202 020567 0ustar00trocstaff000000 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.367/t/10_units/05_filters/51_reference_die.t000644 000765 000024 00000004446 12533317737 021444 0ustar00trocstaff000000 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.367/t/10_units/05_filters/99_filterchange.t000644 000765 000024 00000035574 11440561202 021322 0ustar00trocstaff000000 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.367/t/10_units/05_filters/TestFilter.pm000644 000765 000024 00000004272 11440561202 020573 0ustar00trocstaff000000 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.367/t/10_units/04_drivers/01_sysrw.t000644 000765 000024 00000014061 11614203247 020033 0ustar00trocstaff000000 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.367/t/10_units/03_base/01_poe.t000644 000765 000024 00000001365 11440561202 016660 0ustar00trocstaff000000 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.367/t/10_units/03_base/03_component.t000644 000765 000024 00000000222 11440561202 020070 0ustar00trocstaff000000 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.367/t/10_units/03_base/04_driver.t000644 000765 000024 00000000415 11440561202 017366 0ustar00trocstaff000000 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.367/t/10_units/03_base/05_filter.t000644 000765 000024 00000000415 11440561202 017361 0ustar00trocstaff000000 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.367/t/10_units/03_base/06_loop.t000644 000765 000024 00000000215 11440561202 017044 0ustar00trocstaff000000 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.367/t/10_units/03_base/07_queue.t000644 000765 000024 00000000412 11440561202 017217 0ustar00trocstaff000000 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.367/t/10_units/03_base/08_resource.t000644 000765 000024 00000000221 11440561202 017721 0ustar00trocstaff000000 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.367/t/10_units/03_base/09_resources.t000644 000765 000024 00000005236 11440561202 020120 0ustar00trocstaff000000 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.367/t/10_units/03_base/10_wheel.t000644 000765 000024 00000001462 11440561202 017177 0ustar00trocstaff000000 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.367/t/10_units/03_base/11_assert_usage.t000644 000765 000024 00000026214 11740312201 020557 0ustar00trocstaff000000 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.367/t/10_units/03_base/12_assert_retval.t000644 000765 000024 00000007144 11740313676 020773 0ustar00trocstaff000000 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.367/t/10_units/03_base/13_assert_data.t000644 000765 000024 00000003122 12320356064 020371 0ustar00trocstaff000000 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.367/t/10_units/03_base/14_kernel.t000644 000765 000024 00000001362 11440561202 017356 0ustar00trocstaff000000 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.367/t/10_units/03_base/15_kernel_internal.t000644 000765 000024 00000006365 11527015744 021276 0ustar00trocstaff000000 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.367/t/10_units/03_base/16_nfa_usage.t000644 000765 000024 00000003070 11440561202 020026 0ustar00trocstaff000000 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.367/t/10_units/03_base/17_detach_start.t000644 000765 000024 00000003410 11523064544 020553 0ustar00trocstaff000000 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.367/t/10_units/02_pipes/01_base.t000644 000765 000024 00000000217 11553370163 017220 0ustar00trocstaff000000 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.367/t/10_units/02_pipes/02_oneway.t000644 000765 000024 00000002634 11440561202 017605 0ustar00trocstaff000000 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.367/t/10_units/02_pipes/03_twoway.t000644 000765 000024 00000003717 11440561202 017641 0ustar00trocstaff000000 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.367/t/10_units/01_pod/01_pod.t000644 000765 000024 00000000412 11440561202 016515 0ustar00trocstaff000000 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.367/t/10_units/01_pod/02_pod_coverage.t000644 000765 000024 00000004426 12324035630 020405 0ustar00trocstaff000000 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.367/t/10_units/01_pod/03_pod_no404s.t000644 000765 000024 00000001001 11440561202 017621 0ustar00trocstaff000000 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.367/t/10_units/01_pod/04_pod_linkcheck.t000644 000765 000024 00000000645 12204522646 020553 0ustar00trocstaff000000 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.367/mylib/coverage.perl000644 000765 000024 00000005502 11440561202 016057 0ustar00trocstaff000000 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.367/mylib/cpan-test.perl000644 000765 000024 00000007551 11440561202 016170 0ustar00trocstaff000000 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.367/mylib/Devel/000755 000765 000024 00000000000 12533606200 014437 5ustar00trocstaff000000 000000 POE-1.367/mylib/events_per_second.pl000644 000765 000024 00000003626 11440561202 017447 0ustar00trocstaff000000 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.367/mylib/ForkingDaemon.pm000644 000765 000024 00000016452 11553341542 016477 0ustar00trocstaff000000 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.367/mylib/gen-tests.perl000644 000765 000024 00000005503 12533605457 016215 0ustar00trocstaff000000 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.367/mylib/MyOtherFreezer.pm000644 000765 000024 00000001466 11440561202 016655 0ustar00trocstaff000000 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.367/mylib/PoeBuildInfo.pm000644 000765 000024 00000004270 12425745715 016277 0ustar00trocstaff000000 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.367/mylib/svn-log.perl000644 000765 000024 00000017433 12204063464 015665 0ustar00trocstaff000000 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.367/mylib/Devel/Null.pm000644 000765 000024 00000001543 11440561202 015710 0ustar00trocstaff000000 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] =~ /\-\ 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 -w 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: svn co https://poe.svn.sourceforge.net/svnroot/poe poe =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 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. =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.367/lib/POE/Component/000755 000765 000024 00000000000 12533606200 015417 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Component.pm000644 000765 000024 00000006656 12533605262 016001 0ustar00trocstaff000000 000000 # Copyrights and documentation are after __END__. package POE::Component; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) 1; __END__ =head1 NAME POE::Component - event driven objects or subsystems =head1 SYNOPSIS See specific components. =head1 DESCRIPTION POE "components" are event-driven modules that generally encapsulate mid- to high-level program features. For example, POE::Component::Client::DNS performs message-based asynchronous resolver lookups. POE::Component::Server::TCP is a basic asynchronous network server. The POE::Component namespace was started as place for contributors to publish their POE-based modules without requiring coordination with the main POE distribution. The namespace predates the -X convention, otherwise you'd be reading about POEx instead. As with many things in Perl, there is more than one way to implement component interfaces. Newer components sport OO interfaces, and some even use Moose, but older ones are solely message driven. =head1 OBJECT ORIENTED COMPONENTS One way to create object-oriented components is to embed a POE::Session instance within an object. This is done by creating the session during the object's constructor, setting the session's alias to something unique, and saving a copy of the alias in the object. package Asynchrotron; my $alias_index = 0; sub new { my $class = shift; my $self = bless { alias => __PACKAGE__ . " " . ++$alias_index; }, $class; POE::Session->create( object_states => [ $self => { _start => "_poe_start", do_something => "_poe_do_something", }, ], ); return $self; } sub _poe_start { $_[KERNEL]->alias_set($_[OBJECT]->{alias}); } The alias allows object methods to pass events into the session without having to store something about the session. The POE::Kernel call() transfers execution from the caller session's context into the component's session. sub do_something { my $self = shift; print "Inside the caller's session right now: @_\n"; $poe_kernel->call($self->{alias}, "do_something", @_); } sub _poe_do_something { my @args = @_[ARG0..$#_]; print "Inside the component's session now: @args\n"; $_[OBJECT]{count}++; } Both $_[HEAP] and $_[OBJECT] are visible within the component's session. $_[HEAP] can be used for ultra-private encapsulation, while $_[OBJECT] may be used for data visible by accessors. sub get_count { my $self = shift; return $self->{count}; # $_[OBJECT]{count} above } Too many sessions may bog down object creation and destruction, so avoid creating them for every object. =head1 SEE ALSO The SEE ALSO section in L contains a table of contents covering the entire POE distribution. L is a nascent project to formalize POE components, make POE::Kernel more object-oriented, and provide syntactic and semantic sugar for many common aspects of POE::Component development. It's also easier to type. Please investigate the project. Ideas and I are badly needed to help get the project off the ground. =head1 TO DO Document the customary (but not mandatory!) process of creating and publishing a component. =head1 AUTHORS & COPYRIGHTS Each component is written and copyrighted separately. Please see L for more information about authors and contributors. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.367/lib/POE/Driver/000755 000765 000024 00000000000 12533606200 014710 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Driver.pm000644 000765 000024 00000011537 12533605262 015264 0ustar00trocstaff000000 000000 package POE::Driver; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) use Carp qw(croak); #------------------------------------------------------------------------------ sub new { my $type = shift; croak "$type is not meant to be used directly"; } #------------------------------------------------------------------------------ 1; __END__ =head1 NAME POE::Driver - an abstract interface for buffered, non-blocking I/O =head1 SYNOPSIS This is a contrived example of how POE::Filter and POE::Driver objects may be used in a stand-alone application. my $driver = POE::Driver::SysRW->new(); my $filter = POE::Filter::Line->new(); my $list_of_octet_chunks = $filter->put("A line of text."); $driver->put( $list_of_octet_chunks ); my $octets_remaining_in_buffer = $driver->flush($filehandle); die "couldn't flush everything" if $octets_remaining_in_buffer; while (1) { my $octets_list = $driver->get($filehandle); die $! unless defined $octets_list; $filter->get_one_start($octets_list); while (my $line = $filter->get_one()) { print "Input: $line\n"; } } Most programs will use POE::Filter and POE::Driver objects as parameters to POE::Wheel constructors. See the synopses for particular classes for details. =head1 DESCRIPTION POE::Driver is a common API for I/O drivers that can read from and write to various files, sockets, pipes, and other devices. POE "drivers" implement the specifics of reading and writing to devices. Drivers plug into POE::Wheel objects so that wheels may support a large number of device types without implementing a separate subclass for each. As mentioned in the SYNOPSIS, POE::Driver objects may be used in stand-alone applications. =head2 Public Driver Methods These methods are the generic Driver interface, and every driver must implement them. Specific drivers may have additional methods related to their particular tasks. =head3 new new() creates, initializes, and returns a new driver. Specific drivers may have different constructor parameters. The default constructor parameters should configure the driver for the most common use case. =head3 get FILEHANDLE get() immediately tries to read information from a FILEHANDLE. It returns an array reference on success---even if nothing was read from the FILEHANDLE. get() returns undef on error, and $! will be set to the reason why get() failed. The returned arrayref will be empty if nothing was read from the FILEHANDLE. In an EOF condition, get() returns undef with the numeric value of $! set to zero. The arrayref returned by get() is suitable for passing to any POE::Filter's get() or get_one_start() method. Wheels do exactly this internally. =over =item put ARRAYREF put() accepts an ARRAYREF of raw octet chunks. These octets are added to the driver's internal output queue or buffer. put() returns the number of octets pending output after the new octets are buffered. Some drivers may flush data immediately from their put() methods. =item flush FILEHANDLE flush() attempts to write a driver's buffered data to a given FILEHANDLE. The driver should flush as much data as possible in a single flush() call. flush() returns the number of octets remaining in the driver's output queue or buffer after the maximum amount of data has been written. flush() denotes success or failure by the value of $! after it returns. $! will always numerically equal zero on success. On failure, $! will contain the usual Errno value. In either case, flush() will return the number of octets in the driver's output queue. =item get_out_messages_buffered get_out_messages_buffered() returns the number of messages enqueued in the driver's output queue, rounded up to the nearest whole message. Some applications require the message count rather than the octet count. Messages are raw octet chunks enqueued by put(). The following put() call enqueues two messages for a total of six octets: $filter->put( [ "one", "two" ] ); It is possible for a flush() call to write part of a message. A partial message still counts as one message. =back =head1 SEE ALSO The SEE ALSO section in L contains a table of contents covering the entire POE distribution. L - A base class for POE::Session mix-ins. L - A base class for data parsers and serializers. L - A driver that encapsulates sysread() and buffered syswrite(). =head1 BUGS There is no POE::Driver::SendRecv, but nobody has needed one so far. sysread() and syswrite() manage to do almost everything people need. In theory, drivers should be pretty much interchangeable. In practice, there seems to be an impermeable barrier between the different SOCK_* types. =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.367/lib/POE/Filter/000755 000765 000024 00000000000 12533606201 014703 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Filter.pm000644 000765 000024 00000025207 12533605262 015255 0ustar00trocstaff000000 000000 package POE::Filter; use strict; use vars qw($VERSION); $VERSION = '1.367'; # 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.367/lib/POE/Kernel.pm000644 000765 000024 00000525220 12533605262 015250 0ustar00trocstaff000000 000000 package POE::Kernel; use strict; use vars qw($VERSION); $VERSION = '1.367'; # 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 *$const = sub () { $value }; } # 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.367/lib/POE/Loop/000755 000765 000024 00000000000 12533606200 014366 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Loop.pm000644 000765 000024 00000043711 12533605262 014741 0ustar00trocstaff000000 000000 package POE::Loop; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) 1; __END__ =head1 NAME POE::Loop - documentation for POE's event loop bridge interface =head1 SYNOPSIS $kernel->loop_initialize(); $kernel->loop_finalize(); $kernel->loop_do_timeslice(); $kernel->loop_run(); $kernel->loop_halt(); $kernel->loop_watch_signal($signal_name); $kernel->loop_ignore_signal($signal_name); $kernel->loop_attach_uidestroy($gui_window); $kernel->loop_resume_time_watcher($next_time); $kernel->loop_reset_time_watcher($next_time); $kernel->loop_pause_time_watcher(); $kernel->loop_watch_filehandle($handle, $mode); $kernel->loop_ignore_filehandle($handle, $mode); $kernel->loop_pause_filehandle($handle, $mode); $kernel->loop_resume_filehandle($handle, $mode); =head1 DESCRIPTION POE::Loop is a virtual base class that defines a standard event loop interface. POE::Loop subclasses mix into POE::Kernel and implement the features needed to manage underlying event loops in a consistent fashion. This documentation covers the interface, which is shared by all subclasses. As POE::Kernel loads, it searches through %INC for event loop modules. POE::Kernel loads the most appropriate POE::Loop subclass for the event loop it finds. The subclass slots its methods into POE::Kernel, completing the class at load time. POE and POE::Kernel provide ways to state the desired event loop in case the auto-detection makes a mistake or the developer prefers to be explicit. See L for instructions on how to actually use POE with other event loops, event loop naming conventions, and other details. POE::Loop subclasses exist for many of the event loops Perl supports: select(), IO::Poll, WxWindows, EV, Glib, Event, and so on. See CPAN for a full list. =head1 GENERAL NOTES As previously noted, POE::Loop subclasses provide additional methods to POE::Kernel and are not proper objects in themselves. Each POE::Loop subclass first defines its own namespace and version within it. This way CPAN and other things can track its version. They then switch to the POE::Kernel package to define their additional methods. POE::Loop is designed as a mix-in class because Perl imposed a performance penalty for method inheritance at the time the class was designed. This could be changed in the future, but it will require cascaded changes in several other classes. Here is a skeleton of a POE::Loop subclass: use strict; # YourToolkit bridge for POE::Kernel; package POE::Loop::YourToolkit; use vars qw($VERSION); $VERSION = '1.000'; # NOTE - Should be #.### (three decimal places) package POE::Kernel; # Define private lexical data here. # Implement the POE::Loop interface here. 1; __END__ =head1 NAME ... documentation goes here ... =cut =head1 PUBLIC INTERFACE POE::Loop's public interface is divided into four parts: administrative methods, signal handler methods, time management methods, and filehandle watcher methods. Each group and its members will be described in detail shortly. POE::Loop subclasses use lexical variables to keep track of things. Exact implementation is left up to the subclass' author. POE::Loop::Select keeps its bit vectors for select() calls in class-scoped (static) lexical variables. POE::Loop::Gtk tracks a single time watcher and multiple file watchers there. Bridges often employ private methods as callbacks from their event loops. The Event, Gtk, and Tk bridges do this. Private callback names should begin with "_loop_" to avoid colliding with other methods. Developers should look at existing bridges to get a feel for things. The C<-m> flag for perldoc will show a module in its entirety. perldoc -m POE::Loop::Select perldoc -m POE::Loop::Gtk ... =head2 Administrative Methods These methods initialize and finalize an event loop, run the loop to process events, and halt it. =head3 loop_initialize Initialize the event loop. Graphical toolkits especially need some sort of init() call or sequence to set up. For example, Tk requires a widget to be created before any events will be processed, and the program's user interface will be considered destroyed if that widget is closed. sub loop_initialize { my $self = shift; $poe_main_window = Tk::MainWindow->new(); die "could not create a main Tk window" unless defined $poe_main_window; $self->signal_ui_destroy($poe_main_window); } POE::Loop::Select initializes its select() bit vectors. sub loop_initialize { @loop_vectors = ( '', '', '' ); vec($loop_vectors[MODE_RD], 0, 1) = 0; vec($loop_vectors[MODE_WR], 0, 1) = 0; vec($loop_vectors[MODE_EX], 0, 1) = 0; } =head3 loop_finalize Finalize the event loop. Most event loops do not require anything here since they have already stopped by the time loop_finalize() is called. However, this is a good place to check that a bridge has not leaked memory or data. This example comes from POE::Loop::Event. sub loop_finalize { my $self = shift; foreach my $fd (0..$#fileno_watcher) { next unless defined $fileno_watcher[$fd]; foreach my $mode (MODE_RD, MODE_WR, MODE_EX) { POE::Kernel::_warn( "Mode $mode watcher for fileno $fd is defined during loop finalize" ) if defined $fileno_watcher[$fd]->[$mode]; } } $self->loop_ignore_all_signals(); } =head3 loop_do_timeslice Wait for time to pass or new events to occur, and dispatch any events that become due. If the underlying event loop does this through callbacks, then loop_do_timeslice() will either provide minimal glue or do nothing. For example, loop_do_timeslice() for POE::Loop::Select sets up and calls select(). If any files or other resources become active, it enqueues events for them. Finally, it triggers dispatch for any events are due. On the other hand, the Gtk event loop handles all this, so loop_do_timeslice() is empty for the Gtk bridge. A sample loop_do_timeslice() implementation is not presented here because it would either be quite large or empty. See each POE::Loop::IO_Poll or Select for large ones. Event and Gtk are empty. The bridges for Poll and Select for large ones. The ones for Event and Gtk are empty, and Tk's (in POE::Loop::TkCommon) is rather small. =head3 loop_run Run an event loop until POE has no more sessions to handle events. This method tends to be quite small, and it is often implemented in terms of loop_do_timeslice(). For example, POE::Loop::IO_Poll implements it: sub loop_run { my $self = shift; while ($self->_data_ses_count()) { $self->loop_do_timeslice(); } } This method is even more trivial when an event loop handles it. This is from the Gtk bridge: sub loop_run { unless (defined $_watcher_timer) { $_watcher_timer = Gtk->idle_add(\&_loop_resume_timer); } Gtk->main; } =head3 loop_halt loop_halt() does what it says: It halts POE's underlying event loop. It tends to be either trivial for external event loops or empty for ones that are implemented in the bridge itself (IO_Poll, Select). For example, the loop_run() method in the Poll bridge exits when sessions have run out, so its loop_halt() method is empty: sub loop_halt { # does nothing } Gtk, however, needs to be stopped because it does not know when POE is done. sub loop_halt { Gtk->main_quit(); } =head2 Signal Management Methods These methods enable and disable signal watchers. They are used by POE::Resource::Signals to manage an event loop's signal watchers. Most event loops use Perl's %SIG to watch for signals. This is so common that POE::Loop::PerlSignals implements the interface on behalf of other subclasses. =head3 loop_watch_signal SIGNAL_NAME Watch for a given SIGNAL_NAME. SIGNAL_NAME is the version found in %SIG, which tends to be the operating signal's name with the leading "SIG" removed. POE::Loop::PerlSignals' implementation adds callbacks to %SIG except for CHLD/CLD, which begins a waitpid() polling loop instead. As of this writing, all of the POE::Loop subclasses register their signal handlers through POE::Loop::PerlSignals. There are three types of signal handlers: CHLD/CLD handlers, when managed by the bridges themselves, poll for exited children. POE::Kernel does most of this, but loop_watch_signal() still needs to start the process. PIPE handlers. The PIPE signal event must be sent to the session that is active when the signal occurred. Everything else. Signal events for everything else are sent to POE::Kernel, where they are distributed to every session. The loop_watch_signal() methods tends to be very long, so an example is not presented here. The Event and Select bridges have good examples, though. =head3 loop_ignore_signal SIGNAL_NAME Stop watching SIGNAL_NAME. POE::Loop::PerlSignals does this by resetting the %SIG for the SIGNAL_NAME to a sane value. $SIG{CHLD} is left alone so as to avoid interfering with system() and other things. SIGPIPE is generally harmless since POE generates events for this condition. Therefore $SIG{PIPE} is set to "IGNORE" when it's not being handled. All other signal handlers default to "DEFAULT" when not in use. =head3 loop_attach_uidestroy WIDGET POE, when used with a graphical toolkit, should shut down when the user interface is closed. loop_attach_uidestroy() is used to shut down POE when a particular WIDGET is destroyed. The shutdown is done by firing a UIDESTROY signal when the WIDGET's closure or destruction callback is invoked. UIDESTROY guarantees the program will shut down by virtue of being terminal and non-maskable. loop_attach_uidestroy() is only meaningful in POE::Loop subclasses that tie into user interfaces. All other subclasses leave the method empty. Here's Gtk's: sub loop_attach_uidestroy { my ($self, $window) = @_; $window->signal_connect( delete_event => sub { if ($self->_data_ses_count()) { $self->_dispatch_event( $self, $self, EN_SIGNAL, ET_SIGNAL, [ 'UIDESTROY' ], __FILE__, __LINE__, undef, monotime(), -__LINE__ ); } return 0; } ); } =head2 Alarm and Time Management Methods These methods enable and disable a time watcher or alarm in the underlying event loop. POE only requires one, which is reused or re-created as necessary. Most event loops trigger callbacks when time has passed. It is the bridge's responsibility to register and unregister a callback as needed. When invoked, the callback should dispatch events that have become due and possibly set up a new callback for the next event to be dispatched. The time management methods may accept NEXT_EVENT_TIME. This is the time the next event will become due, in UNIX epoch time. NEXT_EVENT_TIME is a real number and may have sub-second accuracy. It is the bridge's responsibility to convert this value into something the underlying event loop requires. =head3 loop_resume_time_watcher NEXT_EVENT_TIME Resume an already active time watcher. It is used with loop_pause_time_watcher() to provide less expensive timer toggling for frequent use cases. As mentioned above, NEXT_EVENT_TIME is in UNIX epoch time and may have sub-second accuracy. loop_resume_time_watcher() is used by bridges that set them watchers in the underlying event loop. For example, POE::Loop::Gtk implements it this way: sub loop_resume_time_watcher { my ($self, $next_time) = @_; $next_time -= time(); $next_time *= 1000; $next_time = 0 if $next_time < 0; $_watcher_timer = Gtk->timeout_add( $next_time, \&_loop_event_callback ); } This method is usually empty in bridges that implement their own event loops. =head3 loop_reset_time_watcher NEXT_EVENT_TIME Reset a time watcher, often by stopping or destroying an existing one and creating a new one in its place. It is often a wrapper for loop_resume_time_watcher() that first destroys an existing watcher. For example, POE::Loop::Gkt's implementation: sub loop_reset_time_watcher { my ($self, $next_time) = @_; Gtk->timeout_remove($_watcher_timer); undef $_watcher_timer; $self->loop_resume_time_watcher($next_time); } =head3 loop_pause_time_watcher Pause a time watcher without destroying it, if the underlying event loop supports such a thing. POE::Loop::Event does support it: sub loop_pause_time_watcher { $_watcher_timer or return; $_watcher_timer->stop(); } =head2 File Activity Management Methods These methods enable and disable file activity watchers. There are four methods: loop_watch_filehandle(), loop_ignore_filehandle(), loop_pause_filehandle(), and loop_resume_filehandle(). The "pause" and "resume" methods are lightweight versions of "ignore" and "watch", respectively. All the methods take the same two parameters: a file HANDLE and a file access MODE. Modes may be MODE_RD, MODE_WR, or MODE_EX. These constants are defined by POE::Kernel and correspond to the semantics of POE::Kernel's select_read(), select_write(), and select_expedite() methods. POE calls MODE_EX "expedited" because it often signals that a file is ready for out-of-band information. Not all event loops handle MODE_EX. For example, Tk: sub loop_watch_filehandle { my ($self, $handle, $mode) = @_; my $fileno = fileno($handle); my $tk_mode; if ($mode == MODE_RD) { $tk_mode = 'readable'; } elsif ($mode == MODE_WR) { $tk_mode = 'writable'; } else { # The Tk documentation implies by omission that expedited # filehandles aren't, uh, handled. This is part 1 of 2. confess "Tk does not support expedited filehandles"; } # ... rest omitted .... } =head3 loop_watch_filehandle FILE_HANDLE, IO_MODE Watch a FILE_HANDLE for activity in a given IO_MODE. Depending on the underlying event loop, a watcher or callback will be registered for the FILE_HANDLE. Activity in the specified IO_MODE (read, write, or out of band) will trigger emission of the proper event in application space. POE::Loop::Select sets the fileno()'s bit in the proper select() bit vector. It also keeps track of which file descriptors are active. sub loop_watch_filehandle { my ($self, $handle, $mode) = @_; my $fileno = fileno($handle); vec($loop_vectors[$mode], $fileno, 1) = 1; $loop_filenos{$fileno} |= (1<<$mode); } =head3 loop_ignore_filehandle FILE_HANDLE, IO_MODE Stop watching the FILE_HANDLE in a given IO_MODE. Stops (and possibly destroys) an event watcher corresponding to the FILE_HANDLE and IO_MODE. POE::Loop::IO_Poll's loop_ignore_filehandle() manages descriptor/mode bits for its _poll() method here. It also performs some cleanup if a descriptor is no longer being watched after this ignore call. sub loop_ignore_filehandle { my ($self, $handle, $mode) = @_; my $fileno = fileno($handle); my $type = mode_to_poll($mode); my $current = $poll_fd_masks{$fileno} || 0; my $new = $current & ~$type; if (TRACE_FILES) { POE::Kernel::_warn( sprintf( " Ignore $fileno: " . ": Current mask: 0x%02X - removing 0x%02X = 0x%02X\n", $current, $type, $new ) ); } if ($new) { $poll_fd_masks{$fileno} = $new; } else { delete $poll_fd_masks{$fileno}; } } =head3 loop_pause_filehandle FILE_HANDLE, IO_MODE This is a lightweight form of loop_ignore_filehandle(). It is used along with loop_resume_filehandle() to temporarily toggle a watcher's state for a FILE_HANDLE in a particular IO_MODE. Some event loops, such as Event.pm, support their file watchers being disabled and re-enabled without the need to destroy and re-create the watcher objects. sub loop_pause_filehandle { my ($self, $handle, $mode) = @_; my $fileno = fileno($handle); $fileno_watcher[$fileno]->[$mode]->stop(); } By comparison, Event's loop_ignore_filehandle() method cancels and destroys the watcher object. sub loop_ignore_filehandle { my ($self, $handle, $mode) = @_; my $fileno = fileno($handle); if (defined $fileno_watcher[$fileno]->[$mode]) { $fileno_watcher[$fileno]->[$mode]->cancel(); undef $fileno_watcher[$fileno]->[$mode]; } } Ignoring and re-creating watchers is relatively expensive, so POE::Kernel's select_pause_read() and select_resume_read() methods (and the corresponding ones for write and expedite) use the faster versions. =head3 loop_resume_filehandle FILE_HANDLE, IO_MODE This is a lightweight form of loop_watch_filehandle(). It is used along with loop_pause_filehandle() to temporarily toggle a watcher's state for a FILE_HANDLE in a particular IO_MODE. =head1 HOW POE FINDS EVENT LOOP BRIDGES This is a rehash of L. Firstly, if a POE::Loop subclass is manually loaded before POE::Kernel, then that will be used. End of story. If one isn't, POE::Kernel searches for an external event loop module in %INC. For each module in %INC, corresponding POE::XS::Loop and POE::Loop subclasses are tried. For example, if IO::Poll is loaded, POE::Kernel tries use POE::XS::Loop::IO_Poll; use POE::Loop::IO_Poll; This is relatively expensive, but it ensures that POE::Kernel can find new POE::Loop subclasses without defining them in a central registry. POE::Loop::Select is the fallback event loop. It's loaded if no other event loop can be found in %INC. It can't be repeated often enough that event loops must be loaded before POE::Kernel. Otherwise they will not be present in %INC, and POE::Kernel will not detect them. =head1 SEE ALSO L, L, L, L, L, L. L is POE's event loop tests released as a separate, reusable distribution. POE::Loop authors are encouraged to use the tests for their own distributions. =for comment TODO - Link to CPAN for POE::Loop modules. =head1 BUGS None known. =for comment TODO - Link to POE bug queue. =head1 AUTHORS & LICENSING Please see L for more information about authors, contributors, and POE's licensing. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.367/lib/POE/NFA.pm000644 000765 000024 00000100253 12533605262 014427 0ustar00trocstaff000000 000000 package POE::NFA; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) use Carp qw(carp croak); sub SPAWN_INLINES () { 'inline_states' } sub SPAWN_OBJECTS () { 'object_states' } sub SPAWN_PACKAGES () { 'package_states' } sub SPAWN_OPTIONS () { 'options' } sub SPAWN_RUNSTATE () { 'runstate' } sub OPT_TRACE () { 'trace' } sub OPT_DEBUG () { 'debug' } sub OPT_DEFAULT () { 'default' } sub OPT_IMMEDIATE () { 'immediate' } sub EN_DEFAULT () { '_default' } sub EN_START () { '_start' } sub EN_STOP () { '_stop' } sub EN_SIGNAL () { '_signal' } sub NFA_EN_GOTO_STATE () { 'poe_nfa_goto_state' } sub NFA_EN_POP_STATE () { 'poe_nfa_pop_state' } sub NFA_EN_PUSH_STATE () { 'poe_nfa_push_state' } sub NFA_EN_STOP () { 'poe_nfa_stop' } sub SELF_RUNSTATE () { 0 } sub SELF_OPTIONS () { 1 } sub SELF_STATES () { 2 } sub SELF_ID () { 3 } sub SELF_CURRENT () { 4 } sub SELF_STATE_STACK () { 5 } sub SELF_INTERNALS () { 6 } sub SELF_CURRENT_NAME () { 7 } sub SELF_IS_IN_INTERNAL () { 8 } sub STACK_STATE () { 0 } sub STACK_EVENT () { 1 } #------------------------------------------------------------------------------ # 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_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 } sub MACHINE () { 1 } sub KERNEL () { 2 } sub RUNSTATE () { 3 } sub EVENT () { 4 } sub SENDER () { 5 } sub STATE () { 6 } sub CALLER_FILE () { 7 } sub CALLER_LINE () { 8 } sub CALLER_STATE () { 9 } 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 . '::MACHINE' } = \&MACHINE; *{ $package . '::KERNEL' } = \&KERNEL; *{ $package . '::RUNSTATE' } = \&RUNSTATE; *{ $package . '::EVENT' } = \&EVENT; *{ $package . '::SENDER' } = \&SENDER; *{ $package . '::STATE' } = \&STATE; *{ $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; } #------------------------------------------------------------------------------ # Spawn a new state machine. sub _add_ref_states { my ($states, $refs) = @_; foreach my $state (keys %$refs) { $states->{$state} = {}; my $data = $refs->{$state}; croak "the data for state '$state' should be an array" unless ( ref $data eq 'ARRAY' ); croak "the array for state '$state' has an odd number of elements" if ( @$data & 1 ); while (my ($ref, $events) = splice(@$data, 0, 2)) { if (ref $events eq 'ARRAY') { foreach my $event (@$events) { $states->{$state}->{$event} = [ $ref, $event ]; } } elsif (ref $events eq 'HASH') { foreach my $event (keys %$events) { my $method = $events->{$event}; $states->{$state}->{$event} = [ $ref, $method ]; } } else { croak "events with '$ref' for state '$state' " . "need to be a hash or array ref"; } } } } sub spawn { 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. croak "odd number of events/handlers (missing one or the other?)" if @params & 1; my %params = @params; croak "$type requires a working Kernel" unless defined $POE::Kernel::poe_kernel; # Options are optional. my $options = delete $params{+SPAWN_OPTIONS}; $options = { } unless defined $options; # States are required. croak( "$type constructor requires at least one of the following parameters: " . join (", ", SPAWN_INLINES, SPAWN_OBJECTS, SPAWN_PACKAGES) ) unless ( exists $params{+SPAWN_INLINES} or exists $params{+SPAWN_OBJECTS} or exists $params{+SPAWN_PACKAGES} ); my $states = delete($params{+SPAWN_INLINES}) || {}; if (exists $params{+SPAWN_OBJECTS}) { my $objects = delete $params{+SPAWN_OBJECTS}; _add_ref_states($states, $objects); } if (exists $params{+SPAWN_PACKAGES}) { my $packages = delete $params{+SPAWN_PACKAGES}; _add_ref_states($states, $packages); } my $runstate = delete($params{+SPAWN_RUNSTATE}) || {}; # These are unknown. croak( "$type constructor does not recognize these parameter names: ", join(', ', sort(keys(%params))) ) if keys %params; # Build me. my $self = bless [ $runstate, # SELF_RUNSTATE $options, # SELF_OPTIONS $states, # SELF_STATES undef, # SELF_ID undef, # SELF_CURRENT [ ], # SELF_STATE_STACK { }, # SELF_INTERNALS '(undef)', # SELF_CURRENT_NAME 0, # SELF_IS_IN_INTERNAL ], $type; # Register the machine with the POE kernel. $POE::Kernel::poe_kernel->session_alloc($self); # Return it for immediate reuse. return $self; } #------------------------------------------------------------------------------ # Another good inheritance candidate. sub DESTROY { my $self = shift; # NFA'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 { POE::Kernel::_warn( "----- NFA $self Leak Check -----\n", "-- Namespace (HEAP):\n" ); foreach (sort keys (%{$self->[SELF_RUNSTATE]})) { POE::Kernel::_warn(" $_ = ", $self->[SELF_RUNSTATE]->{$_}, "\n"); } POE::Kernel::_warn("-- Options:\n"); foreach (sort keys (%{$self->[SELF_OPTIONS]})) { POE::Kernel::_warn(" $_ = ", $self->[SELF_OPTIONS]->{$_}, "\n"); } POE::Kernel::_warn("-- States:\n"); foreach (sort keys (%{$self->[SELF_STATES]})) { POE::Kernel::_warn(" $_ = ", $self->[SELF_STATES]->{$_}, "\n"); } }; } #------------------------------------------------------------------------------ sub _invoke_state { my ($self, $sender, $event, $args, $file, $line, $fromstate) = @_; # Trace the state invocation if tracing is enabled. if ($self->[SELF_OPTIONS]->{+OPT_TRACE}) { POE::Kernel::_warn( $POE::Kernel::poe_kernel->ID_session_to_id($self), " -> $event\n" ); } # Discard troublesome things. return if $event eq EN_START; return if $event eq EN_STOP; # Stop request has come through the queue. Shut us down. if ($event eq NFA_EN_STOP) { $POE::Kernel::poe_kernel->_data_ses_stop($self->ID); return; } # Make a state transition. if ($event eq NFA_EN_GOTO_STATE) { my ($new_state, $enter_event, @enter_args) = @$args; # Make sure the new state exists. POE::Kernel::_die( $POE::Kernel::poe_kernel->ID_session_to_id($self), " tried to enter nonexistent state '$new_state'\n" ) unless exists $self->[SELF_STATES]->{$new_state}; # If an enter event was specified, make sure that exists too. POE::Kernel::_die( $POE::Kernel::poe_kernel->ID_session_to_id($self), " tried to invoke nonexistent enter event '$enter_event' ", "in state '$new_state'\n" ) unless ( not defined $enter_event or ( length $enter_event and exists $self->[SELF_STATES]->{$new_state}->{$enter_event} ) ); # Invoke the current state's leave event, if one exists. $self->_invoke_state( $self, 'leave', [], undef, undef, undef ) if exists $self->[SELF_CURRENT]->{leave}; # Enter the new state. $self->[SELF_CURRENT] = $self->[SELF_STATES]->{$new_state}; $self->[SELF_CURRENT_NAME] = $new_state; # Invoke the new state's enter event, if requested. $self->_invoke_state( $self, $enter_event, \@enter_args, undef, undef, undef ) if defined $enter_event; return undef; } # Push a state transition. if ($event eq NFA_EN_PUSH_STATE) { my @args = @$args; push( @{$self->[SELF_STATE_STACK]}, [ $self->[SELF_CURRENT_NAME], # STACK_STATE shift(@args), # STACK_EVENT ] ); $self->_invoke_state( $self, NFA_EN_GOTO_STATE, \@args, undef, undef, undef ); return undef; } # Pop a state transition. if ($event eq NFA_EN_POP_STATE) { POE::Kernel::_die( $POE::Kernel::poe_kernel->ID_session_to_id($self), " tried to pop a state from an empty stack\n" ) unless @{ $self->[SELF_STATE_STACK] }; my ($previous_state, $previous_event) = @{ pop @{ $self->[SELF_STATE_STACK] } }; $self->_invoke_state( $self, NFA_EN_GOTO_STATE, [ $previous_state, $previous_event, @$args ], undef, undef, undef ); return undef; } # Stop. # Try to find the event handler in the current state or the internal # event handlers used by wheels and the like. my ( $handler, $is_in_internal ); if (exists $self->[SELF_CURRENT]->{$event}) { $handler = $self->[SELF_CURRENT]->{$event}; } elsif (exists $self->[SELF_INTERNALS]->{$event}) { $handler = $self->[SELF_INTERNALS]->{$event}; $is_in_internal = ++$self->[SELF_IS_IN_INTERNAL]; } # If it wasn't found in either of those, then check for _default in # the current state. elsif (exists $self->[SELF_CURRENT]->{+EN_DEFAULT}) { # If we get this far, then there's a _default event to redirect # the event to. Trace the redirection. if ($self->[SELF_OPTIONS]->{+OPT_TRACE}) { POE::Kernel::_warn( $POE::Kernel::poe_kernel->ID_session_to_id($self), " -> $event redirected to EN_DEFAULT in state ", "'$self->[SELF_CURRENT_NAME]'\n" ); } $handler = $self->[SELF_CURRENT]->{+EN_DEFAULT}; # Transform the parameters for _default. ARG1 and beyond are # copied so they can't be altered at a distance. $args = [ $event, [@$args] ]; $event = EN_DEFAULT; } # No external event handler, no internal event handler, and no # external _default handler. This is a grievous error, and now we # must die. elsif ($event ne EN_SIGNAL) { POE::Kernel::_die( "a '$event' event was sent from $file at $line to session ", $POE::Kernel::poe_kernel->ID_session_to_id($self), ", but session ", $POE::Kernel::poe_kernel->ID_session_to_id($self), " has neither a handler for it nor one for _default ", "in its current state, '$self->[SELF_CURRENT_NAME]'\n" ); } # Inline event handlers are invoked this way. my $return; if (ref($handler) eq 'CODE') { $return = $handler->( undef, # OBJECT $self, # MACHINE $POE::Kernel::poe_kernel, # KERNEL $self->[SELF_RUNSTATE], # RUNSTATE $event, # EVENT $sender, # SENDER $self->[SELF_CURRENT_NAME], # STATE $file, # CALLER_FILE_NAME $line, # CALLER_FILE_LINE $fromstate, # CALLER_STATE @$args # ARG0.. ); } # Package and object handlers are invoked this way. else { my ($object, $method) = @$handler; $return = $object->$method( # OBJECT (package, implied) $self, # MACHINE $POE::Kernel::poe_kernel, # KERNEL $self->[SELF_RUNSTATE], # RUNSTATE $event, # EVENT $sender, # SENDER $self->[SELF_CURRENT_NAME], # STATE $file, # CALLER_FILE_NAME $line, # CALLER_FILE_LINE $fromstate, # CALLER_STATE @$args # ARG0.. ); } $self->[SELF_IS_IN_INTERNAL]-- if $is_in_internal; return $return; } #------------------------------------------------------------------------------ # Add, remove or replace event handlers in the session. This is going # to be tricky since wheels need this but the event handlers can't be # limited to a single state. I think they'll go in a hidden internal # state, or something. sub _register_state { my ($self, $name, $handler, $method) = @_; $method = $name unless defined $method; # Deprecate _signal. 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') { POE::Kernel::_carp( "redefining handler for event($name) for session(", $POE::Kernel::poe_kernel->ID_session_to_id($self), ")" ) if ( $self->[SELF_OPTIONS]->{+OPT_DEBUG} and (exists $self->[SELF_INTERNALS]->{$name}) ); $self->[SELF_INTERNALS]->{$name} = $handler; } # Non-coderef handlers may be package or object states. See if # the method belongs to the handler. elsif ($handler->can($method)) { POE::Kernel::_carp( "redefining handler for event($name) for session(", $POE::Kernel::poe_kernel->ID_session_to_id($self), ")" ) if ( $self->[SELF_OPTIONS]->{+OPT_DEBUG} && (exists $self->[SELF_INTERNALS]->{$name}) ); $self->[SELF_INTERNALS]->{$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->[SELF_OPTIONS]->{+OPT_TRACE} ) { POE::Kernel::_carp( $self->fetch_id(), " : 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->[SELF_INTERNALS]->{$name}; } } #------------------------------------------------------------------------------ # Return the session's ID. This is a thunk into POE::Kernel, where # the session ID really lies. This is a good inheritance candidate. sub _set_id { my ($self, $id) = @_; $self->[SELF_ID] = $id; } sub ID { return shift()->[SELF_ID]; } #------------------------------------------------------------------------------ # Return the session's current state's name. sub get_current_state { my $self = shift; return $self->[SELF_CURRENT_NAME]; } #------------------------------------------------------------------------------ # Fetch the session's run state. 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_runstate { my $self = shift; return $self->[SELF_RUNSTATE]; } #------------------------------------------------------------------------------ # Set or fetch session options. This is virtually identical to # POE::Session and a good inheritance candidate. 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->[SELF_OPTIONS]->{$flag}; $self->[SELF_OPTIONS]->{$flag} = $value; } # Remove the option if the value is undefined. else { $return_values{$flag} = delete $self->[SELF_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->[SELF_OPTIONS]->{$flag}) ? $self->[SELF_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; } } #------------------------------------------------------------------------------ # This stuff is identical to the stuff in POE::Session. Good # inheritance candidate. # Create an anonymous sub that, when called, posts an event back to a # session. This is highly experimental code to support Tk widgets and # maybe Event callbacks. There's no guarantee that this code works # yet, nor is there one that it'll be here in the next version. # 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 %postback_parent_id; # 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::NFA::Postback::DESTROY { my $self = shift; my $parent_id = delete $postback_parent_id{$self}; $POE::Kernel::poe_kernel->refcount_decrement( $parent_id, 'postback' ); } # 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(shift); my $postback = bless sub { $POE::Kernel::poe_kernel->post( $id, $event, [ @etc ], [ @_ ] ); return 0; }, 'POE::NFA::Postback'; $postback_parent_id{$postback} = $id; $POE::Kernel::poe_kernel->refcount_increment( $id, 'postback' ); # 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. # # TODO - Should callbacks hold reference counts like postbacks do? sub callback { my ($self, $event, @etc) = @_; my $id = $POE::Kernel::poe_kernel->ID_session_to_id($self); my $callback = sub { return $POE::Kernel::poe_kernel->call( $id, $event, [ @etc ], [ @_ ] ); }; $callback; } #============================================================================== # New methods. sub goto_state { my ($self, $new_state, $entry_event, @entry_args) = @_; if (defined $self->[SELF_CURRENT] && !$self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) { $POE::Kernel::poe_kernel->post( $self, NFA_EN_GOTO_STATE, $new_state, $entry_event, @entry_args ); } else { $POE::Kernel::poe_kernel->call( $self, NFA_EN_GOTO_STATE, $new_state, $entry_event, @entry_args ); } } sub stop { my $self = shift; $POE::Kernel::poe_kernel->post( $self, NFA_EN_STOP ); } sub call_state { my ($self, $return_event, $new_state, $entry_event, @entry_args) = @_; if ($self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) { $POE::Kernel::poe_kernel->call( $self, NFA_EN_PUSH_STATE, $return_event, $new_state, $entry_event, @entry_args ); } else { $POE::Kernel::poe_kernel->post( $self, NFA_EN_PUSH_STATE, $return_event, $new_state, $entry_event, @entry_args ); } } sub return_state { my ($self, @entry_args) = @_; if ($self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) { $POE::Kernel::poe_kernel->call( $self, NFA_EN_POP_STATE, @entry_args ); } else { $POE::Kernel::poe_kernel->post( $self, NFA_EN_POP_STATE, @entry_args ); } } 1; __END__ =head1 NAME POE::NFA - an event-driven state machine (nondeterministic finite automaton) =head1 SYNOPSIS use POE::Kernel; use POE::NFA; use POE::Wheel::ReadLine; # Spawn an NFA and enter its initial state. POE::NFA->spawn( inline_states => { initial => { setup => \&setup_stuff, }, state_login => { on_entry => \&login_prompt, on_input => \&save_login, }, state_password => { on_entry => \&password_prompt, on_input => \&check_password, }, state_cmd => { on_entry => \&command_prompt, on_input => \&handle_command, }, }, )->goto_state(initial => "setup"); POE::Kernel->run(); exit; sub setup_stuff { $_[RUNSTATE]{io} = POE::Wheel::ReadLine->new( InputEvent => 'on_input', ); $_[MACHINE]->goto_state(state_login => "on_entry"); } sub login_prompt { $_[RUNSTATE]{io}->get('Login: '); } sub save_login { $_[RUNSTATE]{login} = $_[ARG0]; $_[MACHINE]->goto_state(state_password => "on_entry"); } sub password_prompt { $_[RUNSTATE]{io}->get('Password: '); } sub check_password { if ($_[RUNSTATE]{login} eq $_[ARG0]) { $_[MACHINE]->goto_state(state_cmd => "on_entry"); } else { $_[MACHINE]->goto_state(state_login => "on_entry"); } } sub command_prompt { $_[RUNSTATE]{io}->get('Cmd: '); } sub handle_command { $_[RUNSTATE]{io}->put(" <<$_[ARG0]>>"); if ($_[ARG0] =~ /^(?:quit|stop|exit|halt|bye)$/i) { $_[RUNSTATE]{io}->put('Bye!'); $_[MACHINE]->stop(); } else { $_[MACHINE]->goto_state(state_cmd => "on_entry"); } } =head1 DESCRIPTION POE::NFA implements a different kind of POE session: A non-deterministic finite automaton. Let's break that down. A finite automaton is a state machine with a bounded number of states and transitions. Technically, POE::NFA objects may modify themselves at run time, so they aren't really "finite". Run-time modification isn't currently supported by the API, so plausible deniability is maintained! Deterministic state machines are ones where all possible transitions are known at compile time. POE::NFA is "non-deterministic" because transitions may change based on run-time conditions. But more simply, POE::NFA is like POE::Session but with banks of event handlers that may be swapped according to the session's run-time state. Consider the SYNOPSIS example, which has "on_entry" and "on_input" handlers that do different things depending on the run-time state. POE::Wheel::ReadLine throws "on_input", but different things happen depending whether the session is in its "login", "password" or "command" state. POE::NFA borrows heavily from POE::Session, so this document will only discuss the differences. Please see L for things which are similar. =head1 PUBLIC METHODS This document mainly focuses on the differences from POE::Session. =head2 get_current_state Each machine state has a name. get_current_state() returns the name of the machine's current state. get_current_state() is mainly used to retrieve the state of some other machine. It's easier (and faster) to use C<$_[STATE]> in a machine's own event handlers. =head2 get_runstate get_runstate() returns the machine's current runstate. Runstates are equivalent to POE::Session HEAPs, so this method does pretty much the same as POE::Session's get_heap(). It's easier (and faster) to use C<$_[RUNSTATE]> in a machine's own event handlers, however. =head2 spawn STATE_NAME => HANDLERS_HASHREF[, ...] spawn() is POE::NFA's constructor. The name reflects the idea that new state machines are spawned like threads or processes rather than instantiated like objects. The machine itself is defined as a list of state names and hashes that map events to handlers within each state. my %states = ( state_1 => { event_1 => \&handler_1, event_2 => \&handler_2, }, state_2 => { event_1 => \&handler_3, event_2 => \&handler_4, }, ); A single event may be handled by many states. The proper handler will be called depending on the machine's current state. For example, if C is dispatched while the machine is in C, then handler_3() will be called to handle the event. The state -> event -> handler map looks like this: $machine{state_2}{event_1} = \&handler_3; Instead of C, C or C may be used. These map the events of a state to an object or package method respectively. object_states => { state_1 => [ $object_1 => [qw(event_1 event_2)], ], state_2 => [ $object_2 => { event_1 => method_1, event_2 => method_2, } ] } In the example above, in the case of C coming in while the machine is in C, method C will be called on $object_1. If the machine is in C, method C will be called on $object_2. C is very similar, but instead of using an $object, you pass in a C The C parameter allows C to be initialized differently at instantiation time. C, like heaps, are usually anonymous hashrefs, but C may set them to be array references or even objects. State transitions are not necessarily executed immediately by default. Rather, they are placed in POEs event queue behind any currently pending events. Enabling the C option causes state transitions to occur immediately, regardless of any queued events. =head2 goto_state NEW_STATE[, ENTRY_EVENT[, EVENT_ARGS]] goto_state() puts the machine into a new state. If an ENTRY_EVENT is specified, then that event will be dispatched after the machine enters the new state. EVENT_ARGS, if included, will be passed to the entry event's handler via C. # Switch to the next state. $_[MACHINE]->goto_state( 'next_state' ); # Switch to the next state, and call a specific entry point. $_[MACHINE]->goto_state( 'next_state', 'entry_event' ); # Switch to the next state; call an entry point with some values. $_[MACHINE]->goto_state( 'next_state', 'entry_event', @parameters ); =head2 stop stop() forces a machine to stop. The machine will also stop gracefully if it runs out of things to do, just like POE::Session. stop() is heavy-handed. It will force resources to be cleaned up. However, circular references in the machine's C are not POE's responsibility and may cause memory leaks. $_[MACHINE]->stop(); =head2 call_state RETURN_EVENT, NEW_STATE[, ENTRY_EVENT[, EVENT_ARGS]] call_state() is similar to goto_state(), but it pushes the current state on a stack. At some later point, a handler can call return_state() to pop the call stack and return the machine to its old state. At that point, a C will be posted to notify the old state of the return. $machine->call_state( 'return_here', 'new_state', 'entry_event' ); As with goto_state(), C is the event that will be emitted once the machine enters its new state. C are parameters passed to the C handler via C. =head2 return_state [RETURN_ARGS] return_state() returns to the most recent state in which call_state() was invoked. If the preceding call_state() included a return event then its handler will be invoked along with some optional C. The C will be passed to the return handler via C. $_[MACHINE]->return_state( 'success', @success_values ); =head2 Methods that match POE::Session The following methods behave identically to the ones in POE::Session. =over 2 =item ID =item option =item postback =item callback =back =head2 About new() and create() POE::NFA's constructor is spawn(), not new() or create(). =head1 PREDEFINED EVENT FIELDS POE::NFA's predefined event fields are the same as POE::Session's with the following three exceptions. =head2 MACHINE C is equivalent to Session's C field. It holds a reference to the current state machine, and is useful for calling its methods. See POE::Session's C field for more information. $_[MACHINE]->goto_state( $next_state, $next_state_entry_event ); =head2 RUNSTATE C is equivalent to Session's C field. It holds an anonymous hash reference which POE is guaranteed not to touch. Data stored in C will persist between handler invocations. =head2 STATE C contains the name of the machine's current state. It is not equivalent to anything from POE::Session. =head2 EVENT C is equivalent to Session's C field. It holds the name of the event which invoked the current handler. See POE::Session's C field for more information. =head1 PREDEFINED EVENT NAMES POE::NFA defines four events of its own. These events are used internally and may not be overridden by application code. See POE::Session's "PREDEFINED EVENT NAMES" section for more information about other predefined events. The events are: C, C, C, C. Yes, all the internal events begin with "poe_nfa_". More may be forthcoming, but they will always begin the same way. Therefore please do not define events beginning with "poe_nfa_". =head1 SEE ALSO Many of POE::NFA's features are taken directly from POE::Session. Please see L for more information. The SEE ALSO section in L contains a table of contents covering the entire POE distribution. =head1 BUGS See POE::Session's documentation. POE::NFA is not as feature-complete as POE::Session. Your feedback is appreciated. =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.367/lib/POE/Pipe/000755 000765 000024 00000000000 12533606200 014352 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Pipe.pm000644 000765 000024 00000003324 12533605262 014721 0ustar00trocstaff000000 000000 # Deprecation notice: Read the documentation. package POE::Pipe; use warnings; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) use IO::Pipely; 1; __END__ =head1 NAME POE::Pipe - Deprecated and replaced with delegates to IO::Pipely. =head1 SYNOPSIS See L. =head1 DESCRIPTION On June 29, 2012, POE::Pipe and its subclasses, POE::Pipe::OneWay and POE::Pipe::TwoWay were released to CPAN as IO::Pipely. The POE::Pipe family of modules remained unchanged in POE's distribution. On August 18, 2013, POE::Pipe and its subclasses were gutted. Their implementations were replaced with delegates to IO::Pipely. All tests pass, although the delegates add slight overhead. The documentation was replaced by this deprecation schedule. A mandatory deprecation warning is scheduled to be released after September 2014. POE will begin using IO::Pipely directly. This documentation will be updated to schedule the next deprecation step. The mandatory warning will become a mandatory error a year or so later. Ideally this will occur in August 2015, but it may be delayed due to POE's release schedule. This documentation will be updated to schedule the final deprecation step. Finally, in August 2016 or later, POE::Pipe and its subclasses will be removed from POE's distribution altogether. Users will have had at least four years to update their code. That seems fair. =head1 SEE ALSO L =head1 AUTHOR & COPYRIGHT The POE::Pipe is copyright 2001-2013 by Rocco Caputo. All rights reserved. POE::Pipe is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.367/lib/POE/Queue/000755 000765 000024 00000000000 12533606200 014541 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Queue.pm000644 000765 000024 00000021635 12533605262 015115 0ustar00trocstaff000000 000000 package POE::Queue; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) use Carp qw(croak); sub new { my $type = shift; croak "$type is a virtual base class and not meant to be used directly"; } 1; __END__ =head1 NAME POE::Queue - a flexible, generic priority queue API =head1 SYNOPSIS POE::Queue specifies additional methods not illustrated here. #!perl use warnings; use strict; use POE::Queue::Array; my $pqa = POE::Queue::Array->new(); # Enqueue a few items. foreach my $priority (505, 404, 303, 202, 101) { $pqa->enqueue($priority, "payload $priority"); } # Dequeue until the queue is drained. while (1) { my ($priority, $queue_id, $payload) = $pqa->dequeue_next(); last unless defined $priority; print( "dequeued id($queue_id) ", "priority($priority) ", "payload($payload)\n", ); } Sample output: dequeued id(5) priority(101) payload(payload 101) dequeued id(4) priority(202) payload(payload 202) dequeued id(3) priority(303) payload(payload 303) dequeued id(2) priority(404) payload(payload 404) dequeued id(1) priority(505) payload(payload 505) =head1 DESCRIPTION Priority queues may be implemented a number of ways, but they tend to behave similar to lists that are kept in order by some kind of "priority". Enqueued items are stored such that the "next" item to be retrieved is the one with the highest priority. Subsequent fetches return the next lowest priority, and so on, until the queue is emptied. Priority queues (also known as priority heaps) attempt to do this while consuming the fewest resources. Go read about it! It's fascinating stuff! =head2 POE::Queue Items POE::Queue items consist of three fields: A priority, a unique ID assigned at enqueue time, and a payload. The priority and payload are specified by the caller, and the unique ID is generated by POE::Queue when an item is enqueued. POE::Queue imposes two limitations on priorities: Priorities must be numeric, and lower numbers indicate higher priorities. Aside from that, POE::Queue doesn't care what the numbers mean. Unique IDs are handles into the queue. POE::Queue generates and returns them as new items are enqueued. Some methods manipulate items, and they take IDs to identify the items to alter. Item payloads are arbitrary application data. POE::Queue does not examine or alter payloads itself. Any methods that need to examine payloads will accept a filter function. Filter functions examine payloads so POE::Queue need not. =head1 Public Methods POE::Queue is an API specification. Subclasses like L provide actual implementations. =head2 new Creates a new priority queue. Returns a reference to the queue. my $queue = POE::Queue::Array->new(); =head2 enqueue PRIORITY, PAYLOAD Enqueues a PAYLOAD, which can be just about anything that will fit into a Perl scalar, at a particular PRIORITY level. enqueue() returns a unique ID which can be used to manipulate the payload or its priority directly. Following the UNIX tradition, lower priority numbers indicate higher priorities. The payload with the lowest priority number will be dequeued first. If two payloads have the same PRIORITY, then they will be dequeued in the order in which they were enqueued. In this example, a queue is used to manage a number of alarms. The "next" alarm will be the one due soonest. my $payload_id = $queue->enqueue($alarm_time, [ "stuff" ]); =head2 dequeue_next Removes the next item from the queue, returning it as three fields: priority, ID and payload. The "next" item is the one with the lowest priority number. If multiple items exist with the same priority, dequeue_next() will return the one that was given the priority first. ITEM: while (1) { my ($priority, $id, $payload) = $queue->dequeue_next(); last ITEM unless defined $priority; ...; } =head2 get_next_priority Returns the priority of the item at the head of the queue. This is the lowest numeric priority in the queue. get_next_priority() can be useful for checking the queue to see if it's time to dequeue some items. In this case, the queue manages multiple alarms, and there's nothing to do if the next alarm isn't due yet. ALARM: while (1) { my $next_alarm_time = $queue->get_next_priority(); last ALARM unless defined $next_alarm_time; if ($next_alarm_time - time() > 0) { sleep($next_alarm_time - time()); } my ($priority, $id, $payload) = $queue->dequeue_next(); ...; } =head2 get_item_count Returns the number of items in the queue. It's another way to tell whether the queue has been fully drained. Here's an alternative version of the example for get_next_priority(). ALARM: while ($queue->get_item_count()) { my $next_alarm_time = $queue->get_next_priority(); if ($next_alarm_time - time() > 0) { sleep($next_alarm_time - time()); } my ($priority, $id, $payload) = $queue->dequeue_next(); ...; } =head2 remove_item ITEM_ID, FILTER_FUNCTION Removes a single item by its ID, but only if a FILTER_FUNCTION approves of the item's payload. If a payload is found with the given ITEM_ID, it is passed to FILTER_FUNCTION for examination. If FILTER_FUNCTION returns true, the item is removed from the queue and is returned as three fields. my ($priority, $id, $payload) = $queue->remove_item( $target_id, \&monkeys ); sub monkeys { my $payload = shift; $payload->{type} eq "monkey"; } The returned $priority will be undef on failure, and $! will be set to the reason why the item couldn't be removed. That will be ESRCH if the ITEM_ID was not found in the queue, or EPERM if the filter function returned false. =head2 remove_items FILTER_FUNCTION [, MAX_ITEM_COUNT ] Removes and returns items from the queue that match a FILTER_FUNCTION. remove_items() will return immediately if MAX_ITEM_COUNT items is specified and that many items have been removed from the queue. MAX_ITEM_COUNT is a bit of optimization if the application knows in advance how many items will match the FILTER_FUNCTION. Returns a list of items that were removed. Each item is an array reference containing a priority, item ID, and payload. Returns nothing if FILTER_FUNCTION matched nothing. # Remove up to 12 monkeys. my @monkeys = $queue->remove_items(\&monkeys, 12); foreach my $monkey (@monkeys) { my ($priority, $id, $payload) = @$monkey; print( "Removed monkey:\n", " priority = $priority\n", " queue id = $id\n", " payload = $payload\n", ); } There is no guarantee which items will be removed if MAX_ITEM_COUNT is specified too low. =head2 peek_items FILTER_FUNCTION [, MAX_ITEM_COUNT ] peek_items() returns up to MAX_ITEM_COUNT items that match a given FILTER_FUNCTION without removing them from the queue. my @entire_queue = $queue->peek_items(sub { 1 }); foreach my $item (@entire_queue) { my ($priority, $id, $payload) = @$item; print( "Item:\n", " priority = $priority\n", " queue id = $id\n", " payload = $payload\n", ); } =head2 adjust_priority ITEM_ID, FILTER_FUNCTION, DELTA Changes the priority of an item by DELTA. The item is identified by its ITEM_ID, and the change will only happen if the item's payload satisfies a FILTER_FUNCTION. Returns the new priority, which is the previous priority + DELTA. DELTA may be negative. my $new_priority = $queue->adjust_priority( $item_id, \&one_of_mine, 100 ); sub one_of_mine { my $payload = shift; return $payload->{owner} == $me; } Returns undef if the item's priority could not be adjusted, and sets $! to explain why: ESRCH means that the ITEM_ID could not be found, and EPERM means that the FILTER_FUNCTION was not satisfied. =head2 set_priority ITEM_ID, FILTER_FUNCTION, ABSOLUTE_PRIORITY Sets an item's priority to a new ABSOLUTE_PRIORITY. The item is identified by its ITEM_ID, and the change will only be allowed to happen if the item's payload satisfies a FILTER_FUNCTION. Returns the new priority, which should match ABSOLUTE_PRIORITY. Returns undef if the item's priority could not be set, and sets $! to explain why: ESRCH means that the ITEM_ID could not be found, and EPERM means that the FILTER_FUNCTION was not satisfied. my $new_priority = $queue->set_priority( $item_id, \&one_of_mine, time() + 60 ); unless (defined $new_priority) { die "one of our submarines is missing: $item_id" if $! == ESRCH; die "set_priority disallowed for item $item_id" if $! == EPERM; die $!; } sub one_of_mine { $_[0]{owner} == $me; } =head1 SEE ALSO L, L =head1 BUGS None known. =for comment TODO - Should set_priority return the old priority instead of the new one? =for comment TODO - Rename and repackage as its own distribution. =head1 AUTHORS & COPYRIGHTS Please see L for more information about authors, contributors, and POE's licensing. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.367/lib/POE/Resource/000755 000765 000024 00000000000 12533606200 015244 5ustar00trocstaff000000 000000 POE-1.367/lib/POE/Resource.pm000644 000765 000024 00000004321 12533605262 015611 0ustar00trocstaff000000 000000 package POE::Resource; use strict; use vars qw($VERSION); $VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) 1; __END__ =head1 NAME POE::Resource - internal resource managers for POE::Kernel =head1 SYNOPSIS Varies, although most POE::Resource subclasses do not have public APIs. =head1 DESCRIPTION POE manages several types of information internally. Its Resource classes are mix-ins designed to manage those types of information behind tidy, mostly private interfaces. This was done to facilitate testing and a conversion to C without the need to port POE::Kernel all at once. POE::Resource subclasses are generally different from one another, but there are some similarities to note. Every resource should have an initializer and finalizer method. Initializers set up initial data and link resources into POE::Kernel. Finalizers clean up any remaining data and verify that each resource subsystem was left in a consistent state. One common theme in resource implementations is that they don't need to perform much error checking, if any. Resource methods are used internally by POE::Kernel and/or POE::API classes, so it's up to them to ensure correct usage. Resource methods follow the naming convention _data_???_activity, where ??? is an abbreviation for the type of resource it belongs to: POE::Resource::Events _data_ev_initialize POE::Resource::FileHandles _data_handle_initialize POE::Resource::Signals _data_sig_initialize Finalizer methods end in "_finalize". _data_ev_finalize _data_handle_finalize _data_sig_finalize Finalizers return true if a resource shut down cleanly, or false if there were inconsistencies or leaks during end-of-run checking. The t/res/*.t tests rely on these return values. =head1 SEE ALSO L, L, L, L, L, L, L Also see L for public information about POE resources. =head1 BUGS None known. =head1 AUTHORS & LICENSING Please see L for more information about its authors, contributors, and licensing. =cut # rocco // vim: ts=2 sw=2 expandtab # TODO - Edit. POE-1.367/lib/POE/Resources.pm000644 000765 000024 00000004065 12533605262 016001 0ustar00trocstaff000000 000000 package POE::Resources; use strict; use vars qw($VERSION); $VERSION = '1.367'; # 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.367/lib/POE/Session.pm000644 000765 000024 00000155346 12533605262 015463 0ustar00trocstaff000000 000000 package POE::Session; use strict; use vars qw($VERSION); $VERSION = '1.367'; # 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