Commit | Line | Data |
b5aed31e |
1 | #!/usr/bin/perl |
2 | # |
3 | # Check SPLICE function's effect on the file |
4 | # (07_rv_splice.t checks its return value) |
5 | # |
6 | # Each call to 'check_contents' actually performs two tests. |
7 | # First, it calls the tied object's own 'check_integrity' method, |
8 | # which makes sure that the contents of the read cache and offset tables |
9 | # accurately reflect the contents of the file. |
10 | # Then, it checks the actual contents of the file against the expected |
11 | # contents. |
12 | |
7b6b3db1 |
13 | use POSIX 'SEEK_SET'; |
14 | |
b5aed31e |
15 | my $file = "tf$$.txt"; |
16 | my $data = "rec0blahrec1blahrec2blah"; |
17 | |
7b6b3db1 |
18 | print "1..101\n"; |
b5aed31e |
19 | |
20 | my $N = 1; |
21 | use Tie::File; |
22 | print "ok $N\n"; $N++; # partial credit just for showing up |
23 | |
7b6b3db1 |
24 | init_file($data); |
25 | |
b5aed31e |
26 | my $o = tie @a, 'Tie::File', $file, recsep => 'blah'; |
27 | print $o ? "ok $N\n" : "not ok $N\n"; |
28 | $N++; |
29 | |
30 | my $n; |
31 | |
32 | # (3-22) splicing at the beginning |
b5aed31e |
33 | splice(@a, 0, 0, "rec4"); |
34 | check_contents("rec4blah$data"); |
35 | splice(@a, 0, 1, "rec5"); # same length |
36 | check_contents("rec5blah$data"); |
37 | splice(@a, 0, 1, "record5"); # longer |
38 | check_contents("record5blah$data"); |
39 | |
40 | splice(@a, 0, 1, "r5"); # shorter |
41 | check_contents("r5blah$data"); |
42 | splice(@a, 0, 1); # removal |
43 | check_contents("$data"); |
44 | splice(@a, 0, 0); # no-op |
45 | check_contents("$data"); |
46 | splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one |
47 | check_contents("r7blahrec8blah$data"); |
48 | splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete |
49 | check_contents("rec7blahrecord8blahrec9blah$data"); |
50 | |
51 | splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert |
52 | check_contents("record9blahrec10blah$data"); |
53 | splice(@a, 0, 2); # delete more than one |
54 | check_contents("$data"); |
55 | |
56 | |
57 | # (23-42) splicing in the middle |
58 | splice(@a, 1, 0, "rec4"); |
59 | check_contents("rec0blahrec4blahrec1blahrec2blah"); |
60 | splice(@a, 1, 1, "rec5"); # same length |
61 | check_contents("rec0blahrec5blahrec1blahrec2blah"); |
62 | splice(@a, 1, 1, "record5"); # longer |
63 | check_contents("rec0blahrecord5blahrec1blahrec2blah"); |
64 | |
65 | splice(@a, 1, 1, "r5"); # shorter |
66 | check_contents("rec0blahr5blahrec1blahrec2blah"); |
67 | splice(@a, 1, 1); # removal |
68 | check_contents("$data"); |
69 | splice(@a, 1, 0); # no-op |
70 | check_contents("$data"); |
71 | splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one |
72 | check_contents("rec0blahr7blahrec8blahrec1blahrec2blah"); |
73 | splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete |
74 | check_contents("rec0blahrec7blahrecord8blahrec9blahrec1blahrec2blah"); |
75 | |
76 | splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert |
77 | check_contents("rec0blahrecord9blahrec10blahrec1blahrec2blah"); |
78 | splice(@a, 1, 2); # delete more than one |
79 | check_contents("$data"); |
80 | |
81 | # (43-62) splicing at the end |
82 | splice(@a, 3, 0, "rec4"); |
83 | check_contents("$ {data}rec4blah"); |
84 | splice(@a, 3, 1, "rec5"); # same length |
85 | check_contents("$ {data}rec5blah"); |
86 | splice(@a, 3, 1, "record5"); # longer |
87 | check_contents("$ {data}record5blah"); |
88 | |
89 | splice(@a, 3, 1, "r5"); # shorter |
90 | check_contents("$ {data}r5blah"); |
91 | splice(@a, 3, 1); # removal |
92 | check_contents("$data"); |
93 | splice(@a, 3, 0); # no-op |
94 | check_contents("$data"); |
95 | splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one |
96 | check_contents("$ {data}r7blahrec8blah"); |
97 | splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete |
98 | check_contents("$ {data}rec7blahrecord8blahrec9blah"); |
99 | |
100 | splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert |
101 | check_contents("$ {data}record9blahrec10blah"); |
102 | splice(@a, 3, 2); # delete more than one |
103 | check_contents("$data"); |
104 | |
105 | # (63-82) splicing with negative subscript |
106 | splice(@a, -1, 0, "rec4"); |
107 | check_contents("rec0blahrec1blahrec4blahrec2blah"); |
108 | splice(@a, -1, 1, "rec5"); # same length |
109 | check_contents("rec0blahrec1blahrec4blahrec5blah"); |
110 | splice(@a, -1, 1, "record5"); # longer |
111 | check_contents("rec0blahrec1blahrec4blahrecord5blah"); |
112 | |
113 | splice(@a, -1, 1, "r5"); # shorter |
114 | check_contents("rec0blahrec1blahrec4blahr5blah"); |
115 | splice(@a, -1, 1); # removal |
116 | check_contents("rec0blahrec1blahrec4blah"); |
117 | splice(@a, -1, 0); # no-op |
118 | check_contents("rec0blahrec1blahrec4blah"); |
119 | splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one |
120 | check_contents("rec0blahrec1blahr7blahrec8blahrec4blah"); |
121 | splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete |
122 | check_contents("rec0blahrec1blahr7blahrec8blahrec7blahrecord8blahrec9blah"); |
123 | |
124 | splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert |
125 | check_contents("rec0blahrec1blahr7blahrec8blahrecord9blahrec10blah"); |
126 | splice(@a, -4, 3); # delete more than one |
127 | check_contents("rec0blahrec1blahrec10blah"); |
128 | |
129 | # (83-84) scrub it all out |
130 | splice(@a, 0, 3); |
131 | check_contents(""); |
132 | |
133 | # (85-86) put some back in |
134 | splice(@a, 0, 0, "rec0", "rec1"); |
135 | check_contents("rec0blahrec1blah"); |
136 | |
137 | # (87-88) what if we remove too many records? |
138 | splice(@a, 0, 17); |
139 | check_contents(""); |
140 | |
7b6b3db1 |
141 | # (89-92) In the past, splicing past the end was not correctly detected |
142 | # (1.14) |
143 | splice(@a, 89, 3); |
144 | check_contents(""); |
145 | splice(@a, @a, 3); |
146 | check_contents(""); |
147 | |
148 | # (93-96) Also we did not emulate splice's freaky behavior when inserting |
149 | # past the end of the array (1.14) |
150 | splice(@a, 89, 0, "I", "like", "pie"); |
151 | check_contents("Iblahlikeblahpieblah"); |
152 | splice(@a, 89, 0, "pie pie pie"); |
153 | check_contents("Iblahlikeblahpieblahpie pie pieblah"); |
154 | |
155 | # (97) Splicing with too large a negative number should be fatal |
fa408a35 |
156 | # This test ignored because it causes 5.6.1 and 5.7.3 to dump core |
cf8feb78 |
157 | # It also garbles the stack under 5.005_03 (20020401) |
7b6b3db1 |
158 | # NOT MY FAULT |
cf8feb78 |
159 | if ($] > 5.008) { |
7b6b3db1 |
160 | eval { splice(@a, -7, 0) }; |
161 | print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/ |
162 | ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n"; |
163 | } else { |
cf8feb78 |
164 | print "ok $N \# skipped (5.6.0 through 5.8 dump core here.)\n"; |
7b6b3db1 |
165 | } |
166 | $N++; |
167 | |
168 | # (98-101) Test default arguments |
169 | splice @a, 0, 0, (0..11); |
170 | splice @a, 4; |
171 | check_contents("0blah1blah2blah3blah"); |
172 | splice @a; |
173 | check_contents(""); |
174 | |
175 | |
b5aed31e |
176 | sub init_file { |
177 | my $data = shift; |
178 | open F, "> $file" or die $!; |
1768807e |
179 | binmode F; |
b5aed31e |
180 | print F $data; |
181 | close F; |
182 | } |
183 | |
184 | sub check_contents { |
185 | my $x = shift; |
b5aed31e |
186 | my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); |
187 | print $integrity ? "ok $N\n" : "not ok $N\n"; |
188 | $N++; |
7b6b3db1 |
189 | local *FH = $o->{fh}; |
190 | seek FH, 0, SEEK_SET; |
b5aed31e |
191 | my $a; |
192 | { local $/; $a = <FH> } |
7b6b3db1 |
193 | $a = "" unless defined $a; |
194 | if ($a eq $x) { |
195 | print "ok $N\n"; |
196 | } else { |
b3fe5a4c |
197 | ctrlfix(my $msg = "# expected <$x>, got <$a>"); |
198 | print "not ok $N\n$msg\n"; |
7b6b3db1 |
199 | } |
b5aed31e |
200 | $N++; |
201 | } |
202 | |
b3fe5a4c |
203 | sub ctrlfix { |
204 | for (@_) { |
205 | s/\n/\\n/g; |
206 | s/\r/\\r/g; |
207 | } |
208 | } |
209 | |
b5aed31e |
210 | END { |
7b6b3db1 |
211 | undef $o; |
212 | untie @a; |
b5aed31e |
213 | 1 while unlink $file; |
214 | } |
215 | |