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