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