X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass.pm;h=61c09b1670d0ed33b7d027a9acf248623748adc6;hb=0130575a1a5ad9249a5cdc705c043286fabdf32c;hp=b7f24ee74bd3a417617e48cde991ebc74f00d125;hpb=d63c9e6418251a745cc6b6e1ef5ddf4b12ceb190;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index b7f24ee..61c09b1 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,55 +14,124 @@ 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.082899_01'; +$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; +use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); +use Scalar::Util qw( weaken refaddr ); +use namespace::clean; + __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); -__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve'); +__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 -sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor } - -sub mk_classdata { - shift->mk_classaccessor(@_); -} - -sub mk_classaccessor { - my $self = shift; - $self->mk_group_accessors('inherited', $_[0]); - $self->set_inherited(@_) if @_ > 1; +# +# 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 $attr_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->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_} + for keys %$attr_stash; + } + + return 1; + }); + + # renumber the cref registry itself + %$attr_cref_registry = map { + ( defined $_->{weakref} ) + ? ( + # because of how __attr_cache works, ugh + "$_->{weakref}" => $_, + ) + : () + } values %$attr_cref_registry; +} + 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 $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} + for keys %$attr_cref_registry; + + # The original API used stringification instead of refaddr - can't change that now + if( $attr_cref_registry->{$code} ) { + Carp::confess( sprintf + "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work", + refdesc($code), + refdesc($attr_cref_registry->{$code}{weakref}), + "$code" + ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code); + } + else { + weaken( $attr_cref_registry->{$code}{weakref} = $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 || {} }, }; } @@ -209,7 +281,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); @@ -286,7 +358,7 @@ accessible at the following locations: =item * Travis-CI log: L =for html -↪ Stable branch CI status: +↪ Bleeding edge dev CI status: =back