Commit | Line | Data |
---|---|---|
b5aed31e AMS |
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 JH |
13 | use POSIX 'SEEK_SET'; |
14 | ||
b5aed31e AMS |
15 | my $file = "tf$$.txt"; |
16 | my $data = "rec0blahrec1blahrec2blah"; | |
17 | ||
7b6b3db1 | 18 | print "1..101\n"; |
b5aed31e AMS |
19 | |
20 | my $N = 1; | |
21 | use Tie::File; | |
22 | print "ok $N\n"; $N++; # partial credit just for showing up | |
23 | ||
7b6b3db1 JH |
24 | init_file($data); |
25 | ||
b5aed31e AMS |
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 AMS |
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 |
bf919750 | 142 | # (0.14) |
7b6b3db1 JH |
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 |
0bf62e3b | 159 | if ($] > 5.007003) { |
7b6b3db1 JH |
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 { | |
0bf62e3b | 164 | print "ok $N \# skipped (versions through 5.7.3 dump core here.)\n"; |
7b6b3db1 JH |
165 | } |
166 | $N++; | |
bf919750 | 167 | |
7b6b3db1 JH |
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 AMS |
176 | sub init_file { |
177 | my $data = shift; | |
178 | open F, "> $file" or die $!; | |
1768807e | 179 | binmode F; |
b5aed31e AMS |
180 | print F $data; |
181 | close F; | |
182 | } | |
183 | ||
184 | sub check_contents { | |
185 | my $x = shift; | |
b5aed31e AMS |
186 | my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); |
187 | print $integrity ? "ok $N\n" : "not ok $N\n"; | |
188 | $N++; | |
7b6b3db1 JH |
189 | local *FH = $o->{fh}; |
190 | seek FH, 0, SEEK_SET; | |
b5aed31e AMS |
191 | my $a; |
192 | { local $/; $a = <FH> } | |
7b6b3db1 JH |
193 | $a = "" unless defined $a; |
194 | if ($a eq $x) { | |
195 | print "ok $N\n"; | |
196 | } else { | |
b3fe5a4c AMS |
197 | ctrlfix(my $msg = "# expected <$x>, got <$a>"); |
198 | print "not ok $N\n$msg\n"; | |
7b6b3db1 | 199 | } |
b5aed31e AMS |
200 | $N++; |
201 | } | |
202 | ||
b3fe5a4c AMS |
203 | sub ctrlfix { |
204 | for (@_) { | |
205 | s/\n/\\n/g; | |
206 | s/\r/\\r/g; | |
207 | } | |
208 | } | |
209 | ||
b5aed31e | 210 | END { |
7b6b3db1 JH |
211 | undef $o; |
212 | untie @a; | |
b5aed31e AMS |
213 | 1 while unlink $file; |
214 | } | |
215 |