HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
+ TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1
+
UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0,
( map
DBIC_SHUFFLE_UNORDERED_RESULTSETS
DBIC_ASSERT_NO_INTERNAL_WANTARRAY
DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ DBIC_ASSERT_NO_FAILING_SANITY_CHECKS
DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
)
use Carp 'croak';
use Storable 'nfreeze';
use Scalar::Util qw(weaken blessed reftype refaddr);
-use Sub::Quote qw(qsub);
use Sub::Name ();
use attributes ();
+# Usually versions are not specified anywhere aside the Makefile.PL
+# (writing them out in-code is extremely obnoxious)
+# However without a recent enough Moo the quote_sub override fails
+# in very puzzling and hard to detect ways: so add a version check
+# just this once
+use Sub::Quote qw(qsub);
+BEGIN { Sub::Quote->VERSION('2.002002') }
+
# Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
BEGIN { *deep_clone = \&Storable::dclone }
our @EXPORT_OK = qw(
sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
fail_on_internal_wantarray fail_on_internal_call
- refdesc refcount hrefaddr set_subname describe_class_methods
+ refdesc refcount hrefaddr set_subname get_subname describe_class_methods
scope_guard detected_reinvoked_destructor emit_loud_diag
true false
is_exception dbic_internal_try visit_namespaces
$visited_count;
}
-# FIXME In another life switch this to a polyfill like the one in namespace::clean
+# FIXME In another life switch these to a polyfill like the ones in namespace::clean
+sub get_subname ($) {
+ my $gv = B::svref_2object( $_[0] )->GV;
+ wantarray
+ ? ( $gv->STASH->NAME, $gv->NAME )
+ : ( join '::', $gv->STASH->NAME, $gv->NAME )
+ ;
+}
sub set_subname ($$) {
# fully qualify name
}
sub serialize ($) {
+ # stable hash order
local $Storable::canonical = 1;
+
+ # explicitly false - there is nothing sensible that can come out of
+ # an attempt at CODE serialization
+ local $Storable::Deparse;
+
+ # take no chances
+ local $Storable::forgive_me;
+
+ # FIXME
+ # A number of codepaths *expect* this to be Storable.pm-based so that
+ # the STORABLE_freeze hooks in the metadata subtree get executed properly
nfreeze($_[0]);
}
->Deparse(1)
;
- $d->Sparseseen(1) if modver_gt_or_eq (
- 'Data::Dumper', '2.136'
- );
+ # FIXME - this is kinda ridiculous - there ought to be a
+ # Data::Dumper->new_with_defaults or somesuch...
+ #
+ if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) {
+ $d->Sparseseen(1);
+
+ if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) {
+ $d->Maxrecurse(1000);
+
+ if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) {
+ $d->Trailingcomma(1);
+ }
+ }
+ }
$d;
}
exit 70;
}
- my $msg = "\n$0: $args->{msg}";
+ my $msg = "\n" . join( ': ',
+ ( $0 eq '-e' ? () : $0 ),
+ $args->{msg}
+ );
# when we die - we usually want to keep doing it
$args->{emit_dups} = !!$args->{confess}
croak "Nonsensical minimum version supplied"
if ! defined $ver or $ver !~ $ver_rx;
- no strict 'refs';
- my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
- ? {}
- : croak "$mod does not seem to provide a version (perhaps it never loaded)"
- );
+ my $ver_cache = do {
+ no strict 'refs';
+ ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= {}
+ };
! defined $ver_cache->{$ver}
and
local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
if SPURIOUS_VERSION_CHECK_WARNINGS;
+ # prevent captures by potential __WARN__ hooks or the like:
+ # there is nothing of value that can be happening here, and
+ # leaving a hook in-place can only serve to fail some test
+ local $SIG{__WARN__} if (
+ ! SPURIOUS_VERSION_CHECK_WARNINGS
+ and
+ $SIG{__WARN__}
+ );
+
+ croak "$mod does not seem to provide a version (perhaps it never loaded)"
+ unless $mod->VERSION;
+
local $SIG{__DIE__} if $SIG{__DIE__};
local $@;
eval { $mod->VERSION($ver) } ? 1 : 0;
croak "Expecting a class name either as the sole argument or a 'class' option"
if not defined $class or $class !~ $module_name_rx;
+ croak(
+ "The supplied 'class' argument is tainted: this is *extremely* "
+ . 'dangerous, fix your code ASAP!!! ( for more details read through '
+ . 'https://is.gd/perl_mro_taint_wtf )'
+ ) if (
+ DBIx::Class::_ENV_::TAINT_MODE
+ and
+ Scalar::Util::tainted($class)
+ );
+
$requested_mro ||= mro::get_mro($class);
# mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
if (
! DBIx::Class::_ENV_::OLD_MRO
and
- ${^TAINT}
+ DBIx::Class::_ENV_::TAINT_MODE
) {
$slot->{cumulative_gen} = 0;
{
package DB;
$fr = [ CORE::caller(1) ];
- $argdesc = ref $DB::args[0]
- ? DBIx::Class::_Util::refdesc($DB::args[0])
- : ( $DB::args[0] . '' )
+ $argdesc =
+ ( not defined $DB::args[0] ) ? 'UNAVAILABLE'
+ : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0])
+ : $DB::args[0] . ''
;
};
: $fr
;
+
+ die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless (
+
+ # unlikely but who knows...
+ ! @$fr
+
+ or
+
+ # This is a weird-ass double-purpose method, only one branch of which is marked
+ # as an illegal indirect call
+ # Hence the 'indirect' attribute makes no sense
+ # FIXME - likely need to mark this in some other manner
+ $fr->[3] eq 'DBIx::Class::ResultSet::new'
+
+ or
+
+ # RsrcProxy stuff is special and not attr-annotated on purpose
+ # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC
+ # itself should not call these methods as first-entry
+ $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/
+
+ or
+
+ # FIXME - there is likely a more fine-graned way to escape "foreign"
+ # callers, based on annotations... (albeit a slower one)
+ # For the time being just skip in a dumb way
+ $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/
+
+ or
+
+ grep
+ { $_ eq 'DBIC_method_is_indirect_sugar' }
+ do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) }
+ );
+
+
if (
- $argdesc
+ defined $fr->[0]
and
$check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
and
}
}
+if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) {
+
+ no warnings 'redefine';
+
+ my $next_bless = defined(&CORE::GLOBAL::bless)
+ ? \&CORE::GLOBAL::bless
+ : sub { CORE::bless($_[0], $_[1]) }
+ ;
+
+ *CORE::GLOBAL::bless = sub {
+ my $class = (@_ > 1) ? $_[1] : CORE::caller();
+
+ # allow for reblessing (role application)
+ return $next_bless->( $_[0], $class )
+ if defined blessed $_[0];
+
+ my $obj = $next_bless->( $_[0], $class );
+
+ my $calling_sub = (CORE::caller(1))[3] || '';
+
+ (
+ # before 5.18 ->isa() will choke on the "0" package
+ # which we test for in several obscure cases, sigh...
+ !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 )
+ or
+ $class
+ )
+ and
+ (
+ (
+ $calling_sub !~ /^ (?:
+ DBIx::Class::Schema::clone
+ |
+ DBIx::Class::DB::setup_schema_instance
+ )/x
+ and
+ $class->isa("DBIx::Class::Schema")
+ )
+ or
+ (
+ $calling_sub ne 'DBIx::Class::ResultSource::new'
+ and
+ $class->isa("DBIx::Class::ResultSource")
+ )
+ )
+ and
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1
+ and
+ Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor");
+
+
+ $obj;
+ };
+}
+
1;
projects / dbsrgits/DBIx-Class.git / blobdiff