dist/Tie-File/t/32_defer_misc.t

   1 #!/usr/bin/perl
   2 #
   3 # Check interactions of deferred writing
   4 # with miscellaneous methods like DELETE, EXISTS,
   5 # FETCHSIZE, STORESIZE, CLEAR, EXTEND
   6 #
   7
   8 use POSIX 'SEEK_SET';
   9 my $file = "tf$$.txt";
  10 $: = Tie::File::_default_recsep();
  11 my $data = "rec0$:rec1$:rec2$:";
  12 my ($o, $n);
  13
  14 print "1..53\n";
  15
  16 my $N = 1;
  17 use Tie::File;
  18 print "ok $N\n"; $N++;
  19
  20 open F, "> $file" or die $!;
  21 binmode F;
  22 print F $data;
  23 close F;
  24 $o = tie @a, 'Tie::File', $file;
  25 print $o ? "ok $N\n" : "not ok $N\n";
  26 $N++;
  27
  28 # (3-6) EXISTS
  29 if ($] >= 5.006) {
  30   eval << 'TESTS';
  31 $o->defer;
  32 expect(not exists $a[4]);
  33 $a[4] = "rec4";
  34 expect(exists $a[4]);
  35 check_contents($data);          # nothing written yet
  36 $o->discard;
  37 TESTS
  38 } else {
  39     for (3..6) {
  40       print "ok $_ \# skipped (no exists for arrays)\n";
  41           $N++;
  42     }
  43 }
  44
  45 # (7-10) FETCHSIZE
  46 $o->defer;
  47 expect($#a, 2);
  48 $a[4] = "rec4";
  49 expect($#a, 4);
  50 check_contents($data);          # nothing written yet
  51 $o->discard;
  52
  53 # (11-21) STORESIZE
  54 $o->defer;
  55 $#a = 4;
  56 check_contents($data);          # nothing written yet
  57 expect($#a, 4);
  58 $o->flush;
  59 expect($#a, 4);
  60 check_contents("$data$:$:");    # two extra empty records
  61
  62 $o->defer;
  63 $a[4] = "rec4";
  64 $#a = 2;
  65 expect($a[4], undef);
  66 check_contents($data);          # written data was unwritten
  67 $o->flush;
  68 check_contents($data);          # nothing left to write
  69
  70 # (22-28) CLEAR
  71 $o->defer;
  72 $a[9] = "rec9";
  73 check_contents($data);          # nothing written yet
  74 @a = ();
  75 check_contents("");             # this happens right away
  76 expect($a[9], undef);
  77 $o->flush;
  78 check_contents("");             # nothing left to write
  79
  80 # (29-34) EXTEND
  81 # Actually it's not real clear what these tests are for
  82 # since EXTEND has no defined semantics
  83 $o->defer;
  84 @a = (0..3);
  85 check_contents("");             # nothing happened yet
  86 expect($a[3], "3");
  87 expect($a[4], undef);
  88 $o->flush;
  89 check_contents("0$:1$:2$:3$:"); # file now 4 records long
  90
  91 # (35-53) DELETE
  92 if ($] >= 5.006) {
  93   eval << 'TESTS';
  94 my $del;
  95 $o->defer;
  96 $del = delete $a[2];
  97 check_contents("0$:1$:2$:3$:"); # nothing happened yet
  98 expect($a[2], "");
  99 expect($del, "2");
 100 $del = delete $a[3];            # shortens file!
 101 check_contents("0$:1$:2$:");    # deferred writes NOT flushed
 102 expect($a[3], undef);
 103 expect($a[2], "");
 104 expect($del, "3");
 105 $a[2] = "cookies";
 106 $del = delete $a[2];            # shortens file!
 107 expect($a[2], undef);
 108 expect($del, 'cookies');
 109 check_contents("0$:1$:");
 110 $a[0] = "crackers";
 111 $del = delete $a[0];            # file unchanged
 112 expect($a[0], "");
 113 expect($del, 'crackers');
 114 check_contents("0$:1$:");       # no change yet
 115 $o->flush;
 116 check_contents("$:1$:");        # record 0 is NOT 'cookies';
 117 TESTS
 118 } else {
 119     for (35..53) {
 120       print "ok $_ \# skipped (no delete for arrays)\n";
 121           $N++;
 122     }
 123 }
 124
 125 ################################################################
 126
 127
 128 sub check_caches {
 129   my ($xcache, $xdefer) = @_;
 130
 131 #  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
 132 #  print $integrity ? "ok $N\n" : "not ok $N\n";
 133 #  $N++;
 134
 135   my $good = 1;
 136   $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
 137   $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
 138   print $good ? "ok $N\n" : "not ok $N\n";
 139   $N++;
 140 }
 141
 142 sub hash_equal {
 143   my ($a, $b, $ha, $hb) = @_;
 144   $ha = 'first hash'  unless defined $ha;
 145   $hb = 'second hash' unless defined $hb;
 146
 147   my $good = 1;
 148   my %b_seen;
 149
 150   for my $k (keys %$a) {
 151     if (! exists $b->{$k}) {
 152       print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
 153       $good = 0;
 154     } elsif ($b->{$k} ne $a->{$k}) {
 155       print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
 156       $b_seen{$k} = 1;
 157       $good = 0;
 158     } else {
 159       $b_seen{$k} = 1;
 160     }
 161   }
 162
 163   for my $k (keys %$b) {
 164     unless ($b_seen{$k}) {
 165       print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
 166       $good = 0;
 167     }
 168   }
 169
 170   $good;
 171 }
 172
 173
 174 sub check_contents {
 175   my $x = shift;
 176
 177   my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
 178   print $integrity ? "ok $N\n" : "not ok $N\n";
 179   $N++;
 180
 181   local *FH = $o->{fh};
 182   seek FH, 0, SEEK_SET;
 183
 184   my $a;
 185   { local $/; $a = <FH> }
 186   $a = "" unless defined $a;
 187   if ($a eq $x) {
 188     print "ok $N\n";
 189   } else {
 190     my $msg = ctrlfix("# expected <$x>, got <$a>");
 191     print "not ok $N\n$msg\n";
 192   }
 193   $N++;
 194 }
 195
 196 sub expect {
 197   if (@_ == 1) {
 198     print $_[0] ? "ok $N\n" : "not ok $N\n";
 199   } elsif (@_ == 2) {
 200     my ($a, $x) = @_;
 201     if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
 202     elsif (  defined($a) && ! defined($x)) {
 203       ctrlfix(my $msg = "expected UNDEF, got <$a>");
 204       print "not ok $N \# $msg\n";
 205     }
 206     elsif (! defined($a) &&   defined($x)) {
 207       ctrlfix(my $msg = "expected <$x>, got UNDEF");
 208       print "not ok $N \# $msg\n";
 209     } elsif ($a eq $x) { print "ok $N\n" }
 210     else {
 211       ctrlfix(my $msg = "expected <$x>, got <$a>");
 212       print "not ok $N \# $msg\n";
 213     }
 214   } else {
 215     die "expect() got ", scalar(@_), " args, should have been 1 or 2";
 216   }
 217   $N++;
 218 }
 219
 220 sub ctrlfix {
 221   local $_ = shift;
 222   s/\n/\\n/g;
 223   s/\r/\\r/g;
 224   $_;
 225 }
 226
 227 END {
 228   undef $o;
 229   untie @a;
 230   1 while unlink $file;
 231 }
 232