X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCDBICompat%2FRelationships.pm;h=64bcc3c39ee58087581a14a5cb16d95c18693978;hb=5379386ef2b88e002a778e02132b1f58adf31152;hp=3ce3ef53dfa834cead41c916a65f0f3a2acc1319;hpb=ee3337752d314667ec575398bb5007670db9bfbe;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 3ce3ef5..64bcc3c 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -3,11 +3,11 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use base qw/Class::Data::Inheritable/; +use base 'Class::Data::Inheritable'; use Clone; use DBIx::Class::CDBICompat::Relationship; +use DBIx::Class::_Util qw(quote_sub perlstring); __PACKAGE__->mk_classdata('__meta_info' => {}); @@ -40,6 +40,13 @@ sub _declare_has_a { 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'}; @@ -119,19 +126,14 @@ 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; }; - my $name = join '::', $class, $rel; - *$name = Sub::Name::subname $name, - sub { - my $rs = shift->search_related($rel => @_); - $rs->{attrs}{record_filter} = $post_proc; - return (wantarray ? $rs->all : $rs); - }; + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; + my $rs = shift->search_related( %s => @_); + $rs->{attrs}{record_filter} = $rf; + return (wantarray ? $rs->all : $rs); +EOC + return 1; } - }