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