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