From: Matt S Trout <mst@shadowcat.co.uk>
Date: Tue, 2 Aug 2005 12:29:37 +0000 (+0000)
Subject: More refactoring and tweaking, might_have support added
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b28cc0ba2d1d443728c9cb48d97e5a2cdccf8cb4;p=dbsrgits%2FDBIx-Class-Historic.git

More refactoring and tweaking, might_have support added
---

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index 78cfc07..ae25ddd 100644
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -14,6 +14,7 @@ use base qw/DBIx::Class::CDBICompat::Constraints
             DBIx::Class::CDBICompat::Constructor
             DBIx::Class::CDBICompat::AccessorMapping
             DBIx::Class::CDBICompat::ColumnCase
+            DBIx::Class::CDBICompat::MightHave
             DBIx::Class::CDBICompat::HasMany
             DBIx::Class::CDBICompat::HasA
             DBIx::Class::CDBICompat::LazyLoading
diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm
index ece8e2b..7b779e3 100644
--- a/lib/DBIx/Class/CDBICompat/HasMany.pm
+++ b/lib/DBIx/Class/CDBICompat/HasMany.pm
@@ -40,7 +40,7 @@ sub has_many {
   $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});
+  my $cascade = not (ref $args eq 'HASH' && delete $args->{no_cascade_delete});
   $class->add_relationship($rel, $f_class,
                             { "foreign.${f_key}" => "self.${self_key}" },
                             { accessor => 'multi',
diff --git a/lib/DBIx/Class/CDBICompat/MightHave.pm b/lib/DBIx/Class/CDBICompat/MightHave.pm
new file mode 100644
index 0000000..5cf073e
--- /dev/null
+++ b/lib/DBIx/Class/CDBICompat/MightHave.pm
@@ -0,0 +1,22 @@
+package DBIx::Class::CDBICompat::MightHave;
+
+use strict;
+use warnings;
+
+sub might_have {
+  my ($class, $rel, $f_class, @columns) = @_;
+  my ($pri, $too_many) = keys %{ $class->_primaries };
+  $class->throw( "might_have only works with a single primary key; ${class} has more" )
+    if $too_many;
+  my $f_pri;
+  ($f_pri, $too_many) = keys %{ $f_class->_primaries };
+  $class->throw( "might_have only works with a single primary key; ${f_class} has more" )
+    if $too_many;
+  $class->add_relationship($rel, $f_class,
+   { "foreign.${f_pri}" => "self.${pri}" },
+   { accessor => 'single', proxy => \@columns,
+     cascade_update => 1, cascade_delete => 1 });
+  1;
+}
+
+1;
diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm
index 3135fa2..a3fb44e 100644
--- a/lib/DBIx/Class/Core.pm
+++ b/lib/DBIx/Class/Core.pm
@@ -5,6 +5,7 @@ use warnings;
 
 use base qw/DBIx::Class::Relationship::Accessor
             DBIx::Class::Relationship::CascadeActions
+            DBIx::Class::Relationship::ProxyMethods
             DBIx::Class::Relationship
             DBIx::Class::InflateColumn
             DBIx::Class::SQL::OrderBy
diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm
index 976d295..da768ac 100644
--- a/lib/DBIx/Class/Relationship.pm
+++ b/lib/DBIx/Class/Relationship.pm
@@ -132,9 +132,9 @@ sub create_related {
 
 sub new_related {
   my ($self, $rel, $values, $attrs) = @_;
-  $self->throw( "Can't call create_related as class method" ) 
+  $self->throw( "Can't call new_related as class method" ) 
     unless ref $self;
-  $self->throw( "create_related needs a hash" ) 
+  $self->throw( "new_related needs a hash" ) 
     unless (ref $values eq 'HASH');
   my $rel_obj = $self->_relationships->{$rel};
   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
index 2350b81..0c19ef1 100644
--- a/lib/DBIx/Class/Relationship/Accessor.pm
+++ b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -25,8 +25,9 @@ sub _add_relationship_accessor {
       } elsif (exists $self->{_relationship_data}{$rel}) {
         return $self->{_relationship_data}{$rel};
       } else {
-        return $self->{_relationship_data}{$rel}
-                 = $self->find_or_create_related($rel, {}, {});
+        my ($val) = $self->search_related($rel, {}, {});
+        return unless $val;
+        return $self->{_relationship_data}{$rel} = $val;
       }
     };
   } elsif ($acc_type eq 'filter') {
diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm
new file mode 100644
index 0000000..ede62a7
--- /dev/null
+++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm
@@ -0,0 +1,30 @@
+package DBIx::Class::Relationship::ProxyMethods;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+sub add_relationship {
+  my ($class, $rel, @rest) = @_;
+  my $ret = $class->NEXT::ACTUAL::add_relationship($rel => @rest);
+  if (my $proxy_list = $class->_relationships->{$rel}->{attrs}{proxy}) {
+    no strict 'refs';
+    no warnings 'redefine';
+    foreach my $proxy (ref $proxy_list ? @$proxy_list : $proxy_list) {
+      *{"${class}::${proxy}"} =
+        sub {
+          my $self = shift;
+          my $val = $self->$rel;
+          if (@_ && !defined $val) {
+            $val = $self->create_related($rel, { $proxy => $_[0] });
+            @_ = ();
+          }
+          return ($val ? $val->$proxy(@_) : undef);
+       }
+    }
+  }
+  return $ret;
+}
+
+1;
diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index 734e1d9..d8b6658 100644
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -241,6 +241,11 @@ sub find_or_create {
   return defined($exists) ? $exists : $class->create($hash);
 }
 
+sub insert_or_update {
+  my $self = shift;
+  return ($self->in_database ? $self->update : $self->insert);
+}
+
 sub retrieve_all {
   my ($class) = @_;
   return $class->retrieve_from_sql( '1' );