[perl5.git] / cpan / B-Debug / Debug.pm

package B::Debug;

our $VERSION = '1.12';

use strict;
require 5.006;
use B qw(peekop class walkoptree walkoptree_exec
         main_start main_root cstring sv_undef);
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);
}
my $have_B_Flags;
if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
  eval { require B::Flags and $have_B_Flags++ };
}
my %done_gv;

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;
}

sub B::OP::debug {
    my ($op) = @_;
    printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
%s (0x%lx)
	op_ppaddr	%s
	op_next		%s
	op_sibling	%s
	op_targ		%d
	op_type		%d
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	%d	%s
	op_private	%d	%s
EOT
    } else {
        printf <<'EOT', $op->flags, $op->private;
	op_flags	%d
	op_private	%d
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 $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);
	cop_label	"%s"
	cop_stashpv	"%s"
	cop_file	"%s"
	cop_seq		%d
	cop_arybase	%d
	cop_line	%d
	cop_warnings	0x%x
	cop_io		%s
EOT
}

sub B::SVOP::debug {
    my ($op) = @_;
    $op->B::OP::debug();
    printf "\top_sv\t\t0x%x\n", ${$op->sv};
    $op->sv->debug;
}

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 class($sv), " = NULL\n";
	return;
    }
    printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
%s (0x%x)
	REFCNT		%d
	FLAGS		0x%x
EOT
}

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), length($pv);
	xpv_pv		%s
	xpv_cur		%d
EOT
}

sub B::IV::debug {
    my ($sv) = @_;
    $sv->B::SV::debug();
    printf "\txiv_iv\t\t%d\n", $sv->IV;
}

sub B::NV::debug {
    my ($sv) = @_;
    $sv->B::IV::debug();
    printf "\txnv_nv\t\t%s\n", $sv->NV;
}

sub B::PVIV::debug {
    my ($sv) = @_;
    $sv->B::PV::debug();
    printf "\txiv_iv\t\t%d\n", $sv->IV;
}

sub B::PVNV::debug {
    my ($sv) = @_;
    $sv->B::PVIV::debug();
    printf "\txnv_nv\t\t%s\n", $sv->NV;
}

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 ($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;
    printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
	STASH		0x%x
	START		0x%x
	ROOT		0x%x
	GV		0x%x
	FILE		%s
	DEPTH		%d
	PADLIST		0x%x
	OUTSIDE		0x%x
	OUTSIDE_SEQ	%d
EOT
    $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;
    # 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'}) {
      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
    }
    printf <<'EOT', $av->AvFLAGS if $] < 5.009;
	AvFLAGS		%d
EOT
}

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
	GvFLAGS		0x%x
EOT
    $sv->debug if $sv;
    $av->debug if $av;
    $cv->debug if $cv;
}

sub B::SPECIAL::debug {
    my $sv = shift;
    print $specialsv_name[$$sv], "\n";
}

sub compile {
    my $order = shift;
    B::clearsym();
    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[,OPTIONS] foo.pl

=head1 DESCRIPTION

See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.

=head1 OPTIONS

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>
Reini Urban C<rurban@cpan.org>

=head1 LICENSE

Copyright (c) 1996, 1997 Malcolm Beattie
Copyright (c) 2008 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.

=cut
Commit	Line	Data
a798dbf2	1	package B::Debug;
28b605d8	2
daaaeea5	3	our $VERSION = '1.12';
28b605d8	4
a798dbf2	5	use strict;
7cd4b8a8	6	require 5.006;
a798dbf2	7	use B qw(peekop class walkoptree walkoptree_exec
93f00e88	8	main_start main_root cstring sv_undef);
7cd4b8a8 RGS	9	use Config;
7cd4b8a8 RGS	10	my (@optype, @specialsv_name);
93f00e88 RU	11	require B;
	12	if ($] < 5.009) {
	13	require B::Asmdata;
	14	B::Asmdata->import qw(@optype @specialsv_name);
	15	} else {
	16	B->import qw(@optype @specialsv_name);
	17	}
	18	my $have_B_Flags;
7cd4b8a8 RGS	19	if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
7cd4b8a8 RGS	20	eval { require B::Flags and $have_B_Flags++ };
c1307613	21	}
a798dbf2 MB	22	my %done_gv;
a798dbf2 MB	23
c1307613 RU	24	sub _printop {
	25	my $op = shift;
	26	my $addr = ${$op} ? $op->ppaddr : '';
	27	$addr =~ s/^PL_ppaddr// if $addr;
	28	return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
	29	}
	30
a798dbf2 MB	31	sub B::OP::debug {
a798dbf2 MB	32	my ($op) = @_;
c1307613	33	printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
a798dbf2	34	%s (0x%lx)
a798dbf2	35	op_ppaddr %s
c1307613 RU	36	op_next %s
c1307613 RU	37	op_sibling %s
a798dbf2 MB	38	op_targ %d
a798dbf2 MB	39	op_type %d
7252851f	40	EOT
7cd4b8a8	41	if ($] > 5.009) {
85594c31	42	printf <<'EOT', $op->opt;
2814eb74	43	op_opt %d
7252851f NC	44	EOT
	45	} else {
	46	printf <<'EOT', $op->seq;
	47	op_seq %d
	48	EOT
	49	}
93f00e88 RU	50	if ($have_B_Flags) {
	51	printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
	52	op_flags %d %s
	53	op_private %d %s
	54	EOT
	55	} else {
	56	printf <<'EOT', $op->flags, $op->private;
a798dbf2 MB	57	op_flags %d
	58	op_private %d
	59	EOT
93f00e88	60	}
a798dbf2 MB	61	}
	62
	63	sub B::UNOP::debug {
	64	my ($op) = @_;
	65	$op->B::OP::debug();
c1307613	66	printf "\top_first\t%s\n", _printop($op->first);
a798dbf2 MB	67	}
	68
	69	sub B::BINOP::debug {
	70	my ($op) = @_;
	71	$op->B::UNOP::debug();
c1307613	72	printf "\top_last \t%s\n", _printop($op->last);
a798dbf2 MB	73	}
a798dbf2 MB	74
ee3e756d RH	75	sub B::LOOP::debug {
	76	my ($op) = @_;
	77	$op->B::BINOP::debug();
c1307613 RU	78	printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
	79	op_redoop %s
	80	op_nextop %s
	81	op_lastop %s
ee3e756d RH	82	EOT
	83	}
	84
a798dbf2 MB	85	sub B::LOGOP::debug {
	86	my ($op) = @_;
	87	$op->B::UNOP::debug();
c1307613	88	printf "\top_other\t%s\n", _printop($op->other);
a798dbf2 MB	89	}
a798dbf2 MB	90
a798dbf2 MB	91	sub B::LISTOP::debug {
	92	my ($op) = @_;
	93	$op->B::BINOP::debug();
c03c2844	94	printf "\top_children\t%d\n", $op->children;
a798dbf2 MB	95	}
	96
	97	sub B::PMOP::debug {
	98	my ($op) = @_;
	99	$op->B::LISTOP::debug();
7cd4b8a8	100	printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
a798dbf2	101	printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
7cd4b8a8 RGS	102	printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
7cd4b8a8 RGS	103	if ($Config{'useithreads'}) {
c1307613 RU	104	printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
	105	printf "\top_pmoffset\t%d\n", $op->pmoffset;
	106	} else {
	107	printf "\top_pmstash\t%s\n", cstring($op->pmstash);
	108	}
93f00e88	109	printf "\top_precomp\t%s\n", cstring($op->precomp);
a798dbf2	110	printf "\top_pmflags\t0x%x\n", $op->pmflags;
7cd4b8a8 RGS	111	printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
	112	printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
	113	printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
	114	$op->pmreplroot->debug if $] < 5.008;
a798dbf2 MB	115	}
	116
	117	sub B::COP::debug {
	118	my ($op) = @_;
	119	$op->B::OP::debug();
6e6a1aef	120	my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
127212b2	121	printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
c1307613 RU	122	cop_label "%s"
	123	cop_stashpv "%s"
	124	cop_file "%s"
a798dbf2 MB	125	cop_seq %d
	126	cop_arybase %d
	127	cop_line %d
b295d113	128	cop_warnings 0x%x
6e6a1aef	129	cop_io %s
a798dbf2	130	EOT
a798dbf2 MB	131	}
	132
	133	sub B::SVOP::debug {
	134	my ($op) = @_;
	135	$op->B::OP::debug();
	136	printf "\top_sv\t\t0x%x\n", ${$op->sv};
	137	$op->sv->debug;
	138	}
	139
	140	sub B::PVOP::debug {
	141	my ($op) = @_;
	142	$op->B::OP::debug();
3267896c	143	printf "\top_pv\t\t%s\n", cstring($op->pv);
a798dbf2 MB	144	}
a798dbf2 MB	145
7934575e	146	sub B::PADOP::debug {
a798dbf2 MB	147	my ($op) = @_;
a798dbf2 MB	148	$op->B::OP::debug();
c1307613	149	printf "\top_padix\t%ld\n", $op->padix;
a798dbf2 MB	150	}
a798dbf2 MB	151
a798dbf2 MB	152	sub B::NULL::debug {
	153	my ($sv) = @_;
	154	if ($$sv == ${sv_undef()}) {
	155	print "&sv_undef\n";
	156	} else {
	157	printf "NULL (0x%x)\n", $$sv;
	158	}
	159	}
	160
	161	sub B::SV::debug {
	162	my ($sv) = @_;
	163	if (!$$sv) {
	164	print class($sv), " = NULL\n";
	165	return;
	166	}
	167	printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
	168	%s (0x%x)
	169	REFCNT %d
	170	FLAGS 0x%x
	171	EOT
	172	}
	173
3267896c RH	174	sub B::RV::debug {
	175	my ($rv) = @_;
	176	B::SV::debug($rv);
	177	printf <<'EOT', ${$rv->RV};
	178	RV 0x%x
	179	EOT
	180	$rv->RV->debug;
	181	}
	182
a798dbf2 MB	183	sub B::PV::debug {
	184	my ($sv) = @_;
	185	$sv->B::SV::debug();
	186	my $pv = $sv->PV();
	187	printf <<'EOT', cstring($pv), length($pv);
	188	xpv_pv %s
	189	xpv_cur %d
	190	EOT
	191	}
	192
	193	sub B::IV::debug {
	194	my ($sv) = @_;
	195	$sv->B::SV::debug();
	196	printf "\txiv_iv\t\t%d\n", $sv->IV;
	197	}
	198
	199	sub B::NV::debug {
	200	my ($sv) = @_;
	201	$sv->B::IV::debug();
	202	printf "\txnv_nv\t\t%s\n", $sv->NV;
	203	}
	204
	205	sub B::PVIV::debug {
	206	my ($sv) = @_;
	207	$sv->B::PV::debug();
	208	printf "\txiv_iv\t\t%d\n", $sv->IV;
	209	}
	210
	211	sub B::PVNV::debug {
	212	my ($sv) = @_;
	213	$sv->B::PVIV::debug();
	214	printf "\txnv_nv\t\t%s\n", $sv->NV;
	215	}
	216
	217	sub B::PVLV::debug {
	218	my ($sv) = @_;
	219	$sv->B::PVNV::debug();
	220	printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
	221	printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
	222	printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
	223	}
	224
	225	sub B::BM::debug {
	226	my ($sv) = @_;
	227	$sv->B::PVNV::debug();
	228	printf "\txbm_useful\t%d\n", $sv->USEFUL;
	229	printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
	230	printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
	231	}
	232
	233	sub B::CV::debug {
	234	my ($sv) = @_;
	235	$sv->B::PVNV::debug();
	236	my ($stash) = $sv->STASH;
	237	my ($start) = $sv->START;
	238	my ($root) = $sv->ROOT;
	239	my ($padlist) = $sv->PADLIST;
57843af0	240	my ($file) = $sv->FILE;
a798dbf2	241	my ($gv) = $sv->GV;
a3985cdc	242	printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
a798dbf2 MB	243	STASH 0x%x
	244	START 0x%x
	245	ROOT 0x%x
	246	GV 0x%x
57843af0	247	FILE %s
a798dbf2	248	DEPTH %d
7e107e90	249	PADLIST 0x%x
a798dbf2	250	OUTSIDE 0x%x
a3985cdc	251	OUTSIDE_SEQ %d
a798dbf2 MB	252	EOT
	253	$start->debug if $start;
	254	$root->debug if $root;
	255	$gv->debug if $gv;
a798dbf2 MB	256	$padlist->debug if $padlist;
	257	}
	258
	259	sub B::AV::debug {
	260	my ($av) = @_;
	261	$av->B::SV::debug;
93f00e88 RU	262	# tied arrays may leave out FETCHSIZE
93f00e88 RU	263	my (@array) = eval { $av->ARRAY; };
a798dbf2	264	print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
93f00e88	265	my $fill = eval { scalar(@array) };
7cd4b8a8	266	if ($Config{'useithreads'}) {
93f00e88	267	printf <<'EOT', $fill, $av->MAX, $av->OFF;
7e107e90	268	FILL %d
a798dbf2 MB	269	MAX %d
a798dbf2 MB	270	OFF %d
a798dbf2	271	EOT
93f00e88 RU	272	} else {
	273	printf <<'EOT', $fill, $av->MAX;
	274	FILL %d
	275	MAX %d
	276	EOT
	277	}
7cd4b8a8	278	printf <<'EOT', $av->AvFLAGS if $] < 5.009;
bb7c595b NC	279	AvFLAGS %d
bb7c595b NC	280	EOT
a798dbf2	281	}
7e107e90	282
a798dbf2 MB	283	sub B::GV::debug {
	284	my ($gv) = @_;
	285	if ($done_gv{$$gv}++) {
002b978b	286	printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
a798dbf2 MB	287	return;
	288	}
	289	my ($sv) = $gv->SV;
	290	my ($av) = $gv->AV;
	291	my ($cv) = $gv->CV;
	292	$gv->B::SV::debug;
002b978b	293	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;
a798dbf2 MB	294	NAME %s
	295	STASH %s (0x%x)
	296	SV 0x%x
	297	GvREFCNT %d
	298	FORM 0x%x
	299	AV 0x%x
	300	HV 0x%x
	301	EGV 0x%x
	302	CV 0x%x
	303	CVGEN %d
	304	LINE %d
b195d487	305	FILE %s
a798dbf2 MB	306	GvFLAGS 0x%x
	307	EOT
	308	$sv->debug if $sv;
	309	$av->debug if $av;
	310	$cv->debug if $cv;
	311	}
	312
	313	sub B::SPECIAL::debug {
	314	my $sv = shift;
	315	print $specialsv_name[$$sv], "\n";
	316	}
	317
	318	sub compile {
	319	my $order = shift;
2b8dc4d2	320	B::clearsym();
7ebf56ae	321	if ($order && $order eq "exec") {
a798dbf2 MB	322	return sub { walkoptree_exec(main_start, "debug") }
	323	} else {
	324	return sub { walkoptree(main_root, "debug") }
	325	}
	326	}
	327
	328	1;
7f20e9dd GS	329
	330	__END__
	331
	332	=head1 NAME
	333
	334	B::Debug - Walk Perl syntax tree, printing debug info about ops
	335
	336	=head1 SYNOPSIS
	337
	338	perl -MO=Debug[,OPTIONS] foo.pl
	339
	340	=head1 DESCRIPTION
	341
c1307613 RU	342	See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
	343
	344	=head1 OPTIONS
	345
	346	With option -exec, walks tree in execute order,
	347	otherwise in basic order.
7f20e9dd	348
93f00e88 RU	349	=head1 Changes
93f00e88 RU	350
daaaeea5 RU	351	1.12 2010-02-10 rurban
	352	remove archlib installation cruft, and use the proper PM rule.
	353	By Todd Rinaldo (toddr)
	354
7cd4b8a8 RGS	355	1.11 2008-07-14 rurban
	356	avoid B::Flags in CORE tests not to crash on old XS in @INC
	357
	358	1.10 2008-06-28 rurban
	359	require 5.006; Test::More not possible in 5.00505
	360	our => my
0106d518	361
7cd4b8a8 RGS	362	1.09 2008-06-18 rurban
	363	minor META.yml syntax fix
	364	5.8.0 ending nextstate test failure: be more tolerant
	365	PREREQ_PM Test::More
	366
	367	1.08 2008-06-17 rurban
	368	support 5.00558 - 5.6.2
	369
	370	1.07 2008-06-16 rurban
	371	debug.t: fix strawberry perl quoting issue
	372
	373	1.06 2008-06-11 rurban
93f00e88 RU	374	added B::Flags output
	375	dual-life CPAN as B-Debug-1.06 and CORE
	376	protect scalar(@array) if tied arrays leave out FETCHSIZE
	377
	378	1.05_03 2008-04-16 rurban
	379	ithread fixes in B::AV
	380	B-C-1.04_??
	381
	382	B-C-1.04_09 2008-02-24 rurban
	383	support 5.8 (import Asmdata)
	384
	385	1.05_02 2008-02-21 rurban
	386	added _printop
	387	B-C-1.04_08 and CORE
	388
	389	1.05_01 2008-02-05 rurban
	390	5.10 fix for op->seq
	391	B-C-1.04_04
	392
7f20e9dd GS	393	=head1 AUTHOR
	394
	395	Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
93f00e88	396	Reini Urban C<rurban@cpan.org>
7f20e9dd	397
7cd4b8a8 RGS	398	=head1 LICENSE
	399
	400	Copyright (c) 1996, 1997 Malcolm Beattie
	401	Copyright (c) 2008 Reini Urban
	402
	403	This program is free software; you can redistribute it and/or modify
	404	it under the terms of either:
	405
	406	a) the GNU General Public License as published by the Free
	407	Software Foundation; either version 1, or (at your option) any
	408	later version, or
	409
	410	b) the "Artistic License" which comes with this kit.
	411
	412	This program is distributed in the hope that it will be useful,
	413	but WITHOUT ANY WARRANTY; without even the implied warranty of
	414	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
	415	the GNU General Public License or the Artistic License for more details.
	416
	417	You should have received a copy of the Artistic License with this kit,
	418	in the file named "Artistic". If not, you can get one from the Perl
	419	distribution. You should also have received a copy of the GNU General
	420	Public License, in the file named "Copying". If not, you can get one
	421	from the Perl distribution or else write to the Free Software Foundation,
	422	Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
	423
7f20e9dd	424	=cut