view release on metacpan or  search on metacpan

t/70infix.t  view on Meta::CPAN

      return $ret;
   };

   # Reach inside to the first statement
   return B::svref_2object( $sub )->ROOT->first->first->sibling
      ->$dump_optree;
}

sub is_optree
{
   my ( $sub, $exp, $name ) = @_;
   is( _getoptree( $sub ), $exp, $name );
}

{
   is_optree sub { $_[0] add $_[1] },
      "infix_add_0xXXX[aelemfast, aelemfast]",
      'optree of call to infix operator';

   # Check precedence of operator parsing by observing the following precedence
   # ordering:
   #   <--High      Low-->
   #      **  *  +  &&

   is_optree sub { $_[0] * $_[1] add $_[2] * $_[3] },
      "infix_add_0xXXX[multiply[aelemfast, aelemfast], multiply[aelemfast, aelemfast]]",
      'optree binds add lower than *';
   is_optree sub { $_[0] + $_[1] add $_[2] + $_[3] },
      "add[infix_add_0xXXX[add[aelemfast, aelemfast], aelemfast], aelemfast]",
      'optree binds add equal to +';
   is_optree sub { $_[0] && $_[1] add $_[2] && $_[3] },
      "and[and[aelemfast, infix_add_0xXXX[aelemfast, aelemfast]], aelemfast]",
      'optree binds add higher than &&';

   is_optree sub { $_[0] ** $_[1] mul $_[2] ** $_[3] },
      "infix_mul_0xXXX[pow[aelemfast, aelemfast], pow[aelemfast, aelemfast]]",
      'optree binds mul lower than **';
   is_optree sub { $_[0] * $_[1] mul $_[2] * $_[3] },
      "multiply[infix_mul_0xXXX[multiply[aelemfast, aelemfast], aelemfast], aelemfast]",
      'optree binds mul equal to *';
   is_optree sub { $_[0] + $_[1] mul $_[2] + $_[3] },
      "add[add[aelemfast, infix_mul_0xXXX[aelemfast, aelemfast]], aelemfast]",
      'optree binds mul higher than +';

   is_optree sub { $_[0] * ($_[1] add $_[2]) * $_[3] },
      "multiply[multiply[aelemfast, infix_add_0xXXX[aelemfast, aelemfast]], aelemfast]",
      'optree of call to infix operator at forced precedence';
}

sub is_deparsed
{
   my ( $sub, $exp, $name ) = @_;

   my $got = $deparser->coderef2text( $sub );

   # Deparsed output is '{ ... }'-wrapped
   $got = ( $got =~ m/^{\n(.*)\n}$/s )[0];

   # Deparsed output will have a lot of pragmata and so on; just grab the
   # final line
   $got = ( split m/\n/, $got )[-1];
   $got =~ s/^\s+//;

   is( $got, $exp, $name );
}

{
   is_deparsed sub { $_[0] add $_[1] },
      '$_[0] add $_[1];',
      'deparsed call to infix add operator';

   is_deparsed sub { $_[0] * $_[1] add $_[2] * $_[3] },
      '($_[0] * $_[1]) add ($_[2] * $_[3]);',
      'deparsed call to infix add operator at default precedence';

   is_deparsed sub { $_[0] ⊕ $_[1] },
      '$_[0] ⊕ $_[1];',
      'deparsed operator yields UTF-8';

   is_deparsed sub { "+" intersperse (1,2,3) },
      q['+' intersperse (1, 2, 3);],
      'deparsed call to infix operator with list RHS';

   is_deparsed sub { (1,2,3) addpairs (4,5,6) },
      '(1, 2, 3) addpairs (4, 5, 6);',
      'deparsed call to infix list/list operator';
}

# list-associative operator
{
   is( "a" cat "b" cat "c", "^abc^",
      'cat operator runs correctly' );

   is_optree sub { "a" cat "b" cat "c" },
      "infix_cat_0xXXX[const, const, const]",
      'optree of list-associative cat operator';

   is_optree sub { ( "a" cat "b" ) cat "c" },
      "infix_cat_0xXXX[infix_cat_0xXXX[const, const], const]",
      'parens on LHS defeat list-associativity';
   is_optree sub { "a" cat ( "b" cat "c" ) },
      "infix_cat_0xXXX[const, infix_cat_0xXXX[const, const]]",
      'parens on RHS defeat list-associativity';

   is_deparsed sub { "a" cat "b" cat "c" },
      q['a' cat 'b' cat 'c';],
      'deparsed list-associative cat operator';
}

done_testing;