t/op/splice.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   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 - 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] 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 undef first arg
  92 eval { no warnings 'experimental';splice( $new_arrayref, 0, 0, 1, 2, 3 ) };
  93 like($@, qr/Not an ARRAY/, 'undefined first argument to splice');
  94
  95 # Test arrays with nonexistent elements (crashes when it fails)
  96 @a = ();
  97 $#a++;
  98 is sprintf("%s", splice @a, 0, 1), "",
  99   'splice handles nonexistent elems when shrinking the array';
 100 @a = ();
 101 $#a++;
 102 is sprintf("%s", splice @a, 0, 1, undef), "",
 103   'splice handles nonexistent elems when array len stays the same';
 104
 105 done_testing;