cpan/B-Debug/t/debug.t

   1 #!./perl
   2
   3 BEGIN {
   4     delete $ENV{PERL_DL_NONLAZY} if $] < 5.005_58; #Perl_byterun problem
   5     if ($ENV{PERL_CORE}){
   6         chdir('t') if -d 't';
   7         if ($^O eq 'MacOS') {
   8             @INC = qw(: ::lib ::macos:lib);
   9         } else {
  10             @INC = '.';
  11             push @INC, '../lib';
  12         }
  13     } else {
  14         unshift @INC, 't';
  15     }
  16     require Config;
  17     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  18         print "1..0 # Skip -- Perl configured without B module\n";
  19         exit 0;
  20     }
  21 }
  22
  23 $|  = 1;
  24 use warnings;
  25 use strict;
  26 use Config;
  27 use Test::More tests => 8;
  28 use B;
  29 use B::Debug;
  30
  31 my $a;
  32 my $Is_VMS = $^O eq 'VMS';
  33 my $Is_MacOS = $^O eq 'MacOS';
  34
  35 my $path = join " ", map { qq["-I$_"] } @INC;
  36 my $redir = $Is_MacOS ? "" : "2>&1";
  37
  38 $a = `$^X $path "-MO=Debug" -e 1 $redir`;
  39 like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
  40
  41
  42 $a = `$^X $path "-MO=Terse" -e 1 $redir`;
  43 like($a, qr/\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s);
  44
  45 $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
  46 $a =~ s/\(0x[^)]+\)//g;
  47 $a =~ s/\[[^\]]+\]//g;
  48 $a =~ s/-e syntax OK//;
  49 $a =~ s/[^a-z ]+//g;
  50 $a =~ s/\s+/ /g;
  51 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
  52 $a =~ s/^\s+//;
  53 $a =~ s/\s+$//;
  54 $a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore
  55 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
  56 if ($is_thread) {
  57     $b=<<EOF;
  58 leave enter nextstate label leaveloop enterloop null and defined null
  59 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
  60 threadsv const null pushmark rvav gv nextstate subst const unstack
  61 EOF
  62 } else {
  63   $b=<<EOF;
  64 leave enter nextstate label leaveloop enterloop null and defined null null
  65 gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
  66 gvsv const null pushmark rvav gv nextstate subst const unstack
  67 EOF
  68 }
  69 #$b .= " nextstate" if $] < 5.008001; # ??
  70 $b=~s/\n/ /g;$b=~s/\s+/ /g;
  71 $b =~ s/\s+$//;
  72 is($a, $b);
  73
  74 like(B::Debug::_printop(B::main_root),  qr/LISTOP\s+\[OP_LEAVE\]/);
  75 like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/);
  76
  77 $a = `$^X $path "-MO=Debug" -e "B::main_root->debug" $redir`;
  78 like($a, qr/op_next\s+0x0/m);
  79 $a = `$^X $path "-MO=Debug" -e "B::main_start->debug" $redir`;
  80 like($a, qr/PL_ppaddr\[OP_ENTER\]/m);
  81
  82 # pass missing FETCHSIZE, fixed with 1.06
  83 my $tmp = "tmp.pl";
  84 open TMP, "> $tmp";
  85 print TMP 'BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};
  86 print $a[1]';
  87 close TMP;
  88 $a = `$^X $path "-MO=Debug" $tmp $redir`;
  89 unlink $tmp;
  90 unlike($a, qr/locate object method "FETCHSIZE"/m);