From: Matt S Trout <mst@shadowcat.co.uk>
Date: Tue, 2 Aug 2005 10:54:58 +0000 (+0000)
Subject: Factored common cdbi rel features out into Relationship:: packages
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4a07648ace2ace5b878c63aec52b7a30c1432b4d;p=dbsrgits%2FDBIx-Class-Historic.git

Factored common cdbi rel features out into Relationship:: packages
---

diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm
index fe85214..7f86b25 100644
--- a/lib/DBIx/Class/CDBICompat/HasA.pm
+++ b/lib/DBIx/Class/CDBICompat/HasA.pm
@@ -4,24 +4,27 @@ use strict;
 use warnings;
 
 sub has_a {
-  my ($self, $col, $f_class) = @_;
+  my ($self, $col, $f_class, %args) = @_;
   $self->throw( "No such column ${col}" ) unless $self->_columns->{$col};
   eval "require $f_class";
+  if ($args{'inflate'} || $args{'deflate'}) {
+    if (!ref $args{'inflate'}) {
+      my $meth = $args{'inflate'};
+      $args{'inflate'} = sub { $f_class->$meth(shift); };
+    }
+    if (!ref $args{'deflate'}) {
+      my $meth = $args{'deflate'};
+      $args{'deflate'} = sub { shift->$meth; };
+    }
+    $self->inflate_column($col, \%args);
+    return 1;
+  }
   my ($pri, $too_many) = keys %{ $f_class->_primaries };
   $self->throw( "has_a only works with a single primary key; ${f_class} has more" )
     if $too_many;
   $self->add_relationship($col, $f_class,
                             { "foreign.${pri}" => "self.${col}" },
-                            { _type => 'has_a' } );
-  $self->inflate_column($col,
-    { inflate => sub { 
-        my ($val, $self) = @_;
-        return ($self->search_related($col, {}, {}))[0]
-          || $f_class->new({ $pri => $val }); },
-      deflate => sub {
-        my ($val, $self) = @_;
-        $self->throw("$val isn't a $f_class") unless $val->isa($f_class);
-        return ($val->_ident_values)[0] } } );
+                            { _type => 'has_a', accessor => 'filter' } );
   return 1;
 }
 
diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm
index 3099bf6..ece8e2b 100644
--- a/lib/DBIx/Class/CDBICompat/HasMany.pm
+++ b/lib/DBIx/Class/CDBICompat/HasMany.pm
@@ -39,34 +39,14 @@ sub has_many {
     unless $f_key;
   $class->throw( "No such column ${f_key} on foreign class ${f_class}" )
     unless $f_class->_columns->{$f_key};
+  $args ||= {};
+  my $cascade = not (ref $args eq 'HAS' && delete $args->{no_cascade_delete});
   $class->add_relationship($rel, $f_class,
                             { "foreign.${f_key}" => "self.${self_key}" },
-                            { _type => 'has_many', %{$args || {}} } );
-  {
-    no strict 'refs';
-    *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); };
-    *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); };
-  }
+                            { accessor => 'multi',
+                              ($cascade ? ('cascade_delete' => 1) : ()),
+                              %$args } );
   return 1;
 }
 
-sub delete {
-  my ($self, @rest) = @_;
-  return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
-    # I'm just ignoring this for class deletes because hell, the db should
-    # be handling this anyway. Assuming we have joins we probably actually
-    # *could* do them, but I'd rather not.
-
-  my $ret = $self->NEXT::ACTUAL::delete(@rest);
-
-  my %rels = %{ $self->_relationships };
-  my @hm = grep { $rels{$_}{attrs}{_type}
-                   && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
-  foreach my $has_many (@hm) {
-    unless ($rels{$has_many}->{attrs}{no_cascade_delete}) {
-      $_->delete for $self->search_related($has_many)
-    }
-  }
-  return $ret;
-}
 1;
diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm
index 672c27f..3135fa2 100644
--- a/lib/DBIx/Class/Core.pm
+++ b/lib/DBIx/Class/Core.pm
@@ -3,7 +3,9 @@ package DBIx::Class::Core;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::Relationship
+use base qw/DBIx::Class::Relationship::Accessor
+            DBIx::Class::Relationship::CascadeActions
+            DBIx::Class::Relationship
             DBIx::Class::InflateColumn
             DBIx::Class::SQL::OrderBy
             DBIx::Class::SQL::Abstract
diff --git a/lib/DBIx/Class/Cursor.pm b/lib/DBIx/Class/Cursor.pm
index 753b6bc..b0565d1 100644
--- a/lib/DBIx/Class/Cursor.pm
+++ b/lib/DBIx/Class/Cursor.pm
@@ -47,7 +47,10 @@ sub next {
     $self->{live_sth} = 1;
   }
   my @row = $self->{sth}->fetchrow_array;
-  return unless @row;
+  unless (@row) {
+    $self->{sth}->finish if $self->{sth}->{Active};
+    return;
+  }
   $self->{pos}++;
   return $self->{class}->_row_to_object($self->{cols}, \@row);
 }
diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm
index eea026a..a3290b0 100644
--- a/lib/DBIx/Class/InflateColumn.pm
+++ b/lib/DBIx/Class/InflateColumn.pm
@@ -12,17 +12,19 @@ sub inflate_column {
   return 1;
 }
 
-sub _inflate_column_value {
+sub _inflated_column {
   my ($self, $col, $value) = @_;
   return $value unless defined $value; # NULL is NULL is NULL
+  return $value unless exists $self->_columns->{$col}{_inflate_info};
   return $value unless exists $self->_columns->{$col}{_inflate_info}{inflate};
   my $inflate = $self->_columns->{$col}{_inflate_info}{inflate};
   return $inflate->($value, $self);
 }
 
-sub _deflate_column_value {
+sub _deflated_column {
   my ($self, $col, $value) = @_;
   return $value unless ref $value; # If it's not an object, don't touch it
+  return $value unless exists $self->_columns->{$col}{_inflate_info};
   return $value unless exists $self->_columns->{$col}{_inflate_info}{deflate};
   my $deflate = $self->_columns->{$col}{_inflate_info}{deflate};
   return $deflate->($value, $self);
@@ -32,13 +34,11 @@ sub get_inflated_column {
   my ($self, $col) = @_;
   $self->throw("$col is not an inflated column") unless
     exists $self->_columns->{$col}{_inflate_info};
-  #warn $rel;
-  #warn join(', ', %{$self->{_column_data}});
+
   return $self->{_inflated_column}{$col}
     if exists $self->{_inflated_column}{$col};
-  #my ($pri) = (keys %{$self->_relationships->{$rel}{class}->_primaries})[0];
   return $self->{_inflated_column}{$col} =
-           $self->_inflate_column_value($col, $self->get_column($col));
+           $self->_inflated_column($col, $self->get_column($col));
 }
 
 sub set_inflated_column {
@@ -54,8 +54,10 @@ sub store_inflated_column {
     delete $self->{_inflated_column}{$col};
     return $self->store_column($col, $obj);
   }
-  my $deflated = $self->_deflate_column_value($col, $obj);
+
+  my $deflated = $self->_deflated_column($col, $obj);
            # Do this now so we don't store if it's invalid
+
   $self->{_inflated_column}{$col} = $obj;
   #warn "Storing $obj: ".($obj->_ident_values)[0];
   $self->store_column($col, $deflated);
@@ -68,7 +70,7 @@ sub new {
   my %deflated;
   foreach my $key (keys %$attrs) {
     if (exists $class->_columns->{$key}{_inflate_info}) {
-      $deflated{$key} = $class->_deflate_column_value($key,
+      $deflated{$key} = $class->_deflated_column($key,
                                                         delete $attrs->{$key});
     }
   }
@@ -78,7 +80,7 @@ sub new {
 sub _cond_value {
   my ($self, $attrs, $key, $value) = @_;
   if (exists $self->_columns->{$key}) {
-    $value = $self->_deflate_column_value($key, $value);
+    $value = $self->_deflated_column($key, $value);
   }
   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value);
 }
diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm
index 487aa94..fef88a0 100644
--- a/lib/DBIx/Class/PK.pm
+++ b/lib/DBIx/Class/PK.pm
@@ -77,8 +77,10 @@ sub discard_changes {
     $self->in_database(0);
     return $self;
   }
-  $self->store_column($_ => $reload->get_column($_))
-    foreach keys %{$self->_columns};
+  delete @{$self}{keys %$self};
+  @{$self}{keys %$reload} = values %$reload;
+  #$self->store_column($_ => $reload->get_column($_))
+  #  foreach keys %{$self->_columns};
   return $self;
 }
 
diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm
index def2733..976d295 100644
--- a/lib/DBIx/Class/Relationship.pm
+++ b/lib/DBIx/Class/Relationship.pm
@@ -110,7 +110,7 @@ sub search_related {
     $attrs = { %{ pop(@_) } };
   }
   my $rel_obj = $self->_relationships->{$rel};
-  $self->throw( "No such relationship ${rel}" ) unless $rel;
+  $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
   my $s_cond;
   if (@_) {
@@ -126,13 +126,18 @@ sub search_related {
 }
 
 sub create_related {
+  my $class = shift;
+  return $class->new_related(@_)->insert;
+}
+
+sub new_related {
   my ($self, $rel, $values, $attrs) = @_;
   $self->throw( "Can't call create_related as class method" ) 
     unless ref $self;
   $self->throw( "create_related needs a hash" ) 
     unless (ref $values eq 'HASH');
   my $rel_obj = $self->_relationships->{$rel};
-  $self->throw( "No such relationship ${rel}" ) unless $rel;
+  $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
     unless ref $rel_obj->{cond} eq 'HASH';
   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
@@ -141,7 +146,40 @@ sub create_related {
     $self->_cond_value($attrs, $k => $v);
     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
   }
-  return $rel_obj->{class}->create(\%fields);
+  return $rel_obj->{class}->new(\%fields);
+}
+
+sub find_or_create_related {
+  my $self = shift;
+  return ($self->search_related(@_))[0] || $self->create_related(@_);
+}
+
+sub set_from_related {
+  my ($self, $rel, $f_obj) = @_;
+  my $rel_obj = $self->_relationships->{$rel};
+  $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
+  my $cond = $rel_obj->{cond};
+  $self->throw( "set_from_related can only handle a hash condition; the "
+    ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
+      unless ref $cond eq 'HASH';
+  $self->throw( "Object $f_obj isn't a ".$rel_obj->{class} )
+    unless $f_obj->isa($rel_obj->{class});
+  foreach my $key (keys %$cond) {
+    next if ref $cond->{$key}; # Skip literals and complex conditions
+    $self->throw("set_from_related can't handle $key as key")
+      unless $key =~ m/^foreign\.([^\.]+)$/;
+    my $val = $f_obj->get_column($1);
+    $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
+      unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
+    $self->set_column($1 => $val);
+  }
+  return 1;
+}
+
+sub update_from_related {
+  my $self = shift;
+  $self->set_from_related(@_);
+  $self->update;
 }
 
 1;
diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
new file mode 100644
index 0000000..2350b81
--- /dev/null
+++ b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -0,0 +1,64 @@
+package DBIx::Class::Relationship::Accessor;
+
+use strict;
+use warnings;
+
+sub add_relationship {
+  my ($class, $rel, @rest) = @_;
+  my $ret = $class->NEXT::ACTUAL::add_relationship($rel => @rest);
+  my $rel_obj = $class->_relationships->{$rel};
+  if (my $acc_type = $rel_obj->{attrs}{accessor}) {
+    $class->_add_relationship_accessor($rel => $acc_type);
+  }
+  return $ret;
+}
+
+sub _add_relationship_accessor {
+  my ($class, $rel, $acc_type) = @_;
+  my %meth;
+  if ($acc_type eq 'single') {
+    $meth{$rel} = sub {
+      my $self = shift;
+      if (@_) {
+        $self->set_from_related($rel, @_);
+        return $self->{_relationship_data}{$rel} = $_[0];
+      } elsif (exists $self->{_relationship_data}{$rel}) {
+        return $self->{_relationship_data}{$rel};
+      } else {
+        return $self->{_relationship_data}{$rel}
+                 = $self->find_or_create_related($rel, {}, {});
+      }
+    };
+  } elsif ($acc_type eq 'filter') {
+    $class->throw("No such column $rel to filter")
+       unless exists $class->_columns->{$rel};
+    my $f_class = $class->_relationships->{$rel}{class};
+    $class->inflate_column($rel,
+      { inflate => sub {
+          my ($val, $self) = @_;
+          return $self->find_or_create_related($rel, {}, {});
+        },
+        deflate => sub {
+          my ($val, $self) = @_;
+          $self->throw("$val isn't a $f_class") unless $val->isa($f_class);
+          return ($val->_ident_values)[0];
+            # WARNING: probably breaks for multi-pri sometimes. FIXME
+        }
+      }
+    );
+  } elsif ($acc_type eq 'multi') {
+    $meth{$rel} = sub { shift->search_related($rel, @_) };
+    $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); };
+  } else {
+    $class->throw("No such relationship accessor type $acc_type");
+  }
+  {
+    no strict 'refs';
+    no warnings 'redefine';
+    foreach my $meth (keys %meth) {
+      *{"${class}::${meth}"} = $meth{$meth};
+    }
+  }
+}
+
+1;
diff --git a/lib/DBIx/Class/Relationship/CascadeActions.pm b/lib/DBIx/Class/Relationship/CascadeActions.pm
new file mode 100644
index 0000000..53f15b0
--- /dev/null
+++ b/lib/DBIx/Class/Relationship/CascadeActions.pm
@@ -0,0 +1,35 @@
+package DBIx::Class::Relationship::CascadeActions;
+
+sub delete {
+  my ($self, @rest) = @_;
+  return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
+    # I'm just ignoring this for class deletes because hell, the db should
+    # be handling this anyway. Assuming we have joins we probably actually
+    # *could* do them, but I'd rather not.
+
+  my $ret = $self->NEXT::ACTUAL::delete(@rest);
+
+  my %rels = %{ $self->_relationships };
+  my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
+  foreach my $rel (@cascade) {
+    $_->delete for $self->search_related($rel);
+  }
+  return $ret;
+}
+
+sub update {
+  my ($self, @rest) = @_;
+  return $self->NEXT::ACTUAL::update(@rest) unless ref $self;
+    # Because update cascades on a class *really* don't make sense!
+
+  my $ret = $self->NEXT::ACTUAL::update(@rest);
+
+  my %rels = %{ $self->_relationships };
+  my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
+  foreach my $rel (@cascade) {
+    $_->update for $self->$rel;
+  }
+  return $ret;
+}
+
+1;
diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index e6ba457..734e1d9 100644
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -172,9 +172,10 @@ sub retrieve_from_sql {
 sub sth_to_objects {
   my ($class, $sth, $args, $cols, $attrs) = @_;
   my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} );
+  my @args = map { ref $_ ? ''.$_ : $_ } @$args; # Stringify objects
   my $cursor_class = $class->_cursor_class;
   eval "use $cursor_class;";
-  my $cursor = $cursor_class->new($class, $sth, $args, \@cols, $attrs);
+  my $cursor = $cursor_class->new($class, $sth, \@args, \@cols, $attrs);
   return (wantarray ? $cursor->all : $cursor);
 }
 
diff --git a/t/08inflate_has_a.t b/t/08inflate_has_a.t
new file mode 100644
index 0000000..e6bd567
--- /dev/null
+++ b/t/08inflate_has_a.t
@@ -0,0 +1,32 @@
+use Test::More;
+use DateTime;
+
+plan tests => 4;
+
+use lib qw(t/lib);
+
+use_ok('DBICTest');
+
+use DBIx::Class::CDBICompat::HasA;
+
+unshift(@DBICTest::ISA, 'DBIx::Class::CDBICompat::HasA');
+
+DBICTest::CD->has_a( 'year', 'DateTime',
+      inflate => sub { DateTime->new( year => shift ) },
+      deflate => sub { shift->year }
+);
+
+# inflation test
+my $cd = DBICTest::CD->retrieve(3);
+
+is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
+
+is( $cd->year->month, 1, 'inflated month ok' );
+
+# deflate test
+my $now = DateTime->now;
+$cd->year( $now );
+$cd->update;
+
+($cd) = DBICTest::CD->search( year => $now->year );
+is( $cd->year->year, $now->year, 'deflate ok' );