t/50_audit_trail.t

   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
  67 SKIP: {
  68     skip 'Not done yet', 20;
  69 $db->{foo} = 'baz';
  70 like( $audit[2], qr{^\$db->{foo} = 'baz';}, "Basic update correct" );
  71
  72 $db->{bar} = { a => 1 };
  73 like( $audit[3], qr{\$db->\{bar\} = \{\};}, "Hash assignment correct" );
  74 like( $audit[4], qr{\$db->\{bar\}\{a\} = '1';}, "... child 1 good" );
  75
  76 $db->{baz} = [ 1 .. 2 ];
  77 like( $audit[5], qr{\$db->{baz} = \[\];}, "Array assignment correct" );
  78 like( $audit[6], qr{\$db->{baz}\[0\] = '1';}, "... child 1 good" );
  79 like( $audit[7], qr{\$db->{baz}\[1\] = '2';}, "... child 2 good" );
  80
  81 {
  82     my $v = $db->{baz};
  83     $v->[5] = [ 3 .. 5 ];
  84     like( $audit[8], qr{\$db->{baz}\[5\] = \[\];}, "Child array assignment correct" );
  85     like( $audit[9], qr{\$db->{baz}\[5\]\[0\] = '3';}, "... child 1 good" );
  86     like( $audit[10], qr{\$db->{baz}\[5]\[1] = '4';}, "... child 2 good" );
  87     like( $audit[11], qr{\$db->{baz}\[5]\[2] = '5';}, "... child 3 good" );
  88 }
  89
  90 undef $db;
  91
  92 $db = DBM::Deep->new({
  93     file => $filename,
  94     audit_file => $audit_file,
  95 });
  96
  97 $db->{new} = 9;
  98 like( $audit[12], qr{\$db->{new} = '9';}, "Writing after closing the file works" );
  99
 100 my $export = $db->export;
 101 undef $db;
 102
 103 {
 104     my ($fh2, $file2) = new_fh();
 105     my $db = DBM::Deep->new({
 106         file => $file2,
 107     });
 108
 109     for ( @audit ) {
 110         eval "$_";
 111     }
 112
 113     my $export2 = $db->export;
 114
 115     is_deeply( $export2, $export, "And recovery works" );
 116 }
 117
 118 {
 119     $db = DBM::Deep->new({
 120         file => $filename,
 121         audit_file => $audit_file,
 122     });
 123
 124     delete $db->{baz};
 125     like( $audit[13], qr{delete \$db->{baz};}, "Deleting works" );
 126
 127     $export = $db->export;
 128 }
 129
 130 {
 131     my ($fh2, $file2) = new_fh();
 132     my $db = DBM::Deep->new({
 133         file => $file2,
 134     });
 135
 136     for ( @audit ) {
 137         eval "$_";
 138     }
 139
 140     my $export2 = $db->export;
 141
 142     is_deeply( $export2, $export, "And recovery works" );
 143 }
 144
 145 {
 146     $db = DBM::Deep->new({
 147         file => $filename,
 148         audit_file => $audit_file,
 149     });
 150
 151     $db->{bar}->clear;
 152     like( $audit[14], qr{\$db->{bar} = \{\};}, "Clearing works" );
 153
 154     $export = $db->export;
 155 }
 156
 157 {
 158     my ($fh2, $file2) = new_fh();
 159     my $db = DBM::Deep->new({
 160         file => $file2,
 161     });
 162
 163     for ( @audit ) {
 164         eval "$_";
 165     }
 166
 167     my $export2 = $db->export;
 168
 169     is_deeply( $export2, $export, "And recovery works" );
 170 }
 171
 172 {
 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 }
 201 }