severe bugs in change#3786 fixed

[p5sagit/p5-mst-13.2.git] / ext / B / B.pm

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 0fff04d..8c46479 100644 (file)
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -6,15 +6,15 @@
 #      License or the Artistic License, as specified in the README file.
 #
 package B;
-require DynaLoader;
+use XSLoader ();
 require Exporter;
-@ISA = qw(Exporter DynaLoader);
-@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(minus_c ppname
                class peekop cast_I32 cstring cchar hash threadsv_names
-               main_root main_start main_cv svref_2object
+               main_root main_start main_cv svref_2object opnumber amagic_generation
                walkoptree walkoptree_slow walkoptree_exec walksymtable
-               parents comppadlist sv_undef compile_stats timing_info);
-
+               parents comppadlist sv_undef compile_stats timing_info init_av);
+sub OPf_KIDS ();
 use strict;
 @B::SV::ISA = 'B::OBJECT';
 @B::NULL::ISA = 'B::SV';
@@ -38,10 +38,9 @@ use strict;
 @B::UNOP::ISA = 'B::OP';
 @B::BINOP::ISA = 'B::UNOP';
 @B::LOGOP::ISA = 'B::UNOP';
-@B::CONDOP::ISA = 'B::UNOP';
 @B::LISTOP::ISA = 'B::BINOP';
 @B::SVOP::ISA = 'B::OP';
-@B::GVOP::ISA = 'B::OP';
+@B::PADOP::ISA = 'B::OP';
 @B::PVOP::ISA = 'B::OP';
 @B::CVOP::ISA = 'B::OP';
 @B::LOOP::ISA = 'B::LISTOP';
@@ -65,10 +64,6 @@ sub debug {
     walkoptree_debug($value);
 }
 
-# sub OPf_KIDS;
-# add to .xs for perl5.002
-sub OPf_KIDS () { 4 }
-
 sub class {
     my $obj = shift;
     my $name = ref $obj;
@@ -81,7 +76,7 @@ sub parents { \@parents }
 # For debugging
 sub peekop {
     my $op = shift;
-    return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+    return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
 }
 
 sub walkoptree_slow {
@@ -112,6 +107,11 @@ sub timing_info {
 }
 
 my %symtable;
+
+sub clearsym {
+    %symtable = ();
+}
+
 sub savesym {
     my ($obj, $value) = @_;
 #    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
@@ -135,37 +135,26 @@ sub walkoptree_exec {
        }
        savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
        $op->$method($level);
-       $ppname = $op->ppaddr;
-       if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
+       $ppname = $op->name;
+       if ($ppname =~
+           /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/)
+       {
            print $prefix, uc($1), " => {\n";
            walkoptree_exec($op->other, $method, $level + 1);
            print $prefix, "}\n";
-       } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+       } elsif ($ppname eq "match" || $ppname eq "subst") {
            my $pmreplstart = $op->pmreplstart;
            if ($$pmreplstart) {
                print $prefix, "PMREPLSTART => {\n";
                walkoptree_exec($pmreplstart, $method, $level + 1);
                print $prefix, "}\n";
            }
-       } elsif ($ppname eq "pp_substcont") {
+       } elsif ($ppname eq "substcont") {
            print $prefix, "SUBSTCONT => {\n";
            walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
            print $prefix, "}\n";
            $op = $op->other;
-       } elsif ($ppname eq "pp_cond_expr") {
-           # pp_cond_expr never returns op_next
-           print $prefix, "TRUE => {\n";
-           walkoptree_exec($op->true, $method, $level + 1);
-           print $prefix, "}\n";
-           $op = $op->false;
-           redo;
-       } elsif ($ppname eq "pp_range") {
-           print $prefix, "TRUE => {\n";
-           walkoptree_exec($op->true, $method, $level + 1);
-           print $prefix, "}\n", $prefix, "FALSE => {\n";
-           walkoptree_exec($op->false, $method, $level + 1);
-           print $prefix, "}\n";
-       } elsif ($ppname eq "pp_enterloop") {
+       } elsif ($ppname eq "enterloop") {
            print $prefix, "REDO => {\n";
            walkoptree_exec($op->redoop, $method, $level + 1);
            print $prefix, "}\n", $prefix, "NEXT => {\n";
@@ -173,7 +162,7 @@ sub walkoptree_exec {
            print $prefix, "}\n", $prefix, "LAST => {\n";
            walkoptree_exec($op->lastop,  $method, $level + 1);
            print $prefix, "}\n";
-       } elsif ($ppname eq "pp_subst") {
+       } elsif ($ppname eq "subst") {
            my $replstart = $op->pmreplstart;
            if ($$replstart) {
                print $prefix, "SUBST => {\n";
@@ -187,9 +176,12 @@ sub walkoptree_exec {
 sub walksymtable {
     my ($symref, $method, $recurse, $prefix) = @_;
     my $sym;
+    my $ref;
     no strict 'vars';
     local(*glob);
-    while (($sym, *glob) = each %$symref) {
+    $prefix = '' unless defined $prefix;
+    while (($sym, $ref) = each %$symref) {
+       *glob = "*main::".$prefix.$sym;
        if ($sym =~ /::$/) {
            $sym = $prefix . $sym;
            if ($sym ne "main::" && &$recurse($sym)) {
@@ -267,7 +259,7 @@ sub walksymtable {
     }
 }
 
-bootstrap B;
+XSLoader::load 'B';
 
 1;
 
@@ -450,6 +442,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =item LINE
 
+=item FILE
+
 =item FILEGV
 
 =item GvREFCNT
@@ -518,7 +512,7 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =item GV
 
-=item FILEGV
+=item FILE
 
 =item DEPTH
 
@@ -556,8 +550,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =head2 OP-RELATED CLASSES
 
-B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
-B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
+B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
+B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 These classes correspond in
 the obvious way to the underlying C structures of similar names. The
 inheritance hierarchy mimics the underlying C "inheritance". Access
@@ -572,9 +566,14 @@ leading "class indication" prefix removed (op_).
 
 =item sibling
 
+=item name
+
+This returns the op name as a string (e.g. "add", "rv2av").
+
 =item ppaddr
 
-This returns the function name as a string (e.g. pp_add, pp_rv2av).
+This returns the function name as a string (e.g. Perl_pp_add,
+Perl_pp_rv2av).
 
 =item desc
 
@@ -617,16 +616,6 @@ This returns the op description from the global C PL_op_desc array
 
 =back
 
-=head2 B::CONDOP METHODS
-
-=over 4
-
-=item true
-
-=item false
-
-=back
-
 =head2 B::LISTOP METHOD
 
 =over 4
@@ -661,13 +650,15 @@ This returns the op description from the global C PL_op_desc array
 
 =item sv
 
+=item gv
+
 =back
 
-=head2 B::GVOP METHOD
+=head2 B::PADOP METHOD
 
 =over 4
 
-=item gv
+=item padix
 
 =back
 
@@ -699,7 +690,7 @@ This returns the op description from the global C PL_op_desc array
 
 =item stash
 
-=item filegv
+=item file
 
 =item cop_seq
 
@@ -722,6 +713,10 @@ get an initial "handle" on an internal object.
 Return the (faked) CV corresponding to the main part of the Perl
 program.
 
+=item init_av
+
+Returns the AV object (i.e. in class B::AV) representing INIT blocks.
+
 =item main_root
 
 Returns the root op (i.e. an object in the appropriate B::OP-derived
@@ -747,6 +742,10 @@ Returns the SV object corresponding to the C variable C<sv_yes>.
 
 Returns the SV object corresponding to the C variable C<sv_no>.
 
+=item amagic_generation
+
+Returns the SV object corresponding to the C variable C<amagic_generation>.
+
 =item walkoptree(OP, METHOD)
 
 Does a tree-walk of the syntax tree based at OP and calls METHOD on
@@ -813,11 +812,6 @@ preceding the first "::". This is used to turn "B::UNOP" into
 In a perl compiled for threads, this returns a list of the special
 per-thread threadsv variables.
 
-=item byteload_fh(FILEHANDLE)
-
-Load the contents of FILEHANDLE as bytecode. See documentation for
-the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
-
 =back
 
 =head1 AUTHOR