| 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 | use File::Spec; |
| 31 | |
| 32 | my $a; |
| 33 | my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X; |
| 34 | |
| 35 | my $path = join " ", map { qq["-I$_"] } (File::Spec->catfile("blib","lib"), @INC); |
| 36 | my $redir = $^O =~ /VMS|MSWin32|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/\[OP_ENTER\]/m); |
| 81 | |
| 82 | # pass missing FETCHSIZE, fixed with 1.06 |
| 83 | my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]); |
| 84 | $a = `$X $path "-MO=Debug" -e"$e" $redir`; |
| 85 | unlike($a, qr/locate object method "FETCHSIZE"/m); |
| 86 | |
| 87 | # NV assertion with CV, fixed with 1.13 |
| 88 | my $tmp = "tmp.pl"; |
| 89 | open TMP, ">", $tmp; |
| 90 | print TMP 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;'; |
| 91 | close TMP; |
| 92 | $a = `$X $path "-MO=Debug" $tmp $redir`; |
| 93 | ok(! $?); |
| 94 | unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m); |
| 95 | unlike($a, qr/Use of uninitialized value in print/m); |
| 96 | |
| 97 | END { unlink $tmp if $tmp; } |