- Refactored some, moved more stuff over to using get/store column instead of direct...

- Added live object index support (ported from Class::DBI)

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index 4f77c5a..066f0c8 100644 (file)
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -6,6 +6,7 @@ use warnings;
 use base qw/DBIx::Class::CDBICompat::Convenience
             DBIx::Class::CDBICompat::Triggers
             DBIx::Class::CDBICompat::GetSet
+            DBIx::Class::CDBICompat::LiveObjectIndex
             DBIx::Class::CDBICompat::AttributeAPI
             DBIx::Class::CDBICompat::Stringify
             DBIx::Class::CDBICompat::ObjIndexStubs

diff --git a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
new file mode 100644 (file)
index 0000000..29a995e
--- /dev/null
+++ b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
@@ -0,0 +1,95 @@
+package DBIx::Class::CDBICompat::LiveObjectIndex;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw/weaken/;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
+__PACKAGE__->mk_classdata('live_object_index' => { });
+__PACKAGE__->mk_classdata('live_object_init_count' => { });
+
+# Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
+# all blame due to me for whatever bugs I introduced porting it.
+
+sub _live_object_key {
+  my ($me) = @_;
+  my $class   = ref($me) || $me;
+  my @primary = keys %{$class->_primaries};
+
+  # no key unless all PK columns are defined
+  return "" unless @primary == grep defined $me->get_column($_), @primary;
+
+  # create single unique key for this object
+  return join "\030", $class, map { $_ . "\032" . $me->get_column($_) }
+                                sort @primary;
+}
+
+sub purge_dead_from_object_index {
+  my $live = $_[0]->live_object_index;
+  delete @$live{ grep !defined $live->{$_}, keys %$live };
+}
+
+sub remove_from_object_index {
+  my $self    = shift;
+  my $obj_key = $self->_live_object_key;
+  delete $self->live_object_index->{$obj_key};
+}
+
+sub clear_object_index {
+  my $live = $_[0]->live_object_index;
+  delete @$live{ keys %$live };
+}
+
+# And now the fragments to tie it in to DBIx::Class::Table
+
+sub insert {
+  my ($self, @rest) = @_;
+  $self->NEXT::ACTUAL::insert(@rest);
+    # Because the insert will die() if it can't insert into the db (or should)
+    # we can be sure the object *was* inserted if we got this far. In which
+    # case, given primary keys are unique and _live_object_key only returns a
+    # value if the object has all its primary keys, we can be sure there
+    # isn't a real one in the object index already because such a record
+    # cannot have existed without the insert failing.
+  if (my $key = $self->_live_object_key) {
+    my $live = $self->live_object_index;
+    weaken($live->{$key} = $self);
+    $self->purge_dead_from_object_index
+      if ++$self->live_object_init_count->{count}
+              % $self->purge_object_index_every == 0;
+  }
+  #use Data::Dumper; warn Dumper($self);
+  return $self;
+}
+
+sub _row_to_object {
+  my ($class, @rest) = @_;
+  my $new = $class->NEXT::ACTUAL::_row_to_object(@rest);
+  if (my $key = $new->_live_object_key) {
+    #warn "Key $key";
+    my $live = $class->live_object_index;
+    return $live->{$key} if $live->{$key};
+    weaken($live->{$key} = $new);
+    $class->purge_dead_from_object_index
+      if ++$class->live_object_init_count->{count}
+              % $class->purge_object_index_every == 0;
+  }
+  return $new;
+}
+
+sub discard_changes {
+  my ($self) = @_;
+  if (my $key = $self->_live_object_key) {
+    $self->remove_from_object_index;
+    my $ret = $self->NEXT::ACTUAL::discard_changes;
+    $self->live_object_index->{$key} = $self if $self->in_database;
+    return $ret;
+  } else {
+    return $self->NEXT::ACTUAL::discard_changes;
+  }
+}
+
+1;

diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm
index ad70690..fc03c57 100644 (file)
--- a/lib/DBIx/Class/PK.pm
+++ b/lib/DBIx/Class/PK.pm
@@ -50,7 +50,15 @@ sub retrieve {
 sub discard_changes {
   my ($self) = @_;
   delete $self->{_dirty_columns};
-  $_[0] = $self->retrieve($self->id);
+  return unless $self->in_database; # Don't reload if we aren't real!
+  my ($reload) = $self->retrieve($self->id);
+  unless ($reload) { # If we got deleted in the mean-time
+    $self->in_database(0);
+    return $self;
+  }
+  $self->store_column($_ => $reload->get_column($_))
+    foreach keys %{$self->_columns};
+  return $self;
 }
 
 sub id {

diff --git a/lib/DBIx/Class/PK/Auto.pm b/lib/DBIx/Class/PK/Auto.pm
index b9507a8..98e3b89 100644 (file)
--- a/lib/DBIx/Class/PK/Auto.pm
+++ b/lib/DBIx/Class/PK/Auto.pm
@@ -12,7 +12,7 @@ sub insert {
     || (keys %{ $self->_primaries });
   die "More than one possible key found for auto-inc on ".ref $self
     if $too_many;
-  unless (exists $self->{_column_data}{$pri}) {
+  unless (defined $self->get_column($pri)) {
     die "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method"
       unless $self->can('_last_insert_id');
     my $id = $self->_last_insert_id;

diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm
index 1ccf7e9..29cc816 100644 (file)
--- a/lib/DBIx/Class/Table.pm
+++ b/lib/DBIx/Class/Table.pm
@@ -9,7 +9,7 @@ __PACKAGE__->mk_classdata('_columns' => {});
 
 __PACKAGE__->mk_classdata('_table_name');
 
-__PACKAGE__->mk_classdata('table_alias'); # FIXME XXX
+__PACKAGE__->mk_classdata('table_alias'); # Doesn't actually do anything yet!
 
 sub new {
   my ($class, $attrs) = @_;
@@ -27,6 +27,7 @@ sub new {
 sub insert {
   my ($self) = @_;
   return 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}});
@@ -95,7 +96,9 @@ sub get_column {
   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} if $self->_columns->{$column};
+  return $self->{_column_data}{$column}
+    if exists $self->{_column_data}{$column};
+  return undef;
 }
 
 sub set_column {
@@ -147,15 +150,20 @@ sub sth_to_objects {
   $sth->execute(@$args);
   my @found;
   while (my @row = $sth->fetchrow_array) {
-    my $new = $class->new;
-    $new->store_column($_, shift @row) for @cols;
-    $new->in_database(1);
-    push(@found, $new);
+    push(@found, $class->_row_to_object(\@cols, \@row));
   }
   $sth->finish;
   return @found;
 }
 
+sub _row_to_object { # WARNING: Destructive to @$row
+  my ($class, $cols, $row) = @_;
+  my $new = $class->new;
+  $new->store_column($_, shift @$row) for @$cols;
+  $new->in_database(1);
+  return $new;
+}
+
 sub search {
   my $class = shift;
   my $attrs = { };

diff --git a/lib/DBIx/Class/Test/SQLite.pm b/lib/DBIx/Class/Test/SQLite.pm
index e20bdb8..1ddacf8 100644 (file)
--- a/lib/DBIx/Class/Test/SQLite.pm
+++ b/lib/DBIx/Class/Test/SQLite.pm
@@ -32,7 +32,7 @@ tie it to the class.
 
 use strict;
 
-use base qw/DBIx::Class::PK::Auto::SQLite DBIx::Class::PK::Auto DBIx::Class/;
+use base qw/DBIx::Class::CDBICompat DBIx::Class::PK::Auto::SQLite DBIx::Class::PK::Auto DBIx::Class::Core/;
 use File::Temp qw/tempfile/;
 my (undef, $DB) = tempfile();
 END { unlink $DB if -e $DB }

diff --git a/t/cdbi-t/02-Film.t b/t/cdbi-t/02-Film.t
index 3a27e78..1a0c7b3 100644 (file)
--- a/t/cdbi-t/02-Film.t
+++ b/t/cdbi-t/02-Film.t
@@ -349,7 +349,7 @@ if (0) {
 }
 
 SKIP: {
-        skip "DBIx::Class doesn't yet have a live objects index", 3;
+        #skip "DBIx::Class doesn't yet have a live objects index", 3;
        #skip "Scalar::Util::weaken not available", 3
                #if !$Class::DBI::Weaken_Is_Available;