t/op/opt.t

   1 #!./perl
   2
   3 # Use B to test that optimisations are not inadvertently removed.
   4
   5 BEGIN {
   6     chdir 't';
   7     require './test.pl';
   8     skip_all_if_miniperl("No B under miniperl");
   9     @INC = '../lib';
  10 }
  11
  12 plan 18;
  13
  14 use B qw 'svref_2object OPpASSIGN_COMMON';
  15
  16
  17 # aassign with no common vars
  18 {
  19     my $last_expr =
  20       svref_2object(sub { my($self) = @_ })->ROOT->first->last;
  21     if ($last_expr->name ne 'aassign') {
  22         die "Expected aassign but found ", $last_expr->name,
  23             "; this test needs to be rewritten"
  24     }
  25     is $last_expr->private & OPpASSIGN_COMMON, 0,
  26       'no ASSIGN_COMMON for my($self) = @_';
  27 }
  28
  29
  30 # join -> stringify/const
  31
  32 for (['CONSTANT', sub {          join "foo", $_ }],
  33      ['$var'    , sub {          join  $_  , $_ }],
  34      ['$myvar'  , sub { my $var; join  $var, $_ }],
  35 ) {
  36     my($sep,$sub) = @$_;
  37     my $last_expr = svref_2object($sub)->ROOT->first->last;
  38     is $last_expr->name, 'stringify',
  39       "join($sep, \$scalar) optimised to stringify";
  40 }
  41
  42 for (['CONSTANT', sub {          join "foo", "bar"    }, 0, "bar"    ],
  43      ['CONSTANT', sub {          join "foo", "bar", 3 }, 1, "barfoo3"],
  44      ['$var'    , sub {          join  $_  , "bar"    }, 0, "bar"    ],
  45      ['$myvar'  , sub { my $var; join  $var, "bar"    }, 0, "bar"    ],
  46 ) {
  47     my($sep,$sub,$is_list,$expect) = @$_;
  48     my $last_expr = svref_2object($sub)->ROOT->first->last;
  49     my $tn = "join($sep, " . ($is_list?'list of constants':'const') . ")";
  50     is $last_expr->name, 'const', "$tn optimised to constant";
  51     is $sub->(), $expect, "$tn folded correctly";
  52 }
  53
  54
  55 # split to array
  56
  57 for(['@pkgary'      , '@_'       ],
  58     ['@lexary'      , 'my @a; @a'],
  59     ['my(@array)'   , 'my(@a)'   ],
  60     ['local(@array)', 'local(@_)'],
  61     ['@{...}'       , '@{\@_}'   ],
  62 ){
  63     my($tn,$code) = @$_;
  64     my $sub = eval "sub { $code = split }";
  65     my $split = svref_2object($sub)->ROOT->first->last;
  66     is $split->name, 'split', "$tn = split swallows up the assignment";
  67 }
  68
  69
  70 # stringify with join kid --> join
  71 is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join',
  72   'qq"@_" optimised from stringify(join(...)) to join(...)';