From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 24 May 2016 10:38:16 +0000 (+0200)
Subject: Add preliminary non-core attribute support
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=140bcb6a5e00a248c375b741579ed09e36604f64;p=dbsrgits%2FDBIx-Class-Historic.git

Add preliminary non-core attribute support

This is done in such a "cargocult" way to unblock the rsrc work.
Will be gutted out once Moo 2.002 ships
---

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index e7c6126..c12a343 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -47,6 +47,11 @@ sub MODIFY_CODE_ATTRIBUTES {
   return ();
 }
 
+sub FETCH_CODE_ATTRIBUTES {
+  my ($class,$code) = @_;
+  @{ $class->_attr_cache->{$code} || [] }
+}
+
 sub _attr_cache {
   my $self = shift;
   my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {};
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 933aa79..31f038f 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -103,7 +103,11 @@ our @EXPORT_OK = qw(
 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 {
@@ -139,6 +143,27 @@ sub quote_sub {
   };
 
   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 ($) {
diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t
index 23fb057..dcadd20 100644
--- a/xt/extra/internals/quote_sub.t
+++ b/xt/extra/internals/quote_sub.t
@@ -47,4 +47,30 @@ warnings_exist { $no_nothing_q->()->() } [
   }
 ;
 
+### Test the upcoming attributes support
+require DBIx::Class;
+@DBICTest::QSUB::ISA  = 'DBIx::Class';
+
+my $var = \42;
+my $s = quote_sub(
+  'DBICTest::QSUB::attr',
+  '$v',
+  { '$v' => $var },
+  {
+    # use grandfathered 'ResultSet' attribute for starters
+    attributes => [qw( ResultSet )],
+    package => 'DBICTest::QSUB',
+  },
+);
+
+is $s, \&DBICTest::QSUB::attr, 'Same cref installed';
+
+is DBICTest::QSUB::attr(), 42, 'Sub properly installed and callable';
+
+is_deeply
+  [ attributes::get( $s ) ],
+  [ 'ResultSet' ],
+  'Attribute installed',
+unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
+
 done_testing;
diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t
index d5a0b0a..87da4a5 100644
--- a/xt/extra/lean_startup.t
+++ b/xt/extra/lean_startup.t
@@ -141,6 +141,7 @@ BEGIN {
     Sub::Name
     Sub::Defer
     Sub::Quote
+    attributes
     File::Spec
 
     Scalar::Util