X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass.pm;h=ef1c60e2d1287bd4491d287655c2c16eac581799;hb=7dc14bc09910cb750e5fe503dfa18a97eed490d1;hp=070bdc038f7db25efba7e4b7bc63495826b65a2a;hpb=f06eb015d1f5a43c9fc6c44e6d0b2f73a5aca1e0;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index 070bdc0..ef1c60e 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -1,5 +1,8 @@
 package DBIx::Class;
 
+# important to load early
+use DBIx::Class::_Util;
+
 use strict;
 use warnings;
 
@@ -11,48 +14,114 @@ our $VERSION;
 # $VERSION declaration must stay up here, ahead of any other package
 # declarations, as to not confuse various modules attempting to determine
 # this ones version, whether that be s.c.o. or Module::Metadata, etc
-$VERSION = '0.082700_06';
+$VERSION = '0.082899_15';
 
 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
 
-use DBIx::Class::_Util;
 use mro 'c3';
 
-use DBIx::Class::Optional::Dependencies;
-
 use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/;
-use DBIx::Class::StartupCheck;
 use DBIx::Class::Exception;
 
-__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
-__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve');
-
-sub mk_classdata {
-  shift->mk_classaccessor(@_);
-}
+use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
+use Scalar::Util qw( weaken refaddr );
+use namespace::clean;
 
-sub mk_classaccessor {
-  my $self = shift;
-  $self->mk_group_accessors('inherited', $_[0]);
-  $self->set_inherited(@_) if @_ > 1;
+__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
+__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::');
+
+# FIXME - this is not really necessary, and is in
+# fact going to slow things down a bit
+# However it is the right thing to do in order to get
+# various install bases to highlight their brokenness
+# Remove at some unknown point in the future
+#
+# The oddball BEGIN is there for... reason unknown
+# It does make non-segfaulty difference on pre-5.8.5 perls, so shrug
+BEGIN {
+  sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor };
 }
 
 sub component_base_class { 'DBIx::Class' }
 
+
+my $cref_registry;
+sub DBIx::Class::__Attr_iThreads_handler__::CLONE {
+
+  # this is disgusting, but the best we can do without even more surgery
+  visit_namespaces( action => sub {
+    my $pkg = shift;
+
+    # skip dangerous namespaces
+    return 1 if $pkg =~ /^ (?:
+      DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
+    ) $/x;
+
+    no strict 'refs';
+
+    if (
+      exists ${"${pkg}::"}{__cag___attr_cache}
+        and
+      ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH'
+    ) {
+      $attr_stash->{ $cref_registry->{$_} } = delete $attr_stash->{$_}
+        for keys %$attr_stash;
+    }
+
+    return 1;
+  })
+}
+
 sub MODIFY_CODE_ATTRIBUTES {
   my ($class,$code,@attrs) = @_;
-  $class->mk_classdata('__attr_cache' => {})
+  $class->mk_classaccessor('__attr_cache' => {})
     unless $class->can('__attr_cache');
-  $class->__attr_cache->{$code} = [@attrs];
+
+  # compaction step
+  defined $cref_registry->{$_} or delete $cref_registry->{$_}
+    for keys %$cref_registry;
+
+  # The original API used stringification instead of refaddr - can't change that now
+  if( $cref_registry->{$code} ) {
+    Carp::confess( sprintf
+      "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
+      refdesc($code),
+      refdesc($cref_registry->{$code}),
+      "$code"
+    ) if refaddr($cref_registry->{$code}) != refaddr($code);
+  }
+  else {
+    weaken( $cref_registry->{$code} = $code )
+  }
+
+  $class->__attr_cache->{$code} = [ sort( uniq(
+    @{ $class->__attr_cache->{$code} || [] },
+    @attrs,
+  ))];
+
+  # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
+  # decidedly not cool
+  #
+  # There should be some sort of warning on unrecognized attributes or
+  # somesuch... OTOH people do use things in the wild hence the plan of action
+  # is anything but clear :/
+  #
+  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110
+  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29
+  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36
+  #
   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 : {};
-
-  return {
-    %$cache,
+  +{
+    %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
     %{ $self->maybe::next::method || {} },
   };
 }
@@ -202,7 +271,7 @@ Then you can use these classes in your application's code:
   my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ...
   my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query
 
-  # new() makes a Result object but doesnt insert it into the DB.
+  # new() makes a Result object but doesn't insert it into the DB.
   # create() is the same as new() then insert().
   my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' });
   $new_cd->artist($cd->artist);
@@ -279,7 +348,7 @@ accessible at the following locations:
 =item * Travis-CI log: L<https://travis-ci.org/dbsrgits/dbix-class/builds>
 
 =for html
-&#x21AA; Stable branch CI status: <img src="https://secure.travis-ci.org/dbsrgits/dbix-class.png?branch=master"></img>
+&#x21AA; Bleeding edge dev CI status: <img src="https://secure.travis-ci.org/dbsrgits/dbix-class.png?branch=master"></img>
 
 =back