X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB.pm;h=982395bb728ef9265e33b21c63f8378b3b745481;hb=1e1dbab6eed49955498a66ce3beedbd7ea33dc21;hp=75dcfb3b74d2ecae0006c11e5526c786e5955891;hpb=31d7d75aac642a364f35c283bcf351a66fe2c5ed;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B.pm b/ext/B/B.pm index 75dcfb3..982395b 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -6,15 +6,20 @@ # 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); + +# walkoptree comes from B.pm (you are there), walkoptree comes from B.xs +@EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object - walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info init_av); + main_root main_start main_cv svref_2object opnumber + amagic_generation + walkoptree_slow walkoptree walkoptree_exec walksymtable + parents comppadlist sv_undef compile_stats timing_info + begin_av init_av end_av); +sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @B::NULL::ISA = 'B::SV'; @@ -38,10 +43,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 +69,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 +81,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 +112,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 +140,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 +167,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,12 +181,15 @@ 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)) { + if ($sym ne "main::" && $sym ne "::" && &$recurse($sym)) { walksymtable(\%glob, $method, $recurse, $sym); } } else { @@ -267,7 +264,7 @@ sub walksymtable { } } -bootstrap B; +XSLoader::load 'B'; 1; @@ -428,6 +425,10 @@ C (corresponding to the C function C). =over 4 +=item is_empty + +This method returns TRUE if the GP field of the GV is NULL. + =item NAME =item STASH @@ -450,6 +451,8 @@ C (corresponding to the C function C). =item LINE +=item FILE + =item FILEGV =item GvREFCNT @@ -518,7 +521,7 @@ C (corresponding to the C function C). =item GV -=item FILEGV +=item FILE =item DEPTH @@ -532,6 +535,8 @@ C (corresponding to the C function C). =item CvFLAGS +=item const_sv + =back =head2 B::HV METHODS @@ -556,8 +561,8 @@ C (corresponding to the C function C). =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 +577,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. "PL_ppaddr[OP_ADD]", +"PL_ppaddr[OP_RV2AV]"). =item desc @@ -617,16 +627,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 +661,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 +701,7 @@ This returns the op description from the global C PL_op_desc array =item stash -=item filegv +=item file =item cop_seq @@ -751,6 +753,10 @@ Returns the SV object corresponding to the C variable C. Returns the SV object corresponding to the C variable C. +=item amagic_generation + +Returns the SV object corresponding to the C variable C. + =item walkoptree(OP, METHOD) Does a tree-walk of the syntax tree based at OP and calls METHOD on @@ -817,11 +823,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 module in F for how to generate bytecode. - =back =head1 AUTHOR