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