discard_changes is also "refresh from storage"
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / CDBICompat / LiveObjectIndex.pm
1 package # hide from PAUSE
2     DBIx::Class::CDBICompat::LiveObjectIndex;
3
4 use strict;
5 use warnings;
6
7 use Scalar::Util qw/weaken/;
8
9 use 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
18 sub purge_dead_from_object_index {
19   my $live = shift->live_object_index;
20   delete @$live{ grep !defined $live->{$_}, keys %$live };
21 }
22
23 sub remove_from_object_index {
24   my $self = shift;
25   delete $self->live_object_index->{$self->ID};
26 }
27
28 sub clear_object_index {
29   my $live = shift->live_object_index;
30   delete @$live{ keys %$live };
31 }
32
33 # And now the fragments to tie it in to DBIx::Class::Table
34
35 sub insert {
36   my ($self, @rest) = @_;
37   $self->next::method(@rest);
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
40     # case, given primary keys are unique and ID only returns a
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.
44   if (my $key = $self->ID) {
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
55 sub inflate_result {
56   my ($class, @rest) = @_;
57   my $new = $class->next::method(@rest);
58   if (my $key = $new->ID) {
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
70 sub discard_changes {
71   my ($self) = @_;
72   if (my $key = $self->ID) {
73     $self->remove_from_object_index;
74     my $ret = $self->next::method;
75     $self->live_object_index->{$key} = $self if $self->in_storage;
76     return $ret;
77   } else {
78     return $self->next::method;
79   }
80 }
81
82 1;