From: Matt S Trout <mst@shadowcat.co.uk>
Date: Fri, 22 Jul 2005 22:03:18 +0000 (+0000)
Subject: has_a works
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=12bbb33986a29dc27dd3e2b9d082a87f50124ec1;p=dbsrgits%2FDBIx-Class-Historic.git

has_a works
---

diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
index 51dd7bc..7a2da2c 100644
--- a/lib/DBIx/Class/AccessorGroup.pm
+++ b/lib/DBIx/Class/AccessorGroup.pm
@@ -1,5 +1,12 @@
 package DBIx::Class::AccessorGroup;
 
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_accessor_group_deleted' => { });
+
 sub mk_group_accessors {
     my($self, $group, @fields) = @_;
 
@@ -9,6 +16,7 @@ sub mk_group_accessors {
 
 {
     no strict 'refs';
+    no warnings 'redefine';
 
     sub _mk_group_accessors {
         my($self, $maker, $group, @fields) = @_;
@@ -27,11 +35,13 @@ sub mk_group_accessors {
             my $accessor = $self->$maker($group, $field);
             my $alias = "_${field}_accessor";
 
-            *{$class."\:\:$field"}  = $accessor
-              unless defined &{$class."\:\:$field"};
+            #warn "$class $group $field $alias";
 
-            *{$class."\:\:$alias"}  = $accessor
-              unless defined &{$class."\:\:$alias"};
+            *{$class."\:\:$field"}  = $accessor;
+              #unless defined &{$class."\:\:$field"}
+
+            *{$class."\:\:$alias"}  = $accessor;
+              #unless defined &{$class."\:\:$alias"}
         }
     }
 }
@@ -59,10 +69,10 @@ sub make_group_accessor {
         my $self = shift;
 
         if(@_) {
-            return $self->set($field, @_);
+            return $self->$set($field, @_);
         }
         else {
-            return $self->get($field);
+            return $self->$get($field);
         }
     };
 }
@@ -82,7 +92,7 @@ sub make_group_ro_accessor {
                         "objects of class '$class'");
         }
         else {
-            return $self->get($field);
+            return $self->$get($field);
         }
     };
 }
@@ -102,9 +112,18 @@ sub make_group_wo_accessor {
                         "objects of class '$class'");
         }
         else {
-            return $self->set($field, @_);
+            return $self->$set($field, @_);
         }
     };
 }
 
+sub delete_accessor {
+  my ($class, $accessor) = @_;
+  $class = ref $class if ref $class;
+  my $sym = "${class}::${accessor}";
+  undef &$sym;
+  delete $DB::sub{$sym};
+  #$class->_accessor_group_deleted->{"${class}::${accessor}"} = 1;
+}
+
 1;
diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index fc30d0a..c5e2634 100644
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -13,6 +13,7 @@ use base qw/DBIx::Class::CDBICompat::Convenience
             DBIx::Class::CDBICompat::Constructor
             DBIx::Class::CDBICompat::AccessorMapping
             DBIx::Class::CDBICompat::ColumnCase
+            DBIx::Class::CDBICompat::HasA
             DBIx::Class::CDBICompat::LazyLoading
             DBIx::Class::CDBICompat::AutoUpdate
             DBIx::Class::CDBICompat::ColumnGroups
diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm
index e5c23d8..d6f527c 100644
--- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm
+++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm
@@ -6,32 +6,55 @@ use NEXT;
 
 sub _register_column_group {
   my ($class, $group, @cols) = @_;
-  return $class->NEXT::_register_column_group($group => map lc, @cols);
+  return $class->NEXT::ACTUAL::_register_column_group($group => map lc, @cols);
 }
 
 sub _register_columns {
   my ($class, @cols) = @_;
-  return $class->NEXT::_register_columns(map lc, @cols);
+  return $class->NEXT::ACTUAL::_register_columns(map lc, @cols);
+}
+
+sub has_a {
+  my ($class, $col, @rest) = @_;
+  $class->NEXT::ACTUAL::has_a(lc($col), @rest);
+  $class->delete_accessor($col);
+  $class->mk_group_accessors('has_a' => $col);
+  return 1;
+}
+
+sub get_has_a {
+  my ($class, $get, @rest) = @_;
+  return $class->NEXT::ACTUAL::get_has_a(lc($get), @rest);
+}
+
+sub store_has_a {
+  my ($class, $set, @rest) = @_;
+  return $class->NEXT::ACTUAL::store_has_a(lc($set), @rest);
+}
+
+sub set_has_a {
+  my ($class, $set, @rest) = @_;
+  return $class->NEXT::ACTUAL::set_has_a(lc($set), @rest);
 }
 
 sub get_column {
   my ($class, $get, @rest) = @_;
-  return $class->NEXT::get_column(lc $get, @rest);
+  return $class->NEXT::ACTUAL::get_column(lc($get), @rest);
 }
 
 sub set_column {
   my ($class, $set, @rest) = @_;
-  return $class->NEXT::set_column(lc $set, @rest);
+  return $class->NEXT::ACTUAL::set_column(lc($set), @rest);
 }
 
 sub store_column {
   my ($class, $set, @rest) = @_;
-  return $class->NEXT::store_column(lc $set, @rest);
+  return $class->NEXT::ACTUAL::store_column(lc($set), @rest);
 }
 
 sub find_column {
   my ($class, $col) = @_;
-  return $class->NEXT::find_column(lc $col);
+  return $class->NEXT::ACTUAL::find_column(lc($col));
 }
 
 sub _mk_group_accessors {
@@ -39,7 +62,24 @@ sub _mk_group_accessors {
   my %fields;
   $fields{$_} = 1 for @fields,
                     map lc, grep { !defined &{"${class}::${_}"} } @fields;
-  return $class->NEXT::_mk_group_accessors($type, $group, keys %fields);
+  return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group, keys %fields);
+}
+
+sub _cond_key {
+  my ($class, $attrs, $key, @rest) = @_;
+  return $class->NEXT::ACTUAL::_cond_key($attrs, lc($key), @rest);
+}
+
+sub _cond_value {
+  my ($class, $attrs, $key, @rest) = @_;
+  return $class->NEXT::ACTUAL::_cond_value($attrs, lc($key), @rest);
+}
+
+sub new {
+  my ($class, $attrs, @rest) = @_;
+  my %att;
+  $att{lc $_} = $attrs->{$_} for keys %$attrs;
+  return $class->NEXT::ACTUAL::new(\%att, @rest);
 }
 
 1;
diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
index f702f14..d0f16f2 100644
--- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm
+++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
@@ -6,10 +6,49 @@ use warnings;
 use NEXT;
 use base qw/Class::Data::Inheritable/;
 
+__PACKAGE__->mk_classdata('_transform_sql_handler_order'
+                            => [ qw/TABLE ESSENTIAL JOIN/ ] );
+
 __PACKAGE__->mk_classdata('_transform_sql_handlers' =>
   {
-    'TABLE' => sub { return $_[0]->_table_name },
-    'ESSENTIAL' => sub { join(' ', $_[0]->columns('Essential')) },
+    'TABLE' =>
+      sub {
+        my ($self, $class, $data) = @_;
+        return $class->_table_name unless $data;
+        my ($f_class, $alias) = split(/=/, $data);
+        $f_class ||= $class;
+        $self->{_aliases}{$alias} = $f_class;
+        return $f_class->_table_name." ${alias}";
+      },
+    'ESSENTIAL' =>
+      sub {
+        my ($self, $class, $data) = @_;
+        return join(' ', $class->columns('Essential')) unless $data;
+        return join(' ', $self->{_aliases}{$data}->columns('Essential'));
+      },
+    'JOIN' =>
+      sub {
+        my ($self, $class, $data) = @_;
+        my ($from, $to) = split(/ /, $data);
+        my ($from_class, $to_class) = @{$self->{_aliases}}{$from, $to};
+        my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
+                          values %{ $from_class->_relationships };
+        unless ($rel_obj) {
+          ($from, $to) = ($to, $from);
+          ($from_class, $to_class) = ($to_class, $from_class);
+          ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
+                         values %{ $from_class->_relationships };
+        }
+        die "No relationship to JOIN from ${from_class} to ${to_class}"
+          unless $rel_obj;
+        my $attrs = {
+          _aliases => { self => $from, foreign => $to },
+          _action => 'join',
+        };
+        my $join = $from_class->_cond_resolve($rel_obj->{cond}, $attrs);
+        return $join;
+      }
+        
   } );
 
 sub db_Main {
@@ -51,9 +90,10 @@ sub set_sql {
 sub transform_sql {
   my ($class, $sql, @args) = @_;
   my $table = $class->_table_name;
-  foreach my $key (keys %{ $class->_transform_sql_handlers }) {
+  my $attrs = { };
+  foreach my $key (@{$class->_transform_sql_handler_order}) {
     my $h = $class->_transform_sql_handlers->{$key};
-    $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($class, $1)/eg;
+    $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg;
   }
   return sprintf($sql, @args);
 }
diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm
index ed61535..e991cc0 100644
--- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm
+++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm
@@ -23,6 +23,7 @@ sub _flesh {
   my %want;
   $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups;
   if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) {
+    #warn "@want";
     my $sth = $self->_get_sth('select', \@want, $self->_table_name,
                                 $self->_ident_cond); 
     $sth->execute($self->_ident_values);
diff --git a/lib/DBIx/Class/CDBICompat/Triggers.pm b/lib/DBIx/Class/CDBICompat/Triggers.pm
index 21826f9..46a0d49 100644
--- a/lib/DBIx/Class/CDBICompat/Triggers.pm
+++ b/lib/DBIx/Class/CDBICompat/Triggers.pm
@@ -5,7 +5,7 @@ use Class::Trigger;
 sub insert {
   my $self = shift;
   $self->call_trigger('before_create');
-  $self->NEXT::insert(@_);
+  $self->NEXT::ACTUAL::insert(@_);
   $self->call_trigger('after_create');
   return $self;
 }
@@ -15,7 +15,7 @@ sub update {
   $self->call_trigger('before_update');
   my @to_update = keys %{$self->{_dirty_columns} || {}};
   return -1 unless @to_update;
-  $self->NEXT::update(@_);
+  $self->NEXT::ACTUAL::update(@_);
   $self->call_trigger('after_update');
   return $self;
 }
@@ -23,7 +23,7 @@ sub update {
 sub delete {
   my $self = shift;
   $self->call_trigger('before_delete') if ref $self;
-  $self->NEXT::delete(@_);
+  $self->NEXT::ACTUAL::delete(@_);
   $self->call_trigger('after_delete') if ref $self;
   return $self;
 }
diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm
index 14b5367..fb412cc 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::PK
+use base qw/DBIx::Class::Relationship
+            DBIx::Class::SQL::Abstract
+            DBIx::Class::PK
             DBIx::Class::Table
             DBIx::Class::SQL
             DBIx::Class::DB
diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm
index 2725ff9..d1dc87c 100644
--- a/lib/DBIx/Class/PK.pm
+++ b/lib/DBIx/Class/PK.pm
@@ -32,14 +32,18 @@ sub retrieve {
   if (ref $vals[0] eq 'HASH') {
     $query = $vals[0];
   } elsif (@pk == @vals) {
-    return ($class->retrieve_from_sql($class->_ident_cond, @vals))[0];
+    my $ret = ($class->retrieve_from_sql($class->_ident_cond, @vals))[0];
+    #warn "$class: ".join(', ', %{$ret->{_column_data}});
+    return $ret;
   } else {
     $query = {@vals};
   }
   die "Can't retrieve unless all primary keys are specified"
     unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
                                   # column names etc. Not sure what to do yet
-  return ($class->search($query))[0];
+  my $ret = ($class->search($query))[0];
+  #warn "$class: ".join(', ', %{$ret->{_column_data}});
+  return $ret;
 }
 
 sub discard_changes {
diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index 9873ce4..eabc9e7 100644
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -66,10 +66,14 @@ sub delete {
     $sth->finish;
     delete $self->{_in_database};
   } else {
+    my $attrs = { };
+    if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+      $attrs = { %{ pop(@_) } };
+    }
     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
-    my ($cond, $param) = $self->_where_from_hash($query);
+    my ($cond, @param) = $self->_cond_resolve($query, $attrs);
     my $sth = $self->_get_sth('delete', undef, $self->_table_name, $cond);
-    $sth->execute(@$param);
+    $sth->execute(@param);
     $sth->finish;
   }
   return $self;
@@ -138,17 +142,23 @@ sub sth_to_objects {
 }
 
 sub search {
-  my $class    = shift;
-  my $where    = ref $_[0] eq "HASH" ? shift: {@_};
-  my ($cond, $param)  = $class->_where_from_hash($where);
-  return $class->retrieve_from_sql($cond, @{$param});
+  my $class = shift;
+  my $attrs = { };
+  if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+    $attrs = { %{ pop(@_) } };
+  }
+  my $query    = ref $_[0] eq "HASH" ? shift: {@_};
+  my ($cond, @param)  = $class->_cond_resolve($query, $attrs);
+  return $class->retrieve_from_sql($cond, @param);
 }
 
 sub search_like {
   my $class    = shift;
-  my $where    = ref $_[0] eq "HASH" ? shift: {@_};
-  my ($cond, $param)  = $class->_where_from_hash($where, { cmp => 'like' });
-  return $class->retrieve_from_sql($cond, @{$param});
+  my $attrs = { };
+  if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+    $attrs = pop(@_);
+  }
+  return $class->search(@_, { %$attrs, cmp => 'LIKE' });
 }
 
 sub _select_columns {
@@ -162,15 +172,15 @@ sub copy {
   return $new->insert;
 }
 
-sub _where_from_hash {
-  my ($self, $query, $opts) = @_;
-  my $op = $opts->{'cmp'} || '=';
+sub _cond_resolve {
+  my ($self, $query, $attrs) = @_;
+  my $op = $attrs->{'cmp'} || '=';
   my $cond = join(' AND ',
                map { (defined $query->{$_}
                        ? "$_ $op ?"
                        : (do { delete $query->{$_}; "$_ IS NULL"; }));
                    } keys %$query);
-  return ($cond, [ values %$query ]);
+  return ($cond, values %$query);
 }
 
 sub table {
diff --git a/t/cdbi-t/01-columns.t b/t/cdbi-t/01-columns.t
index 6b3346c..2c5fa2e 100644
--- a/t/cdbi-t/01-columns.t
+++ b/t/cdbi-t/01-columns.t
@@ -37,7 +37,7 @@ use base 'DBIx::Class';
 
 City->table('City');
 City->columns(All => qw/Name State Population/);
-#City->has_a(State => 'State');
+City->has_a(State => 'State');
 
 
 #-------------------------------------------------------------------------
diff --git a/t/cdbi-t/02-Film.t b/t/cdbi-t/02-Film.t
index bec54a2..68ee88d 100644
--- a/t/cdbi-t/02-Film.t
+++ b/t/cdbi-t/02-Film.t
@@ -280,7 +280,7 @@ print join("\n", @warnings);
 
 # Change after_update policy
 SKIP: {
-        skip "DBIx::Class compat doesn't handle triggers yet", 4;
+        skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4;
 	my $bt = Film->retrieve($btaste->id);
 	$bt->autoupdate(1);
 
diff --git a/t/cdbi-t/19-set_sql.t b/t/cdbi-t/19-set_sql.t
index 2278cd4..2b986bd 100644
--- a/t/cdbi-t/19-set_sql.t
+++ b/t/cdbi-t/19-set_sql.t
@@ -62,8 +62,8 @@ Film->set_sql(
 	is $pgs[1]->id, $f4->id, "and F4";
 };
 
-SKIP: {
-  skip "DBIx::Class doesn't have has_a yet", 6;
+#SKIP: {
+#  skip "DBIx::Class doesn't have has_a yet", 6;
 {
 	Actor->has_a(film => "Film");
 	Film->set_sql(
@@ -106,4 +106,4 @@ SKIP: {
 	is $apg[1]->title, "B", "and B";
 }
 
-} # end SKIP block
+#} # end SKIP block