This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial check-in of perl compiler.
[perl5.git] / B / Terse.pm
1 package B::Terse;
2 use strict;
3 use B qw(peekop class ad walkoptree 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($cv->ROOT, "terse");
14     }
15 }
16
17 sub compile {
18     my $order = shift;
19     my @options = @_;
20     if (@options) {
21         return sub {
22             my $objname;
23             foreach $objname (@options) {
24                 $objname = "main::$objname" unless $objname =~ /::/;
25                 eval "terse(\$order, \\&$objname)";
26                 die "terse($order, \\&$objname) failed: $@" if $@;
27             }
28         }
29     } else {
30         if ($order eq "exec") {
31             return sub { walkoptree_exec(main_start, "terse") }
32         } else {
33             return sub { walkoptree(main_root, "terse") }
34         }
35     }
36 }
37
38 sub indent {
39     my $level = shift;
40     return "    " x $level;
41 }
42
43 sub B::OP::terse {
44     my ($op, $level) = @_;
45     my $targ = $op->targ;
46     $targ = ($targ > 0) ? " [$targ]" : "";
47     print indent($level), peekop($op), $targ, "\n";
48 }
49
50 sub B::SVOP::terse {
51     my ($op, $level) = @_;
52     print indent($level), peekop($op), "  ";
53     $op->sv->terse(0);
54 }
55
56 sub B::GVOP::terse {
57     my ($op, $level) = @_;
58     print indent($level), peekop($op), "  ";
59     $op->gv->terse(0);
60 }
61
62 sub B::PMOP::terse {
63     my ($op, $level) = @_;
64     my $precomp = $op->precomp;
65     print indent($level), peekop($op),
66         defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
67
68 }
69
70 sub B::PVOP::terse {
71     my ($op, $level) = @_;
72     print indent($level), peekop($op), " ", cstring($op->pv), "\n";
73 }
74
75 sub B::COP::terse {
76     my ($op, $level) = @_;
77     my $label = $op->label;
78     if ($label) {
79         $label = " label ".cstring($label);
80     }
81     print indent($level), peekop($op), $label, "\n";
82 }
83
84 sub B::PV::terse {
85     my ($sv, $level) = @_;
86     print indent($level);
87     printf "%s (0x%lx) %s\n", class($sv), ad($sv), cstring($sv->PV);
88 }
89
90 sub B::AV::terse {
91     my ($sv, $level) = @_;
92     print indent($level);
93     printf "%s (0x%lx) FILL %d\n", class($sv), ad($sv), $sv->FILL;
94 }
95
96 sub B::GV::terse {
97     my ($gv, $level) = @_;
98     my $stash = $gv->STASH->NAME;
99     if ($stash eq "main") {
100         $stash = "";
101     } else {
102         $stash = $stash . "::";
103     }
104     print indent($level);
105     printf "%s (0x%lx) *%s%s\n", class($gv), ad($gv), $stash, $gv->NAME;
106 }
107
108 sub B::IV::terse {
109     my ($sv, $level) = @_;
110     print indent($level);
111     printf "%s (0x%lx) %d\n", class($sv), ad($sv), $sv->IV;
112 }
113
114 sub B::NV::terse {
115     my ($sv, $level) = @_;
116     print indent($level);
117     printf "%s (0x%lx) %s\n", class($sv), ad($sv), $sv->NV;
118 }
119
120 sub B::NULL::terse {
121     my ($sv, $level) = @_;
122     print indent($level);
123     printf "%s (0x%lx)\n", class($sv), ad($sv);
124 }
125     
126 sub B::SPECIAL::terse {
127     my ($sv, $level) = @_;
128     print indent($level);
129     printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
130 }
131
132 1;