diff options
Diffstat (limited to 'cpan')
| -rw-r--r-- | cpan/B-Debug/Debug.pm | 109 | ||||
| -rw-r--r-- | cpan/B-Debug/t/debug.t | 25 |
2 files changed, 56 insertions, 78 deletions
diff --git a/cpan/B-Debug/Debug.pm b/cpan/B-Debug/Debug.pm index 7f2b6af97a..17f026d9fa 100644 --- a/cpan/B-Debug/Debug.pm +++ b/cpan/B-Debug/Debug.pm @@ -1,6 +1,6 @@ package B::Debug; -our $VERSION = '1.14'; +our $VERSION = '1.16'; use strict; require 5.006; @@ -15,9 +15,20 @@ if ($] < 5.009) { } else { B->import (qw(@optype @specialsv_name)); } -my $have_B_Flags; + +if ($] < 5.006002) { + eval q|sub B::GV::SAFENAME { + my $name = (shift())->NAME; + # The regex below corresponds to the isCONTROLVAR macro from toke.c + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; + return $name; + }|; +} + +my ($have_B_Flags, $have_B_Flags_extra); if (!$ENV{PERL_CORE}){ # avoid CORE test crashes eval { require B::Flags and $have_B_Flags++ }; + $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03'; } my %done_gv; @@ -127,7 +138,7 @@ sub B::COP::debug { cop_line %d cop_warnings 0x%x EOT - if ($] >= 5.007 and $] < 5.011) { + if ($] > 5.008 and $] < 5.011) { my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; printf(" cop_io %s\n", cstring($cop_io)); } @@ -167,11 +178,16 @@ sub B::SV::debug { print class($sv), " = NULL\n"; return; } - printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; + printf <<'EOT', class($sv), $$sv, $sv->REFCNT; %s (0x%x) REFCNT %d FLAGS 0x%x EOT + printf "\tFLAGS\t\t0x%x", $sv->FLAGS; + if ($have_B_Flags) { + printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv; + } + print "\n"; } sub B::RV::debug { @@ -253,6 +269,13 @@ sub B::CV::debug { OUTSIDE 0x%x EOT printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007; + if ($have_B_Flags) { + my $SVt_PVCV = $] < 5.010 ? 12 : 13; + printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS, + $have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv); + } else { + printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS); + } $start->debug if $start; $root->debug if $root; $gv->debug if $gv; @@ -278,9 +301,14 @@ EOT MAX %d EOT } - printf <<'EOT', $av->AvFLAGS if $] < 5.009; - AvFLAGS %d -EOT + if ($] < 5.009) { + if ($have_B_Flags) { + printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS, + $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv); + } else { + printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS); + } + } } sub B::GV::debug { @@ -306,8 +334,14 @@ sub B::GV::debug { CVGEN %d LINE %d FILE %s - GvFLAGS 0x%x EOT + if ($have_B_Flags) { + my $SVt_PVGV = $] < 5.010 ? 13 : 9; + printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS, + $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv); + } else { + printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS); + } $sv->debug if $sv; $av->debug if $av; $cv->debug if $cv; @@ -339,7 +373,8 @@ B::Debug - Walk Perl syntax tree, printing debug info about ops =head1 SYNOPSIS - perl -MO=Debug[,OPTIONS] foo.pl + perl -MO=Debug foo.pl + perl -MO=Debug,-exec foo.pl =head1 DESCRIPTION @@ -350,60 +385,6 @@ See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>. With option -exec, walks tree in execute order, otherwise in basic order. -=head1 Changes - - 1.13 2010-09-09 rurban - print name of op_type - print ppaddr consistent with other op addr - fix cop_io - omit cv->OUTSIDE_SEQ for 5.6 - fix NULL specials - fix NV assertion for CV - stabilize tests for space in runperl path - fix t/debug.t test 7 - - 1.12 2010-02-10 rurban - remove archlib installation cruft, and use the proper PM rule. - By Todd Rinaldo (toddr) - - 1.11 2008-07-14 rurban - avoid B::Flags in CORE tests not to crash on old XS in @INC - - 1.10 2008-06-28 rurban - require 5.006; Test::More not possible in 5.00505 - our => my - - 1.09 2008-06-18 rurban - minor META.yml syntax fix - 5.8.0 ending nextstate test failure: be more tolerant - PREREQ_PM Test::More - - 1.08 2008-06-17 rurban - support 5.00558 - 5.6.2 - - 1.07 2008-06-16 rurban - debug.t: fix strawberry perl quoting issue - - 1.06 2008-06-11 rurban - added B::Flags output - dual-life CPAN as B-Debug-1.06 and CORE - protect scalar(@array) if tied arrays leave out FETCHSIZE - - 1.05_03 2008-04-16 rurban - ithread fixes in B::AV - B-C-1.04_?? - - B-C-1.04_09 2008-02-24 rurban - support 5.8 (import Asmdata) - - 1.05_02 2008-02-21 rurban - added _printop - B-C-1.04_08 and CORE - - 1.05_01 2008-02-05 rurban - 5.10 fix for op->seq - B-C-1.04_04 - =head1 AUTHOR Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> @@ -412,7 +393,7 @@ Reini Urban C<rurban@cpan.org> =head1 LICENSE Copyright (c) 1996, 1997 Malcolm Beattie -Copyright (c) 2008 Reini Urban +Copyright (c) 2008, 2010 Reini Urban This program is free software; you can redistribute it and/or modify it under the terms of either: diff --git a/cpan/B-Debug/t/debug.t b/cpan/B-Debug/t/debug.t index fc73e06971..e523d3d565 100644 --- a/cpan/B-Debug/t/debug.t +++ b/cpan/B-Debug/t/debug.t @@ -27,14 +27,13 @@ use Config; use Test::More tests => 11; use B; use B::Debug; +use File::Spec; my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X; -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; +my $path = join " ", map { qq["-I$_"] } (File::Spec->catfile("blib","lib"), @INC); +my $redir = $^O =~ /VMS|MSWin32|MacOS/ ? "" : "2>&1"; $a = `$X $path "-MO=Debug" -e 1 $redir`; like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s); @@ -81,20 +80,18 @@ $a = `$X $path "-MO=Debug" -e "B::main_start->debug" $redir`; like($a, qr/\[OP_ENTER\]/m); # pass missing FETCHSIZE, fixed with 1.06 -my $tmp = "tmp.pl"; -open TMP, "> $tmp"; -print TMP 'BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}}; -print $a[1]'; -close TMP; -$a = `$X $path "-MO=Debug" $tmp $redir`; -unlink $tmp; +my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]); +$a = `$X $path "-MO=Debug" -e"$e" $redir`; unlike($a, qr/locate object method "FETCHSIZE"/m); # NV assertion with CV, fixed with 1.13 -my $e = 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;'; -$a = `$X $path "-MO=Debug" -e'$e' $redir`; +my $tmp = "tmp.pl"; +open TMP, ">", $tmp; +print TMP 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;'; +close TMP; +$a = `$X $path "-MO=Debug" $tmp $redir`; ok(! $?); unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m); unlike($a, qr/Use of uninitialized value in print/m); -END { unlink $tmp; } +END { unlink $tmp if $tmp; } |