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 | |
7c927437 |
36 | # Need to create a second instance of a dbm here, but only of the type |
37 | # being tested. |
38 | if(0){ |
39 | my $db2 = $dbm_maker->(); |
0e3e3555 |
40 | |
41 | $db2->import({ |
42 | hash1 => { |
43 | subkey1 => "subvalue1", |
44 | subkey2 => "subvalue2", |
45 | } |
46 | }); |
7c927437 |
47 | is( $db2->{hash1}{subkey1}, 'subvalue1', "Value1 imported correctly" ); |
48 | is( $db2->{hash1}{subkey2}, 'subvalue2', "Value2 imported correctly" ); |
0e3e3555 |
49 | |
7c927437 |
50 | # Test cross-ref nested hash across DB objects |
0e3e3555 |
51 | throws_ok { |
52 | $db->{copy} = $db2->{hash1}; |
53 | } qr/Cannot store values across DBM::Deep files\. Please use export\(\) instead\./, "cross-ref fails"; |
54 | |
7c927437 |
55 | # This error text is for when internal cross-refs are implemented: |
56 | # qr/Cannot cross-reference\. Use export\(\) instead\./ |
1cff45d7 |
57 | |
7c927437 |
58 | my $x = $db2->{hash1}->export; |
59 | $db->{copy} = $x; |
0e3e3555 |
60 | } |
98ac82af |
61 | |
62 | ## |
0e3e3555 |
63 | # Make sure $db has copy of $db2's hash structure |
98ac82af |
64 | ## |
7c927437 |
65 | # is( $db->{copy}{subkey1}, 'subvalue1', "Value1 copied correctly" ); |
66 | # is( $db->{copy}{subkey2}, 'subvalue2', "Value2 copied correctly" ); |
98ac82af |
67 | } |
ffed8b01 |
68 | |
0e3e3555 |
69 | done_testing; |
1cff45d7 |
70 | |
71 | package Tied::Scalar; |
72 | sub TIESCALAR { bless {}, $_[0]; } |
73 | sub FETCH{} |
74 | |
75 | package Tied::Array; |
76 | sub TIEARRAY { bless {}, $_[0]; } |
77 | |
78 | package Tied::Hash; |
79 | sub TIEHASH { bless {}, $_[0]; } |