view release on metacpan or  search on metacpan

lib/Class/AutoDB/Serialize.pm  view on Meta::CPAN

package Class::AutoDB::Serialize;

use vars qw(@ISA @AUTO_ATTRIBUTES @OTHER_ATTRIBUTES %SYNONYMS);
use strict;
use Class::AutoClass;
use Class::AutoDB::Globals;
use Class::AutoDB::Oid;
use DBI;
use Carp;
#use Scalar::Util qw(weaken);
use Scalar::Util qw(refaddr);
use Class::AutoDB::Dumper;
@ISA = qw(Class::AutoClass); # AutoClass must be first!!
@OTHER_ATTRIBUTES=qw(oid dbh);
Class::AutoClass::declare(__PACKAGE__);

my $DUMPER=new Class::AutoDB::Dumper([undef],['thaw']) ->
  Purity(1)->Indent(1)->
  Freezer('DUMPER_freeze')->Toaster('DUMPER_thaw');

my $GLOBALS=Class::AutoDB::Globals->instance();
my $OID2OBJ=$GLOBALS->oid2obj;
my $OBJ2OID=$GLOBALS->obj2oid;
my $OID_GEN=int rand 1<<30;	# 2**30
my $REGISTRY_OID=$GLOBALS->registry_oid;

sub _init_self {
  my($self,$class,$args)=@_;
  return unless $class eq __PACKAGE__; # to prevent subclasses from re-running this
  # NG 09-12-19: removed ->oid for cleanup of user-object namespace. 
  #              only needed for registry
  # my $oid=$self->oid || $$.$OID_GEN++;
  my $oid=ref $self eq 'Class::AutoDB::Registry'? $REGISTRY_OID: $$.$OID_GEN++;
  oid2obj($oid,$self);
  obj2oid($self,$oid);
}
sub DUMPER_freeze {
  my($self)=@_;
  my $oid=$OBJ2OID->{refaddr $self};
  #print ">>> DUMPER_freeze ->$oid<- ($self)\n";

  # NG 09-12-08: code below is on the right track, but still broken
  # to revert back to old Data::Dumper, 
  #   mysql: delete * from _AutoDB;
  #   ~/local/lib/perl/x86_64-linux-thread-multi/Data: mv Dumper.pm Dumper.pm.new
#   if ($Data::Dumper::VERSION >= 2.122) { # have to modify object itself
#     %$self=(_OID=>$oid,_CLASS=>ref $self);
#     bless $self,'Class::AutoDB::Oid';
#     return $self;
#   }
  return bless {_OID=>$oid,_CLASS=>ref $self},'Class::AutoDB::Oid';
}
sub oid2obj {			# allow call as object or class method, or function
  shift if $_[0] eq __PACKAGE__ || UNIVERSAL::isa($_[0],__PACKAGE__);
  my $oid=shift;
  @_? $OID2OBJ->{$oid}=$_[0]: $OID2OBJ->{$oid};
}
sub obj2oid {			# allow call as class method or function
  shift unless ref $_[0];
  my $obj=shift;
  #print ">>>>>>>>>> obj2oid on $obj\n";
  @_? $OBJ2OID->{refaddr $obj}=$_[0]: $OBJ2OID->{refaddr $obj};
}
*oid=\&obj2oid;

sub dbh {
  my $self=shift;
  $GLOBALS->dbh(@_);
}
# NG 10-09-16: decided some time ago to remove is_extant, is_deleted to avoid polluting 
#              namespace further, but forgot to comment them out from here
# sub is_extant {	   # allow call as object or class method, or function
#   shift if $_[0] eq __PACKAGE__ || UNIVERSAL::isa($_[0],__PACKAGE__);
#   my $obj=shift;
#   my $oid=$obj->oid;
#   Class::AutoDB::Serialize::fetch($oid); # changes $self to real object or OidDeleted
#   ref $obj ne 'Class::AutoDB::OidDeleted';
# }
# sub is_deleted {!is_extant(@_)}

sub store {	   # allow call as object or class method, or function
  shift if $_[0] eq __PACKAGE__;
  my($self,$transients)=@_;
  $DUMPER->Reset;
  # Make a shallow copy, replacing independent objects with stored reps
  my $copy={_CLASS=>ref $self};
  while(my($key,$value)=each %$self) {
    # NG 09-12-05: fixed wrong regex. Scary this wasn't caught earlier!!
    # next if grep /$key/,@$transients;
    next if grep {$_ eq $key} @$transients;
    # NG 06-05-16: fixed bug. UNIVERSAL::isa reports true if arg is __name__
    #              of Serialize subclass. here, we only want true case if arg
    #              __object__ whose class is Serialize subclass
    if (UNIVERSAL::isa(ref $value,__PACKAGE__)) {
      $copy->{$key}=$value->DUMPER_freeze;
    } else {
      $copy->{$key}=$value;
    }
  }
  my $freeze=$DUMPER->Values([$copy])->Dump;
  really_store($self,$freeze);
  #  TODO: weaken($OID2OBJ->{$oid});
  $self;
}
sub fetch {			# allow call as object or class method, or function
  shift if $_[0] eq __PACKAGE__ || UNIVERSAL::isa($_[0],__PACKAGE__);
  my($oid)=@_;
  # three cases: (1) new oid, (2) Oid exists, (3) real object exists
  my $obj=$OID2OBJ->{$oid};
  if (!defined $obj) {		                                # case 1
    # NG 10-08-24: really_fetch never returns undef
    # $obj=really_fetch($oid) || return undef;
    $obj=really_fetch($oid);
    $OID2OBJ->{$oid}=$obj;
    $OBJ2OID->{refaddr $obj}=$oid;
#   weaken($OID2OBJ->{$oid});
  } elsif (UNIVERSAL::isa($obj,'Class::AutoDB::Oid')) { # case 2
    # NG 10-08-24: really_fetch never returns undef
    # $obj=really_fetch($oid,$obj) || return undef;
    $obj=really_fetch($oid,$obj);
# }		                        # case 3 -- nothing more to do
# NG 10-08-26: case now calls really_fetch to handle deleted objects. shouldn't hurt performance
#              too much, if at all, since I don't think this case arises in practice...  
  } else {
    $obj=really_fetch($oid,$obj);
  }
  $obj;
}
# used by 'get' methods in Cursor
sub thaw {			# allow call as object or class method, or function
  shift if $_[0] eq __PACKAGE__ || UNIVERSAL::isa($_[0],__PACKAGE__);
  my($oid,$freeze)=@_;
  # three cases: (1) new oid, (2) Oid exists, (3) OidDeleted exists, (4) real object exists
  my $obj=$OID2OBJ->{$oid};
  # NG 10-09-13: yet another place where testing object messes up on Oid or OidDeleted
  #              'cuz 'bool' overloaded...
  my $ref=ref $obj;
  if (!$ref) {		                                # case 1
    # NG 10-08-24: really_thaw never returns undef
    # $obj=really_thaw($oid,$obj,$freeze) || return undef;
    $obj=really_thaw($oid,$obj,$freeze);
    $OID2OBJ->{$oid}=$obj;
    $OBJ2OID->{refaddr $obj}=$oid;
#   weaken($OID2OBJ->{$oid});
  } elsif ('Class::AutoDB::Oid' eq $ref) { # case 2
    # NG 10-08-24: really_thaw never returns undef
    # $obj=really_thaw($oid,$obj,$freeze) || return undef;
    $obj=really_thaw($oid,$obj,$freeze);
  }			                   # else case 3 or 4 -- nothing more to do
  $obj;
}
# returns number of objects deleted (0 or 1)
sub del {			# allow call as object or class method, or function
  shift if $_[0] eq __PACKAGE__ || UNIVERSAL::isa($_[0],__PACKAGE__);
  my($oid)=@_;
  # two cases: 
  #   1) OidDeleted exists - already deleted, so nothing to do
  #   2) anything else. really_delete does all the work
  my $obj=$OID2OBJ->{$oid};
  UNIVERSAL::isa($obj,'Class::AutoDB::OidDeleted')? 0: really_del($oid,$obj);
}

sub really_store {
  my($self,$freeze)=@_;
  my($sth,$ret);
  my $dbh=$GLOBALS->dbh;
  # NG 09-12-19: removed ->oid for cleanup of user-object namespace. 
  #              cases other than first not needed anyway (I hope!!)
  # my $oid = obj2oid($self) || $self->oid || $OBJ2OID->{refaddr $self};
  my $oid=obj2oid($self);
  #print ">>> storing  ->$oid<-($self)", ref $self, "\n";
#  $sth=$dbh->prepare(qq(insert into _AutoDB(oid,object) values (?,?)));

  $sth=$dbh->prepare(qq(REPLACE INTO _AutoDB(oid,object) VALUES (?,?)));

  $sth->bind_param(1,$oid);
  $sth->bind_param(2,$freeze);
  $ret=$sth->execute or confess $sth->errstr;
}
sub really_fetch {
  my($oid,$obj)=@_;
  my $dbh=$GLOBALS->dbh;
  my $sth=$dbh->prepare(qq(select object from _AutoDB where oid=?));
  $sth->bind_param(1,$oid);
  my $ret=$sth->execute or confess $sth->errstr;
  my($freeze)=$sth->fetchrow_array;
  # NG 10-08-24: changed logic to handle deleted objects
  #              $freeze will be NULL for non-existent oid or deleted object
  #              $ret will be 0E0 for non-existent oid, 1 otherwise
  #                note that 0E0 is both 0 and true! (see DBI docs)
  #              moved errstr check up since always want to check for errors
  confess $sth->errstr if $sth->err;
  if ($ret==0) {		# non-existent oid
    my $class=$obj->{_CLASS};
    # NG 06-05-16: changed warn to confess. calling routine dies immediately anyway
    #              and confess output easier to catch in eval
    confess qq/Trying to deserialize an instance of class $class with oid \'$oid\'. Ensure that: 
    \t 1) The object was serialized correctly (you may have forgotten to call put() on it). 
    \t 2) You can connect to the data source in which it has been serialized.
    \t 3) The object was serialized correctly\n/;
  }
  really_thaw($oid,$obj,$freeze);
}
sub really_thaw {