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 => 64;
  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
  55 {
  56     my $db = DBM::Deep->new(
  57         file     => $filename,
  58         autobless => 1,
  59     );
  60
  61     my $obj = $db->{blessed};
  62     isa_ok( $obj, 'Foo' );
  63     can_ok( $obj, 'export', 'foo' );
  64     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
  65
  66     is( $obj->{a}, 1 );
  67     is( $obj->{b}[0], 1 );
  68     is( $obj->{b}[1], 2 );
  69     is( $obj->{b}[2], 3 );
  70
  71     my $obj2 = $db->{blessed2};
  72     isa_ok( $obj, 'Foo' );
  73     can_ok( $obj, 'export', 'foo' );
  74     ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
  75
  76     is( $obj2->[0]{a}, 'foo' );
  77     is( $obj2->[1], '2' );
  78
  79     is( $db->{unblessed}{a}, 1 );
  80     is( $db->{unblessed}{b}[0], 1 );
  81     is( $db->{unblessed}{b}[1], 2 );
  82     is( $db->{unblessed}{b}[2], 3 );
  83
  84     $obj->{c} = 'new';
  85     is( $db->{blessed}{c}, 'new' );
  86 }
  87
  88 {
  89     my $db = DBM::Deep->new(
  90         file     => $filename,
  91         autobless => 1,
  92     );
  93     is( $db->{blessed}{c}, 'new' );
  94
  95     my $structure = $db->export();
  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( $obj, 'Foo' );
 109     can_ok( $obj, 'export', 'foo' );
 110     ok( !$obj->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 }
 120
 121 {
 122     my $db = DBM::Deep->new(
 123         file     => $filename,
 124         autobless => 0,
 125     );
 126
 127     my $obj = $db->{blessed};
 128     isa_ok( $obj, 'DBM::Deep' );
 129     can_ok( $obj, 'export', 'STORE' );
 130     ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
 131
 132     is( $obj->{a}, 1 );
 133     is( $obj->{b}[0], 1 );
 134     is( $obj->{b}[1], 2 );
 135     is( $obj->{b}[2], 3 );
 136
 137     my $obj2 = $db->{blessed2};
 138     isa_ok( $obj2, 'DBM::Deep' );
 139     can_ok( $obj2, 'export', 'STORE' );
 140     ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
 141
 142     is( $obj2->[0]{a}, 'foo' );
 143     is( $obj2->[1], '2' );
 144
 145     is( $db->{unblessed}{a}, 1 );
 146     is( $db->{unblessed}{b}[0], 1 );
 147     is( $db->{unblessed}{b}[1], 2 );
 148     is( $db->{unblessed}{b}[2], 3 );
 149 }
 150
 151 my ($fh2, $filename2) = new_fh();
 152 {
 153     my $db = DBM::Deep->new(
 154         file     => $filename2,
 155         autobless => 1,
 156     );
 157     my $obj = bless {
 158         a => 1,
 159         b => [ 1 .. 3 ],
 160     }, 'Foo';
 161
 162     $db->import( { blessed => $obj } );
 163 }
 164
 165 {
 166     my $db = DBM::Deep->new(
 167         file     => $filename2,
 168         autobless => 1,
 169     );
 170
 171     my $blessed = $db->{blessed};
 172     isa_ok( $blessed, 'Foo' );
 173     is( $blessed->{a}, 1 );
 174 }
 175
 176 {
 177         ##
 178         # test blessing hash into short named class (Foo), then re-blessing into
 179         # longer named class (FooFoo) and replacing key in db file, then validating
 180         # content after that point in file to check for corruption.
 181         ##
 182     my ($fh3, $filename3) = new_fh();
 183     my $db = DBM::Deep->new(
 184         file     => $filename3,
 185         autobless => 1,
 186     );
 187
 188     my $obj = bless {}, 'Foo';
 189
 190     $db->{blessed} = $obj;
 191     $db->{after} = "hello";
 192
 193     my $obj2 = bless {}, 'FooFoo';
 194
 195     $db->{blessed} = $obj2;
 196
 197     is( $db->{after}, "hello" );
 198 }