X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCDBICompat%2FRelationships.pm;h=ecbc5c2d9570f6299d2332a949324fc8a3daa7ac;hb=09d8fb4a05e6cd025924cc08e41484f17a116695;hp=0a4b4755db0090e1d8448d804f8a445511ca34a3;hpb=c79bd6e9b40607d08e41879ecad0804c38bf14dc;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 0a4b475..ecbc5c2 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -3,18 +3,20 @@ package # hide from PAUSE use strict; use warnings; - -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; use Clone; use DBIx::Class::CDBICompat::Relationship; +use Scalar::Util 'blessed'; +use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; __PACKAGE__->mk_classdata('__meta_info' => {}); =head1 NAME -DBIx::Class::CDBICompat::Relationships +DBIx::Class::CDBICompat::Relationships - Emulate has_a(), has_many(), might_have() and meta_info() =head1 DESCRIPTION @@ -24,10 +26,10 @@ Emulate C, C, C and C. sub has_a { my($self, $col, @rest) = @_; - + $self->_declare_has_a($col, @rest); $self->_mk_inflated_column_accessor($col); - + return 1; } @@ -37,9 +39,16 @@ sub _declare_has_a { $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col); $self->ensure_class_loaded($f_class); - + my $rel_info; + # Class::DBI allows Non database has_a with implicit deflate and inflate + # Hopefully the following will catch Non-database tables. + if( !$f_class->isa('DBIx::Class::Row') and !$f_class->isa('Class::DBI::Row') ) { + $args{'inflate'} ||= sub { $f_class->new(shift) }; # implicit inflate by calling new + $args{'deflate'} ||= sub { shift() . '' }; # implicit deflate by stringification + } + if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a if (!ref $args{'inflate'}) { my $meth = $args{'inflate'}; @@ -50,18 +59,18 @@ sub _declare_has_a { $args{'deflate'} = sub { shift->$meth; }; } $self->inflate_column($col, \%args); - + $rel_info = { class => $f_class }; } else { $self->belongs_to($col, $f_class); - $rel_info = $self->result_source_instance->relationship_info($col); + $rel_info = $self->result_source->relationship_info($col); } - + $rel_info->{args} = \%args; - + $self->_extend_meta( has_a => $col, $rel_info @@ -72,7 +81,7 @@ sub _declare_has_a { sub _mk_inflated_column_accessor { my($class, $col) = @_; - + return $class->mk_group_accessors('inflated_column' => $col); } @@ -101,14 +110,14 @@ sub has_many { if( !$f_key and !@f_method ) { $class->ensure_class_loaded($f_class); - my $f_source = $f_class->result_source_instance; + my $f_source = $f_class->result_source; ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class } $f_source->relationships; } $class->next::method($rel, $f_class, $f_key, $args); - my $rel_info = $class->result_source_instance->relationship_info($rel); + my $rel_info = $class->result_source->relationship_info($rel); $args->{mapping} = \@f_method; $args->{foreign_key} = $f_key; $rel_info->{args} = $args; @@ -119,24 +128,25 @@ sub has_many { ); if (@f_method) { - no strict 'refs'; - no warnings 'redefine'; - my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; }; - *{"${class}::${rel}"} = - sub { - my $rs = shift->search_related($rel => @_); - $rs->{attrs}{record_filter} = $post_proc; - return (wantarray ? $rs->all : $rs); - }; + my @qsub_args = ( + { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }, + { attributes => [ 'DBIC_method_is_generated_from_resultsource_metadata' ] }, + ); + + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), @qsub_args; + my $rs = shift->related_resultset(%s)->search_rs( @_); + $rs->{attrs}{record_filter} = $rf; + return (wantarray ? $rs->all : $rs); +EOC + return 1; } - } sub might_have { my ($class, $rel, $f_class, @columns) = @_; - + my $ret; if (ref $columns[0] || !defined $columns[0]) { $ret = $class->next::method($rel, $f_class, @columns); @@ -145,28 +155,33 @@ sub might_have { { proxy => \@columns }); } - my $rel_info = $class->result_source_instance->relationship_info($rel); + my $rel_info = $class->result_source->relationship_info($rel); $rel_info->{args}{import} = \@columns; $class->_extend_meta( might_have => $rel, $rel_info ); - + return $ret; } sub _extend_meta { my ($class, $type, $rel, $val) = @_; - my %hash = %{ Clone::clone($class->__meta_info || {}) }; + +### Explicitly not using the deep cloner as Clone exhibits specific behavior +### wrt CODE references - it simply passes them as-is to the new structure +### (without deparse/eval cycles). There likely is code that relies on this +### so we just let sleeping dogs lie. + my $hash = Clone::clone($class->__meta_info || {}); $val->{self_class} = $class; $val->{type} = $type; $val->{accessor} = $rel; - $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); - $class->__meta_info(\%hash); + $hash->{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); + $class->__meta_info($hash); } @@ -192,11 +207,31 @@ sub search { : undef()); if (ref $where eq 'HASH') { foreach my $key (keys %$where) { # has_a deflation hack - $where->{$key} = ''.$where->{$key} - if eval { $where->{$key}->isa('DBIx::Class') }; + $where->{$key} = ''.$where->{$key} if ( + defined blessed $where->{$key} + and + $where->{$key}->isa('DBIx::Class') + ); } } $self->next::method($where, $attrs); } +sub new_related { + return shift->search_related(shift)->new_result(@_); +} + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1;