summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B/Debug.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
committerKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
commita4c42bfb2337d37da89d789cb8cc226367994e32 (patch)
treec3eabdef5d565a4e515d2be0d9d4d0540bde0250 /Master/tlpkg/tlperl/lib/B/Debug.pm
parent8274475057f024d35332ac47c2e2f23ea156e6ed (diff)
perl 5.14.2 from siep
git-svn-id: svn://tug.org/texlive/trunk@26525 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Debug.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Debug.pm141
1 files changed, 68 insertions, 73 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm
index f44d59dd022..17f026d9fa8 100644
--- a/Master/tlpkg/tlperl/lib/B/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/B/Debug.pm
@@ -1,23 +1,34 @@
package B::Debug;
-our $VERSION = '1.12';
+our $VERSION = '1.16';
use strict;
require 5.006;
use B qw(peekop class walkoptree walkoptree_exec
- main_start main_root cstring sv_undef);
+ main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
use Config;
my (@optype, @specialsv_name);
require B;
if ($] < 5.009) {
require B::Asmdata;
- B::Asmdata->import qw(@optype @specialsv_name);
+ B::Asmdata->import (qw(@optype @specialsv_name));
} else {
- B->import qw(@optype @specialsv_name);
+ 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;
@@ -25,18 +36,18 @@ sub _printop {
my $op = shift;
my $addr = ${$op} ? $op->ppaddr : '';
$addr =~ s/^PL_ppaddr// if $addr;
- return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
+ return sprintf "0x%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
}
sub B::OP::debug {
my ($op) = @_;
- printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
+ printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
%s (0x%lx)
op_ppaddr %s
op_next %s
op_sibling %s
op_targ %d
- op_type %d
+ op_type %d %s
EOT
if ($] > 5.009) {
printf <<'EOT', $op->opt;
@@ -117,8 +128,8 @@ sub B::PMOP::debug {
sub B::COP::debug {
my ($op) = @_;
$op->B::OP::debug();
- my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
- printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
+ my $warnings = ref $op->warnings ? ${$op->warnings} : 0;
+ printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
cop_label "%s"
cop_stashpv "%s"
cop_file "%s"
@@ -126,8 +137,11 @@ sub B::COP::debug {
cop_arybase %d
cop_line %d
cop_warnings 0x%x
- cop_io %s
EOT
+ 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));
+ }
}
sub B::SVOP::debug {
@@ -164,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 {
@@ -193,25 +212,25 @@ EOT
sub B::IV::debug {
my ($sv) = @_;
$sv->B::SV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
+ printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
}
sub B::NV::debug {
my ($sv) = @_;
$sv->B::IV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
+ printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
}
sub B::PVIV::debug {
my ($sv) = @_;
$sv->B::PV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
+ printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
}
sub B::PVNV::debug {
my ($sv) = @_;
$sv->B::PVIV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
+ printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
}
sub B::PVLV::debug {
@@ -235,11 +254,11 @@ sub B::CV::debug {
$sv->B::PVNV::debug();
my ($stash) = $sv->STASH;
my ($start) = $sv->START;
- my ($root) = $sv->ROOT;
+ my ($root) = $sv->ROOT;
my ($padlist) = $sv->PADLIST;
my ($file) = $sv->FILE;
my ($gv) = $sv->GV;
- printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
STASH 0x%x
START 0x%x
ROOT 0x%x
@@ -248,8 +267,15 @@ sub B::CV::debug {
DEPTH %d
PADLIST 0x%x
OUTSIDE 0x%x
- OUTSIDE_SEQ %d
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;
@@ -275,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 {
@@ -286,9 +317,9 @@ sub B::GV::debug {
printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
return;
}
- my ($sv) = $gv->SV;
- my ($av) = $gv->AV;
- my ($cv) = $gv->CV;
+ my $sv = $gv->SV;
+ my $av = $gv->AV;
+ my $cv = $gv->CV;
$gv->B::SV::debug;
printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
NAME %s
@@ -303,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;
@@ -312,7 +349,8 @@ EOT
sub B::SPECIAL::debug {
my $sv = shift;
- print $specialsv_name[$$sv], "\n";
+ my $i = ref $sv ? $$sv : 0;
+ print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
}
sub compile {
@@ -335,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
@@ -346,50 +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.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>
@@ -398,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: