Commit | Line | Data |
51efdd02 |
1 | #!/usr/bin/perl |
2 | # |
7b6b3db1 |
3 | # Check PUSH, POP, SHIFT, and UNSHIFT |
51efdd02 |
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 | |
7b6b3db1 |
12 | use POSIX 'SEEK_SET'; |
13 | |
51efdd02 |
14 | my $file = "tf$$.txt"; |
15 | 1 while unlink $file; |
b3fe5a4c |
16 | $: = Tie::File::_default_recsep(); |
17 | my $data = "rec0$:rec1$:rec2$:"; |
51efdd02 |
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 | |
0b28bc9a |
25 | my $o = tie @a, 'Tie::File', $file, autochomp => 0; |
51efdd02 |
26 | print $o ? "ok $N\n" : "not ok $N\n"; |
27 | $N++; |
28 | my ($n, @r); |
29 | |
30 | |
51efdd02 |
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 | |
b3fe5a4c |
37 | $n = push @a, "rec3", "rec4$:"; |
38 | check_contents("$ {data}rec3$:rec4$:"); |
51efdd02 |
39 | print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; |
40 | $N++; |
41 | |
42 | # Trivial push |
b3fe5a4c |
43 | $n = push @a, (); |
44 | check_contents("$ {data}rec3$:rec4$:"); |
51efdd02 |
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; |
b3fe5a4c |
50 | check_contents("$ {data}rec3$:"); |
51 | print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n"; |
51efdd02 |
52 | $N++; |
53 | |
54 | # Presumably we have already tested this to death |
55 | splice(@a, 1, 3); |
56 | $n = pop @a; |
57 | check_contents(""); |
b3fe5a4c |
58 | print $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n"; |
51efdd02 |
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 | |
b3fe5a4c |
73 | $n = unshift @a, "rec3", "rec4$:"; |
74 | check_contents("rec3$:rec4$:$data"); |
51efdd02 |
75 | print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; |
76 | $N++; |
77 | |
78 | # Trivial unshift |
b3fe5a4c |
79 | $n = unshift @a, (); |
80 | check_contents("rec3$:rec4$:$data"); |
51efdd02 |
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; |
b3fe5a4c |
86 | check_contents("rec4$:$data"); |
87 | print $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n"; |
51efdd02 |
88 | $N++; |
89 | |
90 | # Presumably we have already tested this to death |
91 | splice(@a, 1, 3); |
92 | $n = shift @a; |
93 | check_contents(""); |
b3fe5a4c |
94 | print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n"; |
51efdd02 |
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 | |
51efdd02 |
103 | sub check_contents { |
104 | my $x = shift; |
51efdd02 |
105 | my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); |
106 | print $integrity ? "ok $N\n" : "not ok $N\n"; |
107 | $N++; |
7b6b3db1 |
108 | |
109 | local *FH = $o->{fh}; |
110 | seek FH, 0, SEEK_SET; |
51efdd02 |
111 | my $a; |
112 | { local $/; $a = <FH> } |
7b6b3db1 |
113 | $a = "" unless defined $a; |
114 | if ($a eq $x) { |
115 | print "ok $N\n"; |
116 | } else { |
b3fe5a4c |
117 | ctrlfix(my $msg = "# expected <$x>, got <$a>"); |
118 | print "not ok $N\n$msg\n"; |
7b6b3db1 |
119 | } |
51efdd02 |
120 | $N++; |
121 | } |
122 | |
b3fe5a4c |
123 | sub ctrlfix { |
124 | for (@_) { |
125 | s/\n/\\n/g; |
126 | s/\r/\\r/g; |
127 | } |
128 | } |
129 | |
51efdd02 |
130 | END { |
7b6b3db1 |
131 | undef $o; |
132 | untie @a; |
51efdd02 |
133 | 1 while unlink $file; |
134 | } |
135 | |