lib/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 my $data = "rec0$/rec1$/rec2$/";
  17
  18 print "1..38\n";
  19
  20 my $N = 1;
  21 use Tie::File;
  22 print "ok $N\n"; $N++;  # partial credit just for showing up
  23
  24 my $o = tie @a, 'Tie::File', $file;
  25 print $o ? "ok $N\n" : "not ok $N\n";
  26 $N++;
  27 my ($n, @r);
  28
  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\n";
  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\n";
  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     s{$/}{\\n}g for $a, $x;
 118     print "not ok $N\n# expected <$x>, got <$a>\n";
 119   }
 120   $N++;
 121 }
 122
 123 END {
 124   undef $o;
 125   untie @a;
 126   1 while unlink $file;
 127 }
 128