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