t/lib/b.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..19\n";
  19
  20 my $test = 1;
  21
  22 sub ok { print "ok $test\n"; $test++ }
  23
  24 use B::Deparse;
  25 my $deparse = B::Deparse->new() or print "not ";
  26 ok;
  27
  28 print "not " if "{\n    1;\n}" ne $deparse->coderef2text(sub {1});
  29 ok;
  30
  31 print "not " if "{\n    '???';\n    2;\n}" ne
  32                     $deparse->coderef2text(sub {1;2});
  33 ok;
  34
  35 print "not " if "{\n    \$test /= 2 if ++\$test;\n}" ne
  36                     $deparse->coderef2text(sub {++$test and $test/=2;});
  37 ok;
  38
  39 print "not " if "{\n    -((1, 2) x 2);\n}" ne
  40                     $deparse->coderef2text(sub {-((1,2)x2)});
  41 ok;
  42
  43 {
  44 my $a = <<'EOF';
  45 {
  46     $test = sub : lvalue {
  47         my $x;
  48     }
  49     ;
  50 }
  51 EOF
  52 chomp $a;
  53 print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
  54 ok;
  55
  56 $a =~ s/lvalue/method/;
  57 print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
  58 ok;
  59
  60 $a =~ s/method/locked method/;
  61 print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
  62                                      ne $a;
  63 ok;
  64 }
  65
  66 print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
  67 ok;
  68
  69 use constant 'c', 'stuff';
  70 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
  71 ok;
  72
  73 $a = 0;
  74 print "not " if "{\n    (-1) ** \$a;\n}"
  75                 ne $deparse->coderef2text(sub{(-1) ** $a });
  76 ok;
  77
  78 # XXX ToDo - constsub that returns a reference
  79 #use constant cr => ['hello'];
  80 #my $string = "sub " . $deparse->coderef2text(\&cr);
  81 #my $val = (eval $string)->();
  82 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
  83 #ok;
  84
  85 my $a;
  86 my $Is_VMS = $^O eq 'VMS';
  87 my $Is_MacOS = $^O eq 'MacOS';
  88
  89 my $path = join " ", map { qq["-I$_"] } @INC;
  90 my $redir = $Is_MacOS ? "" : "2>&1";
  91
  92 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
  93 $a =~ s/-e syntax OK\n//g;
  94 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
  95 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
  96 $b = <<'EOF';
  97
  98 LINE: while (defined($_ = <ARGV>)) {
  99     chomp $_;
 100     @F = split(/\s+/, $_, 0);
 101     '???';
 102 }
 103
 104 EOF
 105 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
 106 ok;
 107
 108 $a = `$^X $path "-MO=Debug" -e 1 $redir`;
 109 print "not " unless $a =~
 110 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
 111 ok;
 112
 113 $a = `$^X $path "-MO=Terse" -e 1 $redir`;
 114 print "not " unless $a =~
 115 /\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s;
 116 ok;
 117
 118 $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
 119 $a =~ s/\(0x[^)]+\)//g;
 120 $a =~ s/\[[^\]]+\]//g;
 121 $a =~ s/-e syntax OK//;
 122 $a =~ s/[^a-z ]+//g;
 123 $a =~ s/\s+/ /g;
 124 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
 125 $a =~ s/^\s+//;
 126 $a =~ s/\s+$//;
 127 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
 128 if ($is_thread) {
 129     $b=<<EOF;
 130 leave enter nextstate label leaveloop enterloop null and defined null
 131 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
 132 threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
 133 EOF
 134 } else {
 135     $b=<<EOF;
 136 leave enter nextstate label leaveloop enterloop null and defined null
 137 null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
 138 null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
 139 EOF
 140 }
 141 $b=~s/\n/ /g;$b=~s/\s+/ /g;
 142 $b =~ s/\s+$//;
 143 print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
 144 ok;
 145
 146 chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
 147 $a = join ',', sort split /,/, $a;
 148 $a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
 149 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
 150 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
 151 $a =~ s/-uCwd,// if $^O eq 'cygwin';
 152 if ($Config{static_ext} eq ' ') {
 153   $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
 154      . '-umain,-ustrict,-uutf8,-uwarnings';
 155   if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
 156       $b = join ',', sort split /,/, $b;
 157   }
 158   print "# [$a] vs [$b]\nnot " if $a ne $b;
 159   ok;
 160 } else {
 161   print "ok $test # skipped: one or more static extensions\n"; $test++;
 162 }
 163
 164 if ($is_thread) {
 165     print "# use5005threads: test $test skipped\n";
 166 } else {
 167     $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
 168     if (ord('A') != 193) { # ASCIIish
 169         print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
 170     }
 171     else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
 172         print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
 173     }
 174 }
 175 ok;
 176
 177 # Bug 20001204.07
 178 {
 179 my $foo = $deparse->coderef2text(sub { { 234; }});
 180 # Constants don't get optimised here.
 181 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
 182 ok;
 183 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
 184 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
 185 ok;
 186 }