package # hide from PAUSE
DBIx::Class::_Util;
-use DBIx::Class::StartupCheck; # load es early as we can, usually a noop
+# load es early as we can, usually a noop
+use DBIx::Class::StartupCheck;
use warnings;
use strict;
{ substr($_, 5) => !!( $ENV{$_} ) }
qw(
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_ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION
DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
)
# Carp::Skip to the rescue soon
use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
+# Ensure it is always there, in case we need to do a $schema-less throw()
+use DBIx::Class::Exception ();
+
use B ();
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 }
use base 'Exporter';
our @EXPORT_OK = qw(
- sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
- fail_on_internal_wantarray fail_on_internal_call
+ sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_call
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
- quote_sub qsub perlstring serialize deep_clone dump_value uniq
+ is_exception dbic_internal_try dbic_internal_catch visit_namespaces
+ quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq
parent_dir mkdir_p
- UNRESOLVABLE_CONDITION
+ UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR
);
use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
+use constant DUMMY_ALIASPAIR => (
+ foreign_alias => "!!!\xFF()!!!_DUMMY_FOREIGN_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!",
+ self_alias => "!!!\xFE()!!!_DUMMY_SELF_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFE!!!",
+);
+
# Override forcing no_defer, and adding naming consistency checks
our %refs_closed_over_by_quote_sub_installed_crefs;
sub quote_sub {
}
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]);
}
) } @_;
}
+sub bag_eq ($$) {
+ croak "bag_eq() requiress two arrayrefs as arguments" if (
+ ref($_[0]) ne 'ARRAY'
+ or
+ ref($_[1]) ne 'ARRAY'
+ );
+
+ return '' unless @{$_[0]} == @{$_[1]};
+
+ my( %seen, $numeric_preserving_copy );
+
+ ( defined $_
+ ? $seen{'value' . ( $numeric_preserving_copy = $_ )}++
+ : $seen{'undef'}++
+ ) for @{$_[0]};
+
+ ( defined $_
+ ? $seen{'value' . ( $numeric_preserving_copy = $_ )}--
+ : $seen{'undef'}--
+ ) for @{$_[1]};
+
+ return (
+ (grep { $_ } values %seen)
+ ? ''
+ : 1
+ );
+}
+
my $dd_obj;
sub dump_value ($) {
local $Data::Dumper::Indent = 1
->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}
{
my $callstack_state;
- # Recreate the logic of try(), while reusing the catch()/finally() as-is
- #
- # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
- # yes, shows up ON TOP of profiles) but this is a batle for another maint
+ # Recreate the logic of Try::Tiny, but without the crazy Sub::Name
+ # invocations and without support for finally() altogether
+ # ( yes, these days Try::Tiny is so "tiny" it shows *ON TOP* of most
+ # random profiles https://youtu.be/PYCbumw0Fis?t=1919 )
sub dbic_internal_try (&;@) {
my $try_cref = shift;
for my $arg (@_) {
- if( ref($arg) eq 'Try::Tiny::Catch' ) {
+ croak 'dbic_internal_try() may not be followed by multiple dbic_internal_catch() blocks'
+ if $catch_cref;
- croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
- if $catch_cref;
+ ($catch_cref = $$arg), next
+ if ref($arg) eq 'DBIx::Class::_Util::Catch';
- $catch_cref = $$arg;
- }
- elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
- croak 'dbic_internal_try() does not support finally{}';
- }
- else {
- croak(
- 'dbic_internal_try() encountered an unexpected argument '
- . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
- . 'a missing semi-colon before or ' # trailing space important
- );
- }
+ croak( 'Mixing dbic_internal_try() with Try::Tiny::catch() is not supported' )
+ if ref($arg) eq 'Try::Tiny::Catch';
+
+ croak( 'dbic_internal_try() does not support finally{}' )
+ if ref($arg) eq 'Try::Tiny::Finally';
+
+ croak(
+ 'dbic_internal_try() encountered an unexpected argument '
+ . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
+ . 'a missing semi-colon before or ' # trailing space important
+ );
}
my $wantarray = wantarray;
my $preexisting_exception = $@;
my @ret;
- my $all_good = eval {
+ my $saul_goodman = eval {
$@ = $preexisting_exception;
local $callstack_state->{in_internal_try} = 1
my $exception = $@;
$@ = $preexisting_exception;
- if ( $all_good ) {
+ if ( $saul_goodman ) {
return $wantarray ? @ret : $ret[0]
}
elsif ( $catch_cref ) {
return;
}
- sub in_internal_try { !! $callstack_state->{in_internal_try} }
+ sub dbic_internal_catch (&;@) {
+
+ croak( 'Useless use of bare dbic_internal_catch()' )
+ unless wantarray;
+
+ croak( 'dbic_internal_catch() must receive exactly one argument at end of expression' )
+ if @_ > 1;
+
+ bless(
+ \( $_[0] ),
+ 'DBIx::Class::_Util::Catch'
+ ),
+ }
+
+ sub in_internal_try () {
+ !! $callstack_state->{in_internal_try}
+ }
}
{
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;
}
-{
- my $list_ctx_ok_stack_marker;
-
- sub fail_on_internal_wantarray () {
- return if $list_ctx_ok_stack_marker;
+sub fail_on_internal_call {
+ my $fr = [ CORE::caller(1) ];
- if (! defined wantarray) {
- croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
- }
+ die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless (
- my $cf = 1;
- while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?:
+ # unlikely but who knows...
+ ! @$fr
- # these are public API parts that alter behavior on wantarray
- search | search_related | slice | search_literal
+ 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'
- # these are explicitly prefixed, since we only recognize them as valid
- # escapes when they come from the guts of CDBICompat
- CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
+ or
- ) $/x ) {
- $cf++;
- }
+ # 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::[^:]+$/
- my ($fr, $want, $argdesc);
- {
- package DB;
- $fr = [ CORE::caller($cf) ];
- $want = ( CORE::caller($cf-1) )[5];
- $argdesc = ref $DB::args[0]
- ? DBIx::Class::_Util::refdesc($DB::args[0])
- : 'non '
- ;
- };
+ or
- if (
- $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
- ) {
- DBIx::Class::Exception->throw( sprintf (
- "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts",
- $argdesc, @{$fr}[1,2]
- ), 'with_stacktrace');
- }
+ # 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::/
- weaken( $list_ctx_ok_stack_marker = my $mark = [] );
+ or
- $mark;
- }
-}
+ grep
+ { $_ eq 'DBIC_method_is_indirect_sugar' }
+ do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) }
+ );
-sub fail_on_internal_call {
- my ($fr, $argdesc);
- {
- package DB;
- $fr = [ CORE::caller(1) ];
- $argdesc = ref $DB::args[0]
- ? DBIx::Class::_Util::refdesc($DB::args[0])
- : ( $DB::args[0] . '' )
- ;
- };
my @fr2;
# need to make allowance for a proxy-yet-direct call
- my $check_fr = (
- $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
- and
- @fr2 = (CORE::caller(2))
- and
+ # or for an exception wrapper
+ $fr = \@fr2 if (
(
- ( $fr->[3] =~ /([^:])+$/ )[0]
- eq
- ( $fr2[3] =~ /([^:])+$/ )[0]
+ $fr->[3] eq '(eval)'
+ and
+ @fr2 = (CORE::caller(2))
)
- )
- ? \@fr2
- : $fr
- ;
+ or
+ (
+ $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
+ and
+ @fr2 = (CORE::caller(2))
+ and
+ (
+ ( $fr->[3] =~ /([^:])+$/ )[0]
+ eq
+ ( $fr2[3] =~ /([^:])+$/ )[0]
+ )
+ )
+ );
+
if (
- $argdesc
+ defined $fr->[0]
+ and
+ $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+ and
+ $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there
+ and
+ # one step higher
+ @fr2 = CORE::caller(@fr2 ? 3 : 2)
and
- $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+ # if the frame that called us is an indirect itself - nothing to see here
+ (! grep
+ { $_ eq 'DBIC_method_is_indirect_sugar' }
+ do {
+ no strict 'refs';
+ attributes::get( \&{ $fr2[3] })
+ }
+ )
and
- $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there
+ (
+ $fr->[3] ne 'DBIx::Class::ResultSet::search'
+ or
+ # these are explicit wantarray-passthrough callsites for search() due to old silly API choice
+ $fr2[3] !~ /^DBIx::Class::Ordered::(?: _group_rs | (?: _ | next_ | previous_ )? siblings )/x
+ )
) {
+
+ my $argdesc;
+
+ {
+ package DB;
+
+ my @throwaway = caller( @fr2 ? 2 : 1 );
+
+ # screwing with $DB::args is rather volatile - be extra careful
+ no warnings 'uninitialized';
+
+ $argdesc =
+ ( not defined $DB::args[0] ) ? 'UNAVAILABLE'
+ : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0])
+ : $DB::args[0] . ''
+ ;
+ };
+
DBIx::Class::Exception->throw( sprintf (
"Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts",
$fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
}
}
+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