B.pm

   1 #      B.pm
   2 #
   3 #      Copyright (c) 1996 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 ad cstring cchar hash
  14                 main_root main_start main_cv svref_2object
  15                 walkoptree walkoptree_exec walksymtable
  16                 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
  60 sub debug {
  61     my ($class, $value) = @_;
  62     $debug = $value;
  63 }
  64
  65 # sub OPf_KIDS;
  66 # add to .xs for perl5.002
  67 sub OPf_KIDS () { 4 }
  68
  69 sub ad {
  70     my $obj = shift;
  71     return $$obj;
  72 }
  73
  74 sub class {
  75     my $obj = shift;
  76     my $name = ref $obj;
  77     $name =~ s/^.*:://;
  78     return $name;
  79 }
  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 {
  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 (ad($op) && ($op->flags & OPf_KIDS)) {
  94         my $kid;
  95         for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
  96             walkoptree($kid, $method, $level + 1);
  97         }
  98     }
  99 }
 100
 101 sub compile_stats {
 102     return "Total number of OPs processed: $op_count\n";
 103 }
 104
 105 sub timing_info {
 106     my ($sec, $min, $hr) = localtime;
 107     my ($user, $sys) = times;
 108     sprintf("%02d:%02d:%02d user=$user sys=$sys",
 109             $hr, $min, $sec, $user, $sys);
 110 }
 111
 112 my %symtable;
 113 sub savesym {
 114     my ($obj, $value) = @_;
 115 #    warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
 116     $symtable{sprintf("sym_%x", ad($obj))} = $value;
 117 }
 118
 119 sub objsym {
 120     my $obj = shift;
 121     return $symtable{sprintf("sym_%x", ad($obj))};
 122 }
 123
 124 sub walkoptree_exec {
 125     my ($op, $method, $level) = @_;
 126     my ($sym, $ppname);
 127     my $prefix = "    " x $level;
 128     for (; $$op; $op = $op->next) {
 129         $sym = objsym($op);
 130         if (defined($sym)) {
 131             print $prefix, "goto $sym\n";
 132             return;
 133         }
 134         savesym($op, sprintf("%s (0x%lx)", class($op), ad($op)));
 135         $op->$method($level);
 136         $ppname = $op->ppaddr;
 137         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
 138             print $prefix, uc($1), " => {\n";
 139             walkoptree_exec($op->other, $method, $level + 1);
 140             print $prefix, "}\n";
 141         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
 142             my $pmreplstart = $op->pmreplstart;
 143             if (ad($pmreplstart)) {
 144                 print $prefix, "PMREPLSTART => {\n";
 145                 walkoptree_exec($pmreplstart, $method, $level + 1);
 146                 print $prefix, "}\n";
 147             }
 148         } elsif ($ppname eq "pp_substcont") {
 149             print $prefix, "SUBSTCONT => {\n";
 150             walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
 151             print $prefix, "}\n";
 152             $op = $op->other;
 153         } elsif ($ppname eq "pp_cond_expr") {
 154             # pp_cond_expr never returns op_next
 155             print $prefix, "TRUE => {\n";
 156             walkoptree_exec($op->true, $method, $level + 1);
 157             print $prefix, "}\n";
 158             $op = $op->false;
 159             redo;
 160         } elsif ($ppname eq "pp_range") {
 161             print $prefix, "TRUE => {\n";
 162             walkoptree_exec($op->true, $method, $level + 1);
 163             print $prefix, "}\n", $prefix, "FALSE => {\n";
 164             walkoptree_exec($op->false, $method, $level + 1);
 165             print $prefix, "}\n";
 166         } elsif ($ppname eq "pp_enterloop") {
 167             print $prefix, "REDO => {\n";
 168             walkoptree_exec($op->redoop, $method, $level + 1);
 169             print $prefix, "}\n", $prefix, "NEXT => {\n";
 170             walkoptree_exec($op->nextop, $method, $level + 1);
 171             print $prefix, "}\n", $prefix, "LAST => {\n";
 172             walkoptree_exec($op->lastop,  $method, $level + 1);
 173             print $prefix, "}\n";
 174         } elsif ($ppname eq "pp_subst") {
 175             my $replstart = $op->pmreplstart;
 176             if (ad($replstart)) {
 177                 print $prefix, "SUBST => {\n";
 178                 walkoptree_exec($replstart, $method, $level + 1);
 179                 print $prefix, "}\n";
 180             }
 181         }
 182     }
 183 }
 184
 185 sub walksymtable {
 186     my ($symref, $method, $recurse) = @_;
 187     my $sym;
 188     no strict 'vars';
 189     local(*glob);
 190     while (($sym, *glob) = each %$symref) {
 191         if ($sym =~ /::$/) {
 192             if ($sym ne "main::" && &$recurse($sym)) {
 193                 walksymtable(\%glob, $method, $recurse);
 194             }
 195         } else {
 196             svref_2object(\*glob)->EGV->$method();
 197         }
 198     }
 199 }
 200
 201 bootstrap B;
 202
 203 1;