t/op/sub.t

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