t/24_autobless.t

   1 use strict;
   2
   3 {
   4     package Foo;
   5
   6     sub export { 'export' };
   7     sub foo { 'foo' };
   8 }
   9
  10 use Test::More tests => 54;
  11 use File::Temp qw( tempfile tempdir );
  12
  13 use_ok( 'DBM::Deep' );
  14
  15 my $dir = tempdir( CLEANUP => 1 );
  16 my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
  17 {
  18     my $db = DBM::Deep->new(
  19         file     => $filename,
  20         autobless => 1,
  21     );
  22
  23     my $obj = bless {
  24         a => 1,
  25         b => [ 1 .. 3 ],
  26     }, 'Foo';
  27
  28     $db->{blessed} = $obj;
  29
  30     my $obj2 = bless [
  31         { a => 'foo' },
  32         2,
  33     ], 'Foo';
  34     $db->{blessed2} = $obj2;
  35
  36     $db->{unblessed} = {};
  37     $db->{unblessed}{a} = 1;
  38     $db->{unblessed}{b} = [];
  39     $db->{unblessed}{b}[0] = 1;
  40     $db->{unblessed}{b}[1] = 2;
  41     $db->{unblessed}{b}[2] = 3;
  42 }
  43
  44 {
  45     my $db = DBM::Deep->new(
  46         file     => $filename,
  47         autobless => 1,
  48     );
  49
  50     my $obj = $db->{blessed};
  51     isa_ok( $obj, 'Foo' );
  52     can_ok( $obj, 'export', 'foo' );
  53     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
  54
  55     is( $obj->{a}, 1 );
  56     is( $obj->{b}[0], 1 );
  57     is( $obj->{b}[1], 2 );
  58     is( $obj->{b}[2], 3 );
  59
  60     my $obj2 = $db->{blessed2};
  61     isa_ok( $obj, 'Foo' );
  62     can_ok( $obj, 'export', 'foo' );
  63     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
  64
  65     is( $obj2->[0]{a}, 'foo' );
  66     is( $obj2->[1], '2' );
  67
  68     is( $db->{unblessed}{a}, 1 );
  69     is( $db->{unblessed}{b}[0], 1 );
  70     is( $db->{unblessed}{b}[1], 2 );
  71     is( $db->{unblessed}{b}[2], 3 );
  72
  73     $obj->{c} = 'new';
  74     is( $db->{blessed}{c}, 'new' );
  75 }
  76
  77 {
  78     my $db = DBM::Deep->new(
  79         file     => $filename,
  80         autobless => 1,
  81     );
  82     is( $db->{blessed}{c}, 'new' );
  83
  84     my $structure = $db->export();
  85
  86     my $obj = $structure->{blessed};
  87     isa_ok( $obj, 'Foo' );
  88     can_ok( $obj, 'export', 'foo' );
  89     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
  90
  91     is( $obj->{a}, 1 );
  92     is( $obj->{b}[0], 1 );
  93     is( $obj->{b}[1], 2 );
  94     is( $obj->{b}[2], 3 );
  95
  96     my $obj2 = $structure->{blessed2};
  97     isa_ok( $obj, 'Foo' );
  98     can_ok( $obj, 'export', 'foo' );
  99     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
 100
 101     is( $obj2->[0]{a}, 'foo' );
 102     is( $obj2->[1], '2' );
 103
 104     is( $structure->{unblessed}{a}, 1 );
 105     is( $structure->{unblessed}{b}[0], 1 );
 106     is( $structure->{unblessed}{b}[1], 2 );
 107     is( $structure->{unblessed}{b}[2], 3 );
 108 }
 109
 110 {
 111     my $db = DBM::Deep->new(
 112         file     => $filename,
 113     );
 114
 115     my $obj = $db->{blessed};
 116     isa_ok( $obj, 'DBM::Deep' );
 117     can_ok( $obj, 'export', 'STORE' );
 118     ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
 119
 120     is( $obj->{a}, 1 );
 121     is( $obj->{b}[0], 1 );
 122     is( $obj->{b}[1], 2 );
 123     is( $obj->{b}[2], 3 );
 124
 125     my $obj2 = $db->{blessed2};
 126     isa_ok( $obj2, 'DBM::Deep' );
 127     can_ok( $obj2, 'export', 'STORE' );
 128     ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
 129
 130     is( $obj2->[0]{a}, 'foo' );
 131     is( $obj2->[1], '2' );
 132
 133     is( $db->{unblessed}{a}, 1 );
 134     is( $db->{unblessed}{b}[0], 1 );
 135     is( $db->{unblessed}{b}[1], 2 );
 136     is( $db->{unblessed}{b}[2], 3 );
 137 }
 138
 139 my ($fh2, $filename2) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
 140 {
 141     my $db = DBM::Deep->new(
 142         file     => $filename2,
 143         autobless => 1,
 144     );
 145     my $obj = bless {
 146         a => 1,
 147         b => [ 1 .. 3 ],
 148     }, 'Foo';
 149
 150     $db->import( { blessed => $obj } );
 151 }
 152
 153 {
 154     my $db = DBM::Deep->new(
 155         file     => $filename2,
 156         autobless => 1,
 157     );
 158
 159     my $blessed = $db->{blessed};
 160     isa_ok( $blessed, 'Foo' );
 161     is( $blessed->{a}, 1 );
 162 }
 163
 164 {
 165         ##
 166         # test blessing hash into short named class (Foo), then re-blessing into
 167         # longer named class (FooFoo) and replacing key in db file, then validating
 168         # content after that point in file to check for corruption.
 169         ##
 170     my ($fh3, $filename3) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
 171     my $db = DBM::Deep->new(
 172         file     => $filename3,
 173         autobless => 1,
 174     );
 175
 176     my $obj = bless {}, 'Foo';
 177
 178     $db->{blessed} = $obj;
 179     $db->{after} = "hello";
 180
 181     my $obj2 = bless {}, 'FooFoo';
 182
 183     $db->{blessed} = $obj2;
 184
 185     is( $db->{after}, "hello" );
 186 }