IO-Event-0.813/0000755000175000017500000000000012216220731011621 5ustar muirmuirIO-Event-0.813/Changes0000644000175000017500000000722412216220704013121 0ustar muirmuirRevision history for Perl module IO::Event 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.813/README0000644000175000017500000004710712216217725012523 0ustar muirmuirNAME IO::Event - Tied Filehandles for Nonblocking IO with Object Callbacks 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 accesible 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 psuedo-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 attept 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 psuedo-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 psuedo-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 occured 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 ETIMEOUT. 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 contineously 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 ins'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. 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. SUBSTITUED 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 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. LICENSE Copyright (C) 2002-2009 David Muir Sharnoff . Copyright (C) 2011-2013 Google, Inc. This module may be used/copied/etc on the same terms as Perl itself. This module is packaged for Fedora by Emmanuel Seyman POD ERRORS Hey! The above document had some coding errors, which are explained below: Around line 476: '=item' outside of any '=over' IO-Event-0.813/META.yml0000644000175000017500000000122512216220731013072 0ustar muirmuir--- abstract: 'Tied Filehandles for Nonblocking IO with Object Callbacks' author: - 'David Muir Sharnoff ' build_requires: AnyEvent: 0 Event: 0 Test::Simple: 0 diagnostics: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: IO-Event no_index: directory: - t - inc requires: IO::Handle: 0 List::MoreUtils: 0 Time::HiRes: 0 resources: repository: http://github.com/muir/File-Flock version: 0.813 IO-Event-0.813/lib/0000755000175000017500000000000012216220731012367 5ustar muirmuirIO-Event-0.813/lib/IO/0000755000175000017500000000000012216220731012676 5ustar muirmuirIO-Event-0.813/lib/IO/Event/0000755000175000017500000000000012216220731013757 5ustar muirmuirIO-Event-0.813/lib/IO/Event/Emulate.pm0000644000175000017500000002140511521566677015737 0ustar muirmuir # # Use a pure-perl event handler that kinda emulates's Event # for IO::Event's event handler. # my $sdebug = 0; { package IO::Event::Emulate; use strict; use warnings; our @ISA = qw(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); our @ISA = qw(IO::Event); our %timers = (); our %levels = (); our %next = (); BEGIN { for $a (qw(at after interval hard cb desc prio repeat timeout)) { my $attrib = $a; no strict 'refs'; *{"IO::Event::Emulate::Timer::$a"} = 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); our @ISA = qw(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; IO-Event-0.813/lib/IO/Event/Event.pm0000644000175000017500000000346412122251736015412 0ustar muirmuir # # 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; require IO::Event; use strict; use warnings; our @ISA = qw(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; IO-Event-0.813/lib/IO/Event/AnyEvent.pm0000644000175000017500000000762712125157672016076 0ustar muirmuir # # Use AnyEvent for the IO::Event's event handler # my $debug = 0; my $debug_timer; my $lost_event_timer; { package IO::Event::AnyEvent; our $lost_event_hack = 2; require IO::Event; use strict; use warnings; use Scalar::Util qw(refaddr); our @ISA = qw(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; IO-Event-0.813/lib/IO/Event/Callback.pm0000644000175000017500000000643411521733261016025 0ustar muirmuir package IO::Event::Callback; 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__ =head1 NAME IO::Event::Callback - A closure based API for IO::Event =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 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 exmaple use of IO::Event::Callback. IO-Event-0.813/lib/IO/Event.pm0000644000175000017500000006576312216217606014345 0ustar muirmuir our $debug = 0; our $edebug = 0; our $sdebug = 0; { package IO::Event; our $VERSION = 0.813; use strict; no strict 'refs'; use warnings; use Carp qw(confess); our $base; our @ISA; 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; require IO::Event::Event; $base = 'IO::Event::Event'; } elsif ($s eq 'AnyEvent') { require AnyEvent; require IO::Event::AnyEvent; $base = 'IO::Event::AnyEvent'; } else { die "unknown import: $s"; } @ISA = $base; } return 1; } sub AUTOLOAD { my $self = shift; our $AUTOLOAD; my $a = $AUTOLOAD; $a =~ 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) { eval { @r = $fh->$a(@_) }; } else { eval { $r = $fh->$a(@_) }; } if ($@ && $@ =~ /Can't locate object method "(.*?)" via package/) { my $event = ${*$self}{ie_event}; if ($1 ne $a) { # nothing to do } elsif ($event && $event->can($a)) { if (wantarray) { eval { @r = $event->$a(@_) }; } else { eval { $r = $event->$a(@_) }; } } else { confess qq{Can't locate object method "$a" via "@{[ ref($self) ]}", "@{[ ref($fh)||'IO::Handle' ]}", or "@{[ ref($event) ]}"}; } } } else { my $event = ${*$self}{ie_event}; if ($event && $event->can($a)) { if (wantarray) { eval { @r = $event->$a(@_) }; } else { eval { $r = $event->$a(@_) }; } } else { confess qq{Can't locate object method "$a" via "@{[ ref($self) ]}" or "@{[ ref($event) ]}"}; } } confess $@ if $@; return @r if wantarray; return $r; } }{package IO::Event::Common; use strict; use warnings; use Symbol; use Carp; require IO::Handle; use POSIX qw(BUFSIZ EAGAIN EBADF EINVAL ETIMEDOUT); 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; } } # # 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) { # 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) { # 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) { # 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) { $$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; } 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::MoreUtils qw(any); our @ISA = qw(IO::Event); sub new { my ($pkg, $a, $b, %sock) = @_; # emulate behavior in the IO::Socket::INET API if (! %sock && ! $b) { $sock{PeerAddr} = $a; } else { $sock{$a} = $b; } 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 = new IO::Socket::INET(%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; our @ISA = qw(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 = new IO::Socket::UNIX(%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; IO-Event-0.813/lib/IO/Event.pod0000644000175000017500000004326712216177525014513 0ustar muirmuir =head1 NAME IO::Event - Tied Filehandles for Nonblocking IO with Object Callbacks =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 accesible 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 psuedo-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 attept 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 psuedo-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 psuedo-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 occured 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 ETIMEOUT. =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 contineously 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 ins'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. =back =item ->ie_desc([new description]) Returns (and sets) the text description of the filehandle. For debugging. =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 SUBSTITUED 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 LICENSE Copyright (C) 2002-2009 David Muir Sharnoff . Copyright (C) 2011-2013 Google, Inc. This module may be used/copied/etc on the same terms as Perl itself. This module is packaged for Fedora by Emmanuel Seyman IO-Event-0.813/META.json0000644000175000017500000000221112216220731013236 0ustar muirmuir{ "abstract" : "Tied Filehandles for Nonblocking IO with Object Callbacks", "author" : [ "David Muir Sharnoff " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "IO-Event", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "AnyEvent" : 0, "Event" : 0, "Test::Simple" : 0, "diagnostics" : 0 } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "runtime" : { "requires" : { "IO::Handle" : 0, "List::MoreUtils" : 0, "Time::HiRes" : 0 } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/muir/File-Flock" } }, "version" : "0.813" } IO-Event-0.813/MANIFEST0000644000175000017500000000073612216220731012760 0ustar muirmuirChanges lib/IO/Event/Callback.pm lib/IO/Event/Event.pm lib/IO/Event/Emulate.pm lib/IO/Event/AnyEvent.pm lib/IO/Event.pm lib/IO/Event.pod Makefile.PL MANIFEST META.yml README t/callbacks1.t t/callbacks2.t t/callbacks3.t t/callbacks.tt t/forked1.t t/forked2.t t/forked3.t t/forked.tt t/getline1.t t/getline2.t t/getline3.t t/getline.tt t/multifork1.t t/multifork2.t t/multifork3.t t/multifork.tt META.json Module JSON meta-data (added by MakeMaker) IO-Event-0.813/Makefile.PL0000755000175000017500000000166012131131346013600 0ustar muirmuir use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile being created. WriteMakefile( 'NAME' => 'IO::Event', 'DISTNAME' => 'IO-Event', 'VERSION_FROM' => 'lib/IO/Event.pm', ($] >= 5.005 ? ( ABSTRACT => 'Tied Filehandles for Nonblocking IO with Object Callbacks', AUTHOR => 'David Muir Sharnoff ', META_MERGE => { resources => { repository => 'http://github.com/muir/File-Flock', }, }, ) : () ), 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'}, 'PREREQ_PM' => { 'IO::Handle' => 0, 'Time::HiRes' => 0, 'List::MoreUtils' => 0, }, 'BUILD_REQUIRES' => { 'Event' => 0, 'AnyEvent' => 0, 'diagnostics' => 0, 'Test::Simple' => 0, } ); package MY; sub postamble { <<"END_OF_POSTAMBLE"; pm_to_blib: README README: lib/IO/Event.pod \tpod2text lib/IO/Event.pod >README END_OF_POSTAMBLE } IO-Event-0.813/t/0000755000175000017500000000000012216220731012064 5ustar muirmuirIO-Event-0.813/t/forked2.t0000755000175000017500000000014211423442564013616 0ustar muirmuir#!/usr/bin/perl use IO::Event 'emulate_Event'; use FindBin; require "$FindBin::Bin/forked.tt"; IO-Event-0.813/t/callbacks3.t0000755000175000017500000000036311522054021014254 0ustar muirmuir#!/usr/bin/perl -I. eval { require AnyEvent::Impl::Perl; require AnyEvent; }; if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use FindBin; use IO::Event; import IO::Event 'AnyEvent'; require "$FindBin::Bin/callbacks.tt"; IO-Event-0.813/t/getline3.t0000755000175000017500000000036112122036552013770 0ustar muirmuir#!/usr/bin/perl -I. eval { require AnyEvent::Impl::Perl; require AnyEvent; }; if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use FindBin; use IO::Event; import IO::Event 'AnyEvent'; require "$FindBin::Bin/getline.tt"; IO-Event-0.813/t/forked1.t0000755000175000017500000000023711423442644013621 0ustar muirmuir#!/usr/bin/perl -I. eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } use FindBin; require "$FindBin::Bin/forked.tt"; IO-Event-0.813/t/forked.tt0000755000175000017500000001742411522214745013731 0ustar muirmuir#!/usr/bin/perl -I. 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(sleep gettimeofday tv_interval); use IO::Pipe; 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"; }; my $pipe = new IO::Pipe; 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 => new Server, Description => 'Listener', ); $timer = Timer->new(); $hbtimer = Heartbeat->new(); $Event::DIED = $Event::DIED = sub { Event::verbose_exception_handler(@_); Event::unloop_all(); }; $pipe->writer(); $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->reader(); 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); } } else { die "fork: $!"; } exit 0; # support routine sub pickport { for (my $i = 0; $i < 1000; $i++) { my $s = new IO::Socket::INET ( 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->read($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->read($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->read($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 { @_ }; } sub ie_connection { my ($self, $s) = @_; $timer->reset; my $serverTest = new Server; 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) = @_; 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); } print "pipesend 'i'\n" if $syncdebug; print $pipe "i"; } 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"; } 1; __END__ IO-Event-0.813/t/getline1.t0000755000175000017500000000024011423462126013765 0ustar muirmuir#!/usr/bin/perl -I. eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } use FindBin; require "$FindBin::Bin/getline.tt"; IO-Event-0.813/t/multifork2.t0000755000175000017500000000014311423442713014355 0ustar muirmuir#!/usr/bin/perl use IO::Event 'emulate_Event'; use FindBin; require "$FindBin::Bin/multifork.tt"; IO-Event-0.813/t/multifork.tt0000644000175000017500000000760711521660772014476 0ustar muirmuirpackage Test::XMultiFork; use IO::Event; use IO::Handle; require POSIX; use Socket; require Exporter; use Time::HiRes qw(sleep); @ISA = qw(Exporter); use strict; 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 = new IO::Handle; $newstdout = new IO::Handle; 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 = new Test::Builder; $tb->output($newstdout); $tb->todo_output($newstdout); $tb->failure_output($newstdout); } 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 (<$ie>) { chomp; if (/^(?:(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 (/^1\.\.(\d+)/) { Test::XMultiFork::notokay(1, "multiple plans", $self->{code}) if defined $self->{plan}; $self->{plan} = $1; next; } print "$_ [$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)); import Test::Simple 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); 1; IO-Event-0.813/t/getline.tt0000755000175000017500000003142011522215027014070 0ustar muirmuir#!/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; my $tnum; 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 (<$p>) { push(@l, $_); } 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 (<$p>) { push(@l, $_); } 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 (<$p>) { push(@l, $_); } 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 (<$p>) { push(@l, $_); } 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 $b; my $c; my @l; while ($c = $p->getc()) { if ($b && substr($b, 0, 1) eq $c) { $b .= $c; } elsif (! $b) { $b = $c; } else { $p->xungetc($c); push(@l, $b); undef $b; } } push(@l, $b) if defined $b; 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 $idle; my $time = time; my $waitingfor = $c; my $ptime; 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 = new IO::Socket::INET ( 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"; $a = $t->{send}; $last_send++; # okay(1, "keys = ".join(' ',keys %$t)); if (ref $a) { eval { &$a() }; if ($@) { T::okay(0, "send error $@"); exit(0); } } else { pusher || confess "no pusher"; print "# printing '$a' for new test\n" if $debug; pusher->print($a); } 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"; } 1; IO-Event-0.813/t/multifork1.t0000755000175000017500000000024211423442755014362 0ustar muirmuir#!/usr/bin/perl -I. eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } use FindBin; require "$FindBin::Bin/multifork.tt"; IO-Event-0.813/t/callbacks.tt0000755000175000017500000001160512120264743014367 0ustar muirmuir#!/usr/bin/perl -I. use strict; 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 = new IO::Socket::INET ( 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); my $run1er; 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"); } } 1; IO-Event-0.813/t/forked3.t0000755000175000017500000000036112122036436013614 0ustar muirmuir#!/usr/bin/perl -I. eval { require AnyEvent::Impl::Perl; require AnyEvent; }; if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use FindBin; use IO::Event; import IO::Event 'AnyEvent'; require "$FindBin::Bin/forked.tt"; IO-Event-0.813/t/multifork3.t0000755000175000017500000000036312122036563014361 0ustar muirmuir#!/usr/bin/perl -I. eval { require AnyEvent::Impl::Perl; require AnyEvent; }; if ($@) { print "1..0 # Skip AnyEvent not installed\n"; exit 0; } use FindBin; use IO::Event; import IO::Event 'AnyEvent'; require "$FindBin::Bin/multifork.tt"; IO-Event-0.813/t/callbacks1.t0000755000175000017500000000024211522053764014263 0ustar muirmuir#!/usr/bin/perl -I. eval { require Event; }; if ($@) { print "1..0 # Skip Event not installed\n"; exit 0; } use FindBin; require "$FindBin::Bin/callbacks.tt"; IO-Event-0.813/t/getline2.t0000755000175000017500000000014311431175730013771 0ustar muirmuir#!/usr/bin/perl use IO::Event 'emulate_Event'; use FindBin; require "$FindBin::Bin/getline.tt"; IO-Event-0.813/t/callbacks2.t0000755000175000017500000000014711423441554014266 0ustar muirmuir#!/usr/bin/perl -I. use IO::Event 'emulate_Event'; use FindBin; require "$FindBin::Bin/callbacks.tt";