Refactoring, basic cursor support, additional syntax supported by HasMany

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / CDBICompat / HasMany.pm

diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm
index f96cf9c..4bf3449 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/HasMany.pm
+++ b/lib/DBIx/Class/CDBICompat/HasMany.pm
@@ -5,28 +5,42 @@ use warnings;
 
 sub has_many {
   my ($class, $rel, $f_class, $f_key, $args) = @_;
-  #die "No such column ${col}" unless $class->_columns->{$col};
+
+  my $self_key;
+
+  if (ref $f_class eq 'ARRAY') {
+    ($f_class, $self_key) = @$f_class;
+  }
+
+  if (!$self_key || $self_key eq 'id') {
+    my ($pri, $too_many) = keys %{ $class->_primaries };
+    die "has_many only works with a single primary key; ${class} has more"
+      if $too_many;
+    $self_key = $pri;
+  }
+    
   eval "require $f_class";
-  my ($pri, $too_many) = keys %{ $class->_primaries };
-  die "has_many only works with a single primary key; ${class} has more"
-    if $too_many;
+
   if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; };
+
   #unless ($f_key) { Not selective enough. Removed pending fix.
   #  ($f_rel) = grep { $_->{class} && $_->{class} eq $class }
   #               $f_class->_relationships;
   #}
+
   unless ($f_key) {
     #warn join(', ', %{ $f_class->_columns });
     $class =~ /([^\:]+)$/;
     #warn $1;
     $f_key = lc $1 if $f_class->_columns->{lc $1};
   }
+
   die "Unable to resolve foreign key for has_many from ${class} to ${f_class}"
     unless $f_key;
   die "No such column ${f_key} on foreign class ${f_class}"
     unless $f_class->_columns->{$f_key};
   $class->add_relationship($rel, $f_class,
-                            { "foreign.${f_key}" => "self.${pri}" },
+                            { "foreign.${f_key}" => "self.${self_key}" },
                             { _type => 'has_many', %{$args || {}} } );
   {
     no strict 'refs';
@@ -49,7 +63,9 @@ sub delete {
   my @hm = grep { $rels{$_}{attrs}{_type}
                    && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
   foreach my $has_many (@hm) {
-    $_->delete for $self->search_related($has_many);
+    unless ($rels{$has_many}->{attrs}{no_cascade_delete}) {
+      $_->delete for $self->search_related($has_many)
+    }
   }
   return $ret;
 }