dist/Tie-File/t/15_pushpop.t

   1 #!/usr/bin/perl
   2 #
   3 # Check PUSH, POP, SHIFT, and UNSHIFT
   4 #
   5 # Each call to 'check_contents' actually performs two tests.
   6 # First, it calls the tied object's own 'check_integrity' method,
   7 # which makes sure that the contents of the read cache and offset tables
   8 # accurately reflect the contents of the file.
   9 # Then, it checks the actual contents of the file against the expected
  10 # contents.
  11
  12 use POSIX 'SEEK_SET';
  13
  14 my $file = "tf$$.txt";
  15 1 while unlink $file;
  16 $: = Tie::File::_default_recsep();
  17 my $data = "rec0$:rec1$:rec2$:";
  18
  19 print "1..38\n";
  20
  21 my $N = 1;
  22 use Tie::File;
  23 print "ok $N\n"; $N++;  # partial credit just for showing up
  24
  25 my $o = tie @a, 'Tie::File', $file, autochomp => 0;
  26 print $o ? "ok $N\n" : "not ok $N\n";
  27 $N++;
  28 my ($n, @r);
  29
  30
  31 # (3-11) PUSH tests
  32 $n = push @a, "rec0", "rec1", "rec2";
  33 check_contents($data);
  34 print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
  35 $N++;
  36
  37 $n = push @a, "rec3", "rec4$:";
  38 check_contents("$ {data}rec3$:rec4$:");
  39 print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
  40 $N++;
  41
  42 # Trivial push
  43 $n = push @a, ();
  44 check_contents("$ {data}rec3$:rec4$:");
  45 print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
  46 $N++;
  47
  48 # (12-20) POP tests
  49 $n = pop @a;
  50 check_contents("$ {data}rec3$:");
  51 print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
  52 $N++;
  53
  54 # Presumably we have already tested this to death
  55 splice(@a, 1, 3);
  56 $n = pop @a;
  57 check_contents("");
  58 print $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n";
  59 $N++;
  60
  61 $n = pop @a;
  62 check_contents("");
  63 print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
  64 $N++;
  65
  66
  67 # (21-29) UNSHIFT tests
  68 $n = unshift @a, "rec0", "rec1", "rec2";
  69 check_contents($data);
  70 print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
  71 $N++;
  72
  73 $n = unshift @a, "rec3", "rec4$:";
  74 check_contents("rec3$:rec4$:$data");
  75 print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
  76 $N++;
  77
  78 # Trivial unshift
  79 $n = unshift @a, ();
  80 check_contents("rec3$:rec4$:$data");
  81 print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
  82 $N++;
  83
  84 # (30-38) SHIFT tests
  85 $n = shift @a;
  86 check_contents("rec4$:$data");
  87 print $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n";
  88 $N++;
  89
  90 # Presumably we have already tested this to death
  91 splice(@a, 1, 3);
  92 $n = shift @a;
  93 check_contents("");
  94 print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
  95 $N++;
  96
  97 $n = shift @a;
  98 check_contents("");
  99 print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
 100 $N++;
 101
 102
 103 sub check_contents {
 104   my $x = shift;
 105   my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
 106   print $integrity ? "ok $N\n" : "not ok $N\n";
 107   $N++;
 108
 109   local *FH = $o->{fh};
 110   seek FH, 0, SEEK_SET;
 111   my $a;
 112   { local $/; $a = <FH> }
 113   $a = "" unless defined $a;
 114   if ($a eq $x) {
 115     print "ok $N\n";
 116   } else {
 117     ctrlfix(my $msg = "# expected <$x>, got <$a>");
 118     print "not ok $N\n$msg\n";
 119   }
 120   $N++;
 121 }
 122
 123 sub ctrlfix {
 124   for (@_) {
 125     s/\n/\\n/g;
 126     s/\r/\\r/g;
 127   }
 128 }
 129
 130 END {
 131   undef $o;
 132   untie @a;
 133   1 while unlink $file;
 134 }
 135