From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 31 Jul 2005 22:20:42 +0000 (+0000)
Subject: Refactoring, basic cursor support, additional syntax supported by HasMany
X-Git-Tag: v0.03001~117
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=95a70f01eae4b2c325a3a527a72cf8ae91796e8c;p=dbsrgits%2FDBIx-Class.git

Refactoring, basic cursor support, additional syntax supported by HasMany
---

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index 1a2103b..aa88e4b 100644
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -3,13 +3,11 @@ package DBIx::Class::CDBICompat;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::CDBICompat::Convenience
-            DBIx::Class::CDBICompat::Triggers
+use base qw/DBIx::Class::CDBICompat::Triggers
             DBIx::Class::CDBICompat::GetSet
             DBIx::Class::CDBICompat::LiveObjectIndex
             DBIx::Class::CDBICompat::AttributeAPI
             DBIx::Class::CDBICompat::Stringify
-            DBIx::Class::CDBICompat::ObjIndexStubs
             DBIx::Class::CDBICompat::DestroyWarning
             DBIx::Class::CDBICompat::Constructor
             DBIx::Class::CDBICompat::AccessorMapping
@@ -21,6 +19,7 @@ use base qw/DBIx::Class::CDBICompat::Convenience
             DBIx::Class::CDBICompat::ColumnGroups
             DBIx::Class::CDBICompat::ImaDBI/;
 
+            #DBIx::Class::CDBICompat::ObjIndexStubs
 1;
 
 =head1 NAME 
diff --git a/lib/DBIx/Class/CDBICompat/Convenience.pm b/lib/DBIx/Class/CDBICompat/Convenience.pm
deleted file mode 100644
index 23ff2ed..0000000
--- a/lib/DBIx/Class/CDBICompat/Convenience.pm
+++ /dev/null
@@ -1,18 +0,0 @@
-package DBIx::Class::CDBICompat::Convenience;
-
-use strict;
-use warnings;
-
-sub find_or_create {
-  my $class    = shift;
-  my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
-  my ($exists) = $class->search($hash);
-  return defined($exists) ? $exists : $class->create($hash);
-}
-
-sub retrieve_all {
-  my ($class) = @_;
-  return $class->retrieve_from_sql( '1' );
-}
-
-1;
diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm
index f96cf9c..4bf3449 100644
--- 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;
 }
diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm
index afaf27b..2134154 100644
--- a/lib/DBIx/Class/DB.pm
+++ b/lib/DBIx/Class/DB.pm
@@ -41,7 +41,7 @@ sub _populate_dbh {
 
 sub _dbi_connect {
   my ($class, @info) = @_;
-  return DBI->connect_cached(@info);
+  return DBI->connect(@info);
 }
 
 sub connection {
diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm
index 08d499f..1ae5331 100644
--- a/lib/DBIx/Class/PK.pm
+++ b/lib/DBIx/Class/PK.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Tie::IxHash;
 
-use base qw/Class::Data::Inheritable DBIx::Class::SQL/;
+use base qw/Class::Data::Inheritable/;
 
 __PACKAGE__->mk_classdata('_primaries' => {});
 
diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm
index 80d3516..2c5adbf 100644
--- a/lib/DBIx/Class/SQL.pm
+++ b/lib/DBIx/Class/SQL.pm
@@ -46,7 +46,7 @@ sub _get_sql {
 
 sub _sql_to_sth {
   my ($class, $sql) = @_;
-  return $class->_get_dbh->prepare_cached($sql);
+  return $class->_get_dbh->prepare($sql);
 }
 
 sub _get_sth {
diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index aacbe0b..d7d67a8 100644
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -3,7 +3,9 @@ package DBIx::Class::Table;
 use strict;
 use warnings;
 
-use base qw/Class::Data::Inheritable DBIx::Class::SQL/;
+use DBIx::Class::Cursor;
+
+use base qw/Class::Data::Inheritable/;
 
 __PACKAGE__->mk_classdata('_columns' => {});
 
@@ -11,6 +13,8 @@ __PACKAGE__->mk_classdata('_table_name');
 
 __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do anything yet!
 
+__PACKAGE__->mk_classdata('_cursor_class' => 'DBIx::Class::Cursor');
+
 =head1 NAME 
 
 DBIx::Class::Table - Basic table methods
@@ -164,13 +168,10 @@ sub retrieve_from_sql {
 sub sth_to_objects {
   my ($class, $sth, $args, $cols) = @_;
   my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} );
-  $sth->execute(@$args);
-  my @found;
-  while (my @row = $sth->fetchrow_array) {
-    push(@found, $class->_row_to_object(\@cols, \@row));
-  }
-  $sth->finish;
-  return @found;
+  my $cursor_class = $class->_cursor_class;
+  eval "use $cursor_class;";
+  my $cursor = $cursor_class->new($class, $sth, $args, \@cols);
+  return (wantarray ? $cursor->all : $cursor);
 }
 
 sub _row_to_object { # WARNING: Destructive to @$row
@@ -228,6 +229,18 @@ sub table {
   shift->_table_name(@_);
 }
 
+sub find_or_create {
+  my $class    = shift;
+  my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
+  my ($exists) = $class->search($hash);
+  return defined($exists) ? $exists : $class->create($hash);
+}
+
+sub retrieve_all {
+  my ($class) = @_;
+  return $class->retrieve_from_sql( '1' );
+}
+
 1;
 
 =back
diff --git a/t/cdbi-t/12-filter.t b/t/cdbi-t/12-filter.t
index a51d34d..bce6e6f 100644
--- a/t/cdbi-t/12-filter.t
+++ b/t/cdbi-t/12-filter.t
@@ -93,12 +93,11 @@ is $@, '', "No errors";
 # Iterators
 #----------------------------------------------------------------------
 
-SKIP: {
-  skip "Compat layer doesn't have iterator support yet", 33;
+my $it_class = 'DBIx::Class::Cursor';
 
 sub test_normal_iterator {
 	my $it = $film->actors;
-	isa_ok $it, "Class::DBI::Iterator";
+	isa_ok $it, $it_class;
 	is $it->count, 3, " - with 3 elements";
 	my $i = 0;
 	while (my $film = $it->next) {
@@ -112,7 +111,7 @@ test_normal_iterator;
 {
 	Film->has_many(actor_ids => [ Actor => 'id' ]);
 	my $it = $film->actor_ids;
-	isa_ok $it, "Class::DBI::Iterator";
+	isa_ok $it, $it_class;
 	is $it->count, 3, " - with 3 elements";
 	my $i = 0;
 	while (my $film_id = $it->next) {
@@ -125,6 +124,10 @@ test_normal_iterator;
 # make sure nothing gets clobbered;
 test_normal_iterator;
 
+SKIP: {
+  skip "dbic iterators don't support slice yet", 12;
+
+
 {
 	my @acts = $film->actors->slice(1, 2);
 	is @acts, 2, "Slice gives 2 actor";
diff --git a/t/cdbi-t/21-iterator.t b/t/cdbi-t/21-iterator.t
new file mode 100644
index 0000000..7a88f43
--- /dev/null
+++ b/t/cdbi-t/21-iterator.t
@@ -0,0 +1,83 @@
+use strict;
+use Test::More;
+
+BEGIN {
+	eval "use DBD::SQLite";
+	plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33);
+}
+
+use lib 't/testlib';
+use Film;
+
+my $it_class = "DBIx::Class::Cursor";
+
+my @film  = (
+	Film->create({ Title => 'Film 1' }),
+	Film->create({ Title => 'Film 2' }),
+	Film->create({ Title => 'Film 3' }),
+	Film->create({ Title => 'Film 4' }),
+	Film->create({ Title => 'Film 5' }),
+	Film->create({ Title => 'Film 6' }),
+);
+
+{
+	my $it1 = Film->retrieve_all;
+	isa_ok $it1, $it_class;
+
+	my $it2 = Film->retrieve_all;
+	isa_ok $it2, $it_class;
+
+	while (my $from1 = $it1->next) {
+		my $from2 = $it2->next;
+		is $from1->id, $from2->id, "Both iterators get $from1";
+	}
+}
+
+{
+	my $it = Film->retrieve_all;
+	is $it->first->title, "Film 1", "Film 1 first";
+	is $it->next->title, "Film 2", "Film 2 next";
+	is $it->first->title, "Film 1", "First goes back to 1";
+	is $it->next->title, "Film 2", "With 2 still next";
+	$it->reset;
+	is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+	is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+SKIP: {
+  skip "Iterator doesn't yet have slice support", 19;
+
+{
+	my $it = Film->retrieve_all;
+	my @slice = $it->slice(2,4);
+	is @slice, 3, "correct slice size (array)";
+	is $slice[0]->title, "Film 3", "Film 3 first";
+	is $slice[2]->title, "Film 5", "Film 5 last";
+}
+
+{
+	my $it = Film->retrieve_all;
+	my $slice = $it->slice(2,4);
+	isa_ok $slice, $it_class, "slice as iterator";
+	is $slice->count, 3,"correct slice size (array)";
+	is $slice->first->title, "Film 3", "Film 3 first";
+	is $slice->next->title, "Film 4", "Film 4 next";
+	is $slice->first->title, "Film 3", "First goes back to 3";
+	is $slice->next->title, "Film 4", "With 4 still next";
+	$slice->reset;
+	is $slice->next->title, "Film 3", "Reset brings us to film 3 again";
+	is $slice->next->title, "Film 4", "And 4 is still next";
+
+	# check if the original iterator still works
+	is $it->count, 6, "back to the original iterator, is of right size";
+	is $it->first->title, "Film 1", "Film 1 first";
+	is $it->next->title, "Film 2", "Film 2 next";
+	is $it->first->title, "Film 1", "First goes back to 1";
+	is $it->next->title, "Film 2", "With 2 still next";
+	is $it->next->title, "Film 3", "Film 3 is still in original Iterator";
+	$it->reset;
+	is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+	is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+} # End SKIP