1 package DBIx::Class::CDBICompat::LiveObjectIndex;
6 use Scalar::Util qw/weaken/;
8 use base qw/Class::Data::Inheritable/;
10 __PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
11 __PACKAGE__->mk_classdata('live_object_index' => { });
12 __PACKAGE__->mk_classdata('live_object_init_count' => { });
14 # Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
15 # all blame due to me for whatever bugs I introduced porting it.
17 sub _live_object_key {
19 my $class = ref($me) || $me;
20 my @primary = keys %{$class->_primaries};
22 # no key unless all PK columns are defined
23 return "" unless @primary == grep defined $me->get_column($_), @primary;
25 # create single unique key for this object
26 return join "\030", $class, map { $_ . "\032" . $me->get_column($_) }
30 sub purge_dead_from_object_index {
31 my $live = $_[0]->live_object_index;
32 delete @$live{ grep !defined $live->{$_}, keys %$live };
35 sub remove_from_object_index {
37 my $obj_key = $self->_live_object_key;
38 delete $self->live_object_index->{$obj_key};
41 sub clear_object_index {
42 my $live = $_[0]->live_object_index;
43 delete @$live{ keys %$live };
46 # And now the fragments to tie it in to DBIx::Class::Table
49 my ($self, @rest) = @_;
50 $self->NEXT::ACTUAL::insert(@rest);
51 # Because the insert will die() if it can't insert into the db (or should)
52 # we can be sure the object *was* inserted if we got this far. In which
53 # case, given primary keys are unique and _live_object_key only returns a
54 # value if the object has all its primary keys, we can be sure there
55 # isn't a real one in the object index already because such a record
56 # cannot have existed without the insert failing.
57 if (my $key = $self->_live_object_key) {
58 my $live = $self->live_object_index;
59 weaken($live->{$key} = $self);
60 $self->purge_dead_from_object_index
61 if ++$self->live_object_init_count->{count}
62 % $self->purge_object_index_every == 0;
64 #use Data::Dumper; warn Dumper($self);
69 my ($class, @rest) = @_;
70 my $new = $class->NEXT::ACTUAL::_row_to_object(@rest);
71 if (my $key = $new->_live_object_key) {
73 my $live = $class->live_object_index;
74 return $live->{$key} if $live->{$key};
75 weaken($live->{$key} = $new);
76 $class->purge_dead_from_object_index
77 if ++$class->live_object_init_count->{count}
78 % $class->purge_object_index_every == 0;
85 if (my $key = $self->_live_object_key) {
86 $self->remove_from_object_index;
87 my $ret = $self->NEXT::ACTUAL::discard_changes;
88 $self->live_object_index->{$key} = $self if $self->in_database;
91 return $self->NEXT::ACTUAL::discard_changes;