Introduce DBIC-specific method attribute support

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / _Util.pm

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index f64e04b..a713ee7 100644 (file)
--- 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;
 
@@ -80,7 +82,7 @@ use B ();
 use Carp 'croak';
 use Storable 'nfreeze';
 use Scalar::Util qw(weaken blessed reftype refaddr);
-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'
@@ -92,14 +94,78 @@ our @EXPORT_OK = qw(
   fail_on_internal_wantarray fail_on_internal_call
   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;
 
@@ -134,6 +200,36 @@ 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 ($$) {
 
@@ -149,6 +245,15 @@ sub serialize ($) {
   nfreeze($_[0]);
 }
 
+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
@@ -371,7 +476,7 @@ sub is_exception ($) {
 {
   my $destruction_registry = {};
 
-  sub CLONE {
+  sub DBIx::Class::__Util_iThreads_handler__::CLONE {
     %$destruction_registry = map {
       (defined $_)
         ? ( refaddr($_) => $_ )
@@ -577,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] . '' )
     ;
   };
 
@@ -589,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';