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