From: Peter Rabbitson Date: Mon, 8 Apr 2013 08:11:46 +0000 (+0200) Subject: More robust tests of dependency lazy-loading and delay of more req loads X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8c49cf15d576f554c2405abd4ebea7cdde053019;p=dbsrgits%2FDBIx-Class-Historic.git More robust tests of dependency lazy-loading and delay of more req loads Inspired by the lazy-loading chase in 723f25e0 Skip the test entirely on 5.8 - it is becoming too difficult to predict extra dependency load order --- diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index e0a1e92..4d2812c 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -15,9 +15,9 @@ BEGIN { ; } +# load Carp early to prevent tickling of the ::Internal stash being +# interpreted as "Carp is already loaded" by some braindead loader use Carp (); -use namespace::clean (); - $Carp::Internal{ (__PACKAGE__) }++; sub __find_caller { diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm index 58319d9..07f587d 100644 --- a/lib/DBIx/Class/Exception.pm +++ b/lib/DBIx/Class/Exception.pm @@ -3,9 +3,13 @@ package DBIx::Class::Exception; use strict; use warnings; -use DBIx::Class::Carp (); +# load Carp early to prevent tickling of the ::Internal stash being +# interpreted as "Carp is already loaded" by some braindead loader +use Carp (); $Carp::Internal{ (__PACKAGE__) }++; +use DBIx::Class::Carp (); + use overload '""' => sub { shift->{msg} }, fallback => 1; diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index b42fb7f..a70da84 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -15,7 +15,6 @@ use Context::Preserve 'preserve_context'; use Try::Tiny; use overload (); use Data::Compare (); # no imports!!! guard against insane architecture -use DBI::Const::GetInfoType (); # no import of retarded global hash use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -1124,12 +1123,13 @@ sub _dbh_get_info { my ($self, $info) = @_; if ($info =~ /[^0-9]/) { + require DBI::Const::GetInfoType; $info = $DBI::Const::GetInfoType::GetInfoType{$info}; $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType") unless defined $info; } - return $self->_get_dbh->get_info($info); + $self->_get_dbh->get_info($info); } sub _describe_connection { diff --git a/t/53lean_startup.t b/t/53lean_startup.t index 248925a..e106da2 100644 --- a/t/53lean_startup.t +++ b/t/53lean_startup.t @@ -1,15 +1,61 @@ # Use a require override instead of @INC munging (less common) # Do the override as early as possible so that CORE::require doesn't get compiled away -# We will add the hook in a bit, got to load some regular stuff -my $test_hook; +my ($initial_inc_contents, $expected_dbic_deps, $require_sites); BEGIN { + # these envvars *will* bring in more stuff than the baseline + delete @ENV{qw(DBICTEST_SQLT_DEPLOY DBIC_TRACE)}; + unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { my $res = $_[0]->(); - $test_hook->($_[1]) if $test_hook; + + my $req = $_[1]; + $req =~ s/\.pm$//; + $req =~ s/\//::/g; + + my $up = 0; + my @caller; + do { @caller = caller($up++) } while ( + @caller and ( + # exclude our test suite, known "module require-rs" and eval frames + $caller[1] =~ /^ t [\/\\] /x + or + $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime ) $/x + or + $caller[3] eq '(eval)', + ) + ); + + push @{$require_sites->{$req}}, "$caller[1] line $caller[2]" + if @caller; + + return $res if $req =~ /^DBIx::Class|^DBICTest::/; + + # exclude everything where the current namespace does not match the called function + # (this works around very weird XS-induced require callstack corruption) + if ( + !$initial_inc_contents->{$req} + and + !$expected_dbic_deps->{$req} + and + @caller + and + $caller[0] =~ /^DBIx::Class/ + and + (caller($up))[3] =~ /\Q$caller[0]/ + ) { + CORE::require('Test/More.pm'); + Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); + + if ($ENV{TEST_VERBOSE}) { + CORE::require('DBICTest/Util.pm'); + Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); + } + } + return $res; }); } @@ -17,119 +63,136 @@ BEGIN { use strict; use warnings; use Test::More; -use DBICTest::Util 'stacktrace'; -# Package::Stash::XS is silly and fails if a require hook contains regular -# expressions on perl < 5.8.7. Load the damned thing if the case BEGIN { - require Package::Stash if $] < 5.008007; + plan skip_all => 'A defined PERL5OPT may inject extra deps crashing this test' + if $ENV{PERL5OPT}; + + plan skip_all => 'Dependency load patterns are radically different before perl 5.10' + if $] < 5.010; + + # add what we loaded so far + for (keys %INC) { + my $mod = $_; + $mod =~ s/\.pm$//; + $mod =~ s!\/!::!g; + $initial_inc_contents->{$mod} = 1; + } } -my $expected_core_modules; - -BEGIN { - $expected_core_modules = { map { $_ => 1 } qw/ - strict - warnings +####### +### This is where the test starts +####### +# checking base schema load, no storage no connection +{ + register_lazy_loadable_requires(qw( + B constant - Config + overload base + Devel::GlobalDestruction mro - overload - Exporter - B - Devel::GlobalDestruction + Carp namespace::clean Try::Tiny - Context::Preserve Sub::Name Scalar::Util List::Util - Hash::Merge Data::Compare - DBI - DBI::Const::GetInfoType - SQL::Abstract - - Carp - Class::Accessor::Grouped Class::C3::Componentised - Moo - Sub::Quote - /, $] < 5.010 ? ( 'Class::C3', 'MRO::Compat' ) : () }; # this is special-cased in DBIx/Class.pm + )); - $test_hook = sub { + require DBICTest::Schema; + assert_no_missing_expected_requires(); +} - my $req = $_[0]; - $req =~ s/\.pm$//; - $req =~ s/\//::/g; +# check schema/storage instantiation with no connect +{ + register_lazy_loadable_requires(qw( + Moo + Sub::Quote + Context::Preserve + )); - return if $req =~ /^DBIx::Class|^DBICTest::/; + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + ok (! $s->storage->connected, 'no connection'); + assert_no_missing_expected_requires(); +} - my $up = 1; - my @caller; - do { @caller = caller($up++) } while ( - @caller and ( - # exclude our test suite, known "module require-rs" and eval frames - $caller[1] =~ /^ t [\/\\] /x - or - $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector) $/x - or - $caller[3] eq '(eval)', - ) - ); +# do something (deploy, insert) +{ + register_lazy_loadable_requires(qw( + DBI + SQL::Abstract + Hash::Merge + )); + + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + $s->storage->dbh_do(sub { + $_[1]->do('CREATE TABLE artist ( + "artistid" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100), + "rank" integer NOT NULL DEFAULT 13, + "charfield" char(10) + )'); + }); - # exclude everything where the current namespace does not match the called function - # (this works around very weird XS-induced require callstack corruption) - if ( - !$expected_core_modules->{$req} - and - @caller - and - $caller[0] =~ /^DBIx::Class/ - and - (caller($up))[3] =~ /\Q$caller[0]/ - ) { - fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); + my $art = $s->resultset('Artist')->create({ name => \[ '?' => 'foo'], rank => 42 }); + $art->discard_changes; + $art->update({ rank => 69, name => 'foo' }); + assert_no_missing_expected_requires(); +} - diag( 'Require invoked' . stacktrace() ) if $ENV{TEST_VERBOSE}; - } - }; +# and do full populate() as well, just in case - shouldn't add new stuff +{ + require DBICTest; + my $s = DBICTest->init_schema; + is ($s->resultset('Artist')->next->name, 'Caterwauler McCrae'); + assert_no_missing_expected_requires(); } -use lib 't/lib'; -use DBICTest; +done_testing; -# these envvars bring in more stuff -delete $ENV{$_} for qw/ - DBICTEST_SQLT_DEPLOY - DBIC_TRACE -/; +sub register_lazy_loadable_requires { + local $Test::Builder::Level = $Test::Builder::Level + 1; -my $schema = DBICTest->init_schema; -is ($schema->resultset('Artist')->next->name, 'Caterwauler McCrae'); + for my $mod (@_) { + (my $modfn = "$mod.pm") =~ s!::!\/!g; + fail(join "\n", + "Module $mod already loaded by require site(s):", + (map { "\t$_" } @{$require_sites->{$mod}}), + '', + ) if $INC{$modfn} and !$initial_inc_contents->{$mod}; + + $expected_dbic_deps->{$mod}++ + } +} # check if anything we were expecting didn't actually load -my $nl; -for (keys %$expected_core_modules) { - my $mod = "$_.pm"; - $mod =~ s/::/\//g; - unless ($INC{$mod}) { - my $err = sprintf "Expected DBIC core module %s never loaded - %s needs adjustment", $_, __FILE__; - if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) { - fail ($err) - } - else { - diag "\n" unless $nl++; - diag $err; +sub assert_no_missing_expected_requires { + my $nl; + for my $mod (keys %$expected_dbic_deps) { + (my $modfn = "$mod.pm") =~ s/::/\//g; + unless ($INC{$modfn}) { + my $err = sprintf "Expected DBIC core dependency '%s' never loaded - %s needs adjustment", $mod, __FILE__; + if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) { + fail ($err) + } + else { + diag "\n" unless $nl->{$mod}++; + diag $err; + } } } + pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s', + __FILE__, + (caller(0))[2], + join (', ', sort keys %$expected_dbic_deps ), + ) unless $nl; } - -done_testing; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 557ee36..0cd2b12 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -3,7 +3,6 @@ package DBICTest::Util; use warnings; use strict; -use Carp; use Config; use base 'Exporter'; @@ -30,7 +29,6 @@ sub local_umask { } } - sub stacktrace { my $frame = shift; $frame++;