X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F52leaks.t;h=eb72a826524cc401884ace60c98bbde87d9870af;hb=c9733800;hp=793e0364aacb7e8a3d40cbe552af5650ab95c76b;hpb=65d351219882184861384aedac6f251b6797d0d7;p=dbsrgits%2FDBIx-Class.git diff --git a/t/52leaks.t b/t/52leaks.t index 793e036..eb72a82 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -23,14 +23,26 @@ use Test::More; my $TB = Test::More->builder; if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { - # without this explicit close ->reset below warns - close ($TB->$_) for qw/output failure_output/; + # without this explicit close older TBs warn in END after a ->reset + if ($TB->VERSION < 1.005) { + close ($TB->$_) for (qw/output failure_output todo_output/); + } - # so done_testing can work - $TB->reset; + # if I do not do this, I get happy sigpipes on new TB, no idea why + # (the above close-and-forget doesn't work - new TB does *not* reopen + # its handles automatically anymore) + else { + for (qw/failure_output todo_output/) { + close $TB->$_; + open ($TB->$_, '>&', *STDERR); + } - # this simulates a subtest - $TB->_indent(' ' x 4); + close $TB->output; + open ($TB->output, '>&', *STDOUT); + } + + # so done_testing can work on every persistent pass + $TB->reset; } use lib qw(t/lib); @@ -67,6 +79,15 @@ unless (DBICTest::RunMode->is_plain) { } ); + # unicode is tricky, and now we happen to invoke it early via a + # regex in connection() + return $obj if (ref $obj) =~ /^utf8/; + + # Test Builder is now making a new object for every pass/fail (que bloat?) + # and as such we can't really store any of its objects (since it will + # re-populate the registry while checking it, ewwww!) + return $obj if (ref $obj) =~ /^TB2::/; + # weaken immediately to avoid weird side effects return populate_weakregistry ($weak_registry, $obj ); }; @@ -90,6 +111,7 @@ unless (DBICTest::RunMode->is_plain) { require DBI; require DBD::SQLite; require FileHandle; + require Moo; %$weak_registry = (); } @@ -290,7 +312,7 @@ my @compose_ns_classes; { my $phantom; for ( - sub { DBICTest->init_schema }, + sub { DBICTest->init_schema( sqlite_use_file => 0 ) }, sub { shift->source('Artist') }, sub { shift->resultset }, sub { shift->result_source }, @@ -401,70 +423,76 @@ assert_empty_weakregistry ($weak_registry); # this is ugly and dirty but we do not yet have a Test::Embedded or # similar -my @pperl_cmd = (qw/pperl --prefork=1/, __FILE__); -my @pperl_term_cmd = @pperl_cmd; -splice @pperl_term_cmd, 1, 0, '--kill'; +# set up -I +require Config; +$ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); +($ENV{PATH}) = $ENV{PATH} =~ /(.+)/; + + +my $persistence_tests = { + PPerl => { + cmd => [qw/pperl --prefork=1/, __FILE__], + }, + 'CGI::SpeedyCGI' => { + cmd => [qw/speedy -- -t5/, __FILE__], + }, +}; # scgi is smart and will auto-reap after -t amount of seconds -my @scgi_cmd = (qw/speedy -- -t5/, __FILE__); +# pperl needs an actual killer :( +$persistence_tests->{PPerl}{termcmd} = [ + $persistence_tests->{PPerl}{cmd}[0], + '--kill', + @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ], +]; SKIP: { skip 'Test already in a persistent loop', 1 if $ENV{DBICTEST_IN_PERSISTENT_ENV}; - skip 'Persistence test disabled on regular installs', 1 - if DBICTest::RunMode->is_plain; - skip 'Main test failed - skipping persistent env tests', 1 unless $TB->is_passing; - # set up -I - require Config; - local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); - local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; - # try with pperl - SKIP: { - skip 'PPerl persistent environment tests require PPerl', 1 - unless eval { require PPerl }; + require IPC::Open2; + + for my $type (keys %$persistence_tests) { SKIP: { + skip "$type module not found", 1 + unless eval "require $type"; + + my @cmd = @{$persistence_tests->{$type}{cmd}}; # since PPerl is racy and sucks - just prime the "server" { local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; - system(@pperl_cmd); + system(@cmd); sleep 1; - # see if it actually runs - if not might as well bail now - skip "Something is wrong with pperl ($!)", 1 - if system(@pperl_cmd); + # see if the thing actually runs, if not - might as well bail now + skip "Something is wrong with $type ($!)", 1 + if system(@cmd); } for (1,2,3) { - system(@pperl_cmd); - ok (!$?, "Run in persistent env (PPerl pass $_): exit $?"); - } - - ok (! system (@pperl_term_cmd), 'killed pperl instance'); - } - - # try with speedy-cgi - SKIP: { - skip 'SPeedyCGI persistent environment tests require CGI::SpeedyCGI', 1 - unless eval { require CGI::SpeedyCGI }; - - { - local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; - skip "Something is wrong with speedy ($!)", 1 - if system(@scgi_cmd); - sleep 1; + note ("Starting run in persistent env ($type pass $_)"); + IPC::Open2::open2(my $out, undef, @cmd); + my @out_lines; + while (my $ln = <$out>) { + next if $ln =~ /^\s*$/; + push @out_lines, " $ln"; + last if $ln =~ /^\d+\.\.\d+$/; # this is persistence, we need to terminate reading on our end + } + print $_ for @out_lines; + close $out; + wait; + ok (!$?, "Run in persistent env ($type pass $_): exit $?"); + ok (scalar @out_lines, "Run in persistent env ($type pass $_): got output"); } - for (1,2,3) { - system(@scgi_cmd); - ok (!$?, "Run in persistent env (SpeedyCGI pass $_): exit $?"); - } - } + ok (! system (@{$persistence_tests->{$type}{termcmd}}), "killed $type server instance") + if $persistence_tests->{$type}{termcmd}; + }} } done_testing; @@ -473,9 +501,8 @@ done_testing; # PID files to go by (man does pperl really suck :( END { unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { - close STDOUT; - close STDERR; + close $_ for (*STDIN, *STDOUT, *STDERR); local $?; # otherwise test will inherit $? of the system() - system (@pperl_term_cmd); + system (@{$persistence_tests->{PPerl}{termcmd}}); } }