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