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