t/lib/b-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..14\n";
  19
  20 my $test = 1;
  21
  22 sub ok { print "ok $test\n"; $test++ }
  23
  24
  25 use B::Deparse;
  26 my $deparse = B::Deparse->new() or print "not ";
  27 ok;
  28
  29 # Tell B::Deparse about our ambient pragmas
  30 { my ($hint_bits, $warning_bits);
  31  BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
  32  $deparse->ambient_pragmas (
  33      hint_bits    => $hint_bits,
  34      warning_bits => $warning_bits,
  35      '$['         => 0 + $[
  36  );
  37 }
  38
  39 print "not " if "{\n    1;\n}" ne $deparse->coderef2text(sub {1});
  40 ok;
  41
  42 print "not " if "{\n    '???';\n    2;\n}" ne
  43                     $deparse->coderef2text(sub {1;2});
  44 ok;
  45
  46 print "not " if "{\n    \$test /= 2 if ++\$test;\n}" ne
  47                     $deparse->coderef2text(sub {++$test and $test/=2;});
  48 ok;
  49
  50 print "not " if "{\n    -((1, 2) x 2);\n}" ne
  51                     $deparse->coderef2text(sub {-((1,2)x2)});
  52 ok;
  53
  54 {
  55 my $a = <<'EOF';
  56 {
  57     $test = sub : lvalue {
  58         my $x;
  59     }
  60     ;
  61 }
  62 EOF
  63 chomp $a;
  64 print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
  65 ok;
  66
  67 $a =~ s/lvalue/method/;
  68 print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
  69 ok;
  70
  71 $a =~ s/method/locked method/;
  72 print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
  73                                      ne $a;
  74 ok;
  75 }
  76
  77 print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
  78 ok;
  79
  80 use constant 'c', 'stuff';
  81 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
  82 ok;
  83
  84 $a = 0;
  85 print "not " if "{\n    (-1) ** \$a;\n}"
  86                 ne $deparse->coderef2text(sub{(-1) ** $a });
  87 ok;
  88
  89 # XXX ToDo - constsub that returns a reference
  90 #use constant cr => ['hello'];
  91 #my $string = "sub " . $deparse->coderef2text(\&cr);
  92 #my $val = (eval $string)->();
  93 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
  94 #ok;
  95
  96 my $a;
  97 my $Is_VMS = $^O eq 'VMS';
  98 my $Is_MacOS = $^O eq 'MacOS';
  99
 100 my $path = join " ", map { qq["-I$_"] } @INC;
 101 my $redir = $Is_MacOS ? "" : "2>&1";
 102
 103 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
 104 $a =~ s/-e syntax OK\n//g;
 105 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 106 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 107 $b = <<'EOF';
 108
 109 LINE: while (defined($_ = <ARGV>)) {
 110     chomp $_;
 111     @F = split(" ", $_, 0);
 112     '???';
 113 }
 114
 115 EOF
 116 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
 117 ok;
 118
 119
 120 # Bug 20001204.07
 121 {
 122 my $foo = $deparse->coderef2text(sub { { 234; }});
 123 # Constants don't get optimised here.
 124 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
 125 ok;
 126 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
 127 unless ($foo =~ /{\s*{\s*234;\s*}\s*continue\s*{\s*123;\s*}/sm) {
 128   print "# [$foo]\n\# vs expected\n# [sub { { 234; } continue { 123; } }]\n";
 129   print "not ";
 130 }
 131 ok;
 132 }