Reorder the accessor_name_for() check to get the more likely one first to
[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
592cd0b1 15# Caching is on by default, but a classic CDBI hack to turn it off is to
16# set this variable false.
17$Class::DBI::Weaken_Is_Available = 1
18 unless defined $Class::DBI::Weaken_Is_Available;
19__PACKAGE__->mk_classdata('__nocache' => 0);
20
21sub nocache {
22 my $class = shift;
23
24 return $class->__nocache(@_) if @_;
25
26 return 1 if $Class::DBI::Weaken_Is_Available == 0;
27 return $class->__nocache;
28}
29
c1d23573 30# Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
31# all blame due to me for whatever bugs I introduced porting it.
32
c1d23573 33sub purge_dead_from_object_index {
1f6715ab 34 my $live = shift->live_object_index;
c1d23573 35 delete @$live{ grep !defined $live->{$_}, keys %$live };
36}
37
38sub remove_from_object_index {
1f6715ab 39 my $self = shift;
40 delete $self->live_object_index->{$self->ID};
c1d23573 41}
42
43sub clear_object_index {
1f6715ab 44 my $live = shift->live_object_index;
c1d23573 45 delete @$live{ keys %$live };
46}
47
592cd0b1 48
c1d23573 49# And now the fragments to tie it in to DBIx::Class::Table
50
51sub insert {
52 my ($self, @rest) = @_;
147dd158 53 $self->next::method(@rest);
592cd0b1 54
55 return $self if $self->nocache;
56
c1d23573 57 # Because the insert will die() if it can't insert into the db (or should)
58 # we can be sure the object *was* inserted if we got this far. In which
1f6715ab 59 # case, given primary keys are unique and ID only returns a
c1d23573 60 # value if the object has all its primary keys, we can be sure there
61 # isn't a real one in the object index already because such a record
62 # cannot have existed without the insert failing.
1f6715ab 63 if (my $key = $self->ID) {
c1d23573 64 my $live = $self->live_object_index;
65 weaken($live->{$key} = $self);
66 $self->purge_dead_from_object_index
67 if ++$self->live_object_init_count->{count}
68 % $self->purge_object_index_every == 0;
69 }
70 #use Data::Dumper; warn Dumper($self);
71 return $self;
72}
73
b52e9bf8 74sub inflate_result {
c1d23573 75 my ($class, @rest) = @_;
147dd158 76 my $new = $class->next::method(@rest);
592cd0b1 77
78 return $new if $new->nocache;
79
1f6715ab 80 if (my $key = $new->ID) {
c1d23573 81 #warn "Key $key";
82 my $live = $class->live_object_index;
83 return $live->{$key} if $live->{$key};
84 weaken($live->{$key} = $new);
85 $class->purge_dead_from_object_index
86 if ++$class->live_object_init_count->{count}
87 % $class->purge_object_index_every == 0;
88 }
89 return $new;
90}
91
c1d23573 921;