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