From: Matt S Trout Date: Fri, 29 Jul 2005 06:15:54 +0000 (+0000) Subject: - Refactored some, moved more stuff over to using get/store column instead of direct... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c1d2357300903fa0f4ec7d85c132f04547c4ccba;p=dbsrgits%2FDBIx-Class-Historic.git - Refactored some, moved more stuff over to using get/store column instead of direct hash access - 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 --- 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 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 --- 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 --- 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 --- 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 --- 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 --- 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;