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");
  18     is("@$x","x");
  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");
  26     is("@$y","a b c y");
  27 }
  28
  29 sub new3 { goto &new1 }
  30 {
  31     my $x = new3("x");
  32     my $y = new3("y");
  33     is("@$y","y");
  34     is("@$x","x");
  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");
  42     is("@$y","a b c y");
  43 }
  44
  45 # see if 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 sub try {
  58     eval { method('foo', 'bar'); };
  59     print "# $@" if $@;
  60 }
  61
  62 for (1..5) { try() }
  63 pass();
  64
  65 # bug #21542 local $_[0] causes reify problems and coredumps
  66
  67 sub local1 { local $_[0] }
  68 my $foo = 'foo'; local1($foo); local1($foo);
  69 print "got [$foo], expected [foo]\nnot " if $foo ne 'foo';
  70 pass();
  71
  72 sub local2 { local $_[0]; last L }
  73 L: { local2 }
  74 pass();
  75
  76 # the following test for local(@_) used to be in t/op/nothr5005.t (because it
  77 # failed with 5005threads)
  78
  79 $|=1;
  80
  81 sub foo { local(@_) = ('p', 'q', 'r'); }
  82 sub bar { unshift @_, 'D'; @_ }
  83 sub baz { push @_, 'E'; return @_ }
  84 for (1..3) {
  85     is(join('',foo('a', 'b', 'c')),'pqr');
  86     is(join('',bar('d')),'Dd');
  87     is(join('',baz('e')),'eE');
  88 }
  89
  90 # [perl #28032] delete $_[0] was freeing things too early
  91
  92 {
  93     my $flag = 0;
  94     sub X::DESTROY { $flag = 1 }
  95     sub f {
  96         delete $_[0];
  97         ok(!$flag, 'delete $_[0] : in f');
  98     }
  99     {
 100         my $x = bless [], 'X';
 101         f($x);
 102         ok(!$flag, 'delete $_[0] : after f');
 103     }
 104     ok($flag, 'delete $_[0] : outside block');
 105 }
 106
 107