IO-Event-0.814/000755 000000 000000 00000000000 15261136517 013101 5ustar00rootroot000000 000000 IO-Event-0.814/Changes000644 000000 000000 00000010525 15261136517 014377 0ustar00rootroot000000 000000 Revision history for IO-Event 0.814 2026-10-06 03:20:11 -0600 - use List::SomeUtils instead of List::MoreUtils (works around a broken dep in List::MoreUtils) (gh#10) - fixed a pod formatting goof - fixed the repository line in the Makefile.PL - migrated to Dist::Zilla - treat EWOULDBLOCK like EAGAIN, so non-blocking sockets work on Windows (rt#84473) - fixed test suite hangs on Windows (rt#84473) - Event backend now uses high resolution timers; previously timers had one second granularity unless the caller did `use Event` - Made the forked test inactivity timer more robust (rt#125351) - fixed race in t/forked2.t that caused failures under heavy load (rt#92200, Debian #730908; patch by Niko Tyni) 0.813 2013/09/17 - Spelling corrections contributed by x.guimard@free.fr - Replace CHANGELOG with Changes 0.812 2013/04/09 - Missing peerpath on FreeBSD 9 will die(). Work around. - Added missing depenency on List::MoreUtils 0.809 2013/04/04 - Remove rinetd.pl -- becoming its own module 0.808 2013/03/20 - No longer required to start with IO::Event->new() - fixed forked3.t, getline3.t, and multifork3.t tests - Added timer tests. - Now specifies "hard" on Event.pm timers - Added ->ie_desc() 0.807 2013/03/14 - Bugfix: IO::Event constructor calls that did not include an - explicit handler were not getting the correct handler. 0.806 2012/02/28 - Add 'diagnostics' to build requirements. - Documentation updates. 0.805 2011/06/17 - Docfix. It's IO::Event->timer() not IO::Event::timer. 0.804 2011/02/28 - Adjust tests to use 127.0.0.1 instead of Sys::Hostname::hostname 0.803 2011/02/27 - Adjust prerequisites and tests. Require Event & AnyEvent, run tests w/o them anyway. 0.802 2011/02/26 - Add missing files to the MANIFEST - Forgot to update README 0.801 2011/02/25 - Add framework to support multiple backend event loops. - Add AnyEvent as a new supported event loop. 0.704 2009/07/23 - Added new API: IO::Event::Callback that provides a - closure/callback interface instead of the subclass - interface of IO::Event. It's a layer. 0.703 2009/04/29 - OOps. Changes for 0.702 didn't actually make it in. 0.702 2009/04/28 - Added shutdown() - Bugfix: writes when the OS buffer was completely full are now handled properly 0.701 2009/02/17 - Made the use of Event.pm optional 0.603 2009/01/30 - Write buffering debugged. - Failure to close() on eof() now auto-closes. - Rewrote rinetd.pl to use Daemon::Generic 0.602 2006/10/05 - Minor bugfix to rinetd.pl 0.601 2005/11/04 - Added example program: rinetd.pl - API CHANGE: Replaced ie_connect_timeout() with ie_connect_failed(). Previously ie_eof() would be called for non-timeout connection failures. Now ie_connect_failed() handles all connection failues. - Documentation fixes. 0.508 2005/08/29 - Bugfix: don't try to read recently-closed filehandles. 0.507 2005/08/29 - Add support for read-only and write-only descriptors. 0.506 2005/01/27 - Drop Event objects to prevent memory leaks. 0.505 2005/01/21 - Removed some race-condition warnings if descriptors are - close()ed before EOF. 0.504 2004/05/05 - Dropped all calls to eof(). Switched from read() to sysread(). Fixed bugs in ie_invoke. Made forked.t portable to DragonflyBSD which probably also made it work on a bunch of other systems too. 0.503 2004/04/20 - Bugfix: eof was falsing positive - Bugfix: partial lines were being returned for <$ieo> 0.502 2004/02/24 - Added can_read() - Bugfix: spurrious warning in unget() - Added ungets() to support FileHandle::Unget semantics 0.501 2003/11/29 - Changed version numbering 'cause we don't want to get to 1.0 quite yet. - Add reentrantcy controls - Add readevents() - Add output buffer size related code. - Bugfix: remove input watermark code - Bugfix: retry read() until EAGAIN prevents lost events - Bugfix: don't suppress ie_eof after reopen or connect. 0.5 2003/11/26 - Lots more bugs fixed. Documentation added. Test case added. 0.4 2003/11/26 - Lots of bad bugs fixed. Some speedups. 0.3 2003/11/26 - Fixed the semantics of read() and sysread() to match perl's documentation. Oops. - Added 'use diagnostics' and fixed the things it complained about. - Added descriptions to the test suite. 0.2 2003/04/14 - Added sysread() 0.1 2002/12/20 - Initial revision IO-Event-0.814/INSTALL000644 000000 000000 00000004517 15261136517 014141 0ustar00rootroot000000 000000 This is the Perl distribution IO-Event. Installing IO-Event is straightforward. ## Installation with cpanm If you have cpanm, you only need one line: % cpanm IO::Event If it does not have permission to install modules to the current perl, cpanm will automatically set up and install to a local::lib in your home directory. See the local::lib documentation (https://metacpan.org/pod/local::lib) for details on enabling it in your environment. ## Installing with the CPAN shell Alternatively, if your CPAN shell is set up, you should just be able to do: % cpan IO::Event ## Manual installation As a last resort, you can manually install it. If you have not already downloaded the release tarball, you can find the download link on the module's MetaCPAN page: https://metacpan.org/pod/IO::Event Untar the tarball, install configure prerequisites (see below), then build it: % perl Makefile.PL % make && make test Then install it: % make install On Windows platforms, you should use `dmake` or `nmake`, instead of `make`. If your perl is system-managed, you can create a local::lib in your home directory to install modules to. For details, see the local::lib documentation: https://metacpan.org/pod/local::lib The prerequisites of this distribution will also have to be installed manually. The prerequisites are listed in one of the files: `MYMETA.yml` or `MYMETA.json` generated by running the manual build process described above. ## Configure Prerequisites This distribution requires other modules to be installed before this distribution's installer can be run. They can be found under the "configure_requires" key of META.yml or the "{prereqs}{configure}{requires}" key of META.json. ## Other Prerequisites This distribution may require additional modules to be installed after running Makefile.PL. Look for prerequisites in the following phases: * to run make, PHASE = build * to use the module code itself, PHASE = runtime * to run tests, PHASE = test They can all be found in the "PHASE_requires" key of MYMETA.yml or the "{prereqs}{PHASE}{requires}" key of MYMETA.json. ## Documentation IO-Event documentation is available as POD. You can run `perldoc` from a shell to read the documentation: % perldoc IO::Event For more information on installing Perl modules via CPAN, please see: https://www.cpan.org/modules/INSTALL.html IO-Event-0.814/LICENSE000644 000000 000000 00000046430 15261136517 014115 0ustar00rootroot000000 000000 This software is copyright (c) 2002-2026 by David Muir Sharnoff . 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) 2002-2026 by David Muir Sharnoff . 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. 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, see . 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 Moe Ghoul, President of Vice That's all there is to it! --- The Perl Artistic License 1.0 --- This software is Copyright (c) 2002-2026 by David Muir Sharnoff . This is free software, licensed under: The Perl 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End IO-Event-0.814/MANIFEST000644 000000 000000 00000001517 15261136517 014236 0ustar00rootroot000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.037 Changes INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README author.yml dist.ini lib/IO/Event.pm lib/IO/Event/AnyEvent.pm lib/IO/Event/Callback.pm lib/IO/Event/Emulate.pm lib/IO/Event/Event.pm maint/cip-before-install perlcriticrc t/00_diag.t t/01_use.t t/callbacks.tt t/callbacks1.t t/callbacks2.t t/callbacks3.t t/forked.tt t/forked1.t t/forked2.t t/forked3.t t/getline.tt t/getline1.t t/getline2.t t/getline3.t t/multifork.tt t/multifork1.t t/multifork2.t t/multifork3.t t/timer.tt t/timer1.t t/timer2.t t/timer3.t xt/author/critic.t xt/author/eol.t xt/author/filename.t xt/author/no_tabs.t xt/author/pod.t xt/author/pod_coverage.t xt/author/pod_spelling_common.t xt/author/pod_spelling_system.t xt/author/strict.t xt/author/version.t xt/release/fixme.t IO-Event-0.814/META.json000644 000000 000000 00000016136 15261136517 014531 0ustar00rootroot000000 000000 { "abstract" : "Tied Filehandles for Nonblocking IO with Object Callbacks", "author" : [ "David Muir Sharnoff ", "Graham Ollis " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.037, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "IO-Event", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "perl" : "5.006" } }, "develop" : { "recommends" : { "Dist::Zilla::Plugin::Author::Plicease::Upload" : "0", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::PruneFiles" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::Author::Plicease" : "2.79", "Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep" : "0", "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval" : "0", "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit" : "0", "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep" : "0", "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap" : "0", "Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA" : "0", "Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless" : "0", "Perl::Critic::Policy::CodeLayout::ProhibitHardTabs" : "0", "Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace" : "0", "Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines" : "0", "Perl::Critic::Policy::Community::ArrayAssignAref" : "0", "Perl::Critic::Policy::Community::BarewordFilehandles" : "0", "Perl::Critic::Policy::Community::ConditionalDeclarations" : "0", "Perl::Critic::Policy::Community::ConditionalImplicitReturn" : "0", "Perl::Critic::Policy::Community::DeprecatedFeatures" : "0", "Perl::Critic::Policy::Community::DiscouragedModules" : "0", "Perl::Critic::Policy::Community::DollarAB" : "0", "Perl::Critic::Policy::Community::Each" : "0", "Perl::Critic::Policy::Community::EmptyReturn" : "0", "Perl::Critic::Policy::Community::IndirectObjectNotation" : "0", "Perl::Critic::Policy::Community::LexicalForeachIterator" : "0", "Perl::Critic::Policy::Community::LoopOnHash" : "0", "Perl::Critic::Policy::Community::ModPerl" : "0", "Perl::Critic::Policy::Community::OpenArgs" : "0", "Perl::Critic::Policy::Community::OverloadOptions" : "0", "Perl::Critic::Policy::Community::POSIXImports" : "0", "Perl::Critic::Policy::Community::PackageMatchesFilename" : "0", "Perl::Critic::Policy::Community::PreferredAlternatives" : "0", "Perl::Critic::Policy::Community::StrictWarnings" : "0", "Perl::Critic::Policy::Community::Threads" : "0", "Perl::Critic::Policy::Community::Wantarray" : "0", "Perl::Critic::Policy::Community::WarningsSwitch" : "0", "Perl::Critic::Policy::Community::WhileDiamondDefaultAssignment" : "0", "Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames" : "0", "Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions" : "0", "Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode" : "0", "Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles" : "0", "Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline" : "0", "Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen" : "0", "Perl::Critic::Policy::Miscellanea::ProhibitFormats" : "0", "Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic" : "0", "Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements" : "0", "Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish" : "0", "Perl::Critic::Policy::Objects::ProhibitIndirectSyntax" : "0", "Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic" : "0", "Perl::Critic::Policy::Subroutines::ProhibitNestedSubs" : "0", "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros" : "0", "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators" : "0", "Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator" : "0", "Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator" : "0", "Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames" : "0", "Perl::Critic::Policy::Variables::ProhibitUnusedVariables" : "0", "Software::License::Perl_5" : "0" }, "requires" : { "File::Basename" : "0", "File::Find" : "0", "File::Glob" : "0", "File::Spec" : "0", "File::chdir" : "0", "FindBin" : "0", "Perl::Critic" : "0", "Test2::Require::Module" : "0.000121", "Test2::Tools::PerlCritic" : "0", "Test2::V0" : "0.000121", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.98", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::Strict" : "0", "YAML" : "0" } }, "runtime" : { "recommends" : { "AnyEvent" : "0", "EV" : "0", "Event" : "0" }, "requires" : { "Carp" : "0", "IO::Handle" : "0", "IO::Socket::INET" : "0", "IO::Socket::UNIX" : "0", "List::SomeUtils" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Socket" : "0", "Symbol" : "0", "Time::HiRes" : "0", "parent" : "0", "perl" : "5.006" } }, "test" : { "recommends" : { "EV" : "0" }, "requires" : { "AnyEvent" : "0", "Event" : "0", "Sys::Hostname" : "0", "Test::More" : "0.98", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/uperl/IO-Event/issues" }, "homepage" : "https://metacpan.org/pod/IO::Event", "repository" : { "type" : "git", "url" : "git://github.com/uperl/IO-Event.git", "web" : "https://github.com/uperl/IO-Event" } }, "version" : "0.814", "x_generated_by_perl" : "v5.42.3", "x_serialization_backend" : "Cpanel::JSON::XS version 4.43", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_use_unsafe_inc" : 0 } IO-Event-0.814/META.yml000644 000000 000000 00000002221 15261136517 014347 0ustar00rootroot000000 000000 --- abstract: 'Tied Filehandles for Nonblocking IO with Object Callbacks' author: - 'David Muir Sharnoff ' - 'Graham Ollis ' build_requires: AnyEvent: '0' Event: '0' Sys::Hostname: '0' Test::More: '0.98' perl: '5.006' configure_requires: ExtUtils::MakeMaker: '0' perl: '5.006' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.037, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: IO-Event recommends: AnyEvent: '0' EV: '0' Event: '0' requires: Carp: '0' IO::Handle: '0' IO::Socket::INET: '0' IO::Socket::UNIX: '0' List::SomeUtils: '0' POSIX: '0' Scalar::Util: '0' Socket: '0' Symbol: '0' Time::HiRes: '0' parent: '0' perl: '5.006' resources: bugtracker: https://github.com/uperl/IO-Event/issues homepage: https://metacpan.org/pod/IO::Event repository: git://github.com/uperl/IO-Event.git version: '0.814' x_generated_by_perl: v5.42.3 x_serialization_backend: 'YAML::Tiny version 1.76' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' x_use_unsafe_inc: 0 IO-Event-0.814/Makefile.PL000644 000000 000000 00000003404 15261136517 015054 0ustar00rootroot000000 000000 BEGIN { use strict; use warnings; unless(eval q{ use 5.006; 1}) { print "Perl 5.006 or better required\n"; exit; } } # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.037 use strict; use warnings; use 5.006; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Tied Filehandles for Nonblocking IO with Object Callbacks", "AUTHOR" => "David Muir Sharnoff , Graham Ollis ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "IO-Event", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.006", "NAME" => "IO::Event", "PREREQ_PM" => { "Carp" => 0, "IO::Handle" => 0, "IO::Socket::INET" => 0, "IO::Socket::UNIX" => 0, "List::SomeUtils" => 0, "POSIX" => 0, "Scalar::Util" => 0, "Socket" => 0, "Symbol" => 0, "Time::HiRes" => 0, "parent" => 0 }, "TEST_REQUIRES" => { "AnyEvent" => 0, "Event" => 0, "Sys::Hostname" => 0, "Test::More" => "0.98" }, "VERSION" => "0.814", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "AnyEvent" => 0, "Carp" => 0, "Event" => 0, "IO::Handle" => 0, "IO::Socket::INET" => 0, "IO::Socket::UNIX" => 0, "List::SomeUtils" => 0, "POSIX" => 0, "Scalar::Util" => 0, "Socket" => 0, "Symbol" => 0, "Sys::Hostname" => 0, "Test::More" => "0.98", "Time::HiRes" => 0, "parent" => 0 ); 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); IO-Event-0.814/README000644 000000 000000 00000046557 15261136517 014002 0ustar00rootroot000000 000000 NAME IO::Event - Tied Filehandles for Nonblocking IO with Object Callbacks VERSION version 0.814 SYNOPSIS use IO::Event; use IO::Event 'emulate_Event'; use IO::Event 'AnyEvent'; my $ioe = IO::Event->new($filehandle); my $ioe = IO::Event::Socket::INET->new( [ARGS] ) my $ioe = IO::Event::Socket::UNIX->new( [ARGS] ) my $timer = IO::Event->timer( [after => $seconds], interval => $seconds, cb => CODE); my $idler = IO::Event->idle( [min => $seconds], [max => $seconds], [reentrant => 0], cb => CODE); IO::Event::loop(); IO::Event::unloop_all(); DESCRIPTION IO::Event provides a object-based callback system for handling nonblocking IO. The design goal is to provide a system that just does the right thing w/o the user needing to think about it much. All APIs are kept as simple as possible yet at the same time, all functionality is accessible if needed. Simple things are easy. Hard things are possible. Most of the time file handling syntax will work fine: <$filehandle> and print $filehandle 'stuff'. IO::Event provides automatic buffering of output (with a callback to throttle). It provides automatic line-at-a-time input. After initial setup, call IO::Event::loop(). IO::Event was originally written to use Event. IO::Event still defaults to using Event but it can now use AnyEvent or its own event loop. CHOOSING AN EVENT HANDLER Until you create your first IO::Event object, you can choose which underlying event handler to use. The default is Event. To choose an event handler, use one of the following lines, import no_emulate_Event, emulate_Event, or AnyEvent. use IO::Event 'no_emulate_Event' use IO::Event 'emulate_Event' use IO::Event 'AnyEvent' The no_emulate_Event option means: use Event. The emulate_Event option means IO::Event should use its own event loop. Why? You should use AnyEvent if you want to have compatibility with other event loops. You should use emulate_Event if you don't need compatibility with other event loops and you have missing-event bugs when using Event. You should use Event if it works for you. The APIs are a bit different depending on which event loop you're using. Event To use Event's event loop: use IO::Event 'no_emulate_Event'; or just: use IO::Event IO::Event's definition for loop(), timer(), idle() and unloop_all() all default to the Event version unless emulate_Event or AnyEvent have been imported. This allows you to easily switch back and forth between Event's API and the others. AnyEvent To use AnyEvent's select loop, import AnyEvent. use IO::Event 'AnyEvent'; You can use AnyEvent's API directly or you can use IO::Event's emulated APIs: IO::Event::loop(), IO::Event::unloop(), IO::Event::timer(), and IO::Event::idle(). These behave like Event's routines of the same name but use AnyEvent underneath. During testing, using the pure-perl event loop of AnyEvent::Impl::Perl from AnyEvent version 5.271, some read events were dropped. To work around this, a synthetic read-ready event is dispatched for all connected read filehandles every two seconds. Turn this off or adjust its frequency by changing $IO::Event::AnyEvent::lost_event_hack. A numeric value is the time (in seconds) between dispatching read events. A false value turns off this performance-sapping hack. AnyEvent only provides basic support for idle() events: it promises to invoke them "every now and then". emulate_Event To use IO::Event's own select loop, import emulate_Event. use IO::Event 'emulate_Event'; IO::Event does not provide a complete emulation of everything that Event does. It provides the full timer API: my $timer = IO::Event::timer( [ARGS] ) instead of my $timer = Event::timer( [ARGS] ) However it does not provide timer events on filehandles, nor does it provide events for signals, or variable accesses. Use IO::Event::loop() instead of Event::loop(). Use IO::Event::unloop_all() instead of Event::unloop_all(). Use IO::Event::idle() instead of Event::idle(). It does not provide any other methods or functions from Event. If you need them, please send a patch. CONSTRUCTORS IO::Event->new($filehandle, [ $handler, [ $options ]]) The basic new constructor takes a filehandle and returns a pseudo-filehandle. Treat the IO::Event object as a filehandle. Do not use the original filehandle without good reason (let us know if you find a good reason so we can fix the problem). The handler is the class or object where you provide callback functions to handle IO events. It defaults to the package of the calling context. If present, $options is a hash reference with the following possible keys: description A text description of this filehandle. Used for debugging and error messages. read_only Set to true if this is a read-only filehandle. Do not accept output. write_only Set to true if this is a write-only filehandle. Do not attempt to read. autoread Set to 0 if this should not be an auto-read filehandle. IO::Event::Socket::INET->new( [ARGS] ) This constructor uses IO::Socket::INET->new() to create a socket using the ARGS provided. It returns an IO::Event object. The handler defaults as above or can be set with an additional pseudo-parameter for IO::Socket::UNIX->new(): Handler. A description for the socket can be provided with an additional pseudo-parameter: Description. IO::Event::Socket::UNIX->new( [ARGS] ) This constructor uses IO::Socket::UNIX->new() to create a socket using the ARGS provided. It returns an IO::Event object. The handler defaults as above or can be set with an additional pseudo-parameter for IO::Socket::UNIX->new(): Handler. A description for the socket can be provided with an additional pseudo-parameter: Description. MANDATORY HANDLERS These handler methods must be available in the handler object/class if the situation in which they would be called arises. ie_input($handler, $ioe, $input_buffer_reference) Invoked when there is fresh data in the input buffer. The input can be retrieved via directly reading it from $$input_buffer_reference or via read() from the $ioe filehandle, or by using a variety of standard methods for getting data: <$ioe> like IO::Handle $ioe->get() like Data::LineBuffer $ioe->read() like IO::Handle $ioe->sysread() like IO::Handle $ioe->getline() like IO::Handle $ioe->getlines() like IO::Handle $ioe->getsome() see below $ioe->ungets() like FileHandle::Unget At end-of-file, ie_input will only be invoked once. There may or may not be data in the input buffer. ie_connection($handler, $ioe) Invoked when a listen()ing socket is ready to accept(). It should call accept: sub ie_connection { my ($pkg, $ioe) = @_; my $newfh = $ioe->accept() } ie_read_ready($handler, $ioe, $underlying_file_handle) If autoreading is turned off then this will be invoked. ie_werror($handler, $ioe, $output_buffer_reference) A write error has occurred when trying to drain the write buffer. Provide an empty subroutine if you don't care. OPTIONAL HANDLERS These handler methods will be called if they are defined but it is not required that they be defined. ie_eof($handler, $ioe, $input_buffer_reference) This is invoked when the read-side of the filehandle has been closed by its source. ie_output This is invoked when data has just been written to the underlying filehandle. ie_outputdone This is invoked when all pending data has just been written to the underlying filehandle. ie_connected This is invoked when a connect() completes. ie_connect_failed($handler, $ioe, $error_code) This is invoked when a connect() fails. For a timeout, the error code will be ETIMEDOUT. ie_died($handler, $ioe, $method, $@) If another handler calls die then ie_died will be called with the IO::Event object, the name of the method just invoked, and the die string. If no ie_died() callback exists then execution will terminate. ie_timer This is invoked for timer events. ie_exception Invoked when an exceptional condition arises on the underlying filehandle ie_outputoverflow($handler, $ioe, $overflowing, $output_buffer_reference) Invoked when there is too much output data and the output buffers are overflowing. You can take some action to generate less output. This will be invoked exactly once (with $overflowing == 1) when there is too much data in the buffer and then exactly once again (with $overflowing == 0) when there is no longer too much data in the buffer. METHODS In addition to methods described in detail below, the following methods behave like their IO (mostly IO::Socket) counterparts (except for being mostly non-blocking...): connect listen open read sysread syswrite print eof shutdown Through AUTOLOAD (see the SUBSTITUTED METHODS section) methods are passed to underlying Event objects: loop unloop and many more... Through AUTOLOAD (see the SUBSTITUTED METHODS section) methods are passed to underlying IO objects: fileno stat truncate error opened untaint and many more... IO::Event defines its own methods too: ->accept($handler, %options) accept() is nearly identical to the normal IO::Socket::accept() method except that instead of optionally passing a class specifier for the new socket, you optionally pass a handler object or class. The returned filehandle is an IO::Event object. Supported options: description Sets the description for the new socket autoread Set to 0 if you do not want auto-read ->can_read($amount) Returns true if $amount bytes worth of input is available for reading. Note: this does not return true at EOF so be careful not to hang forever at EOF. ->getsome($amount) Returns $amount bytes worth of input or undef if the request can't be filled. Returns what it can at EOF. ->get() get() is like getline() except that it pre-chomp()s the results and assumes the input_record_separator is "\n". This is like get() from Data::LineBuffer. ->unget() Push chomp()ed lines back into the input buffer. This is like unget() from Data::LineBuffer. ->ungetline(), ->xungetc(), ->ungets() This is what ungetc() should be: it pushes a string back into the input buffer. This is unlike IO::Handle->ungetc which takes an ordinal and pushes one character back into the the input buffer. This is like FileHandle::Unget. ->handler($new_handler) Sets the handler object/class if $new_handler is provided. Returns the old handler. ->filehandle() Returns the underlying IO::Handle. ->event() Returns the underling Event. ->listener($listening) Used to note that a filehandle is being used to listen for connections (instead of receiving data). A passed parameter of 0 does the opposite. Returns the old value. This is mostly used internally in IO::Event. ->input_record_separator($new_sep) IO::Handle doesn't allow input_record_separator's on a per filehandle basis. IO::Event does. If you don't ever set a filehandle's input record separator, then it continuously defaults to the current value of $/. If you set it, then it will use your value and never look at $/ again. ->readevents($readevents) Get/set listening for read-ready events on the underlying filehandle. This could be used by ie_outputoverflow to control input flows. ->output_bufsize($output_bufsize) Get/set the size of the output buffer. ->autoread($autoread) Get/set automatic reading if data when data can be read. Without autoread turned on, the input buffer isn't filled and none of the read methods will work. The point of this is for working with non-data filehandles. This is an experts-only method that kinda defeats the purpose of this module. This would be necessary using recv() to get data. ->drain() Used to start looking for write-ready events on the underlying filehandle. In normal operation this is handled automatically. Deprecated: use writeevents(1) instead. ->reentrant($reentrant) Get/set reentrant callbacks. By default, IO::Event avoids making reentrant callbacks. This is good because your code is less likely to break. This is bad because you won't learn about things right away. For example, you will not learn the the output buffer is overflowing during print(). You'll have to wait for the output buffer to begin draining to find out. This could be a problem. ->close() If there is output buffered, close will be delayed until the output buffer drains. ->forceclose Close close immediately, even if there is output buffered. ->ie_desc([new description]) Returns (and sets) the text description of the filehandle. For debugging. EVENT LOOP FUNCTIONS These dispatch to whichever event handler was chosen (see "CHOOSING AN EVENT HANDLER"). IO::Event::loop() Run the event loop. IO::Event::unloop() Exit the current event loop. IO::Event::unloop_all() Exit all running event loops. IO::Event->timer( [ARGS] ) Create a timer. See "TIMER API" for the arguments. IO::Event->idle( [ARGS] ) Create an idle event. See "IDLE API" for the arguments. TIMER API The following timer construction arguments are supported by IO::Event's emulated event loop and IO::Event's API on top of AnyEvent: cb A callback to invoke when the timer goes off. The callback can either be a CODE reference or an array reference. If it's an array reference, the array should be a two element tuple: the first element is an object and the second object is a method to invoke on the object. The only argument to the method call a reference to the timer object: my ($object, $method) = @{$timer->{cb}} $object->$method($timer) at A time at which to invoke the callback. interval An interval, in seconds between repeat invocations of the callback. after The interval until the first invocation of the callback. After that, invoke every interval. The following methods (from Event) are supported on timer objects: start(), again(), now(), stop(), cancel(), is_cancelled(), is_running(), is_suspended(), pending. IDLE API The following idle construction arguments are supported by IO::Event's emulated event loop and IO::Event's API on top of AnyEvent: cb A callback to invoke when the event loop is idle. The callback can either be a CODE reference or an array reference. If it's an array reference, the array should be a two element tuple: the first element is an object and the second object is a method to invoke on the object. my ($object, $method) = @{$timer->{cb}} $object->$method(); min The minimum time between invocations of the callback. max The maximum time between invocations of the callback. The following methods (from Event) are supported on idle objects: start(), again(), now(), stop(), cancel(), is_cancelled(), is_running(), is_suspended(), pending. SUBSTITUTED METHODS Any method invocations that fail because the method isn't defined in IO::Event will by tried twice more: once using trying for a method on the inner (hidden) filehandle and once more trying for a method on the Event object that's used to create the select loop for this module. This dispatch is now deprecated with the choice of event handlers. EXAMPLE SERVER # This is a tcp line echo server my $listener = IO::Event::Socket::INET->new( Listen => 10, Proto => 'tcp', LocalPort => 2821, ); Event::loop(); sub ie_connection { my ($pkg, $lstnr) = @_; my $client = $lstnr->accept(); printf "accepted connection from %s:%s\n", $client->peerhost, $client->peerport; } sub ie_input { my ($pkg, $client, $ibufref) = @_; print $client <$client>; } SYSREAD and EOF sysread() is incompatible with eof() because eof() uses getc(). Most of the time this isn't a problem. In other words, some of the time this is a problem: lines go missing. For this reason, IO::Event never uses sysread(). In fact, if you ask it to do a sysread() it does a read() for you instead. On the other hand, at the current time no problems with syswrite have come to light and IO::Event uses syswrite and never any other form of write/print etc. DESTRUCTION IO::Event keeps copies of all of its registered filehandles. If you want to close a filehandle, you'll need to actually call close on it. DATA STRUCTURE The filehandle object itself is a funny kind of hash reference. If you want to use it to store your own data, you can. Please don't use hash keys that begin ie_ or io_ as those are the prefixes used by IO::Event and IO::Socket. The syntax is kinda funny: ${*$filehandle}{'your_hash_key'} SEE ALSO For a different API on top of IO::Event, see IO::Event::Callback. It uses IO::Event but provides a simpler and perhaps easier-to-use API. The following perl modules do something that is kinda similar to what is being done here: AnyEvent::Handle, AnyEvent::AIO, IO::AIO, IO::Multiplex, IO::NonBlocking, IO::Select Event, POE, POE::Component::Server::TCP, Net::Socket::NonBlock, Net::Server::Multiplex, NetServer::Generic The API borrows most heavily from IO::Multiplex. IO::Event uses Event.pm and thus can be used in programs that are already using Event or POE. Since the original writing of IO::Event, AnyEvent has been released and now AnyEvent::AIO and AnyEvent:Handle should be considered the only good alternatives to IO::Event. For an example program using IO::Event, see IO::Event::rinetd which used to be included in this package. BUGS The test suite only covers 40% of the code. The module is used by its author and seems solid. AUTHORS * David Muir Sharnoff * Graham Ollis COPYRIGHT AND LICENSE This software is copyright (c) 2002-2026 by David Muir Sharnoff . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. IO-Event-0.814/author.yml000644 000000 000000 00000000654 15261136517 015133 0ustar00rootroot000000 000000 --- pod_spelling_system: skip: 0 # list of words that are spelled correctly # (regardless of what spell check thinks) stopwords: - autoread - autoreading - cb - reentrant - Sharnoff pod_coverage: skip: 0 # format is "Class#method" or "Class", regex allowed # for either Class or method. private: - IO::Event::(Event|Emulate|AnyEvent) - IO::Event::Callback#ie_.*,handler,sock2handler IO-Event-0.814/dist.ini000644 000000 000000 00000001526 15261136517 014551 0ustar00rootroot000000 000000 name = IO-Event author = David Muir Sharnoff author = Graham Ollis license = Perl_5 copyright_holder = David Muir Sharnoff copyright_year = 2002-2026 version = 0.814 [@Author::Plicease] :version = 2.79 release_tests = 1 installer = MakeMaker release_tests_skip = changes\.t github_user = uperl workflow = static workflow = linux [RemovePrereqs] remove = strict remove = warnings remove = Event remove = Event::Watcher remove = AnyEvent remove = AnyEvent::Impl::Perl remove = diagnostics remove = IO::Event::Common [Prereqs / RuntimeRecommends] Event = 0 AnyEvent = 0 [Prereqs / TestRequires] Event = 0 AnyEvent = 0 [Author::Plicease::Upload] cpan = 1 [PruneFiles] filename = xt/release/changes.t IO-Event-0.814/lib/000755 000000 000000 00000000000 15261136517 013647 5ustar00rootroot000000 000000 IO-Event-0.814/lib/IO/000755 000000 000000 00000000000 15261136517 014156 5ustar00rootroot000000 000000 IO-Event-0.814/lib/IO/Event.pm000644 000000 000000 00000145277 15261136517 015615 0ustar00rootroot000000 000000 our $debug = 0; our $edebug = 0; our $sdebug = 0; { package IO::Event; # ABSTRACT: Tied Filehandles for Nonblocking IO with Object Callbacks our $VERSION = '0.814'; # VERSION use strict; no strict 'refs'; use warnings; use Carp qw(confess); our $base; our @ISA; ## no critic (ClassHierarchies::ProhibitExplicitISA) sub idle { IO::Event->import('no_emulate_Event') unless $base; &{$base . "::idle"}(@_); } sub loop { IO::Event->import('no_emulate_Event') unless $base; &{$base . "::loop"}(@_); } sub unloop { &{$base . "::unloop"}(@_); } sub unloop_all { &{$base . "::unloop_all"}(@_); } sub timer { shift; IO::Event->import('no_emulate_Event') unless $base; $base->timer(@_); } sub new { IO::Event->import('no_emulate_Event') unless $base; &{$base . "::new"}(@_); } sub import { my ($pkg, @stuff) = @_; for my $s (@stuff) { if ($s eq 'emulate_Event') { $base = 'IO::Event::Emulate'; require IO::Event::Emulate; } elsif ($s eq 'no_emulate_Event') { require Event; # Event only uses Time::HiRes when its import is called, # otherwise timers have one second granularity Event->import; require IO::Event::Event; $base = 'IO::Event::Event'; } elsif ($s eq 'AnyEvent') { require AnyEvent; ## no critic (Community::DiscouragedModules) require IO::Event::AnyEvent; $base = 'IO::Event::AnyEvent'; } else { die "unknown import: $s"; } @ISA = $base; ## no critic (ClassHierarchies::ProhibitExplicitISA) } return 1; } sub AUTOLOAD { my $self = shift; our $AUTOLOAD; my $method = $AUTOLOAD; $method =~ s/.*:://; # for whatever reason, UNIVERSAL::can() # doesn't seem to work on some filehandles my $r; my @r; my $fh = ${*$self}{ie_fh}; if ($fh) { if (wantarray) { ## no critic (Community::Wantarray) eval { @r = $fh->$method(@_) }; } else { eval { $r = $fh->$method(@_) }; } if ($@ && $@ =~ /Can't locate object method "(.*?)" via package/) { my $event = ${*$self}{ie_event}; if ($1 ne $method) { # nothing to do } elsif ($event && $event->can($method)) { if (wantarray) { ## no critic (Community::Wantarray) eval { @r = $event->$method(@_) }; } else { eval { $r = $event->$method(@_) }; } } else { confess qq{Can't locate object method "$method" via "@{[ ref($self) ]}", "@{[ ref($fh)||'IO::Handle' ]}", or "@{[ ref($event) ]}"}; } } } else { my $event = ${*$self}{ie_event}; if ($event && $event->can($method)) { if (wantarray) { ## no critic (Community::Wantarray) eval { @r = $event->$method(@_) }; } else { eval { $r = $event->$method(@_) }; } } else { confess qq{Can't locate object method "$method" via "@{[ ref($self) ]}" or "@{[ ref($event) ]}"}; } } confess $@ if $@; return @r if wantarray; ## no critic (Community::Wantarray) return $r; } }{package IO::Event::Common; use strict; use warnings; use Symbol; use Carp; require IO::Handle; use POSIX qw(BUFSIZ EBADF EINVAL ETIMEDOUT); use Errno (); use Socket; use Scalar::Util qw(weaken reftype); use Time::HiRes qw(time); our $in_callback = 0; my %fh_table; my %rxcache; my @pending_callbacks; sub display_bits { print STDERR unpack("b*", $_[0]); } sub count_bits { scalar(grep { $_ } split(//, unpack("b*", $_[0]))); } sub display_want { my ($name, $vec, %hash) = @_; my ($pkg, $file, $line) = caller; print STDERR "\n\nAT $file: $line\n"; print STDERR "$name\n"; for my $ioe (values %hash) { printf STDERR "%03d-", fileno(${*$ioe}{ie_fh}); # display_bits(${*$ioe}{ie_vec}); print STDERR "\n"; } print STDERR "----------"; display_bits($vec); printf STDERR " - %d\n", count_bits($vec); print STDERR scalar(keys(%hash)); print STDERR "\n"; exit 1; } my $counter = 1; sub new { my ($pkg, $fh, $handler, $options) = @_; # stolen from IO::Handle my $self = bless gensym(), $pkg; $handler = (caller(2))[0] unless $handler; confess unless ref $fh; unless (ref $options) { $options = { description => $options, }; } # some bits stolen from IO::Socket ${*$self}{ie_fh} = $fh; ${*$self}{ie_handler} = $handler; ${*$self}{ie_ibuf} = ''; ${*$self}{ie_obuf} = ''; ${*$self}{ie_obufsize} = BUFSIZ*4; ${*$self}{ie_autoread} = 1; ${*$self}{ie_pending} = {}; ${*$self}{ie_desc} = $options->{description} || "wrapper for $fh"; ${*$self}{ie_writeclosed} = EINVAL if $options->{read_only}; ${*$self}{ie_readclosed} = EINVAL if $options->{write_only}; $self->ie_register(); $fh->blocking(0); print "New IO::Event: ${*$self}{ie_desc} - now nonblocking\n" if $debug; # stolen from IO::Multiplex tie(*$self, $pkg, $self); return $self; } sub reset { my $self = shift; delete ${*$self}{ie_writeclosed}; delete ${*$self}{ie_readclosed}; delete ${*$self}{ie_eofinvoked}; delete ${*$self}{ie_overflowinvoked}; } # mark as listener sub listener { my ($self, $listener) = @_; $listener = 1 unless defined $listener; my $o = ${*$self}{ie_listener}; ${*$self}{ie_listener} = $listener; return $o; } # call out sub ie_invoke { my ($self, $required, $method, @args) = @_; if ($in_callback && ! ${*$self}->{ie_reentrant}) { # we'll do this later push(@pending_callbacks, [ $self, $required, $method, @args ]) unless exists ${*$self}{ie_pending}{$method}; ${*$self}{ie_pending}{$method} = 1; # prevent double invocation. needed? print STDERR "Delaying invocation of $method on ${*$self}{ie_desc} because we're already in a callback\n" if $debug; return; } local($in_callback) = 1; $self->ie_do_invoke($required, $method, @args); while (@pending_callbacks) { my ($ie, $req, $meth, @a) = @{shift @pending_callbacks}; delete ${*$ie}{ie_pending}{$meth}; print STDERR "Processing delayed invocation of $meth on ${*$ie}{ie_desc}\n" if $debug; $ie->ie_do_invoke($req, $meth, @a); } return; } sub ie_do_invoke { my ($self, $required, $method, @args) = @_; print STDERR "invoking ${*$self}{ie_fileno} ${*$self}{ie_handler}->$method\n" if $debug; return if ! $required && ! ${*$self}{ie_handler}->can($method); if ($debug) { my ($pkg, $line, $func) = caller(); print "DISPATCHING $method on ${*$self}{ie_desc} from $func at line $line\n"; } eval { ${*$self}{ie_handler}->$method($self, @args); }; print STDERR "return from ${*$self}{ie_fileno} ${*$self}{ie_handler}->$method handler: $@\n" if $debug; return unless $@; if (${*$self}{ie_handler}->can('ie_died')) { ${*$self}{ie_handler}->ie_died($self, $method, $@); } else { confess $@; exit 1; ## no critic (ControlStructures::ProhibitUnreachableCode) } } # # we use a single event handler so that the AUTOLOAD # function can try a single $event object when looking for # methods # sub ie_dispatch { print STDERR "D" if $sdebug; my ($self, $ievent) = @_; my $fh = ${*$self}{ie_fh}; my $got = $ievent->got; { if ($got & Event::Watcher::R()) { last if $self->ie_dispatch_read($fh); } if ($got & Event::Watcher::W()) { last if $self->ie_dispatch_write($fh); } if ($got & Event::Watcher::E()) { $self->ie_dispatch_exception($fh); } if ($got & Event::Watcher::T()) { $self->ie_dispatch_timer(); } } } sub ie_dispatch_read { my ($self, $fh) = @_; printf STDERR "R%d", $self->fileno if $sdebug; if (${*$self}{ie_listener}) { $self->ie_invoke(1, 'ie_connection'); } elsif (${*$self}{ie_autoread}) { $self->ie_input(); } else { $self->ie_invoke(1, 'ie_read_ready', $fh); } return 1 if ${*$self}{ie_writeclosed} && ${*$self}{ie_readclosed}; return 0; } sub ie_dispatch_write { my ($self, $fh) = @_; printf STDERR "W%d", $self->fileno if $sdebug; if (${*$self}{ie_connecting}) { $self->writeevents(0); delete ${*$self}{ie_connecting}; delete ${*$self}{ie_connect_timeout}; $self->ie_invoke(0, 'ie_connected'); } else { my $obuf = \${*$self}{ie_obuf}; my $rv; if (length($$obuf)) { $rv = syswrite($fh, $$obuf); if (defined $rv) { substr($$obuf, 0, $rv) = ''; } elsif ($!{EAGAIN} || $!{EWOULDBLOCK}) { # this shouldn't happen, but # it's not that big a deal } else { # the file descriptor is toast ${*$self}{ie_writeclosed} = $!; $self->ie_invoke(0, 'ie_werror', $obuf); } } if (${*$self}{ie_closerequested}) { if (! length($$obuf)) { $self->ie_deregister(); ${*$self}{ie_fh}->close(); delete ${*$self}{ie_closerequested}; } } elsif (${*$self}{ie_shutdownrequested}) { if (! length($$obuf)) { shutdown(${*$self}{ie_fh}, 1); ${*$self}{ie_writeclosed} = 1; delete ${*$self}{ie_shutdownrequested}; $self->ie_invoke(0, 'ie_outputdone', $obuf, 0); } } else { $self->ie_invoke(0, 'ie_output', $obuf, $rv); return 1 if ${*$self}{ie_writeclosed} && ${*$self}{ie_readclosed}; if (! length($$obuf)) { $self->ie_invoke(0, 'ie_outputdone', $obuf, 1); return 1 if ${*$self}{ie_writeclosed} && ${*$self}{ie_readclosed}; if (! length($$obuf)) { $self->writeevents(0); } } if (length($$obuf) > ${*$self}{ie_obufsize}) { ${*$self}{ie_overflowinvoked} = 1; $self->ie_invoke(0, 'ie_outputoverflow', 1, $obuf); } elsif (${*$self}{ie_overflowinvoked}) { ${*$self}{ie_overflowinvoked} = 0; $self->ie_invoke(0, 'ie_outputoverflow', 0, $obuf); } } } return 1 if ${*$self}{ie_writeclosed} && ${*$self}{ie_readclosed}; return 0; } sub ie_dispatch_exception { my ($self, $fh) = @_; printf STDERR "E%d", fileno(${*$self}{ie_fh}) if $sdebug; if (${*$self}{ie_closerequested}) { $self->forceclose; } elsif (${*$self}{ie_writeclosed} && ${*$self}{ie_readclosed}) { $self->forceclose; } elsif ($fh->eof) { if (length(${*$self}{ie_ibuf})) { $self->ie_invoke(0, 'ie_input', \${*$self}{ie_ibuf}); } if (${*$self}{ie_eofinvoked}++) { warn "EOF repeat"; } else { ${*$self}{ie_closecalled} = 0; $self->ie_invoke(0, 'ie_eof', \${*$self}{ie_ibuf}); unless (${*$self}{ie_closecalled}) { $self->close; } } } else { # print STDERR "!?!"; $self->ie_invoke(0, 'ie_exception'); } } sub ie_dispatch_timer { my ($self) = @_; printf STDERR "T%d", fileno(${*$self}{ie_fh}) if $sdebug; if (${*$self}{ie_connecting} && ${*$self}{ie_connect_timeout} && time >= ${*$self}{ie_connect_timeout}) { delete ${*$self}{ie_connect_timeout}; $self->ie_invoke(0, 'ie_connect_failed', ETIMEDOUT) or $self->ie_invoke(0, 'ie_timer'); } else { $self->ie_invoke(0, 'ie_timer'); } } # same name as handler since we want to intercept invocations # when processing pending callbacks. Why? sub ie_input { my $self = shift; my $ibuf = \${*$self}{ie_ibuf}; # # We'll loop just to make sure we don't miss an event # for (;;) { my $ol = length($$ibuf); my $rv = ${*$self}{ie_fh}->sysread($$ibuf, BUFSIZ, $ol); # my $x = defined($rv) ? $rv : "$!"; # LOST EVENTS # print STDERR ""; # LOST EVENTS if ($rv) { delete ${*$self}{ie_readclosed}; } elsif (defined($rv)) { # must be 0 and closed! ${*$self}{ie_readclosed} = 1; last; } elsif ($!{EAGAIN} || $!{EWOULDBLOCK}) { # readclosed = 0? last; } else { # errors other than EAGAIN aren't recoverable ${*$self}{ie_readclosed} = $!; last; } $self->ie_invoke(1, 'ie_input', $ibuf); last if ${*$self}{ie_readclosed}; } if (${*$self}{ie_readclosed}) { $self->ie_invoke(1, 'ie_input', $ibuf) if length($$ibuf); if (${*$self}{ie_connecting}) { ${*$self}{ie_writeclosed} = $!; $self->writeevents(0); delete ${*$self}{ie_connecting}; delete ${*$self}{ie_connect_timeout}; $self->ie_invoke(0, 'ie_connect_failed', $!); } else { $self->ie_invoke(0, 'ie_eof', $ibuf) unless ${*$self}{ie_eofinvoked}++; } $self->readevents(0); } } sub reentrant { my $self = shift; my $old = ${*$self}{ie_reentrant}; if (@_) { ${*$self}{ie_reentrant} = $_[0]; } return $old; } sub output_bufsize { my $self = shift; my $old = ${*$self}{ie_obufsize}; if (@_) { ${*$self}{ie_obufsize} = $_[0]; if (length(${*$self}{ie_obuf}) > ${*$self}{ie_obufsize}) { $self->ie_invoke(0, 'ie_outputoverflow', 1, ${*$self}{ie_obuf}); ${*$self}{ie_overflowinvoked} = 1; } elsif (${*$self}{ie_overflowinvoked}) { $self->ie_invoke(0, 'ie_outputoverflow', 0, ${*$self}{ie_obuf}); ${*$self}{ie_overflowinvoked} = 0; } # while this should trigger callbacks, we don't want to assume # that our caller's code is re-enterant. } return $old; } # get/set autoread sub autoread { my $self = shift; my $old = ${*$self}{ie_autoread}; if (@_) { ${*$self}{ie_autoread} = $_[0]; if (${*$self}{ie_readclosed}) { delete ${*$self}{ie_readclosed}; $self->readevents(1); } } return $old; } sub writeevents { my $self = shift; my $old = ${*$self}{ie_want_write_events}; return !! $old unless @_; my $new = !! shift; return $old if defined($old) && $old eq $new; ${*$self}{ie_want_write_events} = $new; $self->set_write_polling($new); return $old; } sub readevents { my $self = shift; my $old = ${*$self}{ie_want_read_events}; return !! $old unless @_; my $new = !! shift; # print STDERR ""; # LOST EVENTS return $old if defined($old) && $old eq $new; ${*$self}{ie_want_read_events} = $new; $self->set_read_polling($new); return $old; } sub drain { my $self = shift; $self->writeevents(1); } # register with Event sub ie_register { my ($self) = @_; my $fh = ${*$self}{ie_fh}; $fh->blocking(0); $fh->autoflush(1); my $fileno = ${*$self}{ie_fileno} = $fh->fileno; return ($fh, $fileno); } # deregister with Event sub ie_deregister { my ($self) = @_; my $fh = ${*$self}{ie_fh}; delete $fh_table{$fh}; $self->readevents(0); $self->writeevents(0); } # the standard max() function sub ie_max { my ($max, @stuff) = @_; for my $t (@stuff) { $max = $t if $t > $max; } return $max; } # get the Filehandle sub filehandle { my ($self) = @_; return ${*$self}{ie_fh}; } # get the Event sub event { my ($self) = @_; return ${*$self}{ie_event}; } # set the handler sub handler { my $self = shift; my $old = ${*$self}{ie_handler}; ${*$self}{ie_handler} = $_[0] if @_; return $old; } # is there enough? sub can_read { my ($self, $length) = @_; my $l = length(${*$self}{ie_ibuf}); return $l if $l && $l >= $length; return "0 but true" if $length <= 0; return 0; } # reads N characters or returns undef if it can't sub getsome { my ($self, $length) = @_; return undef unless ${*$self}{ie_autoread}; my $ibuf = \${*$self}{ie_ibuf}; $length = length($$ibuf) unless defined $length; my $tmp = substr($$ibuf, 0, $length); substr($$ibuf, 0, $length) = ''; return undef if ! length($tmp) && ! $self->eof2; return $tmp; } # from base perl # will this work right for SOCK_DGRAM? sub connect { my $self = shift; my $fh = ${*$self}{ie_fh}; my $rv = $fh->connect(@_); $self->reset; $self->readevents(1); unless($fh->connected()) { ${*$self}{ie_connecting} = 1; $self->writeevents(1); ${*$self}{ie_connect_timeout} = time + ${*$self}{ie_socket_timeout} if ${*$self}{ie_socket_timeout}; } return $rv; } # from IO::Socket sub listen { my $self = shift; my $fh = ${*$self}{ie_fh}; my $rv = $fh->listen(); $self->listener(1); return $rv; } # from IO::Socket sub accept { my ($self, $handler) = @_; my $fh = ${*$self}{ie_fh}; my $newfh = $fh->accept(); return undef unless $newfh; # it appears that sockdomain isn't set on accept()ed sockets my $sd = $fh->sockdomain; my $desc; if ($sd == &AF_INET) { $desc = sprintf "Accepted socket from %s:%s to %s:%s", $newfh->peerhost, $newfh->peerport, $newfh->sockhost, $newfh->sockport; } elsif ($sd == &AF_UNIX) { # Unset peerpath crashes on FreeBSD 9 my $pp = eval { $newfh->peerpath }; if ($pp) { $desc = sprintf "Accepted socket from %s to %s", $pp, $newfh->hostpath; } else { $desc = sprintf "Accepted socket from to %s", $newfh->hostpath; } } else { $desc = "Accept for ${*$self}{ie_desc}"; } $handler = ${*$self}{ie_handler} unless defined $handler; my $new = IO::Event->new($newfh, $handler, $desc); ${*$new}{ie_obufsize} = ${*$self}{ie_obufsize}; ${*$new}{ie_reentrant} = ${*$self}{ie_reentrant}; return $new; } # not the same as IO::Handle sub input_record_separator { my $self = shift; my $old = ${*$self}{ie_irs}; ${*$self}{ie_irs} = $_[0] if @_; if ($debug) { my $fn = $self->fileno; my $x = ${*$self}{ie_irs}; $x =~ s/\n/\\n/g; print "input_record_separator($fn) = '$x'\n"; } return $old; } # 0 = read # 1 = write # 2 = both sub shutdown { my ($self, $what) = @_; my $r; if ($what == 1 || $what == 2) { if (length(${*$self}{ie_obuf})) { ${*$self}{ie_shutdownrequested} = $what; if ($what == 2) { $r = shutdown(${*$self}{ie_fh}, 0) } } else { $r = shutdown(${*$self}{ie_fh}, $what); ${*$self}{ie_writeclosed} = 1; } } elsif ($what == 0) { $r = shutdown(${*$self}{ie_fh}, 0); } else { die; } if ($what == 0 || $what == 2) { ${*$self}{ie_readclosed} = 1; } return 1 unless defined($r); return $r; } # from IO::Handle sub close { my ($self) = @_; my $obuf = \${*$self}{ie_obuf}; ${*$self}{ie_closecalled} = 1; if (length($$obuf)) { ${*$self}{ie_closerequested} = 1; ${*$self}{ie_writeclosed} = 1; ${*$self}{ie_readclosed} = 1; } else { return $self->forceclose; } } sub forceclose { my ($self) = @_; $self->ie_deregister(); my $ret = ${*$self}{ie_fh}->close(); ${*$self}{ie_writeclosed} = 1; ${*$self}{ie_readclosed} = 1; ${*$self}{ie_totallyclosed} = 1; print STDERR "forceclose(${*$self}{ie_desc})\n" if $debug; return $ret; } # from IO::Handle sub open { my $self = shift; my $fh = ${*$self}{ie_fh}; $self->ie_deregister(); $self->close() if $fh->opened; $self->reset; my $r; if (@_ == 1) { $r = CORE::open($fh, $_[0]); } elsif (@_ == 2) { $r = CORE::open($fh, $_[0], $_[1]); } elsif (@_ == 3) { $r = CORE::open($fh, $_[0], $_[1], $_[4]); } elsif (@_ > 3) { $r = CORE::open($fh, $_[0], $_[1], $_[4], @_); } else { confess("open w/o enoug args"); } return undef unless defined $r; $self->ie_register(); return $r; } # from IO::Handle VAR LENGTH [OFFSET] # # this returns nothing unless there is enough to fill # the request or it's at eof # sub sysread { my $self = shift; unless (${*$self}{ie_autoread}) { my $buf = shift; my $length = shift; my $rv = ${*$self}{ie_fh}->sysread($buf, $length, @_); if ($rv) { delete ${*$self}{ie_readclosed}; } elsif (defined($rv)) { # must be 0 and closed! ${*$self}{ie_readclosed} = 1; } elsif ($!{EAGAIN} || $!{EWOULDBLOCK}) { # nothing there } else { # errors other than EAGAIN aren't recoverable ${*$self}{ie_readclosed} = $!; } return $rv; } my $ibuf = \${*$self}{ie_ibuf}; my $length = length($$ibuf); return undef unless $length >= $_[1] || $self->eof2; (defined $_[2] ? substr ($_[0], $_[2], length($_[0])) : $_[0]) = substr($$ibuf, 0, $_[1]); substr($$ibuf, 0, $_[1]) = ''; return ($length-length($$ibuf)); } # from IO::Handle sub syswrite { my ($self, $data, $length, $offset) = @_; if (defined $offset or defined $length) { return $self->print(substr($data, $offset, $length)); } else { return $self->print($data); } } # like Data::LineBuffer sub get { my $self = shift; return undef unless ${*$self}{ie_autoread}; my $ibuf = \${*$self}{ie_ibuf}; my $irs = "\n"; my $index = index($$ibuf, $irs); if ($index < 0) { return undef unless $self->eof2; my $l = $$ibuf; $$ibuf = ''; return undef unless length($l); return $l; } my $line = substr($$ibuf, 0, $index - length($irs) + 1); substr($$ibuf, 0, $index + 1) = ''; return $line; } # like Data::LineBuffer # input_record_separator is always "\n". sub unget { my $self = shift; my $irs = "\n"; no warnings; substr(${*$self}{ie_ibuf}, 0, 0) = join($irs, @_, undef); } # from IO::Handle sub getline { my $self = shift; return undef unless ${*$self}{ie_autoread}; my $ibuf = \${*$self}{ie_ibuf}; my $fh = ${*$self}{ie_fh}; my $irs = exists ${*$self}{ie_irs} ? ${*$self}{ie_irs} : $/; my $line; # perl's handling if input record separators is # not completely simple. $irs = $$irs if ref $irs; my $index; if ($irs =~ /^\d/ && int($irs)) { if ($irs > 0 && length($$ibuf) >= $irs) { $line = substr($$ibuf, 0, $irs); } elsif ($self->eof2) { $line = $$ibuf; } } elsif (! defined $irs) { if ($self->eof2) { $line = $$ibuf; } } elsif ($irs eq '') { # paragraph mode $$ibuf =~ s/^\n+//; $irs = "\n\n"; $index = index($$ibuf, "\n\n"); } else { # multi-character (or just \n) $index = index($$ibuf, $irs); } if (defined $index) { $line = $index > -1 ? substr($$ibuf, 0, $index+length($irs)) : ($self->eof2 ? $$ibuf : undef); } if ($debug) { no warnings; my $x = $$ibuf; substr($x, 0, length($line)) = ''; $x =~ s/\n/\\n/g; my $y = $irs; $y =~ s/\n/\\n/g; print "looked for '$y', returning undef, keeping '$x'\n" unless defined $line; my $z = $line; $z =~ s/\n/\\n/g; print "looked for '$y', returning '$z', keeping '$x'\n" if defined $line; } return undef unless defined($line) && length($line); substr($$ibuf, 0, length($line)) = ''; return $line; } # is the following a good idea? #sub tell #{ # my ($self) = @_; # return ${*$self}{ie_fh}->tell() + length(${*$self}{ie_obuf}); #} # from IO::Handle sub getlines { my $self = shift; return undef unless ${*$self}{ie_autoread}; my $ibuf = \${*$self}{ie_ibuf}; #my $ol = length($$ibuf); my $irs = exists ${*$self}{ie_irs} ? ${*$self}{ie_irs} : $/; my @lines; if ($debug) { my $x = $irs; $x =~ s/\n/\\n/g; my $fn = $self->fileno; print "getlines($fn, '$x')\n"; } if ($irs =~ /^\d/ && int($irs)) { if ($irs > 0) { @lines = unpack("(a$irs)*", $$ibuf); $$ibuf = ''; $$ibuf = pop(@lines) if length($lines[$#lines]) != $irs && ! $self->eof2; } else { return undef unless $self->eof2; @lines = $$ibuf; $$ibuf = ''; } } elsif (! defined $irs) { return undef unless $self->eof2; @lines = $$ibuf; $$ibuf = ''; } elsif ($irs eq '') { # paragraphish mode. $$ibuf =~ s/^\n+//; @lines = grep($_ ne '', split(/(.*?\n\n)\n*/s, $$ibuf)); $$ibuf = ''; $$ibuf = pop(@lines) if @lines && substr($lines[$#lines], -2) ne "\n\n" && ! $self->eof2; if ($debug) { my $x = join('|', @lines); $x =~ s/\n/\\n/g; my $y = $$ibuf; $y =~ s/\n/\\n/g; print "getlines returns '$x' but holds onto '$y'\n"; } } else { # multicharacter $rxcache{$irs} = qr/(.*?\Q$irs\E)/s unless exists $rxcache{$irs}; my $irsrx = $rxcache{$irs}; @lines = grep($_ ne '', split(/$rxcache{$irs}/, $$ibuf)); return undef unless @lines; $$ibuf = ''; $$ibuf = pop(@lines) if substr($lines[$#lines], 0-length($irs)) ne $irs && ! $self->eof2; } return @lines; } # from IO::Handle sub ungetc { my ($self, $ord) = @_; my $ibuf = \${*$self}{ie_ibuf}; substr($$ibuf, 0, 0) = chr($ord); } # from FileHandle::Unget & original sub ungets { my $self = shift; substr(${*$self}{ie_ibuf}, 0, 0) = join('', @_); } *xungetc = \&ungets; *ungetline = \&ungets; # from IO::Handle sub getc { my ($self) = @_; $self->getsome(1); } # from IO::Handle sub print { my ($self, @data) = @_; $! = ${*$self}{ie_writeclosed} && return undef if ${*$self}{ie_writeclosed}; my $ol; my $rv; my $er; my $obuf = \${*$self}{ie_obuf}; if ($ol = length($$obuf)) { $$obuf .= join('', @data); $rv = length($$obuf) - $ol; } else { my $fh = ${*$self}{ie_fh}; my $data = join('', @data); $rv = CORE::syswrite($fh, $data); if (defined($rv) && $rv < length($data)) { $$obuf = substr($data, $rv, length($data)-$rv); $self->writeevents(1); $rv = 1; } elsif ((! defined $rv) && ($!{EAGAIN} || $!{EWOULDBLOCK})) { $$obuf = $data; $self->writeevents(1); $rv = 1; } else { $er = 0+$!; } } if (length($$obuf) > ${*$self}{ie_obufsize}) { $self->ie_invoke(0, 'ie_outputoverflow', 1, $obuf); ${*$self}{ie_overflowinvoked} = 1; } elsif (${*$self}{ie_overflowinvoked}) { $self->ie_invoke(0, 'ie_outputoverflow', 0, $obuf); ${*$self}{ie_overflowinvoked} = 0; } $! = $er; return $rv; } # from IO::Handle sub eof { my ($self) = @_; return 0 if length(${*$self}{ie_ibuf}); return 1 if ${*$self}{ie_readclosed}; return 0; # return ${*$self}{ie_fh}->eof; } # internal use only. # just like eof, but we assume the input buffer is empty sub eof2 { my ($self) = @_; if ($debug) { my $fn = $self->fileno; print "eof2($fn)..."; print " readclosed" if ${*$self}{ie_readclosed}; #print " EOF" if ${*$self}{ie_fh}->eof; my $x = 0; $x = 1 if ${*$self}{ie_readclosed}; # $x = ${*$self}{ie_fh}->eof unless defined $x; print " =$x\n"; } return 1 if ${*$self}{ie_readclosed}; return 0; # return ${*$self}{ie_fh}->eof; } sub fileno { my $self = shift; return undef unless $self && ref($self) && reftype($self) eq 'GLOB'; return ${*$self}{ie_fileno} if defined ${*$self}{ie_fileno}; return undef unless ${*$self}{ie_fh} && reftype(${*$self}{ie_fh}) eq 'GLOB'; return ${*$self}{ie_fh}->fileno(); } sub DESTROY { my $self = shift; my $no = $self->fileno; $no = '?' unless defined $no; print "DESTROY $no...\n" if $debug; return undef unless $self && ref($self) && reftype($self) eq 'GLOB'; ${*$self}{ie_event}->cancel if ${*$self}{ie_event}; } sub TIEHANDLE { my ($pkg, $self) = @_; return $self; } sub PRINTF { my $self = shift; $self->print(sprintf(shift, @_)); } sub READLINE { my $self = shift; wantarray ? $self->getlines : $self->getline; ## no critic (Community::Wantarray) } sub ie_desc { my ($self, $new) = @_; my $r = ${*$self}{ie_desc} || "no description"; ${*$self}{ie_desc} = $new if defined $new; return $r; } no warnings; *PRINT = \&print; *READ = \&sysread; # from IO::Handle *read = \&sysread; *WRITE = \&syswrite; *CLOSE = \&close; *EOF = \&eof; *TELL = \&tell; *FILENO = \&fileno; *SEEK = \&seek; *BINMODE = \&binmode; *OPEN = \&open; *GETC = \&getc; use warnings; }{package IO::Event::Socket::INET; # XXX version 1.26 required for IO::Socket::INET use strict; use warnings; use List::SomeUtils qw(any); use parent -norequire, 'IO::Event'; sub new { my ($pkg, $first, $second, %sock) = @_; # emulate behavior in the IO::Socket::INET API if (! %sock && ! $second) { $sock{PeerAddr} = $first; } else { $sock{$first} = $second; } my $handler = $sock{Handler} || (caller)[0]; delete $sock{Handler}; my $timeout; if ($sock{Timeout}) { $timeout = $sock{Timeout}; delete $sock{Timeout}; } $sock{Blocking} = 0; my (%ds) = %sock; delete $sock{Description}; require IO::Socket::INET; my $fh = IO::Socket::INET->new(%sock); return undef unless defined $fh; my $peer = any { /Peer/ } keys %sock; if ($peer) { $ds{LocalPort} = $fh->sockport unless defined $ds{LocalPort}; $ds{LocalHost} = $fh->sockhost unless defined $ds{LocalHost}; } my $desc = $ds{Description} || join(" ", map { defined $ds{$_} ? "$_=$ds{$_}" : $_ } sort keys %ds); return undef unless $fh; my $self = $pkg->SUPER::new($fh, $handler, $desc); bless $self, $pkg; $self->listener(1) if $sock{Listen}; $fh->blocking(0); # XXX may be redundant if ($peer) { if ($fh->connected()) { $self->ie_invoke(0, 'ie_connected'); } else { ${*$self}{ie_connecting} = 1; $self->writeevents(1); ${*$self}{ie_connect_timeout} = $timeout + time if $timeout; } } ${*$self}{ie_socket_timeout} = $timeout if $timeout; return $self; } }{ package IO::Event::Socket::UNIX; use strict; use warnings; use parent -norequire, 'IO::Event'; sub new { my ($pkg, $a, $b, %sock) = @_; # emulate behavior in the IO::Socket::INET API if (! %sock && ! $b) { $sock{Peer} = $a; } else { $sock{$a} = $b; } my $handler = $sock{Handler} || (caller)[0]; delete $sock{Handler}; my $desc = $sock{Description} || join(" ", map { "$_=$sock{$_}" } sort keys %sock); delete $sock{Description}; require IO::Socket::UNIX; my $fh = IO::Socket::UNIX->new(%sock); return undef unless $fh; my $self = $pkg->SUPER::new($fh, $handler, $desc); bless $self, $pkg; $self->listener(1) if $sock{Listen}; $fh->blocking(0); if ($sock{Peer}) { if ($fh->connected()) { $self->ie_invoke(0, 'ie_connected'); } else { ${*$self}{ie_connecting} = 1; $self->writeevents(1); } } return $self; } }#end package 1; __END__ =pod =encoding UTF-8 =head1 NAME IO::Event - Tied Filehandles for Nonblocking IO with Object Callbacks =head1 VERSION version 0.814 =head1 SYNOPSIS use IO::Event; use IO::Event 'emulate_Event'; use IO::Event 'AnyEvent'; my $ioe = IO::Event->new($filehandle); my $ioe = IO::Event::Socket::INET->new( [ARGS] ) my $ioe = IO::Event::Socket::UNIX->new( [ARGS] ) my $timer = IO::Event->timer( [after => $seconds], interval => $seconds, cb => CODE); my $idler = IO::Event->idle( [min => $seconds], [max => $seconds], [reentrant => 0], cb => CODE); IO::Event::loop(); IO::Event::unloop_all(); =head1 DESCRIPTION IO::Event provides a object-based callback system for handling nonblocking IO. The design goal is to provide a system that just does the right thing w/o the user needing to think about it much. All APIs are kept as simple as possible yet at the same time, all functionality is accessible if needed. Simple things are easy. Hard things are possible. Most of the time file handling syntax will work fine: C<< <$filehandle> >> and C. IO::Event provides automatic buffering of output (with a callback to throttle). It provides automatic line-at-a-time input. After initial setup, call C. IO::Event was originally written to use L. IO::Event still defaults to using L but it can now use L or its own event loop. =head1 CHOOSING AN EVENT HANDLER Until you create your first IO::Event object, you can choose which underlying event handler to use. The default is L. To choose an event handler, use one of the following lines, import C, C, or C. use IO::Event 'no_emulate_Event' use IO::Event 'emulate_Event' use IO::Event 'AnyEvent' The C option means: use L. The C option means IO::Event should use its own event loop. Why? You should use L if you want to have compatibility with other event loops. You should use C if you don't need compatibility with other event loops and you have missing-event bugs when using L. You should use L if it works for you. The APIs are a bit different depending on which event loop you're using. =head2 L To use L's event loop: use IO::Event 'no_emulate_Event'; or just: use IO::Event IO::Event's definition for C, C, C and C all default to the L version unless C or C have been imported. This allows you to easily switch back and forth between L's API and the others. =head2 L To use L's select loop, import C. use IO::Event 'AnyEvent'; You can use L's API directly or you can use IO::Event's emulated APIs: C, C, C, and C. These behave like L's routines of the same name but use L underneath. During testing, using the pure-perl event loop of L from L version 5.271, some read events were dropped. To work around this, a synthetic read-ready event is dispatched for all connected read filehandles every two seconds. Turn this off or adjust its frequency by changing C<$IO::Event::AnyEvent::lost_event_hack>. A numeric value is the time (in seconds) between dispatching read events. A false value turns off this performance-sapping hack. L only provides basic support for idle() events: it promises to invoke them "every now and then". =head2 C To use IO::Event's own select loop, import C. use IO::Event 'emulate_Event'; IO::Event does not provide a complete emulation of everything that L does. It provides the full timer API: my $timer = IO::Event::timer( [ARGS] ) instead of my $timer = Event::timer( [ARGS] ) However it does not provide timer events on filehandles, nor does it provide events for signals, or variable accesses. Use C instead of C. Use C instead of C. Use C instead of C. It does not provide any other methods or functions from L. If you need them, please send a patch. =head1 CONSTRUCTORS =over 4 =item IO::Event->new($filehandle, [ $handler, [ $options ]]) The basic C constructor takes a filehandle and returns a pseudo-filehandle. Treat the IO::Event object as a filehandle. Do not use the original filehandle without good reason (let us know if you find a good reason so we can fix the problem). The handler is the class or object where you provide callback functions to handle IO events. It defaults to the package of the calling context. If present, C<$options> is a hash reference with the following possible keys: =over 13 =item description A text description of this filehandle. Used for debugging and error messages. =item read_only Set to true if this is a read-only filehandle. Do not accept output. =item write_only Set to true if this is a write-only filehandle. Do not attempt to read. =item autoread Set to 0 if this should not be an auto-read filehandle. =back =item IO::Event::Socket::INET->new( [ARGS] ) This constructor uses IO::Socket::INET->new() to create a socket using the ARGS provided. It returns an IO::Event object. The handler defaults as above or can be set with an additional pseudo-parameter for IO::Socket::UNIX->new(): C. A description for the socket can be provided with an additional pseudo-parameter: C. =item IO::Event::Socket::UNIX->new( [ARGS] ) This constructor uses IO::Socket::UNIX->new() to create a socket using the ARGS provided. It returns an IO::Event object. The handler defaults as above or can be set with an additional pseudo-parameter for IO::Socket::UNIX->new(): C. A description for the socket can be provided with an additional pseudo-parameter: C. =back =head1 MANDATORY HANDLERS These handler methods must be available in the handler object/class if the situation in which they would be called arises. =over 4 =item ie_input($handler, $ioe, $input_buffer_reference) Invoked when there is fresh data in the input buffer. The input can be retrieved via directly reading it from C<$$input_buffer_reference> or via C from the $ioe filehandle, or by using a variety of standard methods for getting data: <$ioe> like IO::Handle $ioe->get() like Data::LineBuffer $ioe->read() like IO::Handle $ioe->sysread() like IO::Handle $ioe->getline() like IO::Handle $ioe->getlines() like IO::Handle $ioe->getsome() see below $ioe->ungets() like FileHandle::Unget At end-of-file, ie_input will only be invoked once. There may or may not be data in the input buffer. =item ie_connection($handler, $ioe) Invoked when a listen()ing socket is ready to accept(). It should call accept: sub ie_connection { my ($pkg, $ioe) = @_; my $newfh = $ioe->accept() } =item ie_read_ready($handler, $ioe, $underlying_file_handle) If autoreading is turned off then this will be invoked. =item ie_werror($handler, $ioe, $output_buffer_reference) A write error has occurred when trying to drain the write buffer. Provide an empty subroutine if you don't care. =back =head1 OPTIONAL HANDLERS These handler methods will be called if they are defined but it is not required that they be defined. =over 4 =item ie_eof($handler, $ioe, $input_buffer_reference) This is invoked when the read-side of the filehandle has been closed by its source. =item ie_output This is invoked when data has just been written to the underlying filehandle. =item ie_outputdone This is invoked when all pending data has just been written to the underlying filehandle. =item ie_connected This is invoked when a C completes. =item ie_connect_failed($handler, $ioe, $error_code) This is invoked when a C fails. For a timeout, the error code will be C. =item ie_died($handler, $ioe, $method, $@) If another handler calls C then ie_died will be called with the IO::Event object, the name of the method just invoked, and the die string. If no ie_died() callback exists then execution will terminate. =item ie_timer This is invoked for timer events. =item ie_exception Invoked when an exceptional condition arises on the underlying filehandle =item ie_outputoverflow($handler, $ioe, $overflowing, $output_buffer_reference) Invoked when there is too much output data and the output buffers are overflowing. You can take some action to generate less output. This will be invoked exactly once (with $overflowing == 1) when there is too much data in the buffer and then exactly once again (with $overflowing == 0) when there is no longer too much data in the buffer. =back =head1 METHODS In addition to methods described in detail below, the following methods behave like their C (mostly C) counterparts (except for being mostly non-blocking...): connect listen open read sysread syswrite print eof shutdown Through AUTOLOAD (see the SUBSTITUTED METHODS section) methods are passed to underlying C objects: loop unloop and many more... Through AUTOLOAD (see the SUBSTITUTED METHODS section) methods are passed to underlying C objects: fileno stat truncate error opened untaint and many more... IO::Event defines its own methods too: =over 4 =item ->accept($handler, %options) accept() is nearly identical to the normal IO::Socket::accept() method except that instead of optionally passing a class specifier for the new socket, you optionally pass a handler object or class. The returned filehandle is an IO::Event object. Supported options: =over =item description Sets the description for the new socket =item autoread Set to 0 if you do not want auto-read =back =item ->can_read($amount) Returns true if C<$amount> bytes worth of input is available for reading. Note: this does not return true at EOF so be careful not to hang forever at EOF. =item ->getsome($amount) Returns C<$amount> bytes worth of input or undef if the request can't be filled. Returns what it can at EOF. =item ->get() get() is like getline() except that it pre-chomp()s the results and assumes the input_record_separator is "\n". This is like get() from L. =item ->unget() Push chomp()ed lines back into the input buffer. This is like unget() from L. =item ->ungetline(), ->xungetc(), ->ungets() This is what ungetc() should be: it pushes a string back into the input buffer. This is unlike IO::Handle->ungetc which takes an ordinal and pushes one character back into the the input buffer. This is like L. =item ->handler($new_handler) Sets the handler object/class if $new_handler is provided. Returns the old handler. =item ->filehandle() Returns the underlying C. =item ->event() Returns the underling C. =item ->listener($listening) Used to note that a filehandle is being used to listen for connections (instead of receiving data). A passed parameter of 0 does the opposite. Returns the old value. This is mostly used internally in IO::Event. =item ->input_record_separator($new_sep) IO::Handle doesn't allow input_record_separator's on a per filehandle basis. IO::Event does. If you don't ever set a filehandle's input record separator, then it continuously defaults to the current value of C<$/>. If you set it, then it will use your value and never look at C<$/> again. =item ->readevents($readevents) Get/set listening for read-ready events on the underlying filehandle. This could be used by ie_outputoverflow to control input flows. =item ->output_bufsize($output_bufsize) Get/set the size of the output buffer. =item ->autoread($autoread) Get/set automatic reading if data when data can be read. Without autoread turned on, the input buffer isn't filled and none of the read methods will work. The point of this is for working with non-data filehandles. This is an experts-only method that kinda defeats the purpose of this module. This would be necessary using recv() to get data. =item ->drain() Used to start looking for write-ready events on the underlying filehandle. In normal operation this is handled automatically. Deprecated: use C instead. =item ->reentrant($reentrant) Get/set reentrant callbacks. By default, IO::Event avoids making reentrant callbacks. This is good because your code is less likely to break. This is bad because you won't learn about things right away. For example, you will not learn the the output buffer is overflowing during print(). You'll have to wait for the output buffer to begin draining to find out. This could be a problem. =item ->close() If there is output buffered, close will be delayed until the output buffer drains. =item ->forceclose Close close immediately, even if there is output buffered. =item ->ie_desc([new description]) Returns (and sets) the text description of the filehandle. For debugging. =back =head1 EVENT LOOP FUNCTIONS These dispatch to whichever event handler was chosen (see L). =over 4 =item IO::Event::loop() Run the event loop. =item IO::Event::unloop() Exit the current event loop. =item IO::Event::unloop_all() Exit all running event loops. =item IO::Event->timer( [ARGS] ) Create a timer. See L for the arguments. =item IO::Event->idle( [ARGS] ) Create an idle event. See L for the arguments. =back =head1 TIMER API The following timer construction arguments are supported by IO::Event's emulated event loop and IO::Event's API on top of L: =over 4 =item cb A callback to invoke when the timer goes off. The callback can either be a CODE reference or an array reference. If it's an array reference, the array should be a two element tuple: the first element is an object and the second object is a method to invoke on the object. The only argument to the method call a reference to the timer object: my ($object, $method) = @{$timer->{cb}} $object->$method($timer) =item at A time at which to invoke the callback. =item interval An interval, in seconds between repeat invocations of the callback. =item after The interval until the first invocation of the callback. After that, invoke every I. =back The following methods (from L) are supported on timer objects: start(), again(), now(), stop(), cancel(), is_cancelled(), is_running(), is_suspended(), pending. =head1 IDLE API The following idle construction arguments are supported by IO::Event's emulated event loop and IO::Event's API on top of L: =over 4 =item cb A callback to invoke when the event loop is idle. The callback can either be a CODE reference or an array reference. If it's an array reference, the array should be a two element tuple: the first element is an object and the second object is a method to invoke on the object. my ($object, $method) = @{$timer->{cb}} $object->$method(); =item min The minimum time between invocations of the callback. =item max The maximum time between invocations of the callback. =back The following methods (from L) are supported on idle objects: start(), again(), now(), stop(), cancel(), is_cancelled(), is_running(), is_suspended(), pending. =head1 SUBSTITUTED METHODS Any method invocations that fail because the method isn't defined in IO::Event will by tried twice more: once using trying for a method on the inner (hidden) filehandle and once more trying for a method on the Event object that's used to create the select loop for this module. This dispatch is now deprecated with the choice of event handlers. =head1 EXAMPLE SERVER # This is a tcp line echo server my $listener = IO::Event::Socket::INET->new( Listen => 10, Proto => 'tcp', LocalPort => 2821, ); Event::loop(); sub ie_connection { my ($pkg, $lstnr) = @_; my $client = $lstnr->accept(); printf "accepted connection from %s:%s\n", $client->peerhost, $client->peerport; } sub ie_input { my ($pkg, $client, $ibufref) = @_; print $client <$client>; } =head1 SYSREAD and EOF sysread() is incompatible with eof() because eof() uses getc(). Most of the time this isn't a problem. In other words, some of the time this is a problem: lines go missing. For this reason, IO::Event never uses sysread(). In fact, if you ask it to do a sysread() it does a read() for you instead. On the other hand, at the current time no problems with syswrite have come to light and IO::Event uses syswrite and never any other form of write/print etc. =head1 DESTRUCTION IO::Event keeps copies of all of its registered filehandles. If you want to close a filehandle, you'll need to actually call close on it. =head1 DATA STRUCTURE The filehandle object itself is a funny kind of hash reference. If you want to use it to store your own data, you can. Please don't use hash keys that begin C or C as those are the prefixes used by C and C. The syntax is kinda funny: ${*$filehandle}{'your_hash_key'} =head1 SEE ALSO For a different API on top of IO::Event, see L. It uses IO::Event but provides a simpler and perhaps easier-to-use API. The following perl modules do something that is kinda similar to what is being done here: L, L, L, L, L, L L, L, L, L, L, L The API borrows most heavily from IO::Multiplex. IO::Event uses Event.pm and thus can be used in programs that are already using Event or POE. Since the original writing of IO::Event, L has been released and now L and L should be considered the only good alternatives to IO::Event. For an example program using IO::Event, see L which used to be included in this package. =head1 BUGS The test suite only covers 40% of the code. The module is used by its author and seems solid. =head1 AUTHORS =over 4 =item * David Muir Sharnoff =item * Graham Ollis =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002-2026 by David Muir Sharnoff . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut IO-Event-0.814/lib/IO/Event/000755 000000 000000 00000000000 15261136517 015237 5ustar00rootroot000000 000000 IO-Event-0.814/lib/IO/Event/AnyEvent.pm000644 000000 000000 00000012235 15261136517 017331 0ustar00rootroot000000 000000 # # Use AnyEvent for the IO::Event's event handler # my $debug = 0; my $debug_timer; my $lost_event_timer; { package IO::Event::AnyEvent; # ABSTRACT: Use AnyEvent for the IO::Event event handler our $VERSION = '0.814'; # VERSION our $lost_event_hack = 2; require IO::Event; use strict; use warnings; use Scalar::Util qw(refaddr); use parent -norequire, 'IO::Event::Common'; my %selves; my $condvar; sub import { require IO::Event; IO::Event->import('AnyEvent'); } sub new { my ($pkg, @stuff) = @_; my $self = $pkg->SUPER::new(@stuff); return $self; } sub loop { $condvar = AnyEvent->condvar; if ($debug) { $debug_timer = AnyEvent->timer(after => 0.1, interval => 0.1, cb => sub { print STDERR "WATCHING:\n"; for my $ie (values %selves) { print STDERR "\t"; print STDERR "R" if ${*$ie}{ie_anyevent_read}; print STDERR "W" if ${*$ie}{ie_anyevent_read}; print STDERR " ${*$ie}{ie_desc}\n"; } }); } if ($lost_event_hack) { $lost_event_timer = AnyEvent->timer( after => $lost_event_hack, interval => $lost_event_hack, cb => sub { for my $ie (values %selves) { next unless ${*$ie}{ie_anyevent_read}; next if ${*$ie}{ie_listener}; # no spurious connections! # print STDERR "DISPATCHING FOR READ for ${*$ie}{ie_desc}\n"; # LOST EVENTS $ie->ie_dispatch_read(); } }, ); } $condvar->recv; } sub timer { IO::Event::AnyEvent::Wrapper->new('Timer', @_); } sub unloop { $condvar->send(@_) if $condvar; } sub unloop_all { $condvar->send(@_) if $condvar; } sub idle { IO::Event::AnyEvent::Wrapper->new('Idle', @_); } sub set_write_polling { my ($self, $new) = @_; my $event = ${*$self}{ie_write}; if ($new) { ${*$self}{ie_anyevent_write} = AnyEvent->io( fh => ${*$self}{ie_fh}, cb => sub { # print STDERR ""; # LOST EVENTS $self->ie_dispatch_write(); }, poll => 'w', ); } else { delete ${*$self}{ie_anyevent_write}; } } sub set_read_polling { my ($self, $new) = @_; my $event = ${*$self}{ie_event}; if ($new) { ${*$self}{ie_anyevent_read} = AnyEvent->io( fh => ${*$self}{ie_fh}, cb => sub { # print STDERR ""; # LOST EVENTS $self->ie_dispatch_read(); }, poll => 'r', ); } else { delete ${*$self}{ie_anyevent_read}; } } sub ie_register { my ($self) = @_; my ($fh, $fileno) = $self->SUPER::ie_register(); $self->set_read_polling(${*$self}{ie_want_read_events} = ! ${*$self}{ie_readclosed}); ${*$self}{ie_want_write_events} = ''; $selves{refaddr($self)} = $self; print STDERR "registered ${*$self}{ie_fileno}:${*$self}{ie_desc} $self $fh ${*$self}{ie_event}\n" if $debug; } sub ie_deregister { my ($self) = @_; $self->SUPER::ie_deregister(); delete ${*$self}{ie_anyevent_write}; delete ${*$self}{ie_anyevent_read}; delete $selves{refaddr($self)}; } }{package IO::Event::AnyEvent::Wrapper; use strict; use warnings; use Scalar::Util qw(refaddr); my %handlers; sub new { my ($pkg, $type, $req_pkg, %param) = @_; my ($cpkg, $file, $line, $sub) = caller; my $desc; { no warnings; $desc = $param{desc} || "\u$type\E event defined in ${cpkg}::${sub} at $file:$line"; } if (ref($param{cb}) eq 'ARRAY') { my ($obj, $meth) = @{$param{cb}}; $param{cb} = sub { $obj->$meth(); }; } $param{after} ||= $param{interval}; my $self = bless { type => lc($type), desc => $desc, param => \%param, }, $pkg; $self->start(); return $self; } sub start { my ($self) = @_; $handlers{refaddr($self)} = $self; my $type = $self->{type}; $self->{handler} = AnyEvent->$type(%{$self->{param}}); } sub again { my ($self) = @_; $self->start; } sub now { my ($self) = @_; $self->{param}{cb}->($self); } sub stop { my ($self) = @_; delete $self->{handler}; } sub cancel { my ($self) = @_; $self->stop(); delete $handlers{refaddr($self)}; } sub is_cancelled { my ($self) = @_; return ! $handlers{refaddr($self)}; } sub is_active { my ($self) = @_; return ! ! $self->{handler}; } sub is_running { return; } sub pending { return; } }#end package 1; __END__ =pod =encoding UTF-8 =head1 NAME IO::Event::AnyEvent - Use AnyEvent for the IO::Event event handler =head1 VERSION version 0.814 =head1 AUTHORS =over 4 =item * David Muir Sharnoff =item * Graham Ollis =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002-2026 by David Muir Sharnoff . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut IO-Event-0.814/lib/IO/Event/Callback.pm000644 000000 000000 00000011052 15261136517 017270 0ustar00rootroot000000 000000 package IO::Event::Callback; # ABSTRACT: A closure based API for IO::Event our $VERSION = '0.814'; # VERSION use strict; use warnings; use IO::Event; our @handlers; BEGIN { @handlers = qw(input connection read_ready werror eof output outputdone connected connect_failed died timer exception outputoverflow); } sub new { my ($pkg, $filehandle, %h) = @_; my $ro = $h{read_only}; my $wo = $h{write_only}; delete $h{read_only}; delete $h{write_only}; my $self = handler($pkg, %h); return IO::Event->new($filehandle, $self, read_only => $ro, write_only => $wo); } sub ie_input { $_[0]->{'ie_input'}->(@_) }; sub ie_connection { $_[0]->{'ie_connection'}->(@_) }; sub ie_read_ready { $_[0]->{'ie_read_ready'}->(@_) }; sub ie_werror { $_[0]->{'ie_werror'}->(@_) }; sub ie_eof { $_[0]->{'ie_eof'}->(@_) }; sub ie_output { $_[0]->{'ie_output'}->(@_) }; sub ie_outputdone { $_[0]->{'ie_outputdone'}->(@_) }; sub ie_connected { $_[0]->{'ie_connected'}->(@_) }; sub ie_connect_failed { $_[0]->{'ie_connect_failed'}->(@_) }; sub ie_died { $_[0]->{'ie_died'}->(@_) }; sub ie_timer { $_[0]->{'ie_timer'}->(@_) }; sub ie_exception { $_[0]->{'ie_exception'}->(@_) }; sub ie_outputoverflow { $_[0]->{'ie_outputoverflow'}->(@_) }; sub handler { my ($pkg, %h) = @_; my $self = bless {}, $pkg; for my $h (@handlers) { my $key = exists($h{$h}) ? $h : exists($h{"ie_$h"}) ? "ie_$h" : undef; if ($key) { $self->{"ie_$h"} = $h{$key}; delete $h{$key}; } else { $self->{"ie_$h"} = sub {}; } } my @k = keys %h; die "unexpected parameters: @k" if @k; return $self; } sub sock2handler { my ($pkg, $sref) = @_; my %h; for my $h (@handlers) { next unless exists $sref->{$h}; my $key = exists($sref->{$h}) ? $h : exists($sref->{"ie_$h"}) ? "ie_$h" : next; $h{$h} = $sref->{$key}; delete $sref->{$key}; } my $handler = handler($pkg,%h); } package IO::Event::INET::Callback; use strict; use warnings; sub new { my ($pkg, %sock) = @_; my $handler = IO::Event::Callback->sock2handler(\%sock); return IO::Event::INET->new(%sock, Handler => $handler); } package IO::Event::UNIX::Callback; use strict; use warnings; sub new { my ($pkg, %sock) = @_; my $handler = IO::Event::Callback->sock2handler(\%sock); return IO::Event::UNIX->new(%sock, Handler => $handler); } 1; __END__ =pod =encoding UTF-8 =head1 NAME IO::Event::Callback - A closure based API for IO::Event =head1 VERSION version 0.814 =head1 SYNOPSIS use IO::Event::Callback; IO::Event::Callback->new($filehanle, %callbacks); use IO::Event::INET::Callback; IO::Event::INET::Callback->new(%socket_info, %callbacks); use IO::Event::UNIX::Callback; IO::Event::UNIX::Callback->new(%socket_info, %callbacks); =head1 DESCRIPTION IO::Event::Callback is a wrapper around L. It provides an alternative interface to using L. Instead of defining a class with methods like "ie_input", you provide the callbacks as code references when you create the object. The keys for the callbacks are the same as the callbacks for L with the C prefix removed. =head1 CONSTRUCTORS =head2 new my $ioe = IO::Event::Callback->new($filehandle, %callbacks); Create an L object for C<$filehandle> whose handler invokes the given callbacks. The keys of C<%callbacks> are the L handler names, with or without the C prefix (for example C or C). The C and C options are passed through to L. =head1 EXAMPLE use IO::Event::Callback; my $remote = IO::Event::Callback::INET->new( peeraddr => '10.20.10.3', peerport => '23', input => sub { # handle input }, werror => sub { # handdle error }, eof => sub { # handle end-of-file }, ); =head1 SEE ALSO See the source for L for an example use of IO::Event::Callback. =head1 AUTHORS =over 4 =item * David Muir Sharnoff =item * Graham Ollis =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002-2026 by David Muir Sharnoff . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut IO-Event-0.814/lib/IO/Event/Emulate.pm000644 000000 000000 00000026334 15261136517 017201 0ustar00rootroot000000 000000 # # Use a pure-perl event handler that kinda emulates's Event # for IO::Event's event handler. # my $sdebug = 0; { package IO::Event::Emulate; # ABSTRACT: Pure-perl event handler for IO::Event that emulates Event our $VERSION = '0.814'; # VERSION use strict; use warnings; use parent -norequire, 'IO::Event::Common'; my %want_read; my %want_write; my %want_exception; my %active; my $rin = ''; my $win = ''; my $ein = ''; my $unloop; sub import { require IO::Event; IO::Event->import('emulate_Event'); } sub new { my ($pkg, @stuff) = @_; $pkg->SUPER::new(@stuff); } # a replacement for Event::loop sub ie_loop { $unloop = 0; my ($rout, $wout, $eout); for(;;) { print STDERR "EMULATE LOOP-TOP\n" if $sdebug; last if $unloop; my $timer_timeout = IO::Event::Emulate::Timer->get_time_to_timer; my $timeout = $timer_timeout || IO::Event::Emulate::Idle->get_time_to_idle; if ($sdebug > 3) { print STDERR "Readers:\n"; for my $ioe (values %want_read) { print STDERR "\t${*$ioe}{ie_desc}\n"; } print STDERR "Writers:\n"; for my $ioe (values %want_write) { print STDERR "\t${*$ioe}{ie_desc}\n"; } print STDERR "Exceptions:\n"; for my $ioe (values %want_exception) { print STDERR "\t${*$ioe}{ie_desc}\n"; } } my ($nfound, $timeleft) = select($rout=$rin, $wout=$win, $eout=$ein, $timeout); print STDERR "SELECT: N$nfound\n" if $sdebug; if ($nfound) { EVENT: { if ($rout) { for my $ioe (values %want_read) { next unless vec($rout, ${*$ioe}{ie_fileno}, 1); my $ret = $ioe->ie_dispatch_read(${*$ioe}{ie_fh}); if ($ret && vec($wout, ${*$ioe}{ie_fileno}, 1)) { vec($wout, ${*$ioe}{ie_fileno}, 1) = 0; $nfound--; } if ($ret && vec($eout, ${*$ioe}{ie_fileno}, 1)) { vec($eout, ${*$ioe}{ie_fileno}, 1) = 0; $nfound--; } $nfound--; last EVENT unless $nfound > 0; } } if ($wout) { for my $ioe (values %want_write) { next unless vec($wout, ${*$ioe}{ie_fileno}, 1); my $ret = $ioe->ie_dispatch_write(${*$ioe}{ie_fh}); if ($ret && vec($eout, ${*$ioe}{ie_fileno}, 1)) { vec($eout, ${*$ioe}{ie_fileno}, 1) = 0; $nfound--; } $nfound--; last EVENT unless $nfound > 0; } } if ($eout) { for my $ioe (values %want_exception) { next unless vec($eout, ${*$ioe}{ie_fileno}, 1); $ioe->ie_dispatch_exception(${*$ioe}{ie_fh}); $nfound--; last EVENT unless $nfound > 0; } } } } IO::Event::Emulate::Timer->invoke_timers if $timer_timeout; IO::Event::Emulate::Idle->invoke_idlers($nfound == 0); } die unless ref($unloop); my @r = @$unloop; shift(@r); return $r[0] if @r == 1; return @r; } sub loop { ie_loop(@_); } sub timer { shift; IO::Event::Emulate::Timer->new(@_); } sub idle { shift; IO::Event::Emulate::Idle->new(@_); } sub unloop_all { $unloop = [1, @_]; } sub set_write_polling { my ($self, $new) = @_; my $fileno = ${*$self}{ie_fileno}; if ($new) { vec($win, $fileno, 1) = 1; $want_write{$fileno} = $want_exception{$fileno} = $self; } else { vec($win, $fileno, 1) = 0; delete $want_write{$fileno}; delete $want_exception{$fileno} unless $want_read{$fileno}; } $ein = $rin | $win; } sub set_read_polling { my ($self, $new) = @_; my $fileno = ${*$self}{ie_fileno}; if ($new) { vec($rin, $fileno, 1) = 1; $want_read{$fileno} = $want_exception{$fileno} = $self; } else { if (defined $fileno) { vec($rin, $fileno, 1) = 0; delete $want_read{$fileno}; delete $want_exception{$fileno} unless $want_write{$fileno} } } $ein = $rin | $win; } sub ie_register { my ($self) = @_; my ($fh, $fileno) = $self->SUPER::ie_register(); $active{$fileno} = $self; $self->readevents(! ${*$self}{ie_readclosed}); $self->writeevents(0); } sub ie_deregister { my ($self) = @_; $self->SUPER::ie_deregister(); delete $active{${*$self}{ie_fileno}}; } }{package IO::Event::Emulate::Timer; use warnings; use strict; use Time::HiRes qw(time); use Carp qw(confess); use Scalar::Util qw(reftype); use parent -norequire, 'IO::Event'; our %timers = (); our %levels = (); our %next = (); BEGIN { for my $name (qw(at after interval hard cb desc prio repeat timeout)) { my $attrib = $name; no strict 'refs'; *{"IO::Event::Emulate::Timer::$name"} = sub { my $self = shift; return $self->{$attrib} unless @_; my $val = shift; $self->{$attrib} = $val; return $val; }; } } my $tcount = 1; my @timers; sub get_time_to_timer { @timers = sort { $a <=> $b } keys %next; my $t = time; if (@timers) { if ($timers[0] > $t) { my $timeout = $timers[0] - $t; $timeout = 0.01 if $timeout < 0.01; return $timeout; } else { return 0.01; } } return undef; } sub invoke_timers { while (@timers && $timers[0] < time) { print STDERR "Ti" if $sdebug; my $t = shift(@timers); my $te = delete $next{$t}; for my $tnum (keys %$te) { my $timer = $te->{$tnum}; next unless $timer->{next}; next unless $timer->{next} eq $t; $timer->now(); } } } sub new { my ($pkg, %param) = @_; confess unless $param{cb}; die if $param{after} && $param{at}; my $timer = bless { tcount => $tcount, last_time => time, %param }, __PACKAGE__; $timers{$tcount++} = $timer; $timer->schedule; return $timer; } sub schedule { my ($self) = @_; my $next; if ($self->{invoked}) { if ($self->{interval}) { $next = $self->{last_time} + $self->{interval}; if ($self->{hard} && $self->{next}) { $next = $self->{next} + $self->{interval}; } } else { $next = undef; } } elsif ($self->{at}) { $next = $self->{at}; } elsif ($self->{after}) { $next = $self->{after} + time; } elsif ($self->{interval}) { $next = $self->{interval} + time; } else { die; } if ($next) { $next{$next}{$self->{tcount}} = $self; $self->{next} = $next; } else { $self->{next} = 0; $self->stop(); } } sub start { my ($self) = @_; $timers{$self->{tcount}} = $self; delete $self->{stopped}; $self->schedule; } sub again { my ($self) = @_; $self->{last_time} = time; $self->start; } sub now { my ($self) = @_; $self->{last_time} = time; local($levels{$self->{tcount}}) = ($levels{$self->{tcount}} || 0)+1; $self->{invoked}++; if (reftype($self->{cb}) eq 'CODE') { $self->{cb}->($self); } elsif (reftype($self->{cb}) eq 'ARRAY') { my ($o, $m) = @{$self->{cb}}; $o->$m($self); } else { die; } $self->schedule; } sub stop { my ($self) = @_; delete $timers{$self->{tcount}}; $self->{stopped} = time; } sub cancel { my ($self) = @_; $self->{cancelled} = time; delete $timers{$self->{tcount}}; } sub is_cancelled { my ($self) = @_; return $self->{cancelled}; } sub is_active { my ($self) = @_; return exists $timers{$self->{tcount}}; } sub is_running { my ($self) = @_; return $levels{$self->{tcount}}; } sub is_suspended { my ($self) = @_; return 0; } sub pending { return; } }{package IO::Event::Emulate::Idle; use warnings; use strict; use Carp qw(confess); use Scalar::Util qw(reftype); use Time::HiRes qw(time); use parent -norequire, 'IO::Event'; our %timers = (); our %levels = (); our %next = (); my $icount = 0; my %idlers; our $time_to_idle_timeout = 1; sub new { my ($pkg, %param) = @_; confess unless $param{cb}; die if $param{after} && $param{at}; my $idler = bless { icount => $icount, last_time => time, %param }, __PACKAGE__; $idlers{$icount++} = $idler; return $idler; } sub get_time_to_idle { return undef unless %idlers; return $time_to_idle_timeout; } sub start { my ($self) = @_; $idlers{$self->{icount}} = $self; delete $self->{stopped}; $self->schedule; } sub again { my ($self) = @_; $self->{last_time} = time; $self->start; } sub invoke_idlers { my ($pkg, $is_idle) = @_; for my $idler (values %idlers) { if ($idler->{min} && (time - $idler->{last_time}) < $idler->{min}) { next; } unless ($is_idle) { next unless $idler->{max}; next unless (time - $idler->{last_time}) > $idler->{max}; } $idler->now; } } sub now { my ($self) = @_; $self->{last_time} = time; local($levels{$self->{icount}}) = ($levels{$self->{icount}} || 0)+1; if (defined($self->{reentrant}) && ! $self->{reentrant} && $self->{icount}) { return; } $self->{invoked}++; if (defined($self->{repeat}) && ! $self->{repeat}) { $self->cancel; } if (reftype($self->{cb}) eq 'CODE') { $self->{cb}->($self); } elsif (reftype($self->{cb}) eq 'ARRAY') { my ($o, $m) = @{$self->{cb}}; $o->$m($self); } else { die; } $self->{last_time} = time; } sub stop { my ($self) = @_; delete $idlers{$self->{icount}}; $self->{stopped} = time; } sub cancel { my ($self) = @_; $self->{cancelled} = time; delete $idlers{$self->{icount}}; } sub is_cancelled { my ($self) = @_; return $self->{cancelled}; } sub is_active { my ($self) = @_; return exists $idlers{$self->{icount}}; } sub is_running { my ($self) = @_; return $levels{$self->{icount}}; } sub is_suspended { my ($self) = @_; return 0; } sub pending { return; } }#end package 1; __END__ =pod =encoding UTF-8 =head1 NAME IO::Event::Emulate - Pure-perl event handler for IO::Event that emulates Event =head1 VERSION version 0.814 =head1 AUTHORS =over 4 =item * David Muir Sharnoff =item * Graham Ollis =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002-2026 by David Muir Sharnoff . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut IO-Event-0.814/lib/IO/Event/Event.pm000644 000000 000000 00000005172 15261136517 016663 0ustar00rootroot000000 000000 # # Use Event for the IO::Event event handler # my $debug = $IO::Event::debug; my $edebug = $IO::Event::edebug; my $sdebug = $IO::Event::sdebug; package IO::Event::Event; # ABSTRACT: Use Event for the IO::Event event handler our $VERSION = '0.814'; # VERSION require IO::Event; use strict; use warnings; use parent -norequire, 'IO::Event::Common'; sub import { require IO::Event; IO::Event->import('no_emulate_Event'); } sub new { my ($pkg, @stuff) = @_; require Event; require Event::Watcher; $pkg->SUPER::new(@stuff); } sub loop { require Event; Event::loop(@_); } sub unloop_all { require Event; Event::unloop_all(@_); } sub timer { require Event; shift; Event->timer(hard => 1, @_); } sub idle { require Event; shift; Event->idle(@_); } sub set_write_polling { my ($self, $new) = @_; my $event = ${*$self}{ie_event}; if ($new) { $event->poll($event->poll | Event::Watcher::W()); } else { $event->poll($event->poll & ~Event::Watcher::W()); } } sub set_read_polling { my ($self, $new) = @_; my $event = ${*$self}{ie_event}; if ($new) { $event->poll($event->poll | Event::Watcher::R()); } else { if ($event) { $event->poll($event->poll & ~Event::Watcher::R()); } } } sub ie_register { my ($self) = @_; my ($fh, $fileno) = $self->SUPER::ie_register(); my $R = ${*$self}{ie_readclosed} ? 0 : Event::Watcher::R(); ${*$self}{ie_want_read_events} = ! ${*$self}{ie_readclosed}; ${*$self}{ie_want_write_events} = ''; ${*$self}{ie_event} = Event->io( fd => $fileno, poll => Event::Watcher::E()|Event::Watcher::T()|$R, cb => [ $self, 'ie_dispatch' ], desc => ${*$self}{ie_desc}, edebug => $edebug, ); print STDERR "registered ${*$self}{ie_fileno}:${*$self}{ie_desc} $self $fh ${*$self}{ie_event}\n" if $debug; } sub ie_deregister { my ($self) = @_; $self->SUPER::ie_deregister(); ${*$self}{ie_event}->cancel if ${*$self}{ie_event}; delete ${*$self}{ie_event}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME IO::Event::Event - Use Event for the IO::Event event handler =head1 VERSION version 0.814 =head1 AUTHORS =over 4 =item * David Muir Sharnoff =item * Graham Ollis =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002-2026 by David Muir Sharnoff . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut IO-Event-0.814/maint/000755 000000 000000 00000000000 15261136517 014211 5ustar00rootroot000000 000000 IO-Event-0.814/maint/cip-before-install000755 000000 000000 00000000067 15261136517 017621 0ustar00rootroot000000 000000 #!/bin/bash set -ex cip exec cpanm -n AnyEvent Event IO-Event-0.814/perlcriticrc000644 000000 000000 00000003720 15261136517 015513 0ustar00rootroot000000 000000 severity = 1 only = 1 [Community::ArrayAssignAref] [Community::BarewordFilehandles] [Community::ConditionalDeclarations] [Community::ConditionalImplicitReturn] [Community::DeprecatedFeatures] [Community::DiscouragedModules] [Community::DollarAB] [Community::Each] [Community::EmptyReturn] [Community::IndirectObjectNotation] [Community::LexicalForeachIterator] [Community::LoopOnHash] [Community::ModPerl] [Community::OpenArgs] [Community::OverloadOptions] [Community::POSIXImports] [Community::PackageMatchesFilename] [Community::PreferredAlternatives] [Community::StrictWarnings] extra_importers = Test2::V0 [Community::Threads] [Community::Wantarray] [Community::WarningsSwitch] [Community::WhileDiamondDefaultAssignment] [BuiltinFunctions::ProhibitBooleanGrep] [BuiltinFunctions::ProhibitStringyEval] [BuiltinFunctions::ProhibitStringySplit] [BuiltinFunctions::ProhibitVoidGrep] [BuiltinFunctions::ProhibitVoidMap] [ClassHierarchies::ProhibitExplicitISA] [ClassHierarchies::ProhibitOneArgBless] [CodeLayout::ProhibitHardTabs] allow_leading_tabs = 0 [CodeLayout::ProhibitTrailingWhitespace] [CodeLayout::RequireConsistentNewlines] [ControlStructures::ProhibitLabelsWithSpecialBlockNames] [ControlStructures::ProhibitMutatingListFunctions] [ControlStructures::ProhibitUnreachableCode] [InputOutput::ProhibitBarewordFileHandles] [InputOutput::ProhibitJoinedReadline] [InputOutput::ProhibitTwoArgOpen] [Miscellanea::ProhibitFormats] [Miscellanea::ProhibitUselessNoCritic] [Modules::ProhibitConditionalUseStatements] ;[Modules::RequireEndWithOne] [Modules::RequireNoMatchVarsWithUseEnglish] [Objects::ProhibitIndirectSyntax] [RegularExpressions::ProhibitUselessTopic] [Subroutines::ProhibitNestedSubs] [ValuesAndExpressions::ProhibitLeadingZeros] [ValuesAndExpressions::ProhibitMixedBooleanOperators] [ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator] [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] [Variables::ProhibitPerl4PackageNames] [Variables::ProhibitUnusedVariables] IO-Event-0.814/t/000755 000000 000000 00000000000 15261136517 013344 5ustar00rootroot000000 000000 IO-Event-0.814/t/00_diag.t000644 000000 000000 00000002657 15261136517 014746 0ustar00rootroot000000 000000 use strict; use warnings; use Config; use Test::More tests => 1; # This .t file is generated. # make changes instead to dist.ini my %modules; my $post_diag; BEGIN { eval q{ use EV; } } $modules{$_} = $_ for qw( AnyEvent Carp EV Event ExtUtils::MakeMaker IO::Handle IO::Socket::INET IO::Socket::UNIX List::SomeUtils POSIX Scalar::Util Socket Symbol Sys::Hostname Test::More Time::HiRes parent ); my @modules = sort keys %modules; sub spacer () { diag ''; diag ''; diag ''; } pass 'okay'; my $max = 1; $max = $_ > $max ? $_ : $max for map { length $_ } @modules; our $format = "%-${max}s %s"; spacer; my @keys = sort grep /(MOJO|PERL|\A(LC|HARNESS)_|\A(SHELL|LANG)\Z)/i, keys %ENV; if(@keys > 0) { diag "$_=$ENV{$_}" for @keys; if($ENV{PERL5LIB}) { spacer; diag "PERL5LIB path"; diag $_ for split $Config{path_sep}, $ENV{PERL5LIB}; } elsif($ENV{PERLLIB}) { spacer; diag "PERLLIB path"; diag $_ for split $Config{path_sep}, $ENV{PERLLIB}; } spacer; } diag sprintf $format, 'perl', "$] $^O $Config{archname}"; foreach my $module (@modules) { my $pm = "$module.pm"; $pm =~ s{::}{/}g; if(eval { require $pm; 1 }) { my $ver = eval { $module->VERSION }; $ver = 'undef' unless defined $ver; diag sprintf $format, $module, $ver; } else { diag sprintf $format, $module, '-'; } } if($post_diag) { spacer; $post_diag->(); } spacer; IO-Event-0.814/t/01_use.t000644 000000 000000 00000000115 15261136517 014622 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More tests => 1; use_ok( 'IO::Event' ); IO-Event-0.814/t/callbacks.tt000644 000000 000000 00000013200 15261136517 015630 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; my $slowest = 4; my $pause = 0; my $debug = 0; my $c = 1; $| = 1; my $testcount = 6; use Carp qw(verbose); use Sys::Hostname; my $startingport = 1025; package T; use IO::Event; use IO::Socket::INET; use Carp; BEGIN { eval { require Time::HiRes }; if ($@) { print "1..0 $@"; exit; } } # support routine sub pickport { for (my $i = 0; $i < 1000; $i++) { my $s = IO::Socket::INET->new( Listen => 1, LocalPort => $startingport, ); if ($s) { $s->close(); return $startingport++; } $startingport++; } die "could not find an open port"; } # print "ok N" or "not ok N" sub okay { my ($cond, $message) = @_; if ($cond) { $message =~ s/\n/\\n/g; print "ok $c # $message\n"; } else { my($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller(0); print "not ok $c # $filename:$line $message\n"; } if ($c > $testcount) { print STDERR "too many test results\n"; exit(0); } $c++; } # default to oops sub ie_input { confess "we shoudn't be here"; } print "1..$testcount\n"; # let's listen on a socket. We'll expect to receive # test numbers. We'll print ok. my $rp = T::pickport; my $results = IO::Event::Socket::INET->new( Listen => 10, Proto => 'tcp', LocalPort => $rp, LocalAddr => '127.0.0.1', Handler => 'ListenPrintOkay', Description => 'Listener', ); die unless $results; die unless $results->filehandle; my $fh = $results->filehandle; my $fn = $fh->fileno; my $idle; my $time = time; my $waitingfor = $c; my $ptime; # first number is number of test events for this test my (@tests) = ( 1 => sub { my $s = IO::Socket::INET->new( Proto => 'tcp', PeerPort => $rp, PeerAddr => '127.0.0.1', ); $s or T::okay(0, "Create socket to 127.0.0.1:$rp: $!"); my $ioe = SendOne::registerIOE($s); $ioe or T::okay(0, "resiter IOE"); $ioe->print("$c\n"); }, 1 => sub { IO::Event::Socket::INET->new ( Proto => 'tcp', PeerPort => $rp, PeerAddr => '127.0.0.1', Handler => 'SendOne', ) or T::okay(0, "create Sendone to $rp: $@"); }, 1 => sub { my $rp = T::pickport; IO::Event::Socket::INET->new( Listen => 1, Proto => 'tcp', LocalPort => $rp, LocalAddr => '127.0.0.1', Handler => 'ListenGetLine', Description => 'Listener2', ) or T::okay(0, "create listener2 at $rp: $@"); IO::Event::Socket::INET->new ( Proto => 'tcp', PeerPort => $rp, PeerAddr => '127.0.0.1', Handler => 'SendOne', ) or T::okay(0, "create SendOne2 to $rp: $@"); }, ); my $timer = IO::Event->timer ( cb => \&runstuff, reentrant => 0, repeat => 1, interval => 0.05, ); okay($results, "start listening on results socket"); my $r = IO::Event::loop(); okay($r == 7, "loop finshed ($r)"); okay(1, "all done"); exit(0); sub runstuff { if ($ptime) { return if (time < $ptime + $pause); } elsif ($c >= $waitingfor) { print STDERR "runstuff: time to start another test\n" if $debug; # T::okay(1, "runstuff happy"); $ptime = time; } elsif (time - $time > $slowest) { print STDERR "runstuff: uh oh: test timed out\n" if $debug; # let's start the next test anyway... T::okay(0, "runstuff timetout"); $ptime = time; } else { print STDERR "runstuff: idle\n" if $debug && (time > $idle); $idle = time; return; } unless (@tests) { print STDERR "runstuff: no more tests\n" if $debug; IO::Event::unloop_all(7); return; } return if $pause && (time < $ptime + $pause); undef $ptime; my ($count, $test) = splice(@tests, 0, 2); $waitingfor = $c + $count; $time = time; print STDERR "runstuff: starting another test ($c + $count)\n" if $debug; eval { &$test }; T::okay(0, "test evaled: $@") if $@; } # Once we're connected, send the current test number to the server. # print the reply. package SendOne; sub registerIOE { my ($s) = @_; IO::Event->new($s); } sub ie_connected { my ($self, $s1) = @_; $s1->print("$c\n"); } sub ie_input { my ($self, $s, $br) = @_; print $s->getlines(); } # Listen for connections. When One is received, and input is received # on it, wait for input. The input should be the current test number. # Use "get()" # package ListenPrintOkay; sub ie_connection { my ($self, $s) = @_; my $x = $s->accept('ReceivePrintOkay'); } package ReceivePrintOkay; sub ie_input { my ($self, $s) = @_; my $l; while (defined ($l = $s->get)) { T::okay($l eq $c, "input '$l' == '$c' on results socket"); } } # # Listen for connections. When One is received, and input is received # on it, wait for input. The input should be the current test number. # Use "getline()" # package ListenGetLine; sub ie_connection { my ($self, $s) = @_; $s->accept('ReceiveGetLine'); } package ReceiveGetLine; sub ie_input { my ($self, $s) = @_; my $l; while (defined ($l = $s->getline)) { T::okay($l eq "$c\n", "input '$l' == '$c' on results socket"); } } IO-Event-0.814/t/callbacks1.t000644 000000 000000 00000000254 15261136517 015532 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } require './t/callbacks.tt'; IO-Event-0.814/t/callbacks2.t000644 000000 000000 00000000153 15261136517 015531 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; use IO::Event 'emulate_Event'; require './t/callbacks.tt'; IO-Event-0.814/t/callbacks3.t000644 000000 000000 00000000455 15261136517 015537 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require AnyEvent::Impl::Perl; require AnyEvent; }; ## no critic (Community::DiscouragedModules) if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use IO::Event; IO::Event->import('AnyEvent'); require './t/callbacks.tt'; IO-Event-0.814/t/forked.tt000644 000000 000000 00000024317 15261136517 015176 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; my $smallsleep = 0.; my $bigsleep = 0.5; my $debug = 0; my $syncdebug = 0; my $inactivity = 30; my $heartbeat = 0.1; BEGIN { unless (eval { require Test::More; }) { print "1..0 # Skipped: must have Test::More installed\n"; exit; } } BEGIN { unless (eval { require Time::HiRes; }) { print "1..0 # Skipped: must have Time::HiRes installed\n"; exit; } } use Time::HiRes qw(sleep gettimeofday tv_interval); use IO::Handle; use IO::Event; use IO::Socket::INET; use Carp qw(verbose); use Sys::Hostname; use Socket; my $t0 = [gettimeofday]; sleep(0.2); my $elapsed = tv_interval ( $t0 ); print "# elsapsed: $elapsed\n"; unless ($elapsed > 0.1 && $elapsed < 0.5) { print "# Time::HiRes::sleep() doesn't work - going slow\n"; $smallsleep = 1; $bigsleep = 2; } my @tests; my $testcount; BEGIN { @tests = ( { #0 repeat => 5, desc => "lines end in \\n", receive => sub { my $serverTest = shift; my $ieo = shift; my $got = <$ieo>; return $got; }, results => [ "howdy\n", "doody", ], sendqueue => [ "how", "dy\n", "doo", "dy" ], }, { #1 repeat => 5, desc => "paragraph mode", setup => sub { my $serverTest = shift; my $ieo = shift; $ieo->input_record_separator(''); }, receive => sub { my $serverTest = shift; my $ieo = shift; my $got = <$ieo>; return $got; }, results => [ "this is a test\n\n", "a\nb\n\n", "c\n\n", "d\n\n", "e\n", ], sendqueue => [ "this is ", "a test\n", "\n", "a\nb\n\nc\n\n\nd\n\n\n\ne\n", ], }, { #2 repeat => 5, desc => "paragraph mode, getlines", setup => sub { my $serverTest = shift; my $ieo = shift; $ieo->input_record_separator(''); }, receive => sub { my $serverTest = shift; my $ieo = shift; my (@got) = <$ieo>; return undef unless @got; return \@got; }, results => [ [ "this is a test\n\n", ], [ "a\nb\n\n", "c\n\n", "d\n\n", ], [ "e\n", ], ], sendqueue => [ "this is ", "a test\n", "\n", "a\nb\n\nc\n\n\nd\n\n\n\ne\n", ], }, { #3 repeat => 5, desc => "paragraph mode, getline, \$/ set funny", setup => sub { my $serverTest = shift; my $ieo = shift; $/ = 'xyz'; $ieo->input_record_separator(''); }, receive => sub { my $serverTest = shift; my $ieo = shift; return <$ieo>; }, results => [ "this is a test\n\n", "a\nb\n\n", "c\n\n", "d\n\n", "e\n", ], sendqueue => [ "this is ", "a test\n", "\n", "a\nb\n\nc\n\n\nd\n\n\n\ne\n", ], }, { #4 repeat => 5, desc => "paragraph mode, getlines, \$/ set funny", setup => sub { my $serverTest = shift; my $ieo = shift; $/ = 'abc'; $ieo->input_record_separator(''); }, receive => sub { my $serverTest = shift; my $ieo = shift; my (@got) = <$ieo>; return undef unless @got; return \@got; }, results => [ [ "this is a test\n\n", ], [ "a\nb\n\n", "c\n\n", "d\n\n", ], [ "e\n", ], ], sendqueue => [ "this is ", "a test\n", "\n", "a\nb\n\nc\n\n\nd\n\n\n\ne\n", ], }, ); # @tests = ($tests[3]); # splice(@tests, 0, 4); # $tests[0]->{repeat} = 1; $testcount = 0; for my $t (@tests) { my $subtests = scalar(@{$t->{results}}) + 1; $testcount += $t->{repeat} > 0 ? $t->{repeat} * $subtests : $subtests; } } BEGIN { use Test::More tests => $testcount; } my $startingport = 1025; my $rp = pickport(); my $child; my $timer; my $hbtimer; $SIG{PIPE} = sub { print "# SIGPIPE recevied in $$\n"; }; # A socketpair rather than a pipe, because non-blocking mode (used by # syncclear) is not supported on Windows pipes. my $pipe = IO::Handle->new; my $otherend = IO::Handle->new; socketpair($pipe, $otherend, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || die "socketpair: $!"; if ($child = fork()) { print "# PARENT $$ will listen at 127.0.0.1:$rp\n" if $debug; my $listener = IO::Event::Socket::INET->new( Listen => 10, Proto => 'tcp', LocalPort => $rp, LocalAddr => '127.0.0.1', Handler => Server->new, Description => 'Listener', ); $timer = Timer->new(); $hbtimer = Heartbeat->new(); $Event::DIED = $Event::DIED = sub { Event::verbose_exception_handler(@_); Event::unloop_all(); }; $otherend->close(); $pipe->autoflush(1); print $pipe "l"; print "# PARENT looping\n"; IO::Event::loop(); print "# PARENT done looping\n"; } elsif (defined($child)) { print "# CHILD $$ will connect to 127.0.0.1:$rp\n" if $debug; ($pipe, $otherend) = ($otherend, $pipe); $otherend->close(); syncto("l"); while (@tests) { my $test = $tests[0] || last; shift @tests if --$test->{repeat} < 1; print "# test $test->{desc}\n"; my $s = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $rp, Proto => 'tcp', ); syncto("a"); die "$$ could not connect: $!" unless $s; die "$$ socket not open" if eof($s); my $go = <$s>; $go =~ s/\n/\\n/g; print "# got '$go'\n" if $debug; for (my $sqi = 0; $sqi <= $#{$test->{sendqueue}}; $sqi++) { syncclear(); if ($debug) { my $x = $test->{sendqueue}[$sqi]; $x =~ s/\n/\\n/g; print "# SENDING '$x'\n"; } (print $s $test->{sendqueue}[$sqi]) || die "print $$: $!\n"; syncany(); } print "# CHILD closing\n"; close($s); syncto("e"); } } else { die "fork: $!"; } exit 0; # support routine sub pickport { for (my $i = 0; $i < 1000; $i++) { my $s = IO::Socket::INET->new( Listen => 1, LocalPort => $startingport, ); if ($s) { $s->close(); return $startingport++; } $startingport++; } die "could not find an open port"; } sub syncany { print "syncany\n" if $syncdebug; $pipe->blocking(1); my $buf; $pipe->sysread($buf, 1); syncclear(); print "syncany done - $buf\n" if $syncdebug; } sub syncto { my $lookfor = shift; print "syncto $lookfor\n" if $syncdebug; $pipe->blocking(1); my $buf; while ($pipe->sysread($buf, 1) > 0) { print "syncto got $buf\n" if $syncdebug; last if $buf eq $lookfor; } print "syncto $lookfor done\n" if $syncdebug; } sub syncclear { print "synclear\n" if $syncdebug; $pipe->blocking(0); my $buf; while ($pipe->sysread($buf, 4096)) { print "syncclear: '$buf'\n" if $syncdebug; } print "syncclear done\n" if $syncdebug; } package Server; use Test::More; sub new { my $pkg = shift; return bless { @_ }, $pkg; } sub ie_connection { my ($self, $s) = @_; $timer->reset; my $serverTest = Server->new; my $stream = $s->accept($serverTest); $serverTest->{stream} = $stream; $serverTest->{rqi} = 0; my $test = $tests[0]; shift @tests if --$test->{repeat} < 1; @$serverTest{keys %$test} = values %$test; my $setup = $serverTest->{setup}; &$setup($serverTest, $stream) if $setup; print "# ACCEPTED CONNECTION\n" if $debug; print "pipesend 'a'\n" if $syncdebug; print $pipe "a"; print $stream "go\n"; } sub ie_input { my ($self, $s) = @_; $timer->reset; my $rec = $self->{receive}; die unless $rec; for (;;) { my $r = &$rec($self, $s); return unless defined $r; my $expect = $self->{results}[$self->{rqi}++]; is_deeply($r, $expect); } } sub ie_eof { my ($self, $s) = @_; is($self->{rqi}, scalar(@{$self->{results}})); $s->close(); print "pipesend 'e'\n" if $syncdebug; print $pipe "e"; exit 0 unless @tests; } package Timer; use Carp; use strict; use warnings; sub new { my ($pkg) = @_; my $self = bless { }, $pkg; $self->{event} = IO::Event->timer( cb => [ $self, 'timeout' ], interval => $inactivity, hard => 0, desc => 'inactivity timer', ); return $self; } sub timeout { print STDERR "Timeout\n"; kill 9, $child; IO::Event::unloop_all(7.2); exit(1); } sub reset { my ($self) = @_; $self->{event}->stop(); $self->{event}->again(); } package Heartbeat; use Carp; use strict; use warnings; sub new { my ($pkg) = @_; my $self = bless { }, $pkg; $self->{event} = IO::Event->timer( cb => [ $self, 'timeout' ], interval => $heartbeat, hard => 0, desc => 'heartbeat timer', ); return $self; } sub timeout { print "pipesend 't'\n" if $syncdebug; print $pipe "t"; } __END__ IO-Event-0.814/t/forked1.t000644 000000 000000 00000000441 15261136517 015063 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; if ($^O eq 'MSWin32') { print "1..0 # Skip Event is not compatible with emulated fork on Windows\n"; exit 0; } eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } require './t/forked.tt'; IO-Event-0.814/t/forked2.t000644 000000 000000 00000000145 15261136517 015065 0ustar00rootroot000000 000000 #!/usr/bin/perl use strict; use warnings; use IO::Event 'emulate_Event'; require './t/forked.tt'; IO-Event-0.814/t/forked3.t000644 000000 000000 00000000453 15261136517 015070 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require AnyEvent::Impl::Perl; require AnyEvent; }; ## no critic (Community::DiscouragedModules) if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use IO::Event; IO::Event->import('AnyEvent'); require './t/forked.tt'; IO-Event-0.814/t/getline.tt000644 000000 000000 00000040242 15261136517 015346 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; my $slowest = 5; my $debug = 0; my $c = 1; $| = 1; my $testcount = 100; use Carp qw(verbose); use Sys::Hostname; my $startingport = 1025; package T; use IO::Event; use IO::Socket::INET; use Carp; use strict; use warnings; our $last_send = 0; our $last_receive = 0; BEGIN { eval { require Time::HiRes }; if ($@) { print "1..0 # Skipped: $@"; exit; } } # # basic idea... the receiver reads something. Once it # has read it, it performs actions that cause more stuff # to be sent. The recevier stuff is called within ie_input # our (@tests) = ( { # the first one is thrown away }, { #2 send => "woa baby\n", acquire => sub { print "about to get() a line\n" if $debug; puller()->get() }, compare => "woa baby", repeat => 1, desc => 'copy one line: print method & get method', }, { #3 send => "woa frog\n", acquire => sub { print "about to getline() a line\n" if $debug; puller()->getline() }, compare => "woa frog\n", desc => 'copy one line: print method & getline method', repeat => 1, }, { #4 send => sub { my $p = pusher(); print $p "foo\nbar\n"; }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "foo\n", "bar\n" ], repeat => 1, array => 1, desc => 'copy two lines: print filehandle & ', }, { #5 send => sub { my $p = pusher(); printf $p "%s\n%s\n", 'foo', 'baz'; }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "foo\n", "baz\n" ], repeat => 1, array => 1, desc => 'copy two lines: printf filehandle & ', }, { #6 send => sub { pusher()->print("abc123"); }, acquire => sub { my ($s, $ibr, $t) = @_; return '' unless length($$ibr) >= 6; my $p = puller(); my $x; read($p, $x, 3); die unless length($x) == 3; read($p, $x, 3, 3); return $x; }, compare => "abc123", repeat => 1, desc => 'copy 2x3 chars: print method & read filehandle', }, { #7 send => sub { pusher()->print("a\nb\n\nc\n\n\nd\n\n\n\ne\n"); $/ = ''; }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & array context ', }, { #8 send => sub { $/ = ''; pusher()->print("a\nb\n\nc\n\n\nd\n\n\n\ne\n"); }, acquire => sub { my $p = puller(); my @l; while (my $line = <$p>) { push(@l, $line); } return @l; }, compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & scalar context ', }, { #9 send => sub { pusher()->print("\n\n\na\nb\n\nc\n\n\nd\n\n\n\ne\n"); }, connect => sub { $/ = "xyz"; puller()->input_record_separator(''); }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & with $/ funny', }, { #10 send => sub { pusher()->print("\n\na\nb\n\nc\n\n\nd\n\n\n\ne\n"); }, connect => sub { $/ = "xyz"; puller()->input_record_separator(''); }, acquire => sub { my $p = puller(); my @l; while (my $line = <$p>) { push(@l, $line); } return @l; }, compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & scalar with $/ funny', }, { #11 send => sub { pusher()->print("xyz124abc567"); }, connect => sub { $/ = "\n"; puller()->input_record_separator(3); }, acquire => sub { my $p = puller(); my @l; while (my $line = <$p>) { push(@l, $line); } return @l; }, compare => [ "xyz", "124", "abc", "567" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & scalar with $/ == 3', }, { #12 send => sub { pusher()->print("xyz124abc567"); }, connect => sub { $/ = "\n"; puller()->input_record_separator(3); }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "xyz", "124", "abc", "567" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & with $/ == 3', }, { #13 send => sub { pusher()->print("xyzYYY124YYYabcYYY567"); }, connect => sub { $/ = "\n"; puller()->input_record_separator("YYY"); }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "xyzYYY", "124YYY", "abcYYY", "567" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & with $/ == YYY', }, { #14 send => sub { pusher()->print("xyzYYY124YYYYabcYYY567"); }, connect => sub { $/ = "\n"; puller()->input_record_separator("YYY"); }, acquire => sub { my $p = puller(); return <$p>; }, compare => [ "xyzYYY", "124YYY", "YabcYYY", "567" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & with $/ == YYY & extra Y', }, { #15 send => sub { pusher()->print("xyzYYY124YYYYabcYYY567"); }, connect => sub { puller()->input_record_separator("YYY"); }, acquire => sub { my $p = puller(); my @l; while (my $line = <$p>) { push(@l, $line); } return @l; }, compare => [ "xyzYYY", "124YYY", "YabcYYY", "567" ], repeat => 1, array => 1, desc => 'copy 4 sets many lines: print method & scalar with $/ == YYY & extra Y', }, { #15 send => sub { pusher()->print("my\ndog\nate\nmy..."); }, acquire => sub { my $p = puller(); my @l; my $x; while (defined ($x = $p->get())) { push(@l, $x); } return @l; }, compare => [ "my", "dog", "ate", "my..." ], repeat => 1, array => 1, desc => 'copy 4 lines: print method & get method', }, { #16 send => sub { pusher()->print("aaabbbcccddde"); }, acquire => sub { my $p = puller(); my @l; my $x; my $r = "12"; while ($x = $p->sysread($r, 3)) { die unless length($r) == $x; push(@l, $r); } return @l; }, compare => [ "aaa", "bbb", "ccc", "ddd", "e" ], repeat => 1, array => 1, desc => 'copy 5x3 chars: print method & sysread method', }, { #17 send => sub { pusher()->print("aaabbbcccddde"); }, acquire => sub { my $p = puller(); my @l; my $x; my $r = "12"; while ($x = $p->sysread($r, 3, 1)) { die unless length($r) == $x+1; push(@l, $r); } return @l; }, compare => [ "1aaa", "1bbb", "1ccc", "1ddd", "1e" ], repeat => 1, array => 1, desc => 'copy 5x3 chars: print method & sysread method with offset', }, { #18 send => sub { pusher()->print("aaabbbcccddde"); }, acquire => sub { my $p = puller(); my @l; my $x; my $r = "12"; while ($x = sysread($p, $r, 3)) { die unless length($r) == $x; push(@l, $r); } return @l; }, compare => [ "aaa", "bbb", "ccc", "ddd", "e" ], repeat => 1, array => 1, desc => 'copy 5x3 chars: print method & sysread filehandle', }, { #19 send => sub { pusher()->print("aaabbbcccddde"); }, acquire => sub { my $p = puller(); my @l; my $x; my $r = "12"; while ($x = sysread($p, $r, 3, 1)) { die unless length($r) == $x+1; push(@l, $r); } return @l; }, compare => [ "1aaa", "1bbb", "1ccc", "1ddd", "1e" ], repeat => 1, array => 1, desc => 'copy 5x3 chars: print method & sysread filehandle with offset', }, { #20 send => sub { pusher()->print("aaabbbcccddde"); }, acquire => sub { my $p = puller(); my $run; my $c; my @l; while ($c = $p->getc()) { if ($run && substr($run, 0, 1) eq $c) { $run .= $c; } elsif (! $run) { $run = $c; } else { $p->xungetc($c); push(@l, $run); undef $run; } } push(@l, $run) if defined $run; return @l; }, compare => [ "aaa", "bbb", "ccc", "ddd", "e" ], repeat => 1, array => 1, desc => 'getc & xungetc', }, ); printf "1..%d\n", scalar(@tests); # let's listen on a socket. We'll expect to receive # test numbers. We'll print ok. my $rp = T::pickport(); my $results = IO::Event::Socket::INET->new( Listen => 10, Proto => 'tcp', LocalPort => $rp, LocalAddr => '127.0.0.1', Handler => 'Pull', Description => "Listener, will receive on 127.0.0.1:$rp", ); die unless $results; die unless $results->filehandle; my $fh = $results->filehandle; my $fn = $fh->fileno; print STDERR "fh=$fh\n" if $debug; print STDERR "fn=$fn\n" if $debug; my $time = time; my $waitingfor = $c; my $push_socket; my $pull_socket; IO::Event->idle ( cb => \&startup, reentrant => 0, repeat => 0, ); okay($results, "now listening on results socket 127.0.0.1:$rp"); alarm($slowest); print STDERR "about to loop\n" if $debug; my $r = IO::Event::loop(); okay($r == 7, "loop finshed ($r)"); exit(0); sub pusher { my ($np) = @_; $push_socket = $np if $np; return $push_socket; } sub puller { my ($np) = @_; $pull_socket = $np if $np; return $pull_socket; } # support routine sub pickport { for (my $i = 0; $i < 1000; $i++) { my $s = IO::Socket::INET->new( Listen => 1, LocalPort => $startingport, ); if ($s) { $s->close(); return $startingport++; } $startingport++; } die "could not find an open port"; } # support routine sub okay { my ($cond, $message) = @_; if ($cond) { print "ok $c # $message\n"; } else { my($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller(0); print "not ok $c # $filename:$line $message\n"; } $c++; if ($c > $testcount) { print STDERR "too many test results\n"; exit(0); } } # default to oops sub ie_input { confess "we shoudn't be here"; } sub startup { print "Creating new sending socket, connecting to 127.0.0.1:$rp\n" if $debug; IO::Event::Socket::INET->new ( Proto => 'tcp', PeerPort => $rp, PeerAddr => '127.0.0.1', Handler => 'Push', Description => "Sending socket", ) or T::okay(0, "create pusher to $rp: $@"); } sub sender { print "sender() invoked\n" if $debug; die "send/receive out of sync $last_send/$last_receive" if $last_send != $last_receive; shift(@tests); if (! @tests) { okay(1, "all done"); exit(0); } my $t = $tests[0]; print "##############################################################################\n" if $debug; print "# starting $t->{desc}\n"; my $send = $t->{send}; $last_send++; # okay(1, "keys = ".join(' ',keys %$t)); if (ref $send) { eval { &$send() }; if ($@) { T::okay(0, "send error $@"); exit(0); } } else { pusher || confess "no pusher"; print "# printing '$send' for new test\n" if $debug; pusher->print($send); } pusher->close(); alarm($slowest); } package Push; sub ie_connected { my ($self, $s) = @_; T::pusher($s); T::sender($s); } sub ie_input { my ($self, $s, $br) = @_; print $s->getlines(); } package Pull; use strict; use warnings; sub ie_connection { my ($self, $s) = @_; print STDERR "Got puller connection $T::last_receive\n" if $debug; T::puller($s->accept); my $t = $T::tests[0]; my $c = $t->{connect}; &$c if $c; } sub ie_input { print STDERR "INPUT $T::last_receive\n" if $debug; #use Carp; #print Carp::longmess("DEBUG... ie_input called\n"); my ($self, $iput, $ibuf) = @_; my $t = $T::tests[0]; my $acquire = $t->{acquire}; my ($r, @r); if ($t->{array}) { @r = eval { &$acquire($iput, $ibuf, $t) }; } else { $r = eval { &$acquire($iput, $ibuf, $t) }; } if ($@) { T::okay(0, "acquire error: $@ errno:$!"); exit(0); } if ($t->{repeat}) { if ($t->{array}) { unshift(@r, @{$t->{prev}}) if $t->{prev}; $t->{prev} = [ @r ]; } else { $r = $t->{prev}.$r if $t->{prev}; $t->{prev} = $r; } } my $compare = $t->{compare}; my $cr; if (ref $compare eq 'CODE') { if ($t->{array}) { $cr = eval { &$compare(@r) }; } else { $cr = eval { &$compare($r) }; } if ($@) { T::okay(0, "copmare error $@"); exit(0); } } elsif ($t->{array}) { $r = join('><', @r); $compare = join('><', @$compare); $cr = length($r) < length($compare) ? -1 : ($r eq $compare ? 0 : 1); } else { $cr = length($r) < length($compare) ? -1 : ($r eq $compare ? 0 : 1); print "COMPARE '$r' vs '$compare' = $cr\n" if $debug; } my $dr = $r; $dr =~ s/\n/\\n/g; my $dcompare = $compare; $dcompare =~ s/\n/\\n/g; if ($t->{repeat} && $cr == -1 && ! $iput->eof) { print STDERR "waiting for more input:\n\t<$dr>\n\t<$dcompare>\n" if $debug; # we'll wait for more input print "# wait for more input\n"; return; } my $desc = $t->{desc}; if ($cr == 0) { T::okay(1, $desc); } else { T::okay(0, "test $desc failed: $cr: <$dr> <$dcompare>"); } print "# done\n"; print "##############################################################################\n" if $debug; $T::last_receive++; if (@tests > 1) { T::startup; } else { exit 0; } alarm($slowest); } sub ie_eof { print "# eof\n"; } IO-Event-0.814/t/getline1.t000644 000000 000000 00000000252 15261136517 015240 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } require './t/getline.tt'; IO-Event-0.814/t/getline2.t000644 000000 000000 00000000146 15261136517 015243 0ustar00rootroot000000 000000 #!/usr/bin/perl use strict; use warnings; use IO::Event 'emulate_Event'; require './t/getline.tt'; IO-Event-0.814/t/getline3.t000644 000000 000000 00000000453 15261136517 015245 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require AnyEvent::Impl::Perl; require AnyEvent; }; ## no critic (Community::DiscouragedModules) if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use IO::Event; IO::Event->import('AnyEvent'); require './t/getline.tt'; IO-Event-0.814/t/multifork.tt000644 000000 000000 00000012044 15261136517 015732 0ustar00rootroot000000 000000 package Test::XMultiFork; use strict; use warnings; use IO::Event; use IO::Handle; require POSIX; use Socket; use Time::HiRes qw(sleep); use parent 'Exporter'; use diagnostics; # server side my %capture; my $sequence = 1; # client side my $newstdout; sub dofork { my ($pkg, $spec) = @_; while($spec) { $spec =~ s/^([a-z])(\d*)// || die "illegal fork spec"; my $letter = $1; my $count = $2 || 1; for my $n (1..$count) { my $pid; my $psideCapture = IO::Handle->new; $newstdout = IO::Handle->new; socketpair($psideCapture, $newstdout, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || die "socketpair: $!"; if ($pid = fork()) { # parent sleep(0.1); $newstdout->close(); Test::XMultiFork::Capture->new($psideCapture, $letter, $n); } elsif (defined $pid) { # child $psideCapture->close(); # we aren't interested in the other filehandles for my $c (keys %capture) { $capture{$c}{ie}->close(); delete $capture{$c}; } $newstdout->autoflush(1); if (defined &Test::Builder::new) { my $tb = Test::Builder->new; $tb->output($newstdout); $tb->todo_output($newstdout); $tb->failure_output($newstdout); } if ($^O eq 'MSWin32') { # fork is emulated with threads in a single process, # so re-opening STDOUT would redirect the parent's too select($newstdout); } else { my $fn = $newstdout->fileno(); open(STDOUT, '>&=', $fn) || die "redirect stdout: $!"; autoflush STDOUT 1; } return; } else { die "Can't fork: $!"; } } } if (IO::Event::loop(5) == 7.3) { # great notokay(0, "clean shutdown"); } else { notokay(1, "event loop timeout"); } $sequence--; print "1..$sequence\n"; exit(0); } sub notokay { my ($not, $name, $comment) = @_; $not = $not ? "not " : ""; $name = " - $name" unless $name =~ /^\s*-/; $comment = "" unless defined $comment; print "${not}ok $sequence $name # $comment\n"; $sequence++; } package Test::XMultiFork::Capture; use strict; use diagnostics; sub new { my ($pkg, $fh, $letter, $n) = @_; my $self = bless { letter => $letter, n => $n, seq => 1, plan => undef, code => "$letter-$n", }, $pkg; $self->{ie} = IO::Event->new($fh, $self, "For $letter$n"); $capture{$self->{code}} = $self; return $self; } sub ie_input { my ($self, $ie) = @_; while (my $line = <$ie>) { chomp $line; if ($line =~ /^(?:(not)\s+)?ok\S*(?:\s+(\d+))?([^#]*)(?:#(.*))?$/) { my ($not, $seq, $name, $comment) = ($1, $2, $3, $4); $name = '' unless defined $name; $comment = '' unless defined $name; if (defined($seq)) { if ($seq != $self->{seq}) { Test::XMultiFork::notokay(1, "result ordering in $self->{code}", "expected '$self->{seq}' but got '$seq'"); } $self->{seq} = $seq+1; } else { $self->{seq}++; } $comment .= " [ $self->{code} ]"; Test::XMultiFork::notokay($not, $name, $comment); next; } if ($line =~ /^1\.\.(\d+)/) { Test::XMultiFork::notokay(1, "multiple plans", $self->{code}) if defined $self->{plan}; $self->{plan} = $1; next; } print "$line [$self->{code}]\n"; } } sub ie_eof { my ($self, $ie) = @_; if ($self->{plan}) { $self->{seq}--; if ($self->{plan} == $self->{seq}) { Test::XMultiFork::notokay(0, "plan followed", $self->{code}); } else { Test::XMultiFork::notokay(1, "plan followed $self->{code}", "plan: $self->{plan} actual: $self->{seq}"); } } $ie->close(); delete $capture{$self->{code}}; IO::Event::unloop_all(7.3) unless %capture; } package TheTest; use Test::Simple; use Time::HiRes qw(sleep); Test::XMultiFork->dofork("a15"); srand(time ^ ($$ < 5)); Test::Simple->import(tests => 10); sleep(0.1) if rand(1) < .3; ok(1, "one$$"); sleep(0.1) if rand(1) < .3; ok(2, "two$$"); sleep(0.1) if rand(1) < .3; ok(3, "three$$"); sleep(0.1) if rand(1) < .3; ok(4, "four$$"); sleep(0.1) if rand(1) < .3; ok(5, "five$$"); sleep(0.1) if rand(1) < .3; ok(6, "six$$"); sleep(0.1) if rand(1) < .3; ok(7, "seven$$"); sleep(0.1) if rand(1) < .3; ok(8, "eight$$"); sleep(0.1) if rand(1) < .3; ok(9, "nine$$"); sleep(0.1) if rand(1) < .3; ok(10, "ten$$"); sleep(0.1) if rand(1) < .3; exit(0); IO-Event-0.814/t/multifork1.t000644 000000 000000 00000000444 15261136517 015630 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; if ($^O eq 'MSWin32') { print "1..0 # Skip Event is not compatible with emulated fork on Windows\n"; exit 0; } eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } require './t/multifork.tt'; IO-Event-0.814/t/multifork2.t000644 000000 000000 00000000500 15261136517 015622 0ustar00rootroot000000 000000 #!/usr/bin/perl use strict; use warnings; if ($^O eq 'MSWin32') { # all tests pass, but perl frequently crashes while tearing down the # emulated fork children print "1..0 # Skip crashes during emulated fork teardown on Windows\n"; exit 0; } use IO::Event 'emulate_Event'; require './t/multifork.tt'; IO-Event-0.814/t/multifork3.t000644 000000 000000 00000000455 15261136517 015634 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require AnyEvent::Impl::Perl; require AnyEvent; }; ## no critic (Community::DiscouragedModules) if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use IO::Event; IO::Event->import('AnyEvent'); require './t/multifork.tt'; IO-Event-0.814/t/timer.tt000644 000000 000000 00000002427 15261136517 015042 0ustar00rootroot000000 000000 #!/usr/bin/perl use strict; use warnings; my $smallsleep = 0.; my $bigsleep = 0.5; my $debug = 0; my $syncdebug = 0; my $inactivity = 5; my $heartbeat = 0.1; BEGIN { unless (eval { require Test::More; }) { print "1..0 # Skipped: must have Test::More installed\n"; exit; } } BEGIN { unless (eval { require Time::HiRes; }) { print "1..0 # Skipped: must have Time::HiRes installed\n"; exit; } } use Time::HiRes qw(time); use IO::Event; use Carp qw(verbose); use Test::More tests => 6; $SIG{ALRM} = sub { ok(0, "5 second alarlm went off"); exit 1 }; alarm(10); my $start = time; my $timer1count = 0; my $timer2count = 0; IO::Event->timer( interval => 0.2, cb => sub { $timer1count++; }, ); IO::Event->timer( interval => 3, cb => sub { $timer2count++; IO::Event::unloop_all(); }, ); IO::Event::loop(); ok(1, "loop finshed"); my $end = time; my $duration = $end - $start; ok($end - $start > 2, "at least 2 seconds - got $duration"); ok($end - $start < 4, "less than 4 seconds - got $duration"); ok($timer1count > 8, "at least 8 firings - got $timer1count"); ok($timer1count < 20, "no more than 20 firings - got $timer1count"); is($timer2count, 1, "timer2count"); alarm(0); 1; IO-Event-0.814/t/timer1.t000644 000000 000000 00000000250 15261136517 014727 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } require './t/timer.tt'; IO-Event-0.814/t/timer2.t000644 000000 000000 00000000144 15261136517 014732 0ustar00rootroot000000 000000 #!/usr/bin/perl use strict; use warnings; use IO::Event 'emulate_Event'; require './t/timer.tt'; IO-Event-0.814/t/timer3.t000644 000000 000000 00000000452 15261136517 014735 0ustar00rootroot000000 000000 #!/usr/bin/perl -I. use strict; use warnings; eval { require AnyEvent::Impl::Perl; require AnyEvent; }; ## no critic (Community::DiscouragedModules) if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use IO::Event; IO::Event->import('AnyEvent'); require './t/timer.tt'; IO-Event-0.814/xt/000755 000000 000000 00000000000 15261136517 013534 5ustar00rootroot000000 000000 IO-Event-0.814/xt/author/000755 000000 000000 00000000000 15261136517 015036 5ustar00rootroot000000 000000 IO-Event-0.814/xt/author/critic.t000644 000000 000000 00000000701 15261136517 016476 0ustar00rootroot000000 000000 use Test2::Require::Module 'Test2::Tools::PerlCritic'; use Test2::Require::Module 'Perl::Critic'; use Test2::Require::Module 'Perl::Critic::Freenode'; use Test2::V0; use Perl::Critic; use Test2::Tools::PerlCritic; use File::Glob qw( bsd_glob ); my $critic = Perl::Critic->new( -profile => 'perlcriticrc', ); my @tests = grep { $_ ne 't/00_diag.t' } bsd_glob('t/*.t'), bsd_glob('t/*.tt'); perl_critic_ok ['lib', @tests], $critic; done_testing; IO-Event-0.814/xt/author/eol.t000644 000000 000000 00000000510 15261136517 015776 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::EOL' unless eval q{ use Test::EOL; 1 }; }; use Test::EOL; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); all_perl_files_ok(grep { -e $_ } qw( bin lib t Makefile.PL )); IO-Event-0.814/xt/author/filename.t000644 000000 000000 00000000720 15261136517 017002 0ustar00rootroot000000 000000 use Test2::V0 -no_srand => 1; use File::chdir; use File::Find qw( find ); use File::Basename qw( basename ); my $basename = basename $CWD; my $dev = $basename =~ /^([A-Z]+)(-[A-Z]+)*$/i; local $CWD = '..'; find(sub { my $path = $File::Find::name; return if $path =~ /^$basename\/\./; return if $dev && $path =~ /^$basename\/$basename-/; my $length = length($path); cmp_ok $length, '<', 100, "$path"; }, $basename); note "dev = $dev"; done_testing; IO-Event-0.814/xt/author/no_tabs.t000644 000000 000000 00000000522 15261136517 016647 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::NoTabs' unless eval q{ use Test::NoTabs; 1 }; }; use Test::NoTabs; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); all_perl_files_ok( grep { -e $_ } qw( bin lib t Makefile.PL )); IO-Event-0.814/xt/author/pod.t000644 000000 000000 00000000472 15261136517 016010 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Pod' unless eval q{ use Test::Pod; 1 }; }; use Test::Pod; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); all_pod_files_ok( grep { -e $_ } qw( bin lib )); IO-Event-0.814/xt/author/pod_coverage.t000644 000000 000000 00000004001 15261136517 017653 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires 5.010 or better' unless $] >= 5.010; plan skip_all => 'test requires Test::Pod::Coverage' unless eval q{ use Test::Pod::Coverage; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML; 1; }; plan skip_all => 'test does not always work in cip check' if defined $ENV{CIPSTATIC} && $ENV{CIPSTATIC} eq 'true'; }; use Test::Pod::Coverage; use YAML qw( LoadFile ); use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; plan skip_all => 'disabled' if $config->{pod_coverage}->{skip}; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); my @private_classes; my %private_methods; push $config->{pod_coverage}->{private}->@*, 'Alien::.*::Install::Files#Inline'; foreach my $private ($config->{pod_coverage}->{private}->@*) { my($class,$method) = split /#/, $private; if(defined $class && $class ne '') { my $regex = eval 'qr{^' . $class . '$}'; if(defined $method && $method ne '') { push @private_classes, { regex => $regex, method => $method }; } else { push @private_classes, { regex => $regex, all => 1 }; } } elsif(defined $method && $method ne '') { $private_methods{$_} = 1 for split /,/, $method; } } my @classes = all_modules; plan tests => scalar @classes; foreach my $class (@classes) { SKIP: { my($is_private_class) = map { 1 } grep { $class =~ $_->{regex} && $_->{all} } @private_classes; skip "private class: $class", 1 if $is_private_class; my %methods = map {; $_ => 1 } map { split /,/, $_->{method} } grep { $class =~ $_->{regex} } @private_classes; $methods{$_} = 1 for keys %private_methods; my $also_private = eval 'qr{^' . join('|', keys %methods ) . '$}'; pod_coverage_ok $class, { also_private => [$also_private] }; }; } IO-Event-0.814/xt/author/pod_spelling_common.t000644 000000 000000 00000001350 15261136517 021251 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Pod::Spelling::CommonMistakes' unless eval q{ use Test::Pod::Spelling::CommonMistakes; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML qw( LoadFile ); 1 }; }; use Test::Pod::Spelling::CommonMistakes; use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; plan skip_all => 'disabled' if $config->{pod_spelling_common}->{skip}; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); # TODO: test files in bin too. all_pod_files_ok; IO-Event-0.814/xt/author/pod_spelling_system.t000644 000000 000000 00000002367 15261136517 021316 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Spelling' unless eval q{ use Test::Spelling; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML; 1; }; }; use Test::Spelling; use YAML qw( LoadFile ); use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; plan skip_all => 'disabled' if $config->{pod_spelling_system}->{skip}; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); add_stopwords($config->{pod_spelling_system}->{stopwords}->@*); add_stopwords(qw( Plicease stdout stderr stdin subref loopback username os Ollis Mojolicious plicease CPAN reinstall TODO filename filenames login callback callbacks standalone VMS hostname hostnames TCP UDP IP API MSWin32 OpenBSD FreeBSD NetBSD unencrypted WebSocket WebSockets timestamp timestamps poney BackPAN portably RedHat AIX BSD XS FFI perlish optimizations subdirectory RESTful SQLite JavaScript dir plugins munge jQuery namespace PDF PDFs usernames DBI pluggable APIs SSL JSON YAML uncommented Solaris OpenVMS URI URL CGI )); all_pod_files_spelling_ok; IO-Event-0.814/xt/author/strict.t000644 000000 000000 00000001031 15261136517 016526 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Strict' unless eval q{ use Test::Strict; 1 }; }; use Test::Strict; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); unshift @Test::Strict::MODULES_ENABLING_STRICT, 'ozo', 'Test2::Bundle::SIPS', 'Test2::V0', 'Test2::Bundle::Extended'; note "enabling strict = $_" for @Test::Strict::MODULES_ENABLING_STRICT; all_perl_files_ok( grep { -e $_ } qw( bin lib t Makefile.PL )); IO-Event-0.814/xt/author/version.t000644 000000 000000 00000001473 15261136517 016715 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; use FindBin (); BEGIN { plan skip_all => "test requires Test::Version 2.00" unless eval q{ use Test::Version 2.00 qw( version_all_ok ), { has_version => 1, filename_match => sub { $_[0] !~ m{/(ConfigData|Install/Files)\.pm$} }, }; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML; 1; }; } use YAML qw( LoadFile ); use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; if($config->{version}->{dir}) { note "using dir " . $config->{version}->{dir} } version_all_ok($config->{version}->{dir} ? ($config->{version}->{dir}) : ()); done_testing; IO-Event-0.814/xt/release/000755 000000 000000 00000000000 15261136517 015154 5ustar00rootroot000000 000000 IO-Event-0.814/xt/release/fixme.t000644 000000 000000 00000000616 15261136517 016454 0ustar00rootroot000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Fixme' unless eval q{ use Test::Fixme 0.14; 1 }; }; use Test::Fixme 0.07; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); run_tests( match => qr/FIXME/, where => [ grep { -e $_ } qw( bin lib t Makefile.PL Build.PL )], warn => 1, );