From: Matt S Trout <mst@shadowcat.co.uk>
Date: Tue, 19 Jul 2005 13:11:28 +0000 (+0000)
Subject: Most of the first third of 02-Film now works :)
X-Git-Tag: v0.03001~143
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8fe001e1f588a2a35923a74d262cd011466d31aa;hp=ea2e61bf5bb7187dc5e56513cd66c272d71d5074;p=dbsrgits%2FDBIx-Class.git

Most of the first third of 02-Film now works :)
---

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index 22fd5e7..cba2996 100644
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -3,8 +3,10 @@ package DBIx::Class::CDBICompat;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::CDBICompat::AccessorMapping
+use base qw/DBIx::Class::CDBICompat::Convenience
+            DBIx::Class::CDBICompat::AccessorMapping
             DBIx::Class::CDBICompat::ColumnCase
-            DBIx::Class::CDBICompat::ColumnGroups/;
+            DBIx::Class::CDBICompat::ColumnGroups
+            DBIx::Class::CDBICompat::ImaDBI/;
 
 1;
diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
index 3bea78d..1c32842 100644
--- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
+++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
@@ -25,16 +25,15 @@ sub columns {
 sub _set_column_group {
   my ($class, $group, @cols) = @_;
   $class->_register_column_group($group => @cols);
-  $class->_register_columns(@cols);
-  $class->_mk_column_accessors(@cols);
+  #$class->_register_columns(@cols);
+  #$class->_mk_column_accessors(@cols);
+  $class->set_columns(@cols);
 }
 
 sub _register_column_group {
   my ($class, $group, @cols) = @_;
   if ($group eq 'Primary') {
-    my %pri;
-    $pri{$_} = {} for @cols;
-    $class->_primaries(\%pri);
+    $class->set_primary(@cols);
   }
 
   my $groups = { %{$class->_column_groups} };
diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm
index c90d7bc..8855123 100644
--- a/lib/DBIx/Class/Core.pm
+++ b/lib/DBIx/Class/Core.pm
@@ -3,6 +3,9 @@ package DBIx::Class::Core;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::Table DBIx::Class::SQL DBIx::Class::DB/;
+use base qw/DBIx::Class::PK
+            DBIx::Class::Table
+            DBIx::Class::SQL
+            DBIx::Class::DB/;
 
 1;
diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm
index 3fc3013..0ef24b4 100644
--- a/lib/DBIx/Class/DB.pm
+++ b/lib/DBIx/Class/DB.pm
@@ -8,7 +8,8 @@ __PACKAGE__->mk_classdata('_dbh');
 
 sub _get_dbh {
   my ($class) = @_;
-  unless ((my $dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
+  my $dbh;
+  unless (($dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
     $class->_populate_dbh;
   }
   return $class->_dbh;
@@ -23,7 +24,13 @@ sub _populate_dbh {
 
 sub _dbi_connect {
   my ($class, @info) = @_;
-  return DBI->connect_cached(@info);
+  return DBI->connect(@info);
+}
+
+sub connection {
+  my ($class, @info) = @_;
+  $class->_dbi_connect_package($class);
+  $class->_dbi_connect_info(\@info);
 }
 
 1;
diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm
index 2f6326e..a06062e 100644
--- a/lib/DBIx/Class/SQL.pm
+++ b/lib/DBIx/Class/SQL.pm
@@ -12,20 +12,22 @@ use constant COND => 2;
 __PACKAGE__->mk_classdata('_sql_statements',
   {
     'select' =>
-      sub { "SELECT ".join(', ', @$_[COLS])." FROM $_[FROM] WHERE $_[COND]"; },
+      sub { "SELECT ".join(', ', @{$_[COLS]})." FROM $_[FROM] WHERE $_[COND]"; },
     'update' =>
-      sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @$_[COLS]).
+      sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @{$_[COLS]}).
               " WHERE $_[COND]"; },
     'insert' =>
-      sub { "INSERT INTO $_[FROM] (".join(', ', @$_[COLS]).") VALUES (".
-              join(', ', map { '?' } @$_[COLS]).")"; },
+      sub { "INSERT INTO $_[FROM] (".join(', ', @{$_[COLS]}).") VALUES (".
+              join(', ', map { '?' } @{$_[COLS]}).")"; },
     'delete' =>
       sub { "DELETE FROM $_[FROM] WHERE $_[COND]"; },
   } );
 
 sub _get_sql {
   my ($class, $name, $cols, $from, $cond) = @_;
-  return $class->_sql_statements->{$name}->($cols, $from, $cond);
+  my $sql = $class->_sql_statements->{$name}->($cols, $from, $cond);
+  #warn $sql;
+  return $sql;
 }
 
 sub _sql_to_sth {
diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index 9556eb9..8e5fc33 100644
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -7,8 +7,6 @@ use base qw/Class::Data::Inheritable Class::Accessor DBIx::Class::SQL/;
 
 __PACKAGE__->mk_classdata('_columns' => {});
 
-__PACKAGE__->mk_classdata('_primaries' => {});
-
 __PACKAGE__->mk_classdata('_table_name');
 
 sub new {
@@ -16,11 +14,12 @@ sub new {
   $class = ref $class if ref $class;
   my $new = bless({ _column_data => { } }, $class);
   if ($attrs) {
-    die "Attrs must be a hashref" unless ref($attrs) eq 'HASH';
+    die "attrs must be a hashref" unless ref($attrs) eq 'HASH';
     while (my ($k, $v) = each %{$attrs}) {
-      $new->set_column($k => $v);
+      $new->set($k => $v);
     }
   }
+  return $new;
 }
 
 sub insert {
@@ -30,11 +29,13 @@ sub insert {
                               $self->_table_name, undef);
   $sth->execute(values %{$self->{_column_data}});
   $self->{_in_database} = 1;
+  $self->{_dirty_columns} = {};
   return $self;
 }
 
 sub create {
   my ($class, $attrs) = @_;
+  die "create needs a hashref" unless ref $attrs eq 'HASH';
   return $class->new($attrs)->insert;
 }
 
@@ -61,6 +62,7 @@ sub delete {
 
 sub get {
   my ($self, $column) = @_;
+  die "Can't fetch data as class method" unless ref $self;
   die "No such column '${column}'" unless $self->_columns->{$column};
   return $self->{_column_data}{$column};
 }
@@ -73,16 +75,6 @@ sub set {
   return $self->{_column_data}{$column} = $value;
 }
 
-sub _ident_cond {
-  my ($class) = @_;
-  return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
-}
-
-sub _ident_values {
-  my ($self) = @_;
-  return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
-}
-
 sub _register_columns {
   my ($class, @cols) = @_;
   my $names = { %{$class->_columns} };
@@ -95,4 +87,44 @@ sub _mk_column_accessors {
   $class->mk_accessors(@cols);
 }
 
+sub set_columns {
+  my ($class, @cols) = @_;
+  $class->_register_columns(@cols);
+  $class->_mk_column_accessors(@cols);
+}
+
+sub retrieve_from_sql {
+  my ($class, $cond, @vals) = @_;
+  $cond =~ s/^\s*WHERE//;
+  my @cols = $class->_select_columns;
+  my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
+  $sth->execute(@vals);
+  my @found;
+  while (my @row = $sth->fetchrow_array) {
+    my $new = $class->new;
+    $new->set($_, shift @row) for @cols;
+    $new->{_in_database} = 1;
+    push(@found, $new);
+  }
+  return @found;
+}
+
+sub search {
+  my $class    = shift;
+  my $where    = ref $_[0] eq "HASH" ? shift: {@_};
+  my $cond     = join(' AND ', map { "$_ = ?" } keys %$where);
+  return $class->retrieve_from_sql($cond, values %$where);
+}
+
+sub _select_columns {
+  return keys %{$_[0]->_columns};
+}
+
+sub copy {
+  my ($self, $changes) = @_;
+  my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
+  $new->set($_ => $changes->{$_}) for keys %$changes;
+  return $new;
+}
+
 1;
diff --git a/lib/DBIx/Class/Test/SQLite.pm b/lib/DBIx/Class/Test/SQLite.pm
index 02d300d..28647a3 100644
--- a/lib/DBIx/Class/Test/SQLite.pm
+++ b/lib/DBIx/Class/Test/SQLite.pm
@@ -40,8 +40,8 @@ END { unlink $DB if -e $DB }
 my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1 });
 
 __PACKAGE__->connection(@DSN);
-__PACKAGE__->set_sql(_table_pragma => 'PRAGMA table_info(__TABLE__)');
-__PACKAGE__->set_sql(_create_me    => 'CREATE TABLE __TABLE__ (%s)');
+#__PACKAGE__->set_sql(_table_pragma => 'PRAGMA table_info(__TABLE__)');
+#__PACKAGE__->set_sql(_create_me    => 'CREATE TABLE __TABLE__ (%s)');
 
 =head1 METHODS
 
@@ -62,8 +62,11 @@ sub set_table {
 
 sub _create_test_table {
 	my $class = shift;
-	my @vals  = $class->sql__table_pragma->select_row;
-	$class->sql__create_me($class->create_sql)->execute unless @vals;
+	my @vals  = $class->_sql_to_sth(
+                      'PRAGMA table_info(__TABLE__)')->select_row;
+	$class->_sql_to_sth(
+          'CREATE TABLE '.$class->table.' ('.$class->create_sql.')'
+            )->execute unless @vals;
 }
 
 =head2 create_sql (abstract)
diff --git a/t/01-columns.t b/t/01-columns.t
index 50d5831..ca1040e 100644
--- a/t/01-columns.t
+++ b/t/01-columns.t
@@ -87,7 +87,7 @@ ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG');
 
 {
         SKIP: {
-          skip "Different error message", 1;
+          skip "No column objects", 1;
 
   	  eval { my @grps = State->__grouper->groups_for("Huh"); };
 	  ok $@, "Huh not in groups";
@@ -101,7 +101,6 @@ ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG');
 }
 
 SKIP: {
-        skip "->retrieve not yet supported by CDBI compat", 1;
 	local $SIG{__WARN__} = sub { };
 	eval { DBIx::Class->retrieve(1) };
 	like $@, qr/Can't retrieve unless primary columns are defined/, "Need primary key for retrieve";
diff --git a/t/02-Film.t b/t/02-Film.t
index ea2b2d7..5a8df07 100644
--- a/t/02-Film.t
+++ b/t/02-Film.t
@@ -15,9 +15,6 @@ INIT {
 ok(Film->can('db_Main'), 'set_db()');
 is(Film->__driver, "SQLite", "Driver set correctly");
 
-SKIP: {
-  skip "Bunch of slightly different error messages", 5;
-
 {
 	my $nul = eval { Film->retrieve() };
 	is $nul, undef, "Can't retrieve nothing";
@@ -35,9 +32,7 @@ SKIP: {
 } 
 
 eval { my $duh = Film->create; };
-like $@, qr/create needs a hashref/, "create needs a hashref";
-
-} # End skip block
+like $@, qr/create needs a hashref/, "needs a hashref";
 
 ok +Film->create_test_film;
 
@@ -349,7 +344,7 @@ if (0) {
 }
 
 SKIP: {
-	skip "Scalar::Util::weaken not available", 3
+	skip "Scalar::Util::weaken not available", 3;
 		#if !$Class::DBI::Weaken_Is_Available;
 
 	# my bad taste is your bad taste