t/op/const-optree.t

   1 #!perl
   2
   3 # Test the various op trees that turn sub () { ... } into a constant, and
   4 # some variants that don’t.
   5
   6 BEGIN {
   7     chdir 't';
   8     require './test.pl';
   9     @INC = '../lib';
  10 }
  11 plan 31;
  12
  13 # @tests is an array of hash refs, each of which can have various keys:
  14 #
  15 #   nickname    - name of the sub to use in test names
  16 #   generator   - a sub returning a code ref to test
  17 #   finally     - sub to run after the other tests
  18 #
  19 # Each of the following gives expected test results.  If the key is
  20 # omitted, the test is skipped:
  21 #
  22 #   retval      - the returned code ref’s return value
  23 #   same_retval - whether the same scalar is returned each time
  24 #   inlinable   - whether the sub is inlinable
  25 #   deprecated  - whether the sub returning a code ref will emit a depreca-
  26 #                 tion warning when called
  27 #   method      - whether the sub has the :method attribute
  28
  29 # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
  30 sub blonk { ++$blonk_was_called }
  31 push @tests, {
  32   nickname    => 'sub with null+kids (if-block), then constant',
  33   generator   => sub {
  34     # This used to turn into a constant with the value of $x
  35     my $x = 7;
  36     sub() { if($x){ () = "tralala"; blonk() }; 0 }
  37   },
  38   retval      => 0,
  39   same_retval => 0,
  40   inlinable   => 0,
  41   deprecated  => 0,
  42   method      => 0,
  43   finally     => sub { ok($blonk_was_called, 'RT #63540'); },
  44 };
  45
  46 # [perl #79908]
  47 push @tests, {
  48   nickname    => 'sub with simple lexical modified elsewhere',
  49   generator   => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
  50   retval      => 5, # change to 7 when the deprecation cycle is over
  51   same_retval => 0,
  52   inlinable   => 1,
  53   deprecated  => 1,
  54   method      => 0,
  55 };
  56
  57 push @tests, {
  58   nickname    => 'sub () { 0; $x } with $x modified elsewhere',
  59   generator   => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret },
  60   retval      => 8,
  61   same_retval => 0,
  62   inlinable   => 0,
  63   deprecated  => 0,
  64   method      => 0,
  65 };
  66
  67 push @tests, {
  68   nickname    => 'sub () { 0; $x } with $x unmodified elsewhere',
  69   generator   => sub { my $x = 5; my $y = $x; sub(){0;$x} },
  70   retval      => 5,
  71   same_retval => 0,
  72   inlinable   => 1,
  73   deprecated  => 0,
  74   method      => 0,
  75 };
  76
  77 use feature 'state', 'lexical_subs';
  78 no warnings 'experimental::lexical_subs';
  79
  80 push @tests, {
  81   nickname    => 'sub () { my $x; state sub z { $x } $outer }',
  82   generator   => sub {
  83     my $outer = 43;
  84     sub () { my $x; state sub z { $x } $outer }
  85   },
  86   retval      => 43,
  87   same_retval => 0,
  88   inlinable   => 0,
  89   deprecated  => 0,
  90   method      => 0,
  91 };
  92
  93 push @tests, {
  94   nickname    => 'sub:method with simple lexical',
  95   generator   => sub { my $y; sub():method{$y} },
  96   retval      => undef,
  97   same_retval => 0,
  98   inlinable   => 1,
  99   deprecated  => 0,
 100   method      => 1,
 101 };
 102
 103
 104 use feature 'refaliasing';
 105 no warnings 'experimental::refaliasing';
 106 for \%_ (@tests) {
 107     my $nickname = $_{nickname};
 108     my $w;
 109     local $SIG{__WARN__} = sub { $w = shift };
 110     my $sub = &{$_{generator}};
 111     if (exists $_{deprecated}) {
 112         if ($_{deprecated}) {
 113             like $w, qr/^Constants from lexical variables potentially (?x:
 114                        )modified elsewhere are deprecated at /,
 115                 "$nickname is deprecated";
 116         }
 117         else {
 118             is $w, undef, "$nickname is not deprecated";
 119         }
 120     }
 121     if (exists $_{retval}) {
 122         is &$sub, $_{retval}, "retval of $nickname";
 123     }
 124     if (exists $_{same_retval}) {
 125         my $same = $_{same_retval} ? "same" : "different";
 126         &{$_{same_retval} ? \&is : \&isnt}(
 127             \scalar &$sub(), \scalar &$sub(),
 128             "$nickname gives $same retval each call"
 129         );
 130     }
 131     if (exists $_{inlinable}) {
 132         local *temp_inlinability_test = $sub;
 133         $w = undef;
 134         use warnings 'redefine';
 135         *temp_inlinability_test = sub (){};
 136         my $S = $_{inlinable} ? "Constant s" : "S";
 137         my $not = " not" x! $_{inlinable};
 138         like $w, qr/^${S}ubroutine .* redefined at /,
 139                 "$nickname is$not inlinable";
 140     }
 141     if (exists $_{method}) {
 142         local *time = $sub;
 143         $w = undef;
 144         use warnings 'ambiguous';
 145         eval "()=time";
 146         if ($_{method}) {
 147             is $w, undef, "$nickname has :method attribute";
 148         }
 149         else {
 150             like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x:
 151                         )qualify as such or use & at /,
 152                 "$nickname has no :method attribute";
 153         }
 154     }
 155
 156     &{$_{finally} or next}
 157 }