lib/DBIx/Class/_Util.pm

   1 package # hide from PAUSE
   2   DBIx::Class::_Util;
   3
   4 use DBIx::Class::StartupCheck;  # load es early as we can, usually a noop
   5
   6 use warnings;
   7 use strict;
   8
   9 # For the love of everything that is crab-like: DO NOT reach into this
  10 # The entire thing is really fragile and should not be screwed with
  11 # unless absolutely and unavoidably necessary
  12 our $__describe_class_query_cache;
  13
  14 BEGIN {
  15   package # hide from pause
  16     DBIx::Class::_ENV_;
  17
  18   use Config;
  19
  20   use constant {
  21     PERL_VERSION => "$]",
  22     OS_NAME => "$^O",
  23   };
  24
  25   use constant {
  26
  27     # but of course
  28     BROKEN_FORK => (OS_NAME eq 'MSWin32') ? 1 : 0,
  29
  30     BROKEN_GOTO => ( PERL_VERSION < 5.008003 ) ? 1 : 0,
  31
  32     # perl -MScalar::Util=weaken -e 'weaken( $hash{key} = \"value" )'
  33     BROKEN_WEAK_SCALARREF_VALUES => ( PERL_VERSION < 5.008003 ) ? 1 : 0,
  34
  35     HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
  36
  37     TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1
  38
  39     UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0,
  40
  41     ( map
  42       #
  43       # the "DBIC_" prefix below is crucial - this is what makes CI pick up
  44       # all envvars without further adjusting its scripts
  45       # DO NOT CHANGE to the more logical { $_ => !!( $ENV{"DBIC_$_"} ) }
  46       #
  47       { substr($_, 5) => !!( $ENV{$_} ) }
  48       qw(
  49         DBIC_SHUFFLE_UNORDERED_RESULTSETS
  50         DBIC_ASSERT_NO_INTERNAL_WANTARRAY
  51         DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
  52         DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
  53         DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
  54         DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
  55       )
  56     ),
  57
  58     IV_SIZE => $Config{ivsize},
  59   };
  60
  61   if ( PERL_VERSION < 5.009_005) {
  62     require MRO::Compat;
  63     constant->import( OLD_MRO => 1 );
  64
  65     #
  66     # Yes, I know this is a rather PHP-ish name, but please first read
  67     # https://metacpan.org/source/BOBTFISH/MRO-Compat-0.12/lib/MRO/Compat.pm#L363-368
  68     #
  69     # Even if we are using Class::C3::XS it still won't work, as doing
  70     #   defined( *{ "SubClass::"->{$_} }{CODE} )
  71     # will set pkg_gen to the same value for SubClass and *ALL PARENTS*
  72     #
  73     *DBIx::Class::_Util::get_real_pkg_gen = sub ($) {
  74       require Digest::MD5;
  75       require Math::BigInt;
  76
  77       my $cur_class;
  78       no strict 'refs';
  79
  80       # the non-assign-unless-there-is-a-hash is deliberate
  81       ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{gen} ||= (
  82         Math::BigInt->new( '0x' . ( Digest::MD5::md5_hex( join "\0", map {
  83
  84           ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_}{methlist} ||= (
  85
  86             $cur_class = $_
  87
  88               and
  89
  90             # RV to be hashed up and turned into a number
  91             join "\0", (
  92               $cur_class,
  93               map
  94                 {(
  95                   # stringification should be sufficient, ignore names/refaddr entirely
  96                   $_,
  97                   do {
  98                     my @attrs;
  99                     local $@;
 100                     local $SIG{__DIE__} if $SIG{__DIE__};
 101                     # attributes::get may throw on blessed-false crefs :/
 102                     eval { @attrs = attributes::get( $_ ); 1 }
 103                       or warn "Unable to determine attributes of coderef $_ due to the following error: $@";
 104                     @attrs;
 105                   },
 106                 )}
 107                 map
 108                   {(
 109                     # skip dummy C::C3 helper crefs
 110                     ! ( ( $Class::C3::MRO{$cur_class} || {} )->{methods}{$_} )
 111                       and
 112                     (
 113                       ref(\ "${cur_class}::"->{$_} ) ne 'GLOB'
 114                         or
 115                       defined( *{ "${cur_class}::"->{$_} }{CODE} )
 116                     )
 117                   )
 118                     ? ( \&{"${cur_class}::$_"} )
 119                     : ()
 120                   }
 121                   keys %{ "${cur_class}::" }
 122             )
 123           )
 124         } (
 125
 126           @{
 127             ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{linear_isa}
 128               ||=
 129             mro::get_linear_isa($_[0])
 130           },
 131
 132           ((
 133             ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{is_universal}
 134               ||=
 135             mro::is_universal($_[0])
 136           ) ? () : @{
 137             ( $__describe_class_query_cache->{'!internal!'} || {} )->{UNIVERSAL}{linear_isa}
 138               ||=
 139             mro::get_linear_isa("UNIVERSAL")
 140           } ),
 141
 142         ) ) ) )
 143       );
 144     };
 145   }
 146   else {
 147     require mro;
 148     constant->import( OLD_MRO => 0 );
 149     *DBIx::Class::_Util::get_real_pkg_gen = \&mro::get_pkg_gen;
 150   }
 151
 152   # Both of these are no longer used for anything. However bring
 153   # them back after they were purged in 08a8d8f1, as there appear
 154   # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/*
 155   # in their production codebases. There is no point in breaking these
 156   # if whatever they used actually continues to work
 157   my $sigh = sub {
 158     DBIx::Class::_Util::emit_loud_diag(
 159       skip_frames => 1,
 160       msg => "The @{[ (caller(1))[3] ]} constant is no more - adjust your code"
 161     );
 162
 163     0;
 164   };
 165   sub DBICTEST () { &$sigh }
 166   sub PEEPEENESS () { &$sigh }
 167 }
 168
 169 use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ? 1 : 0);
 170
 171 # FIXME - this is not supposed to be here
 172 # Carp::Skip to the rescue soon
 173 use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
 174
 175 use B ();
 176 use Carp 'croak';
 177 use Storable 'nfreeze';
 178 use Scalar::Util qw(weaken blessed reftype refaddr);
 179 use Sub::Name ();
 180 use attributes ();
 181
 182 # Usually versions are not specified anywhere aside the Makefile.PL
 183 # (writing them out in-code is extremely obnoxious)
 184 # However without a recent enough Moo the quote_sub override fails
 185 # in very puzzling and hard to detect ways: so add a version check
 186 # just this once
 187 use Sub::Quote qw(qsub);
 188 BEGIN { Sub::Quote->VERSION('2.002002') }
 189
 190 # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
 191 BEGIN { *deep_clone = \&Storable::dclone }
 192
 193 use base 'Exporter';
 194 our @EXPORT_OK = qw(
 195   sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
 196   fail_on_internal_wantarray fail_on_internal_call
 197   refdesc refcount hrefaddr set_subname get_subname describe_class_methods
 198   scope_guard detected_reinvoked_destructor emit_loud_diag
 199   true false
 200   is_exception dbic_internal_try visit_namespaces
 201   quote_sub qsub perlstring serialize deep_clone dump_value uniq
 202   parent_dir mkdir_p
 203   UNRESOLVABLE_CONDITION
 204 );
 205
 206 use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
 207
 208 # Override forcing no_defer, and adding naming consistency checks
 209 our %refs_closed_over_by_quote_sub_installed_crefs;
 210 sub quote_sub {
 211   Carp::confess( "Anonymous quoting not supported by the DBIC quote_sub override - supply a sub name" ) if
 212     @_ < 2
 213       or
 214     ! defined $_[1]
 215       or
 216     length ref $_[1]
 217   ;
 218
 219   Carp::confess( "The DBIC quote_sub override expects sub name '$_[0]' to be fully qualified" )
 220     unless (my $stash) = $_[0] =~ /^(.+)::/;
 221
 222   Carp::confess(
 223     "The DBIC sub_quote override does not support 'no_install'"
 224   ) if (
 225     $_[3]
 226       and
 227     $_[3]->{no_install}
 228   );
 229
 230   Carp::confess(
 231     'The DBIC quote_sub override expects the namespace-part of sub name '
 232   . "'$_[0]' to match the supplied package argument '$_[3]->{package}'"
 233   ) if (
 234     $_[3]
 235       and
 236     defined $_[3]->{package}
 237       and
 238     $stash ne $_[3]->{package}
 239   );
 240
 241   my @caller = caller(0);
 242   my $sq_opts = {
 243     package => $caller[0],
 244     hints => $caller[8],
 245     warning_bits => $caller[9],
 246     hintshash => $caller[10],
 247     %{ $_[3] || {} },
 248
 249     # explicitly forced for everything
 250     no_defer => 1,
 251   };
 252
 253   weaken (
 254     # just use a growing counter, no need to perform neither compaction
 255     # nor any special ithread-level handling
 256     $refs_closed_over_by_quote_sub_installed_crefs
 257      { scalar keys %refs_closed_over_by_quote_sub_installed_crefs }
 258       = $_
 259   ) for grep {
 260     length ref $_
 261       and
 262     (
 263       ! DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES
 264         or
 265       ref $_ ne 'SCALAR'
 266     )
 267   } values %{ $_[2] || {} };
 268
 269   Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts );
 270 }
 271
 272 sub sigwarn_silencer ($) {
 273   my $pattern = shift;
 274
 275   croak "Expecting a regexp" if ref $pattern ne 'Regexp';
 276
 277   my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
 278
 279   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
 280 }
 281
 282 sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };
 283
 284 sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 }
 285
 286 sub refdesc ($) {
 287   croak "Expecting a reference" if ! length ref $_[0];
 288
 289   # be careful not to trigger stringification,
 290   # reuse @_ as a scratch-pad
 291   sprintf '%s%s(0x%x)',
 292     ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ),
 293     reftype $_[0],
 294     refaddr($_[0]),
 295   ;
 296 }
 297
 298 sub refcount ($) {
 299   croak "Expecting a reference" if ! length ref $_[0];
 300
 301   # No tempvars - must operate on $_[0], otherwise the pad
 302   # will count as an extra ref
 303   B::svref_2object($_[0])->REFCNT;
 304 }
 305
 306 sub visit_namespaces {
 307   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 308
 309   my $visited_count = 1;
 310
 311   # A package and a namespace are subtly different things
 312   $args->{package} ||= 'main';
 313   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 314   $args->{package} =~ s/^:://;
 315
 316   if ( $args->{action}->($args->{package}) ) {
 317     my $ns =
 318       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 319         .
 320       '::'
 321     ;
 322
 323     $visited_count += visit_namespaces( %$args, package => $_ ) for
 324       grep
 325         # this happens sometimes on %:: traversal
 326         { $_ ne '::main' }
 327         map
 328           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 329           do { no strict 'refs'; keys %$ns }
 330     ;
 331   }
 332
 333   $visited_count;
 334 }
 335
 336 # FIXME In another life switch these to a polyfill like the ones in namespace::clean
 337 sub get_subname ($) {
 338   my $gv = B::svref_2object( $_[0] )->GV;
 339   wantarray
 340     ? ( $gv->STASH->NAME, $gv->NAME )
 341     : ( join '::', $gv->STASH->NAME, $gv->NAME )
 342   ;
 343 }
 344 sub set_subname ($$) {
 345
 346   # fully qualify name
 347   splice @_, 0, 1, caller(0) . "::$_[0]"
 348     if $_[0] !~ /::|'/;
 349
 350   &Sub::Name::subname;
 351 }
 352
 353 sub serialize ($) {
 354   local $Storable::canonical = 1;
 355   nfreeze($_[0]);
 356 }
 357
 358 sub uniq {
 359   my( %seen, $seen_undef, $numeric_preserving_copy );
 360   grep { not (
 361     defined $_
 362       ? $seen{ $numeric_preserving_copy = $_ }++
 363       : $seen_undef++
 364   ) } @_;
 365 }
 366
 367 my $dd_obj;
 368 sub dump_value ($) {
 369   local $Data::Dumper::Indent = 1
 370     unless defined $Data::Dumper::Indent;
 371
 372   my $dump_str = (
 373     $dd_obj
 374       ||=
 375     do {
 376       require Data::Dumper;
 377       my $d = Data::Dumper->new([])
 378         ->Purity(0)
 379         ->Pad('')
 380         ->Useqq(1)
 381         ->Terse(1)
 382         ->Freezer('')
 383         ->Quotekeys(0)
 384         ->Bless('bless')
 385         ->Pair(' => ')
 386         ->Sortkeys(1)
 387         ->Deparse(1)
 388       ;
 389
 390       $d->Sparseseen(1) if modver_gt_or_eq (
 391         'Data::Dumper', '2.136'
 392       );
 393
 394       $d;
 395     }
 396   )->Values([$_[0]])->Dump;
 397
 398   $dd_obj->Reset->Values([]);
 399
 400   $dump_str;
 401 }
 402
 403 my $seen_loud_screams;
 404 sub emit_loud_diag {
 405   my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ };
 406
 407   unless ( defined $args->{msg} and length $args->{msg} ) {
 408     emit_loud_diag(
 409       msg => "No 'msg' value supplied to emit_loud_diag()"
 410     );
 411     exit 70;
 412   }
 413
 414   my $msg = "\n" . join( ': ',
 415     ( $0 eq '-e' ? () : $0 ),
 416     $args->{msg}
 417   );
 418
 419   # when we die - we usually want to keep doing it
 420   $args->{emit_dups} = !!$args->{confess}
 421     unless exists $args->{emit_dups};
 422
 423   local $Carp::CarpLevel =
 424     ( $args->{skip_frames} || 0 )
 425       +
 426     $Carp::CarpLevel
 427       +
 428     # hide our own frame
 429     1
 430   ;
 431
 432   my $longmess = Carp::longmess();
 433
 434   # different object references will thwart deduplication without this
 435   ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi;
 436
 437   return $seen_loud_screams->{$key} if
 438     $seen_loud_screams->{$key}++
 439       and
 440     ! $args->{emit_dups}
 441   ;
 442
 443   $msg .= $longmess
 444     unless $msg =~ /\n\z/;
 445
 446   print STDERR "$msg\n"
 447     or
 448   print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n";
 449
 450   return $seen_loud_screams->{$key}
 451     unless $args->{confess};
 452
 453   # increment *again*, because... Carp.
 454   $Carp::CarpLevel++;
 455
 456   # not $msg - Carp will reapply the longmess on its own
 457   Carp::confess($args->{msg});
 458 }
 459
 460
 461 ###
 462 ### This is *NOT* boolean.pm - deliberately not using a singleton
 463 ###
 464 {
 465   package # hide from pause
 466     DBIx::Class::_Util::_Bool;
 467   use overload
 468     bool => sub { ${$_[0]} },
 469     fallback => 1,
 470   ;
 471 }
 472 sub true () { my $x = 1; bless \$x, "DBIx::Class::_Util::_Bool" }
 473 sub false () { my $x = 0; bless \$x, "DBIx::Class::_Util::_Bool" }
 474
 475 sub scope_guard (&) {
 476   croak 'Calling scope_guard() in void context makes no sense'
 477     if ! defined wantarray;
 478
 479   # no direct blessing of coderefs - DESTROY is buggy on those
 480   bless [ $_[0] ], 'DBIx::Class::_Util::ScopeGuard';
 481 }
 482 {
 483   package #
 484     DBIx::Class::_Util::ScopeGuard;
 485
 486   sub DESTROY {
 487     &DBIx::Class::_Util::detected_reinvoked_destructor;
 488
 489     local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
 490
 491     eval {
 492       $_[0]->[0]->();
 493       1;
 494     }
 495       or
 496     DBIx::Class::_Util::emit_loud_diag(
 497       emit_dups => 1,
 498       msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n "
 499     );
 500   }
 501 }
 502
 503
 504 sub is_exception ($) {
 505   my $e = $_[0];
 506
 507   # FIXME
 508   # this is not strictly correct - an eval setting $@ to undef
 509   # is *not* the same as an eval setting $@ to ''
 510   # but for the sake of simplicity assume the following for
 511   # the time being
 512   return 0 unless defined $e;
 513
 514   my ($not_blank, $suberror);
 515   {
 516     local $SIG{__DIE__} if $SIG{__DIE__};
 517     local $@;
 518     eval {
 519       # The ne() here is deliberate - a plain length($e), or worse "$e" ne
 520       # will entirely obviate the need for the encolsing eval{}, as the
 521       # condition we guard against is a missing fallback overload
 522       $not_blank = ( $e ne '' );
 523       1;
 524     } or $suberror = $@;
 525   }
 526
 527   if (defined $suberror) {
 528     if (length (my $class = blessed($e) )) {
 529       carp_unique( sprintf(
 530         'External exception class %s implements partial (broken) overloading '
 531       . 'preventing its instances from being used in simple ($x eq $y) '
 532       . 'comparisons. Given Perl\'s "globally cooperative" exception '
 533       . 'handling this type of brokenness is extremely dangerous on '
 534       . 'exception objects, as it may (and often does) result in silent '
 535       . '"exception substitution". DBIx::Class tries to work around this '
 536       . 'as much as possible, but other parts of your software stack may '
 537       . 'not be even aware of this. Please submit a bugreport against the '
 538       . 'distribution containing %s and in the meantime apply a fix similar '
 539       . 'to the one shown at %s, in order to ensure your exception handling '
 540       . 'is saner application-wide. What follows is the actual error text '
 541       . "as generated by Perl itself:\n\n%s\n ",
 542         $class,
 543         $class,
 544         'http://v.gd/DBIC_overload_tempfix/',
 545         $suberror,
 546       ));
 547
 548       # workaround, keeps spice flowing
 549       $not_blank = !!( length $e );
 550     }
 551     else {
 552       # not blessed yet failed the 'ne'... this makes 0 sense...
 553       # just throw further
 554       die $suberror
 555     }
 556   }
 557   elsif (
 558     # a ref evaluating to '' is definitively a "null object"
 559     ( not $not_blank )
 560       and
 561     length( my $class = ref $e )
 562   ) {
 563     carp_unique(
 564       "Objects of external exception class '$class' stringify to '' (the "
 565     . 'empty string), implementing the so called null-object-pattern. '
 566     . 'Given Perl\'s "globally cooperative" exception handling using this '
 567     . 'class of exceptions is extremely dangerous, as it may (and often '
 568     . 'does) result in silent discarding of errors. DBIx::Class tries to '
 569     . 'work around this as much as possible, but other parts of your '
 570     . 'software stack may not be even aware of the problem. Please submit '
 571     . "a bugreport against the distribution containing '$class'",
 572     );
 573
 574     $not_blank = 1;
 575   }
 576
 577   return $not_blank;
 578 }
 579
 580 {
 581   my $callstack_state;
 582
 583   # Recreate the logic of try(), while reusing the catch()/finally() as-is
 584   #
 585   # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
 586   # yes, shows up ON TOP of profiles) but this is a batle for another maint
 587   sub dbic_internal_try (&;@) {
 588
 589     my $try_cref = shift;
 590     my $catch_cref = undef;  # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311
 591
 592     for my $arg (@_) {
 593
 594       if( ref($arg) eq 'Try::Tiny::Catch' ) {
 595
 596         croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
 597           if $catch_cref;
 598
 599         $catch_cref = $$arg;
 600       }
 601       elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
 602         croak 'dbic_internal_try() does not support finally{}';
 603       }
 604       else {
 605         croak(
 606           'dbic_internal_try() encountered an unexpected argument '
 607         . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
 608         . 'a missing semi-colon before or ' # trailing space important
 609         );
 610       }
 611     }
 612
 613     my $wantarray = wantarray;
 614     my $preexisting_exception = $@;
 615
 616     my @ret;
 617     my $all_good = eval {
 618       $@ = $preexisting_exception;
 619
 620       local $callstack_state->{in_internal_try} = 1
 621         unless $callstack_state->{in_internal_try};
 622
 623       # always unset - someone may have snuck it in
 624       local $SIG{__DIE__} if $SIG{__DIE__};
 625
 626       if( $wantarray ) {
 627         @ret = $try_cref->();
 628       }
 629       elsif( defined $wantarray ) {
 630         $ret[0] = $try_cref->();
 631       }
 632       else {
 633         $try_cref->();
 634       }
 635
 636       1;
 637     };
 638
 639     my $exception = $@;
 640     $@ = $preexisting_exception;
 641
 642     if ( $all_good ) {
 643       return $wantarray ? @ret : $ret[0]
 644     }
 645     elsif ( $catch_cref ) {
 646       for ( $exception ) {
 647         return $catch_cref->($exception);
 648       }
 649     }
 650
 651     return;
 652   }
 653
 654   sub in_internal_try { !! $callstack_state->{in_internal_try} }
 655 }
 656
 657 {
 658   my $destruction_registry = {};
 659
 660   sub DBIx::Class::__Util_iThreads_handler__::CLONE {
 661     %$destruction_registry = map {
 662       (defined $_)
 663         ? ( refaddr($_) => $_ )
 664         : ()
 665     } values %$destruction_registry;
 666
 667     weaken($_) for values %$destruction_registry;
 668
 669     # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 670     # collected before leaving this scope. Depending on the code above, this
 671     # may very well be just a preventive measure guarding future modifications
 672     undef;
 673   }
 674
 675   # This is almost invariably invoked from within DESTROY
 676   # throwing exceptions won't work
 677   sub detected_reinvoked_destructor {
 678
 679     # quick "garbage collection" pass - prevents the registry
 680     # from slowly growing with a bunch of undef-valued keys
 681     defined $destruction_registry->{$_} or delete $destruction_registry->{$_}
 682       for keys %$destruction_registry;
 683
 684     if (! length ref $_[0]) {
 685       emit_loud_diag(
 686         emit_dups => 1,
 687         msg => (caller(0))[3] . '() expects a blessed reference'
 688       );
 689       return undef; # don't know wtf to do
 690     }
 691     elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
 692       weaken( $destruction_registry->{$addr} = $_[0] );
 693       return 0;
 694     }
 695     else {
 696       emit_loud_diag( msg => sprintf (
 697         'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY '
 698       . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your '
 699       . 'application, affecting *ALL* classes without active protection against '
 700       . 'this. Diagnose and fix the root cause ASAP!!!%s',
 701       refdesc $_[0],
 702         ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } )
 703           ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)"
 704           : ''
 705         )
 706       ));
 707
 708       return 1;
 709     }
 710   }
 711 }
 712
 713 my $module_name_rx = qr/ \A [A-Z_a-z] [0-9A-Z_a-z]* (?: :: [0-9A-Z_a-z]+ )* \z /x;
 714 my $ver_rx =         qr/ \A [0-9]+ (?: \. [0-9]+ )* (?: \_ [0-9]+ )*        \z /x;
 715
 716 sub modver_gt_or_eq ($$) {
 717   my ($mod, $ver) = @_;
 718
 719   croak "Nonsensical module name supplied"
 720     if ! defined $mod or $mod !~ $module_name_rx;
 721
 722   croak "Nonsensical minimum version supplied"
 723     if ! defined $ver or $ver !~ $ver_rx;
 724
 725   no strict 'refs';
 726   my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
 727     ? {}
 728     : croak "$mod does not seem to provide a version (perhaps it never loaded)"
 729   );
 730
 731   ! defined $ver_cache->{$ver}
 732     and
 733   $ver_cache->{$ver} = do {
 734
 735     local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
 736       if SPURIOUS_VERSION_CHECK_WARNINGS;
 737
 738     local $SIG{__DIE__} if $SIG{__DIE__};
 739     local $@;
 740     eval { $mod->VERSION($ver) } ? 1 : 0;
 741   };
 742
 743   $ver_cache->{$ver};
 744 }
 745
 746 sub modver_gt_or_eq_and_lt ($$$) {
 747   my ($mod, $v_ge, $v_lt) = @_;
 748
 749   croak "Nonsensical maximum version supplied"
 750     if ! defined $v_lt or $v_lt !~ $ver_rx;
 751
 752   return (
 753     modver_gt_or_eq($mod, $v_ge)
 754       and
 755     ! modver_gt_or_eq($mod, $v_lt)
 756   ) ? 1 : 0;
 757 }
 758
 759 {
 760
 761   sub describe_class_methods {
 762     my $args = (
 763       ref $_[0] eq 'HASH'                 ? $_[0]
 764     : ( @_ == 1 and ! length ref $_[0] )  ? { class => $_[0] }
 765     :                                       { @_ }
 766     );
 767
 768     my ($class, $requested_mro) = @{$args}{qw( class use_mro )};
 769
 770     croak "Expecting a class name either as the sole argument or a 'class' option"
 771       if not defined $class or $class !~ $module_name_rx;
 772
 773     croak(
 774       "The supplied 'class' argument is tainted: this is *extremely* "
 775     . 'dangerous, fix your code ASAP!!! ( for more details read through '
 776     . 'https://is.gd/perl_mro_taint_wtf )'
 777     ) if (
 778       DBIx::Class::_ENV_::TAINT_MODE
 779         and
 780       Scalar::Util::tainted($class)
 781     );
 782
 783     $requested_mro ||= mro::get_mro($class);
 784
 785     # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
 786     my $query_cache_key = "$class|$requested_mro";
 787
 788     my $internal_cache_key =
 789       ( mro::get_mro($class) eq $requested_mro )
 790         ? $class
 791         : $query_cache_key
 792     ;
 793
 794     # use a cache on old MRO, since while we are recursing in this function
 795     # nothing can possibly change (the speedup is immense)
 796     # (yes, people could be tie()ing the stash and adding methods on access
 797     # but there is a limit to how much crazy can be supported here)
 798     #
 799     # we use the cache for linear_isa lookups on new MRO as well - it adds
 800     # a *tiny* speedup, and simplifies the code a lot
 801     #
 802     local $__describe_class_query_cache->{'!internal!'} = {}
 803       unless $__describe_class_query_cache->{'!internal!'};
 804
 805     my $my_gen = 0;
 806
 807     $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = (
 808
 809       @{
 810         $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}
 811           ||=
 812         mro::get_linear_isa($class, $requested_mro)
 813       },
 814
 815       ((
 816         $__describe_class_query_cache->{'!internal!'}{$class}{is_universal}
 817           ||=
 818         mro::is_universal($class)
 819       ) ? () : @{
 820         $__describe_class_query_cache->{'!internal!'}{UNIVERSAL}{linear_isa}
 821           ||=
 822         mro::get_linear_isa("UNIVERSAL")
 823       }),
 824
 825     ));
 826
 827     my $slot = $__describe_class_query_cache->{$query_cache_key} ||= {};
 828
 829     unless ( ($slot->{cumulative_gen}||0) == $my_gen ) {
 830
 831       # reset
 832       %$slot = (
 833         class => $class,
 834         isa => { map { $_ => 1 } @full_ISA },
 835         linear_isa => [
 836           @{ $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} }
 837             [ 1 .. $#{$__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}} ]
 838         ],
 839         mro => {
 840           type => $requested_mro,
 841           is_c3 => ( ($requested_mro eq 'c3') ? 1 : 0 ),
 842         },
 843         cumulative_gen => $my_gen,
 844       );
 845
 846       # remove ourselves from ISA
 847       shift @full_ISA;
 848
 849       # ensure the cache is populated for the parents, code below can then
 850       # efficiently operate over the query_cache directly
 851       describe_class_methods($_) for reverse @full_ISA;
 852
 853       no strict 'refs';
 854
 855       # combine full ISA-order inherited and local method list into a
 856       # "shadowing stack"
 857
 858       (
 859         unshift @{ $slot->{methods}{$_->{name}} }, $_
 860
 861           and
 862
 863         (
 864           $_->{via_class} ne $class
 865             or
 866           $slot->{methods_defined_in_class}{$_->{name}} = $_
 867         )
 868
 869           and
 870
 871         @{ $slot->{methods}{$_->{name}} } > 1
 872
 873           and
 874
 875         $slot->{methods_with_supers}{$_->{name}} = $slot->{methods}{$_->{name}}
 876
 877       ) for (
 878
 879         # what describe_class_methods for @full_ISA produced above
 880         ( map { values %{
 881           $__describe_class_query_cache->{$_}{methods_defined_in_class} || {}
 882         } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ),
 883
 884         # our own non-cleaned subs + their attributes
 885         ( map {
 886           (
 887             # need to account for dummy helper crefs under OLD_MRO
 888             (
 889               ! DBIx::Class::_ENV_::OLD_MRO
 890                 or
 891               ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} )
 892             )
 893               and
 894             # these 2 OR-ed checks are sufficient for 5.10+
 895             (
 896               ref(\ "${class}::"->{$_} ) ne 'GLOB'
 897                 or
 898               defined( *{ "${class}::"->{$_} }{CODE} )
 899             )
 900           ) ? {
 901               via_class => $class,
 902               name => $_,
 903               attributes => { map { $_ => 1 } do {
 904                 my @attrs;
 905                 local $@;
 906                 local $SIG{__DIE__} if $SIG{__DIE__};
 907                 # attributes::get may throw on blessed-false crefs :/
 908                 eval { @attrs = attributes::get( \&{"${class}::${_}"} ); 1 }
 909                   or warn "Unable to determine attributes of the \\&${class}::$_ method due to following error: $@";
 910                 @attrs;
 911               } },
 912             }
 913             : ()
 914         } keys %{"${class}::"} )
 915       );
 916
 917
 918       # recalculate the pkg_gen on newer perls under Taint mode,
 919       # because of shit like:
 920       # perl -T -Mmro -e 'package Foo; sub bar {}; defined( *{ "Foo::"->{bar}}{CODE} ) and warn mro::get_pkg_gen("Foo") for (1,2,3)'
 921       #
 922       if (
 923         ! DBIx::Class::_ENV_::OLD_MRO
 924           and
 925         DBIx::Class::_ENV_::TAINT_MODE
 926       ) {
 927
 928         $slot->{cumulative_gen} = 0;
 929         $slot->{cumulative_gen} += get_real_pkg_gen($_)
 930           for $class, @full_ISA;
 931       }
 932     }
 933
 934     # RV
 935     +{ %$slot };
 936   }
 937 }
 938
 939
 940 #
 941 # Why not just use some higher-level module or at least File::Spec here?
 942 # Because:
 943 # 1)  This is a *very* rarely used function, and the deptree is large
 944 #     enough already as it is
 945 #
 946 # 2)  (more importantly) Our tooling is utter shit in this area. There
 947 #     is no comprehensive support for UNC paths in PathTools and there
 948 #     are also various small bugs in representation across different
 949 #     path-manipulation CPAN offerings.
 950 #
 951 # Since this routine is strictly used for logical path processing (it
 952 # *must* be able to work with not-yet-existing paths), use this seemingly
 953 # simple but I *think* complete implementation to feed to other consumers
 954 #
 955 # If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST*
 956 # the impulse to bring in an external dependency. During runtime there
 957 # is exactly one spot that could potentially maybe once in a blue moon
 958 # use this function. Keep it lean.
 959 #
 960 sub parent_dir ($) {
 961   ( $_[0] =~ m{  [\/\\]  ( \.{0,2} ) ( [\/\\]* ) \z }x )
 962     ? (
 963       $_[0]
 964         .
 965       ( ( length($1) and ! length($2) ) ? '/' : '' )
 966         .
 967       '../'
 968     )
 969     : (
 970       require File::Spec
 971         and
 972       File::Spec->catpath (
 973         ( File::Spec->splitpath( "$_[0]" ) )[0,1],
 974         '/',
 975       )
 976     )
 977   ;
 978 }
 979
 980 sub mkdir_p ($) {
 981   require File::Path;
 982   # do not ask for a recent version, use 1.x API calls
 983   File::Path::mkpath([ "$_[0]" ]);  # File::Path does not like objects
 984 }
 985
 986
 987 {
 988   my $list_ctx_ok_stack_marker;
 989
 990   sub fail_on_internal_wantarray () {
 991     return if $list_ctx_ok_stack_marker;
 992
 993     if (! defined wantarray) {
 994       croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
 995     }
 996
 997     my $cf = 1;
 998     while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?:
 999
1000       # these are public API parts that alter behavior on wantarray
1001       search | search_related | slice | search_literal
1002
1003         |
1004
1005       # these are explicitly prefixed, since we only recognize them as valid
1006       # escapes when they come from the guts of CDBICompat
1007       CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
1008
1009     ) $/x ) {
1010       $cf++;
1011     }
1012
1013     my ($fr, $want, $argdesc);
1014     {
1015       package DB;
1016       $fr = [ CORE::caller($cf) ];
1017       $want = ( CORE::caller($cf-1) )[5];
1018       $argdesc = ref $DB::args[0]
1019         ? DBIx::Class::_Util::refdesc($DB::args[0])
1020         : 'non '
1021       ;
1022     };
1023
1024     if (
1025       $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
1026     ) {
1027       DBIx::Class::Exception->throw( sprintf (
1028         "Improper use of %s instance in list context at %s line %d\n\n    Stacktrace starts",
1029         $argdesc, @{$fr}[1,2]
1030       ), 'with_stacktrace');
1031     }
1032
1033     weaken( $list_ctx_ok_stack_marker = my $mark = [] );
1034
1035     $mark;
1036   }
1037 }
1038
1039 sub fail_on_internal_call {
1040   my ($fr, $argdesc);
1041   {
1042     package DB;
1043     $fr = [ CORE::caller(1) ];
1044     $argdesc =
1045       ( not defined $DB::args[0] )  ? 'UNAVAILABLE'
1046     : ( length ref $DB::args[0] )   ? DBIx::Class::_Util::refdesc($DB::args[0])
1047     : $DB::args[0] . ''
1048     ;
1049   };
1050
1051   my @fr2;
1052   # need to make allowance for a proxy-yet-direct call
1053   my $check_fr = (
1054     $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
1055       and
1056     @fr2 = (CORE::caller(2))
1057       and
1058     (
1059       ( $fr->[3] =~ /([^:])+$/ )[0]
1060         eq
1061       ( $fr2[3] =~ /([^:])+$/ )[0]
1062     )
1063   )
1064     ? \@fr2
1065     : $fr
1066   ;
1067
1068   if (
1069     defined $fr->[0]
1070       and
1071     $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
1072       and
1073     $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
1074   ) {
1075     DBIx::Class::Exception->throw( sprintf (
1076       "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",
1077       $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
1078         require B::Deparse;
1079         no strict 'refs';
1080         B::Deparse->new->coderef2text(\&{$fr->[3]})
1081       }),
1082     ), 'with_stacktrace');
1083   }
1084 }
1085
1086 if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) {
1087
1088   no warnings 'redefine';
1089
1090   my $next_bless = defined(&CORE::GLOBAL::bless)
1091     ? \&CORE::GLOBAL::bless
1092     : sub { CORE::bless($_[0], $_[1]) }
1093   ;
1094
1095   *CORE::GLOBAL::bless = sub {
1096     my $class = (@_ > 1) ? $_[1] : CORE::caller();
1097
1098     # allow for reblessing (role application)
1099     return $next_bless->( $_[0], $class )
1100       if defined blessed $_[0];
1101
1102     my $obj = $next_bless->( $_[0], $class );
1103
1104     my $calling_sub = (CORE::caller(1))[3] || '';
1105
1106     (
1107       # before 5.18 ->isa() will choke on the "0" package
1108       # which we test for in several obscure cases, sigh...
1109       !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 )
1110         or
1111       $class
1112     )
1113       and
1114     (
1115       (
1116         $calling_sub !~ /^ (?:
1117           DBIx::Class::Schema::clone
1118             |
1119           DBIx::Class::DB::setup_schema_instance
1120         )/x
1121           and
1122         $class->isa("DBIx::Class::Schema")
1123       )
1124         or
1125       (
1126         $calling_sub ne 'DBIx::Class::ResultSource::new'
1127           and
1128         $class->isa("DBIx::Class::ResultSource")
1129       )
1130     )
1131       and
1132     local $Carp::CarpLevel = $Carp::CarpLevel + 1
1133       and
1134     Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor");
1135
1136
1137     $obj;
1138   };
1139 }
1140
1141 1;