This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B-Debug 1.14
[perl5.git] / 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 => 11;
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 my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
35
36 my $path = join " ", map { qq["-I$_"] } @INC;
37 my $redir = $Is_MacOS ? "" : "2>&1";
38
39 $a = `$X $path "-MO=Debug" -e 1 $redir`;
40 like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
41
42
43 $a = `$X $path "-MO=Terse" -e 1 $redir`;
44 like($a, qr/\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s);
45
46 $a = `$X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
47 $a =~ s/\(0x[^)]+\)//g;
48 $a =~ s/\[[^\]]+\]//g;
49 $a =~ s/-e syntax OK//;
50 $a =~ s/[^a-z ]+//g;
51 $a =~ s/\s+/ /g;
52 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
53 $a =~ s/^\s+//;
54 $a =~ s/\s+$//;
55 $a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore
56 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
57 if ($is_thread) {
58     $b=<<EOF;
59 leave enter nextstate label leaveloop enterloop null and defined null
60 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
61 threadsv const null pushmark rvav gv nextstate subst const unstack
62 EOF
63 } else {
64   $b=<<EOF;
65 leave enter nextstate label leaveloop enterloop null and defined null null
66 gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
67 gvsv const null pushmark rvav gv nextstate subst const unstack
68 EOF
69 }
70 #$b .= " nextstate" if $] < 5.008001; # ??
71 $b=~s/\n/ /g; $b=~s/\s+/ /g;
72 $b =~ s/\s+$//;
73 is($a, $b);
74
75 like(B::Debug::_printop(B::main_root),  qr/LISTOP\s+\[OP_LEAVE\]/);
76 like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/);
77
78 $a = `$X $path "-MO=Debug" -e "B::main_root->debug" $redir`;
79 like($a, qr/op_next\s+0x0/m);
80 $a = `$X $path "-MO=Debug" -e "B::main_start->debug" $redir`;
81 like($a, qr/\[OP_ENTER\]/m);
82
83 # pass missing FETCHSIZE, fixed with 1.06
84 my $tmp = "tmp.pl";
85 open TMP, "> $tmp";
86 print TMP 'BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};
87 print $a[1]';
88 close TMP;
89 $a = `$X $path "-MO=Debug" $tmp $redir`;
90 unlink $tmp;
91 unlike($a, qr/locate object method "FETCHSIZE"/m);
92
93 # NV assertion with CV, fixed with 1.13
94 my $e = 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;';
95 $a = `$X $path "-MO=Debug" -e'$e' $redir`;
96 ok(! $?);
97 unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m);
98 unlike($a, qr/Use of uninitialized value in print/m);
99
100 END { unlink $tmp; }