# Updated version of Chris's dd_freeze_thaw.t
# tests freeze/thaw behavior of our modified Dumper
use t::lib;
use strict;
use Class::AutoDB::Dumper;
use Test::More;
use Test::Deep;
use FreezeThaw; # defines all test classes
my $dumper_class='Class::AutoDB::Dumper';
# my $dumper_class='Data::Dumper';
# test that classes defined as we expect
my @classes=qw(freeze_thaw freeze freeze2thaw thaw nada);
my %correct_canfreeze=(freeze_thaw=>1,freeze=>1,freeze2thaw=>1);
my %correct_canthaw=(freeze_thaw=>1,thaw=>1);
for my $class (@classes) {
ok(UNIVERSAL::can($class,'DUMPER_freeze'),"$class can freeze") if $correct_canfreeze{$class};
ok(!UNIVERSAL::can($class,'DUMPER_freeze'),"$class can't freeze") if !$correct_canfreeze{$class};
ok(UNIVERSAL::can($class,'DUMPER_thaw'),"$class can thaw") if $correct_canthaw{$class};
ok(!UNIVERSAL::can($class,'DUMPER_thaw'),"$class can't thaw") if !$correct_canthaw{$class};
}
my $DUMPER=$dumper_class->new([undef],['thaw']) ->
Purity(1)->Indent(1)->Freezer('DUMPER_freeze')->Toaster('DUMPER_thaw');
for my $useperl (0..1) {
$DUMPER->Reset->Useperl($useperl);
my $label=$useperl? 'perl:': 'xs:';
# note(("-" x 40)."\n"."$label tests\n".("-" x 40));
for my $class (@classes) {
do_test0($class,$label);
}
for my $class (@classes) {
do_test1($class,$label);
}
}
done_testing();
sub do_test0 {
my($class,$label)=@_;
$label.=" class=$class fill=0";
my $thaw;
my $obj=new $class(name=>$class,fill=>0);
my $freeze = $DUMPER->Values([$obj])->Dump;
eval $freeze; #sets $thaw
if ($@) {
fail("$label: eval. error is ".substr($@,0,20).' ...');
diag("$label: skipping rest of tests");
return;
}
my $thaw_class=$class eq 'freeze2thaw'? 'thaw': $class;
isa_ok($thaw,$thaw_class,"$label: thawed object");
is($obj->fresh,'fresh',"$label: original object unchanged by freeze/thaw");
my($ok,$correct)=chk_fresh($obj,$thaw);
ok($ok,($correct?
"$label: thawed object reflects DUMPER_freeze effects":
"$label: thawed object unchanged by DUMPER_freeze"));
}
sub do_test1 {
my($class,$label)=@_;
$label.=" class=$class fill=1";
my $thaw;
my $obj=new $class(name=>$class,fill=>1);
my $freeze = $DUMPER->Values([$obj])->Dump;
eval $freeze; #sets $thaw
if ($@) {
fail("$label: eval. error is ".substr($@,0,20).' ...');
diag("$label: skipping rest of tests");
return;
}
my $thaw_class=$class eq 'freeze2thaw'? 'thaw': $class;
isa_ok($thaw,$thaw_class,"$label: thawed object");
is($obj->fresh,'fresh',"$label: original object unchanged by freeze/thaw");
for my $attr (@classes) {
unless (ref $thaw->$attr) {
fail("$label: bad news. thaw has no $attr attribute");
diag("$label: skipping rest of $attr tests");
next;
}
my $other=$thaw->$attr;
my $other_class=$attr eq 'freeze2thaw'? 'thaw': $attr;
isa_ok($other,$other_class,"$label: thawed -> $attr");
is($obj->$attr->fresh,'fresh',
"$label: original -> $attr unchanged by freeze/thaw");
my($ok,$correct)=chk_fresh($obj->$attr,$other);
ok($ok,($correct?
"$label: thawed -> $attr reflects DUMPER_freeze effects":
"$label: thawed -> $attr unchanged by DUMPER_freeze"));
}
}
# return ($ok,$correct). $correct indicates whether object should be changed
sub chk_fresh {
my($obj,$thaw)=@_;
my $class=ref $obj;
$correct_canfreeze{$class}?
(($thaw->fresh eq 'nope. frozen and thawed'),1):
(($thaw->fresh eq 'fresh'),0);
}