t/op/args.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 require './test.pl';
   9 plan( tests => 23 );
  10
  11 # test various operations on @_
  12
  13 sub new1 { bless \@_ }
  14 {
  15     my $x = new1("x");
  16     my $y = new1("y");
  17     is("@$y","y", 'bless');
  18     is("@$x","x", 'bless');
  19 }
  20
  21 sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ }
  22 {
  23     my $x = new2("x");
  24     my $y = new2("y");
  25     is("@$x","a b c x", 'splice');
  26     is("@$y","a b c y", 'splice');
  27 }
  28
  29 sub new3 { goto &new1 }
  30 {
  31     my $x = new3("x");
  32     my $y = new3("y");
  33     is("@$y","y", 'goto: single element');
  34     is("@$x","x", 'goto: single element');
  35 }
  36
  37 sub new4 { goto &new2 }
  38 {
  39     my $x = new4("x");
  40     my $y = new4("y");
  41     is("@$x","a b c x", 'goto: multiple elements');
  42     is("@$y","a b c y", 'goto: multiple elements');
  43 }
  44
  45 # see if cx_popsub() gets to see the right pad across a dounwind() with
  46 # a reified @_
  47
  48 sub methimpl {
  49     my $refarg = \@_;
  50     die( "got: @_\n" );
  51 }
  52
  53 sub method {
  54     &methimpl;
  55 }
  56
  57 my $failcount = 0;
  58 sub try {
  59     eval { method('foo', 'bar'); };
  60     print "# $@" if $@;
  61     $failcount++;
  62 }
  63
  64 for (1..5) { try() }
  65 is($failcount, 5,
  66     'cx_popsub sees right pad across a dounwind() with reified @_');
  67
  68 # bug #21542 local $_[0] causes reify problems and coredumps
  69
  70 sub local1 { local $_[0] }
  71 my $foo = 'foo'; local1($foo); local1($foo);
  72 is($foo, 'foo',
  73     "got 'foo' as expected rather than '\$foo': RT \#21542");
  74
  75 sub local2 { local $_[0]; last L }
  76 L: { local2 }
  77 pass("last to label");
  78
  79 # the following test for local(@_) used to be in t/op/nothr5005.t (because it
  80 # failed with 5005threads)
  81
  82 $|=1;
  83
  84 sub foo { local(@_) = ('p', 'q', 'r'); }
  85 sub bar { unshift @_, 'D'; @_ }
  86 sub baz { push @_, 'E'; return @_ }
  87 for (1..3) {
  88     is(join('',foo('a', 'b', 'c')),'pqr', 'local @_');
  89     is(join('',bar('d')),'Dd', 'unshift @_');
  90     is(join('',baz('e')),'eE', 'push @_');
  91 }
  92
  93 # [perl #28032] delete $_[0] was freeing things too early
  94
  95 {
  96     my $flag = 0;
  97     sub X::DESTROY { $flag = 1 }
  98     sub f {
  99         delete $_[0];
 100         ok(!$flag, 'delete $_[0] : in f');
 101     }
 102     {
 103         my $x = bless [], 'X';
 104         f($x);
 105         ok(!$flag, 'delete $_[0] : after f');
 106     }
 107     ok($flag, 'delete $_[0] : outside block');
 108 }
 109
 110