In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0283ad960acb937e9387b3323f1f7852c2adb0fa?hp=f1820d8248083f4ae01a30baeb564afb143537c3>
- Log ----------------------------------------------------------------- commit 0283ad960acb937e9387b3323f1f7852c2adb0fa Author: Dagfinn Ilmari Mannsåker <[email protected]> Date: Thu Jul 27 11:06:35 2017 +0100 [perl #130410] Import B-Debug 1.25 from CPAN This marks it as deprecated in core so it can be removed in 5.30. M Porting/Maintainers.pl M cpan/B-Debug/Debug.pm commit 499e37eb975a8907cf5ee80b17f8908fbdfc3984 Author: Dagfinn Ilmari Mannsåker <[email protected]> Date: Thu Jul 27 10:58:42 2017 +0100 Fetch CPAN modules from the metacpan mirror instead of s.c.o M Porting/sync-with-cpan ----------------------------------------------------------------------- Summary of changes: Porting/Maintainers.pl | 2 +- Porting/sync-with-cpan | 2 +- cpan/B-Debug/Debug.pm | 85 +++++++++++++++++++++++++++++++------------------- 3 files changed, 55 insertions(+), 34 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 961f23ca28..e577fd682b 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -173,7 +173,7 @@ use File::Glob qw(:case); }, 'B::Debug' => { - 'DISTRIBUTION' => 'RURBAN/B-Debug-1.24.tar.gz', + 'DISTRIBUTION' => 'RURBAN/B-Debug-1.25.tar.gz', 'FILES' => q[cpan/B-Debug], 'EXCLUDED' => ['t/pod.t'], }, diff --git a/Porting/sync-with-cpan b/Porting/sync-with-cpan index e6cfd8f36e..0176e18045 100755 --- a/Porting/sync-with-cpan +++ b/Porting/sync-with-cpan @@ -334,7 +334,7 @@ else { die "The latest version of $module is $new_version, but blead already has it\n" if $new_version eq $old_version; - my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";; + my $url = "https://cpan.metacpan.org/authors/id/$new_path";; say "Fetching $url"; # # Fetch the new distro diff --git a/cpan/B-Debug/Debug.pm b/cpan/B-Debug/Debug.pm index e295635d35..b49041f864 100644 --- a/cpan/B-Debug/Debug.pm +++ b/cpan/B-Debug/Debug.pm @@ -1,10 +1,11 @@ package B::Debug; -our $VERSION = '1.24'; +our $VERSION = '1.25'; +BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } } use strict; require 5.006; -use B qw(peekop class walkoptree walkoptree_exec +use B qw(peekop walkoptree walkoptree_exec main_start main_root cstring sv_undef SVf_NOK SVf_IOK); use Config; my (@optype, @specialsv_name); @@ -37,7 +38,7 @@ sub _printop { my $addr = ${$op} ? $op->ppaddr : ''; $addr =~ s/^PL_ppaddr// if $addr; if (${$op}) { - return sprintf "0x%08x %6s %s", ${$op}, class($op), $addr; + return sprintf "0x%08x %6s %s", ${$op}, B::class($op), $addr; } else { return sprintf "0x%x %6s %s", ${$op}, '', $addr; } @@ -45,7 +46,7 @@ sub _printop { sub B::OP::debug { my ($op) = @_; - printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name; + printf <<'EOT', B::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 @@ -64,13 +65,18 @@ EOT } if ($have_B_Flags) { printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv; - op_flags %d %s - op_private %d %s + op_flags %u %s + op_private %u %s EOT } else { printf <<'EOT', $op->flags, $op->private; - op_flags %d - op_private %d + op_flags %u + op_private %u +EOT + } + if ($op->can('rettype')) { + printf <<'EOT', $op->rettype; + op_rettype %u EOT } } @@ -143,7 +149,7 @@ sub B::COP::debug { cop_warnings 0x%x EOT if ($] > 5.008 and $] < 5.011) { - my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; + my $cop_io = B::class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; printf(" cop_io %s\n", cstring($cop_io)); } } @@ -167,6 +173,16 @@ sub B::METHOP::debug { } } +sub B::UNOP_AUX::debug { + my ($op) = @_; + $op->B::OP::debug(); + # string and perl5 aux_list needs the cv + # cperl has aux, Concise,-debug leaves it empty + if ($op->can('aux')) { + printf "\top_aux\t%s\n", cstring($op->aux); + } +} + sub B::PVOP::debug { my ($op) = @_; $op->B::OP::debug(); @@ -191,10 +207,10 @@ sub B::NULL::debug { sub B::SV::debug { my ($sv) = @_; if (!$$sv) { - print class($sv), " = NULL\n"; + print B::class($sv), " = NULL\n"; return; } - printf <<'EOT', class($sv), $$sv, $sv->REFCNT; + printf <<'EOT', B::class($sv), $$sv, $sv->REFCNT; %s (0x%x) REFCNT %d EOT @@ -266,38 +282,43 @@ sub B::BM::debug { } sub B::CV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - my ($stash) = $sv->STASH; - my ($start) = $sv->START; - my ($root) = $sv->ROOT; - my ($padlist) = $sv->PADLIST; - my ($file) = $sv->FILE; - my ($gv) = $sv->GV; + my ($cv) = @_; + $cv->B::PVNV::debug(); + my $stash = $cv->STASH; + my $start = $cv->START; + my $root = $cv->ROOT; + my $padlist = $cv->PADLIST; + my $file = $cv->FILE; + my $gv; printf <<'EOT', $$stash, $$start, $$root; STASH 0x%x START 0x%x ROOT 0x%x EOT - if ( $]>5.017 && ($sv->FLAGS & 0x40000)) { #lexsub - printf("\tNAME\t%%s\n", $sv->NAME); + if ($cv->can('NAME_HEK') && $cv->NAME_HEK) { + printf("\tNAME\t%%s\n", $cv->NAME_HEK); + } + elsif ( $]>5.017 && ($cv->FLAGS & 0x40000)) { #lexsub + printf("\tNAME\t%%s\n", $cv->NAME_HEK); } else { - printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME); + $gv = $cv->GV; + printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME); } - printf <<'EOT', $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; + printf <<'EOT', $file, $cv->DEPTH, $padlist, ${$cv->OUTSIDE}; FILE %s DEPTH %d PADLIST 0x%x OUTSIDE 0x%x EOT - printf("\tOUTSIDE_SEQ\t%d\n", $sv->OUTSIDE_SEQ) if $] > 5.007; + printf("\tOUTSIDE_SEQ\t%d\n", $cv->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); + my $SVt_PVCV = $] < 5.010 ? 12 : 13; + printf("\tCvFLAGS\t0x%x\t%s\n", $cv->CvFLAGS, + $have_B_Flags_extra ? $cv->flagspv($SVt_PVCV) : $cv->flagspv); } else { - printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS); + printf("\tCvFLAGS\t0x%x\n", $cv->CvFLAGS); } + printf("\tSIGOP\t0x%x\n", $cv->SIGOP) if $cv->can('SIGOP'); $start->debug if $start; $root->debug if $root; $gv->debug if $gv; @@ -316,7 +337,7 @@ sub _array_debug { my (@array) = eval { $av->ARRAY; }; print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; my $fill = eval { scalar(@array) }; - if ($Config{'useithreads'} && class($av) ne 'PADLIST') { + if ($Config{'useithreads'} && B::class($av) ne 'PADLIST') { printf <<'EOT', $fill, $av->MAX, $av->OFF; FILL %d MAX %d @@ -382,7 +403,7 @@ sub B::SPECIAL::debug { sub B::PADLIST::debug { my ($padlist) = @_; - printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT; + printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT; %s (0x%x) REFCNT %d EOT @@ -415,7 +436,7 @@ B::Debug - Walk Perl syntax tree, printing debug info about ops =head1 DESCRIPTION -See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>. +See F<ext/B/README> and the newer L<B::Concise>. =head1 OPTIONS @@ -424,7 +445,7 @@ otherwise in basic order. =head1 AUTHOR -Malcolm Beattie, C<[email protected]> +Malcolm Beattie, C<retired> Reini Urban C<[email protected]> =head1 LICENSE -- Perl5 Master Repository
