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