X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F52leaks.t;h=800ec22d58eaaf384d139df54e52ff5983818523;hb=7536c92b1affd50dd567cb1acae7a38f2222d04d;hp=793e0364aacb7e8a3d40cbe552af5650ab95c76b;hpb=65d351219882184861384aedac6f251b6797d0d7;p=dbsrgits%2FDBIx-Class.git diff --git a/t/52leaks.t b/t/52leaks.t index 793e036..800ec22 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -23,19 +23,32 @@ 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); + } + + close $TB->output; + open ($TB->output, '>&', *STDOUT); + } - # this simulates a subtest - $TB->_indent(' ' x 4); + # so done_testing can work on every persistent pass + $TB->reset; } use lib qw(t/lib); use DBICTest::RunMode; -use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/; +use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; +use Scalar::Util 'refaddr'; use DBIx::Class; use B 'svref_2object'; BEGIN { @@ -67,6 +80,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 +112,7 @@ unless (DBICTest::RunMode->is_plain) { require DBI; require DBD::SQLite; require FileHandle; + require Moo; %$weak_registry = (); } @@ -235,9 +258,14 @@ my @compose_ns_classes; leaky_resultset => $rs_bind_circref, leaky_resultset_cond => $cond_rowobj, - leaky_resultset_member => $rs_bind_circref->next, }; + # this needs to fire, even if it can't find anything + # see FIXME below + # we run this only on smokers - trying to establish a pattern + $rs_bind_circref->next + if ( ($ENV{TRAVIS}||'') ne 'true' and DBICTest::RunMode->is_smoker); + require Storable; %$base_collection = ( %$base_collection, @@ -290,7 +318,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 }, @@ -332,8 +360,8 @@ for my $slot (keys %$weak_registry) { # Moo keeps globals around, this is normal delete $weak_registry->{$slot}; } - elsif ($slot =~ /^SQL::Translator/) { - # SQLT is a piece of shit, leaks all over + elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) { + # SQLT got much better, but still leaks a little delete $weak_registry->{$slot}; } elsif ($slot =~ /^Hash::Merge/) { @@ -387,10 +415,8 @@ for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) { # ^ / # \-------- bound value on prepared/cached STH <-----------/ # -TODO: { - local $TODO = 'Not sure how to fix this yet, an entanglment could be an option'; - my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref}; - ok(! defined $r, 'We no longer leak!') +if ( my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref} ) { + ok(! defined $r, 'Self-referential RS conditions no longer leak!') or $r->result_source(undef); } @@ -401,70 +427,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 +505,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}}); } }