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