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 1;