POE-Test-Loops-1.360000755000765000024 012425745722 13422 5ustar00trocstaff000000000000README100644000765000024 365712425745722 14376 0ustar00trocstaff000000000000POE-Test-Loops-1.360NAME POE::Test::Loops - Reusable tests for POE::Loop authors SYNOPSIS #!/usr/bin/perl -w use strict; use Getopt::Long; use POE::Test::Loops; my ($dir_base, $flag_help, @loop_modules, $flag_verbose); my $result = GetOptions( 'dirbase=s' => \$dir_base, 'loop=s' => \@loop_modules, 'verbose' => \$flag_verbose, 'help' => \$flag_help, ); if ( !$result or !$dir_base or $flag_help or !@loop_modules ) { die( "$0 usage:\n", " --dirbase DIR (required) base directory for tests\n", " --loop MODULE (required) loop modules to test\n", " --verbose show some extra output\n", " --help you're reading it\n", ); } POE::Test::Loops::generate($dir_base, \@loop_modules, $flag_verbose); exit 0; DESCRIPTION POE::Test::Loops contains one function, generate(), which will generate all the loop tests for one or more POE::Loop subclasses. The "SYNOPSIS" example is a version of poe-gen-tests, which is a stand-alone utility to generate the actual tests. poe-gen-tests also documents the POE::Test::Loops system in more detail. FUNCTIONS generate( $DIRBASE, \@LOOPS, $VERBOSE ) Generates the loop tests. DIRBASE is the (relative) directory in which a subdirectory for each of the LOOPS is created. If VERBOSE is set to a TRUE value some progress reporting is printed. POE::Test::Loops::generate( "./t", [ "POE::Loop::Yours" ], 1, ); SEE ALSO POE::Loop and poe-gen-tests. AUTHOR & COPYRIGHT See poe-gen-tests. CHANGES100644000765000024 1046412425745722 14523 0ustar00trocstaff000000000000POE-Test-Loops-1.360================================================== Changes from 2013-11-03 00:00:00 +0000 to present. ================================================== ------------------------------------------ version 1.360 at 2014-11-03 18:39:01 +0000 ------------------------------------------ Change: 321dbe7f3249bb5c82c83fbad8a9faf2b0319f22 Author: Rocco Caputo Date : 2014-11-03 11:51:29 +0000 Update dist.ini for relatively new plugi behaviors. Change: 88af7cb4cc1bd0cb92bcfd3d2e986264f2c040d7 Author: Rocco Caputo Date : 2014-10-30 12:38:45 +0000 Reflect a change in POE::Kernel->stop() behavior. ------------------------------------------ version 1.359 at 2014-07-27 07:07:53 +0000 ------------------------------------------ Change: e9ea00e6e02120b66577e68f1a969cb550eaf3ed Author: Rocco Caputo Date : 2014-07-27 03:07:53 +0000 Merge pull request #4 from Hugmeir/master Don't assume that /tmp exists, use File::Temp instead Change: b96cbffbbf9e418014bb049449989ccc9a53f505 Author: Brian Fraser Date : 2014-07-27 03:35:16 +0000 Don't assume that /tmp exists, use File::Temp instead Some unixy systems don't have /tmp (android, blackberry 10) which was causing tests in POE to fail. ------------------------------------------ version 1.358 at 2014-07-12 22:14:15 +0000 ------------------------------------------ Change: 9bb32997c9b77e5c3ae33229f3e8b0aae3ad5263 Author: Rocco Caputo Date : 2014-07-12 18:14:15 +0000 Take 3.5sec off each wheel_tail.pm test run. Change: 50ce8766b931274fcc11ee8da6f1353418f9fb91 Author: Rocco Caputo Date : 2014-07-12 17:36:11 +0000 Take about 1.5 sec off z_steinert_signal_integrity.pm. Most of these fixes are merely reducing timeouts once an expected condition is met. The long wait-for-failure timeout isn't as important once a test has passed, but turning off the timer entirely isn't good either. There could be spurious events that we don't want, and waiting a little extra time gives us some confidence they aren't happening. Change: d7fa569f98714c2a7df7904c034988961fb569ba Author: Rocco Caputo Date : 2014-07-12 17:28:57 +0000 Take about 2sec off each k_signals.pm test. Change: 28eb3a365918bf2d283450a2d9bcee7705740355 Author: Rocco Caputo Date : 2014-07-12 17:20:45 +0000 Take about 3sec off sig_child() tests. ------------------------------------------ version 1.357 at 2014-07-12 06:35:21 +0000 ------------------------------------------ Change: b38be9a86069bdb41244d40198bd30fa94c9cda0 Author: Rocco Caputo Date : 2014-07-12 02:35:21 +0000 Take about 2sec off each POE::Wheel::Accept test that runs. Change: dc33d14687a3c44e118e4ea702700b54a5e085e5 Author: Rocco Caputo Date : 2014-07-12 02:26:30 +0000 Take about 3sec off the UDP SocketFactory test. Change: 63153832441b24466c948c375ac3d5f4f7d46eb5 Author: Rocco Caputo Date : 2014-07-12 00:58:37 +0000 Reduce the time to test basic timers. ------------------------------------------ version 1.356 at 2014-07-12 02:41:59 +0000 ------------------------------------------ Change: a99ffee13fa9a7d149479f89b20855ec4f299e9d Author: Rocco Caputo Date : 2014-07-11 22:41:59 +0000 Reduce the time for another test from ~9sec to ~3.5sec. Change: 49b986fda759a77198fd9a315474797b6619b376 Author: Rocco Caputo Date : 2014-07-11 22:09:46 +0000 Reduce the ending timeout for wheel_tail.pm. ------------------------------------------ version 1.355 at 2014-07-08 04:36:33 +0000 ------------------------------------------ Change: abba8d0ecf3f47a70c4fc52c94b6affdd1f701d8 Author: Rocco Caputo Date : 2014-07-08 00:36:33 +0000 Resolve some CPAN and Dist::Zilla package recognition issues. Change: c2dbf198a3bebd4885cacf6911454282d20222d0 Author: Rocco Caputo Date : 2014-04-08 00:10:24 +0000 Switch a test from ok() to is() for more fail-time information. ================================================= Plus 29 releases after 2013-11-03 00:00:00 +0000. ================================================= LICENSE100644000765000024 4365512425745722 14545 0ustar00trocstaff000000000000POE-Test-Loops-1.360This software is copyright (c) 2014 by Rocco Caputo. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2014 by Rocco Caputo. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2014 by Rocco Caputo. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End dist.ini100644000765000024 144412425745722 15152 0ustar00trocstaff000000000000POE-Test-Loops-1.360name = POE-Test-Loops author = Rocco Caputo copyright_holder = Rocco Caputo [AutoMetaResources] bugtracker.rt = 1 ; Can't use AutoPrereqs here. ; These tests have a circular dependency with POE. [Prereqs] Test::More = 0.95 [CheckPrereqsIndexed] [Prereqs::MatchInstalled::All] exclude = bytes exclude = constant exclude = lib exclude = perl exclude = strict exclude = vars exclude = warnings [Homepage] [ReadmeFromPod] [ReadmeMarkdownFromPod] [ReportVersions] [Repository] git_remote = gh [Git::Check] [Git::NextVersion] first_version = 1.351 version_regexp = ^v(\d+\.\d+)$ [ChangelogFromGit] tag_regexp = v(\d+[_.]\d+) [Git::Tag] tag_format = v%v tag_message = Release %v. [@Filter] -bundle = @Classic -remove = PodVersion -remove = ExtraTests [MetaJSON] META.yml100644000765000024 120712425745722 14754 0ustar00trocstaff000000000000POE-Test-Loops-1.360--- abstract: 'Reusable tests for POE::Loop authors' author: - 'Rocco Caputo ' build_requires: {} configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 5.023, CPAN::Meta::Converter version 2.142690' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: POE-Test-Loops requires: Test::More: '1.001002' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=POE-Test-Loops homepage: http://search.cpan.org/dist/POE-Test-Loops/ repository: git://github.com/rcaputo/poe-test-loops.git version: '1.360' MANIFEST100644000765000024 312712425745722 14637 0ustar00trocstaff000000000000POE-Test-Loops-1.360# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.023. CHANGES LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL README README.mkdn bin/poe-gen-tests dist.ini lib/POE/Test/DondeEstan.pm lib/POE/Test/Loops.pm lib/POE/Test/Loops/00_info.pm lib/POE/Test/Loops/all_errors.pm lib/POE/Test/Loops/comp_tcp.pm lib/POE/Test/Loops/comp_tcp_concurrent.pm lib/POE/Test/Loops/connect_errors.pm lib/POE/Test/Loops/k_alarms.pm lib/POE/Test/Loops/k_aliases.pm lib/POE/Test/Loops/k_detach.pm lib/POE/Test/Loops/k_run_returns.pm lib/POE/Test/Loops/k_selects.pm lib/POE/Test/Loops/k_sig_child.pm lib/POE/Test/Loops/k_signals.pm lib/POE/Test/Loops/k_signals_rerun.pm lib/POE/Test/Loops/sbk_signal_init.pm lib/POE/Test/Loops/ses_nfa.pm lib/POE/Test/Loops/ses_session.pm lib/POE/Test/Loops/wheel_accept.pm lib/POE/Test/Loops/wheel_curses.pm lib/POE/Test/Loops/wheel_readline.pm lib/POE/Test/Loops/wheel_readwrite.pm lib/POE/Test/Loops/wheel_run.pm lib/POE/Test/Loops/wheel_run_size.pm lib/POE/Test/Loops/wheel_sf_ipv6.pm lib/POE/Test/Loops/wheel_sf_tcp.pm lib/POE/Test/Loops/wheel_sf_udp.pm lib/POE/Test/Loops/wheel_sf_unix.pm lib/POE/Test/Loops/wheel_tail.pm lib/POE/Test/Loops/z_kogman_sig_order.pm lib/POE/Test/Loops/z_leolo_wheel_run.pm lib/POE/Test/Loops/z_merijn_sigchld_system.pm lib/POE/Test/Loops/z_rt39872_sigchld.pm lib/POE/Test/Loops/z_rt39872_sigchld_stop.pm lib/POE/Test/Loops/z_rt53302_fh_watchers.pm lib/POE/Test/Loops/z_rt54319_bazerka_followtail.pm lib/POE/Test/Loops/z_steinert_signal_integrity.pm t/000-report-versions.t t/01_no_tests.t xt/release/pod-coverage.t xt/release/pod-syntax.t META.json100644000765000024 246212425745722 15130 0ustar00trocstaff000000000000POE-Test-Loops-1.360{ "abstract" : "Reusable tests for POE::Loop authors", "author" : [ "Rocco Caputo " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.023, CPAN::Meta::Converter version 2.142690", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "POE-Test-Loops", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Pod::Coverage::TrustPod" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08" } }, "runtime" : { "requires" : { "Test::More" : "1.001002" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-POE-Test-Loops@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=POE-Test-Loops" }, "homepage" : "http://search.cpan.org/dist/POE-Test-Loops/", "repository" : { "type" : "git", "url" : "git://github.com/rcaputo/poe-test-loops.git", "web" : "https://github.com/rcaputo/poe-test-loops" } }, "version" : "1.360" } README.mkdn100644000765000024 400112425745722 15306 0ustar00trocstaff000000000000POE-Test-Loops-1.360# NAME POE::Test::Loops - Reusable tests for POE::Loop authors # SYNOPSIS #!/usr/bin/perl -w use strict; use Getopt::Long; use POE::Test::Loops; my ($dir_base, $flag_help, @loop_modules, $flag_verbose); my $result = GetOptions( 'dirbase=s' => \$dir_base, 'loop=s' => \@loop_modules, 'verbose' => \$flag_verbose, 'help' => \$flag_help, ); if ( !$result or !$dir_base or $flag_help or !@loop_modules ) { die( "$0 usage:\n", " --dirbase DIR (required) base directory for tests\n", " --loop MODULE (required) loop modules to test\n", " --verbose show some extra output\n", " --help you're reading it\n", ); } POE::Test::Loops::generate($dir_base, \@loop_modules, $flag_verbose); exit 0; # DESCRIPTION POE::Test::Loops contains one function, generate(), which will generate all the loop tests for one or more POE::Loop subclasses. The ["SYNOPSIS"](#synopsis) example is a version of [poe-gen-tests](https://metacpan.org/pod/poe-gen-tests), which is a stand-alone utility to generate the actual tests. [poe-gen-tests](https://metacpan.org/pod/poe-gen-tests) also documents the POE::Test::Loops system in more detail. # FUNCTIONS ## generate( $DIRBASE, \\@LOOPS, $VERBOSE ) Generates the loop tests. DIRBASE is the (relative) directory in which a subdirectory for each of the LOOPS is created. If VERBOSE is set to a TRUE value some progress reporting is printed. POE::Test::Loops::generate( "./t", [ "POE::Loop::Yours" ], 1, ); # SEE ALSO [POE::Loop](https://metacpan.org/pod/POE::Loop) and [poe-gen-tests](https://metacpan.org/pod/poe-gen-tests). # AUTHOR & COPYRIGHT See [poe-gen-tests](https://metacpan.org/pod/poe-gen-tests). Makefile.PL100644000765000024 200612425745722 15453 0ustar00trocstaff000000000000POE-Test-Loops-1.360 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.023. use strict; use warnings; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Reusable tests for POE::Loop authors", "AUTHOR" => "Rocco Caputo ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "POE-Test-Loops", "EXE_FILES" => [ "bin/poe-gen-tests" ], "LICENSE" => "perl", "NAME" => "POE::Test::Loops", "PREREQ_PM" => { "Test::More" => "1.001002" }, "VERSION" => "1.360", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "ExtUtils::MakeMaker" => 0, "Test::More" => "1.001002" ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); MANIFEST.SKIP100644000765000024 35412425745722 15363 0ustar00trocstaff000000000000POE-Test-Loops-1.360CVS \.\# \.bak$ \.cvsignore \.git \.gz$ \.orig$ \.patch$ \.ppd$ \.rej$ \.rej$ \.svn \.swo$ \.swp$ ^Makefile$ ^Makefile\.old$ ^\. ^_Inline ^_build ^blib/ ^comptest ^cover_db ^coverage\.report$ ^pm_to_blib$ created_by_snerp_vortex.txt ~$ t000755000765000024 012425745722 13606 5ustar00trocstaff000000000000POE-Test-Loops-1.36001_no_tests.t100644000765000024 12112425745722 16243 0ustar00trocstaff000000000000POE-Test-Loops-1.360/tuse warnings; use strict; use Test::More tests => 1; use_ok("POE::Test::Loops"); bin000755000765000024 012425745722 14113 5ustar00trocstaff000000000000POE-Test-Loops-1.360poe-gen-tests100644000765000024 2676212425745722 16725 0ustar00trocstaff000000000000POE-Test-Loops-1.360/bin#!/usr/bin/perl -w use strict; use Getopt::Long; use POE::Test::Loops; my ($dir_base, $flag_help, @loop_modules, $flag_verbose); my $result = GetOptions( 'dirbase=s' => \$dir_base, 'loop=s' => \@loop_modules, 'verbose' => \$flag_verbose, 'help' => \$flag_help, ); if ( !$result or !$dir_base or $flag_help or !@loop_modules ) { die( "$0 usage:\n", " --dirbase DIR (required) base directory for tests\n", " --loop MODULE (required) loop modules to test\n", " --verbose show some extra output\n", " --help you're reading it\n", ); } POE::Test::Loops::generate($dir_base, \@loop_modules, $flag_verbose); exit 0; __END__ =head1 NAME poe-gen-tests - generate standard POE tests for third-party modules =head1 SYNOPSIS poe-gen-tests --dirbase t/loops \ --loop Glib \ --loop Kqueue \ --loop Event::Lib \ --loop POE::XS::Loop::Poll =head1 DESCRIPTION This program and the accompanying POE::Test::Loop::* modules make up POE's tests for POE::Loop subclasses. These tests are designed to run identically regardless of the current event loop. POE uses them to test the event loops it bundles: POE::Loop::Gtk POE::Loop::IO_Poll (--loop IO::Poll) POE::Loop::Tk POE::Loop::Event POE::Loop::Select Developers of other POE::Loop modules are encouraged use this package to generate over 420 comprehensive tests for their own work. =head1 USAGE poe-gen-tests creates test files for one or more event loops beneath the directory specified in --dirbase. For example, poe-gen-tests --dirbase t/loops --loop Select generates the following test files: t/loops/select/all_errors.t t/loops/select/comp_tcp.t t/loops/select/comp_tcp_concurrent.t t/loops/select/connect_errors.t t/loops/select/k_alarms.t t/loops/select/k_aliases.t t/loops/select/k_detach.t t/loops/select/k_selects.t t/loops/select/k_sig_child.t t/loops/select/k_signals.t t/loops/select/k_signals_rerun.t t/loops/select/sbk_signal_init.t t/loops/select/ses_nfa.t t/loops/select/ses_session.t t/loops/select/wheel_accept.t t/loops/select/wheel_curses.t t/loops/select/wheel_readline.t t/loops/select/wheel_readwrite.t t/loops/select/wheel_run.t t/loops/select/wheel_sf_ipv6.t t/loops/select/wheel_sf_tcp.t t/loops/select/wheel_sf_udp.t t/loops/select/wheel_sf_unix.t t/loops/select/wheel_tail.t The --loop parameter is either a POE::Loop::... class name or the event loop class that will complete the POE::Loop::... package name. poe-gen-tests --dirbase t/loops --loop Event::Lib poe-gen-tests --dirbase t/loops --loop POE::Loop::Event_Lib poe-gen-tests looks for a "=for poe_tests" or "=begin poe_tests" section within the POE::Loop class being tested. If defined, this section should include a single function, skip_tests(), that determines whether any given test should be skipped. Please see L for syntax for "=for" and "=begin". Also see L for notable differences between POE::Test::Loop's POD support and the standard. skip_tests() is called with one parameter, the base name of the test about to be executed. It returns false if the test should run, or a message that will be displayed to the user explaining why the test will be skipped. This message is passed directly to Test::More's plan() along with "skip_all". The logic is essentially: if (my $why = skip_tests("k_signals_rerun")) { plan skip_all => $why; } skip_tests() should load any modules required by the event loop. See most of the examples below. =head2 Example poe_tests Directives POE::Loop::Event checks whether the Event module exists and can be loaded, then whether specific tests can run under specific operating systems. =for poe_tests sub skip_tests { return "Event tests require the Event module" if ( do { eval "use Event"; $@ } ); my $test_name = shift; if ($test_name eq "k_signals_rerun" and $^O eq "MSWin32") { return "This test crashes Perl when run with Tk on $^O"; } if ($test_name eq "wheel_readline" and $^O eq "darwin") { return "Event skips two of its own tests for the same reason"; } } POE::Loop::Gtk checks whether DISPLAY is set, which implies that X is running. It then checks whether Gtk is available, loadable, and safely initializable before skipping specific tests. =for poe_tests sub skip_tests { my $test_name = shift; return "Gtk needs a DISPLAY (set one today, okay?)" unless ( defined $ENV{DISPLAY} and length $ENV{DISPLAY} ); return "Gtk tests require the Gtk module" if do { eval "use Gtk"; $@ }; return "Gtk init failed. Is DISPLAY valid?" unless defined Gtk->init_check; if ($test_name eq "z_rt39872_sigchld_stop") { return "Gdk crashes"; } return; } POE::Loop::IO_Poll checks for system compatibility before verifying that IO::Poll is available and loadable. =for poe_tests sub skip_tests { return "IO::Poll is not 100% compatible with $^O" if $^O eq "MSWin32"; return "IO::Poll tests require the IO::Poll module" if ( do { eval "use IO::Poll"; $@ } ); } POE::Loop::Select has no specific requirements. =for poe_tests sub skip_tests { return } POE::Loop::Tk needs an X display (except on Windows). Tk is not safe for fork(), so skip tests that require forking. And finally, check whether the Tk module is available, loadable, and runnable. =for poe_tests sub skip_tests { return "Tk needs a DISPLAY (set one today, okay?)" unless ( (defined $ENV{DISPLAY} and length $ENV{DISPLAY}) or $^O eq "MSWin32" ); my $test_name = shift; if ($test_name eq "k_signals_rerun" and $^O eq "MSWin32") { return "This test crashes Perl when run with Tk on $^O"; } return "Tk tests require the Tk module" if do { eval "use Tk"; $@ }; my $m = eval { Tk::MainWindow->new() }; if ($@) { my $why = $@; $why =~ s/ at .*//; return "Tk couldn't be initialized: $why"; } return; } =head1 INSTALL SCRIPT INTEGRATION The POE::Loop tests started out as part of the POE distribution. All the recommendations and examples that follow are written and tested against ExtUtils::MakeMaker because that's what POE uses. Please adjust these recipes according to your taste and preference. =head2 Calling the Test Generator Tests need to be generated prior to the user or CPAN shell running "make test". A tidy way to do this might be to create a new Makefile target and include that as a dependency for "make test". POE takes a simpler approach, calling the script from its Makefile.PL: system( $^X, "poe-gen-tests", "--dirbase", "t/30_loops", "--loop", "Event", "--loop", "Gtk", "--loop", "IO::Poll", "--loop", "Select", "--loop", "Tk", ) and die $!; The previous approach generates tests at install time, so it's not necessary to include the generated files in the MANIFEST. Test directories should also be excluded from the MANIFEST. poe-gen-tests will create the necessary paths. It's also possible to generate the tests prior to "make dist". The distribution's MANIFEST must include the generated files in this case. Most people will not need to add the generated tests to their repositories. =head1 Running the Tests By default, ExtUtils::MakeMaker generates Makefiles that only run tests matching t/*.t. However authors are allowed to specify other test locations. Add the following parameter to WriteMakefile() so that the tests generated above will be executed: tests => { TESTS => "t/*.t t/30_loops/*/*.t", } =head1 CLEANING UP Makefiles will not clean up files that aren't present in the MANIFEST. This includes tests generated at install time. If this bothers you, you'll need to add directives to include the generated tests in the "clean" and "distclean" targets. clean => { FILES => "t/30_loops/*/* t/30_loops/*", } This assumes the "t/30_loops" directory contains only generated tests. It's recommended that generated and hand-coded tests not coexist in the same directory. It seems like a good idea to delete the deeper directories and files before their parents. =head1 Skipping Network Tests Some generated tests require a network to be present and accessible. Those tests will be skipped unless the file "run_network_tests" is present in the main distribution directory. You can include that file in your distribution's tarball, but it's better create it at install time after asking the user. Here's how POE does it. Naturally you're free to do it some other way. # Switch to default behavior if STDIN isn't a tty. unless (-t STDIN) { warn( "\n", "=============================================\n\n", "STDIN is not a terminal. Assuming --default.\n\n", "=============================================\n\n", ); push @ARGV, "--default"; } # Remind the user she can use --default. unless (grep /^--default$/, @ARGV) { warn( "\n", "================================================\n\n", "Prompts may be bypassed with the --default flag.\n\n", "================================================\n\n", ); } # Should we run the network tests? my $prompt = ( "Some of POE's tests require a functional network.\n" . "You can skip these tests if you'd like.\n\n" . "Would you like to skip the network tests?" ); my $ret = "n"; if (grep /^--default$/, @ARGV) { print $prompt, " [$ret] $ret\n\n"; } else { $ret = prompt($prompt, "n"); } my $marker = 'run_network_tests'; unlink $marker; unless ($ret =~ /^Y$/i) { open(TOUCH,"+>$marker") and close TOUCH; } print "\n"; =head1 Skipping Other Tests POE's loop tests will enable or disable tests based on the event loop's capabilities. Distributions and event loops may set these variables to signal which tests are okay to run. =head2 POE_LOOP_USES_POLL Some platforms do not support poll() on certain kinds of filehandles. Event loops that use poll() should set this environment variable to a true value. It will cause the tests to skip this troublesome combination. =head2 PODDITIES Previous versions of POE::Test::Loops documented "=for poe_tests" sections terminated by =cut and containing blank lines. This is incorrect POD syntax, and it's the reason the skip_tests() functions showed up in perldoc and on search.cpan.org. The following syntax is wrong and should not have been used. I'm so sorry. =for poe_tests sub skip_tests { ... } =cut The proper syntax is to terminate "=for poe_tests" with a blank line: =for poe_tests sub skip_tests { ... } Multi-line tests containing blank lines can be specified using POD's "=begin poe_tests" terminated by "=end poe_tests". =begin poe_tests sub skip_tests { ... } =end poe_tests All three syntaxes above are supported as of POE::Test::Loops version 1.034. The incorrect =for syntax is deprecated and will be removed in some future release. =head1 SEE ALSO L, L, L. =head2 BUG TRACKER https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=POE-Test-Loops =head2 REPOSITORY https://poe.svn.sourceforge.net/svnroot/poe/trunk/poe-test-loops =head2 OTHER RESOURCES http://search.cpan.org/dist/POE-Test-Loops/ =head1 AUTHOR & COPYRIGHT Rocco Caputo . Benjamin Smith . Countless other people. These tests are Copyright 1998-2013 by Rocco Caputo, Benjamin Smith, and countless contributors. All rights are reserved. These tests are free software; you may redistribute them and/or modify them under the same terms as Perl itself. Thanks to Martijn van Beers for beta testing and suggestions. =cut Test000755000765000024 012425745722 15453 5ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POELoops.pm100644000765000024 1630012425745722 17265 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test# vim: ts=2 sw=2 expandtab package POE::Test::Loops; $POE::Test::Loops::VERSION = '1.360'; use warnings; use strict; use File::Spec; use File::Path; use File::Find; use constant TEST_BLOCK_FOR_WHICH => 0x01; use constant TEST_BLOCK_FOR_WRONG => 0x02; use constant TEST_BLOCK_FOR_RIGHT => 0x04; use constant TEST_BLOCK_BEGIN => 0x08; ### Find the test libraries. use lib qw(./lib ../lib); use POE::Test::DondeEstan; my $source_base = POE::Test::DondeEstan->marco(); ### Generate loop tests. sub generate { my ($dir_base, $loops, $flag_verbose) = @_; foreach my $loop (@$loops) { my $loop_dir = lc($loop); $loop_dir =~ s/::/_/g; my $fqmn = _find_event_loop_file($loop); unless ($fqmn) { $flag_verbose and print "Couldn't find a loop for $loop ...\n"; next; } $flag_verbose and print "Found $fqmn\n"; my $loop_cfg = _get_loop_cfg($fqmn); unless (defined $loop_cfg and length $loop_cfg) { $loop_cfg = ( "sub skip_tests { return }" ); } my $source = ( "#!/usr/bin/perl -w\n" . "\n" . "use strict;\n" . "\n" . "use lib qw(--base_lib--);\n" . "use Test::More;\n" . "use POSIX qw(_exit);\n" . "\n" . "--loop_cfg--\n" . "\n" . "BEGIN {\n" . " if (my \$why = skip_tests('--test_name--')) {\n" . " plan skip_all => \$why\n" . " }\n" . "}\n" . "\n" . "# Run the tests themselves.\n" . "require '--base_file--';\n" . "\n" . "_exit 0 if \$^O eq 'MSWin32';\n" . "CORE::exit 0;\n" ); # Full directory where source files are found. my $dir_src = File::Spec->catfile($source_base, "Loops"); my $dir_dst = File::Spec->catfile($dir_base, $loop_dir); # Gather the list of source files. # Each will be used to generate a real test file. opendir BASE, $dir_src or die $!; my @base_files = grep /\.pm$/, readdir(BASE); closedir BASE; # Initialize the destination directory. Clear or create as needed. $dir_dst =~ tr[/][/]s; $dir_dst =~ s{/+$}{}; rmtree($dir_dst); mkpath($dir_dst, 0, 0755); # For each source file, generate a corresponding one in the # configured destination directory. Expand various bits to # customize the test. foreach my $base_file (@base_files) { my $test_name = $base_file; $test_name =~ s/\.pm$//; my $full_file = File::Spec->catfile($dir_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 = $source; $expanded_src =~ s/--base_file--/$base_file/g; $expanded_src =~ s/--base_lib--/$dir_src/g; $expanded_src =~ s/--loop_cfg--/$loop_cfg/g; $expanded_src =~ s/--test_name--/$test_name/g; # Write with lots of error checking. open EXPANDED, ">$full_file" or die $!; print EXPANDED $expanded_src; close EXPANDED or die $!; } } } sub _find_event_loop_file { my $loop_name = shift; my $loop_module; if ($loop_name =~ /^POE::/) { $loop_module = File::Spec->catfile(split(/::/, $loop_name)) . ".pm"; } else { $loop_name =~ s/::/_/g; $loop_module = File::Spec->catfile("POE", "Loop", $loop_name) . ".pm"; } foreach my $inc (@INC) { my $fqmn = File::Spec->catfile($inc, $loop_module); next unless -f $fqmn; return $fqmn; } return; } sub _get_loop_cfg { my $fqmn = shift; my ($in_test_block, @test_source); open SOURCE, "<$fqmn" or die $!; while () { # Not in a test block. unless ($in_test_block) { # Proper =for syntax. if (/^=for\s+poe_tests\s+(\S.*?)$/) { push @test_source, $1; $in_test_block = TEST_BLOCK_FOR_RIGHT; next; } # Not sure which =for syntax is in use. if (/^=for\s+poe_tests\s*$/) { $in_test_block = TEST_BLOCK_FOR_WHICH; next; } if (/^=begin\s+(poe_tests)\s*$/) { $in_test_block = TEST_BLOCK_BEGIN; next; } # Some random line. Do nothing. next; } # Which test block format are we in? if ($in_test_block & TEST_BLOCK_FOR_WHICH) { # If the following line is blank, then we're probably in the # wrong, multi-line kind originally documented and now # deprecated. if (/^\s*$/) { $in_test_block = TEST_BLOCK_FOR_WRONG; next; } # The following line is not blank, so it appears we're in a # properly formatted =for paragraph. $in_test_block = TEST_BLOCK_FOR_RIGHT; push @test_source, $_; next; } # The =begin syntax ends with an =end. if ($in_test_block & TEST_BLOCK_BEGIN) { if (/^=end\s*poe_tests\s*$/) { $in_test_block = 0; next; } # Be helpful? die "=cut not the proper way to end =begin poe_tests" if /^=cut\s*$/; push @test_source, $_; next; } # The proper =for syntax ends on a blank line. if ($in_test_block & TEST_BLOCK_FOR_RIGHT) { if (/^$/) { $in_test_block = 0; next; } # Be helpful? die "=cut not the proper way to end =for poe_tests" if /^=cut\s*$/; push @test_source, $_; next; } # The wrong =for syntax ends on =cut. if ($in_test_block & TEST_BLOCK_FOR_WRONG) { if (/^=cut\s*$/) { $in_test_block = 0; next; } # Be helpful? die "=end not the proper way to end =for poe_tests" if /^=end/; push @test_source, $_; next; } die "parser in unknown state: $in_test_block"; } shift @test_source while @test_source and $test_source[0] =~ /^\s*$/; pop @test_source while @test_source and $test_source[-1] =~ /^\s*$/; return join "", @test_source; } 1; __END__ =head1 NAME POE::Test::Loops - Reusable tests for POE::Loop authors =head1 SYNOPSIS #!/usr/bin/perl -w use strict; use Getopt::Long; use POE::Test::Loops; my ($dir_base, $flag_help, @loop_modules, $flag_verbose); my $result = GetOptions( 'dirbase=s' => \$dir_base, 'loop=s' => \@loop_modules, 'verbose' => \$flag_verbose, 'help' => \$flag_help, ); if ( !$result or !$dir_base or $flag_help or !@loop_modules ) { die( "$0 usage:\n", " --dirbase DIR (required) base directory for tests\n", " --loop MODULE (required) loop modules to test\n", " --verbose show some extra output\n", " --help you're reading it\n", ); } POE::Test::Loops::generate($dir_base, \@loop_modules, $flag_verbose); exit 0; =head1 DESCRIPTION POE::Test::Loops contains one function, generate(), which will generate all the loop tests for one or more POE::Loop subclasses. The L example is a version of L, which is a stand-alone utility to generate the actual tests. L also documents the POE::Test::Loops system in more detail. =head1 FUNCTIONS =head2 generate( $DIRBASE, \@LOOPS, $VERBOSE ) Generates the loop tests. DIRBASE is the (relative) directory in which a subdirectory for each of the LOOPS is created. If VERBOSE is set to a TRUE value some progress reporting is printed. POE::Test::Loops::generate( "./t", [ "POE::Loop::Yours" ], 1, ); =head1 SEE ALSO L and L. =head1 AUTHOR & COPYRIGHT See L. =cut 000-report-versions.t100644000765000024 3127012425745722 17634 0ustar00trocstaff000000000000POE-Test-Loops-1.360/t#!perl use warnings; use strict; use Test::More 0.94; # Include a cut-down version of YAML::Tiny so we don't introduce unnecessary # dependencies ourselves. package Local::YAML::Tiny; use strict; use Carp 'croak'; # UTF Support? sub HAVE_UTF8 () { $] >= 5.007003 } BEGIN { if ( HAVE_UTF8 ) { # The string eval helps hide this from Test::MinimumVersion eval "require utf8;"; die "Failed to load UTF-8 support" if $@; } # Class structure require 5.004; $YAML::Tiny::VERSION = '1.40'; # Error storage $YAML::Tiny::errstr = ''; } # Printable characters for escapes my %UNESCAPES = ( z => "\x00", a => "\x07", t => "\x09", n => "\x0a", v => "\x0b", f => "\x0c", r => "\x0d", e => "\x1b", '\\' => '\\', ); ##################################################################### # Implementation # Create an empty YAML::Tiny object sub new { my $class = shift; bless [ @_ ], $class; } # Create an object from a file sub read { my $class = ref $_[0] ? ref shift : shift; # Check the file my $file = shift or return $class->_error( 'You did not specify a file name' ); return $class->_error( "File '$file' does not exist" ) unless -e $file; return $class->_error( "'$file' is a directory, not a file" ) unless -f _; return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; # Slurp in the file local $/ = undef; local *CFG; unless ( open(CFG, $file) ) { return $class->_error("Failed to open file '$file': $!"); } my $contents = ; unless ( close(CFG) ) { return $class->_error("Failed to close file '$file': $!"); } $class->read_string( $contents ); } # Create an object from a string sub read_string { my $class = ref $_[0] ? ref shift : shift; my $self = bless [], $class; my $string = $_[0]; unless ( defined $string ) { return $self->_error("Did not provide a string to load"); } # Byte order marks # NOTE: Keeping this here to educate maintainers # my %BOM = ( # "\357\273\277" => 'UTF-8', # "\376\377" => 'UTF-16BE', # "\377\376" => 'UTF-16LE', # "\377\376\0\0" => 'UTF-32LE' # "\0\0\376\377" => 'UTF-32BE', # ); if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { return $self->_error("Stream has a non UTF-8 BOM"); } else { # Strip UTF-8 bom if found, we'll just ignore it $string =~ s/^\357\273\277//; } # Try to decode as utf8 utf8::decode($string) if HAVE_UTF8; # Check for some special cases return $self unless length $string; unless ( $string =~ /[\012\015]+\z/ ) { return $self->_error("Stream does not end with newline character"); } # Split the file into lines my @lines = grep { ! /^\s*(?:\#.*)?\z/ } split /(?:\015{1,2}\012|\015|\012)/, $string; # Strip the initial YAML header @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; # A nibbling parser while ( @lines ) { # Do we have a document header? if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { # Handle scalar documents shift @lines; if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { push @$self, $self->_read_scalar( "$1", [ undef ], \@lines ); next; } } if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { # A naked document push @$self, undef; while ( @lines and $lines[0] !~ /^---/ ) { shift @lines; } } elsif ( $lines[0] =~ /^\s*\-/ ) { # An array at the root my $document = [ ]; push @$self, $document; $self->_read_array( $document, [ 0 ], \@lines ); } elsif ( $lines[0] =~ /^(\s*)\S/ ) { # A hash at the root my $document = { }; push @$self, $document; $self->_read_hash( $document, [ length($1) ], \@lines ); } else { croak("YAML::Tiny failed to classify the line '$lines[0]'"); } } $self; } # Deparse a scalar string to the actual scalar sub _read_scalar { my ($self, $string, $indent, $lines) = @_; # Trim trailing whitespace $string =~ s/\s*\z//; # Explitic null/undef return undef if $string eq '~'; # Quotes if ( $string =~ /^\'(.*?)\'\z/ ) { return '' unless defined $1; $string = $1; $string =~ s/\'\'/\'/g; return $string; } if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { # Reusing the variable is a little ugly, # but avoids a new variable and a string copy. $string = $1; $string =~ s/\\"/"/g; $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; return $string; } # Special cases if ( $string =~ /^[\'\"!&]/ ) { croak("YAML::Tiny does not support a feature in line '$lines->[0]'"); } return {} if $string eq '{}'; return [] if $string eq '[]'; # Regular unquoted string return $string unless $string =~ /^[>|]/; # Error croak("YAML::Tiny failed to find multi-line scalar content") unless @$lines; # Check the indent depth $lines->[0] =~ /^(\s*)/; $indent->[-1] = length("$1"); if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { croak("YAML::Tiny found bad indenting in line '$lines->[0]'"); } # Pull the lines my @multiline = (); while ( @$lines ) { $lines->[0] =~ /^(\s*)/; last unless length($1) >= $indent->[-1]; push @multiline, substr(shift(@$lines), length($1)); } my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; return join( $j, @multiline ) . $t; } # Parse an array sub _read_array { my ($self, $array, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { croak("YAML::Tiny found bad indenting in line '$lines->[0]'"); } if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { # Inline nested hash my $indent2 = length("$1"); $lines->[0] =~ s/-/ /; push @$array, { }; $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { # Array entry with a value shift @$lines; push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { shift @$lines; unless ( @$lines ) { push @$array, undef; return 1; } if ( $lines->[0] =~ /^(\s*)\-/ ) { my $indent2 = length("$1"); if ( $indent->[-1] == $indent2 ) { # Null array entry push @$array, undef; } else { # Naked indenter push @$array, [ ]; $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines ); } } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { push @$array, { }; $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); } else { croak("YAML::Tiny failed to classify line '$lines->[0]'"); } } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { # This is probably a structure like the following... # --- # foo: # - list # bar: value # # ... so lets return and let the hash parser handle it return 1; } else { croak("YAML::Tiny failed to classify line '$lines->[0]'"); } } return 1; } # Parse an array sub _read_hash { my ($self, $hash, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { croak("YAML::Tiny found bad indenting in line '$lines->[0]'"); } # Get the key unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) { if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { croak("YAML::Tiny does not support a feature in line '$lines->[0]'"); } croak("YAML::Tiny failed to classify line '$lines->[0]'"); } my $key = $1; # Do we have a value? if ( length $lines->[0] ) { # Yes $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines ); } else { # An indent shift @$lines; unless ( @$lines ) { $hash->{$key} = undef; return 1; } if ( $lines->[0] =~ /^(\s*)-/ ) { $hash->{$key} = []; $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines ); } elsif ( $lines->[0] =~ /^(\s*)./ ) { my $indent2 = length("$1"); if ( $indent->[-1] >= $indent2 ) { # Null hash entry $hash->{$key} = undef; } else { $hash->{$key} = {}; $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); } } } } return 1; } # Set error sub _error { $YAML::Tiny::errstr = $_[1]; undef; } # Retrieve error sub errstr { $YAML::Tiny::errstr; } ##################################################################### # Use Scalar::Util if possible, otherwise emulate it BEGIN { eval { require Scalar::Util; }; if ( $@ ) { # Failed to load Scalar::Util eval <<'END_PERL'; sub refaddr { my $pkg = ref($_[0]) or return undef; if (!!UNIVERSAL::can($_[0], 'can')) { bless $_[0], 'Scalar::Util::Fake'; } else { $pkg = undef; } "$_[0]" =~ /0x(\w+)/; my $i = do { local $^W; hex $1 }; bless $_[0], $pkg if defined $pkg; $i; } END_PERL } else { Scalar::Util->import('refaddr'); } } ##################################################################### # main test ##################################################################### package main; BEGIN { # Skip modules that either don't want to be loaded directly, such as # Module::Install, or that mess with the test count, such as the Test::* # modules listed here. # # Moose::Role conflicts if Moose is loaded as well, but Moose::Role is in # the Moose distribution and it's certain that someone who uses # Moose::Role also uses Moose somewhere, so if we disallow Moose::Role, # we'll still get the relevant version number. my %skip = map { $_ => 1 } qw( App::FatPacker Class::Accessor::Classy Devel::Cover Module::Install Moose::Role POE::Loop::Tk Template::Test Test::Kwalitee Test::Pod::Coverage Test::Portability::Files Test::YAML::Meta open ); my $Test = Test::Builder->new; $Test->plan(skip_all => "META.yml could not be found") unless -f 'META.yml' and -r _; my $meta = (Local::YAML::Tiny->read('META.yml'))->[0]; my %requires; for my $require_key (grep { /requires/ } keys %$meta) { my %h = %{ $meta->{$require_key} }; $requires{$_}++ for keys %h; } delete $requires{perl}; diag("Testing with Perl $], $^X"); for my $module (sort keys %requires) { if ($skip{$module}) { note "$module doesn't want to be loaded directly, skipping"; next; } local $SIG{__WARN__} = sub { note "$module: $_[0]" }; require_ok $module or BAIL_OUT("can't load $module"); my $version = $module->VERSION; $version = 'undefined' unless defined $version; diag(" $module version is $version"); } done_testing; } release000755000765000024 012425745722 15416 5ustar00trocstaff000000000000POE-Test-Loops-1.360/xtpod-syntax.t100644000765000024 22012425745722 20023 0ustar00trocstaff000000000000POE-Test-Loops-1.360/xt/release#!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use Test::More; use Test::Pod 1.41; all_pod_files_ok(); pod-coverage.t100644000765000024 33412425745722 20276 0ustar00trocstaff000000000000POE-Test-Loops-1.360/xt/release#!perl # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); DondeEstan.pm100644000765000024 51412425745722 20155 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Testpackage POE::Test::DondeEstan; $POE::Test::DondeEstan::VERSION = '1.360'; use warnings; use strict; use File::Spec; # It's a pun on Marco Polo, the swimming game, and Marco A. Manzo, # this cool dude I know. Hi, Marco! sub marco { my @aqui = File::Spec->splitdir(__FILE__); pop @aqui; return File::Spec->catdir(@aqui); } 1; Loops000755000765000024 012425745722 16547 5ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test00_info.pm100644000765000024 142712425745722 20503 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # This test simply dumps some debug info to the console use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { eval "sub POE::Kernel::TRACE_DEFAULT () { 1 }" if ( exists $INC{'Devel/Cover.pm'} ); } use Test::More; plan tests => 2; use_ok( "POE" ); use_ok( "POE::Test::Loops" ); # idea from Test::Harness, thanks! diag( "Testing POE $POE::VERSION, ", "POE::Test::Loops $POE::Test::Loops::VERSION, ", "Using Loop(", $POE::Kernel::poe_kernel->poe_kernel_loop(), "), Perl $], ", "$^X on $^O" ); # TODO <@dngor> If it can glean the loop from the test generator, it could compare them to make sure they match. # This would require parsing the "=for poe_tests" block and trying to extract the loop out of it... 1; ses_nfa.pm100644000765000024 2125612425745722 20711 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests NFA sessions. 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; use POE qw(NFA); my $NEW_POE; BEGIN { # fixes Argument "1.294_272" isn't numeric in numeric le my $poe_ver = eval("\$POE::VER" . "SION"); # Pesky CPAN indexer. $poe_ver = $1 if $poe_ver =~ /^(?:[^_]+)\_/; if ($poe_ver <= 1.003) { $NEW_POE = 0; plan tests => 28; } else { $NEW_POE = 1; plan tests => 39; } } ### Plain NFA. This simulates a pushbutton that toggles a light. ### This goes in its own package because POE::Session and POE::NFA ### export conflicting constants. package Switch; use POE::NFA; sub new { my $class = shift; return bless {}, $class; } sub _default { 0; } sub off_enter { Test::More::is($_[OBJECT], 'Switch', '$_[OBJECT] is a package') if ($NEW_POE); $_[KERNEL]->post( $_[ARG0] => visibility => 0 ); } sub off_pushed { $_[MACHINE]->goto_state( on => enter => $_[SENDER] ); } sub enter { Test::More::isa_ok($_[OBJECT], 'Switch', '$_[OBJECT]') if ($NEW_POE); $_[KERNEL]->post( $_[ARG0] => visibility => 1 ); } sub pushed { $_[MACHINE]->goto_state( off => enter => $_[SENDER] ); } my $self = Switch->new; my $args = { inline_states => { # The initial state, and its start event. Make the switch # visible by name, and start in the 'off' state. initial => { start => sub { Test::More::is($_[OBJECT], undef, 'no object') if ($NEW_POE); $_[KERNEL]->alias_set( 'switch' ); $_[MACHINE]->goto_state( 'off' ); }, _default => \&_default, }, }, }; if ($NEW_POE) { $args->{package_states} = { off => [ Switch => { enter => 'off_enter', pushed => 'off_pushed', _default => '_default', }, ], }; $args->{object_states} = { # The light is on. When this state is entered, post a visibility # event at whatever had caused the light to go on. When it's # pushed, have the light go off. on => [ $self => [qw(enter pushed _default)], ], }, } else { $args->{inline_states}->{off} = { enter => \&off_enter, pushed => \&off_pushed, _default => \&_default, }; $args->{inline_states}->{on} = { enter => \&enter, pushed => \&pushed, _default => \&_default, }; } POE::NFA->spawn(%$args) ->goto_state( initial => 'start' ); # enter the initial state ### This NFA uses the stop() method. Gabriel Kihlman discovered that ### POE::NFA lags behind POE::Kernel after 0.24, and stop() wasn't ### fixed to use the new _data_ses_free() method of POE::Kernel. POE::NFA->spawn( inline_states => { initial => { start => sub { $_[MACHINE]->stop() } } } )->goto_state(initial => 'start'); ### A plain session to interact with the switch. It's in its own ### package to avoid conflicting constants. This simulates a causal ### observer who pushes the light's button over and over, watching it ### as it goes on and off. package Operator; use POE::Session; POE::Session->create( inline_states => { # Start by giving the session a name. This keeps the session # alive while other sessions (the light) operate. Set a test # counter, and yield to the 'push' handler. _start => sub { $_[KERNEL]->alias_set( 'operator' ); $_[KERNEL]->yield( 'push' ); $_[HEAP]->{push_count} = 0; }, # Push the button, and count the button push for testing. push => sub { $_[HEAP]->{push_count}++; $_[KERNEL]->post( switch => 'pushed' ); }, # The light did something observable. Check that its on/off # state matches our expectation. If we need to test some more, # push the button again. visibility => sub { Test::More::ok( ($_[HEAP]->{push_count} & 1) == $_[ARG0], "light state matches expected state" ); $_[KERNEL]->yield( 'push' ) if $_[HEAP]->{push_count} < 10; }, # Dummy handlers to avoid ASSERT_STATES warnings. _stop => sub { 0 }, } ); ### This is a Fibonacci number servlet. Post it a request with the F ### number you want, and it calculates and returns it. package FibServer; use POE::NFA; POE::NFA->spawn( inline_states => { # Set up an alias so that clients can find us. initial => { start => sub { $_[KERNEL]->alias_set( 'server' ); $_[MACHINE]->goto_state( 'listen' ); }, _default => sub { 0 }, }, # Listen for a request. The request includes which Fibonacci # number to return. listen => { request => sub { $_[RUNSTATE]->{client} = $_[SENDER]; $_[MACHINE]->call_state( answer => # return event calculate => # new state start => # new state's entry event $_[ARG0] # F-number to return ); }, answer => sub { $_[KERNEL]->post( delete($_[RUNSTATE]->{client}), 'fib', $_[ARG0] ); }, _default => sub { 0 }, }, calculate => { start => sub { $_[MACHINE]->return_state( 0 ) if $_[ARG0] == 0; $_[MACHINE]->return_state( 1 ) if $_[ARG0] == 1; $_[RUNSTATE]->{f} = [ 0, 1 ]; $_[RUNSTATE]->{n} = 1; $_[RUNSTATE]->{target} = $_[ARG0]; $_[KERNEL]->yield( 'next' ); }, next => sub { $_[RUNSTATE]->{n}++; $_[RUNSTATE]->{f}->[2] = $_[RUNSTATE]->{f}->[0] + $_[RUNSTATE]->{f}->[1]; shift @{$_[RUNSTATE]->{f}}; if ($_[RUNSTATE]->{n} == $_[RUNSTATE]->{target}) { $_[MACHINE]->return_state( $_[RUNSTATE]->{f}->[1] ); } else { $_[KERNEL]->yield( 'next' ); } }, _default => sub { 0 }, }, } )->goto_state( initial => 'start' ); ### This is a Fibonacci client. It asks for F numbers and checks the ### responses vs. expectations. package FibClient; use POE::Session; my $test_number = 11; my @test = ( [ 0, 0 ], [ 1, 1 ], [ 2, 1 ], [ 3, 2 ], [ 4, 3 ], [ 5, 5 ], [ 17, 1597 ], [ 23, 28657 ], [ 29, 514229 ], [ 43, 433494437 ], ); POE::Session->create( inline_states => { _start => sub { # Set up an alias so we'll stay alive until everything is done. $_[KERNEL]->alias_set( 'client' ); $_[KERNEL]->yield( 'next_test' ); }, next_test => sub { $_[KERNEL]->post( server => request => $test[0]->[0] ); }, fib => sub { Test::More::ok( $_[ARG0] == $test[0]->[1], "fib($test[0]->[0]) returned $_[ARG0] (wanted $test[0]->[1])" ); shift @test; $test_number++; $_[KERNEL]->yield( 'next_test' ) if @test; }, # Dummy handlers to avoid ASSERT_STATES warnings. _stop => sub { 0 }, }, ); ### This tests using POE::Kernel->state() with a POE::NFA in the same way ### attaching a wheel to a session does ### Also tests options, and (call|post)backs package DynamicStates; use POE::NFA; POE::NFA->spawn( inline_states => { initial => { start => sub { $_[KERNEL]->alias_set( 'dynamicstates' ); $_[MACHINE]->goto_state( 'listen', 'send' ); $_[KERNEL]->state("test_wheel_event" => sub { $_[KERNEL]->yield("happened"); } ); # test options my $orig = $_[MACHINE]->option(default => 1); my $rv = $_[MACHINE]->option('default'); Test::More::ok($rv, "set default option successfully"); $rv = $_[MACHINE]->option('default' => $orig); Test::More::ok($rv, "reset default option successfully"); $rv = $_[MACHINE]->option('default'); Test::More::ok(!($rv xor $orig), "reset default option successfully"); # test (post|call)backs $_[MACHINE]->callback("callback")->(); $_[MACHINE]->postback("postback")->(); }, _default => sub { 0 }, callback => sub { Test::More::pass("POE::NFA::callback"); }, postback => sub { Test::More::fail("POE::NFA::postback"); }, }, listen => { send => sub { $_[KERNEL]->yield("test_wheel_event"); }, happened => sub { Test::More::pass("wheel event happened"); Test::More::is($_[MACHINE]->get_current_state(), $_[STATE], "get_current_state returns the same as \$_[STATE]"); Test::More::is_deeply($_[MACHINE]->get_runstate(), $_[RUNSTATE], "get_runstate returns the same as \$_[RUNSTATE]"); }, callback => sub { Test::More::fail("POE::NFA::callback"); }, postback => sub { Test::More::pass("POE::NFA::postback"); }, }, }, )->goto_state("initial", "start"); ### Run everything until it's all done. package main; POE::Kernel->run(); 1; comp_tcp.pm100644000765000024 1626012425745722 21076 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercise Server::TCP and later, when it's available, Client::TCP. use strict; use lib qw(./mylib ../mylib); BEGIN { unless (-f "run_network_tests") { print "1..0 # Skip Network access (and permission) required to run this test\n"; CORE::exit(); } } use Test::More tests => 34; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw( Component::Server::TCP Wheel::ReadWrite Component::Client::TCP ); my ($acceptor_port, $callback_port); # Create a server. This one uses Acceptor to create a session of the # program's devising. POE::Component::Server::TCP->new( Port => 0, Address => '127.0.0.1', Alias => 'acceptor_server', Started => sub { use Socket qw(sockaddr_in); $acceptor_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, Acceptor => sub { my ($socket, $peer_addr, $peer_port) = @_[ARG0..ARG2]; POE::Session->create( inline_states => { _start => sub { my $heap = $_[HEAP]; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $socket, InputEvent => 'got_input', ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); pass("acceptor server got client connection"); }, _stop => sub { pass("acceptor server stopped the client session"); }, got_input => sub { my ($heap, $input) = @_[HEAP, ARG0]; pass("acceptor server received input"); $heap->{wheel}->put("echo: $input"); $heap->{shutdown} = 1 if $input eq "quit"; }, got_error => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; print "acceptor server got $operation error $errnum: $errstr\n"; }, got_flush => sub { my $heap = $_[HEAP]; pass("acceptor server flushed output"); delete $heap->{wheel} if $heap->{shutdown}; }, }, ); }, ); # Create a server. This one uses ClientXyz to process clients instead # of a user-defined session. POE::Component::Server::TCP->new( Port => 0, Address => '127.0.0.1', Alias => 'input_server', ClientFilter => [ "POE::Filter::Line", Literal => "\n" ], Started => sub { use Socket qw(sockaddr_in); $callback_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, ClientInput => sub { my ($heap, $input) = @_[HEAP, ARG0]; pass("callback server got input"); $heap->{client}->put("echo: $input"); $heap->{shutdown} = 1 if $input eq "quit"; }, ClientError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; print "callback server got $operation error $errnum: $errstr\n"; }, ClientFlushed => sub { pass("callback server flushed output"); }, ClientConnected => sub { pass("callback server got client connection"); }, ClientPreConnect => sub { pass("server got pre-connect callback"); ok(fileno($_[ARG0]), "ARG0 is a socket"); return $_[ARG0]; }, ClientDisconnected => sub { pass("callback server got client disconnected"); }, ); # Test that the constructor of PoCo::Client::TCP is strict in what it # accepts as valid arguments { eval { POE::Component::Client::TCP->new( RemoteAddress => "1.2.3.4", Odd => "Elephant", "Of Arguments") }; ok($@ =~ /odd|even/, "Client::TCP constructor requires even number of parameters"); my %base_args = ( RemoteAddress => '127.0.0.1', RemotePort => 31401, Connected => sub { }, ConnectError => sub { }, Disconnected => sub { }, ServerInput => sub { }, ServerError => sub { }, ServerFlushed => sub { }, ); my $test_missing = sub { my ($args, $remove) = @_; delete $$args{$_} for @$remove; eval { POE::Component::Client::TCP->new( %$args ) }; ok($@ ne '', "Client::TCP constructor requires " . join(", ", @$remove)); }; $test_missing->({%base_args}, ["RemoteAddress"]); $test_missing->({%base_args}, ["RemotePort"]); $test_missing->({%base_args}, ["ServerInput"]); my %mark_args = (%base_args, HighMark => 256, LowMark => 64, ServerHigh => sub { }, ServerLow => sub { } ); $test_missing->({%mark_args}, ["LowMark", "ServerHigh", "ServerLow"]); $test_missing->({%mark_args}, ["HighMark", "ServerHigh", "ServerLow"]); $test_missing->({%mark_args}, ["HighMark", "LowMark", "ServerLow"]); $test_missing->({%mark_args}, ["HighMark", "LowMark", "ServerHigh"]); my $test_notref = sub { my $which = shift; eval { POE::Component::Client::TCP->new( %base_args, $which => "Not a reference" ) }; ok($@ =~ /$which.*reference/i, "Client::TCP constructor requires $which to be a reference"); }; $test_notref->("InlineStates"); $test_notref->("PackageStates"); $test_notref->("ObjectStates"); eval { POE::Component::Client::TCP->new( %base_args, SessionParams => sub { "Not an array reference" }) }; ok($@ =~ /SessionParams/, "Client::TCP constructor requires SessionParams to be an array reference"); } # A client to connect to acceptor_server. POE::Component::Client::TCP->new( RemoteAddress => '127.0.0.1', RemotePort => $acceptor_port, PreConnect => sub { pass("acceptor pre connect"); ok(fileno($_[ARG0]), "acceptor has a socket"); return $_[ARG0]; }, Connected => sub { pass("acceptor client connected"); $_[HEAP]->{server}->put( "quit" ); }, ConnectError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; print "acceptor client got $operation error $errnum: $errstr\n"; }, Disconnected => sub { pass("acceptor client disconnected"); $_[KERNEL]->post( acceptor_server => 'shutdown' ); }, ServerInput => sub { my ($heap, $input) = @_[HEAP, ARG0]; pass("acceptor client got input"); }, ServerError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; ok( ($operation eq "read") && ($errnum == 0), "acceptor client got read error 0 (EOF)" ); }, ServerFlushed => sub { pass("acceptor client flushed output"); }, ); # A client to connect to input_server. POE::Component::Client::TCP->new( RemoteAddress => '127.0.0.1', RemotePort => $callback_port, Filter => [ "POE::Filter::Line", Literal => "\n" ], Connected => sub { pass("callback client connected"); $_[HEAP]->{server}->put( "quit" ); }, ConnectError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; print "callback client got $operation error $errnum: $errstr\n"; }, Disconnected => sub { pass("callback client disconnected"); $_[KERNEL]->post( input_server => 'shutdown' ); }, ServerInput => sub { my ($heap, $input) = @_[HEAP, ARG0]; pass("callback client got input"); }, ServerError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; ok( ($operation eq "read") && ($errnum == 0), "callback client got read error 0 (EOF)" ); }, ServerFlushed => sub { pass("callback client flushed output"); }, ); # Run the tests. POE::Kernel->run(); 1; k_alarms.pm100644000765000024 3475512425745722 21074 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests alarms. use strict; use lib qw(./mylib ../mylib); use Test::More tests => 37; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use constant WAIT => 0.5; BEGIN { use_ok("POE") } # Test the ID-based alarm API. Start several test paths. Each path # exercises # We need this because queue_peek_alarms was deprecated BEGIN { package # split to avoid CPAN indexer POE::Kernel; sub queue_peek_alarms { my $self = shift; my $session = $self->get_active_session; my $alarm_count = $self->_data_ev_get_count_to($session); my $my_alarm = sub { return 0 unless $_[0]->[EV_TYPE] & ET_ALARM; return 0 unless $_[0]->[EV_SESSION] == $session; return 1; }; return( map { $_->[ITEM_PAYLOAD]->[EV_NAME] } $self->[KR_QUEUE]->peek_items($my_alarm, $alarm_count) ); } } sub test_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Path #1: single alarm; make sure it rings. $heap->{test}->{path_one} = 0; $kernel->alarm( path_one => time() + WAIT, 1.1 ); # Path #2: two alarms; make sure only the second one rings. $heap->{test}->{path_two} = 0; $kernel->alarm( path_two => time() + WAIT, 2.1 ); $kernel->alarm( path_two => time() + WAIT, 2.2 ); # Path #3: two alarms; make sure they both ring in order. $heap->{test}->{path_three} = 0; $kernel->alarm_add( path_three => time() + WAIT, 3.1 ); $kernel->alarm_add( path_three => time() + WAIT, 3.2 ); # Path #4: interleaved alarm and alarm_add; only the last two should # ring, in order. $heap->{test}->{path_four} = 0; $kernel->alarm( path_four => time() + WAIT, 4.1 ); $kernel->alarm_add( path_four => time() + WAIT, 4.2 ); $kernel->alarm( path_four => time() + WAIT, 4.3 ); $kernel->alarm_add( path_four => time() + WAIT, 4.4 ); # Path #5: an alarm that is squelched; nothing should ring. $heap->{test}->{path_five} = 1; $kernel->alarm( path_five => time() + WAIT, 5.1 ); $kernel->alarm( 'path_five' ); # Path #6: single delay; make sure it rings. $heap->{test}->{path_six} = 0; $kernel->delay( path_six => WAIT, 6.1 ); # Path #7: two delays; make sure only the second one rings. $heap->{test}->{path_seven} = 0; $kernel->delay( path_seven => WAIT, 7.1 ); $kernel->delay( path_seven => WAIT, 7.2 ); # Path #8: two delays; make sure they both ring in order. $heap->{test}->{path_eight} = 0; $kernel->delay_add( path_eight => WAIT, 8.1 ); $kernel->delay_add( path_eight => WAIT, 8.2 ); # Path #9: interleaved delay and delay_add; only the last two should # ring, in order. $heap->{test}->{path_nine} = 0; $kernel->alarm( path_nine => WAIT, 9.1 ); $kernel->alarm_add( path_nine => WAIT, 9.2 ); $kernel->alarm( path_nine => WAIT, 9.3 ); $kernel->alarm_add( path_nine => WAIT, 9.4 ); # Path #10: a delay that is squelched; nothing should ring. $heap->{test}->{path_ten} = 1; $kernel->delay( path_ten => WAIT, 10.1 ); $kernel->alarm( 'path_ten' ); # Path #11: ensure alarms are enqueued in time order. # To test duplicates on a small queue. my $id_25_3 = $kernel->alarm_set( path_eleven_025_3 => 25 ); my $id_25_2 = $kernel->alarm_set( path_eleven_025_2 => 25 ); my $id_25_1 = $kernel->alarm_set( path_eleven_025_1 => 25 ); # To test micro-updates on a small queue. $kernel->alarm_adjust( $id_25_1 => -0.01 ); # negative $kernel->alarm_adjust( $id_25_3 => 0.01 ); # positive # Fill the alarm queue to engage the "big queue" binary insert. my @eleven_fill; for (my $count=0; $count<600; $count++) { my $time = int(rand(300)); redo unless $time; # Event doesn't like setting alarms for 0 time. push @eleven_fill, $time; $kernel->alarm( "path_eleven_fill_$count", $eleven_fill[-1] ); } # Now to really test the insertion code. $kernel->alarm( path_eleven_100 => 100 ); $kernel->alarm( path_eleven_200 => 200 ); $kernel->alarm( path_eleven_300 => 300 ); $kernel->alarm( path_eleven_050 => 50 ); $kernel->alarm( path_eleven_150 => 150 ); $kernel->alarm( path_eleven_250 => 250 ); $kernel->alarm( path_eleven_350 => 350 ); $kernel->alarm( path_eleven_075 => 75 ); $kernel->alarm( path_eleven_175 => 175 ); $kernel->alarm( path_eleven_275 => 275 ); $kernel->alarm( path_eleven_325 => 325 ); $kernel->alarm( path_eleven_225 => 225 ); $kernel->alarm( path_eleven_125 => 125 ); # To test duplicates. my $id_206 = $kernel->alarm_set( path_eleven_206 => 205 ); my $id_205 = $kernel->alarm_set( path_eleven_205 => 205 ); my $id_204 = $kernel->alarm_set( path_eleven_204 => 205 ); # To test micro-updates on a big queue. $kernel->alarm_adjust( $id_204 => -0.01 ); # negative $kernel->alarm_adjust( $id_206 => 0.01 ); # positive # Now clear the filler states. for (my $count=0; $count<600; $count++) { if ($count & 1) { $kernel->alarm( "path_eleven_fill_$count" ); } else { $kernel->alarm( "path_eleven_fill_$count" ); } } # Now acquire the test alarms. my @alarms_eleven = grep /^path_eleven_[0-9_]+$/, $kernel->queue_peek_alarms(); $heap->{alarms_eleven} = \@alarms_eleven; # Now clear the test alarms since we're just testing the queue # order. foreach (@alarms_eleven) { $kernel->alarm( $_ ); } # All the paths are occurring in parallel so they should complete in # about 2 seconds. Start a timer to make sure. $heap->{start_time} = time(); } sub test_stop { my $heap = $_[HEAP]; is($heap->{test}->{path_one}, 1, "single alarm rang ok"); is($heap->{test}->{path_two}, 1, "second alarm superseded first"); is($heap->{test}->{path_three}, 11, "two alarms rang in proper order"); is($heap->{test}->{path_four}, 11, "mixed alarm APIs rang properly"); is($heap->{test}->{path_five}, 1, "stopped alarm should not ring"); is($heap->{test}->{path_six}, 1, "single delay rang ok"); is($heap->{test}->{path_seven}, 1, "second delay superseded first"); is($heap->{test}->{path_eight}, 11, "two delays rang in proper order"); is($heap->{test}->{path_nine}, 11, "mixed delay APIs rang properly"); is($heap->{test}->{path_ten}, 1, "stopped delay should not ring"); # Here's where we check the overall run time. Increased to 15s for # extremely slow, overtaxed machines like my XP system running under # Virtual PC. cmp_ok(time() - $heap->{start_time}, '<=', 15, "tests ran reasonably fast"); # And test alarm order. is_deeply( $heap->{alarms_eleven}, [ qw( path_eleven_025_1 path_eleven_025_2 path_eleven_025_3 path_eleven_050 path_eleven_075 path_eleven_100 path_eleven_125 path_eleven_150 path_eleven_175 path_eleven_200 path_eleven_204 path_eleven_205 path_eleven_206 path_eleven_225 path_eleven_250 path_eleven_275 path_eleven_300 path_eleven_325 path_eleven_350 ) ], "alarms rang in order" ); } sub test_path_one { my ($heap, $test_id) = @_[HEAP, ARG0]; if ($test_id == 1.1) { $heap->{test}->{path_one} += 1; } else { $heap->{test}->{path_one} += 1000; } } sub test_path_two { my ($heap, $test_id) = @_[HEAP, ARG0]; if ($test_id == 2.2) { $heap->{test}->{path_two} += 1; } else { $heap->{test}->{path_two} += 1000; } } sub test_path_three { my ($heap, $test_id) = @_[HEAP, ARG0]; if (($test_id == 3.1) and ($heap->{test}->{path_three} == 0)) { $heap->{test}->{path_three} += 1; } elsif (($test_id == 3.2) and ($heap->{test}->{path_three} == 1)) { $heap->{test}->{path_three} += 10; } else { $heap->{test}->{path_three} += 1000; } } sub test_path_four { my ($heap, $test_id) = @_[HEAP, ARG0]; if (($test_id == 4.3) and ($heap->{test}->{path_four} == 0)) { $heap->{test}->{path_four} += 1; } elsif (($test_id == 4.4) and ($heap->{test}->{path_four} == 1)) { $heap->{test}->{path_four} += 10; } else { $heap->{test}->{path_four} += 1000; } } sub test_path_five { my ($heap, $test_id) = @_[HEAP, ARG0]; $heap->{test}->{path_five} += 1; } sub test_path_six { my ($heap, $test_id) = @_[HEAP, ARG0]; if ($test_id == 6.1) { $heap->{test}->{path_six} += 1; } else { $heap->{test}->{path_six} += 1000; } } sub test_path_seven { my ($heap, $test_id) = @_[HEAP, ARG0]; if ($test_id == 7.2) { $heap->{test}->{path_seven} += 1; } else { $heap->{test}->{path_seven} += 1000; } } sub test_path_eight { my ($heap, $test_id) = @_[HEAP, ARG0]; if (($test_id == 8.1) and ($heap->{test}->{path_eight} == 0)) { $heap->{test}->{path_eight} += 1; } elsif (($test_id == 8.2) and ($heap->{test}->{path_eight} == 1)) { $heap->{test}->{path_eight} += 10; } else { $heap->{test}->{path_eight} += 1000; } } sub test_path_nine { my ($heap, $test_id) = @_[HEAP, ARG0]; if (($test_id == 9.3) and ($heap->{test}->{path_nine} == 0)) { $heap->{test}->{path_nine} += 1; } elsif (($test_id == 9.4) and ($heap->{test}->{path_nine} == 1)) { $heap->{test}->{path_nine} += 10; } else { $heap->{test}->{path_nine} += 1000; } } sub test_path_ten { my ($heap, $test_id) = @_[HEAP, ARG0]; $heap->{test}->{path_ten} += 1; } ### Spawn a session to test the ID-based alarm API added in June 2001. POE::Session->create( inline_states => { _start => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{test_13} = $kernel->alarm_set( test_13 => 1 => 13 ); my $test_14 = $kernel->alarm_set( test_14 => 1 => 14 ); my @test_array = $kernel->alarm_remove( $test_14 ); is($test_array[0], 'test_14', "alarm 14 remove: name is correct"); is($test_array[1], 1, "alarm 14 remove: time is correct"); is_deeply($test_array[2], [ 14 ], "alarm 14 remove: data is correct"); # Have time stand still so we can test against it. # Heisenberg strikes again! my $now = time; my $test_15 = $kernel->delay_set( test_15 => WAIT, 15 ); my $test_scalar = $kernel->alarm_remove( $test_15 ); is($test_scalar->[0], 'test_15', "alarm 15 remove: name is correct"); ok( ( $test_scalar->[1] <= $now + 3 and $test_scalar->[1] >= $now ), "alarm 15 remove: time is correct" ); is_deeply($test_scalar->[2], [ 15 ], "alarm 15 remove: data is correct"); }, # This one is dispatched. test_13 => sub { my $kernel = $_[KERNEL]; is($_[ARG0], 13, "alarm 13: received proper data"); # Set a couple alarms, then clear them all. $kernel->delay( test_16 => WAIT ); $kernel->delay( test_17 => WAIT ); $kernel->alarm_remove_all(); # Test alarm adjusting on little queues. my $alarm_id = $kernel->alarm_set( test_18 => 50 => 18 ); # One alarm. my $new_time = $kernel->alarm_adjust( $alarm_id => -1 ); is($new_time, 49, "alarm 18: adjusted backward correctly"); $new_time = $kernel->alarm_adjust( $alarm_id => 1 ); is($new_time, 50, "alarm 18: adjusted forward correctly"); # Two alarms. $alarm_id = $kernel->alarm_set( test_19 => 52 => 19 ); $new_time = $kernel->alarm_adjust( $alarm_id => -4 ); is($new_time, 48, "alarm 19: adjusted backward correctly"); $new_time = $kernel->alarm_adjust( $alarm_id => 4 ); is($new_time, 52, "alarm 19: adjusted forward correctly"); # Three alarms. $alarm_id = $kernel->alarm_set( test_20 => 49 => 20 ); $new_time = $kernel->alarm_adjust( $alarm_id => 2 ); is($new_time, 51, "alarm 20: adjusted forward once correctly"); $new_time = $kernel->alarm_adjust( $alarm_id => 2 ); is($new_time, 53, "alarm 20: adjusted forward twice correctly"); $new_time = $kernel->alarm_adjust( $alarm_id => -2 ); is($new_time, 51, "alarm 20: adjusted backward correctly"); # Test alarm adjusting on big queues. my @alarm_filler; for (1..100) { push( @alarm_filler, $kernel->alarm_set( filler => $_) ); } # Moving inside the alarm range. $alarm_id = $kernel->alarm_set( test_21 => 50 => 21 ); $new_time = $kernel->alarm_adjust( $alarm_id => -10 ); is($new_time, 40, "alarm 21: adjusted backward correctly"); $new_time = $kernel->alarm_adjust( $alarm_id => 20 ); is($new_time, 60, "alarm 21: adjusted forward correctly"); # Moving outside (to the beginning) of the alarm range. $new_time = $kernel->alarm_adjust( $alarm_id => -100 ); is($new_time, -40, "alarm 21: adjusted first correctly"); # Moving outside (to the end) of the alarm range. $alarm_id = $kernel->alarm_set( test_22 => 50 => 22 ); $new_time = $kernel->alarm_adjust( $alarm_id => 100 ); is($new_time, 150, "alarm 22: adjusted last correctly"); # Remove the filler events. foreach (@alarm_filler) { $kernel->alarm_remove( $_ ); } }, # These have been removed. They should not be dispatched. test_14 => sub { fail("alarm 14 should have been removed"); }, test_15 => sub { fail("alarm 15 should have been removed"); }, test_16 => sub { fail("alarm 16 should have been removed"); }, test_17 => sub { fail("alarm 17 should have been removed"); }, # These should be dispatched in a certain order. _default => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Save the test's argument on the heap. Check during _stop. push( @{$heap->{tests}}, $_[ARG1]->[0] ) if $_[ARG0] =~ /test_\d+/; # Handle the signal. $kernel->sig_handled(); }, _stop => sub { my $heap = $_[HEAP]; is(@{$heap->{tests}}, 5, "the right number of alarms were dispatched"); is($heap->{tests}->[0], 21, "alarm 21 was dispatched first"); is($heap->{tests}->[1], 18, "alarm 18 was dispatched second"); is($heap->{tests}->[2], 20, "alarm 20 was dispatched third"); is($heap->{tests}->[3], 19, "alarm 19 was dispatched fourth"); is($heap->{tests}->[4], 22, "alarm 22 was dispatched fifth"); }, } ); # Run the old tests here. POE::Session->create( inline_states => { _start => \&test_start, _stop => \&test_stop, path_one => \&test_path_one, path_two => \&test_path_two, path_three => \&test_path_three, path_four => \&test_path_four, path_five => \&test_path_five, path_six => \&test_path_six, path_seven => \&test_path_seven, path_eight => \&test_path_eight, path_nine => \&test_path_nine, path_ten => \&test_path_ten, } ); # Ye olde main loop and exit. POE::Kernel->run(); 1; k_detach.pm100644000765000024 1705112425745722 21033 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests session detaching. use strict; use lib qw(./mylib ../mylib); # Trace output local to this test program. sub DEBUG () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More tests => 9; use POE; # Moved "global" test accumulation variables out of the "main" session # because it was becoming a peer to the others that had been detached. # Sometimes "main" would be stopped before the others, and the program # would fail when they tried to post results back to it. my $test_trace = ""; # Spawn a grandchild. sub spawn_grandchild { my $grandchild_id = shift; POE::Session->create( inline_states => { _start => sub { my $kernel = $_[KERNEL]; $kernel->alias_set( $grandchild_id ); DEBUG and warn $_[SESSION]->ID, " has started.\n"; }, _parent => sub { my ($kernel, $old_parent, $new_parent) = @_[KERNEL, ARG0, ARG1]; my $old_alias = $kernel->call($old_parent, "get_alias"); my $new_alias; if (ref($new_parent) eq 'POE::Kernel') { $new_alias = 'kernel'; } else { $new_alias = $kernel->call($new_parent, "get_alias"); } $test_trace .= "(p $grandchild_id $old_alias $new_alias)"; }, _child => sub { my ($kernel, $op, $child) = @_[KERNEL, ARG0, ARG1]; my $child_alias = $kernel->call($child, 'get_alias' ); $test_trace .= "(c $grandchild_id $op $child_alias)"; }, get_alias => sub { return $grandchild_id; }, detach_self => sub { $_[KERNEL]->detach_myself(); }, detach_child => sub { $_[KERNEL]->detach_child( $_[ARG0] ); }, _stop => sub { my $kernel = $_[KERNEL]; DEBUG and warn $_[SESSION]->ID, " stopped.\n"; }, }, ); # To prevent this from returning a session reference. undef; } # Spawn a child. sub spawn_child { my $child_id = shift; my $alias = "a$child_id"; POE::Session->create( inline_states => { _start => sub { my $kernel = $_[KERNEL]; $kernel->alias_set( $alias ); $kernel->yield( 'spawn_grandchildren' ); DEBUG and warn $_[SESSION]->ID, " has started.\n"; }, spawn_grandchildren => sub { spawn_grandchild( $alias . "_1" ); spawn_grandchild( $alias . "_2" ); spawn_grandchild( $alias . "_3" ); }, _parent => sub { my ($kernel, $old_parent, $new_parent) = @_[KERNEL, ARG0, ARG1]; my $old_alias = $kernel->call($old_parent, 'get_alias'); my $new_alias; if (ref($new_parent) eq 'POE::Kernel') { $new_alias = 'kernel'; } else { $new_alias = $kernel->call($new_parent, 'get_alias'); } $test_trace .= "(p $child_id $old_alias $new_alias)"; }, _child => sub { my ($kernel, $op, $child) = @_[KERNEL, ARG0, ARG1]; my $child_alias = $kernel->call($child, 'get_alias' ); $test_trace .= "(c $child_id $op $child_alias)"; }, get_alias => sub { return $child_id; }, detach_self => sub { my $kernel = $_[KERNEL]; $kernel->detach_myself(); }, detach_child => sub { my $kernel = $_[KERNEL]; $kernel->detach_child( $_[ARG0] ); }, _stop => sub { my $kernel = $_[KERNEL]; DEBUG and warn $_[SESSION]->ID, " has stopped.\n"; }, }, ); # To prevent this from returning a session reference. undef; } # Spawn the main session. This will spawn children, which will spawn # grandchildren. Then the main session will perform controlled # detaches and watch the results. POE::Session->create( inline_states => { _start => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{idle_count} = 0; $kernel->alias_set( 'main' ); $kernel->yield( 'spawn_children' ); DEBUG and warn $_[SESSION]->ID, " has started.\n"; }, spawn_children => sub { my $kernel = $_[KERNEL]; spawn_child( 1 ); spawn_child( 2 ); spawn_child( 3 ); $kernel->delay( run_tests => 0.5 ); }, get_alias => sub { return 'main'; }, detach_self => sub { my $kernel = $_[KERNEL]; $kernel->detach_myself(); }, detach_child => sub { my $kernel = $_[KERNEL]; $kernel->detach_child( $_[ARG0] ); }, run_tests => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; $test_trace = ""; $kernel->call( a1_1 => 'detach_self' ); is( $test_trace, '(c 1 lose a1_1)(p a1_1 1 kernel)', "a1_1 detached itself" ); $test_trace = ''; $kernel->call( a2_1 => 'detach_self' ); is( $test_trace, '(c 2 lose a2_1)(p a2_1 2 kernel)', "a2_1 detached itself" ); $test_trace = ''; $kernel->call( a3_1 => 'detach_self' ); is( $test_trace, '(c 3 lose a3_1)(p a3_1 3 kernel)', "a3_1 detached itself" ); $test_trace = ''; $kernel->call( a1 => detach_child => 'a1_2' ); is( $test_trace, '(c 1 lose a1_2)(p a1_2 1 kernel)', "a1 detached child a1_2" ); $test_trace = ''; $kernel->call( a2 => detach_child => 'a2_2' ); is( $test_trace, '(c 2 lose a2_2)(p a2_2 2 kernel)', "a2 detached child a2_2" ); $test_trace = ''; $kernel->call( a3 => detach_child => 'a3_2' ); is( $test_trace, '(c 3 lose a3_2)(p a3_2 3 kernel)', "a3 detached child a3_2" ); $test_trace = ''; $kernel->call( a1 => 'detach_self' ); is( $test_trace, '(c main lose 1)(p 1 main kernel)', "a1 detached itself" ); $test_trace = ''; $kernel->call( main => detach_child => 'a2' ); is( $test_trace, '(c main lose 2)(p 2 main kernel)', "a2 detached itself" ); }, _parent => sub { my $old_alias = $_[KERNEL]->call( $_[ARG0], 'get_alias' ); my $new_alias; if (ref($_[ARG1]) eq 'POE::Kernel') { $new_alias = 'kernel'; } else { $new_alias = $_[KERNEL]->call( $_[ARG1], 'get_alias' ); } $test_trace .= "(p main $old_alias $new_alias)"; }, _child => sub { my $child_alias = $_[KERNEL]->call( $_[ARG1], 'get_alias' ); $test_trace .= "(c main $_[ARG0] $child_alias)"; }, _stop => sub { DEBUG and warn $_[SESSION]->ID, " has stopped.\n"; }, grandchild_parent => sub { my $old_alias = $_[KERNEL]->call( $_[ARG1], 'get_alias' ); my $new_alias; if (ref($_[ARG2]) eq 'POE::Kernel') { $new_alias = 'kernel'; } else { $new_alias = $_[KERNEL]->call( $_[ARG2], 'get_alias' ); } $test_trace .= "(p $_[ARG0] $old_alias $new_alias)"; }, grandchild_child => sub { my $child_alias = $_[KERNEL]->call( $_[ARG2], 'get_alias' ); $test_trace .= "(c $_[ARG0] $_[ARG1] $child_alias)"; }, }, ); POE::Kernel->run(); # Final test to see if the remaining sessions died properly. The # trace string can be nondeterministic. Split it, sort it, and rejoin # it so it's always in a known order. substr($test_trace, 0, 1) = ''; substr($test_trace, -1, 1) = ''; $test_trace = '(' . (join ')(', sort split /\)\(/, $test_trace) . ')'; is( $test_trace, join( "", "(c 1 lose a1_3)", "(c 2 lose a2_3)", "(c 3 lose a3_3)", "(c main lose 2)", "(c main lose 3)", "(p 2 main kernel)" ), "session destruction order" ); 1; k_aliases.pm100644000765000024 720512425745722 21204 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests basic session aliases. use strict; use Test::More tests => 20; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POSIX qw (:errno_h); BEGIN { use_ok("POE"); } ### Define a simple state machine. sub machine_start { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; my $resolved_session; $kernel->sig(IDLE => "sigidle"); $kernel->sig(ZOMBIE => "sigzombie"); $heap->{idle_count} = $heap->{zombie_count} = 0; ok(!$kernel->alias_set('new name'), "setting new alias"); ok(!$kernel->alias_set('new name'), "overwriting new alias"); $resolved_session = $kernel->alias_resolve( "$session" ); ok($resolved_session eq $session, "resolve stringified session reference"); $resolved_session = $kernel->alias_resolve( $session->ID ); ok($resolved_session eq $session, "resolve session ID"); $resolved_session = $kernel->alias_resolve( 'new name' ); ok($resolved_session eq $session, "resolve alias"); $resolved_session = $kernel->alias_resolve( $session ); ok($resolved_session eq $session, "resolve session reference"); open(SAVE_STDERR, ">&STDERR") or die $!; close(STDERR) or die $!; $resolved_session = eval { $kernel->alias_resolve( 'nonexistent' ) }; open(STDERR, ">&SAVE_STDERR") or die $!; close(SAVE_STDERR) or die $!; ok(!$resolved_session, "fail to resolve nonexistent alias"); my $id = $session->ID; ok($kernel->ID_id_to_session($id) == $session, "id resolves to session"); ok($kernel->ID_session_to_id($session) == $id, "session resolves to id"); ok( $kernel->ID_id_to_session($kernel->ID) == $kernel, "kernel id resolves to kernel reference" ); ok( $kernel->ID_session_to_id($kernel) eq $kernel->ID, "kernel reference resolves to kernel id" ); # Check alias list for session. my @aliases = $kernel->alias_list(); ok(@aliases == 1, "session has only one alias"); ok($aliases[0] eq 'new name', "session's alias is 'new name'"); # Set and test a second alias. $kernel->alias_set( 'second name' ); @aliases = sort $kernel->alias_list( $session ); ok(@aliases == 2, "session now has two aliases"); ok($aliases[0] eq 'new name', "session has 'new name' alias"); ok($aliases[1] eq 'second name', "session has 'second name' alias"); } # Catch SIGIDLE and SIGZOMBIE and count them. sub machine_sig_idle { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{idle_count}++; return $kernel->sig_handled(); } sub machine_sig_zombie { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{zombie_count}++; return $kernel->sig_handled(); } # Make sure we got one SIGIDLE and one SIGZOMBIE. sub machine_stop { my $heap = $_[HEAP]; is($heap->{idle_count}, 1, "session received one SIGIDLE"); is($heap->{zombie_count}, 1, "session received one SIGZOMBIE"); } # Spawn a state machine for testing. POE::Session->create( inline_states => { _start => \&machine_start, sigidle => \&machine_sig_idle, sigzombie => \&machine_sig_zombie, _stop => \&machine_stop }, ); my $sigidle_test = 1; my $sigzombie_test = 1; POE::Session->create( inline_states => { _start => sub { my $kernel = $_[KERNEL]; $kernel->alias_set( 'a_sample_alias' ); ok(!$_[KERNEL]->alias_remove('a_sample_alias'), "removing simple alias"); $kernel->sig(IDLE => "sigidle"); $kernel->sig(ZOMBIE => "sigzombie"); }, sigidle => sub { $sigidle_test = 0; }, sigzombie => sub { $sigzombie_test = 0; }, _stop => sub { }, } ); # Now run the kernel until there's nothing left to do. POE::Kernel->run(); 1; k_selects.pm100644000765000024 1512712425745722 21247 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests basic select operations. 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 => 17; use POE qw(Pipe::OneWay Pipe::TwoWay); ### Test parameters. my $pair_count = 5; my $chat_count = 5; # What to do here? Create ten master sessions that create socket # pairs. Each master session spawns a slave session and gives it the # other end of the pair. The master and slave chat a while, then the # slave exits (odd pairs) or the master exits (even pairs). # Everything should shut down cleanly. # We'll use send and recv with small enough packets to avoid worrying # about combining broken datagrams. ### Master session. sub master_start { my ($kernel, $heap ) = @_[KERNEL, HEAP, ARG0]; my ($master_read, $master_write, $slave_read, $slave_write) = POE::Pipe::TwoWay->new(); ok( defined($master_read), "master: created two-way pipe for testing" ); # Listen on the uplink_read side. $kernel->select_read($master_read, 'input'); # Give the other side to a newly spawned session. POE::Session->create( inline_states => { _start => \&slave_start, _stop => \&slave_stop, input => \&slave_got_input, resume => \&slave_resume_read, output => \&slave_put_output, }, args => [ $slave_read, $slave_write ], ); # Save some values for later. $heap->{write} = $master_write; $heap->{test_count} = 0; $heap->{queue} = [ ]; # Start the write thing. $kernel->select_write($master_write, 'output'); } sub master_stop { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Determine if we were successful. ok( $heap->{test_count} == $chat_count, "master: expected number of messages" ); } sub master_got_input { my ($kernel, $heap, $handle) = @_[KERNEL, HEAP, ARG0]; my $received = sysread($handle, my $buffer = '', 4); unless ($received == 4) { $kernel->select_read($handle); $kernel->select_write($heap->{write}); return; } # The other session requested a quit. Shut down gracefully. if ($buffer eq 'quit') { $kernel->select_read($handle); $kernel->select_write($heap->{write}); return; } # The other session sent a ping. Count it, and send a pong. if ($buffer eq 'ping') { $heap->{test_count}++; push @{$heap->{queue}}, 'pong'; $kernel->select_resume_write($heap->{write}); } } sub master_put_output { my ($kernel, $heap, $handle) = @_[KERNEL, HEAP, ARG0]; # If there is a message queued, write it. if (@{$heap->{queue}}) { my $message = shift @{$heap->{queue}}; die $! unless ( syswrite($handle, $message, length($message)) == length($message) ); } # Otherwise pause the write select. else { $kernel->select_pause_write($handle); } } ### Slave session. sub slave_start { my ($kernel, $heap, $read_handle, $write_handle, $test_index) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2]; # Select on our read handle. $kernel->select_read($read_handle, 'input'); # Remember some things. $heap->{read} = $read_handle; $heap->{write} = $write_handle; $heap->{test_index} = $test_index; $heap->{queue} = [ ]; # Say hello to the master session. push @{$heap->{queue}}, 'ping'; $kernel->select_write($write_handle, 'output'); } sub slave_stop { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Determine if we were successful. ok( $heap->{test_count} == $chat_count, "slave: expected number of messages" ); } # Resume reading after a brief delay. sub slave_resume_read { $_[KERNEL]->select_resume_read( $_[HEAP]->{read} ); $_[KERNEL]->delay( error_resuming => undef ); $_[HEAP]->{resume_count}++; } sub slave_got_input { my ($kernel, $heap, $handle) = @_[KERNEL, HEAP, ARG0]; my $received = sysread($handle, my $buffer = '', 4); unless ($received == 4) { $kernel->select_read($handle); $kernel->select_write($heap->{write}); return; } # The other session sent a pong. if ($buffer eq 'pong') { $heap->{test_count}++; # Send another ping if we're not done. if ($heap->{test_count} < $chat_count) { push @{$heap->{queue}}, 'ping'; $kernel->select_resume_write($heap->{write}); # Pause reading. Gets resumed after a delay. $kernel->select_pause_read( $heap->{read} ); $kernel->delay( resume => 0.5 ); } # Otherwise we're done. Send a quit, and quit ourselves. else { push @{$heap->{queue}}, 'quit'; $kernel->select_read($handle); $kernel->select_resume_write($heap->{write}); } } } sub slave_put_output { my ($kernel, $heap, $handle) = @_[KERNEL, HEAP, ARG0]; # If there is a message queued, write it. if (@{$heap->{queue}}) { my $message = shift @{$heap->{queue}}; die $! unless ( syswrite($handle, $message, length($message)) == length($message) ); # Kludge. We requested quit, so go ahead and quit. $kernel->select_write($handle) if $message eq 'quit'; } # Otherwise pause the write select. else { $kernel->select_pause_write($handle); } } ### Main loop. # Spawn a group of master sessions. for (my $index = 0; $index < $pair_count; $index++) { POE::Session->create( inline_states => { _start => \&master_start, _stop => \&master_stop, _child => sub { }, input => \&master_got_input, output => \&master_put_output, }, args => [ $index ], ); } # Spawn a quick and dirty session to test a new bug found in # _internal_select. POE::Session->create( inline_states => { _start => sub { my $conduit; $conduit = "inet" if $^O eq "MSWin32"; my ($r, $w) = POE::Pipe::OneWay->new($conduit); my $kernel = $_[KERNEL]; $kernel->select_read($r, "input"); $kernel->select_write($r, "output"); $kernel->select_write($r); $kernel->select_write($r, "output"); $kernel->select($r); }, _stop => sub { }, }, ); # Now run them until they're done. POE::Kernel->run(); # Try a re-entrant version. POE::Session->create( inline_states => { _start => sub { $_[HEAP]->{count} = 0; $_[KERNEL]->yield("increment"); }, increment => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; if ($heap->{count} < 10) { $kernel->yield("increment"); $heap->{count}++; } }, _stop => sub { ok( $_[HEAP]->{count} == 10, "re-entered event loop ran" ); }, } ); # Verify that the main loop can run yet again. POE::Kernel->run(); pass("second event loop run exited normally"); 1; k_signals.pm100644000765000024 1362112425745722 21242 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 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; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } BEGIN { # We can't "plan skip_all" because that calls exit(). And Tk will # croak if you call BEGIN { exit() }. And that croak will cause # this test to FAIL instead of skip. my $error; if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { $error = "$^O does not support signals"; } elsif ($^O eq "MacOS" and not $ENV{POE_DANTIC}) { $error = "$^O does not support fork"; } if ($error) { print "1..0 # Skip $error\n"; CORE::exit(); } plan tests => 8; } BEGIN { use_ok("POE") } # This is the number of processes to fork. Increase this number if # your system can handle the resource use. Also try increasing it if # you suspect a problem with POE's SIGCHLD handling. Be warned # though: setting this too high can cause timing problems and test # failures on some systems. my $fork_count = 8; use IO::Pipely qw(pipely); my ($pipe_read, $pipe_write) = pipely(); # Set up a signal catching session. This test uses plain fork(2) and # POE's $SIG{CHLD} handler. POE::Session->create( inline_states => { _start => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Clear the status counters, and catch SIGCHLD. $heap->{forked} = $heap->{reaped} = 0; $kernel->sig( CHLD => 'catch_sigchld' ); # Fork some child processes, all to exit at the same time. my $fork_start_time = time(); for (my $child = 0; $child < $fork_count; $child++) { my $child_pid = fork; if (defined $child_pid) { if ($child_pid) { # Parent side keeps track of child IDs. $heap->{forked}++; $heap->{children}->{$child_pid} = 1; } else { # A brief sleep so the parent has more opportunity to # finish forking. sleep 1; # Defensively make sure SIGINT will be fatal. $SIG{INT} = 'DEFAULT'; # Tell the parent we're ready. print $pipe_write "$$\n"; # Wait for SIGINT. sleep 3600; exit; } } else { die "fork error: $!"; } } ok( $heap->{forked} == $fork_count, "forked $heap->{forked} processes (out of $fork_count)" ); # NOTE: This is bad form. We're going to block here until all # children check in, or die trying. my $ready_count = 0; while (<$pipe_read>) { last if ++$ready_count >= $fork_count; } $kernel->yield( 'forking_time_is_up' ); }, _stop => sub { my $heap = $_[HEAP]; # Everything is done. See whether it succeeded. ok( $heap->{reaped} == $heap->{forked}, "reaped $heap->{reaped} processes (out of $heap->{forked})" ); }, catch_sigchld => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Count the child reap. If that's all of them, wait just a # little longer to make sure there aren't extra ones. if (++$heap->{reaped} >= $fork_count) { $kernel->delay( reaping_time_is_up => 0.500 ); } }, forking_time_is_up => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Forking time is over. We kill all the child processes as # immediately as possible. my $kill_count = kill INT => keys(%{$heap->{children}}); ok( $kill_count == $heap->{forked}, "killed $kill_count processes (out of $heap->{forked})" ); # Start the reap timer. This will tell us how long to wait # between CHLD signals. $heap->{reap_start} = time(); # Cap the maximum time for failures. $kernel->delay( reaping_time_is_up => 10 ); }, # Do nothing here. The timer exists just to keep the session # alive. Once it's dispatched, the session can exit. reaping_time_is_up => sub { $_[KERNEL]->sig( CHLD => undef ); }, }, ); # mstevens found a subtle incompatibility between nested sessions and # SIGIDLE. This should be fun to debug, but first I'll add the test # case here. sub spawn_server { POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("server"); }, do_thing => sub { $_[KERNEL]->post($_[SENDER], thing_done => $_[ARG0]); }, _child => sub { 0 }, _stop => sub { 0 }, }, ); } POE::Session->create( inline_states => { _start => sub { spawn_server(); $_[KERNEL]->post(server => do_thing => 1); }, thing_done => sub { 0 }, _child => sub { 0 }, _stop => sub { 0 }, }, ); # See how SIGPIPE gets handled. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->sig(USR1 => "got_usr1"); $_[KERNEL]->sig(PIPE => "got_pipe"); $_[KERNEL]->yield("send_signals"); }, send_signals => sub { ok(kill("USR1", $$) == 1, "sent self SIGUSR1"); ok(kill("PIPE", $$) == 1, "sent self SIGPIPE"); $_[KERNEL]->delay(signal_wait_timeout => 1); }, got_usr1 => sub { $_[HEAP]->{usr1}++; _reduce_signal_wait_timeout($_[HEAP]); }, got_pipe => sub { $_[HEAP]->{pipe}++; _reduce_signal_wait_timeout($_[HEAP]); }, signal_wait_timeout => sub { $_[KERNEL]->sig( USR1 => undef ); $_[KERNEL]->sig( PIPE => undef ); }, _stop => sub { ok($_[HEAP]->{usr1} == 1, "caught SIGUSR1"); ok($_[HEAP]->{pipe} == 1, "caught SIGPIPE"); }, }, ); sub _reduce_signal_wait_timeout { my ($heap) = @_; if ($heap->{usr1} and $heap->{pipe}) { POE::Kernel->delay(signal_wait_timeout => 0.100); } } # Run the tests. POE::Kernel->run(); 1; wheel_run.pm100644000765000024 4375312425745722 21271 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab use strict; use lib qw(./mylib ../mylib); use Socket; use Test::More; # Skip these tests if fork() is unavailable. # We can't test_setup(0, "reason") because that calls exit(). And Tk # will croak if you call BEGIN { exit() }. And that croak will cause # this test to FAIL instead of skip. our $RUNNING_WIN32; BEGIN { my $error; if ($^O eq "MacOS") { $error = "$^O does not support fork"; } if ($^O eq "MSWin32") { eval 'use Win32::Console'; if ($@) { $error = "Win32::Console is required on $^O - try ActivePerl"; } elsif (exists $INC{"Tk.pm"} and not $ENV{POE_DANTIC}) { $error = "$^O with Tk seems to hang on this test"; } elsif (exists $INC{"Event.pm"} and not $ENV{POE_DANTIC}) { $error = "$^O\'s fork() emulation breaks Event"; } elsif (not $ENV{POE_DANTIC}) { $error = "Signal handling on $^O is too fragile - Perl crashes"; } $RUNNING_WIN32 = 1; } if ($error) { plan skip_all => $error; CORE::exit(); } sub STD_TEST_COUNT () { 8 } plan tests => 4 + 15 + 8 + 8 + 4 + #Silent/Open FD tests 8 * STD_TEST_COUNT; } sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw(Wheel::Run Filter::Line); # the child program comes in two varieties: {{{ # - a string suitable for running with system() # - a coderef my ($chld_program_string, $chld_program_coderef); { my $text = <<'END'; my $out = shift; my $err = shift; local $/ = q(!); local $\ = q(!); my $notify_eof_flag = 0; select STDERR; $| = 1; select STDOUT; $| = 1; my $eof_counter = 0; OUTER: while (1) { $eof_counter++; CORE::exit if $eof_counter > 10; while () { chomp; $eof_counter = 0; last OUTER if /^bye/; $notify_eof_flag = 1 if s/^notify eof/out/; print(STDOUT qq($out: $$)) if /^pid/; print(STDOUT qq($out: $_)) if s/^out //; print(STDERR qq($err: $_)) if s/^err //; } } if ($notify_eof_flag) { print(STDOUT qq($out: got eof)); sleep 10; } END $text =~ s/\s+/ /g; my $os_quote = ($^O eq 'MSWin32') ? q(") : q('); $chld_program_string = [ $^X, "-we", "$text CORE::exit 0" ]; $chld_program_coderef = eval "sub { \$! = 1; " . $text . " }"; die $@ if $@; } my $shutdown_program = sub { my $out = shift; my $err = shift; select STDERR; $| = 1; select STDOUT; $| = 1; local $/ = q(!); local $\ = q(!); my $flag = 0; $SIG{ALRM} = sub { die "alarm\n" }; eval { alarm(30); while () { chomp; if (/flag (\d+)/) { $flag = $1 } elsif (/out (\S+)/) { print STDOUT "$out: $1" } } }; alarm(0); if ($@ eq "alarm\n") { print STDOUT "$out: got alarm"; } else { print STDOUT "$out: got eof $flag"; } sleep 1; }; # }}} { # manage a global timeout {{{ sub TIMEOUT_HALFTIME () { 15 } my $timeout_initialized = 0; my $timeout_poked = 0; my $timeout_refs = 0; create_timeout_session(); sub create_timeout_session { my $sess = POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("timeout") and return; $_[KERNEL]->delay(check_timeout => TIMEOUT_HALFTIME); }, check_timeout => sub { unless ($timeout_poked) { warn scalar(localtime), " - inactivity timeout reached!"; CORE::exit 1; } else { $timeout_poked = 0; $_[KERNEL]->delay(check_timeout => TIMEOUT_HALFTIME); } }, try_shutdown => sub { return unless $timeout_refs == 0; $_[KERNEL]->delay(check_timeout => undef); $_[KERNEL]->alias_remove("timeout"); }, _stop => sub { }, # Pacify assertions. }, ); return $sess->ID; } sub timeout_poke { $timeout_poked++; } sub timeout_incref { timeout_poke(); $timeout_refs++; } sub timeout_decref { timeout_poke(); $timeout_refs--; if ($timeout_refs == 0) { $poe_kernel->post("timeout", "try_shutdown"); } } } # }}} { # {{{ a proxy around POE::Filter::Line that doesn't support get_one package My::LineFilter; sub new { my $class = shift; return bless [ POE::Filter::Line->new(@_) ], $class; } sub get { my $s = shift; return $s->[0]->get(@_) } sub put { my $s = shift; return $s->[0]->put(@_) } } # }}} # next follow some event handles that are used in constructing # each session in &create_test_session sub do_nonexistent { warn scalar(localtime), " - $_[STATE] called on session ".$_[SESSION]->ID." ($_[HEAP]->{label})"; CORE::exit 1; } sub do_error { note(scalar(localtime) . " - $_[HEAP]->{label}: $_[ARG0] error $_[ARG1]: $_[ARG2]"); } # {{{ definition of the main test session sub main_perform_state { my $heap = $_[HEAP]; return unless @{$heap->{expected}}; return unless defined $heap->{expected}->[0][0]; my $action = $heap->{expected}->[0][0]; unless (ref $action) { note(scalar(localtime) . " - $heap->{label}: performing put state: $action"); eval { $heap->{wheel}->put( $action ) }; } elsif ($action->[0] =~ m/^(?:pause|resume)_std(?:out|err)$/) { my $method = $action->[0]; note(scalar(localtime) . " - $heap->{label}: performing method state: $method"); $heap->{wheel}->$method(); } elsif ($action->[0] eq "kill") { note(scalar(localtime) . " - $heap->{label}: performing kill"); $heap->{wheel}->kill(); } elsif ($action->[0] eq "shutdown_stdin") { note(scalar(localtime) . " - $heap->{label}: shutdown_stdin"); $heap->{wheel}->shutdown_stdin(); } else { warn scalar(localtime), " - weird action @$action, this is a bug in the test script"; CORE::exit 1; } # sometimes we don't have anything to wait for, so # just perform the next action if (not defined $heap->{expected}->[0][1]) { shift @{$heap->{expected}}; goto &main_perform_state; } } my $main_counter = 0; sub main_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; my ($label, $program, $conduit, $expected) = @_[ARG0..$#_]; $heap->{label} = $label; # Sometimes use a filter without get_one support my $filter_class = "POE::Filter::Line"; if ($main_counter++ % 2) { $filter_class = "My::LineFilter"; } # Run the child process my $no_stderr = (defined $conduit and $conduit eq "pty"); $heap->{wheel} = POE::Wheel::Run->new( Program => $program, ProgramArgs => [ "out$$", "err$$" ], # we assume $program expects this (defined $conduit ? (Conduit => $conduit) : ()), StdioFilter => $filter_class->new( Literal => "!" ), (!$no_stderr ? (StderrFilter => $filter_class->new( Literal => "!" )) : ()), StdoutEvent => 'stdout_nonexistent', (!$no_stderr ? (StderrEvent => 'stderr_nonexistent') : ()), StdinEvent => 'stdin_nonexistent', ErrorEvent => 'error_nonexistent', CloseEvent => 'close_nonexistent', ); # Test event changing. $heap->{wheel}->event( StdoutEvent => 'stdout', (!$no_stderr ? (StderrEvent => 'stderr') : ()), StdinEvent => 'stdin', ); $heap->{wheel}->event( ErrorEvent => 'error', CloseEvent => 'close', ); $_[KERNEL]->sig_child($heap->{wheel}->PID, "sigchld"); # start the test statemachine $heap->{expected} = [@$expected]; &main_perform_state; # Deliberately passing @_ through. $heap->{flushes_expected} = scalar( grep { (!ref $_->[0]) and defined($_->[1]) } @$expected ); $heap->{flushes} = 0; # timeout delay timeout_incref(); note(scalar(localtime) . " - $heap->{label}: _start"); } my $x__ = 0; sub main_stop { my $heap = $_[HEAP]; # Due to loop timing differences, "out delayed1" and "out # immediate2" may sometimes not be flushed together. Allow one # extra flush to account for "out delayed1" going separately. $heap->{flushes_expected}++ if ( $heap->{label} eq 'string/pause_resume' and $heap->{flushes} - $heap->{flushes_expected} == 1 ); is( $heap->{flushes}, $heap->{flushes_expected}, scalar(localtime) . " - $heap->{label} flush count ($$)" ) unless $heap->{ignore_flushes}; note(scalar(localtime) . " - $heap->{label}: _stop ($$)"); } sub main_stdin { my $heap = $_[HEAP]; $heap->{flushes}++; timeout_poke(); note(scalar(localtime) . " - $heap->{label}: stdin flush"); } sub main_output { my ($heap, $state) = @_[HEAP, STATE]; my $input = $_[ARG0]; my $prefix = $heap->{expected}->[0][1][2] . $$; $heap->{expected}->[0][1][1] = $heap->{wheel}->PID unless defined $heap->{expected}->[0][1][1]; is($state, $heap->{expected}->[0][1][0], scalar(localtime) . " - $heap->{label} response type"); is($input, "$prefix: ".$heap->{expected}->[0][1][1], scalar(localtime) . " - $heap->{label} $state response"); note(scalar(localtime) . " - $heap->{label}: $state $input"); timeout_poke(); shift @{$heap->{expected}}; &main_perform_state; } sub main_close { my ($heap, $kernel) = @_[HEAP, KERNEL]; is('close', $heap->{expected}->[0][1][0], scalar(localtime) . " - $heap->{label} close"); is($_[HEAP]->{wheel}->get_driver_out_octets, 0, scalar(localtime) . " - $heap->{label} driver_out_octets at close") unless $heap->{ignore_flushes}; is($_[HEAP]->{wheel}->get_driver_out_messages, 0, scalar(localtime) . " - $heap->{label} driver_out_messages at close") unless $heap->{ignore_flushes}; delete $_[HEAP]->{wheel}; timeout_decref(); $kernel->sig("CHLD" => undef); note(scalar(localtime) . " - $heap->{label}: close"); } sub main_sigchld { my $heap = $_[HEAP]; my ($signame, $child_pid) = @_[ARG0, ARG1]; my $our_child = $heap->{wheel} ? $heap->{wheel}->PID : -1; note( scalar(localtime) . " - $heap->{label}: sigchld $signame for $child_pid ($our_child)" ); return unless $heap->{wheel} and $our_child == $child_pid; # turn it into a close &main_close; } sub create_test_session { my ($label, $program, $conduit, $expected, $ignore_flushes) = @_; my $sess = POE::Session->create( args => [$label, $program, $conduit, $expected], heap => { ignore_flushes => $ignore_flushes }, inline_states => { _start => \&main_start, _stop => \&main_stop, error => \&do_error, close => \&main_close, stdin => \&main_stdin, stdout => \&main_output, stderr => \&main_output, sigchld => \&main_sigchld, stdout_nonexistent => \&do_nonexistent, stderr_nonexistent => \&do_nonexistent, stdin_nonexistent => \&do_nonexistent, error_nonexistent => \&do_nonexistent, close_nonexistent => \&do_nonexistent, }, ); return $sess->ID; } # }}} # {{{ Constructor tests sub create_constructor_session { my $sess = POE::Session->create( inline_states => { _start => sub { eval { POE::Wheel::Run->new( Program => sub { 1; }, Conduit => 'wibble-magic-pipe', StdoutEvent => 'stdout_event', ErrorEvent => 'error_event', ); }; ok(!(!$@), scalar(localtime) . " - new: only valid conduits"); eval { POE::Wheel::Run->new( Program => sub { 1; }, Filter => POE::Filter::Line->new( Literal => "!" ), StdioFilter => POE::Filter::Line->new( Literal => "!" ), StdoutEvent => 'stdout_event', ErrorEvent => 'error_event', ); }; ok(!(!$@), scalar(localtime) . " - new: cannot mix deprecated Filter with StdioFilter"); eval { POE::Wheel::Run->new( ProgramArgs => [ "out$$", "err$$" ], Conduit => "pty", StdioFilter => POE::Filter::Line->new( Literal => "!" ), StderrFilter => POE::Filter::Line->new( Literal => "!" ), StdoutEvent => 'stdout_nonexistent', StderrEvent => 'stderr_nonexistent', StdinEvent => 'stdin_nonexistent', ErrorEvent => 'error_nonexistent', CloseEvent => 'close_nonexistent', ); }; ok(!(!$@), scalar(localtime) . " - new: Program is needed"); eval { POE::Wheel::Run->new( Program => sub { 0 }, StdoutEvent => "stdout_nonexistent", RedirectStdout => "/non/existent" ); }; ok(!(!$@), scalar(localtime) . " - new: *Event and Redirect* are mutually exclusive"); timeout_poke(); }, _stop => sub { }, # Pacify assertions. }, ); return $sess->ID; } # }}} # Main program: Create test sessions {{{ my @one_stream_expected = ( [ "out test-out", ["stdout", "test-out", "out"] ], [ "err test-err", ["stdout", "test-err", "err"] ], # std*out* not stderr [ "bye", ["close"] ], ); my @two_stream_expected = ( [ "out test-out", ["stdout", "test-out", "out"] ], [ "err test-err", ["stderr", "test-err", "err"] ], [ "bye", ["close"] ], ); my @pause_resume_expected = ( [ "out init", ["stdout", "init", "out"] ], [ ["pause_stdout"], undef ], [ "out delayed1", undef ], [ "err immediate1", ["stderr", "immediate1", "err"] ], [ ["pause_stderr"], undef ], [ "err delayed2", undef ], [ ["resume_stdout"], ["stdout", "delayed1", "out"] ], [ "out immediate2", ["stdout", "immediate2", "out"] ], [ ["resume_stderr"], ["stderr", "delayed2", "err"] ], [ "out immediate3", ["stdout", "immediate3", "out"] ], [ "err immediate4", ["stderr", "immediate4", "err"] ], [ "bye", ["close"] ], ); my @killing_expected = ( [ "out init", ["stdout", "init", "out"] ], [ "pid", ["stdout", undef, "out"] ], [ ["kill"], ["close"] ], ); my @shutdown_expected = ( [ "flag 1", undef], [ "out init", ["stdout", "init", "out"] ], [ ["shutdown_stdin"], undef], [ "flag 2", ["stdout", "got eof 1", "out"] ], [ ["kill"], ["close"] ], ); my @chld_programs = ( ["string", $chld_program_string], ["coderef", $chld_program_coderef], ); # create constructor test session create_constructor_session(); # test pausing/resuming for both stdout and stderr create_test_session( "string/pause_resume", $chld_program_string, undef, \@pause_resume_expected, ); SKIP: { skip "PIDs and shutdown don't work on windows", 13 if $RUNNING_WIN32; # testing killing, and PID create_test_session( "string/killing", $chld_program_string, undef, \@killing_expected, ); # needs to be skipped on windows # test shutdown_stdin create_test_session( "coderef/shutdown", $shutdown_program, "pipe", \@shutdown_expected, 1, # ignore flush counts etc ); } sub silent_start { pipe my ($stdout_read,$stdout_write); pipe my ($stdin_read, $stdin_write); my $wheel = POE::Wheel::Run->new( Program => sub { select STDERR; $|=1; select STDOUT; $|=1; eval "print STDOUT 'CHILD:'"; eval 'my $input = ; chomp($input); print STDERR $input;'; eval 'print STDERR "DONE:";'; close STDOUT; close STDERR; exit(0); }, RedirectOutput => $stdout_write, RedirectStdin => $stdin_read ); select $stdin_write; $|=1; $_[HEAP]->{silent_fdes} = [$stdout_read, $stdin_write]; $_[HEAP]->{silent_wheel} = $wheel; print $stdin_write "PARENT:\n"; $poe_kernel->select_read($stdout_read, 'silent_got_stdout'); $poe_kernel->sig_child($wheel->PID, 'silent_sigchld'); my $no_stdio = POE::Wheel::Run->new( Program => \¬e ); $poe_kernel->sig_child($no_stdio->PID, 'silent_sigchld'); ok(!($no_stdio->[ $no_stdio->HANDLE_STDOUT ] || $no_stdio->[ $no_stdio->HANDLE_STDERR ]), scalar(localtime) . "stdio/standard output handles closed without events"); ok($no_stdio->[ $no_stdio->HANDLE_STDIN ], scalar(localtime) . "stdio discard/STDIN still alive"); $no_stdio = POE::Wheel::Run->new( Program => \¬e, NoStdin => 1 ); $poe_kernel->sig_child($no_stdio->PID, 'silent_sigchld'); ok(!($no_stdio->[ $no_stdio->HANDLE_STDIN ]), scalar(localtime) . "stdio/discarded STDIN with NoStdin"); } sub _silent_check_common { my ($fh,$re,$desc,$a,$term) = @_; sysread($fh, my $buf = "", 8192); if( $a ) { $$a = '' unless defined $$a; $$a .= $buf; return unless $$a =~ $term; } like($buf, $re, $desc); $poe_kernel->select_read($fh); close($fh); } my $ACCUME; sub silent_got_stdout { _silent_check_common( $_[ARG0], qr/CHILD:PARENT:DONE:/, "stdio/redirection", \$ACCUME, qr/DONE/ ); } sub silent_fd_status { _silent_check_common( $_[ARG0], qr/STDERR:-1,STDIN:-1,STDOUT:-1/, "stdio closed in child"); } sub silent_sigchld { #dummy.. } sub silent_test { #Use pipes here for redirection. my $sess = POE::Session->create( inline_states => { _start => \&silent_start, _stop => sub { }, #_stop => sub { note scalar(localtime) . " - Stopped!" }, silent_got_stdout => \&silent_got_stdout, silent_fd_status => \&silent_fd_status, silent_sigchld => \&silent_sigchld } ); } for my $chld_program (@chld_programs) { my ($chld_name, $chld_code) = @$chld_program; create_test_session( "$chld_name/default", $chld_code, # program undef, # conduit \@two_stream_expected # expected ); SKIP: { skip "$chld_name/pipe: doesn't work on windows", STD_TEST_COUNT if $RUNNING_WIN32; create_test_session( "$chld_name/pipe", $chld_code, # program "pipe", # conduit \@two_stream_expected # expected ); } SKIP: { skip "$chld_name/pty: IO::Pty is needed for this test.", 2*STD_TEST_COUNT unless POE::Wheel::Run::PTY_AVAILABLE; skip "$chld_name/pty: The underlying event loop has trouble with ptys on $^O", 2*STD_TEST_COUNT if $^O eq "darwin" and ( exists $INC{"POE/Loop/IO_Poll.pm"} or exists $INC{"POE/Loop/Event.pm"} or $ENV{POE_LOOP_USES_POLL} ); create_test_session( "$chld_name/pty", $chld_code, # program "pty", # conduit \@one_stream_expected # expected ); create_test_session( "$chld_name/pty-pipe", $chld_code, # program "pty-pipe", # conduit \@two_stream_expected # expected ); } } # }}} silent_test(); $poe_kernel->run; 1; all_errors.pm100644000765000024 2401012425745722 21426 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests error conditions. This has to be a separate test since it # depends on ASSERT_DEFAULT being 0. All the other tests enable it. use strict; use lib qw(./mylib ../mylib); sub POE::Kernel::ASSERT_DEFAULT () { 0 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } # use Test::More; print "1..0 # Skip most of these should move into other test files\n"; #use POSIX qw(:errno_h); #use Socket; # #BEGIN { # my @files_to_unuse = qw( # POE/Kernel.pm # # POE/Loop/Event.pm # POE/Loop/Gtk.pm # POE/Loop/Poll.pm # POE/Loop/Select.pm # POE/Loop/Tk.pm # # POE/Loop/PerlSignals.pm # POE/Loop/TkCommon.pm # POE/Loop/TkActiveState.pm # # Event.pm Gtk.pm Tk.pm # ); # # # Clean up after destructive tests. # sub test_cleanup { # # Not used in POE::Kernel now. # # delete @INC{ @files_to_unuse }; # use Symbol qw(delete_package); # delete_package("POE::Kernel"); # } # # # Test that errors occur when multiple event loops are enabled. # # if ($^O eq 'MSWin32' and not $ENV{POE_DANTIC}) { # for (1..3) { # print "ok $_ # skipped: This test crashes ActiveState Perl.\n"; # } # } # else { # # Event + Tk # @INC{'Event.pm', 'Tk.pm'} = (1,1); # $Tk::VER .. SION = 800.021; # stderr_pause(); # eval 'use POE::Kernel'; # stderr_resume(); # print 'not ' unless defined $@ and length $@; # print "ok 1\n"; # test_cleanup(); # # # Gtk + Tk # @INC{'Gtk.pm', 'Tk.pm'} = (1, 1); # $Tk::VER .. SION = 800.021; # stderr_pause(); # eval 'use POE::Kernel'; # stderr_resume(); # print 'not ' unless defined $@ and length $@; # print "ok 2\n"; # test_cleanup(); # # # Event + Gtk # @INC{'Event.pm', 'Gtk.pm'} = (1, 1); # stderr_pause(); # eval 'use POE::Kernel'; # stderr_resume(); # print 'not ' unless defined $@ and length $@; # print "ok 3\n"; # test_cleanup(); # } #} # ## Make these runtime so they occur after the above tests. # #use POE::Session; #use POE::Kernel; #use POE::Component::Server::TCP; #use POE::Wheel::SocketFactory; # ## Test that errors occur when nonexistent modules are used. #stderr_pause(); #eval 'use POE qw(NonExistent);'; #stderr_resume(); #print "not " unless defined $@ and length $@; #print "ok 4\n"; # ## Test that an error occurs when trying to instantiate POE directly. #eval 'my $x = new POE;'; #print "not " unless defined $@ and length $@; #print "ok 5\n"; # #### Test state machine. # #sub test_start { # my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; # # ### Aliases. # # # Test error handling for the Kernel's call() method. # $! = 0; # print "not " # if defined $kernel->call( 1000 => 'nonexistent' ) or $! != ESRCH; # print "ok 8\n"; # # # Test error handling for the Kernel's post() method. # $! = 0; # print "not " # if defined $kernel->post( 1000 => 'nonexistent' ) or $! != ESRCH; # print "ok 9\n"; # # # Failed alias addition. # print "not " if $kernel->alias_set( 'kernel_alias' ) != EEXIST; # print "ok 10\n"; # # # Failed alias removal. Not allowed to remove one from another # # session. # print "not " if $kernel->alias_remove( 'kernel_alias' ) != EPERM; # print "ok 11\n"; # # # Failed alias removal. Not allowed to remove one that doesn't # # exist. # print "not " if $kernel->alias_remove( 'yatta yatta yatta' ) != ESRCH; # print "ok 12\n"; # # ### IDs # # # Test failed ID->session and session->ID lookups. # $! = 0; # print "not " if defined $kernel->ID_id_to_session( 1000 ) or $! != ESRCH; # print "ok 13\n"; # # print "not " if defined $kernel->ID_session_to_id( 1000 ) or $! != ESRCH; # print "ok 14\n"; # # ### Signals. # # # Test failed signal() call. # $! = 0; # print "not " if defined $kernel->signal( 1000 => 'BOOGA' ) or $! != ESRCH; # print "ok 15\n"; # # ### Extra references. # $! = 0; # print 'not ' if defined $kernel->refcount_increment( 'tag' ) or $! != ESRCH; # print "ok 16\n"; # # $! = 0; # print 'not ' if defined $kernel->refcount_decrement( 'tag' ) or $! != ESRCH; # print "ok 17\n"; #} # ## Did we get this far? # #print "ok 6\n"; # #print "not " if $POE::Kernel::poe_kernel->alias_set( 'kernel_alias' ); #print "ok 7\n"; # #POE::Session->create # ( inline_states => # { _start => \&test_start, # } # ); # #print "not " if $POE::Kernel::poe_kernel->alias_remove( 'kernel_alias' ); #print "ok 18\n"; # #print "not " # unless $POE::Kernel::poe_kernel->state( woobly => sub { die } ) == ESRCH; #print "ok 19\n"; # #### TCP Server problems. # #{ my $warnings = 0; # local $SIG{__WARN__} = sub { $warnings++; }; # # POE::Component::Server::TCP->new # ( Port => -1, # Acceptor => sub { die }, # Nonexistent => 'woobly', # ); # # print "not " unless $warnings == 1; # print "ok 20\n"; #} # #### SocketFactory problems. # #{ my $warnings = 0; # local $SIG{__WARN__} = sub { $warnings++; }; # # # Grar! No UNIX sockets on Windows. # if ($^O eq 'MSWin32' and not $ENV{POE_DANTIC}) { # print "ok 21 # skipped: $^O does not support listen on unbound sockets.\n"; # print "ok 22 # skipped: $^O does not support UNIX sockets.\n"; # } # else { # # Odd parameters. # # # Cygwin behaves differently. # if ($^O eq "cygwin") { # print # "ok 21 # skipped: $^O does not support listen on unbound sockets.\n"; # } # else { # POE::Wheel::SocketFactory->new # ( SuccessEvent => [ ], # FailureEvent => [ ], # ); # # print "not " unless $warnings == 2; # print "ok 21\n"; # } # # # Any protocol on UNIX sockets. # $warnings = 0; # POE::Wheel::SocketFactory->new # ( SocketDomain => AF_UNIX, # SocketProtocol => "tcp", # SuccessEvent => "okay", # FailureEvent => "okay", # ); # # print "not " unless $warnings == 1; # print "ok 22\n"; # } # # # Unsupported protocol for an address family. # eval( 'POE::Wheel::SocketFactory->new ' . # '( SocketDomain => AF_INET,' . # ' SocketProtocol => "icmp",' . # ' SuccessEvent => "okay",' . # ' FailureEvent => "okay",' . # ');' # ); # print 'not ' unless defined $@ and length $@; # print "ok 23\n"; #} # #### Main loop. # #stderr_pause(); #$POE::Kernel::poe_kernel->run(); #stderr_resume(); # #### Misuse of unusable modules. # #use POE::Wheel; # #eval 'POE::Wheel->new'; #print 'not ' unless defined $@ and length $@; #print "ok 24\n"; # #use POE::Component; # #eval 'POE::Component->new'; #print 'not ' unless defined $@ and length $@; #print "ok 25\n"; # #use POE::Driver; # #eval 'POE::Driver->new'; #print 'not ' unless defined $@ and length $@; #print "ok 26\n"; # #use POE::Filter; # #eval 'POE::Filter->new'; #print 'not ' unless defined $@ and length $@; #print "ok 27\n"; # #### Misuse of usable modules. # #use POE::Driver::SysRW; # #eval 'POE::Driver::SysRW->new( 1 )'; #print 'not ' unless defined $@ and length $@; #print "ok 28\n"; # #eval 'POE::Driver::SysRW->new( Booga => 1 )'; #print 'not ' unless defined $@ and length $@; #print "ok 29\n"; # #eval 'use POE::Filter::HTTPD;'; #unless (defined $@ and length $@) { # my $pfhttpd = POE::Filter::HTTPD->new(); # # eval '$pfhttpd->get_pending()'; # print 'not ' unless defined $@ and length $@; # print "ok 30\n"; #} #else { # print "ok 30 # skipped: libwww-perl and URI are needed for this test.\n"; #} # ## POE::Session constructor stuff. # #eval 'POE::Session->create( 1 )'; #print 'not ' unless defined $@ and length $@; #print "ok 31\n"; # #eval 'POE::Session->create( options => [] )'; #print 'not ' unless defined $@ and length $@; #print "ok 32\n"; # #eval 'POE::Session->create( inline_states => [] )'; #print 'not ' unless defined $@ and length $@; #print "ok 33\n"; # #eval 'POE::Session->create( inline_states => { _start => 1 } )'; #print 'not ' unless defined $@ and length $@; #print "ok 34\n"; # #eval 'POE::Session->create( package_states => {} )'; #print 'not ' unless defined $@ and length $@; #print "ok 35\n"; # #eval 'POE::Session->create( package_states => [ 1 ] )'; #print 'not ' unless defined $@ and length $@; #print "ok 36\n"; # #eval 'POE::Session->create( package_states => [ main => 1 ] )'; #print 'not ' unless defined $@ and length $@; #print "ok 37\n"; # #eval 'POE::Session->create( object_states => {} )'; #print 'not ' unless defined $@ and length $@; #print "ok 38\n"; # #eval 'POE::Session->create( object_states => [ 1 ] )'; #print 'not ' unless defined $@ and length $@; #print "ok 39\n"; # #eval 'POE::Session->create( package_states => [ main => 1 ] )'; #print 'not ' unless defined $@ and length $@; #print "ok 40\n"; # #eval 'POE::Session->new( 1 )'; ### DEPRECATED #print 'not ' unless defined $@ and length $@; #print "ok 41\n"; # #eval 'POE::Session->new( _start => 1 )'; #print 'not ' unless defined $@ and length $@; #print "ok 42\n"; # #eval 'POE::Session->new( sub {} => 1 )'; #print 'not ' unless defined $@ and length $@; #print "ok 43\n"; # #use POE::Wheel::FollowTail; #use POE::Filter::Stream; # #eval 'POE::Wheel::FollowTail->new( )'; #print 'not ' unless defined $@ and length $@; #print "ok 44\n"; # #eval 'POE::Wheel::FollowTail->new( Handle => \*STDIN )'; #print 'not ' unless defined $@ and length $@; #print "ok 45\n"; # #eval( 'POE::Wheel::FollowTail->new( Handle => \*STDIN,' . # ' Driver => POE::Driver::SysRW->new(),' . # ')' # ); #print 'not ' unless defined $@ and length $@; #print "ok 46\n"; # #eval( 'POE::Wheel::FollowTail->new( Handle => \*STDIN,' . # ' Driver => POE::Driver::SysRW->new(),' . # ' Filter => POE::Filter::Stream->new(),' . # ')' # ); #print 'not ' unless defined $@ and length $@; #print "ok 47\n"; # #if (($^O ne 'MSWin32' and $^O ne 'MacOS') or $ENV{POE_DANTIC}) { # require POE::Wheel::Run; # POE::Wheel::Run->import(); # # eval 'POE::Wheel::Run->new( 1 )'; # print 'not ' unless defined $@ and length $@; # print "ok 48\n"; # # eval 'POE::Wheel::Run->new( Program => 1 )'; # print 'not ' unless defined $@ and length $@; # print "ok 49\n"; #} #else { # for (48..49) { # print "ok $_ # skipped: $^O does not support POE::Wheel::Run.\n"; # } #} 1; wheel_tail.pm100644000765000024 2145212425745722 21406 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises Wheel::FollowTail, Wheel::ReadWrite, and Filter::Block. # TODO - Needs tests for Seek and SeekBack. use strict; use lib qw(./mylib ../mylib); use Socket; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More; plan tests => 10; use POE qw( Component::Server::TCP Wheel::FollowTail Wheel::ReadWrite Wheel::SocketFactory Filter::Line Filter::Block Driver::SysRW ); sub DEBUG () { 0 } my $tcp_server_port; my $max_send_count = 10; # expected to be even ############################################################################### # A generic server session. sub sss_new { my ($socket, $peer_addr, $peer_port) = @_; POE::Session->create( inline_states => { _start => \&sss_start, _stop => \&sss_stop, got_error => \&sss_error, got_block => \&sss_block, ev_timeout => sub { DEBUG and warn "=== handle tail got timeout"; delete $_[HEAP]->{wheel}; }, }, args => [ $socket, $peer_addr, $peer_port ], ); } sub sss_start { my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0..ARG2]; delete $heap->{wheel}; $heap->{wheel} = POE::Wheel::FollowTail->new( Handle => $socket, Driver => POE::Driver::SysRW->new( BlockSize => 24 ), Filter => POE::Filter::Block->new( BlockSize => 16 ), InputEvent => 'got_block_nonexistent', ErrorEvent => 'got_error_nonexistent', ); # Test event changing. $heap->{wheel}->event( InputEvent => 'got_block', ErrorEvent => 'got_error', ); $heap->{test_two} = 1; $heap->{wheel_id} = $heap->{wheel}->ID; $heap->{read_count} = 0; } sub sss_block { my ($kernel, $heap, $block) = @_[KERNEL, HEAP, ARG0]; DEBUG and warn "=== handle tail got block ($block)"; if ($block eq 'DONEDONEDONEDONE') { $kernel->delay( ev_timeout => 1 ); return; } $heap->{read_count}++; $kernel->delay( ev_timeout => 10 ); } sub sss_error { my ($heap, $syscall, $errnum, $errstr, $wheel_id) = @_[HEAP, ARG0..ARG3]; DEBUG and warn "=== handle tail got $syscall error $errnum: $errstr"; $_[HEAP]->{test_two} = 0 if $errnum; } sub sss_stop { my $heap = $_[HEAP]; DEBUG and warn "=== handle tail stopped"; ok($heap->{test_two}, "handle tail test two"); is( $heap->{read_count}, $max_send_count, "handle tail read everything we were sent " . "did($heap->{read_count}) wanted($max_send_count)" ); } ############################################################################### # A TCP socket client. sub client_tcp_start { my $heap = $_[HEAP]; DEBUG and warn "=== client tcp started"; $heap->{wheel} = POE::Wheel::SocketFactory->new( RemoteAddress => '127.0.0.1', RemotePort => $tcp_server_port, SuccessEvent => 'got_server_nonexistent', FailureEvent => 'got_error_nonexistent', ); # Test event changing. $heap->{wheel}->event( SuccessEvent => 'got_server', FailureEvent => 'got_error', ); $heap->{socketfactory_wheel_id} = $heap->{wheel}->ID; $heap->{test_three} = 1; } sub client_tcp_stop { my $heap =$_[HEAP]; ok( $heap->{test_three}, "test three" ); ok( $heap->{put_count} == $max_send_count, "sent everything we should" ); my $sent_count = $_[HEAP]->{put_count} / 2; ok( $heap->{flush_count} == $sent_count, "flushed what we sent (flush=$heap->{flush_count}; sent=$sent_count)" ); ok( $heap->{test_six}, "test six" ); } sub client_tcp_connected { my ($kernel, $heap, $server_socket) = @_[KERNEL, HEAP, ARG0]; delete $heap->{wheel}; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $server_socket, Driver => POE::Driver::SysRW->new( BlockSize => 32 ), Filter => POE::Filter::Block->new( BlockSize => 16 ), ErrorEvent => 'got_error_nonexistent', FlushedEvent => 'got_flush_nonexistent', ); DEBUG and warn "=== client tcp connected"; # Test event changing. $heap->{wheel}->event( ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); $heap->{test_six} = 1; $heap->{readwrite_wheel_id} = $heap->{wheel}->ID; $heap->{flush_count} = 0; $heap->{put_count} = 0; $kernel->yield( 'next_send' ); } sub client_tcp_next_send { my ($kernel, $heap, $line) = @_[KERNEL, HEAP, ARG0]; DEBUG and warn "=== client tcp got alarm"; $heap->{wheel}->put( '0123456789ABCDEF0123456789ABCDEF' ); $heap->{put_count} += 2; # Trigger shutdown after the last test send. if ($heap->{put_count} >= $max_send_count) { $heap->{wheel}->put( 'DONEDONEDONEDONE' ); } } sub client_tcp_got_error { my ($heap, $operation, $errnum, $errstr, $wheel_id) = @_[HEAP, ARG0..ARG3]; if ($wheel_id == $heap->{socketfactory_wheel_id}) { $heap->{test_three} = 0; } if ($wheel_id == $heap->{readwrite_wheel_id}) { $heap->{test_six} = 0; } delete $heap->{wheel}; warn "$operation error $errnum: $errstr"; } sub client_tcp_got_flush { $_[HEAP]->{flush_count}++; DEBUG and warn "=== client_tcp_got_flush"; if ($_[HEAP]->{put_count} < $max_send_count) { # Puts a little delay between puts. $_[KERNEL]->delay( next_send => 0.100 ); } else { # Delays destruction until all data is out. delete $_[HEAP]->{wheel}; } } ############################################################################### # Start the TCP server and client. SKIP: { unless (-f "run_network_tests") { skip "network access (and permission) required to run this test", 7; } POE::Component::Server::TCP->new( Port => 0, Address => '127.0.0.1', Acceptor => sub { &sss_new(@_[ARG0..ARG2]); # This next badness is just for testing. my $sockname = $_[HEAP]->{listener}->getsockname(); delete $_[HEAP]->{listener}; my ($port, $addr) = sockaddr_in($sockname); $addr = inet_ntoa($addr); ok( ($addr eq '127.0.0.1') && ($port == $tcp_server_port), "received connection" ); }, Started => sub { $tcp_server_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, ); POE::Session->create( inline_states => { _start => \&client_tcp_start, _stop => \&client_tcp_stop, got_server => \&client_tcp_connected, got_error => \&client_tcp_got_error, got_flush => \&client_tcp_got_flush, next_send => \&client_tcp_next_send, } ); } ### Test a file that appears and disappears. SKIP: { if (($^O eq 'MSWin32' or $^O eq 'cygwin') and not $ENV{POE_DANTIC}) { skip "Can't test file reset on $^O because the OS locks opened files", 2; } POE::Session->create( inline_states => { _start => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; unlink "./test-tail-file"; $heap->{wheel} = POE::Wheel::FollowTail->new( Filter => POE::Filter::Line->new(Literal => "\n"), Filename => "./test-tail-file", InputEvent => "got_input", ErrorEvent => "got_error", ResetEvent => "got_reset", IdleEvent => "create_file", PollInterval => 0.500, ); $heap->{sent_count} = 0; $heap->{recv_count} = 0; $heap->{reset_count} = 0; DEBUG and warn "=== file tail start"; }, create_file => sub { open(FH, ">./test-tail-file") or die $!; print FH "moo\n"; close FH; DEBUG and warn "=== file tail create file"; $_[HEAP]->{sent_count}++; # Make file creation a one-shot occurrence. $_[HEAP]->{wheel}->event( IdleEvent => undef ); }, got_input => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{recv_count}++; DEBUG and warn "=== file tail input: $_[ARG0]\n"; unlink "./test-tail-file"; if ($heap->{recv_count} == 1) { # Trigger a new one-shot file creation. $heap->{wheel}->event( IdleEvent => 'create_file' ); return; } delete $heap->{wheel}; }, got_error => sub { warn "$_[ARG0] error $_[ARG1]: $_[ARG2]"; die }, got_reset => sub { DEBUG and warn "=== file tail got reset"; $_[HEAP]->{reset_count}++; }, _stop => sub { DEBUG and warn "=== file tail stop"; my $heap = $_[HEAP]; ok( ($heap->{sent_count} == $heap->{recv_count}) && ($heap->{sent_count} == 2), "file tail sent and received everything we should " . "sent($heap->{sent_count}) recv($heap->{recv_count}) wanted(2)" ); is($heap->{reset_count}, 2, "file tail resets detected"); }, }, ); } ### main loop POE::Kernel->run(); pass("run() returned successfully"); 1; k_sig_child.pm100644000765000024 1270412425745722 21530 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 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; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } # This is the number of processes to fork. Increase this number if # your system can handle the resource use. Also try increasing it if # you suspect a problem with POE's SIGCHLD handling. Be warned # though: setting this too high can cause timing problems and test # failures on some systems. use constant FORK_COUNT => 8; BEGIN { # We can't "plan skip_all" because that calls exit(). And Tk will # croak if you call BEGIN { exit() }. And that croak will cause # this test to FAIL instead of skip. my $error; if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { $error = "$^O does not support signals"; } elsif ($^O eq "MacOS" and not $ENV{POE_DANTIC}) { $error = "$^O does not support fork"; } if ($error) { print "1..0 # Skip $error\n"; CORE::exit(); } plan tests => FORK_COUNT+ 7; } use IO::Pipely qw(pipely); my ($pipe_read, $pipe_write) = pipely(); BEGIN { use_ok("POE") } # Set up a second session that watches for child signals. This is to # test whether a session with only sig_child() stays alive because of # the signals. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set("catcher") }, catch => sub { my ($kernel, $heap, $pid) = @_[KERNEL, HEAP, ARG0]; $kernel->sig(CHLD => "got_sigchld"); $kernel->sig_child($pid, "got_chld"); $heap->{children}{$pid} = 1; $heap->{watched}++; }, remove_alias => sub { $_[KERNEL]->alias_remove("catcher") }, got_chld => sub { my ($heap, $pid) = @_[HEAP, ARG1]; ok(delete($heap->{children}{$pid}), "caught SIGCHLD for watched pid $pid"); $heap->{caught}++; }, got_sigchld => sub { $_[HEAP]->{caught_sigchld}++; }, _stop => sub { my $heap = $_[HEAP]; ok( $heap->{watched} == $heap->{caught}, "expected $heap->{watched} reaped children, got $heap->{caught}" ); ok( $heap->{watched} == $heap->{caught_sigchld}, "expected $heap->{watched} sig(CHLD), got $heap->{caught_sigchld}" ); ok(!keys(%{$heap->{children}}), "all reaped children were watched"); }, }, ); # Set up a signal catching session. This test uses plain fork(2) and # POE's $SIG{CHLD} handler. POE::Session->create( inline_states => { _start => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Clear the status counters, and catch SIGCHLD. $heap->{forked} = $heap->{reaped} = 0; # Fork some child processes, all to exit at the same time. my $fork_start_time = time(); for (my $child = 0; $child < FORK_COUNT; $child++) { my $child_pid = fork; if (defined $child_pid) { if ($child_pid) { # Parent side keeps track of child IDs. $heap->{forked}++; $heap->{children}{$child_pid} = 1; $kernel->sig_child($child_pid, "catch_sigchld"); $kernel->post(catcher => catch => $child_pid); } else { # A brief sleep so the parent has more opportunity to # finish forking. sleep 1; # Defensively make sure SIGINT will be fatal. $SIG{INT} = 'DEFAULT'; # Tell the parent we're ready. print $pipe_write "$$\n"; # Wait for SIGINT. sleep 3600; exit; } } else { die "fork error: $!"; } } ok( $heap->{forked} == FORK_COUNT, "forked $heap->{forked} processes (out of " . FORK_COUNT . ")" ); # NOTE: This is bad form. We're going to block here until all # children check in, or die trying. my $ready_count = 0; while (<$pipe_read>) { last if ++$ready_count >= FORK_COUNT; } $kernel->yield( 'forking_time_is_up' ); }, _stop => sub { my $heap = $_[HEAP]; # Everything is done. See whether it succeeded. ok( $heap->{reaped} == $heap->{forked}, "reaped $heap->{reaped} processes (out of $heap->{forked})" ); }, catch_sigchld => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Count the child reap. If that's all of them, wait just a # little longer to make sure there aren't extra ones. if (++$heap->{reaped} >= FORK_COUNT) { $kernel->delay( reaping_time_is_up => 0.500 ); } }, forking_time_is_up => sub { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Forking time is over. We kill all the child processes as # immediately as possible. my $kill_count = kill INT => keys(%{$heap->{children}}); ok( $kill_count == $heap->{forked}, "killed $kill_count processes (out of $heap->{forked})" ); # Start the reap timer. This will tell us how long to wait # between CHLD signals. $heap->{reap_start} = time(); # Cap the maximum time for failures. $kernel->delay( reaping_time_is_up => 10 ); }, # Do nothing here. The timer exists just to keep the session # alive. Once it's dispatched, the session can exit. reaping_time_is_up => sub { undef }, }, ); # Run the tests. POE::Kernel->run(); 1; ses_session.pm100644000765000024 4231212425745722 21624 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Tests basic compilation and events. 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 => 41; use POE; diag("This test generates some STDERR during trace testing."); ### Test parameters and results. my $machine_count = 10; my $event_count = 5; my $sigalrm_caught = 0; my $sigpipe_caught = 0; my $sender_count = 0; my $got_heap_count = 0; my $default_count = 0; die "machine count must be even" if $machine_count & 1; ### Status registers for each state machine instance. my ( @completions, @objpack ); #------------------------------------------------------------------------------ # Define a simple state machine. sub task_start { my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0]; $heap->{count} = 0; $kernel->yield( count => $id ); } sub task_run { my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0]; $sender_count++ if $_[SENDER] == $session; if ($heap->{count} & 1) { $kernel->yield( bogus => $id ); # _default } else { $kernel->post( $session, bogus => $id ); # _default } if ( $kernel->call( $session, next_count => $id ) < $event_count ) { if ($heap->{count} & 1) { $kernel->yield( count => $id ); } else { $kernel->post( $session, count => $id ); } } else { $heap->{id} = $id; } } sub task_default { return 0 if $_[ARG0] eq '_signal'; # ignore signals $default_count++ if $_[STATE] eq '_default'; } sub task_next_count { my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0]; ++$heap->{count}; } sub task_stop { $completions[$_[HEAP]->{id}] = $_[HEAP]->{count}; $got_heap_count++ if ( defined($_[HEAP]->{got_heap}) and $_[HEAP]->{got_heap} == $_[HEAP]->{id} ); } #------------------------------------------------------------------------------ # Test simple signals. # Spawn a quick state machine to test signals. This is a classic # example of inline states being just that: inline anonymous coderefs. # It makes quick hacks quicker! POE::Session->create( inline_states => { _start => sub { $_[HEAP]->{kills_to_go} = $event_count; $_[KERNEL]->sig( ALRM => 'sigalrm_target' ); $_[KERNEL]->sig( PIPE => 'sigpipe_target' ); $_[KERNEL]->delay( fire_signals => 0.5 ); }, fire_signals => sub { if ($_[HEAP]->{kills_to_go}--) { $_[KERNEL]->delay( fire_signals => 0.5 ); if ($^O eq 'MSWin32') { $_[KERNEL]->signal( $_[KERNEL], 'ALRM' ); $_[KERNEL]->signal( $_[KERNEL], 'PIPE' ); } else { kill ALRM => $$; kill PIPE => $$; } } # One last timer so the session lingers long enough to catch # the final signal. else { $_[KERNEL]->delay( done_waiting => 1 ); } }, sigalrm_target => sub { $sigalrm_caught++ if $_[ARG0] eq 'ALRM'; $_[KERNEL]->sig_handled(); }, sigpipe_target => sub { $sigpipe_caught++ if $_[ARG0] eq 'PIPE'; $_[KERNEL]->sig_handled(); }, done_waiting => sub { $_[KERNEL]->sig( ALRM => undef ); $_[KERNEL]->sig( PIPE => undef ); }, _stop => sub { }, # Pacify assertions. } ); # Spawn ten state machines. for (my $i=0; $i<$machine_count; $i++) { POE::Session->create( inline_states => { _start => \&task_start, _stop => \&task_stop, count => \&task_run, next_count => \&task_next_count, _default => \&task_default, }, args => [ $i ], heap => { got_heap => $i }, ); } #------------------------------------------------------------------------------ # Simple client/server sessions using events as inter-session # communications. Tests postbacks, too. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->alias_set( 'server' ); $_[HEAP]->{response} = 0; }, sync_query => sub { $_[ARG0]->( ++$_[HEAP]->{response} ); }, query => sub { $_[ARG0]->( ++$_[HEAP]->{response} ); }, _stop => sub { }, # Pacify assertions. }, ); # A simple client session. It requests five counts and then stops. # Its magic is that it passes a postback for the response. my $postback_test = 1; my $callback_test = 1; POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield( 'query' ); $_[HEAP]->{cookie} = 0; }, query => sub { $_[KERNEL]->post( server => query => $_[SESSION]->postback(response => ++$_[HEAP]->{cookie}) ); $_[HEAP]->{sync_called_back} = 0; $_[KERNEL]->call( server => sync_query => $_[SESSION]->callback(sync_response => ++$_[HEAP]->{cookie}) ); $callback_test = 0 unless $_[HEAP]->{sync_called_back}; }, sync_response => sub { my ($req, $rsp) = ($_[ARG0]->[0], $_[ARG1]->[0] + 1); $callback_test = 0 unless $req == $rsp; $_[HEAP]->{sync_called_back} = 1; }, response => sub { my ($req, $rsp) = ($_[ARG0]->[0], $_[ARG1]->[0] - 1); $postback_test = 0 unless $req == $rsp; if ($_[HEAP]->{cookie} < 5) { $_[KERNEL]->yield( 'query' ); } }, _stop => sub { is( $_[KERNEL]->get_active_session(), $_[SESSION], "get_active_session within session" ); is( $_[KERNEL]->get_active_session()->get_heap(), $_[HEAP], "get_heap during stop" ); }, } ); #------------------------------------------------------------------------------ # Unmapped package session. package UnmappedPackage; use POE::Session; # for constants sub _start { $_[KERNEL]->yield( 'count' ); $_[HEAP]->{count} = 0; $_[HEAP]->{id} = $_[ARG0]; } sub count { return unless $_[OBJECT] eq __PACKAGE__; $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count; } sub _stop { $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count}; } #------------------------------------------------------------------------------ # Unmapped object session. package UnmappedObject; use POE::Session; # for constants # Trivial constructor. sub new { bless [ ], shift; } sub _start { $_[KERNEL]->yield( 'count' ); $_[HEAP]->{count} = 0; $_[HEAP]->{id} = $_[ARG0]; } sub count { return unless ref($_[OBJECT]) eq __PACKAGE__; $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count; } sub _stop { $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count}; } #------------------------------------------------------------------------------ # Unmapped package session. package MappedPackage; use POE::Session; # for constants sub my_start { $_[KERNEL]->yield( 'count' ); $_[HEAP]->{count} = 0; $_[HEAP]->{id} = $_[ARG0]; } sub my_count { return unless $_[OBJECT] eq __PACKAGE__; $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count; } sub my_stop { $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count}; } #------------------------------------------------------------------------------ # Unmapped object session. package MappedObject; use POE::Session; # for constants # Trivial constructor. sub new { bless [ ], shift; } sub my_start { $_[KERNEL]->yield( 'count' ); $_[HEAP]->{count} = 0; $_[HEAP]->{id} = $_[ARG0]; } sub my_count { return unless ref($_[OBJECT]) eq __PACKAGE__; $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count; } sub my_stop { $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count}; } #------------------------------------------------------------------------------ # Test the Package and Object sessions. package main; # New style (create) object session without event to method name map. POE::Session->create( object_states => [ UnmappedObject->new() => [ '_start', 'count', '_stop' ], ], args => [ 0 ], ); # New style (create) object session with event to method name map. POE::Session->create( object_states => [ MappedObject->new => { _start => 'my_start', count => 'my_count', _stop => 'my_stop', }, ], args => [ 1 ], ); # New style (create) package session without event to method name map. POE::Session->create( package_states => [ UnmappedPackage => [ '_start', 'count', '_stop' ], ], args => [ 2 ], ); # New style (create) package session with event to method name map. POE::Session->create( package_states => [ MappedPackage => { _start => 'my_start', count => 'my_count', _stop => 'my_stop', }, ], args => [ 3 ], ); #------------------------------------------------------------------------------ # Test changing options POE::Session->create( inline_states => { _start => sub { my $orig = $_[SESSION]->option(default => 1); Test::More::ok($orig, "option original value"); my $rv = $_[SESSION]->option('default'); Test::More::ok($rv, "set default option successfully"); $rv = $_[SESSION]->option('default' => $orig); Test::More::ok($rv, "reset default option successfully"); $rv = $_[SESSION]->option('default'); Test::More::ok(!($rv xor $orig), "reset default option successfully"); $_[KERNEL]->yield("idle"); }, idle => sub { }, _stop => sub { }, # Pacify assertions. }, options => { default => 1 }, ); #------------------------------------------------------------------------------ # Test deprecation of new(), test invalid arguments to create() eval { POE::Session->new("foo" => sub { } ) }; ok($@ ne '', "new() is deprecated"); eval { POE::Session->create("an", "odd", "number", "of", "elephants") }; ok($@ ne '', "create() doesn't accept an odd number of args"); #------------------------------------------------------------------------------ # Main loop. is( $poe_kernel->get_active_session(), $poe_kernel, "get_active_session before POE::Kernel->run()" ); POE::Kernel->run(); is( $poe_kernel->get_active_session(), $poe_kernel, "get_active_session after POE::Kernel->run()" ); #------------------------------------------------------------------------------ # Final tests. # Now make sure they've run. for (my $i=0; $i<$machine_count; $i++) { is( $completions[$i], $event_count, "test $i ran" ); } # Were all the signals caught? SKIP: { if (($^O eq "MSWin32" or $^O eq "MacOS") and not $ENV{POE_DANTIC}) { skip "$^O does not support signals", 2; } is( $sigalrm_caught, $event_count, "caught enough SIGALRMs" ); is( $sigpipe_caught, $event_count, "caught enough SIGPIPEs" ); } # Did the postbacks work? ok( $postback_test, "postback test" ); ok( $callback_test, "callback test" ); # Gratuitous tests to appease the coverage gods. ok( (ARG1 == ARG0+1) && (ARG2 == ARG1+1) && (ARG3 == ARG2+1) && (ARG4 == ARG3+1) && (ARG5 == ARG4+1) && (ARG6 == ARG5+1) && (ARG7 == ARG6+1) && (ARG8 == ARG7+1) && (ARG9 == ARG8+1), "ARG constants are good" ); is( $sender_count, $machine_count * $event_count, "sender_count" ); is( $default_count, $machine_count * $event_count, "default_count" ); is( $got_heap_count, $machine_count, "got_heap_count" ); # Object/package sessions. is_deeply( \@objpack, [ ($event_count) x 4 ], "object/package session event count" ); my $sessions_destroyed = 0; my $objects_destroyed = 0; my $stop_called = 0; my $parent_called = 0; my $child_called = 0; package POE::MySession; use vars qw(@ISA); use POE::Session; @ISA = qw(POE::Session); sub DESTROY { $_[0]->SUPER::DESTROY; $sessions_destroyed++; } package MyObject; sub new { bless {} } sub DESTROY { $objects_destroyed++ } package main; POE::MySession->create( inline_states => { _start => sub { $_[HEAP]->{object} = MyObject->new; POE::MySession->create( inline_states => { _start => sub { $_[HEAP]->{object} = MyObject->new; POE::MySession->create( inline_states => { _start => sub { $_[HEAP]->{object} = MyObject->new; POE::MySession->create( inline_states => { _start => sub { $_[HEAP]->{object} = MyObject->new; $_[KERNEL]->delay(nonexistent => 3600); $_[KERNEL]->alias_set('test4'); }, _parent => sub { $parent_called++; }, _child => sub { }, # To shush ASSERT _stop => sub { $stop_called++; }, }, ); $_[KERNEL]->delay(nonexistent => 3600); $_[KERNEL]->alias_set('test3'); }, _parent => sub { $parent_called++; }, _child => sub { $child_called++ if $_[ARG0] eq 'lose'; }, _stop => sub { $stop_called++; }, }, ); $_[KERNEL]->delay(nonexistent => 3600); $_[KERNEL]->alias_set('test2'); }, _parent => sub { $parent_called++; }, _child => sub { $child_called++ if $_[ARG0] eq 'lose'; }, _stop => sub { $stop_called++; }, }, ); $_[KERNEL]->delay(nonexistent => 3600); $_[KERNEL]->alias_set('test1'); $_[KERNEL]->yield("stop"); }, _parent => sub { $parent_called++; }, _child => sub { $child_called++ if $_[ARG0] eq 'lose'; }, _stop => sub { $stop_called++; }, stop => sub { POE::Kernel->stop(); my $expected; if ($] >= 5.004 and $] < 5.00405) { diag( "Note: We find your choice of Perl versions disturbing" ); diag( "primarily due to the number of bugs POE triggers within" ); diag( "it. You should seriously consider upgrading." ); $expected = 0; } else { $expected = 3; } is( $sessions_destroyed, $expected, "$sessions_destroyed sessions destroyed (expected $expected)" ); # 5.004 and 5.005 have some nasty gc issues. Near as I can tell, # data inside the heap is surviving the session DESTROY. This # isn't possible in a sane and normal world. So if this is giving # you fits, consider it a sign that your "legacy perl" fetish is # bizarre and harmful. if ($] >= 5.006 or ($] >= 5.004 and $] < 5.00405)) { $expected = 3; } else { $expected = 2; diag("Detected a memory leak in Perl version $]."); diag("Please consider upgrading if you use Perl in production."); } is( $objects_destroyed, $expected, "$objects_destroyed objects destroyed (expected $expected)" ); } } ); POE::Kernel->run(); is( $stop_called, 4, "_stop was called the correct number of times" ); is( $child_called, 3, "_child wasn't called" ); is( $parent_called, 0, "_parent wasn't called" ); my $expected; if ($] >= 5.004 and $] < 5.00405) { diag( "Seriously. We've had to create special cases just to cater" ); diag( "to your freakish 'legacy buggy perl' fetish. Consider upgrading" ); $expected = 0; } else { $expected = 4; } is( $sessions_destroyed, $expected, "destroyed $sessions_destroyed sessions (expected $expected)" ); # 5.004 and 5.005 have some nasty gc issues. Near as I can tell, # data inside the heap is surviving the session DESTROY. This # isn't possible in a sane and normal world. if($] >= '5.006') { $expected = 4; } elsif ($] == 5.005_04 or $] == 5.004_05) { $expected = 3; diag( "Here's yet another special test case to work around memory" ); diag( "leaks in Perl $]." ); } else { $expected = 4; } is( $objects_destroyed, $expected, "destroyed $objects_destroyed objects (expected $expected)" ); # This simple session just makes sure we can start another Session and # another Kernel. If all goes well, it'll dispatch some events and # exit normally. # The restart test dumps core when using Tk with Perl 5.8.0 and # beyond, but only if they're built without threading support. It # happens consistently in a pure Tk test case. It happens # consistently in POE's "make test" suite. It doesn't happen at all # when running the test by hand. # # http://rt.cpan.org/Ticket/Display.html?id=8588 is tracking the Tk # test case. Wish us luck there. # # Meanwhile, these tests will be skipped under Tk if Perl is 5.8.0 or # beyond, and it's not built for threading. SKIP: { # use Config; # skip "Restarting Tk dumps core in single-threaded perl $]", 6 if ( # $] >= 5.008 and # exists $INC{"Tk.pm"} and # !$Config{useithreads} # ); POE::Session->create( options => { trace => 1, default => 1, debug => 1 }, inline_states => { _start => sub { pass("restarted event loop session _start"); $_[KERNEL]->yield("woot"); $_[KERNEL]->delay(narf => 1); }, woot => sub { pass("restarted event loop session yield()"); }, narf => sub { pass("restarted event loop session timer delay()"); }, _stop => sub { pass("restarted event loop session _stop"); }, } ); POE::Kernel->run(); pass("restarted event loop returned normally"); } 1; wheel_accept.pm100644000765000024 571712425745722 21702 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises the ListenAccept wheel. use strict; use lib qw(./mylib ../mylib); use IO::Socket; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More; use POE qw(Wheel::ListenAccept Wheel::SocketFactory); unless (-f "run_network_tests") { plan skip_all => "Network access (and permission) required to run this test"; } use constant CONNECTOR_COUNT => 5; plan tests => 2; my $bound_port; ### A listening session. sub listener_start { my $heap = $_[HEAP]; my $listening_socket = IO::Socket::INET->new( LocalAddr => '127.0.0.1', #LocalPort => 0, # 0 is the default, and as a bonus this works on MSWin32+ActiveState 5.6.1 Listen => 5, Proto => 'tcp', Reuse => 'yes', ); if (defined $listening_socket) { pass("created listening socket"); } else { fail("created listening socket error: $@"); fail("listening socket accepted connections"); return; } $bound_port = (sockaddr_in(getsockname($listening_socket)))[0]; $heap->{listener_wheel} = POE::Wheel::ListenAccept->new( Handle => $listening_socket, AcceptEvent => 'got_connection_nonexistent', ErrorEvent => 'got_error_nonexistent' ); $heap->{listener_wheel}->event( AcceptEvent => 'got_connection', ErrorEvent => 'got_error' ); $heap->{accept_count} = 0; $_[KERNEL]->delay( got_timeout => 10 ); } sub listener_stop { if (defined $bound_port) { ok( $_[HEAP]->{accept_count} == CONNECTOR_COUNT, "listening socket accepted connections" ); } } sub listener_got_connection { if (++$_[HEAP]->{accept_count} == CONNECTOR_COUNT) { $_[KERNEL]->delay( got_timeout => 1 ); } } sub listener_got_error { delete $_[HEAP]->{listener_wheel}; $_[KERNEL]->delay( got_timeout => 1 ); } sub listener_got_timeout { delete $_[HEAP]->{listener_wheel}; } ### A connecting session. sub connector_start { $_[HEAP]->{connector_wheel} = POE::Wheel::SocketFactory->new( RemoteAddress => '127.0.0.1', RemotePort => $bound_port, SuccessEvent => 'got_connection', FailureEvent => 'got_error', ); } sub connector_got_connection { delete $_[HEAP]->{connector_wheel}; } sub connector_got_error { delete $_[HEAP]->{connector_wheel}; } ### Main loop. POE::Session->create( inline_states => { _start => \&listener_start, _stop => \&listener_stop, got_connection => \&listener_got_connection, got_error => \&listener_got_error, got_timeout => \&listener_got_timeout, } ); if (defined $bound_port) { foreach (1..CONNECTOR_COUNT) { POE::Session->create( inline_states => { _start => \&connector_start, got_connection => \&connector_got_connection, got_error => \&connector_got_error, _stop => sub { }, # Pacify assertions. } ); } } $poe_kernel->run(); 1; wheel_curses.pm100644000765000024 541612425745722 21743 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises Wheel::Curses use strict; use lib qw(./mylib ../mylib); sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } use Test::More; use Symbol qw(gensym); BEGIN { if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { plan skip_all => "Can't multiplex consoles in $^O"; } eval "use IO::Pty"; plan skip_all => 'IO::Pty not available' if $@; eval { require Curses }; plan skip_all => 'Curses not available' if $@; } my ($saved_stdin, $saved_stdout, $pty_master, $pty_slave); BEGIN { # Redirect STDIN and STDOUT to temporary handles for the duration of # this test. $saved_stdin = gensym(); open($saved_stdin, "<&STDIN") or die "can't save stdin: $!"; $saved_stdout = gensym(); open($saved_stdout, ">&STDOUT") or die "can't save stdout: $!"; # Create a couple one-way pipes for our new stdin and stdout. $pty_master = IO::Pty->new() or die "pty: $!"; select $pty_master; $| = 1; $pty_slave = $pty_master->slave(); select $pty_slave; $| = 1; # Redirect our STDIN and STDOUT to the pipes. open(STDIN, "<&=" . fileno($pty_slave)) or die "stdin pipe redir: $!"; open(STDOUT, ">&=" . fileno($pty_slave)) or die "stdout pipe redir: $!"; select STDOUT; $| = 1; } BEGIN { plan skip_all => "Need help with Curses functions blocking under ptys"; plan tests => 5; use_ok('POE'); use_ok('POE::Wheel::Curses'); use_ok('POE::Filter::Stream'); use_ok('POE::Wheel::ReadWrite'); } # Restore the original stdio at the end of the run. END { if ($saved_stdin) { open(STDIN, "<&=" . fileno($saved_stdin)) or die "stdin restore: $!"; $saved_stdin = undef; } if ($saved_stdout) { open(STDOUT, ">&=" . fileno($saved_stdout)) or die "stdout restore: $!"; $saved_stdout = undef; } } ### Session to drive the tests. POE::Session->create( inline_states => { _start => \&test_start, got_keystroke => \&test_keystroke, got_readwrite_input => sub { }, _stop => sub { }, }, ); ### main loop POE::Kernel->run(); ### Event handlers from here on. sub test_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{child_input} = ""; $heap->{curses} = POE::Wheel::Curses->new( InputEvent => "got_keystroke" ); $heap->{readwrite} = POE::Wheel::ReadWrite->new( Handle => $pty_master, Filter => POE::Filter::Stream->new(), InputEvent => "got_readwrite_input", ); $heap->{readwrite}->put("this is a test!"); } sub test_keystroke { my ($kernel, $heap, $input) = @_[KERNEL, HEAP, ARG0]; $heap->{child_input} .= $input; if ($heap->{child_input} =~ /!/) { delete $heap->{curses}; delete $heap->{readwrite}; ok( $heap->{child_input} eq "this is a test!", "got keystrokes" ); } } 1; wheel_sf_tcp.pm100644000765000024 1230112425745722 21724 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises the wheels commonly used with TCP sockets. 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 Socket; use POE qw( Component::Server::TCP Wheel::ReadWrite Filter::Line Driver::SysRW ); my $tcp_server_port; use Test::More; unless (-f "run_network_tests") { plan skip_all => "Network access (and permission) required to run this test"; } plan tests => 9; ############################################################################### # A generic server session. sub sss_new { my ($socket, $peer_addr, $peer_port) = @_; POE::Session->create( inline_states => { _start => \&sss_start, _stop => \&sss_stop, got_line => \&sss_line, got_error => \&sss_error, got_flush => \&sss_flush, _child => sub { }, }, args => [ $socket, $peer_addr, $peer_port ], ); } sub sss_start { my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0..ARG2]; # Swap the SocketFactory for the ReadWrite. This exercises a subtle # bug in SocketFactory which should now be fixed. $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $socket, Driver => POE::Driver::SysRW->new( BlockSize => 10 ), Filter => POE::Filter::Line->new(), InputEvent => 'got_line', ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); $heap->{wheel_id} = $heap->{wheel}->ID; $heap->{test_two} = 1; $heap->{flush_count} = 0; $heap->{put_count} = 0; } sub sss_line { my ($heap, $line) = @_[HEAP, ARG0]; $line =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 $heap->{wheel}->put($line); $heap->{put_count}++; } sub sss_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; ok(!$errnum, "sss expecting errnum 0; got $errnum"); $heap->{test_two} = 0 if $errnum; delete $heap->{wheel}; } sub sss_flush { $_[HEAP]->{flush_count}++; } sub sss_stop { my $heap = $_[HEAP]; ok($heap->{test_two}, "test two"); ok($heap->{put_count} == $heap->{flush_count}, "flushed all put data"); } ############################################################################### # A TCP socket client. sub client_tcp_start { my $heap = $_[HEAP]; $heap->{wheel} = POE::Wheel::SocketFactory->new( RemoteAddress => '127.0.0.1', RemotePort => $tcp_server_port, SuccessEvent => 'got_server', FailureEvent => 'got_error', ); $heap->{socket_wheel_id} = $heap->{wheel}->ID; $heap->{test_five} = 1; } sub client_tcp_stop { my ($kernel, $heap) = @_[KERNEL, HEAP]; ok($heap->{test_five}, "test five"); ok($heap->{test_seven}, "test seven"); $_[KERNEL]->post( tcp_server => 'shutdown' ); } sub client_tcp_connected { my ($heap, $server_socket) = @_[HEAP, ARG0]; delete $heap->{wheel}; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $server_socket, Driver => POE::Driver::SysRW->new( BlockSize => 10 ), Filter => POE::Filter::Line->new(), InputEvent => 'got_line', ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); $heap->{readwrite_wheel_id} = $heap->{wheel}->ID; $heap->{test_seven} = 1; $heap->{flush_count} = 0; $heap->{put_count} = 1; $heap->{wheel}->put( '1: this is a test' ); ok($heap->{wheel}->get_driver_out_octets() == 19, "buffered 19 octets"); ok($heap->{wheel}->get_driver_out_messages() == 1, "buffered 1 message"); } sub client_tcp_got_line { my ($heap, $line) = @_[HEAP, ARG0]; if ($line =~ s/^1: //) { $heap->{put_count}++; $heap->{wheel}->put( '2: ' . $line ); } elsif ($line =~ s/^2: //) { ok($line eq 'this is a test', "received test message"); delete $heap->{wheel}; } } sub client_tcp_got_error { my ($heap, $operation, $errnum, $errstr, $wheel_id) = @_[HEAP, ARG0..ARG3]; if ($wheel_id == $heap->{socket_wheel_id}) { $heap->{test_five} = 0; } if ($wheel_id == $heap->{readwrite_wheel_id}) { $heap->{test_seven} = 0; } delete $heap->{wheel}; warn "$operation error $errnum: $errstr"; } sub client_tcp_got_flush { $_[HEAP]->{flush_count}++; } ############################################################################### # Start the TCP server and client. POE::Component::Server::TCP->new( Port => 0, Address => '127.0.0.1', Alias => 'tcp_server', Acceptor => sub { &sss_new(@_[ARG0..ARG2]); # This next badness is just for testing. my $sockname = $_[HEAP]->{listener}->getsockname(); delete $_[HEAP]->{listener}; my ($port, $addr) = sockaddr_in($sockname); $addr = inet_ntoa($addr); ok( ($addr eq '127.0.0.1') && ($port == $tcp_server_port), "received connection" ); }, Started => sub { $tcp_server_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, ); POE::Session->create( inline_states => { _start => \&client_tcp_start, _stop => \&client_tcp_stop, got_server => \&client_tcp_connected, got_line => \&client_tcp_got_line, got_error => \&client_tcp_got_error, got_flush => \&client_tcp_got_flush, } ); ### main loop POE::Kernel->run(); 1; wheel_sf_udp.pm100644000765000024 1430112425745722 21730 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises the wheels commonly used with UDP sockets. 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 Socket; use Test::More; use POE qw( Wheel::SocketFactory ); my $max_send_count = 10; unless (-f "run_network_tests") { plan skip_all => "Network access (and permission) required to run this test"; } plan tests => 10; ############################################################################### # Both a UDP server and a client in one session. This is a contrived # example of using two sockets/filehandles at once. # samples/proxy.perl does something similar. sub udp_start { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; $heap->{peer_a_setup_wheel} = POE::Wheel::SocketFactory->new( BindAddress => '127.0.0.1', BindPort => 0, SocketProtocol => 'udp', Reuse => 'yes', SuccessEvent => 'ev_peer_a_socket', FailureEvent => 'ev_peer_a_error', ); $heap->{peer_a_id} = $heap->{peer_a_setup_wheel}->ID; $heap->{peer_b_setup_wheel} = POE::Wheel::SocketFactory->new( BindAddress => '127.0.0.1', BindPort => 0, SocketProtocol => 'udp', Reuse => 'yes', SuccessEvent => 'ev_peer_b_socket', FailureEvent => 'ev_peer_b_error', ); $heap->{peer_b_id} = $heap->{peer_b_setup_wheel}->ID; $heap->{peer_a_recv_error} = 0; $heap->{peer_a_send_error} = 0; $heap->{peer_a_sock_error} = 0; $heap->{peer_b_recv_error} = 0; $heap->{peer_b_send_error} = 0; $heap->{peer_b_sock_error} = 0; $heap->{peer_a_send_count} = 0; $heap->{peer_b_send_count} = 0; $heap->{test_one} = 1; $heap->{test_two} = 1; $kernel->delay( ev_took_too_long => 5 ); } sub udp_stop { my $heap = $_[HEAP]; ok($heap->{test_one}, "test one"); ok($heap->{test_two}, "test two"); ok(!$heap->{peer_a_recv_error}, "peer a no recv errors"); ok(!$heap->{peer_a_send_error}, "peer a no send errors"); ok(!$heap->{peer_a_sock_error}, "peer a no sock errors"); ok(!$heap->{peer_b_recv_error}, "peer b no recv errors"); ok(!$heap->{peer_b_send_error}, "peer b no send errors"); ok(!$heap->{peer_b_sock_error}, "peer b no sock errors"); ok( $heap->{peer_a_send_count} == $max_send_count, "peer a sent $heap->{peer_a_send_count} (wanted $max_send_count)" ); ok( $heap->{peer_b_send_count} == $max_send_count, "peer b sent $heap->{peer_b_send_count} (wanted $max_send_count)" ); } sub udp_peer_a_socket { my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0]; delete $heap->{peer_a_setup_wheel}; $heap->{peer_a_socket_handle} = $socket; $kernel->select_read( $socket, 'ev_peer_a_input' ); if ( defined($heap->{peer_a_socket_handle}) and defined($heap->{peer_b_socket_handle}) ) { my $peer_b_address = getsockname($heap->{peer_b_socket_handle}); die unless defined $peer_b_address; my ($peer_b_port, $peer_b_addr) = unpack_sockaddr_in($peer_b_address); $heap->{peer_a_send_count}++; send( $socket, '1: this is a test', 0, $peer_b_address ) or $heap->{peer_a_send_error}++; } } sub udp_peer_b_socket { my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0]; delete $heap->{peer_b_setup_wheel}; $heap->{peer_b_socket_handle} = $socket; $kernel->select_read( $socket, 'ev_peer_b_input' ); if ( defined($heap->{peer_a_socket_handle}) and defined($heap->{peer_b_socket_handle}) ) { my $peer_a_address = getsockname($heap->{peer_a_socket_handle}); die unless defined $peer_a_address; my ($peer_a_port, $peer_a_addr) = unpack_sockaddr_in($peer_a_address); $heap->{peer_b_send_count}++; send( $socket, '1: this is a test', 0, $peer_a_address ) or $heap->{peer_b_send_error}++; } } sub udp_peer_a_error { my ($heap, $wheel_id) = @_[HEAP, ARG3]; if ($wheel_id == $heap->{peer_a_id}) { delete $heap->{peer_a_setup_wheel}; $heap->{test_one} = 0; } $heap->{peer_a_sock_error}++; } sub udp_peer_b_error { my ($heap, $wheel_id) = @_[HEAP, ARG3]; if ($wheel_id == $heap->{peer_b_id}) { delete $heap->{peer_b_setup_wheel}; $heap->{test_two} = 0; } $heap->{peer_b_sock_error}++; } sub udp_peer_a_input { my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0]; my $remote_socket = recv( $socket, my $message = '', 1024, 0 ); if (defined $remote_socket) { if ($heap->{peer_a_send_count} < $max_send_count) { $message =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 $heap->{peer_a_send_count}++; send( $socket, $message, 0, $remote_socket ) or $heap->{peer_a_send_error}++; } else { $kernel->delay( ev_took_too_long => 0.5 ); } } else { $heap->{peer_a_recv_error}++; } } sub udp_peer_b_input { my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0]; my $remote_socket = recv( $socket, my $message = '', 1024, 0 ); if (defined $remote_socket) { if ($heap->{peer_b_send_count} < $max_send_count) { $message =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 $heap->{peer_b_send_count}++; send( $socket, $message, 0, $remote_socket ) or $heap->{peer_b_send_error}++; } else { $kernel->delay( ev_took_too_long => 0.5 ); } } else { $heap->{peer_b_recv_error}++; } } sub udp_timeout { my ($kernel, $heap) = @_[KERNEL, HEAP]; if (defined $heap->{peer_a_socket_handle}) { $kernel->select($heap->{peer_a_socket_handle}); delete $heap->{peer_a_socket_handle}; } if (defined $heap->{peer_b_socket_handle}) { $kernel->select($heap->{peer_b_socket_handle}); delete $heap->{peer_b_socket_handle}; } } ############################################################################### POE::Session->create( inline_states => { _start => \&udp_start, _stop => \&udp_stop, ev_took_too_long => \&udp_timeout, ev_peer_a_socket => \&udp_peer_a_socket, ev_peer_a_error => \&udp_peer_a_error, ev_peer_a_input => \&udp_peer_a_input, ev_peer_b_socket => \&udp_peer_b_socket, ev_peer_b_error => \&udp_peer_b_error, ev_peer_b_input => \&udp_peer_b_input, }, ); $poe_kernel->run(); 1; k_run_returns.pm100644000765000024 104712425745722 22147 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # POE::Kernel->run() should return right away if there are no # sessions. 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 Test::More tests => 1; { my $death_note = "never returned\n"; local $SIG{ALRM} = sub { die $death_note }; alarm(10); eval { POE::Kernel->run() }; alarm(0); is($@, "", "POE::Kernel->run() returned right away"); } 1; wheel_sf_ipv6.pm100644000765000024 1226412425745722 22032 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises Client and Server TCP components, which exercise # SocketFactory in AF_INET6 mode. use strict; use lib qw(./mylib ../mylib); BEGIN { # 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 @_ }; eval { require Socket; Socket->import('AF_INET6') }; if ($@) { eval { require Socket6; Socket6->import('AF_INET6') }; if ($@) { print "1..0 # Skip Cannot find AF_INET6 support in Socket or Socket6.\n"; CORE::exit(); } } } # Second BEGIN block so that AF_INET6 is defined before this code is # compiled. BEGIN { my $error; eval 'use Socket::GetAddrInfo qw(:newapi getaddrinfo getnameinfo NI_NUMERICHOST NI_NUMERICSERV)'; if ($@) { $error = "Socket::GetAddrInfo is needed for IPv6 tests"; } elsif ($^O eq "cygwin") { $error = ( "IPv6 isn't available on Cygwin, even with Socket::GetAddrInfo installed" ); } else { my $addr; eval { my ($error, @addr) = getaddrinfo( "localhost", 80, { family => AF_INET6 } ); $addr = $addr[0]{addr} if @addr; }; if ($@) { $error = "error resolving localhost for IPv6: $@"; } elsif (!defined $addr) { $error = "IPv6 tests require a configured IPv6 localhost address"; } elsif (!-f 'run_network_tests') { $error = "Network access (and permission) required to run this test"; } } # Not Test::More, because I'm pretty sure skip_all calls Perl's # regular exit(). if ($error) { print "1..0 # Skip $error\n"; CORE::exit(); } } sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw( Component::Client::TCP Component::Server::TCP ); my $tcp_server_port; # Congratulations! We made it this far! use Test::More tests => 3; diag( "This test may hang if your firewall blocks IPv6" ); diag( "packets across your localhost interface." ); ############################################################################### # Start the TCP server. POE::Component::Server::TCP->new( Port => 0, Address => '::1', Domain => AF_INET6, Alias => 'server', ClientConnected => \&server_got_connect, ClientInput => \&server_got_input, ClientFlushed => \&server_got_flush, ClientDisconnected => \&server_got_disconnect, Error => \&server_got_error, ClientError => sub { }, # Hush a warning. Started => sub { eval { my $socket_name = $_[HEAP]{listener}->getsockname(); (my ($err, $host), $tcp_server_port) = getnameinfo( $socket_name, NI_NUMERICHOST | NI_NUMERICSERV ); }; if (!$tcp_server_port || $@) { $tcp_server_port = undef; SKIP: { my $errstr = @$ || 'server port undefined'; skip "AF_INET6 probably not supported or configured ($errstr)", 2; } } }, ); sub server_got_connect { my $heap = $_[HEAP]; $heap->{server_test_one} = 1; $heap->{flush_count} = 0; $heap->{put_count} = 0; } sub server_got_input { my ($heap, $line) = @_[HEAP, ARG0]; $line =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 $heap->{client}->put($line); $heap->{put_count}++; } sub server_got_flush { $_[HEAP]->{flush_count}++; } sub server_got_disconnect { my $heap = $_[HEAP]; ok( $heap->{put_count} == $heap->{flush_count}, "server put_count matches flush_count" ); } sub server_got_error { my ($syscall, $errno, $error) = @_[ARG0..ARG2]; SKIP: { skip "AF_INET6 probably not supported ($syscall error $errno: $error)", 1 } } ############################################################################### # Start the TCP client. if ($tcp_server_port) { POE::Component::Client::TCP->new( RemoteAddress => '::1', RemotePort => $tcp_server_port, Domain => AF_INET6, BindAddress => '::1', Connected => \&client_got_connect, ServerInput => \&client_got_input, ServerFlushed => \&client_got_flush, Disconnected => \&client_got_disconnect, ConnectError => \&client_got_connect_error, ); } sub client_got_connect { my $heap = $_[HEAP]; $heap->{flush_count} = 0; $heap->{put_count} = 1; $heap->{server}->put( '1: this is a test' ); } sub client_got_input { my ($kernel, $heap, $line) = @_[KERNEL, HEAP, ARG0]; if ($line =~ s/^1: //) { $heap->{put_count}++; $heap->{server}->put( '2: ' . $line ); } elsif ($line =~ s/^2: //) { ok( $line eq "this is a test", "received input" ); $kernel->post(server => "shutdown"); $kernel->yield("shutdown"); } } sub client_got_flush { $_[HEAP]->{flush_count}++; } sub client_got_disconnect { my $heap = $_[HEAP]; ok( $heap->{put_count} == $heap->{flush_count}, "client put_count matches flush_count" ); } sub client_got_connect_error { my ($syscall, $errno, $error) = @_[ARG0..ARG2]; SKIP: { skip "AF_INET6 probably not supported ($syscall error $errno: $error)", 2; } } ### main loop POE::Kernel->run(); 1; wheel_sf_unix.pm100644000765000024 1533512425745722 22133 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises the wheels commonly used with UNIX domain sockets. 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 Socket; use File::Temp qw(tempfile); # We can't test_setup(0, "reason") because that calls exit(). And Tk # will croak if you call BEGIN { exit() }. And that croak will cause # this test to FAIL instead of skip. 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") and not $ENV{POE_DANTIC}) { $error = "$^O does not support UNIX sockets"; } elsif ($^O eq "cygwin" and not $ENV{POE_DANTIC}) { $error = "UNIX sockets on $^O always block"; } if ($error) { # Not using Test::More so we can avoid Tk::exit. print "1..0 # Skip $error\n"; CORE::exit(); } } use Test::More tests => 12; use POE qw( Wheel::SocketFactory Wheel::ReadWrite Filter::Line Driver::SysRW ); my (undef, $unix_server_socket) = tempfile('poe-usrv-XXXXXX'); ############################################################################### # A generic server session. sub sss_new { my ($socket, $peer_addr, $peer_port) = @_; POE::Session->create( inline_states => { _start => \&sss_start, _stop => \&sss_stop, got_line => \&sss_line, got_error => \&sss_error, got_flush => \&sss_flush, }, args => [ $socket, $peer_addr, $peer_port ], ); } sub sss_start { my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0..ARG2]; delete $heap->{wheel}; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $socket, Driver => POE::Driver::SysRW->new( BlockSize => 10 ), Filter => POE::Filter::Line->new(), InputEvent => 'got_line', ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); $heap->{wheel_id} = $heap->{wheel}->ID; $heap->{test_six} = 1; $heap->{flush_count} = 0; $heap->{put_count} = 0; } sub sss_line { my ($heap, $line) = @_[HEAP, ARG0]; $line =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 $heap->{wheel}->put($line); $heap->{put_count}++; } sub sss_error { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; ok(!$errnum, "sss expecting errnum 0; got $errnum"); $heap->{test_six} = 0 if $errnum; delete $heap->{wheel}; } sub sss_flush { $_[HEAP]->{flush_count}++; } sub sss_stop { my $heap = $_[HEAP]; ok($heap->{test_six}, "test six"); ok( $_[HEAP]->{put_count} == $_[HEAP]->{flush_count}, "flushed everything we put" ); } ############################################################################### # A UNIX domain socket server. sub server_unix_start { my $heap = $_[HEAP]; unlink $unix_server_socket if -e $unix_server_socket; $heap->{wheel} = POE::Wheel::SocketFactory->new( SocketDomain => PF_UNIX, BindAddress => $unix_server_socket, SuccessEvent => 'got_client', FailureEvent => 'got_error', ); $heap->{client_count} = 0; $heap->{test_two} = 1; } sub server_unix_stop { my $heap = $_[HEAP]; delete $heap->{wheel}; ok($heap->{test_two}, "test two"); ok($heap->{client_count} == 1, "only one client"); unlink $unix_server_socket if -e $unix_server_socket; } sub server_unix_answered { $_[HEAP]->{client_count}++; sss_new(@_[ARG0..ARG2]); } sub server_unix_error { my ($session, $heap, $operation, $errnum, $errstr, $wheel_id) = @_[SESSION, HEAP, ARG0..ARG3]; if ($wheel_id == $heap->{wheel}->ID) { delete $heap->{wheel}; $heap->{test_two} = 0; } warn $session->ID, " got $operation error $errnum: $errstr\n"; } # This arrives with 'lose' when a server session has closed. sub server_unix_child { if ($_[ARG0] eq 'create') { $_[HEAP]->{child} = $_[ARG1]; } if ($_[ARG0] eq 'lose') { delete $_[HEAP]->{wheel}; ok( $_[ARG1] == $_[HEAP]->{child}, "lost expected child session" ); } } ############################################################################### # A UNIX domain socket client. sub client_unix_start { my $heap = $_[HEAP]; $heap->{wheel} = POE::Wheel::SocketFactory->new( SocketDomain => PF_UNIX, RemoteAddress => $unix_server_socket, SuccessEvent => 'got_server', FailureEvent => 'got_error', ); $heap->{socket_wheel_id} = $heap->{wheel}->ID; $heap->{test_three} = 1; } sub client_unix_stop { my $heap = $_[HEAP]; ok($heap->{test_three}, "test three"); ok($heap->{test_four}, "test four"); } sub client_unix_connected { my ($heap, $server_socket) = @_[HEAP, ARG0]; delete $heap->{wheel}; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $server_socket, Driver => POE::Driver::SysRW->new( BlockSize => 10 ), Filter => POE::Filter::Line->new(), InputEvent => 'got_line', ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); $heap->{readwrite_wheel_id} = $heap->{wheel}->ID; $heap->{test_four} = 1; $heap->{flush_count} = 0; $heap->{put_count} = 1; $heap->{wheel}->put( '1: this is a test' ); ok( $heap->{wheel}->get_driver_out_octets() == 19, "buffered 19 octets" ); ok( $heap->{wheel}->get_driver_out_messages() == 1, "buffered 1 message" ); } sub client_unix_got_line { my ($heap, $line) = @_[HEAP, ARG0]; if ($line =~ s/^1: //) { $heap->{put_count}++; $heap->{wheel}->put( '2: ' . $line ); } elsif ($line =~ s/^2: //) { ok( $line eq 'this is a test', "received expected text" ); delete $heap->{wheel}; } } sub client_unix_got_error { my ($session, $heap, $operation, $errnum, $errstr, $wheel_id) = @_[SESSION, HEAP, ARG0..ARG3]; if ($wheel_id == $heap->{socket_wheel_id}) { $heap->{test_three} = 0; } if ($wheel_id == $heap->{readwrite_wheel_id}) { $heap->{test_four} = 0; } delete $heap->{wheel}; warn $session->ID, " caught $operation error $errnum: $errstr"; } sub client_unix_got_flush { $_[HEAP]->{flush_count}++; } ### Start the UNIX domain server and client. POE::Session->create( inline_states => { _start => \&server_unix_start, _stop => \&server_unix_stop, _child => \&server_unix_child, got_client => \&server_unix_answered, got_error => \&server_unix_error, } ); POE::Session->create( inline_states => { _start => \&client_unix_start, _stop => \&client_unix_stop, got_server => \&client_unix_connected, got_line => \&client_unix_got_line, got_error => \&client_unix_got_error, got_flush => \&client_unix_got_flush } ); ### main loop POE::Kernel->run(); pass("run() returned normally"); 1; connect_errors.pm100644000765000024 442012425745722 22272 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # POE::XS::Loop::Poll wasn't handling errors correctly, this was # particularly noticeable for connect() failures, so check connection # failures are handled correctly use strict; use Test::More; unless (-f "run_network_tests") { plan skip_all => "Network access (and permission) required to run this test"; } # MSWin32+ActiveState 5.6.1 and 5.10.1 always time out. And if we remove the # delay, then the OS never times out. 5.8.0 seems to work fine. Since this # behavior seems to come and go, we're skipping it for all versions of MSWin32. if ($^O eq 'MSWin32' and not $ENV{POE_DANTIC}) { plan skip_all => "This test fails for various versions of MSWin32 perl"; } plan tests => 3; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw( Wheel::ReadWrite Component::Client::TCP ); # Dynamically find an unused port for the failure-to-connect test. # Listen on the port, but accept no connections there. my $unused_port; { use IO::Socket::INET; my $reserved = IO::Socket::INET->new( LocalAddr => '127.0.0.1', ReuseAddr => 0, ); if (defined $reserved) { $unused_port = (sockaddr_in(getsockname($reserved)))[0]; pass("found unused port: $unused_port"); } else { fail("found unused port error: $@"); } } # Timeout. POE::Session->create( inline_states => { _start => sub { $poe_kernel->alias_set('watcher'); $_[HEAP]{alarm} = $poe_kernel->delay_set(timeout => 10); }, timeout => sub { $poe_kernel->post(client => 'shutdown'); fail("timeout for connection"); }, shutdown => sub { $poe_kernel->alarm_remove($_[HEAP]{alarm}); }, _stop => sub { }, # Pacify assertions. } ); # Test connection failure. POE::Component::Client::TCP->new( RemotePort => $unused_port, RemoteAddress => '127.0.0.1', Alias => 'client', Connected => sub { fail("should have failed to connect"); }, ConnectError => sub { $poe_kernel->post(watcher => 'shutdown'); pass("expected connection failure occurred"); }, ServerInput => sub { warn "ServerInput called unexpectedly\n"; }, ); # Run the tests. POE::Kernel->run(); pass("run() returned successfully"); 1; wheel_readline.pm100644000765000024 2501712425745722 22241 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercises Wheel::ReadLine use strict; use warnings; use lib qw(./mylib ../mylib); sub DEBUG () { 0 } # Set the INPUTRC environment variable to a nonexistent file. This # prevents users from overriding the behaviors of keystrokes we user # here. BEGIN { foreach my $candidate (qw(nonexistent moo deleteme please-dont-exist)) { next if -f $candidate; $ENV{INPUTRC} = $candidate; last; } } ### Tests to run. # # Each test consists of a "name" for test reporting, a series of steps # that contain text to "type" in a particular order, and a "done" line # that should contain the final input from Wheel::ReadLine. my @tests = ( { name => "plain typing", step => [ "this is a test", # plain typing "\cJ", # accept-line ], done => "this is a test", }, { name => "backspace", step => [ "this is a test", "\cH\cH\cH\cH", # backward-delete-char "TEST", "\cA", # beginning-of-line "\cA", # beginning-of-line (fail bol) "\cD", # delete-char "T", "\cJ", ], done => "This is a TEST", }, { name => "forward/backward", step => [ "one three five", "\cA", # beginning-of-line "\cB", # backward-char (fail bol) "\eb", # backward-word (fail bol) "\cH", # backward-delete-char (fail bol) "\cF\cF\cF two", # forward-char "\cE", # end-of-line "\cE", # end-of-line (fail eol) "\cF", # forward-char (fail eol) "\cD", # delete-char (fail eol) "\ef", # forward-word (fail eol) "\cB\cB\cB\cB", # backward-char "four \cJ", ], done => "one two three four five", }, { name => "delete words", step => [ "one two three", "\ed", # kill-word (fail eol) "\e\cH", # backward-kill-word "four", "\cA", "\e\cH", # backward-kill-word (fail bol) "\ed", # kill-word "\cJ", ], done => "two four", }, { name => "case changes", step => [ "LOWER upper other", "\cA\cF\cF\cF", "\el", # downcase-word "\ef", # forward-word "\eb", # backward-word "\cF\cF\cF", "\eu", # upcase-word "\ec", # capitalize-word "\cE", "\el", # downcase-word (fail eol) "\eu", # upcase-word (fail eol) "\ec", # capitalize-word (fail eol) "\cJ", ], done => "LOWer uppER Other", }, { name => "transpose", step => [ "one two 12", "\cb", "\cT", # transpose-chars "\eb\eb", "\et", # transpose-words "\cA\cT", # transpose-chars (fail bol) "\cE12\cT", # transpose-chars (at eol "\cJ", ], done => "two one 2121", }, ); sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More; # There are some reasons not to run this test. BEGIN { my $error; if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { $error = "$^O cannot multiplex terminals"; } elsif (!-t STDIN) { $error = "not running in a terminal"; } else { eval "use Term::ReadKey"; if ($@) { $error = "This test requires Term::ReadKey"; } else { eval "use IO::Pty"; if ($@) { $error = "This test requires IO::Pty"; } else { eval "use Term::Cap"; if ($@) { $error = "This test requires Term::Cap"; } } } } unless ($error) { use POSIX (); my $termios = POSIX::Termios->new(); $termios->getattr(); my $ospeed = $termios->getospeed() || eval { POSIX::B38400() } || 0; $ENV{TERM} = "vt100" if $^O eq "solaris" or not $ENV{TERM}; my $termcap = eval { Term::Cap->Tgetent( { TERM => $ENV{TERM}, OSPEED => $ospeed } ) }; unless ($termcap) { $error = "Term::Cap failure: $@"; $error =~ s/ at \S+ line \d+.*//; $error =~ s/\s+/ /g; } } if ($error) { plan skip_all => $error; CORE::exit(); } } use Symbol qw(gensym); use POSIX qw( sysconf setsid _SC_OPEN_MAX ECHO ICANON IEXTEN ISIG BRKINT ICRNL INPCK ISTRIP IXON CSIZE PARENB OPOST TCSANOW ); # Redirection must be done before POE::Wheel::ReadLine is loaded, # otherwise it grabs copies of STDIN and STDOUT. my ($saved_stdin, $saved_stdout, $pty_master, $pty_slave); BEGIN { # Redirect STDIN and STDOUT to temporary handles for the duration of # this test. $saved_stdin = gensym(); open($saved_stdin, "<&STDIN") or die "can't save stdin: $!"; $saved_stdout = gensym(); open($saved_stdout, ">&STDOUT") or die "can't save stdout: $!"; # Create a couple one-way pipes for our new stdin and stdout. $pty_master = IO::Pty->new() or die "pty: $!"; select $pty_master; $| = 1; $pty_slave = $pty_master->slave(); # Put the pty conduit (slave side) into "raw" or "cbreak" mode, # per APITUE 19.4 and 11.10. my $tio = POSIX::Termios->new(); $tio->getattr(fileno($pty_slave)); my $lflag = $tio->getlflag; $lflag &= ~(ECHO | ICANON | IEXTEN | ISIG); $tio->setlflag($lflag); my $iflag = $tio->getiflag; $iflag &= ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON); $tio->setiflag($iflag); my $cflag = $tio->getcflag; $cflag &= ~(CSIZE | PARENB); $tio->setcflag($cflag); my $oflag = $tio->getoflag; $oflag &= ~(OPOST); $tio->setoflag($oflag); $tio->setattr(fileno($pty_slave), TCSANOW); select $pty_slave; $| = 1; # Redirect our STDIN and STDOUT to the pipes. open(STDIN, "<&=" . fileno($pty_slave)) or die "stdin pipe redir: $!"; open(STDOUT, ">&=" . fileno($pty_slave)) or die "stdout pipe redir: $!"; select STDOUT; $| = 1; } # Restore the original stdio at the end of the run. END { if ($saved_stdin) { open(STDIN, "<&=" . fileno($saved_stdin)) or die "stdin restore: $!"; $saved_stdin = undef; } if ($saved_stdout) { open(STDOUT, ">&=" . fileno($saved_stdout)) or die "stdout restore: $!"; $saved_stdout = undef; } } use POE qw(Filter::Stream Wheel::ReadWrite); eval "use POE::Wheel::ReadLine"; if ($@ and $@ =~ /(requires a termcap|failed termcap lookup|cannot run)/) { my $error = $@; $error =~ s/ at \S+ line \d+.*//s; $error =~ s/\s+/ /g; plan skip_all => $error; } plan tests => scalar(@tests); ### Session to run the tests. POE::Session->create( inline_states => { _start => \&test_start, got_readwrite_output => \&test_readwrite_output, got_readline_input => \&test_readline_input, start_next_test => \&test_start_next, step_this_test => \&test_step, _stop => sub { }, }, ); ### Main loop. POE::Kernel->run(); ### The rest of this code is event handlers. sub test_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # The ReadLine wheel to drive and test. eval { $heap->{readline} = POE::Wheel::ReadLine->new( InputEvent => "got_readline_input", appname => "my_cli", ); }; if ($@) { my $error = $@; $error =~ s/ at \S+ line \d+.*//s; $error =~ s/\s+/ /g; plan skip_all => $error; return; } unless ($heap->{readline}) { plan skip_all => "POE::Wheel::Readline->new failed (term=$ENV{TERM})"; return; } # Create a Wheel::ReadWrite to work on the driving side of the # pipes. $heap->{readwrite} = POE::Wheel::ReadWrite->new( Handle => $pty_master, Filter => POE::Filter::Stream->new(), InputEvent => "got_readwrite_output", ); # And start testing. $kernel->yield("start_next_test"); } sub test_readwrite_output { my ($heap, $input) = @_[HEAP, ARG0]; if (DEBUG) { $input =~ s/[\x0A\x0D]+/{ENTER}/g; warn "$heap->{test}{name} - got output from child ($input)\n"; } } sub test_readline_input { my ($kernel, $heap, $input) = @_[KERNEL, HEAP, ARG0]; my $test = $heap->{test}; my $name = $test->{name}; DEBUG and warn "$name - got readline input ($input)\n"; if (@{$test->{step}}) { fail("$name - got test input prematurely"); } else { is( $input, $test->{done}, $name ); } $kernel->yield("start_next_test"); } sub test_start_next { my ($kernel, $heap) = @_[KERNEL, HEAP]; if (@tests) { $heap->{test} = shift @tests; $kernel->yield("step_this_test"); $heap->{readline}->get("next step"); # Second get to instrument a test for this sort of thing. $heap->{readline}->get("next step"); return; } # Delete them first so that we can tell the relative order of # destruction when DEBUG is turned on. delete $heap->{readline}; delete $heap->{readwrite}; DEBUG and warn "Done with all tests.\n"; return; } sub test_step { my ($kernel, $heap) = @_[KERNEL, HEAP]; my $next_step = shift @{$heap->{test}{step}}; unless ($next_step) { DEBUG and warn "$heap->{test}{name} - done with test\n"; return; } if (DEBUG) { my $output_next_step = $next_step; $output_next_step =~ s/[\x00-\x1F\x7F]/./g; warn "$heap->{test}{name} - typing ($output_next_step)\n"; } $heap->{readwrite}->put($next_step); $kernel->yield("step_this_test"); } 1; __END__ TODO: These are emacs key bindings for things we haven't yet tested. C-]: character-search C-_: undo C-c: interrupt C-g: abort C-i: complete C-k: kill-line C-l: clear-screen C-n: next-history C-p: previous-history C-q: poe-wheel-debug C-r: reverse-search-history C-s: forward-search-history C-u: unix-line-discard C-v: quoted-insert C-w: unix-word-rubout C-xC-g: abort C-xC-r: re-read-init-file C-xDel: backward-kill-line C-xk: dump-key C-xm: dump-macros C-xv: dump-variables C-y: yank M-#: insert-comment M-&: tilde-expand M-*: insert-completions M--: digit-argument M-.: yank-last-arg M-0: digit-argument M-1: digit-argument M-2: digit-argument M-3: digit-argument M-4: digit-argument M-5: digit-argument M-6: digit-argument M-7: digit-argument M-8: digit-argument M-9: digit-argument M-<: beginning-of-history M->: end-of-history M-?: possible-completions M-C-[: complete M-C-]: character-search-backward M-C-g: abort M-C-i: tab-insert M-C-j: vi-editing-mode M-C-r: revert-line M-C-y: yank-nth-arg M-\: delete-horizontal-space M-_: yank-last-arg M-n: non-incremental-forward-search-history M-p: non-incremental-reverse-search-history M-r: revert-line M-space: set-mark M-y: yank-pop M-~: tilde-expand down: next-history ins: overwrite-mode up: previous-history wheel_run_size.pm100644000765000024 423112425745722 22267 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab use strict; use Test::More; use POSIX qw(_exit); use POE qw(Wheel::Run Filter::Line Filter::Stream Wheel::ReadWrite); BEGIN { my $why; $why = "This test requires Term::Size" if do { eval "use Term::Size"; $@ }; plan skip_all => $why if $why; } plan tests => 4; my $winsize = [85, 29, 100, 200]; ### Handle the _start event. This sets things in motion. sub handle_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Set a signal handler. $kernel->sig(CHLD => "got_sigchld"); # Start the terminal reader/writer. $heap->{stdio} = POE::Wheel::ReadWrite->new( InputHandle => \*STDIN, OutputHandle => \*STDOUT, InputEvent => "got_terminal_stdin", Filter => POE::Filter::Line->new(), ); # Start the asynchronous child process. $heap->{program} = POE::Wheel::Run->new( Program => [ $^X, '-e', ( 'use Term::Size qw(chars pixels); ' . 'my ($c, $r, $px, $py) = (chars(\\*STDIN), pixels(\\*STDIN)); ' . 'print "rows: $r, cols: $c, xpix: $px, ypix: $py\\n"; ' ) ], Conduit => "pty", Winsize => $winsize, StdoutEvent => "got_child_stdout", StdioFilter => POE::Filter::Line->new(), ); } sub handle_terminal_stdin { my ($heap, $input) = @_[HEAP, ARG0]; $heap->{program}->put($input); } sub handle_child_stdout { my ($heap, $input) = @_[HEAP, ARG0]; if ($input =~ m/^rows: (\d+), cols: (\d+), xpix: (\d+), ypix: (\d+)$/) { is($winsize->[0], $1, 'rows set correctly'); is($winsize->[1], $2, 'cols set correctly'); is($winsize->[2], $3, 'xpix set correctly'); is($winsize->[3], $4, 'ypix set correctly'); } } sub handle_sigchld { my ($heap, $child_pid) = @_[HEAP, ARG1]; if ($child_pid == $heap->{program}->PID) { delete $heap->{program}; delete $heap->{stdio}; } return 0; } ### Start a session to encapsulate the previous features. POE::Session->create( inline_states => { _start => \&handle_start, got_terminal_stdin => \&handle_terminal_stdin, got_child_stdout => \&handle_child_stdout, got_sigchld => \&handle_sigchld, }, ); POE::Kernel->run(); 1; k_signals_rerun.pm100644000765000024 632712425745722 22442 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops# vim: ts=2 sw=2 expandtab # Yuval Kogman's test case for edge issues with rethrowing unhandled # die() exceptions and re-calling run() after it's returned due to # such exceptions. use warnings; use strict; use Test::More; if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { plan skip_all => "Perl on $^O is too fragile for this test - it crashes"; CORE::exit(0); eval 'use Win32::Console'; if ($@) { plan skip_all => "Win32::Console is required on $^O - try ActivePerl"; } if (exists $INC{'Tk.pm'} and not $ENV{POE_DANTIC}) { plan skip_all => "Perl crashes in this test with Tk on $^O"; } if (exists $INC{'Event.pm'} and not $ENV{POE_DANTIC}) { plan skip_all => "Perl crashes in this test with Event on $^O"; } } plan tests => 9; sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE qw/Wheel::Run/; foreach my $die_on_bad_exit ( 0, 1 ) { foreach my $exit ( 0, 1, 0, 0 ) { POE::Session->create( inline_states => { _start => sub { POE::Session->create( inline_states => { stdout => sub { }, stdin => sub { }, _parent => sub { }, _start => sub { my ( $kernel, $session, $heap ) = @_[KERNEL, SESSION, HEAP]; $kernel->sig( CHLD => "sigchld_handler" ); my $wheel = POE::Wheel::Run->new( Program => $heap->{program}, StdinEvent => "stdin", StdoutEvent => "stdout", ); $heap->{pid_to_wheel}->{ $wheel->PID } = $wheel; $heap->{id_to_wheel}->{ $wheel->ID } = $wheel; $kernel->refcount_increment( $session->ID, "running_processes" ); }, sigchld_handler => sub { my ( $kernel, $session, $heap, $pid, $child_error ) = @_[ KERNEL, SESSION, HEAP, ARG1, ARG2 ]; return unless exists $heap->{pid_to_wheel}{$pid}; $kernel->refcount_decrement( $session->ID, "running_processes" ); my $wheel = delete $heap->{pid_to_wheel}{$pid}; delete $heap->{id_to_wheel}{ $wheel->ID }; $kernel->sig( CHLD => undef ); $heap->{program_exit} = $child_error; }, _stop => sub { my ( $heap ) = $_[HEAP]; if ( scalar keys %{ $heap->{pid_to_wheel} } ) { die "AAAAAAAHHH Running process leak!"; } die "bad exit\n" if $die_on_bad_exit and ( $heap->{program_exit} >> 8 ) != 0; } }, heap => { program => [ $^X, "-wle", "exit $exit" ] }, ); }, _stop => sub { }, _child => sub { }, _parent => sub { }, }, ); eval { POE::Kernel->run }; if ( $die_on_bad_exit and $exit ) { ok( $@, "($die_on_bad_exit-$exit) died with bad exit code" ); is( $@, "bad exit\n", "($die_on_bad_exit-$exit) error is correct" ); } else { ok( !$@, "($die_on_bad_exit-$exit) no error when process exited OK" ) or diag($@); } } } 1; sbk_signal_init.pm100644000765000024 165012425745722 22406 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl # vim: ts=2 sw=2 expandtab # Tests whether POE::Kernel affects signal handlers at initialization # time. Based on test code provided by Stuart Kendrick, in # rt.cpan.org ticket 19529. use warnings; use strict; # 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 Test::More tests => 1; BEGIN { $SIG{ALRM} = \&dispatch_normal_signal; } my $signal_dispatched = 0; sub dispatch_normal_signal { $signal_dispatched = 1 } use POE; alarm(1); if ($^O eq "MSWin32") { # Cant' select. Windows will get me! # Windows has trouble with select() and undefined input vectors. sleep(5); } else { # Can't sleep. HP-UX will get me! # HP-UX implements sleep() with alarm(), so they don't mix. select(undef, undef, undef, 5); } ok($signal_dispatched, "normal SIGALRM dispatched"); 1; wheel_readwrite.pm100644000765000024 3030312425745722 22436 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab use strict; use warnings; use IO::File; use Test::More tests => 28; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE qw(Filter::Map Driver::SysRW Pipe::TwoWay); sub DEBUG () { 0 } use_ok('POE::Wheel::ReadWrite'); can_ok('POE::Wheel::ReadWrite', qw( new put event set_filter set_input_filter set_output_filter set_high_mark set_low_mark get_driver_out_octets get_driver_out_messages ID pause_input resume_input shutdown_input shutdown_output )); # checks new() fails appropriately sub test_new { my ($name, @args) = @_; eval { POE::Wheel::ReadWrite->new(@args) }; ok($@ ne '', $name); } # Part 0 - Dispatch tests {{{ sub test_dispatcher { my @tests = ( \&part1, \&part2, \&part3 ); POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield('run_next'); $_[KERNEL]->alias_set('test_dispatcher'); }, run_next => sub { if (@tests) { warn "dispatching $tests[0]" if DEBUG; eval { (shift @tests)->() }; if ($@) { warn $@; exit 1; } # POE isn't very good at dieing hard } else { $_[KERNEL]->alias_remove('test_dispatcher'); } }, _child => sub { if ($_[ARG0] eq 'lose') { delete $_[HEAP]->{$_[ARG1]->ID}; $_[KERNEL]->yield('run_next') unless keys %{$_[HEAP]}; } else { $_[HEAP]->{$_[ARG1]->ID}++; } }, _stop => sub { }, }, ); } # }}} # Appendix 1 - Mock/Proxy Driver {{{ { package MockDriver; # Those readers interested in good practice should see Test::MockObject use vars qw($AUTOLOAD); sub SELF_DRIVER () { 0 } sub SELF_CALLED () { 1 } sub new { my ($class, $driver) = @_; return bless [$driver, {}], $class; } sub mock_called { my ($self, $meth) = @_; return $self->[SELF_CALLED]->{$meth}; } sub DESTROY { } sub AUTOLOAD { my $self = shift; $AUTOLOAD =~ s/^MockDriver:://; my $meth = $self->[SELF_DRIVER]->can($AUTOLOAD); $self->[SELF_CALLED]->{$AUTOLOAD}++; unshift @_, $self->[SELF_DRIVER]; goto &$meth; } } # }}} # Part 1 - Check new() {{{ sub part1 { POE::Session->create( inline_states => { _start => sub { test_new("new(): no args"); test_new("new(): handles for both directions", InputHandle => \*STDIN); local $SIG{__WARN__} = sub {}; test_new("new(): passing kernel deprecated", $poe_kernel); test_new("new(): both marks must be given", Handle => \*DATA, HighMark => 5, HighEvent => 'high', LowEvent => 'low'); test_new("new(): both marks must be given", Handle => \*DATA, LowMark => 5, HighEvent => 'high', LowEvent => 'low'); test_new("new(): both marks must be valid", Handle => \*DATA, LowMark => 5, HighMark => -1, HighEvent => 'high', LowEvent => 'low'); test_new("new(): both marks must be valid", Handle => \*DATA, LowMark => -1, HighMark => 5, HighEvent => 'high', LowEvent => 'low'); test_new("new(): both marks must be valid", Handle => \*DATA, LowMark => -1, HighMark => -1, HighEvent => 'high', LowEvent => 'low'); test_new("new(): both mark events needed", Handle => \*DATA, LowMark => 3, HighMark => 8, HighEvent => 'high'); test_new("new(): both mark events needed", Handle => \*DATA, LowMark => 3, HighMark => 8, LowEvent => 'low'); test_new("new(): mark events need levels", Handle => \*DATA, HighEvent => 'high'); test_new("new(): mark events need levels", Handle => \*DATA, LowEvent => 'low'); test_new("new(): mark events need levels", Handle => \*DATA, LowEvent => 'low', HighEvent => 'high'); }, _stop => sub { }, }, ); } # }}} # Part 2 - Check filter handling {{{ my $TMPDATA = <<"END"; TMPDATA 12345 TMPDATA ABCDE $$ $< $> $] END my $TMPDATA_LINES = () = $TMPDATA =~ m/\n/g; sub part2 { my $tmpfile = IO::File->new_tmpfile(); die "Couldn't create temporary file" unless defined $tmpfile; print $tmpfile $TMPDATA; seek $tmpfile, 0, 0 or do { print STDERR "seek failed: $!"; exit 1 }; if (exists $INC{'Tk.pm'}) { SKIP: { skip( "part2 doesn't work with Tk", 13 ); } $poe_kernel->post("test_dispatcher" => "run_next"); return; } elsif ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { SKIP: { skip( "part2 doesn't work on windows", 13 ); } $poe_kernel->post("test_dispatcher" => "run_next"); return; } POE::Session->create( inline_states => { _start => sub { $_[HEAP]->{fh} = $tmpfile; $_[HEAP]->{driver} = MockDriver->new(POE::Driver::SysRW->new); $_[HEAP]->{wheel} = POE::Wheel::ReadWrite->new( Handle => $tmpfile, Driver => $_[HEAP]->{driver}, LowMark => 1, HighMark => 12, InputEvent => 'wrong_input', FlushedEvent => 'wrong_flushed', ErrorEvent => 'wrong_error', HighEvent => 'wrong_high', LowEvent => 'wrong_low', ); $_[HEAP]->{wheel_id} = $_[HEAP]->{wheel}->ID; # start state machines $_[HEAP]->{read_machine} = "start"; $_[HEAP]->{write_machine} = "start"; # try changing all the events $_[HEAP]->{wheel}->event( InputEvent => 'input', FlushedEvent => 'flushed', ErrorEvent => 'error', HighEvent => 'high', LowEvent => 'low', ); }, resume_input => sub { $_[HEAP]->{wheel}->resume_input }, input => \&part2_input, flushed => \&part2_flushed, error => \&part2_handle, high => \&part2_high, low => \&part2_low, wrong_input => \&part2_wrong, wrong_flushed => \&part2_wrong, wrong_error => \&part2_wrong, wrong_high => \&part2_wrong, wrong_low => \&part2_wrong, _stop => \&part2_stop, }, ); } sub part2_wrong { print STDERR "$_[STATE] called unexpectedly"; exit 1; } # two phases, first we do reads w/ pauses, then we do writes w/ pauses. sub part2_input { my ($heap, $input, $id) = @_[HEAP, ARG0, ARG1]; $heap->{read_lines}++; $heap->{"called_input"}++; $heap->{"wrong_id"}++ if $id != $heap->{wheel_id}; unless ($heap->{check_filters}++) { &part2_check_filters; } if ($heap->{read_machine} eq "start") { $heap->{wheel}->pause_input; $heap->{read_machine} = "paused"; } elsif ($heap->{read_machine} eq 'paused') { if ($heap->{read_lines} == $TMPDATA_LINES) { # we've reached EOF while paused seek $heap->{fh}, 0, 0 or do { print STDERR "seek failed: $!"; exit 1 }; $heap->{read_machine} = "paused+reset"; $_[KERNEL]->delay('resume_input', 0.5); } } elsif ($heap->{read_machine} eq 'paused+reset') { # reading started again! if ($heap->{read_lines} >= 2*$TMPDATA_LINES) { $heap->{read_machine} = "stop"; if ($heap->{write_machine} eq "start") { $heap->{wheel}->put("LINE 1"); $heap->{write_machine} = "line2"; } } } else { warn "read machine state == $heap->{read_machine}"; delete $heap->{wheel}; } } sub part2_flushed { my ($heap, $id) = @_[HEAP, ARG0]; $heap->{called_flushed}++; $heap->{wrong_id}++ if $id != $heap->{wheel_id}; if ($heap->{write_machine} eq "line2") { $heap->{wheel}->put("LINE 2"); $heap->{wheel}->put("LINE 3"); $heap->{wheel}->put("LINE 4"); $heap->{write_machine} = "line5"; } elsif ($heap->{write_machine} eq "line5") { # $heap->{wheel}->set_high_mark(550); # $heap->{wheel}->set_low_mark(500); $heap->{wheel}->put("LINE 5"); $heap->{wheel}->put("LINE 6"); $heap->{wheel}->put("LINE 7"); $heap->{write_machine} = "delete"; } elsif ($heap->{write_machine} eq "delete") { $heap->{write_machine} = "stop"; $heap->{wheel}->shutdown_input; $heap->{wheel}->shutdown_output; delete $heap->{wheel}; } else { warn "write machine state == $heap->{write_machine}"; delete $heap->{wheel}; } } sub part2_high { my $heap = $_[HEAP]; $heap->{called_high}++; } sub part2_low { my $heap = $_[HEAP]; if ($heap->{write_machine} eq 'delete') { $heap->{low_not_set}++; } $heap->{called_low}++; } sub part2_check_filters { isa_ok($_[HEAP]->{wheel}->get_input_filter, 'POE::Filter', "input filter isa POE::Filter"); isa_ok($_[HEAP]->{wheel}->get_output_filter, 'POE::Filter', "output filter isa POE::Filter"); } sub part2_handle { $_[HEAP]->{"called_$_[STATE]"}++; } sub part2_stop { my $heap = $_[HEAP]; # the post-mortem - check that things we expected to happen, happened ok($heap->{called_input}, "input event happened"); ok($heap->{called_flushed}, "flushed event happened"); ok($heap->{called_error}, "error event happened"); # ok($heap->{called_high}, "high event happened"); ok($heap->{called_low}, "low event happened"); # ok(!$heap->{low_not_set}, "low mark successfully changed"); ok($heap->{driver}->mock_called('get'), "driver's get called"); ok($heap->{driver}->mock_called('put'), "driver's put called"); ok($heap->{driver}->mock_called('flush'), "driver's flush called"); ok(!$heap->{wrong_id}, "correct wheel id consistently used"); is($heap->{read_lines}, 2*$TMPDATA_LINES, "correct number of lines read"); is($heap->{read_machine}, "stop", "read state machine finished"); is($heap->{write_machine}, "stop", "write state machine finished"); } # }}} # Part 3 - Changing watermarks (testing with a pipe) {{{ sub part3 { POE::Session->create( inline_states => { _start => sub { }, _stop => sub { } }, ); return; # skip # create the pipe my ($a_read, $a_write, $b_read, $b_write) = POE::Pipe::TwoWay->new("inet"); # flow is $b_write --> $a_read # the two session IDs my ($sender, $receiver); # sender POE::Session->create( inline_states => { problem => sub { diag("problem in part3 sender!"); $_[HEAP]->{wheel} = $_[HEAP]->{fh} = undef; }, _start => sub { $sender = $_[SESSION]->ID; $_[HEAP]->{wheel} = POE::Wheel::ReadWrite->new( Handle => $b_write, HighMark => 1, LowMark => 1, FlushedEvent => 'flushed', HighEvent => 'high', LowEvent => 'low', ErrorEvent => 'problem', ); # now boost the watermarks much higher $_[HEAP]->{wheel}->set_high_mark(512); $_[HEAP]->{wheel}->set_low_mark(32); $_[HEAP]->{state} = "start"; $_[HEAP]->{wheel}->put("start"); }, second => sub { is($_[HEAP]->{state}, "start", "sender: start --> second"); $_[HEAP]->{state} = "second"; $_[KERNEL]->yield("second_send"); }, second_send => sub { if ($_[HEAP]->{state} eq "second") { $_[HEAP]->{wheel}->put("\0" x (1024*1024)); $_[KERNEL]->yield("second_send"); } }, flushed => sub { }, #print "flushed\n" }, high => sub { print "high\n"; $_[HEAP]->{state} = "high"; }, low => sub { print "low\n" }, _stop => sub { }, }, ); # receiver POE::Session->create( inline_states => { problem => sub { diag("problem in part3 receiver!"); $_[HEAP]->{wheel} = $_[HEAP]->{fh} = undef; }, _start => sub { $receiver = $_[SESSION]->ID; $_[HEAP]->{wheel} = POE::Wheel::ReadWrite->new( Handle => $a_read, InputEvent => 'input', ErrorEvent => 'problem', ); $_[HEAP]->{state} = "start"; }, input => sub { my ($heap, $line) = @_[HEAP, ARG0]; my $state = $heap->{state}; if ($state eq "start") { is($line, "start", "first line ok"); $heap->{state} = "second"; $heap->{wheel}->pause_input(); $_[KERNEL]->post($sender, "second"); } elsif ($state eq "second") { is($line, "second", "second line ok"); } else { warn "weird receive state $_[HEAP]->{state}"; delete $heap->{wheel}; } }, _stop => sub { }, }, ); } # }}} # Start it all off test_dispatcher(); $poe_kernel->run(); 1; z_leolo_wheel_run.pm100644000765000024 657312425745722 22773 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl # vim: ts=2 sw=2 expandtab use warnings; use strict; use Test::More; if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { plan skip_all => "Perl crashes on $^O"; } plan tests => 14; my $port; use POE; use POE::Wheel::Run; SKIP: { skip("The underlying event loop has trouble with ptys on $^O", 6) if $^O eq "darwin" and ( exists $INC{"POE/Loop/IO_Poll.pm"} or exists $INC{"POE/Loop/Event.pm"} or $ENV{POE_LOOP_USES_POLL} ) and not $ENV{POE_DANTIC}; eval "use IO::Pty"; skip("IO::Pty is not available; skipping pty tests", 6) if $@; PoeTestWorker->spawn( 'pty' ); PoeTestWorker->spawn( 'pty-pipe' ); } PoeTestWorker->spawn( 'socketpair' ); PoeTestWorker->spawn( 'inet' ); pass( "Start" ); $poe_kernel->run; pass( "Done" ); ############################################################################# package PoeTestWorker; use strict; use warnings; use POE; use Test::More; sub DEBUG () { 0 } sub seen { my( $heap, $what ) = @_; $heap->{seen}{$what}++; DEBUG and diag "$$: seen $what\n"; if( 3==keys %{$heap->{seen}} ) { delete $heap->{wheel}; $poe_kernel->alarm_remove( delete $heap->{tid} ) if $heap->{tid}; } } sub spawn { my( $package, $conduit ) = @_; POE::Session->create( args => [ $conduit ], inline_states => { _start => sub { my( $heap, $kernel, $conduit ) = @_[ HEAP, KERNEL, ARG0 ]; $heap->{conduit} = $conduit; $heap->{seen} = {}; $kernel->sig_child( TERM => 'TERM' ); $heap->{wheel} = POE::Wheel::Run->new( StderrEvent => ( $conduit eq 'pty' ? undef() : 'stderr' ), StdoutEvent => 'stdout', #ErrorEvent => 'error', CloseEvent => 'closeE', Conduit => $conduit, Program => sub { print "hello\n"; sleep 1; print "hello world" x 1024, "\n"; print "done\n"; } ); $kernel->sig_child( $heap->{wheel}->PID, 'CHLD' ); $heap->{tid} = $kernel->delay_set( timeout => 600 ); }, _stop => sub { my( $heap, $kernel ) = @_[ HEAP, KERNEL ]; ## This is the money shot foreach my $need ( qw( done close CHLD ) ) { is( $heap->{seen}{$need}, 1, "$heap->{conduit}: $need" ); } }, timeout => sub { my( $heap, $kernel ) = @_[ HEAP, KERNEL ]; $poe_kernel->alarm_remove( delete $heap->{tid} ) if $heap->{tid}; delete $heap->{wheel}; delete $heap->{tid}; }, TERM => sub { my( $heap, $kernel ) = @_[ HEAP, KERNEL ]; $poe_kernel->alarm_remove( delete $heap->{tid} ) if $heap->{tid}; delete $heap->{wheel}; $kernel->sig_handled; }, closeE => sub { my( $heap, $kernel ) = @_[ HEAP, KERNEL ]; seen( $heap, 'close' ); }, CHLD => sub { my( $heap, $kernel ) = @_[ HEAP, KERNEL ]; seen( $heap, 'CHLD' ); $kernel->sig_handled; }, stdout => sub { my( $heap, $kernel, $line, $wid ) = @_[ HEAP, KERNEL, ARG0..$#_ ]; seen( $heap, 'done' ) if $line eq 'done'; }, stderr => sub { my( $heap, $kernel, $line, $wid ) = @_[ HEAP, KERNEL, ARG0..$#_ ]; warn "ERROR [$$]: $line\n"; seen( $heap, 'error' ); $poe_kernel->alarm_remove( delete $heap->{tid} ) if $heap->{tid}; }, } ); } 1; z_rt39872_sigchld.pm100644000765000024 1006412425745722 22356 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl # vim: ts=2 sw=2 expandtab use strict; use warnings; sub POE::Kernel::USE_SIGCHLD () { 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; use POE::Wheel::Run; use POSIX qw( SIGINT ); if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { plan skip_all => "Perl crashes on $^O"; exit 0; } if ($INC{'Tk.pm'}) { plan skip_all => "Test causes XIO and other errors under Tk."; exit 0; } plan tests => 6; POE::Session->create( inline_states => { _start => \&_start, _stop => \&_stop, stdout => \&stdout, stderr => \&stderr, sig_CHLD => \&sig_CHLD, error => \&error, done => \&done } ); $poe_kernel->run; pass( "Sane exit" ); ### End of main code. Beginning of subroutines. sub _start { my( $kernel, $heap ) = @_[KERNEL, HEAP]; # This subprocess announces its name and exits when told to. my $prog = <<' PERL'; $|++; my $N = shift; print "I am $N\n"; while() { chomp; exit 0 if /^bye/; print "Unknown command '$_'\n"; } PERL note "$$ _start"; # Linger a bit. $kernel->alias_set( 'worker' ); # The W1 test # Start two subprocesses. # They will trigger stdout() when they announce themselves. $heap->{W1} = POE::Wheel::Run->new( Program => [ $^X, '-e', $prog, "W1" ], StdoutEvent => 'stdout', StderrEvent => 'stderr', ErrorEvent => 'error' ); $heap->{wheel_id_to_name}{ $heap->{W1}->ID } = 'W1'; $heap->{wheel_pid_to_name}{ $heap->{W1}->PID } = 'W1'; $kernel->sig_child($heap->{W1}->PID(), 'sig_CHLD'); $heap->{W2} = POE::Wheel::Run->new( Program => [ $^X, '-e', $prog, "W2" ], StdoutEvent => 'stdout', StderrEvent => 'stderr', ErrorEvent => 'error' ); $heap->{wheel_id_to_name}{ $heap->{W2}->ID } = 'W2'; $heap->{wheel_pid_to_name}{ $heap->{W2}->PID } = 'W2'; $kernel->sig_child($heap->{W2}->PID(), 'sig_CHLD'); } sub _stop { my( $kernel, $heap ) = @_[KERNEL, HEAP]; note "$$ _stop"; } # The first wheel is done. # Kill the other wheels. We want to be sure only one wheel is done. sub done { my( $kernel, $heap ) = @_[KERNEL, HEAP]; note "$$ done"; delete $heap->{W1}; delete $heap->{W2}; my @list = keys %{ $heap->{wheel_pid_to_name} }; is( 0+@list, 1, "One wheel left" ); kill SIGINT, @list; alarm(5); $SIG{ALRM} = sub { die "test case didn't end sanely" }; } # A child process has announced itself. # Test whether we got the right output. # If it's the "W1" test, have it shut down cleanly. sub stdout { my( $kernel, $heap, $input, $id ) = @_[KERNEL, HEAP, ARG0, ARG1]; my $N = $heap->{wheel_id_to_name}{$id}; note "$$ ($N) ($id) STDOUT: '$input'"; # Success if this is an announcement. ok( ($input =~ /I am $N/), "Intro output" ); return if $N ne 'W1'; my $wheel = $heap->{ $N }; # One of the subprocesses will be closed normally. # The other will be killed later. $heap->{closing}{ $N } = 1; $wheel->put( 'bye' ); } # Dump the child's STDERR for diagnostics. sub stderr { my( $kernel, $heap, $input, $id ) = @_[KERNEL, HEAP, ARG0, ARG1]; my $N = $heap->{wheel_id_to_name}{$id}; diag("$$ ($N) ($id) STDERR: '$input'"); } # Abnormal errors. Not part of the test, but the test should fail # anyway. sub error { my( $kernel, $heap, $op, $errnum, $errstr, $id, $fh ) = @_[ KERNEL, HEAP, ARG0..$#_ ]; unless ( $op eq 'read' and $errnum==0 ) { my $N = $heap->{wheel_id_to_name}{$id}; die("$$ Error $N ($id): $op $errnum ($errstr)"); } } # A child process has exited. How's that working out for us? sub sig_CHLD { my( $kernel, $heap, $signal, $pid, $status ) = @_[ KERNEL, HEAP, ARG0..$#_ ]; my $N = delete $heap->{wheel_pid_to_name}{$pid}; note "$$ CHLD $N ($pid)"; unless ($N eq 'W1') { is( $heap->{closing}{$N}, undef, "$N killed" ); return; } is( $heap->{closing}{$N}, 1, "$N closing" ); my $wheel = delete $heap->{ $N }; delete $heap->{closing}{$N}; delete $heap->{wheel_id_to_name}{ $wheel->ID }; # A brief delay to make sure all child processes are reaped. $kernel->delay( done => 0.25 ); } 1; z_kogman_sig_order.pm100644000765000024 2530112425745722 23130 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops# vim: ts=2 sw=2 expandtab # Tests propagation of signals through the session ancestry use warnings; use strict; use Test::More tests => 7; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; { my @log; my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->sig("foo" => "foo"); $_[KERNEL]->signal( $_[SESSION], "foo" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[STATE, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ leave_start => $session ], [ foo => $session ], [ stop => $session ], ], "simple signal on one session", ); } { my @log; my $child; my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $child = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->delay("bar" => 0.1); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->sig("foo" => "foo"); $_[KERNEL]->signal( $_[SESSION], "foo" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ enter_start => $child ], [ leave_start => $child ], [ child => $session ], [ leave_start => $session ], [ foo => $session ], [ default => bar => $child ], [ stop => $child ], [ child => $session ], [ stop => $session ], ], "signal on parent, oblivious child", ); } { my @log; my $child; my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $child = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->delay("bar" => 0.1); $_[KERNEL]->sig("foo" => "foo"); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->sig("foo" => "foo"); $_[KERNEL]->signal( $_[SESSION], "foo" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ enter_start => $child ], [ leave_start => $child ], [ child => $session ], [ leave_start => $session ], [ foo => $child ], [ foo => $session ], [ default => bar => $child ], [ stop => $child ], [ child => $session ], [ stop => $session ], ], "signal on child, then parent", ); } { my @log; my $child; my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $child = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->delay("bar" => 1); $_[KERNEL]->sig("TERM" => "TERM"); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->sig("TERM" => "TERM"); $_[KERNEL]->signal( $_[SESSION], "TERM" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ enter_start => $child ], [ leave_start => $child ], [ child => $session ], [ leave_start => $session ], [ default => TERM => $child ], [ default => TERM => $session ], [ stop => $child ], [ child => $session ], [ stop => $session ], ], "TERM signal on child, then parent", ); } { my @log; my $child; my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $child = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->delay("bar" => 1); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->signal( $_[SESSION], "TERM" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ enter_start => $child ], [ leave_start => $child ], [ child => $session ], [ leave_start => $session ], [ stop => $child ], [ child => $session ], [ stop => $session ], ], "TERM signal with no handlers on child, then parent", ); } { my @log; my ( $child, $grandchild ); my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $child = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $grandchild = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->delay("bar" => 1); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->sig( TERM => "TERM" ); $_[KERNEL]->delay("bar" => 1); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->signal( $_[SESSION], "TERM" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ enter_start => $child ], [ enter_start => $grandchild ], [ leave_start => $grandchild ], [ child => $child ], [ leave_start => $child ], [ child => $session ], [ leave_start => $session ], [ default => TERM => $child ], [ stop => $grandchild ], [ child => $child ], [ stop => $child ], [ child => $session ], [ stop => $session ], ], "TERM signal on granchild, then child (with handler), then parent", ); } { my @log; my ( $child, $grandchild ); my $session = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $child = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $grandchild = POE::Session->create( inline_states => { _start => sub { push @log, [ enter_start => $_[SESSION] ]; $_[KERNEL]->delay("bar" => 1); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->delay("bar" => 1); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); $_[KERNEL]->signal( $_[SESSION], "TERM" ); push @log, [ leave_start => $_[SESSION] ]; }, _child => sub { push @log, [ child => $_[SESSION] ] }, _stop => sub { push @log, [ stop => $_[SESSION] ] }, _default => sub { push @log, [ default => @_[ARG0, SESSION] ] }, foo => sub { push @log, [ foo => $_[SESSION] ] }, }, ); POE::Kernel->run; is_deeply( \@log, [ [ enter_start => $session ], [ enter_start => $child ], [ enter_start => $grandchild ], [ leave_start => $grandchild ], [ child => $child ], [ leave_start => $child ], [ child => $session ], [ leave_start => $session ], [ stop => $grandchild ], [ child => $child ], [ stop => $child ], [ child => $session ], [ stop => $session ], ], "TERM signal with no handlers on granchild, then child, then parent", ); } 1; comp_tcp_concurrent.pm100644000765000024 2051412425745722 23335 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Exercise Server::TCP and later, when it's available, Client::TCP. use strict; use lib qw(./mylib ../mylib); BEGIN { unless (-f "run_network_tests") { print "1..0 # Skip Network access (and permission) required to run this test\n"; CORE::exit(); } if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { print "1..0 # Skip Windows sockets aren't as concurrent as those on Unix\n"; CORE::exit(); } } my $NUM_CLIENTS; BEGIN { $NUM_CLIENTS = 9 } # rt.cpan.org 32034 use Test::More tests => $NUM_CLIENTS * 2; diag( "You might see a 'disconnect' error during this test." ); diag( "It may be ignored." ); sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 0 } use POE qw( Component::Server::TCP Wheel::ReadWrite Component::Client::TCP ); #use POE::API::Peek; my ($acceptor_port, $callback_port); sub DEBUG () { 0 } do_servers(); do_clients(); # Run the tests. POE::Kernel->run(); sub do_servers { my($acceptorN, $callbackN)=(0,0); my(%connected); ###################################################################### # Create a server. This one uses Acceptor to create a session of the # program's devising. POE::Component::Server::TCP->new( Port => 0, Address => '127.0.0.1', Alias => 'acceptor_server', Concurrency => 1, Started => sub { use Socket qw(sockaddr_in); $acceptor_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, Acceptor => sub { my ($socket, $peer_addr, $peer_port) = @_[ARG0..ARG2]; if( $connected{acceptor} ) { fail("acceptor server got simultaneous connections"); } else { pass("acceptor server : one connection open"); } $connected{acceptor} = 1; POE::Session->create( inline_states => { _start => sub { my $heap = $_[HEAP]; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $socket, InputEvent => 'got_input', ErrorEvent => 'got_error', FlushedEvent => 'got_flush', ); $heap->{tcp_server} = $_[SENDER]->ID; DEBUG and warn("$$: acceptor server got client connection"); }, _stop => sub { DEBUG and warn("$$: acceptor server stopped the client session"); $connected{acceptor} = 0; }, got_input => sub { my ($heap, $input) = @_[HEAP, ARG0]; $acceptorN++; DEBUG and warn( "$$: acceptor server received input ($input) ", "acceptorN=$acceptorN" ); $heap->{wheel}->put("echo: $input #$acceptorN"); if($input eq "quit") { DEBUG and warn("$$: accept_server quit"); $heap->{shutdown} = 1; $_[KERNEL]->post( $heap->{tcp_server} => 'shutdown' ); } }, got_error => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; if($operation eq 'read' and $errnum==0) { DEBUG and warn("$$: acceptor server disconnect error"); $heap->{shutdown} = 1; $_[KERNEL]->post( $heap->{tcp_server} => 'disconnected' ); } else { warn( "$$: acceptor server got $operation error $errnum: $errstr\n" ); } delete $heap->{wheel}; }, got_flush => sub { my $heap = $_[HEAP]; DEBUG and warn("$$: acceptor server flushed output"); if($heap->{shutdown}) { delete $heap->{wheel}; DEBUG and warn "$$: acceptor server disconnected"; $_[KERNEL]->post( $heap->{tcp_server} => 'disconnected' ); } }, }, ); }, ); ###################################################################### # Create a server. This one uses ClientXyz to process clients instead # of a user-defined session. POE::Component::Server::TCP->new( Port => 0, Address => '127.0.0.1', Alias => 'callback_server', Started => sub { use Socket qw(sockaddr_in); $callback_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, Concurrency => 4, # ClientShutdownOnError => 0, ClientInput => sub { my ($heap, $input) = @_[HEAP, ARG0]; $callbackN++; DEBUG and warn( "$$: callback server received input ($input) callbackN=$callbackN" ); if($input eq "quit") { DEBUG and warn("$$: callback_server quit"); $_[KERNEL]->post( callback_server => 'shutdown' ); } else { $heap->{client}->put("echo: $input #$callbackN"); } }, ClientError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; unless( $operation eq 'read' and $errnum == 0 ) { warn "$$: callback server got $operation error $errnum: $errstr\n"; } $_[KERNEL]->yield('shutdown'); }, ClientFlushed => sub { DEBUG and warn("$$: callback server flushed output"); }, ClientConnected => sub { $connected{callback} ++; if( $connected{callback} > 4 ) { fail( "callback server got $connected{callback} simultaneous connections" ); } else { pass("callback server : $connected{callback} connections open"); } DEBUG and warn("$$: callback server got client connection"); }, ClientDisconnected => sub { DEBUG and warn("$$: callback server got client disconnected"); $connected{callback} --; }, ); } sub do_clients { foreach my $N (1..$NUM_CLIENTS) { DEBUG and warn "$$: SPAWN\n"; two_clients($N); } } sub two_clients { my($N) = @_; my $parent=0; ###################################################################### # A client to connect to acceptor_server. POE::Component::Client::TCP->new( RemoteAddress => '127.0.0.1', RemotePort => $acceptor_port, Alias => "acceptor client $N", Connected => sub { DEBUG and warn("$$: acceptor client $N connected"); $_[HEAP]->{server}->put( "hello $N" ); }, ConnectError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; warn "$$: acceptor client $N got $operation error $errnum: $errstr\n"; }, Disconnected => sub { DEBUG and warn("$$: acceptor client $N disconnected"); }, ServerInput => sub { my ($heap, $input) = @_[HEAP, ARG0]; DEBUG and warn("$$: acceptor client $N got input ($input)"); if( $input =~ /#$NUM_CLIENTS$/ ) { $_[HEAP]->{server}->put( 'quit' ); } $_[KERNEL]->yield('shutdown'); }, ServerError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; ok( ($operation eq "read") && ($errnum == 0), "acceptor client $N got read error 0 (EOF)" ); }, ServerFlushed => sub { DEBUG and warn("$$: acceptor client $N flushed output"); }, ); ###################################################################### # A client to connect to callback_server. POE::Component::Client::TCP->new( RemoteAddress => '127.0.0.1', RemotePort => $callback_port, Alias => "callback client $N", Connected => sub { DEBUG and warn("$$: callback client $N connected"); $_[HEAP]->{server}->put( "hello $N" ); }, ConnectError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; warn "$$: callback client $N got $operation error $errnum: $errstr\n"; }, Disconnected => sub { DEBUG and warn("$$: callback client $N disconnected"); }, ServerInput => sub { my ($heap, $input) = @_[HEAP, ARG0]; DEBUG and warn("$$: callback client $N got input ($input)"); if( $input =~ /#$NUM_CLIENTS$/ ) { $_[HEAP]->{server}->put( 'quit' ); } $_[KERNEL]->yield('shutdown'); }, ServerError => sub { my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0..ARG2]; ok( ($operation eq "read") && ($errnum == 0), "callback client $N got $operation error $errnum (EOF)" ); }, ServerFlushed => sub { DEBUG and warn("$$: callback client $N flushed output"); }, ); } 1; z_rt53302_fh_watchers.pm100644000765000024 572012425745722 23201 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Rocco Caputo noticed this bug in POE::Loop::Glib v0.037. # LotR wanted this converted into a test in PTL so we can # verify the bug is gone and help other loop authors :) # TODO do we need a way to timeout the test? use strict; BEGIN { unless (-f "run_network_tests") { print "1..0 # Skip Network access (and permission) required to run this test\n"; CORE::exit(); } } sub POE::Kernel::ASSERT_DEFAULT () { 1 } #sub POE::Kernel::TRACE_FILES () { 1 } BEGIN { eval "sub POE::Kernel::TRACE_DEFAULT () { 1 }" if ( exists $INC{'Devel/Cover.pm'} ); } use Test::More; plan tests => 8; use POE qw( Component::Server::TCP Component::Client::TCP ); use Socket qw( sockaddr_in ); my $num_clients = 5; # testing variables my $num_server_connects = 0; my $num_server_disconnects = 0; my $num_server_inputs = 0; my $num_server_flushes = 0; my $acceptor_port; my $num_client_connects = 0; my $num_client_disconnects = 0; my $num_client_inputs = 0; my $num_client_flushes = 0; # Spawn the TCP server. POE::Component::Server::TCP->new( Alias => 'server', Address => 'localhost', Port => 0, Started => sub { $acceptor_port = ( sockaddr_in($_[HEAP]->{listener}->getsockname()) )[0]; }, ClientConnected => sub { $num_server_connects++ }, ClientInput => sub { $num_server_inputs++; $_[HEAP]->{client}->put( 'from server' ); $_[KERNEL]->yield( 'shutdown' ); }, ClientFlushed => sub { $num_server_flushes++ }, ClientDisconnected => sub { $num_server_disconnects++; # end the test after N clients is done if ( $num_server_disconnects >= $num_clients ) { $_[KERNEL]->call( 'server', 'shutdown' ); } }, ); # spawn the client for ( 1 .. $num_clients ) { POE::Component::Client::TCP->new( RemoteAddress => 'localhost', RemotePort => $acceptor_port, ConnectTimeout => 2, Connected => sub { $num_client_connects++; $_[HEAP]->{server}->put( 'from client' ); }, Disconnected => sub { $num_client_disconnects++ }, ServerInput => sub { $num_client_inputs++; $_[KERNEL]->delay( 'shutdown' => 1 ); }, ServerError => sub {}, ServerFlushed => sub { $num_client_flushes++ }, ); } $poe_kernel->run(); # Okay, make sure we processed N connections is( $num_server_connects, $num_clients, "Server got $num_clients client connections" ); is( $num_server_disconnects, $num_clients, "Server got $num_clients client disconnections" ); is( $num_server_inputs, $num_clients, "Client sent input $num_clients times" ); is( $num_server_flushes, $num_clients, "Server flushed $num_clients lines of data" ); is( $num_client_connects, $num_clients, "Client connected $num_clients times" ); is( $num_client_disconnects, $num_clients, "Client disconnected $num_clients times" ); is( $num_client_inputs, $num_clients, "Server sent input $num_clients times" ); is( $num_client_flushes, $num_clients, "Client flushed $num_clients lines of data" ); 1; z_rt39872_sigchld_stop.pm100644000765000024 661512425745722 23412 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl # vim: ts=2 sw=2 expandtab use strict; use warnings; my $REFCNT; sub POE::Kernel::USE_SIGCHLD () { 1 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use Test::More; use POSIX qw( SIGINT SIGUSR1 ); use POE; use POE::Wheel::Run; if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) { plan skip_all => "SIGUSR1 not supported on $^O"; exit 0; } if ($INC{'Tk.pm'} and not $ENV{POE_DANTIC}) { plan skip_all => "Test causes XIO and other errors under Tk."; exit 0; } $SIG{__WARN__} = sub { print STDERR "$$: $_[0]"; }; plan tests => 4; our $PARENT = 1; POE::Session->create( inline_states => { _start => \&_start, _stop => \&_stop, work => \&work, child => \&child, parent => \&parent, T1 => \&T1, T2 => \&T2, sig_CHLD => \&sig_CHLD, sig_USR1 => \&sig_USR1, done => \&done } ); note "Parent"; $poe_kernel->run; pass( "Sane exit" ) if $PARENT; note "Exit"; ### End of main code. Beginning of subroutines. sub _start { my( $kernel, $heap ) = @_[KERNEL, HEAP]; note "_start"; $kernel->yield( 'work' ); } sub work { my( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION]; foreach my $name ( qw( T1 T2 ) ) { my $pid = fork(); die "Unable to fork: $!" unless defined $pid; if( $pid ) { # parent $heap->{$name}{PID} = $pid; $heap->{pid_to_name}{ $pid } = $name; $kernel->sig_child($pid, 'sig_CHLD'); } else { $kernel->can('has_forked') and $kernel->has_forked(); $kernel->yield( 'child' ); return; } } foreach my $name ( qw( T1 T2 ) ) { $kernel->refcount_increment( $session->ID, $name ); } $kernel->delay_add( 'parent', 3 ); diag( "Parent $$ waiting 3sec for slow systems to settle." ); return; } sub parent { my( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION]; note "parent"; diag( "sending sigusr1" ); kill SIGUSR1, $heap->{T1}{PID}; diag( "sent sigusr1" ); $heap->{T1}{closing} = 1; } sub child { my( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION]; $PARENT = 0; note "child"; $kernel->sig( 'CHLD' ); $kernel->sig( USR1 => 'sig_USR1' ); $kernel->refcount_increment( $session->ID, 'USR1' ); } sub sig_USR1 { my( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION]; note "USR1"; $REFCNT = 1; $kernel->sig( 'USR1' ); $kernel->refcount_decrement( $session->ID, 'USR1' ); } sub _stop { my( $kernel, $heap ) = @_[KERNEL, HEAP]; note "_stop"; } sub done { my( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION]; note "done"; my @list = keys %{ $heap->{pid_to_name} }; is( 0+@list, 1, "One child left ($list[0])" ); kill SIGUSR1, @list; $REFCNT = 1; $kernel->refcount_decrement( $session->ID, 'T2' ); alarm(30); $SIG{ALRM} = sub { die "test case didn't end sanely" }; } sub sig_CHLD { my( $kernel, $heap, $signal, $pid, $status ) = @_[ KERNEL, HEAP, ARG0..$#_ ]; unless( $heap->{pid_to_name}{$pid} ) { return; } my $name = $heap->{pid_to_name}{$pid}; my $D = delete $heap->{$name}; if ($name ne 'T1') { is( $D->{closing}, undef, "Expected child exited" ); return; } is( $D->{closing}, 1, "Expected child exited" ); $kernel->refcount_decrement( $_[SESSION]->ID, $name ); delete $heap->{$name}; delete $heap->{pid_to_name}{$pid}; $kernel->yield( 'done' ); } 1; z_merijn_sigchld_system.pm100644000765000024 530212425745722 24163 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab filetype=perl # System shouldn't fail in this case. use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { package POE::Kernel; use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'}); } use POE; use constant TESTS => 4; use Test::More tests => TESTS; my $command = "/bin/true"; SKIP: { my @commands = grep { -x } qw(/bin/true /usr/bin/true); skip( "Couldn't find a 'true' to run under system()", TESTS ) unless ( @commands ); my $command = shift @commands; diag( "Using '$command' as our thing to run under system()" ); my $caught_child = 0; POE::Session->create( inline_states => { _start => sub { my $sig_chld; $sig_chld = $SIG{CHLD}; $sig_chld = "(undef)" unless defined $sig_chld; $! = undef; is( system( $command ), 0, "System returns properly chld($sig_chld) err($!)" ); # system() may return -1 when $SIG{CHLD} is in effect. # https://rt.perl.org/rt3/Ticket/Display.html?id=105700 # # The machinations to avoid this in POE would incur an ongoing # performance penalty for everyone: # # 1. Save the contents of $SIG{CHLD}. # # 2. Set $SIG{CHLD} = 'DEFAULT' before dispatching every # event, unless it's already 'DEFAULT'. # # 3. If $SIG{CHLD} is deliberately to 'DEFAULT' as a result of # actions inside a callback, set a flag indicating that the # value saved in step #1 should not be restored. # # 4. At the end of every event, restore $SIG{CHLD} to the # saved value, unless the flag not to restore it is set. # # Less convenient but much more optimal is for application and # module developers to localize $SIG{CHLD} = 'DEFAULT' before # calling system() or causing a module to call system(). $_[KERNEL]->sig( 'CHLD', 'chld' ); $sig_chld = $SIG{CHLD}; $sig_chld = "(undef)" unless defined $sig_chld; $! = undef; is( system( $command ), 0, "System returns properly chld($sig_chld) err($!)" ); # Turn off the handler, and try again. $_[KERNEL]->sig( 'CHLD' ); $sig_chld = $SIG{CHLD}; $sig_chld = "(undef)" unless defined $sig_chld; $! = undef; is( system( $command ), 0, "System returns properly chld($sig_chld) err($!)" ); }, chld => sub { diag( "Caught child" ); $caught_child++; }, _stop => sub { }, # Pacify assertions. } ); is( $caught_child, 0, "no child procs caught" ); } POE::Kernel->run(); 1; z_steinert_signal_integrity.pm100644000765000024 301612425745722 25066 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#!/usr/bin/perl -w # vim: ts=2 sw=2 expandtab # Jonathan Steinert produced a patch to fix POE::Wheel destruction # timing, and possibly other things, when they're passed as arguments # to an event handler. It didn't take into consideration a subtle and # obscure aspect of recursive signal dispatch. This regression test # makes sure nested signal dispatches receive the proper parameters. use strict; sub POE::Kernel::ASSERT_DEFAULT () { 1 } BEGIN { eval "sub POE::Kernel::TRACE_DEFAULT () { 1 }" if ( exists $INC{'Devel/Cover.pm'} ); } use POE; use POE::Wheel::ReadWrite; use POE::Pipe::OneWay; use Test::More tests => 2; my $session_count = 0; sub start_session { $session_count++; POE::Session->create( inline_states => { _start => \&setup, got_signal => \&handle_signal, timed_out => \&timed_out, # To pacify assertions. _stop => sub { }, _parent => sub { }, _child => sub { }, } ); } start_session(); $poe_kernel->signal($poe_kernel, MOO => 99); POE::Kernel->run(); ### End of main code. Beginning of subroutines. sub setup { start_session() if $session_count < 2; $_[KERNEL]->sig(MOO => "got_signal"); $_[KERNEL]->delay(timed_out => 2); } sub handle_signal { ok( ($_[ARG0] eq "MOO") && ($_[ARG1] == 99), "signal parameters: ('$_[ARG0]' eq 'MOO', $_[ARG1] == 99)" ); # Wait just a little bit, in case of spurious signal. POE::Kernel->delay( timed_out => 0.250 ); } sub timed_out { $_[KERNEL]->sig(MOO => undef); } 1; z_rt54319_bazerka_followtail.pm100644000765000024 373712425745722 24576 0ustar00trocstaff000000000000POE-Test-Loops-1.360/lib/POE/Test/Loops#! /usr/bin/env perl # vim: ts=2 sw=2 expandtab use strict; use warnings; sub POE::Kernel::CATCH_EXCEPTIONS () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } use Time::HiRes qw(time); use IO::Handle; use POE qw(Wheel::FollowTail); use constant { TESTS => 6, TIME_BETWEEN_WRITES => 0.5, }; use Test::More; use File::Temp; # Sanely generate the tempfile my $write_fh; eval { $write_fh = File::Temp->new( UNLINK => 1 ) }; plan skip_all => "Unable to create tempfile for testing" if $@; $write_fh->autoflush(1); my $write_count = 0; plan tests => TESTS; # Write to the log 2x as fast as it's polled. # Make sure none of the lines is delayed overly long. POE::Session->create( inline_states => { _start => sub { $_[KERNEL]->yield("on_tick"); }, on_tick => sub { print $write_fh ++$write_count, " ", time(), "\n"; $_[KERNEL]->delay("on_tick" => TIME_BETWEEN_WRITES) if $write_count < TESTS; }, _stop => sub { undef }, } ); # Read from the log at one check every 3 seconds. my $poll_interval = TIME_BETWEEN_WRITES * 2; my $per_test_timeout = TIME_BETWEEN_WRITES * 3; POE::Session->create( inline_states => { _start => sub { $_[HEAP]{tailor} = POE::Wheel::FollowTail->new( Filename => $write_fh->filename, InputEvent => "got_log_line", PollInterval => $poll_interval, ); # A long timeout to begin with. $_[KERNEL]->delay(timeout => $poll_interval * TESTS); }, got_log_line => sub { my ($write, $time) = split /\s+/, $_[ARG0]; my $elapsed = sprintf("%.2f", time() - $time); ok( $elapsed <= $per_test_timeout, "response time <= $per_test_timeout sec ($elapsed)" ); return if $write < TESTS; # Stop the timeout when we're done. $_[KERNEL]->delay(timeout => undef); delete $_[HEAP]{tailor}; }, timeout => sub { delete $_[HEAP]{tailor}; }, _stop => sub { undef }, } ); POE::Kernel->run(); 1;