lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm

   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
  17 sub purge_dead_from_object_index {
  18   my $live = shift->live_object_index;
  19   delete @$live{ grep !defined $live->{$_}, keys %$live };
  20 }
  21
  22 sub remove_from_object_index {
  23   my $self = shift;
  24   delete $self->live_object_index->{$self->ID};
  25 }
  26
  27 sub clear_object_index {
  28   my $live = shift->live_object_index;
  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) = @_;
  36   $self->NEXT::ACTUAL::insert(@rest);
  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
  39     # case, given primary keys are unique and ID only returns a
  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.
  43   if (my $key = $self->ID) {
  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
  54 sub _row_to_object {
  55   my ($class, @rest) = @_;
  56   my $new = $class->NEXT::ACTUAL::_row_to_object(@rest);
  57   if (my $key = $new->ID) {
  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) = @_;
  71   if (my $key = $self->ID) {
  72     $self->remove_from_object_index;
  73     my $ret = $self->NEXT::ACTUAL::discard_changes;
  74     $self->live_object_index->{$key} = $self if $self->in_storage;
  75     return $ret;
  76   } else {
  77     return $self->NEXT::ACTUAL::discard_changes;
  78   }
  79 }
  80
  81 1;