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$0: $args->{msg}";
 415
 416   # when we die - we usually want to keep doing it
 417   $args->{emit_dups} = !!$args->{confess}
 418     unless exists $args->{emit_dups};
 419
 420   local $Carp::CarpLevel =
 421     ( $args->{skip_frames} || 0 )
 422       +
 423     $Carp::CarpLevel
 424       +
 425     # hide our own frame
 426     1
 427   ;
 428
 429   my $longmess = Carp::longmess();
 430
 431   # different object references will thwart deduplication without this
 432   ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi;
 433
 434   return $seen_loud_screams->{$key} if
 435     $seen_loud_screams->{$key}++
 436       and
 437     ! $args->{emit_dups}
 438   ;
 439
 440   $msg .= $longmess
 441     unless $msg =~ /\n\z/;
 442
 443   print STDERR "$msg\n"
 444     or
 445   print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n";
 446
 447   return $seen_loud_screams->{$key}
 448     unless $args->{confess};
 449
 450   # increment *again*, because... Carp.
 451   $Carp::CarpLevel++;
 452
 453   # not $msg - Carp will reapply the longmess on its own
 454   Carp::confess($args->{msg});
 455 }
 456
 457
 458 ###
 459 ### This is *NOT* boolean.pm - deliberately not using a singleton
 460 ###
 461 {
 462   package # hide from pause
 463     DBIx::Class::_Util::_Bool;
 464   use overload
 465     bool => sub { ${$_[0]} },
 466     fallback => 1,
 467   ;
 468 }
 469 sub true () { my $x = 1; bless \$x, "DBIx::Class::_Util::_Bool" }
 470 sub false () { my $x = 0; bless \$x, "DBIx::Class::_Util::_Bool" }
 471
 472 sub scope_guard (&) {
 473   croak 'Calling scope_guard() in void context makes no sense'
 474     if ! defined wantarray;
 475
 476   # no direct blessing of coderefs - DESTROY is buggy on those
 477   bless [ $_[0] ], 'DBIx::Class::_Util::ScopeGuard';
 478 }
 479 {
 480   package #
 481     DBIx::Class::_Util::ScopeGuard;
 482
 483   sub DESTROY {
 484     &DBIx::Class::_Util::detected_reinvoked_destructor;
 485
 486     local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
 487
 488     eval {
 489       $_[0]->[0]->();
 490       1;
 491     }
 492       or
 493     DBIx::Class::_Util::emit_loud_diag(
 494       emit_dups => 1,
 495       msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n "
 496     );
 497   }
 498 }
 499
 500
 501 sub is_exception ($) {
 502   my $e = $_[0];
 503
 504   # FIXME
 505   # this is not strictly correct - an eval setting $@ to undef
 506   # is *not* the same as an eval setting $@ to ''
 507   # but for the sake of simplicity assume the following for
 508   # the time being
 509   return 0 unless defined $e;
 510
 511   my ($not_blank, $suberror);
 512   {
 513     local $SIG{__DIE__} if $SIG{__DIE__};
 514     local $@;
 515     eval {
 516       # The ne() here is deliberate - a plain length($e), or worse "$e" ne
 517       # will entirely obviate the need for the encolsing eval{}, as the
 518       # condition we guard against is a missing fallback overload
 519       $not_blank = ( $e ne '' );
 520       1;
 521     } or $suberror = $@;
 522   }
 523
 524   if (defined $suberror) {
 525     if (length (my $class = blessed($e) )) {
 526       carp_unique( sprintf(
 527         'External exception class %s implements partial (broken) overloading '
 528       . 'preventing its instances from being used in simple ($x eq $y) '
 529       . 'comparisons. Given Perl\'s "globally cooperative" exception '
 530       . 'handling this type of brokenness is extremely dangerous on '
 531       . 'exception objects, as it may (and often does) result in silent '
 532       . '"exception substitution". DBIx::Class tries to work around this '
 533       . 'as much as possible, but other parts of your software stack may '
 534       . 'not be even aware of this. Please submit a bugreport against the '
 535       . 'distribution containing %s and in the meantime apply a fix similar '
 536       . 'to the one shown at %s, in order to ensure your exception handling '
 537       . 'is saner application-wide. What follows is the actual error text '
 538       . "as generated by Perl itself:\n\n%s\n ",
 539         $class,
 540         $class,
 541         'http://v.gd/DBIC_overload_tempfix/',
 542         $suberror,
 543       ));
 544
 545       # workaround, keeps spice flowing
 546       $not_blank = !!( length $e );
 547     }
 548     else {
 549       # not blessed yet failed the 'ne'... this makes 0 sense...
 550       # just throw further
 551       die $suberror
 552     }
 553   }
 554   elsif (
 555     # a ref evaluating to '' is definitively a "null object"
 556     ( not $not_blank )
 557       and
 558     length( my $class = ref $e )
 559   ) {
 560     carp_unique(
 561       "Objects of external exception class '$class' stringify to '' (the "
 562     . 'empty string), implementing the so called null-object-pattern. '
 563     . 'Given Perl\'s "globally cooperative" exception handling using this '
 564     . 'class of exceptions is extremely dangerous, as it may (and often '
 565     . 'does) result in silent discarding of errors. DBIx::Class tries to '
 566     . 'work around this as much as possible, but other parts of your '
 567     . 'software stack may not be even aware of the problem. Please submit '
 568     . "a bugreport against the distribution containing '$class'",
 569     );
 570
 571     $not_blank = 1;
 572   }
 573
 574   return $not_blank;
 575 }
 576
 577 {
 578   my $callstack_state;
 579
 580   # Recreate the logic of try(), while reusing the catch()/finally() as-is
 581   #
 582   # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
 583   # yes, shows up ON TOP of profiles) but this is a batle for another maint
 584   sub dbic_internal_try (&;@) {
 585
 586     my $try_cref = shift;
 587     my $catch_cref = undef;  # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311
 588
 589     for my $arg (@_) {
 590
 591       if( ref($arg) eq 'Try::Tiny::Catch' ) {
 592
 593         croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
 594           if $catch_cref;
 595
 596         $catch_cref = $$arg;
 597       }
 598       elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
 599         croak 'dbic_internal_try() does not support finally{}';
 600       }
 601       else {
 602         croak(
 603           'dbic_internal_try() encountered an unexpected argument '
 604         . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
 605         . 'a missing semi-colon before or ' # trailing space important
 606         );
 607       }
 608     }
 609
 610     my $wantarray = wantarray;
 611     my $preexisting_exception = $@;
 612
 613     my @ret;
 614     my $all_good = eval {
 615       $@ = $preexisting_exception;
 616
 617       local $callstack_state->{in_internal_try} = 1
 618         unless $callstack_state->{in_internal_try};
 619
 620       # always unset - someone may have snuck it in
 621       local $SIG{__DIE__} if $SIG{__DIE__};
 622
 623       if( $wantarray ) {
 624         @ret = $try_cref->();
 625       }
 626       elsif( defined $wantarray ) {
 627         $ret[0] = $try_cref->();
 628       }
 629       else {
 630         $try_cref->();
 631       }
 632
 633       1;
 634     };
 635
 636     my $exception = $@;
 637     $@ = $preexisting_exception;
 638
 639     if ( $all_good ) {
 640       return $wantarray ? @ret : $ret[0]
 641     }
 642     elsif ( $catch_cref ) {
 643       for ( $exception ) {
 644         return $catch_cref->($exception);
 645       }
 646     }
 647
 648     return;
 649   }
 650
 651   sub in_internal_try { !! $callstack_state->{in_internal_try} }
 652 }
 653
 654 {
 655   my $destruction_registry = {};
 656
 657   sub DBIx::Class::__Util_iThreads_handler__::CLONE {
 658     %$destruction_registry = map {
 659       (defined $_)
 660         ? ( refaddr($_) => $_ )
 661         : ()
 662     } values %$destruction_registry;
 663
 664     weaken($_) for values %$destruction_registry;
 665
 666     # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 667     # collected before leaving this scope. Depending on the code above, this
 668     # may very well be just a preventive measure guarding future modifications
 669     undef;
 670   }
 671
 672   # This is almost invariably invoked from within DESTROY
 673   # throwing exceptions won't work
 674   sub detected_reinvoked_destructor {
 675
 676     # quick "garbage collection" pass - prevents the registry
 677     # from slowly growing with a bunch of undef-valued keys
 678     defined $destruction_registry->{$_} or delete $destruction_registry->{$_}
 679       for keys %$destruction_registry;
 680
 681     if (! length ref $_[0]) {
 682       emit_loud_diag(
 683         emit_dups => 1,
 684         msg => (caller(0))[3] . '() expects a blessed reference'
 685       );
 686       return undef; # don't know wtf to do
 687     }
 688     elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
 689       weaken( $destruction_registry->{$addr} = $_[0] );
 690       return 0;
 691     }
 692     else {
 693       emit_loud_diag( msg => sprintf (
 694         'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY '
 695       . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your '
 696       . 'application, affecting *ALL* classes without active protection against '
 697       . 'this. Diagnose and fix the root cause ASAP!!!%s',
 698       refdesc $_[0],
 699         ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } )
 700           ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)"
 701           : ''
 702         )
 703       ));
 704
 705       return 1;
 706     }
 707   }
 708 }
 709
 710 my $module_name_rx = qr/ \A [A-Z_a-z] [0-9A-Z_a-z]* (?: :: [0-9A-Z_a-z]+ )* \z /x;
 711 my $ver_rx =         qr/ \A [0-9]+ (?: \. [0-9]+ )* (?: \_ [0-9]+ )*        \z /x;
 712
 713 sub modver_gt_or_eq ($$) {
 714   my ($mod, $ver) = @_;
 715
 716   croak "Nonsensical module name supplied"
 717     if ! defined $mod or $mod !~ $module_name_rx;
 718
 719   croak "Nonsensical minimum version supplied"
 720     if ! defined $ver or $ver !~ $ver_rx;
 721
 722   no strict 'refs';
 723   my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
 724     ? {}
 725     : croak "$mod does not seem to provide a version (perhaps it never loaded)"
 726   );
 727
 728   ! defined $ver_cache->{$ver}
 729     and
 730   $ver_cache->{$ver} = do {
 731
 732     local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
 733       if SPURIOUS_VERSION_CHECK_WARNINGS;
 734
 735     local $SIG{__DIE__} if $SIG{__DIE__};
 736     local $@;
 737     eval { $mod->VERSION($ver) } ? 1 : 0;
 738   };
 739
 740   $ver_cache->{$ver};
 741 }
 742
 743 sub modver_gt_or_eq_and_lt ($$$) {
 744   my ($mod, $v_ge, $v_lt) = @_;
 745
 746   croak "Nonsensical maximum version supplied"
 747     if ! defined $v_lt or $v_lt !~ $ver_rx;
 748
 749   return (
 750     modver_gt_or_eq($mod, $v_ge)
 751       and
 752     ! modver_gt_or_eq($mod, $v_lt)
 753   ) ? 1 : 0;
 754 }
 755
 756 {
 757
 758   sub describe_class_methods {
 759     my $args = (
 760       ref $_[0] eq 'HASH'                 ? $_[0]
 761     : ( @_ == 1 and ! length ref $_[0] )  ? { class => $_[0] }
 762     :                                       { @_ }
 763     );
 764
 765     my ($class, $requested_mro) = @{$args}{qw( class use_mro )};
 766
 767     croak "Expecting a class name either as the sole argument or a 'class' option"
 768       if not defined $class or $class !~ $module_name_rx;
 769
 770     croak(
 771       "The supplied 'class' argument is tainted: this is *extremely* "
 772     . 'dangerous, fix your code ASAP!!! ( for more details read through '
 773     . 'https://is.gd/perl_mro_taint_wtf )'
 774     ) if (
 775       DBIx::Class::_ENV_::TAINT_MODE
 776         and
 777       Scalar::Util::tainted($class)
 778     );
 779
 780     $requested_mro ||= mro::get_mro($class);
 781
 782     # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
 783     my $query_cache_key = "$class|$requested_mro";
 784
 785     my $internal_cache_key =
 786       ( mro::get_mro($class) eq $requested_mro )
 787         ? $class
 788         : $query_cache_key
 789     ;
 790
 791     # use a cache on old MRO, since while we are recursing in this function
 792     # nothing can possibly change (the speedup is immense)
 793     # (yes, people could be tie()ing the stash and adding methods on access
 794     # but there is a limit to how much crazy can be supported here)
 795     #
 796     # we use the cache for linear_isa lookups on new MRO as well - it adds
 797     # a *tiny* speedup, and simplifies the code a lot
 798     #
 799     local $__describe_class_query_cache->{'!internal!'} = {}
 800       unless $__describe_class_query_cache->{'!internal!'};
 801
 802     my $my_gen = 0;
 803
 804     $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = (
 805
 806       @{
 807         $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}
 808           ||=
 809         mro::get_linear_isa($class, $requested_mro)
 810       },
 811
 812       ((
 813         $__describe_class_query_cache->{'!internal!'}{$class}{is_universal}
 814           ||=
 815         mro::is_universal($class)
 816       ) ? () : @{
 817         $__describe_class_query_cache->{'!internal!'}{UNIVERSAL}{linear_isa}
 818           ||=
 819         mro::get_linear_isa("UNIVERSAL")
 820       }),
 821
 822     ));
 823
 824     my $slot = $__describe_class_query_cache->{$query_cache_key} ||= {};
 825
 826     unless ( ($slot->{cumulative_gen}||0) == $my_gen ) {
 827
 828       # reset
 829       %$slot = (
 830         class => $class,
 831         isa => { map { $_ => 1 } @full_ISA },
 832         linear_isa => [
 833           @{ $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} }
 834             [ 1 .. $#{$__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}} ]
 835         ],
 836         mro => {
 837           type => $requested_mro,
 838           is_c3 => ( ($requested_mro eq 'c3') ? 1 : 0 ),
 839         },
 840         cumulative_gen => $my_gen,
 841       );
 842
 843       # remove ourselves from ISA
 844       shift @full_ISA;
 845
 846       # ensure the cache is populated for the parents, code below can then
 847       # efficiently operate over the query_cache directly
 848       describe_class_methods($_) for reverse @full_ISA;
 849
 850       no strict 'refs';
 851
 852       # combine full ISA-order inherited and local method list into a
 853       # "shadowing stack"
 854
 855       (
 856         unshift @{ $slot->{methods}{$_->{name}} }, $_
 857
 858           and
 859
 860         (
 861           $_->{via_class} ne $class
 862             or
 863           $slot->{methods_defined_in_class}{$_->{name}} = $_
 864         )
 865
 866           and
 867
 868         @{ $slot->{methods}{$_->{name}} } > 1
 869
 870           and
 871
 872         $slot->{methods_with_supers}{$_->{name}} = $slot->{methods}{$_->{name}}
 873
 874       ) for (
 875
 876         # what describe_class_methods for @full_ISA produced above
 877         ( map { values %{
 878           $__describe_class_query_cache->{$_}{methods_defined_in_class} || {}
 879         } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ),
 880
 881         # our own non-cleaned subs + their attributes
 882         ( map {
 883           (
 884             # need to account for dummy helper crefs under OLD_MRO
 885             (
 886               ! DBIx::Class::_ENV_::OLD_MRO
 887                 or
 888               ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} )
 889             )
 890               and
 891             # these 2 OR-ed checks are sufficient for 5.10+
 892             (
 893               ref(\ "${class}::"->{$_} ) ne 'GLOB'
 894                 or
 895               defined( *{ "${class}::"->{$_} }{CODE} )
 896             )
 897           ) ? {
 898               via_class => $class,
 899               name => $_,
 900               attributes => { map { $_ => 1 } do {
 901                 my @attrs;
 902                 local $@;
 903                 local $SIG{__DIE__} if $SIG{__DIE__};
 904                 # attributes::get may throw on blessed-false crefs :/
 905                 eval { @attrs = attributes::get( \&{"${class}::${_}"} ); 1 }
 906                   or warn "Unable to determine attributes of the \\&${class}::$_ method due to following error: $@";
 907                 @attrs;
 908               } },
 909             }
 910             : ()
 911         } keys %{"${class}::"} )
 912       );
 913
 914
 915       # recalculate the pkg_gen on newer perls under Taint mode,
 916       # because of shit like:
 917       # perl -T -Mmro -e 'package Foo; sub bar {}; defined( *{ "Foo::"->{bar}}{CODE} ) and warn mro::get_pkg_gen("Foo") for (1,2,3)'
 918       #
 919       if (
 920         ! DBIx::Class::_ENV_::OLD_MRO
 921           and
 922         DBIx::Class::_ENV_::TAINT_MODE
 923       ) {
 924
 925         $slot->{cumulative_gen} = 0;
 926         $slot->{cumulative_gen} += get_real_pkg_gen($_)
 927           for $class, @full_ISA;
 928       }
 929     }
 930
 931     # RV
 932     +{ %$slot };
 933   }
 934 }
 935
 936
 937 #
 938 # Why not just use some higher-level module or at least File::Spec here?
 939 # Because:
 940 # 1)  This is a *very* rarely used function, and the deptree is large
 941 #     enough already as it is
 942 #
 943 # 2)  (more importantly) Our tooling is utter shit in this area. There
 944 #     is no comprehensive support for UNC paths in PathTools and there
 945 #     are also various small bugs in representation across different
 946 #     path-manipulation CPAN offerings.
 947 #
 948 # Since this routine is strictly used for logical path processing (it
 949 # *must* be able to work with not-yet-existing paths), use this seemingly
 950 # simple but I *think* complete implementation to feed to other consumers
 951 #
 952 # If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST*
 953 # the impulse to bring in an external dependency. During runtime there
 954 # is exactly one spot that could potentially maybe once in a blue moon
 955 # use this function. Keep it lean.
 956 #
 957 sub parent_dir ($) {
 958   ( $_[0] =~ m{  [\/\\]  ( \.{0,2} ) ( [\/\\]* ) \z }x )
 959     ? (
 960       $_[0]
 961         .
 962       ( ( length($1) and ! length($2) ) ? '/' : '' )
 963         .
 964       '../'
 965     )
 966     : (
 967       require File::Spec
 968         and
 969       File::Spec->catpath (
 970         ( File::Spec->splitpath( "$_[0]" ) )[0,1],
 971         '/',
 972       )
 973     )
 974   ;
 975 }
 976
 977 sub mkdir_p ($) {
 978   require File::Path;
 979   # do not ask for a recent version, use 1.x API calls
 980   File::Path::mkpath([ "$_[0]" ]);  # File::Path does not like objects
 981 }
 982
 983
 984 {
 985   my $list_ctx_ok_stack_marker;
 986
 987   sub fail_on_internal_wantarray () {
 988     return if $list_ctx_ok_stack_marker;
 989
 990     if (! defined wantarray) {
 991       croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
 992     }
 993
 994     my $cf = 1;
 995     while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?:
 996
 997       # these are public API parts that alter behavior on wantarray
 998       search | search_related | slice | search_literal
 999
1000         |
1001
1002       # these are explicitly prefixed, since we only recognize them as valid
1003       # escapes when they come from the guts of CDBICompat
1004       CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
1005
1006     ) $/x ) {
1007       $cf++;
1008     }
1009
1010     my ($fr, $want, $argdesc);
1011     {
1012       package DB;
1013       $fr = [ CORE::caller($cf) ];
1014       $want = ( CORE::caller($cf-1) )[5];
1015       $argdesc = ref $DB::args[0]
1016         ? DBIx::Class::_Util::refdesc($DB::args[0])
1017         : 'non '
1018       ;
1019     };
1020
1021     if (
1022       $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
1023     ) {
1024       DBIx::Class::Exception->throw( sprintf (
1025         "Improper use of %s instance in list context at %s line %d\n\n    Stacktrace starts",
1026         $argdesc, @{$fr}[1,2]
1027       ), 'with_stacktrace');
1028     }
1029
1030     weaken( $list_ctx_ok_stack_marker = my $mark = [] );
1031
1032     $mark;
1033   }
1034 }
1035
1036 sub fail_on_internal_call {
1037   my ($fr, $argdesc);
1038   {
1039     package DB;
1040     $fr = [ CORE::caller(1) ];
1041     $argdesc =
1042       ( not defined $DB::args[0] )  ? 'UNAVAILABLE'
1043     : ( length ref $DB::args[0] )   ? DBIx::Class::_Util::refdesc($DB::args[0])
1044     : $DB::args[0] . ''
1045     ;
1046   };
1047
1048   my @fr2;
1049   # need to make allowance for a proxy-yet-direct call
1050   my $check_fr = (
1051     $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
1052       and
1053     @fr2 = (CORE::caller(2))
1054       and
1055     (
1056       ( $fr->[3] =~ /([^:])+$/ )[0]
1057         eq
1058       ( $fr2[3] =~ /([^:])+$/ )[0]
1059     )
1060   )
1061     ? \@fr2
1062     : $fr
1063   ;
1064
1065   if (
1066     defined $fr->[0]
1067       and
1068     $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
1069       and
1070     $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
1071   ) {
1072     DBIx::Class::Exception->throw( sprintf (
1073       "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",
1074       $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
1075         require B::Deparse;
1076         no strict 'refs';
1077         B::Deparse->new->coderef2text(\&{$fr->[3]})
1078       }),
1079     ), 'with_stacktrace');
1080   }
1081 }
1082
1083 if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) {
1084
1085   no warnings 'redefine';
1086
1087   my $next_bless = defined(&CORE::GLOBAL::bless)
1088     ? \&CORE::GLOBAL::bless
1089     : sub { CORE::bless($_[0], $_[1]) }
1090   ;
1091
1092   *CORE::GLOBAL::bless = sub {
1093     my $class = (@_ > 1) ? $_[1] : CORE::caller();
1094
1095     # allow for reblessing (role application)
1096     return $next_bless->( $_[0], $class )
1097       if defined blessed $_[0];
1098
1099     my $obj = $next_bless->( $_[0], $class );
1100
1101     my $calling_sub = (CORE::caller(1))[3] || '';
1102
1103     (
1104       # before 5.18 ->isa() will choke on the "0" package
1105       # which we test for in several obscure cases, sigh...
1106       !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 )
1107         or
1108       $class
1109     )
1110       and
1111     (
1112       (
1113         $calling_sub !~ /^ (?:
1114           DBIx::Class::Schema::clone
1115             |
1116           DBIx::Class::DB::setup_schema_instance
1117         )/x
1118           and
1119         $class->isa("DBIx::Class::Schema")
1120       )
1121         or
1122       (
1123         $calling_sub ne 'DBIx::Class::ResultSource::new'
1124           and
1125         $class->isa("DBIx::Class::ResultSource")
1126       )
1127     )
1128       and
1129     local $Carp::CarpLevel = $Carp::CarpLevel + 1
1130       and
1131     Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor");
1132
1133
1134     $obj;
1135   };
1136 }
1137
1138 1;