ext/B/B.pm

   1 #      B.pm
   2 #
   3 #      Copyright (c) 1996, 1997 Malcolm Beattie
   4 #
   5 #      You may distribute under the terms of either the GNU General Public
   6 #      License or the Artistic License, as specified in the README file.
   7 #
   8 package B;
   9 require DynaLoader;
  10 require Exporter;
  11 @ISA = qw(Exporter DynaLoader);
  12 @EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
  13                 class peekop cast_I32 cstring cchar hash threadsv_names
  14                 main_root main_start main_cv svref_2object
  15                 walkoptree walkoptree_slow walkoptree_exec walksymtable
  16                 parents comppadlist sv_undef compile_stats timing_info);
  17
  18 use strict;
  19 @B::SV::ISA = 'B::OBJECT';
  20 @B::NULL::ISA = 'B::SV';
  21 @B::PV::ISA = 'B::SV';
  22 @B::IV::ISA = 'B::SV';
  23 @B::NV::ISA = 'B::IV';
  24 @B::RV::ISA = 'B::SV';
  25 @B::PVIV::ISA = qw(B::PV B::IV);
  26 @B::PVNV::ISA = qw(B::PV B::NV);
  27 @B::PVMG::ISA = 'B::PVNV';
  28 @B::PVLV::ISA = 'B::PVMG';
  29 @B::BM::ISA = 'B::PVMG';
  30 @B::AV::ISA = 'B::PVMG';
  31 @B::GV::ISA = 'B::PVMG';
  32 @B::HV::ISA = 'B::PVMG';
  33 @B::CV::ISA = 'B::PVMG';
  34 @B::IO::ISA = 'B::PVMG';
  35 @B::FM::ISA = 'B::CV';
  36
  37 @B::OP::ISA = 'B::OBJECT';
  38 @B::UNOP::ISA = 'B::OP';
  39 @B::BINOP::ISA = 'B::UNOP';
  40 @B::LOGOP::ISA = 'B::UNOP';
  41 @B::CONDOP::ISA = 'B::UNOP';
  42 @B::LISTOP::ISA = 'B::BINOP';
  43 @B::SVOP::ISA = 'B::OP';
  44 @B::GVOP::ISA = 'B::OP';
  45 @B::PVOP::ISA = 'B::OP';
  46 @B::CVOP::ISA = 'B::OP';
  47 @B::LOOP::ISA = 'B::LISTOP';
  48 @B::PMOP::ISA = 'B::LISTOP';
  49 @B::COP::ISA = 'B::OP';
  50
  51 @B::SPECIAL::ISA = 'B::OBJECT';
  52
  53 {
  54     # Stop "-w" from complaining about the lack of a real B::OBJECT class
  55     package B::OBJECT;
  56 }
  57
  58 my $debug;
  59 my $op_count = 0;
  60 my @parents = ();
  61
  62 sub debug {
  63     my ($class, $value) = @_;
  64     $debug = $value;
  65     walkoptree_debug($value);
  66 }
  67
  68 # sub OPf_KIDS;
  69 # add to .xs for perl5.002
  70 sub OPf_KIDS () { 4 }
  71
  72 sub class {
  73     my $obj = shift;
  74     my $name = ref $obj;
  75     $name =~ s/^.*:://;
  76     return $name;
  77 }
  78
  79 sub parents { \@parents }
  80
  81 # For debugging
  82 sub peekop {
  83     my $op = shift;
  84     return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
  85 }
  86
  87 sub walkoptree_slow {
  88     my($op, $method, $level) = @_;
  89     $op_count++; # just for statistics
  90     $level ||= 0;
  91     warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
  92     $op->$method($level);
  93     if ($$op && ($op->flags & OPf_KIDS)) {
  94         my $kid;
  95         unshift(@parents, $op);
  96         for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
  97             walkoptree_slow($kid, $method, $level + 1);
  98         }
  99         shift @parents;
 100     }
 101 }
 102
 103 sub compile_stats {
 104     return "Total number of OPs processed: $op_count\n";
 105 }
 106
 107 sub timing_info {
 108     my ($sec, $min, $hr) = localtime;
 109     my ($user, $sys) = times;
 110     sprintf("%02d:%02d:%02d user=$user sys=$sys",
 111             $hr, $min, $sec, $user, $sys);
 112 }
 113
 114 my %symtable;
 115 sub savesym {
 116     my ($obj, $value) = @_;
 117 #    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
 118     $symtable{sprintf("sym_%x", $$obj)} = $value;
 119 }
 120
 121 sub objsym {
 122     my $obj = shift;
 123     return $symtable{sprintf("sym_%x", $$obj)};
 124 }
 125
 126 sub walkoptree_exec {
 127     my ($op, $method, $level) = @_;
 128     my ($sym, $ppname);
 129     my $prefix = "    " x $level;
 130     for (; $$op; $op = $op->next) {
 131         $sym = objsym($op);
 132         if (defined($sym)) {
 133             print $prefix, "goto $sym\n";
 134             return;
 135         }
 136         savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
 137         $op->$method($level);
 138         $ppname = $op->ppaddr;
 139         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
 140             print $prefix, uc($1), " => {\n";
 141             walkoptree_exec($op->other, $method, $level + 1);
 142             print $prefix, "}\n";
 143         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
 144             my $pmreplstart = $op->pmreplstart;
 145             if ($$pmreplstart) {
 146                 print $prefix, "PMREPLSTART => {\n";
 147                 walkoptree_exec($pmreplstart, $method, $level + 1);
 148                 print $prefix, "}\n";
 149             }
 150         } elsif ($ppname eq "pp_substcont") {
 151             print $prefix, "SUBSTCONT => {\n";
 152             walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
 153             print $prefix, "}\n";
 154             $op = $op->other;
 155         } elsif ($ppname eq "pp_cond_expr") {
 156             # pp_cond_expr never returns op_next
 157             print $prefix, "TRUE => {\n";
 158             walkoptree_exec($op->true, $method, $level + 1);
 159             print $prefix, "}\n";
 160             $op = $op->false;
 161             redo;
 162         } elsif ($ppname eq "pp_range") {
 163             print $prefix, "TRUE => {\n";
 164             walkoptree_exec($op->true, $method, $level + 1);
 165             print $prefix, "}\n", $prefix, "FALSE => {\n";
 166             walkoptree_exec($op->false, $method, $level + 1);
 167             print $prefix, "}\n";
 168         } elsif ($ppname eq "pp_enterloop") {
 169             print $prefix, "REDO => {\n";
 170             walkoptree_exec($op->redoop, $method, $level + 1);
 171             print $prefix, "}\n", $prefix, "NEXT => {\n";
 172             walkoptree_exec($op->nextop, $method, $level + 1);
 173             print $prefix, "}\n", $prefix, "LAST => {\n";
 174             walkoptree_exec($op->lastop,  $method, $level + 1);
 175             print $prefix, "}\n";
 176         } elsif ($ppname eq "pp_subst") {
 177             my $replstart = $op->pmreplstart;
 178             if ($$replstart) {
 179                 print $prefix, "SUBST => {\n";
 180                 walkoptree_exec($replstart, $method, $level + 1);
 181                 print $prefix, "}\n";
 182             }
 183         }
 184     }
 185 }
 186
 187 sub walksymtable {
 188     my ($symref, $method, $recurse, $prefix) = @_;
 189     my $sym;
 190     no strict 'vars';
 191     local(*glob);
 192     while (($sym, *glob) = each %$symref) {
 193         if ($sym =~ /::$/) {
 194             $sym = $prefix . $sym;
 195             if ($sym ne "main::" && &$recurse($sym)) {
 196                 walksymtable(\%glob, $method, $recurse, $sym);
 197             }
 198         } else {
 199             svref_2object(\*glob)->EGV->$method();
 200         }
 201     }
 202 }
 203
 204 {
 205     package B::Section;
 206     my $output_fh;
 207     my %sections;
 208
 209     sub new {
 210         my ($class, $section, $symtable, $default) = @_;
 211         $output_fh ||= FileHandle->new_tmpfile;
 212         my $obj = bless [-1, $section, $symtable, $default], $class;
 213         $sections{$section} = $obj;
 214         return $obj;
 215     }
 216
 217     sub get {
 218         my ($class, $section) = @_;
 219         return $sections{$section};
 220     }
 221
 222     sub add {
 223         my $section = shift;
 224         while (defined($_ = shift)) {
 225             print $output_fh "$section->[1]\t$_\n";
 226             $section->[0]++;
 227         }
 228     }
 229
 230     sub index {
 231         my $section = shift;
 232         return $section->[0];
 233     }
 234
 235     sub name {
 236         my $section = shift;
 237         return $section->[1];
 238     }
 239
 240     sub symtable {
 241         my $section = shift;
 242         return $section->[2];
 243     }
 244
 245     sub default {
 246         my $section = shift;
 247         return $section->[3];
 248     }
 249
 250     sub output {
 251         my ($section, $fh, $format) = @_;
 252         my $name = $section->name;
 253         my $sym = $section->symtable || {};
 254         my $default = $section->default;
 255
 256         seek($output_fh, 0, 0);
 257         while (<$output_fh>) {
 258             chomp;
 259             s/^(.*?)\t//;
 260             if ($1 eq $name) {
 261                 s{(s\\_[0-9a-f]+)} {
 262                     exists($sym->{$1}) ? $sym->{$1} : $default;
 263                 }ge;
 264                 printf $fh $format, $_;
 265             }
 266         }
 267     }
 268 }
 269
 270 bootstrap B;
 271
 272 1;