1 package # hide from PAUSE
4 use DBIx::Class::StartupCheck; # load es early as we can, usually a noop
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;
15 package # hide from pause
28 BROKEN_FORK => (OS_NAME eq 'MSWin32') ? 1 : 0,
30 BROKEN_GOTO => ( PERL_VERSION < 5.008003 ) ? 1 : 0,
32 # perl -MScalar::Util=weaken -e 'weaken( $hash{key} = \"value" )'
33 BROKEN_WEAK_SCALARREF_VALUES => ( PERL_VERSION < 5.008003 ) ? 1 : 0,
35 HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
37 TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1
39 UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0,
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_$_"} ) }
47 { substr($_, 5) => !!( $ENV{$_} ) }
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
57 IV_SIZE => $Config{ivsize},
60 if ( PERL_VERSION < 5.009_005) {
62 constant->import( OLD_MRO => 1 );
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
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*
72 *DBIx::Class::_Util::get_real_pkg_gen = sub ($) {
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 {
83 ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_}{methlist} ||= (
89 # RV to be hashed up and turned into a number
94 # stringification should be sufficient, ignore names/refaddr entirely
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: $@";
108 # skip dummy C::C3 helper crefs
109 ! ( ( $Class::C3::MRO{$cur_class} || {} )->{methods}{$_} )
112 ref(\ "${cur_class}::"->{$_} ) ne 'GLOB'
114 defined( *{ "${cur_class}::"->{$_} }{CODE} )
117 ? ( \&{"${cur_class}::$_"} )
120 keys %{ "${cur_class}::" }
126 ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{linear_isa}
128 mro::get_linear_isa($_[0])
132 ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{is_universal}
134 mro::is_universal($_[0])
136 ( $__describe_class_query_cache->{'!internal!'} || {} )->{UNIVERSAL}{linear_isa}
138 mro::get_linear_isa("UNIVERSAL")
147 constant->import( OLD_MRO => 0 );
148 *DBIx::Class::_Util::get_real_pkg_gen = \&mro::get_pkg_gen;
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
157 DBIx::Class::_Util::emit_loud_diag(
159 msg => "The @{[ (caller(1))[3] ]} constant is no more - adjust your code"
164 sub DBICTEST () { &$sigh }
165 sub PEEPEENESS () { &$sigh }
168 use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ? 1 : 0);
170 # FIXME - this is not supposed to be here
171 # Carp::Skip to the rescue soon
172 use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
176 use Storable 'nfreeze';
177 use Scalar::Util qw(weaken blessed reftype refaddr);
181 # Usually versions are not specified anywhere aside the Makefile.PL
182 # (writing them out in-code is extremely obnoxious)
183 # However without a recent enough Moo the quote_sub override fails
184 # in very puzzling and hard to detect ways: so add a version check
186 use Sub::Quote qw(qsub);
187 BEGIN { Sub::Quote->VERSION('2.002002') }
189 # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
190 BEGIN { *deep_clone = \&Storable::dclone }
194 sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
195 fail_on_internal_wantarray fail_on_internal_call
196 refdesc refcount hrefaddr set_subname get_subname describe_class_methods
197 scope_guard detected_reinvoked_destructor emit_loud_diag
199 is_exception dbic_internal_try visit_namespaces
200 quote_sub qsub perlstring serialize deep_clone dump_value uniq
202 UNRESOLVABLE_CONDITION
205 use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
207 # Override forcing no_defer, and adding naming consistency checks
208 our %refs_closed_over_by_quote_sub_installed_crefs;
210 Carp::confess( "Anonymous quoting not supported by the DBIC quote_sub override - supply a sub name" ) if
218 Carp::confess( "The DBIC quote_sub override expects sub name '$_[0]' to be fully qualified" )
219 unless (my $stash) = $_[0] =~ /^(.+)::/;
222 "The DBIC sub_quote override does not support 'no_install'"
230 'The DBIC quote_sub override expects the namespace-part of sub name '
231 . "'$_[0]' to match the supplied package argument '$_[3]->{package}'"
235 defined $_[3]->{package}
237 $stash ne $_[3]->{package}
240 my @caller = caller(0);
242 package => $caller[0],
244 warning_bits => $caller[9],
245 hintshash => $caller[10],
248 # explicitly forced for everything
253 # just use a growing counter, no need to perform neither compaction
254 # nor any special ithread-level handling
255 $refs_closed_over_by_quote_sub_installed_crefs
256 { scalar keys %refs_closed_over_by_quote_sub_installed_crefs }
262 ! DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES
266 } values %{ $_[2] || {} };
268 Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts );
271 sub sigwarn_silencer ($) {
274 croak "Expecting a regexp" if ref $pattern ne 'Regexp';
276 my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
278 return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
281 sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };
283 sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 }
286 croak "Expecting a reference" if ! length ref $_[0];
288 # be careful not to trigger stringification,
289 # reuse @_ as a scratch-pad
290 sprintf '%s%s(0x%x)',
291 ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ),
298 croak "Expecting a reference" if ! length ref $_[0];
300 # No tempvars - must operate on $_[0], otherwise the pad
301 # will count as an extra ref
302 B::svref_2object($_[0])->REFCNT;
305 sub visit_namespaces {
306 my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
308 my $visited_count = 1;
310 # A package and a namespace are subtly different things
311 $args->{package} ||= 'main';
312 $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
313 $args->{package} =~ s/^:://;
315 if ( $args->{action}->($args->{package}) ) {
317 ( ($args->{package} eq 'main') ? '' : $args->{package} )
322 $visited_count += visit_namespaces( %$args, package => $_ ) for
324 # this happens sometimes on %:: traversal
327 { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
328 do { no strict 'refs'; keys %$ns }
335 # FIXME In another life switch these to a polyfill like the ones in namespace::clean
336 sub get_subname ($) {
337 my $gv = B::svref_2object( $_[0] )->GV;
339 ? ( $gv->STASH->NAME, $gv->NAME )
340 : ( join '::', $gv->STASH->NAME, $gv->NAME )
343 sub set_subname ($$) {
346 splice @_, 0, 1, caller(0) . "::$_[0]"
353 local $Storable::canonical = 1;
358 my( %seen, $seen_undef, $numeric_preserving_copy );
361 ? $seen{ $numeric_preserving_copy = $_ }++
368 local $Data::Dumper::Indent = 1
369 unless defined $Data::Dumper::Indent;
375 require Data::Dumper;
376 my $d = Data::Dumper->new([])
389 $d->Sparseseen(1) if modver_gt_or_eq (
390 'Data::Dumper', '2.136'
395 )->Values([$_[0]])->Dump;
397 $dd_obj->Reset->Values([]);
402 my $seen_loud_screams;
404 my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ };
406 unless ( defined $args->{msg} and length $args->{msg} ) {
408 msg => "No 'msg' value supplied to emit_loud_diag()"
413 my $msg = "\n$0: $args->{msg}";
415 # when we die - we usually want to keep doing it
416 $args->{emit_dups} = !!$args->{confess}
417 unless exists $args->{emit_dups};
419 local $Carp::CarpLevel =
420 ( $args->{skip_frames} || 0 )
428 my $longmess = Carp::longmess();
430 # different object references will thwart deduplication without this
431 ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi;
433 return $seen_loud_screams->{$key} if
434 $seen_loud_screams->{$key}++
440 unless $msg =~ /\n\z/;
442 print STDERR "$msg\n"
444 print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n";
446 return $seen_loud_screams->{$key}
447 unless $args->{confess};
449 # increment *again*, because... Carp.
452 # not $msg - Carp will reapply the longmess on its own
453 Carp::confess($args->{msg});
458 ### This is *NOT* boolean.pm - deliberately not using a singleton
461 package # hide from pause
462 DBIx::Class::_Util::_Bool;
464 bool => sub { ${$_[0]} },
468 sub true () { my $x = 1; bless \$x, "DBIx::Class::_Util::_Bool" }
469 sub false () { my $x = 0; bless \$x, "DBIx::Class::_Util::_Bool" }
471 sub scope_guard (&) {
472 croak 'Calling scope_guard() in void context makes no sense'
473 if ! defined wantarray;
475 # no direct blessing of coderefs - DESTROY is buggy on those
476 bless [ $_[0] ], 'DBIx::Class::_Util::ScopeGuard';
480 DBIx::Class::_Util::ScopeGuard;
483 &DBIx::Class::_Util::detected_reinvoked_destructor;
485 local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
492 DBIx::Class::_Util::emit_loud_diag(
494 msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n "
500 sub is_exception ($) {
504 # this is not strictly correct - an eval setting $@ to undef
505 # is *not* the same as an eval setting $@ to ''
506 # but for the sake of simplicity assume the following for
508 return 0 unless defined $e;
510 my ($not_blank, $suberror);
512 local $SIG{__DIE__} if $SIG{__DIE__};
515 # The ne() here is deliberate - a plain length($e), or worse "$e" ne
516 # will entirely obviate the need for the encolsing eval{}, as the
517 # condition we guard against is a missing fallback overload
518 $not_blank = ( $e ne '' );
523 if (defined $suberror) {
524 if (length (my $class = blessed($e) )) {
525 carp_unique( sprintf(
526 'External exception class %s implements partial (broken) overloading '
527 . 'preventing its instances from being used in simple ($x eq $y) '
528 . 'comparisons. Given Perl\'s "globally cooperative" exception '
529 . 'handling this type of brokenness is extremely dangerous on '
530 . 'exception objects, as it may (and often does) result in silent '
531 . '"exception substitution". DBIx::Class tries to work around this '
532 . 'as much as possible, but other parts of your software stack may '
533 . 'not be even aware of this. Please submit a bugreport against the '
534 . 'distribution containing %s and in the meantime apply a fix similar '
535 . 'to the one shown at %s, in order to ensure your exception handling '
536 . 'is saner application-wide. What follows is the actual error text '
537 . "as generated by Perl itself:\n\n%s\n ",
540 'http://v.gd/DBIC_overload_tempfix/',
544 # workaround, keeps spice flowing
545 $not_blank = !!( length $e );
548 # not blessed yet failed the 'ne'... this makes 0 sense...
554 # a ref evaluating to '' is definitively a "null object"
557 length( my $class = ref $e )
560 "Objects of external exception class '$class' stringify to '' (the "
561 . 'empty string), implementing the so called null-object-pattern. '
562 . 'Given Perl\'s "globally cooperative" exception handling using this '
563 . 'class of exceptions is extremely dangerous, as it may (and often '
564 . 'does) result in silent discarding of errors. DBIx::Class tries to '
565 . 'work around this as much as possible, but other parts of your '
566 . 'software stack may not be even aware of the problem. Please submit '
567 . "a bugreport against the distribution containing '$class'",
579 # Recreate the logic of try(), while reusing the catch()/finally() as-is
581 # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
582 # yes, shows up ON TOP of profiles) but this is a batle for another maint
583 sub dbic_internal_try (&;@) {
585 my $try_cref = shift;
586 my $catch_cref = undef; # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311
590 if( ref($arg) eq 'Try::Tiny::Catch' ) {
592 croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
597 elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
598 croak 'dbic_internal_try() does not support finally{}';
602 'dbic_internal_try() encountered an unexpected argument '
603 . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
604 . 'a missing semi-colon before or ' # trailing space important
609 my $wantarray = wantarray;
610 my $preexisting_exception = $@;
613 my $all_good = eval {
614 $@ = $preexisting_exception;
616 local $callstack_state->{in_internal_try} = 1
617 unless $callstack_state->{in_internal_try};
619 # always unset - someone may have snuck it in
620 local $SIG{__DIE__} if $SIG{__DIE__};
623 @ret = $try_cref->();
625 elsif( defined $wantarray ) {
626 $ret[0] = $try_cref->();
636 $@ = $preexisting_exception;
639 return $wantarray ? @ret : $ret[0]
641 elsif ( $catch_cref ) {
643 return $catch_cref->($exception);
650 sub in_internal_try { !! $callstack_state->{in_internal_try} }
654 my $destruction_registry = {};
656 sub DBIx::Class::__Util_iThreads_handler__::CLONE {
657 %$destruction_registry = map {
659 ? ( refaddr($_) => $_ )
661 } values %$destruction_registry;
663 weaken($_) for values %$destruction_registry;
665 # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
666 # collected before leaving this scope. Depending on the code above, this
667 # may very well be just a preventive measure guarding future modifications
671 # This is almost invariably invoked from within DESTROY
672 # throwing exceptions won't work
673 sub detected_reinvoked_destructor {
675 # quick "garbage collection" pass - prevents the registry
676 # from slowly growing with a bunch of undef-valued keys
677 defined $destruction_registry->{$_} or delete $destruction_registry->{$_}
678 for keys %$destruction_registry;
680 if (! length ref $_[0]) {
683 msg => (caller(0))[3] . '() expects a blessed reference'
685 return undef; # don't know wtf to do
687 elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
688 weaken( $destruction_registry->{$addr} = $_[0] );
692 emit_loud_diag( msg => sprintf (
693 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY '
694 . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your '
695 . 'application, affecting *ALL* classes without active protection against '
696 . 'this. Diagnose and fix the root cause ASAP!!!%s',
698 ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } )
699 ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)"
709 my $module_name_rx = qr/ \A [A-Z_a-z] [0-9A-Z_a-z]* (?: :: [0-9A-Z_a-z]+ )* \z /x;
710 my $ver_rx = qr/ \A [0-9]+ (?: \. [0-9]+ )* (?: \_ [0-9]+ )* \z /x;
712 sub modver_gt_or_eq ($$) {
713 my ($mod, $ver) = @_;
715 croak "Nonsensical module name supplied"
716 if ! defined $mod or $mod !~ $module_name_rx;
718 croak "Nonsensical minimum version supplied"
719 if ! defined $ver or $ver !~ $ver_rx;
722 my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
724 : croak "$mod does not seem to provide a version (perhaps it never loaded)"
727 ! defined $ver_cache->{$ver}
729 $ver_cache->{$ver} = do {
731 local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
732 if SPURIOUS_VERSION_CHECK_WARNINGS;
734 local $SIG{__DIE__} if $SIG{__DIE__};
736 eval { $mod->VERSION($ver) } ? 1 : 0;
742 sub modver_gt_or_eq_and_lt ($$$) {
743 my ($mod, $v_ge, $v_lt) = @_;
745 croak "Nonsensical maximum version supplied"
746 if ! defined $v_lt or $v_lt !~ $ver_rx;
749 modver_gt_or_eq($mod, $v_ge)
751 ! modver_gt_or_eq($mod, $v_lt)
757 sub describe_class_methods {
759 ref $_[0] eq 'HASH' ? $_[0]
760 : ( @_ == 1 and ! length ref $_[0] ) ? { class => $_[0] }
764 my ($class, $requested_mro) = @{$args}{qw( class use_mro )};
766 croak "Expecting a class name either as the sole argument or a 'class' option"
767 if not defined $class or $class !~ $module_name_rx;
770 "The supplied 'class' argument is tainted: this is *extremely* "
771 . 'dangerous, fix your code ASAP!!! ( for more details read through '
772 . 'https://is.gd/perl_mro_taint_wtf )'
774 DBIx::Class::_ENV_::TAINT_MODE
776 Scalar::Util::tainted($class)
779 $requested_mro ||= mro::get_mro($class);
781 # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
782 my $query_cache_key = "$class|$requested_mro";
784 my $internal_cache_key =
785 ( mro::get_mro($class) eq $requested_mro )
790 # use a cache on old MRO, since while we are recursing in this function
791 # nothing can possibly change (the speedup is immense)
792 # (yes, people could be tie()ing the stash and adding methods on access
793 # but there is a limit to how much crazy can be supported here)
795 # we use the cache for linear_isa lookups on new MRO as well - it adds
796 # a *tiny* speedup, and simplifies the code a lot
798 local $__describe_class_query_cache->{'!internal!'} = {}
799 unless $__describe_class_query_cache->{'!internal!'};
803 $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = (
806 $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}
808 mro::get_linear_isa($class, $requested_mro)
812 $__describe_class_query_cache->{'!internal!'}{$class}{is_universal}
814 mro::is_universal($class)
816 $__describe_class_query_cache->{'!internal!'}{UNIVERSAL}{linear_isa}
818 mro::get_linear_isa("UNIVERSAL")
823 my $slot = $__describe_class_query_cache->{$query_cache_key} ||= {};
825 unless ( ($slot->{cumulative_gen}||0) == $my_gen ) {
830 isa => { map { $_ => 1 } @full_ISA },
832 @{ $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} }
833 [ 1 .. $#{$__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}} ]
836 type => $requested_mro,
837 is_c3 => ( ($requested_mro eq 'c3') ? 1 : 0 ),
839 cumulative_gen => $my_gen,
842 # remove ourselves from ISA
845 # ensure the cache is populated for the parents, code below can then
846 # efficiently operate over the query_cache directly
847 describe_class_methods($_) for reverse @full_ISA;
851 # combine full ISA-order inherited and local method list into a
855 unshift @{ $slot->{methods}{$_->{name}} }, $_
860 $_->{via_class} ne $class
862 $slot->{methods_defined_in_class}{$_->{name}} = $_
867 @{ $slot->{methods}{$_->{name}} } > 1
871 $slot->{methods_with_supers}{$_->{name}} = $slot->{methods}{$_->{name}}
875 # what describe_class_methods for @full_ISA produced above
877 $__describe_class_query_cache->{$_}{methods_defined_in_class} || {}
878 } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ),
880 # our own non-cleaned subs + their attributes
883 # need to account for dummy helper crefs under OLD_MRO
885 ! DBIx::Class::_ENV_::OLD_MRO
887 ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} )
890 # these 2 OR-ed checks are sufficient for 5.10+
892 ref(\ "${class}::"->{$_} ) ne 'GLOB'
894 defined( *{ "${class}::"->{$_} }{CODE} )
899 attributes => { map { $_ => 1 } do {
902 local $SIG{__DIE__} if $SIG{__DIE__};
903 # attributes::get may throw on blessed-false crefs :/
904 eval { @attrs = attributes::get( \&{"${class}::${_}"} ); 1 }
905 or warn "Unable to determine attributes of the \\&${class}::$_ method due to following error: $@";
910 } keys %{"${class}::"} )
914 # recalculate the pkg_gen on newer perls under Taint mode,
915 # because of shit like:
916 # perl -T -Mmro -e 'package Foo; sub bar {}; defined( *{ "Foo::"->{bar}}{CODE} ) and warn mro::get_pkg_gen("Foo") for (1,2,3)'
919 ! DBIx::Class::_ENV_::OLD_MRO
921 DBIx::Class::_ENV_::TAINT_MODE
924 $slot->{cumulative_gen} = 0;
925 $slot->{cumulative_gen} += get_real_pkg_gen($_)
926 for $class, @full_ISA;
937 # Why not just use some higher-level module or at least File::Spec here?
939 # 1) This is a *very* rarely used function, and the deptree is large
940 # enough already as it is
942 # 2) (more importantly) Our tooling is utter shit in this area. There
943 # is no comprehensive support for UNC paths in PathTools and there
944 # are also various small bugs in representation across different
945 # path-manipulation CPAN offerings.
947 # Since this routine is strictly used for logical path processing (it
948 # *must* be able to work with not-yet-existing paths), use this seemingly
949 # simple but I *think* complete implementation to feed to other consumers
951 # If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST*
952 # the impulse to bring in an external dependency. During runtime there
953 # is exactly one spot that could potentially maybe once in a blue moon
954 # use this function. Keep it lean.
957 ( $_[0] =~ m{ [\/\\] ( \.{0,2} ) ( [\/\\]* ) \z }x )
961 ( ( length($1) and ! length($2) ) ? '/' : '' )
968 File::Spec->catpath (
969 ( File::Spec->splitpath( "$_[0]" ) )[0,1],
978 # do not ask for a recent version, use 1.x API calls
979 File::Path::mkpath([ "$_[0]" ]); # File::Path does not like objects
984 my $list_ctx_ok_stack_marker;
986 sub fail_on_internal_wantarray () {
987 return if $list_ctx_ok_stack_marker;
989 if (! defined wantarray) {
990 croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
994 while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?:
996 # these are public API parts that alter behavior on wantarray
997 search | search_related | slice | search_literal
1001 # these are explicitly prefixed, since we only recognize them as valid
1002 # escapes when they come from the guts of CDBICompat
1003 CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
1009 my ($fr, $want, $argdesc);
1012 $fr = [ CORE::caller($cf) ];
1013 $want = ( CORE::caller($cf-1) )[5];
1014 $argdesc = ref $DB::args[0]
1015 ? DBIx::Class::_Util::refdesc($DB::args[0])
1021 $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
1023 DBIx::Class::Exception->throw( sprintf (
1024 "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts",
1025 $argdesc, @{$fr}[1,2]
1026 ), 'with_stacktrace');
1029 weaken( $list_ctx_ok_stack_marker = my $mark = [] );
1035 sub fail_on_internal_call {
1039 $fr = [ CORE::caller(1) ];
1040 $argdesc = ref $DB::args[0]
1041 ? DBIx::Class::_Util::refdesc($DB::args[0])
1042 : ( $DB::args[0] . '' )
1047 # need to make allowance for a proxy-yet-direct call
1049 $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
1051 @fr2 = (CORE::caller(2))
1054 ( $fr->[3] =~ /([^:])+$/ )[0]
1056 ( $fr2[3] =~ /([^:])+$/ )[0]
1066 $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
1068 $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there
1070 DBIx::Class::Exception->throw( sprintf (
1071 "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",
1072 $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
1075 B::Deparse->new->coderef2text(\&{$fr->[3]})
1077 ), 'with_stacktrace');