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 _live_object_key {
  18   my ($me) = @_;
  19   my $class   = ref($me) || $me;
  20   my @primary = keys %{$class->_primaries};
  21
  22   # no key unless all PK columns are defined
  23   return "" unless @primary == grep defined $me->get_column($_), @primary;
  24
  25   # create single unique key for this object
  26   return join "\030", $class, map { $_ . "\032" . $me->get_column($_) }
  27                                 sort @primary;
  28 }
  29
  30 sub purge_dead_from_object_index {
  31   my $live = $_[0]->live_object_index;
  32   delete @$live{ grep !defined $live->{$_}, keys %$live };
  33 }
  34
  35 sub remove_from_object_index {
  36   my $self    = shift;
  37   my $obj_key = $self->_live_object_key;
  38   delete $self->live_object_index->{$obj_key};
  39 }
  40
  41 sub clear_object_index {
  42   my $live = $_[0]->live_object_index;
  43   delete @$live{ keys %$live };
  44 }
  45
  46 # And now the fragments to tie it in to DBIx::Class::Table
  47
  48 sub insert {
  49   my ($self, @rest) = @_;
  50   $self->NEXT::ACTUAL::insert(@rest);
  51     # Because the insert will die() if it can't insert into the db (or should)
  52     # we can be sure the object *was* inserted if we got this far. In which
  53     # case, given primary keys are unique and _live_object_key only returns a
  54     # value if the object has all its primary keys, we can be sure there
  55     # isn't a real one in the object index already because such a record
  56     # cannot have existed without the insert failing.
  57   if (my $key = $self->_live_object_key) {
  58     my $live = $self->live_object_index;
  59     weaken($live->{$key} = $self);
  60     $self->purge_dead_from_object_index
  61       if ++$self->live_object_init_count->{count}
  62               % $self->purge_object_index_every == 0;
  63   }
  64   #use Data::Dumper; warn Dumper($self);
  65   return $self;
  66 }
  67
  68 sub _row_to_object {
  69   my ($class, @rest) = @_;
  70   my $new = $class->NEXT::ACTUAL::_row_to_object(@rest);
  71   if (my $key = $new->_live_object_key) {
  72     #warn "Key $key";
  73     my $live = $class->live_object_index;
  74     return $live->{$key} if $live->{$key};
  75     weaken($live->{$key} = $new);
  76     $class->purge_dead_from_object_index
  77       if ++$class->live_object_init_count->{count}
  78               % $class->purge_object_index_every == 0;
  79   }
  80   return $new;
  81 }
  82
  83 sub discard_changes {
  84   my ($self) = @_;
  85   if (my $key = $self->_live_object_key) {
  86     $self->remove_from_object_index;
  87     my $ret = $self->NEXT::ACTUAL::discard_changes;
  88     $self->live_object_index->{$key} = $self if $self->in_database;
  89     return $ret;
  90   } else {
  91     return $self->NEXT::ACTUAL::discard_changes;
  92   }
  93 }
  94
  95 1;