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