Thread: [poe-commits] SF.net SVN: poe: [1929] trunk/poe
Brought to you by:
rcaputo
From: <rc...@us...> - 2006-04-06 15:14:36
|
Revision: 1929 Author: rcaputo Date: 2006-04-06 08:14:24 -0700 (Thu, 06 Apr 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1929&view=rev Log Message: ----------- We're 0.34 now. Make some pre-release README tweaks, too. Modified Paths: -------------- trunk/poe/README trunk/poe/lib/POE.pm Modified: trunk/poe/README =================================================================== --- trunk/poe/README 2006-04-06 14:57:17 UTC (rev 1928) +++ trunk/poe/README 2006-04-06 15:14:24 UTC (rev 1929) @@ -23,34 +23,27 @@ Installing POE -------------- -See http://poe.perl.org/?Where_to_Get_POE for download sites, Windows -installation tips, and anonymous CVS instructions. +POE can be installed through the CPAN or CPANPLUS shell in the usual +manner. -POE may be installed through the CPAN shell in the usual manner. - % perl -MCPAN -e shell cpan> install POE -To install on a Win32 machine using ActiveState's PPM. If PPM fails, -try PPM3. +http://poe.perl.org/?Where_to_Get_POE explains other options for +obtaining POE, including anonymous Subversion access. - > ppm install http://unc.dl.sourceforge.net/sourceforge/poe/POE.ppd +As of version 0.34, we are working to make sure ActiveState's +automated package system can build POE PPDs itself. POE's homegrown +PPD build system is being phased out. -or - - > ppm3 install http://unc.dl.sourceforge.net/sourceforge/poe/POE.ppd - ------------ Test Results ------------ -POE is tested before each release and post-release by a group of -volunteers known as the CPAN Testers. You can see the public results -of their work at: +The CPAN Testers are a group of volunteers who test new CPAN +distributions on a number of platforms. You can see their test +results at: http://testers.cpan.org/search?request=dist&dist=POE - http://testers.cpan.org/search?request=dist&dist=POE - -- CPAN testers' reports. - POE's ongoing improvement relies on your feedback. You file bug reports, feature requests, and even success stories by e-mailing <bu...@rt...>. @@ -69,10 +62,10 @@ What POE Is ----------- -POE is a networking and multitasking (some say cooperative threading) -framework for Perl. It has been in active development since 1996, -with its first open release in 1998. O'Reilly's "The Perl Conference" -(now OSCON's Perl track) named POE "Best New Module" in 1999. +POE is an event-driven networking and multitasking framework for Perl. +It has been in active development since 1996, with its first open +release in 1998. O'Reilly's "The Perl Conference" (now OSCON's Perl +track) named POE "Best New Module" in 1999. POE has been used in mission-critical systems such as internetworked financial markets, file systems, commerce and application servers. It @@ -80,8 +73,7 @@ thousands. POE is compatible with perl versions as old as 5.005_03. This may -change as it becomes harder and harder to support old versions of Perl -over time. +change as it becomes harder to support old versions of Perl over time. POE includes an evolving component framework. Components are high-level, modular, reusable pieces of programs. Several components @@ -99,4 +91,4 @@ Thanks for reading! -- -Rocco Caputo / rc...@cp... / poe.perl.org +Rocco Caputo / rc...@cp... / http://poe.perl.org/ Modified: trunk/poe/lib/POE.pm =================================================================== --- trunk/poe/lib/POE.pm 2006-04-06 14:57:17 UTC (rev 1928) +++ trunk/poe/lib/POE.pm 2006-04-06 15:14:24 UTC (rev 1929) @@ -7,7 +7,7 @@ use Carp qw( croak ); use vars qw($VERSION $REVISION); -$VERSION = '0.33_02'; +$VERSION = '0.34'; $REVISION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; sub import { @@ -141,7 +141,7 @@ POE::Wheel classes operate at a slightly higher level. They plug into sessions and perform very common, general tasks. For example, -POE::Wheel::ReadWrite performs buffered I/O. +POE::Wheel::ReadWrite performs buffered I/O. Unlike cheese, wheels do not stand alone. They are customized by POE::Driver and POE::Filter classes. Using the proper filter, a This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-04-10 22:38:30
|
Revision: 1934 Author: rcaputo Date: 2006-04-10 15:38:22 -0700 (Mon, 10 Apr 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1934&view=rev Log Message: ----------- Chris Fedde found a bug in the way Server::TCP creates filters. He was kind enough to provide a test case, so I was able to find and fix the problem easily. Thank you! Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/lib/POE/Component/Client/TCP.pm trunk/poe/lib/POE/Component/Server/TCP.pm trunk/poe/lib/POE/Filter/HTTPD.pm Added Paths: ----------- trunk/poe/tests/90_regression/cfedde-filter-httpd.t Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-04-10 20:37:40 UTC (rev 1933) +++ trunk/poe/MANIFEST 2006-04-10 22:38:22 UTC (rev 1934) @@ -155,6 +155,7 @@ tests/30_loops/00_base/wheel_tail.pm tests/90_regression/averell-callback-ret.t tests/90_regression/broeren-win32-nbio.t +tests/90_regression/cfedde-filter-httpd.t tests/90_regression/ferrari-server-unix.t tests/90_regression/merijn-sigchld-system.t tests/90_regression/neyuki_detach.t Modified: trunk/poe/lib/POE/Component/Client/TCP.pm =================================================================== --- trunk/poe/lib/POE/Component/Client/TCP.pm 2006-04-10 20:37:40 UTC (rev 1933) +++ trunk/poe/lib/POE/Component/Client/TCP.pm 2006-04-10 22:38:22 UTC (rev 1934) @@ -54,12 +54,14 @@ $args = [] unless defined $args; croak "Args must be an array reference" unless ref($args) eq "ARRAY"; - foreach ( qw( Connected ConnectError Disconnected ServerInput - ServerError ServerFlushed Started - ) - ) { - croak "$_ must be a coderef" - if defined($param{$_}) and ref($param{$_}) ne 'CODE'; + foreach ( + qw( Connected ConnectError Disconnected ServerInput + ServerError ServerFlushed Started + ) + ) { + croak "$_ must be a coderef" if( + defined($param{$_}) and ref($param{$_}) ne 'CODE' + ); } my $conn_callback = delete $param{Connected}; Modified: trunk/poe/lib/POE/Component/Server/TCP.pm =================================================================== --- trunk/poe/lib/POE/Component/Server/TCP.pm 2006-04-10 20:37:40 UTC (rev 1933) +++ trunk/poe/lib/POE/Component/Server/TCP.pm 2006-04-10 22:38:22 UTC (rev 1934) @@ -109,7 +109,6 @@ } if (defined $client_input) { - my @filters; if (defined $client_infilter and defined $client_outfilter) { @client_infilter_args = (); @@ -118,47 +117,73 @@ if (ref($client_infilter) eq 'ARRAY') { @client_infilter_args = @$client_infilter; $client_infilter = shift @client_infilter_args; - $client_infilter = "POE::Filter::Line" - unless _loadfilter($client_infilter); - push @filters, "InputFilter", $client_infilter->new(@client_infilter_args); - } elsif (ref $client_infilter) { + $client_infilter = "POE::Filter::Line" unless ( + _loadfilter($client_infilter) + ); + push( + @filters, + "InputFilter", $client_infilter->new(@client_infilter_args) + ); + } + elsif (ref $client_infilter) { push @filters, "InputFilter", $client_infilter->clone(); - } else { - $client_infilter = "POE::Filter::Line" - unless _loadfilter($client_infilter); - push @filters, "InputFilter", $client_infilter->new(@client_infilter_args); } + else { + $client_infilter = "POE::Filter::Line" unless ( + _loadfilter($client_infilter) + ); + push( + @filters, + "InputFilter", $client_infilter->new(@client_infilter_args) + ); + } if (ref($client_outfilter) eq 'ARRAY') { @client_outfilter_args = @$client_outfilter; $client_outfilter = shift @client_outfilter_args; - $client_outfilter = "POE::Filter::Line" - unless _loadfilter($client_outfilter); - push @filters, "OutputFilter", $client_outfilter->new(@client_outfilter_args); - } elsif (ref $client_outfilter) { + $client_outfilter = "POE::Filter::Line" unless ( + _loadfilter($client_outfilter) + ); + push( + @filters, + "OutputFilter", $client_outfilter->new(@client_outfilter_args) + ); + } + elsif (ref $client_outfilter) { push @filters, "OutputFilter", $client_outfilter->clone(); - } else { - $client_outfilter = "POE::Filter::Line" - unless _loadfilter($client_outfilter); - push @filters, "OutputFilter", $client_outfilter->new(@client_outfilter_args); } + else { + $client_outfilter = "POE::Filter::Line" unless( + _loadfilter($client_outfilter) + ); + push( + @filters, + "OutputFilter", $client_outfilter->new(@client_outfilter_args) + ); + } } - else { - undef($client_infilter); # just to be safe in case one was defined - undef($client_outfilter); # and the other wasn't - - unless (defined $client_filter) { - @filters = ( Filter => POE::Filter::Line->new(), ); - } - elsif (ref($client_filter) eq 'ARRAY') { + elsif (defined $client_filter) { + if (ref($client_filter) eq 'ARRAY') { @client_filter_args = @$client_filter; $client_filter = shift @client_filter_args; @filters = ( Filter => $client_filter->new(@client_filter_args), ); } - elsif (ref $client_filter) { + elsif (ref($client_filter)) { @filters = ( Filter => $client_filter->clone(), ); } + else { + @filters = ( Filter => $client_filter->new(), ); + } } + elsif (defined($client_infilter) or defined($client_outfilter)) { + croak( + "Must supply either ClientFilter or both " . + "ClientInputFilter and ClientOutputFilter" + ); + } + else { + @filters = ( Filter => POE::Filter::Line->new(), ); + } $client_error = \&_default_client_error unless defined $client_error; $client_connected = sub {} unless defined $client_connected; Modified: trunk/poe/lib/POE/Filter/HTTPD.pm =================================================================== --- trunk/poe/lib/POE/Filter/HTTPD.pm 2006-04-10 20:37:40 UTC (rev 1933) +++ trunk/poe/lib/POE/Filter/HTTPD.pm 2006-04-10 22:38:22 UTC (rev 1934) @@ -20,11 +20,11 @@ $VERSION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; @ISA = qw(POE::Filter); -sub BUFFER () { 0 } -sub TYPE () { 1 } -sub FINISH () { 2 } -sub HEADER () { 3 } -sub CLIENT_PROTO () { 4 } +sub BUFFER () { 0 } +sub TYPE () { 1 } +sub FINISH () { 2 } +sub HEADER () { 3 } +sub CLIENT_PROTO () { 4 } use Carp qw(croak); use HTTP::Status qw( status_message RC_BAD_REQUEST RC_OK RC_LENGTH_REQUIRED ); Added: trunk/poe/tests/90_regression/cfedde-filter-httpd.t =================================================================== --- trunk/poe/tests/90_regression/cfedde-filter-httpd.t (rev 0) +++ trunk/poe/tests/90_regression/cfedde-filter-httpd.t 2006-04-10 22:38:22 UTC (rev 1934) @@ -0,0 +1,66 @@ +#!/usr/bin/perl +# $Id$ +# vim: filetype=perl + +use warnings; +use strict; + +use HTTP::Response; +use Data::Dumper; +use Test::More tests => 2; + +use constant PORT => 31416; + +use POE qw( + Component::Client::TCP + Component::Server::TCP + Filter::HTTPD +); + +# +# handler +# + +POE::Component::Server::TCP->new( + Port => PORT, + ClientFilter => 'POE::Filter::HTTPD', + + ClientInput => sub { + my ( $kernel, $heap, $request ) = @_[ KERNEL, HEAP, ARG0 ]; + isa_ok( $request, 'HTTP::Message', $request); + }, +); + +POE::Component::Client::TCP->new ( + RemoteAddress => '127.0.0.1', + RemotePort => PORT, + ServerInput => sub { + diag("Server Input: $_[ARG0]"); + } +); + +POE::Component::Client::TCP->new ( + RemoteAddress => '127.0.0.1', + RemotePort => PORT, + Connected => sub { + ok 1, 'client connected'; + $_[HEAP]->{server}->put( "GET / 1.0\015\012\015\012"); + }, + ServerInput => sub { + ok 1, "client got $_[ARG0]"; + } +); + +POE::Session->create( + inline_states => { + _start => sub { + $_[KERNEL]->delay_add( done => 3 ); + }, + done => sub { + exit 1; + } + } +); + +$poe_kernel->run(); +exit 0; Property changes on: trunk/poe/tests/90_regression/cfedde-filter-httpd.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-04-29 22:37:42
|
Revision: 1944 Author: rcaputo Date: 2006-04-29 15:37:31 -0700 (Sat, 29 Apr 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1944&view=rev Log Message: ----------- Add a test case for rt14444 based on test code by Matt Sickler. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/tests/90_regression/rt14444-arg1.t Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-04-29 18:13:09 UTC (rev 1943) +++ trunk/poe/MANIFEST 2006-04-29 22:37:31 UTC (rev 1944) @@ -159,6 +159,7 @@ tests/90_regression/ferrari-server-unix.t tests/90_regression/merijn-sigchld-system.t tests/90_regression/neyuki_detach.t +tests/90_regression/rt14444-arg1.t tests/90_regression/rt1648-tied-stderr.t tests/90_regression/steinert-passed-wheel.t tests/90_regression/steinert-recursive-signal.t Added: trunk/poe/tests/90_regression/rt14444-arg1.t =================================================================== --- trunk/poe/tests/90_regression/rt14444-arg1.t (rev 0) +++ trunk/poe/tests/90_regression/rt14444-arg1.t 2006-04-29 22:37:31 UTC (rev 1944) @@ -0,0 +1,46 @@ +#!/usr/bin/perl +# $Id$ +# vim: filetype=perl + +use warnings; +use strict; + +use POE; +use Test::More tests => 3; + +my $test_state = "some_random_state"; +my @test_args = qw(some random args); + +POE::Session->create( + inline_states => { + _start => sub { + $_[KERNEL]->yield($test_state, @test_args); + }, + _default => sub { + my ($orig_state, $orig_args) = @_[ARG0,ARG1]; + if ($orig_state eq $test_state) { + is_deeply(\@test_args, $orig_args, "test args passed okay"); + } + + $_[KERNEL]->yield( check_ref => $_[ARG1] ); + $_[KERNEL]->yield( check_copy => [@{$_[ARG1]}] ); + }, + check_ref => sub { + my $test_args = $_[ARG0]; + is_deeply( + \@test_args, $test_args, + "args preserved in pass by reference", + ); + }, + check_copy => sub { + my $test_args = $_[ARG0]; + is_deeply( + \@test_args, $test_args, + "args preserved in pass by copy", + ); + } + } +); + +POE::Kernel->run; +exit 0; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <im...@us...> - 2006-05-01 03:38:18
|
Revision: 1949 Author: immute Date: 2006-04-30 20:38:09 -0700 (Sun, 30 Apr 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1949&view=rev Log Message: ----------- Added test to check PoCo-Server-TCP's Filter arg mechanism Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/tests/90_regression/immute-server-tcp-filter.t Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-04-30 06:35:56 UTC (rev 1948) +++ trunk/poe/MANIFEST 2006-05-01 03:38:09 UTC (rev 1949) @@ -157,6 +157,7 @@ tests/90_regression/broeren-win32-nbio.t tests/90_regression/cfedde-filter-httpd.t tests/90_regression/ferrari-server-unix.t +tests/90_regression/immute-server-tcp-filter.t tests/90_regression/merijn-sigchld-system.t tests/90_regression/neyuki_detach.t tests/90_regression/rt14444-arg1.t Added: trunk/poe/tests/90_regression/immute-server-tcp-filter.t =================================================================== --- trunk/poe/tests/90_regression/immute-server-tcp-filter.t (rev 0) +++ trunk/poe/tests/90_regression/immute-server-tcp-filter.t 2006-05-01 03:38:09 UTC (rev 1949) @@ -0,0 +1,98 @@ +#!/usr/bin/perl +use strict; +use warnings; + +BEGIN { @INC = ('/share/immute/svn/poelib', @INC); } +sub DEBUG () { 0 } + +use POE qw/ + Component::Server::TCP + Wheel::ReadWrite + Wheel::SocketFactory + Filter::HTTPD + Filter::Stream + /; +use HTTP::Response; +use Data::Dumper; +$Data::Dumper::Indent = 1; +use Test::More tests => 12; # FILL MEE IN! +my $PORT = '64130'; + +DEBUG and print "HTTPD: $POE::Filter::HTTPD::VERSION\n"; +DO_TEST("Single String", [ ClientFilter => 'POE::Filter::HTTPD' ]); +DO_TEST("Single Ref", [ ClientFilter => POE::Filter::HTTPD->new() ]); +DO_TEST("Single ArrRef", [ ClientFilter => ['POE::Filter::HTTPD'] ]); + +DO_TEST("String + String", [ ClientInputFilter => 'POE::Filter::HTTPD', ClientOutputFilter => 'POE::Filter::HTTPD' ]); +DO_TEST("String + Ref ", [ ClientInputFilter => 'POE::Filter::HTTPD', ClientOutputFilter => POE::Filter::HTTPD->new() ]); +DO_TEST("String + ArrRef", [ ClientInputFilter => 'POE::Filter::HTTPD', ClientOutputFilter => ['POE::Filter::HTTPD'] ]); +DO_TEST("Ref + String", [ ClientInputFilter => POE::Filter::HTTPD->new(), ClientOutputFilter => 'POE::Filter::HTTPD' ]); +DO_TEST("Ref + Ref", [ ClientInputFilter => POE::Filter::HTTPD->new(), ClientOutputFilter => POE::Filter::HTTPD->new() ]); +DO_TEST("Ref + ArrRef", [ ClientInputFilter => POE::Filter::HTTPD->new(), ClientOutputFilter => ['POE::Filter::HTTPD'] ]); +DO_TEST("ArrRef + String", [ ClientInputFilter => ['POE::Filter::HTTPD'], ClientOutputFilter => 'POE::Filter::HTTPD' ]); +DO_TEST("ArrRef + Ref", [ ClientInputFilter => ['POE::Filter::HTTPD'], ClientOutputFilter => POE::Filter::HTTPD->new() ]); +DO_TEST("ArrRef + ArrRef", [ ClientInputFilter => ['POE::Filter::HTTPD'], ClientOutputFilter => ['POE::Filter::HTTPD'] ]); + + +sub DO_TEST { +my ($TEST, $FILTER) = @_; +POE::Session->create( + inline_states => { + _start => sub { + my $h = $_[HEAP]; + POE::Component::Server::TCP->new( + Port => ($PORT), + @$FILTER, + ClientInput => sub { + DEBUG and print "Got Client Input\n"; + DEBUG and print "REQUEST: ", Dumper($_[ARG0]),"\n"; + my $response = HTTP::Response->new(200); + $response->protocol('HTTP/1.0'); + $response->push_header( 'Content-type', 'text/plain' ); + $response->content("OK\n"); + #$response = "HTTP/1.0 200 (OK)\nContent-Type: text/html\n\nOK"; + $_[HEAP]->{client}->put($response); + $_[KERNEL]->yield('shutdown'); + }, + Started => sub { $h->{id} = $_[SESSION]->ID; DEBUG and print "Server Started\n"; }, + ); + $_[KERNEL]->delay('test_server', 1); + $_[KERNEL]->delay('kill_server', 5); + }, + kill_server => sub { $_[KERNEL]->post($_[HEAP]->{id}, 'shutdown'); }, + test_server => sub { + DEBUG and print "Creating Client Socket\n"; + my $wheel = POE::Wheel::SocketFactory->new( + RemotePort => $PORT, + RemoteAddress => '127.0.0.1', + SuccessEvent => "_connected", + FailureEvent => "_fail_connect", + ); + $_[HEAP]->{wheel} = $wheel; + }, + _connected => sub { + DEBUG and print "Creating ReadWrite\n"; + delete $_[HEAP]->{wheel}; + my $rw = POE::Wheel::ReadWrite->new( + Handle => $_[ARG0], + Filter => POE::Filter::Line->new(), + InputEvent => '_got_server', + ErrorEvent => '_rw_error', + ); + $_[HEAP]->{rw} = $rw; + $rw->put( "GET / HTTP/1.0\n\n"); + }, + _got_server => sub { + if ($_[ARG0] =~ /HTTP\/\d\.\d\s+200/) { $_[HEAP]->{flag} = 1 } + }, + _fail_connect => sub { die "Connect Failed"; }, + _rw_error => sub { + delete $_[HEAP]->{rw}; + ok(defined $_[HEAP]->{flag}, "Testing Filter Combo: $TEST"); + }, + + }, +); +POE::Kernel->run; +} +exit 0; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bs...@us...> - 2006-05-30 19:15:39
|
Revision: 1970 Author: bsmith Date: 2006-05-30 12:15:22 -0700 (Tue, 30 May 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1970&view=rev Log Message: ----------- Removed the old test upload programs, and their test harness, and references to them. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/mylib/Makefile-5004.pm trunk/poe/mylib/Makefile-5005.pm Removed Paths: ------------- trunk/poe/mylib/Test/ trunk/poe/mylib/reportupload.pl trunk/poe/mylib/testreport.pl Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-05-30 19:10:28 UTC (rev 1969) +++ trunk/poe/MANIFEST 2006-05-30 19:15:22 UTC (rev 1970) @@ -69,13 +69,7 @@ mylib/MyOtherFreezer.pm mylib/PoeBuildInfo.pm mylib/preprocessor.perl -mylib/reportupload.pl mylib/svn-log.perl -mylib/Test/Harness.pm -mylib/Test/Harness/Assert.pm -mylib/Test/Harness/Iterator.pm -mylib/Test/Harness/Straps.pm -mylib/testreport.pl README samples/create.perl samples/fakelogin.perl Modified: trunk/poe/mylib/Makefile-5004.pm =================================================================== --- trunk/poe/mylib/Makefile-5004.pm 2006-05-30 19:10:28 UTC (rev 1969) +++ trunk/poe/mylib/Makefile-5004.pm 2006-05-30 19:15:22 UTC (rev 1970) @@ -24,18 +24,6 @@ ### Generate Makefile.PL. -#sub MY::postamble { -# return <<EOF; -#reportupload: poe_report.xml -#\cI$^X mylib/reportupload.pl -# -#uploadreport: poe_report.xml -#\cI$^X mylib/reportupload.pl -# -#testreport: poe_report.xml -# -#poe_report.xml: Makefile -#\cI$^X mylib/testreport.pl sub MY::postamble { return <<EOF; coverage: Makefile Modified: trunk/poe/mylib/Makefile-5005.pm =================================================================== --- trunk/poe/mylib/Makefile-5005.pm 2006-05-30 19:10:28 UTC (rev 1969) +++ trunk/poe/mylib/Makefile-5005.pm 2006-05-30 19:15:22 UTC (rev 1970) @@ -89,19 +89,6 @@ ### Generate Makefile.PL. -# sub MY::postamble { -# return ExtUtils::AutoInstall::postamble() . -# <<EOF; -# reportupload: poe_report.xml -# \cI$^X mylib/reportupload.pl -# -# uploadreport: poe_report.xml -# \cI$^X mylib/reportupload.pl -# -# testreport: poe_report.xml -# -# poe_report.xml: Makefile -# \cI$^X mylib/testreport.pl sub MY::postamble { return <<EOF; Deleted: trunk/poe/mylib/reportupload.pl =================================================================== --- trunk/poe/mylib/reportupload.pl 2006-05-30 19:10:28 UTC (rev 1969) +++ trunk/poe/mylib/reportupload.pl 2006-05-30 19:15:22 UTC (rev 1970) @@ -1,88 +0,0 @@ -#!/usr/bin/perl - -die "$0 is currently disabled\n"; - -=head1 NAME - -reportupload.pl - upload an xml test report - -=head1 VERSION - -$Revision$ - -=head1 USAGE - - perl -Ilib/ -I./ reportupload.pl - -This will attempt to transmit a file called C<poe_report.xml> to a -central server for recording and browsing by POE's users and -development team. - -=head1 AUTHOR - -This program was written by Matt Cashner. - -=cut - -use IO::Socket::INET; -use strict; -local $/; - -unless(open(XML, 'poe_report.xml')) { - print "Cannot find 'poe_report.xml'.\n"; - exit(1); -} -my $xml = <XML>; -close XML; - -print "Connecting to test server.\n"; -my $sock = IO::Socket::INET->new(PeerHost => 'eekeek.org', - PeerPort => 'http(80)', - Proto => 'tcp', - ); -if($sock && $sock->connected) { - print "Connection to test server successful.\n"; -} else { - print "Connection to test server failed.\n"; - exit(1); -} -my $body = qq| ---MAGICPANTS -Content-Disposition: form-data; name="action" - -upload ---MAGICPANTS -Content-Disposition: form-data; name="reportfile"; filename="poe_report.xml" -Content-Type: text/plain - -$xml ---MAGICPANTS-- -|; - -my $length = length($body); -my $packet =<<EOP; -POST http://eekeek.org/poe-tests/ HTTP/1.0 -User-Agent: reportupload.pl -Content-Type: multipart/form-data; boundary=MAGICPANTS -Content-Length: $length - -$body -EOP - -print "Sending report...\n"; -$sock->send($packet); - -my $output; -$output = <$sock>; # for debug purposes -if($output =~ /Test Submission/) { - print( - "Report upload succeeded. Thank you for your contribution.\n", - "Please visit http://eekeek.org/poe-tests/ to see other results.\n" - ); -} else { - print "Report upload failed.\n"; -} - -$sock->shutdown(2); # Check please. -exit(0); - Deleted: trunk/poe/mylib/testreport.pl =================================================================== --- trunk/poe/mylib/testreport.pl 2006-05-30 19:10:28 UTC (rev 1969) +++ trunk/poe/mylib/testreport.pl 2006-05-30 19:15:22 UTC (rev 1970) @@ -1,226 +0,0 @@ -#!/usr/bin/perl - -=head1 NAME - -testreport.pl - generate a test report in xml - -=head1 VERSION - -$Revision$ - -=head1 USAGE - - perl -Ilib/ -I./ testreport.pl - -This will output a file called C<poe_report.xml>. - -=head1 AUTHOR - -This program was written by Matt Cashner. - -=cut - -package My::Strap; -use lib qw(../mylib ../ ./mylib ./ ../lib ./lib); -use Test::Harness; -use base qw(Test::Harness::Straps); -use Sys::Hostname; -use vars qw($VERSION); - -$VERSION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; - -local $| = 1; - -# Makefile.PL does it. Why don't we? -$ENV{PERL_DL_NONLAZY} = 1; - -my $s = My::Strap->new; - -my %handlers = ( - bailout => sub { - my($self, $line, $type, $totals) = @_; - - die sprintf "FAILED--Further testing stopped%s\n", - $self->{bailout_reason} ? ": $self->{bailout_reason}" : ''; - }, - test => sub { - my($self, $line, $type, $totals) = @_; - my $curr = $totals->{seen}; - - if( $totals->{details}[-1]{ok} ) { - $self->_display("ok $curr/$totals->{max}"); - } - else { - $self->_display("NOK $curr"); - } - - if( $curr > $self->{'next'} ) { - $self->_print("Test output counter mismatch [test $curr]\n"); - } - elsif( $curr < $self->{'next'} ) { - $self->_print("Confused test output: test $curr answered after ". - "test ", $self->{next} - 1, "\n"); -# $self->{'next'} = $curr; - } - }, -); - -$s->{callback} = sub { - my($self, $line, $type, $totals) = @_; - print $line if $Test::Harness::Verbose; - - $handlers{$type}->($self, $line, $type, $totals) if $handlers{$type}; -}; - - -sub _display { - my($self, $out) = @_; - print "$ml$out"; -} - -sub _print { - my($self) = shift; - print @_; -} - -# Locate Makefile. This allows the script to be run from POE's main -# directory or from lib itself. - -my $directory = "."; - -unless (-e "Makefile") { - unless (-e "../Makefile") { - die "Could not find Makefile or ../Makefile. Stopping.\n"; - } - $directory = "../"; -} - -# Find the test files beneath the Makefile directory. - -use File::Find; -use File::Spec; - -my %test_files; -find( - sub { - return unless -f; - return unless /\.t$/; - $test_files{File::Spec->catfile($File::Find::dir, $_)} = 1; - }, - $directory, -); - -my @test_files = sort keys %test_files; - -# Require POE early, so we don't bother with the tests if something -# catastrophic has occurred (like POE's library directory moves -# outside C<use lib> or something). The version number is still -# dumped into the XML file at the appropriate time. -require POE; - -my %test_results; -my $width = Test::Harness::_leader_width(@test_files); -foreach my $file (@test_files) { - ($leader, $ml) = Test::Harness::_mk_leader($file, $width); - print $leader; - my %result = $s->analyze_file($file); - $file =~ s#^\.\.?/##; - $file =~ s#^tests/##; - $test_results{$file} = \%result; - $s->_display($result{passing} ? 'ok' : 'FAILED'); - print "\n"; -} - -my $username = "(" . lc($^O) . "-user)"; -eval { $username = (getpwuid($<))[0]; }; -my $hostname = hostname(); -my $time = scalar gmtime(time()); - -my $xml = "<poe_test_report>\n"; -$xml .= "<generatedby username=\"$username\" hostname=\"$hostname\" time=\"$time\" />\n"; -$xml .= "<tests>\n"; -foreach my $test_file (sort keys %test_results) { - $xml .= "\t<test filename=\"$test_file\">\n"; - if(defined $test_results{$test_file}{skip_all}) { - $xml .= "\t\t<skip_all>$test_results{$test_file}{skip_all}</skip_all>\n"; - } else { - $xml .= "\t\t<expected>$test_results{$test_file}{max}</expected>\n"; - $xml .= "\t\t<seen>$test_results{$test_file}{seen}</seen>\n"; - $xml .= "\t\t<ok>$test_results{$test_file}{ok}</ok>\n"; - $xml .= "\t\t<skip>$test_results{$test_file}{skip}</skip>\n"; - $xml .= "\t\t<todo>$test_results{$test_file}{todo}</todo>\n"; - $xml .= "\t\t<skipped>\n"; - for (my $i = 0; $i < @{$test_results{$test_file}{details}}; $i++) { - if($test_results{$test_file}{details}[$i]{type} eq 'skip') { - $xml .= "\t\t\t<test num=\"". ($i+1) ."\" reason=\"$test_results{$test_file}{details}[$i]->{reason}\" />\n"; - } - } - $xml .= "\t\t</skipped>\n"; - $xml .= "\t\t<failing>\n"; - for (my $i = 0; $i < @{$test_results{$test_file}{details}}; $i++) { - if($test_results{$test_file}{details}[$i]->{ok} == 0) { - $xml .= "\t\t\t<test num=\"". ($i+1) ."\" reason=\"$test_results{$test_file}{details}[$i]->{reason}\" />\n"; - } - } - $xml .= "\t\t</failing>\n"; - } - $xml .= "\t</test>\n"; -} -$xml .= "</tests>\n"; - -$xml .= "<system>\n"; -eval { - use POSIX; - $xml .= "\t<machine>\n"; - my @sysinfo = uname(); - $xml .= "\t\t<sysname>$sysinfo[0]</sysname>\n"; - $xml .= "\t\t<nodename>$sysinfo[1]</nodename>\n"; - $xml .= "\t\t<release>$sysinfo[2]</release>\n"; - $xml .= "\t\t<version>$sysinfo[3]</version>\n"; - $xml .= "\t\t<machine>$sysinfo[4]</machine>\n"; - $xml .= "\t</machine>\n"; -}; -$xml .= "\t<perl_modules>\n"; -$xml .= "\t\t<perl version=\"$]\" />\n"; - -# Dump POE's version. POE has been required earlier, without an -# eval() wrapper, so the version must be available by this time. -$xml .= "\t\t<poe version=\"$POE::VERSION\" />\n"; - -eval "use Gtk;"; -if($@) { - $xml .= "\t\t<gtk />\n"; -} else { - $xml .= "\t\t<gtk version=\"$Gtk::VERSION\" />\n"; -} - -eval "use Tk;"; -if($@) { - $xml .= "\t\t<tk />\n"; -} else { - $xml .= "\t\t<tk version=\"$Tk::VERSION\" />\n"; -} - -eval "use Event;"; -if($@) { - $xml .= "\t\t<event />\n"; -} else { - $xml .= "\t\t<event version=\"$Event::VERSION\" />\n"; -} - -eval "use IO::Tty;"; -if($@) { - $xml .= "\t\t<iotty />\n"; -} else { - $xml .= "\t\t<iotty version=\"$IO::Tty::VERSION\" />\n"; -}; - -$xml .= "\t</perl_modules>\n"; -$xml .= "</system>\n"; -$xml .= "</poe_test_report>"; - -open OUT, "+>poe_report.xml"; -print OUT $xml; -close OUT; - - This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bs...@us...> - 2006-05-31 09:28:30
|
Revision: 1973 Author: bsmith Date: 2006-05-31 02:28:16 -0700 (Wed, 31 May 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1973&view=rev Log Message: ----------- Small smoker script from BinGOs that posts results to the pastebot. Also fix MANIFEST. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/mylib/smoker.perl Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-05-30 20:51:59 UTC (rev 1972) +++ trunk/poe/MANIFEST 2006-05-31 09:28:16 UTC (rev 1973) @@ -58,6 +58,7 @@ MANIFEST This list of files MANIFEST.SKIP META.yml +mylib/commitrelay.pl mylib/coverage.perl mylib/cpan-test.perl mylib/Devel/Null.pm @@ -69,6 +70,7 @@ mylib/MyOtherFreezer.pm mylib/PoeBuildInfo.pm mylib/preprocessor.perl +mylib/smoker.perl mylib/svn-log.perl README samples/create.perl Added: trunk/poe/mylib/smoker.perl =================================================================== --- trunk/poe/mylib/smoker.perl (rev 0) +++ trunk/poe/mylib/smoker.perl 2006-05-31 09:28:16 UTC (rev 1973) @@ -0,0 +1,104 @@ +use strict; +use warnings; +use POE qw(Wheel::Run Component::Client::UserAgent); +use HTTP::Request::Common; + +my $make = '/usr/pkg/bin/gmake'; +my $perl = '/usr/bin/perl'; +my $working = '/home/chris/dev/poe/poe/'; +my $pbotutil = '/usr/pkg/bin/pbotutil'; +my $pbotopts = [ '-s', 'shadow', '-c', '#poe', '-u', 'POESmoke', '-m', 'Results of TEST' ]; + +POE::Component::Client::UserAgent->new(); + +POE::Session->create( + package_states => [ + 'main' => [qw(_start _stop _output _wheel_error _wheel_close sig_chld process _response)], + ], + options => { trace => 0 }, +); + +$poe_kernel->run(); +exit 0; + +sub sig_chld { + my ($kernel,$heap,$thing,$pid,$status) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2]; + my $processed = delete $heap->{processing}->{ $pid }; + return $poe_kernel->sig_handled() unless $processed; + print STDOUT "Cmd: ", join(' ', @{ $processed }), " Status: $status\n"; + $heap->{status} = $status unless $status == 0; + $poe_kernel->sig_handled(); +} + +sub _start { + my ($kernel,$heap) = @_[KERNEL,HEAP]; + $kernel->alias_set("Smoker"); + chdir $working; + $heap->{status} = 0; + $heap->{output} = [ ]; + $heap->{todo} = [ [ "$perl Makefile.PL", '--default' ], + [ $make ], [ $make, 'test' ], [ $make, 'distclean' ], ]; + $heap->{processing} = { }; + $kernel->sig( CHLD => 'sig_chld' ); + $poe_kernel->yield( 'process' ); + undef; +} + +sub process { + my ($kernel,$heap) = @_[KERNEL,HEAP]; + my $todo = shift @{ $heap->{todo} }; + unless ( $todo ) { + my $postback = $_[SESSION]->postback('_response'); + my %formdata = ( channel => '#poe', nick => 'POEsmoker', summary => 'Results of svn POE Smoke', paste => join( "\n", @{ $heap->{output} } ) ); + my $request = HTTP::Request::Common::POST( 'http://scsys.co.uk:8001/paste' => [ %formdata ] ); + $poe_kernel -> post (useragent => request => { request => $request, response => $postback } ); + return; + } + my $cmd = shift @{ $todo }; + my $wheel = POE::Wheel::Run->new( + Program => $cmd, + ProgramArgs => $todo, + StdoutEvent => '_output', + StderrEvent => '_output', + ErrorEvent => '_wheel_error', + CloseEvent => '_wheel_close', + ); + if ( $wheel ) { + $heap->{wheels}->{ $wheel->ID() } = $wheel; + $heap->{processing}->{ $wheel->PID() } = [ $cmd, @{ $todo } ]; + } + undef; +} + +sub _stop { + print STDOUT $_, "\n" for @{ $_[HEAP]->{output} }; + print STDOUT "Something went wrong\n" if $_[HEAP]->{status}; + undef; +} + +sub _output { + push @{ $_[HEAP]->{output} }, $_[ARG0]; + undef; +} + +sub _wheel_error { + my ($heap,$wheel_id) = @_[HEAP,ARG3]; + delete $heap->{wheels}->{ $wheel_id }; + $poe_kernel->yield( 'process' ); + undef; +} + +sub _wheel_close { + my ($heap,$wheel_id) = @_[HEAP,ARG0]; + delete $heap->{wheels}->{ $wheel_id }; + undef; +} + +sub _response { + my ($kernel,$heap) = @_[KERNEL,HEAP]; + my ($request, $response, $entry) = @{$_[ARG1]}; + print STDOUT $response -> status_line; + $kernel->alias_remove($_) for $kernel->alias_list(); + $kernel->post (useragent => 'shutdown'); + undef; +} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-05-31 14:07:59
|
Revision: 1974 Author: rcaputo Date: 2006-05-31 07:07:46 -0700 (Wed, 31 May 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1974&view=rev Log Message: ----------- Move the bots over to extras. Remove them from MANIFEST. They're not directly part of POE development, and they don't need to be included in the distribution. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/extras/commitrelay.pl trunk/extras/smoker.perl Removed Paths: ------------- trunk/poe/mylib/commitrelay.pl trunk/poe/mylib/smoker.perl Copied: trunk/extras/commitrelay.pl (from rev 1973, trunk/poe/mylib/commitrelay.pl) =================================================================== --- trunk/extras/commitrelay.pl (rev 0) +++ trunk/extras/commitrelay.pl 2006-05-31 14:07:46 UTC (rev 1974) @@ -0,0 +1,88 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use POE qw(Component::IRC Component::IRC::Plugin::Connector + Component::IRC::Plugin::CTCP); + +our $NICK = "poecommits"; + +our $IN_SERVER = "irc.freenode.net"; +our $IN_CHANNEL = "#commits"; +our $OUT_SERVER = "irc.perl.org"; +our $OUT_CHANNEL = "#poe"; + +POE::Session->create( + package_states => [ + 'My::Receiver' => [ qw(_start irc_001 irc_public shutdown) ], + ], +); + +POE::Session->create( + package_states => [ + 'My::Transmitter' => [ qw(_start irc_001 irc_public a_commit) ], + ], +); + +{ + package My::Receiver; + use POE; + sub _start { + $_[KERNEL]->alias_set('receiver'); + my $irc = $_[HEAP]->{irc} = POE::Component::IRC->spawn( + nick => $NICK, + server => $IN_SERVER, + ircname => "irc.perl.org #poe commit relay (IN)", + ) or die $!; + $irc->yield(register => qw(001 public)); + $irc->plugin_add(Connector => POE::Component::IRC::Plugin::Connector->new); + $irc->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new); + $irc->yield(connect => {}); + } + sub irc_001 { + $_[KERNEL]->post($_[SENDER] => join => $IN_CHANNEL); + } + sub irc_public { + my ($irc, $who, $where, $what) = ($_[HEAP]->{irc}, @_[ARG0..ARG2]); + my $channel = $where->[0]; + return unless $channel eq $IN_CHANNEL; + return unless $who =~ m/^CIA-\d+!.=cia@/i; + $what =~ s/\cC\d+(,\d+)*//g; + $what =~ tr/\x00-\x1f//d; + my ($project) = $what =~ m/(\w{3,}):/; + print "<$channel> <$who> <$project> <$what>\n"; + return unless $project and $project eq 'poe'; + $_[KERNEL]->post(transmitter => a_commit => $what); + print " signaled transmitter\n"; + } + sub shutdown { + $_[HEAP]->{irc}->yield('shutdown'); + } +} + +{ + package My::Transmitter; + use POE; + sub _start { + $_[KERNEL]->alias_set('transmitter'); + my $irc = $_[HEAP]->{irc} = POE::Component::IRC->spawn( + nick => $NICK, + server => $OUT_SERVER, + ircname => "irc.perl.org #poe commit relay (OUT)", + ) or die $!; + $irc->yield(register => qw(001 public)); + $irc->plugin_add(Connector => POE::Component::IRC::Plugin::Connector->new); + $irc->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new); + $irc->yield(connect => {}); + } + sub irc_001 { + $_[KERNEL]->post($_[SENDER] => join => $OUT_CHANNEL); + } + sub irc_public { } + sub a_commit { + print "a_commit <$_[ARG0]>\n"; + $_[HEAP]->{irc}->yield(privmsg => $OUT_CHANNEL => $_[ARG0]); + } +} + +$poe_kernel->run; Copied: trunk/extras/smoker.perl (from rev 1973, trunk/poe/mylib/smoker.perl) =================================================================== --- trunk/extras/smoker.perl (rev 0) +++ trunk/extras/smoker.perl 2006-05-31 14:07:46 UTC (rev 1974) @@ -0,0 +1,104 @@ +use strict; +use warnings; +use POE qw(Wheel::Run Component::Client::UserAgent); +use HTTP::Request::Common; + +my $make = '/usr/pkg/bin/gmake'; +my $perl = '/usr/bin/perl'; +my $working = '/home/chris/dev/poe/poe/'; +my $pbotutil = '/usr/pkg/bin/pbotutil'; +my $pbotopts = [ '-s', 'shadow', '-c', '#poe', '-u', 'POESmoke', '-m', 'Results of TEST' ]; + +POE::Component::Client::UserAgent->new(); + +POE::Session->create( + package_states => [ + 'main' => [qw(_start _stop _output _wheel_error _wheel_close sig_chld process _response)], + ], + options => { trace => 0 }, +); + +$poe_kernel->run(); +exit 0; + +sub sig_chld { + my ($kernel,$heap,$thing,$pid,$status) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2]; + my $processed = delete $heap->{processing}->{ $pid }; + return $poe_kernel->sig_handled() unless $processed; + print STDOUT "Cmd: ", join(' ', @{ $processed }), " Status: $status\n"; + $heap->{status} = $status unless $status == 0; + $poe_kernel->sig_handled(); +} + +sub _start { + my ($kernel,$heap) = @_[KERNEL,HEAP]; + $kernel->alias_set("Smoker"); + chdir $working; + $heap->{status} = 0; + $heap->{output} = [ ]; + $heap->{todo} = [ [ "$perl Makefile.PL", '--default' ], + [ $make ], [ $make, 'test' ], [ $make, 'distclean' ], ]; + $heap->{processing} = { }; + $kernel->sig( CHLD => 'sig_chld' ); + $poe_kernel->yield( 'process' ); + undef; +} + +sub process { + my ($kernel,$heap) = @_[KERNEL,HEAP]; + my $todo = shift @{ $heap->{todo} }; + unless ( $todo ) { + my $postback = $_[SESSION]->postback('_response'); + my %formdata = ( channel => '#poe', nick => 'POEsmoker', summary => 'Results of svn POE Smoke', paste => join( "\n", @{ $heap->{output} } ) ); + my $request = HTTP::Request::Common::POST( 'http://scsys.co.uk:8001/paste' => [ %formdata ] ); + $poe_kernel -> post (useragent => request => { request => $request, response => $postback } ); + return; + } + my $cmd = shift @{ $todo }; + my $wheel = POE::Wheel::Run->new( + Program => $cmd, + ProgramArgs => $todo, + StdoutEvent => '_output', + StderrEvent => '_output', + ErrorEvent => '_wheel_error', + CloseEvent => '_wheel_close', + ); + if ( $wheel ) { + $heap->{wheels}->{ $wheel->ID() } = $wheel; + $heap->{processing}->{ $wheel->PID() } = [ $cmd, @{ $todo } ]; + } + undef; +} + +sub _stop { + print STDOUT $_, "\n" for @{ $_[HEAP]->{output} }; + print STDOUT "Something went wrong\n" if $_[HEAP]->{status}; + undef; +} + +sub _output { + push @{ $_[HEAP]->{output} }, $_[ARG0]; + undef; +} + +sub _wheel_error { + my ($heap,$wheel_id) = @_[HEAP,ARG3]; + delete $heap->{wheels}->{ $wheel_id }; + $poe_kernel->yield( 'process' ); + undef; +} + +sub _wheel_close { + my ($heap,$wheel_id) = @_[HEAP,ARG0]; + delete $heap->{wheels}->{ $wheel_id }; + undef; +} + +sub _response { + my ($kernel,$heap) = @_[KERNEL,HEAP]; + my ($request, $response, $entry) = @{$_[ARG1]}; + print STDOUT $response -> status_line; + $kernel->alias_remove($_) for $kernel->alias_list(); + $kernel->post (useragent => 'shutdown'); + undef; +} Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-05-31 09:28:16 UTC (rev 1973) +++ trunk/poe/MANIFEST 2006-05-31 14:07:46 UTC (rev 1974) @@ -58,7 +58,6 @@ MANIFEST This list of files MANIFEST.SKIP META.yml -mylib/commitrelay.pl mylib/coverage.perl mylib/cpan-test.perl mylib/Devel/Null.pm @@ -70,7 +69,6 @@ mylib/MyOtherFreezer.pm mylib/PoeBuildInfo.pm mylib/preprocessor.perl -mylib/smoker.perl mylib/svn-log.perl README samples/create.perl Deleted: trunk/poe/mylib/commitrelay.pl =================================================================== --- trunk/poe/mylib/commitrelay.pl 2006-05-31 09:28:16 UTC (rev 1973) +++ trunk/poe/mylib/commitrelay.pl 2006-05-31 14:07:46 UTC (rev 1974) @@ -1,88 +0,0 @@ -#!/usr/bin/env perl - -use strict; -use warnings; -use POE qw(Component::IRC Component::IRC::Plugin::Connector - Component::IRC::Plugin::CTCP); - -our $NICK = "poecommits"; - -our $IN_SERVER = "irc.freenode.net"; -our $IN_CHANNEL = "#commits"; -our $OUT_SERVER = "irc.perl.org"; -our $OUT_CHANNEL = "#poe"; - -POE::Session->create( - package_states => [ - 'My::Receiver' => [ qw(_start irc_001 irc_public shutdown) ], - ], -); - -POE::Session->create( - package_states => [ - 'My::Transmitter' => [ qw(_start irc_001 irc_public a_commit) ], - ], -); - -{ - package My::Receiver; - use POE; - sub _start { - $_[KERNEL]->alias_set('receiver'); - my $irc = $_[HEAP]->{irc} = POE::Component::IRC->spawn( - nick => $NICK, - server => $IN_SERVER, - ircname => "irc.perl.org #poe commit relay (IN)", - ) or die $!; - $irc->yield(register => qw(001 public)); - $irc->plugin_add(Connector => POE::Component::IRC::Plugin::Connector->new); - $irc->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new); - $irc->yield(connect => {}); - } - sub irc_001 { - $_[KERNEL]->post($_[SENDER] => join => $IN_CHANNEL); - } - sub irc_public { - my ($irc, $who, $where, $what) = ($_[HEAP]->{irc}, @_[ARG0..ARG2]); - my $channel = $where->[0]; - return unless $channel eq $IN_CHANNEL; - return unless $who =~ m/^CIA-\d+!.=cia@/i; - $what =~ s/\cC\d+(,\d+)*//g; - $what =~ tr/\x00-\x1f//d; - my ($project) = $what =~ m/(\w{3,}):/; - print "<$channel> <$who> <$project> <$what>\n"; - return unless $project and $project eq 'poe'; - $_[KERNEL]->post(transmitter => a_commit => $what); - print " signaled transmitter\n"; - } - sub shutdown { - $_[HEAP]->{irc}->yield('shutdown'); - } -} - -{ - package My::Transmitter; - use POE; - sub _start { - $_[KERNEL]->alias_set('transmitter'); - my $irc = $_[HEAP]->{irc} = POE::Component::IRC->spawn( - nick => $NICK, - server => $OUT_SERVER, - ircname => "irc.perl.org #poe commit relay (OUT)", - ) or die $!; - $irc->yield(register => qw(001 public)); - $irc->plugin_add(Connector => POE::Component::IRC::Plugin::Connector->new); - $irc->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new); - $irc->yield(connect => {}); - } - sub irc_001 { - $_[KERNEL]->post($_[SENDER] => join => $OUT_CHANNEL); - } - sub irc_public { } - sub a_commit { - print "a_commit <$_[ARG0]>\n"; - $_[HEAP]->{irc}->yield(privmsg => $OUT_CHANNEL => $_[ARG0]); - } -} - -$poe_kernel->run; Deleted: trunk/poe/mylib/smoker.perl =================================================================== --- trunk/poe/mylib/smoker.perl 2006-05-31 09:28:16 UTC (rev 1973) +++ trunk/poe/mylib/smoker.perl 2006-05-31 14:07:46 UTC (rev 1974) @@ -1,104 +0,0 @@ -use strict; -use warnings; -use POE qw(Wheel::Run Component::Client::UserAgent); -use HTTP::Request::Common; - -my $make = '/usr/pkg/bin/gmake'; -my $perl = '/usr/bin/perl'; -my $working = '/home/chris/dev/poe/poe/'; -my $pbotutil = '/usr/pkg/bin/pbotutil'; -my $pbotopts = [ '-s', 'shadow', '-c', '#poe', '-u', 'POESmoke', '-m', 'Results of TEST' ]; - -POE::Component::Client::UserAgent->new(); - -POE::Session->create( - package_states => [ - 'main' => [qw(_start _stop _output _wheel_error _wheel_close sig_chld process _response)], - ], - options => { trace => 0 }, -); - -$poe_kernel->run(); -exit 0; - -sub sig_chld { - my ($kernel,$heap,$thing,$pid,$status) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2]; - my $processed = delete $heap->{processing}->{ $pid }; - return $poe_kernel->sig_handled() unless $processed; - print STDOUT "Cmd: ", join(' ', @{ $processed }), " Status: $status\n"; - $heap->{status} = $status unless $status == 0; - $poe_kernel->sig_handled(); -} - -sub _start { - my ($kernel,$heap) = @_[KERNEL,HEAP]; - $kernel->alias_set("Smoker"); - chdir $working; - $heap->{status} = 0; - $heap->{output} = [ ]; - $heap->{todo} = [ [ "$perl Makefile.PL", '--default' ], - [ $make ], [ $make, 'test' ], [ $make, 'distclean' ], ]; - $heap->{processing} = { }; - $kernel->sig( CHLD => 'sig_chld' ); - $poe_kernel->yield( 'process' ); - undef; -} - -sub process { - my ($kernel,$heap) = @_[KERNEL,HEAP]; - my $todo = shift @{ $heap->{todo} }; - unless ( $todo ) { - my $postback = $_[SESSION]->postback('_response'); - my %formdata = ( channel => '#poe', nick => 'POEsmoker', summary => 'Results of svn POE Smoke', paste => join( "\n", @{ $heap->{output} } ) ); - my $request = HTTP::Request::Common::POST( 'http://scsys.co.uk:8001/paste' => [ %formdata ] ); - $poe_kernel -> post (useragent => request => { request => $request, response => $postback } ); - return; - } - my $cmd = shift @{ $todo }; - my $wheel = POE::Wheel::Run->new( - Program => $cmd, - ProgramArgs => $todo, - StdoutEvent => '_output', - StderrEvent => '_output', - ErrorEvent => '_wheel_error', - CloseEvent => '_wheel_close', - ); - if ( $wheel ) { - $heap->{wheels}->{ $wheel->ID() } = $wheel; - $heap->{processing}->{ $wheel->PID() } = [ $cmd, @{ $todo } ]; - } - undef; -} - -sub _stop { - print STDOUT $_, "\n" for @{ $_[HEAP]->{output} }; - print STDOUT "Something went wrong\n" if $_[HEAP]->{status}; - undef; -} - -sub _output { - push @{ $_[HEAP]->{output} }, $_[ARG0]; - undef; -} - -sub _wheel_error { - my ($heap,$wheel_id) = @_[HEAP,ARG3]; - delete $heap->{wheels}->{ $wheel_id }; - $poe_kernel->yield( 'process' ); - undef; -} - -sub _wheel_close { - my ($heap,$wheel_id) = @_[HEAP,ARG0]; - delete $heap->{wheels}->{ $wheel_id }; - undef; -} - -sub _response { - my ($kernel,$heap) = @_[KERNEL,HEAP]; - my ($request, $response, $entry) = @{$_[ARG1]}; - print STDOUT $response -> status_line; - $kernel->alias_remove($_) for $kernel->alias_list(); - $kernel->post (useragent => 'shutdown'); - undef; -} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-06-11 19:23:41
|
Revision: 1980 Author: rcaputo Date: 2006-06-11 12:23:12 -0700 (Sun, 11 Jun 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1980&view=rev Log Message: ----------- Resolve Stuart Kendrick's bug, rt.cpan.org 19529, in which POE resets all signal handlers at "use" time. This is too early for some applications. Now it doesn't even DEFAULT/IGNORE signals unless it really must. That's pretty much SIGCHLD and SIGPIPE. Attempt no handling there. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/lib/POE/Loop/Event.pm trunk/poe/lib/POE/Loop/Gtk.pm trunk/poe/lib/POE/Loop/IO_Poll.pm trunk/poe/lib/POE/Loop/PerlSignals.pm trunk/poe/lib/POE/Loop/Select.pm trunk/poe/lib/POE/Loop/Tk.pm trunk/poe/lib/POE/Loop/TkActiveState.pm trunk/poe/lib/POE/NFA.pm trunk/poe/lib/POE/Resource/Signals.pm trunk/poe/lib/POE/Session.pm Added Paths: ----------- trunk/poe/tests/30_loops/00_base/sbk_signal_init.pm Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/MANIFEST 2006-06-11 19:23:12 UTC (rev 1980) @@ -138,6 +138,7 @@ tests/30_loops/00_base/k_detach.pm tests/30_loops/00_base/k_selects.pm tests/30_loops/00_base/k_signals.pm +tests/30_loops/00_base/sbk_signal_init.pm tests/30_loops/00_base/ses_nfa.pm tests/30_loops/00_base/ses_session.pm tests/30_loops/00_base/wheel_accept.pm Modified: trunk/poe/lib/POE/Loop/Event.pm =================================================================== --- trunk/poe/lib/POE/Loop/Event.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/Event.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -41,6 +41,8 @@ } sub loop_finalize { + my $self = shift; + foreach my $fd (0..$#fileno_watcher) { next unless defined $fileno_watcher[$fd]; foreach my $mode (MODE_RD, MODE_WR, MODE_EX) { @@ -49,6 +51,10 @@ ) if defined $fileno_watcher[$fd]->[$mode]; } } + + foreach my $signal (keys %signal_watcher) { + $self->loop_ignore_signal($signal); + } } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/Loop/Gtk.pm =================================================================== --- trunk/poe/lib/POE/Loop/Gtk.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/Gtk.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -50,6 +50,8 @@ } sub loop_finalize { + my $self = shift; + foreach my $fd (0..$#fileno_watcher) { next unless defined $fileno_watcher[$fd]; foreach my $mode (MODE_RD, MODE_WR, MODE_EX) { @@ -58,6 +60,8 @@ ) if defined $fileno_watcher[$fd]->[$mode]; } } + + $self->loop_ignore_all_signals(); } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/Loop/IO_Poll.pm =================================================================== --- trunk/poe/lib/POE/Loop/IO_Poll.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/IO_Poll.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -67,7 +67,8 @@ } sub loop_finalize { - # does nothing + my $self = shift; + $self->loop_ignore_all_signals(); } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/Loop/PerlSignals.pm =================================================================== --- trunk/poe/lib/POE/Loop/PerlSignals.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/PerlSignals.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -18,6 +18,10 @@ use strict; use POE::Kernel; +# Flag so we know which signals are watched. Used to reset those +# signals during finalization. +my %signal_watched; + #------------------------------------------------------------------------------ # Signal handlers/callbacks. @@ -51,6 +55,8 @@ sub loop_watch_signal { my ($self, $signal) = @_; + $signal_watched{$signal} = 1; + # Child process has stopped. if ($signal eq 'CHLD' or $signal eq 'CLD') { # We should never twiddle $SIG{CH?LD} under poe, unless we want to override @@ -73,6 +79,8 @@ sub loop_ignore_signal { my ($self, $signal) = @_; + delete $signal_watched{$signal}; + if ($signal eq 'CHLD' or $signal eq 'CLD') { $self->_data_sig_cease_polling(); # We should never twiddle $SIG{CH?LD} under poe, unless we want to override @@ -89,6 +97,13 @@ $SIG{$signal} = "DEFAULT"; } +sub loop_ignore_all_signals { + my $self = shift; + foreach my $signal (keys %signal_watched) { + $self->loop_ignore_signal($signal); + } +} + 1; __END__ Modified: trunk/poe/lib/POE/Loop/Select.pm =================================================================== --- trunk/poe/lib/POE/Loop/Select.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/Select.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -65,6 +65,8 @@ POE::Kernel::_warn "<rc> LOOP VECTOR LEAK: $mode_name = $bits\a\n"; } } + + $self->loop_ignore_all_signals(); } #------------------------------------------------------------------------------ @@ -295,7 +297,7 @@ sleep($timeout); } else { - CORE::select(undef, undef, undef, $timeout); + CORE::select(undef, undef, undef, $timeout); } } } Modified: trunk/poe/lib/POE/Loop/Tk.pm =================================================================== --- trunk/poe/lib/POE/Loop/Tk.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/Tk.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -43,7 +43,8 @@ } sub loop_finalize { - # does nothing + my $self = shift; + $self->loop_ignore_all_signals(); } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/Loop/TkActiveState.pm =================================================================== --- trunk/poe/lib/POE/Loop/TkActiveState.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Loop/TkActiveState.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -75,6 +75,8 @@ POE::Kernel::_warn "<rc> LOOP VECTOR LEAK: $mode_name = $bits\a\n"; } } + + $self->loop_ignore_all_signals(); } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/NFA.pm =================================================================== --- trunk/poe/lib/POE/NFA.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/NFA.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -353,7 +353,7 @@ $handler = $self->[SELF_CURRENT]->{+EN_DEFAULT}; # Transform the parameters for _default. ARG1 and beyond are - # copied so they can't be altered at a distance. + # copied so they can't be altered at a distance. $args = [ $event, [@$args] ]; $event = EN_DEFAULT; } Modified: trunk/poe/lib/POE/Resource/Signals.pm =================================================================== --- trunk/poe/lib/POE/Resource/Signals.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Resource/Signals.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -95,13 +95,15 @@ # Nonexistent signals, and ones which are globally unhandled. next if ( - $signal =~ /^( NUM\d+ - |__[A-Z0-9]+__ - |ALL|CATCHALL|DEFER|HOLD|IGNORE|MAX|PAUSE - |RTMIN|RTMAX|SETS - |SEGV - | - )$/x + $signal =~ /^ + ( NUM\d+ + |__[A-Z0-9]+__ + |ALL|CATCHALL|DEFER|HOLD|IGNORE|MAX|PAUSE + |RTMIN|RTMAX|SETS + |SEGV + | + ) + $/x ); # Windows doesn't have a SIGBUS, but the debugger causes SIGBUS @@ -111,13 +113,15 @@ # Apache uses SIGCHLD and/or SIGCLD itself, so we can't. next if $signal =~ /^CH?LD$/ and exists $INC{'Apache.pm'}; - # Reset the signal handler. Some signal handlers are set to - # IGNORE, while most are kept to DEFAULT. The event loop will - # know what to do. - $self->loop_ignore_signal($signal); - $_safe_signals{$signal} = 1; } + + # Reset some important signal handlers. The rest remain + # untouched. + + $self->loop_ignore_signal("CHLD") if exists $SIG{CHLD}; + $self->loop_ignore_signal("CLD") if exists $SIG{CLD}; + $self->loop_ignore_signal("PIPE") if exists $SIG{PIPE}; } } Modified: trunk/poe/lib/POE/Session.pm =================================================================== --- trunk/poe/lib/POE/Session.pm 2006-06-11 18:01:44 UTC (rev 1979) +++ trunk/poe/lib/POE/Session.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -216,9 +216,9 @@ if ((@states > 1) && (ref($states[0]) eq 'POE::Kernel')); croak( - "POE::Session->new() has been deprecated for over a year. Please\n", - "use create() instead. http://www.nntp.perl.org/group/perl.poe/2613\n", - "discusses the deprecation.\n", + "POE::Session->new() has been deprecated for over a year. Please\n", + "use create() instead. http://www.nntp.perl.org/group/perl.poe/2613\n", + "discusses the deprecation.\n", ); } @@ -469,7 +469,7 @@ # Transmogrify the original state transition into a corresponding # _default invocation. ARG1 is copied from $etc so it can't be - # altered from a distance. + # altered from a distance. $etc = [ $state, [@$etc] ]; $state = EN_DEFAULT; @@ -491,7 +491,7 @@ undef, # unused #6 $file, # caller file name $line, # caller file line - $fromstate, # caller state + $fromstate, # caller state @$etc # args ); } Added: trunk/poe/tests/30_loops/00_base/sbk_signal_init.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/sbk_signal_init.pm (rev 0) +++ trunk/poe/tests/30_loops/00_base/sbk_signal_init.pm 2006-06-11 19:23:12 UTC (rev 1980) @@ -0,0 +1,28 @@ +#!/usr/bin/perl +# $Id$ + +# Tests whether POE::Kernel affects signal handlers at initialization +# time. Based on test code provided by Stuart Kendrick, in +# rt.cpan.org ticket 19529. + +use warnings; +use strict; + +use Test::More tests => 1; + +BEGIN { + $SIG{ALRM} = \&dispatch_normal_signal; +} + +my $signal_dispatched = 0; + +sub dispatch_normal_signal { $signal_dispatched = 1 } + +use POE; + +alarm(1); +sleep 5; + +ok($signal_dispatched, "normal SIGALRM dispatched"); + +1; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-06-18 20:34:07
|
Revision: 1995 Author: rcaputo Date: 2006-06-18 13:33:55 -0700 (Sun, 18 Jun 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=1995&view=rev Log Message: ----------- Move the bytes.pm preprocessing from Makefile.PL to ExtUtils::MakeMaker's PM_FILTER. Modified Paths: -------------- trunk/poe/Makefile.PL trunk/poe/mylib/Makefile-5004.pm trunk/poe/mylib/Makefile-5005.pm trunk/poe/mylib/preprocessor.perl Modified: trunk/poe/Makefile.PL =================================================================== --- trunk/poe/Makefile.PL 2006-06-17 22:40:25 UTC (rev 1994) +++ trunk/poe/Makefile.PL 2006-06-18 20:33:55 UTC (rev 1995) @@ -67,37 +67,6 @@ print "\n"; -# Comment out "use bytes" if it's not supported. - -use File::Find; -my $code; -if ($] < 5.006) { - print "Perl $] does not support bytes.pm. Commenting it out...\n"; - $code = 's/^(\s*)(use bytes;).*/$1#$2 # perl version $] at install/'; -} -else { - print "Perl $] supports bytes.pm. Ensuring it's in...\n"; - $code = 's/^(\s*)#\s*(use bytes;).*/$1$2/'; -} - -find( - sub { - return unless -f and /\.pm$/; - system($^X, "-p", "-i.pp", "-e", $code, $_) and die "System error: $!"; - }, - "lib" -); - -find( - sub { - return unless -f and /\.pp$/; - unlink $_; - }, - "lib" -); - -print "\n"; - # Which kind of makefile should we build? if ($] < 5.005004) { @@ -121,24 +90,4 @@ require "./mylib/Makefile-5005.pm"; } -# And finally, ask the user to run a test report. -# -# NOTE: This is currently disabled. Don't use it. -# -# use Config; -# my $make = $Config::Config{make}; -# -# print( -# "\n", -# "=======================================================================\n", -# "\n", -# "Please consider running '$make uploadreport' to create and upload a\n", -# "test report. You can see samples of other test reports by visitng\n", -# "http://eekeek.org/poe-tests/\n", -# "\n", -# "Thank you.\n", -# "\n", -# "=======================================================================\n", -# ); - 0; Modified: trunk/poe/mylib/Makefile-5004.pm =================================================================== --- trunk/poe/mylib/Makefile-5004.pm 2006-06-17 22:40:25 UTC (rev 1994) +++ trunk/poe/mylib/Makefile-5004.pm 2006-06-18 20:33:55 UTC (rev 1995) @@ -54,8 +54,9 @@ FILES => CLEAN_FILES, }, - PL_FILES => { }, + PL_FILES => { }, PREREQ_PM => { CORE_REQUIREMENTS }, + PM_FILTER => 'mylib/preprocessor.perl', ); 1; Modified: trunk/poe/mylib/Makefile-5005.pm =================================================================== --- trunk/poe/mylib/Makefile-5005.pm 2006-06-17 22:40:25 UTC (rev 1994) +++ trunk/poe/mylib/Makefile-5005.pm 2006-06-18 20:33:55 UTC (rev 1995) @@ -137,6 +137,7 @@ PL_FILES => { }, NO_META => 1, PREREQ_PM => { CORE_REQUIREMENTS }, + PM_FILTER => 'mylib/preprocessor.perl', ); 1; Modified: trunk/poe/mylib/preprocessor.perl =================================================================== --- trunk/poe/mylib/preprocessor.perl 2006-06-17 22:40:25 UTC (rev 1994) +++ trunk/poe/mylib/preprocessor.perl 2006-06-18 20:33:55 UTC (rev 1995) @@ -5,7 +5,10 @@ while (<STDIN>) { if ($] < 5.006) { - s/^(\s*)(use bytes;)$/$1#$2 # perl was $] at install time./; + s/^(\s*)(use bytes;).*/$1#$2 # perl version $] at install/; } + else { + s/^(\s*)#\s*(use bytes;).*/$1$2/; + } print; } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bs...@us...> - 2006-06-25 12:47:20
|
Revision: 2002 Author: bsmith Date: 2006-06-25 05:46:58 -0700 (Sun, 25 Jun 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=2002&view=rev Log Message: ----------- Stub tests for POE::Wheel::Curses and POE::Wheel::ReadLine. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/tests/30_loops/00_base/wheel_curses.pm trunk/poe/tests/30_loops/00_base/wheel_readline.pm Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-06-25 12:39:03 UTC (rev 2001) +++ trunk/poe/MANIFEST 2006-06-25 12:46:58 UTC (rev 2002) @@ -144,6 +144,8 @@ tests/30_loops/00_base/ses_nfa.pm tests/30_loops/00_base/ses_session.pm tests/30_loops/00_base/wheel_accept.pm +tests/30_loops/00_base/wheel_curses.pm +tests/30_loops/00_base/wheel_readline.pm tests/30_loops/00_base/wheel_run.pm tests/30_loops/00_base/wheel_sf_ipv6.pm tests/30_loops/00_base/wheel_sf_tcp.pm Added: trunk/poe/tests/30_loops/00_base/wheel_curses.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/wheel_curses.pm (rev 0) +++ trunk/poe/tests/30_loops/00_base/wheel_curses.pm 2006-06-25 12:46:58 UTC (rev 2002) @@ -0,0 +1,35 @@ +#!/usr/bin/perl -w +# $Id: /branches/poe-tests/tests/30_loops/00_base/wheel_tail.pm 10644 2006-05-29T17:02:47.597324Z bsmith $ + +# Exercises Wheel::Curses + +use strict; +use lib qw(./mylib ../mylib); + +sub POE::Kernel::ASSERT_DEFAULT () { 1 } +sub POE::Kernel::TRACE_DEFAULT () { 1 } +sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } + +use Test::More; +use POE; + +BEGIN { + eval { require Curses }; + if ($@) { + plan skip_all => 'Curses not available'; + } + + plan tests => 2; + use_ok('POE::Wheel::Curses'); +} + +sub DEBUG () { 0 } + + +### main loop + +POE::Kernel->run(); + +pass("run() returned successfully"); + +1; Property changes on: trunk/poe/tests/30_loops/00_base/wheel_curses.pm ___________________________________________________________________ Name: svn:executable + * Added: trunk/poe/tests/30_loops/00_base/wheel_readline.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/wheel_readline.pm (rev 0) +++ trunk/poe/tests/30_loops/00_base/wheel_readline.pm 2006-06-25 12:46:58 UTC (rev 2002) @@ -0,0 +1,28 @@ +#!/usr/bin/perl -w +# $Id: /branches/poe-tests/tests/30_loops/00_base/wheel_tail.pm 10644 2006-05-29T17:02:47.597324Z bsmith $ + +# Exercises Wheel::ReadLine + +use strict; +use warnings; +use lib qw(./mylib ../mylib); + +#sub POE::Kernel::ASSERT_DEFAULT () { 1 } +#sub POE::Kernel::TRACE_DEFAULT () { 1 } +#sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } + +use Test::More tests => 2; + +use POE; + +use_ok('POE::Wheel::ReadLine'); + +sub DEBUG () { 0 } + +### main loop + +POE::Kernel->run(); + +pass("run() returned successfully"); + +1; Property changes on: trunk/poe/tests/30_loops/00_base/wheel_readline.pm ___________________________________________________________________ Name: svn:executable + * This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bs...@us...> - 2006-06-25 12:39:48
|
Revision: 2001 Author: bsmith Date: 2006-06-25 05:39:03 -0700 (Sun, 25 Jun 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=2001&view=rev Log Message: ----------- Add subtests to 10_units/05_filters, including: * Common subroutines for testing the presence and operation of the filter interface factored out to TestFilter.pm * Improved coverage of POE::Filter::{RecordBlock,HTTPD,Stackable}. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/tests/10_units/05_filters/01_block.t trunk/poe/tests/10_units/05_filters/02_grep.t trunk/poe/tests/10_units/05_filters/03_http.t trunk/poe/tests/10_units/05_filters/04_line.t trunk/poe/tests/10_units/05_filters/05_map.t trunk/poe/tests/10_units/05_filters/06_recordblock.t trunk/poe/tests/10_units/05_filters/07_reference.t trunk/poe/tests/10_units/05_filters/08_stream.t trunk/poe/tests/10_units/05_filters/50_stackable.t Added Paths: ----------- trunk/poe/tests/10_units/05_filters/TestFilter.pm Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/MANIFEST 2006-06-25 12:39:03 UTC (rev 2001) @@ -117,6 +117,7 @@ tests/10_units/05_filters/08_stream.t tests/10_units/05_filters/50_stackable.t tests/10_units/05_filters/99_filterchange.t +tests/10_units/05_filters/TestFilter.pm tests/10_units/06_queues/01_array.t tests/10_units/07_exceptions/01_normal.t tests/10_units/07_exceptions/02_turn_off.t Modified: trunk/poe/tests/10_units/05_filters/01_block.t =================================================================== --- trunk/poe/tests/10_units/05_filters/01_block.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/01_block.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -7,14 +7,17 @@ use strict; use lib qw(./mylib ../mylib); +use lib qw(tests/10_units/05_filters); -use Test::More tests => 20; +use TestFilter; +use Test::More tests => 20 + $COUNT_FILTER_INTERFACE; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } use_ok("POE::Filter::Block"); +test_filter_interface("POE::Filter::Block"); # Test block filter in fixed-length mode. { Modified: trunk/poe/tests/10_units/05_filters/02_grep.t =================================================================== --- trunk/poe/tests/10_units/05_filters/02_grep.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/02_grep.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -4,12 +4,19 @@ use strict; use lib qw(./mylib ../mylib); +use lib qw(tests/10_units/05_filters); + use Data::Dumper; $Data::Dumper::Indent=1; -use POE::Filter::Grep; -use Test::More tests => 17; # FILL ME IN +use TestFilter; +use Test::More tests => 26 + $COUNT_FILTER_INTERFACE + 2*$COUNT_FILTER_STANDARD; + +use_ok("POE::Filter::Grep"); +test_filter_interface("POE::Filter::Grep"); + # Test erroneous new() args test_new("No Args"); +test_new("even", "one", "two", "odd"); test_new("Non code CODE ref", Code => [ ]); test_new("Single Get ref", Get => sub { }); test_new("Single Put ref", Put => sub { }); @@ -21,39 +28,83 @@ my @args = @_; my $filter; eval { $filter = POE::Filter::Grep->new(@args); }; - ok(defined $@, $name); + ok(!(!$@), $name); } -my $filter; # Test actual mapping of Get, Put, and Code -$filter = POE::Filter::Grep->new( Get => sub { /\d/ }, Put => sub { /[a-zA-Z]/ } ); -is_deeply($filter->put([qw/A B C 1 2 3/]), [qw/A B C/], "Test Put"); -is_deeply($filter->get([qw/a b c 1 2 3/]), [qw/1 2 3/], "Test Get"); +{ # Test Get and Put + my $filter = POE::Filter::Grep->new( + Get => sub { /\d/ }, + Put => sub { /[a-zA-Z]/ } + ); + is_deeply($filter->put([qw/A B C 1 2 3/]), [qw/A B C/], "Test Put"); + is_deeply($filter->get([qw/a b c 1 2 3/]), [qw/1 2 3/], "Test Get"); -$filter = POE::Filter::Grep->new(Code => sub { /(\w)/ }); -is_deeply($filter->put([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Test Put (as Code)"); -is_deeply($filter->get([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Test Get (as Code)"); + test_filter_standard( + $filter, + [qw/a b c 1 2 3/], + [qw/1 2 3/], + [qw//], + ); +} +{ # Test Code + my $filter = POE::Filter::Grep->new(Code => sub { /(\w)/ }); + is_deeply($filter->put([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], + "Test Put (as Code)"); + is_deeply($filter->get([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], + "Test Get (as Code)"); + test_filter_standard( + $filter, + [qw/a b c 1 2 3 ! @/], + [qw/a b c 1 2 3/], + [qw/a b c 1 2 3/], + ); +} -$filter = POE::Filter::Grep->new( Get => sub { /1/ }, Put => sub { /1/ } ); -# Test erroneous modification -test_modify("Modify Get not CODE ref", $filter, Get => [ ]); -test_modify("Modify Put not CODE ref", $filter, Put => [ ]); -test_modify("Modify Code not CODE ref", $filter, Code => [ ]); +{ + my $filter = POE::Filter::Grep->new( Get => sub { /1/ }, Put => sub { /1/ } ); -sub test_modify { - my ($name, $filter, @args) = @_; - eval { $filter->modify(@args); }; - ok(defined $@, $name); + # Test erroneous modification + test_modify("Modify Get not CODE ref", $filter, Get => [ ]); + test_modify("Modify Put not CODE ref", $filter, Put => [ ]); + test_modify("Modify Code not CODE ref", $filter, Code => [ ]); + test_modify("Modify with invalid key", $filter, Elephant => sub { }); + + sub test_modify { + my ($name, $filter, @args) = @_; + local $SIG{__WARN__} = sub { }; + eval { $filter->modify(@args); }; + ok(defined $@, $name); + } + + $filter->modify(Get => sub { /\d/ }); + is_deeply($filter->get([qw/a b c 1 2 3/]), [qw/1 2 3/], "Modify Get"); + + $filter->modify(Put => sub { /[a-zA-Z]/ }); + is_deeply($filter->put([qw/A B C 1 2 3/]), [qw/A B C/], "Modify Put"); + + $filter->modify(Code => sub { /(\w)/ }); + is_deeply($filter->put([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Modify Put (as Code)"); + is_deeply($filter->get([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Modify Get (as Code)"); } -$filter->modify(Get => sub { /\d/ }); -is_deeply($filter->get([qw/a b c 1 2 3/]), [qw/1 2 3/], "Modify Get"); +# Grep (from stackable's tests) -- testing get_pending +{ + my @test_list = (1, 1, 2, 3, 5); + my $grep = POE::Filter::Grep->new( Code => sub { $_ & 1 } ); + $grep->get_one_start( [ @test_list ] ); -$filter->modify(Put => sub { /[a-zA-Z]/ }); -is_deeply($filter->put([qw/A B C 1 2 3/]), [qw/A B C/], "Modify Put"); + my $grep_pending = join '', @{$grep->get_pending()}; + ok($grep_pending eq '11235', "grep filter's parser buffer verifies"); -$filter->modify(Code => sub { /(\w)/ }); -is_deeply($filter->put([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Modify Put (as Code)"); -is_deeply($filter->get([qw/a b c 1 2 3 ! @ /]), [qw/a b c 1 2 3/], "Modify Get (as Code)"); + foreach my $compare (@test_list) { + next unless $compare & 1; + my $next = $grep->get_one(); + is_deeply($next, [ $compare ], "grep filter get_one() returns [$compare]"); + } + + my $grep_next = $grep->get_one(); + ok(!@$grep_next, "nothing left to get from grep filter"); +} Modified: trunk/poe/tests/10_units/05_filters/03_http.t =================================================================== --- trunk/poe/tests/10_units/05_filters/03_http.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/03_http.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -8,56 +8,71 @@ use lib qw(./mylib ../mylib); +use Test::More; + BEGIN { - if (-f 'run_network_tests') { - eval " use HTTP::Request; use HTTP::Request::Common; "; - if($@) { - eval " use Test::More skip_all => 'HTTP::Request is needed for these tests.' "; - } else { - eval { - eval " use Test::More tests => 64; "; - use_ok('POE::Filter::HTTPD'); - } - } - } else { - eval "use Test::More skip_all => 'Need network access (and permission) for these tests'"; - exit; + unless (-f 'run_network_tests') { + plan skip_all => 'Need network access (and permission) for these tests'; } + + eval { use HTTP::Request; use HTTP::Request::Common; use HTTP::Status }; + if ($@) { + plan skip_all => 'HTTP::Request is needed for these tests.'; + } } +BEGIN { + plan tests => 88; +} -{ # simple get {{{ +use_ok('POE::Filter::HTTPD'); - my $filter; +# takes a object, and a hash { method_name => expected_value }, +# and an optional name for the test +# uses is(), so values are simple scalars +sub check_fields { + my ($object, $expected, $name) = @_; + $name = $name ? "$name: " : ""; + while (my ($method, $expected_value) = each %$expected) { + is($object->$method, $expected_value, "$name$method"); + } +} - eval { $filter = POE::Filter::HTTPD->new() }; - ok(!$@, 'new() throws no exceptions'); - ok(defined $filter, 'new() returns something'); - is(ref $filter, 'POE::Filter::HTTPD', 'new() returns properly blessed object'); +sub check_error_response { + my ($data, $code, $label) = @_; - my $get_request = HTTP::Request->new('GET', 'http://localhost/pie.mhtml'); - my $data; - eval { $data = $filter->get([ $get_request->as_string() ]); }; - ok(!$@, 'simple get: get() throws no exceptions'); - ok(defined $data, "simple get: get() returns something"); - is(ref $data, 'ARRAY', 'simple get: get() returns list of requests'); - is(scalar @$data, 1, 'simple get: get() returned single request'); + ok( + (ref($data) eq 'ARRAY') && + (scalar(@$data) == 1) && + ($$data[0]->code == $code), + $label + ); +} - my $req = shift @$data; +{ # simple get {{{ + my $filter = POE::Filter::HTTPD->new(); + isa_ok($filter, 'POE::Filter::HTTPD'); - is(ref $req, 'HTTP::Request', 'simple get: get() returns HTTP::Request object'); - is($req->method, 'GET', 'simple get: HTTP::Request object contains proper HTTP method'); - is($req->url, 'http://localhost/pie.mhtml', 'simple get: HTTP::Request object contains proper URI'); - is($req->content, '', 'simple get: HTTP::Request object properly contains no content'); + my $get_request = + HTTP::Request->new('GET', 'http://localhost/pie.mhtml'); + my $records = $filter->get([ $get_request->as_string ]); + is(ref($records), 'ARRAY', 'simple get: get() returns list of requests'); + is(scalar(@$records), 1, 'simple get: get() returned single request'); + + my ($req) = @$records; + + isa_ok($req, 'HTTP::Request', 'simple get'); + check_fields($req, { + method => $get_request->method, + url => $get_request->url, + content => $get_request->content, + }, "simple get"); } # }}} { # More complex get {{{ + my $filter = POE::Filter::HTTPD->new(); - my $filter; - - $filter = POE::Filter::HTTPD->new(); - my $get_data = q|GET /foo.html HTTP/1.0 User-Agent: Wget/1.8.2 Host: localhost:8080 @@ -65,66 +80,53 @@ Connection: Keep-Alive |; - my $data; - eval { $data = $filter->get([ $get_data ]); }; - ok(!$@, 'HTTP 1.0 get: get() throws no exceptions'); - ok(defined $data, "HTTP 1.0 get: get() returns something"); + + my $data = $filter->get([ $get_data ]); is(ref $data, 'ARRAY', 'HTTP 1.0 get: get() returns list of requests'); is(scalar @$data, 1, 'HTTP 1.0 get: get() returned single request'); - my $req = shift @$data; - is(ref $req, 'HTTP::Request', - 'HTTP 1.0 get: get() returns HTTP::Request object'); + my ($req) = @$data; - is($req->method, 'GET', - 'HTTP 1.0 get: HTTP::Request object contains proper HTTP method'); + isa_ok($req, 'HTTP::Request', 'HTTP 1.0 get'); + check_fields($req, { + method => 'GET', + url => '/foo.html', + content => '', + }, "HTTP 1.0 get"); - is($req->url, '/foo.html', - 'HTTP 1.0 get: HTTP::Request object contains proper URI'); + my %headers = ( + 'User-Agent' => 'Wget/1.8.2', + 'Host' => 'localhost:8080', + 'Accept' => '*/*', + 'Connection' => 'Keep-Alive', + ); - is($req->content, '', - 'HTTP 1.0 get: HTTP::Request object properly contains no content'); - is($req->header('User-Agent'), 'Wget/1.8.2', - 'HTTP 1.0 get: HTTP::Request object contains proper User-Agent header'); - - is($req->header('Host'), 'localhost:8080', - 'HTTP 1.0 get: HTTP::Request object contains proper Host header'); - - is($req->header('Accept'), '*/*', - 'HTTP 1.0 get: HTTP::Request object contains proper Accept header'); - - is($req->header('Connection'), 'Keep-Alive', - 'HTTP 1.0 get: HTTP::Request object contains proper Connection header'); - + while (my ($k, $v) = each %headers) { + is($req->header($k), $v, "HTTP 1.0 get: $k header"); + } } # }}} { # simple post {{{ - my $post_request = POST 'http://localhost/foo.mhtml', [ 'I' => 'like', 'tasty' => 'pie' ]; $post_request->protocol('HTTP/1.0'); my $filter = POE::Filter::HTTPD->new(); - my $str = $post_request->as_string; - - my $data; - eval { $data = $filter->get([ $str ]); }; - ok(!$@, 'simple post: get() throws no exceptions'); - ok(defined $data, "simple post: get() returns something"); + my $data = $filter->get([ $post_request->as_string ]); is(ref $data, 'ARRAY', 'simple post: get() returns list of requests'); is(scalar @$data, 1, 'simple post: get() returned single request'); - my $req = shift @$data; + my ($req) = @$data; - is(ref $req, 'HTTP::Request', + isa_ok($req, 'HTTP::Request', 'simple post: get() returns HTTP::Request object'); - is($req->method, 'POST', - 'simple post: HTTP::Request object contains proper HTTP method'); + check_fields($req, { + method => 'POST', + url => 'http://localhost/foo.mhtml', + protocol => 'HTTP/1.0', + }, "simple post"); - is($req->url, 'http://localhost/foo.mhtml', - 'simple post: HTTP::Request object contains proper URI'); - # The HTTP::Request bundled with ActivePerl 5.6.1 causes a test # failure here. The one included in ActivePerl 5.8.3 works fine. # It was suggested by an anonymous bug reporter to test against @@ -148,65 +150,51 @@ is($req->header('Content-Type'), 'application/x-www-form-urlencoded', 'simple post: HTTP::Request object contains proper Content-Type header'); - } # }}} { # simple head {{{ - - my $head_request = HEAD 'http://localhost/foo.mhtml'; my $filter = POE::Filter::HTTPD->new(); - my $data; - eval { $data = $filter->get([ $head_request->as_string ]); }; - ok(!$@, 'simple head: get() throws no exceptions'); - ok(defined $data, "simple head: get() returns something"); + my $data = $filter->get([ $head_request->as_string ]); is(ref $data, 'ARRAY', 'simple head: get() returns list of requests'); is(scalar @$data, 1, 'simple head: get() returned single request'); - my $req = shift @$data; + my ($req) = @$data; - is(ref $req, 'HTTP::Request', + isa_ok($req, 'HTTP::Request', 'simple head: get() returns HTTP::Request object'); - is($req->method, 'HEAD', - 'simple head: HTTP::Request object contains proper HTTP method'); - - is($req->url, 'http://localhost/foo.mhtml', - 'simple head: HTTP::Request object contains proper URI'); - + check_fields($req, { + method => 'HEAD', + url => 'http://localhost/foo.mhtml', + }, "simple head"); } # }}} SKIP: { # simple put {{{ + skip "PUT not supported yet", 5; - skip "PUT not supported yet.", 7; my $put_request = PUT 'http://localhost/foo.mhtml'; my $filter = POE::Filter::HTTPD->new(); - my $data; - eval { $data = $filter->get([ $put_request->as_string ]); }; - ok(!$@, 'simple put: get() throws no exceptions'); - ok(defined $data, "simple put: get() returns something"); + my $data = $filter->get([ $put_request->as_string ]); is(ref $data, 'ARRAY', 'simple put: get() returns list of requests'); is(scalar @$data, 1, 'simple put: get() returned single request'); - my $req = shift @$data; + my ($req) = @$data; - is(ref $req, 'HTTP::Request', + isa_ok($req, 'HTTP::Request', 'simple put: get() returns HTTP::Request object'); - - is($req->method, 'PUT', - 'simple put: HTTP::Request object contains proper HTTP method'); - - is($req->url, 'http://localhost/foo.mhtml', - 'simple put: HTTP::Request object contains proper URI'); - + + check_fields($req, { + method => 'PUT', + url => 'http://localhost/foo.mhtml', + }, "simple put"); } # }}} { # multipart form data post {{{ - my $request = POST 'http://localhost/foo.mhtml', Content_Type => 'form-data', content => [ 'I' => 'like', 'tasty' => 'pie', file => [ $0 ] @@ -215,24 +203,21 @@ my $filter = POE::Filter::HTTPD->new(); - my $data; - eval { $data = $filter->get([ $request->as_string ]); }; - ok(!$@, 'multipart form data: get() throws no exceptions'); - ok(defined $data, "multipart form data: get() returns something"); + my $data = $filter->get([ $request->as_string ]); is(ref $data, 'ARRAY', 'multipart form data: get() returns list of requests'); is(scalar @$data, 1, 'multipart form data: get() returned single request'); - my $req = shift @$data; + my ($req) = @$data; - is(ref $req, 'HTTP::Request', + isa_ok($req, 'HTTP::Request', 'multipart form data: get() returns HTTP::Request object'); - is($req->method, 'POST', - 'multipart form data: HTTP::Request object contains proper HTTP method'); + check_fields($req, { + method => 'POST', + url => 'http://localhost/foo.mhtml', + protocol => 'HTTP/1.0', + }, "multipart form data"); - is($req->url, 'http://localhost/foo.mhtml', - 'multipart form data: HTTP::Request object contains proper URI'); - if($] >= '5.006') { eval " like(\$req->header('Content-Type'), qr#multipart/form-data#, @@ -242,38 +227,204 @@ 'multipart form data: content seems to contain all data sent'); "; } else { - SKIP: { - skip("Need qr// support for these tests",2); - ok(1); - ok(1); - } + ok($req->header('Content-Type') =~ m{multipart/form-data}, + "multipart form data: HTTP::Request object contains proper Content-Type header"); + ok($req->content =~ m{&results;.*?exit;}s, + 'multipart form data: content seems to contain all data sent'); } } # }}} { # options request {{{ - my $request = HTTP::Request->new('OPTIONS', '*'); $request->protocol('HTTP/1.0'); my $filter = POE::Filter::HTTPD->new(); - my $data; - eval { $data = $filter->get([ $request->as_string ]); }; - ok(!$@, 'options: get() throws no exceptions'); - ok(defined $data, "options: get() returns something"); + my $data = $filter->get([ $request->as_string ]); is(ref $data, 'ARRAY', 'options: get() returns list of requests'); is(scalar @$data, 1, 'options: get() returned single request'); - my $req = shift @$data; + my ($req) = @$data; - is(ref $req, 'HTTP::Request', + isa_ok($req, 'HTTP::Request', 'options: get() returns HTTP::Request object'); - is($req->method, 'OPTIONS', - 'options: HTTP::Request object contains proper HTTP method'); + check_fields($req, { + method => 'OPTIONS', + url => '*', + protocol => 'HTTP/1.0', + }, 'options'); +} # }}} - is($req->url, '*', - 'options: HTTP::Request object contains proper URI'); +{ # unless specified, version defaults to HTTP/0.9 in get {{{ + my $req_str = <<'END'; +GET / +END + + my $filter = POE::Filter::HTTPD->new; + + my $data = $filter->get([ $req_str ]); + my ($req) = @$data; + isa_ok($req, 'HTTP::Request', 'HTTP/0.9 defaulting: get gives HTTP::Request'); + check_fields($req, { + method => 'GET', + url => '/', + protocol => 'HTTP/0.9', + }, 'HTTP/0.9 defaulting'); } # }}} + +{ # reconstruction from lots of fragments {{{ + my $req = POST 'http://localhost:1234/foobar.html', + [ 'I' => 'like', 'honey' => 'with peas' ]; + $req->protocol('HTTP/1.1'); + my @req_frags = unpack("(a2)*", $req->as_string); + my $filter = POE::Filter::HTTPD->new; + + #my $pending_ok = 0; + my $req_too_early; + my @records; + while (@req_frags) { + my $data = $filter->get([ splice(@req_frags, 0, 2) ]); + #$pending_ok++ if $filter->get_pending(); + if (@req_frags) { + $req_too_early++ if @$data; + } + push @records, @$data; + } + + #ok($pending_ok, 'fragments: get_pending() non-empty at some point'); + #is($filter->get_pending(), undef, 'fragments: get_pending() empty at end'); + ok(!$req_too_early, "fragments: get() returning nothing until end"); + + is(scalar(@records), 1, 'fragments: only one request returned'); + isa_ok($records[0], 'HTTP::Request', 'fragments: request isa HTTP::Request'); + check_fields($req, { + method => 'POST', + url => 'http://localhost:1234/foobar.html', + content => $req->content, + }, 'fragments'); + +} # }}} + +{ # trailing content on request {{{ + my $req = HTTP::Request->new('GET', 'http://localhost:1234/foobar.html'); + + # request + trailing whitespace in one block == just request + { + my $filter = POE::Filter::HTTPD->new; + my $data = $filter->get([ $req->as_string . "\r\n \r\n\n" ]); + is(ref($data), 'ARRAY', 'trailing: whitespace in block: ref'); + is(scalar(@$data), 1, 'trailing: whitespace in block: one req'); + isa_ok($$data[0], 'HTTP::Request', + 'trailing: whitespace in block: HTTP::Request'); + check_fields($req, { + method => 'GET', + url => 'http://localhost:1234/foobar.html' + }, 'trailing: whitespace in block'); + } + + # request + garbage together == request + { + my $filter = POE::Filter::HTTPD->new; + my $data = $filter->get([ $req->as_string . "GARBAGE!" ]); + is(ref($data), 'ARRAY', 'trailing: garbage in block: ref'); + is(scalar(@$data), 1, 'trailing: garbage in block: one req'); + isa_ok($$data[0], 'HTTP::Request', + 'trailing: garbage in block: HTTP::Request'); + check_fields($req, { + method => 'GET', + url => 'http://localhost:1234/foobar.html' + }, 'trailing: garbage in block'); + } + + # request + trailing whitespace in separate block == just request + { + my $filter = POE::Filter::HTTPD->new; + my $data = $filter->get([ $req->as_string, "\r\n \r\n\n" ]); + is(ref($data), 'ARRAY', 'trailing: extra whitespace packet: ref'); + is(scalar(@$data), 1, 'trailing: extra whitespace packet: one req'); + isa_ok($$data[0], 'HTTP::Request', + 'trailing: extra whitespace packet: HTTP::Request'); + check_fields($req, { + method => 'GET', + url => 'http://localhost:1234/foobar.html' + }, 'trailing: extra whitespace packet'); + } + + # request + trailing whitespace in separate get == just request + { + my $filter = POE::Filter::HTTPD->new; + $filter->get([ $req->as_string ]); # assume this one is fine + my $data = $filter->get([ "\r\n \r\n\n" ]); + is(ref($data), 'ARRAY', 'trailing: extra whitespace get: ref'); + is(scalar(@$data), 1, 'trailing: extra whitespace get: no req'); + } + + # request + garbage in separate get == error + { + my $filter = POE::Filter::HTTPD->new; + $filter->get([ $req->as_string ]); # assume this one is fine + my $data = $filter->get([ $req->as_string, "GARBAGE!" ]); + check_error_response($data, RC_BAD_REQUEST, + 'trailing: error with trailing garbage'); + } +} # }}} + +TODO: { # wishlist for supporting get_pending! {{{ + local $TODO = 'add get_pending support'; + my $filter = POE::Filter::HTTPD->new; + eval { $filter->get_pending() }; + ok(!$@, 'get_pending supported!'); +} # }}} + +{ # basic checkout of put {{{ + my $res = HTTP::Response->new("404", "Not found"); + + my $filter = POE::Filter::HTTPD->new; + + use Carp; + $SIG{__DIE__} = \&Carp::croak; + my $chunks = $filter->put([$res]); + is(ref($chunks), 'ARRAY', 'put: returns arrayref'); + +} # }}} + +{ # really, really garbage requests get rejected, but goofy ones accepted {{{ + { + my $filter = POE::Filter::HTTPD->new; + my $data = $filter->get([ "ELEPHANT\n\r\n" ]); + check_error_response($data, RC_BAD_REQUEST, + 'garbage request line: bad request'); + } + + { + my $filter = POE::Filter::HTTPD->new; + my $data = $filter->get([ "GET\t/elephant.gif\n\n" ]); + isa_ok($$data[0], 'HTTP::Request', 'goofy request accepted'); + check_fields($$data[0], { + protocol => 'HTTP/0.9', + method => 'GET', + uri => '/elephant.gif', + }, 'goofy request'); + } +} # }}} + +{ # unsupported method {{{ + { # bad request -- 0.9 so no length required + my $filter = POE::Filter::HTTPD->new; + my $req = HTTP::Request->new('ELEPHANT', '/'); + my $data = $filter->get([ $req->as_string ]); + check_error_response($data, RC_BAD_REQUEST, + 'unsupported method: bad request'); + } + { # bad request -- 1.1 so length required + my $filter = POE::Filter::HTTPD->new; + my $req = HTTP::Request->new('ELEPHANT', 'http://localhost/'); + $req->protocol('HTTP/1.1'); + my $data = $filter->get([ $req->as_string ]); + check_error_response($data, RC_LENGTH_REQUIRED, + 'unsupported method: length required'); + } +} # }}} Modified: trunk/poe/tests/10_units/05_filters/04_line.t =================================================================== --- trunk/poe/tests/10_units/05_filters/04_line.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/04_line.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -6,49 +6,56 @@ use strict; use lib qw(./mylib ../mylib); +use lib qw(tests/10_units/05_filters); sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } -use Test::More tests => 14; +use TestFilter; +use Test::More tests => 18 + $COUNT_FILTER_INTERFACE + 2*$COUNT_FILTER_STANDARD; use_ok("POE::Filter::Line"); +test_filter_interface("POE::Filter::Line"); +test_new("new(): even number of args", "one", "two", "odd"); +test_new("new(): empty Literal", Literal => ""); +# What is Regexp? I see InputRegexp, but not Regexp +test_new("new(): Literal and Regexp", Regexp => "\r", Literal => "\n"); +test_new("new(): Literal and InputRegexp", InputRegexp => "\r", Literal => "\n"); +test_new("new(): Literal and InputLiteral", InputLiteral => "\r", Literal => "\n"); +test_new("new(): Literal and OutputLiteral", OutputLiteral => "\r", Literal => "\n"); +test_new("new(): InputLiteral and InputRegexp", InputRegexp => "\r", InputLiteral => "\n"); + +sub test_new { + my ($name, @args) = @_; + eval { POE::Filter::Line->new(@args); }; + ok(!(!$@), $name); +} + # Test the line filter in default mode. - { my $filter = POE::Filter::Line->new(); + isa_ok($filter, 'POE::Filter::Line'); - my $received = $filter->get( [ "a\x0D", "b\x0A", "c\x0D\x0A", "d\x0A\x0D" ] ); - is_deeply( - $received, [ "a", "b", "c", "d" ], - "line serializer stripped newlines on input" + test_filter_standard( + $filter, + [ "a\x0D", "b\x0A", "c\x0D\x0A", "d\x0A\x0D" ], + [ "a", "b", "c", "d" ], + [ "a\x0D\x0A", "b\x0D\x0A", "c\x0D\x0A", "d\x0D\x0A" ], ); - - my $sent = $filter->put($received); - is_deeply( - $sent, [ "a\x0D\x0A", "b\x0D\x0A", "c\x0D\x0A", "d\x0D\x0A" ], - "line serializer added newlines to output" - ); } # Test the line filter in literal mode. - { my $filter = POE::Filter::Line->new( Literal => 'x' ); - my $received = $filter->get( [ "axa", "bxb", "cxc", "dxd" ] ); - is_deeply( - $received, [ "a", "ab", "bc", "cd" ], - "literal mode line filter parsed input" + test_filter_standard( + $filter, + [ "axa", "bxb", "cxc", "dxd" ], + [ "a", "ab", "bc", "cd" ], + [ "ax", "abx", "bcx", "cdx" ], ); - - my $sent = $filter->put( $received ); - is_deeply( - $sent, [ "ax", "abx", "bcx", "cdx" ], - "literal mode line filter serialized output" - ); } # Test the line filter with different input and output literals. Modified: trunk/poe/tests/10_units/05_filters/05_map.t =================================================================== --- trunk/poe/tests/10_units/05_filters/05_map.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/05_map.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -4,12 +4,17 @@ use strict; use lib qw(./mylib ../mylib); +use lib qw(tests/10_units/05_filters); -use POE::Filter::Map; -use Test::More tests => 17; # FILL ME IN +use TestFilter; +use Test::More tests => 19 + $COUNT_FILTER_INTERFACE; +use_ok('POE::Filter::Map'); +test_filter_interface('POE::Filter::Map'); + # Test erroneous new() args test_new("No Args"); +test_new("Odd number of args", "one", "two", "odd"); test_new("Non code CODE ref", Code => [ ]); test_new("Single Get ref", Get => sub { }); test_new("Single Put ref", Put => sub { }); @@ -21,7 +26,7 @@ my @args = @_; my $filter; eval { $filter = POE::Filter::Map->new(@args); }; - ok(defined $@, $name); + ok($@ ne '', $name); } my $filter; @@ -38,14 +43,18 @@ $filter = POE::Filter::Map->new( Get => sub { 'GET' }, Put => sub { 'PUT' } ); # Test erroneous modification -test_modify("Modify Get not CODE ref", $filter, Get => [ ]); -test_modify("Modify Put not CODE ref", $filter, Put => [ ]); -test_modify("Modify Code not CODE ref", $filter, Code => [ ]); +TODO: { + local $TODO = "modify() carps rather than dieing"; + local $SIG{__WARN__} = sub { }; + test_modify("Modify Get not CODE ref", $filter, Get => [ ]); + test_modify("Modify Put not CODE ref", $filter, Put => [ ]); + test_modify("Modify Code not CODE ref", $filter, Code => [ ]); +} sub test_modify { my ($name, $filter, @args) = @_; eval { $filter->modify(@args); }; - ok(defined $@, $name); + ok($@ ne '', $name); } $filter->modify(Get => sub { 'NGet' }); Modified: trunk/poe/tests/10_units/05_filters/06_recordblock.t =================================================================== --- trunk/poe/tests/10_units/05_filters/06_recordblock.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/06_recordblock.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -1,9 +1,110 @@ #!/usr/bin/perl -w +# Exercises POE::Filter::RecordBlock without the rest of POE + use strict; +use lib qw(tests/10_units/05_filters); -use Test::More; +use TestFilter; +use Test::More tests => 21 + $COUNT_FILTER_INTERFACE + $COUNT_FILTER_STANDARD; -print "1..0 # SKIP not implemented yet\n"; +use_ok("POE::Filter::RecordBlock"); +test_filter_interface("POE::Filter::RecordBlock"); -exit 0; +# standard tests and blocksize +{ + my $filter = POE::Filter::RecordBlock->new( BlockSize => 4 ); + + test_filter_standard( + $filter, + [qw/1 2 3 4 5 6 7 8 9 10/], + [[qw/1 2 3 4/], [qw/5 6 7 8/]], + [qw/1 2 3 4 5 6 7 8/], + ); + + is($filter->blocksize(), 4, "blocksize() returns blocksize"); + $filter->blocksize(2); + is($filter->blocksize(), 2, "blocksize() can be changed"); + + eval { $filter->blocksize(undef) }; + eval { local $^W = 0; $filter->blocksize("elephant") }; + eval { $filter->blocksize(-50) }; + eval { $filter->blocksize(0) }; + is($filter->blocksize(), 2, "blocksize() rejects invalid sizes"); +} + +# new() error checking +{ + eval { POE::Filter::RecordBlock->new( BlockSize => 0 ) }; + ok(!!$@, "BlockSize == 0 fails"); + eval { POE::Filter::RecordBlock->new( ) }; + ok(!!$@, "BlockSize must be given"); + eval { local $^W = 0; POE::Filter::RecordBlock->new( BlockSize => "elephant" ) }; + ok(!!$@, "BlockSize must not be an elephant"); + eval { POE::Filter::RecordBlock->new( "one", "two", "odd number" ) }; + ok(!!$@, "odd number of named parameters is invalid"); +} + +# test checkput +{ + my $filter = POE::Filter::RecordBlock->new( BlockSize => 3, CheckPut => 1 ); + + is_deeply( + $filter->put( [[qw/1 2/], [qw/3 A/]] ), + [qw/1 2 3/], + "check put on: short blocks" + ); + is_deeply( + $filter->put_pending(), + [qw/A/], + " put_pending" + ); + + is_deeply( + $filter->put( [[qw/2 3 1 2 3/], [qw/1 2 3 B/]] ), + [qw/A 2 3 1 2 3 1 2 3/], + "check put on: long blocks" + ); + is_deeply( + $filter->put_pending(), + [qw/B/], + " put_pending" + ); + + is_deeply( + $filter->put( [[qw/2 3 1 2/], [qw/3 1/], [qw/2 3 1/], [qw/2 3/]] ), + [qw/B 2 3 1 2 3 1 2 3 1 2 3/], + "check put on: mixed blocks" + ); + ok(!defined($filter->put_pending()), " put_pending"); + + ok($filter->checkput(), "checkput() returns CheckPut flag"); + $filter->checkput(0); + ok(!$filter->checkput(), "checkput() can be changed"); +} + +# test checkput can be turned off! +{ + my $filter = POE::Filter::RecordBlock->new( BlockSize => 3 ); + ok(!$filter->checkput(), "checkput() returns CheckPut flag"); + + is_deeply( + $filter->put( [[qw/1 2/], [qw/1 2/]] ), + [qw/1 2 1 2/], + "check put off: short blocks" + ); + + ok(!defined($filter->put_pending()), " put_pending is empty"); + + is_deeply( + $filter->put( [[qw/1 2 3 4 5/], [qw/1 2 3 4/]] ), + [qw/1 2 3 4 5 1 2 3 4/], + "check put off: long blocks" + ); + + is_deeply( + $filter->put( [[qw/1 2 3 4/], [qw/1 2/], [qw/1 2 3/], [qw/1 2/]] ), + [qw/1 2 3 4 1 2 1 2 3 1 2/], + "check put off: mixed blocks" + ); +} Modified: trunk/poe/tests/10_units/05_filters/07_reference.t =================================================================== --- trunk/poe/tests/10_units/05_filters/07_reference.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/07_reference.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -6,17 +6,20 @@ use strict; use lib qw(./mylib ../mylib); +use lib qw(tests/10_units/05_filters); sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } +use TestFilter; use Test::More; -use POE::Filter::Reference; use Symbol qw(delete_package); +use POE::Filter::Reference; + # Determine whether we can run these tests. -BEGIN: { +BEGIN { local $SIG{__WARN__} = sub { }; my $reference = eval { POE::Filter::Reference->new(); }; if (length $@) { @@ -28,8 +31,12 @@ } } -plan tests => 11; +BEGIN { + plan tests => 11 + $COUNT_FILTER_INTERFACE; +} +test_filter_interface('POE::Filter::Reference'); + # A trivial, special-case serializer and reconstitutor. sub MyFreezer::freeze { Modified: trunk/poe/tests/10_units/05_filters/08_stream.t =================================================================== --- trunk/poe/tests/10_units/05_filters/08_stream.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/08_stream.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -5,18 +5,31 @@ use strict; use lib qw(./mylib ../mylib); +use lib qw(tests/10_units/05_filters); -use Test::More tests => 8; +use TestFilter; +use Test::More tests => 9 + $COUNT_FILTER_INTERFACE + $COUNT_FILTER_STANDARD; sub POE::Kernel::ASSERT_DEFAULT () { 1 } sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } -BEGIN { use_ok("POE::Filter::Stream") } +use_ok("POE::Filter::Stream"); +test_filter_interface("POE::Filter::Stream"); -my $filter = new POE::Filter::Stream; +my $filter = POE::Filter::Stream->new; +isa_ok($filter, 'POE::Filter::Stream'); my @test_fodder = qw(a bc def ghij klmno); +# General test +test_filter_standard( + $filter, + [qw(a bc def ghij klmno)], + [qw(abcdefghijklmno)], + [qw(abcdefghijklmno)], +); + +# Specific tests for stream filter { my $received = $filter->get( \@test_fodder ); ok( eq_array($received, [ 'abcdefghijklmno' ]), Modified: trunk/poe/tests/10_units/05_filters/50_stackable.t =================================================================== --- trunk/poe/tests/10_units/05_filters/50_stackable.t 2006-06-25 12:36:52 UTC (rev 2000) +++ trunk/poe/tests/10_units/05_filters/50_stackable.t 2006-06-25 12:39:03 UTC (rev 2001) @@ -11,13 +11,13 @@ sub POE::Kernel::TRACE_DEFAULT () { 1 } sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } -use POE::Filter::Stackable; -use POE::Filter::Grep; -use POE::Filter::Map; -use POE::Filter::RecordBlock; -use POE::Filter::Line; +use Test::More tests => 30; -use Test::More tests => 22; +use_ok('POE::Filter::Stackable'); +use_ok('POE::Filter::Grep'); +use_ok('POE::Filter::Map'); +use_ok('POE::Filter::RecordBlock'); +use_ok('POE::Filter::Line'); # Create a filter stack to test. @@ -51,6 +51,12 @@ my $block = $filter_stack->get( [ "test one (1)!test two (2)!" ] ); ok(!@$block, "partial get returned nothing"); +my $pending = $filter_stack->get_pending(); +is_deeply( + $pending, [ "(((test one (1))))" ], + "filter stack has correct get_pending" +); + $block = $filter_stack->get( [ "test three (3)!test four (100)!" ] ); is_deeply( $block, [ [ "(((test one (1))))", "(((test four (100))))" ] ], @@ -94,64 +100,79 @@ my $map_next = $map->get_one(); ok(!@$map_next, "nothing left to get from map filter"); -# Grep +### Go back and test more of Stackable. -my $grep = POE::Filter::Grep->new( Code => sub { $_ & 1 } ); -$grep->get_one_start( [ @test_list ] ); +{ + my @filters_should_be = qw( Line Map Grep RecordBlock ); + my @filters_are = $filter_stack->filter_types(); + is_deeply(\@filters_are, \@filters_should_be, + "filter types stacked correctly"); -my $grep_pending = join '', @{$grep->get_pending()}; -ok($grep_pending eq '11235', "grep filter's parser buffer verifies"); - -foreach my $compare (@test_list) { - next unless $compare & 1; - my $next = $grep->get_one(); - is_deeply($next, [ $compare ], "grep filter get_one() returns [$compare]"); + my @filters_also_should_be = map { "POE::Filter::$_" } @filters_should_be; + my @filters_also_are = map { ref($_) } $filter_stack->filters(); + is_deeply(\@filters_also_are, \@filters_also_should_be, + "filters stacked correctly"); } -my $grep_next = $grep->get_one(); -ok(!@$grep_next, "nothing left to get from grep filter"); +# test pushing and popping +{ + my @filters_strlist = map { "$_" } $filter_stack->filters(); -### Go back and test more of Stackable. + my $filter_pop = $filter_stack->pop(); + ok( + ref($filter_pop) eq "POE::Filter::RecordBlock", + "popped the correct filter" + ); -my @filters_should_be = qw( Line Map Grep RecordBlock ); + my $filter_shift = $filter_stack->shift(); + ok( + ref($filter_shift) eq 'POE::Filter::Line', + "shifted the correct filter" + ); -my $filters_are = join ' --- ', $filter_stack->filter_types(); -my $filters_test = join ' --- ', @filters_should_be; + $filter_stack->push( $filter_pop ); + $filter_stack->unshift( $filter_shift ); -ok($filters_test eq $filters_are, "filter types stacked correctly"); + my @filters_strlist_end = map { "$_" } $filter_stack->filters(); + is_deeply(\@filters_strlist_end, \@filters_strlist, + "repushed, reshifted filters are in original order"); +} -my $filters_also_are = ( - join ' --- ', map { ref($_) } $filter_stack->filters() -); -my $filters_also_test = ( - join ' --- ', map { 'POE::Filter::' . $_ } @filters_should_be -); +# push error checking +{ + my @filters_strlist = map { "$_" } $filter_stack->filters(); -ok( - $filters_also_test eq $filters_also_are, - "filters stacked correctly" -); + eval { $filter_stack->push(undef) }; + ok(!!$@, "undef is not a filter"); -my $filter_pop = $filter_stack->pop(); -ok( - ref($filter_pop) eq "POE::Filter::RecordBlock", - "popped the correct filter" -); + eval { $filter_stack->push(['i am not a filter']) }; + ok(!!$@, "bare references are not filters"); -my $filter_shift = $filter_stack->shift(); -ok( - ref($filter_shift) eq 'POE::Filter::Line', - "shifted the correct filter" -); + eval { $filter_stack->push(bless(['i am not a filter'], "foo$$")) }; + ok(!!$@, "random blessed references are not filters"); + # not blessed into a package that ISA POE::Filter -$filter_stack->push( $filter_pop ); -$filter_stack->unshift( $filter_shift ); + eval { $filter_stack->push(123, "two not-filter things") }; + ok(!!$@, "multiple non-filters are not filters"); -my $filters_are_again = join ' --- ', $filter_stack->filter_types(); + my @filters_strlist_end = map { "$_" } $filter_stack->filters(); + is_deeply(\@filters_strlist_end, \@filters_strlist, + "filters unchanged despite errors"); +} -ok( - $filters_test eq $filters_are_again, - "repushed, reshifted filters are in order" -); +# test cloning +{ + my @filters_strlist = map { "$_" } $filter_stack->filters(); + my @filter_types = $filter_stack->filter_types(); + my $new_stack = $filter_stack->clone(); + + isnt("$new_stack", "$filter_stack", "cloned stack is different"); + isnt(join('---', @filters_strlist), + join('---', $new_stack->filters()), + "filters are different"); + is_deeply(\@filter_types, [$new_stack->filter_types()], + "but types are the same"); +} + exit 0; Added: trunk/poe/tests/10_units/05_filters/TestFilter.pm =================================================================== --- trunk/poe/tests/10_units/05_filters/TestFilter.pm (rev 0) +++ trunk/poe/tests/10_units/05_filters/TestFilter.pm 2006-06-25 12:39:03 UTC (rev 2001) @@ -0,0 +1,87 @@ +# filter testing utility functions +package TestFilter; + +use strict; +use Exporter; +use vars qw(@ISA @EXPORT $COUNT_FILTER_INTERFACE $COUNT_FILTER_STANDARD); +use Test::More; + +@ISA = qw/Exporter/; +@EXPORT = qw/ + $COUNT_FILTER_INTERFACE test_filter_interface + $COUNT_FILTER_STANDARD test_filter_standard +/; + +## each of these needs the number of subtests documented +## export this in a variable + +# check interface exists +$COUNT_FILTER_INTERFACE = 8; +sub test_filter_interface { + my $class = ref $_[0] || $_[0]; + + ok(UNIVERSAL::isa($class, 'POE::Filter'), '$class isa POE::Filter'); + can_ok($class, 'new'); + can_ok($class, 'get'); + can_ok($class, 'get_one_start'); + can_ok($class, 'get_one'); + can_ok($class, 'put'); + can_ok($class, 'get_pending'); + can_ok($class, 'clone'); +} + +# given a input, and the expected output run it through the filter in a few ways +$COUNT_FILTER_STANDARD = 7; +sub test_filter_standard { + my ($filter, $in, $out, $put) = @_; + + { # first using get() + my $records = $filter->get($in); + is_deeply($records, $out, "get [standard test]"); + } + + # now clone the filter which will clear the buffer + { + my $type = ref($filter); + $filter = $filter->clone; + ok(!defined($filter->get_pending()), + "clone() clears buffer [standard test]"); + is(ref($filter), $type, + "clone() doesn't change filter type [standard test]"); + } + + { # second using get_one() + $filter->get_one_start($in); + { + my $pending = $filter->get_pending(); + unless (ref($pending) eq 'ARRAY') { + fail("get_pending() didn't return array"); + } else { + is(join('', @$pending), join('', @$in), + "get_one_start() only loads buffer [standard test]"); + } + } + + my @records; + my $ret_arrayref = 1; + GET_ONE: while (my $r = $filter->get_one()) { + unless (ref($r) eq 'ARRAY') { + $ret_arrayref = 0; + last GET_ONE; + } + + last GET_ONE unless @{$r}; + push @records, @{$r}; + } + + ok($ret_arrayref, "get_one returns arrayref [standard test]"); + is_deeply(\@records, $out, "get_one [standard test]"); + } + + { # third using put() + my $chunks = $filter->put($out); + is_deeply($chunks, $put, "put [standard test]"); + } +} + +1; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-08-06 23:18:06
|
Revision: 2024 Author: rcaputo Date: 2006-08-06 16:16:42 -0700 (Sun, 06 Aug 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=2024&view=rev Log Message: ----------- Add a test for Randal Schwartz's bug, rt.cpan.org ticket 19908. Also add Id tag expansion to some irrelevant files. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/tests/90_regression/rt19908-merlyn-stop.t Property Changed: ---------------- trunk/poe/tests/30_loops/00_base/sbk_signal_init.pm trunk/poe/tests/90_regression/immute-server-tcp-filter.t trunk/poe/tests/90_regression/rt14444-arg1.t Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-08-06 23:00:53 UTC (rev 2023) +++ trunk/poe/MANIFEST 2006-08-06 23:16:42 UTC (rev 2024) @@ -161,6 +161,7 @@ tests/90_regression/neyuki_detach.t tests/90_regression/rt14444-arg1.t tests/90_regression/rt1648-tied-stderr.t +tests/90_regression/rt19908-merlyn-stop.t tests/90_regression/steinert-passed-wheel.t tests/90_regression/steinert-recursive-signal.t tests/90_regression/steinert-signal-integrity.t Property changes on: trunk/poe/tests/30_loops/00_base/sbk_signal_init.pm ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Property changes on: trunk/poe/tests/90_regression/immute-server-tcp-filter.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Property changes on: trunk/poe/tests/90_regression/rt14444-arg1.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Added: trunk/poe/tests/90_regression/rt19908-merlyn-stop.t =================================================================== --- trunk/poe/tests/90_regression/rt19908-merlyn-stop.t (rev 0) +++ trunk/poe/tests/90_regression/rt19908-merlyn-stop.t 2006-08-06 23:16:42 UTC (rev 2024) @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w +# $Id$ +# vim: filetype=perl + +# Randal Schwartz reported that die() within _stop causes an infinite +# loop. He's right. This tests rt.cpan.org ticket 19908. + +use POE; +use Test::More tests => 2; + +$SIG{ALRM} = sub { exit }; +alarm(5); + +POE::Session->create( + inline_states => { + _start => sub { + pass("started"); + }, + _stop => sub { + die "stop"; + }, + } +); + +POE::Kernel->run(); +pass("stopped"); Property changes on: trunk/poe/tests/90_regression/rt19908-merlyn-stop.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-08-20 06:37:05
|
Revision: 2055 Author: rcaputo Date: 2006-08-19 23:36:57 -0700 (Sat, 19 Aug 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=2055&view=rev Log Message: ----------- Add Yuval Kogman's test case for edge conditions in rethrowing die() and restarting POE::Kernel's run() loop. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-08-20 06:35:45 UTC (rev 2054) +++ trunk/poe/MANIFEST 2006-08-20 06:36:57 UTC (rev 2055) @@ -140,6 +140,7 @@ tests/30_loops/00_base/k_detach.pm tests/30_loops/00_base/k_selects.pm tests/30_loops/00_base/k_signals.pm +tests/30_loops/00_base/k_signals_rerun.pm tests/30_loops/00_base/sbk_signal_init.pm tests/30_loops/00_base/ses_nfa.pm tests/30_loops/00_base/ses_session.pm Added: trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm (rev 0) +++ trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm 2006-08-20 06:36:57 UTC (rev 2055) @@ -0,0 +1,91 @@ +# $Id$ +# vim: filetype=perl + +use warnings; +use strict; + +# Yuval Kogman's test case for edge issues with rethrowing unhandled +# die() exceptions and re-calling run() after it's returned due to +# such exceptions. + +use Test::More tests => 9; + +sub POE::Kernel::ASSERT_DEFAULT () { 1 } +use POE qw/Wheel::Run/; + +foreach my $die_on_bad_exit ( 0, 1 ) { + foreach my $exit ( 0, 1, 0, 0 ) { + POE::Session->create( + inline_states => { + _start => sub { + POE::Session->create( + inline_states => { + _start => sub { + my ( $kernel, $session, $heap ) = @_[KERNEL, SESSION, HEAP]; + + $kernel->sig( CHLD => "sigchld_handler" ); + + my $wheel = POE::Wheel::Run->new( + Program => $heap->{program}, + StdinEvent => "stdin", + StdoutEvent => "stdout", + ); + + $heap->{pid_to_wheel}->{ $wheel->PID } = $wheel; + $heap->{id_to_wheel}->{ $wheel->ID } = $wheel; + + $kernel->refcount_increment( + $session->ID, "running_processes" + ); + }, + sigchld_handler => sub { + my ( $kernel, $session, $heap, $pid, $child_error ) = @_[ + KERNEL, SESSION, HEAP, ARG1, ARG2 + ]; + return unless exists $heap->{pid_to_wheel}{$pid}; + + $kernel->refcount_decrement( + $session->ID, "running_processes" + ); + + my $wheel = delete $heap->{pid_to_wheel}{$pid}; + delete $heap->{id_to_wheel}{ $wheel->ID }; + $kernel->sig( CHLD => undef ); + + $heap->{program_exit} = $child_error; + }, + _stop => sub { + my ( $heap ) = $_[HEAP]; + + if ( scalar keys %{ $heap->{pid_to_wheel} } ) { + die "AAAAAAAHHH Running process leak!"; + } + + die "bad exit\n" if $die_on_bad_exit and ( + $heap->{program_exit} >> 8 + ) != 0; + } + }, + heap => { program => sub { exit $exit } }, + ); + }, + _stop => sub { }, + _child => sub { }, + }, + ); + + eval { POE::Kernel->run }; + + if ( $die_on_bad_exit and $exit ) { + ok( $@, "($die_on_bad_exit-$exit) died with bad exit code" ); + is( $@, "bad exit\n", "($die_on_bad_exit-$exit) error is correct" ); + } + else { + ok( + !$@, "($die_on_bad_exit-$exit) no error when process exited OK" + ) or diag($@); + } + } +} + +1; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-08-21 06:28:15
|
Revision: 2059 Author: rcaputo Date: 2006-08-20 23:28:01 -0700 (Sun, 20 Aug 2006) ViewCVS: http://svn.sourceforge.net/poe/?rev=2059&view=rev Log Message: ----------- Add a test case (and fix) for a session garbage collection timing issue discoverd by Yuval Kogman. Incrementing and then decrementing an extra reference count could prematurely trigger a session's destruction. Now checks are in place to make sure it can't. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/lib/POE/Kernel.pm trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm Added Paths: ----------- trunk/poe/tests/20_resources/00_base/extrefs_gc.pm Property Changed: ---------------- trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-08-21 06:25:50 UTC (rev 2058) +++ trunk/poe/MANIFEST 2006-08-21 06:28:01 UTC (rev 2059) @@ -127,6 +127,7 @@ tests/20_resources/00_base/controls.pm tests/20_resources/00_base/events.pm tests/20_resources/00_base/extrefs.pm +tests/20_resources/00_base/extrefs_gc.pm tests/20_resources/00_base/filehandles.pm tests/20_resources/00_base/sessions.pm tests/20_resources/00_base/sids.pm Modified: trunk/poe/lib/POE/Kernel.pm =================================================================== --- trunk/poe/lib/POE/Kernel.pm 2006-08-21 06:25:50 UTC (rev 2058) +++ trunk/poe/lib/POE/Kernel.pm 2006-08-21 06:28:01 UTC (rev 2059) @@ -2453,9 +2453,17 @@ } my $refcount = $self->_data_extref_dec($session, $tag); - $self->_data_ses_collect_garbage($session); - # trace it here + # We don't need to garbage-test the decremented session if the + # reference count is nonzero. Likewise, we don't need to GC it if + # it's the current session under the assumption that it will be GC + # tested when the current event dispatch is through. + + if ( !$refcount and $kr_active_session->ID ne $session_id ) { + $self->_data_ses_collect_garbage($session); + } + + # -><- trace it here return $refcount; } Added: trunk/poe/tests/20_resources/00_base/extrefs_gc.pm =================================================================== --- trunk/poe/tests/20_resources/00_base/extrefs_gc.pm (rev 0) +++ trunk/poe/tests/20_resources/00_base/extrefs_gc.pm 2006-08-21 06:28:01 UTC (rev 2059) @@ -0,0 +1,86 @@ +# $Id$ +# vim: filetype=perl + +# Test a case that Yuval Kogman ran into. Decrementing a reference +# count would immediately trigger a GC test. During _start, that +# means a session might be GC'd before _start's handler returned. +# Fatal hilarity would ensue. + +use warnings; +use strict; + +use Test::More tests => 5; + +sub POE::Kernel::ASSERT_DEFAULT () { 1 } +use POE; + +my $sigidle = 0; + +# The "bystander" session is kept alive solely by its extra reference +# count. It should be stopped when the "refcount" session destructs. +# This is determined by comparing the _stop time vs. SIGIDLE delivery. +# If _stop is first, then the bystander was reaped correctly. + +my $bystander_id = POE::Session->create( + inline_states => { + _start => sub { + $_[KERNEL]->refcount_increment( $_[SESSION]->ID, "just hold me"); + }, + _stop => sub { + ok( + !$sigidle, + "bystander stopped before sigidle" + ); + }, + }, +)->ID; + +# The "sigidle" session watches for SIGIDLE and sets a flag. If the +# bystander is reaped after SIGIDLE, it means that the refcount +# session did not trigger its destruction. + +POE::Session->create( + inline_states => { + _start => sub { + $_[KERNEL]->sig( IDLE => 'got_sigidle' ); + }, + got_sigidle => sub { + $sigidle++; + pass("got sigidle"); + }, + _stop => sub { + pass("sigidle session is allowed to stop"); + }, + }, +); + +# The "refcount" session attempts to trigger its own untimely +# destruction by incrementing and decrementing a reference count. If +# it succeeds in killing itself off early, then its "do_something" +# event will cause a fatal runtime error when ASSERT_DEFAULT is on. +# +# As part of _stop, it decrements the extra reference on the bystander +# session, triggering its destruction before SIGIDLE. If there's a +# problem, SIGIDLE will arrive first---because POE::Kernel has a +# refcount of 0 but the session still exists. + +POE::Session->create( + inline_states => { + _start => sub { + $_[KERNEL]->refcount_increment($_[SESSION]->ID, "just hold me"); + $_[KERNEL]->refcount_decrement($_[SESSION]->ID, "just hold me"); + $_[KERNEL]->yield("do_something"); + }, + do_something => sub { + pass("refcount session is allowed to run"); + }, + _stop => sub { + pass("refcount session is allowed to stop"); + $_[KERNEL]->refcount_decrement($bystander_id, "just hold me"); + }, + }, +); + +POE::Kernel->run(); + +1; Property changes on: trunk/poe/tests/20_resources/00_base/extrefs_gc.pm ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Modified: trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm 2006-08-21 06:25:50 UTC (rev 2058) +++ trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm 2006-08-21 06:28:01 UTC (rev 2059) @@ -1,13 +1,13 @@ # $Id$ # vim: filetype=perl -use warnings; -use strict; - # Yuval Kogman's test case for edge issues with rethrowing unhandled # die() exceptions and re-calling run() after it's returned due to # such exceptions. +use warnings; +use strict; + use Test::More tests => 9; sub POE::Kernel::ASSERT_DEFAULT () { 1 } Property changes on: trunk/poe/tests/30_loops/00_base/k_signals_rerun.pm ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-08-31 01:13:34
|
Revision: 2078 http://svn.sourceforge.net/poe/?rev=2078&view=rev Author: rcaputo Date: 2006-08-30 18:12:47 -0700 (Wed, 30 Aug 2006) Log Message: ----------- Disallow users calling put() on a POE::Wheel::Run instance that has already had its STDIN handle closed. Modified Paths: -------------- trunk/poe/lib/POE/Wheel/Run.pm trunk/poe/tests/30_loops/00_base/wheel_run.pm Modified: trunk/poe/lib/POE/Wheel/Run.pm =================================================================== --- trunk/poe/lib/POE/Wheel/Run.pm 2006-08-28 19:09:00 UTC (rev 2077) +++ trunk/poe/lib/POE/Wheel/Run.pm 2006-08-31 01:12:47 UTC (rev 2078) @@ -907,6 +907,12 @@ sub put { my ($self, @chunks) = @_; + + # Avoid big bada boom if someone put()s on a dead wheel. + croak "Called put() on a wheel without an open STDIN handle" unless ( + $self->[HANDLE_STDIN] + ); + if ( $self->[OCTETS_STDIN] = # assignment on purpose $self->[DRIVER_STDIN]->put($self->[FILTER_STDIN]->put(\@chunks)) @@ -953,7 +959,11 @@ $poe_kernel->select_write($self->[HANDLE_STDIN], undef); eval { local $^W = 0; shutdown($self->[HANDLE_STDIN], 1) }; - close $self->[HANDLE_STDIN] if $@; + if ($@ or $self->[HANDLE_STDIN] != $self->[HANDLE_STDOUT]) { + close $self->[HANDLE_STDIN]; + } + + $self->[HANDLE_STDIN] = undef; } #------------------------------------------------------------------------------ Modified: trunk/poe/tests/30_loops/00_base/wheel_run.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/wheel_run.pm 2006-08-28 19:09:00 UTC (rev 2077) +++ trunk/poe/tests/30_loops/00_base/wheel_run.pm 2006-08-31 01:12:47 UTC (rev 2078) @@ -201,7 +201,7 @@ unless (ref $action) { DEBUG and warn "$heap->{label}: performing put state: $action"; - $heap->{wheel}->put( $action ); + eval { $heap->{wheel}->put( $action ) }; } elsif ($action->[0] =~ m/^(?:pause|resume)_std(?:out|err)$/) { my $method = $action->[0]; DEBUG and warn "$heap->{label}: performing method state: $method"; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-04 20:52:15
|
Revision: 2095 http://svn.sourceforge.net/poe/?rev=2095&view=rev Author: rcaputo Date: 2006-09-04 13:50:53 -0700 (Mon, 04 Sep 2006) Log Message: ----------- Instrument some code in POE's import, especially the code for explicit loop loading and its failure. Modified Paths: -------------- trunk/poe/lib/POE.pm Added Paths: ----------- trunk/poe/tests/10_units/03_base/15_explicit_loop.t trunk/poe/tests/10_units/03_base/16_explicit_loop_fail.t Modified: trunk/poe/lib/POE.pm =================================================================== --- trunk/poe/lib/POE.pm 2006-09-04 20:08:31 UTC (rev 2094) +++ trunk/poe/lib/POE.pm 2006-09-04 20:50:53 UTC (rev 2095) @@ -48,7 +48,7 @@ if ($@) { warn $@; push @failed, "Kernel" - }; + } } # Load all the others. Added: trunk/poe/tests/10_units/03_base/15_explicit_loop.t =================================================================== --- trunk/poe/tests/10_units/03_base/15_explicit_loop.t (rev 0) +++ trunk/poe/tests/10_units/03_base/15_explicit_loop.t 2006-09-04 20:50:53 UTC (rev 2095) @@ -0,0 +1,8 @@ +#!/usr/bin/perl -w +# $Id$ + +use strict; + +use Test::More tests => 1; +sub POE::Kernel::ASSERT_DEFAULT () { 1 } +BEGIN { use_ok("POE", "Loop::Select") } Added: trunk/poe/tests/10_units/03_base/16_explicit_loop_fail.t =================================================================== --- trunk/poe/tests/10_units/03_base/16_explicit_loop_fail.t (rev 0) +++ trunk/poe/tests/10_units/03_base/16_explicit_loop_fail.t 2006-09-04 20:50:53 UTC (rev 2095) @@ -0,0 +1,14 @@ +#!/usr/bin/perl -w +# $Id$ + +use strict; + +use Test::More tests => 1; +sub POE::Kernel::ASSERT_DEFAULT () { 1 } + +# Hide warnings. +{ + local $SIG{__WARN__} = sub { undef }; + eval "use POE qw(Loop::NightMooseDontExist)"; +} +ok($@, "loading a nonexistent loop throws an error"); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-04 21:19:07
|
Revision: 2097 http://svn.sourceforge.net/poe/?rev=2097&view=rev Author: rcaputo Date: 2006-09-04 14:17:47 -0700 (Mon, 04 Sep 2006) Log Message: ----------- Add two new tests to the manifest. Skip more coverage databases. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/MANIFEST.SKIP Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-09-04 21:15:33 UTC (rev 2096) +++ trunk/poe/MANIFEST 2006-09-04 21:17:47 UTC (rev 2097) @@ -106,7 +106,9 @@ tests/10_units/03_base/12_assert_retval.t tests/10_units/03_base/13_assert_data.t tests/10_units/03_base/14_kernel.t -tests/10_units/03_base/14_kernel_internal.t +tests/10_units/03_base/15_kernel_internal.t +tests/10_units/03_base/16_explicit_loop.t +tests/10_units/03_base/17_explicit_loop_fail.t tests/10_units/04_drivers/01_sysrw.t tests/10_units/05_filters/01_block.t tests/10_units/05_filters/02_grep.t Modified: trunk/poe/MANIFEST.SKIP =================================================================== --- trunk/poe/MANIFEST.SKIP 2006-09-04 21:15:33 UTC (rev 2096) +++ trunk/poe/MANIFEST.SKIP 2006-09-04 21:17:47 UTC (rev 2097) @@ -19,7 +19,7 @@ ^_build ^blib/ ^comptest -^cover_db/ +^cover_db ^coverage\.report$ ^docs ^pm_to_blib$ This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-05 03:19:17
|
Revision: 2102 http://svn.sourceforge.net/poe/?rev=2102&view=rev Author: rcaputo Date: 2006-09-04 20:19:08 -0700 (Mon, 04 Sep 2006) Log Message: ----------- Put the intrflush() call back, and skip all my shiny new tests because some Curses functions block terribly under unbuffered ptys. But they only do the blocking on some platforms. Grrrr. Modified Paths: -------------- trunk/poe/lib/POE/Wheel/Curses.pm trunk/poe/tests/30_loops/00_base/wheel_curses.pm Modified: trunk/poe/lib/POE/Wheel/Curses.pm =================================================================== --- trunk/poe/lib/POE/Wheel/Curses.pm 2006-09-05 02:48:00 UTC (rev 2101) +++ trunk/poe/lib/POE/Wheel/Curses.pm 2006-09-05 03:19:08 UTC (rev 2102) @@ -61,7 +61,7 @@ timeout(0); keypad(1); - # intrflush(0); + intrflush(0); meta(1); typeahead(-1); Modified: trunk/poe/tests/30_loops/00_base/wheel_curses.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/wheel_curses.pm 2006-09-05 02:48:00 UTC (rev 2101) +++ trunk/poe/tests/30_loops/00_base/wheel_curses.pm 2006-09-05 03:19:08 UTC (rev 2102) @@ -6,7 +6,6 @@ use strict; use lib qw(./mylib ../mylib); -sub DEBUG () { 0 } sub POE::Kernel::ASSERT_DEFAULT () { 1 } #sub POE::Kernel::TRACE_DEFAULT () { 1 } #sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } @@ -50,6 +49,7 @@ } BEGIN { + plan skip_all => "Need help with Curses functions blocking under ptys"; plan tests => 5; use_ok('POE'); use_ok('POE::Wheel::Curses'); @@ -111,8 +111,7 @@ $heap->{child_input} .= $input; if ($heap->{child_input} =~ /!/) { - close STDOUT; - delete $heap->{curses}; + delete $heap->{curses}; } delete $heap->{readwrite}; ok( $heap->{child_input} eq "this is a test!", "got keystrokes" ); } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bin...@us...> - 2006-09-05 14:19:08
|
Revision: 2106 http://svn.sourceforge.net/poe/?rev=2106&view=rev Author: bingosnet Date: 2006-09-05 07:18:29 -0700 (Tue, 05 Sep 2006) Log Message: ----------- Added pod tests, fixed pod errors and improved pod coverage. Set POE_TEST_POD env var to enable tests. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/lib/POE/Component/Client/TCP.pm trunk/poe/lib/POE/Component/Server/TCP.pm trunk/poe/lib/POE/Driver/SysRW.pm trunk/poe/lib/POE/Filter/Grep.pm trunk/poe/lib/POE/Filter/HTTPD.pm trunk/poe/lib/POE/Filter/Map.pm trunk/poe/lib/POE/Filter/RecordBlock.pm trunk/poe/lib/POE/Filter/Stackable.pm trunk/poe/lib/POE/Pipe/OneWay.pm trunk/poe/lib/POE/Pipe/TwoWay.pm trunk/poe/lib/POE/Resources.pm trunk/poe/lib/POE/Session.pm trunk/poe/lib/POE/Wheel/FollowTail.pm trunk/poe/lib/POE/Wheel/ListenAccept.pm trunk/poe/lib/POE/Wheel/ReadWrite.pm trunk/poe/lib/POE/Wheel/Run.pm trunk/poe/lib/POE/Wheel/SocketFactory.pm Added Paths: ----------- trunk/poe/tests/00_pod_tests/ trunk/poe/tests/00_pod_tests/01_pod.t trunk/poe/tests/00_pod_tests/02_pod_coverage.t Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/MANIFEST 2006-09-05 14:18:29 UTC (rev 2106) @@ -88,6 +88,8 @@ samples/watermarks.perl samples/wheels2.perl test.pl +tests/00_pod_tests/01_pod.t +tests/00_pod_tests/02_pod_coverage.t tests/10_units/02_pipes/01_base.t tests/10_units/02_pipes/02_oneway.t tests/10_units/02_pipes/03_twoway.t Modified: trunk/poe/lib/POE/Component/Client/TCP.pm =================================================================== --- trunk/poe/lib/POE/Component/Client/TCP.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Component/Client/TCP.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -451,10 +451,16 @@ =head1 Constructor Parameters +=over + +=item new + The new() method can accept quite a lot of parameters. It will return the session ID of the accecptor session. One must use callbacks to check for errors rather than the return value of new(). +=back + =over 2 =item Alias Modified: trunk/poe/lib/POE/Component/Server/TCP.pm =================================================================== --- trunk/poe/lib/POE/Component/Server/TCP.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Component/Server/TCP.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -630,6 +630,10 @@ =head1 CONSTRUCTOR PARAMETERS +=over + +=item new + The new() method can accept quite a lot of parameters. It will return the session ID of the accecptor session. One must use callbacks to check for errors rather than the return value of new(). @@ -637,6 +641,8 @@ POE::Component::Server::TCP supplies common defaults for most callbacks and handlers. +=back + =over 2 =item Acceptor => CODEREF Modified: trunk/poe/lib/POE/Driver/SysRW.pm =================================================================== --- trunk/poe/lib/POE/Driver/SysRW.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Driver/SysRW.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -210,6 +210,40 @@ my $driver = POE::Driver::SysRW->new; +=item get FILEHANDLE + +get() immediately tries to read information from a filehandle. It +returns a reference to an array containing whatever it managed to +read, or an empty array if nothing could be read. It returns undef on +error, and $! will be set. + +The arrayref get() returns is suitable for passing to any +POE::Filter's get() method. This is exactly what the ReadWrite wheel +does with it. + +=item put ARRAYREF + +put() places raw data chunks into the driver's output queue. it +accepts a reference to a list of raw data chunks, and it returns the +number of octets remaining in its output queue. + +Some drivers may flush data immediately from their put() methods. + +=item flush FILEHANDLE + +flush() attempts to flush some data from the driver's output queue to +the FILEHANDLE. It returns the number of octets remaining in the +output queue after the flush attempt. + +flush() does the physical write, counterpoint to get's read. If +flush() fails for any reason, $! will be set with the reason for its +failure. Otherwise $! will be zero. + +=item get_out_messages_buffered + +This data accessor returns the number of messages in the driver's +output queue. Partial messages are counted as whole ones. + =back =head1 DESIGN NOTES Modified: trunk/poe/lib/POE/Filter/Grep.pm =================================================================== --- trunk/poe/lib/POE/Filter/Grep.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Filter/Grep.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -135,7 +135,7 @@ =over 4 -=item * +=item modify POE::Filter::Grep::modify Modified: trunk/poe/lib/POE/Filter/HTTPD.pm =================================================================== --- trunk/poe/lib/POE/Filter/HTTPD.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Filter/HTTPD.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -92,7 +92,7 @@ } return [ - $self->build_error( + $self->_build_error( RC_BAD_REQUEST, "Did not want any more data. Got this:" . "<p><pre>" . join("", @dump) . "</pre></p>" @@ -157,7 +157,7 @@ # Parse the request line. if ($buf !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { return [ - $self->build_error(RC_BAD_REQUEST, "Request line parse failure.") + $self->_build_error(RC_BAD_REQUEST, "Request line parse failure.") ]; } my $proto = $3 || "HTTP/0.9"; @@ -215,7 +215,7 @@ unless(defined $cl) { if($self->[CLIENT_PROTO] == 9) { return [ - $self->build_error( + $self->_build_error( RC_BAD_REQUEST, "POST request detected in an HTTP 0.9 transaction. " . "POST is not a valid HTTP 0.9 transaction type. " . @@ -232,14 +232,14 @@ } else { return [ - $self->build_error(RC_LENGTH_REQUIRED, "No content length found.") + $self->_build_error(RC_LENGTH_REQUIRED, "No content length found.") ]; } } unless ($cl =~ /^\d+$/) { return [ - $self->build_error( + $self->_build_error( RC_BAD_REQUEST, "Content length contains non-digits." ) @@ -321,7 +321,7 @@ # Build a basic response, given a status, a content type, and some # content. -sub build_basic_response { +sub _build_basic_response { my ($self, $content, $content_type, $status) = @_; # Need to check lengths in octets, not characters. @@ -339,14 +339,14 @@ return $response; } -sub build_error { +sub _build_error { my($self, $status, $details) = @_; $status ||= RC_BAD_REQUEST; $details ||= ''; my $message = status_message($status) || "Unknown Error"; - return $self->build_basic_response( + return $self->_build_basic_response( ( "<html>" . "<head>" . "<title>Error $status: $message</title>" . Modified: trunk/poe/lib/POE/Filter/Map.pm =================================================================== --- trunk/poe/lib/POE/Filter/Map.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Filter/Map.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -139,7 +139,7 @@ =over 4 -=item * +=item modify POE::Filter::Map::modify Modified: trunk/poe/lib/POE/Filter/RecordBlock.pm =================================================================== --- trunk/poe/lib/POE/Filter/RecordBlock.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Filter/RecordBlock.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -165,7 +165,7 @@ =over 4 -=item * +=item new POE::Filter::RecordBlock::new @@ -176,21 +176,21 @@ flushing pending records to be put is your responsibility (see put_pending()). -=item * +=item put_pending POE::Filter::RecordBlock::put_pending The put_pending() method returns an arrayref of any records that are waiting to be sent. -=item * +=item blocksize POE::Filter::RecordBlock::blocksize The blocksize() method takes one optional parameter, the new blocksize. It returns the current blocksize. -=item * +=item checkput POE::Filter::RecordBlock::checkput Modified: trunk/poe/lib/POE/Filter/Stackable.pm =================================================================== --- trunk/poe/lib/POE/Filter/Stackable.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Filter/Stackable.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -226,16 +226,17 @@ =over 4 -=item * +=item new -POE::Filter::Stackable::new( ... ) - The new() method creates the Stackable filter. It accepts an optional parameter "Filters" that specifies an arrayref of initial filters. If no filters are given, Stackable will pass data through unchanged; this is true if there are no filters present at any time. -=item * +=item pop +=item shift +=item push +=item unshift POE::Filter::Stackable::pop() POE::Filter::Stackable::shift() @@ -246,18 +247,14 @@ of the same name. push() and unshift() will return the new number of filters inside the Stackable filter. -=item * +=item filter_types -POE::Filter::Stackable::filter_types - The filter_types() method returns a list of types for the filters inside the Stackable filter, in order from near to far; for example, qw(Block HTTPD). -=item * +=item filters -POE::Filter::Stackable::filters - The filters() method returns a list of the objects inside the Stackable filter, in order from near to far. Modified: trunk/poe/lib/POE/Pipe/OneWay.pm =================================================================== --- trunk/poe/lib/POE/Pipe/OneWay.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Pipe/OneWay.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -165,6 +165,16 @@ And now you have a pipe with a read side and a write side. +=head1 CONSTRUCTOR + +=over + +=item new + + my ($read, $write) = POE::Pipe::OneWay->new(); + +=back + =head1 DEBUGGING It's possible to force POE::Pipe::OneWay to use one of its underlying Modified: trunk/poe/lib/POE/Pipe/TwoWay.pm =================================================================== --- trunk/poe/lib/POE/Pipe/TwoWay.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Pipe/TwoWay.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -185,6 +185,16 @@ B. Writing to C<$a_write> passes data to C<$b_read>, and writing to C<$b_write> passes data to C<$a_read>. +=head1 CONSTRUCTOR + +=over + +=item new + + my ($a_read, $a_write, $b_read, $b_write) = POE::Pipe::TwoWay->new(); + +=back + =head1 DEBUGGING It's possible to force POE::Pipe::TwoWay to use one of its underlying Modified: trunk/poe/lib/POE/Resources.pm =================================================================== --- trunk/poe/lib/POE/Resources.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Resources.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -53,6 +53,16 @@ For each resource type, initialize first tries to load C<POE::XS::Resource::*> and then falls back to C<POE::Resource::*>. +=head1 METHODS + +=over + +=item initialize + +Used internally by the kernel. + +=back + =head1 SEE ALSO L<POE::Resource> Modified: trunk/poe/lib/POE/Session.pm =================================================================== --- trunk/poe/lib/POE/Session.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Session.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -1657,6 +1657,8 @@ The signal handler will be passed a single argument, a hashref, containing the following data. +=over 2 + =item source_session The session from which the event originated @@ -1687,6 +1689,8 @@ The value of C<$@>, which contains the error string created by the exception. +=back + =head2 Session's Debugging Features POE::Session contains a two debugging assertions, for now. Modified: trunk/poe/lib/POE/Wheel/FollowTail.pm =================================================================== --- trunk/poe/lib/POE/Wheel/FollowTail.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Wheel/FollowTail.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -528,6 +528,16 @@ This is a read-only wheel so it does not include a put() method. +=head1 CONSTRUCTOR + +=over + +=item new + +new() creates a new wheel, returning the wheels reference. + +=back + =head1 PUBLIC METHODS =over 2 Modified: trunk/poe/lib/POE/Wheel/ListenAccept.pm =================================================================== --- trunk/poe/lib/POE/Wheel/ListenAccept.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Wheel/ListenAccept.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -162,6 +162,16 @@ This wheel neither needs nor includes a put() method. +=head1 CONSTRUCTOR + +=over + +=item new + +new() creates a new wheel, returning the wheels reference. + +=back + =head1 PUBLIC METHODS =over 2 Modified: trunk/poe/lib/POE/Wheel/ReadWrite.pm =================================================================== --- trunk/poe/lib/POE/Wheel/ReadWrite.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Wheel/ReadWrite.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -701,6 +701,16 @@ generates events for common file conditions, such as when data has been read or flushed. +=head1 CONSTRUCTOR + +=over + +=item new + +new() creates a new wheel, returning the wheels reference. + +=back + =head1 PUBLIC METHODS =over 2 @@ -795,6 +805,12 @@ they will continue. These methods map directly to shutdown() for the wheel's input and output sockets. +=item get_driver_out_octets + +=item get_driver_out_messages + +Return driver statistics. + =back =head1 EVENTS AND PARAMETERS Modified: trunk/poe/lib/POE/Wheel/Run.pm =================================================================== --- trunk/poe/lib/POE/Wheel/Run.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Wheel/Run.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -1453,6 +1453,12 @@ The kill() method will send SIGTERM if SIGNAL is undef or omitted. +=item get_driver_out_messages + +=item get_driver_out_octets + +Return driver statistics. + =back =head1 EVENTS AND PARAMETERS Modified: trunk/poe/lib/POE/Wheel/SocketFactory.pm =================================================================== --- trunk/poe/lib/POE/Wheel/SocketFactory.pm 2006-09-05 06:18:46 UTC (rev 2105) +++ trunk/poe/lib/POE/Wheel/SocketFactory.pm 2006-09-05 14:18:29 UTC (rev 2106) @@ -111,7 +111,7 @@ # Perform system-dependent translations on Unix addresses, if # necessary. -sub condition_unix_address { +sub _condition_unix_address { my ($address) = @_; # OS/2 would like sockets to use backwhacks, and please place them @@ -827,7 +827,7 @@ return $self; } - $bind_address = &condition_unix_address($params{BindAddress}); + $bind_address = &_condition_unix_address($params{BindAddress}); $bind_address = pack_sockaddr_un($bind_address); unless ($bind_address) { $poe_kernel->yield( @@ -954,7 +954,7 @@ # understands. elsif ($abstract_domain eq DOM_UNIX) { - $connect_address = condition_unix_address($params{RemoteAddress}); + $connect_address = _condition_unix_address($params{RemoteAddress}); $connect_address = pack_sockaddr_un($connect_address); unless (defined $connect_address) { $poe_kernel->yield( Added: trunk/poe/tests/00_pod_tests/01_pod.t =================================================================== --- trunk/poe/tests/00_pod_tests/01_pod.t (rev 0) +++ trunk/poe/tests/00_pod_tests/01_pod.t 2006-09-05 14:18:29 UTC (rev 2106) @@ -0,0 +1,5 @@ +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +plan skip_all => 'set POE_TEST_POD to enable this test' unless $ENV{POE_TEST_POD}; +all_pod_files_ok(); Added: trunk/poe/tests/00_pod_tests/02_pod_coverage.t =================================================================== --- trunk/poe/tests/00_pod_tests/02_pod_coverage.t (rev 0) +++ trunk/poe/tests/00_pod_tests/02_pod_coverage.t 2006-09-05 14:18:29 UTC (rev 2106) @@ -0,0 +1,38 @@ +use Test::More; +eval "use Test::Pod::Coverage 1.00"; +plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; +plan skip_all => 'set POE_TEST_POD to enable this test' unless $ENV{POE_TEST_POD}; + +# These are the default Pod::Coverage options. +my $default_opts = { also_private => [ qr/^[A-Z0-9_]+$/, ] }; + +# Special case modules. Only define modules here if you want to skip ( 0 ) or +# apply different Pod::Coverage options ( { } ). +my %special = ( 'POE' => 0, + #'POE::Kernel' => 0, + #'POE::Session' => 0, + 'POE::Pipe' => 0, + 'POE::Component' => 0, + 'POE::Loop' => 0, + 'POE::Resource' => 0, + 'POE::Wheel::ReadLine' => 0, +); + +my @modules = all_modules(); + +plan tests => scalar @modules; + +foreach my $module ( @modules ) { + my $opts = $default_opts; + if ( $module =~ /^POE::(Driver|Filter|Wheel|Queue)::/ ) { + $opts = { also_private => [ qr/^[A-Z0-9_]+$/, ], + coverage_class => 'Pod::Coverage::CountParents' }; + } + SKIP: { + if ( exists $special{$module} ) { + skip "$module", 1 unless $special{$module}; + $opts = $special{$module} if ref $special{$module} eq 'HASH'; + } + pod_coverage_ok( $module, $opts ); + } +} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-05 16:03:25
|
Revision: 2107 http://svn.sourceforge.net/poe/?rev=2107&view=rev Author: rcaputo Date: 2006-09-05 08:59:17 -0700 (Tue, 05 Sep 2006) Log Message: ----------- Move the POD tests to 10_units/01_pod. Modified Paths: -------------- trunk/poe/MANIFEST Added Paths: ----------- trunk/poe/tests/10_units/01_pod/ Removed Paths: ------------- trunk/poe/tests/00_pod_tests/ Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-09-05 14:18:29 UTC (rev 2106) +++ trunk/poe/MANIFEST 2006-09-05 15:59:17 UTC (rev 2107) @@ -88,8 +88,8 @@ samples/watermarks.perl samples/wheels2.perl test.pl -tests/00_pod_tests/01_pod.t -tests/00_pod_tests/02_pod_coverage.t +tests/10_units/01_pod/01_pod.t +tests/10_units/01_pod/02_pod_coverage.t tests/10_units/02_pipes/01_base.t tests/10_units/02_pipes/02_oneway.t tests/10_units/02_pipes/03_twoway.t Copied: trunk/poe/tests/10_units/01_pod (from rev 2106, trunk/poe/tests/00_pod_tests) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-08 02:51:59
|
Revision: 2113 http://svn.sourceforge.net/poe/?rev=2113&view=rev Author: rcaputo Date: 2006-09-07 19:51:51 -0700 (Thu, 07 Sep 2006) Log Message: ----------- Rename samples to examples. Added Paths: ----------- trunk/poe/examples/ Removed Paths: ------------- trunk/poe/samples/ Copied: trunk/poe/examples (from rev 2112, trunk/poe/samples) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-08 04:46:53
|
Revision: 2116 http://svn.sourceforge.net/poe/?rev=2116&view=rev Author: rcaputo Date: 2006-09-07 21:45:45 -0700 (Thu, 07 Sep 2006) Log Message: ----------- Updated Chris Williams' fine POD tests to more explicitly treat certain methods as private. Also added a "strict" mode that doesn't skip over the methods temporarily considered private while we figure out whether they should really be so. Also removed tabs while I was in there. Curse you, tabs! Removed new() methods from classes that are really uninstantiated mixins. Calling a nonexistent method is semantically about the same as calling a constructor that only exists to croak. Had to remove tests for the croaks as well. Documented select_pause_read() and select_resume_read(). Added leading underscores to a bunch of helper functions and methods that should really have been private. There are more to come, but their privacy status is less obvious. Modified Paths: -------------- trunk/poe/lib/POE/Component.pm trunk/poe/lib/POE/Kernel.pm trunk/poe/lib/POE/Loop.pm trunk/poe/lib/POE/NFA.pm trunk/poe/lib/POE/Pipe/OneWay.pm trunk/poe/lib/POE/Pipe/TwoWay.pm trunk/poe/lib/POE/Pipe.pm trunk/poe/lib/POE/Resource.pm trunk/poe/lib/POE/Session.pm trunk/poe/lib/POE/Wheel/ReadLine.pm trunk/poe/lib/POE.pm trunk/poe/tests/10_units/01_pod/01_pod.t trunk/poe/tests/10_units/01_pod/02_pod_coverage.t trunk/poe/tests/10_units/03_base/01_poe.t trunk/poe/tests/10_units/03_base/03_component.t trunk/poe/tests/10_units/03_base/06_loop.t trunk/poe/tests/10_units/03_base/08_resource.t Modified: trunk/poe/lib/POE/Component.pm =================================================================== --- trunk/poe/lib/POE/Component.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Component.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -8,13 +8,6 @@ use vars qw($VERSION); $VERSION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; -use Carp qw(croak); - -sub new { - my $type = shift; - croak "$type is not meant to be used directly"; -} - 1; __END__ Modified: trunk/poe/lib/POE/Kernel.pm =================================================================== --- trunk/poe/lib/POE/Kernel.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Kernel.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -62,7 +62,7 @@ unless (UNIVERSAL::can('POE::Kernel', 'poe_kernel_loop')) { $loop =~ s/^((POE::)?Loop::)?/POE::Loop::/ if defined $loop; - test_loop($loop); + _test_loop($loop); # Bootstrap the kernel. This is inherited from a time when multiple # kernels could be present in the same Perl process. POE::Kernel->new() if UNIVERSAL::can('POE::Kernel', 'poe_kernel_loop'); @@ -265,7 +265,7 @@ # Debugging and configuration constants. # Shorthand for defining a trace constant. -sub define_trace { +sub _define_trace { no strict 'refs'; foreach my $name (@_) { next if defined *{"TRACE_$name"}{CODE}; @@ -282,7 +282,7 @@ BEGIN { # Shorthand for defining an assert constant. - sub define_assert { + sub _define_assert { no strict 'refs'; foreach my $name (@_) { next if defined *{"ASSERT_$name"}{CODE}; @@ -329,7 +329,7 @@ defined &TRACE_DEFAULT or *TRACE_DEFAULT = sub () { 0 }; - define_trace qw( + _define_trace qw( EVENTS FILES PROFILE REFCNT RETVALS SESSIONS SIGNALS STATISTICS ); @@ -338,7 +338,7 @@ defined &ASSERT_DEFAULT or *ASSERT_DEFAULT = sub () { 0 }; - define_assert qw(DATA EVENTS FILES RETVALS USAGE); + _define_assert qw(DATA EVENTS FILES RETVALS USAGE); } # An "idle" POE::Kernel may still have events enqueued. These events @@ -462,7 +462,7 @@ #------------------------------------------------------------------------------ # Adapt POE::Kernel's personality to whichever event loop is present. -sub find_loop { +sub _find_loop { my ($mod) = @_; foreach my $dir (@INC) { @@ -471,7 +471,7 @@ return 0; } -sub load_loop { +sub _load_loop { my $loop = shift; *poe_kernel_loop = sub { return "$loop" }; @@ -491,14 +491,14 @@ } } -sub test_loop { +sub _test_loop { my $used_first = shift; local $SIG{__DIE__} = "DEFAULT"; # First see if someone wants to load a POE::Loop or XS version # explicitly. if (defined $used_first) { - load_loop($used_first); + _load_loop($used_first); return; } @@ -517,9 +517,9 @@ # Try for the XS version first. If it fails, try the plain # version. If that fails, we're up a creek. $module = "POE/XS/Loop/$module.pm"; - unless (find_loop($module)) { + unless (_find_loop($module)) { $module =~ s|XS/||; - next unless (find_loop($module)); + next unless (_find_loop($module)); } if (defined $used_first and $used_first ne $module) { @@ -541,14 +541,14 @@ # No loop found. Default to our internal select() loop. unless (defined $used_first) { $used_first = "POE/XS/Loop/Select.pm"; - unless (find_loop($used_first)) { + unless (_find_loop($used_first)) { $used_first =~ s/XS\///; } } substr($used_first, -3) = ""; $used_first =~ s|/|::|g; - load_loop($used_first); + _load_loop($used_first); } #------------------------------------------------------------------------------ @@ -1522,7 +1522,7 @@ return 1; } -### Helpful accessors. -><- Most of these are not documented. +### Helpful accessors. sub get_active_session { return $kr_active_session; @@ -1532,10 +1532,12 @@ return $kr_active_event; } +# FIXME - Should this exist? sub get_event_count { return $kr_queue->get_item_count(); } +# FIXME - Should this exist? sub get_next_event_time { return $kr_queue->get_next_priority(); } @@ -3445,17 +3447,29 @@ select_expedite() does not return a meaningful value. +=item select_pause_read FILE_HANDLE + +=item select_resume_read FILE_HANDLE + =item select_pause_write FILE_HANDLE =item select_resume_write FILE_HANDLE -select_pause_write() temporarily pauses event generation when a -FILE_HANDLE can be written to. select_resume_write() turns event -generation back on. +select_pause_read() and select_pause_write() temporarily pause events +that are generated when a FILE_HANDLE can be read from or written to, +respectively. -These functions are more efficient than select_write() because they -don't perform full resource management. +select_resume_read() and select_resume_write() turn events back on. +These functions are more efficient than select_read() and +select_write() because they don't perform full resource management +within POE::Kernel. + +Pause and resume a filehandle's readable events: + + $kernel->select_pause_read( $filehandle ); + $kernel->select_resume_read( $filehandle ); + Pause and resume a filehandle's writable events: $kernel->select_pause_write( $filehandle ); Modified: trunk/poe/lib/POE/Loop.pm =================================================================== --- trunk/poe/lib/POE/Loop.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Loop.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -7,13 +7,6 @@ use vars qw($VERSION); $VERSION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; -use Carp qw(croak); - -sub new { - my $type = shift; - croak "$type is a virtual base class and not meant to be used directly"; -} - 1; __END__ Modified: trunk/poe/lib/POE/NFA.pm =================================================================== --- trunk/poe/lib/POE/NFA.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/NFA.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -41,7 +41,8 @@ #------------------------------------------------------------------------------ # Shorthand for defining a trace constant. -sub define_trace { + +sub _define_trace { no strict 'refs'; foreach my $name (@_) { next if defined *{"TRACE_$name"}{CODE}; @@ -90,7 +91,7 @@ } }; - define_trace("DESTROY"); + _define_trace("DESTROY"); } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/Pipe/OneWay.pm =================================================================== --- trunk/poe/lib/POE/Pipe/OneWay.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Pipe/OneWay.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -34,10 +34,10 @@ if $self->_try_type($conduit_type, \$a_read, \$b_write); } - while (my $try_type = $self->get_next_preference()) { + while (my $try_type = $self->_get_next_preference()) { return ($a_read, $b_write) if $self->_try_type($try_type, \$a_read, \$b_write); - $self->shift_preference(); + $self->_shift_preference(); } # There's nothing left to try. @@ -103,7 +103,7 @@ # Try a pair of plain INET sockets. if ($type eq "inet") { eval { - ($$a_read, $$b_write) = $self->make_socket(); + ($$a_read, $$b_write) = $self->_make_socket(); }; if (length $@) { Modified: trunk/poe/lib/POE/Pipe/TwoWay.pm =================================================================== --- trunk/poe/lib/POE/Pipe/TwoWay.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Pipe/TwoWay.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -40,14 +40,14 @@ ); } - while (my $try_type = $self->get_next_preference()) { + while (my $try_type = $self->_get_next_preference()) { return ($a_read, $a_write, $b_read, $b_write) if $self->_try_type( $try_type, \$a_read, \$a_write, \$b_read, \$b_write ); - $self->shift_preference(); + $self->_shift_preference(); } # There's nothing left to try. @@ -117,7 +117,7 @@ # Try a pair of plain INET sockets. if ($type eq "inet") { eval { - ($$a_read, $$b_read) = $self->make_socket(); + ($$a_read, $$b_read) = $self->_make_socket(); }; # Sockets failed. Modified: trunk/poe/lib/POE/Pipe.pm =================================================================== --- trunk/poe/lib/POE/Pipe.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Pipe.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -50,11 +50,11 @@ @preference = qw(socketpair pipe inet); } -sub get_next_preference { +sub _get_next_preference { return $preference[0]; } -sub shift_preference { +sub _shift_preference { shift @preference; } @@ -150,7 +150,7 @@ # Make a socket. This is a homebrew socketpair() for systems that # don't support it. The things I must do to make Windows happy. -sub make_socket { +sub _make_socket { ### Server side. Modified: trunk/poe/lib/POE/Resource.pm =================================================================== --- trunk/poe/lib/POE/Resource.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Resource.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -5,13 +5,6 @@ use vars qw($VERSION); $VERSION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; -use Carp qw(croak); - -sub new { - my $type = shift; - croak "$type is a virtual base class and not meant to be used directly"; -} - 1; __END__ Modified: trunk/poe/lib/POE/Session.pm =================================================================== --- trunk/poe/lib/POE/Session.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Session.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -36,7 +36,8 @@ # here. # Shorthand for defining an assert constant. -sub define_assert { + +sub _define_assert { no strict 'refs'; foreach my $name (@_) { @@ -59,7 +60,7 @@ } # Shorthand for defining a trace constant. -sub define_trace { +sub _define_trace { no strict 'refs'; BEGIN { $^W = 0 }; @@ -109,8 +110,8 @@ } }; - define_assert("STATES"); - define_trace("DESTROY"); + _define_assert("STATES"); + _define_trace("DESTROY"); } #------------------------------------------------------------------------------ Modified: trunk/poe/lib/POE/Wheel/ReadLine.pm =================================================================== --- trunk/poe/lib/POE/Wheel/ReadLine.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE/Wheel/ReadLine.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -866,12 +866,12 @@ $self->[SELF_STATE_IDLE] = ( ref($self) . "(" . $self->[SELF_UNIQUE_ID] . ") -> input timeout" ); - $poe_kernel->state($self->[SELF_STATE_IDLE], $self, 'idle_state'); + $poe_kernel->state($self->[SELF_STATE_IDLE], $self, '_idle_state'); $self->[SELF_STATE_READ] = ( ref($self) . "(" . $self->[SELF_UNIQUE_ID] . ") -> select read" ); - $poe_kernel->state($self->[SELF_STATE_READ], $self, 'read_state'); + $poe_kernel->state($self->[SELF_STATE_READ], $self, '_read_state'); return $self; } @@ -916,7 +916,7 @@ # See the comments for &_define_read_state for more information about # these closure tricks. -sub idle_state { +sub _idle_state { my ($self) = $_[OBJECT]; if (@{$self->[SELF_PUT_BUFFER]}) { @@ -929,7 +929,7 @@ $self->[SELF_HAS_TIMER] = 0; } -sub read_state { +sub _read_state { my ($self, $k) = @_[OBJECT, KERNEL]; # Read keys, non-blocking, as long as there are some. Modified: trunk/poe/lib/POE.pm =================================================================== --- trunk/poe/lib/POE.pm 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/lib/POE.pm 2006-09-08 04:45:45 UTC (rev 2116) @@ -66,14 +66,6 @@ @failed and croak "could not import qw(" . join(' ', @failed) . ")"; } -#------------------------------------------------------------------------------ - -sub new { - my $type = shift; - croak "$type is not meant to be used directly"; -} - -#------------------------------------------------------------------------------ 1; __END__ Modified: trunk/poe/tests/10_units/01_pod/01_pod.t =================================================================== --- trunk/poe/tests/10_units/01_pod/01_pod.t 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/tests/10_units/01_pod/01_pod.t 2006-09-08 04:45:45 UTC (rev 2116) @@ -1,5 +1,9 @@ +# $Id$ +# vim: filetpe=perl + use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; -plan skip_all => 'set POE_TEST_POD to enable this test' unless $ENV{POE_TEST_POD}; +plan skip_all => 'set POE_TEST_POD or POE_TEST_POD_STRICT to enable this test' + unless $ENV{POE_TEST_POD} or $ENV{POE_TEST_POD_STRICT}; all_pod_files_ok(); Modified: trunk/poe/tests/10_units/01_pod/02_pod_coverage.t =================================================================== --- trunk/poe/tests/10_units/01_pod/02_pod_coverage.t 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/tests/10_units/01_pod/02_pod_coverage.t 2006-09-08 04:45:45 UTC (rev 2116) @@ -1,22 +1,82 @@ +# $Id$ +# vim: filetype=perl + use Test::More; eval "use Test::Pod::Coverage 1.00"; -plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; -plan skip_all => 'set POE_TEST_POD to enable this test' unless $ENV{POE_TEST_POD}; +plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" + if $@; +plan skip_all => 'set POE_TEST_POD or POE_TEST_POD_STRICT to enable this test' + unless $ENV{POE_TEST_POD} or $ENV{POE_TEST_POD_STRICT}; +my $strict = $ENV{POE_TEST_POD_STRICT}; + # These are the default Pod::Coverage options. -my $default_opts = { also_private => [ qr/^[A-Z0-9_]+$/, ] }; +my $default_opts = { + also_private => [ + qr/^[A-Z0-9_]+$/, # Constant subroutines. + ], +}; -# Special case modules. Only define modules here if you want to skip ( 0 ) or -# apply different Pod::Coverage options ( { } ). -my %special = ( 'POE' => 0, - #'POE::Kernel' => 0, - #'POE::Session' => 0, - 'POE::Pipe' => 0, - 'POE::Component' => 0, - 'POE::Loop' => 0, - 'POE::Resource' => 0, - 'POE::Wheel::ReadLine' => { also_private => [ qr/^[A-Z0-9_]+$/, qr/^rl_/, qr/^(idle_state|read_state|option|search)$/, ], - coverage_class => 'Pod::Coverage::CountParents' }, +# Special case modules. Only define modules here if you want to skip +# (0) or apply different Pod::Coverage options ({}). These options +# clobber $default_opts above, so be sure to duplicate the default +# options you want to keep. + +my %special = ( + 'POE::Kernel' => { + also_private => [ + qr/^[A-Z0-9_]+$/, + ( $strict + ? ( ) + : ( + 'finalize_kernel', # Should be _finalize_kernel. + 'get_event_count', # Should this exist? + 'get_next_event_time', # Should this exist? + 'new', # Definitely private. Necessary? + 'queue_peek_alarms', # Public or private? + 'session_alloc', # Should be documented. + ) + ) + ], + }, + 'POE::Session' => { + also_private => [ + qr/^[A-Z0-9_]+$/, + ( $strict + ? ( ) + : ( + 'register_state', # Should become _register_state. + 'instantiate', # Public or private? + 'try_alloc', # Public or private? + ) + ) + ], + }, + 'POE::NFA' => { + also_private => [ + qr/^[A-Z0-9_]+$/, + ( $strict + ? ( ) + : ( + 'register_state', # Should become _register_state. + ) + ) + ], + }, + 'POE::Wheel::ReadLine' => { + also_private => [ + qr/^[A-Z0-9_]+$/, # Constants subs. + qr/^rl_/, # Keystroke callbacks. + ( $strict + ? ( ) + : ( + 'option', # Should this be public or private? + 'search', # Should this be public or private? + ) + ) + ], + coverage_class => 'Pod::Coverage::CountParents' + }, ); my @modules = all_modules(); @@ -25,15 +85,19 @@ foreach my $module ( @modules ) { my $opts = $default_opts; - if ( $module =~ /^POE::(Driver|Filter|Wheel|Queue)::/ ) { - $opts = { also_private => [ qr/^[A-Z0-9_]+$/, ], - coverage_class => 'Pod::Coverage::CountParents' }; + + # Modules that inherit documentation from their parents. + if ( $module =~ /^POE::(Loop|Driver|Filter|Wheel|Queue)::/ ) { + $opts = { + %$default_opts, + coverage_class => 'Pod::Coverage::CountParents', + }; } SKIP: { - if ( exists $special{$module} ) { - skip "$module", 1 unless $special{$module}; - $opts = $special{$module} if ref $special{$module} eq 'HASH'; - } - pod_coverage_ok( $module, $opts ); + if ( exists $special{$module} ) { + skip "$module", 1 unless $special{$module}; + $opts = $special{$module} if ref $special{$module} eq 'HASH'; + } + pod_coverage_ok( $module, $opts ); } } Modified: trunk/poe/tests/10_units/03_base/01_poe.t =================================================================== --- trunk/poe/tests/10_units/03_base/01_poe.t 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/tests/10_units/03_base/01_poe.t 2006-09-08 04:45:45 UTC (rev 2116) @@ -1,16 +1,15 @@ #!/usr/bin/perl -w +# $Id$ +# vim: filetype=perl use strict; -use Test::More tests => 5; +use Test::More tests => 4; BEGIN { eval "use POE"; ok(!$@, "you just saved a kitten"); } # Start with errors. -eval { my $x = POE->new() }; -ok($@ && $@ =~ /not meant to be used directly/, "don't instantiate POE"); - eval { POE->import( qw( NFA Session ) ) }; ok( $@ && $@ =~ /export conflicting constants/, Modified: trunk/poe/tests/10_units/03_base/03_component.t =================================================================== --- trunk/poe/tests/10_units/03_base/03_component.t 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/tests/10_units/03_base/03_component.t 2006-09-08 04:45:45 UTC (rev 2116) @@ -1,15 +1,11 @@ #!/usr/bin/perl -w +# $Id$ +# vim: filetype=perl use strict; -use Test::More tests => 2; +use Test::More tests => 1; BEGIN { use_ok("POE::Component") } -eval { my $x = POE::Component->new() }; -ok( - $@ && $@ =~ /not meant to be used directly/, - "don't instantiate POE::Component" -); - exit 0; Modified: trunk/poe/tests/10_units/03_base/06_loop.t =================================================================== --- trunk/poe/tests/10_units/03_base/06_loop.t 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/tests/10_units/03_base/06_loop.t 2006-09-08 04:45:45 UTC (rev 2116) @@ -1,15 +1,11 @@ #!/usr/bin/perl -w +# $Id$ +# vim: filetype=perl use strict; -use Test::More tests => 2; +use Test::More tests => 1; BEGIN { use_ok("POE::Loop") } -eval { my $x = POE::Loop->new() }; -ok( - $@ && $@ =~ /not meant to be used directly/, - "don't instantiate POE::Loop" -); - exit 0; Modified: trunk/poe/tests/10_units/03_base/08_resource.t =================================================================== --- trunk/poe/tests/10_units/03_base/08_resource.t 2006-09-08 02:56:42 UTC (rev 2115) +++ trunk/poe/tests/10_units/03_base/08_resource.t 2006-09-08 04:45:45 UTC (rev 2116) @@ -1,15 +1,11 @@ #!/usr/bin/perl -w +# $Id$ +# vim: filetype=perl use strict; -use Test::More tests => 2; +use Test::More tests => 1; BEGIN { use_ok("POE::Resource") } -eval { my $x = POE::Resource->new() }; -ok( - $@ && $@ =~ /not meant to be used directly/, - "don't instantiate POE::Resource" -); - exit 0; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <lo...@us...> - 2006-09-08 20:28:27
|
Revision: 2122 http://svn.sourceforge.net/poe/?rev=2122&view=rev Author: lotr Date: 2006-09-08 13:28:16 -0700 (Fri, 08 Sep 2006) Log Message: ----------- document instantiate and try_alloc, and thus remove them from the exception list in tests/10_units/01_pod/02_pod_coverage.t Modified Paths: -------------- trunk/poe/lib/POE/Session.pm trunk/poe/tests/10_units/01_pod/02_pod_coverage.t Modified: trunk/poe/lib/POE/Session.pm =================================================================== --- trunk/poe/lib/POE/Session.pm 2006-09-08 16:23:04 UTC (rev 2121) +++ trunk/poe/lib/POE/Session.pm 2006-09-08 20:28:16 UTC (rev 2122) @@ -1237,6 +1237,51 @@ =back +=head2 Subclassing + +There are a few methods available to help people trying to subclass +L<POE::Session>. + +=over 2 + +=item instantiate + +When you want to subclass L<POE::Session>, you may want to allow for extra +parameters to be passed to the constructor, and maybe store some extra data +in the object structure. + +The easiest way to do this is by overriding the instantiate method, which +creates an empty object for you, and is passed a reference to the hash of +parameters passed to create(). + +When overriding it, be sure to first call the parent classes instantiate +method, so you have a reference to the empty object. Then you should remove +all the extra parameters from the hash of parameters you get passed, so +L<POE::Session>'s create() doesn't croak when it encounters parameters it +doesn't know. + +Also, don't forget to return the reference to the object (optionally already +filled with your data; try to keep out of the places where L<POE::Session> +stores its stuff, or it'll get overwritten) + +=item try_alloc + +At the end of L<POE::Session>'s create() method, try_alloc() is called. +This tells the POE Kernel to allocate an actual session with the object +just created. + +If you want to fiddle with the object the constructor just created, to +modify parameters that already exist in the base L<POE::Session> class, +based on your extra parameters for example, this is the place to do it. +override the try_alloc() method, do your evil, and end with calling +the parent try_alloc(), returning its return value. + +try_alloc() is passed the arguments for the _start state (the contents of +the listref passed in the 'args' parameter for create()). Make sure to pass +this on to the parent method (after maybe fiddling with that too). + +=back + =head1 PREDEFINED EVENT FIELDS Each session maintains its unique runtime context. Sessions pass @@ -1717,7 +1762,6 @@ =back - =head1 SEE ALSO POE::Kernel. Modified: trunk/poe/tests/10_units/01_pod/02_pod_coverage.t =================================================================== --- trunk/poe/tests/10_units/01_pod/02_pod_coverage.t 2006-09-08 16:23:04 UTC (rev 2121) +++ trunk/poe/tests/10_units/01_pod/02_pod_coverage.t 2006-09-08 20:28:16 UTC (rev 2122) @@ -46,8 +46,6 @@ ? ( ) : ( 'register_state', # Should become _register_state. - 'instantiate', # Public or private? - 'try_alloc', # Public or private? ) ) ], This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-10 16:15:10
|
Revision: 2123 http://svn.sourceforge.net/poe/?rev=2123&view=rev Author: rcaputo Date: 2006-09-10 09:11:58 -0700 (Sun, 10 Sep 2006) Log Message: ----------- Remove the sig() reference count. After this commit, registering a sig() handler will not be sufficient to keep a session alive. This reverses a design decision that was in place for about nine months. A subsequent release will reintroduce the feature, but hopefully in a way that doesn't break prior existing code. Modified Paths: -------------- trunk/poe/lib/POE/Kernel.pm trunk/poe/lib/POE/Resource/Sessions.pm trunk/poe/lib/POE/Resource/Signals.pm trunk/poe/lib/POE/Session.pm trunk/poe/tests/20_resources/00_base/extrefs_gc.pm Modified: trunk/poe/lib/POE/Kernel.pm =================================================================== --- trunk/poe/lib/POE/Kernel.pm 2006-09-08 20:28:16 UTC (rev 2122) +++ trunk/poe/lib/POE/Kernel.pm 2006-09-10 16:11:58 UTC (rev 2123) @@ -599,7 +599,6 @@ "<rc> | Files : ", $self->_data_handle_count(), "\n", "<rc> | Extra : ", $self->_data_extref_count(), "\n", "<rc> | Procs : ", $self->_data_sig_child_procs(), "\n", - "<rc> | Signals: ", $self->_data_sig_count(), "\n", "<rc> `---------------------------\n", "<rc> ..." ); @@ -609,8 +608,7 @@ $kr_queue->get_item_count() > $idle_queue_size or $self->_data_handle_count() or $self->_data_extref_count() or - $self->_data_sig_child_procs() or - $self->_data_sig_count() + $self->_data_sig_child_procs() ) { $self->_data_ev_enqueue( $self, $self, EN_SIGNAL, ET_SIGNAL, [ 'IDLE' ], Modified: trunk/poe/lib/POE/Resource/Sessions.pm =================================================================== --- trunk/poe/lib/POE/Resource/Sessions.pm 2006-09-08 20:28:16 UTC (rev 2122) +++ trunk/poe/lib/POE/Resource/Sessions.pm 2006-09-10 16:11:58 UTC (rev 2123) @@ -394,7 +394,6 @@ "<rc> | child sessions: ", scalar(keys(%{$ss->[SS_CHILDREN]})), "\n", "<rc> | handles in use: ", $self->_data_handle_count_ses($session), "\n", "<rc> | aliases in use: ", $self->_data_alias_count_ses($session), "\n", - "<rc> | sig watchers : ", $self->_data_sig_count_ses($session), "\n", "<rc> | extra refs : ", $self->_data_extref_count_ses($session), "\n", "<rc> +---------------------------------------------------\n", ); @@ -405,6 +404,7 @@ "<rc> +---------------------------------------------------\n", ); } + _carp "<rc> | called"; } if (ASSERT_DATA) { @@ -415,8 +415,7 @@ scalar(keys(%{$ss->[SS_CHILDREN]})) + $self->_data_handle_count_ses($session) + $self->_data_extref_count_ses($session) + - $self->_data_alias_count_ses($session) + - $self->_data_sig_count_ses($session) + $self->_data_alias_count_ses($session) ); # The calculated reference count really ought to match the one @@ -508,7 +507,7 @@ $self->_data_ses_free($session); # GC the parent, if there is one. - if (defined $parent) { + if (defined $parent and $parent != $self) { $self->_data_ses_collect_garbage($parent); } Modified: trunk/poe/lib/POE/Resource/Signals.pm =================================================================== --- trunk/poe/lib/POE/Resource/Signals.pm 2006-09-08 20:28:16 UTC (rev 2122) +++ trunk/poe/lib/POE/Resource/Signals.pm 2006-09-10 16:11:58 UTC (rev 2123) @@ -165,48 +165,11 @@ return $finalized_ok; } -### Count the number of refcount slots used for a particular -### session in signal watchers. - -sub _data_sig_count_ses { - my ($self, $session) = @_; - - return 0 unless exists $kr_sessions_to_signals{$session}; - return scalar keys %{$kr_sessions_to_signals{$session}}; -} - -# Return a count of signals watched by sessions that aren't the -# Kernel. Also, don't count IDLE or ZOMBIE signals, otherwise a -# program watching for them will never receive them. -# -# TODO - This is slow, and it's called relatively often. We should -# maintain a reference count as signals are added ard removed rather -# than recalculate the count each time. - -sub _data_sig_count { - my $signal_count; - foreach my $session (keys %kr_sessions_to_signals) { - next if $session eq $poe_kernel; - foreach my $signal (keys %{$kr_sessions_to_signals{$session}}) { - next if $signal eq "IDLE" or $signal eq "ZOMBIE"; - $signal_count++; - } - } - return $signal_count; -} - ### Add a signal to a session. sub _data_sig_add { my ($self, $session, $signal, $event) = @_; - unless ( - exists($kr_sessions_to_signals{$session}) and - exists($kr_sessions_to_signals{$session}->{$signal}) - ) { - $self->_data_ses_refcount_inc( $session ); - } - $kr_sessions_to_signals{$session}->{$signal} = $event; $kr_signals{$signal}->{$session} = $event; @@ -225,13 +188,6 @@ sub _data_sig_remove { my ($self, $session, $signal) = @_; - if ( - exists($kr_sessions_to_signals{$session}) and - exists($kr_sessions_to_signals{$session}->{$signal}) - ) { - $self->_data_ses_refcount_dec( $session ); - } - delete $kr_sessions_to_signals{$session}->{$signal}; delete $kr_sessions_to_signals{$session} unless keys(%{$kr_sessions_to_signals{$session}}); @@ -357,8 +313,12 @@ # -><- Implicit signal reaping. This is deprecated behavior and # will eventually be removed. See the commented out tests in # t/res/signals.t. + # + # Don't reap the parent if it's the kernel. It still needs to be + # a part of the system for finalization in certain cases. foreach my $touched_session (@kr_signaled_sessions) { next unless $self->_data_ses_exists($touched_session); + next if $touched_session == $self; $self->_data_ses_collect_garbage($touched_session); } } Modified: trunk/poe/lib/POE/Session.pm =================================================================== --- trunk/poe/lib/POE/Session.pm 2006-09-08 20:28:16 UTC (rev 2122) +++ trunk/poe/lib/POE/Session.pm 2006-09-10 16:11:58 UTC (rev 2123) @@ -1046,8 +1046,8 @@ The equivalent for create() is inline_states => { - event_one => \&state_one, - event_two => sub { ... }, + event_one => \&state_one, + event_two => sub { ... }, }, Object states were specified as object references mapped to list or Modified: trunk/poe/tests/20_resources/00_base/extrefs_gc.pm =================================================================== --- trunk/poe/tests/20_resources/00_base/extrefs_gc.pm 2006-09-08 20:28:16 UTC (rev 2122) +++ trunk/poe/tests/20_resources/00_base/extrefs_gc.pm 2006-09-10 16:11:58 UTC (rev 2123) @@ -43,6 +43,7 @@ inline_states => { _start => sub { $_[KERNEL]->sig( IDLE => 'got_sigidle' ); + $_[KERNEL]->alias_set("stayin_alive"); }, got_sigidle => sub { $sigidle++; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <rc...@us...> - 2006-09-16 05:34:14
|
Revision: 2126 http://svn.sourceforge.net/poe/?rev=2126&view=rev Author: rcaputo Date: 2006-09-15 22:33:53 -0700 (Fri, 15 Sep 2006) Log Message: ----------- Added sig_chlid(), test case, and documentation. Resolves rt.cpan.org 18392. Collateral damage: POE::Loop::Event's signal handler callbacks have been replaced by POE::Loop::PerlSignals. Also added keyword expansion metadata to various files that need it. Modified Paths: -------------- trunk/poe/MANIFEST trunk/poe/lib/POE/Kernel.pm trunk/poe/lib/POE/Loop/Event.pm trunk/poe/lib/POE/Resource/Sessions.pm trunk/poe/lib/POE/Resource/Signals.pm trunk/poe/tests/30_loops/00_base/wheel_curses.pm Added Paths: ----------- trunk/poe/tests/30_loops/00_base/k_sig_child.pm Property Changed: ---------------- trunk/poe/tests/10_units/01_pod/01_pod.t trunk/poe/tests/10_units/01_pod/02_pod_coverage.t trunk/poe/tests/10_units/03_base/16_explicit_loop.t trunk/poe/tests/10_units/03_base/17_explicit_loop_fail.t trunk/poe/tests/30_loops/00_base/wheel_curses.pm trunk/poe/tests/30_loops/00_base/wheel_readline.pm Modified: trunk/poe/MANIFEST =================================================================== --- trunk/poe/MANIFEST 2006-09-14 00:45:24 UTC (rev 2125) +++ trunk/poe/MANIFEST 2006-09-16 05:33:53 UTC (rev 2126) @@ -145,6 +145,7 @@ tests/30_loops/00_base/k_aliases.pm tests/30_loops/00_base/k_detach.pm tests/30_loops/00_base/k_selects.pm +tests/30_loops/00_base/k_sig_child.pm tests/30_loops/00_base/k_signals.pm tests/30_loops/00_base/k_signals_rerun.pm tests/30_loops/00_base/sbk_signal_init.pm Modified: trunk/poe/lib/POE/Kernel.pm =================================================================== --- trunk/poe/lib/POE/Kernel.pm 2006-09-14 00:45:24 UTC (rev 2125) +++ trunk/poe/lib/POE/Kernel.pm 2006-09-16 05:33:53 UTC (rev 2126) @@ -157,6 +157,7 @@ sub KR_SIZE () { 10 } # XXX UNUSED ??? sub KR_RUN () { 11 } # \$kr_run_warning sub KR_ACTIVE_EVENT () { 12 } # \$kr_active_event +sub KR_PIDS () { 13 } # \%kr_pids_to_events # ] # This flag indicates that POE::Kernel's run() method was called. @@ -216,6 +217,7 @@ sub ET_ALARM () { 0x0200 } # Alarm events. sub ET_SELECT () { 0x0400 } # File activity events. sub ET_STAT () { 0x0800 } # Statistics gathering +sub ET_SIGCLD () { 0x1000 } # sig_child() events. # A mask for all events generated by/for users. sub ET_MASK_USER () { ~(ET_GC | ET_SCPOLL | ET_STAT) } @@ -732,7 +734,29 @@ $self->loop_attach_uidestroy($window); } +# Handle child PIDs being reaped. Added 2006-09-15. +sub sig_child { + my ($self, $pid, $event_name) = @_; + + if (ASSERT_USAGE) { + _confess "<us> must call sig_chld() from a running session" + if $kr_active_session == $self; + _confess "<us> undefined process ID in sig_chld()" unless defined $pid; + _carp( + "<us> The '$event_name' event is one of POE's own. Its " . + "effect cannot be achieved assigning it to a signal" + ) if defined($event_name) and exists($poes_own_events{$event_name}); + }; + + if (defined $event_name) { + $self->_data_sig_pid_watch($kr_active_session, $pid, $event_name); + } + else { + $self->_data_sig_pid_ignore($kr_active_session, $pid); + } +} + #============================================================================== # KERNEL #============================================================================== @@ -3611,6 +3635,9 @@ operating system's name for it. This simplifies your code since you don't need to check for both. +The SIGCHLD/SIGCLD signal event is delivered to handlers registered by +both the sig() method and sig_child(). + The SIGCHLD/SIGCHLD signal event comes with three custom parameters. C<ARG0> contains 'CHLD', even if SIGCLD was caught. @@ -3668,6 +3695,25 @@ The sig() method does not return a meaningful value. +=item sig_child PID, EVENT_NAME + +=item sig_child PID + +sig_chld() is a convenient way to deliver an event (EVENT_NAME) with +some OPTIONAL_ARGS only when a child process specified by PID has been +reaped. Omit EVENT_NAME and OPTIONAL_ARGS to stop waiting for a given +PID. + +sig_child() differs from using sig() to handle CHLD: + +sig_child() notifies a session when a particular process ID has been +reaped. sig(CHLD, EVENT) notifies a session for every SIGCHLD +delivered regardless of the PID. + +sig_child() keeps a session alive until the given PID has been reaped. +The watcher is automatically removed when the event for the given +process ID has been delivered. sig() does not keep a session alive. + =item sig_handled sig_handled() informs POE that a signal was handled. It is only Modified: trunk/poe/lib/POE/Loop/Event.pm =================================================================== --- trunk/poe/lib/POE/Loop/Event.pm 2006-09-14 00:45:24 UTC (rev 2125) +++ trunk/poe/lib/POE/Loop/Event.pm 2006-09-16 05:33:53 UTC (rev 2126) @@ -7,6 +7,10 @@ use strict; +# Include common signal handling. Signals should be safe now, and for +# some reason Event isn't dispatching SIGCHLD to me circa POE r2084. +use POE::Loop::PerlSignals; + use vars qw($VERSION); $VERSION = do {my($r)=(q$Revision$=~/(\d+)/);sprintf"1.%04d",$r}; @@ -43,100 +47,12 @@ } } - foreach my $signal (keys %signal_watcher) { - $self->loop_ignore_signal($signal); - } + $self->loop_ignore_all_signals(); } #------------------------------------------------------------------------------ -# Signal handlers/callbacks. - -sub _loop_signal_handler_generic { - if (TRACE_SIGNALS) { - POE::Kernel::_warn "<sg> Enqueuing generic SIG$_[0] event"; - } - - $poe_kernel->_data_ev_enqueue( - $poe_kernel, $poe_kernel, EN_SIGNAL, ET_SIGNAL, [ $_[0]->w->signal ], - __FILE__, __LINE__, undef, time(), - ); -} - -sub _loop_signal_handler_pipe { - if (TRACE_SIGNALS) { - POE::Kernel::_warn "<sg> Enqueuing PIPE-like SIG$_[0] event"; - } - - $poe_kernel->_data_ev_enqueue( - $poe_kernel->get_active_session(), $poe_kernel, - EN_SIGNAL, ET_SIGNAL, [ $_[0]->w->signal ], - __FILE__, __LINE__, undef, time(), - ); -} - -sub _loop_signal_handler_child { - if (TRACE_SIGNALS) { - POE::Kernel::_warn "<sg> Enqueuing CHLD-like SIG$_[0] event"; - } - - $poe_kernel->_idle_queue_grow(); - $poe_kernel->_data_ev_enqueue( - $poe_kernel, $poe_kernel, EN_SCPOLL, ET_SCPOLL, [ ], - __FILE__, __LINE__, undef, time(), - ); -} - -#------------------------------------------------------------------------------ # Signal handler maintenance functions. -sub loop_watch_signal { - my ($self, $signal) = @_; - - # Child process has stopped. We use Event's safe SIGCHLD handler. - if ($signal eq 'CHLD' or $signal eq 'CLD') { - $SIG{$signal} = "DEFAULT"; - $signal_watcher{CHLD} = Event->signal( - signal => $signal, - cb => \&_loop_signal_handler_child - ); - return; - } - - # Broken pipe. - if ($signal eq 'PIPE') { - $SIG{$signal} = "DEFAULT"; - $signal_watcher{$signal} = Event->signal( - signal => $signal, - cb => \&_loop_signal_handler_pipe - ); - return; - } - - # Event doesn't like watching nonmaskable signals. - return if $signal eq 'KILL' or $signal eq 'STOP'; - - # Everything else. - $signal_watcher{$signal} = Event->signal( - signal => $signal, - cb => \&_loop_signal_handler_generic - ); -} - -sub loop_ignore_signal { - my ($self, $signal) = @_; - - if (defined $signal_watcher{$signal}) { - $signal_watcher{$signal}->stop(); - delete $signal_watcher{$signal}; - } - - # Certain kinds of signals should be ignored by default. - if ($signal =~ /^(CH?LD|PIPE)$/) { - $SIG{$signal} = "IGNORE"; - return; - } -} - sub loop_attach_uidestroy { # does nothing } Modified: trunk/poe/lib/POE/Resource/Sessions.pm =================================================================== --- trunk/poe/lib/POE/Resource/Sessions.pm 2006-09-14 00:45:24 UTC (rev 2125) +++ trunk/poe/lib/POE/Resource/Sessions.pm 2006-09-16 05:33:53 UTC (rev 2126) @@ -395,6 +395,7 @@ "<rc> | handles in use: ", $self->_data_handle_count_ses($session), "\n", "<rc> | aliases in use: ", $self->_data_alias_count_ses($session), "\n", "<rc> | extra refs : ", $self->_data_extref_count_ses($session), "\n", + "<rc> | pid count : ", $self->_data_sig_pids_ses($session), "\n", "<rc> +---------------------------------------------------\n", ); unless ($ss->[SS_REFCOUNT]) { @@ -415,7 +416,8 @@ scalar(keys(%{$ss->[SS_CHILDREN]})) + $self->_data_handle_count_ses($session) + $self->_data_extref_count_ses($session) + - $self->_data_alias_count_ses($session) + $self->_data_alias_count_ses($session) + + $self->_data_sig_pids_ses($session) ); # The calculated reference count really ought to match the one Modified: trunk/poe/lib/POE/Resource/Signals.pm =================================================================== --- trunk/poe/lib/POE/Resource/Signals.pm 2006-09-14 00:45:24 UTC (rev 2125) +++ trunk/poe/lib/POE/Resource/Signals.pm 2006-09-16 05:33:53 UTC (rev 2126) @@ -32,6 +32,21 @@ # ..., # ); +my %kr_pids_to_events; +# { $pid => +# { $session => +# [ $blessed_session, # PID_SESSION +# $event_name, # PID_EVENT +# ] +# } +# } + +my %kr_sessions_to_pids; +# { $session => { $pid => 1 } } + +sub PID_SESSION () { 0 } +sub PID_EVENT () { 1 } + # Bookkeeping per dispatched signal. use vars ( @@ -55,6 +70,7 @@ sub _data_sig_preload { $poe_kernel->[KR_SIGNALS] = \%kr_signals; + $poe_kernel->[KR_PIDS] = \%kr_pids_to_events; } use POE::API::ResLoader \&_data_sig_preload; @@ -152,12 +168,26 @@ } } + while (my ($ses, $pid_rec) = each(%kr_sessions_to_pids)) { + $finalized_ok = 0; + my @pids = keys %$pid_rec; + _warn "!!! Leaked session to PID map: $ses -> (@pids)\n"; + } + + while (my ($pid, $ses_rec) = each(%kr_pids_to_events)) { + $finalized_ok = 0; + _warn "!!! Leaked PID to event map: $pid\n"; + while (my ($ses, $event_rec) = each %$ses_rec) { + _warn "!!!\t$ses -> $event_rec->[PID_EVENT]\n"; + } + } + %_safe_signals = (); unless (RUNNING_IN_HELL) { local $!; until ((my $pid = waitpid( -1, 0 )) == -1) { - _warn( "Child process PID:$pid reaped: $!\n" ) if ($pid); + _warn( "!!! Child process PID:$pid reaped: $!\n" ) if $pid; $finalized_ok = 0; } } @@ -171,18 +201,36 @@ my ($self, $session, $signal, $event) = @_; $kr_sessions_to_signals{$session}->{$signal} = $event; + $self->_data_sig_signal_watch($session, $signal); $kr_signals{$signal}->{$session} = $event; +} +sub _data_sig_signal_watch { + my ($self, $session, $signal) = @_; + # First session to watch the signal. # Ask the event loop to watch the signal. if ( - (keys %{$kr_signals{$signal}} == 1) and - (exists $_safe_signals{$signal}) + !exists($kr_signals{$signal}) and + exists($_safe_signals{$signal}) and + ($signal ne "CHLD" or !exists($kr_sessions_to_pids{$session})) ) { $self->loop_watch_signal($signal); } } +sub _data_sig_signal_ignore { + my ($self, $session, $signal) = @_; + + if ( + !exists($kr_signals{$signal}) and + exists($_safe_signals{$signal}) and + ($signal ne "CHLD" or !exists($kr_sessions_to_pids{$session})) + ) { + $self->loop_ignore_signal($signal); + } +} + ### Remove a signal from a session. sub _data_sig_remove { @@ -197,9 +245,7 @@ # Last watcher for that signal. Stop watching it internally. unless (keys %{$kr_signals{$signal}}) { delete $kr_signals{$signal}; - if (exists $_safe_signals{$signal}) { - $self->loop_ignore_signal($signal); - } + $self->_data_sig_signal_ignore($session, $signal); } } @@ -211,12 +257,63 @@ sub _data_sig_clear_session { my ($self, $session) = @_; - return unless exists $kr_sessions_to_signals{$session}; # avoid autoviv - foreach (keys %{$kr_sessions_to_signals{$session}}) { - $self->_data_sig_remove($session, $_); + + if (exists $kr_sessions_to_signals{$session}) { # avoid autoviv + foreach (keys %{$kr_sessions_to_signals{$session}}) { + $self->_data_sig_remove($session, $_); + } } + + if (exists $kr_sessions_to_pids{$session}) { # avoid autoviv + foreach (keys %{$kr_sessions_to_pids{$session}}) { + $self->_data_sig_pid_ignore($session, $_); + } + } } +### Watch and ignore PIDs. + +sub _data_sig_pid_watch { + my ($self, $session, $pid, $event) = @_; + + $kr_pids_to_events{$pid}{$session} = [ + $session, # PID_SESSION + $event, # PID_EVENT + ]; + + $self->_data_sig_signal_watch($session, "CHLD"); + + $kr_sessions_to_pids{$session}{$pid} = 1; + $self->_data_ses_refcount_inc($session); +} + +sub _data_sig_pid_ignore { + my ($self, $session, $pid) = @_; + + # Remove PID to event mapping. + + delete $kr_pids_to_events{$pid}{$session}; + delete $kr_pids_to_events{$pid} unless ( + keys %{$kr_pids_to_events{$pid}} + ); + + # Remove session to PID mapping. + + delete $kr_sessions_to_pids{$session}{$pid}; + unless (keys %{$kr_sessions_to_pids{$session}}) { + delete $kr_sessions_to_pids{$session}; + $self->_data_sig_signal_ignore($session, "CHLD"); + } + + $self->_data_ses_refcount_dec($session); +} + +sub _data_sig_pids_ses { + my ($self, $session) = @_; + return 0 unless exists $kr_sessions_to_pids{$session}; + return scalar keys %{$kr_sessions_to_pids{$session}}; +} + ### Return a signal's type, or SIGTYPE_BENIGN if it's not special. sub _data_sig_type { @@ -349,6 +446,7 @@ } sub _data_sig_cease_polling { + return if keys %kr_pids_to_events; $polling_for_signals = 0; } @@ -378,7 +476,6 @@ my $pid; while ($pid = waitpid(-1, WNOHANG)) { - # waitpid(2) returned a process ID. Emit an appropriate SIGCHLD # event and loop around again. @@ -389,6 +486,23 @@ _warn("<sg> POE::Kernel detected SIGCHLD (pid=$pid; exit=$?)"); } + # Check for explicit SIGCHLD watchers, and enqueue explicit + # events for them. + + if (exists $kr_pids_to_events{$pid}) { + my @sessions_to_clear; + while (my ($ses_key, $ses_rec) = each %{$kr_pids_to_events{$pid}}) { + $self->_data_ev_enqueue( + $ses_rec->[PID_SESSION], $self, $ses_rec->[PID_EVENT], ET_SIGCLD, + [ 'CHLD', $pid, $? ], + __FILE__, __LINE__, undef, time(), + ); + push @sessions_to_clear, $ses_rec->[PID_SESSION]; + } + $self->_data_sig_pid_ignore($_, $pid) foreach @sessions_to_clear; + } + + # Kick off a SIGCHLD cascade. $self->_data_ev_enqueue( $self, $self, EN_SIGNAL, ET_SIGNAL, [ 'CHLD', $pid, $? ], __FILE__, __LINE__, undef, time(), @@ -466,6 +580,7 @@ # Are there child processes worth waiting for? # We don't really care if we're not polling for signals. +# TODO - Will this change? sub _data_sig_child_procs { return unless $polling_for_signals; Property changes on: trunk/poe/tests/10_units/01_pod/01_pod.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Property changes on: trunk/poe/tests/10_units/01_pod/02_pod_coverage.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Property changes on: trunk/poe/tests/10_units/03_base/16_explicit_loop.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Property changes on: trunk/poe/tests/10_units/03_base/17_explicit_loop_fail.t ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Added: trunk/poe/tests/30_loops/00_base/k_sig_child.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/k_sig_child.pm (rev 0) +++ trunk/poe/tests/30_loops/00_base/k_sig_child.pm 2006-09-16 05:33:53 UTC (rev 2126) @@ -0,0 +1,211 @@ +#!/usr/bin/perl -w +# $Id$ + +# Tests various signals using POE's stock signal handlers. These are +# plain Perl signals, so mileage may vary. + +use strict; +use lib qw(./mylib ../mylib); + +use Test::More; + +sub POE::Kernel::ASSERT_DEFAULT () { 1 } +sub POE::Kernel::TRACE_DEFAULT () { 1 } +sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } + +# This is the number of processes to fork. Increase this number if +# your system can handle the resource use. Also try increasing it if +# you suspect a problem with POE's SIGCHLD handling. Be warned +# though: setting this too high can cause timing problems and test +# failures on some systems. + +my $fork_count; + +BEGIN { + # We can't "plan skip_all" because that calls exit(). And Tk will + # croak if you call BEGIN { exit() }. And that croak will cause + # this test to FAIL instead of skip. + + my $error; + if ($^O eq "MSWin32") { + $error = "$^O does not support signals"; + } + elsif ($^O eq "MacOS") { + $error = "$^O does not support fork"; + } + + if ($error) { + print "1..0 # Skip $error\n"; + CORE::exit(); + } + + $fork_count = 8; + plan tests => $fork_count + 7; +} + +BEGIN { use_ok("POE") } + +# Set up a second session that watches for child signals. This is ot +# test whether a session with only sig_child() stays alive because of +# the signals. + +POE::Session->create( + inline_states => { + _start => sub { $_[KERNEL]->alias_set("catcher") }, + catch => sub { + my ($kernel, $heap, $pid) = @_[KERNEL, HEAP, ARG0]; + $kernel->sig(CHLD => "got_sigchld"); + $kernel->sig_child($pid, "got_chld"); + $heap->{children}{$pid} = 1; + $heap->{watched}++; + }, + remove_alias => sub { $_[KERNEL]->alias_remove("catcher") }, + got_chld => sub { + my ($heap, $pid) = @_[HEAP, ARG1]; + ok(delete($heap->{children}{$pid}), "caught SIGCHLD for watched pid $pid"); + $heap->{caught}++; + }, + got_sigchld => sub { + $_[HEAP]->{caught_sigchld}++; + }, + _stop => sub { + my $heap = $_[HEAP]; + + ok( + $heap->{watched} == $heap->{caught}, + "expected $heap->{watched} reaped children, got $heap->{caught}" + ); + + ok( + $heap->{watched} == $heap->{caught_sigchld}, + "expected $heap->{watched} sig(CHLD), got $heap->{caught_sigchld}" + ); + + ok(!keys(%{$heap->{children}}), "all reaped children were watched"); + }, + }, +); + +# Set up a signal catching session. This test uses plain fork(2) and +# POE's $SIG{CHLD} handler. + +POE::Session->create( + inline_states => { + _start => sub { + my ($kernel, $heap) = @_[KERNEL, HEAP]; + + # Clear the status counters, and catch SIGCHLD. + + $heap->{forked} = $heap->{reaped} = 0; + + # Fork some child processes, all to exit at the same time. + + my $fork_start_time = time(); + + for (my $child = 0; $child < $fork_count; $child++) { + my $child_pid = fork; + + if (defined $child_pid) { + if ($child_pid) { + # Parent side keeps track of child IDs. + $heap->{forked}++; + $heap->{children}{$child_pid} = 1; + $kernel->sig_child($child_pid, "catch_sigchld"); + $kernel->post(catcher => catch => $child_pid); + } + else { + # Child side sleeps. With the fishes. + $SIG{INT} = 'DEFAULT'; + sleep 3600; + exit; + } + } + else { + die "fork error: $!"; + } + } + + + ok( + $heap->{forked} == $fork_count, + "forked $heap->{forked} processes (out of $fork_count)" + ); + + # Wait a factor of the fork time for things to settle down. + # This prevents false negatives on slower systems. + + my $fork_delay = time() - $fork_start_time; + + if ($fork_delay < 2) { + $fork_delay = 2; + } + elsif ($fork_delay < 5) { + $fork_delay = 5; + } + else { + $fork_delay = 10; + } + + $kernel->delay( forking_time_is_up => $fork_delay ); + diag("Waiting $fork_delay seconds for child processes to settle."); + }, + + _stop => sub { + my $heap = $_[HEAP]; + + # Everything is done. See whether it succeeded. + ok( + $heap->{reaped} == $heap->{forked}, + "reaped $heap->{reaped} processes (out of $heap->{forked})" + ); + }, + + catch_sigchld => sub { + my ($kernel, $heap) = @_[KERNEL, HEAP]; + + # Count the child reap. + $heap->{reaped}++; + + # Refresh the fork timeout. + $kernel->delay( + reaping_time_is_up => 2 * ($heap->{forked} - $heap->{reaped} + 1) + ); + }, + + forking_time_is_up => sub { + my ($kernel, $heap) = @_[KERNEL, HEAP]; + + # Forking time is over. We kill all the child processes as + # immediately as possible. + + my $kill_count = kill INT => keys(%{$heap->{children}}); + ok( + $kill_count == $heap->{forked}, + "killed $kill_count processes (out of $heap->{forked})" + ); + + # Start the reap timer. This will tell us how long to wait + # between CHLD signals. + + $heap->{reap_start} = time(); + + # Wait a factor of the number of child processes, plus one, for + # reaped children. The extra time is to ensure we don't reap + # more processes than we started with. + + $kernel->delay( + reaping_time_is_up => 2 * ($heap->{forked} - $heap->{reaped} + 1) + ); + }, + + # Do nothing here. The timer exists just to keep the session + # alive. Once it's dispatched, the session can exit. + reaping_time_is_up => sub { }, + }, +); + +# Run the tests. + +POE::Kernel->run(); + +1; Property changes on: trunk/poe/tests/30_loops/00_base/k_sig_child.pm ___________________________________________________________________ Name: svn:executable + * Name: svn:keywords + Id Revision Date Author URL Modified: trunk/poe/tests/30_loops/00_base/wheel_curses.pm =================================================================== --- trunk/poe/tests/30_loops/00_base/wheel_curses.pm 2006-09-14 00:45:24 UTC (rev 2125) +++ trunk/poe/tests/30_loops/00_base/wheel_curses.pm 2006-09-16 05:33:53 UTC (rev 2126) @@ -1,5 +1,5 @@ #!/usr/bin/perl -w -# $Id: /branches/poe-tests/tests/30_loops/00_base/wheel_tail.pm 10644 2006-05-29T17:02:47.597324Z bsmith $ +# $Id$ # Exercises Wheel::Curses Property changes on: trunk/poe/tests/30_loops/00_base/wheel_curses.pm ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL Property changes on: trunk/poe/tests/30_loops/00_base/wheel_readline.pm ___________________________________________________________________ Name: svn:keywords + Id Revision Date Author URL This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |