t/lib/b.t

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