ext/B/t/deparse.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     if ($^O eq 'MacOS') {
   6         @INC = qw(: ::lib ::macos:lib);
   7     } else {
   8         @INC = '.';
   9         push @INC, '../lib';
  10     }
  11 }
  12
  13 $|  = 1;
  14 use warnings;
  15 use strict;
  16 use Config;
  17
  18 print "1..18\n";
  19
  20 use B::Deparse;
  21 my $deparse = B::Deparse->new() or print "not ";
  22 my $i=1;
  23 print "ok " . $i++ . "\n";
  24
  25
  26 # Tell B::Deparse about our ambient pragmas
  27 { my ($hint_bits, $warning_bits);
  28  BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
  29  $deparse->ambient_pragmas (
  30      hint_bits    => $hint_bits,
  31      warning_bits => $warning_bits,
  32      '$['         => 0 + $[
  33  );
  34 }
  35
  36 $/ = "\n####\n";
  37 while (<DATA>) {
  38     chomp;
  39     s/#.*$//mg;
  40
  41     my ($input, $expected);
  42     if (/(.*)\n>>>>\n(.*)/s) {
  43         ($input, $expected) = ($1, $2);
  44     }
  45     else {
  46         ($input, $expected) = ($_, $_);
  47     }
  48
  49     my $coderef = eval "sub {$input}";
  50
  51     if ($@) {
  52         print "not ok " . $i++ . "\n";
  53         print "# $@";
  54     }
  55     else {
  56         my $deparsed = $deparse->coderef2text( $coderef );
  57         my $regex = quotemeta($expected);
  58         do {
  59             no warnings 'misc';
  60             $regex =~ s/\s+/\s+/g;
  61         };
  62
  63         my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
  64         print (($ok ? "ok " : "not ok ") . $i++ . "\n");
  65         if (!$ok) {
  66             print "# EXPECTED:\n";
  67             $regex =~ s/^/# /mg;
  68             print "$regex\n";
  69
  70             print "\n# GOT: \n";
  71             $deparsed =~ s/^/# /mg;
  72             print "$deparsed\n";
  73         }
  74     }
  75 }
  76
  77 use constant 'c', 'stuff';
  78 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
  79 print "ok " . $i++ . "\n";
  80
  81 $a = 0;
  82 print "not " if "{\n    (-1) ** \$a;\n}"
  83                 ne $deparse->coderef2text(sub{(-1) ** $a });
  84 print "ok " . $i++ . "\n";
  85
  86 # XXX ToDo - constsub that returns a reference
  87 #use constant cr => ['hello'];
  88 #my $string = "sub " . $deparse->coderef2text(\&cr);
  89 #my $val = (eval $string)->();
  90 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
  91 #print "ok " . $i++ . "\n";
  92
  93 my $a;
  94 my $Is_VMS = $^O eq 'VMS';
  95 my $Is_MacOS = $^O eq 'MacOS';
  96
  97 my $path = join " ", map { qq["-I$_"] } @INC;
  98 $path .= " -MMac::err=unix" if $Is_MacOS;
  99 my $redir = $Is_MacOS ? "" : "2>&1";
 100
 101 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
 102 $a =~ s/-e syntax OK\n//g;
 103 $a =~ s/.*possible typo.*\n//;     # Remove warning line
 104 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 105 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 106 $b = <<'EOF';
 107 BEGIN { $^I = ".bak"; }
 108 BEGIN { $^W = 1; }
 109 BEGIN { $/ = "\n"; $\ = "\n"; }
 110 LINE: while (defined($_ = <ARGV>)) {
 111     chomp $_;
 112     our(@F) = split(" ", $_, 0);
 113     '???';
 114 }
 115 EOF
 116 $b =~ s/(LINE:)/sub BEGIN {
 117     'MacPerl'->bootstrap;
 118     'OSA'->bootstrap;
 119     'XL'->bootstrap;
 120 }
 121 $1/ if $Is_MacOS;
 122 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
 123 print "ok " . $i++ . "\n";
 124
 125 __DATA__
 126 # 2
 127 1;
 128 ####
 129 # 3
 130 {
 131     no warnings;
 132     '???';
 133     2;
 134 }
 135 ####
 136 # 4
 137 my $test;
 138 ++$test and $test /= 2;
 139 >>>>
 140 my $test;
 141 $test /= 2 if ++$test;
 142 ####
 143 # 5
 144 -((1, 2) x 2);
 145 ####
 146 # 6
 147 {
 148     my $test = sub : lvalue {
 149         my $x;
 150     }
 151     ;
 152 }
 153 ####
 154 # 7
 155 {
 156     my $test = sub : method {
 157         my $x;
 158     }
 159     ;
 160 }
 161 ####
 162 # 8
 163 {
 164     my $test = sub : locked method {
 165         my $x;
 166     }
 167     ;
 168 }
 169 ####
 170 # 9
 171 {
 172     234;
 173 }
 174 continue {
 175     123;
 176 }
 177 ####
 178 # 10
 179 my $x;
 180 print $main::x;
 181 ####
 182 # 11
 183 my @x;
 184 print $main::x[1];
 185 ####
 186 # 12
 187 my %x;
 188 $x{warn()};
 189 ####
 190 # 13
 191 my $foo;
 192 $_ .= <ARGV> . <$foo>;
 193 ####
 194 # 14
 195 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 196 ####
 197 # 15
 198 s/x/'y';/e;