update my own contrib entry
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / CDBICompat / LiveObjectIndex.pm
CommitLineData
75d07914 1package # hide from PAUSE
c0e7b4e5 2 DBIx::Class::CDBICompat::LiveObjectIndex;
c1d23573 3
4use strict;
5use warnings;
6
7use Scalar::Util qw/weaken/;
8
9use base qw/Class::Data::Inheritable/;
10
11__PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
12__PACKAGE__->mk_classdata('live_object_index' => { });
13__PACKAGE__->mk_classdata('live_object_init_count' => { });
14
15# Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
16# all blame due to me for whatever bugs I introduced porting it.
17
c1d23573 18sub purge_dead_from_object_index {
1f6715ab 19 my $live = shift->live_object_index;
c1d23573 20 delete @$live{ grep !defined $live->{$_}, keys %$live };
21}
22
23sub remove_from_object_index {
1f6715ab 24 my $self = shift;
25 delete $self->live_object_index->{$self->ID};
c1d23573 26}
27
28sub clear_object_index {
1f6715ab 29 my $live = shift->live_object_index;
c1d23573 30 delete @$live{ keys %$live };
31}
32
33# And now the fragments to tie it in to DBIx::Class::Table
34
35sub insert {
36 my ($self, @rest) = @_;
147dd158 37 $self->next::method(@rest);
c1d23573 38 # Because the insert will die() if it can't insert into the db (or should)
39 # we can be sure the object *was* inserted if we got this far. In which
1f6715ab 40 # case, given primary keys are unique and ID only returns a
c1d23573 41 # value if the object has all its primary keys, we can be sure there
42 # isn't a real one in the object index already because such a record
43 # cannot have existed without the insert failing.
1f6715ab 44 if (my $key = $self->ID) {
c1d23573 45 my $live = $self->live_object_index;
46 weaken($live->{$key} = $self);
47 $self->purge_dead_from_object_index
48 if ++$self->live_object_init_count->{count}
49 % $self->purge_object_index_every == 0;
50 }
51 #use Data::Dumper; warn Dumper($self);
52 return $self;
53}
54
b52e9bf8 55sub inflate_result {
c1d23573 56 my ($class, @rest) = @_;
147dd158 57 my $new = $class->next::method(@rest);
1f6715ab 58 if (my $key = $new->ID) {
c1d23573 59 #warn "Key $key";
60 my $live = $class->live_object_index;
61 return $live->{$key} if $live->{$key};
62 weaken($live->{$key} = $new);
63 $class->purge_dead_from_object_index
64 if ++$class->live_object_init_count->{count}
65 % $class->purge_object_index_every == 0;
66 }
67 return $new;
68}
69
70sub discard_changes {
71 my ($self) = @_;
1f6715ab 72 if (my $key = $self->ID) {
c1d23573 73 $self->remove_from_object_index;
147dd158 74 my $ret = $self->next::method;
8d5134b0 75 $self->live_object_index->{$key} = $self if $self->in_storage;
c1d23573 76 return $ret;
77 } else {
147dd158 78 return $self->next::method;
c1d23573 79 }
80}
81
821;