X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=a713ee7db8ff0840594e2ff8ed2f777f2ab537ad;hb=5ab7259324b6e3d0feea533239b6d77db0b28c9c;hp=60a4815ab3304a8dab6ecad3adf298d8d89482bf;hpb=8fc4291ef4f19b6f4c4f25cd695cb613da613fe1;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 60a4815..a713ee7 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::_Util; +use DBIx::Class::StartupCheck; # load es early as we can, usually a noop + use warnings; use strict; @@ -52,6 +54,24 @@ BEGIN { require mro; constant->import( OLD_MRO => 0 ); } + + # Both of these are no longer used for anything. However bring + # them back after they were purged in 08a8d8f1, as there appear + # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/* + # in their production codebases. There is no point in breaking these + # if whatever they used actually continues to work + my $warned; + my $sigh = sub { + + require Carp; + my $cluck = "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" . Carp::longmess(); + + warn $cluck unless $warned->{$cluck}++; + + 0; + }; + sub DBICTEST () { &$sigh } + sub PEEPEENESS () { &$sigh } } # FIXME - this is not supposed to be here @@ -62,8 +82,8 @@ use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use List::Util qw(first); -use Sub::Quote qw(qsub quote_sub); +use Sub::Quote qw(qsub); +use Sub::Name (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } @@ -72,16 +92,80 @@ use base 'Exporter'; our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr + refdesc refcount hrefaddr set_subname scope_guard detected_reinvoked_destructor - is_exception dbic_internal_try - quote_sub qsub perlstring serialize deep_clone dump_value + is_exception dbic_internal_try visit_namespaces + quote_sub qsub perlstring serialize deep_clone dump_value uniq parent_dir mkdir_p UNRESOLVABLE_CONDITION ); use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; +BEGIN { + # add preliminary attribute support + # FIXME FIXME FIXME + # To be revisited when Moo with proper attr support ships + Sub::Quote->VERSION(2.002); + require attributes; +} +# Override forcing no_defer, and adding naming consistency checks +sub quote_sub { + Carp::confess( "Anonymous quoting not supported by the DBIC sub_quote override - supply a sub name" ) if + @_ < 2 + or + ! defined $_[1] + or + length ref $_[1] + ; + + Carp::confess( "The DBIC sub_quote override expects sub name '$_[0]' to be fully qualified" ) + unless $_[0] =~ /::/; + + Carp::confess( "The DBIC sub_quote override expects the sub name '$_[0]' to match the supplied 'package' argument" ) if + $_[3] + and + defined $_[3]->{package} + and + index( $_[0], $_[3]->{package} ) != 0 + ; + + my @caller = caller(0); + my $sq_opts = { + package => $caller[0], + hints => $caller[8], + warning_bits => $caller[9], + hintshash => $caller[10], + %{ $_[3] || {} }, + + # explicitly forced for everything + no_defer => 1, + }; + + my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); + + # FIXME FIXME FIXME + # To be revisited when Moo with proper attr support ships + if( + # external application does not work on things like :prototype(...), :lvalue, etc + my @attrs = grep { + $_ !~ /^[a-z]/ + or + Carp::confess( "The DBIC sub_quote override does not support applying of reserved attribute '$_'" ) + } @{ $sq_opts->{attributes} || []} + ) { + Carp::confess( "The DBIC sub_quote override does not allow mixing 'attributes' with 'no_install'" ) + if $sq_opts->{no_install}; + + # might be different from $sq_opts->{package}; + my ($install_into) = $_[0] =~ /(.+)::[^:]+$/; + + attributes->import( $install_into, $cref, @attrs ); + } + + $cref; +} + sub sigwarn_silencer ($) { my $pattern = shift; @@ -116,17 +200,66 @@ sub refcount ($) { B::svref_2object($_[0])->REFCNT; } +sub visit_namespaces { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + my $visited_count = 1; + + # A package and a namespace are subtly different things + $args->{package} ||= 'main'; + $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; + $args->{package} =~ s/^:://; + + if ( $args->{action}->($args->{package}) ) { + my $ns = + ( ($args->{package} eq 'main') ? '' : $args->{package} ) + . + '::' + ; + + $visited_count += visit_namespaces( %$args, package => $_ ) for + grep + # this happens sometimes on %:: traversal + { $_ ne '::main' } + map + { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } + do { no strict 'refs'; keys %$ns } + ; + } + + $visited_count; +} + +# FIXME In another life switch this to a polyfill like the one in namespace::clean +sub set_subname ($$) { + + # fully qualify name + splice @_, 0, 1, caller(0) . "::$_[0]" + if $_[0] !~ /::|'/; + + &Sub::Name::subname; +} + sub serialize ($) { local $Storable::canonical = 1; nfreeze($_[0]); } -my ($dd_obj, $dump_str); +sub uniq { + my( %seen, $seen_undef, $numeric_preserving_copy ); + grep { not ( + defined $_ + ? $seen{ $numeric_preserving_copy = $_ }++ + : $seen_undef++ + ) } @_; +} + +my $dd_obj; sub dump_value ($) { local $Data::Dumper::Indent = 1 unless defined $Data::Dumper::Indent; - $dump_str = ( + my $dump_str = ( $dd_obj ||= do { @@ -343,11 +476,14 @@ sub is_exception ($) { { my $destruction_registry = {}; - sub CLONE { - $destruction_registry = { map - { defined $_ ? ( refaddr($_) => $_ ) : () } - values %$destruction_registry - }; + sub DBIx::Class::__Util_iThreads_handler__::CLONE { + %$destruction_registry = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$destruction_registry; + + weaken($_) for values %$destruction_registry; # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage # collected before leaving this scope. Depending on the code above, this @@ -533,8 +669,8 @@ sub mkdir_p ($) { ), 'with_stacktrace'); } - my $mark = []; - weaken ( $list_ctx_ok_stack_marker = $mark ); + weaken( $list_ctx_ok_stack_marker = my $mark = [] ); + $mark; } } @@ -546,7 +682,7 @@ sub fail_on_internal_call { $fr = [ CORE::caller(1) ]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) - : undef + : ( $DB::args[0] . '' ) ; }; @@ -558,7 +694,7 @@ sub fail_on_internal_call { $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there ) { DBIx::Class::Exception->throw( sprintf ( - "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", + "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", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do { require B::Deparse; no strict 'refs';