1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7}
8
9$|  = 1;
10
11@a = (1..10);
12
13sub j { join(":",@_) }
14
15is( j(splice(@a,@a,0,11,12)), '', 'return value of splice when nothing is removed, only added');
16is( j(@a), j(1..12), '... added two elements');
17
18is( j(splice(@a,-1)), "12", 'remove last element, return value');
19is( j(@a), j(1..11), '... removed last element');
20
21is( j(splice(@a,0,1)), "1", 'remove first element, return value');
22is( j(@a), j(2..11), '... first element removed');
23
24is( j(splice(@a,0,0,0,1)), "", 'emulate shift, return value is empty');
25is( j(@a), j(0..11), '... added two elements to beginning of the list');
26
27is( j(splice(@a,5,1,5)), "5", 'remove and replace an element to the end of the list, return value is the element');
28is( j(@a), j(0..11), '... list remains the same');
29
30is( j(splice(@a, @a, 0, 12, 13)), "", 'push two elements onto the end of the list, return value is empty');
31is( j(@a), j(0..13), '... added two elements to the end of the list');
32
33is( j(splice(@a, -@a, @a, 1, 2, 3)), j(0..13), 'splice the whole list out, add 3 elements, return value is @a');
34is( j(@a), j(1..3), '... array only contains new elements');
35
36is( j(splice(@a, 1, -1, 7, 7)), "2", 'replace middle element with two elements, negative offset, return value is the element' );
37is( j(@a), j(1,7,7,3), '... array 1,7,7,3');
38
39is( j(splice(@a,-3,-2,2)), j(7), 'replace first 7 with a 2, negative offset, negative length, return value is 7');
40is( j(@a), j(1,2,7,3), '... array has 1,2,7,3');
41
42# Bug 20000223.001 (#2196) - no test for splice(@array).  Destructive test!
43is( j(splice(@a)), j(1,2,7,3), 'bare splice empties the array, return value is the array');
44is( j(@a),  '', 'array is empty');
45
46# Tests 11 and 12:
47# [ID 20010711.005 (#7265)] in Tie::Array, SPLICE ignores context, breaking SHIFT
48
49my $foo;
50
51@a = ('red', 'green', 'blue');
52$foo = splice @a, 1, 2;
53is( $foo, 'blue', 'remove a single element in scalar context');
54
55@a = ('red', 'green', 'blue');
56$foo = shift @a;
57is( $foo, 'red', 'do the same with shift');
58
59# Bug [perl #30568] - insertions of deleted elements
60@a = (1, 2, 3);
61splice( @a, 0, 3, $a[1], $a[0] );
62is( j(@a), j(2,1), 'splice and replace with indexes 1, 0');
63
64@a = (1, 2, 3);
65splice( @a, 0, 3 ,$a[0], $a[1] );
66is( j(@a), j(1,2), 'splice and replace with indexes 0, 1');
67
68@a = (1, 2, 3);
69splice( @a, 0, 3 ,$a[2], $a[1], $a[0] );
70is( j(@a), j(3,2,1), 'splice and replace with indexes 2, 1, 0');
71
72@a = (1, 2, 3);
73splice( @a, 0, 3, $a[0], $a[1], $a[2], $a[0], $a[1], $a[2] );
74is( j(@a), j(1,2,3,1,2,3), 'splice and replace with a whole bunch');
75
76@a = (1, 2, 3);
77splice( @a, 1, 2, $a[2], $a[1] );
78is( j(@a), j(1,3,2), 'swap last two elements');
79
80@a = (1, 2, 3);
81splice( @a, 1, 2, $a[1], $a[1] );
82is( j(@a), j(1,2,2), 'duplicate middle element on the end');
83
84# splice should invoke get magic
85
86ok( ! Foo->isa('Bar'), 'Foo is not a Bar');
87
88splice @Foo::ISA, 0, 0, 'Bar';
89ok( Foo->isa('Bar'), 'splice @ISA and make Foo a Bar');
90
91# Test arrays with nonexistent elements (crashes when it fails)
92@a = ();
93$#a++;
94is sprintf("%s", splice @a, 0, 1), "",
95  'splice handles nonexistent elems when shrinking the array';
96@a = ();
97$#a++;
98is sprintf("%s", splice @a, 0, 1, undef), "",
99  'splice handles nonexistent elems when array len stays the same';
100
101# RT#131000
102{
103    local $@;
104    my @readonly_array = 10..11;
105    Internals::SvREADONLY(@readonly_array, 1);
106    eval { splice @readonly_array, 1, 0, () };
107    like $@, qr/^Modification of a read-only value/,
108        "croak when splicing into readonly array";
109}
110
111# GH#18667 - av_extend_guts must zero duplicate SV*s
112fresh_perl_is('my @data = (undef) x 4; splice @data, 1, 1;
113    splice @data, 2, 1; $data[3] = undef; splice @data, 3, 1;',
114    '', {}, 'GH#18667 - av_extend_guts must zero duplicate SV*s');
115
116
117done_testing;
118