lib/DBIx/Class/CDBICompat/HasMany.pm

   1 package DBIx::Class::CDBICompat::HasMany;
   2
   3 use strict;
   4 use warnings;
   5
   6 sub has_many {
   7   my ($class, $rel, $f_class, $f_key, $args) = @_;
   8
   9   my @f_method;
  10
  11   if (ref $f_class eq 'ARRAY') {
  12     ($f_class, @f_method) = @$f_class;
  13   }
  14
  15   my ($pri, $too_many) = keys %{ $class->_primaries };
  16   $class->throw( "has_many only works with a single primary key; ${class} has more" )
  17       if $too_many;
  18   my $self_key = $pri;
  19
  20   eval "require $f_class";
  21
  22   if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; };
  23
  24   #unless ($f_key) { Not selective enough. Removed pending fix.
  25   #  ($f_rel) = grep { $_->{class} && $_->{class} eq $class }
  26   #               $f_class->_relationships;
  27   #}
  28
  29   unless ($f_key) {
  30     #warn join(', ', %{ $f_class->_columns });
  31     $class =~ /([^\:]+)$/;
  32     #warn $1;
  33     $f_key = lc $1 if $f_class->_columns->{lc $1};
  34   }
  35
  36   $class->throw( "Unable to resolve foreign key for has_many from ${class} to ${f_class}" )
  37     unless $f_key;
  38   $class->throw( "No such column ${f_key} on foreign class ${f_class}" )
  39     unless $f_class->_columns->{$f_key};
  40   $args ||= {};
  41   my $cascade = not (ref $args eq 'HASH' && delete $args->{no_cascade_delete});
  42
  43  $class->add_relationship($rel, $f_class,
  44                             { "foreign.${f_key}" => "self.${self_key}" },
  45                             { accessor => 'multi',
  46                               join_type => 'LEFT',
  47                               ($cascade ? ('cascade_delete' => 1) : ()),
  48                               %$args } );
  49   if (@f_method) {
  50     no strict 'refs';
  51     no warnings 'redefine';
  52     my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
  53     *{"${class}::${rel}"} =
  54       sub {
  55         my $rs = shift->search_related($rel => @_);
  56         $rs->{attrs}{record_filter} = $post_proc;
  57         return (wantarray ? $rs->all : $rs);
  58       };
  59     return 1;
  60   }
  61
  62 }
  63
  64 1;