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 # 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
  21 sub 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
  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
  33 sub purge_dead_from_object_index {
  34   my $live = shift->live_object_index;
  35   delete @$live{ grep !defined $live->{$_}, keys %$live };
  36 }
  37
  38 sub remove_from_object_index {
  39   my $self = shift;
  40   delete $self->live_object_index->{$self->ID};
  41 }
  42
  43 sub clear_object_index {
  44   my $live = shift->live_object_index;
  45   delete @$live{ keys %$live };
  46 }
  47
  48
  49 # And now the fragments to tie it in to DBIx::Class::Table
  50
  51 sub insert {
  52   my ($self, @rest) = @_;
  53   $self->next::method(@rest);
  54
  55   return $self if $self->nocache;
  56
  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
  59   # case, given primary keys are unique and ID only returns a
  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.
  63   if (my $key = $self->ID) {
  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
  71   return $self;
  72 }
  73
  74 sub inflate_result {
  75   my ($class, @rest) = @_;
  76
  77   # we don't want to inflate_result on new_result
  78   return $rest[3] if(defined $rest[3] && Scalar::Util::blessed $rest[3]);
  79
  80   my $new = $class->next::method(@rest);
  81   return $new if $new->nocache;
  82
  83   if (my $key = $new->ID) {
  84     #warn "Key $key";
  85     my $live = $class->live_object_index;
  86     return $live->{$key} if $live->{$key};
  87     weaken($live->{$key} = $new);
  88     $class->purge_dead_from_object_index
  89       if ++$class->live_object_init_count->{count}
  90               % $class->purge_object_index_every == 0;
  91   }
  92   return $new;
  93 }
  94
  95 1;