3 # Check SPLICE function's return value
4 # (04_splice.t checks its effect on the file)
8 $: = Tie::File::_default_recsep();
9 my $data = "rec0$:rec1$:rec2$:";
15 print "ok $N\n"; $N++; # partial credit just for showing up
19 my $o = tie @a, 'Tie::File', $file;
20 print $o ? "ok $N\n" : "not ok $N\n";
25 # (3-12) splicing at the beginning
26 @r = splice(@a, 0, 0, "rec4");
28 @r = splice(@a, 0, 1, "rec5"); # same length
30 @r = splice(@a, 0, 1, "record5"); # longer
33 @r = splice(@a, 0, 1, "r5"); # shorter
34 check_result("record5");
35 @r = splice(@a, 0, 1); # removal
37 @r = splice(@a, 0, 0); # no-op
39 @r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
41 @r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
42 check_result('r7', 'rec8');
44 @r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
45 check_result('rec7', 'record8', 'rec9');
46 @r = splice(@a, 0, 2); # delete more than one
47 check_result('record9', 'rec10');
50 # (13-22) splicing in the middle
51 @r = splice(@a, 1, 0, "rec4");
53 @r = splice(@a, 1, 1, "rec5"); # same length
55 @r = splice(@a, 1, 1, "record5"); # longer
58 @r = splice(@a, 1, 1, "r5"); # shorter
59 check_result("record5");
60 @r = splice(@a, 1, 1); # removal
62 @r = splice(@a, 1, 0); # no-op
64 @r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
66 @r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
67 check_result('r7', 'rec8');
69 @r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
70 check_result('rec7', 'record8', 'rec9');
71 @r = splice(@a, 1, 2); # delete more than one
72 check_result('record9','rec10');
74 # (23-32) splicing at the end
75 @r = splice(@a, 3, 0, "rec4");
77 @r = splice(@a, 3, 1, "rec5"); # same length
79 @r = splice(@a, 3, 1, "record5"); # longer
82 @r = splice(@a, 3, 1, "r5"); # shorter
83 check_result('record5');
84 @r = splice(@a, 3, 1); # removal
86 @r = splice(@a, 3, 0); # no-op
88 @r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
90 @r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
91 check_result('r7', 'rec8');
93 @r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
94 check_result('rec7', 'record8', 'rec9');
95 @r = splice(@a, 3, 2); # delete more than one
96 check_result('record9', 'rec10');
98 # (33-42) splicing with negative subscript
99 @r = splice(@a, -1, 0, "rec4");
101 @r = splice(@a, -1, 1, "rec5"); # same length
102 check_result('rec2');
103 @r = splice(@a, -1, 1, "record5"); # longer
104 check_result("rec5");
106 @r = splice(@a, -1, 1, "r5"); # shorter
107 check_result("record5");
108 @r = splice(@a, -1, 1); # removal
110 @r = splice(@a, -1, 0); # no-op
112 @r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
114 @r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
115 check_result('rec4');
117 @r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
118 check_result('rec7', 'record8', 'rec9');
119 @r = splice(@a, -4, 3); # delete more than one
120 check_result('r7', 'rec8', 'record9');
122 # (43) scrub it all out
123 @r = splice(@a, 0, 3);
124 check_result('rec0', 'rec1', 'rec10');
126 # (44) put some back in
127 @r = splice(@a, 0, 0, "rec0", "rec1");
130 # (45) what if we remove too many records?
131 @r = splice(@a, 0, 17);
132 check_result('rec0', 'rec1');
134 # (46-48) Now check the scalar context return
135 splice(@a, 0, 0, qw(I like pie));
137 $r = splice(@a, 0, 0);
138 print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef\n";
141 $r = splice(@a, 2, 1);
142 print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n";
145 $r = splice(@a, 0, 2);
146 print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n";
149 # (49-50) Test default arguments
150 splice @a, 0, 0, (0..11);
158 open F, "> $file" or die $!;
164 # actual results are in @r.
165 # expected results are in @_
170 $good = 0 unless @r == @x;
171 for my $i (0 .. $#r) {
172 $good = 0 unless $r[$i] eq $x[$i];
174 print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
181 1 while unlink $file;