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