t/24_autobless.t

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