15_pushpop.t revision 1.1.1.2
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 12use strict; 13use warnings; 14 15use POSIX 'SEEK_SET'; 16 17my $file = "tf15-$$.txt"; 181 while unlink $file; 19$: = Tie::File::_default_recsep(); 20my $data = "rec0$:rec1$:rec2$:"; 21 22print "1..38\n"; 23 24my $N = 1; 25use Tie::File; 26print "ok $N\n"; $N++; # partial credit just for showing up 27 28my @a; 29my $o = tie @a, 'Tie::File', $file, autochomp => 0; 30print $o ? "ok $N\n" : "not ok $N\n"; 31$N++; 32my ($n, @r); 33 34 35# (3-11) PUSH tests 36$n = push @a, "rec0", "rec1", "rec2"; 37check_contents($data); 38print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n"; 39$N++; 40 41$n = push @a, "rec3", "rec4$:"; 42check_contents("$ {data}rec3$:rec4$:"); 43print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; 44$N++; 45 46# Trivial push 47$n = push @a, (); 48check_contents("$ {data}rec3$:rec4$:"); 49print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; 50$N++; 51 52# (12-20) POP tests 53$n = pop @a; 54check_contents("$ {data}rec3$:"); 55print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n"; 56$N++; 57 58# Presumably we have already tested this to death 59splice(@a, 1, 3); 60$n = pop @a; 61check_contents(""); 62print $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n"; 63$N++; 64 65$n = pop @a; 66check_contents(""); 67print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n"; 68$N++; 69 70 71# (21-29) UNSHIFT tests 72$n = unshift @a, "rec0", "rec1", "rec2"; 73check_contents($data); 74print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n"; 75$N++; 76 77$n = unshift @a, "rec3", "rec4$:"; 78check_contents("rec3$:rec4$:$data"); 79print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; 80$N++; 81 82# Trivial unshift 83$n = unshift @a, (); 84check_contents("rec3$:rec4$:$data"); 85print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; 86$N++; 87 88# (30-38) SHIFT tests 89$n = shift @a; 90check_contents("rec4$:$data"); 91print $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n"; 92$N++; 93 94# Presumably we have already tested this to death 95splice(@a, 1, 3); 96$n = shift @a; 97check_contents(""); 98print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n"; 99$N++; 100 101$n = shift @a; 102check_contents(""); 103print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n"; 104$N++; 105 106 107sub check_contents { 108 my $x = shift; 109 my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); 110 print $integrity ? "ok $N\n" : "not ok $N\n"; 111 $N++; 112 113 local *FH = $o->{fh}; 114 seek FH, 0, SEEK_SET; 115 my $a; 116 { local $/; $a = <FH> } 117 $a = "" unless defined $a; 118 if ($a eq $x) { 119 print "ok $N\n"; 120 } else { 121 ctrlfix(my $msg = "# expected <$x>, got <$a>"); 122 print "not ok $N\n$msg\n"; 123 } 124 $N++; 125} 126 127sub ctrlfix { 128 for (@_) { 129 s/\n/\\n/g; 130 s/\r/\\r/g; 131 } 132} 133 134END { 135 undef $o; 136 untie @a; 137 1 while unlink $file; 138} 139 140