From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 4 Aug 2005 14:30:39 +0000 (+0000)
Subject: Mostly refactored everything to select/update/delete off storage handle
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8b445e337a0dbacf4ccb827211002f8d691ad671;p=dbsrgits%2FDBIx-Class-Historic.git

Mostly refactored everything to select/update/delete off storage handle
---

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index c1cc569..9cb1b36 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -10,7 +10,7 @@ $VERSION = '0.01';
 
 sub load_components {
   my $class = shift;
-  my @comp = map { "DBIx::Class::$_" } @_;
+  my @comp = map { "DBIx::Class::$_" } grep { $_ !~ /^#/ } @_;
   foreach my $comp (@comp) {
     eval "use $comp";
     die $@ if $@;
diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
index 9a451a2..8aaa564 100644
--- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm
+++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
@@ -53,18 +53,18 @@ __PACKAGE__->mk_classdata('_transform_sql_handlers' =>
   } );
 
 sub db_Main {
-  return $_[0]->_get_dbh;
+  return $_[0]->storage->dbh;
 }
 
-sub _dbi_connect {
+sub connection {
   my ($class, @info) = @_;
   $info[3] = { %{ $info[3] || {}} };
   $info[3]->{RootClass} = 'DBIx::ContextualFetch';
-  return $class->NEXT::_dbi_connect(@info);
+  return $class->NEXT::connection(@info);
 }
 
 sub __driver {
-  return $_[0]->_get_dbh->{Driver}->{Name};
+  return $_[0]->storage->dbh->{Driver}->{Name};
 }
 
 sub set_sql {
@@ -76,7 +76,7 @@ sub set_sql {
     sub {
       my $sql = $sql;
       my $class = shift;
-      return $class->_sql_to_sth($class->transform_sql($sql, @_));
+      return $class->storage->sth($class->transform_sql($sql, @_));
     };
   if ($sql =~ /select/i) {
     my $meth = "sql_${name}";
diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm
index d15345a..ea76d0c 100644
--- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm
+++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm
@@ -24,10 +24,13 @@ sub _flesh {
   my %want;
   $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups;
   if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) {
-    my $sth = $self->_get_sth('select', \@want, $self->_table_name,
-                                $self->_ident_cond); 
-    $sth->execute($self->_ident_values);
+    my $sth = $self->storage->select($self->_table_name, \@want,
+                \$self->_ident_cond, { bind => [ $self->_ident_values ] });
+    #my $sth = $self->storage->select($self->_table_name, \@want,
+    #                                   $self->ident_condition);
+    # Not sure why the first one works and this doesn't :(
     my @val = $sth->fetchrow_array;
+#warn "Flesh: ".join(', ', @want, '=>', @val);
     foreach my $w (@want) {
       $self->{'_column_data'}{$w} = shift @val;
     }
diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm
index 7f36763..b85e9e5 100644
--- a/lib/DBIx/Class/Core.pm
+++ b/lib/DBIx/Class/Core.pm
@@ -15,7 +15,6 @@ __PACKAGE__->load_components(qw/
   SQL::Abstract
   PK
   Table
-  SQL
   DB
   Exception
   AccessorGroup/);
diff --git a/lib/DBIx/Class/Cursor.pm b/lib/DBIx/Class/Cursor.pm
index df8aea5..4c59ff3 100644
--- a/lib/DBIx/Class/Cursor.pm
+++ b/lib/DBIx/Class/Cursor.pm
@@ -11,8 +11,8 @@ sub new {
   #use Data::Dumper; warn Dumper(@_);
   $it_class = ref $it_class if ref $it_class;
   unless ($sth) {
-    $sth = $db_class->_get_sth('select', $cols,
-                             $db_class->_table_name, $attrs->{where});
+    $sth = $db_class->storage->select($db_class->_table_name,$cols,
+                                        $attrs->{where},$attrs);
   }
   my $new = {
     class => $db_class,
@@ -56,12 +56,8 @@ sub count {
   my ($self) = @_;
   return $self->{attrs}{rows} if $self->{attrs}{rows};
   if (my $cond = $self->{attrs}->{where}) {
-    my $class = $self->{class};
-    my $sth = $class->_get_sth( 'select', [ 'COUNT(*)' ],
-                                  $class->_table_name, $cond);
-    my ($count) = $class->_get_dbh->selectrow_array(
-                                      $sth, undef, @{$self->{args} || []});
-    return $count;
+#warn "Counting ".$$cond;
+    return $self->{class}->count($cond, { bind => $self->{args} });
   } else {
     return scalar $_[0]->all; # So inefficient
   }
diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm
index c39ec03..b4f8beb 100644
--- a/lib/DBIx/Class/DB.pm
+++ b/lib/DBIx/Class/DB.pm
@@ -1,21 +1,30 @@
 package DBIx::Class::DB;
 
 use base qw/Class::Data::Inheritable/;
+use DBIx::Class::Storage::DBI;
 use DBI;
 
-__PACKAGE__->mk_classdata('_dbi_connect_info');
-__PACKAGE__->mk_classdata('_dbi_connect_package');
-__PACKAGE__->mk_classdata('_dbh');
-
 =head1 NAME 
 
-DBIx::Class::DB - DBIx::Class Database connection
+DBIx::Class::DB - Simple DBIx::Class Database connection by class inheritance
 
 =head1 SYNOPSIS
 
+  package MyDB;
+
+  use base qw/DBIx::Class/;
+  __PACKAGE__->load_components('DB');
+
+  __PACKAGE__->connection('dbi:...', 'user', 'pass', \%attrs);
+
+  package MyDB::MyTable;
+
+  use base qw/MyDB/;
+  __PACKAGE__->load_components('Table');
+
 =head1 DESCRIPTION
 
-This class represents the connection to the database
+This class provides a simple way of specifying a database connection.
 
 =head1 METHODS
 
@@ -23,26 +32,7 @@ This class represents the connection to the database
 
 =cut
 
-sub _get_dbh {
-  my ($class) = @_;
-  my $dbh;
-  unless (($dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
-    $class->_populate_dbh;
-  }
-  return $class->_dbh;
-}
-
-sub _populate_dbh {
-  my ($class) = @_;
-  my @info = @{$class->_dbi_connect_info || []};
-  my $pkg = $class->_dbi_connect_package || $class;
-  $pkg->_dbh($class->_dbi_connect(@info));
-}
-
-sub _dbi_connect {
-  my ($class, @info) = @_;
-  return DBI->connect(@info);
-}
+__PACKAGE__->mk_classdata('storage');
 
 =item connection
 
@@ -55,8 +45,9 @@ instantiate the class dbh when required.
 
 sub connection {
   my ($class, @info) = @_;
-  $class->_dbi_connect_package($class);
-  $class->_dbi_connect_info(\@info);
+  my $storage = DBIx::Class::Storage::DBI->new;
+  $storage->connect_info(\@info);
+  $class->storage($storage);
 }
 
 =item dbi_commit
@@ -67,7 +58,7 @@ Issues a commit again the current dbh
 
 =cut
 
-sub dbi_commit { $_[0]->_get_dbh->commit; }
+sub dbi_commit { $_[0]->storage->commit; }
 
 =item dbi_rollback
 
@@ -77,7 +68,9 @@ Issues a rollback again the current dbh
 
 =cut
 
-sub dbi_rollback { $_[0]->_get_dbh->rollback; }
+sub dbi_rollback { $_[0]->storage->rollback; }
+
+sub _get_dbh { shift->storage->dbh; }
 
 1;
 
diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm
index fef88a0..bcd545d 100644
--- a/lib/DBIx/Class/PK.pm
+++ b/lib/DBIx/Class/PK.pm
@@ -91,6 +91,10 @@ sub id {
   return (wantarray ? @pk : $pk[0]);
 }
 
+sub primary_columns {
+  return keys %{shift->_primaries};
+}
+
 1;
 
 =back
diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm
index 569de9b..109edf2 100644
--- a/lib/DBIx/Class/Relationship.pm
+++ b/lib/DBIx/Class/Relationship.pm
@@ -104,12 +104,12 @@ sub _cond_value {
 
 sub search_related {
   my $self = shift;
-  $self->_from_sql_related('retrieve', @_);
+  return $self->_from_sql_related('retrieve', @_);
 }
 
 sub count_related {
   my $self = shift;
-  $self->_from_sql_related('count', @_);
+  return $self->_from_sql_related('count', @_);
 }
 
 sub _from_sql_related {
@@ -134,6 +134,7 @@ sub _from_sql_related {
                                  # to merge into the AST really?
   my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
   $cond = "${s_cond} AND ${cond}" if $s_cond;
+  #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}});
   return $rel_obj->{class}->$meth($cond, @{$attrs->{bind} || []}, $attrs);
 }
 
diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm
index 2c5adbf..65beae4 100644
--- a/lib/DBIx/Class/SQL.pm
+++ b/lib/DBIx/Class/SQL.pm
@@ -28,8 +28,7 @@ __PACKAGE__->mk_classdata('_sql_statements',
     'select' =>
       sub { "SELECT ".join(', ', @{$_[COLS]})." FROM $_[FROM] WHERE $_[COND]"; },
     'update' =>
-      sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @{$_[COLS]}).
-              " WHERE $_[COND]"; },
+      sub { "UPDATE $_[FROM] SET $_[COLS] WHERE $_[COND]"; },
     'insert' =>
       sub { "INSERT INTO $_[FROM] (".join(', ', @{$_[COLS]}).") VALUES (".
               join(', ', map { '?' } @{$_[COLS]}).")"; },
@@ -37,13 +36,15 @@ __PACKAGE__->mk_classdata('_sql_statements',
       sub { "DELETE FROM $_[FROM] WHERE $_[COND]"; },
   } );
 
-sub _get_sql {
+sub create_sql {
   my ($class, $name, $cols, $from, $cond) = @_;
   my $sql = $class->_sql_statements->{$name}->($cols, $from, $cond);
   #warn $sql;
   return $sql;
 }
 
+*_get_sql = \&create_sql;
+
 sub _sql_to_sth {
   my ($class, $sql) = @_;
   return $class->_get_dbh->prepare($sql);
diff --git a/lib/DBIx/Class/SQL/Abstract.pm b/lib/DBIx/Class/SQL/Abstract.pm
index 893e8c8..a0740c2 100644
--- a/lib/DBIx/Class/SQL/Abstract.pm
+++ b/lib/DBIx/Class/SQL/Abstract.pm
@@ -1,5 +1,8 @@
 package DBIx::Class::SQL::Abstract;
 
+use strict;
+use warnings;
+
 # Many thanks to SQL::Abstract, from which I stole most of this
 
 sub _debug { }
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
new file mode 100644
index 0000000..2a4d84a
--- /dev/null
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -0,0 +1,148 @@
+package DBIx::Class::Storage::DBI;
+
+use DBI;
+
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/SQL::Abstract SQL Exception AccessorGroup/);
+
+__PACKAGE__->mk_group_accessors('simple' => qw/connect_info _dbh/);
+
+sub new {
+  bless({}, ref $_[0] || $_[0]);
+}
+
+sub get_simple {
+  my ($self, $get) = @_;
+  return $self->{$get};
+}
+
+sub set_simple {
+  my ($self, $set, $val) = @_;
+  return $self->{$set} = $val;
+}
+
+=head1 NAME 
+
+DBIx::Class::Storage::DBI - DBI storage handler
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This class represents the connection to the database
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+sub dbh {
+  my ($self) = @_;
+  my $dbh;
+  unless (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
+    $self->_populate_dbh;
+  }
+  return $self->_dbh;
+}
+
+sub _populate_dbh {
+  my ($self) = @_;
+  my @info = @{$self->connect_info || []};
+  $self->_dbh($self->_connect(@info));
+}
+
+sub _connect {
+  my ($self, @info) = @_;
+  return DBI->connect(@info);
+}
+
+=item commit
+
+  $class->commit;
+
+Issues a commit again the current dbh
+
+=cut
+
+sub commit { $_[0]->dbh->commit; }
+
+=item rollback
+
+  $class->rollback;
+
+Issues a rollback again the current dbh
+
+=cut
+
+sub rollback { $_[0]->dbh->rollback; }
+
+sub insert {
+  my ($self, $ident, $to_insert) = @_;
+  my $sql = $self->create_sql('insert', [ keys %{$to_insert} ], $ident, undef);
+  my $sth = $self->sth($sql);
+  $sth->execute(values %{$to_insert});
+  $self->throw( "Couldn't insert ".join(%to_insert)." into ${ident}" )
+    unless $sth->rows;
+  return $to_insert;
+}
+
+sub update {
+  my ($self, $ident, $to_update, $condition) = @_;
+  my $attrs = { };
+  my $set_sql = $self->_cond_resolve($to_update, $attrs, ',');
+  $set_sql =~ s/^\(//;
+  $set_sql =~ s/\)$//;
+  my $cond_sql = $self->_cond_resolve($condition, $attrs);
+  my $sql = $self->create_sql('update', $set_sql, $ident, $cond_sql);
+  my $sth = $self->sth($sql);
+  my $rows = $sth->execute( @{$attrs->{bind}||[]} );
+  return $rows;
+}
+
+sub delete {
+  my ($self, $ident, $condition) = @_;
+  my $attrs = { };
+  my $cond_sql = $self->_cond_resolve($condition, $attrs);
+  my $sql = $self->create_sql('delete', undef, $ident, $cond_sql);
+  #warn "$sql ".join(', ',@{$attrs->{bind}||[]});
+  my $sth = $self->sth($sql);
+  return $sth->execute( @{$attrs->{bind}||[]} );
+}
+
+sub select {
+  my ($self, $ident, $select, $condition, $attrs) = @_;
+  $attrs ||= { };
+  #my $select_sql = $self->_cond_resolve($select, $attrs, ',');
+  my $cond_sql = $self->_cond_resolve($condition, $attrs);
+  1 while $cond_sql =~ s/^\s*\(\s*(.*ORDER.*)\s*\)\s*$/$1/;
+  my $sql = $self->create_sql('select', $select, $ident, $cond_sql);
+  #warn $sql.' '.join(', ', @{$attrs->{bind}||[]});
+  my $sth = $self->sth($sql);
+  if (@{$attrs->{bind}||[]}) {
+    $sth->execute( @{$attrs->{bind}||[]} );
+  } else {
+    $sth->execute;
+  }
+  return $sth;
+}
+
+sub sth {
+  shift->dbh->prepare(@_);
+}
+
+1;
+
+=back
+
+=head1 AUTHORS
+
+Matt S. Trout <perl-stuff@trout.me.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index 71f41cb..32a83fc 100644
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -66,10 +66,12 @@ sub insert {
   my ($self) = @_;
   return $self if $self->in_database;
   #use Data::Dumper; warn Dumper($self);
-  my $sth = $self->_get_sth('insert', [ keys %{$self->{_column_data}} ],
-                              $self->_table_name, undef);
-  $sth->execute(values %{$self->{_column_data}});
-  $sth->finish;
+  my %in;
+  $in{$_} = $self->get_column($_)
+    for grep { defined $self->get_column($_) } $self->columns;
+  my %out = %{ $self->storage->insert($self->_table_name, \%in) };
+  $self->store_column($_, $out{$_})
+    for grep { $self->get_column($_) ne $out{$_} } keys %out;
   $self->in_database(1);
   $self->{_dirty_columns} = {};
   return $self;
@@ -114,24 +116,29 @@ UPDATE query to commit any changes to the object to the db if required.
 =cut
 
 sub update {
-  my ($self) = @_;
+  my ($self, $upd) = @_;
   $self->throw( "Not in database" ) unless $self->in_database;
-  my @to_update = keys %{$self->{_dirty_columns} || {}};
-  return -1 unless @to_update;
-  my $sth = $self->_get_sth('update', \@to_update,
-                              $self->_table_name, $self->_ident_cond);
-  my $rows = $sth->execute( (map { $self->{_column_data}{$_} } @to_update),
-                  $self->_ident_values );
-  $sth->finish;
+  my %to_update = %{$upd || {}};
+  $to_update{$_} = $self->get_column($_) for $self->is_changed;
+  return -1 unless keys %to_update;
+  my $rows = $self->storage->update($self->_table_name, \%to_update,
+                                      $self->ident_condition);
   if ($rows == 0) {
-    $self->throw( "Can't update $self: row not found" );
+    $self->throw( "Can't update ${self}: row not found" );
   } elsif ($rows > 1) {
-    $self->throw("Can't update $self: updated more than one row");
+    $self->throw("Can't update ${self}: updated more than one row");
   }
   $self->{_dirty_columns} = {};
   return $self;
 }
 
+sub ident_condition {
+  my ($self) = @_;
+  my %cond;
+  $cond{$_} = $self->get_column($_) for keys %{$self->_primaries};
+  return \%cond;
+}
+
 =item delete
 
   $obj->delete
@@ -147,22 +154,18 @@ sub delete {
   if (ref $self) {
     $self->throw( "Not in database" ) unless $self->in_database;
     #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
-    my $sth = $self->_get_sth('delete', undef,
-                                $self->_table_name, $self->_ident_cond);
-    $sth->execute($self->_ident_values);
-    $sth->finish;
+    $self->storage->delete($self->_table_name, $self->ident_condition);
     $self->in_database(undef);
+    #$self->store_column($_ => undef) for $self->primary_columns;
       # Should probably also arrange to trash PK if auto
+      # but if we do, post-delete cascade triggers fail :/
   } else {
     my $attrs = { };
     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
       $attrs = { %{ pop(@_) } };
     }
     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
-    my ($cond, @param) = $self->_cond_resolve($query, $attrs);
-    my $sth = $self->_get_sth('delete', undef, $self->_table_name, $cond);
-    $sth->execute(@param);
-    $sth->finish;
+    $self->storage->delete($self->_table_name, $query);
   }
   return $self;
 }
@@ -257,9 +260,8 @@ sub retrieve_from_sql {
   $cond =~ s/^\s*WHERE//i;
   my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
   my @cols = $class->_select_columns($attrs);
-  my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
-  #warn "$cond @vals";
-  return $class->sth_to_objects($sth, \@vals, \@cols, { where => $cond });
+  #warn "@cols $cond @vals";
+  return $class->sth_to_objects(undef, \@vals, \@cols, { where => \$cond });
 }
 
 =item count_from_sql
@@ -269,13 +271,13 @@ sub retrieve_from_sql {
 =cut
 
 sub count_from_sql {
-  my ($class, $cond, @vals) = @_;
+  my ($self, $cond, @vals) = @_;
   $cond =~ s/^\s*WHERE//i;
   my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
   my @cols = 'COUNT(*)';
-  my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
+  $attrs->{bind} = [ @vals ];
+  my $sth = $self->storage->select($self->_table_name,\@cols,\$cond, $attrs);
   #warn "$cond @vals";
-  $sth->execute(@vals);
   my ($count) = $sth->fetchrow_array;
   $sth->finish;
   return $count;
@@ -293,9 +295,9 @@ sub count {
   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
     $attrs = { %{ pop(@_) } };
   }
-  my $query    = ref $_[0] eq "HASH" ? shift: {@_};
-  my ($cond, @param)  = $class->_cond_resolve($query, $attrs);
-  return $class->count_from_sql($cond, @param, $attrs);
+  my $query    = ref $_[0] eq "HASH" || (@_ == 1) ? shift: {@_};
+  my ($cond)  = $class->_cond_resolve($query, $attrs);
+  return $class->count_from_sql($cond, @{$attrs->{bind}||[]}, $attrs);
 }
 
 =item sth_to_objects
@@ -332,6 +334,7 @@ sub _row_to_object { # WARNING: Destructive to @$row
 
 sub search {
   my $class = shift;
+  #warn "@_";
   my $attrs = { };
   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
     $attrs = { %{ pop(@_) } };
@@ -445,6 +448,8 @@ sub is_changed {
   return keys %{shift->{_dirty_columns} || {}};
 }
 
+sub columns { return keys %{shift->_columns}; }
+
 1;
 
 =back
diff --git a/t/cdbi-t/02-Film.t b/t/cdbi-t/02-Film.t
index f47db3b..ca0a004 100644
--- a/t/cdbi-t/02-Film.t
+++ b/t/cdbi-t/02-Film.t
@@ -159,6 +159,8 @@ eval {
 		Film->create({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
 	my $new_leaf =
 		Film->create({ Title => 'A New Leaf', Director => 'Elaine May' });
+
+#use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' ));
 	cmp_ok(Film->search(Director => 'Elaine May'), '==', 3,
 		"3 Films by Elaine May");
 	ok(Film->retrieve('Ishtar')->delete,
@@ -226,7 +228,10 @@ is($btaste->Director, $orig_director, 'discard_changes()');
 	my $btaste2 = Film->retrieve($btaste->id);
 	$btaste->NumExplodingSheep(18);
 	my @warnings;
-	local $SIG{__WARN__} = sub { push @warnings, @_; };
+	local $SIG{__WARN__} = sub {
+          unless ($_[0] =~ m/ContextualFetch/) {
+            push(@warnings, @_);
+          } };
 	{
 
 		# unhook from live object cache, so next one is not from cache