-package DBIx::Class::CDBICompat::LiveObjectIndex;
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::LiveObjectIndex;
use strict;
use warnings;
__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.
+# Caching is on by default, but a classic CDBI hack to turn it off is to
+# set this variable false.
+$Class::DBI::Weaken_Is_Available = 1
+ unless defined $Class::DBI::Weaken_Is_Available;
+__PACKAGE__->mk_classdata('__nocache' => 0);
-sub _live_object_key {
- my ($me) = @_;
- my $class = ref($me) || $me;
- my @primary = keys %{$class->_primaries};
+sub nocache {
+ my $class = shift;
- # no key unless all PK columns are defined
- return "" unless @primary == grep defined $me->get_column($_), @primary;
+ return $class->__nocache(@_) if @_;
- # create single unique key for this object
- return join "\030", $class, map { $_ . "\032" . $me->get_column($_) }
- sort @primary;
+ return 1 if $Class::DBI::Weaken_Is_Available == 0;
+ return $class->__nocache;
}
+# 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 purge_dead_from_object_index {
- my $live = $_[0]->live_object_index;
+ my $live = shift->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};
+ my $self = shift;
+ delete $self->live_object_index->{$self->ID};
}
sub clear_object_index {
- my $live = $_[0]->live_object_index;
+ my $live = shift->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) {
+ $self->next::method(@rest);
+
+ return $self if $self->nocache;
+
+ # 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 ID 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->ID) {
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 {
+sub inflate_result {
my ($class, @rest) = @_;
- my $new = $class->NEXT::ACTUAL::_row_to_object(@rest);
- if (my $key = $new->_live_object_key) {
+ my $new = $class->next::method(@rest);
+
+ return $new if $new->nocache;
+
+ if (my $key = $new->ID) {
#warn "Key $key";
my $live = $class->live_object_index;
return $live->{$key} if $live->{$key};
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_storage;
- return $ret;
- } else {
- return $self->NEXT::ACTUAL::discard_changes;
- }
-}
-
1;