| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 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 | |
| 13 | sub j { join(":",@_) } |
| 14 | |
| 15 | is( j(splice(@a,@a,0,11,12)), '', 'return value of splice when nothing is removed, only added'); |
| 16 | is( j(@a), j(1..12), '... added two elements'); |
| 17 | |
| 18 | is( j(splice(@a,-1)), "12", 'remove last element, return value'); |
| 19 | is( j(@a), j(1..11), '... removed last element'); |
| 20 | |
| 21 | is( j(splice(@a,0,1)), "1", 'remove first element, return value'); |
| 22 | is( j(@a), j(2..11), '... first element removed'); |
| 23 | |
| 24 | is( j(splice(@a,0,0,0,1)), "", 'emulate shift, return value is empty'); |
| 25 | is( j(@a), j(0..11), '... added two elements to beginning of the list'); |
| 26 | |
| 27 | is( j(splice(@a,5,1,5)), "5", 'remove and replace an element to the end of the list, return value is the element'); |
| 28 | is( j(@a), j(0..11), '... list remains the same'); |
| 29 | |
| 30 | is( j(splice(@a, @a, 0, 12, 13)), "", 'push two elements onto the end of the list, return value is empty'); |
| 31 | is( j(@a), j(0..13), '... added two elements to the end of the list'); |
| 32 | |
| 33 | is( j(splice(@a, -@a, @a, 1, 2, 3)), j(0..13), 'splice the whole list out, add 3 elements, return value is @a'); |
| 34 | is( j(@a), j(1..3), '... array only contains new elements'); |
| 35 | |
| 36 | is( j(splice(@a, 1, -1, 7, 7)), "2", 'replace middle element with two elements, negative offset, return value is the element' ); |
| 37 | is( j(@a), j(1,7,7,3), '... array 1,7,7,3'); |
| 38 | |
| 39 | is( j(splice(@a,-3,-2,2)), j(7), 'replace first 7 with a 2, negative offset, negative length, return value is 7'); |
| 40 | is( 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! |
| 43 | is( j(splice(@a)), j(1,2,7,3), 'bare splice empties the array, return value is the array'); |
| 44 | is( 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 | |
| 49 | my $foo; |
| 50 | |
| 51 | @a = ('red', 'green', 'blue'); |
| 52 | $foo = splice @a, 1, 2; |
| 53 | is( $foo, 'blue', 'remove a single element in scalar context'); |
| 54 | |
| 55 | @a = ('red', 'green', 'blue'); |
| 56 | $foo = shift @a; |
| 57 | is( $foo, 'red', 'do the same with shift'); |
| 58 | |
| 59 | # Bug [perl #30568] - insertions of deleted elements |
| 60 | @a = (1, 2, 3); |
| 61 | splice( @a, 0, 3, $a[1], $a[0] ); |
| 62 | is( j(@a), j(2,1), 'splice and replace with indexes 1, 0'); |
| 63 | |
| 64 | @a = (1, 2, 3); |
| 65 | splice( @a, 0, 3 ,$a[0], $a[1] ); |
| 66 | is( j(@a), j(1,2), 'splice and replace with indexes 0, 1'); |
| 67 | |
| 68 | @a = (1, 2, 3); |
| 69 | splice( @a, 0, 3 ,$a[2], $a[1], $a[0] ); |
| 70 | is( j(@a), j(3,2,1), 'splice and replace with indexes 2, 1, 0'); |
| 71 | |
| 72 | @a = (1, 2, 3); |
| 73 | splice( @a, 0, 3, $a[0], $a[1], $a[2], $a[0], $a[1], $a[2] ); |
| 74 | is( j(@a), j(1,2,3,1,2,3), 'splice and replace with a whole bunch'); |
| 75 | |
| 76 | @a = (1, 2, 3); |
| 77 | splice( @a, 1, 2, $a[2], $a[1] ); |
| 78 | is( j(@a), j(1,3,2), 'swap last two elements'); |
| 79 | |
| 80 | @a = (1, 2, 3); |
| 81 | splice( @a, 1, 2, $a[1], $a[1] ); |
| 82 | is( j(@a), j(1,2,2), 'duplicate middle element on the end'); |
| 83 | |
| 84 | # splice should invoke get magic |
| 85 | |
| 86 | ok( ! Foo->isa('Bar'), 'Foo is not a Bar'); |
| 87 | |
| 88 | splice @Foo::ISA, 0, 0, 'Bar'; |
| 89 | ok( 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++; |
| 94 | is sprintf("%s", splice @a, 0, 1), "", |
| 95 | 'splice handles nonexistent elems when shrinking the array'; |
| 96 | @a = (); |
| 97 | $#a++; |
| 98 | is 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 | done_testing; |