+++ /dev/null
-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<ext/B/README> and the newer L<B::Concise>.
-
-=head1 OPTIONS
-
-With option -exec, walks tree in execute order,
-otherwise in basic order.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<retired>
-Reini Urban C<rurban@cpan.org>
-
-=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
-
+++ /dev/null
-#!./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=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null
-threadsv readline gv lineseq nextstate aassign null pushmark split pushre
-threadsv const null pushmark rvav gv nextstate subst const unstack
-EOF
-} elsif ($] >= 5.021005) {
- $b=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null null
-gvsv readline gv lineseq nextstate split pushre null
-gvsv const nextstate subst const unstack
-EOF
-} else {
- $b=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null null
-gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
-gvsv const null pushmark rvav gv nextstate subst const unstack
-EOF
-}
-$b=~s/\n/ /g; $b=~s/\s+/ /g;
-$b =~ s/\s+$//;
-$b =~ s/split pushre/split/ if $] >= 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; }
https://perl5.git.perl.org / perl5.git / commitdiff