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