nasty memleak with version.pm on multiple ->VERSION invocations)
- The internal carp module now correctly skips CAG frames when
reporting a callsite
+ - Fix test failures on perl < 5.8.7 and new Package::Stash::XS
* Misc
- No longer depend on Variable::Magic now that a pure-perl
# 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 replace $req_override in a bit
+# We will add the hook in a bit, got to load some regular stuff
my $test_hook;
BEGIN {
- $test_hook = sub {}; # noop at first
- *CORE::GLOBAL::require = sub {
- $test_hook->(@_);
- CORE::require($_[0]);
- };
+ unshift @INC, 't/lib';
+ require DBICTest::Util::OverrideRequire;
+
+ DBICTest::Util::OverrideRequire::override_global_require( sub {
+ my $res = $_[0]->();
+ $test_hook->($_[1]) if $test_hook;
+ return $res;
+ });
}
use strict;
use Test::More;
use Data::Dumper;
+# 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;
+}
+
my $expected_core_modules;
BEGIN {
$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) {
+ if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) {
fail ($err)
}
else {
-# Pre-5.10 perls pollute %INC on unsuccesfull module
-# require, making it appear as if the module is already
-# loaded on subsequent require()s
-# Can't seem to find the exact RT/perldelta entry
-#
-# we want to do this here, in the very beginning, before even
-# warnings/strict are loaded
BEGIN {
if ($] < 5.010) {
- # All of this almost verbatim copied from Lexical::SealRequireHints
- # Zefram++
-
- # a potential caller() in $next_require must see the correct
- # immediate frame caller
- my $caller = caller(0);
-
- our $next_require = defined(&CORE::GLOBAL::require)
- ? \&CORE::GLOBAL::require
- : sub {
- my ($arg) = @_;
-
- # The shenanigans with $CORE::GLOBAL::{require}
- # are required because if there's a
- # &CORE::GLOBAL::require when the eval is
- # executed then the CORE::require in there is
- # interpreted as plain require on some Perl
- # versions, leading to recursion.
- my $grequire = delete $CORE::GLOBAL::{require};
-
- my $result = eval sprintf '
- local $SIG{__DIE__};
- $CORE::GLOBAL::{require} = $grequire;
- package %s;
- CORE::require($arg);
- ', $caller;
-
- die $@ if $@ ne '';
- return $result;
- }
- ;
-
- *CORE::GLOBAL::require = sub {
- die "wrong number of arguments to require\n"
- unless @_ == 1;
-
- my $res = eval "package $caller; \$next_require->(\@_)";
+ # Pre-5.10 perls pollute %INC on unsuccesfull module
+ # require, making it appear as if the module is already
+ # loaded on subsequent require()s
+ # Can't seem to find the exact RT/perldelta entry
+ #
+ # The reason we can't just use a sane, clean loader, is because
+ # if a Module require()s another module the %INC will still
+ # get filled with crap and we are back to square one. A global
+ # fix is really the only way for this test, as we try to load
+ # each available module separately, and have no control (nor
+ # knowledge) over their common dependencies.
+ #
+ # we want to do this here, in the very beginning, before even
+ # warnings/strict are loaded
+
+ unshift @INC, 't/lib';
+ require DBICTest::Util::OverrideRequire;
+
+ DBICTest::Util::OverrideRequire::override_global_require( sub {
+ my $res = eval { $_[0]->() };
if ($@ ne '') {
- delete $INC{$_[0]};
+ delete $INC{$_[1]};
die $@;
}
-
- $res;
- };
+ return $res;
+ } );
}
}
return sort @modules;
}
-
done_testing;
--- /dev/null
+package DBICTest::Util::OverrideRequire;
+
+# no use/require of any kind - work bare
+
+BEGIN {
+ # 0 - no trace
+ # 1 - just requires and return values
+ # 2 - full stacktrace
+ *TRACE = sub () { 0 };
+}
+
+# Takes a single coderef and replaces CORE::GLOBAL::require with it.
+#
+# On subsequent require() calls, the coderef will be invoked with
+# two arguments - ($next_require, $module_name_copy)
+#
+# $next_require is a coderef closing over the module name. It needs
+# to be invoked at some point without arguments for the actual
+# require to take place (this way your coderef in essence becomes an
+# around modifier)
+#
+# $module_name_copy is a string-copy of what $next_require is closing
+# over. The reason for the copy is that you may trigger a side effect
+# on magical values, and subsequently abort the require (e.g.
+# require v.5.8.8 magic)
+#
+# All of this almost verbatim copied from Lexical::SealRequireHints
+# Zefram++
+sub override_global_require (&) {
+ my $override_cref = shift;
+
+ our $next_require = defined(&CORE::GLOBAL::require)
+ ? \&CORE::GLOBAL::require
+ : sub {
+
+ my ($arg) = @_;
+
+ # The shenanigans with $CORE::GLOBAL::{require}
+ # are required because if there's a
+ # &CORE::GLOBAL::require when the eval is
+ # executed then the CORE::require in there is
+ # interpreted as plain require on some Perl
+ # versions, leading to recursion.
+ my $grequire = delete $CORE::GLOBAL::{require};
+
+ my $res = eval sprintf '
+ local $SIG{__DIE__};
+ $CORE::GLOBAL::{require} = $grequire;
+ package %s;
+ CORE::require($arg);
+ ', scalar caller(0); # the caller already had its package replaced
+
+ my $err = $@ if $@ ne '';
+
+ if( TRACE ) {
+ if (TRACE == 1) {
+ printf STDERR "Require of '%s' (returned: '%s')\n",
+ (my $m_copy = $arg),
+ (my $r_copy = $res),
+ ;
+ }
+ else {
+ my ($fr_num, @fr, @tr, $excise);
+ while (@fr = caller($fr_num++)) {
+
+ # Package::Stash::XS is a cock and gets mightily confused if one
+ # uses a regex in the require hook - go figure
+
+ if (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) {
+ push @tr, [@fr]
+ }
+
+ if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
+ $excise ||= $tr[-2];
+ }
+ }
+
+ my @stack =
+ map { "$_->[1], line $_->[2]" }
+ grep { not ($_->[1] eq $excise->[1] and $_->[2] eq $_->[2]) }
+ @tr
+ ;
+
+ printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
+ (my $m_copy = $arg),
+ (my $r_copy = $res||''),
+ join "\n", (map { " $_" } @stack)
+ ;
+ }
+ }
+
+ die $err if defined $err;
+
+ return $res;
+ }
+ ;
+
+ # Need to suppress the redefinition warning, without
+ # invoking warnings.pm.
+ BEGIN { ${^WARNING_BITS} = ""; }
+
+ *CORE::GLOBAL::require = sub {
+ die "wrong number of arguments to require\n"
+ unless @_ == 1;
+
+ # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
+ my ($arg_copy) = our ($arg) = @_;
+
+ return $override_cref->(sub {
+ die "The require delegate takes no arguments\n"
+ if @_;
+
+ my $res = eval sprintf '
+ local $SIG{__DIE__};
+ package %s;
+ $next_require->($arg);
+ ', scalar caller(2); # 2 for the indirection of the $override_cref around
+
+ die $@ if $@ ne '';
+
+ return $res;
+
+ }, $arg_copy);
+ }
+}
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff