t/op/sub.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan( tests => 34 );
  10
  11 sub empty_sub {}
  12
  13 is(empty_sub,undef,"Is empty");
  14 is(empty_sub(1,2,3),undef,"Is still empty");
  15 @test = empty_sub();
  16 is(scalar(@test), 0, 'Didnt return anything');
  17 @test = empty_sub(1,2,3);
  18 is(scalar(@test), 0, 'Didnt return anything');
  19
  20 # RT #63790:  calling PL_sv_yes as a sub is special-cased to silently
  21 # return (so Foo->import() silently fails if import() doesn't exist),
  22 # But make sure it correctly pops the stack and mark stack before returning.
  23
  24 {
  25     my @a;
  26     push @a, 4, 5, main->import(6,7);
  27     ok(eq_array(\@a, [4,5]), "import with args");
  28
  29     @a = ();
  30     push @a, 14, 15, main->import;
  31     ok(eq_array(\@a, [14,15]), "import without args");
  32
  33     my $x = 1;
  34
  35     @a = ();
  36     push @a, 24, 25, &{$x == $x}(26,27);
  37     ok(eq_array(\@a, [24,25]), "yes with args");
  38
  39     @a = ();
  40     push @a, 34, 35, &{$x == $x};
  41     ok(eq_array(\@a, [34,35]), "yes without args");
  42 }
  43
  44 # [perl #81944] return should always copy
  45 {
  46     $foo{bar} = 7;
  47     for my $x ($foo{bar}) {
  48         # Pity test.pl doesnt have isn't.
  49         isnt \sub { delete $foo{bar} }->(), \$x,
  50            'result of delete(helem) is copied when returned';
  51     }
  52     $foo{bar} = 7;
  53     for my $x ($foo{bar}) {
  54         isnt \sub { return delete $foo{bar} }->(), \$x,
  55            'result of delete(helem) is copied when explicitly returned';
  56     }
  57     my $x;
  58     isnt \sub { delete $_[0] }->($x), \$x,
  59       'result of delete(aelem) is copied when returned';
  60     isnt \sub { return delete $_[0] }->($x), \$x,
  61       'result of delete(aelem) is copied when explicitly returned';
  62     isnt \sub { ()=\@_; shift }->($x), \$x,
  63       'result of shift is copied when returned';
  64     isnt \sub { ()=\@_; return shift }->($x), \$x,
  65       'result of shift is copied when explicitly returned';
  66 }
  67
  68 fresh_perl_is
  69   <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
  70 *foo = \&baz;
  71 *bar = *foo;
  72 eval 'sub bar { print +(caller 0)[3], "\n" }';
  73 bar();
  74 end
  75
  76 fresh_perl_is
  77   <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
  78 my $sub = sub { 4 };
  79 *foo = $sub;
  80 *bar = *foo;
  81 undef &$sub;
  82 eval 'sub bar { print +(caller 0)[3], "\n" }';
  83 &$sub;
  84 undef *foo;
  85 undef *bar;
  86 print "ok\n";
  87 end
  88
  89 # The outer call sets the scalar returned by ${\""}.${\""} to the current
  90 # package name.
  91 # The inner call sets it to "road".
  92 # Each call records the value twice, the outer call surrounding the inner
  93 # call.  In 5.10-5.18 under ithreads, what gets pushed is
  94 # qw(main road road road) because the inner call is clobbering the same
  95 # scalar.  If __PACKAGE__ is changed to "main", it works, the last element
  96 # becoming "main".
  97 my @scratch;
  98 sub a {
  99   for (${\""}.${\""}) {
 100     $_ = $_[0];
 101     push @scratch, $_;
 102     a("road",1) unless $_[1];
 103     push @scratch, $_;
 104   }
 105 }
 106 a(__PACKAGE__);
 107 require Config;
 108 is "@scratch", "main road road main",
 109    'recursive calls do not share shared-hash-key TARGs';
 110
 111 # Another test for the same bug, that does not rely on foreach.  It depends
 112 # on ref returning a shared hash key TARG.
 113 undef @scratch;
 114 sub b {
 115     my ($pack, $depth) = @_;
 116     my $o = bless[], $pack;
 117     $pack++;
 118     push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
 119 }
 120 b('n',0);
 121 is "@scratch", "o n",
 122    'recursive calls do not share shared-hash-key TARGs (2)';
 123
 124 # [perl #78194] @_ aliasing op return values
 125 sub { is \$_[0], \$_[0],
 126         '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
 127  ->("${\''}");
 128
 129 # The return statement should make no difference in this case:
 130 sub not_constant () {        42 }
 131 sub not_constantr() { return 42 }
 132 use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
 133 my sub not_constantm () {        42 }
 134 my sub not_constantmr() { return 42 }
 135 eval { ${\not_constant}++ };
 136 is $@, "", 'sub (){42} returns a mutable value';
 137 eval { ${\not_constantr}++ };
 138 is $@, "", 'sub (){ return 42 } returns a mutable value';
 139 eval { ${\not_constantm}++ };
 140 is $@, "", 'my sub (){42} returns a mutable value';
 141 eval { ${\not_constantmr}++ };
 142 is $@, "", 'my sub (){ return 42 } returns a mutable value';
 143 is eval {
 144     sub Crunchy () { 1 }
 145     sub Munchy { $_[0] = 2 }
 146     eval "Crunchy"; # test that freeing this op does not turn off PADTMP
 147     Munchy(Crunchy);
 148 } || $@, 2, 'freeing ops does not make sub(){42} immutable';
 149
 150 # [perl #79908]
 151 {
 152     my $x = 5;
 153     *_79908 = sub (){$x};
 154     $x = 7;
 155     TODO: {
 156         local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p";
 157         is eval "_79908", 7, 'sub(){$x} does not break closures';
 158     }
 159     isnt eval '\_79908', \$x, 'sub(){$x} returns a copy';
 160
 161     # Test another thing that was broken by $x inlinement
 162     my $y;
 163     no warnings 'once';
 164     local *time = sub():method{$y};
 165     my $w;
 166     local $SIG{__WARN__} = sub { $w .= shift };
 167     eval "()=time";
 168     TODO: {
 169         local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p";
 170         is $w, undef,
 171           '*keyword = sub():method{$y} does not cause ambiguity warnings';
 172     }
 173 }
 174
 175 # &xsub when @_ has nonexistent elements
 176 {
 177     no warnings "uninitialized";
 178     local @_ = ();
 179     $#_++;
 180     &utf8::encode;
 181     is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
 182     is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
 183 }
 184
 185 # &xsub when @_ itself does not exist
 186 undef *_;
 187 eval { &utf8::encode };
 188 # The main thing we are testing is that it did not crash.  But make sure
 189 # *_{ARRAY} was untouched, too.
 190 is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
 191
 192 # We do not want re.pm loaded at this point.  Move this test up or find
 193 # another XSUB if this fails.
 194 ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
 195 {
 196     sub re::regmust{}
 197     bless \&re::regmust;
 198     DESTROY {
 199         no warnings 'redefine', 'prototype';
 200         my $str1 = "$_[0]";
 201         *re::regmust = sub{}; # GvSV had no refcount, so this freed it
 202         my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
 203         @str = ($str1, $str2);
 204     }
 205     local $^W; # Suppress redef warnings in XSLoader
 206     require re;
 207     is $str[1], $str[0],
 208       'XSUB clobbering sub whose DESTROY assigns to the glob';
 209 }
 210 {
 211     no warnings 'redefine';
 212     sub foo {}
 213     bless \&foo, 'newATTRSUBbug';
 214     sub newATTRSUBbug::DESTROY {
 215         my $str1 = "$_[0]";
 216         *foo = sub{}; # GvSV had no refcount, so this freed it
 217         my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
 218         @str = ($str1, $str2);
 219     }
 220     splice @str;
 221     eval "sub foo{}";
 222     is $str[1], $str[0],
 223       'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
 224 }
 225
 226 # [perl #122107] previously this would return
 227 #  Subroutine BEGIN redefined at (eval 2) line 2.
 228 fresh_perl_is(<<'EOS', "", { stderr => 1 },
 229 use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
 230 EOS
 231                "check special blocks are cleared on error");