This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
suppress warning (from John Tobey <jtobey@epsilondev.com>)
[perl5.git] / ext / B / B / Terse.pm
1 package B::Terse;
2 use strict;
3 use B qw(peekop class walkoptree_slow walkoptree_exec
4          main_start main_root cstring svref_2object);
5 use B::Asmdata qw(@specialsv_name);
6
7 sub terse {
8     my ($order, $cvref) = @_;
9     my $cv = svref_2object($cvref);
10     if ($order eq "exec") {
11         walkoptree_exec($cv->START, "terse");
12     } else {
13         walkoptree_slow($cv->ROOT, "terse");
14     }
15 }
16
17 sub compile {
18     my $order = shift;
19     my @options = @_;
20     B::clearsym();
21     if (@options) {
22         return sub {
23             my $objname;
24             foreach $objname (@options) {
25                 $objname = "main::$objname" unless $objname =~ /::/;
26                 eval "terse(\$order, \\&$objname)";
27                 die "terse($order, \\&$objname) failed: $@" if $@;
28             }
29         }
30     } else {
31         if ($order eq "exec") {
32             return sub { walkoptree_exec(main_start, "terse") }
33         } else {
34             return sub { walkoptree_slow(main_root, "terse") }
35         }
36     }
37 }
38
39 sub indent {
40     my $level = shift;
41     return "    " x $level;
42 }
43
44 sub B::OP::terse {
45     my ($op, $level) = @_;
46     my $targ = $op->targ;
47     $targ = ($targ > 0) ? " [$targ]" : "";
48     print indent($level), peekop($op), $targ, "\n";
49 }
50
51 sub B::SVOP::terse {
52     my ($op, $level) = @_;
53     print indent($level), peekop($op), "  ";
54     $op->sv->terse(0);
55 }
56
57 sub B::GVOP::terse {
58     my ($op, $level) = @_;
59     print indent($level), peekop($op), "  ";
60     $op->gv->terse(0);
61 }
62
63 sub B::PMOP::terse {
64     my ($op, $level) = @_;
65     my $precomp = $op->precomp;
66     print indent($level), peekop($op),
67         defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
68
69 }
70
71 sub B::PVOP::terse {
72     my ($op, $level) = @_;
73     print indent($level), peekop($op), " ", cstring($op->pv), "\n";
74 }
75
76 sub B::COP::terse {
77     my ($op, $level) = @_;
78     my $label = $op->label;
79     if ($label) {
80         $label = " label ".cstring($label);
81     }
82     print indent($level), peekop($op), $label || "", "\n";
83 }
84
85 sub B::PV::terse {
86     my ($sv, $level) = @_;
87     print indent($level);
88     printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
89 }
90
91 sub B::AV::terse {
92     my ($sv, $level) = @_;
93     print indent($level);
94     printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
95 }
96
97 sub B::GV::terse {
98     my ($gv, $level) = @_;
99     my $stash = $gv->STASH->NAME;
100     if ($stash eq "main") {
101         $stash = "";
102     } else {
103         $stash = $stash . "::";
104     }
105     print indent($level);
106     printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME;
107 }
108
109 sub B::IV::terse {
110     my ($sv, $level) = @_;
111     print indent($level);
112     printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV;
113 }
114
115 sub B::NV::terse {
116     my ($sv, $level) = @_;
117     print indent($level);
118     printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
119 }
120
121 sub B::NULL::terse {
122     my ($sv, $level) = @_;
123     print indent($level);
124     printf "%s (0x%lx)\n", class($sv), $$sv;
125 }
126     
127 sub B::SPECIAL::terse {
128     my ($sv, $level) = @_;
129     print indent($level);
130     printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
131 }
132
133 1;
134
135 __END__
136
137 =head1 NAME
138
139 B::Terse - Walk Perl syntax tree, printing terse info about ops
140
141 =head1 SYNOPSIS
142
143         perl -MO=Terse[,OPTIONS] foo.pl
144
145 =head1 DESCRIPTION
146
147 See F<ext/B/README>.
148
149 =head1 AUTHOR
150
151 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
152
153 =cut