Commit | Line | Data |
---|---|---|
a798dbf2 MB |
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 = @_; | |
2b8dc4d2 | 20 | B::clearsym(); |
a798dbf2 MB |
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 | } | |
c7a610ab | 82 | print indent($level), peekop($op), $label || "", "\n"; |
a798dbf2 MB |
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; | |
7f20e9dd GS |
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 |