Commit | Line | Data |
ffed8b01 |
1 | use strict; |
0e3e3555 |
2 | use warnings FATAL => 'all'; |
3 | |
4 | use Test::More; |
9d4fa373 |
5 | use Test::Exception; |
0e3e3555 |
6 | use t::common qw( new_dbm ); |
ffed8b01 |
7 | |
8 | use_ok( 'DBM::Deep' ); |
9 | |
0e3e3555 |
10 | my $dbm_factory = new_dbm(); |
11 | while ( my $dbm_maker = $dbm_factory->() ) { |
12 | my $db = $dbm_maker->(); |
98ac82af |
13 | |
0e3e3555 |
14 | SKIP: { |
15 | skip "Apparently, we cannot detect a tied scalar?", 1; |
16 | tie my $foo, 'Tied::Scalar'; |
17 | throws_ok { |
18 | $db->{failure} = $foo; |
19 | } qr/Cannot store something that is tied\./, "tied scalar storage fails"; |
20 | } |
1cff45d7 |
21 | |
0e3e3555 |
22 | { |
23 | tie my @foo, 'Tied::Array'; |
24 | throws_ok { |
25 | $db->{failure} = \@foo; |
26 | } qr/Cannot store something that is tied\./, "tied array storage fails"; |
27 | } |
1cff45d7 |
28 | |
0e3e3555 |
29 | { |
30 | tie my %foo, 'Tied::Hash'; |
31 | throws_ok { |
32 | $db->{failure} = \%foo; |
33 | } qr/Cannot store something that is tied\./, "tied hash storage fails"; |
34 | } |
35 | |
36 | my $dbm_factory2 = new_dbm(); |
37 | while ( my $dbm_maker2 = $dbm_factory2->() ) { |
38 | my $db2 = $dbm_maker2->(); |
39 | |
40 | $db2->import({ |
41 | hash1 => { |
42 | subkey1 => "subvalue1", |
43 | subkey2 => "subvalue2", |
44 | } |
45 | }); |
46 | is( $db2->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" ); |
47 | is( $db2->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" ); |
48 | |
49 | # Test cross-ref nested hash accross DB objects |
50 | throws_ok { |
51 | $db->{copy} = $db2->{hash1}; |
52 | } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails"; |
53 | |
54 | # This error text is for when internal cross-refs are implemented |
55 | #} qr/Cannot cross-reference\. Use export\(\) instead\./ |
1cff45d7 |
56 | |
0e3e3555 |
57 | $db->{copy} = $db2->{hash1}->export; |
58 | } |
98ac82af |
59 | |
60 | ## |
0e3e3555 |
61 | # Make sure $db has copy of $db2's hash structure |
98ac82af |
62 | ## |
0e3e3555 |
63 | is( $db->{copy}{subkey1}, 'subvalue1', "Value copied correctly" ); |
64 | is( $db->{copy}{subkey2}, 'subvalue2', "Value copied correctly" ); |
98ac82af |
65 | } |
ffed8b01 |
66 | |
0e3e3555 |
67 | done_testing; |
1cff45d7 |
68 | |
69 | package Tied::Scalar; |
70 | sub TIESCALAR { bless {}, $_[0]; } |
71 | sub FETCH{} |
72 | |
73 | package Tied::Array; |
74 | sub TIEARRAY { bless {}, $_[0]; } |
75 | |
76 | package Tied::Hash; |
77 | sub TIEHASH { bless {}, $_[0]; } |