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 => 65;
  11 use t::common qw( new_fh );
  12
  13 use_ok( 'DBM::Deep' );
  14
  15 my ($fh, $filename) = new_fh();
  16 {
  17     my $db = DBM::Deep->new(
  18         file     => $filename,
  19         fh => $fh,
  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     $db->{blessed_long} = bless {}, 'a' x 1000;
  56     $db->_get_self->_engine->storage->close( $db->_get_self );
  57 }
  58
  59 {
  60     my $db = DBM::Deep->new(
  61         file     => $filename,
  62         autobless => 1,
  63     );
  64
  65     my $obj = $db->{blessed};
  66     isa_ok( $obj, 'Foo' );
  67     can_ok( $obj, 'export', 'foo' );
  68     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
  69
  70     is( $obj->{a}, 1 );
  71     is( $obj->{b}[0], 1 );
  72     is( $obj->{b}[1], 2 );
  73     is( $obj->{b}[2], 3 );
  74
  75     my $obj2 = $db->{blessed2};
  76     isa_ok( $obj2, 'Foo' );
  77     can_ok( $obj2, 'export', 'foo' );
  78     ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
  79
  80     is( $obj2->[0]{a}, 'foo' );
  81     is( $obj2->[1], '2' );
  82
  83     is( $db->{unblessed}{a}, 1 );
  84     is( $db->{unblessed}{b}[0], 1 );
  85     is( $db->{unblessed}{b}[1], 2 );
  86     is( $db->{unblessed}{b}[2], 3 );
  87
  88     $obj->{c} = 'new';
  89     is( $db->{blessed}{c}, 'new' );
  90
  91     isa_ok( $db->{blessed_long}, 'a' x 1000 );
  92     $db->_get_self->_engine->storage->close( $db->_get_self );
  93 }
  94
  95 {
  96     my $db = DBM::Deep->new(
  97         file     => $filename,
  98         autobless => 1,
  99     );
 100     is( $db->{blessed}{c}, 'new' );
 101
 102     my $structure = $db->export();
 103     use Data::Dumper;print Dumper $structure;
 104
 105     my $obj = $structure->{blessed};
 106     isa_ok( $obj, 'Foo' );
 107     can_ok( $obj, 'export', 'foo' );
 108     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
 109
 110     is( $obj->{a}, 1 );
 111     is( $obj->{b}[0], 1 );
 112     is( $obj->{b}[1], 2 );
 113     is( $obj->{b}[2], 3 );
 114
 115     my $obj2 = $structure->{blessed2};
 116     isa_ok( $obj2, 'Foo' );
 117     can_ok( $obj2, 'export', 'foo' );
 118     ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
 119
 120     is( $obj2->[0]{a}, 'foo' );
 121     is( $obj2->[1], '2' );
 122
 123     is( $structure->{unblessed}{a}, 1 );
 124     is( $structure->{unblessed}{b}[0], 1 );
 125     is( $structure->{unblessed}{b}[1], 2 );
 126     is( $structure->{unblessed}{b}[2], 3 );
 127     $db->_get_self->_engine->storage->close( $db->_get_self );
 128 }
 129
 130 {
 131     my $db = DBM::Deep->new(
 132         file     => $filename,
 133         autobless => 0,
 134     );
 135
 136     my $obj = $db->{blessed};
 137     isa_ok( $obj, 'DBM::Deep' );
 138     can_ok( $obj, 'export', 'STORE' );
 139     ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
 140
 141     is( $obj->{a}, 1 );
 142     is( $obj->{b}[0], 1 );
 143     is( $obj->{b}[1], 2 );
 144     is( $obj->{b}[2], 3 );
 145
 146     my $obj2 = $db->{blessed2};
 147     isa_ok( $obj2, 'DBM::Deep' );
 148     can_ok( $obj2, 'export', 'STORE' );
 149     ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
 150
 151     is( $obj2->[0]{a}, 'foo' );
 152     is( $obj2->[1], '2' );
 153
 154     is( $db->{unblessed}{a}, 1 );
 155     is( $db->{unblessed}{b}[0], 1 );
 156     is( $db->{unblessed}{b}[1], 2 );
 157     is( $db->{unblessed}{b}[2], 3 );
 158     $db->_get_self->_engine->storage->close( $db->_get_self );
 159 }
 160
 161 {
 162     my ($fh2, $filename2) = new_fh();
 163     {
 164         my $db = DBM::Deep->new(
 165             file     => $filename2,
 166             fh => $fh2,
 167             autobless => 1,
 168         );
 169         my $obj = bless {
 170             a => 1,
 171             b => [ 1 .. 3 ],
 172         }, 'Foo';
 173
 174         $db->import( { blessed => $obj } );
 175         $db->_get_self->_engine->storage->close( $db->_get_self );
 176     }
 177
 178     {
 179         my $db = DBM::Deep->new(
 180             file     => $filename2,
 181             autobless => 1,
 182         );
 183
 184         my $blessed = $db->{blessed};
 185         isa_ok( $blessed, 'Foo' );
 186         is( $blessed->{a}, 1 );
 187         $db->_get_self->_engine->storage->close( $db->_get_self );
 188     }
 189 }
 190
 191 {
 192     ##
 193     # test blessing hash into short named class (Foo), then re-blessing into
 194     # longer named class (FooFoo) and replacing key in db file, then validating
 195     # content after that point in file to check for corruption.
 196     ##
 197     my ($fh3, $filename3) = new_fh();
 198     my $db = DBM::Deep->new(
 199         file     => $filename3,
 200         fh => $fh3,
 201         autobless => 1,
 202     );
 203
 204     my $obj = bless {}, 'Foo';
 205
 206     $db->{blessed} = $obj;
 207     $db->{after} = "hello";
 208
 209     my $obj2 = bless {}, 'FooFoo';
 210
 211     $db->{blessed} = $obj2;
 212
 213     is( $db->{after}, "hello" );
 214 }