diff --git a/MANIFEST b/MANIFEST index 4b3af711316d..928eac33c0f9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -139,8 +139,6 @@ cpan/AutoLoader/lib/AutoLoader.pm Autoloader base class cpan/AutoLoader/lib/AutoSplit.pm Split up autoload functions cpan/AutoLoader/t/01AutoLoader.t See if AutoLoader works cpan/AutoLoader/t/02AutoSplit.t See if AutoSplit works -cpan/B-Debug/Debug.pm Compiler Debug backend -cpan/B-Debug/t/debug.t See if B::Debug works cpan/bignum/lib/bigint.pm bigint cpan/bignum/lib/bignum.pm bignum cpan/bignum/lib/bigrat.pm bigrat diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 5b0768da22aa..7e75d6af32d2 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -179,13 +179,6 @@ package Maintainers; 'EXCLUDED' => [qr{^t/release-.*\.t}], }, - 'B::Debug' => { - 'DISTRIBUTION' => 'RURBAN/B-Debug-1.26.tar.gz', - 'FILES' => q[cpan/B-Debug], - 'EXCLUDED' => ['t/pod.t'], - 'DEPRECATED' => '5.027003', - }, - 'base' => { 'DISTRIBUTION' => 'RJBS/base-2.23.tar.gz', 'FILES' => q[dist/base], diff --git a/cpan/B-Debug/Debug.pm b/cpan/B-Debug/Debug.pm deleted file mode 100644 index d121cbbcfa64..000000000000 --- a/cpan/B-Debug/Debug.pm +++ /dev/null @@ -1,478 +0,0 @@ -package B::Debug; - -our $VERSION = '1.26'; -BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } } - -use strict; -require 5.006; -use B qw(peekop walkoptree walkoptree_exec - 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)); -} else { - B->import (qw(@optype @specialsv_name)); -} - -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; - -sub _printop { - my $op = shift; - my $addr = ${$op} ? $op->ppaddr : ''; - $addr =~ s/^PL_ppaddr// if $addr; - if (${$op}) { - return sprintf "0x%08x %6s %s", ${$op}, B::class($op), $addr; - } else { - return sprintf "0x%x %6s %s", ${$op}, '', $addr; - } -} - -sub B::OP::debug { - my ($op) = @_; - 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 - op_sibling %s - op_targ %d - op_type %d %s -EOT - if ($] > 5.009) { - printf <<'EOT', $op->opt; - op_opt %d -EOT - } else { - printf <<'EOT', $op->seq; - op_seq %d -EOT - } - if ($have_B_Flags) { - printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv; - op_flags %u %s - op_private %u %s -EOT - } else { - printf <<'EOT', $op->flags, $op->private; - op_flags %u - op_private %u -EOT - } - if ($op->can('rettype')) { - printf <<'EOT', $op->rettype; - op_rettype %u -EOT - } -} - -sub B::UNOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_first\t%s\n", _printop($op->first); -} - -sub B::BINOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_last \t%s\n", _printop($op->last); -} - -sub B::LOOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop); - op_redoop %s - op_nextop %s - op_lastop %s -EOT -} - -sub B::LOGOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_other\t%s\n", _printop($op->other); -} - -sub B::LISTOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf "\top_children\t%d\n", $op->children; -} - -sub B::PMOP::debug { - my ($op) = @_; - $op->B::LISTOP::debug(); - printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot; - printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; - printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005; - if ($Config{'useithreads'}) { - printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv); - printf "\top_pmoffset\t%d\n", $op->pmoffset; - } else { - printf "\top_pmstash\t%s\n", cstring($op->pmstash); - } - printf "\top_precomp\t%s\n", cstring($op->precomp); - printf "\top_pmflags\t0x%x\n", $op->pmflags; - printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009; - printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009; - printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009; - $op->pmreplroot->debug if $] < 5.008; -} - -sub B::COP::debug { - my ($op) = @_; - $op->B::OP::debug(); - 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" - cop_seq %d - cop_arybase %d - cop_line %d - cop_warnings 0x%x -EOT - if ($] > 5.008 and $] < 5.011) { - my $cop_io = B::class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; - printf(" cop_io %s\n", cstring($cop_io)); - } -} - -sub B::SVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_sv\t\t0x%x\n", ${$op->sv}; - $op->sv->debug; -} - -sub B::METHOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - if (${$op->first}) { - printf "\top_first\t0x%x\n", ${$op->first}; - $op->first->debug; - } else { - printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv}; - $op->meth_sv->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(); - printf "\top_pv\t\t%s\n", cstring($op->pv); -} - -sub B::PADOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_padix\t%ld\n", $op->padix; -} - -sub B::NULL::debug { - my ($sv) = @_; - if ($$sv == ${sv_undef()}) { - print "&sv_undef\n"; - } else { - printf "NULL (0x%x)\n", $$sv; - } -} - -sub B::SV::debug { - my ($sv) = @_; - if (!$$sv) { - print B::class($sv), " = NULL\n"; - return; - } - printf <<'EOT', B::class($sv), $$sv, $sv->REFCNT; -%s (0x%x) - REFCNT %d -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 { - my ($rv) = @_; - B::SV::debug($rv); - printf <<'EOT', ${$rv->RV}; - RV 0x%x -EOT - $rv->RV->debug; -} - -sub B::PV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN; - xpv_pv %s - xpv_cur %d - xpv_len %d -EOT -} - -sub B::IV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - 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 if $sv->FLAGS & SVf_NOK; -} - -sub B::PVIV::debug { - my ($sv) = @_; - $sv->B::PV::debug(); - 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 if $sv->FLAGS & SVf_NOK; -} - -sub B::PVLV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txlv_targoff\t%d\n", $sv->TARGOFF; - printf "\txlv_targlen\t%u\n", $sv->TARGLEN; - printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); -} - -sub B::BM::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txbm_useful\t%d\n", $sv->USEFUL; - printf "\txbm_previous\t%u\n", $sv->PREVIOUS; - printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); -} - -sub B::CV::debug { - 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 ($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 { - $gv = $cv->GV; - printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME); - } - 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", $cv->OUTSIDE_SEQ) if $] > 5.007; - if ($have_B_Flags) { - 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", $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; - $padlist->debug if $padlist; -} - -sub B::AV::debug { - my ($av) = @_; - $av->B::SV::debug; - _array_debug($av); -} - -sub _array_debug { - my ($av) = @_; - # tied arrays may leave out FETCHSIZE - my (@array) = eval { $av->ARRAY; }; - print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; - my $fill = eval { scalar(@array) }; - if ($Config{'useithreads'} && B::class($av) ne 'PADLIST') { - printf <<'EOT', $fill, $av->MAX, $av->OFF; - FILL %d - MAX %d - OFF %d -EOT - } else { - printf <<'EOT', $fill, $av->MAX; - FILL %d - MAX %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 { - my ($gv) = @_; - if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; - return; - } - 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 - STASH %s (0x%x) - SV 0x%x - GvREFCNT %d - FORM 0x%x - AV 0x%x - HV 0x%x - EGV 0x%x - CV 0x%x - CVGEN %d - LINE %d - FILE %s -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; -} - -sub B::SPECIAL::debug { - my $sv = shift; - my $i = ref $sv ? $$sv : 0; - print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n"; -} - -sub B::PADLIST::debug { - my ($padlist) = @_; - printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT; -%s (0x%x) - REFCNT %d -EOT - _array_debug($padlist); -} - -sub compile { - my $order = shift; - B::clearsym(); - $DB::single = 1 if defined &DB::DB; - if ($order && $order eq "exec") { - return sub { walkoptree_exec(main_start, "debug") } - } else { - return sub { walkoptree(main_root, "debug") } - } -} - -1; - -__END__ - -=head1 NAME - -B::Debug - Walk Perl syntax tree, printing debug info about ops - -=head1 SYNOPSIS - - perl -MO=Debug foo.pl - perl -MO=Debug,-exec foo.pl - -=head1 DESCRIPTION - -See F and the newer L. - -=head1 OPTIONS - -With option -exec, walks tree in execute order, -otherwise in basic order. - -=head1 AUTHOR - -Malcolm Beattie, C -Reini Urban C - -=head1 LICENSE - -Copyright (c) 1996, 1997 Malcolm Beattie -Copyright (c) 2008, 2010, 2013, 2014 Reini Urban - - This program is free software; you can redistribute it and/or modify - it under the terms of either: - - a) the GNU General Public License as published by the Free - Software Foundation; either version 1, or (at your option) any - later version, or - - b) the "Artistic License" which comes with this kit. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either - the GNU General Public License or the Artistic License for more details. - - You should have received a copy of the Artistic License with this kit, - in the file named "Artistic". If not, you can get one from the Perl - distribution. You should also have received a copy of the GNU General - Public License, in the file named "Copying". If not, you can get one - from the Perl distribution or else write to the Free Software Foundation, - Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. - -=cut - diff --git a/cpan/B-Debug/t/debug.t b/cpan/B-Debug/t/debug.t deleted file mode 100644 index c362d7456df8..000000000000 --- a/cpan/B-Debug/t/debug.t +++ /dev/null @@ -1,105 +0,0 @@ -#!./perl - -BEGIN { - delete $ENV{PERL_DL_NONLAZY} if $] < 5.005_58; #Perl_byterun problem - if ($ENV{PERL_CORE}){ - chdir('t') if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - } else { - unshift @INC, 't'; - } - require Config; - if (($Config::Config{'extensions'} !~ /\bB\b/) ){ - print "1..0 # Skip -- Perl configured without B module\n"; - exit 0; - } -} - -$| = 1; -use warnings; -use strict; -use Config; -use Test::More tests => 11; -use B; -use B::Debug; -use File::Spec; - -my $a; -my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X; - -local $ENV{PERL5LIB} = - join $Config{path_sep}, File::Spec->catfile("blib","lib"), @INC; -my $redir = $^O =~ /VMS|MSWin32|MacOS/ ? "" : "2>&1"; - -$a = `$X "-MO=Debug" -e 1 $redir`; -like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s); - - -$a = `$X "-MO=Terse" -e 1 $redir`; -like($a, qr/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s); - -$a = `$X "-MO=Terse" -ane "s/foo/bar/" $redir`; -$a =~ s/\(0x[^)]+\)//g; -$a =~ s/\[[^\]]+\]//g; -$a =~ s/-e syntax OK//; -$a =~ s/[^a-z ]+//g; -$a =~ s/\s+/ /g; -$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g; -$a =~ s/^\s+//; -$a =~ s/\s+$//; -$a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore -my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; -if ($is_thread) { - $b=<= 5.021005) { - $b=<= 5.025006; - -is($a, $b); - -like(B::Debug::_printop(B::main_root), qr/LISTOP\s+\[OP_LEAVE\]/); -like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/); - -$a = `$X "-MO=Debug" -e "B::main_root->debug" $redir`; -like($a, qr/op_next\s+0x0/m); -$a = `$X "-MO=Debug" -e "B::main_start->debug" $redir`; -like($a, qr/\[OP_ENTER\]/m); - -# pass missing FETCHSIZE, fixed with 1.06 -my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]); -$a = `$X "-MO=Debug" -e"$e" $redir`; -unlike($a, qr/locate object method "FETCHSIZE"/m); - -# NV assertion with CV, fixed with 1.13 -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 "-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 if $tmp; } diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 9032e9b082bd..729fcd95f482 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "1.003"; +our $VERSION = "1.004"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -1284,7 +1284,7 @@ This is mainly a joke. =item B<-debug> -Use formatting conventions reminiscent of B; these aren't +Use formatting conventions reminiscent of CPAN module B; these aren't very concise at all. =item B<-env> diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 681112e9041b..4401073f2536 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,6 +1,6 @@ package B::Terse; -our $VERSION = '1.08'; +our $VERSION = '1.09'; use strict; use B qw(class @specialsv_name); @@ -73,7 +73,7 @@ B::Terse - Walk Perl syntax tree, printing terse info about ops =head1 DESCRIPTION This module prints the contents of the parse tree, but without as much -information as L. For comparison, C +information as CPAN module B::Debug. For comparison, C produced 96 lines of output from B::Debug, but only 6 from B::Terse. This module is useful for people who are writing their own back end, diff --git a/lib/.gitignore b/lib/.gitignore index 7af784898dda..626aa67011d8 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -16,7 +16,6 @@ /AutoSplit.pm /B.pm /B/Concise.pm -/B/Debug.pm /B/Showlex.pm /B/Terse.pm /B/Xref.pm diff --git a/pod/perlhacktips.pod b/pod/perlhacktips.pod index cbf1d3c9f62a..7ec2b40aa876 100644 --- a/pod/perlhacktips.pod +++ b/pod/perlhacktips.pod @@ -964,7 +964,7 @@ subroutine: We can also dump out this op: the current op is always stored in C, and we can dump it with C. This'll give us -similar output to L. +similar output to CPAN module B::Debug. (gdb) print Perl_op_dump(PL_op) { diff --git a/pod/perlinterp.pod b/pod/perlinterp.pod index 7ac6c9ee4cb4..2d7073723ebe 100644 --- a/pod/perlinterp.pod +++ b/pod/perlinterp.pod @@ -434,7 +434,7 @@ operations in. The easiest way to examine the op tree is to stop Perl after it has finished parsing, and get it to dump out the tree. This is exactly what the compiler backends L, L -and L do. +and CPAN module : diff --git a/t/TEST b/t/TEST index f8f338ffe245..fb293d414118 100755 --- a/t/TEST +++ b/t/TEST @@ -60,8 +60,7 @@ my %abs = ( '../dist/Tie-File' => 1, ); -my %temp_no_core = - ('../cpan/B-Debug' => 1, +my %temp_no_core = ( '../cpan/Compress-Raw-Bzip2' => 1, '../cpan/Compress-Raw-Zlib' => 1, '../cpan/Devel-PPPort' => 1,