Commit | Line | Data |
359a01ac |
1 | use strict; |
2 | use warnings; |
3 | |
4 | { |
5 | # This is here because Tie::File is STOOPID. |
6 | |
7 | package My::Tie::File; |
8 | sub TIEARRAY { |
9 | my $class = shift; |
10 | my ($filename) = @_; |
11 | |
12 | return bless { |
13 | filename => $filename, |
14 | }, $class; |
15 | } |
16 | |
17 | sub FETCH { |
18 | my $self = shift; |
19 | my ($idx) = @_; |
20 | |
21 | open( my $fh, $self->{filename} ); |
22 | my @x = <$fh>; |
23 | close $fh; |
24 | |
25 | return $x[$idx]; |
26 | } |
27 | |
28 | sub FETCHSIZE { |
29 | my $self = shift; |
30 | |
31 | open( my $fh, $self->{filename} ); |
32 | my @x = <$fh>; |
33 | close $fh; |
34 | |
35 | return scalar @x; |
36 | } |
37 | |
38 | sub STORESIZE {} |
39 | } |
40 | |
41 | use Test::More tests => 24; |
42 | use t::common qw( new_fh ); |
43 | |
44 | use_ok( 'DBM::Deep' ); |
45 | |
46 | my ($audit_fh, $audit_file) = new_fh(); |
47 | |
48 | my @audit; |
49 | tie @audit, 'My::Tie::File', $audit_file; |
50 | |
51 | my ($fh, $filename) = new_fh(); |
52 | my $db = DBM::Deep->new({ |
53 | file => $filename, |
54 | audit_file => $audit_file, |
55 | #autuflush => 1, |
56 | }); |
57 | isa_ok( $db, 'DBM::Deep' ); |
58 | |
59 | like( |
60 | $audit[0], qr/^\# Database created on/, |
61 | "Audit file header written to", |
62 | ); |
63 | |
64 | $db->{foo} = 'bar'; |
65 | like( $audit[1], qr{^\$db->{foo} = 'bar';}, "Basic assignment correct" ); |
66 | |
359a01ac |
67 | $db->{foo} = 'baz'; |
68 | like( $audit[2], qr{^\$db->{foo} = 'baz';}, "Basic update correct" ); |
69 | |
70 | $db->{bar} = { a => 1 }; |
71 | like( $audit[3], qr{\$db->\{bar\} = \{\};}, "Hash assignment correct" ); |
72 | like( $audit[4], qr{\$db->\{bar\}\{a\} = '1';}, "... child 1 good" ); |
73 | |
74 | $db->{baz} = [ 1 .. 2 ]; |
75 | like( $audit[5], qr{\$db->{baz} = \[\];}, "Array assignment correct" ); |
76 | like( $audit[6], qr{\$db->{baz}\[0\] = '1';}, "... child 1 good" ); |
77 | like( $audit[7], qr{\$db->{baz}\[1\] = '2';}, "... child 2 good" ); |
78 | |
79 | { |
80 | my $v = $db->{baz}; |
81 | $v->[5] = [ 3 .. 5 ]; |
82 | like( $audit[8], qr{\$db->{baz}\[5\] = \[\];}, "Child array assignment correct" ); |
83 | like( $audit[9], qr{\$db->{baz}\[5\]\[0\] = '3';}, "... child 1 good" ); |
84 | like( $audit[10], qr{\$db->{baz}\[5]\[1] = '4';}, "... child 2 good" ); |
85 | like( $audit[11], qr{\$db->{baz}\[5]\[2] = '5';}, "... child 3 good" ); |
86 | } |
87 | |
88 | undef $db; |
89 | |
90 | $db = DBM::Deep->new({ |
91 | file => $filename, |
92 | audit_file => $audit_file, |
93 | }); |
94 | |
95 | $db->{new} = 9; |
96 | like( $audit[12], qr{\$db->{new} = '9';}, "Writing after closing the file works" ); |
97 | |
98 | my $export = $db->export; |
99 | undef $db; |
100 | |
101 | { |
102 | my ($fh2, $file2) = new_fh(); |
103 | my $db = DBM::Deep->new({ |
104 | file => $file2, |
105 | }); |
106 | |
107 | for ( @audit ) { |
108 | eval "$_"; |
109 | } |
110 | |
111 | my $export2 = $db->export; |
112 | |
113 | is_deeply( $export2, $export, "And recovery works" ); |
114 | } |
115 | |
116 | { |
117 | $db = DBM::Deep->new({ |
118 | file => $filename, |
119 | audit_file => $audit_file, |
120 | }); |
121 | |
122 | delete $db->{baz}; |
123 | like( $audit[13], qr{delete \$db->{baz};}, "Deleting works" ); |
124 | |
125 | $export = $db->export; |
126 | } |
127 | |
128 | { |
129 | my ($fh2, $file2) = new_fh(); |
130 | my $db = DBM::Deep->new({ |
131 | file => $file2, |
132 | }); |
133 | |
134 | for ( @audit ) { |
135 | eval "$_"; |
136 | } |
137 | |
138 | my $export2 = $db->export; |
139 | |
140 | is_deeply( $export2, $export, "And recovery works" ); |
141 | } |
142 | |
a97c8f67 |
143 | SKIP: { |
144 | skip 'Not done yet', 1; |
359a01ac |
145 | $db = DBM::Deep->new({ |
146 | file => $filename, |
147 | audit_file => $audit_file, |
148 | }); |
149 | |
150 | $db->{bar}->clear; |
151 | like( $audit[14], qr{\$db->{bar} = \{\};}, "Clearing works" ); |
152 | |
153 | $export = $db->export; |
154 | } |
155 | |
156 | { |
157 | my ($fh2, $file2) = new_fh(); |
158 | my $db = DBM::Deep->new({ |
159 | file => $file2, |
160 | }); |
161 | |
162 | for ( @audit ) { |
163 | eval "$_"; |
164 | } |
165 | |
166 | my $export2 = $db->export; |
167 | |
168 | is_deeply( $export2, $export, "And recovery works" ); |
169 | } |
170 | |
a97c8f67 |
171 | SKIP: { |
172 | skip "Not working", 3; |
359a01ac |
173 | $db = DBM::Deep->new({ |
174 | file => $filename, |
175 | audit_file => $audit_file, |
176 | }); |
177 | |
178 | $db->{blessed} = bless { a => 5, b => 3 }, 'Floober'; |
179 | like( $audit[15], qr{\$db->{blessed} = bless {}, 'Floober';}, |
180 | "Assignment of a blessed reference works" ); |
181 | like( $audit[16], qr{\$db->{blessed}{a} = '5';}, "... child 1" ); |
182 | like( $audit[17], qr{\$db->{blessed}{b} = '3';}, "... child 2" ); |
183 | |
184 | $export = $db->export; |
185 | } |
186 | |
187 | { |
188 | my ($fh2, $file2) = new_fh(); |
189 | my $db = DBM::Deep->new({ |
190 | file => $file2, |
191 | }); |
192 | |
193 | for ( @audit ) { |
194 | eval "$_"; |
195 | } |
196 | |
197 | my $export2 = $db->export; |
198 | |
199 | is_deeply( $export2, $export, "And recovery works" ); |
200 | } |