t/20-deparse.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use blib 't/Sub-Op-LexicalSub';
   7
   8 use Test::More tests => 13;
   9
  10 use Devel::Peek;
  11 use B::Deparse;
  12
  13 my $bd = B::Deparse->new;
  14
  15 $bd->ambient_pragmas(
  16  strict   => 'all',
  17  warnings => 'all',
  18 );
  19
  20 {
  21  local $/ = "####\n";
  22  while (<DATA>) {
  23   chomp;
  24   s/\s*$//;
  25   my $code = $_;
  26
  27   my $test = eval <<"  TESTCASE";
  28    sub {
  29     use Sub::Op::LexicalSub f => sub { };
  30     use Sub::Op::LexicalSub g => sub { };
  31     $code
  32    }
  33   TESTCASE
  34   if ($@) {
  35    fail "unable to compile testcase: $@";
  36    next;
  37   }
  38   my $deparsed = $bd->coderef2text($test);
  39   $deparsed =~ s[BEGIN \s* \{ \s* \$\^H \s* \{ .*? \} .*? \} \s*][]gxs;
  40
  41   my $expected = do {
  42    local *f = sub { };
  43    local *g = sub { };
  44    f(); g(); # silence 'once' warnings without setting the bits
  45    my $exp = eval <<"   EXPECTED";
  46     sub {
  47      $code
  48     }
  49    EXPECTED
  50    if ($@) {
  51     fail "unable to compile expected code: $@";
  52     next;
  53    }
  54    $bd->coderef2text($exp);
  55   };
  56
  57   is $deparsed, $expected, "deparsed <$code> is as expected";
  58  }
  59 }
  60
  61 __DATA__
  62 f();
  63 ####
  64 f;
  65 ####
  66 f(1);
  67 ####
  68 f 1;
  69 ####
  70 f(1, 2);
  71 ####
  72 f 1, 2;
  73 ####
  74 f(1); g(2);
  75 ####
  76 f 1, f(2), 3, g(4, f(g, 5), 6);
  77 ####
  78 &f;
  79 ####
  80 &f();
  81 ####
  82 &f(1);
  83 ####
  84 &f(1, 2);
  85 ####
  86 my $x = \&f;