X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=4829539a40efa42f2583635133081016c1009901;hb=69016f65df5f30e446734b8cc94c216915c9105b;hp=9f984d297b7b65846700f45b5475404f1cd3b200;hpb=c1ce337f0f1c6a35d33edbeeb10fecce76812008;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 9f984d2..4829539 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -4,37 +4,6 @@ package # hide from PAUSE use warnings; use strict; -# Temporary - tempextlib -use namespace::clean; -BEGIN { - require Module::Runtime; - require File::Spec; - - # There can be only one of these, make sure we get the bundled part and - # *not* something off the site lib - for (qw( - DBIx::Class::SQLMaker - SQL::Abstract - SQL::Abstract::Test - )) { - if ($INC{Module::Runtime::module_notional_filename($_)}) { - die "\nUnable to continue - a part of the bundled templib contents " - . "was already loaded (likely an older version from CPAN). " - . "Make sure that @{[ __PACKAGE__ ]} is loaded before $_\n\n" - ; - } - } - - our ($HERE) = File::Spec->rel2abs( - File::Spec->catdir( (File::Spec->splitpath(__FILE__))[1], '_TempExtlib' ) - ) =~ /^(.*)$/; # screw you, taint mode - - die "TempExtlib $HERE does not seem to exist - perhaps you need to run `perl Makefile.PL` in the DBIC checkout?\n" - unless -d $HERE; - - unshift @INC, $HERE; -} - use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0); BEGIN { @@ -52,8 +21,7 @@ BEGIN { HAS_ITHREADS => $Config{useithreads} ? 1 : 0, - # ::Runmode would only be loaded by DBICTest, which in turn implies t/ - DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0, + DBICTEST => $INC{"DBICTest/Util.pm"} ? 1 : 0, # During 5.13 dev cycle HELEMs started to leak on copy # add an escape for these perls ON SMOKERS - a user will still get death @@ -65,6 +33,10 @@ BEGIN { ASSERT_NO_INTERNAL_INDIRECT_CALLS => $ENV{DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS} ? 1 : 0, + STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE => $ENV{DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE} ? 1 : 0, + + STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE => $ENV{DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE} ? 1 : 0, + IV_SIZE => $Config{ivsize}, OS_NAME => $^O, @@ -84,27 +56,22 @@ BEGIN { # Carp::Skip to the rescue soon use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; +use B (); use Carp 'croak'; -use Scalar::Util qw(weaken blessed reftype); +use Storable 'nfreeze'; +use Scalar::Util qw(weaken blessed reftype refaddr); use List::Util qw(first); +use Sub::Quote qw(qsub quote_sub); -# DO NOT edit away without talking to riba first, he will just put it back -# BEGIN pre-Moo2 import block -BEGIN { - my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all}; - local $ENV{PERL_STRICTURES_EXTRA} = 0; - require Sub::Quote; Sub::Quote->import('quote_sub'); - ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} ); -} -sub qsub ($) { goto "e_sub } # no point depping on new Moo just for this -# END pre-Moo2 import block +# 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 + sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr is_exception - quote_sub qsub perlstring + refdesc refcount hrefaddr is_exception detected_reinvoked_destructor + quote_sub qsub perlstring serialize deep_clone UNRESOLVABLE_CONDITION ); @@ -122,7 +89,7 @@ sub sigwarn_silencer ($) { sub perlstring ($) { q{"}. quotemeta( shift ). q{"} }; -sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr||0 } +sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 } sub refdesc ($) { croak "Expecting a reference" if ! length ref $_[0]; @@ -132,19 +99,23 @@ sub refdesc ($) { sprintf '%s%s(0x%x)', ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ), reftype $_[0], - Scalar::Util::refaddr($_[0]), + refaddr($_[0]), ; } sub refcount ($) { croak "Expecting a reference" if ! length ref $_[0]; - require B; # No tempvars - must operate on $_[0], otherwise the pad # will count as an extra ref B::svref_2object($_[0])->REFCNT; } +sub serialize ($) { + local $Storable::canonical = 1; + nfreeze($_[0]); +} + sub is_exception ($) { my $e = $_[0]; @@ -193,10 +164,79 @@ sub is_exception ($) { die $suberror } } + elsif ( + # a ref evaluating to '' is definitively a "null object" + ( not $not_blank ) + and + length( my $class = ref $e ) + ) { + carp_unique( sprintf( + "Objects of external exception class '%s' stringify to '' (the " + . 'empty string), implementing the so called null-object-pattern. ' + . 'Given Perl\'s "globally cooperative" exception handling using this ' + . 'class of exceptions is extremely dangerous, as it may (and often ' + . 'does) result in silent discarding of errors. DBIx::Class tries to ' + . 'work around this as much as possible, but other parts of your ' + . 'software stack may not be even aware of the problem. Please submit ' + . 'a bugreport against the distribution containing %s.', + + ($class) x 2, + )); + + $not_blank = 1; + } return $not_blank; } +{ + my $destruction_registry = {}; + + sub CLONE { + $destruction_registry = { map + { defined $_ ? ( refaddr($_) => $_ ) : () } + values %$destruction_registry + }; + } + + # This is almost invariably invoked from within DESTROY + # throwing exceptions won't work + sub detected_reinvoked_destructor { + + # quick "garbage collection" pass - prevents the registry + # from slowly growing with a bunch of undef-valued keys + defined $destruction_registry->{$_} or delete $destruction_registry->{$_} + for keys %$destruction_registry; + + if (! length ref $_[0]) { + printf STDERR '%s() expects a blessed reference %s', + (caller(0))[3], + Carp::longmess, + ; + return undef; # don't know wtf to do + } + elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) { + weaken( $destruction_registry->{$addr} = $_[0] ); + return 0; + } + else { + carp_unique ( sprintf ( + 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY ' + . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your ' + . 'application, affecting *ALL* classes without active protection against ' + . 'this. Diagnose and fix the root cause ASAP!!!%s', + refdesc $_[0], + ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } ) + ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)" + : '' + ) + )); + + return 1; + } + } +} + sub modver_gt_or_eq ($$) { my ($mod, $ver) = @_; @@ -216,6 +256,19 @@ sub modver_gt_or_eq ($$) { eval { $mod->VERSION($ver) } ? 1 : 0; } +sub modver_gt_or_eq_and_lt ($$$) { + my ($mod, $v_ge, $v_lt) = @_; + + croak "Nonsensical maximum version supplied" + if ! defined $v_lt or $v_lt =~ /[^0-9\.\_]/; + + return ( + modver_gt_or_eq($mod, $v_ge) + and + ! modver_gt_or_eq($mod, $v_lt) + ) ? 1 : 0; +} + { my $list_ctx_ok_stack_marker; @@ -227,7 +280,7 @@ sub modver_gt_or_eq ($$) { } my $cf = 1; - while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?: + while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?: # these are public API parts that alter behavior on wantarray search | search_related | slice | search_literal @@ -245,8 +298,8 @@ sub modver_gt_or_eq ($$) { my ($fr, $want, $argdesc); { package DB; - $fr = [ caller($cf) ]; - $want = ( caller($cf-1) )[5]; + $fr = [ CORE::caller($cf) ]; + $want = ( CORE::caller($cf-1) )[5]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) : 'non ' @@ -272,7 +325,7 @@ sub fail_on_internal_call { my ($fr, $argdesc); { package DB; - $fr = [ caller(1) ]; + $fr = [ CORE::caller(1) ]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) : undef