[Jifty-commit] r3567 - in B: . B C ramblings t
jifty-commit at lists.jifty.org
jifty-commit at lists.jifty.org
Tue Jun 26 12:23:27 EDT 2007
Author: clkao
Date: Tue Jun 26 12:23:24 2007
New Revision: 3567
Added:
B/B/
B/B.pm
B/B.xs
B/B/Asmdata.pm
B/B/Assembler.pm
B/B/Bblock.pm
B/B/Bytecode.pm
B/B/C.pm
B/B/CC.pm
B/B/Concise.pm
B/B/Debug.pm
B/B/Deparse.pm
B/B/Disassembler.pm
B/B/Lint.pm
B/B/Showlex.pm
B/B/Stackobj.pm
B/B/Stash.pm
B/B/Terse.pm
B/B/Xref.pm
B/B/assemble
B/B/cc_harness
B/B/disassemble
B/B/makeliblinks
B/C/
B/C/C.xs
B/C/Makefile.PL
B/Makefile.PL
B/NOTES
B/O.pm
B/README
B/TESTS
B/Todo
B/defsubs_h.PL
B/hints/
B/hints/darwin.pl
B/hints/openbsd.pl
B/ramblings/
B/ramblings/cc.notes
B/ramblings/curcop.runtime
B/ramblings/flip-flop
B/ramblings/magic
B/ramblings/reg.alloc
B/ramblings/runtime.porting
B/t/
B/t/OptreeCheck.pm
B/t/asmdata.t (contents, props changed)
B/t/assembler.t (contents, props changed)
B/t/b.t (contents, props changed)
B/t/bblock.t (contents, props changed)
B/t/bytecode.t (contents, props changed)
B/t/concise-xs.t (contents, props changed)
B/t/concise.t (contents, props changed)
B/t/debug.t (contents, props changed)
B/t/deparse.t (contents, props changed)
B/t/f_map
B/t/f_map.t (contents, props changed)
B/t/f_sort
B/t/f_sort.t (contents, props changed)
B/t/lint.t (contents, props changed)
B/t/o.t (contents, props changed)
B/t/optree_check.t (contents, props changed)
B/t/optree_concise.t (contents, props changed)
B/t/optree_samples.t (contents, props changed)
B/t/optree_sort.t (contents, props changed)
B/t/optree_specials.t (contents, props changed)
B/t/optree_varinit.t (contents, props changed)
B/t/showlex.t (contents, props changed)
B/t/stash.t (contents, props changed)
B/t/terse.t (contents, props changed)
B/t/xref.t (contents, props changed)
B/typemap
Modified:
B/ (props changed)
Log:
publish my cleaned-up B::Deparse.
Added: B/B.pm
==============================================================================
--- (empty file)
+++ B/B.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,1111 @@
+# B.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B;
+
+our $VERSION = '1.09_01';
+
+use XSLoader ();
+require Exporter;
+ at ISA = qw(Exporter);
+
+# walkoptree_slow comes from B.pm (you are there),
+# walkoptree comes from B.xs
+ at 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 opnumber
+ amagic_generation perlstring
+ walkoptree_slow walkoptree walkoptree_exec walksymtable
+ parents comppadlist sv_undef compile_stats timing_info
+ begin_av init_av check_av end_av regex_padav dowarn
+ defstash curstash warnhook diehook inc_gv
+ );
+
+sub OPf_KIDS ();
+use strict;
+ at B::SV::ISA = 'B::OBJECT';
+ at B::NULL::ISA = 'B::SV';
+ at B::PV::ISA = 'B::SV';
+ at B::IV::ISA = 'B::SV';
+ at B::NV::ISA = 'B::SV';
+ at B::RV::ISA = 'B::SV';
+ at B::PVIV::ISA = qw(B::PV B::IV);
+ at B::PVNV::ISA = qw(B::PVIV B::NV);
+ at B::PVMG::ISA = 'B::PVNV';
+# Change in the inheritance hierarchy post 5.9.0
+ at B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
+ at B::BM::ISA = 'B::PVMG';
+ at B::AV::ISA = 'B::PVMG';
+ at B::GV::ISA = 'B::PVMG';
+ at B::HV::ISA = 'B::PVMG';
+ at B::CV::ISA = 'B::PVMG';
+ at B::IO::ISA = 'B::PVMG';
+ at B::FM::ISA = 'B::CV';
+
+ at B::OP::ISA = 'B::OBJECT';
+ at B::UNOP::ISA = 'B::OP';
+ at B::BINOP::ISA = 'B::UNOP';
+ at B::LOGOP::ISA = 'B::UNOP';
+ at B::LISTOP::ISA = 'B::BINOP';
+ at B::SVOP::ISA = 'B::OP';
+ at B::PADOP::ISA = 'B::OP';
+ at B::PVOP::ISA = 'B::OP';
+ at B::LOOP::ISA = 'B::LISTOP';
+ at B::PMOP::ISA = 'B::LISTOP';
+ at B::COP::ISA = 'B::OP';
+
+ at B::SPECIAL::ISA = 'B::OBJECT';
+
+{
+ # Stop "-w" from complaining about the lack of a real B::OBJECT class
+ package B::OBJECT;
+}
+
+sub B::GV::SAFENAME {
+ my $name = (shift())->NAME;
+
+ # The regex below corresponds to the isCONTROLVAR macro
+ # from toke.c
+
+ $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
+ chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
+
+ # When we say unicode_to_native we really mean ascii_to_native,
+ # which matters iff this is a non-ASCII platform (EBCDIC).
+
+ return $name;
+}
+
+sub B::IV::int_value {
+ my ($self) = @_;
+ return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
+}
+
+sub B::NULL::as_string() {""}
+sub B::IV::as_string() {goto &B::IV::int_value}
+sub B::PV::as_string() {goto &B::PV::PV}
+
+my $debug;
+my $op_count = 0;
+my @parents = ();
+
+sub debug {
+ my ($class, $value) = @_;
+ $debug = $value;
+ walkoptree_debug($value);
+}
+
+sub class {
+ my $obj = shift;
+ my $name = ref $obj;
+ $name =~ s/^.*:://;
+ return $name;
+}
+
+sub parents { \@parents }
+
+# For debugging
+sub peekop {
+ my $op = shift;
+ return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
+}
+
+sub walkoptree_slow {
+ my($op, $method, $level) = @_;
+ $op_count++; # just for statistics
+ $level ||= 0;
+ warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
+ $op->$method($level);
+ if ($$op && ($op->flags & OPf_KIDS)) {
+ my $kid;
+ unshift(@parents, $op);
+ for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walkoptree_slow($kid, $method, $level + 1);
+ }
+ shift @parents;
+ }
+ if (class($op) eq 'PMOP' && ref($op->pmreplroot) && ${$op->pmreplroot}) {
+ unshift(@parents, $op);
+ walkoptree_slow($op->pmreplroot, $method, $level + 1);
+ shift @parents;
+ }
+}
+
+sub compile_stats {
+ return "Total number of OPs processed: $op_count\n";
+}
+
+sub timing_info {
+ my ($sec, $min, $hr) = localtime;
+ my ($user, $sys) = times;
+ sprintf("%02d:%02d:%02d user=$user sys=$sys",
+ $hr, $min, $sec, $user, $sys);
+}
+
+my %symtable;
+
+sub clearsym {
+ %symtable = ();
+}
+
+sub savesym {
+ my ($obj, $value) = @_;
+# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", $$obj)};
+}
+
+sub walkoptree_exec {
+ my ($op, $method, $level) = @_;
+ $level ||= 0;
+ my ($sym, $ppname);
+ my $prefix = " " x $level;
+ for (; $$op; $op = $op->next) {
+ $sym = objsym($op);
+ if (defined($sym)) {
+ print $prefix, "goto $sym\n";
+ return;
+ }
+ savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
+ $op->$method($level);
+ $ppname = $op->name;
+ if ($ppname =~
+ /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/)
+ {
+ print $prefix, uc($1), " => {\n";
+ walkoptree_exec($op->other, $method, $level + 1);
+ print $prefix, "}\n";
+ } 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 "substcont") {
+ print $prefix, "SUBSTCONT => {\n";
+ walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->other;
+ } elsif ($ppname eq "enterloop") {
+ print $prefix, "REDO => {\n";
+ walkoptree_exec($op->redoop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "NEXT => {\n";
+ walkoptree_exec($op->nextop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "LAST => {\n";
+ walkoptree_exec($op->lastop, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "subst") {
+ my $replstart = $op->pmreplstart;
+ if ($$replstart) {
+ print $prefix, "SUBST => {\n";
+ walkoptree_exec($replstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ }
+ }
+}
+
+sub walksymtable {
+ my ($symref, $method, $recurse, $prefix) = @_;
+ my $sym;
+ my $ref;
+ my $fullname;
+ no strict 'refs';
+ $prefix = '' unless defined $prefix;
+ while (($sym, $ref) = each %$symref) {
+ $fullname = "*main::".$prefix.$sym;
+ if ($sym =~ /::$/) {
+ $sym = $prefix . $sym;
+ if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
+ walksymtable(\%$fullname, $method, $recurse, $sym);
+ }
+ } else {
+ svref_2object(\*$fullname)->$method();
+ }
+ }
+}
+
+{
+ package B::Section;
+ my $output_fh;
+ my %sections;
+
+ sub new {
+ my ($class, $section, $symtable, $default) = @_;
+ $output_fh ||= FileHandle->new_tmpfile;
+ my $obj = bless [-1, $section, $symtable, $default], $class;
+ $sections{$section} = $obj;
+ return $obj;
+ }
+
+ sub get {
+ my ($class, $section) = @_;
+ return $sections{$section};
+ }
+
+ sub add {
+ my $section = shift;
+ while (defined($_ = shift)) {
+ print $output_fh "$section->[1]\t$_\n";
+ $section->[0]++;
+ }
+ }
+
+ sub index {
+ my $section = shift;
+ return $section->[0];
+ }
+
+ sub name {
+ my $section = shift;
+ return $section->[1];
+ }
+
+ sub symtable {
+ my $section = shift;
+ return $section->[2];
+ }
+
+ sub default {
+ my $section = shift;
+ return $section->[3];
+ }
+
+ sub output {
+ my ($section, $fh, $format) = @_;
+ my $name = $section->name;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+
+ seek($output_fh, 0, 0);
+ while (<$output_fh>) {
+ chomp;
+ s/^(.*?)\t//;
+ if ($1 eq $name) {
+ s{(s\\_[0-9a-f]+)} {
+ exists($sym->{$1}) ? $sym->{$1} : $default;
+ }ge;
+ printf $fh $format, $_;
+ }
+ }
+ }
+}
+
+XSLoader::load 'B';
+
+1;
+
+__END__
+
+=head1 NAME
+
+B - The Perl Compiler
+
+=head1 SYNOPSIS
+
+ use B;
+
+=head1 DESCRIPTION
+
+The C<B> module supplies classes which allow a Perl program to delve
+into its own innards. It is the module used to implement the
+"backends" of the Perl compiler. Usage of the compiler does not
+require knowledge of this module: see the F<O> module for the
+user-visible part. The C<B> module is of use to those who want to
+write new compiler backends. This documentation assumes that the
+reader knows a fair amount about perl's internals including such
+things as SVs, OPs and the internal symbol table and syntax tree
+of a program.
+
+=head1 OVERVIEW
+
+The C<B> module contains a set of utility functions for querying the
+current state of the Perl interpreter; typically these functions
+return objects from the B::SV and B::OP classes, or their derived
+classes. These classes in turn define methods for querying the
+resulting objects about their own internal state.
+
+=head1 Utility Functions
+
+The C<B> module exports a variety of functions: some are simple
+utility functions, others provide a Perl program with a way to
+get an initial "handle" on an internal object.
+
+=head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects
+
+For descriptions of the class hierarchy of these objects and the
+methods that can be called on them, see below, L<"OVERVIEW OF
+CLASSES"> and L<"SV-RELATED CLASSES">.
+
+=over 4
+
+=item sv_undef
+
+Returns the SV object corresponding to the C variable C<sv_undef>.
+
+=item sv_yes
+
+Returns the SV object corresponding to the C variable C<sv_yes>.
+
+=item sv_no
+
+Returns the SV object corresponding to the C variable C<sv_no>.
+
+=item svref_2object(SVREF)
+
+Takes a reference to any Perl value, and turns the referred-to value
+into an object in the appropriate B::OP-derived or B::SV-derived
+class. Apart from functions such as C<main_root>, this is the primary
+way to get an initial "handle" on an internal perl data structure
+which can then be followed with the other access methods.
+
+The returned object will only be valid as long as the underlying OPs
+and SVs continue to exist. Do not attempt to use the object after the
+underlying structures are freed.
+
+=item amagic_generation
+
+Returns the SV object corresponding to the C variable C<amagic_generation>.
+
+=item init_av
+
+Returns the AV object (i.e. in class B::AV) representing INIT blocks.
+
+=item check_av
+
+Returns the AV object (i.e. in class B::AV) representing CHECK blocks.
+
+=item begin_av
+
+Returns the AV object (i.e. in class B::AV) representing BEGIN blocks.
+
+=item end_av
+
+Returns the AV object (i.e. in class B::AV) representing END blocks.
+
+=item comppadlist
+
+Returns the AV object (i.e. in class B::AV) of the global comppadlist.
+
+=item regex_padav
+
+Only when perl was compiled with ithreads.
+
+=item main_cv
+
+Return the (faked) CV corresponding to the main part of the Perl
+program.
+
+=back
+
+=head2 Functions for Examining the Symbol Table
+
+=over 4
+
+=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
+
+Walk the symbol table starting at SYMREF and call METHOD on each
+symbol (a B::GV object) visited. When the walk reaches package
+symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
+name, and only recurses into the package if that sub returns true.
+
+PREFIX is the name of the SYMREF you're walking.
+
+For example:
+
+ # Walk CGI's symbol table calling print_subs on each symbol.
+ # Recurse only into CGI::Util::
+ walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
+ 'CGI::');
+
+print_subs() is a B::GV method you have declared. Also see L<"B::GV
+Methods">, below.
+
+=back
+
+=head2 Functions Returning C<B::OP> objects or for walking op trees
+
+For descriptions of the class hierarchy of these objects and the
+methods that can be called on them, see below, L<"OVERVIEW OF
+CLASSES"> and L<"OP-RELATED CLASSES">.
+
+=over 4
+
+=item main_root
+
+Returns the root op (i.e. an object in the appropriate B::OP-derived
+class) of the main part of the Perl program.
+
+=item main_start
+
+Returns the starting op of the main part of the Perl program.
+
+=item walkoptree(OP, METHOD)
+
+Does a tree-walk of the syntax tree based at OP and calls METHOD on
+each op it visits. Each node is visited before its children. If
+C<walkoptree_debug> (see below) has been called to turn debugging on then
+the method C<walkoptree_debug> is called on each op before METHOD is
+called.
+
+=item walkoptree_debug(DEBUG)
+
+Returns the current debugging flag for C<walkoptree>. If the optional
+DEBUG argument is non-zero, it sets the debugging flag to that. See
+the description of C<walkoptree> above for what the debugging flag
+does.
+
+=back
+
+=head2 Miscellaneous Utility Functions
+
+=over 4
+
+=item ppname(OPNUM)
+
+Return the PP function name (e.g. "pp_add") of op number OPNUM.
+
+=item hash(STR)
+
+Returns a string in the form "0x..." representing the value of the
+internal hash function used by perl on string STR.
+
+=item cast_I32(I)
+
+Casts I to the internal I32 type used by that perl.
+
+=item minus_c
+
+Does the equivalent of the C<-c> command-line option. Obviously, this
+is only useful in a BEGIN block or else the flag is set too late.
+
+=item cstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in C source code.
+
+=item perlstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in Perl source code.
+
+=item class(OBJ)
+
+Returns the class of an object without the part of the classname
+preceding the first C<"::">. This is used to turn C<"B::UNOP"> into
+C<"UNOP"> for example.
+
+=item threadsv_names
+
+In a perl compiled for threads, this returns a list of the special
+per-thread threadsv variables.
+
+=back
+
+
+
+
+=head1 OVERVIEW OF CLASSES
+
+The C structures used by Perl's internals to hold SV and OP
+information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
+class hierarchy and the C<B> module gives access to them via a true
+object hierarchy. Structure fields which point to other objects
+(whether types of SV or types of OP) are represented by the C<B>
+module as Perl objects of the appropriate class.
+
+The bulk of the C<B> module is the methods for accessing fields of
+these structures.
+
+Note that all access is read-only. You cannot modify the internals by
+using this module. Also, note that the B::OP and B::SV objects created
+by this module are only valid for as long as the underlying objects
+exist; their creation doesn't increase the reference counts of the
+underlying objects. Trying to access the fields of a freed object will
+give incomprehensible results, or worse.
+
+=head2 SV-RELATED CLASSES
+
+B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
+B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
+the obvious way to the underlying C structures of similar names. The
+inheritance hierarchy mimics the underlying C "inheritance". For 5.9.1
+and later this is:
+
+ B::SV
+ |
+ +--------------+----------+------------+
+ | | | |
+ B::PV B::IV B::NV B::RV
+ \ / /
+ \ / /
+ B::PVIV /
+ \ /
+ \ /
+ \ /
+ B::PVNV
+ |
+ |
+ B::PVMG
+ |
+ +-----+----+------+-----+-----+
+ | | | | | |
+ B::BM B::AV B::GV B::HV B::CV B::IO
+ | |
+ B::PVLV |
+ B::FM
+
+
+For 5.9.0 and earlier, PVLV is a direct subclass of PVMG, so the base
+of this diagram is
+
+ |
+ B::PVMG
+ |
+ +------+-----+----+------+-----+-----+
+ | | | | | | |
+ B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO
+ |
+ |
+ B::FM
+
+
+Access methods correspond to the underlying C macros for field access,
+usually with the leading "class indication" prefix removed (Sv, Av,
+Hv, ...). The leading prefix is only left in cases where its removal
+would cause a clash in method name. For example, C<GvREFCNT> stays
+as-is since its abbreviation would clash with the "superclass" method
+C<REFCNT> (corresponding to the C function C<SvREFCNT>).
+
+=head2 B::SV Methods
+
+=over 4
+
+=item REFCNT
+
+=item FLAGS
+
+=item object_2svref
+
+Returns a reference to the regular scalar corresponding to this
+B::SV object. In other words, this method is the inverse operation
+to the svref_2object() subroutine. This scalar and other data it points
+at should be considered read-only: modifying them is neither safe nor
+guaranteed to have a sensible effect.
+
+=back
+
+=head2 B::IV Methods
+
+=over 4
+
+=item IV
+
+Returns the value of the IV, I<interpreted as
+a signed integer>. This will be misleading
+if C<FLAGS & SVf_IVisUV>. Perhaps you want the
+C<int_value> method instead?
+
+=item IVX
+
+=item UVX
+
+=item int_value
+
+This method returns the value of the IV as an integer.
+It differs from C<IV> in that it returns the correct
+value regardless of whether it's stored signed or
+unsigned.
+
+=item needs64bits
+
+=item packiv
+
+=back
+
+=head2 B::NV Methods
+
+=over 4
+
+=item NV
+
+=item NVX
+
+=back
+
+=head2 B::RV Methods
+
+=over 4
+
+=item RV
+
+=back
+
+=head2 B::PV Methods
+
+=over 4
+
+=item PV
+
+This method is the one you usually want. It constructs a
+string using the length and offset information in the struct:
+for ordinary scalars it will return the string that you'd see
+from Perl, even if it contains null characters.
+
+=item RV
+
+Same as B::RV::RV, except that it will die() if the PV isn't
+a reference.
+
+=item PVX
+
+This method is less often useful. It assumes that the string
+stored in the struct is null-terminated, and disregards the
+length information.
+
+It is the appropriate method to use if you need to get the name
+of a lexical variable from a padname array. Lexical variable names
+are always stored with a null terminator, and the length field
+(SvCUR) is overloaded for other purposes and can't be relied on here.
+
+=back
+
+=head2 B::PVMG Methods
+
+=over 4
+
+=item MAGIC
+
+=item SvSTASH
+
+=back
+
+=head2 B::MAGIC Methods
+
+=over 4
+
+=item MOREMAGIC
+
+=item precomp
+
+Only valid on r-magic, returns the string that generated the regexp.
+
+=item PRIVATE
+
+=item TYPE
+
+=item FLAGS
+
+=item OBJ
+
+Will die() if called on r-magic.
+
+=item PTR
+
+=item REGEX
+
+Only valid on r-magic, returns the integer value of the REGEX stored
+in the MAGIC.
+
+=back
+
+=head2 B::PVLV Methods
+
+=over 4
+
+=item TARGOFF
+
+=item TARGLEN
+
+=item TYPE
+
+=item TARG
+
+=back
+
+=head2 B::BM Methods
+
+=over 4
+
+=item USEFUL
+
+=item PREVIOUS
+
+=item RARE
+
+=item TABLE
+
+=back
+
+=head2 B::GV Methods
+
+=over 4
+
+=item is_empty
+
+This method returns TRUE if the GP field of the GV is NULL.
+
+=item NAME
+
+=item SAFENAME
+
+This method returns the name of the glob, but if the first
+character of the name is a control character, then it converts
+it to ^X first, so that *^G would return "^G" rather than "\cG".
+
+It's useful if you want to print out the name of a variable.
+If you restrict yourself to globs which exist at compile-time
+then the result ought to be unambiguous, because code like
+C<${"^G"} = 1> is compiled as two ops - a constant string and
+a dereference (rv2gv) - so that the glob is created at runtime.
+
+If you're working with globs at runtime, and need to disambiguate
+*^G from *{"^G"}, then you should use the raw NAME method.
+
+=item STASH
+
+=item SV
+
+=item IO
+
+=item FORM
+
+=item AV
+
+=item HV
+
+=item EGV
+
+=item CV
+
+=item CVGEN
+
+=item LINE
+
+=item FILE
+
+=item FILEGV
+
+=item GvREFCNT
+
+=item FLAGS
+
+=back
+
+=head2 B::IO Methods
+
+=over 4
+
+=item LINES
+
+=item PAGE
+
+=item PAGE_LEN
+
+=item LINES_LEFT
+
+=item TOP_NAME
+
+=item TOP_GV
+
+=item FMT_NAME
+
+=item FMT_GV
+
+=item BOTTOM_NAME
+
+=item BOTTOM_GV
+
+=item SUBPROCESS
+
+=item IoTYPE
+
+=item IoFLAGS
+
+=item IsSTD
+
+Takes one arguments ( 'stdin' | 'stdout' | 'stderr' ) and returns true
+if the IoIFP of the object is equal to the handle whose name was
+passed as argument ( i.e. $io->IsSTD('stderr') is true if
+IoIFP($io) == PerlIO_stdin() ).
+
+=back
+
+=head2 B::AV Methods
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item OFF
+
+=item ARRAY
+
+=item ARRAYelt
+
+Like C<ARRAY>, but takes an index as an argument to get only one element,
+rather than a list of all of them.
+
+=item AvFLAGS
+
+=back
+
+=head2 B::CV Methods
+
+=over 4
+
+=item STASH
+
+=item START
+
+=item ROOT
+
+=item GV
+
+=item FILE
+
+=item DEPTH
+
+=item PADLIST
+
+=item OUTSIDE
+
+=item OUTSIDE_SEQ
+
+=item XSUB
+
+=item XSUBANY
+
+For constant subroutines, returns the constant SV returned by the subroutine.
+
+=item CvFLAGS
+
+=item const_sv
+
+=back
+
+=head2 B::HV Methods
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item KEYS
+
+=item RITER
+
+=item NAME
+
+=item PMROOT
+
+=item ARRAY
+
+=back
+
+=head2 OP-RELATED CLASSES
+
+C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
+C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<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":
+
+ B::OP
+ |
+ +---------------+--------+--------+
+ | | | |
+ B::UNOP B::SVOP B::PADOP B::COP
+ ,' `-.
+ / `--.
+ B::BINOP B::LOGOP
+ |
+ |
+ B::LISTOP
+ ,' `.
+ / \
+ B::LOOP B::PMOP
+
+Access methods correspond to the underlying C structre field names,
+with the leading "class indication" prefix (C<"op_">) removed.
+
+=head2 B::OP Methods
+
+These methods get the values of similarly named fields within the OP
+data structure. See top of C<op.h> for more info.
+
+=over 4
+
+=item next
+
+=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. "PL_ppaddr[OP_ADD]",
+"PL_ppaddr[OP_RV2AV]").
+
+=item desc
+
+This returns the op description from the global C PL_op_desc array
+(e.g. "addition" "array deref").
+
+=item targ
+
+=item type
+
+=item opt
+
+=item static
+
+=item flags
+
+=item private
+
+=item spare
+
+=back
+
+=head2 B::UNOP METHOD
+
+=over 4
+
+=item first
+
+=back
+
+=head2 B::BINOP METHOD
+
+=over 4
+
+=item last
+
+=back
+
+=head2 B::LOGOP METHOD
+
+=over 4
+
+=item other
+
+=back
+
+=head2 B::LISTOP METHOD
+
+=over 4
+
+=item children
+
+=back
+
+=head2 B::PMOP Methods
+
+=over 4
+
+=item pmreplroot
+
+=item pmreplstart
+
+=item pmnext
+
+=item pmregexp
+
+=item pmflags
+
+=item pmdynflags
+
+=item pmpermflags
+
+=item precomp
+
+=item pmoffset
+
+Only when perl was compiled with ithreads.
+
+=back
+
+=head2 B::SVOP METHOD
+
+=over 4
+
+=item sv
+
+=item gv
+
+=back
+
+=head2 B::PADOP METHOD
+
+=over 4
+
+=item padix
+
+=back
+
+=head2 B::PVOP METHOD
+
+=over 4
+
+=item pv
+
+=back
+
+=head2 B::LOOP Methods
+
+=over 4
+
+=item redoop
+
+=item nextop
+
+=item lastop
+
+=back
+
+=head2 B::COP Methods
+
+=over 4
+
+=item label
+
+=item stash
+
+=item stashpv
+
+=item file
+
+=item cop_seq
+
+=item arybase
+
+=item line
+
+=item warnings
+
+=item io
+
+=back
+
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B.xs
==============================================================================
--- (empty file)
+++ B/B.xs Tue Jun 26 12:23:24 2007
@@ -0,0 +1,1716 @@
+/* B.xs
+ *
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef PerlIO
+typedef PerlIO * InputStream;
+#else
+typedef FILE * InputStream;
+#endif
+
+
+static char *svclassnames[] = {
+ "B::NULL",
+ "B::IV",
+ "B::NV",
+ "B::RV",
+ "B::PV",
+ "B::PVIV",
+ "B::PVNV",
+ "B::PVMG",
+ "B::BM",
+#if PERL_VERSION >= 9
+ "B::GV",
+#endif
+ "B::PVLV",
+ "B::AV",
+ "B::HV",
+ "B::CV",
+#if PERL_VERSION <= 8
+ "B::GV",
+#endif
+ "B::FM",
+ "B::IO",
+};
+
+typedef enum {
+ OPc_NULL, /* 0 */
+ OPc_BASEOP, /* 1 */
+ OPc_UNOP, /* 2 */
+ OPc_BINOP, /* 3 */
+ OPc_LOGOP, /* 4 */
+ OPc_LISTOP, /* 5 */
+ OPc_PMOP, /* 6 */
+ OPc_SVOP, /* 7 */
+ OPc_PADOP, /* 8 */
+ OPc_PVOP, /* 9 */
+ OPc_LOOP, /* 10 */
+ OPc_COP /* 11 */
+} opclass;
+
+static char *opclassnames[] = {
+ "B::NULL",
+ "B::OP",
+ "B::UNOP",
+ "B::BINOP",
+ "B::LOGOP",
+ "B::LISTOP",
+ "B::PMOP",
+ "B::SVOP",
+ "B::PADOP",
+ "B::PVOP",
+ "B::LOOP",
+ "B::COP"
+};
+
+static size_t opsizes[] = {
+ 0,
+ sizeof(OP),
+ sizeof(UNOP),
+ sizeof(BINOP),
+ sizeof(LOGOP),
+ sizeof(LISTOP),
+ sizeof(PMOP),
+ sizeof(SVOP),
+ sizeof(PADOP),
+ sizeof(PVOP),
+ sizeof(LOOP),
+ sizeof(COP)
+};
+
+#define MY_CXT_KEY "B::_guts" XS_VERSION
+
+typedef struct {
+ int x_walkoptree_debug; /* Flag for walkoptree debug hook */
+ SV * x_specialsv_list[7];
+} my_cxt_t;
+
+START_MY_CXT
+
+#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
+#define specialsv_list (MY_CXT.x_specialsv_list)
+
+static opclass
+cc_opclass(pTHX_ const OP *o)
+{
+ if (!o)
+ return OPc_NULL;
+
+ if (o->op_type == 0)
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ if (o->op_type == OP_SASSIGN)
+ return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+
+#ifdef USE_ITHREADS
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
+ o->op_type == OP_AELEMFAST || o->op_type == OP_RCATLINE)
+ return OPc_PADOP;
+#endif
+
+ switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+ case OA_BASEOP:
+ return OPc_BASEOP;
+
+ case OA_UNOP:
+ return OPc_UNOP;
+
+ case OA_BINOP:
+ return OPc_BINOP;
+
+ case OA_LOGOP:
+ return OPc_LOGOP;
+
+ case OA_LISTOP:
+ return OPc_LISTOP;
+
+ case OA_PMOP:
+ return OPc_PMOP;
+
+ case OA_SVOP:
+ return OPc_SVOP;
+
+ case OA_PADOP:
+ return OPc_PADOP;
+
+ case OA_PVOP_OR_SVOP:
+ /*
+ * Character translations (tr///) are usually a PVOP, keeping a
+ * pointer to a table of shorts used to look up translations.
+ * Under utf8, however, a simple table isn't practical; instead,
+ * the OP is an SVOP, and the SV is a reference to a swash
+ * (i.e., an RV pointing to an HV).
+ */
+ return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+ ? OPc_SVOP : OPc_PVOP;
+
+ case OA_LOOP:
+ return OPc_LOOP;
+
+ case OA_COP:
+ return OPc_COP;
+
+ case OA_BASEOP_OR_UNOP:
+ /*
+ * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
+ * whether parens were seen. perly.y uses OPf_SPECIAL to
+ * signal whether a BASEOP had empty parens or none.
+ * Some other UNOPs are created later, though, so the best
+ * test is OPf_KIDS, which is set in newUNOP.
+ */
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ case OA_FILESTATOP:
+ /*
+ * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+ * the OPf_REF flag to distinguish between OP types instead of the
+ * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+ * return OPc_UNOP so that walkoptree can find our children. If
+ * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+ * (no argument to the operator) it's an OP; with OPf_REF set it's
+ * an SVOP (and op_sv is the GV for the filehandle argument).
+ */
+ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+#ifdef USE_ITHREADS
+ (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
+#else
+ (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
+#endif
+ case OA_LOOPEXOP:
+ /*
+ * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+ * label was omitted (in which case it's a BASEOP) or else a term was
+ * seen. In this last case, all except goto are definitely PVOP but
+ * goto is either a PVOP (with an ordinary constant label), an UNOP
+ * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
+ * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
+ * get set.
+ */
+ if (o->op_flags & OPf_STACKED)
+ return OPc_UNOP;
+ else if (o->op_flags & OPf_SPECIAL)
+ return OPc_BASEOP;
+ else
+ return OPc_PVOP;
+ }
+ warn("can't determine class of operator %s, assuming BASEOP\n",
+ PL_op_name[o->op_type]);
+ return OPc_BASEOP;
+}
+
+static char *
+cc_opclassname(pTHX_ const OP *o)
+{
+ return opclassnames[cc_opclass(aTHX_ o)];
+}
+
+static SV *
+make_sv_object(pTHX_ SV *arg, SV *sv)
+{
+ char *type = 0;
+ IV iv;
+ dMY_CXT;
+
+ for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
+ if (sv == specialsv_list[iv]) {
+ type = "B::SPECIAL";
+ break;
+ }
+ }
+ if (!type) {
+ type = svclassnames[SvTYPE(sv)];
+ iv = PTR2IV(sv);
+ }
+ sv_setiv(newSVrv(arg, type), iv);
+ return arg;
+}
+
+static SV *
+make_mg_object(pTHX_ SV *arg, MAGIC *mg)
+{
+ sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
+ return arg;
+}
+
+static SV *
+cstring(pTHX_ SV *sv, bool perlstyle)
+{
+ SV *sstr = newSVpvn("", 0);
+
+ if (!SvOK(sv))
+ sv_setpvn(sstr, "0", 1);
+ else if (perlstyle && SvUTF8(sv)) {
+ SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
+ const STRLEN len = SvCUR(sv);
+ const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
+ sv_setpvn(sstr,"\"",1);
+ while (*s)
+ {
+ if (*s == '"')
+ sv_catpvn(sstr, "\\\"", 2);
+ else if (*s == '$')
+ sv_catpvn(sstr, "\\$", 2);
+ else if (*s == '@')
+ sv_catpvn(sstr, "\\@", 2);
+ else if (*s == '\\')
+ {
+ if (strchr("nrftax\\",*(s+1)))
+ sv_catpvn(sstr, s++, 2);
+ else
+ sv_catpvn(sstr, "\\\\", 2);
+ }
+ else /* should always be printable */
+ sv_catpvn(sstr, s, 1);
+ ++s;
+ }
+ sv_catpv(sstr, "\"");
+ return sstr;
+ }
+ else
+ {
+ /* XXX Optimise? */
+ STRLEN len;
+ const char *s = SvPV(sv, len);
+ sv_catpv(sstr, "\"");
+ for (; len; len--, s++)
+ {
+ /* At least try a little for readability */
+ if (*s == '"')
+ sv_catpv(sstr, "\\\"");
+ else if (*s == '\\')
+ sv_catpv(sstr, "\\\\");
+ /* trigraphs - bleagh */
+ else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ sprintf(escbuff, "\\%03o", '?');
+ sv_catpv(sstr, escbuff);
+ }
+ else if (perlstyle && *s == '$')
+ sv_catpv(sstr, "\\$");
+ else if (perlstyle && *s == '@')
+ sv_catpv(sstr, "\\@");
+#ifdef EBCDIC
+ else if (isPRINT(*s))
+#else
+ else if (*s >= ' ' && *s < 127)
+#endif /* EBCDIC */
+ sv_catpvn(sstr, s, 1);
+ else if (*s == '\n')
+ sv_catpv(sstr, "\\n");
+ else if (*s == '\r')
+ sv_catpv(sstr, "\\r");
+ else if (*s == '\t')
+ sv_catpv(sstr, "\\t");
+ else if (*s == '\a')
+ sv_catpv(sstr, "\\a");
+ else if (*s == '\b')
+ sv_catpv(sstr, "\\b");
+ else if (*s == '\f')
+ sv_catpv(sstr, "\\f");
+ else if (!perlstyle && *s == '\v')
+ sv_catpv(sstr, "\\v");
+ else
+ {
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ const unsigned char c = (unsigned char) *s;
+ sprintf(escbuff, "\\%03o", c);
+ sv_catpv(sstr, escbuff);
+ }
+ /* XXX Add line breaks if string is long */
+ }
+ sv_catpv(sstr, "\"");
+ }
+ return sstr;
+}
+
+static SV *
+cchar(pTHX_ SV *sv)
+{
+ SV *sstr = newSVpvn("'", 1);
+ const char *s = SvPV_nolen(sv);
+
+ if (*s == '\'')
+ sv_catpvn(sstr, "\\'", 2);
+ else if (*s == '\\')
+ sv_catpvn(sstr, "\\\\", 2);
+#ifdef EBCDIC
+ else if (isPRINT(*s))
+#else
+ else if (*s >= ' ' && *s < 127)
+#endif /* EBCDIC */
+ sv_catpvn(sstr, s, 1);
+ else if (*s == '\n')
+ sv_catpvn(sstr, "\\n", 2);
+ else if (*s == '\r')
+ sv_catpvn(sstr, "\\r", 2);
+ else if (*s == '\t')
+ sv_catpvn(sstr, "\\t", 2);
+ else if (*s == '\a')
+ sv_catpvn(sstr, "\\a", 2);
+ else if (*s == '\b')
+ sv_catpvn(sstr, "\\b", 2);
+ else if (*s == '\f')
+ sv_catpvn(sstr, "\\f", 2);
+ else if (*s == '\v')
+ sv_catpvn(sstr, "\\v", 2);
+ else
+ {
+ /* no trigraph support */
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ unsigned char c = (unsigned char) *s;
+ sprintf(escbuff, "\\%03o", c);
+ sv_catpv(sstr, escbuff);
+ }
+ sv_catpvn(sstr, "'", 1);
+ return sstr;
+}
+
+static void
+walkoptree(pTHX_ SV *opsv, const char *method)
+{
+ dSP;
+ OP *o, *kid;
+ dMY_CXT;
+
+ if (!SvROK(opsv))
+ croak("opsv is not a reference");
+ opsv = sv_mortalcopy(opsv);
+ o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
+ if (walkoptree_debug) {
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method("walkoptree_debug", G_DISCARD);
+ }
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method(method, G_DISCARD);
+ if (o && (o->op_flags & OPf_KIDS)) {
+ for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
+ /* Use the same opsv. Rely on methods not to mess it up. */
+ sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
+ walkoptree(aTHX_ opsv, method);
+ }
+ }
+ if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
+ && (kid = cPMOPo->op_pmreplroot))
+ {
+ sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
+ walkoptree(aTHX_ opsv, method);
+ }
+}
+
+static SV **
+oplist(pTHX_ OP *o, SV **SP)
+{
+ for(; o; o = o->op_next) {
+ SV *opsv;
+#if PERL_VERSION >= 9
+ if (o->op_opt == 0)
+ break;
+ o->op_opt = 0;
+#else
+ if (o->op_seq == 0)
+ break;
+ o->op_seq = 0;
+#endif
+ opsv = sv_newmortal();
+ sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
+ XPUSHs(opsv);
+ switch (o->op_type) {
+ case OP_SUBST:
+ SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
+ continue;
+ case OP_SORT:
+ if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
+ OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
+ kid = kUNOP->op_first; /* pass rv2gv */
+ kid = kUNOP->op_first; /* pass leave */
+ SP = oplist(aTHX_ kid->op_next, SP);
+ }
+ continue;
+ }
+ switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+ case OA_LOGOP:
+ SP = oplist(aTHX_ cLOGOPo->op_other, SP);
+ break;
+ case OA_LOOP:
+ SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
+ SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
+ SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
+ break;
+ }
+ }
+ return SP;
+}
+
+typedef OP *B__OP;
+typedef UNOP *B__UNOP;
+typedef BINOP *B__BINOP;
+typedef LOGOP *B__LOGOP;
+typedef LISTOP *B__LISTOP;
+typedef PMOP *B__PMOP;
+typedef SVOP *B__SVOP;
+typedef PADOP *B__PADOP;
+typedef PVOP *B__PVOP;
+typedef LOOP *B__LOOP;
+typedef COP *B__COP;
+
+typedef SV *B__SV;
+typedef SV *B__IV;
+typedef SV *B__PV;
+typedef SV *B__NV;
+typedef SV *B__PVMG;
+typedef SV *B__PVLV;
+typedef SV *B__BM;
+typedef SV *B__RV;
+typedef SV *B__FM;
+typedef AV *B__AV;
+typedef HV *B__HV;
+typedef CV *B__CV;
+typedef GV *B__GV;
+typedef IO *B__IO;
+
+typedef MAGIC *B__MAGIC;
+
+MODULE = B PACKAGE = B PREFIX = B_
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+ HV *stash = gv_stashpvn("B", 1, TRUE);
+ AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
+ MY_CXT_INIT;
+ specialsv_list[0] = Nullsv;
+ specialsv_list[1] = &PL_sv_undef;
+ specialsv_list[2] = &PL_sv_yes;
+ specialsv_list[3] = &PL_sv_no;
+ specialsv_list[4] = pWARN_ALL;
+ specialsv_list[5] = pWARN_NONE;
+ specialsv_list[6] = pWARN_STD;
+#if PERL_VERSION <= 8
+# define CVf_ASSERTION 0
+#endif
+#include "defsubs.h"
+}
+
+#define B_main_cv() PL_main_cv
+#define B_init_av() PL_initav
+#define B_inc_gv() PL_incgv
+#define B_check_av() PL_checkav_save
+#define B_begin_av() PL_beginav_save
+#define B_end_av() PL_endav
+#define B_main_root() PL_main_root
+#define B_main_start() PL_main_start
+#define B_amagic_generation() PL_amagic_generation
+#define B_defstash() PL_defstash
+#define B_curstash() PL_curstash
+#define B_dowarn() PL_dowarn
+#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
+#define B_sv_undef() &PL_sv_undef
+#define B_sv_yes() &PL_sv_yes
+#define B_sv_no() &PL_sv_no
+#define B_formfeed() PL_formfeed
+#ifdef USE_ITHREADS
+#define B_regex_padav() PL_regex_padav
+#endif
+
+B::AV
+B_init_av()
+
+B::AV
+B_check_av()
+
+B::AV
+B_begin_av()
+
+B::AV
+B_end_av()
+
+B::GV
+B_inc_gv()
+
+#ifdef USE_ITHREADS
+
+B::AV
+B_regex_padav()
+
+#endif
+
+B::CV
+B_main_cv()
+
+B::OP
+B_main_root()
+
+B::OP
+B_main_start()
+
+long
+B_amagic_generation()
+
+B::AV
+B_comppadlist()
+
+B::SV
+B_sv_undef()
+
+B::SV
+B_sv_yes()
+
+B::SV
+B_sv_no()
+
+B::HV
+B_curstash()
+
+B::HV
+B_defstash()
+
+U8
+B_dowarn()
+
+B::SV
+B_formfeed()
+
+void
+B_warnhook()
+ CODE:
+ ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
+
+void
+B_diehook()
+ CODE:
+ ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
+
+MODULE = B PACKAGE = B
+
+void
+walkoptree(opsv, method)
+ SV * opsv
+ const char * method
+ CODE:
+ walkoptree(aTHX_ opsv, method);
+
+int
+walkoptree_debug(...)
+ CODE:
+ dMY_CXT;
+ RETVAL = walkoptree_debug;
+ if (items > 0 && SvTRUE(ST(1)))
+ walkoptree_debug = 1;
+ OUTPUT:
+ RETVAL
+
+#define address(sv) PTR2IV(sv)
+
+IV
+address(sv)
+ SV * sv
+
+B::SV
+svref_2object(sv)
+ SV * sv
+ CODE:
+ if (!SvROK(sv))
+ croak("argument is not a reference");
+ RETVAL = (SV*)SvRV(sv);
+ OUTPUT:
+ RETVAL
+
+void
+opnumber(name)
+const char * name
+CODE:
+{
+ int i;
+ IV result = -1;
+ ST(0) = sv_newmortal();
+ if (strncmp(name,"pp_",3) == 0)
+ name += 3;
+ for (i = 0; i < PL_maxo; i++)
+ {
+ if (strcmp(name, PL_op_name[i]) == 0)
+ {
+ result = i;
+ break;
+ }
+ }
+ sv_setiv(ST(0),result);
+}
+
+void
+ppname(opnum)
+ int opnum
+ CODE:
+ ST(0) = sv_newmortal();
+ if (opnum >= 0 && opnum < PL_maxo) {
+ sv_setpvn(ST(0), "pp_", 3);
+ sv_catpv(ST(0), PL_op_name[opnum]);
+ }
+
+void
+hash(sv)
+ SV * sv
+ CODE:
+ STRLEN len;
+ U32 hash = 0;
+ char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
+ const char *s = SvPV(sv, len);
+ PERL_HASH(hash, s, len);
+ sprintf(hexhash, "0x%"UVxf, (UV)hash);
+ ST(0) = sv_2mortal(newSVpv(hexhash, 0));
+
+#define cast_I32(foo) (I32)foo
+IV
+cast_I32(i)
+ IV i
+
+void
+minus_c()
+ CODE:
+ PL_minus_c = TRUE;
+
+void
+save_BEGINs()
+ CODE:
+ PL_savebegin = TRUE;
+
+SV *
+cstring(sv)
+ SV * sv
+ CODE:
+ RETVAL = cstring(aTHX_ sv, 0);
+ OUTPUT:
+ RETVAL
+
+SV *
+perlstring(sv)
+ SV * sv
+ CODE:
+ RETVAL = cstring(aTHX_ sv, 1);
+ OUTPUT:
+ RETVAL
+
+SV *
+cchar(sv)
+ SV * sv
+ CODE:
+ RETVAL = cchar(aTHX_ sv);
+ OUTPUT:
+ RETVAL
+
+void
+threadsv_names()
+ PPCODE:
+#if PERL_VERSION <= 8
+# ifdef USE_5005THREADS
+ int i;
+ const STRLEN len = strlen(PL_threadsv_names);
+
+ EXTEND(sp, len);
+ for (i = 0; i < len; i++)
+ PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
+# endif
+#endif
+
+#define OP_next(o) o->op_next
+#define OP_sibling(o) o->op_sibling
+#define OP_desc(o) PL_op_desc[o->op_type]
+#define OP_targ(o) o->op_targ
+#define OP_type(o) o->op_type
+#if PERL_VERSION >= 9
+# define OP_opt(o) o->op_opt
+# define OP_static(o) o->op_static
+#else
+# define OP_seq(o) o->op_seq
+#endif
+#define OP_flags(o) o->op_flags
+#define OP_private(o) o->op_private
+#define OP_spare(o) o->op_spare
+
+MODULE = B PACKAGE = B::OP PREFIX = OP_
+
+size_t
+OP_size(o)
+ B::OP o
+ CODE:
+ RETVAL = opsizes[cc_opclass(aTHX_ o)];
+ OUTPUT:
+ RETVAL
+
+B::OP
+OP_next(o)
+ B::OP o
+
+B::OP
+OP_sibling(o)
+ B::OP o
+
+char *
+OP_name(o)
+ B::OP o
+ CODE:
+ RETVAL = PL_op_name[o->op_type];
+ OUTPUT:
+ RETVAL
+
+
+void
+OP_ppaddr(o)
+ B::OP o
+ PREINIT:
+ int i;
+ SV *sv = sv_newmortal();
+ CODE:
+ sv_setpvn(sv, "PL_ppaddr[OP_", 13);
+ sv_catpv(sv, PL_op_name[o->op_type]);
+ for (i=13; (STRLEN)i < SvCUR(sv); ++i)
+ SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
+ sv_catpv(sv, "]");
+ ST(0) = sv;
+
+char *
+OP_desc(o)
+ B::OP o
+
+PADOFFSET
+OP_targ(o)
+ B::OP o
+
+U16
+OP_type(o)
+ B::OP o
+
+#if PERL_VERSION >= 9
+
+U8
+OP_opt(o)
+ B::OP o
+
+U8
+OP_static(o)
+ B::OP o
+
+#else
+
+U16
+OP_seq(o)
+ B::OP o
+
+#endif
+
+U8
+OP_flags(o)
+ B::OP o
+
+U8
+OP_private(o)
+ B::OP o
+
+#if PERL_VERSION >= 9
+
+U8
+OP_spare(o)
+ B::OP o
+
+#endif
+
+void
+OP_oplist(o)
+ B::OP o
+ PPCODE:
+ SP = oplist(aTHX_ o, SP);
+
+#define UNOP_first(o) o->op_first
+
+MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
+
+B::OP
+UNOP_first(o)
+ B::UNOP o
+
+#define BINOP_last(o) o->op_last
+
+MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
+
+B::OP
+BINOP_last(o)
+ B::BINOP o
+
+#define LOGOP_other(o) o->op_other
+
+MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
+
+B::OP
+LOGOP_other(o)
+ B::LOGOP o
+
+MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
+
+U32
+LISTOP_children(o)
+ B::LISTOP o
+ OP * kid = NO_INIT
+ int i = NO_INIT
+ CODE:
+ i = 0;
+ for (kid = o->op_first; kid; kid = kid->op_sibling)
+ i++;
+ RETVAL = i;
+ OUTPUT:
+ RETVAL
+
+#define PMOP_pmreplroot(o) o->op_pmreplroot
+#define PMOP_pmreplstart(o) o->op_pmreplstart
+#define PMOP_pmnext(o) o->op_pmnext
+#define PMOP_pmregexp(o) PM_GETRE(o)
+#ifdef USE_ITHREADS
+#define PMOP_pmoffset(o) o->op_pmoffset
+#define PMOP_pmstashpv(o) o->op_pmstashpv
+#else
+#define PMOP_pmstash(o) o->op_pmstash
+#endif
+#define PMOP_pmflags(o) o->op_pmflags
+#define PMOP_pmpermflags(o) o->op_pmpermflags
+#define PMOP_pmdynflags(o) o->op_pmdynflags
+
+MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
+
+void
+PMOP_pmreplroot(o)
+ B::PMOP o
+ OP * root = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ root = o->op_pmreplroot;
+ /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
+ if (o->op_type == OP_PUSHRE) {
+#ifdef USE_ITHREADS
+ sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
+#else
+ sv_setiv(newSVrv(ST(0), root ?
+ svclassnames[SvTYPE((SV*)root)] : "B::SV"),
+ PTR2IV(root));
+#endif
+ }
+ else {
+ sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
+ }
+
+B::OP
+PMOP_pmreplstart(o)
+ B::PMOP o
+
+B::PMOP
+PMOP_pmnext(o)
+ B::PMOP o
+
+#ifdef USE_ITHREADS
+
+IV
+PMOP_pmoffset(o)
+ B::PMOP o
+
+char*
+PMOP_pmstashpv(o)
+ B::PMOP o
+
+#else
+
+B::HV
+PMOP_pmstash(o)
+ B::PMOP o
+
+#endif
+
+U32
+PMOP_pmflags(o)
+ B::PMOP o
+
+U32
+PMOP_pmpermflags(o)
+ B::PMOP o
+
+U8
+PMOP_pmdynflags(o)
+ B::PMOP o
+
+void
+PMOP_precomp(o)
+ B::PMOP o
+ REGEXP * rx = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ rx = PM_GETRE(o);
+ if (rx)
+ sv_setpvn(ST(0), rx->precomp, rx->prelen);
+
+#define SVOP_sv(o) cSVOPo->op_sv
+#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
+
+MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
+
+B::SV
+SVOP_sv(o)
+ B::SVOP o
+
+B::GV
+SVOP_gv(o)
+ B::SVOP o
+
+#define PADOP_padix(o) o->op_padix
+#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
+#define PADOP_gv(o) ((o->op_padix \
+ && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
+ ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
+
+MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
+
+PADOFFSET
+PADOP_padix(o)
+ B::PADOP o
+
+B::SV
+PADOP_sv(o)
+ B::PADOP o
+
+B::GV
+PADOP_gv(o)
+ B::PADOP o
+
+MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
+
+void
+PVOP_pv(o)
+ B::PVOP o
+ CODE:
+ /*
+ * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
+ * whereas other PVOPs point to a null terminated string.
+ */
+ if (o->op_type == OP_TRANS &&
+ (o->op_private & OPpTRANS_COMPLEMENT) &&
+ !(o->op_private & OPpTRANS_DELETE))
+ {
+ const short* const tbl = (short*)o->op_pv;
+ const short entries = 257 + tbl[256];
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
+ }
+ else if (o->op_type == OP_TRANS) {
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
+ }
+ else
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
+
+#define LOOP_redoop(o) o->op_redoop
+#define LOOP_nextop(o) o->op_nextop
+#define LOOP_lastop(o) o->op_lastop
+
+MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
+
+
+B::OP
+LOOP_redoop(o)
+ B::LOOP o
+
+B::OP
+LOOP_nextop(o)
+ B::LOOP o
+
+B::OP
+LOOP_lastop(o)
+ B::LOOP o
+
+#define COP_label(o) o->cop_label
+#define COP_stashpv(o) CopSTASHPV(o)
+#define COP_stash(o) CopSTASH(o)
+#define COP_file(o) CopFILE(o)
+#define COP_filegv(o) CopFILEGV(o)
+#define COP_cop_seq(o) o->cop_seq
+#define COP_arybase(o) o->cop_arybase
+#define COP_line(o) CopLINE(o)
+#define COP_warnings(o) o->cop_warnings
+#define COP_io(o) o->cop_io
+
+MODULE = B PACKAGE = B::COP PREFIX = COP_
+
+char *
+COP_label(o)
+ B::COP o
+
+char *
+COP_stashpv(o)
+ B::COP o
+
+B::HV
+COP_stash(o)
+ B::COP o
+
+char *
+COP_file(o)
+ B::COP o
+
+B::GV
+COP_filegv(o)
+ B::COP o
+
+
+U32
+COP_cop_seq(o)
+ B::COP o
+
+I32
+COP_arybase(o)
+ B::COP o
+
+U32
+COP_line(o)
+ B::COP o
+
+B::SV
+COP_warnings(o)
+ B::COP o
+
+B::SV
+COP_io(o)
+ B::COP o
+
+MODULE = B PACKAGE = B::SV
+
+U32
+SvTYPE(sv)
+ B::SV sv
+
+#define object_2svref(sv) sv
+#define SVREF SV *
+
+SVREF
+object_2svref(sv)
+ B::SV sv
+
+MODULE = B PACKAGE = B::SV PREFIX = Sv
+
+U32
+SvREFCNT(sv)
+ B::SV sv
+
+U32
+SvFLAGS(sv)
+ B::SV sv
+
+U32
+SvPOK(sv)
+ B::SV sv
+
+U32
+SvROK(sv)
+ B::SV sv
+
+U32
+SvMAGICAL(sv)
+ B::SV sv
+
+MODULE = B PACKAGE = B::IV PREFIX = Sv
+
+IV
+SvIV(sv)
+ B::IV sv
+
+IV
+SvIVX(sv)
+ B::IV sv
+
+UV
+SvUVX(sv)
+ B::IV sv
+
+
+MODULE = B PACKAGE = B::IV
+
+#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
+
+int
+needs64bits(sv)
+ B::IV sv
+
+void
+packiv(sv)
+ B::IV sv
+ CODE:
+ if (sizeof(IV) == 8) {
+ U32 wp[2];
+ const IV iv = SvIVX(sv);
+ /*
+ * The following way of spelling 32 is to stop compilers on
+ * 32-bit architectures from moaning about the shift count
+ * being >= the width of the type. Such architectures don't
+ * reach this code anyway (unless sizeof(IV) > 8 but then
+ * everything else breaks too so I'm not fussed at the moment).
+ */
+#ifdef UV_IS_QUAD
+ wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
+#else
+ wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
+#endif
+ wp[1] = htonl(iv & 0xffffffff);
+ ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
+ } else {
+ U32 w = htonl((U32)SvIVX(sv));
+ ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
+ }
+
+MODULE = B PACKAGE = B::NV PREFIX = Sv
+
+NV
+SvNV(sv)
+ B::NV sv
+
+NV
+SvNVX(sv)
+ B::NV sv
+
+MODULE = B PACKAGE = B::RV PREFIX = Sv
+
+B::SV
+SvRV(sv)
+ B::RV sv
+
+MODULE = B PACKAGE = B::PV PREFIX = Sv
+
+char*
+SvPVX(sv)
+ B::PV sv
+
+B::SV
+SvRV(sv)
+ B::PV sv
+ CODE:
+ if( SvROK(sv) ) {
+ RETVAL = SvRV(sv);
+ }
+ else {
+ croak( "argument is not SvROK" );
+ }
+ OUTPUT:
+ RETVAL
+
+void
+SvPV(sv)
+ B::PV sv
+ CODE:
+ ST(0) = sv_newmortal();
+ if( SvPOK(sv) ) {
+ /* FIXME - we need a better way for B to identify PVs that are
+ in the pads as variable names. */
+ if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
+ /* It claims to be longer than the space allocated for it -
+ presuambly it's a variable name in the pad */
+ sv_setpv(ST(0), SvPV_nolen_const(sv));
+ } else {
+ sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
+ }
+ SvFLAGS(ST(0)) |= SvUTF8(sv);
+ }
+ else {
+ /* XXX for backward compatibility, but should fail */
+ /* croak( "argument is not SvPOK" ); */
+ sv_setpvn(ST(0), NULL, 0);
+ }
+
+void
+SvPVBM(sv)
+ B::PV sv
+ CODE:
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), SvPVX_const(sv),
+ SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
+
+
+STRLEN
+SvLEN(sv)
+ B::PV sv
+
+STRLEN
+SvCUR(sv)
+ B::PV sv
+
+MODULE = B PACKAGE = B::PVMG PREFIX = Sv
+
+void
+SvMAGIC(sv)
+ B::PVMG sv
+ MAGIC * mg = NO_INIT
+ PPCODE:
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
+ XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
+
+MODULE = B PACKAGE = B::PVMG
+
+B::HV
+SvSTASH(sv)
+ B::PVMG sv
+
+#define MgMOREMAGIC(mg) mg->mg_moremagic
+#define MgPRIVATE(mg) mg->mg_private
+#define MgTYPE(mg) mg->mg_type
+#define MgFLAGS(mg) mg->mg_flags
+#define MgOBJ(mg) mg->mg_obj
+#define MgLENGTH(mg) mg->mg_len
+#define MgREGEX(mg) PTR2IV(mg->mg_obj)
+
+MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
+
+B::MAGIC
+MgMOREMAGIC(mg)
+ B::MAGIC mg
+ CODE:
+ if( MgMOREMAGIC(mg) ) {
+ RETVAL = MgMOREMAGIC(mg);
+ }
+ else {
+ XSRETURN_UNDEF;
+ }
+ OUTPUT:
+ RETVAL
+
+U16
+MgPRIVATE(mg)
+ B::MAGIC mg
+
+char
+MgTYPE(mg)
+ B::MAGIC mg
+
+U8
+MgFLAGS(mg)
+ B::MAGIC mg
+
+B::SV
+MgOBJ(mg)
+ B::MAGIC mg
+
+IV
+MgREGEX(mg)
+ B::MAGIC mg
+ CODE:
+ if( mg->mg_type == 'r' ) {
+ RETVAL = MgREGEX(mg);
+ }
+ else {
+ croak( "REGEX is only meaningful on r-magic" );
+ }
+ OUTPUT:
+ RETVAL
+
+SV*
+precomp(mg)
+ B::MAGIC mg
+ CODE:
+ if (mg->mg_type == 'r') {
+ REGEXP* rx = (REGEXP*)mg->mg_obj;
+ if( rx )
+ RETVAL = newSVpvn( rx->precomp, rx->prelen );
+ }
+ else {
+ croak( "precomp is only meaningful on r-magic" );
+ }
+ OUTPUT:
+ RETVAL
+
+I32
+MgLENGTH(mg)
+ B::MAGIC mg
+
+void
+MgPTR(mg)
+ B::MAGIC mg
+ CODE:
+ ST(0) = sv_newmortal();
+ if (mg->mg_ptr){
+ if (mg->mg_len >= 0){
+ sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+ } else if (mg->mg_len == HEf_SVKEY) {
+ ST(0) = make_sv_object(aTHX_
+ sv_newmortal(), (SV*)mg->mg_ptr);
+ }
+ }
+
+MODULE = B PACKAGE = B::PVLV PREFIX = Lv
+
+U32
+LvTARGOFF(sv)
+ B::PVLV sv
+
+U32
+LvTARGLEN(sv)
+ B::PVLV sv
+
+char
+LvTYPE(sv)
+ B::PVLV sv
+
+B::SV
+LvTARG(sv)
+ B::PVLV sv
+
+MODULE = B PACKAGE = B::BM PREFIX = Bm
+
+I32
+BmUSEFUL(sv)
+ B::BM sv
+
+U16
+BmPREVIOUS(sv)
+ B::BM sv
+
+U8
+BmRARE(sv)
+ B::BM sv
+
+void
+BmTABLE(sv)
+ B::BM sv
+ STRLEN len = NO_INIT
+ char * str = NO_INIT
+ CODE:
+ str = SvPV(sv, len);
+ /* Boyer-Moore table is just after string and its safety-margin \0 */
+ ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
+
+MODULE = B PACKAGE = B::GV PREFIX = Gv
+
+void
+GvNAME(gv)
+ B::GV gv
+ CODE:
+ ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
+
+bool
+is_empty(gv)
+ B::GV gv
+ CODE:
+ RETVAL = GvGP(gv) == Null(GP*);
+ OUTPUT:
+ RETVAL
+
+void*
+GvGP(gv)
+ B::GV gv
+
+B::HV
+GvSTASH(gv)
+ B::GV gv
+
+B::SV
+GvSV(gv)
+ B::GV gv
+
+B::IO
+GvIO(gv)
+ B::GV gv
+
+B::FM
+GvFORM(gv)
+ B::GV gv
+ CODE:
+ RETVAL = (SV*)GvFORM(gv);
+ OUTPUT:
+ RETVAL
+
+B::AV
+GvAV(gv)
+ B::GV gv
+
+B::HV
+GvHV(gv)
+ B::GV gv
+
+B::GV
+GvEGV(gv)
+ B::GV gv
+
+B::CV
+GvCV(gv)
+ B::GV gv
+
+U32
+GvCVGEN(gv)
+ B::GV gv
+
+U32
+GvLINE(gv)
+ B::GV gv
+
+char *
+GvFILE(gv)
+ B::GV gv
+
+B::GV
+GvFILEGV(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::GV
+
+U32
+GvREFCNT(gv)
+ B::GV gv
+
+U8
+GvFLAGS(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::IO PREFIX = Io
+
+long
+IoLINES(io)
+ B::IO io
+
+long
+IoPAGE(io)
+ B::IO io
+
+long
+IoPAGE_LEN(io)
+ B::IO io
+
+long
+IoLINES_LEFT(io)
+ B::IO io
+
+char *
+IoTOP_NAME(io)
+ B::IO io
+
+B::GV
+IoTOP_GV(io)
+ B::IO io
+
+char *
+IoFMT_NAME(io)
+ B::IO io
+
+B::GV
+IoFMT_GV(io)
+ B::IO io
+
+char *
+IoBOTTOM_NAME(io)
+ B::IO io
+
+B::GV
+IoBOTTOM_GV(io)
+ B::IO io
+
+short
+IoSUBPROCESS(io)
+ B::IO io
+
+bool
+IsSTD(io,name)
+ B::IO io
+ const char* name
+ PREINIT:
+ PerlIO* handle = 0;
+ CODE:
+ if( strEQ( name, "stdin" ) ) {
+ handle = PerlIO_stdin();
+ }
+ else if( strEQ( name, "stdout" ) ) {
+ handle = PerlIO_stdout();
+ }
+ else if( strEQ( name, "stderr" ) ) {
+ handle = PerlIO_stderr();
+ }
+ else {
+ croak( "Invalid value '%s'", name );
+ }
+ RETVAL = handle == IoIFP(io);
+ OUTPUT:
+ RETVAL
+
+MODULE = B PACKAGE = B::IO
+
+char
+IoTYPE(io)
+ B::IO io
+
+U8
+IoFLAGS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::AV PREFIX = Av
+
+SSize_t
+AvFILL(av)
+ B::AV av
+
+SSize_t
+AvMAX(av)
+ B::AV av
+
+#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
+
+IV
+AvOFF(av)
+ B::AV av
+
+void
+AvARRAY(av)
+ B::AV av
+ PPCODE:
+ if (AvFILL(av) >= 0) {
+ SV **svp = AvARRAY(av);
+ I32 i;
+ for (i = 0; i <= AvFILL(av); i++)
+ XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
+ }
+
+void
+AvARRAYelt(av, idx)
+ B::AV av
+ int idx
+ PPCODE:
+ if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
+ XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
+ else
+ XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
+
+
+MODULE = B PACKAGE = B::AV
+
+U8
+AvFLAGS(av)
+ B::AV av
+
+MODULE = B PACKAGE = B::FM PREFIX = Fm
+
+IV
+FmLINES(form)
+ B::FM form
+
+MODULE = B PACKAGE = B::CV PREFIX = Cv
+
+U32
+CvCONST(cv)
+ B::CV cv
+
+B::HV
+CvSTASH(cv)
+ B::CV cv
+
+B::OP
+CvSTART(cv)
+ B::CV cv
+
+B::OP
+CvROOT(cv)
+ B::CV cv
+
+B::GV
+CvGV(cv)
+ B::CV cv
+
+char *
+CvFILE(cv)
+ B::CV cv
+
+long
+CvDEPTH(cv)
+ B::CV cv
+
+B::AV
+CvPADLIST(cv)
+ B::CV cv
+
+B::CV
+CvOUTSIDE(cv)
+ B::CV cv
+
+U32
+CvOUTSIDE_SEQ(cv)
+ B::CV cv
+
+void
+CvXSUB(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv))));
+
+
+void
+CvXSUBANY(cv)
+ B::CV cv
+ CODE:
+ ST(0) = CvCONST(cv) ?
+ make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
+ sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+
+MODULE = B PACKAGE = B::CV
+
+U16
+CvFLAGS(cv)
+ B::CV cv
+
+MODULE = B PACKAGE = B::CV PREFIX = cv_
+
+B::SV
+cv_const_sv(cv)
+ B::CV cv
+
+
+MODULE = B PACKAGE = B::HV PREFIX = Hv
+
+STRLEN
+HvFILL(hv)
+ B::HV hv
+
+STRLEN
+HvMAX(hv)
+ B::HV hv
+
+I32
+HvKEYS(hv)
+ B::HV hv
+
+I32
+HvRITER(hv)
+ B::HV hv
+
+char *
+HvNAME(hv)
+ B::HV hv
+
+B::PMOP
+HvPMROOT(hv)
+ B::HV hv
+
+void
+HvARRAY(hv)
+ B::HV hv
+ PPCODE:
+ if (HvKEYS(hv) > 0) {
+ SV *sv;
+ char *key;
+ I32 len;
+ (void)hv_iterinit(hv);
+ EXTEND(sp, HvKEYS(hv) * 2);
+ while ((sv = hv_iternextsv(hv, &key, &len))) {
+ PUSHs(newSVpvn(key, len));
+ PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
+ }
+ }
Added: B/B/Asmdata.pm
==============================================================================
--- (empty file)
+++ B/B/Asmdata.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,250 @@
+# -#- buffer-read-only: t -#-
+#
+# Copyright (c) 1996-1999 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+#
+#
+# This file is autogenerated from bytecode.pl. Changes made here will be lost.
+#
+package B::Asmdata;
+
+our $VERSION = '1.01';
+
+use Exporter;
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+our(%insn_data, @insn_name, @optype, @specialsv_name);
+
+ at optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
+ at specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
+
+# XXX insn_data is initialised this way because with a large
+# %insn_data = (foo => [...], bar => [...], ...) initialiser
+# I get a hard-to-track-down stack underflow and segfault.
+$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"];
+$insn_data{nop} = [10, \&PUT_none, "GET_none"];
+$insn_data{ret} = [0, \&PUT_none, "GET_none"];
+$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
+$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"];
+$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
+$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
+$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"];
+$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"];
+$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"];
+$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"];
+$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"];
+$insn_data{newop} = [11, \&PUT_U8, "GET_U8"];
+$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"];
+$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"];
+$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"];
+$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{pv_free} = [16, \&PUT_none, "GET_none"];
+$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"];
+$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"];
+$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"];
+$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"];
+$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"];
+$insn_data{xpv} = [22, \&PUT_none, "GET_none"];
+$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"];
+$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"];
+$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"];
+$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"];
+$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"];
+$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"];
+$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"];
+$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"];
+$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"];
+$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"];
+$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"];
+$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"];
+$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_subprocess} = [46, \&PUT_U16, "GET_U16"];
+$insn_data{xio_type} = [47, \&PUT_U8, "GET_U8"];
+$insn_data{xio_flags} = [48, \&PUT_U8, "GET_U8"];
+$insn_data{xcv_xsubany} = [49, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_stash} = [50, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_start} = [51, \&PUT_opindex, "GET_opindex"];
+$insn_data{xcv_root} = [52, \&PUT_opindex, "GET_opindex"];
+$insn_data{xcv_gv} = [53, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_file} = [54, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xcv_depth} = [55, \&PUT_long, "GET_long"];
+$insn_data{xcv_padlist} = [56, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_outside} = [57, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_outside_seq} = [58, \&PUT_U32, "GET_U32"];
+$insn_data{xcv_flags} = [59, \&PUT_U16, "GET_U16"];
+$insn_data{av_extend} = [60, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{av_pushx} = [61, \&PUT_svindex, "GET_svindex"];
+$insn_data{av_push} = [62, \&PUT_svindex, "GET_svindex"];
+$insn_data{xav_fill} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xav_max} = [64, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xav_flags} = [65, \&PUT_U8, "GET_U8"];
+$insn_data{xhv_riter} = [66, \&PUT_I32, "GET_I32"];
+$insn_data{xhv_name} = [67, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xhv_pmroot} = [68, \&PUT_opindex, "GET_opindex"];
+$insn_data{hv_store} = [69, \&PUT_svindex, "GET_svindex"];
+$insn_data{sv_magic} = [70, \&PUT_U8, "GET_U8"];
+$insn_data{mg_obj} = [71, \&PUT_svindex, "GET_svindex"];
+$insn_data{mg_private} = [72, \&PUT_U16, "GET_U16"];
+$insn_data{mg_flags} = [73, \&PUT_U8, "GET_U8"];
+$insn_data{mg_name} = [74, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{mg_namex} = [75, \&PUT_svindex, "GET_svindex"];
+$insn_data{xmg_stash} = [76, \&PUT_svindex, "GET_svindex"];
+$insn_data{gv_fetchpv} = [77, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_fetchpvx} = [78, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpv} = [79, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpvx} = [80, \&PUT_strconst, "GET_strconst"];
+$insn_data{gp_sv} = [81, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_refcnt} = [82, \&PUT_U32, "GET_U32"];
+$insn_data{gp_refcnt_add} = [83, \&PUT_I32, "GET_I32"];
+$insn_data{gp_av} = [84, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_hv} = [85, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_cv} = [86, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_file} = [87, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{gp_io} = [88, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_form} = [89, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_cvgen} = [90, \&PUT_U32, "GET_U32"];
+$insn_data{gp_line} = [91, \&PUT_U32, "GET_U32"];
+$insn_data{gp_share} = [92, \&PUT_svindex, "GET_svindex"];
+$insn_data{xgv_flags} = [93, \&PUT_U8, "GET_U8"];
+$insn_data{op_next} = [94, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_sibling} = [95, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_ppaddr} = [96, \&PUT_strconst, "GET_strconst"];
+$insn_data{op_targ} = [97, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_type} = [98, \&PUT_U16, "GET_U16"];
+$insn_data{op_seq} = [99, \&PUT_U16, "GET_U16"];
+$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"];
+$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"];
+$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmnext} = [107, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmstashpv} = [108, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{op_pmreplrootpo} = [109, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_pmstash} = [110, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_pmreplrootgv} = [111, \&PUT_svindex, "GET_svindex"];
+$insn_data{pregcomp} = [112, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pmflags} = [113, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmpermflags} = [114, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmdynflags} = [115, \&PUT_U8, "GET_U8"];
+$insn_data{op_sv} = [116, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_padix} = [117, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_pv} = [118, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [119, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [120, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_nextop} = [121, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_lastop} = [122, \&PUT_opindex, "GET_opindex"];
+$insn_data{cop_label} = [123, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_stashpv} = [124, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_file} = [125, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_stash} = [126, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_filegv} = [127, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_seq} = [128, \&PUT_U32, "GET_U32"];
+$insn_data{cop_arybase} = [129, \&PUT_I32, "GET_I32"];
+$insn_data{cop_line} = [130, \&PUT_U32, "GET_U32"];
+$insn_data{cop_io} = [131, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_warnings} = [132, \&PUT_svindex, "GET_svindex"];
+$insn_data{main_start} = [133, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_root} = [134, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_cv} = [135, \&PUT_svindex, "GET_svindex"];
+$insn_data{curpad} = [136, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_begin} = [137, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_init} = [138, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_end} = [139, \&PUT_svindex, "GET_svindex"];
+$insn_data{curstash} = [140, \&PUT_svindex, "GET_svindex"];
+$insn_data{defstash} = [141, \&PUT_svindex, "GET_svindex"];
+$insn_data{data} = [142, \&PUT_U8, "GET_U8"];
+$insn_data{incav} = [143, \&PUT_svindex, "GET_svindex"];
+$insn_data{load_glob} = [144, \&PUT_svindex, "GET_svindex"];
+$insn_data{regex_padav} = [145, \&PUT_svindex, "GET_svindex"];
+$insn_data{dowarn} = [146, \&PUT_U8, "GET_U8"];
+$insn_data{comppad_name} = [147, \&PUT_svindex, "GET_svindex"];
+$insn_data{xgv_stash} = [148, \&PUT_svindex, "GET_svindex"];
+$insn_data{signal} = [149, \&PUT_strconst, "GET_strconst"];
+$insn_data{formfeed} = [150, \&PUT_svindex, "GET_svindex"];
+
+my ($insn_name, $insn_data);
+while (($insn_name, $insn_data) = each %insn_data) {
+ $insn_name[$insn_data->[0]] = $insn_name;
+}
+# Fill in any gaps
+ at insn_name = map($_ || "unused", @insn_name);
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
+
+=head1 SYNOPSIS
+
+ use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name);
+
+=head1 DESCRIPTION
+
+Provides information about Perl ops in order to generate bytecode via
+a bunch of exported variables. Its mostly used by B::Assembler and
+B::Disassembler.
+
+=over 4
+
+=item %insn_data
+
+ my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name};
+
+For a given $op_name (for example, 'cop_label', 'sv_flags', etc...)
+you get an array ref containing the bytecode number of the op, a
+reference to the subroutine used to 'PUT', and the name of the method
+used to 'GET'.
+
+=for _private
+Add more detail about what $put_sub and $get_meth are and how to use them.
+
+=item @insn_name
+
+ my $op_name = $insn_name[$bytecode_num];
+
+A simple mapping of the bytecode number to the name of the op.
+Suitable for using with %insn_data like so:
+
+ my $op_info = $insn_data{$insn_name[$bytecode_num]};
+
+=item @optype
+
+ my $op_type = $optype[$op_type_num];
+
+A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
+
+=item @specialsv_name
+
+ my $sv_name = $specialsv_name[$sv_index];
+
+Certain SV types are considered 'special'. They're represented by
+B::SPECIAL and are referred to by a number from the specialsv_list.
+This array maps that number back to the name of the SV (like 'Nullsv'
+or '&PL_sv_undef').
+
+=back
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
+
+# ex: set ro:
Added: B/B/Assembler.pm
==============================================================================
--- (empty file)
+++ B/B/Assembler.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,328 @@
+# Assembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+
+package B::Assembler;
+use Exporter;
+use B qw(ppname);
+use B::Asmdata qw(%insn_data @insn_name);
+use Config qw(%Config);
+require ByteLoader; # we just need its $VERSION
+
+no warnings; # XXX
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
+$VERSION = 0.07;
+
+use strict;
+my %opnumber;
+my ($i, $opname);
+for ($i = 0; defined($opname = ppname($i)); $i++) {
+ $opnumber{$opname} = $i;
+}
+
+my($linenum, $errors, $out); # global state, set up by newasm
+
+sub error {
+ my $str = shift;
+ warn "$linenum: $str\n";
+ $errors++;
+}
+
+my $debug = 0;
+sub debug { $debug = shift }
+
+sub limcheck($$$$){
+ my( $val, $lo, $hi, $loc ) = @_;
+ if( $val < $lo || $hi < $val ){
+ error "argument for $loc outside [$lo, $hi]: $val";
+ $val = $hi;
+ }
+ return $val;
+}
+
+#
+# First define all the data conversion subs to which Asmdata will refer
+#
+
+sub B::Asmdata::PUT_U8 {
+ my $arg = shift;
+ my $c = uncstring($arg);
+ if (defined($c)) {
+ if (length($c) != 1) {
+ error "argument for U8 is too long: $c";
+ $c = substr($c, 0, 1);
+ }
+ } else {
+ $arg = limcheck( $arg, 0, 0xff, 'U8' );
+ $c = chr($arg);
+ }
+ return $c;
+}
+
+sub B::Asmdata::PUT_U16 {
+ my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
+ pack("S", $arg);
+}
+sub B::Asmdata::PUT_U32 {
+ my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
+ pack("L", $arg);
+}
+sub B::Asmdata::PUT_I32 {
+ my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
+ pack("l", $arg);
+}
+sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
+ # may not even be portable between compilers
+sub B::Asmdata::PUT_objindex { # could allow names here
+ my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
+ pack("L", $arg);
+}
+sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
+sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
+sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
+
+sub B::Asmdata::PUT_strconst {
+ my $arg = shift;
+ my $str = uncstring($arg);
+ if (!defined($str)) {
+ error "bad string constant: $arg";
+ $str = '';
+ }
+ if ($str =~ s/\0//g) {
+ error "string constant argument contains NUL: $arg";
+ $str = '';
+ }
+ return $str . "\0";
+}
+
+sub B::Asmdata::PUT_pvcontents {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_PV {
+ my $arg = shift;
+ my $str = uncstring($arg);
+ if( ! defined($str) ){
+ error "bad string argument: $arg";
+ $str = '';
+ }
+ return pack("L", length($str)) . $str;
+}
+sub B::Asmdata::PUT_comment_t {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ error "bad string argument: $arg" unless defined($arg);
+ if ($arg =~ s/\n//g) {
+ error "comment argument contains linefeed: $arg";
+ }
+ return $arg . "\n";
+}
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
+sub B::Asmdata::PUT_none {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_op_tr_array {
+ my @ary = split /\s*,\s*/, shift;
+ return pack "S*", @ary;
+}
+
+sub B::Asmdata::PUT_IV64 {
+ return pack "Q", shift;
+}
+
+sub B::Asmdata::PUT_IV {
+ $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
+}
+
+sub B::Asmdata::PUT_PADOFFSET {
+ $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
+}
+
+sub B::Asmdata::PUT_long {
+ $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
+}
+
+my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
+ b => "\b", f => "\f", v => "\013");
+
+sub uncstring {
+ my $s = shift;
+ $s =~ s/^"// and $s =~ s/"$// or return undef;
+ $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
+ return $s;
+}
+
+sub strip_comments {
+ my $stmt = shift;
+ # Comments only allowed in instructions which don't take string arguments
+ # Treat string as a single line so .* eats \n characters.
+ $stmt =~ s{
+ ^\s* # Ignore leading whitespace
+ (
+ [^"]* # A double quote '"' indicates a string argument. If we
+ # find a double quote, the match fails and we strip nothing.
+ )
+ \s*\# # Any amount of whitespace plus the comment marker...
+ .*$ # ...which carries on to end-of-string.
+ }{$1}sx; # Keep only the instruction and optional argument.
+ return $stmt;
+}
+
+# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
+# ptrsize, byteorder
+# nvtype is irrelevant (floats are stored as strings)
+# byteorder is strconst not U32 because of varying size issues
+
+sub gen_header {
+ my $header = "";
+
+ $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
+ $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
+ $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
+ $header .= B::Asmdata::PUT_U32($Config{ivsize});
+ $header .= B::Asmdata::PUT_U32($Config{ptrsize});
+ $header;
+}
+
+sub parse_statement {
+ my $stmt = shift;
+ my ($insn, $arg) = $stmt =~ m{
+ ^\s* # allow (but ignore) leading whitespace
+ (.*?) # Instruction continues up until...
+ (?: # ...an optional whitespace+argument group
+ \s+ # first whitespace.
+ (.*) # The argument is all the rest (newlines included).
+ )?$ # anchor at end-of-line
+ }sx;
+ if (defined($arg)) {
+ if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
+ $arg = hex($arg);
+ } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
+ $arg = oct($arg);
+ } elsif ($arg =~ /^pp_/) {
+ $arg =~ s/\s*$//; # strip trailing whitespace
+ my $opnum = $opnumber{$arg};
+ if (defined($opnum)) {
+ $arg = $opnum;
+ } else {
+ error qq(No such op type "$arg");
+ $arg = 0;
+ }
+ }
+ }
+ return ($insn, $arg);
+}
+
+sub assemble_insn {
+ my ($insn, $arg) = @_;
+ my $data = $insn_data{$insn};
+ if (defined($data)) {
+ my ($bytecode, $putsub) = @{$data}[0, 1];
+ my $argcode = &$putsub($arg);
+ return chr($bytecode).$argcode;
+ } else {
+ error qq(no such instruction "$insn");
+ return "";
+ }
+}
+
+sub assemble_fh {
+ my ($fh, $out) = @_;
+ my $line;
+ my $asm = newasm($out);
+ while ($line = <$fh>) {
+ assemble($line);
+ }
+ endasm();
+}
+
+sub newasm {
+ my($outsub) = @_;
+
+ die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
+ die <<EOD if ref $out;
+Can't have multiple byteassembly sessions at once!
+ (perhaps you forgot an endasm()?)
+EOD
+
+ $linenum = $errors = 0;
+ $out = $outsub;
+
+ $out->(gen_header());
+}
+
+sub endasm {
+ if ($errors) {
+ die "There were $errors assembly errors\n";
+ }
+ $linenum = $errors = $out = 0;
+}
+
+sub assemble {
+ my($line) = @_;
+ my ($insn, $arg);
+ $linenum++;
+ chomp $line;
+ if ($debug) {
+ my $quotedline = $line;
+ $quotedline =~ s/\\/\\\\/g;
+ $quotedline =~ s/"/\\"/g;
+ $out->(assemble_insn("comment", qq("$quotedline")));
+ }
+ if( $line = strip_comments($line) ){
+ ($insn, $arg) = parse_statement($line);
+ $out->(assemble_insn($insn, $arg));
+ if ($debug) {
+ $out->(assemble_insn("nop", undef));
+ }
+ }
+}
+
+### temporary workaround
+
+sub asm {
+ return if $_[0] =~ /\s*\W/;
+ if (defined $_[1]) {
+ return if $_[1] eq "0" and
+ $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
+ return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
+ }
+ assemble "@_";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Assembler - Assemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use B::Assembler qw(newasm endasm assemble);
+ newasm(\&printsub); # sets up for assembly
+ assemble($buf); # assembles one line
+ endasm(); # closes down
+
+ use B::Assembler qw(assemble_fh);
+ assemble_fh($fh, \&printsub); # assemble everything in $fh
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Assembler.pm>.
+
+=head1 AUTHORS
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+Per-statement interface by Benjamin Stuhl, C<sho_pi at hotmail.com>
+
+=cut
Added: B/B/Bblock.pm
==============================================================================
--- (empty file)
+++ B/B/Bblock.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,224 @@
+package B::Bblock;
+
+our $VERSION = '1.02_01';
+
+use Exporter ();
+ at ISA = "Exporter";
+ at EXPORT_OK = qw(find_leaders);
+
+use B qw(peekop walkoptree walkoptree_exec
+ main_root main_start svref_2object
+ OPf_SPECIAL OPf_STACKED );
+
+use B::Concise qw(concise_cv concise_main set_style_standard);
+use strict;
+
+my $bblock;
+my @bblock_ends;
+
+sub mark_leader {
+ my $op = shift;
+ if ($$op) {
+ $bblock->{$$op} = $op;
+ }
+}
+
+sub remove_sortblock{
+ foreach (keys %$bblock){
+ my $leader=$$bblock{$_};
+ delete $$bblock{$_} if( $leader == 0);
+ }
+}
+sub find_leaders {
+ my ($root, $start) = @_;
+ $bblock = {};
+ mark_leader($start) if ( ref $start ne "B::NULL" );
+ walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
+ remove_sortblock();
+ return $bblock;
+}
+
+# Debugging
+sub walk_bblocks {
+ my ($root, $start) = @_;
+ my ($op, $lastop, $leader, $bb);
+ $bblock = {};
+ mark_leader($start);
+ walkoptree($root, "mark_if_leader");
+ my @leaders = values %$bblock;
+ while ($leader = shift @leaders) {
+ $lastop = $leader;
+ $op = $leader->next;
+ while ($$op && !exists($bblock->{$$op})) {
+ $bblock->{$$op} = $leader;
+ $lastop = $op;
+ $op = $op->next;
+ }
+ push(@bblock_ends, [$leader, $lastop]);
+ }
+ foreach $bb (@bblock_ends) {
+ ($leader, $lastop) = @$bb;
+ printf "%s .. %s\n", peekop($leader), peekop($lastop);
+ for ($op = $leader; $$op != $$lastop; $op = $op->next) {
+ printf " %s\n", peekop($op);
+ }
+ printf " %s\n", peekop($lastop);
+ }
+}
+
+sub walk_bblocks_obj {
+ my $cvref = shift;
+ my $cv = svref_2object($cvref);
+ walk_bblocks($cv->ROOT, $cv->START);
+}
+
+sub B::OP::mark_if_leader {}
+
+sub B::COP::mark_if_leader {
+ my $op = shift;
+ if ($op->label) {
+ mark_leader($op);
+ }
+}
+
+sub B::LOOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->next);
+ mark_leader($op->nextop);
+ mark_leader($op->redoop);
+ mark_leader($op->lastop->next);
+}
+
+sub B::LOGOP::mark_if_leader {
+ my $op = shift;
+ my $opname = $op->name;
+ mark_leader($op->next);
+ if ($opname eq "entertry") {
+ mark_leader($op->other->next);
+ } else {
+ mark_leader($op->other);
+ }
+}
+
+sub B::LISTOP::mark_if_leader {
+ my $op = shift;
+ my $first=$op->first;
+ $first=$first->next while ($first->name eq "null");
+ mark_leader($op->first) unless (exists( $bblock->{$$first}));
+ mark_leader($op->next);
+ if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
+ and $op->flags & OPf_STACKED){
+ my $root=$op->first->sibling->first;
+ my $leader=$root->first;
+ $bblock->{$$leader} = 0;
+ }
+}
+
+sub B::PMOP::mark_if_leader {
+ my $op = shift;
+ if ($op->name ne "pushre") {
+ my $replroot = $op->pmreplroot;
+ if ($$replroot) {
+ mark_leader($replroot);
+ mark_leader($op->next);
+ mark_leader($op->pmreplstart);
+ }
+ }
+}
+
+# PMOP stuff omitted
+
+sub compile {
+ my @options = @_;
+ B::clearsym();
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "walk_bblocks_obj(\\&$objname)";
+ die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+ print "-------\n";
+ set_style_standard("terse");
+ eval "concise_cv('exec', \\&$objname)";
+ die "concise_cv('exec', \\&$objname) failed: $@" if $@;
+ }
+ }
+ } else {
+ return sub {
+ walk_bblocks(main_root, main_start);
+ print "-------\n";
+ set_style_standard("terse");
+ concise_main("exec");
+ };
+ }
+}
+
+# Basic block leaders:
+# Any COP (pp_nextstate) with a non-NULL label
+# [The op after a pp_enter] Omit
+# [The op after a pp_entersub. Don't count this one.]
+# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
+# The ops pointed at by op_next and op_other of a LOGOP, except
+# for pp_entertry which has op_next and op_other->op_next
+# The op pointed at by op_pmreplstart of a PMOP
+# The op pointed at by op_other->op_pmreplstart of pp_substcont?
+# [The op after a pp_return] Omit
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Bblock - Walk basic blocks
+
+=head1 SYNOPSIS
+
+ # External interface
+ perl -MO=Bblock[,OPTIONS] foo.pl
+
+ # Programmatic API
+ use B::Bblock qw(find_leaders);
+ my $leaders = find_leaders($root_op, $start_op);
+
+=head1 DESCRIPTION
+
+This module is used by the B::CC back end. It walks "basic blocks".
+A basic block is a series of operations which is known to execute from
+start to finish, with no possibility of branching or halting.
+
+It can be used either stand alone or from inside another program.
+
+=for _private
+Somebody who understands the stand-alone options document them, please.
+
+=head2 Functions
+
+=over 4
+
+=item B<find_leaders>
+
+ my $leaders = find_leaders($root_op, $start_op);
+
+Given the root of the op tree and an op from which to start
+processing, it will return a hash ref representing all the ops which
+start a block.
+
+=for _private
+The above description may be somewhat wrong.
+
+The values of %$leaders are the op objects themselves. Keys are $$op
+addresses.
+
+=for _private
+Above cribbed from B::CC's comments. What's a $$op address?
+
+=back
+
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/Bytecode.pm
==============================================================================
--- (empty file)
+++ B/B/Bytecode.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,889 @@
+# B::Bytecode.pm
+# Copyright (c) 2003 Enache Adrian. All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# Based on the original Bytecode.pm module written by Malcolm Beattie.
+
+package B::Bytecode;
+
+our $VERSION = '1.01_01';
+
+use strict;
+use Config;
+use B qw(class main_cv main_root main_start cstring comppadlist
+ defstash curstash begin_av init_av end_av inc_gv warnhook diehook
+ dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
+ OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
+use B::Asmdata qw(@specialsv_name);
+use B::Assembler qw(asm newasm endasm);
+
+#################################################
+
+my ($varix, $opix, $savebegins, %walked, %files, @cloop);
+my %strtab = (0,0);
+my %svtab = (0,0);
+my %optab = (0,0);
+my %spectab = (0,0);
+my $tix = 1;
+sub asm;
+sub nice ($) { }
+
+BEGIN {
+ my $ithreads = $Config{'useithreads'} eq 'define';
+ eval qq{
+ sub ITHREADS() { $ithreads }
+ sub VERSION() { $] }
+ }; die $@ if $@;
+}
+
+#################################################
+
+sub pvstring {
+ my $pv = shift;
+ defined($pv) ? cstring ($pv."\0") : "\"\"";
+}
+
+sub pvix {
+ my $str = pvstring shift;
+ my $ix = $strtab{$str};
+ defined($ix) ? $ix : do {
+ asm "newpv", $str;
+ asm "stpv", $strtab{$str} = $tix;
+ $tix++;
+ }
+}
+
+sub B::OP::ix {
+ my $op = shift;
+ my $ix = $optab{$$op};
+ defined($ix) ? $ix : do {
+ nice "[".$op->name." $tix]";
+ asm "newopx", $op->size | $op->type <<7;
+ $optab{$$op} = $opix = $ix = $tix++;
+ $op->bsave($ix);
+ $ix;
+ }
+}
+
+sub B::SPECIAL::ix {
+ my $spec = shift;
+ my $ix = $spectab{$$spec};
+ defined($ix) ? $ix : do {
+ nice '['.$specialsv_name[$$spec].']';
+ asm "ldspecsvx", $$spec;
+ $spectab{$$spec} = $varix = $tix++;
+ }
+}
+
+sub B::SV::ix {
+ my $sv = shift;
+ my $ix = $svtab{$$sv};
+ defined($ix) ? $ix : do {
+ nice '['.class($sv).']';
+ asm "newsvx", $sv->FLAGS;
+ $svtab{$$sv} = $varix = $ix = $tix++;
+ $sv->bsave($ix);
+ $ix;
+ }
+}
+
+sub B::GV::ix {
+ my ($gv,$desired) = @_;
+ my $ix = $svtab{$$gv};
+ defined($ix) ? $ix : do {
+ if ($gv->GP) {
+ my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
+ nice "[GV]";
+ my $name = $gv->STASH->NAME . "::" . $gv->NAME;
+ asm "gv_fetchpvx", cstring $name;
+ $svtab{$$gv} = $varix = $ix = $tix++;
+ asm "sv_flags", $gv->FLAGS;
+ asm "sv_refcnt", $gv->REFCNT;
+ asm "xgv_flags", $gv->GvFLAGS;
+
+ asm "gp_refcnt", $gv->GvREFCNT;
+ asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
+ return $ix
+ unless $desired || desired $gv;
+ $svix = $gv->SV->ix;
+ $avix = $gv->AV->ix;
+ $hvix = $gv->HV->ix;
+
+ # XXX {{{{
+ my $cv = $gv->CV;
+ $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
+ my $form = $gv->FORM;
+ $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
+
+ $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
+ # }}}} XXX
+
+ nice "-GV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "gp_sv", $svix;
+ asm "gp_av", $avix;
+ asm "gp_hv", $hvix;
+ asm "gp_cv", $cvix;
+ asm "gp_io", $ioix;
+ asm "gp_cvgen", $gv->CVGEN;
+ asm "gp_form", $formix;
+ asm "gp_file", pvix $gv->FILE;
+ asm "gp_line", $gv->LINE;
+ asm "formfeed", $svix if $name eq "main::\cL";
+ } else {
+ nice "[GV]";
+ asm "newsvx", $gv->FLAGS;
+ $svtab{$$gv} = $varix = $ix = $tix++;
+ my $stashix = $gv->STASH->ix;
+ $gv->B::PVMG::bsave($ix);
+ asm "xgv_flags", $gv->GvFLAGS;
+ asm "xgv_stash", $stashix;
+ }
+ $ix;
+ }
+}
+
+sub B::HV::ix {
+ my $hv = shift;
+ my $ix = $svtab{$$hv};
+ defined($ix) ? $ix : do {
+ my ($ix,$i, at array);
+ my $name = $hv->NAME;
+ if ($name) {
+ nice "[STASH]";
+ asm "gv_stashpvx", cstring $name;
+ asm "sv_flags", $hv->FLAGS;
+ $svtab{$$hv} = $varix = $ix = $tix++;
+ asm "xhv_name", pvix $name;
+ # my $pmrootix = $hv->PMROOT->ix; # XXX
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ # asm "xhv_pmroot", $pmrootix; # XXX
+ } else {
+ nice "[HV]";
+ asm "newsvx", $hv->FLAGS;
+ $svtab{$$hv} = $varix = $ix = $tix++;
+ my $stashix = $hv->SvSTASH->ix;
+ for (@array = $hv->ARRAY) {
+ next if $i = not $i;
+ $_ = $_->ix;
+ }
+ nice "-HV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
+ for @array;
+ if (VERSION < 5.009) {
+ asm "xnv", $hv->NVX;
+ }
+ asm "xmg_stash", $stashix;
+ asm "xhv_riter", $hv->RITER;
+ }
+ asm "sv_refcnt", $hv->REFCNT;
+ $ix;
+ }
+}
+
+sub B::NULL::ix {
+ my $sv = shift;
+ $$sv ? $sv->B::SV::ix : 0;
+}
+
+sub B::NULL::opwalk { 0 }
+
+#################################################
+
+sub B::NULL::bsave {
+ my ($sv,$ix) = @_;
+
+ nice '-'.class($sv).'-',
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "sv_refcnt", $sv->REFCNT;
+}
+
+sub B::SV::bsave;
+ *B::SV::bsave = *B::NULL::bsave;
+
+sub B::RV::bsave {
+ my ($sv,$ix) = @_;
+ my $rvix = $sv->RV->ix;
+ $sv->B::NULL::bsave($ix);
+ asm "xrv", $rvix;
+}
+
+sub B::PV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "newpv", pvstring $sv->PVBM;
+ asm "xpv";
+}
+
+sub B::IV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "xiv", $sv->IVX;
+}
+
+sub B::NV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "xnv", sprintf "%.40g", $sv->NVX;
+}
+
+sub B::PVIV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->POK ?
+ $sv->B::PV::bsave($ix):
+ $sv->ROK ?
+ $sv->B::RV::bsave($ix):
+ $sv->B::NULL::bsave($ix);
+ if (VERSION >= 5.009) {
+ # See note below in B::PVNV::bsave
+ return if $sv->isa('B::AV');
+ return if $sv->isa('B::HV');
+ }
+ asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
+ "0 but true" : $sv->IVX;
+}
+
+sub B::PVNV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::PVIV::bsave($ix);
+ if (VERSION >= 5.009) {
+ # Magical AVs end up here, but AVs now don't have an NV slot actually
+ # allocated. Hence don't write out assembly to store the NV slot if
+ # we're actually an array.
+ return if $sv->isa('B::AV');
+ # Likewise HVs have no NV slot actually allocated.
+ # I don't think that they can get here, but better safe than sorry
+ return if $sv->isa('B::HV');
+ }
+ asm "xnv", sprintf "%.40g", $sv->NVX;
+}
+
+sub B::PVMG::domagic {
+ my ($sv,$ix) = @_;
+ nice '-MAGICAL-';
+ my @mglist = $sv->MAGIC;
+ my (@mgix, @namix);
+ for (@mglist) {
+ push @mgix, $_->OBJ->ix;
+ push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
+ }
+
+ nice '-'.class($sv).'-',
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ for (@mglist) {
+ asm "sv_magic", cstring $_->TYPE;
+ asm "mg_obj", shift @mgix;
+ my $length = $_->LENGTH;
+ if ($length == B::HEf_SVKEY) {
+ asm "mg_namex", shift @namix;
+ } elsif ($length) {
+ asm "newpv", pvstring $_->PTR;
+ asm "mg_name";
+ }
+ }
+}
+
+sub B::PVMG::bsave {
+ my ($sv,$ix) = @_;
+ my $stashix = $sv->SvSTASH->ix;
+ $sv->B::PVNV::bsave($ix);
+ asm "xmg_stash", $stashix;
+ $sv->domagic($ix) if $sv->MAGICAL;
+}
+
+sub B::PVLV::bsave {
+ my ($sv,$ix) = @_;
+ my $targix = $sv->TARG->ix;
+ $sv->B::PVMG::bsave($ix);
+ asm "xlv_targ", $targix;
+ asm "xlv_targoff", $sv->TARGOFF;
+ asm "xlv_targlen", $sv->TARGLEN;
+ asm "xlv_type", $sv->TYPE;
+
+}
+
+sub B::BM::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::PVMG::bsave($ix);
+ asm "xpv_cur", $sv->CUR;
+ asm "xbm_useful", $sv->USEFUL;
+ asm "xbm_previous", $sv->PREVIOUS;
+ asm "xbm_rare", $sv->RARE;
+}
+
+sub B::IO::bsave {
+ my ($io,$ix) = @_;
+ my $topix = $io->TOP_GV->ix;
+ my $fmtix = $io->FMT_GV->ix;
+ my $bottomix = $io->BOTTOM_GV->ix;
+ $io->B::PVMG::bsave($ix);
+ asm "xio_lines", $io->LINES;
+ asm "xio_page", $io->PAGE;
+ asm "xio_page_len", $io->PAGE_LEN;
+ asm "xio_lines_left", $io->LINES_LEFT;
+ asm "xio_top_name", pvix $io->TOP_NAME;
+ asm "xio_top_gv", $topix;
+ asm "xio_fmt_name", pvix $io->FMT_NAME;
+ asm "xio_fmt_gv", $fmtix;
+ asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
+ asm "xio_bottom_gv", $bottomix;
+ asm "xio_subprocess", $io->SUBPROCESS;
+ asm "xio_type", ord $io->IoTYPE;
+ # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
+}
+
+sub B::CV::bsave {
+ my ($cv,$ix) = @_;
+ my $stashix = $cv->STASH->ix;
+ my $gvix = $cv->GV->ix;
+ my $padlistix = $cv->PADLIST->ix;
+ my $outsideix = $cv->OUTSIDE->ix;
+ my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
+ my $startix = $cv->START->opwalk;
+ my $rootix = $cv->ROOT->ix;
+
+ $cv->B::PVMG::bsave($ix);
+ asm "xcv_stash", $stashix;
+ asm "xcv_start", $startix;
+ asm "xcv_root", $rootix;
+ asm "xcv_xsubany", $constix;
+ asm "xcv_gv", $gvix;
+ asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
+ asm "xcv_padlist", $padlistix;
+ asm "xcv_outside", $outsideix;
+ asm "xcv_flags", $cv->CvFLAGS;
+ asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
+ asm "xcv_depth", $cv->DEPTH;
+}
+
+sub B::FM::bsave {
+ my ($form,$ix) = @_;
+
+ $form->B::CV::bsave($ix);
+ asm "xfm_lines", $form->LINES;
+}
+
+sub B::AV::bsave {
+ my ($av,$ix) = @_;
+ return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
+ my @array = $av->ARRAY;
+ $_ = $_->ix for @array;
+ my $stashix = $av->SvSTASH->ix;
+
+ nice "-AV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "av_extend", $av->MAX if $av->MAX >= 0;
+ asm "av_pushx", $_ for @array;
+ asm "sv_refcnt", $av->REFCNT;
+ if (VERSION < 5.009) {
+ asm "xav_flags", $av->AvFLAGS;
+ }
+ asm "xmg_stash", $stashix;
+}
+
+sub B::GV::desired {
+ my $gv = shift;
+ my ($cv, $form);
+ $files{$gv->FILE} && $gv->LINE
+ || ${$cv = $gv->CV} && $files{$cv->FILE}
+ || ${$form = $gv->FORM} && $files{$form->FILE}
+}
+
+sub B::HV::bwalk {
+ my $hv = shift;
+ return if $walked{$$hv}++;
+ my %stash = $hv->ARRAY;
+ while (my($k,$v) = each %stash) {
+ if ($v->SvTYPE == SVt_PVGV) {
+ my $hash = $v->HV;
+ if ($$hash && $hash->NAME) {
+ $hash->bwalk;
+ }
+ $v->ix(1) if desired $v;
+ } else {
+ nice "[prototype]";
+ asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
+ $svtab{$$v} = $varix = $tix;
+ $v->bsave($tix++);
+ asm "sv_flags", $v->FLAGS;
+ }
+ }
+}
+
+######################################################
+
+
+sub B::OP::bsave_thin {
+ my ($op, $ix) = @_;
+ my $next = $op->next;
+ my $nextix = $optab{$$next};
+ $nextix = 0, push @cloop, $op unless defined $nextix;
+ if ($ix != $opix) {
+ nice '-'.$op->name.'-',
+ asm "ldop", $opix = $ix;
+ }
+ asm "op_next", $nextix;
+ asm "op_targ", $op->targ if $op->type; # tricky
+ asm "op_flags", $op->flags;
+ asm "op_private", $op->private;
+}
+
+sub B::OP::bsave;
+ *B::OP::bsave = *B::OP::bsave_thin;
+
+sub B::UNOP::bsave {
+ my ($op, $ix) = @_;
+ my $name = $op->name;
+ my $flags = $op->flags;
+ my $first = $op->first;
+ my $firstix =
+ $name =~ /fl[io]p/
+ # that's just neat
+ || (!ITHREADS && $name eq 'regcomp')
+ # trick for /$a/o in pp_regcomp
+ || $name eq 'rv2sv'
+ && $op->flags & OPf_MOD
+ && $op->private & OPpLVAL_INTRO
+ # change #18774 made my life hard
+ ? $first->ix
+ : 0;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+}
+
+sub B::BINOP::bsave {
+ my ($op, $ix) = @_;
+ if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
+ my $last = $op->last;
+ my $lastix = do {
+ local *B::OP::bsave = *B::OP::bsave_fat;
+ local *B::UNOP::bsave = *B::UNOP::bsave_fat;
+ $last->ix;
+ };
+ asm "ldop", $lastix unless $lastix == $opix;
+ asm "op_targ", $last->targ;
+ $op->B::OP::bsave($ix);
+ asm "op_last", $lastix;
+ } else {
+ $op->B::OP::bsave($ix);
+ }
+}
+
+# not needed if no pseudohashes
+
+*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
+
+# deal with sort / formline
+
+sub B::LISTOP::bsave {
+ my ($op, $ix) = @_;
+ my $name = $op->name;
+ sub blocksort() { OPf_SPECIAL|OPf_STACKED }
+ if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
+ my $first = $op->first;
+ my $pushmark = $first->sibling;
+ my $rvgv = $pushmark->first;
+ my $leave = $rvgv->first;
+
+ my $leaveix = $leave->ix;
+
+ my $rvgvix = $rvgv->ix;
+ asm "ldop", $rvgvix unless $rvgvix == $opix;
+ asm "op_first", $leaveix;
+
+ my $pushmarkix = $pushmark->ix;
+ asm "ldop", $pushmarkix unless $pushmarkix == $opix;
+ asm "op_first", $rvgvix;
+
+ my $firstix = $first->ix;
+ asm "ldop", $firstix unless $firstix == $opix;
+ asm "op_sibling", $pushmarkix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+ } elsif ($name eq 'formline') {
+ $op->B::UNOP::bsave_fat($ix);
+ } else {
+ $op->B::OP::bsave($ix);
+ }
+}
+
+# fat versions
+
+sub B::OP::bsave_fat {
+ my ($op, $ix) = @_;
+ my $siblix = $op->sibling->ix;
+
+ $op->B::OP::bsave_thin($ix);
+ asm "op_sibling", $siblix;
+ # asm "op_seq", -1; XXX don't allocate OPs piece by piece
+}
+
+sub B::UNOP::bsave_fat {
+ my ($op,$ix) = @_;
+ my $firstix = $op->first->ix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+}
+
+sub B::BINOP::bsave_fat {
+ my ($op,$ix) = @_;
+ my $last = $op->last;
+ my $lastix = $op->last->ix;
+ if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
+ asm "ldop", $lastix unless $lastix == $opix;
+ asm "op_targ", $last->targ;
+ }
+
+ $op->B::UNOP::bsave($ix);
+ asm "op_last", $lastix;
+}
+
+sub B::LOGOP::bsave {
+ my ($op,$ix) = @_;
+ my $otherix = $op->other->ix;
+
+ $op->B::UNOP::bsave($ix);
+ asm "op_other", $otherix;
+}
+
+sub B::PMOP::bsave {
+ my ($op,$ix) = @_;
+ my ($rrop, $rrarg, $rstart);
+
+ # my $pmnextix = $op->pmnext->ix; # XXX
+
+ if (ITHREADS) {
+ if ($op->name eq 'subst') {
+ $rrop = "op_pmreplroot";
+ $rrarg = $op->pmreplroot->ix;
+ $rstart = $op->pmreplstart->ix;
+ } elsif ($op->name eq 'pushre') {
+ $rrop = "op_pmreplrootpo";
+ $rrarg = $op->pmreplroot;
+ }
+ $op->B::BINOP::bsave($ix);
+ asm "op_pmstashpv", pvix $op->pmstashpv;
+ } else {
+ $rrop = "op_pmreplrootgv";
+ $rrarg = $op->pmreplroot->ix;
+ $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
+ my $stashix = $op->pmstash->ix;
+ $op->B::BINOP::bsave($ix);
+ asm "op_pmstash", $stashix;
+ }
+
+ asm $rrop, $rrarg if $rrop;
+ asm "op_pmreplstart", $rstart if $rstart;
+
+ asm "op_pmflags", $op->pmflags;
+ asm "op_pmpermflags", $op->pmpermflags;
+ asm "op_pmdynflags", $op->pmdynflags;
+ # asm "op_pmnext", $pmnextix; # XXX
+ asm "newpv", pvstring $op->precomp;
+ asm "pregcomp";
+}
+
+sub B::SVOP::bsave {
+ my ($op,$ix) = @_;
+ my $svix = $op->sv->ix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_sv", $svix;
+}
+
+sub B::PADOP::bsave {
+ my ($op,$ix) = @_;
+
+ $op->B::OP::bsave($ix);
+ asm "op_padix", $op->padix;
+}
+
+sub B::PVOP::bsave {
+ my ($op,$ix) = @_;
+ $op->B::OP::bsave($ix);
+ return unless my $pv = $op->pv;
+
+ if ($op->name eq 'trans') {
+ asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
+ } else {
+ asm "newpv", pvstring $pv;
+ asm "op_pv";
+ }
+}
+
+sub B::LOOP::bsave {
+ my ($op,$ix) = @_;
+ my $nextix = $op->nextop->ix;
+ my $lastix = $op->lastop->ix;
+ my $redoix = $op->redoop->ix;
+
+ $op->B::BINOP::bsave($ix);
+ asm "op_redoop", $redoix;
+ asm "op_nextop", $nextix;
+ asm "op_lastop", $lastix;
+}
+
+sub B::COP::bsave {
+ my ($cop,$ix) = @_;
+ my $warnix = $cop->warnings->ix;
+ my $ioix = $cop->io->ix;
+ if (ITHREADS) {
+ $cop->B::OP::bsave($ix);
+ asm "cop_stashpv", pvix $cop->stashpv;
+ asm "cop_file", pvix $cop->file;
+ } else {
+ my $stashix = $cop->stash->ix;
+ my $fileix = $cop->filegv->ix(1);
+ $cop->B::OP::bsave($ix);
+ asm "cop_stash", $stashix;
+ asm "cop_filegv", $fileix;
+ }
+ asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
+ asm "cop_seq", $cop->cop_seq;
+ asm "cop_arybase", $cop->arybase;
+ asm "cop_line", $cop->line;
+ asm "cop_warnings", $warnix;
+ asm "cop_io", $ioix;
+}
+
+sub B::OP::opwalk {
+ my $op = shift;
+ my $ix = $optab{$$op};
+ defined($ix) ? $ix : do {
+ my $ix;
+ my @oplist = $op->oplist;
+ push @cloop, undef;
+ $ix = $_->ix while $_ = pop @oplist;
+ while ($_ = pop @cloop) {
+ asm "ldop", $optab{$$_};
+ asm "op_next", $optab{${$_->next}};
+ }
+ $ix;
+ }
+}
+
+#################################################
+
+sub save_cq {
+ my $av;
+ if (($av=begin_av)->isa("B::AV")) {
+ if ($savebegins) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_begin", $_->ix;
+ }
+ } else {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ # XXX BEGIN { goto A while 1; A: }
+ for (my $op = $_->START; $$op; $op = $op->next) {
+ next unless $op->name eq 'require' ||
+ # this kludge needed for tests
+ $op->name eq 'gv' && do {
+ my $gv = class($op) eq 'SVOP' ?
+ $op->gv :
+ (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
+ $$gv && $gv->NAME =~ /use_ok|plan/
+ };
+ asm "push_begin", $_->ix;
+ last;
+ }
+ }
+ }
+ }
+ if (($av=init_av)->isa("B::AV")) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_init", $_->ix;
+ }
+ }
+ if (($av=end_av)->isa("B::AV")) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_end", $_->ix;
+ }
+ }
+}
+
+sub compile {
+ my ($head, $scan, $T_inhinc, $keep_syn);
+ my $cwd = '';
+ $files{$0} = 1;
+ sub keep_syn {
+ $keep_syn = 1;
+ *B::OP::bsave = *B::OP::bsave_fat;
+ *B::UNOP::bsave = *B::UNOP::bsave_fat;
+ *B::BINOP::bsave = *B::BINOP::bsave_fat;
+ *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
+ }
+ sub bwarn { print STDERR "Bytecode.pm: @_\n" }
+
+ for (@_) {
+ if (/^-S/) {
+ *newasm = *endasm = sub { };
+ *asm = sub { print " @_\n" };
+ *nice = sub ($) { print "\n at _\n" };
+ } elsif (/^-H/) {
+ require ByteLoader;
+ $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
+ } elsif (/^-k/) {
+ keep_syn;
+ } elsif (/^-o(.*)$/) {
+ open STDOUT, ">$1" or die "open $1: $!";
+ } elsif (/^-f(.*)$/) {
+ $files{$1} = 1;
+ } elsif (/^-s(.*)$/) {
+ $scan = length($1) ? $1 : $0;
+ } elsif (/^-b/) {
+ $savebegins = 1;
+ # this is here for the testsuite
+ } elsif (/^-TI/) {
+ $T_inhinc = 1;
+ } elsif (/^-TF(.*)/) {
+ my $thatfile = $1;
+ *B::COP::file = sub { $thatfile };
+ } else {
+ bwarn "Ignoring '$_' option";
+ }
+ }
+ if ($scan) {
+ my $f;
+ if (open $f, $scan) {
+ while (<$f>) {
+ /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
+ /^#/ and next;
+ if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
+ bwarn "keeping the syntax tree: \"goto\" op found";
+ keep_syn;
+ }
+ }
+ } else {
+ bwarn "cannot rescan '$scan'";
+ }
+ close $f;
+ }
+ binmode STDOUT;
+ return sub {
+ print $head if $head;
+ newasm sub { print @_ };
+
+ defstash->bwalk;
+ asm "main_start", main_start->opwalk;
+ asm "main_root", main_root->ix;
+ asm "main_cv", main_cv->ix;
+ asm "curpad", (comppadlist->ARRAY)[1]->ix;
+
+ asm "signal", cstring "__WARN__" # XXX
+ if warnhook->ix;
+ asm "incav", inc_gv->AV->ix if $T_inhinc;
+ save_cq;
+ asm "incav", inc_gv->AV->ix if $T_inhinc;
+ asm "dowarn", dowarn;
+
+ {
+ no strict 'refs';
+ nice "<DATA>";
+ my $dh = *{defstash->NAME."::DATA"};
+ unless (eof $dh) {
+ local undef $/;
+ asm "data", ord 'D';
+ print <$dh>;
+ } else {
+ asm "ret";
+ }
+ }
+
+ endasm;
+ }
+}
+
+1;
+
+=head1 NAME
+
+B::Bytecode - Perl compiler's bytecode backend
+
+=head1 SYNOPSIS
+
+B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
+
+=head1 DESCRIPTION
+
+Compiles a Perl script into a bytecode format that could be loaded
+later by the ByteLoader module and executed as a regular Perl script.
+
+=head1 EXAMPLE
+
+ $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
+ $ perl hi
+ hi!
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-b>
+
+Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
+other files (ex. C<use Foo;>) are saved.
+
+=item B<-H>
+
+prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
+
+=item B<-k>
+
+keep the syntax tree - it is stripped by default.
+
+=item B<-o>I<outfile>
+
+put the bytecode in <outfile> instead of dumping it to STDOUT.
+
+=item B<-s>
+
+scan the script for C<# line ..> directives and for <goto LABEL>
+expressions. When gotos are found keep the syntax tree.
+
+=back
+
+=head1 KNOWN BUGS
+
+=over 4
+
+=item *
+
+C<BEGIN { goto A: while 1; A: }> won't even compile.
+
+=item *
+
+C<?...?> and C<reset> do not work as expected.
+
+=item *
+
+variables in C<(?{ ... })> constructs are not properly scoped.
+
+=item *
+
+scripts that use source filters will fail miserably.
+
+=back
+
+=head1 NOTICE
+
+There are also undocumented bugs and options.
+
+THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
+
+=head1 AUTHORS
+
+Originally written by Malcolm Beattie <mbeattie at sable.ox.ac.uk> and
+modified by Benjamin Stuhl <sho_pi at hotmail.com>.
+
+Rewritten by Enache Adrian <enache at rdslink.ro>, 2003 a.d.
+
+=cut
Added: B/B/C.pm
==============================================================================
--- (empty file)
+++ B/B/C.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,2272 @@
+# C.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+
+package B::C;
+
+our $VERSION = '1.04_01';
+
+package B::C::Section;
+
+use B ();
+use base B::Section;
+
+sub new
+{
+ my $class = shift;
+ my $o = $class->SUPER::new(@_);
+ push @$o, { values => [] };
+ return $o;
+}
+
+sub add
+{
+ my $section = shift;
+ push(@{$section->[-1]{values}}, at _);
+}
+
+sub index
+{
+ my $section = shift;
+ return scalar(@{$section->[-1]{values}})-1;
+}
+
+sub output
+{
+ my ($section, $fh, $format) = @_;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+ my $i;
+ foreach (@{$section->[-1]{values}})
+ {
+ s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
+ printf $fh $format, $_, $i;
+ ++$i;
+ }
+}
+
+package B::C::InitSection;
+
+# avoid use vars
+ at B::C::InitSection::ISA = qw(B::C::Section);
+
+sub new {
+ my $class = shift;
+ my $max_lines = 10000; #pop;
+ my $section = $class->SUPER::new( @_ );
+
+ $section->[-1]{evals} = [];
+ $section->[-1]{chunks} = [];
+ $section->[-1]{nosplit} = 0;
+ $section->[-1]{current} = [];
+ $section->[-1]{count} = 0;
+ $section->[-1]{max_lines} = $max_lines;
+
+ return $section;
+}
+
+sub split {
+ my $section = shift;
+ $section->[-1]{nosplit}--
+ if $section->[-1]{nosplit} > 0;
+}
+
+sub no_split {
+ shift->[-1]{nosplit}++;
+}
+
+sub inc_count {
+ my $section = shift;
+
+ $section->[-1]{count} += $_[0];
+ # this is cheating
+ $section->add();
+}
+
+sub add {
+ my $section = shift->[-1];
+ my $current = $section->{current};
+ my $nosplit = $section->{nosplit};
+
+ push @$current, @_;
+ $section->{count} += scalar(@_);
+ if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
+ push @{$section->{chunks}}, $current;
+ $section->{current} = [];
+ $section->{count} = 0;
+ }
+}
+
+sub add_eval {
+ my $section = shift;
+ my @strings = @_;
+
+ foreach my $i ( @strings ) {
+ $i =~ s/\"/\\\"/g;
+ }
+ push @{$section->[-1]{evals}}, @strings;
+}
+
+sub output {
+ my( $section, $fh, $format, $init_name ) = @_;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+ push @{$section->[-1]{chunks}}, $section->[-1]{current};
+
+ my $name = "aaaa";
+ foreach my $i ( @{$section->[-1]{chunks}} ) {
+ print $fh <<"EOT";
+static int perl_init_${name}()
+{
+ dTARG;
+ dSP;
+EOT
+ foreach my $j ( @$i ) {
+ $j =~ s{(s\\_[0-9a-f]+)}
+ { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
+ print $fh "\t$j\n";
+ }
+ print $fh "\treturn 0;\n}\n";
+
+ $section->SUPER::add( "perl_init_${name}();" );
+ ++$name;
+ }
+ foreach my $i ( @{$section->[-1]{evals}} ) {
+ $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
+ }
+
+ print $fh <<"EOT";
+static int ${init_name}()
+{
+ dTARG;
+ dSP;
+EOT
+ $section->SUPER::output( $fh, $format );
+ print $fh "\treturn 0;\n}\n";
+}
+
+
+package B::C;
+use Exporter ();
+our %REGEXP;
+
+{ # block necessary for caller to work
+ my $caller = caller;
+ if( $caller eq 'O' ) {
+ require XSLoader;
+ XSLoader::load( 'B::C' );
+ }
+}
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
+ init_sections set_callback save_unused_subs objsym save_context);
+
+use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
+ class cstring cchar svref_2object compile_stats comppadlist hash
+ threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
+ HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
+use B::Asmdata qw(@specialsv_name);
+
+use FileHandle;
+use Carp;
+use strict;
+use Config;
+
+my $hv_index = 0;
+my $gv_index = 0;
+my $re_index = 0;
+my $pv_index = 0;
+my $cv_index = 0;
+my $anonsub_index = 0;
+my $initsub_index = 0;
+
+my %symtable;
+my %xsub;
+my $warn_undefined_syms;
+my $verbose;
+my %unused_sub_packages;
+my $use_xsloader;
+my $nullop_count;
+my $pv_copy_on_grow = 0;
+my $optimize_ppaddr = 0;
+my $optimize_warn_sv = 0;
+my $use_perl_script_name = 0;
+my $save_data_fh = 0;
+my $save_sig = 0;
+my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
+my $max_string_len;
+
+my $ithreads = $Config{useithreads} eq 'define';
+
+my @threadsv_names;
+BEGIN {
+ @threadsv_names = threadsv_names();
+}
+
+# Code sections
+my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
+ $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
+ $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
+ $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
+ $xrvsect, $xpvbmsect, $xpviosect );
+my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
+ $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
+ $unopsect );
+
+sub walk_and_save_optree;
+my $saveoptree_callback = \&walk_and_save_optree;
+sub set_callback { $saveoptree_callback = shift }
+sub saveoptree { &$saveoptree_callback(@_) }
+
+sub walk_and_save_optree {
+ my ($name, $root, $start) = @_;
+ walkoptree($root, "save");
+ return objsym($start);
+}
+
+# Look this up here so we can do just a number compare
+# rather than looking up the name of every BASEOP in B::OP
+my $OP_THREADSV = opnumber('threadsv');
+
+sub savesym {
+ my ($obj, $value) = @_;
+ my $sym = sprintf("s\\_%x", $$obj);
+ $symtable{$sym} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("s\\_%x", $$obj)};
+}
+
+sub getsym {
+ my $sym = shift;
+ my $value;
+
+ return 0 if $sym eq "sym_0"; # special case
+ $value = $symtable{$sym};
+ if (defined($value)) {
+ return $value;
+ } else {
+ warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
+ return "UNUSED";
+ }
+}
+
+sub savere {
+ my $re = shift;
+ my $sym = sprintf("re%d", $re_index++);
+ $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
+
+ return ($sym,length(pack "a*",$re));
+}
+
+sub savepv {
+ my $pv = pack "a*", shift;
+ my $pvsym = 0;
+ my $pvmax = 0;
+ if ($pv_copy_on_grow) {
+ $pvsym = sprintf("pv%d", $pv_index++);
+
+ if( defined $max_string_len && length($pv) > $max_string_len ) {
+ my $chars = join ', ', map { cchar $_ } split //, $pv;
+ $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
+ }
+ else {
+ my $cstring = cstring($pv);
+ if ($cstring ne "0") { # sic
+ $decl->add(sprintf("static char %s[] = %s;",
+ $pvsym, $cstring));
+ }
+ }
+ } else {
+ $pvmax = length(pack "a*",$pv) + 1;
+ }
+ return ($pvsym, $pvmax);
+}
+
+sub save_rv {
+ my $sv = shift;
+# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
+ my $rv = $sv->RV->save;
+
+ $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
+
+ return $rv;
+}
+
+# savesym, pvmax, len, pv
+sub save_pv_or_rv {
+ my $sv = shift;
+
+ my $rok = $sv->FLAGS & SVf_ROK;
+ my $pok = $sv->FLAGS & SVf_POK;
+ my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
+ if( $rok ) {
+ $savesym = '(char*)' . save_rv( $sv );
+ }
+ else {
+ $pv = $pok ? (pack "a*", $sv->PV) : undef;
+ $len = $pok ? length($pv) : 0;
+ ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
+ }
+
+ return ( $savesym, $pvmax, $len, $pv );
+}
+
+# see also init_op_ppaddr below; initializes the ppaddt to the
+# OpTYPE; init_op_ppaddr iterates over the ops and sets
+# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
+# in perl_init ( ~10 bytes/op with GCC/i386 )
+sub B::OP::fake_ppaddr {
+ return $optimize_ppaddr ?
+ sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
+ 'NULL';
+}
+
+# This pair is needed becase B::FAKEOP::save doesn't scalar dereference
+# $op->next and $op->sibling
+
+{
+ # For 5.9 the hard coded text is the values for op_opt and op_static in each
+ # op. The value of op_opt is irrelevant, and the value of op_static needs to
+ # be 1 to tell op_free that this is a statically defined op and that is
+ # shouldn't be freed.
+
+ # For 5.8:
+ # Current workaround/fix for op_free() trying to free statically
+ # defined OPs is to set op_seq = -1 and check for that in op_free().
+ # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
+ # so that it can be changed back easily if necessary. In fact, to
+ # stop compilers from moaning about a U16 being initialised with an
+ # uncast -1 (the printf format is %d so we can't tweak it), we have
+ # to "know" that op_seq is a U16 and use 65535. Ugh.
+
+ my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535;
+ sub B::OP::_save_common_middle {
+ my $op = shift;
+ sprintf ("%s, %u, %u, $static, 0x%x, 0x%x",
+ $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private);
+ }
+}
+
+sub B::OP::_save_common {
+ my $op = shift;
+ return sprintf("s\\_%x, s\\_%x, %s",
+ ${$op->next}, ${$op->sibling}, $op->_save_common_middle);
+}
+
+sub B::OP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ my $type = $op->type;
+ $nullop_count++ unless $type;
+ if ($type == $OP_THREADSV) {
+ # saves looking up ppaddr but it's a bit naughty to hard code this
+ $init->add(sprintf("(void)find_threadsv(%s);",
+ cstring($threadsv_names[$op->targ])));
+ }
+ $opsect->add($op->_save_common);
+ my $ix = $opsect->index;
+ $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "&op_list[$ix]");
+}
+
+sub B::FAKEOP::new {
+ my ($class, %objdata) = @_;
+ bless \%objdata, $class;
+}
+
+sub B::FAKEOP::save {
+ my ($op, $level) = @_;
+ $opsect->add(sprintf("%s, %s, %s",
+ $op->next, $op->sibling, $op->_save_common_middle));
+ my $ix = $opsect->index;
+ $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ return "&op_list[$ix]";
+}
+
+sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
+sub B::FAKEOP::type { $_[0]->{type} || 0}
+sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
+sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
+sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
+sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
+sub B::FAKEOP::private { $_[0]->{private} || 0 }
+
+sub B::UNOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first}));
+ my $ix = $unopsect->index;
+ $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "(OP*)&unop_list[$ix]");
+}
+
+sub B::BINOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ $binopsect->add(sprintf("%s, s\\_%x, s\\_%x",
+ $op->_save_common, ${$op->first}, ${$op->last}));
+ my $ix = $binopsect->index;
+ $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "(OP*)&binop_list[$ix]");
+}
+
+sub B::LISTOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ $listopsect->add(sprintf("%s, s\\_%x, s\\_%x",
+ $op->_save_common, ${$op->first}, ${$op->last}));
+ my $ix = $listopsect->index;
+ $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "(OP*)&listop_list[$ix]");
+}
+
+sub B::LOGOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ $logopsect->add(sprintf("%s, s\\_%x, s\\_%x",
+ $op->_save_common, ${$op->first}, ${$op->other}));
+ my $ix = $logopsect->index;
+ $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "(OP*)&logop_list[$ix]");
+}
+
+sub B::LOOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
+ # peekop($op->redoop), peekop($op->nextop),
+ # peekop($op->lastop)); # debug
+ $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
+ $op->_save_common, ${$op->first}, ${$op->last},
+ ${$op->redoop}, ${$op->nextop},
+ ${$op->lastop}));
+ my $ix = $loopsect->index;
+ $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "(OP*)&loop_list[$ix]");
+}
+
+sub B::PVOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv)));
+ my $ix = $pvopsect->index;
+ $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ savesym($op, "(OP*)&pvop_list[$ix]");
+}
+
+sub B::SVOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ my $sv = $op->sv;
+ my $svsym = '(SV*)' . $sv->save;
+ my $is_const_addr = $svsym =~ m/Null|\&/;
+ $svopsect->add(sprintf("%s, %s", $op->_save_common,
+ ( $is_const_addr ? $svsym : 'Nullsv' )));
+ my $ix = $svopsect->index;
+ $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ $init->add("svop_list[$ix].op_sv = $svsym;")
+ unless $is_const_addr;
+ savesym($op, "(OP*)&svop_list[$ix]");
+}
+
+sub B::PADOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ $padopsect->add(sprintf("%s, %d",
+ $op->_save_common, $op->padix));
+ my $ix = $padopsect->index;
+ $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
+ savesym($op, "(OP*)&padop_list[$ix]");
+}
+
+sub B::COP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
+ if $debug_cops;
+ # shameless cut'n'paste from B::Deparse
+ my $warn_sv;
+ my $warnings = $op->warnings;
+ my $is_special = $warnings->isa("B::SPECIAL");
+ if ($is_special && $$warnings == 4) {
+ # use warnings 'all';
+ $warn_sv = $optimize_warn_sv ?
+ 'INT2PTR(SV*,1)' :
+ 'pWARN_ALL';
+ }
+ elsif ($is_special && $$warnings == 5) {
+ # no warnings 'all';
+ $warn_sv = $optimize_warn_sv ?
+ 'INT2PTR(SV*,2)' :
+ 'pWARN_NONE';
+ }
+ elsif ($is_special) {
+ # use warnings;
+ $warn_sv = $optimize_warn_sv ?
+ 'INT2PTR(SV*,3)' :
+ 'pWARN_STD';
+ }
+ else {
+ # something else
+ $warn_sv = $warnings->save;
+ }
+
+ $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s",
+ $op->_save_common, cstring($op->label), $op->cop_seq,
+ $op->arybase, $op->line,
+ ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
+ my $ix = $copsect->index;
+ $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+ unless $optimize_ppaddr;
+ $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
+ unless $optimize_warn_sv;
+ $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
+ sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
+
+ savesym($op, "(OP*)&cop_list[$ix]");
+}
+
+sub B::PMOP::save {
+ my ($op, $level) = @_;
+ my $sym = objsym($op);
+ return $sym if defined $sym;
+ my $replroot = $op->pmreplroot;
+ my $replstart = $op->pmreplstart;
+ my $replrootfield;
+ my $replstartfield = sprintf("s\\_%x", $$replstart);
+ my $gvsym;
+ my $ppaddr = $op->ppaddr;
+ # under ithreads, OP_PUSHRE.op_replroot is an integer
+ $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
+ if($ithreads && $op->name eq "pushre") {
+ $replrootfield = "INT2PTR(OP*,${replroot})";
+ } elsif ($$replroot) {
+ # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
+ # argument to a split) stores a GV in op_pmreplroot instead
+ # of a substitution syntax tree. We don't want to walk that...
+ if ($op->name eq "pushre") {
+ $gvsym = $replroot->save;
+# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
+ $replrootfield = 0;
+ } else {
+ $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
+ }
+ }
+ # pmnext handling is broken in perl itself, I think. Bad op_pmnext
+ # fields aren't noticed in perl's runtime (unless you try reset) but we
+ # segfault when trying to dereference it to find op->op_pmnext->op_type
+ $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
+ $op->_save_common, ${$op->first}, ${$op->last},
+ $replrootfield, $replstartfield,
+ ( $ithreads ? $op->pmoffset : 0 ),
+ $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
+ my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
+ $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
+ unless $optimize_ppaddr;
+ my $re = $op->precomp;
+ if (defined($re)) {
+ my( $resym, $relen ) = savere( $re );
+ $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
+ $relen));
+ }
+ if ($gvsym) {
+ $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
+ }
+ savesym($op, "(OP*)&$pm");
+}
+
+sub B::SPECIAL::save {
+ my ($sv) = @_;
+ # special case: $$sv is not the address but an index into specialsv_list
+# warn "SPECIAL::save specialsv $$sv\n"; # debug
+ my $sym = $specialsv_name[$$sv];
+ if (!defined($sym)) {
+ confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
+ }
+ return $sym;
+}
+
+sub B::OBJECT::save {}
+
+sub B::NULL::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+# warn "Saving SVt_NULL SV\n"; # debug
+ # debug
+ if ($$sv == 0) {
+ warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
+ return savesym($sv, "(void*)Nullsv /* XXX */");
+ }
+ $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::IV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
+ $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
+ $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::NV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $val= $sv->NVX;
+ $val .= '.00' if $val =~ /^-?\d+$/;
+ $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
+ $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
+ $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub savepvn {
+ my ($dest,$pv) = @_;
+ my @res;
+ # work with byte offsets/lengths
+ my $pv = pack "a*", $pv;
+ if (defined $max_string_len && length($pv) > $max_string_len) {
+ push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1);
+ my $offset = 0;
+ while (length $pv) {
+ my $str = substr $pv, 0, $max_string_len, '';
+ push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
+ cstring($str), length($str));
+ $offset += length $str;
+ }
+ push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
+ }
+ else {
+ push @res, sprintf("%s = savepvn(%s, %u);", $dest,
+ cstring($pv), length($pv));
+ }
+ return @res;
+}
+
+sub B::PVLV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ my ($lvtarg, $lvtarg_sym);
+ $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
+ $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
+ $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
+ $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
+ $xpvlvsect->index), $pv));
+ }
+ $sv->save_magic;
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVIV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+ $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
+ $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
+ $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
+ if (defined($pv) && !$pv_copy_on_grow) {
+ $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
+ $xpvivsect->index), $pv));
+ }
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVNV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+ my $val= $sv->NVX;
+ $val .= '.00' if $val =~ /^-?\d+$/;
+ $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
+ $savesym, $len, $pvmax, $sv->IVX, $val));
+ $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
+ $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
+ if (defined($pv) && !$pv_copy_on_grow) {
+ $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
+ $xpvnvsect->index), $pv));
+ }
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::BM::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
+ my $len = length($pv);
+ $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
+ $len, $len + 258, $sv->IVX, $sv->NVX,
+ $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
+ $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
+ $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
+ $sv->save_magic;
+ $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
+ $xpvbmsect->index), $pv),
+ sprintf("xpvbm_list[%d].xpv_cur = %u;",
+ $xpvbmsect->index, $len - 257));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+ $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
+ $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
+ $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
+ if (defined($pv) && !$pv_copy_on_grow) {
+ $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
+ $xpvsect->index), $pv));
+ }
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVMG::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+
+ $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
+ $savesym, $len, $pvmax,
+ $sv->IVX, $sv->NVX));
+ $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
+ $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
+ if (defined($pv) && !$pv_copy_on_grow) {
+ $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
+ $xpvmgsect->index), $pv));
+ }
+ $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+ $sv->save_magic;
+ return $sym;
+}
+
+sub B::PVMG::save_magic {
+ my ($sv) = @_;
+ #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
+ my $stash = $sv->SvSTASH;
+ $stash->save;
+ if ($$stash) {
+ warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
+ if $debug_mg;
+ # XXX Hope stash is already going to be saved.
+ $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
+ }
+ my @mgchain = $sv->MAGIC;
+ my ($mg, $type, $obj, $ptr,$len,$ptrsv);
+ foreach $mg (@mgchain) {
+ $type = $mg->TYPE;
+ $ptr = $mg->PTR;
+ $len=$mg->LENGTH;
+ if ($debug_mg) {
+ warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
+ class($sv), $$sv, class($obj), $$obj,
+ cchar($type), cstring($ptr));
+ }
+
+ unless( $type eq 'r' ) {
+ $obj = $mg->OBJ;
+ $obj->save;
+ }
+
+ if ($len == HEf_SVKEY){
+ #The pointer is an SV*
+ $ptrsv=svref_2object($ptr)->save;
+ $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
+ $$sv, $$obj, cchar($type),$ptrsv,$len));
+ }elsif( $type eq 'r' ){
+ my $rx = $mg->REGEX;
+ my $pmop = $REGEXP{$rx};
+
+ confess "PMOP not found for REGEXP $rx" unless $pmop;
+
+ my( $resym, $relen ) = savere( $mg->precomp );
+ my $pmsym = $pmop->save;
+ $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
+{
+ REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
+ sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
+}
+CODE
+ }else{
+ $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
+ $$sv, $$obj, cchar($type),cstring($ptr),$len));
+ }
+ }
+}
+
+sub B::RV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $rv = save_rv( $sv );
+ # GVs need to be handled at runtime
+ if( ref( $sv->RV ) eq 'B::GV' ) {
+ $xrvsect->add( "(SV*)Nullgv" );
+ $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
+ }
+ # and stashes, too
+ elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
+ $xrvsect->add( "(SV*)Nullhv" );
+ $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
+ }
+ else {
+ $xrvsect->add($rv);
+ }
+ $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
+ $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub try_autoload {
+ my ($cvstashname, $cvname) = @_;
+ warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
+ # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
+ # use should be handled by the class itself.
+ no strict 'refs';
+ my $isa = \@{"$cvstashname\::ISA"};
+ if (grep($_ eq "AutoLoader", @$isa)) {
+ warn "Forcing immediate load of sub derived from AutoLoader\n";
+ # Tweaked version of AutoLoader::AUTOLOAD
+ my $dir = $cvstashname;
+ $dir =~ s(::)(/)g;
+ eval { require "auto/$dir/$cvname.al" };
+ if ($@) {
+ warn qq(failed require "auto/$dir/$cvname.al": $@\n);
+ return 0;
+ } else {
+ return 1;
+ }
+ }
+}
+sub Dummy_initxs{};
+sub B::CV::save {
+ my ($cv) = @_;
+ my $sym = objsym($cv);
+ if (defined($sym)) {
+# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
+ return $sym;
+ }
+ # Reserve a place in svsect and xpvcvsect and record indices
+ my $gv = $cv->GV;
+ my ($cvname, $cvstashname);
+ if ($$gv){
+ $cvname = $gv->NAME;
+ $cvstashname = $gv->STASH->NAME;
+ }
+ my $root = $cv->ROOT;
+ my $cvxsub = $cv->XSUB;
+ my $isconst = $cv->CvFLAGS & CVf_CONST;
+ if( $isconst ) {
+ my $value = $cv->XSUBANY;
+ my $stash = $gv->STASH;
+ my $vsym = $value->save;
+ my $stsym = $stash->save;
+ my $name = cstring($cvname);
+ $decl->add( "static CV* cv$cv_index;" );
+ $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
+ my $sym = savesym( $cv, "cv$cv_index" );
+ $cv_index++;
+ return $sym;
+ }
+ #INIT is removed from the symbol table, so this call must come
+ # from PL_initav->save. Re-bootstrapping will push INIT back in
+ # so nullop should be sent.
+ if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
+ my $egv = $gv->EGV;
+ my $stashname = $egv->STASH->NAME;
+ if ($cvname eq "bootstrap")
+ {
+ my $file = $gv->FILE;
+ $decl->add("/* bootstrap $file */");
+ warn "Bootstrap $stashname $file\n";
+ # if it not isa('DynaLoader'), it should hopefully be XSLoaded
+ # ( attributes being an exception, of course )
+ if( $stashname ne 'attributes' &&
+ !UNIVERSAL::isa($stashname,'DynaLoader') ) {
+ $xsub{$stashname}='Dynamic-XSLoaded';
+ $use_xsloader = 1;
+ }
+ else {
+ $xsub{$stashname}='Dynamic';
+ }
+ # $xsub{$stashname}='Static' unless $xsub{$stashname};
+ return qq/NULL/;
+ }
+ else
+ {
+ # XSUBs for IO::File, IO::Handle, IO::Socket,
+ # IO::Seekable and IO::Poll
+ # are defined in IO.xs, so let's bootstrap it
+ svref_2object( \&IO::bootstrap )->save
+ if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
+ IO::Seekable IO::Poll);
+ }
+ warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
+ return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
+ }
+ if ($cvxsub && $cvname eq "INIT") {
+ no strict 'refs';
+ return svref_2object(\&Dummy_initxs)->save;
+ }
+ my $sv_ix = $svsect->index + 1;
+ $svsect->add("svix$sv_ix");
+ my $xpvcv_ix = $xpvcvsect->index + 1;
+ $xpvcvsect->add("xpvcvix$xpvcv_ix");
+ # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
+ $sym = savesym($cv, "&sv_list[$sv_ix]");
+ warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
+ if (!$$root && !$cvxsub) {
+ if (try_autoload($cvstashname, $cvname)) {
+ # Recalculate root and xsub
+ $root = $cv->ROOT;
+ $cvxsub = $cv->XSUB;
+ if ($$root || $cvxsub) {
+ warn "Successful forced autoload\n";
+ }
+ }
+ }
+ my $startfield = 0;
+ my $padlist = $cv->PADLIST;
+ my $pv = $cv->PV;
+ my $xsub = 0;
+ my $xsubany = "Nullany";
+ if ($$root) {
+ warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
+ $$cv, $$root) if $debug_cv;
+ my $ppname = "";
+ if ($$gv) {
+ my $stashname = $gv->STASH->NAME;
+ my $gvname = $gv->NAME;
+ if ($gvname ne "__ANON__") {
+ $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
+ $ppname .= ($stashname eq "main") ?
+ $gvname : "$stashname\::$gvname";
+ $ppname =~ s/::/__/g;
+ if ($gvname eq "INIT"){
+ $ppname .= "_$initsub_index";
+ $initsub_index++;
+ }
+ }
+ }
+ if (!$ppname) {
+ $ppname = "pp_anonsub_$anonsub_index";
+ $anonsub_index++;
+ }
+ $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
+ warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
+ $$cv, $ppname, $$root) if $debug_cv;
+ if ($$padlist) {
+ warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
+ $$padlist, $$cv) if $debug_cv;
+ $padlist->save;
+ warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
+ $$padlist, $$cv) if $debug_cv;
+ }
+ }
+ else {
+ warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
+ $cvstashname, $cvname); # debug
+ }
+ $pv = '' unless defined $pv; # Avoid use of undef warnings
+ $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x",
+ $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
+ $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
+ $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
+ $cv->OUTSIDE_SEQ));
+
+ if (${$cv->OUTSIDE} == ${main_cv()}){
+ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
+ $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
+ }
+
+ if ($$gv) {
+ $gv->save;
+ $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
+ warn sprintf("done saving GV 0x%x for CV 0x%x\n",
+ $$gv, $$cv) if $debug_cv;
+ }
+ if( $ithreads ) {
+ $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
+ }
+ else {
+ $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
+ }
+ my $stash = $cv->STASH;
+ if ($$stash) {
+ $stash->save;
+ $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
+ warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
+ $$stash, $$cv) if $debug_cv;
+ }
+ $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
+ $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
+ return $sym;
+}
+
+sub B::GV::save {
+ my ($gv) = @_;
+ my $sym = objsym($gv);
+ if (defined($sym)) {
+ #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
+ return $sym;
+ } else {
+ my $ix = $gv_index++;
+ $sym = savesym($gv, "gv_list[$ix]");
+ #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
+ }
+ my $is_empty = $gv->is_empty;
+ my $gvname = $gv->NAME;
+ my $fullname = $gv->STASH->NAME . "::" . $gvname;
+ my $name = cstring($fullname);
+ #warn "GV name is $name\n"; # debug
+ my $egvsym;
+ unless ($is_empty) {
+ my $egv = $gv->EGV;
+ if ($$gv != $$egv) {
+ #warn(sprintf("EGV name is %s, saving it now\n",
+ # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
+ $egvsym = $egv->save;
+ }
+ }
+ $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
+ sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
+ sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
+ $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
+ # XXX hack for when Perl accesses PVX of GVs
+ $init->add("SvPVX($sym) = emptystring;\n");
+ # Shouldn't need to do save_magic since gv_fetchpv handles that
+ #$gv->save_magic;
+ # XXX will always be > 1!!!
+ my $refcnt = $gv->REFCNT + 1;
+ $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
+
+ return $sym if $is_empty;
+
+ # XXX B::walksymtable creates an extra reference to the GV
+ my $gvrefcnt = $gv->GvREFCNT;
+ if ($gvrefcnt > 1) {
+ $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
+ }
+ # some non-alphavetic globs require some parts to be saved
+ # ( ex. %!, but not $! )
+ sub Save_HV() { 1 }
+ sub Save_AV() { 2 }
+ sub Save_SV() { 4 }
+ sub Save_CV() { 8 }
+ sub Save_FORM() { 16 }
+ sub Save_IO() { 32 }
+ my $savefields = 0;
+ if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
+ $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
+ }
+ elsif( $gvname eq '!' ) {
+ $savefields = Save_HV;
+ }
+ # attributes::bootstrap is created in perl_parse
+ # saving it would overwrite it, because perl_init() is
+ # called after perl_parse()
+ $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
+
+ # save it
+ # XXX is that correct?
+ if (defined($egvsym) && $egvsym !~ m/Null/ ) {
+ # Shared glob *foo = *bar
+ $init->add("gp_free($sym);",
+ "GvGP($sym) = GvGP($egvsym);");
+ } elsif ($savefields) {
+ # Don't save subfields of special GVs (*_, *1, *# and so on)
+# warn "GV::save saving subfields\n"; # debug
+ my $gvsv = $gv->SV;
+ if ($$gvsv && $savefields&Save_SV) {
+ $gvsv->save;
+ $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
+# warn "GV::save \$$name\n"; # debug
+ }
+ my $gvav = $gv->AV;
+ if ($$gvav && $savefields&Save_AV) {
+ $gvav->save;
+ $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
+# warn "GV::save \@$name\n"; # debug
+ }
+ my $gvhv = $gv->HV;
+ if ($$gvhv && $savefields&Save_HV) {
+ $gvhv->save;
+ $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
+# warn "GV::save \%$name\n"; # debug
+ }
+ my $gvcv = $gv->CV;
+ if ($$gvcv && $savefields&Save_CV) {
+ my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
+ "::" . $gvcv->GV->EGV->NAME);
+ if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
+ # must save as a 'stub' so newXS() has a CV to populate
+ $init->add("{ CV *cv;");
+ $init->add("\tcv=perl_get_cv($origname,TRUE);");
+ $init->add("\tGvCV($sym)=cv;");
+ $init->add("\tSvREFCNT_inc((SV *)cv);");
+ $init->add("}");
+ } else {
+ $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
+# warn "GV::save &$name\n"; # debug
+ }
+ }
+ $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
+# warn "GV::save GvFILE(*$name)\n"; # debug
+ my $gvform = $gv->FORM;
+ if ($$gvform && $savefields&Save_FORM) {
+ $gvform->save;
+ $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
+# warn "GV::save GvFORM(*$name)\n"; # debug
+ }
+ my $gvio = $gv->IO;
+ if ($$gvio && $savefields&Save_IO) {
+ $gvio->save;
+ $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
+ if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
+ no strict 'refs';
+ my $fh = *{$fullname}{IO};
+ use strict 'refs';
+ $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
+ }
+# warn "GV::save GvIO(*$name)\n"; # debug
+ }
+ }
+ return $sym;
+}
+
+sub B::AV::save {
+ my ($av) = @_;
+ my $sym = objsym($av);
+ return $sym if defined $sym;
+ my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0";
+ $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009;
+ $xpvavsect->add($line);
+ $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
+ $xpvavsect->index, $av->REFCNT , $av->FLAGS));
+ my $sv_list_index = $svsect->index;
+ my $fill = $av->FILL;
+ $av->save_magic;
+ if ($debug_av) {
+ $line = sprintf("saving AV 0x%x FILL=$fill", $$av);
+ $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009;
+ warn $line;
+ }
+ # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
+ #if ($fill > -1 && ($avflags & AVf_REAL)) {
+ if ($fill > -1) {
+ my @array = $av->ARRAY;
+ if ($debug_av) {
+ my $el;
+ my $i = 0;
+ foreach $el (@array) {
+ warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
+ $$av, $i++, class($el), $$el);
+ }
+ }
+# my @names = map($_->save, @array);
+ # XXX Better ways to write loop?
+ # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
+ # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
+
+ # micro optimization: op/pat.t ( and other code probably )
+ # has very large pads ( 20k/30k elements ) passing them to
+ # ->add is a performance bottleneck: passing them as a
+ # single string cuts runtime from 6min20sec to 40sec
+
+ # you want to keep this out of the no_split/split
+ # map("\t*svp++ = (SV*)$_;", @names),
+ my $acc = '';
+ foreach my $i ( 0..$#array ) {
+ $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
+ }
+ $acc .= "\n";
+
+ $init->no_split;
+ $init->add("{",
+ "\tSV **svp;",
+ "\tAV *av = (AV*)&sv_list[$sv_list_index];",
+ "\tav_extend(av, $fill);",
+ "\tsvp = AvARRAY(av);" );
+ $init->add($acc);
+ $init->add("\tAvFILLp(av) = $fill;",
+ "}");
+ $init->split;
+ # we really added a lot of lines ( B::C::InitSection->add
+ # should really scan for \n, but that would slow
+ # it down
+ $init->inc_count( $#array );
+ } else {
+ my $max = $av->MAX;
+ $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
+ if $max > -1;
+ }
+ return savesym($av, "(AV*)&sv_list[$sv_list_index]");
+}
+
+sub B::HV::save {
+ my ($hv) = @_;
+ my $sym = objsym($hv);
+ return $sym if defined $sym;
+ my $name = $hv->NAME;
+ if ($name) {
+ # It's a stash
+
+ # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
+ # the only symptom is that sv_reset tries to reset the PMf_USED flag of
+ # a trashed op but we look at the trashed op_type and segfault.
+ #my $adpmroot = ${$hv->PMROOT};
+ my $adpmroot = 0;
+ $decl->add("static HV *hv$hv_index;");
+ # XXX Beware of weird package names containing double-quotes, \n, ...?
+ $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
+ if ($adpmroot) {
+ $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
+ $adpmroot));
+ }
+ $sym = savesym($hv, "hv$hv_index");
+ $hv_index++;
+ return $sym;
+ }
+ # It's just an ordinary HV
+ $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
+ $hv->MAX, $hv->RITER));
+ $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
+ $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
+ my $sv_list_index = $svsect->index;
+ my @contents = $hv->ARRAY;
+ if (@contents) {
+ my $i;
+ for ($i = 1; $i < @contents; $i += 2) {
+ $contents[$i] = $contents[$i]->save;
+ }
+ $init->no_split;
+ $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
+ while (@contents) {
+ my ($key, $value) = splice(@contents, 0, 2);
+ $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+ cstring($key),length(pack "a*",$key),
+ $value, hash($key)));
+# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+# cstring($key),length($key),$value, 0));
+ }
+ $init->add("}");
+ $init->split;
+ }
+ $hv->save_magic();
+ return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
+}
+
+sub B::IO::save_data {
+ my( $io, $globname, @data ) = @_;
+ my $data = join '', @data;
+
+ # XXX using $DATA might clobber it!
+ my $sym = svref_2object( \\$data )->save;
+ $init->add( split /\n/, <<CODE );
+ {
+ GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
+ SV* sv = $sym;
+ GvSV( gv ) = sv;
+ }
+CODE
+ # for PerlIO::scalar
+ $use_xsloader = 1;
+ $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
+}
+
+sub B::IO::save {
+ my ($io) = @_;
+ my $sym = objsym($io);
+ return $sym if defined $sym;
+ my $pv = $io->PV;
+ $pv = '' unless defined $pv;
+ my $len = length($pv);
+ $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
+ $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
+ $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
+ cstring($io->TOP_NAME), cstring($io->FMT_NAME),
+ cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
+ cchar($io->IoTYPE), $io->IoFLAGS));
+ $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
+ $xpviosect->index, $io->REFCNT , $io->FLAGS));
+ $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
+ # deal with $x = *STDIN/STDOUT/STDERR{IO}
+ my $perlio_func;
+ foreach ( qw(stdin stdout stderr) ) {
+ $io->IsSTD($_) and $perlio_func = $_;
+ }
+ if( $perlio_func ) {
+ $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
+ $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
+ }
+
+ my ($field, $fsym);
+ foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
+ $fsym = $io->$field();
+ if ($$fsym) {
+ $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
+ $fsym->save;
+ }
+ }
+ $io->save_magic;
+ return $sym;
+}
+
+sub B::SV::save {
+ my $sv = shift;
+ # This is where we catch an honest-to-goodness Nullsv (which gets
+ # blessed into B::SV explicitly) and any stray erroneous SVs.
+ return 0 unless $$sv;
+ confess sprintf("cannot save that type of SV: %s (0x%x)\n",
+ class($sv), $$sv);
+}
+
+sub output_all {
+ my $init_name = shift;
+ my $section;
+ my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
+ $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
+ $loopsect, $copsect, $svsect, $xpvsect,
+ $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
+ $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
+ $symsect->output(\*STDOUT, "#define %s\n");
+ print "\n";
+ output_declarations();
+ foreach $section (@sections) {
+ my $lines = $section->index + 1;
+ if ($lines) {
+ my $name = $section->name;
+ my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+ print "Static $typename ${name}_list[$lines];\n";
+ }
+ }
+ # XXX hack for when Perl accesses PVX of GVs
+ print 'Static char emptystring[] = "\0";';
+
+ $decl->output(\*STDOUT, "%s\n");
+ print "\n";
+ foreach $section (@sections) {
+ my $lines = $section->index + 1;
+ if ($lines) {
+ my $name = $section->name;
+ my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+ printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
+ $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
+ print "};\n\n";
+ }
+ }
+
+ $init->output(\*STDOUT, "\t%s\n", $init_name );
+ if ($verbose) {
+ warn compile_stats();
+ warn "NULLOP count: $nullop_count\n";
+ }
+}
+
+sub output_declarations {
+ print <<'EOT';
+#ifdef BROKEN_STATIC_REDECL
+#define Static extern
+#else
+#define Static static
+#endif /* BROKEN_STATIC_REDECL */
+
+#ifdef BROKEN_UNION_INIT
+/*
+ * Cribbed from cv.h with ANY (a union) replaced by void*.
+ * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
+ */
+typedef struct {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xof_off; /* integer value */
+ NV xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ void (*xcv_xsub) (pTHX_ CV*);
+ ANY xcv_xsubany;
+ GV * xcv_gv;
+ char * xcv_file;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ CV * xcv_outside;
+EOT
+ print <<'EOT' if $] < 5.009;
+#ifdef USE_5005THREADS
+ perl_mutex *xcv_mutexp;
+ struct perl_thread *xcv_owner; /* current owner thread */
+#endif /* USE_5005THREADS */
+EOT
+ print <<'EOT';
+ cv_flags_t xcv_flags;
+ U32 xcv_outside_seq; /* the COP sequence (at the point of our
+ * compilation) in the lexically enclosing
+ * sub */
+} XPVCV_or_similar;
+#define ANYINIT(i) i
+#else
+#define XPVCV_or_similar XPVCV
+#define ANYINIT(i) {i}
+#endif /* BROKEN_UNION_INIT */
+#define Nullany ANYINIT(0)
+
+#define UNUSED 0
+#define sym_0 0
+EOT
+ print "static GV *gv_list[$gv_index];\n" if $gv_index;
+ print "\n";
+}
+
+
+sub output_boilerplate {
+ print <<'EOT';
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* Workaround for mapstart: the only op which needs a different ppaddr */
+#undef Perl_pp_mapstart
+#define Perl_pp_mapstart Perl_pp_grepstart
+#undef OP_MAPSTART
+#define OP_MAPSTART OP_GREPSTART
+#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
+EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
+
+static void xs_init (pTHX);
+static void dl_init (pTHX);
+static PerlInterpreter *my_perl;
+EOT
+}
+
+sub init_op_addr {
+ my( $op_type, $num ) = @_;
+ my $op_list = $op_type."_list";
+
+ $init->add( split /\n/, <<EOT );
+ {
+ int i;
+
+ for( i = 0; i < ${num}; ++i )
+ {
+ ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
+ }
+ }
+EOT
+}
+
+sub init_op_warn {
+ my( $op_type, $num ) = @_;
+ my $op_list = $op_type."_list";
+
+ # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
+ $init->add( split /\n/, <<EOT );
+ {
+ int i;
+
+ for( i = 0; i < ${num}; ++i )
+ {
+ switch( (int)(${op_list}\[i].cop_warnings) )
+ {
+ case 1:
+ ${op_list}\[i].cop_warnings = pWARN_ALL;
+ break;
+ case 2:
+ ${op_list}\[i].cop_warnings = pWARN_NONE;
+ break;
+ case 3:
+ ${op_list}\[i].cop_warnings = pWARN_STD;
+ break;
+ default:
+ break;
+ }
+ }
+ }
+EOT
+}
+
+sub output_main {
+ print <<'EOT';
+/* if USE_IMPLICIT_SYS, we need a 'real' exit */
+#if defined(exit)
+#undef exit
+#endif
+
+int
+main(int argc, char **argv, char **env)
+{
+ int exitstatus;
+ int i;
+ char **fakeargv;
+ GV* tmpgv;
+ SV* tmpsv;
+ int options_count;
+
+ PERL_SYS_INIT3(&argc,&argv,&env);
+
+ if (!PL_do_undump) {
+ my_perl = perl_alloc();
+ if (!my_perl)
+ exit(1);
+ perl_construct( my_perl );
+ PL_perl_destruct_level = 0;
+ }
+EOT
+ if( $ithreads ) {
+ # XXX init free elems!
+ my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
+
+ print <<EOT;
+#ifdef USE_ITHREADS
+ for( i = 0; i < $pad_len; ++i ) {
+ av_push( PL_regex_padav, newSViv(0) );
+ }
+ PL_regex_pad = AvARRAY( PL_regex_padav );
+#endif
+EOT
+ }
+
+ print <<'EOT';
+#ifdef CSH
+ if (!PL_cshlen)
+ PL_cshlen = strlen(PL_cshname);
+#endif
+
+#ifdef ALLOW_PERL_OPTIONS
+#define EXTRA_OPTIONS 3
+#else
+#define EXTRA_OPTIONS 4
+#endif /* ALLOW_PERL_OPTIONS */
+ Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *);
+
+ fakeargv[0] = argv[0];
+ fakeargv[1] = "-e";
+ fakeargv[2] = "";
+ options_count = 3;
+EOT
+ # honour -T
+ print <<EOT;
+ if( ${^TAINT} ) {
+ fakeargv[options_count] = "-T";
+ ++options_count;
+ }
+EOT
+ print <<'EOT';
+#ifndef ALLOW_PERL_OPTIONS
+ fakeargv[options_count] = "--";
+ ++options_count;
+#endif /* ALLOW_PERL_OPTIONS */
+ for (i = 1; i < argc; i++)
+ fakeargv[i + options_count - 1] = argv[i];
+ fakeargv[argc + options_count - 1] = 0;
+
+ exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
+ fakeargv, NULL);
+
+ if (exitstatus)
+ exit( exitstatus );
+
+ TAINT;
+EOT
+
+ if( $use_perl_script_name ) {
+ my $dollar_0 = $0;
+ $dollar_0 =~ s/\\/\\\\/g;
+ $dollar_0 = '"' . $dollar_0 . '"';
+
+ print <<EOT;
+ if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
+ tmpsv = GvSV(tmpgv);
+ sv_setpv(tmpsv, ${dollar_0});
+ SvSETMAGIC(tmpsv);
+ }
+EOT
+ }
+ else {
+ print <<EOT;
+ if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
+ tmpsv = GvSV(tmpgv);
+ sv_setpv(tmpsv, argv[0]);
+ SvSETMAGIC(tmpsv);
+ }
+EOT
+ }
+
+ print <<'EOT';
+ if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
+ tmpsv = GvSV(tmpgv);
+#ifdef WIN32
+ sv_setpv(tmpsv,"perl.exe");
+#else
+ sv_setpv(tmpsv,"perl");
+#endif
+ SvSETMAGIC(tmpsv);
+ }
+
+ TAINT_NOT;
+
+ /* PL_main_cv = PL_compcv; */
+ PL_compcv = 0;
+
+ exitstatus = perl_init();
+ if (exitstatus)
+ exit( exitstatus );
+ dl_init(aTHX);
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ PERL_SYS_TERM();
+
+ exit( exitstatus );
+}
+
+/* yanked from perl.c */
+static void
+xs_init(pTHX)
+{
+ char *file = __FILE__;
+ dTARG;
+ dSP;
+EOT
+ print "\n#ifdef USE_DYNAMIC_LOADING";
+ print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
+ print "\n#endif\n" ;
+ # delete $xsub{'DynaLoader'};
+ delete $xsub{'UNIVERSAL'};
+ print("/* bootstrapping code*/\n\tSAVETMPS;\n");
+ print("\ttarg=sv_newmortal();\n");
+ print "#ifdef USE_DYNAMIC_LOADING\n";
+ print "\tPUSHMARK(sp);\n";
+ print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
+ print qq/\tPUTBACK;\n/;
+ print "\tboot_DynaLoader(aTHX_ NULL);\n";
+ print qq/\tSPAGAIN;\n/;
+ print "#endif\n";
+ foreach my $stashname (keys %xsub){
+ if ($xsub{$stashname} !~ m/Dynamic/ ) {
+ my $stashxsub=$stashname;
+ $stashxsub =~ s/::/__/g;
+ print "\tPUSHMARK(sp);\n";
+ print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
+ print qq/\tPUTBACK;\n/;
+ print "\tboot_$stashxsub(aTHX_ NULL);\n";
+ print qq/\tSPAGAIN;\n/;
+ }
+ }
+ print("\tFREETMPS;\n/* end bootstrapping code */\n");
+ print "}\n";
+
+print <<'EOT';
+static void
+dl_init(pTHX)
+{
+ char *file = __FILE__;
+ dTARG;
+ dSP;
+EOT
+ print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
+ print("\ttarg=sv_newmortal();\n");
+ foreach my $stashname (@DynaLoader::dl_modules) {
+ warn "Loaded $stashname\n";
+ if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
+ my $stashxsub=$stashname;
+ $stashxsub =~ s/::/__/g;
+ print "\tPUSHMARK(sp);\n";
+ print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
+ print qq/\tPUTBACK;\n/;
+ print "#ifdef USE_DYNAMIC_LOADING\n";
+ warn "bootstrapping $stashname added to xs_init\n";
+ if( $xsub{$stashname} eq 'Dynamic' ) {
+ print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
+ }
+ else {
+ print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
+ }
+ print "#else\n";
+ print "\tboot_$stashxsub(aTHX_ NULL);\n";
+ print "#endif\n";
+ print qq/\tSPAGAIN;\n/;
+ }
+ }
+ print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
+ print "}\n";
+}
+sub dump_symtable {
+ # For debugging
+ my ($sym, $val);
+ warn "----Symbol table:\n";
+ while (($sym, $val) = each %symtable) {
+ warn "$sym => $val\n";
+ }
+ warn "---End of symbol table\n";
+}
+
+sub save_object {
+ my $sv;
+ foreach $sv (@_) {
+ svref_2object($sv)->save;
+ }
+}
+
+sub Dummy_BootStrap { }
+
+sub B::GV::savecv
+{
+ my $gv = shift;
+ my $package=$gv->STASH->NAME;
+ my $name = $gv->NAME;
+ my $cv = $gv->CV;
+ my $sv = $gv->SV;
+ my $av = $gv->AV;
+ my $hv = $gv->HV;
+
+ my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
+
+ # We may be looking at this package just because it is a branch in the
+ # symbol table which is on the path to a package which we need to save
+ # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
+ #
+ return unless ($unused_sub_packages{$package});
+ return unless ($$cv || $$av || $$sv || $$hv);
+ $gv->save;
+}
+
+sub mark_package
+{
+ my $package = shift;
+ unless ($unused_sub_packages{$package})
+ {
+ no strict 'refs';
+ $unused_sub_packages{$package} = 1;
+ if (defined @{$package.'::ISA'})
+ {
+ foreach my $isa (@{$package.'::ISA'})
+ {
+ if ($isa eq 'DynaLoader')
+ {
+ unless (defined(&{$package.'::bootstrap'}))
+ {
+ warn "Forcing bootstrap of $package\n";
+ eval { $package->bootstrap };
+ }
+ }
+# else
+ {
+ unless ($unused_sub_packages{$isa})
+ {
+ warn "$isa saved (it is in $package\'s \@ISA)\n";
+ mark_package($isa);
+ }
+ }
+ }
+ }
+ }
+ return 1;
+}
+
+sub should_save
+{
+ no strict qw(vars refs);
+ my $package = shift;
+ $package =~ s/::$//;
+ return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
+ # warn "Considering $package\n";#debug
+ foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
+ {
+ # If this package is a prefix to something we are saving, traverse it
+ # but do not mark it for saving if it is not already
+ # e.g. to get to Getopt::Long we need to traverse Getopt but need
+ # not save Getopt
+ return 1 if ($u =~ /^$package\:\:/);
+ }
+ if (exists $unused_sub_packages{$package})
+ {
+ # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
+ delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
+ return $unused_sub_packages{$package};
+ }
+ # Omit the packages which we use (and which cause grief
+ # because of fancy "goto &$AUTOLOAD" stuff).
+ # XXX Surely there must be a nicer way to do this.
+ if ($package eq "FileHandle" || $package eq "Config" ||
+ $package eq "SelectSaver" || $package =~/^(B|IO)::/)
+ {
+ delete_unsaved_hashINC($package);
+ return $unused_sub_packages{$package} = 0;
+ }
+ # Now see if current package looks like an OO class this is probably too strong.
+ foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
+ {
+ if (UNIVERSAL::can($package, $m))
+ {
+ warn "$package has method $m: saving package\n";#debug
+ return mark_package($package);
+ }
+ }
+ delete_unsaved_hashINC($package);
+ return $unused_sub_packages{$package} = 0;
+}
+sub delete_unsaved_hashINC{
+ my $packname=shift;
+ $packname =~ s/\:\:/\//g;
+ $packname .= '.pm';
+# warn "deleting $packname" if $INC{$packname} ;# debug
+ delete $INC{$packname};
+}
+sub walkpackages
+{
+ my ($symref, $recurse, $prefix) = @_;
+ my $sym;
+ my $ref;
+ no strict 'vars';
+ $prefix = '' unless defined $prefix;
+ while (($sym, $ref) = each %$symref)
+ {
+ local(*glob);
+ *glob = $ref;
+ if ($sym =~ /::$/)
+ {
+ $sym = $prefix . $sym;
+ if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
+ {
+ walkpackages(\%glob, $recurse, $sym);
+ }
+ }
+ }
+}
+
+
+sub save_unused_subs
+{
+ no strict qw(refs);
+ &descend_marked_unused;
+ warn "Prescan\n";
+ walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
+ warn "Saving methods\n";
+ walksymtable(\%{"main::"}, "savecv", \&should_save);
+}
+
+sub save_context
+{
+ my $curpad_nam = (comppadlist->ARRAY)[0]->save;
+ my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+ my $inc_hv = svref_2object(\%INC)->save;
+ my $inc_av = svref_2object(\@INC)->save;
+ my $amagic_generate= amagic_generation;
+ $init->add( "PL_curpad = AvARRAY($curpad_sym);",
+ "GvHV(PL_incgv) = $inc_hv;",
+ "GvAV(PL_incgv) = $inc_av;",
+ "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
+ "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+ "PL_amagic_generation= $amagic_generate;" );
+}
+
+sub descend_marked_unused {
+ foreach my $pack (keys %unused_sub_packages)
+ {
+ mark_package($pack);
+ }
+}
+
+sub save_main {
+ # this is mainly for the test suite
+ my $warner = $SIG{__WARN__};
+ local $SIG{__WARN__} = sub { print STDERR @_ };
+
+ warn "Starting compile\n";
+ warn "Walking tree\n";
+ seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
+ walkoptree(main_root, "save");
+ warn "done main optree, walking symtable for extras\n" if $debug_cv;
+ save_unused_subs();
+ # XSLoader was used, force saving of XSLoader::load
+ if( $use_xsloader ) {
+ my $cv = svref_2object( \&XSLoader::load );
+ $cv->save;
+ }
+ # save %SIG ( in case it was set in a BEGIN block )
+ if( $save_sig ) {
+ local $SIG{__WARN__} = $warner;
+ $init->no_split;
+ $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
+ foreach my $k ( keys %SIG ) {
+ next unless ref $SIG{$k};
+ my $cv = svref_2object( \$SIG{$k} );
+ my $sv = $cv->save;
+ $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
+ $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+ cstring($k),length(pack "a*",$k),
+ 'sv', hash($k)));
+ $init->add('mg_set(sv);','}');
+ }
+ $init->add('}');
+ $init->split;
+ }
+ # honour -w
+ $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
+ #
+ my $init_av = init_av->save;
+ my $end_av = end_av->save;
+ $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
+ sprintf("PL_main_start = s\\_%x;", ${main_start()}),
+ "PL_initav = (AV *) $init_av;",
+ "PL_endav = (AV*) $end_av;");
+ save_context();
+ # init op addrs ( must be the last action, otherwise
+ # some ops might not be initialized
+ if( $optimize_ppaddr ) {
+ foreach my $i ( @op_sections ) {
+ my $section = $$i;
+ next unless $section->index >= 0;
+ init_op_addr( $section->name, $section->index + 1);
+ }
+ }
+ init_op_warn( $copsect->name, $copsect->index + 1)
+ if $optimize_warn_sv && $copsect->index >= 0;
+
+ warn "Writing output\n";
+ output_boilerplate();
+ print "\n";
+ output_all("perl_init");
+ print "\n";
+ output_main();
+}
+
+sub init_sections {
+ my @sections = (decl => \$decl, sym => \$symsect,
+ binop => \$binopsect, condop => \$condopsect,
+ cop => \$copsect, padop => \$padopsect,
+ listop => \$listopsect, logop => \$logopsect,
+ loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
+ pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
+ sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
+ xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
+ xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
+ xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
+ xrv => \$xrvsect, xpvbm => \$xpvbmsect,
+ xpvio => \$xpviosect);
+ my ($name, $sectref);
+ while (($name, $sectref) = splice(@sections, 0, 2)) {
+ $$sectref = new B::C::Section $name, \%symtable, 0;
+ }
+ $init = new B::C::InitSection 'init', \%symtable, 0;
+}
+
+sub mark_unused
+{
+ my ($arg,$val) = @_;
+ $unused_sub_packages{$arg} = $val;
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ my @eval_at_startup;
+ my %option_map = ( 'cog' => \$pv_copy_on_grow,
+ 'save-data' => \$save_data_fh,
+ 'ppaddr' => \$optimize_ppaddr,
+ 'warn-sv' => \$optimize_warn_sv,
+ 'use-script-name' => \$use_perl_script_name,
+ 'save-sig-hash' => \$save_sig,
+ );
+ my %optimization_map = ( 0 => [ qw() ], # special case
+ 1 => [ qw(-fcog) ],
+ 2 => [ qw(-fwarn-sv -fppaddr) ],
+ );
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ }
+ if ($opt eq "w") {
+ $warn_undefined_syms = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "c") {
+ $debug_cops = 1;
+ } elsif ($arg eq "A") {
+ $debug_av = 1;
+ } elsif ($arg eq "C") {
+ $debug_cv = 1;
+ } elsif ($arg eq "M") {
+ $debug_mg = 1;
+ } else {
+ warn "ignoring unknown debug option: $arg\n";
+ }
+ }
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "v") {
+ $verbose = 1;
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ mark_unused($arg,undef);
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ $arg =~ m/(no-)?(.*)/;
+ my $no = defined($1) && $1 eq 'no-';
+ $arg = $no ? $2 : $arg;
+ if( exists $option_map{$arg} ) {
+ ${$option_map{$arg}} = !$no;
+ } else {
+ die "Invalid optimization '$arg'";
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ my @opt;
+ foreach my $i ( 1 .. $arg ) {
+ push @opt, @{$optimization_map{$i}}
+ if exists $optimization_map{$i};
+ }
+ unshift @options, @opt;
+ } elsif ($opt eq "e") {
+ push @eval_at_startup, $arg;
+ } elsif ($opt eq "l") {
+ $max_string_len = $arg;
+ }
+ }
+ init_sections();
+ foreach my $i ( @eval_at_startup ) {
+ $init->add_eval( $i );
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ eval "save_object(\\$objname)";
+ }
+ output_all();
+ }
+ } else {
+ return sub { save_main() };
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::C - Perl compiler's C backend
+
+=head1 SYNOPSIS
+
+ perl -MO=C[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend takes Perl source and generates C source code
+corresponding to the internal structures that perl uses to run
+your program. When the generated C source is compiled and run, it
+cuts out the time which perl would have taken to load and parse
+your program into its internal semi-compiled form. That means that
+compiling with this backend will not help improve the runtime
+execution speed of your program but may improve the start-up time.
+Depending on the environment in which your program runs this may be
+either a help or a hindrance.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be
+names of objects to be saved (probably doesn't work properly yet).
+Without extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT
+
+=item B<-v>
+
+Verbose compilation (currently gives a few compilation statistics).
+
+=item B<-->
+
+Force end of options
+
+=item B<-uPackname>
+
+Force apparently unused subs from package Packname to be compiled.
+This allows programs to use eval "foo()" even when sub foo is never
+seen to be used at compile time. The down side is that any subs which
+really are never used also have code generated. This option is
+necessary, for example, if you have a signal handler foo which you
+initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
+to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
+options. The compiler tries to figure out which packages may possibly
+have subs in which need compiling but the current version doesn't do
+it very well. In particular, it is confused by nested packages (i.e.
+of the form C<A::B>) where package C<A> does not contain any subs.
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Do>
+
+OPs, prints each OP as it's processed
+
+=item B<-Dc>
+
+COPs, prints COPs as processed (incl. file & line num)
+
+=item B<-DA>
+
+prints AV information on saving
+
+=item B<-DC>
+
+prints CV information on saving
+
+=item B<-DM>
+
+prints MAGIC information on saving
+
+=item B<-f>
+
+Force options/optimisations on or off one at a time. You can explicitly
+disable an option using B<-fno-option>. All options default to
+B<disabled>.
+
+=over 4
+
+=item B<-fcog>
+
+Copy-on-grow: PVs declared and initialised statically.
+
+=item B<-fsave-data>
+
+Save package::DATA filehandles ( only available with PerlIO ).
+
+=item B<-fppaddr>
+
+Optimize the initialization of op_ppaddr.
+
+=item B<-fwarn-sv>
+
+Optimize the initialization of cop_warnings.
+
+=item B<-fuse-script-name>
+
+Use the script name instead of the program name as $0.
+
+=item B<-fsave-sig-hash>
+
+Save compile-time modifications to the %SIG hash.
+
+=back
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
+
+=over 4
+
+=item B<-O0>
+
+Disable all optimizations.
+
+=item B<-O1>
+
+Enable B<-fcog>.
+
+=item B<-O2>
+
+Enable B<-fppaddr>, B<-fwarn-sv>.
+
+=back
+
+=item B<-llimit>
+
+Some C compilers impose an arbitrary limit on the length of string
+constants (e.g. 2048 characters for Microsoft Visual C++). The
+B<-llimit> options tells the C backend not to generate string literals
+exceeding that limit.
+
+=back
+
+=head1 EXAMPLES
+
+ perl -MO=C,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+Note that C<cc_harness> lives in the C<B> subdirectory of your perl
+library directory. The utility called C<perlcc> may also be used to
+help make use of this compiler.
+
+ perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/CC.pm
==============================================================================
--- (empty file)
+++ B/B/CC.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,2005 @@
+# CC.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::CC;
+
+our $VERSION = '1.00_01';
+
+use Config;
+use strict;
+use B qw(main_start main_root class comppadlist peekop svref_2object
+ timing_info init_av sv_undef amagic_generation
+ OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
+ OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
+ OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
+ CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
+ );
+use B::C qw(save_unused_subs objsym init_sections mark_unused
+ output_all output_boilerplate output_main);
+use B::Bblock qw(find_leaders);
+use B::Stackobj qw(:types :flags);
+
+# These should probably be elsewhere
+# Flags for $op->flags
+
+my $module; # module name (when compiled with -m)
+my %done; # hash keyed by $$op of leaders of basic blocks
+ # which have already been done.
+my $leaders; # ref to hash of basic block leaders. Keys are $$op
+ # addresses, values are the $op objects themselves.
+my @bblock_todo; # list of leaders of basic blocks that need visiting
+ # sometime.
+my @cc_todo; # list of tuples defining what PP code needs to be
+ # saved (e.g. CV, main or PMOP repl code). Each tuple
+ # is [$name, $root, $start, @padlist]. PMOP repl code
+ # tuples inherit padlist.
+my @stack; # shadows perl's stack when contents are known.
+ # Values are objects derived from class B::Stackobj
+my @pad; # Lexicals in current pad as Stackobj-derived objects
+my @padlist; # Copy of current padlist so PMOP repl code can find it
+my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
+my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
+my %constobj; # OP_CONST constants as Stackobj-derived objects
+ # keyed by $$sv.
+my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
+ # block or even to the end of each loop of blocks,
+ # depending on optimisation options.
+my $know_op = 0; # Set when C variable op already holds the right op
+ # (from an immediately preceding DOOP(ppname)).
+my $errors = 0; # Number of errors encountered
+my %skip_stack; # Hash of PP names which don't need write_back_stack
+my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
+my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
+my %ignore_op; # Hash of ops which do nothing except returning op_next
+my %need_curcop; # Hash of ops which need PL_curcop
+
+my %lexstate; #state of padsvs at the start of a bblock
+
+BEGIN {
+ foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
+ $ignore_op{$_} = 1;
+ }
+}
+
+my ($module_name);
+my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
+ $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
+
+# Optimisation options. On the command line, use hyphens instead of
+# underscores for compatibility with gcc-style options. We use
+# underscores here because they are OK in (strict) barewords.
+my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
+my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
+ freetmps_each_loop => \$freetmps_each_loop,
+ omit_taint => \$omit_taint);
+# perl patchlevel to generate code for (defaults to current patchlevel)
+my $patchlevel = int(0.5 + 1000 * ($] - 5));
+
+# Could rewrite push_runtime() and output_runtime() to use a
+# temporary file if memory is at a premium.
+my $ppname; # name of current fake PP function
+my $runtime_list_ref;
+my $declare_ref; # Hash ref keyed by C variable type of declarations.
+
+my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
+ # tuples to be written out.
+
+my ($init, $decl);
+
+sub init_hash { map { $_ => 1 } @_ }
+
+#
+# Initialise the hashes for the default PP functions where we can avoid
+# either write_back_stack, write_back_lexicals or invalidate_lexicals.
+#
+%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
+%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
+%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
+ pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
+ pp_entertry pp_enterloop pp_enteriter pp_entersub
+ pp_enter pp_method);
+
+sub debug {
+ if ($debug_runtime) {
+ warn(@_);
+ } else {
+ my @tmp=@_;
+ runtime(map { chomp; "/* $_ */"} @tmp);
+ }
+}
+
+sub declare {
+ my ($type, $var) = @_;
+ push(@{$declare_ref->{$type}}, $var);
+}
+
+sub push_runtime {
+ push(@$runtime_list_ref, @_);
+ warn join("\n", @_) . "\n" if $debug_runtime;
+}
+
+sub save_runtime {
+ push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
+}
+
+sub output_runtime {
+ my $ppdata;
+ print qq(#include "cc_runtime.h"\n);
+ foreach $ppdata (@pp_list) {
+ my ($name, $runtime, $declare) = @$ppdata;
+ print "\nstatic\nCCPP($name)\n{\n";
+ my ($type, $varlist, $line);
+ while (($type, $varlist) = each %$declare) {
+ print "\t$type ", join(", ", @$varlist), ";\n";
+ }
+ foreach $line (@$runtime) {
+ print $line, "\n";
+ }
+ print "}\n";
+ }
+}
+
+sub runtime {
+ my $line;
+ foreach $line (@_) {
+ push_runtime("\t$line");
+ }
+}
+
+sub init_pp {
+ $ppname = shift;
+ $runtime_list_ref = [];
+ $declare_ref = {};
+ runtime("dSP;");
+ declare("I32", "oldsave");
+ declare("SV", "**svp");
+ map { declare("SV", "*$_") } qw(sv src dst left right);
+ declare("MAGIC", "*mg");
+ $decl->add("static OP * $ppname (pTHX);");
+ debug "init_pp: $ppname\n" if $debug_queue;
+}
+
+# Initialise runtime_callback function for Stackobj class
+BEGIN { B::Stackobj::set_callback(\&runtime) }
+
+# Initialise saveoptree_callback for B::C class
+sub cc_queue {
+ my ($name, $root, $start, @pl) = @_;
+ debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
+ if $debug_queue;
+ if ($name eq "*ignore*") {
+ $name = 0;
+ } else {
+ push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
+ }
+ my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
+ $start = $fakeop->save;
+ debug "cc_queue: name $name returns $start\n" if $debug_queue;
+ return $start;
+}
+BEGIN { B::C::set_callback(\&cc_queue) }
+
+sub valid_int { $_[0]->{flags} & VALID_INT }
+sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
+sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
+sub valid_sv { $_[0]->{flags} & VALID_SV }
+
+sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
+sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
+sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
+sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
+sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
+
+sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
+sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
+sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
+sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
+sub pop_bool {
+ if (@stack) {
+ return ((pop @stack)->as_bool);
+ } else {
+ # Careful: POPs has an auto-decrement and SvTRUE evaluates
+ # its argument more than once.
+ runtime("sv = POPs;");
+ return "SvTRUE(sv)";
+ }
+}
+
+sub write_back_lexicals {
+ my $avoid = shift || 0;
+ debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+ if $debug_shadow;
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ $lex->write_back unless $lex->{flags} & $avoid;
+ }
+}
+
+sub save_or_restore_lexical_state {
+ my $bblock=shift;
+ unless( exists $lexstate{$bblock}){
+ foreach my $lex (@pad) {
+ next unless ref($lex);
+ ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
+ }
+ }
+ else {
+ foreach my $lex (@pad) {
+ next unless ref($lex);
+ my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
+ next if ( $old_flags eq $lex->{flags});
+ if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){
+ $lex->write_back;
+ }
+ if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
+ $lex->load_double;
+ }
+ if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
+ $lex->load_int;
+ }
+ }
+ }
+}
+
+sub write_back_stack {
+ my $obj;
+ return unless @stack;
+ runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
+ foreach $obj (@stack) {
+ runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
+ }
+ @stack = ();
+}
+
+sub invalidate_lexicals {
+ my $avoid = shift || 0;
+ debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+ if $debug_shadow;
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ $lex->invalidate unless $lex->{flags} & $avoid;
+ }
+}
+
+sub reload_lexicals {
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ my $type = $lex->{type};
+ if ($type == T_INT) {
+ $lex->as_int;
+ } elsif ($type == T_DOUBLE) {
+ $lex->as_double;
+ } else {
+ $lex->as_sv;
+ }
+ }
+}
+
+{
+ package B::Pseudoreg;
+ #
+ # This class allocates pseudo-registers (OK, so they're C variables).
+ #
+ my %alloc; # Keyed by variable name. A value of 1 means the
+ # variable has been declared. A value of 2 means
+ # it's in use.
+
+ sub new_scope { %alloc = () }
+
+ sub new ($$$) {
+ my ($class, $type, $prefix) = @_;
+ my ($ptr, $i, $varname, $status, $obj);
+ $prefix =~ s/^(\**)//;
+ $ptr = $1;
+ $i = 0;
+ do {
+ $varname = "$prefix$i";
+ $status = $alloc{$varname};
+ } while $status == 2;
+ if ($status != 1) {
+ # Not declared yet
+ B::CC::declare($type, "$ptr$varname");
+ $alloc{$varname} = 2; # declared and in use
+ }
+ $obj = bless \$varname, $class;
+ return $obj;
+ }
+ sub DESTROY {
+ my $obj = shift;
+ $alloc{$$obj} = 1; # no longer in use but still declared
+ }
+}
+{
+ package B::Shadow;
+ #
+ # This class gives a standard API for a perl object to shadow a
+ # C variable and only generate reloads/write-backs when necessary.
+ #
+ # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
+ # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
+ # Use $obj->invalidate whenever an unknown function may have
+ # set shadow itself.
+
+ sub new {
+ my ($class, $write_back) = @_;
+ # Object fields are perl shadow variable, validity flag
+ # (for *C* variable) and callback sub for write_back
+ # (passed perl shadow variable as argument).
+ bless [undef, 1, $write_back], $class;
+ }
+ sub load {
+ my ($obj, $newval) = @_;
+ $obj->[1] = 0; # C variable no longer valid
+ $obj->[0] = $newval;
+ }
+ sub write_back {
+ my $obj = shift;
+ if (!($obj->[1])) {
+ $obj->[1] = 1; # C variable will now be valid
+ &{$obj->[2]}($obj->[0]);
+ }
+ }
+ sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
+}
+my $curcop = new B::Shadow (sub {
+ my $opsym = shift->save;
+ runtime("PL_curcop = (COP*)$opsym;");
+});
+
+#
+# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
+#
+sub dopoptoloop {
+ my $cxix = $#cxstack;
+ while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
+ $cxix--;
+ }
+ debug "dopoptoloop: returning $cxix" if $debug_cxstack;
+ return $cxix;
+}
+
+sub dopoptolabel {
+ my $label = shift;
+ my $cxix = $#cxstack;
+ while ($cxix >= 0 &&
+ ($cxstack[$cxix]->{type} != CXt_LOOP ||
+ $cxstack[$cxix]->{label} ne $label)) {
+ $cxix--;
+ }
+ debug "dopoptolabel: returning $cxix" if $debug_cxstack;
+ return $cxix;
+}
+
+sub error {
+ my $format = shift;
+ my $file = $curcop->[0]->file;
+ my $line = $curcop->[0]->line;
+ $errors++;
+ if (@_) {
+ warn sprintf("%s:%d: $format\n", $file, $line, @_);
+ } else {
+ warn sprintf("%s:%d: %s\n", $file, $line, $format);
+ }
+}
+
+#
+# Load pad takes (the elements of) a PADLIST as arguments and loads
+# up @pad with Stackobj-derived objects which represent those lexicals.
+# If/when perl itself can generate type information (my int $foo) then
+# we'll take advantage of that here. Until then, we'll use various hacks
+# to tell the compiler when we want a lexical to be a particular type
+# or to be a register.
+#
+sub load_pad {
+ my ($namelistav, $valuelistav) = @_;
+ @padlist = @_;
+ my @namelist = $namelistav->ARRAY;
+ my @valuelist = $valuelistav->ARRAY;
+ my $ix;
+ @pad = ();
+ debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
+ # Temporary lexicals don't get named so it's possible for @valuelist
+ # to be strictly longer than @namelist. We count $ix up to the end of
+ # @valuelist but index into @namelist for the name. Any temporaries which
+ # run off the end of @namelist will make $namesv undefined and we treat
+ # that the same as having an explicit SPECIAL sv_undef object in @namelist.
+ # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
+ for ($ix = 1; $ix < @valuelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ my $type = T_UNKNOWN;
+ my $flags = 0;
+ my $name = "tmp$ix";
+ my $class = class($namesv);
+ if (!defined($namesv) || $class eq "SPECIAL") {
+ # temporaries have &PL_sv_undef instead of a PVNV for a name
+ $flags = VALID_SV|TEMPORARY|REGISTER;
+ } else {
+ if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
+ $name = $1;
+ if ($2 eq "i") {
+ $type = T_INT;
+ $flags = VALID_SV|VALID_INT;
+ } elsif ($2 eq "d") {
+ $type = T_DOUBLE;
+ $flags = VALID_SV|VALID_DOUBLE;
+ }
+ $flags |= REGISTER if $3;
+ }
+ }
+ $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
+ "i_$name", "d_$name");
+
+ debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
+ }
+}
+
+sub declare_pad {
+ my $ix;
+ for ($ix = 1; $ix <= $#pad; $ix++) {
+ my $type = $pad[$ix]->{type};
+ declare("IV", $type == T_INT ?
+ sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
+ declare("double", $type == T_DOUBLE ?
+ sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
+
+ }
+}
+#
+# Debugging stuff
+#
+sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
+
+#
+# OP stuff
+#
+
+sub label {
+ my $op = shift;
+ # XXX Preserve original label name for "real" labels?
+ return sprintf("lab_%x", $$op);
+}
+
+sub write_label {
+ my $op = shift;
+ push_runtime(sprintf(" %s:", label($op)));
+}
+
+sub loadop {
+ my $op = shift;
+ my $opsym = $op->save;
+ runtime("PL_op = $opsym;") unless $know_op;
+ return $opsym;
+}
+
+sub doop {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ my $sym = loadop($op);
+ runtime("DOOP($ppname);");
+ $know_op = 1;
+ return $sym;
+}
+
+sub gimme {
+ my $op = shift;
+ my $flags = $op->flags;
+ return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
+}
+
+#
+# Code generation for PP code
+#
+
+sub pp_null {
+ my $op = shift;
+ return $op->next;
+}
+
+sub pp_stub {
+ my $op = shift;
+ my $gimme = gimme($op);
+ if ($gimme != G_ARRAY) {
+ my $obj= new B::Stackobj::Const(sv_undef);
+ push(@stack, $obj);
+ # XXX Change to push a constant sv_undef Stackobj onto @stack
+ #write_back_stack();
+ #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
+ }
+ return $op->next;
+}
+
+sub pp_unstack {
+ my $op = shift;
+ @stack = ();
+ runtime("PP_UNSTACK;");
+ return $op->next;
+}
+
+sub pp_and {
+ my $op = shift;
+ my $next = $op->next;
+ reload_lexicals();
+ unshift(@bblock_todo, $next);
+ if (@stack >= 1) {
+ my $bool = pop_bool();
+ write_back_stack();
+ save_or_restore_lexical_state($$next);
+ runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
+ } else {
+ save_or_restore_lexical_state($$next);
+ runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
+ "*sp--;");
+ }
+ return $op->other;
+}
+
+sub pp_or {
+ my $op = shift;
+ my $next = $op->next;
+ reload_lexicals();
+ unshift(@bblock_todo, $next);
+ if (@stack >= 1) {
+ my $bool = pop_bool @stack;
+ write_back_stack();
+ save_or_restore_lexical_state($$next);
+ runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
+ $bool, label($next)));
+ } else {
+ save_or_restore_lexical_state($$next);
+ runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
+ "*sp--;");
+ }
+ return $op->other;
+}
+
+sub pp_cond_expr {
+ my $op = shift;
+ my $false = $op->next;
+ unshift(@bblock_todo, $false);
+ reload_lexicals();
+ my $bool = pop_bool();
+ write_back_stack();
+ save_or_restore_lexical_state($$false);
+ runtime(sprintf("if (!$bool) goto %s;", label($false)));
+ return $op->other;
+}
+
+sub pp_padsv {
+ my $op = shift;
+ my $ix = $op->targ;
+ push(@stack, $pad[$ix]);
+ if ($op->flags & OPf_MOD) {
+ my $private = $op->private;
+ if ($private & OPpLVAL_INTRO) {
+ runtime("SAVECLEARSV(PL_curpad[$ix]);");
+ } elsif ($private & OPpDEREF) {
+ runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
+ $ix, $private & OPpDEREF));
+ $pad[$ix]->invalidate;
+ }
+ }
+ return $op->next;
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ my $obj;
+ # constant could be in the pad (under useithreads)
+ if ($$sv) {
+ $obj = $constobj{$$sv};
+ if (!defined($obj)) {
+ $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+ }
+ }
+ else {
+ $obj = $pad[$op->targ];
+ }
+ push(@stack, $obj);
+ return $op->next;
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $curcop->load($op);
+ @stack = ();
+ debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
+ runtime("TAINT_NOT;") unless $omit_taint;
+ runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
+ if ($freetmps_each_bblock || $freetmps_each_loop) {
+ $need_freetmps = 1;
+ } else {
+ runtime("FREETMPS;");
+ }
+ return $op->next;
+}
+
+sub pp_dbstate {
+ my $op = shift;
+ $curcop->invalidate; # XXX?
+ return default_pp($op);
+}
+
+#default_pp will handle this:
+#sub pp_bless { $curcop->write_back; default_pp(@_) }
+#sub pp_repeat { $curcop->write_back; default_pp(@_) }
+# The following subs need $curcop->write_back if we decide to support arybase:
+# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
+#sub pp_caller { $curcop->write_back; default_pp(@_) }
+#sub pp_reset { $curcop->write_back; default_pp(@_) }
+
+sub pp_rv2gv{
+ my $op =shift;
+ $curcop->write_back;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ my $sym=doop($op);
+ if ($op->private & OPpDEREF) {
+ $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
+ $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
+ $op->first->type));
+ }
+ return $op->next;
+}
+sub pp_sort {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
+ #this indicates the sort BLOCK Array case
+ #ugly surgery required.
+ my $root=$op->first->sibling->first;
+ my $start=$root->first;
+ $op->first->save;
+ $op->first->sibling->save;
+ $root->save;
+ my $sym=$start->save;
+ my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
+ $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
+ }
+ $curcop->write_back;
+ write_back_lexicals();
+ write_back_stack();
+ doop($op);
+ return $op->next;
+}
+
+sub pp_gv {
+ my $op = shift;
+ my $gvsym;
+ if ($Config{useithreads}) {
+ $gvsym = $pad[$op->padix]->as_sv;
+ }
+ else {
+ $gvsym = $op->gv->save;
+ }
+ write_back_stack();
+ runtime("XPUSHs((SV*)$gvsym);");
+ return $op->next;
+}
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gvsym;
+ if ($Config{useithreads}) {
+ $gvsym = $pad[$op->padix]->as_sv;
+ }
+ else {
+ $gvsym = $op->gv->save;
+ }
+ write_back_stack();
+ if ($op->private & OPpLVAL_INTRO) {
+ runtime("XPUSHs(save_scalar($gvsym));");
+ } else {
+ runtime("XPUSHs(GvSV($gvsym));");
+ }
+ return $op->next;
+}
+
+sub pp_aelemfast {
+ my $op = shift;
+ my $gvsym;
+ if ($Config{useithreads}) {
+ $gvsym = $pad[$op->padix]->as_sv;
+ }
+ else {
+ $gvsym = $op->gv->save;
+ }
+ my $ix = $op->private;
+ my $flag = $op->flags & OPf_MOD;
+ write_back_stack();
+ runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
+ "PUSHs(svp ? *svp : &PL_sv_undef);");
+ return $op->next;
+}
+
+sub int_binop {
+ my ($op, $operator) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_int();
+ if (@stack >= 1) {
+ my $left = top_int();
+ $stack[-1]->set_int(&$operator($left, $right));
+ } else {
+ runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
+ $targ->set_int(&$operator($$left, $$right));
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub INTS_CLOSED () { 0x1 }
+sub INT_RESULT () { 0x2 }
+sub NUMERIC_RESULT () { 0x4 }
+
+sub numeric_binop {
+ my ($op, $operator, $flags) = @_;
+ my $force_int = 0;
+ $force_int ||= ($flags & INT_RESULT);
+ $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
+ && valid_int($stack[-2]) && valid_int($stack[-1]));
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_numeric();
+ if (@stack >= 1) {
+ my $left = top_numeric();
+ if ($force_int) {
+ $stack[-1]->set_int(&$operator($left, $right));
+ } else {
+ $stack[-1]->set_numeric(&$operator($left, $right));
+ }
+ } else {
+ if ($force_int) {
+ my $rightruntime = new B::Pseudoreg ("IV", "riv");
+ runtime(sprintf("$$rightruntime = %s;",$right));
+ runtime(sprintf("sv_setiv(TOPs, %s);",
+ &$operator("TOPi", $$rightruntime)));
+ } else {
+ my $rightruntime = new B::Pseudoreg ("double", "rnv");
+ runtime(sprintf("$$rightruntime = %s;",$right));
+ runtime(sprintf("sv_setnv(TOPs, %s);",
+ &$operator("TOPn",$$rightruntime)));
+ }
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ $force_int ||= ($targ->{type} == T_INT);
+ if ($force_int) {
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ $targ->set_int(&$operator($$left, $$right));
+ } else {
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ $targ->set_numeric(&$operator($$left, $$right));
+ }
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub pp_ncmp {
+ my ($op) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_numeric();
+ if (@stack >= 1) {
+ my $left = top_numeric();
+ runtime sprintf("if (%s > %s){",$left,$right);
+ $stack[-1]->set_int(1);
+ $stack[-1]->write_back();
+ runtime sprintf("}else if (%s < %s ) {",$left,$right);
+ $stack[-1]->set_int(-1);
+ $stack[-1]->write_back();
+ runtime sprintf("}else if (%s == %s) {",$left,$right);
+ $stack[-1]->set_int(0);
+ $stack[-1]->write_back();
+ runtime sprintf("}else {");
+ $stack[-1]->set_sv("&PL_sv_undef");
+ runtime "}";
+ } else {
+ my $rightruntime = new B::Pseudoreg ("double", "rnv");
+ runtime(sprintf("$$rightruntime = %s;",$right));
+ runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
+ runtime sprintf("sv_setiv(TOPs,1);");
+ runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
+ runtime sprintf("sv_setiv(TOPs,-1);");
+ runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
+ runtime sprintf("sv_setiv(TOPs,0);");
+ runtime sprintf(qq/}else {/);
+ runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
+ runtime "}";
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ runtime sprintf("if (%s > %s){",$$left,$$right);
+ $targ->set_int(1);
+ $targ->write_back();
+ runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
+ $targ->set_int(-1);
+ $targ->write_back();
+ runtime sprintf("}else if (%s == %s) {",$$left,$$right);
+ $targ->set_int(0);
+ $targ->write_back();
+ runtime sprintf("}else {");
+ $targ->set_sv("&PL_sv_undef");
+ runtime "}";
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub sv_binop {
+ my ($op, $operator, $flags) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_sv();
+ if (@stack >= 1) {
+ my $left = top_sv();
+ if ($flags & INT_RESULT) {
+ $stack[-1]->set_int(&$operator($left, $right));
+ } elsif ($flags & NUMERIC_RESULT) {
+ $stack[-1]->set_numeric(&$operator($left, $right));
+ } else {
+ # XXX Does this work?
+ runtime(sprintf("sv_setsv($left, %s);",
+ &$operator($left, $right)));
+ $stack[-1]->invalidate;
+ }
+ } else {
+ my $f;
+ if ($flags & INT_RESULT) {
+ $f = "sv_setiv";
+ } elsif ($flags & NUMERIC_RESULT) {
+ $f = "sv_setnv";
+ } else {
+ $f = "sv_setsv";
+ }
+ runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
+ if ($flags & INT_RESULT) {
+ $targ->set_int(&$operator("left", "right"));
+ } elsif ($flags & NUMERIC_RESULT) {
+ $targ->set_numeric(&$operator("left", "right"));
+ } else {
+ # XXX Does this work?
+ runtime(sprintf("sv_setsv(%s, %s);",
+ $targ->as_sv, &$operator("left", "right")));
+ $targ->invalidate;
+ }
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub bool_int_binop {
+ my ($op, $operator) = @_;
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_int(&$operator($$left, $$right));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub bool_numeric_binop {
+ my ($op, $operator) = @_;
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_numeric(&$operator($$left, $$right));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub bool_sv_binop {
+ my ($op, $operator) = @_;
+ runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_numeric(&$operator("left", "right"));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub infix_op {
+ my $opname = shift;
+ return sub { "$_[0] $opname $_[1]" }
+}
+
+sub prefix_op {
+ my $opname = shift;
+ return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
+}
+
+BEGIN {
+ my $plus_op = infix_op("+");
+ my $minus_op = infix_op("-");
+ my $multiply_op = infix_op("*");
+ my $divide_op = infix_op("/");
+ my $modulo_op = infix_op("%");
+ my $lshift_op = infix_op("<<");
+ my $rshift_op = infix_op(">>");
+ my $scmp_op = prefix_op("sv_cmp");
+ my $seq_op = prefix_op("sv_eq");
+ my $sne_op = prefix_op("!sv_eq");
+ my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
+ my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
+ my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
+ my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
+ my $eq_op = infix_op("==");
+ my $ne_op = infix_op("!=");
+ my $lt_op = infix_op("<");
+ my $gt_op = infix_op(">");
+ my $le_op = infix_op("<=");
+ my $ge_op = infix_op(">=");
+
+ #
+ # XXX The standard perl PP code has extra handling for
+ # some special case arguments of these operators.
+ #
+ sub pp_add { numeric_binop($_[0], $plus_op) }
+ sub pp_subtract { numeric_binop($_[0], $minus_op) }
+ sub pp_multiply { numeric_binop($_[0], $multiply_op) }
+ sub pp_divide { numeric_binop($_[0], $divide_op) }
+ sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
+
+ sub pp_left_shift { int_binop($_[0], $lshift_op) }
+ sub pp_right_shift { int_binop($_[0], $rshift_op) }
+ sub pp_i_add { int_binop($_[0], $plus_op) }
+ sub pp_i_subtract { int_binop($_[0], $minus_op) }
+ sub pp_i_multiply { int_binop($_[0], $multiply_op) }
+ sub pp_i_divide { int_binop($_[0], $divide_op) }
+ sub pp_i_modulo { int_binop($_[0], $modulo_op) }
+
+ sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
+ sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
+ sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
+ sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
+ sub pp_le { bool_numeric_binop($_[0], $le_op) }
+ sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
+
+ sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
+ sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
+ sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
+ sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
+ sub pp_i_le { bool_int_binop($_[0], $le_op) }
+ sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
+
+ sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
+ sub pp_slt { bool_sv_binop($_[0], $slt_op) }
+ sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
+ sub pp_sle { bool_sv_binop($_[0], $sle_op) }
+ sub pp_sge { bool_sv_binop($_[0], $sge_op) }
+ sub pp_seq { bool_sv_binop($_[0], $seq_op) }
+ sub pp_sne { bool_sv_binop($_[0], $sne_op) }
+}
+
+
+sub pp_sassign {
+ my $op = shift;
+ my $backwards = $op->private & OPpASSIGN_BACKWARDS;
+ my ($dst, $src);
+ if (@stack >= 2) {
+ $dst = pop @stack;
+ $src = pop @stack;
+ ($src, $dst) = ($dst, $src) if $backwards;
+ my $type = $src->{type};
+ if ($type == T_INT) {
+ $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
+ } elsif ($type == T_DOUBLE) {
+ $dst->set_numeric($src->as_numeric);
+ } else {
+ $dst->set_sv($src->as_sv);
+ }
+ push(@stack, $dst);
+ } elsif (@stack == 1) {
+ if ($backwards) {
+ my $src = pop @stack;
+ my $type = $src->{type};
+ runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
+ if ($type == T_INT) {
+ if ($src->{flags} & VALID_UNSIGNED){
+ runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
+ }else{
+ runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+ }
+ } elsif ($type == T_DOUBLE) {
+ runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
+ } else {
+ runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
+ }
+ runtime("SvSETMAGIC(TOPs);");
+ } else {
+ my $dst = $stack[-1];
+ my $type = $dst->{type};
+ runtime("sv = POPs;");
+ runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
+ if ($type == T_INT) {
+ $dst->set_int("SvIV(sv)");
+ } elsif ($type == T_DOUBLE) {
+ $dst->set_double("SvNV(sv)");
+ } else {
+ runtime("SvSetMagicSV($dst->{sv}, sv);");
+ $dst->invalidate;
+ }
+ }
+ } else {
+ if ($backwards) {
+ runtime("src = POPs; dst = TOPs;");
+ } else {
+ runtime("dst = POPs; src = TOPs;");
+ }
+ runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
+ "SvSetSV(dst, src);",
+ "SvSETMAGIC(dst);",
+ "SETs(dst);");
+ }
+ return $op->next;
+}
+
+sub pp_preinc {
+ my $op = shift;
+ if (@stack >= 1) {
+ my $obj = $stack[-1];
+ my $type = $obj->{type};
+ if ($type == T_INT || $type == T_DOUBLE) {
+ $obj->set_int($obj->as_int . " + 1");
+ } else {
+ runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
+ $obj->invalidate();
+ }
+ } else {
+ runtime sprintf("PP_PREINC(TOPs);");
+ }
+ return $op->next;
+}
+
+
+sub pp_pushmark {
+ my $op = shift;
+ write_back_stack();
+ runtime("PUSHMARK(sp);");
+ return $op->next;
+}
+
+sub pp_list {
+ my $op = shift;
+ write_back_stack();
+ my $gimme = gimme($op);
+ if ($gimme == G_ARRAY) { # sic
+ runtime("POPMARK;"); # need this even though not a "full" pp_list
+ } else {
+ runtime("PP_LIST($gimme);");
+ }
+ return $op->next;
+}
+
+sub pp_entersub {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+ runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
+ runtime("SPAGAIN;}");
+ $know_op = 0;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+sub pp_formline {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ my $sym=doop($op);
+ # See comment in pp_grepwhile to see why!
+ $init->add("((LISTOP*)$sym)->op_first = $sym;");
+ runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
+ save_or_restore_lexical_state(${$op->first});
+ runtime( sprintf("goto %s;",label($op->first)));
+ runtime("}");
+ return $op->next;
+}
+
+sub pp_goto{
+
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ my $sym=doop($op);
+ runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
+ invalidate_lexicals() unless $skip_invalidate{$ppname};
+ return $op->next;
+}
+sub pp_enterwrite {
+ my $op = shift;
+ pp_entersub($op);
+}
+sub pp_leavesub{
+ my $op = shift;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
+ runtime("\tPUTBACK;return 0;");
+ runtime("}");
+ doop($op);
+ return $op->next;
+}
+sub pp_leavewrite {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ # XXX Is this the right way to distinguish between it returning
+ # CvSTART(cv) (via doform) and pop_return()?
+ #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
+ runtime("SPAGAIN;");
+ $know_op = 0;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub doeval {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = loadop($op);
+ my $ppaddr = $op->ppaddr;
+ #runtime(qq/printf("$ppaddr type eval\n");/);
+ runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
+ $know_op = 1;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_entereval { doeval(@_) }
+sub pp_dofile { doeval(@_) }
+
+#pp_require is protected by pp_entertry, so no protection for it.
+sub pp_require {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+ runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
+ runtime("SPAGAIN;}");
+ $know_op = 1;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+
+sub pp_entertry {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
+ declare("JMPENV", $jmpbuf);
+ runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_leavetry{
+ my $op=shift;
+ default_pp($op);
+ runtime("PP_LEAVETRY;");
+ return $op->next;
+}
+
+sub pp_grepstart {
+ my $op = shift;
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
+ $need_freetmps = 0;
+ }
+ write_back_stack();
+ my $sym= doop($op);
+ my $next=$op->next;
+ $next->save;
+ my $nexttonext=$next->next;
+ $nexttonext->save;
+ save_or_restore_lexical_state($$nexttonext);
+ runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
+ label($nexttonext)));
+ return $op->next->other;
+}
+
+sub pp_mapstart {
+ my $op = shift;
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
+ $need_freetmps = 0;
+ }
+ write_back_stack();
+ # pp_mapstart can return either op_next->op_next or op_next->op_other and
+ # we need to be able to distinguish the two at runtime.
+ my $sym= doop($op);
+ my $next=$op->next;
+ $next->save;
+ my $nexttonext=$next->next;
+ $nexttonext->save;
+ save_or_restore_lexical_state($$nexttonext);
+ runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
+ label($nexttonext)));
+ return $op->next->other;
+}
+
+sub pp_grepwhile {
+ my $op = shift;
+ my $next = $op->next;
+ unshift(@bblock_todo, $next);
+ write_back_lexicals();
+ write_back_stack();
+ my $sym = doop($op);
+ # pp_grepwhile can return either op_next or op_other and we need to
+ # be able to distinguish the two at runtime. Since it's possible for
+ # both ops to be "inlined", the fields could both be zero. To get
+ # around that, we hack op_next to be our own op (purely because we
+ # know it's a non-NULL pointer and can't be the same as op_other).
+ $init->add("((LOGOP*)$sym)->op_next = $sym;");
+ save_or_restore_lexical_state($$next);
+ runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
+ $know_op = 0;
+ return $op->other;
+}
+
+sub pp_mapwhile {
+ pp_grepwhile(@_);
+}
+
+sub pp_return {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ doop($op);
+ runtime("PUTBACK;", "return PL_op;");
+ $know_op = 0;
+ return $op->next;
+}
+
+sub nyi {
+ my $op = shift;
+ warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
+ return default_pp($op);
+}
+
+sub pp_range {
+ my $op = shift;
+ my $flags = $op->flags;
+ if (!($flags & OPf_WANT)) {
+ error("context of range unknown at compile-time");
+ }
+ write_back_lexicals();
+ write_back_stack();
+ unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
+ # We need to save our UNOP structure since pp_flop uses
+ # it to find and adjust out targ. We don't need it ourselves.
+ $op->save;
+ save_or_restore_lexical_state(${$op->other});
+ runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
+ $op->targ, label($op->other));
+ unshift(@bblock_todo, $op->other);
+ }
+ return $op->next;
+}
+
+sub pp_flip {
+ my $op = shift;
+ my $flags = $op->flags;
+ if (!($flags & OPf_WANT)) {
+ error("context of flip unknown at compile-time");
+ }
+ if (($flags & OPf_WANT)==OPf_WANT_LIST) {
+ return $op->first->other;
+ }
+ write_back_lexicals();
+ write_back_stack();
+ # We need to save our UNOP structure since pp_flop uses
+ # it to find and adjust out targ. We don't need it ourselves.
+ $op->save;
+ my $ix = $op->targ;
+ my $rangeix = $op->first->targ;
+ runtime(($op->private & OPpFLIP_LINENUM) ?
+ "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
+ : "if (SvTRUE(TOPs)) {");
+ runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
+ if ($op->flags & OPf_SPECIAL) {
+ runtime("sv_setiv(PL_curpad[$ix], 1);");
+ } else {
+ save_or_restore_lexical_state(${$op->first->other});
+ runtime("\tsv_setiv(PL_curpad[$ix], 0);",
+ "\tsp--;",
+ sprintf("\tgoto %s;", label($op->first->other)));
+ }
+ runtime("}",
+ qq{sv_setpv(PL_curpad[$ix], "");},
+ "SETs(PL_curpad[$ix]);");
+ $know_op = 0;
+ return $op->next;
+}
+
+sub pp_flop {
+ my $op = shift;
+ default_pp($op);
+ $know_op = 0;
+ return $op->next;
+}
+
+sub enterloop {
+ my $op = shift;
+ my $nextop = $op->nextop;
+ my $lastop = $op->lastop;
+ my $redoop = $op->redoop;
+ $curcop->write_back;
+ debug "enterloop: pushing on cxstack" if $debug_cxstack;
+ push(@cxstack, {
+ type => CXt_LOOP,
+ op => $op,
+ "label" => $curcop->[0]->label,
+ nextop => $nextop,
+ lastop => $lastop,
+ redoop => $redoop
+ });
+ $nextop->save;
+ $lastop->save;
+ $redoop->save;
+ return default_pp($op);
+}
+
+sub pp_enterloop { enterloop(@_) }
+sub pp_enteriter { enterloop(@_) }
+
+sub pp_leaveloop {
+ my $op = shift;
+ if (!@cxstack) {
+ die "panic: leaveloop";
+ }
+ debug "leaveloop: popping from cxstack" if $debug_cxstack;
+ pop(@cxstack);
+ return default_pp($op);
+}
+
+sub pp_next {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"next" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "next %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $nextop = $cxstack[$cxix]->{nextop};
+ push(@bblock_todo, $nextop);
+ save_or_restore_lexical_state($$nextop);
+ runtime(sprintf("goto %s;", label($nextop)));
+ return $op->next;
+}
+
+sub pp_redo {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"redo" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "redo %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $redoop = $cxstack[$cxix]->{redoop};
+ push(@bblock_todo, $redoop);
+ save_or_restore_lexical_state($$redoop);
+ runtime(sprintf("goto %s;", label($redoop)));
+ return $op->next;
+}
+
+sub pp_last {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"last" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "last %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ # XXX Add support for "last" to leave non-loop blocks
+ if ($cxstack[$cxix]->{type} != CXt_LOOP) {
+ error('Use of "last" for non-loop blocks is not yet implemented');
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $lastop = $cxstack[$cxix]->{lastop}->next;
+ push(@bblock_todo, $lastop);
+ save_or_restore_lexical_state($$lastop);
+ runtime(sprintf("goto %s;", label($lastop)));
+ return $op->next;
+}
+
+sub pp_subst {
+ my $op = shift;
+ write_back_lexicals();
+ write_back_stack();
+ my $sym = doop($op);
+ my $replroot = $op->pmreplroot;
+ if ($$replroot) {
+ save_or_restore_lexical_state($$replroot);
+ runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
+ $sym, label($replroot));
+ $op->pmreplstart->save;
+ push(@bblock_todo, $replroot);
+ }
+ invalidate_lexicals();
+ return $op->next;
+}
+
+sub pp_substcont {
+ my $op = shift;
+ write_back_lexicals();
+ write_back_stack();
+ doop($op);
+ my $pmop = $op->other;
+ # warn sprintf("substcont: op = %s, pmop = %s\n",
+ # peekop($op), peekop($pmop));#debug
+# my $pmopsym = objsym($pmop);
+ my $pmopsym = $pmop->save; # XXX can this recurse?
+# warn "pmopsym = $pmopsym\n";#debug
+ save_or_restore_lexical_state(${$pmop->pmreplstart});
+ runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
+ $pmopsym, label($pmop->pmreplstart));
+ invalidate_lexicals();
+ return $pmop->next;
+}
+
+sub default_pp {
+ my $op = shift;
+ my $ppname = "pp_" . $op->name;
+ if ($curcop and $need_curcop{$ppname}){
+ $curcop->write_back;
+ }
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ doop($op);
+ # XXX If the only way that ops can write to a TEMPORARY lexical is
+ # when it's named in $op->targ then we could call
+ # invalidate_lexicals(TEMPORARY) and avoid having to write back all
+ # the temporaries. For now, we'll play it safe and write back the lot.
+ invalidate_lexicals() unless $skip_invalidate{$ppname};
+ return $op->next;
+}
+
+sub compile_op {
+ my $op = shift;
+ my $ppname = "pp_" . $op->name;
+ if (exists $ignore_op{$ppname}) {
+ return $op->next;
+ }
+ debug peek_stack() if $debug_stack;
+ if ($debug_op) {
+ debug sprintf("%s [%s]\n",
+ peekop($op),
+ $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
+ }
+ no strict 'refs';
+ if (defined(&$ppname)) {
+ $know_op = 0;
+ return &$ppname($op);
+ } else {
+ return default_pp($op);
+ }
+}
+
+sub compile_bblock {
+ my $op = shift;
+ #warn "compile_bblock: ", peekop($op), "\n"; # debug
+ save_or_restore_lexical_state($$op);
+ write_label($op);
+ $know_op = 0;
+ do {
+ $op = compile_op($op);
+ } while (defined($op) && $$op && !exists($leaders->{$$op}));
+ write_back_stack(); # boo hoo: big loss
+ reload_lexicals();
+ return $op;
+}
+
+sub cc {
+ my ($name, $root, $start, @padlist) = @_;
+ my $op;
+ if($done{$$start}){
+ #warn "repeat=>".ref($start)."$name,\n";#debug
+ $decl->add(sprintf("#define $name %s",$done{$$start}));
+ return;
+ }
+ init_pp($name);
+ load_pad(@padlist);
+ %lexstate=();
+ B::Pseudoreg->new_scope;
+ @cxstack = ();
+ if ($debug_timings) {
+ warn sprintf("Basic block analysis at %s\n", timing_info);
+ }
+ $leaders = find_leaders($root, $start);
+ my @leaders= keys %$leaders;
+ if ($#leaders > -1) {
+ @bblock_todo = ($start, values %$leaders) ;
+ } else{
+ runtime("return PL_op?PL_op->op_next:0;");
+ }
+ if ($debug_timings) {
+ warn sprintf("Compilation at %s\n", timing_info);
+ }
+ while (@bblock_todo) {
+ $op = shift @bblock_todo;
+ #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
+ next if !defined($op) || !$$op || $done{$$op};
+ #warn "...compiling it\n"; # debug
+ do {
+ $done{$$op} = $name;
+ $op = compile_bblock($op);
+ if ($need_freetmps && $freetmps_each_bblock) {
+ runtime("FREETMPS;");
+ $need_freetmps = 0;
+ }
+ } while defined($op) && $$op && !$done{$$op};
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;");
+ $need_freetmps = 0;
+ }
+ if (!$$op) {
+ runtime("PUTBACK;","return PL_op;");
+ } elsif ($done{$$op}) {
+ save_or_restore_lexical_state($$op);
+ runtime(sprintf("goto %s;", label($op)));
+ }
+ }
+ if ($debug_timings) {
+ warn sprintf("Saving runtime at %s\n", timing_info);
+ }
+ declare_pad(@padlist) ;
+ save_runtime();
+}
+
+sub cc_recurse {
+ my $ccinfo;
+ my $start;
+ $start = cc_queue(@_) if @_;
+ while ($ccinfo = shift @cc_todo) {
+ cc(@$ccinfo);
+ }
+ return $start;
+}
+
+sub cc_obj {
+ my ($name, $cvref) = @_;
+ my $cv = svref_2object($cvref);
+ my @padlist = $cv->PADLIST->ARRAY;
+ my $curpad_sym = $padlist[1]->save;
+ cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
+}
+
+sub cc_main {
+ my @comppadlist = comppadlist->ARRAY;
+ my $curpad_nam = $comppadlist[0]->save;
+ my $curpad_sym = $comppadlist[1]->save;
+ my $init_av = init_av->save;
+ my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
+ # Do save_unused_subs before saving inc_hv
+ save_unused_subs();
+ cc_recurse();
+
+ my $inc_hv = svref_2object(\%INC)->save;
+ my $inc_av = svref_2object(\@INC)->save;
+ my $amagic_generate= amagic_generation;
+ return if $errors;
+ if (!defined($module)) {
+ $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
+ "PL_main_start = $start;",
+ "PL_curpad = AvARRAY($curpad_sym);",
+ "PL_initav = (AV *) $init_av;",
+ "GvHV(PL_incgv) = $inc_hv;",
+ "GvAV(PL_incgv) = $inc_av;",
+ "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
+ "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+ "PL_amagic_generation= $amagic_generate;",
+ );
+
+ }
+ seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
+ output_boilerplate();
+ print "\n";
+ output_all("perl_init");
+ output_runtime();
+ print "\n";
+ output_main();
+ if (defined($module)) {
+ my $cmodule = $module;
+ $cmodule =~ s/::/__/g;
+ print <<"EOT";
+
+#include "XSUB.h"
+XS(boot_$cmodule)
+{
+ dXSARGS;
+ perl_init();
+ ENTER;
+ SAVETMPS;
+ SAVEVPTR(PL_curpad);
+ SAVEVPTR(PL_op);
+ PL_curpad = AvARRAY($curpad_sym);
+ PL_op = $start;
+ pp_main(aTHX);
+ FREETMPS;
+ LEAVE;
+ ST(0) = &PL_sv_yes;
+ XSRETURN(1);
+}
+EOT
+ }
+ if ($debug_timings) {
+ warn sprintf("Done at %s\n", timing_info);
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
+ } elsif ($opt eq "n") {
+ $arg ||= shift @options;
+ $module_name = $arg;
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ mark_unused($arg,undef);
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ my $value = $arg !~ s/^no-//;
+ $arg =~ s/-/_/g;
+ my $ref = $optimise{$arg};
+ if (defined($ref)) {
+ $$ref = $value;
+ } else {
+ warn qq(ignoring unknown optimisation option "$arg"\n);
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ my $ref;
+ foreach $ref (values %optimise) {
+ $$ref = 0;
+ }
+ if ($arg >= 2) {
+ $freetmps_each_loop = 1;
+ }
+ if ($arg >= 1) {
+ $freetmps_each_bblock = 1 unless $freetmps_each_loop;
+ }
+ } elsif ($opt eq "m") {
+ $arg ||= shift @options;
+ $module = $arg;
+ mark_unused($arg,undef);
+ } elsif ($opt eq "p") {
+ $arg ||= shift @options;
+ $patchlevel = $arg;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "s") {
+ $debug_stack = 1;
+ } elsif ($arg eq "c") {
+ $debug_cxstack = 1;
+ } elsif ($arg eq "p") {
+ $debug_pad = 1;
+ } elsif ($arg eq "r") {
+ $debug_runtime = 1;
+ } elsif ($arg eq "S") {
+ $debug_shadow = 1;
+ } elsif ($arg eq "q") {
+ $debug_queue = 1;
+ } elsif ($arg eq "l") {
+ $debug_lineno = 1;
+ } elsif ($arg eq "t") {
+ $debug_timings = 1;
+ }
+ }
+ }
+ }
+ init_sections();
+ $init = B::Section->get("init");
+ $decl = B::Section->get("decl");
+
+ if (@options) {
+ return sub {
+ my ($objname, $ppname);
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ ($ppname = $objname) =~ s/^.*?:://;
+ eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
+ die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
+ return if $errors;
+ }
+ output_boilerplate();
+ print "\n";
+ output_all($module_name || "init_module");
+ output_runtime();
+ }
+ } else {
+ return sub { cc_main() };
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::CC - Perl compiler's optimized C translation backend
+
+=head1 SYNOPSIS
+
+ perl -MO=CC[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend takes Perl source and generates C source code
+corresponding to the flow of your program. In other words, this
+backend is somewhat a "real" compiler in the sense that many people
+think about compilers. Note however that, currently, it is a very
+poor compiler in that although it generates (mostly, or at least
+sometimes) correct code, it performs relatively few optimisations.
+This will change as the compiler develops. The result is that
+running an executable compiled with this backend may start up more
+quickly than running the original Perl program (a feature shared
+by the B<C> compiler backend--see F<B::C>) and may also execute
+slightly faster. This is by no means a good optimising compiler--yet.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be
+names of objects to be saved (probably doesn't work properly yet).
+Without extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT
+
+=item B<-v>
+
+Verbose compilation (currently gives a few compilation statistics).
+
+=item B<-->
+
+Force end of options
+
+=item B<-uPackname>
+
+Force apparently unused subs from package Packname to be compiled.
+This allows programs to use eval "foo()" even when sub foo is never
+seen to be used at compile time. The down side is that any subs which
+really are never used also have code generated. This option is
+necessary, for example, if you have a signal handler foo which you
+initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
+to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
+options. The compiler tries to figure out which packages may possibly
+have subs in which need compiling but the current version doesn't do
+it very well. In particular, it is confused by nested packages (i.e.
+of the form C<A::B>) where package C<A> does not contain any subs.
+
+=item B<-mModulename>
+
+Instead of generating source for a runnable executable, generate
+source for an XSUB module. The boot_Modulename function (which
+DynaLoader can look for) does the appropriate initialisation and runs
+the main part of the Perl source that is being compiled.
+
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Dr>
+
+Writes debugging output to STDERR just as it's about to write to the
+program's runtime (otherwise writes debugging info as comments in
+its C output).
+
+=item B<-DO>
+
+Outputs each OP as it's compiled
+
+=item B<-Ds>
+
+Outputs the contents of the shadow stack at each OP
+
+=item B<-Dp>
+
+Outputs the contents of the shadow pad of lexicals as it's loaded for
+each sub or the main program.
+
+=item B<-Dq>
+
+Outputs the name of each fake PP function in the queue as it's about
+to process it.
+
+=item B<-Dl>
+
+Output the filename and line number of each original line of Perl
+code as it's processed (C<pp_nextstate>).
+
+=item B<-Dt>
+
+Outputs timing information of compilation stages.
+
+=item B<-f>
+
+Force optimisations on or off one at a time.
+
+=item B<-ffreetmps-each-bblock>
+
+Delays FREETMPS from the end of each statement to the end of the each
+basic block.
+
+=item B<-ffreetmps-each-loop>
+
+Delays FREETMPS from the end of each statement to the end of the group
+of basic blocks forming a loop. At most one of the freetmps-each-*
+options can be used.
+
+=item B<-fomit-taint>
+
+Omits generating code for handling perl's tainting mechanism.
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
+Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
+sets B<-ffreetmps-each-loop>.
+
+=back
+
+=head1 EXAMPLES
+
+ perl -MO=CC,-O2,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+Note that C<cc_harness> lives in the C<B> subdirectory of your perl
+library directory. The utility called C<perlcc> may also be used to
+help make use of this compiler.
+
+ perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+ perl cc_harness -shared -c -o Foo.so Foo.c
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
+
+=head1 DIFFERENCES
+
+These aren't really bugs but they are constructs which are heavily
+tied to perl's compile-and-go implementation and with which this
+compiler backend cannot cope.
+
+=head2 Loops
+
+Standard perl calculates the target of "next", "last", and "redo"
+at run-time. The compiler calculates the targets at compile-time.
+For example, the program
+
+ sub skip_on_odd { next NUMBER if $_[0] % 2 }
+ NUMBER: for ($i = 0; $i < 5; $i++) {
+ skip_on_odd($i);
+ print $i;
+ }
+
+produces the output
+
+ 024
+
+with standard perl but gives a compile-time error with the compiler.
+
+=head2 Context of ".."
+
+The context (scalar or array) of the ".." operator determines whether
+it behaves as a range or a flip/flop. Standard perl delays until
+runtime the decision of which context it is in but the compiler needs
+to know the context at compile-time. For example,
+
+ @a = (4,6,1,0,0,1);
+ sub range { (shift @a)..(shift @a) }
+ print range();
+ while (@a) { print scalar(range()) }
+
+generates the output
+
+ 456123E0
+
+with standard Perl but gives a compile-time error with compiled Perl.
+
+=head2 Arithmetic
+
+Compiled Perl programs use native C arithmetic much more frequently
+than standard perl. Operations on large numbers or on boundary
+cases may produce different behaviour.
+
+=head2 Deprecated features
+
+Features of standard perl such as C<$[> which have been deprecated
+in standard perl since Perl5 was released have not been implemented
+in the compiler.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/Concise.pm
==============================================================================
--- (empty file)
+++ B/B/Concise.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,1628 @@
+package B::Concise;
+# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
+# This program is free software; you can redistribute and/or modify it
+# under the same terms as Perl itself.
+
+# Note: we need to keep track of how many use declarations/BEGIN
+# blocks this module uses, so we can avoid printing them when user
+# asks for the BEGIN blocks in her program. Update the comments and
+# the count in concise_specials if you add or delete one. The
+# -MO=Concise counts as use #1.
+
+use strict; # use #2
+use warnings; # uses #3 and #4, since warnings uses Carp
+
+use Exporter (); # use #5
+
+our $VERSION = "0.66";
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw( set_style set_style_standard add_callback
+ concise_subref concise_cv concise_main
+ add_style walk_output compile reset_sequence );
+our %EXPORT_TAGS =
+ ( io => [qw( walk_output compile reset_sequence )],
+ style => [qw( add_style set_style_standard )],
+ cb => [qw( add_callback )],
+ mech => [qw( concise_subref concise_cv concise_main )], );
+
+# use #6
+use B qw(class ppname main_start main_root main_cv cstring svref_2object
+ SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
+ CVf_ANON);
+
+my %style =
+ ("terse" =>
+ ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
+ . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
+ "(*( )*)goto #class (#addr)\n",
+ "#class pp_#name"],
+ "concise" =>
+ ["#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n"
+ , " (*( )*) goto #seq\n",
+ "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
+ "linenoise" =>
+ ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
+ "gt_#seq ",
+ "(?(#seq)?)#noise#arg(?([#targarg])?)"],
+ "debug" =>
+ ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
+ . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
+ ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
+ . "\top_flags\t#flagval\n\top_private\t#privval\n"
+ . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
+ . "(?(\top_sv\t\t#svaddr\n)?)",
+ " GOTO #addr\n",
+ "#addr"],
+ "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
+ $ENV{B_CONCISE_TREE_FORMAT}],
+ );
+
+# Renderings, ie how Concise prints, is controlled by these vars
+# primary:
+our $stylename; # selects current style from %style
+my $order = "basic"; # how optree is walked & printed: basic, exec, tree
+
+# rendering mechanics:
+# these 'formats' are the line-rendering templates
+# they're updated from %style when $stylename changes
+my ($format, $gotofmt, $treefmt);
+
+# lesser players:
+my $base = 36; # how <sequence#> is displayed
+my $big_endian = 1; # more <sequence#> display
+my $tree_style = 0; # tree-order details
+my $banner = 1; # print banner before optree is traversed
+my $do_main = 0; # force printing of main routine
+
+# another factor: can affect all styles!
+our @callbacks; # allow external management
+
+set_style_standard("concise");
+
+my $curcv;
+my $cop_seq_base;
+
+sub set_style {
+ ($format, $gotofmt, $treefmt) = @_;
+ #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle, at args) = @_;
+ die "style '$newstyle' already exists, choose a new name\n"
+ if exists $style{$newstyle};
+ die "expecting 3 style-format args\n" unless @args == 3;
+ $style{$newstyle} = [@args];
+ $stylename = $newstyle; # update rendering state
+}
+
+sub set_style_standard {
+ ($stylename) = @_; # update rendering state
+ die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
+ set_style(@{$style{$stylename}});
+}
+
+sub add_callback {
+ push @callbacks, @_;
+}
+
+# output handle, used with all Concise-output printing
+our $walkHandle; # public for your convenience
+BEGIN { $walkHandle = \*STDOUT }
+
+sub walk_output { # updates $walkHandle
+ my $handle = shift;
+ return $walkHandle unless $handle; # allow use as accessor
+
+ if (ref $handle eq 'SCALAR') {
+ require Config;
+ die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
+ unless $Config::Config{useperlio};
+ # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
+ open my $tmp, '>', $handle; # but cant re-set existing STDOUT
+ $walkHandle = $tmp; # so use my $tmp as intermediate var
+ return $walkHandle;
+ }
+ my $iotype = ref $handle;
+ die "expecting argument/object that can print\n"
+ unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
+ $walkHandle = $handle;
+}
+
+sub concise_subref {
+ my($order, $coderef, $name) = @_;
+ my $codeobj = svref_2object($coderef);
+
+ return concise_stashref(@_)
+ unless ref $codeobj eq 'B::CV';
+ concise_cv_obj($order, $codeobj, $name);
+}
+
+sub concise_stashref {
+ my($order, $h) = @_;
+ foreach my $k (sort keys %$h) {
+ local *s = $h->{$k};
+ my $coderef = *s{CODE} or next;
+ reset_sequence();
+ print "FUNC: ", *s, "\n";
+ my $codeobj = svref_2object($coderef);
+ next unless ref $codeobj eq 'B::CV';
+ eval { concise_cv_obj($order, $codeobj) }
+ or warn "err $@ on $codeobj";
+ }
+}
+
+# This should have been called concise_subref, but it was exported
+# under this name in versions before 0.56
+*concise_cv = \&concise_subref;
+
+sub concise_cv_obj {
+ my ($order, $cv, $name) = @_;
+ # name is either a string, or a CODE ref (copy of $cv arg??)
+
+ $curcv = $cv;
+ if ($cv->XSUB) {
+ print $walkHandle "$name is XS code\n";
+ return;
+ }
+ if (class($cv->START) eq "NULL") {
+ no strict 'refs';
+ if (ref $name eq 'CODE') {
+ print $walkHandle "coderef $name has no START\n";
+ }
+ elsif (exists &$name) {
+ print $walkHandle "$name exists in stash, but has no START\n";
+ }
+ else {
+ print $walkHandle "$name not in symbol table\n";
+ }
+ return;
+ }
+ sequence($cv->START);
+ if ($order eq "exec") {
+ walk_exec($cv->START);
+ }
+ elsif ($order eq "basic") {
+ # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
+ my $root = $cv->ROOT;
+ unless (ref $root eq 'B::NULL') {
+ walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
+ } else {
+ print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
+ }
+ } else {
+ print $walkHandle tree($cv->ROOT, 0);
+ }
+}
+
+sub concise_main {
+ my($order) = @_;
+ sequence(main_start);
+ $curcv = main_cv;
+ if ($order eq "exec") {
+ return if class(main_start) eq "NULL";
+ walk_exec(main_start);
+ } elsif ($order eq "tree") {
+ return if class(main_root) eq "NULL";
+ print $walkHandle tree(main_root, 0);
+ } elsif ($order eq "basic") {
+ return if class(main_root) eq "NULL";
+ walk_topdown(main_root,
+ sub { $_[0]->concise($_[1]) }, 0);
+ }
+}
+
+sub concise_specials {
+ my($name, $order, @cv_s) = @_;
+ my $i = 1;
+ if ($name eq "BEGIN") {
+ splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
+ } elsif ($name eq "CHECK") {
+ pop @cv_s; # skip the CHECK block that calls us
+ }
+ for my $cv (@cv_s) {
+ print $walkHandle "$name $i:\n";
+ $i++;
+ concise_cv_obj($order, $cv, $name);
+ }
+}
+
+my $start_sym = "\e(0"; # "\cN" sometimes also works
+my $end_sym = "\e(B"; # "\cO" respectively
+
+my @tree_decorations =
+ ([" ", "--", "+-", "|-", "| ", "`-", "-", 1],
+ [" ", "-", "+", "+", "|", "`", "", 0],
+ [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
+ [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
+ );
+
+
+sub compileOpts {
+ # set rendering state from options and args
+ my (@options, at args);
+ if (@_) {
+ @options = grep(/^-/, @_);
+ @args = grep(!/^-/, @_);
+ }
+ for my $o (@options) {
+ # mode/order
+ if ($o eq "-basic") {
+ $order = "basic";
+ } elsif ($o eq "-exec") {
+ $order = "exec";
+ } elsif ($o eq "-tree") {
+ $order = "tree";
+ }
+ # tree-specific
+ elsif ($o eq "-compact") {
+ $tree_style |= 1;
+ } elsif ($o eq "-loose") {
+ $tree_style &= ~1;
+ } elsif ($o eq "-vt") {
+ $tree_style |= 2;
+ } elsif ($o eq "-ascii") {
+ $tree_style &= ~2;
+ }
+ # sequence numbering
+ elsif ($o =~ /^-base(\d+)$/) {
+ $base = $1;
+ } elsif ($o eq "-bigendian") {
+ $big_endian = 1;
+ } elsif ($o eq "-littleendian") {
+ $big_endian = 0;
+ }
+ elsif ($o eq "-nobanner") {
+ $banner = 0;
+ } elsif ($o eq "-banner") {
+ $banner = 1;
+ }
+ elsif ($o eq "-main") {
+ $do_main = 1;
+ } elsif ($o eq "-nomain") {
+ $do_main = 0;
+ }
+ # line-style options
+ elsif (exists $style{substr($o, 1)}) {
+ $stylename = substr($o, 1);
+ set_style_standard($stylename);
+ } else {
+ warn "Option $o unrecognized";
+ }
+ }
+ return (@args);
+}
+
+sub compile {
+ my (@args) = compileOpts(@_);
+ return sub {
+ my @newargs = compileOpts(@_); # accept new rendering options
+ warn "disregarding non-options: @newargs\n" if @newargs;
+
+ for my $objname (@args) {
+ next unless $objname; # skip null args to avoid noisy responses
+
+ if ($objname eq "BEGIN") {
+ concise_specials("BEGIN", $order,
+ B::begin_av->isa("B::AV") ?
+ B::begin_av->ARRAY : ());
+ } elsif ($objname eq "INIT") {
+ concise_specials("INIT", $order,
+ B::init_av->isa("B::AV") ?
+ B::init_av->ARRAY : ());
+ } elsif ($objname eq "CHECK") {
+ concise_specials("CHECK", $order,
+ B::check_av->isa("B::AV") ?
+ B::check_av->ARRAY : ());
+ } elsif ($objname eq "END") {
+ concise_specials("END", $order,
+ B::end_av->isa("B::AV") ?
+ B::end_av->ARRAY : ());
+ }
+ else {
+ # convert function names to subrefs
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Concise::compile($objname)\n"
+ if $banner;
+ $objref = $objname;
+ } else {
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ unless (exists &$objname) {
+ print $walkHandle "err: unknown function ($objname)\n";
+ return;
+ }
+ $objref = \&$objname;
+ }
+ concise_subref($order, $objref, $objname);
+ }
+ }
+ if (!@args or $do_main) {
+ print $walkHandle "main program:\n" if $do_main;
+ concise_main($order);
+ }
+ return @args; # something
+ }
+}
+
+my %labels;
+my $lastnext; # remembers op-chain, used to insert gotos
+
+my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
+ 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
+ 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
+
+no warnings 'qw'; # "Possible attempt to put comments..."; use #7
+my @linenoise =
+ qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
+ ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
+ -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i<
+ > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
+ ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
+ uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@
+ a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
+ v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o
+ ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
+ ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
+ -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
+ co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
+ g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
+ e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
+ Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
+
+my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+sub op_flags { # common flags (see BASOP.op_flags in op.h)
+ my($x) = @_;
+ my(@v);
+ push @v, "v" if ($x & 3) == 1;
+ push @v, "s" if ($x & 3) == 2;
+ push @v, "l" if ($x & 3) == 3;
+ push @v, "K" if $x & 4;
+ push @v, "P" if $x & 8;
+ push @v, "R" if $x & 16;
+ push @v, "M" if $x & 32;
+ push @v, "S" if $x & 64;
+ push @v, "*" if $x & 128;
+ return join("", @v);
+}
+
+sub base_n {
+ my $x = shift;
+ return "-" . base_n(-$x) if $x < 0;
+ my $str = "";
+ do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
+ $str = reverse $str if $big_endian;
+ return $str;
+}
+
+my %sequence_num;
+my $seq_max = 1;
+
+sub reset_sequence {
+ # reset the sequence
+ %sequence_num = ();
+ $seq_max = 1;
+ $lastnext = 0;
+}
+
+sub seq {
+ my($op) = @_;
+ return "-" if not exists $sequence_num{$$op};
+ return base_n($sequence_num{$$op});
+}
+
+sub walk_topdown {
+ my($op, $sub, $level) = @_;
+ $sub->($op, $level);
+ if ($op->flags & OPf_KIDS) {
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walk_topdown($kid, $sub, $level + 1);
+ }
+ }
+ elsif (class($op) eq "PMOP") {
+ my $maybe_root = $op->pmreplroot;
+ if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
+ # It really is the root of the replacement, not something
+ # else stored here for lack of space elsewhere
+ walk_topdown($maybe_root, $sub, $level + 1);
+ }
+ }
+}
+
+sub walklines {
+ my($ar, $level) = @_;
+ for my $l (@$ar) {
+ if (ref($l) eq "ARRAY") {
+ walklines($l, $level + 1);
+ } else {
+ $l->concise($level);
+ }
+ }
+}
+
+sub walk_exec {
+ my($top, $level) = @_;
+ my %opsseen;
+ my @lines;
+ my @todo = ([$top, \@lines]);
+ while (@todo and my($op, $targ) = @{shift @todo}) {
+ for (; $$op; $op = $op->next) {
+ last if $opsseen{$$op}++;
+ push @$targ, $op;
+ my $name = $op->name;
+ if (class($op) eq "LOGOP") {
+ my $ar = [];
+ push @$targ, $ar;
+ push @todo, [$op->other, $ar];
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ my $ar = [];
+ push @$targ, $ar;
+ push @todo, [$op->pmreplstart, $ar];
+ } elsif ($name =~ /^enter(loop|iter)$/) {
+ if ($] > 5.009) {
+ $labels{${$op->nextop}} = "NEXT";
+ $labels{${$op->lastop}} = "LAST";
+ $labels{${$op->redoop}} = "REDO";
+ } else {
+ $labels{$op->nextop->seq} = "NEXT";
+ $labels{$op->lastop->seq} = "LAST";
+ $labels{$op->redoop->seq} = "REDO";
+ }
+ }
+ }
+ }
+ walklines(\@lines, 0);
+}
+
+# The structure of this routine is purposely modeled after op.c's peep()
+sub sequence {
+ my($op) = @_;
+ my $oldop = 0;
+ return if class($op) eq "NULL" or exists $sequence_num{$$op};
+ for (; $$op; $op = $op->next) {
+ last if exists $sequence_num{$$op};
+ my $name = $op->name;
+ if ($name =~ /^(null|scalar|lineseq|scope)$/) {
+ next if $oldop and $ {$op->next};
+ } else {
+ $sequence_num{$$op} = $seq_max++;
+ if (class($op) eq "LOGOP") {
+ my $other = $op->other;
+ $other = $other->next while $other->name eq "null";
+ sequence($other);
+ } elsif (class($op) eq "LOOP") {
+ my $redoop = $op->redoop;
+ $redoop = $redoop->next while $redoop->name eq "null";
+ sequence($redoop);
+ my $nextop = $op->nextop;
+ $nextop = $nextop->next while $nextop->name eq "null";
+ sequence($nextop);
+ my $lastop = $op->lastop;
+ $lastop = $lastop->next while $lastop->name eq "null";
+ sequence($lastop);
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ my $replstart = $op->pmreplstart;
+ $replstart = $replstart->next while $replstart->name eq "null";
+ sequence($replstart);
+ }
+ }
+ $oldop = $op;
+ }
+}
+
+sub fmt_line { # generate text-line for op.
+ my($hr, $op, $text, $level) = @_;
+
+ $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
+
+ return '' if $hr->{SKIP}; # suppress line if a callback said so
+ return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
+
+ # spec: (?(text1#varText2)?)
+ $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
+ $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+
+ # spec: (x(exec_text;basic_text)x)
+ $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
+
+ # spec: (*(text)*)
+ $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
+
+ # spec: (*(text1;text2)*)
+ $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
+
+ # convert #Var to tag=>val form: Var\t#var
+ $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
+
+ # spec: #varN
+ $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
+
+ $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's
+ $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes
+ chomp $text;
+ return "$text\n" if $text ne "";
+ return $text; # suppress empty lines
+}
+
+our %priv; # used to display each opcode's BASEOP.op_private values
+
+$priv{$_}{128} = "LVINTRO"
+ for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
+ "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
+ "padav", "padhv", "enteriter");
+$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
+$priv{"aassign"}{64} = "COMMON";
+$priv{"aassign"}{32} = "PHASH" if $] < 5.009;
+$priv{"sassign"}{64} = "BKWARD";
+$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
+@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
+ "COMPL", "GROWS");
+$priv{"repeat"}{64} = "DOLIST";
+$priv{"leaveloop"}{64} = "CONT";
+@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
+ for (qw(rv2gv rv2sv padsv aelem helem));
+@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
+@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
+$priv{"gv"}{32} = "EARLYCV";
+$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
+$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
+ "enteriter");
+$priv{$_}{16} = "TARGMY"
+ for (map(($_,"s$_"),"chop", "chomp"),
+ map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
+ "add", "subtract", "negate"), "pow", "concat", "stringify",
+ "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
+ "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
+ "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
+ "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
+ "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
+ "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
+ "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
+ "setpriority", "time", "sleep");
+$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
+@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
+$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
+$priv{"list"}{64} = "GUESSED";
+$priv{"delete"}{64} = "SLICE";
+$priv{"exists"}{64} = "SUB";
+$priv{$_}{64} = "LOCALE"
+ for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
+ "scmp", "lc", "uc", "lcfirst", "ucfirst");
+@{$priv{"sort"}}{1,2,4,8,16} = ("NUM", "INT", "REV", "INPLACE","DESC");
+$priv{"threadsv"}{64} = "SVREFd";
+@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
+ for ("open", "backtick");
+$priv{"exit"}{128} = "VMS";
+$priv{$_}{2} = "FTACCESS"
+ for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
+if ($] >= 5.009) {
+ # Stacked filetests are post 5.8.x
+ $priv{$_}{4} = "FTSTACKED"
+ for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
+ "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
+ "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
+ "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
+ "ftbinary");
+ # Lexical $_ is post 5.8.x
+ $priv{$_}{2} = "GREPLEX"
+ for ("mapwhile", "mapstart", "grepwhile", "grepstart");
+}
+
+sub private_flags {
+ my($name, $x) = @_;
+ my @s;
+ for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) {
+ if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) {
+ $x -= $flag;
+ push @s, $priv{$name}{$flag};
+ }
+ }
+ push @s, $x if $x;
+ return join(",", @s);
+}
+
+sub concise_sv {
+ my($sv, $hr, $preferpv) = @_;
+ $hr->{svclass} = class($sv);
+ $hr->{svclass} = "UV"
+ if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
+ Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
+ $hr->{svaddr} = sprintf("%#x", $$sv);
+ if ($hr->{svclass} eq "GV") {
+ my $gv = $sv;
+ my $stash = $gv->STASH->NAME;
+ if ($stash eq "main") {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ $hr->{svval} = "*$stash" . $gv->SAFENAME;
+ return "*$stash" . $gv->SAFENAME;
+ } else {
+ while (class($sv) eq "RV") {
+ $hr->{svval} .= "\\";
+ $sv = $sv->RV;
+ }
+ if (class($sv) eq "SPECIAL") {
+ $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
+ } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+ $hr->{svval} .= cstring($sv->PV);
+ } elsif ($sv->FLAGS & SVf_NOK) {
+ $hr->{svval} .= $sv->NV;
+ } elsif ($sv->FLAGS & SVf_IOK) {
+ $hr->{svval} .= $sv->int_value;
+ } elsif ($sv->FLAGS & SVf_POK) {
+ $hr->{svval} .= cstring($sv->PV);
+ } elsif (class($sv) eq "HV") {
+ $hr->{svval} .= 'HASH';
+ }
+
+ $hr->{svval} = 'undef' unless defined $hr->{svval};
+ my $out = $hr->{svclass};
+ return $out .= " $hr->{svval}" ;
+ }
+}
+
+sub concise_op {
+ my ($op, $level, $format) = @_;
+ my %h;
+ $h{exname} = $h{name} = $op->name;
+ $h{NAME} = uc $h{name};
+ $h{class} = class($op);
+ $h{extarg} = $h{targ} = $op->targ;
+ $h{extarg} = "" unless $h{extarg};
+ if ($h{name} eq "null" and $h{targ}) {
+ # targ holds the old type
+ $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
+ $h{extarg} = "";
+ } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
+ # targ potentially holds a reference count
+ if ($op->private & 64) {
+ my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
+ $h{targarglife} = $h{targarg} = "$h{targ} $refs";
+ }
+ } elsif ($h{targ}) {
+ my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
+ if (defined $padname and class($padname) ne "SPECIAL") {
+ $h{targarg} = $padname->PVX;
+ if ($padname->FLAGS & SVf_FAKE) {
+ if ($] < 5.009) {
+ $h{targarglife} = "$h{targarg}:FAKE";
+ } else {
+ # These changes relate to the jumbo closure fix.
+ # See changes 19939 and 20005
+ my $fake = '';
+ $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
+ $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
+ $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
+ $h{targarglife} = "$h{targarg}:FAKE:$fake";
+ }
+ }
+ else {
+ my $intro = $padname->NVX - $cop_seq_base;
+ my $finish = int($padname->IVX) - $cop_seq_base;
+ $finish = "end" if $finish == 999999999 - $cop_seq_base;
+ $h{targarglife} = "$h{targarg}:$intro,$finish";
+ }
+ } else {
+ $h{targarglife} = $h{targarg} = "t" . $h{targ};
+ }
+ }
+ $h{arg} = "";
+ $h{svclass} = $h{svaddr} = $h{svval} = "";
+ if ($h{class} eq "PMOP") {
+ my $precomp = $op->precomp;
+ if (defined $precomp) {
+ $precomp = cstring($precomp); # Escape literal control sequences
+ $precomp = "/$precomp/";
+ } else {
+ $precomp = "";
+ }
+ my $pmreplroot = $op->pmreplroot;
+ my $pmreplstart;
+ if (ref($pmreplroot) eq "B::GV") {
+ # with C<@stash_array = split(/pat/, str);>,
+ # *stash_array is stored in /pat/'s pmreplroot.
+ $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
+ } elsif (!ref($pmreplroot) and $pmreplroot) {
+ # same as the last case, except the value is actually a
+ # pad offset for where the GV is kept (this happens under
+ # ithreads)
+ my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
+ $h{arg} = "($precomp => \@" . $gv->NAME . ")";
+ } elsif ($ {$op->pmreplstart}) {
+ undef $lastnext;
+ $pmreplstart = "replstart->" . seq($op->pmreplstart);
+ $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
+ } else {
+ $h{arg} = "($precomp)";
+ }
+ } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+ $h{arg} = '("' . $op->pv . '")';
+ $h{svval} = '"' . $op->pv . '"';
+ } elsif ($h{class} eq "COP") {
+ my $label = $op->label;
+ $h{coplabel} = $label;
+ $label = $label ? "$label: " : "";
+ my $loc = $op->file;
+ $loc =~ s[.*/][];
+ $loc .= ":" . $op->line;
+ my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
+ my $arybase = $op->arybase;
+ $arybase = $arybase ? ' $[=' . $arybase : "";
+ $h{arg} = "($label$stash $cseq $loc$arybase)";
+ } elsif ($h{class} eq "LOOP") {
+ $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
+ . " redo->" . seq($op->redoop) . ")";
+ } elsif ($h{class} eq "LOGOP") {
+ undef $lastnext;
+ $h{arg} = "(other->" . seq($op->other) . ")";
+ }
+ elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
+ unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
+ my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
+ my $preferpv = $h{name} eq "method_named";
+ if ($h{class} eq "PADOP" or !${$op->sv}) {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
+ $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
+ $h{targarglife} = $h{targarg} = "";
+ } else {
+ $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
+ }
+ }
+ }
+ $h{seq} = $h{hyphseq} = seq($op);
+ $h{seq} = "" if $h{seq} eq "-";
+ if ($] > 5.009) {
+ $h{opt} = $op->opt;
+ $h{static} = $op->static;
+ $h{label} = $labels{$$op};
+ } else {
+ $h{seqnum} = $op->seq;
+ $h{label} = $labels{$op->seq};
+ }
+ $h{next} = $op->next;
+ $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
+ $h{nextaddr} = sprintf("%#x", $ {$op->next});
+ $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
+ $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
+ $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
+
+ $h{classsym} = $opclass{$h{class}};
+ $h{flagval} = $op->flags;
+ $h{flags} = op_flags($op->flags);
+ $h{privval} = $op->private;
+ $h{private} = private_flags($h{name}, $op->private);
+ $h{addr} = sprintf("%#x", $$op);
+ $h{typenum} = $op->type;
+ $h{noise} = $linenoise[$op->type];
+
+ return fmt_line(\%h, $op, $format, $level);
+}
+
+sub B::OP::concise {
+ my($op, $level) = @_;
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto' line
+ my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext),
+ "goto" => seq($lastnext), # simplify goto '-' removal
+ };
+ print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
+ }
+ $lastnext = $op->next;
+ print $walkHandle concise_op($op, $level, $format);
+}
+
+# B::OP::terse (see Terse.pm) now just calls this
+sub b_terse {
+ my($op, $level) = @_;
+
+ # This isn't necessarily right, but there's no easy way to get
+ # from an OP to the right CV. This is a limitation of the
+ # ->terse() interface style, and there isn't much to do about
+ # it. In particular, we can die in concise_op if the main pad
+ # isn't long enough, or has the wrong kind of entries, compared to
+ # the pad a sub was compiled with. The fix for that would be to
+ # make a backwards compatible "terse" format that never even
+ # looked at the pad, just like the old B::Terse. I don't think
+ # that's worth the effort, though.
+ $curcv = main_cv unless $curcv;
+
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto'
+ my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext)};
+ print # $walkHandle
+ fmt_line($h, $op, $style{"terse"}[1], $level+1);
+ }
+ $lastnext = $op->next;
+ print # $walkHandle
+ concise_op($op, $level, $style{"terse"}[0]);
+}
+
+sub tree {
+ my $op = shift;
+ my $level = shift;
+ my $style = $tree_decorations[$tree_style];
+ my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
+ my $name = concise_op($op, $level, $treefmt);
+ if (not $op->flags & OPf_KIDS) {
+ return $name . "\n";
+ }
+ my @lines;
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ push @lines, tree($kid, $level+1);
+ }
+ my $i;
+ for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
+ $lines[$i] = $space . $lines[$i];
+ }
+ if ($i > 0) {
+ $lines[$i] = $last . $lines[$i];
+ while ($i-- > 1) {
+ if (substr($lines[$i], 0, 1) eq " ") {
+ $lines[$i] = $nokid . $lines[$i];
+ } else {
+ $lines[$i] = $kid . $lines[$i];
+ }
+ }
+ $lines[$i] = $kids . $lines[$i];
+ } else {
+ $lines[0] = $single . $lines[0];
+ }
+ return("$name$lead" . shift @lines,
+ map(" " x (length($name)+$size) . $_, @lines));
+}
+
+# *** Warning: fragile kludge ahead ***
+# Because the B::* modules run in the same interpreter as the code
+# they're compiling, their presence tends to distort the view we have of
+# the code we're looking at. In particular, perl gives sequence numbers
+# to COPs. If the program we're looking at were run on its own, this
+# would start at 1. Because all of B::Concise and all the modules it
+# uses are compiled first, though, by the time we get to the user's
+# program the sequence number is already pretty high, which could be
+# distracting if you're trying to tell OPs apart. Therefore we'd like to
+# subtract an offset from all the sequence numbers we display, to
+# restore the simpler view of the world. The trick is to know what that
+# offset will be, when we're still compiling B::Concise! If we
+# hardcoded a value, it would have to change every time B::Concise or
+# other modules we use do. To help a little, what we do here is compile
+# a little code at the end of the module, and compute the base sequence
+# number for the user's program as being a small offset later, so all we
+# have to worry about are changes in the offset.
+
+# [For 5.8.x and earlier perl is generating sequence numbers for all ops,
+# and using them to reference labels]
+
+
+# When you say "perl -MO=Concise -e '$a'", the output should look like:
+
+# 4 <@> leave[t1] vKP/REFC ->(end)
+# 1 <0> enter ->2
+ #^ smallest OP sequence number should be 1
+# 2 <;> nextstate(main 1 -e:1) v ->3
+ # ^ smallest COP sequence number should be 1
+# - <1> ex-rv2sv vK/1 ->4
+# 3 <$> gvsv(*a) s ->4
+
+# If the second of the marked numbers there isn't 1, it means you need
+# to update the corresponding magic number in the next line.
+# Remember, this needs to stay the last things in the module.
+
+# Why is this different for MacOS? Does it matter?
+my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
+$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Concise - Walk Perl syntax tree, printing concise info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Concise[,OPTIONS] foo.pl
+
+ use B::Concise qw(set_style add_callback);
+
+=head1 DESCRIPTION
+
+This compiler backend prints the internal OPs of a Perl program's syntax
+tree in one of several space-efficient text formats suitable for debugging
+the inner workings of perl or other compiler backends. It can print OPs in
+the order they appear in the OP tree, in the order they will execute, or
+in a text approximation to their tree structure, and the format of the
+information displayed is customizable. Its function is similar to that of
+perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
+sophisticated and flexible.
+
+=head1 EXAMPLE
+
+Here's an example of 2 outputs (aka 'renderings'), using the
+-exec and -basic (i.e. default) formatting conventions on the same code
+snippet.
+
+ % perl -MO=Concise,-exec -e '$a = $b + 42'
+ 1 <0> enter
+ 2 <;> nextstate(main 1 -e:1) v
+ 3 <#> gvsv[*b] s
+ 4 <$> const[IV 42] s
+ * 5 <2> add[t3] sK/2
+ 6 <#> gvsv[*a] s
+ 7 <2> sassign vKS/2
+ 8 <@> leave[1 ref] vKP/REFC
+
+Each line corresponds to an opcode. The opcode marked with '*' is used
+in a few examples below.
+
+The 1st column is the op's sequence number, starting at 1, and is
+displayed in base 36 by default. This rendering is in -exec (i.e.
+execution) order.
+
+The symbol between angle brackets indicates the op's type, for
+example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
+used in threaded perls. (see L</"OP class abbreviations">).
+
+The opname, as in B<'add[t1]'>, which may be followed by op-specific
+information in parentheses or brackets (ex B<'[t1]'>).
+
+The op-flags (ex B<'sK/2'>) follow, and are described in (L</"OP flags
+abbreviations">).
+
+ % perl -MO=Concise -e '$a = $b + 42'
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
+ 1 <0> enter ->2
+ 2 <;> nextstate(main 1 -e:1) v ->3
+ 7 <2> sassign vKS/2 ->8
+ * 5 <2> add[t1] sK/2 ->6
+ - <1> ex-rv2sv sK/1 ->4
+ 3 <$> gvsv(*b) s ->4
+ 4 <$> const(IV 42) s ->5
+ - <1> ex-rv2sv sKRM*/1 ->7
+ 6 <$> gvsv(*a) s ->7
+
+The default rendering is top-down, so they're not in execution order.
+This form reflects the way the stack is used to parse and evaluate
+expressions; the add operates on the two terms below it in the tree.
+
+Nullops appear as C<ex-opname>, where I<opname> is an op that has been
+optimized away by perl. They're displayed with a sequence-number of
+'-', because they are not executed (they don't appear in previous
+example), they're printed here because they reflect the parse.
+
+The arrow points to the sequence number of the next op; they're not
+displayed in -exec mode, for obvious reasons.
+
+Note that because this rendering was done on a non-threaded perl, the
+PADOPs in the previous examples are now SVOPs, and some (but not all)
+of the square brackets have been replaced by round ones. This is a
+subtle feature to provide some visual distinction between renderings
+on threaded and un-threaded perls.
+
+
+=head1 OPTIONS
+
+Arguments that don't start with a hyphen are taken to be the names of
+subroutines to print the OPs of; if no such functions are specified,
+the main body of the program (outside any subroutines, and not
+including use'd or require'd files) is rendered. Passing C<BEGIN>,
+C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
+special blocks to be printed.
+
+Options affect how things are rendered (ie printed). They're presented
+here by their visual effect, 1st being strongest. They're grouped
+according to how they interrelate; within each group the options are
+mutually exclusive (unless otherwise stated).
+
+=head2 Options for Opcode Ordering
+
+These options control the 'vertical display' of opcodes. The display
+'order' is also called 'mode' elsewhere in this document.
+
+=over 4
+
+=item B<-basic>
+
+Print OPs in the order they appear in the OP tree (a preorder
+traversal, starting at the root). The indentation of each OP shows its
+level in the tree, and the '->' at the end of the line indicates the
+next opcode in execution order. This mode is the default, so the flag
+is included simply for completeness.
+
+=item B<-exec>
+
+Print OPs in the order they would normally execute (for the majority
+of constructs this is a postorder traversal of the tree, ending at the
+root). In most cases the OP that usually follows a given OP will
+appear directly below it; alternate paths are shown by indentation. In
+cases like loops when control jumps out of a linear path, a 'goto'
+line is generated.
+
+=item B<-tree>
+
+Print OPs in a text approximation of a tree, with the root of the tree
+at the left and 'left-to-right' order of children transformed into
+'top-to-bottom'. Because this mode grows both to the right and down,
+it isn't suitable for large programs (unless you have a very wide
+terminal).
+
+=back
+
+=head2 Options for Line-Style
+
+These options select the line-style (or just style) used to render
+each opcode, and dictates what info is actually printed into each line.
+
+=over 4
+
+=item B<-concise>
+
+Use the author's favorite set of formatting conventions. This is the
+default, of course.
+
+=item B<-terse>
+
+Use formatting conventions that emulate the output of B<B::Terse>. The
+basic mode is almost indistinguishable from the real B<B::Terse>, and the
+exec mode looks very similar, but is in a more logical order and lacks
+curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
+is only vaguely reminiscent of B<B::Terse>.
+
+=item B<-linenoise>
+
+Use formatting conventions in which the name of each OP, rather than being
+written out in full, is represented by a one- or two-character abbreviation.
+This is mainly a joke.
+
+=item B<-debug>
+
+Use formatting conventions reminiscent of B<B::Debug>; these aren't
+very concise at all.
+
+=item B<-env>
+
+Use formatting conventions read from the environment variables
+C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
+
+=back
+
+=head2 Options for tree-specific formatting
+
+=over 4
+
+=item B<-compact>
+
+Use a tree format in which the minimum amount of space is used for the
+lines connecting nodes (one character in most cases). This squeezes out
+a few precious columns of screen real estate.
+
+=item B<-loose>
+
+Use a tree format that uses longer edges to separate OP nodes. This format
+tends to look better than the compact one, especially in ASCII, and is
+the default.
+
+=item B<-vt>
+
+Use tree connecting characters drawn from the VT100 line-drawing set.
+This looks better if your terminal supports it.
+
+=item B<-ascii>
+
+Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
+look as clean as the VT100 characters, but they'll work with almost any
+terminal (or the horizontal scrolling mode of less(1)) and are suitable
+for text documentation or email. This is the default.
+
+=back
+
+These are pairwise exclusive, i.e. compact or loose, vt or ascii.
+
+=head2 Options controlling sequence numbering
+
+=over 4
+
+=item B<-base>I<n>
+
+Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
+digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
+for 37 will be 'A', and so on until 62. Values greater than 62 are not
+currently supported. The default is 36.
+
+=item B<-bigendian>
+
+Print sequence numbers with the most significant digit first. This is the
+usual convention for Arabic numerals, and the default.
+
+=item B<-littleendian>
+
+Print seqence numbers with the least significant digit first. This is
+obviously mutually exclusive with bigendian.
+
+=back
+
+=head2 Other options
+
+These are pairwise exclusive.
+
+=over 4
+
+=item B<-main>
+
+Include the main program in the output, even if subroutines were also
+specified. This rendering is normally suppressed when a subroutine
+name or reference is given.
+
+=item B<-nomain>
+
+This restores the default behavior after you've changed it with '-main'
+(it's not normally needed). If no subroutine name/ref is given, main is
+rendered, regardless of this flag.
+
+=item B<-nobanner>
+
+Renderings usually include a banner line identifying the function name
+or stringified subref. This suppresses the printing of the banner.
+
+TBC: Remove the stringified coderef; while it provides a 'cookie' for
+each function rendered, the cookies used should be 1,2,3.. not a
+random hex-address. It also complicates string comparison of two
+different trees.
+
+=item B<-banner>
+
+restores default banner behavior.
+
+=item B<-banneris> => subref
+
+TBC: a hookpoint (and an option to set it) for a user-supplied
+function to produce a banner appropriate for users needs. It's not
+ideal, because the rendering-state variables, which are a natural
+candidate for use in concise.t, are unavailable to the user.
+
+=back
+
+=head2 Option Stickiness
+
+If you invoke Concise more than once in a program, you should know that
+the options are 'sticky'. This means that the options you provide in
+the first call will be remembered for the 2nd call, unless you
+re-specify or change them.
+
+=head1 ABBREVIATIONS
+
+The concise style uses symbols to convey maximum info with minimal
+clutter (like hex addresses). With just a little practice, you can
+start to see the flowers, not just the branches, in the trees.
+
+=head2 OP class abbreviations
+
+These symbols appear before the op-name, and indicate the
+B:: namespace that represents the ops in your Perl code.
+
+ 0 OP (aka BASEOP) An OP with no children
+ 1 UNOP An OP with one child
+ 2 BINOP An OP with two children
+ | LOGOP A control branch OP
+ @ LISTOP An OP that could have lots of children
+ / PMOP An OP with a regular expression
+ $ SVOP An OP with an SV
+ " PVOP An OP with a string
+ { LOOP An OP that holds pointers for a loop
+ ; COP An OP that marks the start of a statement
+ # PADOP An OP with a GV on the pad
+
+=head2 OP flags abbreviations
+
+OP flags are either public or private. The public flags alter the
+behavior of each opcode in consistent ways, and are represented by 0
+or more single characters.
+
+ v OPf_WANT_VOID Want nothing (void context)
+ s OPf_WANT_SCALAR Want single value (scalar context)
+ l OPf_WANT_LIST Want list of any length (list context)
+ Want is unknown
+ K OPf_KIDS There is a firstborn child.
+ P OPf_PARENS This operator was parenthesized.
+ (Or block needs explicit scope entry.)
+ R OPf_REF Certified reference.
+ (Return container, not containee).
+ M OPf_MOD Will modify (lvalue).
+ S OPf_STACKED Some arg is arriving on the stack.
+ * OPf_SPECIAL Do something weird for this op (see op.h)
+
+Private flags, if any are set for an opcode, are displayed after a '/'
+
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
+ 7 <2> sassign vKS/2 ->8
+
+They're opcode specific, and occur less often than the public ones, so
+they're represented by short mnemonics instead of single-chars; see
+F<op.h> for gory details, or try this quick 2-liner:
+
+ $> perl -MB::Concise -de 1
+ DB<1> |x \%B::Concise::priv
+
+=head1 FORMATTING SPECIFICATIONS
+
+For each line-style ('concise', 'terse', 'linenoise', etc.) there are
+3 format-specs which control how OPs are rendered.
+
+The first is the 'default' format, which is used in both basic and exec
+modes to print all opcodes. The 2nd, goto-format, is used in exec
+mode when branches are encountered. They're not real opcodes, and are
+inserted to look like a closing curly brace. The tree-format is tree
+specific.
+
+When a line is rendered, the correct format-spec is copied and scanned
+for the following items; data is substituted in, and other
+manipulations like basic indenting are done, for each opcode rendered.
+
+There are 3 kinds of items that may be populated; special patterns,
+#vars, and literal text, which is copied verbatim. (Yes, it's a set
+of s///g steps.)
+
+=head2 Special Patterns
+
+These items are the primitives used to perform indenting, and to
+select text from amongst alternatives.
+
+=over 4
+
+=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
+
+Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
+
+=item B<(*(>I<text>B<)*)>
+
+Generates one copy of I<text> for each indentation level.
+
+=item B<(*(>I<text1>B<;>I<text2>B<)*)>
+
+Generates one fewer copies of I<text1> than the indentation level, followed
+by one copy of I<text2> if the indentation level is more than 0.
+
+=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
+
+If the value of I<var> is true (not empty or zero), generates the
+value of I<var> surrounded by I<text1> and I<Text2>, otherwise
+nothing.
+
+=item B<~>
+
+Any number of tildes and surrounding whitespace will be collapsed to
+a single space.
+
+=back
+
+=head2 # Variables
+
+These #vars represent opcode properties that you may want as part of
+your rendering. The '#' is intended as a private sigil; a #var's
+value is interpolated into the style-line, much like "read $this".
+
+These vars take 3 forms:
+
+=over 4
+
+=item B<#>I<var>
+
+A property named 'var' is assumed to exist for the opcodes, and is
+interpolated into the rendering.
+
+=item B<#>I<var>I<N>
+
+Generates the value of I<var>, left justified to fill I<N> spaces.
+Note that this means while you can have properties 'foo' and 'foo2',
+you cannot render 'foo2', but you could with 'foo2a'. You would be
+wise not to rely on this behavior going forward ;-)
+
+=item B<#>I<Var>
+
+This ucfirst form of #var generates a tag-value form of itself for
+display; it converts '#Var' into a 'Var => #var' style, which is then
+handled as described above. (Imp-note: #Vars cannot be used for
+conditional-fills, because the => #var transform is done after the check
+for #Var's value).
+
+=back
+
+The following variables are 'defined' by B::Concise; when they are
+used in a style, their respective values are plugged into the
+rendering of each opcode.
+
+Only some of these are used by the standard styles, the others are
+provided for you to delve into optree mechanics, should you wish to
+add a new style (see L</add_style> below) that uses them. You can
+also add new ones using L</add_callback>.
+
+=over 4
+
+=item B<#addr>
+
+The address of the OP, in hexadecimal.
+
+=item B<#arg>
+
+The OP-specific information of the OP (such as the SV for an SVOP, the
+non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
+
+=item B<#class>
+
+The B-determined class of the OP, in all caps.
+
+=item B<#classsym>
+
+A single symbol abbreviating the class of the OP.
+
+=item B<#coplabel>
+
+The label of the statement or block the OP is the start of, if any.
+
+=item B<#exname>
+
+The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
+
+=item B<#extarg>
+
+The target of the OP, or nothing for a nulled OP.
+
+=item B<#firstaddr>
+
+The address of the OP's first child, in hexadecimal.
+
+=item B<#flags>
+
+The OP's flags, abbreviated as a series of symbols.
+
+=item B<#flagval>
+
+The numeric value of the OP's flags.
+
+=item B<#hyphseq>
+
+The sequence number of the OP, or a hyphen if it doesn't have one.
+
+=item B<#label>
+
+'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
+mode, or empty otherwise.
+
+=item B<#lastaddr>
+
+The address of the OP's last child, in hexadecimal.
+
+=item B<#name>
+
+The OP's name.
+
+=item B<#NAME>
+
+The OP's name, in all caps.
+
+=item B<#next>
+
+The sequence number of the OP's next OP.
+
+=item B<#nextaddr>
+
+The address of the OP's next OP, in hexadecimal.
+
+=item B<#noise>
+
+A one- or two-character abbreviation for the OP's name.
+
+=item B<#private>
+
+The OP's private flags, rendered with abbreviated names if possible.
+
+=item B<#privval>
+
+The numeric value of the OP's private flags.
+
+=item B<#seq>
+
+The sequence number of the OP. Note that this is a sequence number
+generated by B::Concise.
+
+=item B<#seqnum>
+
+5.8.x and earlier only. 5.9 and later do not provide this.
+
+The real sequence number of the OP, as a regular number and not adjusted
+to be relative to the start of the real program. (This will generally be
+a fairly large number because all of B<B::Concise> is compiled before
+your program is).
+
+=item B<#opt>
+
+Whether or not the op has been optimised by the peephole optimiser.
+
+Only available in 5.9 and later.
+
+=item B<#static>
+
+Whether or not the op is statically defined. This flag is used by the
+B::C compiler backend and indicates that the op should not be freed.
+
+Only available in 5.9 and later.
+
+=item B<#sibaddr>
+
+The address of the OP's next youngest sibling, in hexadecimal.
+
+=item B<#svaddr>
+
+The address of the OP's SV, if it has an SV, in hexadecimal.
+
+=item B<#svclass>
+
+The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
+
+=item B<#svval>
+
+The value of the OP's SV, if it has one, in a short human-readable format.
+
+=item B<#targ>
+
+The numeric value of the OP's targ.
+
+=item B<#targarg>
+
+The name of the variable the OP's targ refers to, if any, otherwise the
+letter t followed by the OP's targ in decimal.
+
+=item B<#targarglife>
+
+Same as B<#targarg>, but followed by the COP sequence numbers that delimit
+the variable's lifetime (or 'end' for a variable in an open scope) for a
+variable.
+
+=item B<#typenum>
+
+The numeric value of the OP's type, in decimal.
+
+=back
+
+=head1 Using B::Concise outside of the O framework
+
+The common (and original) usage of B::Concise was for command-line
+renderings of simple code, as given in EXAMPLE. But you can also use
+B<B::Concise> from your code, and call compile() directly, and
+repeatedly. By doing so, you can avoid the compile-time only
+operation of O.pm, and even use the debugger to step through
+B::Concise::compile() itself.
+
+Once you're doing this, you may alter Concise output by adding new
+rendering styles, and by optionally adding callback routines which
+populate new variables, if such were referenced from those (just
+added) styles.
+
+=head2 Example: Altering Concise Renderings
+
+ use B::Concise qw(set_style add_callback);
+ add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
+ add_callback
+ ( sub {
+ my ($h, $op, $format, $level, $stylename) = @_;
+ $h->{variable} = some_func($op);
+ });
+ $walker = B::Concise::compile(@options, at subnames, at subrefs);
+ $walker->();
+
+=head2 set_style()
+
+B<set_style> accepts 3 arguments, and updates the three format-specs
+comprising a line-style (basic-exec, goto, tree). It has one minor
+drawback though; it doesn't register the style under a new name. This
+can become an issue if you render more than once and switch styles.
+Thus you may prefer to use add_style() and/or set_style_standard()
+instead.
+
+=head2 set_style_standard($name)
+
+This restores one of the standard line-styles: C<terse>, C<concise>,
+C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
+names previously defined with add_style().
+
+=head2 add_style()
+
+This subroutine accepts a new style name and three style arguments as
+above, and creates, registers, and selects the newly named style. It is
+an error to re-add a style; call set_style_standard() to switch between
+several styles.
+
+=head2 add_callback()
+
+If your newly minted styles refer to any new #variables, you'll need
+to define a callback subroutine that will populate (or modify) those
+variables. They are then available for use in the style you've
+chosen.
+
+The callbacks are called for each opcode visited by Concise, in the
+same order as they are added. Each subroutine is passed five
+parameters.
+
+ 1. A hashref, containing the variable names and values which are
+ populated into the report-line for the op
+ 2. the op, as a B<B::OP> object
+ 3. a reference to the format string
+ 4. the formatting (indent) level
+ 5. the selected stylename
+
+To define your own variables, simply add them to the hash, or change
+existing values if you need to. The level and format are passed in as
+references to scalars, but it is unlikely that they will need to be
+changed or even used.
+
+=head2 Running B::Concise::compile()
+
+B<compile> accepts options as described above in L</OPTIONS>, and
+arguments, which are either coderefs, or subroutine names.
+
+It constructs and returns a $treewalker coderef, which when invoked,
+traverses, or walks, and renders the optrees of the given arguments to
+STDOUT. You can reuse this, and can change the rendering style used
+each time; thereafter the coderef renders in the new style.
+
+B<walk_output> lets you change the print destination from STDOUT to
+another open filehandle, or into a string passed as a ref (unless
+you've built perl with -Uuseperlio).
+
+ my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
+ walk_output(\my $buf);
+ $walker->(); # 1 renders -terse
+ set_style_standard('concise'); # 2
+ $walker->(); # 2 renders -concise
+ $walker->(@new); # 3 renders whatever
+ print "3 different renderings: terse, concise, and @new: $buf\n";
+
+When $walker is called, it traverses the subroutines supplied when it
+was created, and renders them using the current style. You can change
+the style afterwards in several different ways:
+
+ 1. call C<compile>, altering style or mode/order
+ 2. call C<set_style_standard>
+ 3. call $walker, passing @new options
+
+Passing new options to the $walker is the easiest way to change
+amongst any pre-defined styles (the ones you add are automatically
+recognized as options), and is the only way to alter rendering order
+without calling compile again. Note however that rendering state is
+still shared amongst multiple $walker objects, so they must still be
+used in a coordinated manner.
+
+=head2 B::Concise::reset_sequence()
+
+This function (not exported) lets you reset the sequence numbers (note
+that they're numbered arbitrarily, their goal being to be human
+readable). Its purpose is mostly to support testing, i.e. to compare
+the concise output from two identical anonymous subroutines (but
+different instances). Without the reset, B::Concise, seeing that
+they're separate optrees, generates different sequence numbers in
+the output.
+
+=head2 Errors
+
+Errors in rendering (non-existent function-name, non-existent coderef)
+are written to the STDOUT, or wherever you've set it via
+walk_output().
+
+Errors using the various *style* calls, and bad args to walk_output(),
+result in die(). Use an eval if you wish to catch these errors and
+continue processing.
+
+=head1 AUTHOR
+
+Stephen McCamant, E<lt>smcc at CSUA.Berkeley.EDUE<gt>.
+
+=cut
Added: B/B/Debug.pm
==============================================================================
--- (empty file)
+++ B/B/Debug.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,305 @@
+package B::Debug;
+
+our $VERSION = '1.02_01';
+
+use strict;
+use B qw(peekop class walkoptree walkoptree_exec
+ main_start main_root cstring sv_undef);
+use B::Asmdata qw(@specialsv_name);
+
+my %done_gv;
+
+sub B::OP::debug {
+ my ($op) = @_;
+ printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type;
+%s (0x%lx)
+ op_next 0x%x
+ op_sibling 0x%x
+ op_ppaddr %s
+ op_targ %d
+ op_type %d
+EOT
+ if ($] > 5.009) {
+ printf <<'EOT', $op->opt, $op->static;
+ op_opt %d
+ op_static %d
+EOT
+ } else {
+ printf <<'EOT', $op->seq;
+ op_seq %d
+EOT
+ }
+ printf <<'EOT', $op->flags, $op->private;
+ op_flags %d
+ op_private %d
+EOT
+}
+
+sub B::UNOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_first\t0x%x\n", ${$op->first};
+}
+
+sub B::BINOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_last\t\t0x%x\n", ${$op->last};
+}
+
+sub B::LOOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};
+ op_redoop 0x%x
+ op_nextop 0x%x
+ op_lastop 0x%x
+EOT
+}
+
+sub B::LOGOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_other\t0x%x\n", ${$op->other};
+}
+
+sub B::LISTOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf "\top_children\t%d\n", $op->children;
+}
+
+sub B::PMOP::debug {
+ my ($op) = @_;
+ $op->B::LISTOP::debug();
+ printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
+ printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
+ printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
+ printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
+ printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ $op->pmreplroot->debug;
+}
+
+sub B::COP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
+ printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
+ cop_label %s
+ cop_stashpv %s
+ cop_file %s
+ cop_seq %d
+ cop_arybase %d
+ cop_line %d
+ cop_warnings 0x%x
+ cop_io %s
+EOT
+}
+
+sub B::SVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_sv\t\t0x%x\n", ${$op->sv};
+ $op->sv->debug;
+}
+
+sub B::PVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_pv\t\t%s\n", cstring($op->pv);
+}
+
+sub B::PADOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_padix\t\t%ld\n", $op->padix;
+}
+
+sub B::NULL::debug {
+ my ($sv) = @_;
+ if ($$sv == ${sv_undef()}) {
+ print "&sv_undef\n";
+ } else {
+ printf "NULL (0x%x)\n", $$sv;
+ }
+}
+
+sub B::SV::debug {
+ my ($sv) = @_;
+ if (!$$sv) {
+ print class($sv), " = NULL\n";
+ return;
+ }
+ printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+%s (0x%x)
+ REFCNT %d
+ FLAGS 0x%x
+EOT
+}
+
+sub B::RV::debug {
+ my ($rv) = @_;
+ B::SV::debug($rv);
+ printf <<'EOT', ${$rv->RV};
+ RV 0x%x
+EOT
+ $rv->RV->debug;
+}
+
+sub B::PV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ my $pv = $sv->PV();
+ printf <<'EOT', cstring($pv), length($pv);
+ xpv_pv %s
+ xpv_cur %d
+EOT
+}
+
+sub B::IV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::NV::debug {
+ my ($sv) = @_;
+ $sv->B::IV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVIV::debug {
+ my ($sv) = @_;
+ $sv->B::PV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::PVNV::debug {
+ my ($sv) = @_;
+ $sv->B::PVIV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVLV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
+ printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
+ printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
+}
+
+sub B::BM::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txbm_useful\t%d\n", $sv->USEFUL;
+ printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
+ printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
+}
+
+sub B::CV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ my ($stash) = $sv->STASH;
+ my ($start) = $sv->START;
+ my ($root) = $sv->ROOT;
+ my ($padlist) = $sv->PADLIST;
+ my ($file) = $sv->FILE;
+ my ($gv) = $sv->GV;
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
+ STASH 0x%x
+ START 0x%x
+ ROOT 0x%x
+ GV 0x%x
+ FILE %s
+ DEPTH %d
+ PADLIST 0x%x
+ OUTSIDE 0x%x
+ OUTSIDE_SEQ %d
+EOT
+ $start->debug if $start;
+ $root->debug if $root;
+ $gv->debug if $gv;
+ $padlist->debug if $padlist;
+}
+
+sub B::AV::debug {
+ my ($av) = @_;
+ $av->B::SV::debug;
+ my(@array) = $av->ARRAY;
+ print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
+ printf <<'EOT', scalar(@array), $av->MAX, $av->OFF;
+ FILL %d
+ MAX %d
+ OFF %d
+EOT
+ printf <<'EOT', $av->AvFLAGS if $] < 5.009;
+ AvFLAGS %d
+EOT
+}
+
+sub B::GV::debug {
+ my ($gv) = @_;
+ if ($done_gv{$$gv}++) {
+ printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
+ return;
+ }
+ my ($sv) = $gv->SV;
+ my ($av) = $gv->AV;
+ my ($cv) = $gv->CV;
+ $gv->B::SV::debug;
+ printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
+ NAME %s
+ STASH %s (0x%x)
+ SV 0x%x
+ GvREFCNT %d
+ FORM 0x%x
+ AV 0x%x
+ HV 0x%x
+ EGV 0x%x
+ CV 0x%x
+ CVGEN %d
+ LINE %d
+ FILE %s
+ GvFLAGS 0x%x
+EOT
+ $sv->debug if $sv;
+ $av->debug if $av;
+ $cv->debug if $cv;
+}
+
+sub B::SPECIAL::debug {
+ my $sv = shift;
+ print $specialsv_name[$$sv], "\n";
+}
+
+sub compile {
+ my $order = shift;
+ B::clearsym();
+ if ($order && $order eq "exec") {
+ return sub { walkoptree_exec(main_start, "debug") }
+ } else {
+ return sub { walkoptree(main_root, "debug") }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Debug - Walk Perl syntax tree, printing debug info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Debug[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+See F<ext/B/README>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/Deparse.pm
==============================================================================
--- (empty file)
+++ B/B/Deparse.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,4645 @@
+# B::Deparse.pm
+# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# This is based on the module of the same name by Malcolm Beattie,
+# but essentially none of his code remains.
+
+package B::Deparse;
+use Carp;
+use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
+ OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
+ OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
+ OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
+ OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
+ SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
+ CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
+ PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
+$VERSION = 0.71;
+use strict;
+use vars qw/$AUTOLOAD/;
+use warnings ();
+
+# Changes between 0.50 and 0.51:
+# - fixed nulled leave with live enter in sort { }
+# - fixed reference constants (\"str")
+# - handle empty programs gracefully
+# - handle infinte loops (for (;;) {}, while (1) {})
+# - differentiate between `for my $x ...' and `my $x; for $x ...'
+# - various minor cleanups
+# - moved globals into an object
+# - added `-u', like B::C
+# - package declarations using cop_stash
+# - subs, formats and code sorted by cop_seq
+# Changes between 0.51 and 0.52:
+# - added pp_threadsv (special variables under USE_5005THREADS)
+# - added documentation
+# Changes between 0.52 and 0.53:
+# - many changes adding precedence contexts and associativity
+# - added `-p' and `-s' output style options
+# - various other minor fixes
+# Changes between 0.53 and 0.54:
+# - added support for new `for (1..100)' optimization,
+# thanks to Gisle Aas
+# Changes between 0.54 and 0.55:
+# - added support for new qr// construct
+# - added support for new pp_regcreset OP
+# Changes between 0.55 and 0.56:
+# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
+# - fixed $# on non-lexicals broken in last big rewrite
+# - added temporary fix for change in opcode of OP_STRINGIFY
+# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed precedence in conditional of ?:
+# - tweaked list paren elimination in `my($x) = @_'
+# - made continue-block detection trickier wrt. null ops
+# - fixed various prototype problems in pp_entersub
+# - added support for sub prototypes that never get GVs
+# - added unquoting for special filehandle first arg in truncate
+# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - added semicolons at the ends of blocks
+# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
+# Changes between 0.56 and 0.561:
+# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
+# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
+# Changes between 0.561 and 0.57:
+# - stylistic changes to symbolic constant stuff
+# - handled scope in s///e replacement code
+# - added unquote option for expanding "" into concats, etc.
+# - split method and proto parts of pp_entersub into separate functions
+# - various minor cleanups
+# Changes after 0.57:
+# - added parens in \&foo (patch by Albert Dvornik)
+# Changes between 0.57 and 0.58:
+# - fixed `0' statements that weren't being printed
+# - added methods for use from other programs
+# (based on patches from James Duncan and Hugo van der Sanden)
+# - added -si and -sT to control indenting (also based on a patch from Hugo)
+# - added -sv to print something else instead of '???'
+# - preliminary version of utf8 tr/// handling
+# Changes after 0.58:
+# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
+# - added support for Hugo's new OP_SETSTATE (like nextstate)
+# Changes between 0.58 and 0.59
+# - added support for Chip's OP_METHOD_NAMED
+# - added support for Ilya's OPpTARGET_MY optimization
+# - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
+# Changes between 0.60 and 0.61 (mostly by Robin Houston)
+# - many bug-fixes
+# - support for pragmas and 'use'
+# - support for the little-used $[ variable
+# - support for __DATA__ sections
+# - UTF8 support
+# - BEGIN, CHECK, INIT and END blocks
+# - scoping of subroutine declarations fixed
+# - compile-time output from the input program can be suppressed, so that the
+# output is just the deparsed code. (a change to O.pm in fact)
+# - our() declarations
+# - *all* the known bugs are now listed in the BUGS section
+# - comprehensive test mechanism (TEST -deparse)
+# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
+# - bug-fixes
+# - new switch -P
+# - support for command-line switches (-l, -0, etc.)
+# Changes between 0.63 and 0.64
+# - support for //, CHECK blocks, and assertions
+# - improved handling of foreach loops and lexicals
+# - option to use Data::Dumper for constants
+# - more bug fixes
+# - discovered lots more bugs not yet fixed
+
+# Todo:
+# (See also BUGS section at the end of this file)
+#
+# - finish tr/// changes
+# - add option for even more parens (generalize \&foo change)
+# - left/right context
+# - copy comments (look at real text with $^P?)
+# - avoid semis in one-statement blocks
+# - associativity of &&=, ||=, ?:
+# - ',' => '=>' (auto-unquote?)
+# - break long lines ("\r" as discretionary break?)
+# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
+# - more style options: brace style, hex vs. octal, quotes, ...
+# - print big ints as hex/octal instead of decimal (heuristic?)
+# - handle `my $x if 0'?
+# - version using op_next instead of op_first/sibling?
+# - avoid string copies (pass arrays, one big join?)
+# - here-docs?
+
+# Current test.deparse failures
+# comp/assertions 38 - disabled assertions should be like "my($x) if 0"
+# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}'
+# comp/hints 6 - location of BEGIN blocks wrt. block openings
+# run/switchI 1 - missing -I switches entirely
+# perl -Ifoo -e 'print @INC'
+# op/caller 2 - warning mask propagates backwards before warnings::register
+# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
+# op/getpid 2 - can't assign to shared my() declaration (threads only)
+# 'my $x : shared = 5'
+# op/override 7 - parens on overriden require change v-string interpretation
+# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
+# c.f. 'BEGIN { *f = sub {0} }; f 2'
+# op/pat 774 - losing Unicode-ness of Latin1-only strings
+# 'use charnames ":short"; $x="\N{latin:a with acute}"'
+# op/recurse 12 - missing parens on recursive call makes it look like method
+# 'sub f { f($x) }'
+# op/subst 90 - inconsistent handling of utf8 under "use utf8"
+# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
+# op/tiehandle compile - "use strict" deparsed in the wrong place
+# uni/tr_ several
+# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
+# ext/Data/Dumper/t/dumper compile
+# ext/DB_file/several
+# ext/Encode/several
+# ext/Ernno/Errno warnings
+# ext/IO/lib/IO/t/io_sel 23
+# ext/PerlIO/t/encoding compile
+# ext/POSIX/t/posix 6
+# ext/Socket/Socket 8
+# ext/Storable/t/croak compile
+# lib/Attribute/Handlers/t/multi compile
+# lib/bignum/ several
+# lib/charnames 35
+# lib/constant 32
+# lib/English 40
+# lib/ExtUtils/t/bytes 4
+# lib/File/DosGlob compile
+# lib/Filter/Simple/t/data 1
+# lib/Math/BigInt/t/constant 1
+# lib/Net/t/config Deparse-warning
+# lib/overload compile
+# lib/Switch/ several
+# lib/Symbol 4
+# lib/Test/Simple several
+# lib/Term/Complete
+# lib/Tie/File/t/29_downcopy 5
+# lib/vars 22
+
+# Object fields (were globals):
+#
+# avoid_local:
+# (local($a), local($b)) and local($a, $b) have the same internal
+# representation but the short form looks better. We notice we can
+# use a large-scale local when checking the list, but need to prevent
+# individual locals too. This hash holds the addresses of OPs that
+# have already had their local-ness accounted for. The same thing
+# is done with my().
+#
+# curcv:
+# CV for current sub (or main program) being deparsed
+#
+# curcvlex:
+# Cached hash of lexical variables for curcv: keys are names,
+# each value is an array of pairs, indicating the cop_seq of scopes
+# in which a var of that name is valid.
+#
+# curcop:
+# COP for statement being deparsed
+#
+# curstash:
+# name of the current package for deparsed code
+#
+# subs_todo:
+# array of [cop_seq, CV, is_format?] for subs and formats we still
+# want to deparse
+#
+# protos_todo:
+# as above, but [name, prototype] for subs that never got a GV
+#
+# subs_done, forms_done:
+# keys are addresses of GVs for subs and formats we've already
+# deparsed (or at least put into subs_todo)
+#
+# subs_declared
+# keys are names of subs for which we've printed declarations.
+# That means we can omit parentheses from the arguments.
+#
+# subs_deparsed
+# Keeps track of fully qualified names of all deparsed subs.
+#
+# parens: -p
+# linenums: -l
+# unquote: -q
+# cuddle: ` ' or `\n', depending on -sC
+# indent_size: -si
+# use_tabs: -sT
+# ex_const: -sv
+
+# A little explanation of how precedence contexts and associativity
+# work:
+#
+# deparse() calls each per-op subroutine with an argument $cx (short
+# for context, but not the same as the cx* in the perl core), which is
+# a number describing the op's parents in terms of precedence, whether
+# they're inside an expression or at statement level, etc. (see
+# chart below). When ops with children call deparse on them, they pass
+# along their precedence. Fractional values are used to implement
+# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
+# parentheses hacks. The major disadvantage of this scheme is that
+# it doesn't know about right sides and left sides, so say if you
+# assign a listop to a variable, it can't tell it's allowed to leave
+# the parens off the listop.
+
+# Precedences:
+# 26 [TODO] inside interpolation context ("")
+# 25 left terms and list operators (leftward)
+# 24 left ->
+# 23 nonassoc ++ --
+# 22 right **
+# 21 right ! ~ \ and unary + and -
+# 20 left =~ !~
+# 19 left * / % x
+# 18 left + - .
+# 17 left << >>
+# 16 nonassoc named unary operators
+# 15 nonassoc < > <= >= lt gt le ge
+# 14 nonassoc == != <=> eq ne cmp
+# 13 left &
+# 12 left | ^
+# 11 left &&
+# 10 left ||
+# 9 nonassoc .. ...
+# 8 right ?:
+# 7 right = += -= *= etc.
+# 6 left , =>
+# 5 nonassoc list operators (rightward)
+# 4 right not
+# 3 left and
+# 2 left or xor
+# 1 statement modifiers
+# 0.5 statements, but still print scopes as do { ... }
+# 0 statement level
+
+# Nonprinting characters with special meaning:
+# \cS - steal parens (see maybe_parens_unop)
+# \n - newline and indent
+# \t - increase indent
+# \b - decrease indent (`outdent')
+# \f - flush left (no indent)
+# \cK - kill following semicolon, if any
+
+sub null {
+ my $op = shift;
+ return class($op) eq "NULL";
+}
+
+sub todo {
+ my $self = shift;
+ my($cv, $is_form) = @_;
+ return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
+ my $seq;
+ if ($cv->OUTSIDE_SEQ) {
+ $seq = $cv->OUTSIDE_SEQ;
+ } elsif (!null($cv->START) and is_state($cv->START)) {
+ $seq = $cv->START->cop_seq;
+ } else {
+ $seq = 0;
+ }
+ push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
+ unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
+ $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
+ }
+}
+
+sub next_todo {
+ my $self = shift;
+ my $ent = shift @{$self->{'subs_todo'}};
+ my $cv = $ent->[1];
+ my $gv = $cv->GV;
+ my $name = $self->gv_name($gv);
+ if ($ent->[2]) {
+ return "format $name =\n"
+ . $self->deparse_format($ent->[1]). "\n";
+ } else {
+ $self->{'subs_declared'}{$name} = 1;
+ if ($name eq "BEGIN") {
+ my $use_dec = $self->begin_is_use($cv);
+ if (defined ($use_dec) and $self->{'expand'} < 5) {
+ return () if 0 == length($use_dec);
+ return $use_dec;
+ }
+ }
+ my $l = '';
+ if ($self->{'linenums'}) {
+ my $line = $gv->LINE;
+ my $file = $gv->FILE;
+ $l = "\n\f#line $line \"$file\"\n";
+ }
+ my $p = '';
+ if (class($cv->STASH) ne "SPECIAL") {
+ my $stash = $cv->STASH->NAME;
+ if ($stash ne $self->{'curstash'}) {
+ $p = "package $stash;\n";
+ $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
+ $self->{'curstash'} = $stash;
+ }
+ $name =~ s/^\Q$stash\E:://;
+ }
+ return "${p}${l}sub $name " . $self->deparse_sub($cv);
+ }
+}
+
+# Return a "use" declaration for this BEGIN block, if appropriate
+sub begin_is_use {
+ my ($self, $cv) = @_;
+ my $root = $cv->ROOT;
+ local @$self{qw'curcv curcvlex'} = ($cv);
+#require B::Debug;
+#B::walkoptree($cv->ROOT, "debug");
+ my $lineseq = $root->first;
+ return if $lineseq->name ne "lineseq";
+
+ my $req_op = $lineseq->first->sibling;
+ return if $req_op->name ne "require";
+
+ my $module;
+ if ($req_op->first->private & OPpCONST_BARE) {
+ # Actually it should always be a bareword
+ $module = $self->const_sv($req_op->first)->PV;
+ $module =~ s[/][::]g;
+ $module =~ s/.pm$//;
+ }
+ else {
+ $module = $self->const($self->const_sv($req_op->first), 6);
+ }
+
+ my $version;
+ my $version_op = $req_op->sibling;
+ return if class($version_op) eq "NULL";
+ if ($version_op->name eq "lineseq") {
+ # We have a version parameter; skip nextstate & pushmark
+ my $constop = $version_op->first->next->next;
+
+ return unless $self->const_sv($constop)->PV eq $module;
+ $constop = $constop->sibling;
+ $version = $self->const_sv($constop);
+ if (class($version) eq "IV") {
+ $version = $version->int_value;
+ } elsif (class($version) eq "NV") {
+ $version = $version->NV;
+ } elsif (class($version) ne "PVMG") {
+ # Includes PVIV and PVNV
+ $version = $version->PV;
+ } else {
+ # version specified as a v-string
+ $version = 'v'.join '.', map ord, split //, $version->PV;
+ }
+ $constop = $constop->sibling;
+ return if $constop->name ne "method_named";
+ return if $self->const_sv($constop)->PV ne "VERSION";
+ }
+
+ $lineseq = $version_op->sibling;
+ return if $lineseq->name ne "lineseq";
+ my $entersub = $lineseq->first->sibling;
+ if ($entersub->name eq "stub") {
+ return "use $module $version ();\n" if defined $version;
+ return "use $module ();\n";
+ }
+ return if $entersub->name ne "entersub";
+
+ # See if there are import arguments
+ my $args = '';
+
+ my $svop = $entersub->first->sibling; # Skip over pushmark
+ return unless $self->const_sv($svop)->PV eq $module;
+
+ # Pull out the arguments
+ for ($svop=$svop->sibling; $svop->name ne "method_named";
+ $svop = $svop->sibling) {
+ $args .= ", " if length($args);
+ $args .= $self->deparse($svop, 6);
+ }
+
+ my $use = 'use';
+ my $method_named = $svop;
+ return if $method_named->name ne "method_named";
+ my $method_name = $self->const_sv($method_named)->PV;
+
+ if ($method_name eq "unimport") {
+ $use = 'no';
+ }
+
+ # Certain pragmas are dealt with using hint bits,
+ # so we ignore them here
+ if ($module eq 'strict' || $module eq 'integer'
+ || $module eq 'bytes' || $module eq 'warnings') {
+ return "";
+ }
+
+ if (defined $version && length $args) {
+ return "$use $module $version ($args);\n";
+ } elsif (defined $version) {
+ return "$use $module $version;\n";
+ } elsif (length $args) {
+ return "$use $module ($args);\n";
+ } else {
+ return "$use $module;\n";
+ }
+}
+
+sub stash_subs {
+ my ($self, $pack) = @_;
+ my (@ret, $stash);
+ if (!defined $pack) {
+ $pack = '';
+ $stash = \%::;
+ }
+ else {
+ $pack =~ s/(::)?$/::/;
+ no strict 'refs';
+ $stash = \%$pack;
+ }
+ my %stash = svref_2object($stash)->ARRAY;
+ while (my ($key, $val) = each %stash) {
+ next if $key eq 'main::'; # avoid infinite recursion
+ my $class = class($val);
+ if ($class eq "PV") {
+ # Just a prototype. As an ugly but fairly effective way
+ # to find out if it belongs here is to see if the AUTOLOAD
+ # (if any) for the stash was defined in one of our files.
+ my $A = $stash{"AUTOLOAD"};
+ if (defined ($A) && class($A) eq "GV" && defined($A->CV)
+ && class($A->CV) eq "CV") {
+ my $AF = $A->FILE;
+ next unless $AF eq $0 || exists $self->{'files'}{$AF};
+ }
+ push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
+ } elsif ($class eq "IV") {
+ # Just a name. As above.
+ my $A = $stash{"AUTOLOAD"};
+ if (defined ($A) && class($A) eq "GV" && defined($A->CV)
+ && class($A->CV) eq "CV") {
+ my $AF = $A->FILE;
+ next unless $AF eq $0 || exists $self->{'files'}{$AF};
+ }
+ push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "GV") {
+ if (class(my $cv = $val->CV) ne "SPECIAL") {
+ next if $self->{'subs_done'}{$$val}++;
+ next if $$val != ${$cv->GV}; # Ignore imposters
+ $self->todo($cv, 0);
+ }
+ if (class(my $cv = $val->FORM) ne "SPECIAL") {
+ next if $self->{'forms_done'}{$$val}++;
+ next if $$val != ${$cv->GV}; # Ignore imposters
+ $self->todo($cv, 1);
+ }
+ if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
+ $self->stash_subs($pack . $key);
+ }
+ }
+ }
+}
+
+sub print_protos {
+ my $self = shift;
+ my $ar;
+ my @ret;
+ foreach $ar (@{$self->{'protos_todo'}}) {
+ my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
+ push @ret, "sub " . $ar->[0] . "$proto;\n";
+ }
+ delete $self->{'protos_todo'};
+ return @ret;
+}
+
+sub style_opts {
+ my $self = shift;
+ my $opts = shift;
+ my $opt;
+ while (length($opt = substr($opts, 0, 1))) {
+ if ($opt eq "C") {
+ $self->{'cuddle'} = " ";
+ $opts = substr($opts, 1);
+ } elsif ($opt eq "i") {
+ $opts =~ s/^i(\d+)//;
+ $self->{'indent_size'} = $1;
+ } elsif ($opt eq "T") {
+ $self->{'use_tabs'} = 1;
+ $opts = substr($opts, 1);
+ } elsif ($opt eq "v") {
+ $opts =~ s/^v([^.]*)(.|$)//;
+ $self->{'ex_const'} = $1;
+ }
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->{'cuddle'} = "\n";
+ $self->{'curcop'} = undef;
+ $self->{'curstash'} = "main";
+ $self->{'ex_const'} = "'???'";
+ $self->{'expand'} = 0;
+ $self->{'files'} = {};
+ $self->{'indent_size'} = 4;
+ $self->{'linenums'} = 0;
+ $self->{'parens'} = 0;
+ $self->{'subs_todo'} = [];
+ $self->{'unquote'} = 0;
+ $self->{'use_dumper'} = 0;
+ $self->{'use_tabs'} = 0;
+
+ $self->{'ambient_arybase'} = 0;
+ $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
+ $self->{'ambient_hints'} = 0;
+ $self->init();
+
+ while (my $arg = shift @_) {
+ if ($arg eq "-d") {
+ $self->{'use_dumper'} = 1;
+ require Data::Dumper;
+ } elsif ($arg =~ /^-f(.*)/) {
+ $self->{'files'}{$1} = 1;
+ } elsif ($arg eq "-l") {
+ $self->{'linenums'} = 1;
+ } elsif ($arg eq "-p") {
+ $self->{'parens'} = 1;
+ } elsif ($arg eq "-P") {
+ $self->{'noproto'} = 1;
+ } elsif ($arg eq "-q") {
+ $self->{'unquote'} = 1;
+ } elsif (substr($arg, 0, 2) eq "-s") {
+ $self->style_opts(substr $arg, 2);
+ } elsif ($arg =~ /^-x(\d)$/) {
+ $self->{'expand'} = $1;
+ }
+ }
+ return $self;
+}
+
+{
+ # Mask out the bits that L<warnings::register> uses
+ my $WARN_MASK;
+ BEGIN {
+ $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
+ }
+ sub WARN_MASK () {
+ return $WARN_MASK;
+ }
+}
+
+# Initialise the contextual information, either from
+# defaults provided with the ambient_pragmas method,
+# or from perl's own defaults otherwise.
+sub init {
+ my $self = shift;
+
+ $self->{'arybase'} = $self->{'ambient_arybase'};
+ $self->{'warnings'} = defined ($self->{'ambient_warnings'})
+ ? $self->{'ambient_warnings'} & WARN_MASK
+ : undef;
+ $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
+
+ # also a convenient place to clear out subs_declared
+ delete $self->{'subs_declared'};
+}
+
+sub compile {
+ my(@args) = @_;
+ return sub {
+ my $self = B::Deparse->new(@args);
+ # First deparse command-line args
+ if (defined $^I) { # deparse -i
+ print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
+ }
+ if ($^W) { # deparse -w
+ print qq(BEGIN { \$^W = $^W; }\n);
+ }
+ if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
+ my $fs = perlstring($/) || 'undef';
+ my $bs = perlstring($O::savebackslash) || 'undef';
+ print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
+ }
+ my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
+ my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+ my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
+ my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
+ for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) {
+ $self->todo($block, 0);
+ }
+ $self->stash_subs();
+ local($SIG{"__DIE__"}) =
+ sub {
+ if ($self->{'curcop'}) {
+ my $cop = $self->{'curcop'};
+ my($line, $file) = ($cop->line, $cop->file);
+ print STDERR "While deparsing $file near line $line,\n";
+ }
+ };
+ $self->{'curcv'} = main_cv;
+ $self->{'curcvlex'} = undef;
+ print $self->print_protos;
+ @{$self->{'subs_todo'}} =
+ sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
+ print $self->indent($self->deparse_root(main_root)), "\n"
+ unless null main_root;
+ my @text;
+ while (scalar(@{$self->{'subs_todo'}})) {
+ push @text, $self->next_todo;
+ }
+ print $self->indent(join("", @text)), "\n" if @text;
+
+ # Print __DATA__ section, if necessary
+ no strict 'refs';
+ my $laststash = defined $self->{'curcop'}
+ ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
+ if (defined *{$laststash."::DATA"}{IO}) {
+ print "package $laststash;\n"
+ unless $laststash eq $self->{'curstash'};
+ print "__DATA__\n";
+ print readline(*{$laststash."::DATA"});
+ }
+ }
+}
+
+sub coderef2text {
+ my $self = shift;
+ my $sub = shift;
+ croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
+
+ $self->init();
+ return $self->indent($self->deparse_sub(svref_2object($sub)));
+}
+
+sub ambient_pragmas {
+ my $self = shift;
+ my ($arybase, $hint_bits, $warning_bits) = (0, 0);
+
+ while (@_ > 1) {
+ my $name = shift();
+ my $val = shift();
+
+ if ($name eq 'strict') {
+ require strict;
+
+ if ($val eq 'none') {
+ $hint_bits &= ~strict::bits(qw/refs subs vars/);
+ next();
+ }
+
+ my @names;
+ if ($val eq "all") {
+ @names = qw/refs subs vars/;
+ }
+ elsif (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split' ', $val;
+ }
+ $hint_bits |= strict::bits(@names);
+ }
+
+ elsif ($name eq '$[') {
+ $arybase = $val;
+ }
+
+ elsif ($name eq 'integer'
+ || $name eq 'bytes'
+ || $name eq 'utf8') {
+ require "$name.pm";
+ if ($val) {
+ $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
+ }
+ else {
+ $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
+ }
+ }
+
+ elsif ($name eq 're') {
+ require re;
+ if ($val eq 'none') {
+ $hint_bits &= ~re::bits(qw/taint eval/);
+ next();
+ }
+
+ my @names;
+ if ($val eq 'all') {
+ @names = qw/taint eval/;
+ }
+ elsif (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split' ',$val;
+ }
+ $hint_bits |= re::bits(@names);
+ }
+
+ elsif ($name eq 'warnings') {
+ if ($val eq 'none') {
+ $warning_bits = $warnings::NONE;
+ next();
+ }
+
+ my @names;
+ if (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split/\s+/, $val;
+ }
+
+ $warning_bits = $warnings::NONE if !defined ($warning_bits);
+ $warning_bits |= warnings::bits(@names);
+ }
+
+ elsif ($name eq 'warning_bits') {
+ $warning_bits = $val;
+ }
+
+ elsif ($name eq 'hint_bits') {
+ $hint_bits = $val;
+ }
+
+ else {
+ croak "Unknown pragma type: $name";
+ }
+ }
+ if (@_) {
+ croak "The ambient_pragmas method expects an even number of args";
+ }
+
+ $self->{'ambient_arybase'} = $arybase;
+ $self->{'ambient_warnings'} = $warning_bits;
+ $self->{'ambient_hints'} = $hint_bits;
+}
+
+# This method is the inner loop, so try to keep it simple
+sub deparse {
+ my $self = shift;
+ my($op, $cx) = @_;
+
+ Carp::confess("Null op in deparse") if !defined($op)
+ || class($op) eq "NULL";
+ my $meth = "pp_" . $op->name;
+ return $self->$meth($op, $cx);
+}
+
+sub indent {
+ my $self = shift;
+ my $txt = shift;
+ my @lines = split(/\n/, $txt);
+ my $leader = "";
+ my $level = 0;
+ my $line;
+ for $line (@lines) {
+ my $cmd = substr($line, 0, 1);
+ if ($cmd eq "\t" or $cmd eq "\b") {
+ $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
+ if ($self->{'use_tabs'}) {
+ $leader = "\t" x ($level / 8) . " " x ($level % 8);
+ } else {
+ $leader = " " x $level;
+ }
+ $line = substr($line, 1);
+ }
+ if (substr($line, 0, 1) eq "\f") {
+ $line = substr($line, 1); # no indent
+ } else {
+ $line = $leader . $line;
+ }
+ $line =~ s/\cK;?//g;
+ }
+ return join("\n", @lines);
+}
+
+sub deparse_sub {
+ my $self = shift;
+ my $cv = shift;
+ my $proto = "";
+Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
+Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
+ local $self->{'curcop'} = $self->{'curcop'};
+ if ($cv->FLAGS & SVf_POK) {
+ $proto = "(". $cv->PV . ") ";
+ }
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
+ $proto .= ": ";
+ $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
+ $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
+ $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+ $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION;
+ }
+
+ local($self->{'curcv'}) = $cv;
+ local($self->{'curcvlex'});
+ local(@$self{qw'curstash warnings hints'})
+ = @$self{qw'curstash warnings hints'};
+ my $body;
+ if (not null $cv->ROOT) {
+ my $lineseq = $cv->ROOT->first;
+ if ($lineseq->name eq "lineseq") {
+ my @ops;
+ for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
+ push @ops, $o;
+ }
+ $body = $self->lineseq(undef, @ops).";";
+ my $scope_en = $self->find_scope_en($lineseq);
+ if (defined $scope_en) {
+ my $subs = join"", $self->seq_subs($scope_en);
+ $body .= ";\n$subs" if length($subs);
+ }
+ }
+ else {
+ $body = $self->deparse($cv->ROOT->first, 0);
+ }
+ }
+ else {
+ my $sv = $cv->const_sv;
+ if ($$sv) {
+ # uh-oh. inlinable sub... format it differently
+ return $proto . "{ " . $self->const($sv, 0) . " }\n";
+ } else { # XSUB? (or just a declaration)
+ return "$proto;\n";
+ }
+ }
+ return $proto ."{\n\t$body\n\b}" ."\n";
+}
+
+sub deparse_format {
+ my $self = shift;
+ my $form = shift;
+ my @text;
+ local($self->{'curcv'}) = $form;
+ local($self->{'curcvlex'});
+ local($self->{'in_format'}) = 1;
+ local(@$self{qw'curstash warnings hints'})
+ = @$self{qw'curstash warnings hints'};
+ my $op = $form->ROOT;
+ my $kid;
+ return "\f." if $op->first->name eq 'stub'
+ || $op->first->name eq 'nextstate';
+ $op = $op->first->first; # skip leavewrite, lineseq
+ while (not null $op) {
+ $op = $op->sibling; # skip nextstate
+ my @exprs;
+ $kid = $op->first->sibling; # skip pushmark
+ push @text, "\f".$self->const_sv($kid)->PV;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 0);
+ }
+ push @text, "\f".join(", ", @exprs)."\n" if @exprs;
+ $op = $op->sibling;
+ }
+ return join("", @text) . "\f.";
+}
+
+sub is_scope {
+ my $op = shift;
+ return $op->name eq "leave" || $op->name eq "scope"
+ || $op->name eq "lineseq"
+ || ($op->name eq "null" && class($op) eq "UNOP"
+ && (is_scope($op->first) || $op->first->name eq "enter"));
+}
+
+sub is_state {
+ my $name = $_[0]->name;
+ return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
+}
+
+sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+ my $op = shift;
+ return (!null($op) and null($op->sibling)
+ and $op->name eq "null" and class($op) eq "UNOP"
+ and (($op->first->name =~ /^(and|or)$/
+ and $op->first->first->sibling->name eq "lineseq")
+ or ($op->first->name eq "lineseq"
+ and not null $op->first->first->sibling
+ and $op->first->first->sibling->name eq "unstack")
+ ));
+}
+
+# Check if the op and its sibling are the initialization and the rest of a
+# for (..;..;..) { ... } loop
+sub is_for_loop {
+ my $op = shift;
+ # This OP might be almost anything, though it won't be a
+ # nextstate. (It's the initialization, so in the canonical case it
+ # will be an sassign.) The sibling is a lineseq whose first child
+ # is a nextstate and whose second is a leaveloop.
+ my $lseq = $op->sibling;
+ if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+ if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
+ && (my $sib = $lseq->first->sibling)) {
+ return (!null($sib) && $sib->name eq "leaveloop");
+ }
+ }
+ return 0;
+}
+
+sub is_scalar {
+ my $op = shift;
+ return ($op->name eq "rv2sv" or
+ $op->name eq "padsv" or
+ $op->name eq "gv" or # only in array/hash constructs
+ $op->flags & OPf_KIDS && !null($op->first)
+ && $op->first->name eq "gvsv");
+}
+
+sub maybe_parens {
+ my $self = shift;
+ my($text, $cx, $prec) = @_;
+ if ($prec < $cx # unary ops nest just fine
+ or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
+ or $self->{'parens'})
+ {
+ $text = "($text)";
+ # In a unop, let parent reuse our parens; see maybe_parens_unop
+ $text = "\cS" . $text if $cx == 16;
+ return $text;
+ } else {
+ return $text;
+ }
+}
+
+# same as above, but get around the `if it looks like a function' rule
+sub maybe_parens_unop {
+ my $self = shift;
+ my($name, $kid, $cx) = @_;
+ if ($cx > 16 or $self->{'parens'}) {
+ $kid = $self->deparse($kid, 1);
+ if ($name eq "umask" && $kid =~ /^\d+$/) {
+ $kid = sprintf("%#o", $kid);
+ }
+ return "$name($kid)";
+ } else {
+ $kid = $self->deparse($kid, 16);
+ if ($name eq "umask" && $kid =~ /^\d+$/) {
+ $kid = sprintf("%#o", $kid);
+ }
+ if (substr($kid, 0, 1) eq "\cS") {
+ # use kid's parens
+ return $name . substr($kid, 1);
+ } elsif (substr($kid, 0, 1) eq "(") {
+ # avoid looks-like-a-function trap with extra parens
+ # (`+' can lead to ambiguities)
+ return "$name(" . $kid . ")";
+ } else {
+ return "$name $kid";
+ }
+ }
+}
+
+sub maybe_parens_func {
+ my $self = shift;
+ my($func, $text, $cx, $prec) = @_;
+ if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
+ return "$func($text)";
+ } else {
+ return "$func $text";
+ }
+}
+
+sub maybe_local {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
+ if ($op->private & (OPpLVAL_INTRO|$our_intro)
+ and not $self->{'avoid_local'}{$$op}) {
+ my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
+ if( $our_local eq 'our' ) {
+ # XXX This assertion fails code with non-ASCII identifiers,
+ # like ./ext/Encode/t/jperl.t
+ die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+ $text =~ s/(\w+::)+//;
+ }
+ if (want_scalar($op)) {
+ return "$our_local $text";
+ } else {
+ return $self->maybe_parens_func("$our_local", $text, $cx, 16);
+ }
+ } else {
+ return $text;
+ }
+}
+
+sub maybe_targmy {
+ my $self = shift;
+ my($op, $cx, $func, @args) = @_;
+ if ($op->private & OPpTARGET_MY) {
+ my $var = $self->padname($op->targ);
+ my $val = $func->($self, $op, 7, @args);
+ return $self->maybe_parens("$var = $val", $cx, 7);
+ } else {
+ return $func->($self, $op, $cx, @args);
+ }
+}
+
+sub padname_sv {
+ my $self = shift;
+ my $targ = shift;
+ return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
+}
+
+sub maybe_my {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ if (want_scalar($op)) {
+ return "my $text";
+ } else {
+ return $self->maybe_parens_func("my", $text, $cx, 16);
+ }
+ } else {
+ return $text;
+ }
+}
+
+# The following OPs don't have functions:
+
+# pp_padany -- does not exist after parsing
+
+sub AUTOLOAD {
+ if ($AUTOLOAD =~ s/^.*::pp_//) {
+ warn "unexpected OP_".uc $AUTOLOAD;
+ return "XXX";
+ } else {
+ die "Undefined subroutine $AUTOLOAD called";
+ }
+}
+
+sub DESTROY {} # Do not AUTOLOAD
+
+# $root should be the op which represents the root of whatever
+# we're sequencing here. If it's undefined, then we don't append
+# any subroutine declarations to the deparsed ops, otherwise we
+# append appropriate declarations.
+sub lineseq {
+ my($self, $root, @ops) = @_;
+ my($expr, @exprs);
+
+ my $out_cop = $self->{'curcop'};
+ my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
+ my $limit_seq;
+ if (defined $root) {
+ $limit_seq = $out_seq;
+ my $nseq;
+ $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
+ $limit_seq = $nseq if !defined($limit_seq)
+ or defined($nseq) && $nseq < $limit_seq;
+ }
+ $limit_seq = $self->{'limit_seq'}
+ if defined($self->{'limit_seq'})
+ && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
+ local $self->{'limit_seq'} = $limit_seq;
+
+ $self->walk_lineseq($root, \@ops,
+ sub { push @exprs, $_[0]} );
+
+ my $body = join(";\n", grep {length} @exprs);
+ my $subs = "";
+ if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
+ $subs = join "\n", $self->seq_subs($limit_seq);
+ }
+ return join(";\n", grep {length} $body, $subs);
+}
+
+sub scopeop {
+ my($real_block, $self, $op, $cx) = @_;
+ my $kid;
+ my @kids;
+
+ local(@$self{qw'curstash warnings hints'})
+ = @$self{qw'curstash warnings hints'} if $real_block;
+ if ($real_block) {
+ $kid = $op->first->sibling; # skip enter
+ if (is_miniwhile($kid)) {
+ my $top = $kid->first;
+ my $name = $top->name;
+ if ($name eq "and") {
+ $name = "while";
+ } elsif ($name eq "or") {
+ $name = "until";
+ } else { # no conditional -> while 1 or until 0
+ return $self->deparse($top->first, 1) . " while 1";
+ }
+ my $cond = $top->first;
+ my $body = $cond->sibling->first; # skip lineseq
+ $cond = $self->deparse($cond, 1);
+ $body = $self->deparse($body, 1);
+ return "$body $name $cond";
+ }
+ } else {
+ $kid = $op->first;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
+ return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
+ } else {
+ my $lineseq = $self->lineseq($op, @kids);
+ return (length ($lineseq) ? "$lineseq;" : "");
+ }
+}
+
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
+
+# This is a special case of scopeop and lineseq, for the case of the
+# main_root. The difference is that we print the output statements as
+# soon as we get them, for the sake of impatient users.
+sub deparse_root {
+ my $self = shift;
+ my($op) = @_;
+ local(@$self{qw'curstash warnings hints'})
+ = @$self{qw'curstash warnings hints'};
+ my @kids;
+ for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ $self->walk_lineseq($op, \@kids,
+ sub { print $self->indent($_[0].';');
+ print "\n" unless $_[1] == $#kids;
+ });
+}
+
+sub walk_lineseq {
+ my ($self, $op, $kids, $callback) = @_;
+ my @kids = @$kids;
+ for (my $i = 0; $i < @kids; $i++) {
+ my $expr = "";
+ if (is_state $kids[$i]) {
+ $expr = $self->deparse($kids[$i++], 0);
+ if ($i > $#kids) {
+ $callback->($expr, $i);
+ last;
+ }
+ }
+ if (is_for_loop($kids[$i])) {
+ $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
+ next;
+ }
+ $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr =~ s/;\n?\z//;
+ $callback->($expr, $i);
+ }
+}
+
+# The BEGIN {} is used here because otherwise this code isn't executed
+# when you run B::Deparse on itself.
+my %globalnames;
+BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
+ "ENV", "ARGV", "ARGVOUT", "_"); }
+
+sub gv_name {
+ my $self = shift;
+ my $gv = shift;
+Carp::confess() unless ref($gv) eq "B::GV";
+ my $stash = $gv->STASH->NAME;
+ my $name = $gv->SAFENAME;
+ if (($stash eq 'main' && $globalnames{$name})
+ or ($stash eq $self->{'curstash'} && !$globalnames{$name})
+ or $name =~ /^[^A-Za-z_:]/)
+ {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ if ($name =~ /^(\^..|{)/) {
+ $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
+ }
+ return $stash . $name;
+}
+
+# Return the name to use for a stash variable.
+# If a lexical with the same name is in scope, it may need to be
+# fully-qualified.
+sub stash_variable {
+ my ($self, $prefix, $name) = @_;
+
+ return "$prefix$name" if $name =~ /::/;
+
+ unless ($prefix eq '$' || $prefix eq '@' || #'
+ $prefix eq '%' || $prefix eq '$#') {
+ return "$prefix$name";
+ }
+
+ my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
+ return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
+ return "$prefix$name";
+}
+
+sub lex_in_scope {
+ my ($self, $name) = @_;
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+
+ return 0 if !defined($self->{'curcop'});
+ my $seq = $self->{'curcop'}->cop_seq;
+ return 0 if !exists $self->{'curcvlex'}{$name};
+ for my $a (@{$self->{'curcvlex'}{$name}}) {
+ my ($st, $en) = @$a;
+ return 1 if $seq > $st && $seq <= $en;
+ }
+ return 0;
+}
+
+sub populate_curcvlex {
+ my $self = shift;
+ for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
+ my $padlist = $cv->PADLIST;
+ # an undef CV still in lexical chain
+ next if class($padlist) eq "SPECIAL";
+ my @padlist = $padlist->ARRAY;
+ my @ns = $padlist[0]->ARRAY;
+
+ for (my $i=0; $i<@ns; ++$i) {
+ next if class($ns[$i]) eq "SPECIAL";
+ next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
+ if (class($ns[$i]) eq "PV") {
+ # Probably that pesky lexical @_
+ next;
+ }
+ my $name = $ns[$i]->PVX;
+ my ($seq_st, $seq_en) =
+ ($ns[$i]->FLAGS & SVf_FAKE)
+ ? (0, 999999)
+ : ($ns[$i]->NVX, $ns[$i]->IVX);
+
+ push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
+ }
+ }
+}
+
+sub find_scope_st { ((find_scope(@_))[0]); }
+sub find_scope_en { ((find_scope(@_))[1]); }
+
+# Recurses down the tree, looking for pad variable introductions and COPs
+sub find_scope {
+ my ($self, $op, $scope_st, $scope_en) = @_;
+ carp("Undefined op in find_scope") if !defined $op;
+ return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
+
+ for (my $o=$op->first; $$o; $o=$o->sibling) {
+ if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
+ my $s = int($self->padname_sv($o->targ)->NVX);
+ my $e = $self->padname_sv($o->targ)->IVX;
+ $scope_st = $s if !defined($scope_st) || $s < $scope_st;
+ $scope_en = $e if !defined($scope_en) || $e > $scope_en;
+ }
+ elsif (is_state($o)) {
+ my $c = $o->cop_seq;
+ $scope_st = $c if !defined($scope_st) || $c < $scope_st;
+ $scope_en = $c if !defined($scope_en) || $c > $scope_en;
+ }
+ elsif ($o->flags & OPf_KIDS) {
+ ($scope_st, $scope_en) =
+ $self->find_scope($o, $scope_st, $scope_en)
+ }
+ }
+
+ return ($scope_st, $scope_en);
+}
+
+# Returns a list of subs which should be inserted before the COP
+sub cop_subs {
+ my ($self, $op, $out_seq) = @_;
+ my $seq = $op->cop_seq;
+ # If we have nephews, then our sequence number indicates
+ # the cop_seq of the end of some sort of scope.
+ if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
+ and my $nseq = $self->find_scope_st($op->sibling) ) {
+ $seq = $nseq;
+ }
+ $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
+ return $self->seq_subs($seq);
+}
+
+sub seq_subs {
+ my ($self, $seq) = @_;
+ my @text;
+#push @text, "# ($seq)\n";
+
+ return "" if !defined $seq;
+ while (scalar(@{$self->{'subs_todo'}})
+ and $seq > $self->{'subs_todo'}[0][0]) {
+ push @text, $self->next_todo;
+ }
+ return @text;
+}
+
+# Notice how subs and formats are inserted between statements here;
+# also $[ assignments and pragmas.
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ $self->{'curcop'} = $op;
+ my @text;
+ push @text, $self->cop_subs($op);
+ push @text, $op->label . ": " if $op->label;
+ my $stash = $op->stashpv;
+ if ($stash ne $self->{'curstash'}) {
+ push @text, "package $stash;\n";
+ $self->{'curstash'} = $stash;
+ }
+
+ if ($self->{'arybase'} != $op->arybase) {
+ push @text, '$[ = '. $op->arybase .";\n";
+ $self->{'arybase'} = $op->arybase;
+ }
+
+ my $warnings = $op->warnings;
+ my $warning_bits;
+ if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
+ $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
+ }
+ elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
+ $warning_bits = $warnings::NONE;
+ }
+ elsif ($warnings->isa("B::SPECIAL")) {
+ $warning_bits = undef;
+ }
+ else {
+ $warning_bits = $warnings->PV & WARN_MASK;
+ }
+
+ if (defined ($warning_bits) and
+ !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
+ push @text, declare_warnings($self->{'warnings'}, $warning_bits);
+ $self->{'warnings'} = $warning_bits;
+ }
+
+ if ($self->{'hints'} != $op->private) {
+ push @text, declare_hints($self->{'hints'}, $op->private);
+ $self->{'hints'} = $op->private;
+ }
+
+ # This should go after of any branches that add statements, to
+ # increase the chances that it refers to the same line it did in
+ # the original program.
+ if ($self->{'linenums'}) {
+ push @text, "\f#line " . $op->line .
+ ' "' . $op->file, qq'"\n';
+ }
+
+ return join("", @text);
+}
+
+sub declare_warnings {
+ my ($from, $to) = @_;
+ if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
+ return "use warnings;\n";
+ }
+ elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
+ return "no warnings;\n";
+ }
+ return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
+}
+
+sub declare_hints {
+ my ($from, $to) = @_;
+ my $use = $to & ~$from;
+ my $no = $from & ~$to;
+ my $decls = "";
+ for my $pragma (hint_pragmas($use)) {
+ $decls .= "use $pragma;\n";
+ }
+ for my $pragma (hint_pragmas($no)) {
+ $decls .= "no $pragma;\n";
+ }
+ return $decls;
+}
+
+sub hint_pragmas {
+ my ($bits) = @_;
+ my @pragmas;
+ push @pragmas, "integer" if $bits & 0x1;
+ push @pragmas, "strict 'refs'" if $bits & 0x2;
+ push @pragmas, "bytes" if $bits & 0x8;
+ return @pragmas;
+}
+
+sub pp_dbstate { pp_nextstate(@_) }
+sub pp_setstate { pp_nextstate(@_) }
+
+sub pp_unstack { return "" } # see also leaveloop
+
+sub baseop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ return $name;
+}
+
+sub pp_stub {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if ($cx >= 1) {
+ return "()";
+ }
+ else {
+ return "();";
+ }
+}
+sub pp_wantarray { baseop(@_, "wantarray") }
+sub pp_fork { baseop(@_, "fork") }
+sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
+sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
+sub pp_time { maybe_targmy(@_, \&baseop, "time") }
+sub pp_tms { baseop(@_, "times") }
+sub pp_ghostent { baseop(@_, "gethostent") }
+sub pp_gnetent { baseop(@_, "getnetent") }
+sub pp_gprotoent { baseop(@_, "getprotoent") }
+sub pp_gservent { baseop(@_, "getservent") }
+sub pp_ehostent { baseop(@_, "endhostent") }
+sub pp_enetent { baseop(@_, "endnetent") }
+sub pp_eprotoent { baseop(@_, "endprotoent") }
+sub pp_eservent { baseop(@_, "endservent") }
+sub pp_gpwent { baseop(@_, "getpwent") }
+sub pp_spwent { baseop(@_, "setpwent") }
+sub pp_epwent { baseop(@_, "endpwent") }
+sub pp_ggrent { baseop(@_, "getgrent") }
+sub pp_sgrent { baseop(@_, "setgrent") }
+sub pp_egrent { baseop(@_, "endgrent") }
+sub pp_getlogin { baseop(@_, "getlogin") }
+
+sub POSTFIX () { 1 }
+
+# I couldn't think of a good short name, but this is the category of
+# symbolic unary operators with interesting precedence
+
+sub pfixop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0);
+ my $kid = $op->first;
+ $kid = $self->deparse($kid, $prec);
+ return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
+ $cx, $prec);
+}
+
+sub pp_preinc { pfixop(@_, "++", 23) }
+sub pp_predec { pfixop(@_, "--", 23) }
+sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_i_preinc { pfixop(@_, "++", 23) }
+sub pp_i_predec { pfixop(@_, "--", 23) }
+sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
+
+sub pp_negate { maybe_targmy(@_, \&real_negate) }
+sub real_negate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->name =~ /^(i_)?negate$/) {
+ # avoid --$x
+ $self->pfixop($op, $cx, "-", 21.5);
+ } else {
+ $self->pfixop($op, $cx, "-", 21);
+ }
+}
+sub pp_i_negate { pp_negate(@_) }
+
+sub pp_not {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($cx <= 4) {
+ $self->pfixop($op, $cx, "not ", 4);
+ } else {
+ $self->pfixop($op, $cx, "!", 21);
+ }
+}
+
+sub unop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ if (defined prototype("CORE::$name")
+ && prototype("CORE::$name") =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $kid = $kid->first;
+ }
+
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_defined { unop(@_, "defined") }
+sub pp_undef { unop(@_, "undef") }
+sub pp_study { unop(@_, "study") }
+sub pp_ref { unop(@_, "ref") }
+sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
+
+sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
+sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
+sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
+sub pp_srand { unop(@_, "srand") }
+sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
+sub pp_log { maybe_targmy(@_, \&unop, "log") }
+sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
+sub pp_int { maybe_targmy(@_, \&unop, "int") }
+sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
+sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
+sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
+
+sub pp_length { maybe_targmy(@_, \&unop, "length") }
+sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
+sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
+
+sub pp_each { unop(@_, "each") }
+sub pp_values { unop(@_, "values") }
+sub pp_keys { unop(@_, "keys") }
+sub pp_pop { unop(@_, "pop") }
+sub pp_shift { unop(@_, "shift") }
+
+sub pp_caller { unop(@_, "caller") }
+sub pp_reset { unop(@_, "reset") }
+sub pp_exit { unop(@_, "exit") }
+sub pp_prototype { unop(@_, "prototype") }
+
+sub pp_close { unop(@_, "close") }
+sub pp_fileno { unop(@_, "fileno") }
+sub pp_umask { unop(@_, "umask") }
+sub pp_untie { unop(@_, "untie") }
+sub pp_tied { unop(@_, "tied") }
+sub pp_dbmclose { unop(@_, "dbmclose") }
+sub pp_getc { unop(@_, "getc") }
+sub pp_eof { unop(@_, "eof") }
+sub pp_tell { unop(@_, "tell") }
+sub pp_getsockname { unop(@_, "getsockname") }
+sub pp_getpeername { unop(@_, "getpeername") }
+
+sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
+sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
+sub pp_readlink { unop(@_, "readlink") }
+sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
+sub pp_readdir { unop(@_, "readdir") }
+sub pp_telldir { unop(@_, "telldir") }
+sub pp_rewinddir { unop(@_, "rewinddir") }
+sub pp_closedir { unop(@_, "closedir") }
+sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
+sub pp_localtime { unop(@_, "localtime") }
+sub pp_gmtime { unop(@_, "gmtime") }
+sub pp_alarm { unop(@_, "alarm") }
+sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
+
+sub pp_dofile { unop(@_, "do") }
+sub pp_entereval { unop(@_, "eval") }
+
+sub pp_ghbyname { unop(@_, "gethostbyname") }
+sub pp_gnbyname { unop(@_, "getnetbyname") }
+sub pp_gpbyname { unop(@_, "getprotobyname") }
+sub pp_shostent { unop(@_, "sethostent") }
+sub pp_snetent { unop(@_, "setnetent") }
+sub pp_sprotoent { unop(@_, "setprotoent") }
+sub pp_sservent { unop(@_, "setservent") }
+sub pp_gpwnam { unop(@_, "getpwnam") }
+sub pp_gpwuid { unop(@_, "getpwuid") }
+sub pp_ggrnam { unop(@_, "getgrnam") }
+sub pp_ggrgid { unop(@_, "getgrgid") }
+
+sub pp_lock { unop(@_, "lock") }
+
+sub pp_exists {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpEXISTS_SUB) {
+ # Checking for the existence of a subroutine
+ return $self->maybe_parens_func("exists",
+ $self->pp_rv2cv($op->first, 16), $cx, 16);
+ }
+ if ($op->flags & OPf_SPECIAL) {
+ # Array element, not hash element
+ return $self->maybe_parens_func("exists",
+ $self->pp_aelem($op->first, 16), $cx, 16);
+ }
+ return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ $cx, 16);
+}
+
+sub pp_delete {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpSLICE) {
+ if ($op->flags & OPf_SPECIAL) {
+ # Deleting from an array, not a hash
+ return $self->maybe_parens_func("delete",
+ $self->pp_aslice($op->first, 16),
+ $cx, 16);
+ }
+ return $self->maybe_parens_func("delete",
+ $self->pp_hslice($op->first, 16),
+ $cx, 16);
+ } else {
+ if ($op->flags & OPf_SPECIAL) {
+ # Deleting from an array, not a hash
+ return $self->maybe_parens_func("delete",
+ $self->pp_aelem($op->first, 16),
+ $cx, 16);
+ }
+ return $self->maybe_parens_func("delete",
+ $self->pp_helem($op->first, 16),
+ $cx, 16);
+ }
+}
+
+sub pp_require {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
+ if (class($op) eq "UNOP" and $op->first->name eq "const"
+ and $op->first->private & OPpCONST_BARE)
+ {
+ my $name = $self->const_sv($op->first)->PV;
+ $name =~ s[/][::]g;
+ $name =~ s/\.pm//g;
+ return "$opname $name";
+ } else {
+ $self->unop($op, $cx, $opname);
+ }
+}
+
+sub pp_scalar {
+ my $self = shift;
+ my($op, $cv) = @_;
+ my $kid = $op->first;
+ if (not null $kid->sibling) {
+ # XXX Was a here-doc
+ return $self->dquote($op);
+ }
+ $self->unop(@_, "scalar");
+}
+
+
+sub padval {
+ my $self = shift;
+ my $targ = shift;
+ return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
+}
+
+sub pp_refgen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->name eq "null") {
+ $kid = $kid->first;
+ if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
+ my($pre, $post) = @{{"anonlist" => ["[","]"],
+ "anonhash" => ["{","}"]}->{$kid->name}};
+ my($expr, @exprs);
+ $kid = $kid->first->sibling; # skip pushmark
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr;
+ }
+ return $pre . join(", ", @exprs) . $post;
+ } elsif (!null($kid->sibling) and
+ $kid->sibling->name eq "anoncode") {
+ return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
+ } elsif ($kid->name eq "pushmark") {
+ my $sib_name = $kid->sibling->name;
+ if ($sib_name =~ /^(pad|rv2)[ah]v$/
+ and not $kid->sibling->flags & OPf_REF)
+ {
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ return "\\(" . $self->pp_list($op->first) . ")";
+ } elsif ($sib_name eq 'entersub') {
+ my $text = $self->deparse($kid->sibling, 1);
+ # Always show parens for \(&func()), but only with -p otherwise
+ $text = "($text)" if $self->{'parens'}
+ or $kid->sibling->private & OPpENTERSUB_AMPER;
+ return "\\$text";
+ }
+ }
+ }
+ $self->pfixop($op, $cx, "\\", 20);
+}
+
+sub e_anoncode {
+ my ($self, $info) = @_;
+ my $text = $self->deparse_sub($info->{code});
+ return "sub " . $text;
+}
+
+sub pp_srefgen { pp_refgen(@_) }
+
+sub pp_readline {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
+ return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
+ return $self->unop($op, $cx, "readline");
+}
+
+sub pp_rcatline {
+ my $self = shift;
+ my($op) = @_;
+ return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
+}
+
+# Unary operators that can occur as pseudo-listops inside double quotes
+sub dq_unop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ # If there's more than one kid, the first is an ex-pushmark.
+ $kid = $kid->sibling if not null $kid->sibling;
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_ucfirst { dq_unop(@_, "ucfirst") }
+sub pp_lcfirst { dq_unop(@_, "lcfirst") }
+sub pp_uc { dq_unop(@_, "uc") }
+sub pp_lc { dq_unop(@_, "lc") }
+sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
+
+sub loopex {
+ my $self = shift;
+ my ($op, $cx, $name) = @_;
+ if (class($op) eq "PVOP") {
+ return "$name " . $op->pv;
+ } elsif (class($op) eq "OP") {
+ return $name;
+ } elsif (class($op) eq "UNOP") {
+ # Note -- loop exits are actually exempt from the
+ # looks-like-a-func rule, but a few extra parens won't hurt
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ }
+}
+
+sub pp_last { loopex(@_, "last") }
+sub pp_next { loopex(@_, "next") }
+sub pp_redo { loopex(@_, "redo") }
+sub pp_goto { loopex(@_, "goto") }
+sub pp_dump { loopex(@_, "dump") }
+
+sub ftst {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if (class($op) eq "UNOP") {
+ # Genuine `-X' filetests are exempt from the LLAFR, but not
+ # l?stat(); for the sake of clarity, give'em all parens
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ } elsif (class($op) =~ /^(SV|PAD)OP$/) {
+ return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
+ } else { # I don't think baseop filetests ever survive ck_ftst, but...
+ return $name;
+ }
+}
+
+sub pp_lstat { ftst(@_, "lstat") }
+sub pp_stat { ftst(@_, "stat") }
+sub pp_ftrread { ftst(@_, "-R") }
+sub pp_ftrwrite { ftst(@_, "-W") }
+sub pp_ftrexec { ftst(@_, "-X") }
+sub pp_fteread { ftst(@_, "-r") }
+sub pp_ftewrite { ftst(@_, "-w") }
+sub pp_fteexec { ftst(@_, "-x") }
+sub pp_ftis { ftst(@_, "-e") }
+sub pp_fteowned { ftst(@_, "-O") }
+sub pp_ftrowned { ftst(@_, "-o") }
+sub pp_ftzero { ftst(@_, "-z") }
+sub pp_ftsize { ftst(@_, "-s") }
+sub pp_ftmtime { ftst(@_, "-M") }
+sub pp_ftatime { ftst(@_, "-A") }
+sub pp_ftctime { ftst(@_, "-C") }
+sub pp_ftsock { ftst(@_, "-S") }
+sub pp_ftchr { ftst(@_, "-c") }
+sub pp_ftblk { ftst(@_, "-b") }
+sub pp_ftfile { ftst(@_, "-f") }
+sub pp_ftdir { ftst(@_, "-d") }
+sub pp_ftpipe { ftst(@_, "-p") }
+sub pp_ftlink { ftst(@_, "-l") }
+sub pp_ftsuid { ftst(@_, "-u") }
+sub pp_ftsgid { ftst(@_, "-g") }
+sub pp_ftsvtx { ftst(@_, "-k") }
+sub pp_fttty { ftst(@_, "-t") }
+sub pp_fttext { ftst(@_, "-T") }
+sub pp_ftbinary { ftst(@_, "-B") }
+
+sub SWAP_CHILDREN () { 1 }
+sub ASSIGN () { 2 } # has OP= variant
+sub LIST_CONTEXT () { 4 } # Assignment is in list context
+
+my(%left, %right);
+
+sub assoc_class {
+ my $op = shift;
+ my $name = $op->name;
+ if ($name eq "concat" and $op->first->name eq "concat") {
+ # avoid spurious `=' -- see comment in pp_concat
+ return "concat";
+ }
+ if ($name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|x?or)$/
+ and null $op->first->sibling)
+ {
+ # Like all conditional constructs, OP_ANDs and OP_ORs are topped
+ # with a null that's used as the common end point of the two
+ # flows of control. For precedence purposes, ignore it.
+ # (COND_EXPRs have these too, but we don't bother with
+ # their associativity).
+ return assoc_class($op->first);
+ }
+ return $name . ($op->flags & OPf_STACKED ? "=" : "");
+}
+
+# Left associative operators, like `+', for which
+# $a + $b + $c is equivalent to ($a + $b) + $c
+
+BEGIN {
+ %left = ('multiply' => 19, 'i_multiply' => 19,
+ 'divide' => 19, 'i_divide' => 19,
+ 'modulo' => 19, 'i_modulo' => 19,
+ 'repeat' => 19,
+ 'add' => 18, 'i_add' => 18,
+ 'subtract' => 18, 'i_subtract' => 18,
+ 'concat' => 18,
+ 'left_shift' => 17, 'right_shift' => 17,
+ 'bit_and' => 13,
+ 'bit_or' => 12, 'bit_xor' => 12,
+ 'and' => 3,
+ 'or' => 2, 'xor' => 2,
+ );
+}
+
+sub deparse_binop_left {
+ my $self = shift;
+ my($op, $left, $prec) = @_;
+ if ($left{assoc_class($op)} && $left{assoc_class($left)}
+ and $left{assoc_class($op)} == $left{assoc_class($left)})
+ {
+ return $self->deparse($left, $prec - .00001);
+ } else {
+ return $self->deparse($left, $prec);
+ }
+}
+
+# Right associative operators, like `=', for which
+# $a = $b = $c is equivalent to $a = ($b = $c)
+
+BEGIN {
+ %right = ('pow' => 22,
+ 'sassign=' => 7, 'aassign=' => 7,
+ 'multiply=' => 7, 'i_multiply=' => 7,
+ 'divide=' => 7, 'i_divide=' => 7,
+ 'modulo=' => 7, 'i_modulo=' => 7,
+ 'repeat=' => 7,
+ 'add=' => 7, 'i_add=' => 7,
+ 'subtract=' => 7, 'i_subtract=' => 7,
+ 'concat=' => 7,
+ 'left_shift=' => 7, 'right_shift=' => 7,
+ 'bit_and=' => 7,
+ 'bit_or=' => 7, 'bit_xor=' => 7,
+ 'andassign' => 7,
+ 'orassign' => 7,
+ );
+}
+
+sub deparse_binop_right {
+ my $self = shift;
+ my($op, $right, $prec) = @_;
+ if ($right{assoc_class($op)} && $right{assoc_class($right)}
+ and $right{assoc_class($op)} == $right{assoc_class($right)})
+ {
+ return $self->deparse($right, $prec - .00001);
+ } else {
+ return $self->deparse($right, $prec);
+ }
+}
+
+sub binop {
+ my $self = shift;
+ my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if ($flags & SWAP_CHILDREN) {
+ ($left, $right) = ($right, $left);
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $left = "($left)" if $flags & LIST_CONTEXT
+ && $left !~ /^(my|our|local|)[\@\(]/;
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
+}
+
+sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
+sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
+sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
+
+sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
+sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
+sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
+sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
+sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
+
+sub pp_eq { binop(@_, "==", 14) }
+sub pp_ne { binop(@_, "!=", 14) }
+sub pp_lt { binop(@_, "<", 15) }
+sub pp_gt { binop(@_, ">", 15) }
+sub pp_ge { binop(@_, ">=", 15) }
+sub pp_le { binop(@_, "<=", 15) }
+sub pp_ncmp { binop(@_, "<=>", 14) }
+sub pp_i_eq { binop(@_, "==", 14) }
+sub pp_i_ne { binop(@_, "!=", 14) }
+sub pp_i_lt { binop(@_, "<", 15) }
+sub pp_i_gt { binop(@_, ">", 15) }
+sub pp_i_ge { binop(@_, ">=", 15) }
+sub pp_i_le { binop(@_, "<=", 15) }
+sub pp_i_ncmp { binop(@_, "<=>", 14) }
+
+sub pp_seq { binop(@_, "eq", 14) }
+sub pp_sne { binop(@_, "ne", 14) }
+sub pp_slt { binop(@_, "lt", 15) }
+sub pp_sgt { binop(@_, "gt", 15) }
+sub pp_sge { binop(@_, "ge", 15) }
+sub pp_sle { binop(@_, "le", 15) }
+sub pp_scmp { binop(@_, "cmp", 14) }
+
+sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
+sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
+
+# `.' is special because concats-of-concats are optimized to save copying
+# by making all but the first concat stacked. The effect is as if the
+# programmer had written `($a . $b) .= $c', except legal.
+sub pp_concat { maybe_targmy(@_, \&real_concat) }
+sub real_concat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 18;
+ if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
+ $eq = "=";
+ $prec = 7;
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left .$eq $right", $cx, $prec);
+}
+
+# `x' is weird when the left arg is a list
+sub pp_repeat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 19;
+ if ($op->flags & OPf_STACKED) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if (null($right)) { # list repeat; count is inside left-side ex-list
+ my $kid = $left->first->sibling; # skip pushmark
+ my @exprs;
+ for (; !null($kid->sibling); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ $right = $kid;
+ $left = "(" . join(", ", @exprs). ")";
+ } else {
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ }
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left x$eq $right", $cx, $prec);
+}
+
+sub range {
+ my $self = shift;
+ my ($op, $cx, $type) = @_;
+ my $left = $op->first;
+ my $right = $left->sibling;
+ $left = $self->deparse($left, 9);
+ $right = $self->deparse($right, 9);
+ return $self->maybe_parens("$left $type $right", $cx, 9);
+}
+
+sub pp_flop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $flip = $op->first;
+ my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
+ return $self->range($flip->first, $cx, $type);
+}
+
+# one-line while/until is handled in pp_leave
+
+sub logop {
+ my $self = shift;
+ my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling;
+ if ($cx < 1 and is_scope($right) and $blockname
+ and $self->{'expand'} < 7)
+ { # if ($a) {$b}
+ $left = $self->deparse($left, 1);
+ $right = $self->deparse($right, 0);
+ return "$blockname ($left) {\n\t$right\n\b}\cK";
+ } elsif ($cx < 1 and $blockname and not $self->{'parens'}
+ and $self->{'expand'} < 7) { # $b if $a
+ $right = $self->deparse($right, 1);
+ $left = $self->deparse($left, 1);
+ return "$right $blockname $left";
+ } elsif ($cx > $lowprec and $highop) { # $a && $b
+ $left = $self->deparse_binop_left($op, $left, $highprec);
+ $right = $self->deparse_binop_right($op, $right, $highprec);
+ return $self->maybe_parens("$left $highop $right", $cx, $highprec);
+ } else { # $a and $b
+ $left = $self->deparse_binop_left($op, $left, $lowprec);
+ $right = $self->deparse_binop_right($op, $right, $lowprec);
+ return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
+ }
+}
+
+sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
+sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
+sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
+
+# xor is syntactically a logop, but it's really a binop (contrary to
+# old versions of opcode.pl). Syntax is what matters here.
+sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
+
+sub logassignop {
+ my $self = shift;
+ my ($op, $cx, $opname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling->first; # skip sassign
+ $left = $self->deparse($left, 7);
+ $right = $self->deparse($right, 7);
+ return $self->maybe_parens("$left $opname $right", $cx, 7);
+}
+
+sub pp_andassign { logassignop(@_, "&&=") }
+sub pp_orassign { logassignop(@_, "||=") }
+sub pp_dorassign { logassignop(@_, "//=") }
+
+sub listop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ return $name if null $kid;
+ my $first;
+ $name = "socketpair" if $name eq "sockpair";
+ my $proto = prototype("CORE::$name");
+ if (defined $proto
+ && $proto =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $first = $self->deparse($kid->first, 6);
+ }
+ else {
+ $first = $self->deparse($kid, 6);
+ }
+ if ($name eq "chmod" && $first =~ /^\d+$/) {
+ $first = sprintf("%#o", $first);
+ }
+ $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
+ push @exprs, $first;
+ $kid = $kid->sibling;
+ if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
+ push @exprs, $self->deparse($kid->first, 6);
+ $kid = $kid->sibling;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ if ($parens) {
+ return "$name(" . join(", ", @exprs) . ")";
+ } else {
+ return "$name " . join(", ", @exprs);
+ }
+}
+
+sub pp_bless { listop(@_, "bless") }
+sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
+sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
+sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_index { maybe_targmy(@_, \&listop, "index") }
+sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
+sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
+sub pp_formline { listop(@_, "formline") } # see also deparse_format
+sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
+sub pp_unpack { listop(@_, "unpack") }
+sub pp_pack { listop(@_, "pack") }
+sub pp_join { maybe_targmy(@_, \&listop, "join") }
+sub pp_splice { listop(@_, "splice") }
+sub pp_push { maybe_targmy(@_, \&listop, "push") }
+sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
+sub pp_reverse { listop(@_, "reverse") }
+sub pp_warn { listop(@_, "warn") }
+sub pp_die { listop(@_, "die") }
+# Actually, return is exempt from the LLAFR (see examples in this very
+# module!), but for consistency's sake, ignore that fact
+sub pp_return { listop(@_, "return") }
+sub pp_open { listop(@_, "open") }
+sub pp_pipe_op { listop(@_, "pipe") }
+sub pp_tie { listop(@_, "tie") }
+sub pp_binmode { listop(@_, "binmode") }
+sub pp_dbmopen { listop(@_, "dbmopen") }
+sub pp_sselect { listop(@_, "select") }
+sub pp_select { listop(@_, "select") }
+sub pp_read { listop(@_, "read") }
+sub pp_sysopen { listop(@_, "sysopen") }
+sub pp_sysseek { listop(@_, "sysseek") }
+sub pp_sysread { listop(@_, "sysread") }
+sub pp_syswrite { listop(@_, "syswrite") }
+sub pp_send { listop(@_, "send") }
+sub pp_recv { listop(@_, "recv") }
+sub pp_seek { listop(@_, "seek") }
+sub pp_fcntl { listop(@_, "fcntl") }
+sub pp_ioctl { listop(@_, "ioctl") }
+sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
+sub pp_socket { listop(@_, "socket") }
+sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_bind { listop(@_, "bind") }
+sub pp_connect { listop(@_, "connect") }
+sub pp_listen { listop(@_, "listen") }
+sub pp_accept { listop(@_, "accept") }
+sub pp_shutdown { listop(@_, "shutdown") }
+sub pp_gsockopt { listop(@_, "getsockopt") }
+sub pp_ssockopt { listop(@_, "setsockopt") }
+sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
+sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
+sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
+sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
+sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
+sub pp_link { maybe_targmy(@_, \&listop, "link") }
+sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
+sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
+sub pp_open_dir { listop(@_, "opendir") }
+sub pp_seekdir { listop(@_, "seekdir") }
+sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
+sub pp_system { maybe_targmy(@_, \&listop, "system") }
+sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
+sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
+sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
+sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
+sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
+sub pp_shmget { listop(@_, "shmget") }
+sub pp_shmctl { listop(@_, "shmctl") }
+sub pp_shmread { listop(@_, "shmread") }
+sub pp_shmwrite { listop(@_, "shmwrite") }
+sub pp_msgget { listop(@_, "msgget") }
+sub pp_msgctl { listop(@_, "msgctl") }
+sub pp_msgsnd { listop(@_, "msgsnd") }
+sub pp_msgrcv { listop(@_, "msgrcv") }
+sub pp_semget { listop(@_, "semget") }
+sub pp_semctl { listop(@_, "semctl") }
+sub pp_semop { listop(@_, "semop") }
+sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
+sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
+sub pp_gpbynumber { listop(@_, "getprotobynumber") }
+sub pp_gsbyname { listop(@_, "getservbyname") }
+sub pp_gsbyport { listop(@_, "getservbyport") }
+sub pp_syscall { listop(@_, "syscall") }
+
+sub pp_glob {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $text = $self->dq($op->first->sibling); # skip pushmark
+ if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
+ or $text =~ /[<>]/) {
+ return 'glob(' . single_delim('qq', '"', $text) . ')';
+ } else {
+ return '<' . $text . '>';
+ }
+}
+
+# Truncate is special because OPf_SPECIAL makes a bareword first arg
+# be a filehandle. This could probably be better fixed in the core
+# by moving the GV lookup into ck_truc.
+
+sub pp_truncate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ my $fh;
+ if ($op->flags & OPf_SPECIAL) {
+ # $kid is an OP_CONST
+ $fh = $self->const_sv($kid)->PV;
+ } else {
+ $fh = $self->deparse($kid, 6);
+ $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
+ }
+ my $len = $self->deparse($kid->sibling, 6);
+ if ($parens) {
+ return "truncate($fh, $len)";
+ } else {
+ return "truncate $fh, $len";
+ }
+}
+
+sub indirop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling;
+ my $indir = "";
+ if ($op->flags & OPf_STACKED) {
+ $indir = $kid;
+ $indir = $indir->first; # skip rv2gv
+ if (is_scope($indir)) {
+ $indir = "{" . $self->deparse($indir, 0) . "}";
+ $indir = "{;}" if $indir eq "{}";
+ } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
+ $indir = $self->const_sv($indir)->PV;
+ } else {
+ $indir = $self->deparse($indir, 24);
+ }
+ $indir = $indir . " ";
+ $kid = $kid->sibling;
+ }
+ if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
+ $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
+ : '{$a <=> $b} ';
+ }
+ elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
+ $indir = '{$b cmp $a} ';
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr;
+ }
+ my $name2 = $name;
+ if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
+ $name2 = 'reverse sort';
+ }
+ if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
+ return "$exprs[0] = $name2 $indir $exprs[0]";
+ }
+
+ my $args = $indir . join(", ", @exprs);
+ if ($indir ne "" and $name eq "sort") {
+ # We don't want to say "sort(f 1, 2, 3)", since perl -w will
+ # give bareword warnings in that case. Therefore if context
+ # requires, we'll put parens around the outside "(sort f 1, 2,
+ # 3)". Unfortunately, we'll currently think the parens are
+ # necessary more often that they really are, because we don't
+ # distinguish which side of an assignment we're on.
+ if ($cx >= 5) {
+ return "($name2 $args)";
+ } else {
+ return "$name2 $args";
+ }
+ } else {
+ return $self->maybe_parens_func($name2, $args, $cx, 5);
+ }
+
+}
+
+sub pp_prtf { indirop(@_, "printf") }
+sub pp_print { indirop(@_, "print") }
+sub pp_sort { indirop(@_, "sort") }
+
+sub mapop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first; # this is the (map|grep)start
+ $kid = $kid->first->sibling; # skip a pushmark
+ my $code = $kid->first; # skip a null
+ if (is_scope $code) {
+ $code = "{" . $self->deparse($code, 0) . "} ";
+ } else {
+ $code = $self->deparse($code, 24) . ", ";
+ }
+ $kid = $kid->sibling;
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr if defined $expr;
+ }
+ return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+}
+
+sub pp_mapwhile { mapop(@_, "map") }
+sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapstart { baseop(@_, "map") }
+sub pp_grepstart { baseop(@_, "grep") }
+
+sub pp_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling; # skip pushmark
+ my $lop;
+ my $local = "either"; # could be local(...), my(...) or our(...)
+ for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
+ # This assumes that no other private flags equal 128, and that
+ # OPs that store things other than flags in their op_private,
+ # like OP_AELEMFAST, won't be immediate children of a list.
+ #
+ # OP_ENTERSUB can break this logic, so check for it.
+ # I suspect that open and exit can too.
+
+ if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
+ or $lop->name eq "undef")
+ or $lop->name eq "entersub"
+ or $lop->name eq "exit"
+ or $lop->name eq "open")
+ {
+ $local = ""; # or not
+ last;
+ }
+ if ($lop->name =~ /^pad[ash]v$/) { # my()
+ ($local = "", last) if $local eq "local" || $local eq "our";
+ $local = "my";
+ } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
+ && $lop->private & OPpOUR_INTRO
+ or $lop->name eq "null" && $lop->first->name eq "gvsv"
+ && $lop->first->private & OPpOUR_INTRO) { # our()
+ ($local = "", last) if $local eq "my" || $local eq "local";
+ $local = "our";
+ } elsif ($lop->name ne "undef"
+ # specifically avoid the "reverse sort" optimisation,
+ # where "reverse" is nullified
+ && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ {
+ # local()
+ ($local = "", last) if $local eq "my" || $local eq "our";
+ $local = "local";
+ }
+ }
+ $local = "" if $local eq "either"; # no point if it's all undefs
+ return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
+ for (; !null($kid); $kid = $kid->sibling) {
+ if ($local) {
+ if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
+ $lop = $kid->first;
+ } else {
+ $lop = $kid;
+ }
+ $self->{'avoid_local'}{$$lop}++;
+ $expr = $self->deparse($kid, 6);
+ delete $self->{'avoid_local'}{$$lop};
+ } else {
+ $expr = $self->deparse($kid, 6);
+ }
+ push @exprs, $expr;
+ }
+ if ($local) {
+ return "$local(" . join(", ", @exprs) . ")";
+ } else {
+ return $self->maybe_parens( join(", ", @exprs), $cx, 6);
+ }
+}
+
+sub is_ifelse_cont {
+ my $op = shift;
+ return ($op->name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|cond_expr)$/
+ and is_scope($op->first->first->sibling));
+}
+
+sub pp_cond_expr {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+ my $false = $true->sibling;
+ my $cuddle = $self->{'cuddle'};
+ unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
+ (is_scope($false) || is_ifelse_cont($false))
+ and $self->{'expand'} < 7) {
+ $cond = $self->deparse($cond, 8);
+ $true = $self->deparse($true, 8);
+ $false = $self->deparse($false, 8);
+ return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
+ }
+
+ $cond = $self->deparse($cond, 1);
+ $true = $self->deparse($true, 0);
+ my $head = "if ($cond) {\n\t$true\n\b}";
+ my @elsifs;
+ while (!null($false) and is_ifelse_cont($false)) {
+ my $newop = $false->first;
+ my $newcond = $newop->first;
+ my $newtrue = $newcond->sibling;
+ $false = $newtrue->sibling; # last in chain is OP_AND => no else
+ $newcond = $self->deparse($newcond, 1);
+ $newtrue = $self->deparse($newtrue, 0);
+ push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ }
+ if (!null($false)) {
+ $false = $cuddle . "else {\n\t" .
+ $self->deparse($false, 0) . "\n\b}\cK";
+ } else {
+ $false = "\cK";
+ }
+ return $head . join($cuddle, "", @elsifs) . $false;
+}
+
+sub loop_common {
+ my $self = shift;
+ my($op, $cx, $init) = @_;
+ my $enter = $op->first;
+ my $kid = $enter->sibling;
+ local(@$self{qw'curstash warnings hints'})
+ = @$self{qw'curstash warnings hints'};
+ my $head = "";
+ my $bare = 0;
+ my $body;
+ my $cond = undef;
+ if ($kid->name eq "lineseq") { # bare or infinite loop
+ if ($kid->last->name eq "unstack") { # infinite
+ $head = "while (1) "; # Can't use for(;;) if there's a continue
+ $cond = "";
+ } else {
+ $bare = 1;
+ }
+ $body = $kid;
+ } elsif ($enter->name eq "enteriter") { # foreach
+ my $ary = $enter->first->sibling; # first was pushmark
+ my $var = $ary->sibling;
+ if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
+ # "reverse" was optimised away
+ $ary = listop($self, $ary->first->sibling, 1, 'reverse');
+ } elsif ($enter->flags & OPf_STACKED
+ and not null $ary->first->sibling->sibling)
+ {
+ $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
+ $self->deparse($ary->first->sibling->sibling, 9);
+ } else {
+ $ary = $self->deparse($ary, 1);
+ }
+ if (null $var) {
+ if ($enter->flags & OPf_SPECIAL) { # thread special var
+ $var = $self->pp_threadsv($enter, 1);
+ } else { # regular my() variable
+ $var = $self->pp_padsv($enter, 1);
+ }
+ } elsif ($var->name eq "rv2gv") {
+ $var = $self->pp_rv2sv($var, 1);
+ if ($enter->private & OPpOUR_INTRO) {
+ # our declarations don't have package names
+ $var =~ s/^(.).*::/$1/;
+ $var = "our $var";
+ }
+ } elsif ($var->name eq "gv") {
+ $var = "\$" . $self->deparse($var, 1);
+ }
+ $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+ if (!is_state $body->first and $body->first->name ne "stub") {
+ confess unless $var eq '$_';
+ $body = $body->first;
+ return $self->deparse($body, 2) . " foreach ($ary)";
+ }
+ $head = "foreach $var ($ary) ";
+ } elsif ($kid->name eq "null") { # while/until
+ $kid = $kid->first;
+ my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+ $cond = $self->deparse($kid->first, 1);
+ $head = "$name ($cond) ";
+ $body = $kid->first->sibling;
+ } elsif ($kid->name eq "stub") { # bare and empty
+ return "{;}"; # {} could be a hashref
+ }
+ # If there isn't a continue block, then the next pointer for the loop
+ # will point to the unstack, which is kid's last child, except
+ # in a bare loop, when it will point to the leaveloop. When neither of
+ # these conditions hold, then the second-to-last child is the continue
+ # block (or the last in a bare loop).
+ my $cont_start = $enter->nextop;
+ my $cont;
+ if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
+ if ($bare) {
+ $cont = $body->last;
+ } else {
+ $cont = $body->first;
+ while (!null($cont->sibling->sibling)) {
+ $cont = $cont->sibling;
+ }
+ }
+ my $state = $body->first;
+ my $cuddle = $self->{'cuddle'};
+ my @states;
+ for (; $$state != $$cont; $state = $state->sibling) {
+ push @states, $state;
+ }
+ $body = $self->lineseq(undef, @states);
+ if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+ $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+ $cont = "\cK";
+ } else {
+ $cont = $cuddle . "continue {\n\t" .
+ $self->deparse($cont, 0) . "\n\b}\cK";
+ }
+ } else {
+ return "" if !defined $body;
+ if (length $init) {
+ $head = "for ($init; $cond;) ";
+ }
+ $cont = "\cK";
+ $body = $self->deparse($body, 0);
+ }
+ $body =~ s/;?$/;\n/;
+
+ return $head . "{\n\t" . $body . "\b}" . $cont;
+}
+
+sub pp_leaveloop { loop_common(@_, "") }
+
+sub for_loop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $init = $self->deparse($op, 1);
+ return $self->loop_common($op->sibling->first->sibling, $cx, $init);
+}
+
+sub pp_leavetry {
+ my $self = shift;
+ return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
+}
+
+BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
+BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
+BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
+BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
+
+sub pp_null {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if (class($op) eq "OP") {
+ # old value is lost
+ return $self->{'ex_const'} if $op->targ == OP_CONST;
+ } elsif ($op->first->name eq "pushmark") {
+ return $self->pp_list($op, $cx);
+ } elsif ($op->first->name eq "enter") {
+ return $self->pp_leave($op, $cx);
+ } elsif ($op->targ == OP_STRINGIFY) {
+ return $self->dquote($op, $cx);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "readline" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 7) . " = "
+ . $self->deparse($op->first->sibling, 7),
+ $cx, 7);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "trans" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
+ . $self->deparse($op->first->sibling, 20),
+ $cx, 20);
+ } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
+ return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "null" and
+ class($op->first->sibling) eq "UNOP" and
+ $op->first->sibling->first->flags & OPf_STACKED and
+ $op->first->sibling->first->name eq "rcatline") {
+ return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
+ . $self->deparse($op->first->sibling, 18),
+ $cx, 18);
+ } else {
+ return $self->deparse($op->first, $cx);
+ }
+}
+
+sub padname {
+ my $self = shift;
+ my $targ = shift;
+ return $self->padname_sv($targ)->PVX;
+}
+
+sub padany {
+ my $self = shift;
+ my $op = shift;
+ return substr($self->padname($op->targ), 1); # skip $/@/%
+}
+
+sub pp_padsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_my($op, $cx, $self->padname($op->targ));
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+my @threadsv_names;
+
+BEGIN {
+ @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
+ "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
+ "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
+ "!", "@");
+}
+
+sub pp_threadsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
+}
+
+sub gv_or_padgv {
+ my $self = shift;
+ my $op = shift;
+ if (class($op) eq "PADOP") {
+ return $self->padval($op->padix);
+ } else { # class($op) eq "SVOP"
+ return $op->gv;
+ }
+}
+
+sub pp_gvsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $self->gv_or_padgv($op);
+ return $self->maybe_local($op, $cx, $self->stash_variable("\$",
+ $self->gv_name($gv)));
+}
+
+sub pp_gv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $self->gv_or_padgv($op);
+ return $self->gv_name($gv);
+}
+
+sub pp_aelemfast {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $name;
+ if ($op->flags & OPf_SPECIAL) { # optimised PADAV
+ $name = $self->padname($op->targ);
+ $name =~ s/^@/\$/;
+ }
+ else {
+ my $gv = $self->gv_or_padgv($op);
+ $name = $self->gv_name($gv);
+ $name = $self->{'curstash'}."::$name"
+ if $name !~ /::/ && $self->lex_in_scope('@'.$name);
+ $name = '$' . $name;
+ }
+
+ return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+}
+
+sub rv2x {
+ my $self = shift;
+ my($op, $cx, $type) = @_;
+
+ if (class($op) eq 'NULL' || !$op->can("first")) {
+ carp("Unexpected op in pp_rv2x");
+ return 'XXX';
+ }
+ my $kid = $op->first;
+ if ($kid->name eq "gv") {
+ return $self->stash_variable($type, $self->deparse($kid, 0));
+ } elsif (is_scalar $kid) {
+ my $str = $self->deparse($kid, 0);
+ if ($str =~ /^\$([^\w\d])\z/) {
+ # "$$+" isn't a legal way to write the scalar dereference
+ # of $+, since the lexer can't tell you aren't trying to
+ # do something like "$$ + 1" to get one more than your
+ # PID. Either "${$+}" or "$${+}" are workable
+ # disambiguations, but if the programmer did the former,
+ # they'd be in the "else" clause below rather than here.
+ # It's not clear if this should somehow be unified with
+ # the code in dq and re_dq that also adds lexer
+ # disambiguation braces.
+ $str = '$' . "{$1}"; #'
+ }
+ return $type . $str;
+ } else {
+ return $type . "{" . $self->deparse($kid, 0) . "}";
+ }
+}
+
+sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
+sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
+sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
+
+# skip rv2av
+sub pp_av2arylen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->name eq "padav") {
+ return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
+ } else {
+ return $self->maybe_local($op, $cx,
+ $self->rv2x($op->first, $cx, '$#'));
+ }
+}
+
+# skip down to the old, ex-rv2cv
+sub pp_rv2cv {
+ my ($self, $op, $cx) = @_;
+ if (!null($op->first) && $op->first->name eq 'null' &&
+ $op->first->targ eq OP_LIST)
+ {
+ return $self->rv2x($op->first->first->sibling, $cx, "&")
+ }
+ else {
+ return $self->rv2x($op, $cx, "")
+ }
+}
+
+sub list_const {
+ my $self = shift;
+ my($cx, @list) = @_;
+ my @a = map $self->const($_, 6), @list;
+ if (@a == 0) {
+ return "()";
+ } elsif (@a == 1) {
+ return $a[0];
+ } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
+ # collapse (-1,0,1,2) into (-1..2)
+ my ($s, $e) = @a[0,-1];
+ my $i = $s;
+ return $self->maybe_parens("$s..$e", $cx, 9)
+ unless grep $i++ != $_, @a;
+ }
+ return $self->maybe_parens(join(", ", @a), $cx, 6);
+}
+
+sub pp_rv2av {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->name eq "const") { # constant list
+ my $av = $self->const_sv($kid);
+ return $self->list_const($cx, $av->ARRAY);
+ } else {
+ return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
+ }
+ }
+
+sub is_subscriptable {
+ my $op = shift;
+ if ($op->name =~ /^[ahg]elem/) {
+ return 1;
+ } elsif ($op->name eq "entersub") {
+ my $kid = $op->first;
+ return 0 unless null $kid->sibling;
+ $kid = $kid->first;
+ $kid = $kid->sibling until null $kid->sibling;
+ return 0 if is_scope($kid);
+ $kid = $kid->first;
+ return 0 if $kid->name eq "gv";
+ return 0 if is_scalar($kid);
+ return is_subscriptable($kid);
+ } else {
+ return 0;
+ }
+}
+
+sub elem {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $padname) = @_;
+ my($array, $idx) = ($op->first, $op->first->sibling);
+ unless ($array->name eq $padname) { # Maybe this has been fixed
+ $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
+ }
+ if ($array->name eq $padname) {
+ $array = $self->padany($array);
+ } elsif (is_scope($array)) { # ${expr}[0]
+ $array = "{" . $self->deparse($array, 0) . "}";
+ } elsif ($array->name eq "gv") {
+ $array = $self->gv_name($self->gv_or_padgv($array));
+ if ($array !~ /::/) {
+ my $prefix = ($left eq '[' ? '@' : '%');
+ $array = $self->{curstash}.'::'.$array
+ if $self->lex_in_scope($prefix . $array);
+ }
+ } elsif (is_scalar $array) { # $x[0], $$x[0], ...
+ $array = $self->deparse($array, 24);
+ } else {
+ # $x[20][3]{hi} or expr->[20]
+ my $arrow = is_subscriptable($array) ? "" : "->";
+ return $self->deparse($array, 24) . $arrow .
+ $left . $self->deparse($idx, 1) . $right;
+ }
+ $idx = $self->deparse($idx, 1);
+
+ # Outer parens in an array index will confuse perl
+ # if we're interpolating in a regular expression, i.e.
+ # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
+ #
+ # If $self->{parens}, then an initial '(' will
+ # definitely be paired with a final ')'. If
+ # !$self->{parens}, the misleading parens won't
+ # have been added in the first place.
+ #
+ # [You might think that we could get "(...)...(...)"
+ # where the initial and final parens do not match
+ # each other. But we can't, because the above would
+ # only happen if there's an infix binop between the
+ # two pairs of parens, and *that* means that the whole
+ # expression would be parenthesized as well.]
+ #
+ $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
+
+ # Hash-element braces will autoquote a bareword inside themselves.
+ # We need to make sure that C<$hash{warn()}> doesn't come out as
+ # C<$hash{warn}>, which has a quite different meaning. Currently
+ # B::Deparse will always quote strings, even if the string was a
+ # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
+ # for constant strings.) So we can cheat slightly here - if we see
+ # a bareword, we know that it is supposed to be a function call.
+ #
+ $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
+
+ return "\$" . $array . $left . $idx . $right;
+}
+
+sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
+sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
+
+sub pp_gelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($glob, $part) = ($op->first, $op->last);
+ $glob = $glob->first; # skip rv2gv
+ $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
+ my $scope = is_scope($glob);
+ $glob = $self->deparse($glob, 0);
+ $part = $self->deparse($part, 1);
+ return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
+}
+
+sub slice {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $regname, $padname) = @_;
+ my $last;
+ my(@elems, $kid, $array, $list);
+ if (class($op) eq "LISTOP") {
+ $last = $op->last;
+ } else { # ex-hslice inside delete()
+ for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
+ $last = $kid;
+ }
+ $array = $last;
+ $array = $array->first
+ if $array->name eq $regname or $array->name eq "null";
+ if (is_scope($array)) {
+ $array = "{" . $self->deparse($array, 0) . "}";
+ } elsif ($array->name eq $padname) {
+ $array = $self->padany($array);
+ } else {
+ $array = $self->deparse($array, 24);
+ }
+ $kid = $op->first->sibling; # skip pushmark
+ if ($kid->name eq "list") {
+ $kid = $kid->first->sibling; # skip list, pushmark
+ for (; !null $kid; $kid = $kid->sibling) {
+ push @elems, $self->deparse($kid, 6);
+ }
+ $list = join(", ", @elems);
+ } else {
+ $list = $self->deparse($kid, 1);
+ }
+ return "\@" . $array . $left . $list . $right;
+}
+
+sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
+sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+
+sub pp_lslice {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $idx = $op->first;
+ my $list = $op->last;
+ my(@elems, $kid);
+ $list = $self->deparse($list, 1);
+ $idx = $self->deparse($idx, 1);
+ return "($list)" . "[$idx]";
+}
+
+sub want_scalar {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
+}
+
+sub want_list {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
+}
+
+sub _method {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first->sibling; # skip pushmark
+ my($meth, $obj, @exprs);
+ if ($kid->name eq "list" and want_list $kid) {
+ # When an indirect object isn't a bareword but the args are in
+ # parens, the parens aren't part of the method syntax (the LLAFR
+ # doesn't apply), but they make a list with OPf_PARENS set that
+ # doesn't get flattened by the append_elem that adds the method,
+ # making a (object, arg1, arg2, ...) list where the object
+ # usually is. This can be distinguished from
+ # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
+ # object) because in the later the list is in scalar context
+ # as the left side of -> always is, while in the former
+ # the list is in list context as method arguments always are.
+ # (Good thing there aren't method prototypes!)
+ $meth = $kid->sibling;
+ $kid = $kid->first->sibling; # skip pushmark
+ $obj = $kid;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ } else {
+ $obj = $kid;
+ $kid = $kid->sibling;
+ for (; !null ($kid->sibling) && $kid->name ne "method_named";
+ $kid = $kid->sibling) {
+ push @exprs, $kid
+ }
+ $meth = $kid;
+ }
+
+ if ($meth->name eq "method_named") {
+ $meth = $self->const_sv($meth)->PV;
+ } else {
+ $meth = $meth->first;
+ if ($meth->name eq "const") {
+ # As of 5.005_58, this case is probably obsoleted by the
+ # method_named case above
+ $meth = $self->const_sv($meth)->PV; # needs to be bare
+ }
+ }
+
+ return { method => $meth, variable_method => ref($meth),
+ object => $obj, args => \@exprs };
+}
+
+# compat function only
+sub method {
+ my $self = shift;
+ my $info = $self->_method(@_);
+ return $self->e_method( $self->_method(@_) );
+}
+
+sub e_method {
+ my ($self, $info) = @_;
+ my $obj = $self->deparse($info->{object}, 24);
+
+ my $meth = $info->{method};
+ $meth = $self->deparse($meth, 1) if $info->{variable_method};
+ my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
+ my $kid = $obj . "->" . $meth;
+ if (length $args) {
+ return $kid . "(" . $args . ")"; # parens mandatory
+ } else {
+ return $kid;
+ }
+}
+
+# returns "&" if the prototype doesn't match the args,
+# or ("", $args_after_prototype_demunging) if it does.
+sub check_proto {
+ my $self = shift;
+ return "&" if $self->{'noproto'};
+ my($proto, @args) = @_;
+ my($arg, $real);
+ my $doneok = 0;
+ my @reals;
+ # An unbackslashed @ or % gobbles up the rest of the args
+ 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
+ while ($proto) {
+ $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
+ my $chr = $1;
+ if ($chr eq "") {
+ return "&" if @args;
+ } elsif ($chr eq ";") {
+ $doneok = 1;
+ } elsif ($chr eq "@" or $chr eq "%") {
+ push @reals, map($self->deparse($_, 6), @args);
+ @args = ();
+ } else {
+ $arg = shift @args;
+ last unless $arg;
+ if ($chr eq "\$") {
+ if (want_scalar $arg) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ return "&";
+ }
+ } elsif ($chr eq "&") {
+ if ($arg->name =~ /^(s?refgen|undef)$/) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ return "&";
+ }
+ } elsif ($chr eq "*") {
+ if ($arg->name =~ /^s?refgen$/
+ and $arg->first->first->name eq "rv2gv")
+ {
+ $real = $arg->first->first; # skip refgen, null
+ if ($real->first->name eq "gv") {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ push @reals, $self->deparse($real->first, 6);
+ }
+ } else {
+ return "&";
+ }
+ } elsif (substr($chr, 0, 1) eq "\\") {
+ $chr =~ tr/\\[]//d;
+ if ($arg->name =~ /^s?refgen$/ and
+ !null($real = $arg->first) and
+ ($chr =~ /\$/ && is_scalar($real->first)
+ or ($chr =~ /@/
+ && class($real->first->sibling) ne 'NULL'
+ && $real->first->sibling->name
+ =~ /^(rv2|pad)av$/)
+ or ($chr =~ /%/
+ && class($real->first->sibling) ne 'NULL'
+ && $real->first->sibling->name
+ =~ /^(rv2|pad)hv$/)
+ #or ($chr =~ /&/ # This doesn't work
+ # && $real->first->name eq "rv2cv")
+ or ($chr =~ /\*/
+ && $real->first->name eq "rv2gv")))
+ {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ return "&";
+ }
+ }
+ }
+ }
+ return "&" if $proto and !$doneok; # too few args and no `;'
+ return "&" if @args; # too many args
+ return ("", join ", ", @reals);
+}
+
+sub pp_entersub {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->e_method($self->_method($op, $cx))
+ unless null $op->first->sibling;
+ my $prefix = "";
+ my $amper = "";
+ my($kid, @exprs);
+ if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
+ $prefix = "do ";
+ } elsif ($op->private & OPpENTERSUB_AMPER) {
+ $amper = "&";
+ }
+ $kid = $op->first;
+ $kid = $kid->first->sibling; # skip ex-list, pushmark
+ for (; not null $kid->sibling; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ my $simple = 0;
+ my $proto = undef;
+ if (is_scope($kid)) {
+ $amper = "&";
+ $kid = "{" . $self->deparse($kid, 0) . "}";
+ } elsif ($kid->first->name eq "gv") {
+ my $gv = $self->gv_or_padgv($kid->first);
+ if (class($gv->CV) ne "SPECIAL") {
+ $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
+ }
+ $simple = 1; # only calls of named functions can be prototyped
+ $kid = $self->deparse($kid, 24);
+ } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
+ $amper = "&";
+ $kid = $self->deparse($kid, 24);
+ } else {
+ $prefix = "";
+ my $arrow = is_subscriptable($kid->first) ? "" : "->";
+ $kid = $self->deparse($kid, 24) . $arrow;
+ }
+
+ # Doesn't matter how many prototypes there are, if
+ # they haven't happened yet!
+ my $declared;
+ {
+ no strict 'refs';
+ no warnings 'uninitialized';
+ $declared = exists $self->{'subs_declared'}{$kid}
+ || (
+ defined &{ ${$self->{'curstash'}."::"}{$kid} }
+ && !exists
+ $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
+ && defined prototype $self->{'curstash'}."::".$kid
+ );
+ if (!$declared && defined($proto)) {
+ # Avoid "too early to check prototype" warning
+ ($amper, $proto) = ('&');
+ }
+ }
+
+ my $args;
+ if ($declared and defined $proto and not $amper) {
+ ($amper, $args) = $self->check_proto($proto, @exprs);
+ if ($amper eq "&") {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ } else {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ if ($prefix or $amper) {
+ if ($op->flags & OPf_STACKED) {
+ return $prefix . $amper . $kid . "(" . $args . ")";
+ } else {
+ return $prefix . $amper. $kid;
+ }
+ } else {
+ # glob() invocations can be translated into calls of
+ # CORE::GLOBAL::glob with a second parameter, a number.
+ # Reverse this.
+ if ($kid eq "CORE::GLOBAL::glob") {
+ $kid = "glob";
+ $args =~ s/\s*,[^,]+$//;
+ }
+
+ # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
+ # so it must have been translated from a keyword call. Translate
+ # it back.
+ $kid =~ s/^CORE::GLOBAL:://;
+
+ my $dproto = defined($proto) ? $proto : "undefined";
+ if (!$declared) {
+ return "$kid(" . $args . ")";
+ } elsif ($dproto eq "") {
+ return $kid;
+ } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
+ # is_scalar is an excessively conservative test here:
+ # really, we should be comparing to the precedence of the
+ # top operator of $exprs[0] (ala unop()), but that would
+ # take some major code restructuring to do right.
+ return $self->maybe_parens_func($kid, $args, $cx, 16);
+ } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
+ return $self->maybe_parens_func($kid, $args, $cx, 5);
+ } else {
+ return "$kid(" . $args . ")";
+ }
+ }
+}
+
+sub pp_enterwrite { unop(@_, "write") }
+
+# escape things that cause interpolation in double quotes,
+# but not character escapes
+sub uninterp {
+ my($str) = @_;
+ $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
+ return $str;
+}
+
+{
+my $bal;
+BEGIN {
+ use re "eval";
+ # Matches any string which is balanced with respect to {braces}
+ $bal = qr(
+ (?:
+ [^\\{}]
+ | \\\\
+ | \\[{}]
+ | \{(??{$bal})\}
+ )*
+ )x;
+}
+
+# the same, but treat $|, $), $( and $ at the end of the string differently
+sub re_uninterp {
+ my($str) = @_;
+
+ $str =~ s/
+ ( ^|\G # $1
+ | [^\\]
+ )
+
+ ( # $2
+ (?:\\\\)*
+ )
+
+ ( # $3
+ (\(\?\??\{$bal\}\)) # $4
+ | [\$\@]
+ (?!\||\)|\(|$)
+ | \\[uUlLQE]
+ )
+
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+}
+
+# This is for regular expressions with the /x modifier
+# We have to leave comments unmangled.
+sub re_uninterp_extended {
+ my($str) = @_;
+
+ $str =~ s/
+ ( ^|\G # $1
+ | [^\\]
+ )
+
+ ( # $2
+ (?:\\\\)*
+ )
+
+ ( # $3
+ ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
+ | \#[^\n]* # (skip over comments)
+ )
+ | [\$\@]
+ (?!\||\)|\(|$|\s)
+ | \\[uUlLQE]
+ )
+
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+}
+}
+
+my %unctrl = # portable to to EBCDIC
+ (
+ "\c@" => '\c@', # unused
+ "\cA" => '\cA',
+ "\cB" => '\cB',
+ "\cC" => '\cC',
+ "\cD" => '\cD',
+ "\cE" => '\cE',
+ "\cF" => '\cF',
+ "\cG" => '\cG',
+ "\cH" => '\cH',
+ "\cI" => '\cI',
+ "\cJ" => '\cJ',
+ "\cK" => '\cK',
+ "\cL" => '\cL',
+ "\cM" => '\cM',
+ "\cN" => '\cN',
+ "\cO" => '\cO',
+ "\cP" => '\cP',
+ "\cQ" => '\cQ',
+ "\cR" => '\cR',
+ "\cS" => '\cS',
+ "\cT" => '\cT',
+ "\cU" => '\cU',
+ "\cV" => '\cV',
+ "\cW" => '\cW',
+ "\cX" => '\cX',
+ "\cY" => '\cY',
+ "\cZ" => '\cZ',
+ "\c[" => '\c[', # unused
+ "\c\\" => '\c\\', # unused
+ "\c]" => '\c]', # unused
+ "\c_" => '\c_', # unused
+ );
+
+# character escapes, but not delimiters that might need to be escaped
+sub escape_str { # ASCII, UTF8
+ my($str) = @_;
+ $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+ $str =~ s/\a/\\a/g;
+# $str =~ s/\cH/\\b/g; # \b means something different in a regex
+ $str =~ s/\t/\\t/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\e/\\e/g;
+ $str =~ s/\f/\\f/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
+ $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
+ return $str;
+}
+
+# For regexes with the /x modifier.
+# Leave whitespace unmangled.
+sub escape_extended_re {
+ my($str) = @_;
+ $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+ $str =~ s/([[:^print:]])/
+ ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
+ $str =~ s/\n/\n\f/g;
+ return $str;
+}
+
+# Don't do this for regexen
+sub unback {
+ my($str) = @_;
+ $str =~ s/\\/\\\\/g;
+ return $str;
+}
+
+# Remove backslashes which precede literal control characters,
+# to avoid creating ambiguity when we escape the latter.
+sub re_unback {
+ my($str) = @_;
+
+ # the insane complexity here is due to the behaviour of "\c\"
+ $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
+ return $str;
+}
+
+sub balanced_delim {
+ my($str) = @_;
+ my @str = split //, $str;
+ my($ar, $open, $close, $fail, $c, $cnt);
+ for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
+ ($open, $close) = @$ar;
+ $fail = 0; $cnt = 0;
+ for $c (@str) {
+ if ($c eq $open) {
+ $cnt++;
+ } elsif ($c eq $close) {
+ $cnt--;
+ if ($cnt < 0) {
+ # qq()() isn't ")("
+ $fail = 1;
+ last;
+ }
+ }
+ }
+ $fail = 1 if $cnt != 0;
+ return ($open, "$open$str$close") if not $fail;
+ }
+ return ("", $str);
+}
+
+sub single_delim {
+ my($q, $default, $str) = @_;
+ return "$default$str$default" if $default and index($str, $default) == -1;
+ if ($q ne 'qr') {
+ (my $succeed, $str) = balanced_delim($str);
+ return "$q$str" if $succeed;
+ }
+ for my $delim ('/', '"', '#') {
+ return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+ }
+ if ($default) {
+ $str =~ s/$default/\\$default/g;
+ return "$default$str$default";
+ } else {
+ $str =~ s[/][\\/]g;
+ return "$q/$str/";
+ }
+}
+
+my $max_prec;
+BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
+
+# Split a floating point number into an integer mantissa and a binary
+# exponent. Assumes you've already made sure the number isn't zero or
+# some weird infinity or NaN.
+sub split_float {
+ my($f) = @_;
+ my $exponent = 0;
+ if ($f == int($f)) {
+ while ($f % 2 == 0) {
+ $f /= 2;
+ $exponent++;
+ }
+ } else {
+ while ($f != int($f)) {
+ $f *= 2;
+ $exponent--;
+ }
+ }
+ my $mantissa = sprintf("%.0f", $f);
+ return ($mantissa, $exponent);
+}
+
+sub const {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ if ($self->{'use_dumper'}) {
+ return $self->const_dumper($sv, $cx);
+ }
+ if (class($sv) eq "SPECIAL") {
+ # sv_undef, sv_yes, sv_no
+ return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
+ } elsif (class($sv) eq "NULL") {
+ return 'undef';
+ }
+ # convert a version object into the "v1.2.3" string in its V magic
+ if ($sv->FLAGS & SVs_RMG) {
+ for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ return $mg->PTR if $mg->TYPE eq 'V';
+ }
+ }
+
+ if ($sv->FLAGS & SVf_IOK) {
+ my $str = $sv->int_value;
+ $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
+ return $str;
+ } elsif ($sv->FLAGS & SVf_NOK) {
+ my $nv = $sv->NV;
+ if ($nv == 0) {
+ if (pack("F", $nv) eq pack("F", 0)) {
+ # positive zero
+ return "0";
+ } else {
+ # negative zero
+ return $self->maybe_parens("-.0", $cx, 21);
+ }
+ } elsif (1/$nv == 0) {
+ if ($nv > 0) {
+ # positive infinity
+ return $self->maybe_parens("9**9**9", $cx, 22);
+ } else {
+ # negative infinity
+ return $self->maybe_parens("-9**9**9", $cx, 21);
+ }
+ } elsif ($nv != $nv) {
+ # NaN
+ if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
+ # the normal kind
+ return "sin(9**9**9)";
+ } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
+ # the inverted kind
+ return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
+ } else {
+ # some other kind
+ my $hex = unpack("h*", pack("F", $nv));
+ return qq'unpack("F", pack("h*", "$hex"))';
+ }
+ }
+ # first, try the default stringification
+ my $str = "$nv";
+ if ($str != $nv) {
+ # failing that, try using more precision
+ $str = sprintf("%.${max_prec}g", $nv);
+# if (pack("F", $str) ne pack("F", $nv)) {
+ if ($str != $nv) {
+ # not representable in decimal with whatever sprintf()
+ # and atof() Perl is using here.
+ my($mant, $exp) = split_float($nv);
+ return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
+ }
+ }
+ $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
+ return $str;
+ } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
+ my $ref = $sv->RV;
+ if (class($ref) eq "AV") {
+ return "[" . $self->list_const(2, $ref->ARRAY) . "]";
+ } elsif (class($ref) eq "HV") {
+ my %hash = $ref->ARRAY;
+ my @elts;
+ for my $k (sort keys %hash) {
+ push @elts, "$k => " . $self->const($hash{$k}, 6);
+ }
+ return "{" . join(", ", @elts) . "}";
+ } elsif (class($ref) eq "CV") {
+ return "sub " . $self->deparse_sub($ref);
+ }
+ if ($ref->FLAGS & SVs_SMG) {
+ for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ if ($mg->TYPE eq 'r') {
+ my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
+ return single_delim("qr", "", $re);
+ }
+ }
+ }
+
+ return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
+ } elsif ($sv->FLAGS & SVf_POK) {
+ my $str = $sv->PV;
+ if ($str =~ /[^ -~]/) { # ASCII for non-printing
+ return single_delim("qq", '"', uninterp escape_str unback $str);
+ } else {
+ return single_delim("q", "'", unback $str);
+ }
+ } else {
+ return "undef";
+ }
+}
+
+sub const_dumper {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ my $ref = $sv->object_2svref();
+ my $dumper = Data::Dumper->new([$$ref], ['$v']);
+ $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
+ my $str = $dumper->Dump();
+ if ($str =~ /^\$v/) {
+ return '${my ' . $str . ' \$v}';
+ } else {
+ return $str;
+ }
+}
+
+sub const_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->sv;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($op->targ) unless $$sv;
+ return $sv;
+}
+
+sub pp_const {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->private & OPpCONST_ARYBASE) {
+ return '$[';
+ }
+# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
+# return $self->const_sv($op)->PV;
+# }
+ my $sv = $self->const_sv($op);
+ return $self->const($sv, $cx);
+}
+
+sub dq {
+ my $self = shift;
+ my $op = shift;
+ my $type = $op->name;
+ if ($type eq "const") {
+ return '$[' if $op->private & OPpCONST_ARYBASE;
+ return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
+ } elsif ($type eq "concat") {
+ my $first = $self->dq($op->first);
+ my $last = $self->dq($op->last);
+
+ # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[:'{\[\w_]/ && #'
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+
+ return $first . $last;
+ } elsif ($type eq "uc") {
+ return '\U' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "lc") {
+ return '\L' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "ucfirst") {
+ return '\u' . $self->dq($op->first->sibling);
+ } elsif ($type eq "lcfirst") {
+ return '\l' . $self->dq($op->first->sibling);
+ } elsif ($type eq "quotemeta") {
+ return '\Q' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pp_backtick {
+ my $self = shift;
+ my($op, $cx) = @_;
+ # skip pushmark
+ return single_delim("qx", '`', $self->dq($op->first->sibling));
+}
+
+sub dquote {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first->sibling; # skip ex-stringify, pushmark
+ return $self->deparse($kid, $cx) if $self->{'unquote'};
+ $self->maybe_targmy($kid, $cx,
+ sub {single_delim("qq", '"', $self->dq($_[1]))});
+}
+
+# OP_STRINGIFY is a listop, but it only ever has one arg
+sub pp_stringify { maybe_targmy(@_, \&dquote) }
+
+# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
+# note that tr(from)/to/ is OK, but not tr/from/(to)
+sub double_delim {
+ my($from, $to) = @_;
+ my($succeed, $delim);
+ if ($from !~ m[/] and $to !~ m[/]) {
+ return "/$from/$to/";
+ } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
+ if (($succeed, $to) = balanced_delim($to) and $succeed) {
+ return "$from$to";
+ } else {
+ for $delim ('/', '"', '#') { # note no `'' -- s''' is special
+ return "$from$delim$to$delim" if index($to, $delim) == -1;
+ }
+ $to =~ s[/][\\/]g;
+ return "$from/$to/";
+ }
+ } else {
+ for $delim ('/', '"', '#') { # note no '
+ return "$delim$from$delim$to$delim"
+ if index($to . $from, $delim) == -1;
+ }
+ $from =~ s[/][\\/]g;
+ $to =~ s[/][\\/]g;
+ return "/$from/$to/";
+ }
+}
+
+# Only used by tr///, so backslashes hyphens
+sub pchr { # ASCII
+ my($n) = @_;
+ if ($n == ord '\\') {
+ return '\\\\';
+ } elsif ($n == ord "-") {
+ return "\\-";
+ } elsif ($n >= ord(' ') and $n <= ord('~')) {
+ return chr($n);
+ } elsif ($n == ord "\a") {
+ return '\\a';
+ } elsif ($n == ord "\b") {
+ return '\\b';
+ } elsif ($n == ord "\t") {
+ return '\\t';
+ } elsif ($n == ord "\n") {
+ return '\\n';
+ } elsif ($n == ord "\e") {
+ return '\\e';
+ } elsif ($n == ord "\f") {
+ return '\\f';
+ } elsif ($n == ord "\r") {
+ return '\\r';
+ } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
+ return '\\c' . chr(ord("@") + $n);
+ } else {
+# return '\x' . sprintf("%02x", $n);
+ return '\\' . sprintf("%03o", $n);
+ }
+}
+
+sub collapse {
+ my(@chars) = @_;
+ my($str, $c, $tr) = ("");
+ for ($c = 0; $c < @chars; $c++) {
+ $tr = $chars[$c];
+ $str .= pchr($tr);
+ if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
+ $chars[$c + 2] == $tr + 2)
+ {
+ for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
+ {}
+ $str .= "-";
+ $str .= pchr($chars[$c]);
+ }
+ }
+ return $str;
+}
+
+sub tr_decode_byte {
+ my($table, $flags) = @_;
+ my(@table) = unpack("s*", $table);
+ splice @table, 0x100, 1; # Number of subsequent elements
+ my($c, $tr, @from, @to, @delfrom, $delhyphen);
+ if ($table[ord "-"] != -1 and
+ $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
+ {
+ $tr = $table[ord "-"];
+ $table[ord "-"] = -1;
+ if ($tr >= 0) {
+ @from = ord("-");
+ @to = $tr;
+ } else { # -2 ==> delete
+ $delhyphen = 1;
+ }
+ }
+ for ($c = 0; $c < @table; $c++) {
+ $tr = $table[$c];
+ if ($tr >= 0) {
+ push @from, $c; push @to, $tr;
+ } elsif ($tr == -2) {
+ push @delfrom, $c;
+ }
+ }
+ @from = (@from, @delfrom);
+ if ($flags & OPpTRANS_COMPLEMENT) {
+ my @newfrom = ();
+ my %from;
+ @from{@from} = (1) x @from;
+ for ($c = 0; $c < 256; $c++) {
+ push @newfrom, $c unless $from{$c};
+ }
+ @from = @newfrom;
+ }
+ unless ($flags & OPpTRANS_DELETE || !@to) {
+ pop @to while $#to and $to[$#to] == $to[$#to -1];
+ }
+ my($from, $to);
+ $from = collapse(@from);
+ $to = collapse(@to);
+ $from .= "-" if $delhyphen;
+ return ($from, $to);
+}
+
+sub tr_chr {
+ my $x = shift;
+ if ($x == ord "-") {
+ return "\\-";
+ } elsif ($x == ord "\\") {
+ return "\\\\";
+ } else {
+ return chr $x;
+ }
+}
+
+# XXX This doesn't yet handle all cases correctly either
+
+sub tr_decode_utf8 {
+ my($swash_hv, $flags) = @_;
+ my %swash = $swash_hv->ARRAY;
+ my $final = undef;
+ $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
+ my $none = $swash{"NONE"}->IV;
+ my $extra = $none + 1;
+ my(@from, @delfrom, @to);
+ my $line;
+ foreach $line (split /\n/, $swash{'LIST'}->PV) {
+ my($min, $max, $result) = split(/\t/, $line);
+ $min = hex $min;
+ if (length $max) {
+ $max = hex $max;
+ } else {
+ $max = $min;
+ }
+ $result = hex $result;
+ if ($result == $extra) {
+ push @delfrom, [$min, $max];
+ } else {
+ push @from, [$min, $max];
+ push @to, [$result, $result + $max - $min];
+ }
+ }
+ for my $i (0 .. $#from) {
+ if ($from[$i][0] == ord '-') {
+ unshift @from, splice(@from, $i, 1);
+ unshift @to, splice(@to, $i, 1);
+ last;
+ } elsif ($from[$i][1] == ord '-') {
+ $from[$i][1]--;
+ $to[$i][1]--;
+ unshift @from, ord '-';
+ unshift @to, ord '-';
+ last;
+ }
+ }
+ for my $i (0 .. $#delfrom) {
+ if ($delfrom[$i][0] == ord '-') {
+ push @delfrom, splice(@delfrom, $i, 1);
+ last;
+ } elsif ($delfrom[$i][1] == ord '-') {
+ $delfrom[$i][1]--;
+ push @delfrom, ord '-';
+ last;
+ }
+ }
+ if (defined $final and $to[$#to][1] != $final) {
+ push @to, [$final, $final];
+ }
+ push @from, @delfrom;
+ if ($flags & OPpTRANS_COMPLEMENT) {
+ my @newfrom;
+ my $next = 0;
+ for my $i (0 .. $#from) {
+ push @newfrom, [$next, $from[$i][0] - 1];
+ $next = $from[$i][1] + 1;
+ }
+ @from = ();
+ for my $range (@newfrom) {
+ if ($range->[0] <= $range->[1]) {
+ push @from, $range;
+ }
+ }
+ }
+ my($from, $to, $diff);
+ for my $chunk (@from) {
+ $diff = $chunk->[1] - $chunk->[0];
+ if ($diff > 1) {
+ $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
+ } elsif ($diff == 1) {
+ $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
+ } else {
+ $from .= tr_chr($chunk->[0]);
+ }
+ }
+ for my $chunk (@to) {
+ $diff = $chunk->[1] - $chunk->[0];
+ if ($diff > 1) {
+ $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
+ } elsif ($diff == 1) {
+ $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
+ } else {
+ $to .= tr_chr($chunk->[0]);
+ }
+ }
+ #$final = sprintf("%04x", $final) if defined $final;
+ #$none = sprintf("%04x", $none) if defined $none;
+ #$extra = sprintf("%04x", $extra) if defined $extra;
+ #print STDERR "final: $final\n none: $none\nextra: $extra\n";
+ #print STDERR $swash{'LIST'}->PV;
+ return (escape_str($from), escape_str($to));
+}
+
+sub pp_trans {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($from, $to);
+ if (class($op) eq "PVOP") {
+ ($from, $to) = tr_decode_byte($op->pv, $op->private);
+ } else { # class($op) eq "SVOP"
+ ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
+ $flags .= "d" if $op->private & OPpTRANS_DELETE;
+ $to = "" if $from eq $to and $flags eq "";
+ $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+ return "tr" . double_delim($from, $to) . $flags;
+}
+
+# Like dq(), but different
+sub re_dq {
+ my $self = shift;
+ my ($op, $extended) = @_;
+
+ my $type = $op->name;
+ if ($type eq "const") {
+ return '$[' if $op->private & OPpCONST_ARYBASE;
+ my $unbacked = re_unback($self->const_sv($op)->as_string);
+ return re_uninterp_extended(escape_extended_re($unbacked))
+ if $extended;
+ return re_uninterp(escape_str($unbacked));
+ } elsif ($type eq "concat") {
+ my $first = $self->re_dq($op->first, $extended);
+ my $last = $self->re_dq($op->last, $extended);
+
+ # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[{\[\w_]/ &&
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+
+ return $first . $last;
+ } elsif ($type eq "uc") {
+ return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "lc") {
+ return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "ucfirst") {
+ return '\u' . $self->re_dq($op->first->sibling, $extended);
+ } elsif ($type eq "lcfirst") {
+ return '\l' . $self->re_dq($op->first->sibling, $extended);
+ } elsif ($type eq "quotemeta") {
+ return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pure_string {
+ my ($self, $op) = @_;
+ return 0 if null $op;
+ my $type = $op->name;
+
+ if ($type eq 'const') {
+ return 1;
+ }
+ elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
+ return $self->pure_string($op->first->sibling);
+ }
+ elsif ($type eq 'join') {
+ my $join_op = $op->first->sibling; # Skip pushmark
+ return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
+
+ my $gvop = $join_op->first;
+ return 0 unless $gvop->name eq 'gvsv';
+ return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
+
+ return 0 unless ${$join_op->sibling} eq ${$op->last};
+ return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
+ }
+ elsif ($type eq 'concat') {
+ return $self->pure_string($op->first)
+ && $self->pure_string($op->last);
+ }
+ elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
+ return 1;
+ }
+ elsif ($type eq "null" and $op->can('first') and not null $op->first and
+ $op->first->name eq "null" and $op->first->can('first')
+ and not null $op->first->first and
+ $op->first->first->name eq "aelemfast") {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub regcomp {
+ my $self = shift;
+ my($op, $cx, $extended) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->name eq "regcmaybe";
+ $kid = $kid->first if $kid->name eq "regcreset";
+ if ($kid->name eq "null" and !null($kid->first)
+ and $kid->first->name eq 'pushmark')
+ {
+ my $str = '';
+ $kid = $kid->first->sibling;
+ while (!null($kid)) {
+ $str .= $self->re_dq($kid, $extended);
+ $kid = $kid->sibling;
+ }
+ return $str, 1;
+ }
+
+ return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
+ return ($self->deparse($kid, $cx), 0);
+}
+
+sub pp_regcomp {
+ my ($self, $op, $cx) = @_;
+ return (($self->regcomp($op, $cx, 0))[0]);
+}
+
+# osmic acid -- see osmium tetroxide
+
+my %matchwords;
+map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
+ 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
+ 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
+
+sub matchop {
+ my $self = shift;
+ my($op, $cx, $name, $delim) = @_;
+ my $kid = $op->first;
+ my ($binop, $var, $re) = ("", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $quote = 1;
+ my $extended = ($op->pmflags & PMf_EXTENDED);
+ if (null $kid) {
+ my $unbacked = re_unback($op->precomp);
+ if ($extended) {
+ $re = re_uninterp_extended(escape_extended_re($unbacked));
+ } else {
+ $re = re_uninterp(escape_str(re_unback($op->precomp)));
+ }
+ } elsif ($kid->name ne 'regcomp') {
+ carp("found ".$kid->name." where regcomp expected");
+ } else {
+ ($re, $quote) = $self->regcomp($kid, 21, $extended);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->pmflags & PMf_CONTINUE;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $op->pmflags & PMf_EXTENDED;
+ $flags = $matchwords{$flags} if $matchwords{$flags};
+ if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
+ $re =~ s/\?/\\?/g;
+ $re = "?$re?";
+ } elsif ($quote) {
+ $re = single_delim($name, $delim, $re);
+ }
+ $re = $re . $flags if $quote;
+ if ($binop) {
+ return $self->maybe_parens("$var =~ $re", $cx, 20);
+ } else {
+ return $re;
+ }
+}
+
+sub pp_match { matchop(@_, "m", "/") }
+sub pp_pushre { matchop(@_, "m", "/") }
+sub pp_qr { matchop(@_, "qr", "") }
+
+sub pp_split {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($kid, @exprs, $ary, $expr);
+ $kid = $op->first;
+
+ # For our kid (an OP_PUSHRE), pmreplroot is never actually the
+ # root of a replacement; it's either empty, or abused to point to
+ # the GV for an array we split into (an optimization to save
+ # assignment overhead). Depending on whether we're using ithreads,
+ # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
+ # figures out for us which it is.
+ my $replroot = $kid->pmreplroot;
+ my $gv = 0;
+ if (ref($replroot) eq "B::GV") {
+ $gv = $replroot;
+ } elsif (!ref($replroot) and $replroot > 0) {
+ $gv = $self->padval($replroot);
+ }
+ $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
+
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+
+ # handle special case of split(), and split(" ") that compiles to /\s+/
+ $kid = $op->first;
+ if ($kid->flags & OPf_SPECIAL
+ && $exprs[0] eq '/\\s+/'
+ && $kid->pmflags & PMf_SKIPWHITE ) {
+ $exprs[0] = '" "';
+ }
+
+ $expr = "split(" . join(", ", @exprs) . ")";
+ if ($ary) {
+ return $self->maybe_parens("$ary = $expr", $cx, 7);
+ } else {
+ return $expr;
+ }
+}
+
+# oxime -- any of various compounds obtained chiefly by the action of
+# hydroxylamine on aldehydes and ketones and characterized by the
+# bivalent grouping C=NOH [Webster's Tenth]
+
+my %substwords;
+map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
+ 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
+ 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
+ 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
+
+sub pp_subst {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ my($binop, $var, $re, $repl) = ("", "", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $flags = "";
+ if (null($op->pmreplroot)) {
+ $repl = $self->dq($kid);
+ $kid = $kid->sibling;
+ } else {
+ $repl = $op->pmreplroot->first; # skip substcont
+ while ($repl->name eq "entereval") {
+ $repl = $repl->first;
+ $flags .= "e";
+ }
+ if ($op->pmflags & PMf_EVAL) {
+ $repl = $self->deparse($repl->first, 0);
+ } else {
+ $repl = $self->dq($repl);
+ }
+ }
+ my $extended = ($op->pmflags & PMf_EXTENDED);
+ if (null $kid) {
+ my $unbacked = re_unback($op->precomp);
+ if ($extended) {
+ $re = re_uninterp_extended(escape_extended_re($unbacked));
+ }
+ else {
+ $re = re_uninterp(escape_str($unbacked));
+ }
+ } else {
+ ($re) = $self->regcomp($kid, 1, $extended);
+ }
+ $flags .= "e" if $op->pmflags & PMf_EVAL;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $extended;
+ $flags = $substwords{$flags} if $substwords{$flags};
+ if ($binop) {
+ return $self->maybe_parens("$var =~ s"
+ . double_delim($re, $repl) . $flags,
+ $cx, 20);
+ } else {
+ return "s". double_delim($re, $repl) . $flags;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+B::Deparse - Perl compiler backend to produce perl code
+
+=head1 SYNOPSIS
+
+B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
+ [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
+
+=head1 DESCRIPTION
+
+B::Deparse is a backend module for the Perl compiler that generates
+perl source code, based on the internal compiled structure that perl
+itself creates after parsing a program. The output of B::Deparse won't
+be exactly the same as the original source, since perl doesn't keep
+track of comments or whitespace, and there isn't a one-to-one
+correspondence between perl's syntactical constructions and their
+compiled form, but it will often be close. When you use the B<-p>
+option, the output also includes parentheses even when they are not
+required by precedence, which can make it easy to see if perl is
+parsing your expressions the way you intended.
+
+While B::Deparse goes to some lengths to try to figure out what your
+original program was doing, some parts of the language can still trip
+it up; it still fails even on some parts of Perl's own test suite. If
+you encounter a failure other than the most common ones described in
+the BUGS section below, you can help contribute to B::Deparse's
+ongoing development by submitting a bug report with a small
+example.
+
+=head1 OPTIONS
+
+As with all compiler backend options, these must follow directly after
+the '-MO=Deparse', separated by a comma but not any white space.
+
+=over 4
+
+=item B<-d>
+
+Output data values (when they appear as constants) using Data::Dumper.
+Without this option, B::Deparse will use some simple routines of its
+own for the same purpose. Currently, Data::Dumper is better for some
+kinds of data (such as complex structures with sharing and
+self-reference) while the built-in routines are better for others
+(such as odd floating-point values).
+
+=item B<-f>I<FILE>
+
+Normally, B::Deparse deparses the main code of a program, and all the subs
+defined in the same file. To include subs defined in other files, pass the
+B<-f> option with the filename. You can pass the B<-f> option several times, to
+include more than one secondary file. (Most of the time you don't want to
+use it at all.) You can also use this option to include subs which are
+defined in the scope of a B<#line> directive with two parameters.
+
+=item B<-l>
+
+Add '#line' declarations to the output based on the line and file
+locations of the original code.
+
+=item B<-p>
+
+Print extra parentheses. Without this option, B::Deparse includes
+parentheses in its output only when they are needed, based on the
+structure of your program. With B<-p>, it uses parentheses (almost)
+whenever they would be legal. This can be useful if you are used to
+LISP, or if you want to see how perl parses your input. If you say
+
+ if ($var & 0x7f == 65) {print "Gimme an A!"}
+ print ($which ? $a : $b), "\n";
+ $name = $ENV{USER} or "Bob";
+
+C<B::Deparse,-p> will print
+
+ if (($var & 0)) {
+ print('Gimme an A!')
+ };
+ (print(($which ? $a : $b)), '???');
+ (($name = $ENV{'USER'}) or '???')
+
+which probably isn't what you intended (the C<'???'> is a sign that
+perl optimized away a constant value).
+
+=item B<-P>
+
+Disable prototype checking. With this option, all function calls are
+deparsed as if no prototype was defined for them. In other words,
+
+ perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
+
+will print
+
+ sub foo (\@) {
+ 1;
+ }
+ &foo(\@x);
+
+making clear how the parameters are actually passed to C<foo>.
+
+=item B<-q>
+
+Expand double-quoted strings into the corresponding combinations of
+concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
+instance, print
+
+ print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
+
+as
+
+ print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
+ . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
+
+Note that the expanded form represents the way perl handles such
+constructions internally -- this option actually turns off the reverse
+translation that B::Deparse usually does. On the other hand, note that
+C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
+of $y into a string before doing the assignment.
+
+=item B<-s>I<LETTERS>
+
+Tweak the style of B::Deparse's output. The letters should follow
+directly after the 's', with no space or punctuation. The following
+options are available:
+
+=over 4
+
+=item B<C>
+
+Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
+
+ if (...) {
+ ...
+ } else {
+ ...
+ }
+
+instead of
+
+ if (...) {
+ ...
+ }
+ else {
+ ...
+ }
+
+The default is not to cuddle.
+
+=item B<i>I<NUMBER>
+
+Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
+
+=item B<T>
+
+Use tabs for each 8 columns of indent. The default is to use only spaces.
+For instance, if the style options are B<-si4T>, a line that's indented
+3 times will be preceded by one tab and four spaces; if the options were
+B<-si8T>, the same line would be preceded by three tabs.
+
+=item B<v>I<STRING>B<.>
+
+Print I<STRING> for the value of a constant that can't be determined
+because it was optimized away (mnemonic: this happens when a constant
+is used in B<v>oid context). The end of the string is marked by a period.
+The string should be a valid perl expression, generally a constant.
+Note that unless it's a number, it probably needs to be quoted, and on
+a command line quotes need to be protected from the shell. Some
+conventional values include 0, 1, 42, '', 'foo', and
+'Useless use of constant omitted' (which may need to be
+B<-sv"'Useless use of constant omitted'.">
+or something similar depending on your shell). The default is '???'.
+If you're using B::Deparse on a module or other file that's require'd,
+you shouldn't use a value that evaluates to false, since the customary
+true constant at the end of a module will be in void context when the
+file is compiled as a main program.
+
+=back
+
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
+while loops with continue blocks; for instance
+
+ for ($i = 0; $i < 10; ++$i) {
+ print $i;
+ }
+
+turns into
+
+ $i = 0;
+ while ($i < 10) {
+ print $i;
+ } continue {
+ ++$i
+ }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop's initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 5, C<use> declarations will be translated into
+C<BEGIN> blocks containing calls to C<require> and C<import>; for
+instance,
+
+ use strict 'refs';
+
+turns into
+
+ sub BEGIN {
+ require strict;
+ do {
+ 'strict'->import('refs')
+ };
+ }
+
+If I<LEVEL> is at least 7, C<if> statements will be translated into
+equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+ print 'hi' if $nice;
+ if ($nice) {
+ print 'hi';
+ }
+ if ($nice) {
+ print 'hi';
+ } else {
+ print 'bye';
+ }
+
+turns into
+
+ $nice and print 'hi';
+ $nice and do { print 'hi' };
+ $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
+=back
+
+=head1 USING B::Deparse AS A MODULE
+
+=head2 Synopsis
+
+ use B::Deparse;
+ $deparse = B::Deparse->new("-p", "-sC");
+ $body = $deparse->coderef2text(\&func);
+ eval "sub func $body"; # the inverse operation
+
+=head2 Description
+
+B::Deparse can also be used on a sub-by-sub basis from other perl
+programs.
+
+=head2 new
+
+ $deparse = B::Deparse->new(OPTIONS)
+
+Create an object to store the state of a deparsing operation and any
+options. The options are the same as those that can be given on the
+command line (see L</OPTIONS>); options that are separated by commas
+after B<-MO=Deparse> should be given as separate strings. Some
+options, like B<-u>, don't make sense for a single subroutine, so
+don't pass them.
+
+=head2 ambient_pragmas
+
+ $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
+
+The compilation of a subroutine can be affected by a few compiler
+directives, B<pragmas>. These are:
+
+=over 4
+
+=item *
+
+use strict;
+
+=item *
+
+use warnings;
+
+=item *
+
+Assigning to the special variable $[
+
+=item *
+
+use integer;
+
+=item *
+
+use bytes;
+
+=item *
+
+use utf8;
+
+=item *
+
+use re;
+
+=back
+
+Ordinarily, if you use B::Deparse on a subroutine which has
+been compiled in the presence of one or more of these pragmas,
+the output will include statements to turn on the appropriate
+directives. So if you then compile the code returned by coderef2text,
+it will behave the same way as the subroutine which you deparsed.
+
+However, you may know that you intend to use the results in a
+particular context, where some pragmas are already in scope. In
+this case, you use the B<ambient_pragmas> method to describe the
+assumptions you wish to make.
+
+Not all of the options currently have any useful effect. See
+L</BUGS> for more details.
+
+The parameters it accepts are:
+
+=over 4
+
+=item strict
+
+Takes a string, possibly containing several values separated
+by whitespace. The special values "all" and "none" mean what you'd
+expect.
+
+ $deparse->ambient_pragmas(strict => 'subs refs');
+
+=item $[
+
+Takes a number, the value of the array base $[.
+
+=item bytes
+
+=item utf8
+
+=item integer
+
+If the value is true, then the appropriate pragma is assumed to
+be in the ambient scope, otherwise not.
+
+=item re
+
+Takes a string, possibly containing a whitespace-separated list of
+values. The values "all" and "none" are special. It's also permissible
+to pass an array reference here.
+
+ $deparser->ambient_pragmas(re => 'eval');
+
+
+=item warnings
+
+Takes a string, possibly containing a whitespace-separated list of
+values. The values "all" and "none" are special, again. It's also
+permissible to pass an array reference here.
+
+ $deparser->ambient_pragmas(warnings => [qw[void io]]);
+
+If one of the values is the string "FATAL", then all the warnings
+in that list will be considered fatal, just as with the B<warnings>
+pragma itself. Should you need to specify that some warnings are
+fatal, and others are merely enabled, you can pass the B<warnings>
+parameter twice:
+
+ $deparser->ambient_pragmas(
+ warnings => 'all',
+ warnings => [FATAL => qw/void io/],
+ );
+
+See L<perllexwarn> for more information about lexical warnings.
+
+=item hint_bits
+
+=item warning_bits
+
+These two parameters are used to specify the ambient pragmas in
+the format used by the special variables $^H and ${^WARNING_BITS}.
+
+They exist principally so that you can write code like:
+
+ { my ($hint_bits, $warning_bits);
+ BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ $deparser->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[
+ ); }
+
+which specifies that the ambient pragmas are exactly those which
+are in scope at the point of calling.
+
+=back
+
+=head2 coderef2text
+
+ $body = $deparse->coderef2text(\&func)
+ $body = $deparse->coderef2text(sub ($$) { ... })
+
+Return source code for the body of a subroutine (a block, optionally
+preceded by a prototype in parens), given a reference to the
+sub. Because a subroutine can have no names, or more than one name,
+this method doesn't return a complete subroutine definition -- if you
+want to eval the result, you should prepend "sub subname ", or "sub "
+for an anonymous function constructor. Unless the sub was defined in
+the main:: package, the code will include a package declaration.
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+The only pragmas to be completely supported are: C<use warnings>,
+C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
+behaves like a pragma, is also supported.)
+
+Excepting those listed above, we're currently unable to guarantee that
+B::Deparse will produce a pragma at the correct point in the program.
+(Specifically, pragmas at the beginning of a block often appear right
+before the start of the block instead.)
+Since the effects of pragmas are often lexically scoped, this can mean
+that the pragma holds sway over a different portion of the program
+than in the input file.
+
+=item *
+
+In fact, the above is a specific instance of a more general problem:
+we can't guarantee to produce BEGIN blocks or C<use> declarations in
+exactly the right place. So if you use a module which affects compilation
+(such as by over-riding keywords, overloading constants or whatever)
+then the output code might not work as intended.
+
+This is the most serious outstanding problem, and will require some help
+from the Perl core to fix.
+
+=item *
+
+If a keyword is over-ridden, and your program explicitly calls
+the built-in version by using CORE::keyword, the output of B::Deparse
+will not reflect this. If you run the resulting code, it will call
+the over-ridden version rather than the built-in one. (Maybe there
+should be an option to B<always> print keyword calls as C<CORE::name>.)
+
+=item *
+
+Some constants don't print correctly either with or without B<-d>.
+For instance, neither B::Deparse nor Data::Dumper know how to print
+dual-valued scalars correctly, as in:
+
+ use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
+
+=item *
+
+An input file that uses source filtering probably won't be deparsed into
+runnable code, because it will still include the B<use> declaration
+for the source filtering module, even though the code that is
+produced is already ordinary Perl which shouldn't be filtered again.
+
+=item *
+
+Optimised away statements are rendered as '???'. This includes statements that
+have a compile-time side-effect, such as the obscure
+
+ my $x if 0;
+
+which is not, consequently, deparsed correctly.
+
+=item *
+
+There are probably many more bugs on non-ASCII platforms (EBCDIC).
+
+=back
+
+=head1 AUTHOR
+
+Stephen McCamant <smcc at CSUA.Berkeley.EDU>, based on an earlier version
+by Malcolm Beattie <mbeattie at sable.ox.ac.uk>, with contributions from
+Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
+Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
+Garcia-Suarez.
+
+=cut
Added: B/B/Disassembler.pm
==============================================================================
--- (empty file)
+++ B/B/Disassembler.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,233 @@
+# Disassembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+
+$B::Disassembler::VERSION = '1.05';
+
+package B::Disassembler::BytecodeStream;
+
+use FileHandle;
+use Carp;
+use Config qw(%Config);
+use B qw(cstring cast_I32);
+ at ISA = qw(FileHandle);
+sub readn {
+ my ($fh, $len) = @_;
+ my $data;
+ read($fh, $data, $len);
+ croak "reached EOF while reading $len bytes" unless length($data) == $len;
+ return $data;
+}
+
+sub GET_U8 {
+ my $fh = shift;
+ my $c = $fh->getc;
+ croak "reached EOF while reading U8" unless defined($c);
+ return ord($c);
+}
+
+sub GET_U16 {
+ my $fh = shift;
+ my $str = $fh->readn(2);
+ croak "reached EOF while reading U16" unless length($str) == 2;
+ return unpack("S", $str);
+}
+
+sub GET_NV {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_U32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading U32" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_I32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading I32" unless length($str) == 4;
+ return unpack("l", $str);
+}
+
+sub GET_objindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading objindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_opindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading opindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_svindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading svindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_pvindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading pvindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_strconst {
+ my $fh = shift;
+ my ($str, $c);
+ $str = '';
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading strconst" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_pvcontents {}
+
+sub GET_PV {
+ my $fh = shift;
+ my $str;
+ my $len = $fh->GET_U32;
+ if ($len) {
+ read($fh, $str, $len);
+ croak "reached EOF while reading PV" unless length($str) == $len;
+ return cstring($str);
+ } else {
+ return '""';
+ }
+}
+
+sub GET_comment_t {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\n") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading comment" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_double {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_none {}
+
+sub GET_op_tr_array {
+ my $fh = shift;
+ my $len = unpack "S", $fh->readn(2);
+ my @ary = unpack "S*", $fh->readn($len*2);
+ return join(",", $len, @ary);
+}
+
+sub GET_IV64 {
+ my $fh = shift;
+ my $str = $fh->readn(8);
+ croak "reached EOF while reading I32" unless length($str) == 8;
+ return sprintf "0x%09llx", unpack("q", $str);
+}
+
+sub GET_IV {
+ $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
+}
+
+sub GET_PADOFFSET {
+ $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
+}
+
+sub GET_long {
+ $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
+}
+
+
+package B::Disassembler;
+use Exporter;
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(disassemble_fh get_header);
+use Carp;
+use strict;
+
+use B::Asmdata qw(%insn_data @insn_name);
+
+our( $magic, $archname, $blversion, $ivsize, $ptrsize );
+
+sub dis_header($){
+ my( $fh ) = @_;
+ $magic = $fh->GET_U32();
+ warn( "bad magic" ) if $magic != 0x43424c50;
+ $archname = $fh->GET_strconst();
+ $blversion = $fh->GET_strconst();
+ $ivsize = $fh->GET_U32();
+ $ptrsize = $fh->GET_U32();
+}
+
+sub get_header(){
+ return( $magic, $archname, $blversion, $ivsize, $ptrsize);
+}
+
+sub disassemble_fh {
+ my ($fh, $out) = @_;
+ my ($c, $getmeth, $insn, $arg);
+ bless $fh, "B::Disassembler::BytecodeStream";
+ dis_header( $fh );
+ while (defined($c = $fh->getc)) {
+ $c = ord($c);
+ $insn = $insn_name[$c];
+ if (!defined($insn) || $insn eq "unused") {
+ my $pos = $fh->tell - 1;
+ die "Illegal instruction code $c at stream offset $pos\n";
+ }
+ $getmeth = $insn_data{$insn}->[2];
+ $arg = $fh->$getmeth();
+ if (defined($arg)) {
+ &$out($insn, $arg);
+ } else {
+ &$out($insn);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Disassembler - Disassemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use Disassembler;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Disassembler.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/Lint.pm
==============================================================================
--- (empty file)
+++ B/B/Lint.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,392 @@
+package B::Lint;
+
+our $VERSION = '1.03';
+
+=head1 NAME
+
+B::Lint - Perl lint
+
+=head1 SYNOPSIS
+
+perl -MO=Lint[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Lint module is equivalent to an extended version of the B<-w>
+option of B<perl>. It is named after the program F<lint> which carries
+out a similar process for C programs.
+
+=head1 OPTIONS AND LINT CHECKS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options. Following any options
+(indicated by a leading B<->) come lint check arguments. Each such
+argument (apart from the special B<all> and B<none> options) is a
+word representing one possible lint check (turning on that check) or
+is B<no-foo> (turning off that check). Before processing the check
+arguments, a standard list of checks is turned on. Later options
+override earlier ones. Available options are:
+
+=over 8
+
+=item B<context>
+
+Produces a warning whenever an array is used in an implicit scalar
+context. For example, both of the lines
+
+ $foo = length(@bar);
+ $foo = @bar;
+
+will elicit a warning. Using an explicit B<scalar()> silences the
+warning. For example,
+
+ $foo = scalar(@bar);
+
+=item B<implicit-read> and B<implicit-write>
+
+These options produce a warning whenever an operation implicitly
+reads or (respectively) writes to one of Perl's special variables.
+For example, B<implicit-read> will warn about these:
+
+ /foo/;
+
+and B<implicit-write> will warn about these:
+
+ s/foo/bar/;
+
+Both B<implicit-read> and B<implicit-write> warn about this:
+
+ for (@a) { ... }
+
+=item B<bare-subs>
+
+This option warns whenever a bareword is implicitly quoted, but is also
+the name of a subroutine in the current package. Typical mistakes that it will
+trap are:
+
+ use constant foo => 'bar';
+ @a = ( foo => 1 );
+ $b{foo} = 2;
+
+Neither of these will do what a naive user would expect.
+
+=item B<dollar-underscore>
+
+This option warns whenever C<$_> is used either explicitly anywhere or
+as the implicit argument of a B<print> statement.
+
+=item B<private-names>
+
+This option warns on each use of any variable, subroutine or
+method name that lives in a non-current package but begins with
+an underscore ("_"). Warnings aren't issued for the special case
+of the single character name "_" by itself (e.g. C<$_> and C<@_>).
+
+=item B<undefined-subs>
+
+This option warns whenever an undefined subroutine is invoked.
+This option will only catch explicitly invoked subroutines such
+as C<foo()> and not indirect invocations such as C<&$subref()>
+or C<$obj-E<gt>meth()>. Note that some programs or modules delay
+definition of subs until runtime by means of the AUTOLOAD
+mechanism.
+
+=item B<regexp-variables>
+
+This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
+is used. Any occurrence of any of these variables in your
+program can slow your whole program down. See L<perlre> for
+details.
+
+=item B<all>
+
+Turn all warnings on.
+
+=item B<none>
+
+Turn all warnings off.
+
+=back
+
+=head1 NON LINT-CHECK OPTIONS
+
+=over 8
+
+=item B<-u Package>
+
+Normally, Lint only checks the main code of the program together
+with all subs defined in package main. The B<-u> option lets you
+include other package names whose subs are then checked by Lint.
+
+=back
+
+=head1 BUGS
+
+This is only a very preliminary version.
+
+This module doesn't work correctly on thread-enabled perls.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie at sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(walkoptree_slow main_root walksymtable svref_2object parents
+ OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
+ );
+
+my $file = "unknown"; # shadows current filename
+my $line = 0; # shadows current line number
+my $curstash = "main"; # shadows current stash
+
+# Lint checks
+my %check;
+my %implies_ok_context;
+BEGIN {
+ map($implies_ok_context{$_}++,
+ qw(scalar av2arylen aelem aslice helem hslice
+ keys values hslice defined undef delete));
+}
+
+# Lint checks turned on by default
+my @default_checks = qw(context);
+
+my %valid_check;
+# All valid checks
+BEGIN {
+ map($valid_check{$_}++,
+ qw(context implicit_read implicit_write dollar_underscore
+ private_names bare_subs undefined_subs regexp_variables));
+}
+
+# Debugging options
+my ($debug_op);
+
+my %done_cv; # used to mark which subs have already been linted
+my @extra_packages; # Lint checks mainline code and all subs which are
+ # in main:: or in one of these packages.
+
+sub warning {
+ my $format = (@_ < 2) ? "%s" : shift;
+ warn sprintf("$format at %s line %d\n", @_, $file, $line);
+}
+
+# This gimme can't cope with context that's only determined
+# at runtime via dowantarray().
+sub gimme {
+ my $op = shift;
+ my $flags = $op->flags;
+ if ($flags & OPf_WANT) {
+ return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
+ }
+ return undef;
+}
+
+sub B::OP::lint {}
+
+sub B::COP::lint {
+ my $op = shift;
+ if ($op->name eq "nextstate") {
+ $file = $op->file;
+ $line = $op->line;
+ $curstash = $op->stash->NAME;
+ }
+}
+
+sub B::UNOP::lint {
+ my $op = shift;
+ my $opname = $op->name;
+ if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
+ my $parent = parents->[0];
+ my $pname = $parent->name;
+ return if gimme($op) || $implies_ok_context{$pname};
+ # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
+ # null out the parent so we have to check for a parent of pp_null and
+ # a grandparent of pp_enteriter or pp_delete
+ if ($pname eq "null") {
+ my $gpname = parents->[1]->name;
+ return if $gpname eq "enteriter" || $gpname eq "delete";
+ }
+ warning("Implicit scalar context for %s in %s",
+ $opname eq "rv2av" ? "array" : "hash", $parent->desc);
+ }
+ if ($check{private_names} && $opname eq "method") {
+ my $methop = $op->first;
+ if ($methop->name eq "const") {
+ my $method = $methop->sv->PV;
+ if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
+ warning("Illegal reference to private method name $method");
+ }
+ }
+ }
+}
+
+sub B::PMOP::lint {
+ my $op = shift;
+ if ($check{implicit_read}) {
+ if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
+ warning('Implicit match on $_');
+ }
+ }
+ if ($check{implicit_write}) {
+ if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
+ warning('Implicit substitution on $_');
+ }
+ }
+}
+
+sub B::LOOP::lint {
+ my $op = shift;
+ if ($check{implicit_read} || $check{implicit_write}) {
+ if ($op->name eq "enteriter") {
+ my $last = $op->last;
+ if ($last->name eq "gv" && $last->gv->NAME eq "_") {
+ warning('Implicit use of $_ in foreach');
+ }
+ }
+ }
+}
+
+sub B::SVOP::lint {
+ my $op = shift;
+ if ( $check{bare_subs} && $op->name eq 'const'
+ && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h
+ {
+ my $sv = $op->sv;
+ if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
+ warning "Bare sub name '" . $sv->PV . "' interpreted as string";
+ }
+ }
+ if ($check{dollar_underscore} && $op->name eq "gvsv"
+ && $op->gv->NAME eq "_")
+ {
+ warning('Use of $_');
+ }
+ if ($check{private_names}) {
+ my $opname = $op->name;
+ if ($opname eq "gv" || $opname eq "gvsv") {
+ my $gv = $op->gv;
+ if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
+ warning('Illegal reference to private name %s', $gv->NAME);
+ }
+ } elsif ($opname eq "method_named") {
+ my $method = $op->gv->PV;
+ if ($method =~ /^_./) {
+ warning("Illegal reference to private method name $method");
+ }
+ }
+ }
+ if ($check{undefined_subs}) {
+ if ($op->name eq "gv"
+ && $op->next->name eq "entersub")
+ {
+ my $gv = $op->gv;
+ my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
+ no strict 'refs';
+ if (!defined(&$subname)) {
+ $subname =~ s/^main:://;
+ warning('Undefined subroutine %s called', $subname);
+ }
+ }
+ }
+ if ($check{regexp_variables} && $op->name eq "gvsv") {
+ my $name = $op->gv->NAME;
+ if ($name =~ /^[&'`]$/) {
+ warning('Use of regexp variable $%s', $name);
+ }
+ }
+}
+
+sub B::GV::lintcv {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ #warn sprintf("lintcv: %s::%s (done=%d)\n",
+ # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
+ return if !$$cv || $done_cv{$$cv}++;
+ my $root = $cv->ROOT;
+ #warn " root = $root (0x$$root)\n";#debug
+ walkoptree_slow($root, "lint") if $$root;
+}
+
+sub do_lint {
+ my %search_pack;
+ walkoptree_slow(main_root, "lint") if ${main_root()};
+
+ # Now do subs in main
+ no strict qw(vars refs);
+ local(*glob);
+ for my $sym (keys %main::) {
+ next if $sym =~ /::$/;
+ *glob = $main::{$sym};
+ svref_2object(\*glob)->EGV->lintcv;
+ }
+
+ # Now do subs in non-main packages given by -u options
+ map { $search_pack{$_} = 1 } @extra_packages;
+ walksymtable(\%{"main::"}, "lintcv", sub {
+ my $package = shift;
+ $package =~ s/::$//;
+ #warn "Considering $package\n";#debug
+ return exists $search_pack{$package};
+ });
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ # Turn on default lint checks
+ for $opt (@default_checks) {
+ $check{$opt} = 1;
+ }
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ }
+ }
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ push(@extra_packages, $arg);
+ }
+ }
+ foreach $opt (@default_checks, @options) {
+ $opt =~ tr/-/_/;
+ if ($opt eq "all") {
+ %check = %valid_check;
+ }
+ elsif ($opt eq "none") {
+ %check = ();
+ }
+ else {
+ if ($opt =~ s/^no_//) {
+ $check{$opt} = 0;
+ }
+ else {
+ $check{$opt} = 1;
+ }
+ warn "No such check: $opt\n" unless defined $valid_check{$opt};
+ }
+ }
+ # Remaining arguments are things to check
+
+ return \&do_lint;
+}
+
+1;
Added: B/B/Showlex.pm
==============================================================================
--- (empty file)
+++ B/B/Showlex.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,205 @@
+package B::Showlex;
+
+our $VERSION = '1.02';
+
+use strict;
+use B qw(svref_2object comppadlist class);
+use B::Terse ();
+use B::Concise ();
+
+#
+# Invoke as
+# perl -MO=Showlex,foo bar.pl
+# to see the names of lexical variables used by &foo
+# or as
+# perl -MO=Showlex bar.pl
+# to see the names of file scope lexicals used by bar.pl
+#
+
+
+# borrowed from B::Concise
+our $walkHandle = \*STDOUT;
+
+sub walk_output { # updates $walkHandle
+ $walkHandle = B::Concise::walk_output(@_);
+ #print "got $walkHandle";
+ #print $walkHandle "using it";
+ $walkHandle;
+}
+
+sub shownamearray {
+ my ($name, $av) = @_;
+ my @els = $av->ARRAY;
+ my $count = @els;
+ my $i;
+ print $walkHandle "$name has $count entries\n";
+ for ($i = 0; $i < $count; $i++) {
+ my $sv = $els[$i];
+ if (class($sv) ne "SPECIAL") {
+ printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
+ } else {
+ printf $walkHandle "$i: %s\n", $sv->terse;
+ #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
+ }
+ }
+}
+
+sub showvaluearray {
+ my ($name, $av) = @_;
+ my @els = $av->ARRAY;
+ my $count = @els;
+ my $i;
+ print $walkHandle "$name has $count entries\n";
+ for ($i = 0; $i < $count; $i++) {
+ printf $walkHandle "$i: %s\n", $els[$i]->terse;
+ #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]);
+ }
+}
+
+sub showlex {
+ my ($objname, $namesav, $valsav) = @_;
+ shownamearray("Pad of lexical names for $objname", $namesav);
+ showvaluearray("Pad of lexical values for $objname", $valsav);
+}
+
+my ($newlex, $nosp1); # rendering state vars
+
+sub newlex { # drop-in for showlex
+ my ($objname, $names, $vals) = @_;
+ my @names = $names->ARRAY;
+ my @vals = $vals->ARRAY;
+ my $count = @names;
+ print $walkHandle "$objname Pad has $count entries\n";
+ printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1;
+ for (my $i = 1; $i < $count; $i++) {
+ printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse
+ unless $nosp1 and $names[$i]->terse =~ /SPECIAL/;
+ }
+}
+
+sub showlex_obj {
+ my ($objname, $obj) = @_;
+ $objname =~ s/^&main::/&/;
+ showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex;
+ newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex;
+}
+
+sub showlex_main {
+ showlex("comppadlist", comppadlist->ARRAY) if !$newlex;
+ newlex ("main", comppadlist->ARRAY) if $newlex;
+}
+
+sub compile {
+ my @options = grep(/^-/, @_);
+ my @args = grep(!/^-/, @_);
+ for my $o (@options) {
+ $newlex = 1 if $o eq "-newlex";
+ $nosp1 = 1 if $o eq "-nosp";
+ }
+
+ return \&showlex_main unless @args;
+ return sub {
+ my $objref;
+ foreach my $objname (@args) {
+ next unless $objname; # skip nulls w/o carping
+
+ if (ref $objname) {
+ print $walkHandle "B::Showlex::compile($objname)\n";
+ $objref = $objname;
+ } else {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ die "err: unknown function ($objname)\n"
+ unless *{$objname}{CODE};
+ $objref = \&$objname;
+ }
+ showlex_obj($objname, $objref);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Showlex - Show lexical variables used in functions or files
+
+=head1 SYNOPSIS
+
+ perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl
+
+=head1 DESCRIPTION
+
+When a comma-separated list of subroutine names is given as options, Showlex
+prints the lexical variables used in those subroutines. Otherwise, it prints
+the file-scope lexicals in the file.
+
+=head1 EXAMPLES
+
+Traditional form:
+
+ $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")'
+ Pad of lexical names for comppadlist has 4 entries
+ 0: SPECIAL #1 &PL_sv_undef
+ 1: PVNV (0x9db0fb0) $i
+ 2: PVNV (0x9db0f38) $j
+ 3: PVNV (0x9db0f50) $k
+ Pad of lexical values for comppadlist has 5 entries
+ 0: SPECIAL #1 &PL_sv_undef
+ 1: NULL (0x9da4234)
+ 2: NULL (0x9db0f2c)
+ 3: NULL (0x9db0f44)
+ 4: NULL (0x9da4264)
+ -e syntax OK
+
+New-style form:
+
+ $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")'
+ main Pad has 4 entries
+ 0: SPECIAL #1 &PL_sv_undef
+ 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234)
+ 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34)
+ 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
+ -e syntax OK
+
+New form, no specials, outside O framework:
+
+ $ perl -MB::Showlex -e \
+ 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()'
+ main Pad has 4 entries
+ 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1
+ 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo"
+ 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74)
+
+Note that this example shows the values of the lexicals, whereas the other
+examples did not (as they're compile-time only).
+
+=head2 OPTIONS
+
+The C<-newlex> option produces a more readable C<< name => value >> format,
+and is shown in the second example above.
+
+The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL
+#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm
+your declared lexicals.
+
+=head1 SEE ALSO
+
+C<B::Showlex> can also be used outside of the O framework, as in the third
+example. See C<B::Concise> for a fuller explanation of reasons.
+
+=head1 TODO
+
+Some of the reported info, such as hex addresses, is not particularly
+valuable. Other information would be more useful for the typical
+programmer, such as line-numbers, pad-slot reuses, etc.. Given this,
+-newlex isnt a particularly good flag-name.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/Stackobj.pm
==============================================================================
--- (empty file)
+++ B/B/Stackobj.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,349 @@
+# Stackobj.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::Stackobj;
+
+our $VERSION = '1.00';
+
+use Exporter ();
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
+ VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
+%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
+ flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
+ VALID_UNSIGNED REGISTER TEMPORARY)]);
+
+use Carp qw(confess);
+use strict;
+use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
+
+# Types
+sub T_UNKNOWN () { 0 }
+sub T_DOUBLE () { 1 }
+sub T_INT () { 2 }
+sub T_SPECIAL () { 3 }
+
+# Flags
+sub VALID_INT () { 0x01 }
+sub VALID_UNSIGNED () { 0x02 }
+sub VALID_DOUBLE () { 0x04 }
+sub VALID_SV () { 0x08 }
+sub REGISTER () { 0x10 } # no implicit write-back when calling subs
+sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
+sub SAVE_INT () { 0x40 } #if int part needs to be saved at all
+sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all
+
+
+#
+# Callback for runtime code generation
+#
+my $runtime_callback = sub { confess "set_callback not yet called" };
+sub set_callback (&) { $runtime_callback = shift }
+sub runtime { &$runtime_callback(@_) }
+
+#
+# Methods
+#
+
+sub write_back { confess "stack object does not implement write_back" }
+
+sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
+
+sub as_sv {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_SV)) {
+ $obj->write_back;
+ $obj->{flags} |= VALID_SV;
+ }
+ return $obj->{sv};
+}
+
+sub as_int {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_INT)) {
+ $obj->load_int;
+ $obj->{flags} |= VALID_INT|SAVE_INT;
+ }
+ return $obj->{iv};
+}
+
+sub as_double {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_DOUBLE)) {
+ $obj->load_double;
+ $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+ }
+ return $obj->{nv};
+}
+
+sub as_numeric {
+ my $obj = shift;
+ return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
+}
+
+sub as_bool {
+ my $obj=shift;
+ if ($obj->{flags} & VALID_INT ){
+ return $obj->{iv};
+ }
+ if ($obj->{flags} & VALID_DOUBLE ){
+ return $obj->{nv};
+ }
+ return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
+}
+
+#
+# Debugging methods
+#
+sub peek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ my @flags;
+ if ($type == T_UNKNOWN) {
+ $type = "T_UNKNOWN";
+ } elsif ($type == T_INT) {
+ $type = "T_INT";
+ } elsif ($type == T_DOUBLE) {
+ $type = "T_DOUBLE";
+ } else {
+ $type = "(illegal type $type)";
+ }
+ push(@flags, "VALID_INT") if $flags & VALID_INT;
+ push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
+ push(@flags, "VALID_SV") if $flags & VALID_SV;
+ push(@flags, "REGISTER") if $flags & REGISTER;
+ push(@flags, "TEMPORARY") if $flags & TEMPORARY;
+ @flags = ("none") unless @flags;
+ return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
+ class($obj), join("|", @flags));
+}
+
+sub minipeek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ if ($type == T_INT || $flags & VALID_INT) {
+ return $obj->{iv};
+ } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
+ return $obj->{nv};
+ } else {
+ return $obj->{sv};
+ }
+}
+
+#
+# Caller needs to ensure that set_int, set_double,
+# set_numeric and set_sv are only invoked on legal lvalues.
+#
+sub set_int {
+ my ($obj, $expr,$unsigned) = @_;
+ runtime("$obj->{iv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
+ $obj->{flags} |= VALID_INT|SAVE_INT;
+ $obj->{flags} |= VALID_UNSIGNED if $unsigned;
+}
+
+sub set_double {
+ my ($obj, $expr) = @_;
+ runtime("$obj->{nv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_INT);
+ $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+}
+
+sub set_numeric {
+ my ($obj, $expr) = @_;
+ if ($obj->{type} == T_INT) {
+ $obj->set_int($expr);
+ } else {
+ $obj->set_double($expr);
+ }
+}
+
+sub set_sv {
+ my ($obj, $expr) = @_;
+ runtime("SvSetSV($obj->{sv}, $expr);");
+ $obj->invalidate;
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Padsv
+#
+
+ at B::Stackobj::Padsv::ISA = 'B::Stackobj';
+sub B::Stackobj::Padsv::new {
+ my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+ $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
+ $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
+ bless {
+ type => $type,
+ flags => VALID_SV | $extra_flags,
+ sv => "PL_curpad[$ix]",
+ iv => "$iname",
+ nv => "$dname"
+ }, $class;
+}
+
+sub B::Stackobj::Padsv::load_int {
+ my $obj = shift;
+ if ($obj->{flags} & VALID_DOUBLE) {
+ runtime("$obj->{iv} = $obj->{nv};");
+ } else {
+ runtime("$obj->{iv} = SvIV($obj->{sv});");
+ }
+ $obj->{flags} |= VALID_INT|SAVE_INT;
+}
+
+sub B::Stackobj::Padsv::load_double {
+ my $obj = shift;
+ $obj->write_back;
+ runtime("$obj->{nv} = SvNV($obj->{sv});");
+ $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+}
+sub B::Stackobj::Padsv::save_int {
+ my $obj = shift;
+ return $obj->{flags} & SAVE_INT;
+}
+
+sub B::Stackobj::Padsv::save_double {
+ my $obj = shift;
+ return $obj->{flags} & SAVE_DOUBLE;
+}
+
+sub B::Stackobj::Padsv::write_back {
+ my $obj = shift;
+ my $flags = $obj->{flags};
+ return if $flags & VALID_SV;
+ if ($flags & VALID_INT) {
+ if ($flags & VALID_UNSIGNED ){
+ runtime("sv_setuv($obj->{sv}, $obj->{iv});");
+ }else{
+ runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+ }
+ } elsif ($flags & VALID_DOUBLE) {
+ runtime("sv_setnv($obj->{sv}, $obj->{nv});");
+ } else {
+ confess "write_back failed for lexical @{[$obj->peek]}\n";
+ }
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Const
+#
+
+ at B::Stackobj::Const::ISA = 'B::Stackobj';
+sub B::Stackobj::Const::new {
+ my ($class, $sv) = @_;
+ my $obj = bless {
+ flags => 0,
+ sv => $sv # holds the SV object until write_back happens
+ }, $class;
+ if ( ref($sv) eq "B::SPECIAL" ){
+ $obj->{type}= T_SPECIAL;
+ }else{
+ my $svflags = $sv->FLAGS;
+ if ($svflags & SVf_IOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_INT;
+ if ($svflags & SVf_IVisUV){
+ $obj->{flags} |= VALID_UNSIGNED;
+ $obj->{nv} = $obj->{iv} = $sv->UVX;
+ }else{
+ $obj->{nv} = $obj->{iv} = $sv->IV;
+ }
+ } elsif ($svflags & SVf_NOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_DOUBLE;
+ $obj->{iv} = $obj->{nv} = $sv->NV;
+ } else {
+ $obj->{type} = T_UNKNOWN;
+ }
+ }
+ return $obj;
+}
+
+sub B::Stackobj::Const::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ # Save the SV object and replace $obj->{sv} by its C source code name
+ $obj->{sv} = $obj->{sv}->save;
+ $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::load_int {
+ my $obj = shift;
+ if (ref($obj->{sv}) eq "B::RV"){
+ $obj->{iv} = int($obj->{sv}->RV->PV);
+ }else{
+ $obj->{iv} = int($obj->{sv}->PV);
+ }
+ $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Const::load_double {
+ my $obj = shift;
+ if (ref($obj->{sv}) eq "B::RV"){
+ $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
+ }else{
+ $obj->{nv} = $obj->{sv}->PV + 0.0;
+ }
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::invalidate {}
+
+#
+# Stackobj::Bool
+#
+
+ at B::Stackobj::Bool::ISA = 'B::Stackobj';
+sub B::Stackobj::Bool::new {
+ my ($class, $preg) = @_;
+ my $obj = bless {
+ type => T_INT,
+ flags => VALID_INT|VALID_DOUBLE,
+ iv => $$preg,
+ nv => $$preg,
+ preg => $preg # this holds our ref to the pseudo-reg
+ }, $class;
+ return $obj;
+}
+
+sub B::Stackobj::Bool::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
+ $obj->{flags} |= VALID_SV;
+}
+
+# XXX Might want to handle as_double/set_double/load_double?
+
+sub B::Stackobj::Bool::invalidate {}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Stackobj - Helper module for CC backend
+
+=head1 SYNOPSIS
+
+ use B::Stackobj;
+
+=head1 DESCRIPTION
+
+See F<ext/B/README>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/B/Stash.pm
==============================================================================
--- (empty file)
+++ B/B/Stash.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,52 @@
+# Stash.pm -- show what stashes are loaded
+# vishalb at hotmail.com
+package B::Stash;
+
+our $VERSION = '1.00';
+
+=pod
+
+=head1 NAME
+
+B::Stash - show what stashes are loaded
+
+=cut
+
+BEGIN { %Seen = %INC }
+
+CHECK {
+ my @arr=scan($main::{"main::"});
+ @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr;
+ print "-umain,-u", join (",-u", at arr) ,"\n";
+}
+sub scan{
+ my $start=shift;
+ my $prefix=shift;
+ $prefix = '' unless defined $prefix;
+ my @return;
+ foreach my $key ( keys %{$start}){
+# print $prefix,$key,"\n";
+ if ($key =~ /::$/){
+ unless ($start eq ${$start}{$key} or $key eq "B::" ){
+ push @return, $key unless omit($prefix.$key);
+ foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){
+ push @return, "$key".$subscan;
+ }
+ }
+ }
+ }
+ return @return;
+}
+sub omit{
+ my $module = shift;
+ my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 ,
+ "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 );
+ return 1 if $omit{$module};
+ if ($module eq "IO::" or $module eq "IO::Handle::"){
+ $module =~ s/::/\//g;
+ return 1 unless $INC{$module};
+ }
+
+ return 0;
+}
+1;
Added: B/B/Terse.pm
==============================================================================
--- (empty file)
+++ B/B/Terse.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,103 @@
+package B::Terse;
+
+our $VERSION = '1.03_01';
+
+use strict;
+use B qw(class);
+use B::Asmdata qw(@specialsv_name);
+use B::Concise qw(concise_subref set_style_standard);
+use Carp;
+
+sub terse {
+ my ($order, $subref) = @_;
+ set_style_standard("terse");
+ if ($order eq "exec") {
+ concise_subref('exec', $subref);
+ } else {
+ concise_subref('basic', $subref);
+ }
+}
+
+sub compile {
+ my @args = @_;
+ my $order = @args ? shift(@args) : "";
+ $order = "-exec" if $order eq "exec";
+ unshift @args, $order if $order ne "";
+ B::Concise::compile("-terse", @args);
+}
+
+sub indent {
+ my ($level) = @_ ? shift : 0;
+ return " " x $level;
+}
+
+# Don't use this, at least on OPs in subroutines: it has no way of
+# getting to the pad, and will give wrong answers or crash.
+sub B::OP::terse {
+ carp "B::OP::terse is deprecated; use B::Concise instead";
+ B::Concise::b_terse(@_);
+}
+
+sub B::SV::terse {
+ my($sv, $level) = (@_, 0);
+ my %info;
+ B::Concise::concise_sv($sv, \%info);
+ my $s = indent($level)
+ . B::Concise::fmt_line(\%info, $sv,
+ "#svclass~(?((#svaddr))?)~#svval", 0);
+ chomp $s;
+ print "$s\n" unless defined wantarray;
+ $s;
+}
+
+sub B::NULL::terse {
+ my ($sv, $level) = (@_, 0);
+ my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv;
+ print "$s\n" unless defined wantarray;
+ $s;
+}
+
+sub B::SPECIAL::terse {
+ my ($sv, $level) = (@_, 0);
+ my $s = indent($level)
+ . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]);
+ print "$s\n" unless defined wantarray;
+ $s;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Terse - Walk Perl syntax tree, printing terse info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Terse[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This version of B::Terse is really just a wrapper that calls B::Concise
+with the B<-terse> option. It is provided for compatibility with old scripts
+(and habits) but using B::Concise directly is now recommended instead.
+
+For compatibility with the old B::Terse, this module also adds a
+method named C<terse> to B::OP and B::SV objects. The B::SV method is
+largely compatible with the old one, though authors of new software
+might be advised to choose a more user-friendly output format. The
+B::OP C<terse> method, however, doesn't work well. Since B::Terse was
+first written, much more information in OPs has migrated to the
+scratchpad datastructure, but the C<terse> interface doesn't have any
+way of getting to the correct pad. As a kludge, the new version will
+always use the pad for the main program, but for OPs in subroutines
+this will give the wrong answer or crash.
+
+=head1 AUTHOR
+
+The original version of B::Terse was written by Malcolm Beattie,
+E<lt>mbeattie at sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
+McCamant, E<lt>smcc at MIT.EDUE<gt>.
+
+=cut
Added: B/B/Xref.pm
==============================================================================
--- (empty file)
+++ B/B/Xref.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,430 @@
+package B::Xref;
+
+our $VERSION = '1.01';
+
+=head1 NAME
+
+B::Xref - Generates cross reference reports for Perl programs
+
+=head1 SYNOPSIS
+
+perl -MO=Xref[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Xref module is used to generate a cross reference listing of all
+definitions and uses of variables, subroutines and formats in a Perl program.
+It is implemented as a backend for the Perl compiler.
+
+The report generated is in the following format:
+
+ File filename1
+ Subroutine subname1
+ Package package1
+ object1 line numbers
+ object2 line numbers
+ ...
+ Package package2
+ ...
+
+Each B<File> section reports on a single file. Each B<Subroutine> section
+reports on a single subroutine apart from the special cases
+"(definitions)" and "(main)". These report, respectively, on subroutine
+definitions found by the initial symbol table walk and on the main part of
+the program or module external to all subroutines.
+
+The report is then grouped by the B<Package> of each variable,
+subroutine or format with the special case "(lexicals)" meaning
+lexical variables. Each B<object> name (implicitly qualified by its
+containing B<Package>) includes its type character(s) at the beginning
+where possible. Lexical variables are easier to track and even
+included dereferencing information where possible.
+
+The C<line numbers> are a comma separated list of line numbers (some
+preceded by code letters) where that object is used in some way.
+Simple uses aren't preceded by a code letter. Introductions (such as
+where a lexical is first defined with C<my>) are indicated with the
+letter "i". Subroutine and method calls are indicated by the character
+"&". Subroutine definitions are indicated by "s" and format
+definitions by "f".
+
+=head1 OPTIONS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options.
+
+=over 8
+
+=item C<-oFILENAME>
+
+Directs output to C<FILENAME> instead of standard output.
+
+=item C<-r>
+
+Raw output. Instead of producing a human-readable report, outputs a line
+in machine-readable form for each definition/use of a variable/sub/format.
+
+=item C<-d>
+
+Don't output the "(definitions)" sections.
+
+=item C<-D[tO]>
+
+(Internal) debug options, probably only useful if C<-r> included.
+The C<t> option prints the object on the top of the stack as it's
+being tracked. The C<O> option prints each operator as it's being
+processed in the execution order of the program.
+
+=back
+
+=head1 BUGS
+
+Non-lexical variables are quite difficult to track through a program.
+Sometimes the type of a non-lexical variable's use is impossible to
+determine. Introductions of non-lexical non-scalars don't seem to be
+reported properly.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie at sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use Config;
+use B qw(peekop class comppadlist main_start svref_2object walksymtable
+ OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
+ );
+
+sub UNKNOWN { ["?", "?", "?"] }
+
+my @pad; # lexicals in current pad
+ # as ["(lexical)", type, name]
+my %done; # keyed by $$op: set when each $op is done
+my $top = UNKNOWN; # shadows top element of stack as
+ # [pack, type, name] (pack can be "(lexical)")
+my $file; # shadows current filename
+my $line; # shadows current line number
+my $subname; # shadows current sub name
+my %table; # Multi-level hash to record all uses etc.
+my @todo = (); # List of CVs that need processing
+
+my %code = (intro => "i", used => "",
+ subdef => "s", subused => "&",
+ formdef => "f", meth => "->");
+
+
+# Options
+my ($debug_op, $debug_top, $nodefs, $raw);
+
+sub process {
+ my ($var, $event) = @_;
+ my ($pack, $type, $name) = @$var;
+ if ($type eq "*") {
+ if ($event eq "used") {
+ return;
+ } elsif ($event eq "subused") {
+ $type = "&";
+ }
+ }
+ $type =~ s/(.)\*$/$1/g;
+ if ($raw) {
+ printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
+ $file, $subname, $line, $pack, $type, $name, $event;
+ } else {
+ # Wheee
+ push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
+ $line);
+ }
+}
+
+sub load_pad {
+ my $padlist = shift;
+ my ($namelistav, $vallistav, @namelist, $ix);
+ @pad = ();
+ return if class($padlist) eq "SPECIAL";
+ ($namelistav,$vallistav) = $padlist->ARRAY;
+ @namelist = $namelistav->ARRAY;
+ for ($ix = 1; $ix < @namelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ next if class($namesv) eq "SPECIAL";
+ my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
+ $pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
+ }
+ if ($Config{useithreads}) {
+ my (@vallist);
+ @vallist = $vallistav->ARRAY;
+ for ($ix = 1; $ix < @vallist; $ix++) {
+ my $valsv = $vallist[$ix];
+ next unless class($valsv) eq "GV";
+ # these pad GVs don't have corresponding names, so same @pad
+ # array can be used without collisions
+ $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
+ }
+ }
+}
+
+sub xref {
+ my $start = shift;
+ my $op;
+ for ($op = $start; $$op; $op = $op->next) {
+ last if $done{$$op}++;
+ warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
+ warn peekop($op), "\n" if $debug_op;
+ my $opname = $op->name;
+ if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
+ xref($op->other);
+ } elsif ($opname eq "match" || $opname eq "subst") {
+ xref($op->pmreplstart);
+ } elsif ($opname eq "substcont") {
+ xref($op->other->pmreplstart);
+ $op = $op->other;
+ redo;
+ } elsif ($opname eq "enterloop") {
+ xref($op->redoop);
+ xref($op->nextop);
+ xref($op->lastop);
+ } elsif ($opname eq "subst") {
+ xref($op->pmreplstart);
+ } else {
+ no strict 'refs';
+ my $ppname = "pp_$opname";
+ &$ppname($op) if defined(&$ppname);
+ }
+ }
+}
+
+sub xref_cv {
+ my $cv = shift;
+ my $pack = $cv->GV->STASH->NAME;
+ $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
+ load_pad($cv->PADLIST);
+ xref($cv->START);
+ $subname = "(main)";
+}
+
+sub xref_object {
+ my $cvref = shift;
+ xref_cv(svref_2object($cvref));
+}
+
+sub xref_main {
+ $subname = "(main)";
+ load_pad(comppadlist);
+ xref(main_start);
+ while (@todo) {
+ xref_cv(shift @todo);
+ }
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $file = $op->file;
+ $line = $op->line;
+ $top = UNKNOWN;
+}
+
+sub pp_padsv {
+ my $op = shift;
+ $top = $pad[$op->targ];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+sub deref {
+ my ($op, $var, $as) = @_;
+ $var->[1] = $as . $var->[1];
+ process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
+}
+
+sub pp_rv2cv { deref(shift, $top, "&"); }
+sub pp_rv2hv { deref(shift, $top, "%"); }
+sub pp_rv2sv { deref(shift, $top, "\$"); }
+sub pp_rv2av { deref(shift, $top, "\@"); }
+sub pp_rv2gv { deref(shift, $top, "*"); }
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gv;
+ if ($Config{useithreads}) {
+ $top = $pad[$op->padix];
+ $top = UNKNOWN unless $top;
+ $top->[1] = '$';
+ }
+ else {
+ $gv = $op->gv;
+ $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
+ }
+ process($top, $op->private & OPpLVAL_INTRO ||
+ $op->private & OPpOUR_INTRO ? "intro" : "used");
+}
+
+sub pp_gv {
+ my $op = shift;
+ my $gv;
+ if ($Config{useithreads}) {
+ $top = $pad[$op->padix];
+ $top = UNKNOWN unless $top;
+ $top->[1] = '*';
+ }
+ else {
+ $gv = $op->gv;
+ $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
+ }
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ # constant could be in the pad (under useithreads)
+ if ($$sv) {
+ $top = ["?", "",
+ (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
+ ? cstring($sv->PV) : "?"];
+ }
+ else {
+ $top = $pad[$op->targ];
+ $top = UNKNOWN unless $top;
+ }
+}
+
+sub pp_method {
+ my $op = shift;
+ $top = ["(method)", "->".$top->[1], $top->[2]];
+}
+
+sub pp_entersub {
+ my $op = shift;
+ if ($top->[1] eq "m") {
+ process($top, "meth");
+ } else {
+ process($top, "subused");
+ }
+ $top = UNKNOWN;
+}
+
+#
+# Stuff for cross referencing definitions of variables and subs
+#
+
+sub B::GV::xref {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ if ($$cv) {
+ #return if $done{$$cv}++;
+ $file = $gv->FILE;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
+ push(@todo, $cv);
+ }
+ my $form = $gv->FORM;
+ if ($$form) {
+ return if $done{$$form}++;
+ $file = $gv->FILE;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
+ }
+}
+
+sub xref_definitions {
+ my ($pack, %exclude);
+ return if $nodefs;
+ $subname = "(definitions)";
+ foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
+ strict vars FileHandle Exporter Carp PerlIO::Layer
+ attributes utf8 warnings)) {
+ $exclude{$pack."::"} = 1;
+ }
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
+}
+
+sub output {
+ return if $raw;
+ my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
+ $perpack, $pername, $perev);
+ foreach $file (sort(keys(%table))) {
+ $perfile = $table{$file};
+ print "File $file\n";
+ foreach $subname (sort(keys(%$perfile))) {
+ $persubname = $perfile->{$subname};
+ print " Subroutine $subname\n";
+ foreach $pack (sort(keys(%$persubname))) {
+ $perpack = $persubname->{$pack};
+ print " Package $pack\n";
+ foreach $name (sort(keys(%$perpack))) {
+ $pername = $perpack->{$name};
+ my @lines;
+ foreach $ev (qw(intro formdef subdef meth subused used)) {
+ $perev = $pername->{$ev};
+ if (defined($perev) && @$perev) {
+ my $code = $code{$ev};
+ push(@lines, map("$code$_", @$perev));
+ }
+ }
+ printf " %-16s %s\n", $name, join(", ", @lines);
+ }
+ }
+ }
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "d") {
+ $nodefs = 1;
+ } elsif ($opt eq "r") {
+ $raw = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "t") {
+ $debug_top = 1;
+ }
+ }
+ }
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ xref_definitions();
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "xref_object(\\&$objname)";
+ die "xref_object(\\&$objname) failed: $@" if $@;
+ }
+ output();
+ }
+ } else {
+ return sub {
+ xref_definitions();
+ xref_main();
+ output();
+ }
+ }
+}
+
+1;
Added: B/B/assemble
==============================================================================
--- (empty file)
+++ B/B/assemble Tue Jun 26 12:23:24 2007
@@ -0,0 +1,30 @@
+use B::Assembler qw(assemble_fh);
+use FileHandle;
+
+my ($filename, $fh, $out);
+
+if ($ARGV[0] eq "-d") {
+ B::Assembler::debug(1);
+ shift;
+}
+
+$out = \*STDOUT;
+
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+ $filename = "-";
+} elsif (@ARGV == 1) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+} elsif (@ARGV == 2) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+ $out = new FileHandle ">$ARGV[1]";
+} else {
+ die "Usage: assemble [filename] [outfilename]\n";
+}
+
+binmode $out;
+$SIG{__WARN__} = sub { warn "$filename:@_" };
+$SIG{__DIE__} = sub { die "$filename: @_" };
+assemble_fh($fh, sub { print $out @_ });
Added: B/B/cc_harness
==============================================================================
--- (empty file)
+++ B/B/cc_harness Tue Jun 26 12:23:24 2007
@@ -0,0 +1,12 @@
+use Config;
+
+$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
+
+if (!grep(/^-[cS]$/, @ARGV)) {
+ $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
+ @Config{qw(ldflags libs)});
+}
+
+$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
+print "$cccmd\n";
+exec $cccmd;
Added: B/B/disassemble
==============================================================================
--- (empty file)
+++ B/B/disassemble Tue Jun 26 12:23:24 2007
@@ -0,0 +1,22 @@
+use B::Disassembler qw(disassemble_fh);
+use FileHandle;
+
+my $fh;
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+} elsif (@ARGV == 1) {
+ $fh = new FileHandle "<$ARGV[0]";
+} else {
+ die "Usage: disassemble [filename]\n";
+}
+
+sub print_insn {
+ my ($insn, $arg) = @_;
+ if (defined($arg)) {
+ printf "%s %s\n", $insn, $arg;
+ } else {
+ print $insn, "\n";
+ }
+}
+
+disassemble_fh($fh, \&print_insn);
Added: B/B/makeliblinks
==============================================================================
--- (empty file)
+++ B/B/makeliblinks Tue Jun 26 12:23:24 2007
@@ -0,0 +1,54 @@
+use File::Find;
+use Config;
+
+if (@ARGV != 2) {
+ warn <<"EOT";
+Usage: makeliblinks libautodir targetdir
+where libautodir is the architecture-dependent auto directory
+(e.g. $Config::Config{archlib}/auto).
+EOT
+ exit 2;
+}
+
+my ($libautodir, $targetdir) = @ARGV;
+
+# Calculate relative path prefix from $targetdir to $libautodir
+sub relprefix {
+ my ($to, $from) = @_;
+ my $up;
+ for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
+ $from =~ s(
+ [^/]+ (?# a group of non-slashes)
+ /* (?# maybe with some trailing slashes)
+ $ (?# at the end of the path)
+ )()x;
+ }
+ return (("../" x $up) . substr($to, length($from)));
+}
+
+my $relprefix = relprefix($libautodir, $targetdir);
+
+my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
+
+sub link_if_library {
+ if (/\.($dlext|$lib_ext)$/o) {
+ my $ext = $1;
+ my $name = $File::Find::name;
+ if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
+ die "directory of $name doesn't match $libautodir\n";
+ }
+ substr($name, 0, length($libautodir) + 1) = '';
+ my @parts = split(m(/), $name);
+ if ($parts[-1] ne "$parts[-2].$ext") {
+ die "module name $_ doesn't match its directory $libautodir\n";
+ }
+ pop @parts;
+ my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
+ print "$libpath -> $relprefix/$name\n";
+ symlink("$relprefix/$name", $libpath)
+ or warn "above link failed with error: $!\n";
+ }
+}
+
+find(\&link_if_library, $libautodir);
+exit 0;
Added: B/C/C.xs
==============================================================================
--- (empty file)
+++ B/C/C.xs Tue Jun 26 12:23:24 2007
@@ -0,0 +1,53 @@
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
+static int
+my_runops(pTHX)
+{
+ HV* regexp_hv = get_hv( "B::C::REGEXP", 0 );
+ SV* key = newSViv( 0 );
+
+ do {
+ PERL_ASYNC_CHECK();
+
+ if( PL_op->op_type == OP_QR ) {
+ PMOP* op;
+ REGEXP* rx = PM_GETRE( (PMOP*)PL_op );
+ SV* rv = newSViv( 0 );
+
+ Newx( op, 1, PMOP );
+ Copy( PL_op, op, 1, PMOP );
+ /* we need just the flags */
+ op->op_next = NULL;
+ op->op_sibling = NULL;
+ op->op_first = NULL;
+ op->op_last = NULL;
+ op->op_pmreplroot = NULL;
+ op->op_pmreplstart = NULL;
+ op->op_pmnext = NULL;
+#ifdef USE_ITHREADS
+ op->op_pmoffset = 0;
+#else
+ op->op_pmregexp = 0;
+#endif
+
+ sv_setiv( key, PTR2IV( rx ) );
+ sv_setref_iv( rv, "B::PMOP", PTR2IV( op ) );
+
+ hv_store_ent( regexp_hv, key, rv, 0 );
+ }
+ } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+
+ SvREFCNT_dec( key );
+
+ TAINT_NOT;
+ return 0;
+}
+
+MODULE=B__C PACKAGE=B::C
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ PL_runops = my_runops;
Added: B/C/Makefile.PL
==============================================================================
--- (empty file)
+++ B/C/Makefile.PL Tue Jun 26 12:23:24 2007
@@ -0,0 +1,8 @@
+#!perl
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile( NAME => 'B::C',
+ VERSION_FROM => '../B/C.pm'
+ );
+
Added: B/Makefile.PL
==============================================================================
--- (empty file)
+++ B/Makefile.PL Tue Jun 26 12:23:24 2007
@@ -0,0 +1,65 @@
+use ExtUtils::MakeMaker;
+use Config;
+use File::Spec;
+
+my $e = $Config{'exe_ext'};
+my $o = $Config{'obj_ext'};
+my $exeout_flag = '-o ';
+my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV;
+if ($^O eq 'MSWin32') {
+ if ($Config{'cc'} =~ /^cl/i) {
+ $exeout_flag = '-Fe';
+ }
+ elsif ($Config{'cc'} =~ /^bcc/i) {
+ $exeout_flag = '-e';
+ }
+}
+
+WriteMakefile(
+ NAME => "B",
+ VERSION_FROM => "B.pm",
+ PL_FILES => { 'defsubs_h.PL' => 'defsubs.h' },
+ MAN3PODS => {},
+ clean => {
+ FILES => "perl$e *$o B.c defsubs.h *~"
+ }
+);
+
+package MY;
+
+sub post_constants {
+ "\nLIBS = $Config::Config{libs}\n"
+}
+
+sub headerfilefile {
+ push @makefileopts, MAN3PODS => {};
+}
+
+sub headerpath {
+ if ($core) {
+ return File::Spec->catdir(File::Spec->updir,
+ File::Spec->updir);
+ } else {
+ return File::Spec->catdir($Config::Config{archlibexp}, "CORE");
+ }
+}
+
+sub MY::postamble {
+ my $headerpath = headerpath();
+ my @headers = map { File::Spec->catfile($headerpath, $_) } qw(op.h cop.h);
+ my $noecho = shift->{NOECHO};
+
+"
+B\$(OBJ_EXT) : defsubs.h
+
+defsubs.h :: @headers defsubs_h.PL
+ \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) defsubs_h.PL defsubs.h $headerpath
+"
+}
+
+sub MY::processPL {
+ my $text = shift->SUPER::processPL(@_);
+ # Append our extra parameter
+ $text =~ s/^\t.*defsubs_h\.PL.*/$& . ' ' . headerpath()/me;
+ $text;
+}
Added: B/NOTES
==============================================================================
--- (empty file)
+++ B/NOTES Tue Jun 26 12:23:24 2007
@@ -0,0 +1,168 @@
+C backend invocation
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -v Verbose (currently gives a few compilation statistics)
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed
+ c COPs, prints COPs as processed (incl. file & line num)
+ A prints AV information on saving
+ C prints CV information on saving
+ M prints MAGIC information on saving
+ -f Force optimisations on or off one at a time.
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 and higher set -fcog.
+
+Examples
+ perl -MO=C foo.pl > foo.c
+ perl cc_harness -o foo foo.c
+
+ perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+CC backend invocation
+ If there are any non-option arguments, they are taken to be names of
+ subs to be saved. Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -mModulename Instead of generating source for a runnable executable,
+ generate source for an XSUB module. The
+ boot_Modulename function (which DynaLoader can look
+ for) does the appropriate initialisation and runs the
+ main part of the Perl source that is being compiled.
+ -pn Generate code for perl patchlevel n (e.g. 3 or 4).
+ The default is to generate C code which will link
+ with the currently executing version of perl.
+ running the perl compiler.
+ -D Debug options (concat or separate flags like perl -D)
+ r Writes debugging output to STDERR just as it's about
+ to write to the program's runtime (otherwise writes
+ debugging info as comments in its C output).
+ O Outputs each OP as it's compiled
+ s Outputs the contents of the shadow stack at each OP
+ p Outputs the contents of the shadow pad of lexicals as
+ it's loaded for each sub or the main program.
+ q Outputs the name of each fake PP function in the queue
+ as it's about to processes.
+ l Output the filename and line number of each original
+ line of Perl code as it's processed (pp_nextstate).
+ t Outputs timing information of compilation stages
+ -f Force optimisations on or off one at a time.
+ [
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ These two not in CC yet.
+ ]
+ freetmps-each-bblock Delays FREETMPS from the end of each
+ statement to the end of the each basic
+ block.
+ freetmps-each-loop Delays FREETMPS from the end of each
+ statement to the end of the group of
+ basic blocks forming a loop. At most
+ one of the freetmps-each-* options can
+ be used.
+ omit-taint Omits generating code for handling
+ perl's tainting mechanism.
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 sets -ffreetmps-each-bblock and -O2
+ sets -ffreetmps-each-loop.
+
+Example
+ perl -MO=CC,-O2,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+ perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+ perl cc_harness -shared -c -o Foo.so Foo.c
+
+
+Bytecode backend invocation
+
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT.
+ -- Force end of options.
+ -f Force optimisations on or off one at a time.
+ Each can be preceded by no- to turn the option off.
+ compress-nullops
+ Only fills in the necessary fields of ops which have
+ been optimised away by perl's internal compiler.
+ omit-sequence-numbers
+ Leaves out code to fill in the op_seq field of all ops
+ which is only used by perl's internal compiler.
+ bypass-nullops
+ If op->op_next ever points to a NULLOP, replaces the
+ op_next field with the first non-NULLOP in the path
+ of execution.
+ strip-syntax-tree
+ Leaves out code to fill in the pointers which link the
+ internal syntax tree together. They're not needed at
+ run-time but leaving them out will make it impossible
+ to recompile or disassemble the resulting program.
+ It will also stop "goto label" statements from working.
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ -O1 sets -fcompress-nullops -fomit-sequence numbers.
+ -O6 adds -fstrip-syntax-tree.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed.
+ b print debugging information about bytecompiler progress
+ a tells the assembler to include source assembler lines
+ in its output as bytecode comments.
+ C prints each CV taken from the final symbol tree walk.
+ -S Output assembler source rather than piping it
+ through the assembler and outputting bytecode.
+ -m Compile as a module rather than a standalone program.
+ Currently this just means that the bytecodes for
+ initialising main_start, main_root and curpad are
+ omitted.
+
+Example
+ perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+
+ perl -MO=Bytecode,-S foo.pl > foo.S
+ assemble foo.S > foo.plc
+ byteperl foo.plc
+
+ perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+
+Backends for debugging
+ perl -MO=Terse,exec foo.pl
+ perl -MO=Debug bar.pl
+
+O module
+ Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend
+ B::Backend with options foo and bar. O invokes the sub
+ B::Backend::compile() with arguments foo and bar at BEGIN time.
+ That compile() sub must do any inital argument processing replied.
+ If unsuccessful, it should return a string which O arranges to be
+ printed as an error message followed by a clean error exit. In the
+ normal case where any option processing in compile() is successful,
+ it should return a sub ref (usually a closure) to perform the
+ actual compilation. When O regains control, it ensures that the
+ "-c" option is forced (so that the program being compiled doesn't
+ end up running) and registers a CHECK block to call back the sub ref
+ returned from the backend's compile(). Perl then continues by
+ parsing prog.pl (just as it would with "perl -c prog.pl") and after
+ doing so, assuming there are no parse-time errors, the CHECK block
+ of O gets called and the actual backend compilation happens. Phew.
Added: B/O.pm
==============================================================================
--- (empty file)
+++ B/O.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,144 @@
+package O;
+
+our $VERSION = '1.00';
+
+use B qw(minus_c save_BEGINs);
+use Carp;
+
+sub import {
+ my ($class, @options) = @_;
+ my ($quiet, $veryquiet) = (0, 0);
+ if ($options[0] eq '-q' || $options[0] eq '-qq') {
+ $quiet = 1;
+ open (SAVEOUT, ">&STDOUT");
+ close STDOUT;
+ open (STDOUT, ">", \$O::BEGIN_output);
+ if ($options[0] eq '-qq') {
+ $veryquiet = 1;
+ }
+ shift @options;
+ }
+ my $backend = shift (@options);
+ eval q[
+ BEGIN {
+ minus_c;
+ save_BEGINs;
+ }
+
+ CHECK {
+ if ($quiet) {
+ close STDOUT;
+ open (STDOUT, ">&SAVEOUT");
+ close SAVEOUT;
+ }
+
+ # Note: if you change the code after this 'use', please
+ # change the fudge factors in B::Concise (grep for
+ # "fragile kludge") so that its output still looks
+ # nice. Thanks. --smcc
+ use B::].$backend.q[ ();
+ if ($@) {
+ croak "use of backend $backend failed: $@";
+ }
+
+
+ my $compilesub = &{"B::${backend}::compile"}(@options);
+ if (ref($compilesub) ne "CODE") {
+ die $compilesub;
+ }
+
+ local $savebackslash = $\;
+ local ($\,$",$,) = (undef,' ','');
+ &$compilesub();
+
+ close STDERR if $veryquiet;
+ }
+ ];
+ die $@ if $@;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+O - Generic interface to Perl Compiler backends
+
+=head1 SYNOPSIS
+
+ perl -MO=[-q,]Backend[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This is the module that is used as a frontend to the Perl Compiler.
+
+If you pass the C<-q> option to the module, then the STDOUT
+filehandle will be redirected into the variable C<$O::BEGIN_output>
+during compilation. This has the effect that any output printed
+to STDOUT by BEGIN blocks or use'd modules will be stored in this
+variable rather than printed. It's useful with those backends which
+produce output themselves (C<Deparse>, C<Concise> etc), so that
+their output is not confused with that generated by the code
+being compiled.
+
+The C<-qq> option behaves like C<-q>, except that it also closes
+STDERR after deparsing has finished. This suppresses the "Syntax OK"
+message normally produced by perl.
+
+=head1 CONVENTIONS
+
+Most compiler backends use the following conventions: OPTIONS
+consists of a comma-separated list of words (no white-space).
+The C<-v> option usually puts the backend into verbose mode.
+The C<-ofile> option generates output to B<file> instead of
+stdout. The C<-D> option followed by various letters turns on
+various internal debugging flags. See the documentation for the
+desired backend (named C<B::Backend> for the example above) to
+find out about that backend.
+
+=head1 IMPLEMENTATION
+
+This section is only necessary for those who want to write a
+compiler backend module that can be used via this module.
+
+The command-line mentioned in the SYNOPSIS section corresponds to
+the Perl code
+
+ use O ("Backend", OPTIONS);
+
+The C<import> function which that calls loads in the appropriate
+C<B::Backend> module and calls the C<compile> function in that
+package, passing it OPTIONS. That function is expected to return
+a sub reference which we'll call CALLBACK. Next, the "compile-only"
+flag is switched on (equivalent to the command-line option C<-c>)
+and a CHECK block is registered which calls CALLBACK. Thus the main
+Perl program mentioned on the command-line is read in, parsed and
+compiled into internal syntax tree form. Since the C<-c> flag is
+set, the program does not start running (excepting BEGIN blocks of
+course) but the CALLBACK function registered by the compiler
+backend is called.
+
+In summary, a compiler backend module should be called "B::Foo"
+for some foo and live in the appropriate directory for that name.
+It should define a function called C<compile>. When the user types
+
+ perl -MO=Foo,OPTIONS foo.pl
+
+that function is called and is passed those OPTIONS (split on
+commas). It should return a sub ref to the main compilation function.
+After the user's program is loaded and parsed, that returned sub ref
+is invoked which can then go ahead and do the compilation, usually by
+making use of the C<B> module's functionality.
+
+=head1 BUGS
+
+The C<-q> and C<-qq> options don't work correctly if perl isn't
+compiled with PerlIO support : STDOUT will be closed instead of being
+redirected to C<$O::BEGIN_output>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+
+=cut
Added: B/README
==============================================================================
--- (empty file)
+++ B/README Tue Jun 26 12:23:24 2007
@@ -0,0 +1,325 @@
+ Perl Compiler Kit, Version alpha4
+
+ Copyright (c) 1996, 1997, Malcolm Beattie
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this kit,
+ in the file named "Artistic". If not, you can get one from the Perl
+ distribution. You should also have received a copy of the GNU General
+ Public License, in the file named "Copying". If not, you can get one
+ from the Perl distribution or else write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+CHANGES
+
+New since alpha3
+ Anonymous subs work properly with C and CC.
+ Heuristics for forcing compilation of apparently unused subs/methods.
+ Subs which use the AutoLoader module are forcibly loaded at compile-time.
+ Slightly faster compilation.
+ Handles slightly more complex code within a BEGIN { }.
+ Minor bug fixes.
+
+New since alpha2
+ CC backend now supports ".." and s//e.
+ Xref backend generates cross-reference reports
+ Cleanups to fix benign but irritating "-w" warnings
+ Minor cxstack fix
+New since alpha1
+ Working CC backend
+ Shared globs and pre-initialised hash support
+ Some XSUB support
+ Assorted bug fixes
+
+INSTALLATION
+
+(1) You need perl5.002 or later.
+
+(2) If you want to compile and run programs with the C or CC backends
+which undefine (or redefine) subroutines, then you need to apply a
+one-line patch to perl itself. One or two of the programs in perl's
+own test suite do this. The patch is in file op.patch. It prevents
+perl from calling free() on OPs with the magic sequence number (U16)-1.
+The compiler declares all OPs as static structures and uses that magic
+sequence number.
+
+(3) Type
+ perl Makefile.PL
+to write a personalised Makefile for your system. If you want the
+bytecode modules to support reading bytecode from strings (instead of
+just from files) then add the option
+ -DINDIRECT_BGET_MACROS
+into the middle of the definition of the CCCMD macro in the Makefile.
+Your C compiler may need to be able to cope with Standard C for this.
+I haven't tested this option yet with an old pre-Standard compiler.
+
+(4) If your platform supports dynamic loading then just type
+ make
+and you can then use
+ perl -Iblib/arch -MO=foo bar
+to use the compiler modules (see later for details).
+If you need/want instead to make a statically linked perl which
+contains the appropriate modules, then type
+ make perl
+ make byteperl
+and you can then use
+ ./perl -MO=foo bar
+to use the compiler modules.
+In both cases, the byteperl executable is required for running standalone
+bytecode programs. It is *not* a standard perl+XSUB perl executable.
+
+USAGE
+
+As of the alpha3 release, the Bytecode, C and CC backends are now all
+functional enough to compile almost the whole of the main perl test
+suite. In the case of the CC backend, any failures are all due to
+differences and/or known bugs documented below. See the file TESTS.
+In the following examples, you'll need to replace "perl" by
+ perl -Iblib/arch
+if you have built the extensions for a dynamic loading platform but
+haven't installed the extensions completely. You'll need to replace
+"perl" by
+ ./perl
+if you have built the extensions into a statically linked perl binary.
+
+(1) To compile perl program foo.pl with the C backend, do
+ perl -MO=C,-ofoo.c foo.pl
+Then use the cc_harness perl program to compile the resulting C source:
+ perl cc_harness -O2 -o foo foo.c
+
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the
+options you use:
+ perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+static initialisation of structures with union members then add
+-DBROKEN_UNION_INIT to the options you use. If you want command line
+arguments passed to your executable to be interpreted by perl (e.g. -Dx)
+then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line
+arguments passed to foo will appear directly in @ARGV. The resulting
+executable foo is the compiled version of foo.pl. See the file NOTES for
+extra options you can pass to -MO=C.
+
+There are some constraints on the contents on foo.pl if you want to be
+able to compile it successfully. Some problems can be fixed fairly easily
+by altering foo.pl; some problems with the compiler are known to be
+straightforward to solve and I'll do so soon. The file Todo lists a
+number of known problems. See the XSUB section lower down for information
+about compiling programs which use XSUBs.
+
+(2) To compile foo.pl with the CC backend (which generates actual
+optimised C code for the execution path of your perl program), use
+ perl -MO=CC,-ofoo.c foo.pl
+
+and proceed just as with the C backend. You should almost certainly
+use an option such as -O2 with the subsequent cc_harness invocation
+so that your C compiler uses optimisation. The C code generated by
+the Perl compiler's CC backend looks ugly to humans but is easily
+optimised by C compilers.
+
+To make the most of this compiler backend, you need to tell the
+compiler when you're using int or double variables so that it can
+optimise appropriately (although this part of the compiler is the most
+buggy). You currently do that by naming lexical variables ending in
+"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or
+"_dr" for double "register" variables. Here "register" is a promise
+that you won't pass a reference to the variable into a sub which then
+modifies the variable. The compiler ought to catch attempts to use
+"\$i" just as C compilers catch attempts to do "&i" for a register int
+i but it doesn't at the moment. Bugs in the CC backend may make your
+program fail in mysterious ways and give wrong answers rather than just
+crash in boring ways. But, hey, this is an alpha release so you knew
+that anyway. See the XSUB section lower down for information about
+compiling programs which use XSUBs.
+
+If your program uses classes which define methods (or other subs which
+are not exported and not apparently used until runtime) then you'll
+need to use -u compile-time options (see the NOTES file) to force the
+subs to be compiled. Future releases will probably default the other
+way, do more auto-detection and provide more fine-grained control.
+
+Since compiled executables need linking with libperl, you may want
+to turn libperl.a into a shared library if your platform supports
+it. For example, with Digital UNIX, do something like
+ ld -shared -o libperl.so -all libperl.a -none -lc
+and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
+also suggest -fomit-frame-pointer for Linux on Intel architetcures),
+do "make libperl.a" and then do
+ gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
+and then
+ # cp libperl.so.5.3 /usr/lib
+ # cd /usr/lib
+ # ln -s libperl.so.5.3 libperl.so.5
+ # ln -s libperl.so.5 libperl.so
+ # ldconfig
+When you compile perl executables with cc_harness, append -L/usr/lib
+otherwise the -L for the perl source directory will override it. For
+example,
+ perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench
+ perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib
+ ls -l foo3
+ -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3
+You'll probably also want to link your main perl executable against
+libperl.so; it's nice having an 11K perl executable.
+
+(3) To compile foo.pl into bytecode do
+ perl -MO=Bytecode,-ofoo foo.pl
+To run the resulting bytecode file foo as a standalone program, you
+use the program byteperl which should have been built along with the
+extensions.
+ ./byteperl foo
+Any extra arguments are passed in as @ARGV; they are not interpreted
+as perl options. If you want to load chunks of bytecode into an already
+running perl program then use the -m option and investigate the
+byteload_fh and byteload_string functions exported by the B module.
+See the NOTES file for details of these and other options (including
+optimisation options and ways of getting at the intermediate "assembler"
+code that the Bytecode backend uses).
+
+(3) There are little Bourne shell scripts and perl programs to aid with
+some common operations: assemble, disassemble, run_bytecode_test,
+run_test, cc_harness, test_harness, test_harness_bytecode.
+
+(4) Walk the op tree in execution order printing terse info about each op
+ perl -MO=Terse,exec foo.pl
+
+(5) Walk the op tree in syntax order printing lengthier debug info about
+each op. You can also append ",exec" to walk in execution order, but the
+formatting is designed to look nice with Terse rather than Debug.
+ perl -MO=Debug foo.pl
+
+(6) Produce a cross-reference report of the line numbers at which all
+variables, subs and formats are defined and used.
+ perl -MO=Xref foo.pl
+
+XSUBS
+
+The C and CC backends can successfully compile some perl programs which
+make use of XSUB extensions. [I'll add more detail to this section in a
+later release.] As a prerequisite, such extensions must not need to do
+anything in their BOOT: section which needs to be done at runtime rather
+than compile time. Normally, the only code in the boot_Foo() function is
+a list of newXS() calls which xsubpp puts there and the compiler handles
+saving those XS subs itself. For each XSUB used, the C and CC compiler
+will generate an initialiser in their C output which refers to the name
+of the relevant C function (XS_Foo_somesub). What is not yet automated
+is the necessary commands and cc command-line options (e.g. via
+"perl cc_harness") which link against the extension libraries. For now,
+you need the XSUB extension to have installed files in the right format
+for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or
+your platform's version) aren't suitable for linking against, you will
+have to reget the extension source and rebuild it as a static extension
+to force the generation of a suitable Foo.a file. Then you need to make
+a symlink (or copy or rename) of that file into a libFoo.a suitable for
+cc linking. Then add the appropriate -L and -l options to your
+"perl cc_harness" command line to find and link against those libraries.
+You may also need to fix up some platform-dependent environment variable
+to ensure that linked-against .so files are found at runtime too.
+
+DIFFERENCES
+
+The result of running a compiled Perl program can sometimes be different
+from running the same program with standard perl. Think of the compiler
+as having a slightly different implementation of the language Perl.
+Unfortunately, since Perl has had a single implementation until now,
+there are no formal standards or documents defining what behaviour is
+guaranteed of Perl the language and what just "happens to work".
+Some of the differences below are almost impossible to change because of
+the way the compiler works. Others can be changed to produce "standard"
+perl behaviour if it's deemed proper and the resulting performance hit
+is accepted. I'll use "standard perl" to mean the result of running a
+Perl program using the perl executable from the perl distribution.
+I'll use "compiled Perl program" to mean running an executable produced
+by this compiler kit ("the compiler") with the CC backend.
+
+Loops
+ Standard perl calculates the target of "next", "last", and "redo"
+ at run-time. The compiler calculates the targets at compile-time.
+ For example, the program
+
+ sub skip_on_odd { next NUMBER if $_[0] % 2 }
+ NUMBER: for ($i = 0; $i < 5; $i++) {
+ skip_on_odd($i);
+ print $i;
+ }
+
+ produces the output
+ 024
+ with standard perl but gives a compile-time error with the compiler.
+
+Context of ".."
+ The context (scalar or array) of the ".." operator determines whether
+ it behaves as a range or a flip/flop. Standard perl delays until
+ runtime the decision of which context it is in but the compiler needs
+ to know the context at compile-time. For example,
+ @a = (4,6,1,0,0,1);
+ sub range { (shift @a)..(shift @a) }
+ print range();
+ while (@a) { print scalar(range()) }
+ generates the output
+ 456123E0
+ with standard Perl but gives a compile-time error with compiled Perl.
+
+Arithmetic
+ Compiled Perl programs use native C arithemtic much more frequently
+ than standard perl. Operations on large numbers or on boundary
+ cases may produce different behaviour.
+
+Deprecated features
+ Features of standard perl such as $[ which have been deprecated
+ in standard perl since version 5 was released have not been
+ implemented in the compiler.
+
+Others
+ I'll add to this list as I remember what they are.
+
+BUGS
+
+Here are some things which may cause the compiler problems.
+
+The following render the compiler useless (without serious hacking):
+* Use of the DATA filehandle (via __END__ or __DATA__ tokens)
+* Operator overloading with %OVERLOAD
+* The (deprecated) magic array-offset variable $[ does not work
+* The following operators are not yet implemented for CC
+ goto
+ sort with a non-default comparison (i.e. a named sub or inline block)
+* You can't use "last" to exit from a non-loop block.
+
+The following may give significant problems:
+* BEGIN blocks containing complex initialisation code
+* Code which is only ever referred to at runtime (e.g. via eval "..." or
+ via method calls): see the -u option for the C and CC backends.
+* Run-time lookups of lexical variables in "outside" closures
+
+The following may cause problems (not thoroughly tested):
+* Dependencies on whether values of some "magic" Perl variables are
+ determined at compile-time or runtime.
+* For the C and CC backends: compile-time strings which are longer than
+ your C compiler can cope with in a single line or definition.
+* Reliance on intimate details of global destruction
+* For the Bytecode backend: high -On optimisation numbers with code
+ that has complex flow of control.
+* Any "-w" option in the first line of your perl program is seen and
+ acted on by perl itself before the compiler starts. The compiler
+ itself then runs with warnings turned on. This may cause perl to
+ print out warnings about the compiler itself since I haven't tested
+ it thoroughly with warnings turned on.
+
+There is a terser but more complete list in the Todo file.
+
+Malcolm Beattie
+2 September 1996
Added: B/TESTS
==============================================================================
--- (empty file)
+++ B/TESTS Tue Jun 26 12:23:24 2007
@@ -0,0 +1,78 @@
+Test results from compiling t/*/*.t
+ C Bytecode CC
+
+base/cond.t OK ok OK
+base/if.t OK ok OK
+base/lex.t OK ok OK
+base/pat.t OK ok OK
+base/term.t OK ok OK
+cmd/elsif.t OK ok OK
+cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter
+cmd/mod.t OK ok ok
+cmd/subval.t OK ok 1..34, not ok 27,28 (simply
+ because filename changes).
+cmd/switch.t OK ok ok
+cmd/while.t OK ok ok
+io/argv.t OK ok ok
+io/dup.t OK ok ok
+io/fs.t OK ok ok
+io/inplace.t OK ok ok
+io/pipe.t OK ok ok with -umain
+io/print.t OK ok ok
+io/tell.t OK ok ok
+op/append.t OK ok OK
+op/array.t OK ok 1..36, not ok 7,10 (no $[)
+op/auto.t OK ok OK
+op/chop.t OK ok OK
+op/cond.t OK ok OK
+op/delete.t OK ok OK
+op/do.t OK ok OK
+op/each.t OK ok OK
+op/eval.t OK ok ok 1-6 of 16 then exits
+op/exec.t OK ok OK
+op/exp.t OK ok OK
+op/flip.t OK ok OK
+op/fork.t OK ok OK
+op/glob.t OK ok OK
+op/goto.t OK ok 1..9, Can't find label label1.
+op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
+op/index.t OK ok OK
+op/int.t OK ok OK
+op/join.t OK ok OK
+op/list.t OK ok OK
+op/local.t OK ok OK
+op/magic.t OK ok OK
+op/misc.t no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t OK ok OK
+op/my.t OK ok OK
+op/oct.t OK ok OK (C large const warnings)
+op/ord.t OK ok OK
+op/overload.t Mostly not ok Mostly not ok C errors.
+op/pack.t OK ok OK
+op/pat.t omit 26 (reset) ok [lots of memory for compile]
+op/push.t OK ok OK
+op/quotemeta.t OK ok OK
+op/rand.t OK ok
+op/range.t OK ok OK
+op/read.t OK ok OK
+op/readdir.t OK ok OK (substcont works too)
+op/ref.t omits "ok 40" (lex destruction) ok (Bytecode)
+ CC: need -u for OBJ,BASEOBJ,
+ UNIVERSAL,WHATEVER,main.
+ 1..41, ok1-33,36-38,
+ then ok 41, ok 39.DESTROY probs
+op/regexp.t OK ok ok (trivially all eval'd)
+op/repeat.t OK ok ok
+op/sleep.t OK ok ok
+op/sort.t OK ok 1..10, ok 1, Out of memory!
+op/split.t OK ok ok
+op/sprintf.t OK ok ok
+op/stat.t OK ok ok
+op/study.t OK ok ok
+op/subst.t OK ok ok
+op/substr.t OK ok ok1-22 except 7-9,11 (all $[)
+op/time.t OK ok ok
+op/undef.t omit 21 ok ok
+op/unshift.t OK ok ok
+op/vec.t OK ok ok
+op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
Added: B/Todo
==============================================================================
--- (empty file)
+++ B/Todo Tue Jun 26 12:23:24 2007
@@ -0,0 +1,37 @@
+* Fixes
+
+CC backend: goto, sort with non-default comparison. last for non-loop blocks.
+Version checking
+improve XSUB handling (both static and dynamic)
+sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts
+allocation of XPV[INAHC]V structures needs fixing: Perl tries to free
+them whereas the compiler expects them to be linked to a xpv[inahc]v_root
+list the same as X[IPR]V structures.
+ref counts
+perl_parse replacement
+fix cstring for long strings
+compile-time initialisation of AvARRAYs
+signed/unsigned problems with NV (and IV?) initialisation and elsewhere?
+CvOUTSIDE for ordinary subs
+DATA filehandle for standalone Bytecode program (easy)
+DATA filehandle for multiple bytecode-compiled modules (harder)
+DATA filehandle for C-compiled program (yet harder)
+
+* Features
+
+type checking
+compile time v. runtime initialisation
+save PMOPs in compiled form
+selection of what to dump
+options for cutting out line info etc.
+comment output
+shared constants
+module dependencies
+
+* Optimisations
+collapse LISTOPs to UNOPs or BASEOPs
+compile-time qw(), constant subs
+global analysis of variables, type hints etc.
+demand-loaded bytecode (leader of each basic block replaced by an op
+which loads in bytecode for its block)
+fast sub calls for CC backend
Added: B/defsubs_h.PL
==============================================================================
--- (empty file)
+++ B/defsubs_h.PL Tue Jun 26 12:23:24 2007
@@ -0,0 +1,76 @@
+# Do not remove the following line; MakeMaker relies on it to identify
+# this file as a template for defsubs.h
+# Extracting defsubs.h (with variable substitutions)
+#!perl -w
+use File::Spec;
+my (undef, $headerpath) = @ARGV;
+my ($out) = __FILE__ =~ /(^.*)\.PL/i;
+$out =~ s/_h$/.h/;
+open(OUT,">$out") || die "Cannot open $file:$!";
+print "Extracting $out...\n";
+print OUT <<"END";
+/*
+ !!! Don't modify this file - it's autogenerated from $0 !!!
+ */
+END
+
+foreach my $const (qw(
+ AVf_REAL
+ CVf_ANON
+ CVf_ASSERTION
+ CVf_CLONE
+ CVf_CLONED
+ CVf_CONST
+ CVf_LOCKED
+ CVf_LVALUE
+ CVf_METHOD
+ CVf_NODEBUG
+ CVf_OLDSTYLE
+ CVf_UNIQUE
+ CVf_WEAKOUTSIDE
+ GVf_IMPORTED_AV
+ GVf_IMPORTED_CV
+ GVf_IMPORTED_HV
+ GVf_IMPORTED_SV
+ HEf_SVKEY
+ SVTYPEMASK
+ SVf_FAKE
+ SVf_IOK
+ SVf_IVisUV
+ SVf_NOK
+ SVf_POK
+ SVf_READONLY
+ SVf_ROK
+ SVp_IOK
+ SVp_NOK
+ SVp_POK
+ SVpad_OUR
+ SVs_RMG
+ SVs_SMG
+ SVt_PVGV
+ SVt_PVHV
+ ))
+ {
+ doconst($const);
+ }
+foreach my $file (qw(op.h cop.h))
+ {
+ my $path = File::Spec->catfile($headerpath, $file);
+ open(OPH,"$path") || die "Cannot open $path:$!";
+ while (<OPH>)
+ {
+ doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/);
+ }
+ close(OPH);
+ }
+close(OUT);
+
+sub doconst
+{
+ my $sym = shift;
+ my $l = length($sym);
+ print OUT <<"END";
+ newCONSTSUB(stash,"$sym",newSViv($sym));
+ av_push(export_ok,newSVpvn("$sym",$l));
+END
+}
Added: B/hints/darwin.pl
==============================================================================
--- (empty file)
+++ B/hints/darwin.pl Tue Jun 26 12:23:24 2007
@@ -0,0 +1,2 @@
+# gcc -O3 (and -O2) get overly excited over B.c in MacOS X 10.1.4.
+$self->{OPTIMIZE} = '-O1';
Added: B/hints/openbsd.pl
==============================================================================
--- (empty file)
+++ B/hints/openbsd.pl Tue Jun 26 12:23:24 2007
@@ -0,0 +1,2 @@
+# gcc -O3 (and -O2) get overly excited over B.c in OpenBSD 3.3/sparc 64
+$self->{OPTIMIZE} = '-O1' if $Config{ARCH} eq 'sparc64';
Added: B/ramblings/cc.notes
==============================================================================
--- (empty file)
+++ B/ramblings/cc.notes Tue Jun 26 12:23:24 2007
@@ -0,0 +1,32 @@
+At entry to each basic block, the following can be assumed (and hence
+must be forced where necessary at the end of each basic block):
+
+The shadow stack @stack is empty.
+For each lexical object in @pad, VALID_IV holds for each T_INT,
+VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise.
+The C shadow variable sp holds the stack pointer (not necessarily stack_sp).
+
+write_back_stack
+ Writes the contents of the shadow stack @stack back to the real stack.
+ A write-back of each object in the stack is forced so that its
+ backing SV contains the right value and that SV is then pushed onto the
+ real stack. On return, @stack is empty.
+
+write_back_lexicals
+ Forces a write-back (i.e. achieves VALID_SV), where necessary, for each
+ lexical object in @pad. Objects with the TEMPORARY flag are skipped. If
+ write_back_lexicals is called with an (optional) argument, then it is
+ taken to be a bitmask of more flags: any lexical object with one of those
+ flags set is also skipped and not written back to its SV.
+
+invalidate_lexicals($avoid)
+ The VALID_INT and VALID_DOUBLE flags are turned off for each lexical
+ object in @pad whose flags field doesn't overlap with $avoid.
+
+reload_lexicals
+ For each necessary lexical object in @pad, makes sure that VALID_IV
+ holds for objects of type T_INT, VALID_DOUBLE holds for objects for
+ type T_DOUBLE, and VALID_SV holds for other objects. An object is
+ considered for reloading if its flags field does not overlap with the
+ (optional) argument passed to reload_lexicals.
+
Added: B/ramblings/curcop.runtime
==============================================================================
--- (empty file)
+++ B/ramblings/curcop.runtime Tue Jun 26 12:23:24 2007
@@ -0,0 +1,39 @@
+PP code uses of curcop
+----------------------
+
+pp_rv2gv
+ when a new glob is created for an OPpLVAL_INTRO,
+ curcop->cop_line is stored as GvLINE() in the new GP.
+pp_bless
+ curcop->cop_stash is used as the stash in the one-arg form of bless
+
+pp_repeat
+ tests (curcop != &compiling) to warn "Can't x= to readonly value"
+
+pp_pos
+pp_substr
+pp_index
+pp_rindex
+pp_aslice
+pp_lslice
+pp_splice
+ curcop->cop_arybase
+
+pp_sort
+ curcop->cop_stash used to determine whether to gv_fetchpv $a and $b
+
+pp_caller
+ tests (curcop->cop_stash == debstash) to determine whether
+ to set DB::args
+
+pp_reset
+ resets vars in curcop->cop_stash
+
+pp_dbstate
+ sets curcop = (COP*)op
+
+doeval
+ compiles into curcop->cop_stash
+
+pp_nextstate
+ sets curcop = (COP*)op
Added: B/ramblings/flip-flop
==============================================================================
--- (empty file)
+++ B/ramblings/flip-flop Tue Jun 26 12:23:24 2007
@@ -0,0 +1,54 @@
+PP(pp_range)
+{
+ if (GIMME == G_ARRAY)
+ return NORMAL;
+ if (SvTRUEx(PAD_SV(PL_op->op_targ)))
+ return cLOGOP->op_other;
+ else
+ return NORMAL;
+}
+
+pp_range is a LOGOP.
+In list context, it just returns op_next.
+In scalar context it checks the truth of targ and returns
+op_other if true, op_next if false.
+
+flip is an UNOP.
+It "looks after" its child which is always a pp_range LOGOP.
+In list context, it just returns the child's op_other.
+In scalar context, there are three possible outcomes:
+ (1) set child's targ to 1, our targ to 1 and return op_next.
+ (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other.
+ (3) Blank targ and TOPs and return op_next.
+Case 1 happens for a "..." with a matching lineno... or true TOPs.
+Case 2 happens for a ".." with a matching lineno... or true TOPs.
+Case 3 happens for a non-matching lineno or false TOPs.
+
+ $a = lhs..rhs;
+
+ ,-------> range
+ ^ / \
+ | true/ \false
+ | / \
+ first| lhs rhs
+ | \ first /
+ ^--- flip <----- flop
+ \ /
+ \ /
+ sassign
+
+
+/* range */
+if (SvTRUE(curpad[op->op_targ]))
+ goto label(op_other);
+/* op_next */
+...
+/* flip */
+/* For "..." returns op_next. For ".." returns op_next or op_first->op_other */
+/* end of basic block */
+goto out;
+label(range op_other):
+...
+/* flop */
+out:
+...
Added: B/ramblings/magic
==============================================================================
--- (empty file)
+++ B/ramblings/magic Tue Jun 26 12:23:24 2007
@@ -0,0 +1,93 @@
+sv_magic()
+----------
+av.c
+av_store()
+ Storing a non-undef element into an SMAGICAL array, av,
+ assigns the equivalent lowercase form of magic (of the first
+ MAGIC in the chain) to the value (with obj = av, name = 0 and
+ namlen = array index).
+
+gv.c
+gv_init()
+ Initialising gv assigns '*' magic to it with obj = gv, name =
+ GvNAME and namlen = GvNAMELEN.
+gv_fetchpv()
+ @ISA gets 'I' magic with obj = gv, zero name and namlen.
+ %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen.
+ $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv,
+ name = GvNAME and namlen = len ( = 1 presumably).
+Gv_AMupdate()
+ Stashes for overload magic seem to get 'c' magic with obj = 0,
+ name = &amt and namlen = sizeof(amt).
+hv_magic(hv, gv, how)
+ Gives magic how to hv with obj = gv and zero name and namlen.
+
+mg.c
+mg_copy(sv, nsv, key, klen)
+ Traverses the magic chain of sv. Upper case forms of magic
+ (only) are copied across to nsv, preserving obj but using
+ name = key and namlen = klen.
+magic_setpos()
+ LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos.
+
+op.c
+mod()
+ PVLV operators give magic to their targs with
+ obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v'
+ and OP_SUBSTR gives 'x'.
+
+perl.c
+magicname(sym, name, namlen)
+ Fetches/creates a GV with name sym and gives it '\0' magic
+ with obj = gv, name and namlen as passed.
+init_postdump_symbols()
+ Elements of the environment get given SVs with 'e' magic.
+ obj = sv and name and namlen point to the actual string
+ within env.
+
+pp.c
+pp_av2arylen()
+ $#foo gives '#' magic to the new SV with obj = av and
+ name = namlen = 0.
+pp_study()
+ SV gets 'g' magic with obj = name = namlen = 0.
+pp_substr()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+pp_vec()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+
+pp_hot.c
+pp_match()
+ m//g gets 'g' magic with obj = name = namlen = 0.
+
+pp_sys.c
+pp_tie()
+ sv gets magic with obj = sv and name = namlen = 0.
+ If an HV or an AV, it gets 'P' magic, otherwise 'q' magic.
+pp_dbmopen()
+ 'P' magic for the HV just as with pp_tie().
+pp_sysread()
+ If tainting, the buffer SV gets 't' magic with
+ obj = name = namlen = 0.
+
+sv.c
+sv_setsv()
+ Doing sv_setsv(dstr, gv) gives '*' magic to dstr with
+ obj = dstr, name = GvNAME, namlen = GvNAMELEN.
+
+util.c
+fbm_compile()
+ The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID
+ is set to indicate that the Boyer-Moore table is valid.
+ magic_setbm() just clears the SvVALID flag.
+
+hv_magic()
+----------
+
+gv.c
+gv_fetchfile()
+ With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv.
+gv_fetchpv()
+ %SIG gets 'S' magic with obj = siggv.
+init_postdump_symbols()
+ %ENV gets 'E' magic with obj = envgv.
Added: B/ramblings/reg.alloc
==============================================================================
--- (empty file)
+++ B/ramblings/reg.alloc Tue Jun 26 12:23:24 2007
@@ -0,0 +1,32 @@
+while ($i--) {
+ foo();
+}
+exit
+
+ PP code if i an int register if i an int but not a
+ (i.e. can't be register (i.e. can be
+ implicitly invalidated) implicitly invalidated)
+ nextstate
+ enterloop
+
+
+ loop:
+ gvsv GV (0xe6078) *i validates i validates i
+ postdec invalidates $i invalidates $i
+ and if_false goto out;
+ i valid; $i invalid i valid; $i invalid
+
+ i valid; $i invalid i valid; $i invalid
+ nextstate
+ pushmark
+ gv GV (0xe600c) *foo
+ entersub validates $i; invals i
+
+ unstack
+ goto loop:
+
+ i valid; $i invalid
+ out:
+ leaveloop
+ nextstate
+ exit
Added: B/ramblings/runtime.porting
==============================================================================
--- (empty file)
+++ B/ramblings/runtime.porting Tue Jun 26 12:23:24 2007
@@ -0,0 +1,357 @@
+Notes on porting the perl runtime PP engine.
+Importance: 1 = who cares?, 10 = vital
+Difficulty: 1 = trivial, 10 = very difficult. Level assumes a
+reasonable implementation of the SV and OP API already ported.
+
+OP Import Diff Comments
+null 10 1
+stub 10 1
+scalar 10 1
+pushmark 10 1 PUSHMARK
+wantarray 7 3 cxstack, dopoptosub
+const 10 1
+gvsv 10 1 save_scalar
+gv 10 1
+gelem 3 3
+padsv 10 2 SAVECLEARSV, provide_ref
+padav 10 2
+padhv 10 2
+padany 1 1
+pushre 7 3 pushes an op. Blech.
+rv2gv 6 5
+rv2sv 10 4
+av2arylen 7 3 sv_magic
+rv2cv 8 5 sv_2cv
+anoncode 7 6 cv_clone
+prototype 4 4 sv_2cv
+refgen 8 3
+srefgen 8 2
+ref 8 3
+bless 7 3
+backtick 5 4
+glob 5 2 do_readline
+readline 8 2 do_readline
+rcatline 8 2
+regcmaybe 8 1
+regcreset 8 1
+regcomp 8 9 pregcomp
+match 8 10
+qr 8 1
+subst 8 10
+substcont 8 7
+trans 7 4 do_trans
+sassign 10 3 mg_find, SvSETMAGIC
+aassign 10 5
+chop 8 3 do_chop
+schop 8 3 do_chop
+chomp 8 3 do_chomp
+schomp 8 3 do_chomp
+defined 10 2
+undef 10 3
+study 4 5
+pos 8 3 PVLV, mg_find
+preinc 10 2 sv_inc, SvSETMAGIC
+i_preinc
+predec 10 2 sv_dec, SvSETMAGIC
+i_predec
+postinc 10 2 sv_dec, SvSETMAGIC
+i_postinc
+postdec 10 2 sv_dec, SvSETMAGIC
+i_postdec
+pow 10 1
+multiply 10 1
+i_multiply 10 1
+divide 10 2
+i_divide 10 1
+modulo 10 2
+i_modulo 10 1
+repeat 6 4
+add 10 1
+i_add 10 1
+subtract 10 1
+i_subtract 10 1
+concat 10 2 mg_get
+stringify 10 2 sv_setpvn
+left_shift 10 1
+right_shift 10 1
+lt 10 1
+i_lt 10 1
+gt 10 1
+i_gt 10 1
+le 10 1
+i_le 10 1
+ge 10 1
+i_ge 10 1
+eq 10 1
+i_eq 10 1
+ne 10 1
+i_ne 10 1
+ncmp 10 1
+i_ncmp 10 1
+slt 10 2
+sgt 10 2
+sle 10 2
+sge 10 2
+seq 10 2 sv_eq
+sne 10 2
+scmp 10 2
+bit_and 10 2
+bit_xor 10 2
+bit_or 10 2
+negate 10 3
+i_negate 10 1
+not 10 1
+complement 10 3
+atan2 6 1
+sin 6 1
+cos 6 1
+rand 5 2
+srand 5 2
+exp 6 1
+log 6 2
+sqrt 6 2
+int 10 2
+hex 9 2
+oct 9 2
+abs 10 1
+length 10 1
+substr 10 4 PVLV
+vec 5 4
+index 9 3
+rindex 9 3
+sprintf 9 4 do_sprintf
+formline 6 7
+ord 6 2
+chr 6 2
+crypt 3 2
+ucfirst 6 2
+lcfirst 6 2
+uc 6 2
+lc 6 2
+quotemeta 6 3
+rv2av 10 3 save_svref, mg_get, save_ary
+aelemfast 10 2 av_fetch
+aelem 10 3
+aslice 9 4
+each 10 3 hv_iternext
+values 10 3 do_kv
+keys 10 3 do_kv
+delete 10 3
+exists 10 3
+rv2hv 10 3 save_svref, mg_get, save_ary, do_kv
+helem 10 3 save_svref, provide_ref
+hslice 9 4
+unpack 9 6 lengthy
+pack 9 6 lengthy
+split 9 9
+join 10 4 do_join
+list 10 2
+lslice 9 4
+anonlist 10 2
+anonhash 10 3
+splice 9 6
+push 10 2
+pop 10 2
+shift 10 2
+unshift 10 2
+sort 6 7
+reverse 9 4
+grepstart 6 5 modifies flow of control
+grepwhile 6 5 modifies flow of control
+mapstart 1 1
+mapwhile 6 5 modifies flow of control
+range 7 3 modifies flow of control
+flip 7 4 modifies flow of control
+flop 7 4 modifies flow of control
+and 10 3 modifies flow of control
+or 10 3 modifies flow of control
+xor
+cond_expr 10 3 modifies flow of control
+andassign 7 3 modifies flow of control
+orassign 7 3 modifies flow of control
+method 8 5
+entersub 10 7
+leavesub 10 5
+leavesublv
+caller 2 8
+warn 9 3
+die 9 3
+reset 2 2
+lineseq 1 1
+nextstate 10 1 Update stack_sp from cxstack. FREETMPS.
+dbstate 3 7
+unstack
+enter 10 3 cxstack, ENTER, SAVETMPS, PUSHBLOCK
+leave 10 3 cxstack, SAVETMPS, LEAVE, POPBLOCK
+scope 1 1
+enteriter 9 4 cxstack
+iter 9 3 cxstack
+enterloop 10 4
+leaveloop 10 4
+return 10 5
+last 9 6
+next 9 6
+redo 9 6
+dump 1 9 pp_goto
+goto 6 9
+exit 9 2 my_exit
+open 9 5 do_open
+close 9 3 do_close
+pipe_op 7 4
+fileno 9 2
+umask 4 2
+binmode 4 2
+tie 5 5 pp_entersub
+untie 5 2 sv_unmagic
+tied 5 2
+dbmopen 4 5
+dbmclose 4 2
+sselect 4 4
+select 7 3
+getc 7 2
+read 8 2 pp_sysread
+enterwrite 4 4 doform
+leavewrite 4 5
+prtf 4 4 do_sprintf
+print 8 6
+sysopen 8 2
+sysseek 8 2
+sysread 8 4
+syswrite 8 4 pp_send
+send 8 4
+recv 8 4 pp_sysread
+eof 9 2
+tell 9 3
+seek 9 2
+truncate 8 3
+fcntl 8 4 pp_ioctl
+ioctl 8 4
+flock 8 2
+socket 5 3
+sockpair 5 3
+bind 5 3
+connect 5 3
+listen 5 3
+accept 5 3
+shutdown 5 2
+gsockopt 5 3 pp_ssockopt
+ssockopt 5 3
+getsockname 5 3 pp_getpeername
+getpeername 5 3
+lstat 5 4 pp_stat
+stat 5 4 lengthy
+ftrread 5 2 cando
+ftrwrite 5 2 cando
+ftrexec 5 2 cando
+fteread 5 2 cando
+ftewrite 5 2 cando
+fteexec 5 2 cando
+ftis 5 2 cando
+fteowned 5 2 cando
+ftrowned 5 2 cando
+ftzero 5 2 cando
+ftsize 5 2 cando
+ftmtime 5 2 cando
+ftatime 5 2 cando
+ftctime 5 2 cando
+ftsock 5 2 cando
+ftchr 5 2 cando
+ftblk 5 2 cando
+ftfile 5 2 cando
+ftdir 5 2 cando
+ftpipe 5 2 cando
+ftlink 5 2 cando
+ftsuid 5 2 cando
+ftsgid 5 2 cando
+ftsvtx 5 2 cando
+fttty 5 2 cando
+fttext 5 4
+ftbinary 5 4 fttext
+chdir
+chown
+chroot
+unlink
+chmod
+utime
+rename
+link
+symlink
+readlink
+mkdir
+rmdir
+open_dir
+readdir
+telldir
+seekdir
+rewinddir
+closedir
+fork
+wait
+waitpid
+system
+exec
+kill
+getppid
+getpgrp
+setpgrp
+getpriority
+setpriority
+time
+tms
+localtime
+gmtime
+alarm
+sleep
+shmget
+shmctl
+shmread
+shmwrite
+msgget
+msgctl
+msgsnd
+msgrcv
+semget
+semctl
+semop
+require 6 9 doeval
+dofile 6 9 doeval
+entereval 6 9 doeval
+leaveeval 6 5
+entertry 7 4 modifies flow of control
+leavetry 7 3
+ghbyname
+ghbyaddr
+ghostent
+gnbyname
+gnbyaddr
+gnetent
+gpbyname
+gpbynumber
+gprotoent
+gsbyname
+gsbyport
+gservent
+shostent
+snetent
+sprotoent
+sservent
+ehostent
+enetent
+eprotoent
+eservent
+gpwnam
+gpwuid
+gpwent
+spwent
+epwent
+ggrnam
+ggrgid
+ggrent
+sgrent
+egrent
+getlogin
+syscall
+lock 6 1
+threadsv 6 2 unused if not USE_5005THREADS, absent post 5.8
+setstate 1 1 currently unused anywhere
+method_named 10 2
Added: B/t/OptreeCheck.pm
==============================================================================
--- (empty file)
+++ B/t/OptreeCheck.pm Tue Jun 26 12:23:24 2007
@@ -0,0 +1,1068 @@
+package OptreeCheck;
+use base 'Exporter';
+require "test.pl";
+
+our $VERSION = '0.01';
+
+# now export checkOptree, and those test.pl functions used by tests
+our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
+ require_ok runperl );
+
+
+=head1 NAME
+
+OptreeCheck - check optrees as rendered by B::Concise
+
+=head1 SYNOPSIS
+
+OptreeCheck supports 'golden-sample' regression testing of perl's
+parser, optimizer, bytecode generator, via a single function:
+checkOptree(%in).
+
+It invokes B::Concise upon the sample code, checks that the rendering
+'agrees' with the golden sample, and reports mismatches.
+
+Additionally, the module processes @ARGV (which is typically unused in
+the Core test harness), and thus provides a means to run the tests in
+various modes.
+
+=head1 EXAMPLE
+
+ # your test file
+ use OptreeCheck;
+ plan tests => 1;
+
+ checkOptree (
+ name => "test-name', # optional, made from others if not given
+
+ # code-under-test: must provide 1 of them
+ code => sub {my $a}, # coderef, or source (wrapped and evald)
+ prog => 'sort @a', # run in subprocess, aka -MO=Concise
+ bcopts => '-exec', # $opt or \@opts, passed to BC::compile
+
+ errs => 'Useless variable "@main::a" .*' # str, regex, [str+] [regex+],
+
+ # various test options
+ # errs => '.*', # match against any emitted errs, -w warnings
+ # skip => 1, # skips test
+ # todo => 'excuse', # anticipated failures
+ # fail => 1 # force fail (by redirecting result)
+ # retry => 1 # retry on test failure
+ # debug => 1, # use re 'debug' for retried failures !!
+
+ # the 'golden-sample's, (must provide both)
+
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # start HERE-DOCS
+ # 1 <;> nextstate(main 45 optree.t:23) v
+ # 2 <0> padsv[$a:45,46] M/LVINTRO
+ # 3 <1> leavesub[1 ref] K/REFC,1
+ EOT_EOT
+ # 1 <;> nextstate(main 45 optree.t:23) v
+ # 2 <0> padsv[$a:45,46] M/LVINTRO
+ # 3 <1> leavesub[1 ref] K/REFC,1
+ EONT_EONT
+
+ __END__
+
+=head2 Failure Reports
+
+ Heres a sample failure, as induced by the following command.
+ Note the argument; option=value, after the test-file, more on that later
+
+ $> PERL_CORE=1 ./perl ext/B/t/optree_check.t testmode=cross
+ ...
+ ok 19 - canonical example w -basic
+ not ok 20 - -exec code: $a=$b+42
+ # Failed at test.pl line 249
+ # got '1 <;> nextstate(main 600 optree_check.t:208) v
+ # 2 <#> gvsv[*b] s
+ # 3 <$> const[IV 42] s
+ # 4 <2> add[t3] sK/2
+ # 5 <#> gvsv[*a] s
+ # 6 <2> sassign sKS/2
+ # 7 <1> leavesub[1 ref] K/REFC,1
+ # '
+ # expected /(?ms-xi:^1 <;> (?:next|db)state(.*?) v
+ # 2 <\$> gvsv\(\*b\) s
+ # 3 <\$> const\(IV 42\) s
+ # 4 <2> add\[t\d+\] sK/2
+ # 5 <\$> gvsv\(\*a\) s
+ # 6 <2> sassign sKS/2
+ # 7 <1> leavesub\[\d+ refs?\] K/REFC,1
+ # $)/
+ # got: '2 <#> gvsv[*b] s'
+ # want: (?-xism:2 <\$> gvsv\(\*b\) s)
+ # got: '3 <$> const[IV 42] s'
+ # want: (?-xism:3 <\$> const\(IV 42\) s)
+ # got: '5 <#> gvsv[*a] s'
+ # want: (?-xism:5 <\$> gvsv\(\*a\) s)
+ # remainder:
+ # 2 <#> gvsv[*b] s
+ # 3 <$> const[IV 42] s
+ # 5 <#> gvsv[*a] s
+ # these lines not matched:
+ # 2 <#> gvsv[*b] s
+ # 3 <$> const[IV 42] s
+ # 5 <#> gvsv[*a] s
+
+Errors are reported 3 different ways;
+
+The 1st form is directly from test.pl's like() and unlike(). Note
+that this form is used as input, so you can easily cut-paste results
+into test-files you are developing. Just make sure you recognize
+insane results, to avoid canonizing them as golden samples.
+
+The 2nd and 3rd forms show only the unexpected results and opcodes.
+This is done because it's blindingly tedious to find a single opcode
+causing the failure. 2 different ways are done in case one is
+unhelpful.
+
+=head1 TestCase Overview
+
+checkOptree(%tc) constructs a testcase object from %tc, and then calls
+methods which eventually call test.pl's like() to produce test
+results.
+
+=head2 getRendering
+
+getRendering() runs code or prog through B::Concise, and captures its
+rendering. Errors emitted during rendering are checked against
+expected errors, and are reported as diagnostics by default, or as
+failures if 'report=fail' cmdline-option is given.
+
+prog is run in a sub-shell, with $bcopts passed through. This is the way
+to run code intended for main. The code arg in contrast, is always a
+CODEREF, either because it starts that way as an arg, or because it's
+wrapped and eval'd as $sub = sub {$code};
+
+=head2 mkCheckRex
+
+mkCheckRex() selects the golden-sample for the threaded-ness of the
+platform, and produces a regex which matches the expected rendering,
+and fails when it doesn't match.
+
+The regex includes 'workarounds' which accommodate expected rendering
+variations. These include:
+
+ string constants # avoid injection
+ line numbers, etc # args of nexstate()
+ hexadecimal-numbers
+
+ pad-slot-assignments # for 5.8 compat, and testmode=cross
+ (map|grep)(start|while) # for 5.8 compat
+
+=head2 mylike
+
+mylike() calls either unlike() or like(), depending on
+expectations. Mismatch reports are massaged, because the actual
+difference can easily be lost in the forest of opcodes.
+
+=head1 checkOptree API and Operation
+
+Since the arg is a hash, the api is wide-open, and this really is
+about what elements must be or are in the hash, and what they do. %tc
+is passed to newTestCase(), the ctor, which adds in %proto, a global
+prototype object.
+
+=head2 name => STRING
+
+If name property is not provided, it is synthesized from these params:
+bcopts, note, prog, code. This is more convenient than trying to do
+it manually.
+
+=head2 code or prog
+
+Either code or prog must be present.
+
+=head2 prog => $perl_source_string
+
+prog => $src provides a snippet of code, which is run in a sub-process,
+via test.pl:runperl, and through B::Concise like so:
+
+ './perl -w -MO=Concise,$bcopts_massaged -e $src'
+
+=head2 code => $perl_source_string || CODEREF
+
+The $code arg is passed to B::Concise::compile(), and run in-process.
+If $code is a string, it's first wrapped and eval'd into a $coderef.
+In either case, $coderef is then passed to B::Concise::compile():
+
+ $subref = eval "sub{$code}";
+ $render = B::Concise::compile($subref)->();
+
+=head2 expect and expect_nt
+
+expect and expect_nt args are the B<golden-sample> renderings, and are
+sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds.
+They're both required, and the correct one is selected for the platform
+being tested, and saved into the synthesized property B<wanted>.
+
+=head2 bcopts => $bcopts || [ @bcopts ]
+
+When getRendering() runs, it passes bcopts into B::Concise::compile().
+The bcopts arg can be a single string, or an array of strings.
+
+=head2 errs => $err_str_regex || [ @err_str_regexs ]
+
+getRendering() processes the code or prog arg under warnings, and both
+parsing and optree-traversal errors are collected. These are
+validated against the one or more errors you specify.
+
+=head1 testcase modifier properties
+
+These properties are set as %tc parameters to change test behavior.
+
+=head2 skip => 'reason'
+
+invokes skip('reason'), causing test to skip.
+
+=head2 todo => 'reason'
+
+invokes todo('reason')
+
+=head2 fail => 1
+
+For code arguments, this option causes getRendering to redirect the
+rendering operation to STDERR, which causes the regex match to fail.
+
+=head2 retry => 1
+
+If retry is set, and a test fails, it is run a second time, possibly
+with regex debug.
+
+=head2 debug => 1
+
+If a failure is retried, this turns on eval "use re 'debug'", thus
+turning on regex debug. It's quite verbose, and not hugely helpful.
+
+=head2 noanchors => 1
+
+If set, this relaxes the regex check, which is normally pretty strict.
+It's used primarily to validate checkOptree via tests in optree_check.
+
+
+=head1 Synthesized object properties
+
+These properties are added into the test object during execution.
+
+=head2 wanted
+
+This stores the chosen expect expect_nt string. The OptreeCheck
+object may in the future delete the raw strings once wanted is set,
+thus saving space.
+
+=head2 cross => 1
+
+This tag is added if testmode=cross is passed in as argument.
+It causes test-harness to purposely use the wrong string.
+
+
+=head2 checkErrs
+
+checkErrs() is a getRendering helper that verifies that expected errs
+against those found when rendering the code on the platform. It is
+run after rendering, and before mkCheckRex.
+
+Errors can be reported 3 different ways; diag, fail, print.
+
+ diag - uses test.pl _diag()
+ fail - causes double-testing
+ print-.no # in front of the output (may mess up test harnesses)
+
+The 3 ways are selectable at runtimve via cmdline-arg:
+report={diag,fail,print}.
+
+
+
+=cut
+
+use Config;
+use Carp;
+use B::Concise qw(walk_output);
+
+BEGIN {
+ $SIG{__WARN__} = sub {
+ my $err = shift;
+ $err =~ m/Subroutine re::(un)?install redefined/ and return;
+ };
+}
+
+sub import {
+ my $pkg = shift;
+ $pkg->export_to_level(1,'checkOptree', @EXPORT);
+ getCmdLine(); # process @ARGV
+}
+
+
+# %gOpts params comprise a global test-state. Initial values here are
+# HELP strings, they MUST BE REPLACED by runtime values before use, as
+# is done by getCmdLine(), via import
+
+our %gOpts = # values are replaced at runtime !!
+ (
+ # scalar values are help string
+ retry => 'retry failures after turning on re debug',
+ debug => 'turn on re debug for those retries',
+ selftest => 'self-tests mkCheckRex vs the reference rendering',
+
+ fail => 'force all test to fail, print to stdout',
+ dump => 'dump cmdline arg prcessing',
+ noanchors => 'dont anchor match rex',
+
+ # array values are one-of selections, with 1st value as default
+ # array: 2nd value is used as help-str, 1st val (still) default
+ help => [0, 'provides help and exits', 0],
+ testmode => [qw/ native cross both /],
+
+ # reporting mode for rendering errs
+ report => [qw/ diag fail print /],
+ errcont => [1, 'if 1, tests match even if report is fail', 0],
+
+ # fixup for VMS, cygwin, which dont have stderr b4 stdout
+ rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0],
+ strip => [1, 'if 1, catch errs and remove from renderings',0],
+ stripv => 'if strip&&1, be verbose about it',
+ errs => 'expected compile errs, array if several',
+ );
+
+
+# Not sure if this is too much cheating. Officially we say that
+# $Config::Config{usethreads} is true if some sort of threading is in
+# use, in which case we ought to be able to use it in place of the ||
+# below. However, it is now possible to Configure perl with "threads"
+# but neither ithreads or 5005threads, which forces the re-entrant
+# APIs, but no perl user visible threading.
+
+# This seems to have the side effect that most of perl doesn't think
+# that it's threaded, hence the ops aren't threaded either. Not sure
+# if this is actually a "supported" configuration, but given that
+# ponie uses it, it's going to be used by something official at least
+# in the interim. So it's nice for tests to all pass.
+
+our $threaded = 1
+ if $Config::Config{useithreads} || $Config::Config{use5005threads};
+our $platform = ($threaded) ? "threaded" : "plain";
+our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
+
+our %modes = (
+ both => [ 'expect', 'expect_nt'],
+ native => [ ($threaded) ? 'expect' : 'expect_nt'],
+ cross => [ !($threaded) ? 'expect' : 'expect_nt'],
+ expect => [ 'expect' ],
+ expect_nt => [ 'expect_nt' ],
+ );
+
+our %msgs # announce cross-testing.
+ = (
+ # cross-platform
+ 'expect_nt-threaded' => " (nT on T) ",
+ 'expect-nonthreaded' => " (T on nT) ",
+ # native - nothing to say (must stay empty - used for $crosstesting)
+ 'expect_nt-nonthreaded' => '',
+ 'expect-threaded' => '',
+ );
+
+#######
+sub getCmdLine { # import assistant
+ # offer help
+ print(qq{\n$0 accepts args to update these state-vars:
+ turn on a flag by typing its name,
+ select a value from list by typing name=val.\n },
+ mydumper(\%gOpts))
+ if grep /help/, @ARGV;
+
+ # replace values for each key !! MUST MARK UP %gOpts
+ foreach my $opt (keys %gOpts) {
+
+ # scan ARGV for known params
+ if (ref $gOpts{$opt} eq 'ARRAY') {
+
+ # $opt is a One-Of construct
+ # replace with valid selection from the list
+
+ # uhh this WORKS. but it's inscrutable
+ # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
+ my $tval; # temp
+ if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
+ # check val before accepting
+ my @allowed = @{$gOpts{$opt}};
+ if (grep { $_ eq $tval } @allowed) {
+ $gOpts{$opt} = $tval;
+ }
+ else {die "invalid value: '$tval' for $opt\n"}
+ }
+
+ # take 1st val as default
+ $gOpts{$opt} = ${$gOpts{$opt}}[0]
+ if ref $gOpts{$opt} eq 'ARRAY';
+ }
+ else { # handle scalars
+
+ # if 'opt' is present, true
+ $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0;
+
+ # override with 'foo' if 'opt=foo' appears
+ grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
+ }
+ }
+ print("$0 heres current state:\n", mydumper(\%gOpts))
+ if $gOpts{help} or $gOpts{dump};
+
+ exit if $gOpts{help};
+}
+# the above arg-handling cruft should be replaced by a Getopt call
+
+##############################
+# the API (1 function)
+
+sub checkOptree {
+ my $tc = newTestCases(@_); # ctor
+ my ($rendering);
+
+ print "checkOptree args: ",mydumper($tc) if $tc->{dump};
+ SKIP: {
+ skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip};
+
+ return runSelftest($tc) if $gOpts{selftest};
+
+ $tc->getRendering(); # get the actual output
+ $tc->checkErrs();
+
+ TODO:
+ foreach $want (@{$modes{$gOpts{testmode}}}) {
+ local $TODO = $tc->{todo} if $tc->{todo};
+
+ $tc->{cross} = $msgs{"$want-$thrstat"};
+
+ $tc->mkCheckRex($want);
+ $tc->mylike();
+ }
+ }
+ $res;
+}
+
+sub newTestCases {
+ # make test objects (currently 1) from args (passed to checkOptree)
+ my $tc = bless { @_ }, __PACKAGE__
+ or die "test cases are hashes";
+
+ $tc->label();
+
+ # cpy globals into each test
+ foreach $k (keys %gOpts) {
+ if ($gOpts{$k}) {
+ $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
+ }
+ }
+ # transform errs to self-hash for efficient set-math
+ if ($tc->{errs}) {
+ if (not ref $tc->{errs}) {
+ $tc->{errs} = { $tc->{errs} => 1};
+ }
+ elsif (ref $tc->{errs} eq 'ARRAY') {
+ my %errs;
+ @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}};
+ $tc->{errs} = \%errs;
+ }
+ elsif (ref $tc->{errs} eq 'Regexp') {
+ warn "regexp err matching not yet implemented";
+ }
+ }
+ return $tc;
+}
+
+sub label {
+ # may help get/keep test output consistent
+ my ($tc) = @_;
+ return $tc->{name} if $tc->{name};
+
+ my $buf = (ref $tc->{bcopts})
+ ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};
+
+ foreach (qw( note prog code )) {
+ $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
+ }
+ return $tc->{name} = $buf;
+}
+
+#################
+# render and its helpers
+
+sub getRendering {
+ my $tc = shift;
+ fail("getRendering: code or prog is required")
+ unless $tc->{code} or $tc->{prog};
+
+ my @opts = get_bcopts($tc);
+ my $rendering = ''; # suppress "Use of uninitialized value in open"
+ my @errs; # collect errs via
+
+
+ if ($tc->{prog}) {
+ $rendering = runperl( switches => ['-w',join(',',"-MO=Concise", at opts)],
+ prog => $tc->{prog}, stderr => 1,
+ ); # verbose => 1);
+ } else {
+ my $code = $tc->{code};
+ unless (ref $code eq 'CODE') {
+ # treat as source, and wrap into subref
+ # in caller's package ( to test arg-fixup, comment next line)
+ my $pkg = '{ package '.caller(1) .';';
+ $code = eval "$pkg sub { $code } }";
+ # return errors
+ if ($@) { chomp $@; push @errs, $@ }
+ }
+ # set walk-output b4 compiling, which writes 'announce' line
+ walk_output(\$rendering);
+ if ($tc->{fail}) {
+ fail("forced failure: stdout follows");
+ walk_output(\*STDOUT);
+ }
+ my $opwalker = B::Concise::compile(@opts, $code);
+ die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
+
+ B::Concise::reset_sequence();
+ $opwalker->();
+
+ # kludge error into rendering if its empty.
+ $rendering = $@ if $@ and ! $rendering;
+ }
+ # separate banner, other stuff whose printing order isnt guaranteed
+ if ($tc->{strip}) {
+ $rendering =~ s/(B::Concise::compile.*?\n)//;
+ print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
+
+ #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
+ while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
+ print "stripped <$1> $2\n" if $tc->{stripv};
+ push @errs, $1;
+ }
+ $rendering =~ s/-e syntax OK\n//;
+ $rendering =~ s/-e had compilation errors\.\n//;
+ }
+ $tc->{got} = $rendering;
+ $tc->{goterrs} = \@errs if @errs;
+ return $rendering, @errs;
+}
+
+sub get_bcopts {
+ # collect concise passthru-options if any
+ my ($tc) = shift;
+ my @opts = ();
+ if ($tc->{bcopts}) {
+ @opts = (ref $tc->{bcopts} eq 'ARRAY')
+ ? @{$tc->{bcopts}} : ($tc->{bcopts});
+ }
+ return @opts;
+}
+
+sub checkErrs {
+ # check rendering errs against expected errors, reduce and report
+ my $tc = shift;
+
+ # check for agreement, by hash (order less important)
+ my (%goterrs, @got);
+ @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}};
+
+ foreach my $k (keys %{$tc->{errs}}) {
+ if (@got = grep /^$k$/, keys %goterrs) {
+ delete $tc->{errs}{$k};
+ delete $goterrs{$_} foreach @got;
+ }
+ }
+ $tc->{goterrs} = \%goterrs;
+
+ # relook at altered
+ if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
+ $tc->diag_or_fail();
+ }
+ fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ?
+}
+
+sub diag_or_fail {
+ # help checkErrs
+ my $tc = shift;
+
+ my @lines;
+ push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}};
+ push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}};
+
+ if (@lines) {
+ unshift @lines, $tc->{name};
+ my $report = join("\n", @lines);
+
+ if ($gOpts{report} eq 'diag') { _diag ($report) }
+ elsif ($gOpts{report} eq 'fail') { fail ($report) }
+ else { print ($report) }
+ next unless $gOpts{errcont}; # skip block
+ }
+}
+
+=head1 mkCheckRex ($tc)
+
+It selects the correct golden-sample from the test-case object, and
+converts it into a Regexp which should match against the original
+golden-sample (used in selftest, see below), and on the renderings
+obtained by applying the code on the perl being tested.
+
+The selection is driven by platform mostly, but also by test-mode,
+which rather complicates the code. This is worsened by the potential
+need to make platform specific conversions on the reftext.
+
+but is otherwise as strict as possible. For example, it should *not*
+match when opcode flags change, or when optimizations convert an op to
+an ex-op.
+
+
+=head2 match criteria
+
+The selected golden-sample is massaged to eliminate various match
+irrelevancies. This is done so that the tests dont fail just because
+you added a line to the top of the test file. (Recall that the
+renderings contain the program's line numbers). Similar cleanups are
+done on "strings", hex-constants, etc.
+
+The need to massage is reflected in the 2 golden-sample approach of
+the test-cases; we want the match to be as rigorous as possible, and
+thats easier to achieve when matching against 1 input than 2.
+
+Opcode arguments (text within braces) are disregarded for matching
+purposes. This loses some info in 'add[t5]', but greatly simplifies
+matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
+for regressions, not for complete accuracy.
+
+The regex is anchored by default, but can be suppressed with
+'noanchors', allowing 1-liner tests to succeed if opcode is found.
+
+=cut
+
+# needless complexity due to 'too much info' from B::Concise v.60
+my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
+
+sub mkCheckRex {
+ # converts expected text into Regexp which should match against
+ # unaltered version. also adjusts threaded => non-threaded
+ my ($tc, $want) = @_;
+ eval "no re 'debug'";
+
+ my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias
+ $str = $tc->{$want} if $want && $tc->{$want}; # stated pref
+
+ die("no '$want' golden-sample found: $tc->{name}") unless $str;
+
+ $str =~ s/^\# //mg; # ease cut-paste testcase authoring
+
+ if ($] < 5.009) {
+ # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
+ # works because it adds no wildcards, which are butchered below..
+ $str =~ s|(mapstart l?K\*?)|$1/2|mg;
+ $str =~ s|(grepstart l?K\*?)|$1/2|msg;
+ $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
+ $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
+ }
+ $tc->{wantstr} = $str;
+
+ # convert all (args) and [args] to temp forms wo bracing
+ $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
+ $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
+ $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
+
+ # escape bracing, etc.. manual \Q (doesnt escape '+')
+ $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
+
+ # now replace temp forms with original, preserving reference bracing
+ $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
+ $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
+ $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
+
+ # treat dbstate like nextstate (no in-debugger false reports)
+ $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
+ # widened for -terse mode
+ $str =~ s/(?:next|db)state/(?:next|db)state/msg;
+
+ # don't care about:
+ $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
+ $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
+ $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
+ $str =~ s/".*?"/".*?"/msg; # quoted strings
+
+ $str =~ s/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural)
+ $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
+ #$str =~ s/(\s*)\n/\n/msg; # trailing spaces
+
+ # these fix up pad-slot assignment args
+ if ($] < 5.009 or $tc->{cross}) {
+ $str =~ s/\[t\d+\\]/\[t\\d+\\]/msg; # pad slot assignments
+ }
+
+ croak "no reftext found for $want: $tc->{name}"
+ unless $str =~ /\w+/; # fail unless a real test
+
+ # $str = '.*' if 1; # sanity test
+ # $str .= 'FAIL' if 1; # sanity test
+
+ # allow -eval, banner at beginning of anchored matches
+ $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
+ unless $tc->{noanchors} or $tc->{rxnoorder};
+
+ eval "use re 'debug'" if $debug;
+ my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
+ no re 'debug';
+
+ $tc->{rex} = $qr;
+ $tc->{rexstr} = $str;
+ $tc;
+}
+
+##############
+# compare and report
+
+sub mylike {
+ # reworked mylike to use hash-obj
+ my $tc = shift;
+ my $got = $tc->{got};
+ my $want = $tc->{rex};
+ my $cmnt = $tc->{name};
+ my $cross = $tc->{cross};
+
+ my $msgs = $tc->{msgs};
+ my $retry = $tc->{retry}; # || $gopts{retry};
+ my $debug = $tc->{debug}; #|| $gopts{retrydbg};
+
+ # bad is anticipated failure
+ my $bad = (0 or ( $cross && $tc->{crossfail})
+ or (!$cross && $tc->{fail})
+ or 0); # no undefs !
+
+ # same as A ^ B, but B has side effects
+ my $ok = ( $bad && unlike ($got, $want, $cmnt, @$msgs)
+ or !$bad && like ($got, $want, $cmnt, @$msgs));
+
+ reduceDiffs ($tc) if not $ok;
+
+ if (not $ok and $retry) {
+ # redo, perhaps with use re debug - NOT ROBUST
+ eval "use re 'debug'" if $debug;
+ $ok = ( $bad && unlike ($got, $want, "(RETRY) $cmnt", @$msgs)
+ or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs));
+ eval "no re 'debug'";
+ }
+ return $ok;
+}
+
+sub reduceDiffs {
+ # isolate the real diffs and report them.
+ # i.e. these kinds of errs:
+ # 1. missing or extra ops. this skews all following op-sequences
+ # 2. single op diff, the rest of the chain is unaltered
+ # in either case, std err report is inadequate;
+
+ my $tc = shift;
+ my $got = $tc->{got};
+ my @got = split(/\n/, $got);
+ my $want = $tc->{wantstr};
+ my @want = split(/\n/, $want);
+
+ # split rexstr into units that should eat leading lines.
+ my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});
+
+ foreach my $rex (@rexs) {
+ my $exp = shift @want;
+ my $line = shift @got;
+ # remove matches, and report
+ unless ($got =~ s/($rex\n)//msg) {
+ _diag("got:\t\t'$line'\nwant:\t $rex\n");
+ }
+ }
+ _diag("remainder:\n$got");
+ _diag("these lines not matched:\n$got\n");
+}
+
+=head1 Global modes
+
+Unusually, this module also processes @ARGV for command-line arguments
+which set global modes. These 'options' change the way the tests run,
+essentially reusing the tests for different purposes.
+
+
+
+Additionally, there's an experimental control-arg interface (i.e.
+subject to change) which allows the user to set global modes.
+
+
+=head1 Testing Method
+
+At 1st, optreeCheck used one reference-text, but the differences
+between Threaded and Non-threaded renderings meant that a single
+reference (sampled from say, threaded) would be tricky and iterative
+to convert for testing on a non-threaded build. Worse, this conflicts
+with making tests both strict and precise.
+
+We now use 2 reference texts, the right one is used based upon the
+build's threaded-ness. This has several benefits:
+
+ 1. native reference data allows closer/easier matching by regex.
+ 2. samples can be eyeballed to grok T-nT differences.
+ 3. data can help to validate mkCheckRex() operation.
+ 4. can develop regexes which accommodate T-nT differences.
+ 5. can test with both native and cross-converted regexes.
+
+Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
+differences in B::Concise output, so mkCheckRex has code to do some
+cross-test manipulations. This area needs more work.
+
+=head1 Test Modes
+
+One consequence of a single-function API is difficulty controlling
+test-mode. I've chosen for now to use a package hash, %gOpts, to store
+test-state. These properties alter checkOptree() function, either
+short-circuiting to selftest, or running a loop that runs the testcase
+2^N times, varying conditions each time. (current N is 2 only).
+
+So Test-mode is controlled with cmdline args, also called options below.
+Run with 'help' to see the test-state, and how to change it.
+
+=head2 selftest
+
+This argument invokes runSelftest(), which tests a regex against the
+reference renderings that they're made from. Failure of a regex match
+its 'mold' is a strong indicator that mkCheckRex is buggy.
+
+That said, selftest mode currently runs a cross-test too, they're not
+completely orthogonal yet. See below.
+
+=head2 testmode=cross
+
+Cross-testing is purposely creating a T-NT mismatch, looking at the
+fallout, which helps to understand the T-NT differences.
+
+The tweaking appears contrary to the 2-refs philosophy, but the tweaks
+will be made in conversion-specific code, which (will) handles T->NT
+and NT->T separately. The tweaking is incomplete.
+
+A reasonable 1st step is to add tags to indicate when TonNT or NTonT
+is known to fail. This needs an option to force failure, so the
+test.pl reporting mechanics show results to aid the user.
+
+=head2 testmode=native
+
+This is normal mode. Other valid values are: native, cross, both.
+
+=head2 checkOptree Notes
+
+Accepts test code, renders its optree using B::Concise, and matches
+that rendering against a regex built from one of 2 reference
+renderings %tc data.
+
+The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
+remove match-irrelevancies, such as (args) and [args]. For example,
+it strips leading '# ', making it easy to cut-paste new tests into
+your test-file, run it, and cut-paste actual results into place. You
+then retest and reedit until all 'errors' are gone. (now make sure you
+haven't 'enshrined' a bug).
+
+name: The test name. May be augmented by a label, which is built from
+important params, and which helps keep names in sync with whats being
+tested.
+
+=cut
+
+sub runSelftest {
+ # tests the regex produced by mkCheckRex()
+ # by using on the expect* text it was created with
+ # failures indicate a code bug,
+ # OR regexs plugged into the expect* text (which defeat conversions)
+ my $tc = shift;
+
+ for my $provenance (qw/ expect expect_nt /) {
+ #next unless $tc->{$provenance};
+
+ $tc->mkCheckRex($provenance);
+ $tc->{got} = $tc->{wantstr}; # fake the rendering
+ $tc->mylike();
+ }
+}
+
+my $dumploaded = 0;
+
+sub mydumper {
+
+ do { Dumper(@_); return } if $dumploaded;
+
+ eval "require Data::Dumper"
+ or do{
+ print "Sorry, Data::Dumper is not available\n";
+ print "half hearted attempt:\n";
+ foreach $it (@_) {
+ if (ref $it eq 'HASH') {
+ print " $_ => $it->{$_}\n" foreach sort keys %$it;
+ }
+ }
+ return;
+ };
+
+ Data::Dumper->import;
+ $Data::Dumper::Sortkeys = 1;
+ $dumploaded++;
+ Dumper(@_);
+}
+
+############################
+# support for test writing
+
+sub preamble {
+ my $testct = shift || 1;
+ return <<EO_HEADER;
+#!perl
+
+BEGIN {
+ chdir q(t);
+ \@INC = qw(../lib ../ext/B/t);
+ require q(./test.pl);
+}
+use OptreeCheck;
+plan tests => $testct;
+
+EO_HEADER
+
+}
+
+sub OptreeCheck::wrap {
+ my $code = shift;
+ $code =~ s/(?:(\#.*?)\n)//gsm;
+ $code =~ s/\s+/ /mgs;
+ chomp $code;
+ return unless $code =~ /\S/;
+ my $comment = $1;
+
+ my $testcode = qq{
+
+checkOptree(note => q{$comment},
+ bcopts => q{-exec},
+ code => q{$code},
+ expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
+ThreadedRef
+ paste your 'golden-example' here, then retest
+EOT_EOT
+NonThreadedRef
+ paste your 'golden-example' here, then retest
+EONT_EONT
+
+};
+ return $testcode;
+}
+
+sub OptreeCheck::gentest {
+ my ($code,$opts) = @_;
+ my $rendering = getRendering({code => $code});
+ my $testcode = OptreeCheck::wrap($code);
+ return unless $testcode;
+
+ # run the prog, capture 'reference' concise output
+ my $preamble = preamble(1);
+ my $got = runperl( prog => "$preamble $testcode", stderr => 1,
+ #switches => ["-I../ext/B/t", "-MOptreeCheck"],
+ ); #verbose => 1);
+
+ # extract the 'reftext' ie the got 'block'
+ if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
+ my $goldentxt = $1;
+ #and plug it into the test-src
+ if ($threaded) {
+ $testcode =~ s/ThreadedRef/$goldentxt/;
+ } else {
+ $testcode =~ s/NonThreadRef/$goldentxt/;
+ }
+ my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
+ my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
+ $testcode =~ s/$b4/$af/;
+
+ my $got;
+ if ($internal_retest) {
+ $got = runperl( prog => "$preamble $testcode", stderr => 1,
+ #switches => ["-I../ext/B/t", "-MOptreeCheck"],
+ verbose => 1);
+ print "got: $got\n";
+ }
+ return $testcode;
+ }
+ return '';
+}
+
+
+sub OptreeCheck::processExamples {
+ my @files = @_;
+
+ # gets array of paragraphs, which should be code-samples. Theyre
+ # turned into optreeCheck tests,
+
+ foreach my $file (@files) {
+ open (my $fh, $file) or die "cant open $file: $!\n";
+ $/ = "";
+ my @chunks = <$fh>;
+ print preamble (scalar @chunks);
+ foreach $t (@chunks) {
+ print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
+ print OptreeCheck::gentest ($t);
+ }
+ }
+}
+
+# OK - now for the final insult to your good taste...
+
+if ($0 =~ /OptreeCheck\.pm/) {
+
+ #use lib 't';
+ require './t/test.pl';
+
+ # invoked as program. Work like former gentest.pl,
+ # ie read files given as cmdline args,
+ # convert them to usable test files.
+
+ require Getopt::Std;
+ Getopt::Std::getopts('') or
+ die qq{ $0 sample-files* # no options
+
+ expecting filenames as args. Each should have paragraphs,
+ these are converted to checkOptree() tests, and printed to
+ stdout. Redirect to file then edit for test. \n};
+
+ OptreeCheck::processExamples(@ARGV);
+}
+
+1;
+
+__END__
+
+=head1 TEST DEVELOPMENT SUPPORT
+
+This optree regression testing framework needs tests in order to find
+bugs. To that end, OptreeCheck has support for developing new tests,
+according to the following model:
+
+ 1. write a set of sample code into a single file, one per
+ paragraph. Add <=for gentest> blocks if you care to, or just look at
+ f_map and f_sort in ext/B/t/ for examples.
+
+ 2. run OptreeCheck as a program on the file
+
+ ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
+ ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
+
+ gentest reads the sample code, runs each to generate a reference
+ rendering, folds this rendering into an optreeCheck() statement,
+ and prints it to stdout.
+
+ 3. run the output file as above, redirect to files, then rerun on
+ same build (for sanity check), and on thread-opposite build. With
+ editor in 1 window, and cmd in other, it's fairly easy to cut-paste
+ the gots into the expects, easier than running step 2 on both
+ builds then trying to sdiff them together.
+
+=head1 CAVEATS
+
+This code is purely for testing core. While checkOptree feels flexible
+enough to be stable, the whole selftest framework is subject to change
+w/o notice.
+
+=cut
Added: B/t/asmdata.t
==============================================================================
--- (empty file)
+++ B/t/asmdata.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,53 @@
+#!./perl -Tw
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 13;
+
+use_ok('B::Asmdata', qw(%insn_data @insn_name @optype @specialsv_name));
+
+# check we got something.
+isnt( keys %insn_data, 0, '%insn_data exported and populated' );
+isnt( @insn_name, 0, ' @insn_name' );
+isnt( @optype, 0, ' @optype' );
+isnt( @specialsv_name, 0, ' @specialsv_name' );
+
+# pick an op that's not likely to go away in the future
+my @data = values %insn_data;
+is( (grep { ref eq 'ARRAY' } @data), @data, '%insn_data contains arrays' );
+
+# pick one at random to test with.
+my $opname = (keys %insn_data)[rand @data];
+my $data = $insn_data{$opname};
+like( $data->[0], qr/^\d+$/, ' op number' );
+is( ref $data->[1], 'CODE', ' PUT code ref' );
+ok( !ref $data->[2], ' GET method' );
+
+is( $insn_name[$data->[0]], $opname, '@insn_name maps correctly' );
+
+
+# I'm going to assume that op types will all be named /OP$/.
+# If this changes in the future, change this test.
+is( grep(/OP$/, @optype), @optype, '@optype is all /OP$/' );
+
+
+# comment in bytecode.pl says "Nullsv *must come first so that the
+# condition ($$sv == 0) can continue to be used to test (sv == Nullsv)."
+is( $specialsv_name[0], 'Nullsv', 'Nullsv come first in @special_sv_name' );
+
+# other than that, we can't really say much more about @specialsv_name
+# than it has to contain strings (on the off chance &PL_sv_undef gets
+# flubbed)
+is( grep(!ref, @specialsv_name), @specialsv_name, ' contains all strings' );
Added: B/t/assembler.t
==============================================================================
--- (empty file)
+++ B/t/assembler.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,389 @@
+#!./perl -w
+
+=pod
+
+=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
+
+=head2 Description
+
+The general idea is to test by assembling a choice set of assembler
+instructions, then disassemble them, and check that we've completed the
+round trip. Also, error checking of Assembler.pm is tested by feeding
+it assorted errors.
+
+Since Assembler.pm likes to assemble a file, we comply by writing a
+text file. This file contains three sections:
+
+ testing operand categories
+ use each opcode
+ erronous assembler instructions
+
+An "operand category" is identified by the suffix of the PUT_/GET_
+subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
+opcode C<ldsv> has operand category C<svindex>:
+
+ insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
+
+Because Disassembler.pm also assumes input from a file, we write the
+resulting object code to a file. And disassembled output is written to
+yet another text file which is then compared to the original input.
+(Erronous assembler instructions still generate code, but this is not
+written to the object file; therefore disassembly bails out at the first
+instruction in error.)
+
+All files are kept in memory by using TIEHASH.
+
+
+=head2 Caveats
+
+An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
+generates invalid object code will not be detected.
+
+Due to the way this test has been set up, failure of a single test
+could cause all subsequent tests to fail as well: After an unexpected
+assembler error no output is written, and disassembled lines will be
+out of sync for all lines thereafter.
+
+Not all possibilities for writing a valid operand value can be tested
+because disassembly results in a uniform representation.
+
+
+=head2 Maintenance
+
+New opcodes are added automatically.
+
+A new operand category will cause this program to die ("no operand list
+for XXX"). The cure is to add suitable entries to C<%goodlist> and
+C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
+happen that the corresponding assembly or disassembly subroutine is
+missing.) Note that an empty array as a C<%goodlist> entry means that
+opcodes of the operand category do not take an operand (and therefore the
+corresponding entry in C<%badlist> should have one). An C<undef> entry
+in C<%badlist> means that any value is acceptable (and thus there is no
+way to cause an error).
+
+Set C<$dbg> to debug this test.
+
+=cut
+
+package VirtFile;
+use strict;
+
+# Note: This is NOT a general purpose package. It implements
+# sequential text and binary file i/o in a rather simple form.
+
+sub TIEHANDLE($;$){
+ my( $class, $data ) = @_;
+ my $obj = { data => defined( $data ) ? $data : '',
+ pos => 0 };
+ return bless( $obj, $class );
+}
+
+sub PRINT($@){
+ my( $self ) = shift;
+ $self->{data} .= join( '', @_ );
+}
+
+sub WRITE($$;$$){
+ my( $self, $buf, $len, $offset ) = @_;
+ unless( defined( $len ) ){
+ $len = length( $buf );
+ $offset = 0;
+ }
+ unless( defined( $offset ) ){
+ $offset = 0;
+ }
+ $self->{data} .= substr( $buf, $offset, $len );
+ return $len;
+}
+
+
+sub GETC($){
+ my( $self ) = @_;
+ return undef() if $self->{pos} >= length( $self->{data} );
+ return substr( $self->{data}, $self->{pos}++, 1 );
+}
+
+sub READLINE($){
+ my( $self ) = @_;
+ return undef() if $self->{pos} >= length( $self->{data} );
+ my $lfpos = index( $self->{data}, "\n", $self->{pos} );
+ if( $lfpos < 0 ){
+ $lfpos = length( $self->{data} );
+ }
+ my $pos = $self->{pos};
+ $self->{pos} = $lfpos + 1;
+ return substr( $self->{data}, $pos, $self->{pos} - $pos );
+}
+
+sub READ($@){
+ my $self = shift();
+ my $bufref = \$_[0];
+ my( undef, $len, $offset ) = @_;
+ if( $offset ){
+ die( "offset beyond end of buffer\n" )
+ if ! defined( $$bufref ) || $offset > length( $$bufref );
+ } else {
+ $$bufref = '';
+ $offset = 0;
+ }
+ my $remlen = length( $self->{data} ) - $self->{pos};
+ $len = $remlen if $remlen < $len;
+ return 0 unless $len;
+ substr( $$bufref, $offset, $len ) =
+ substr( $self->{data}, $self->{pos}, $len );
+ $self->{pos} += $len;
+ return $len;
+}
+
+sub TELL($){
+ my $self = shift();
+ return $self->{pos};
+}
+
+sub CLOSE($){
+ my( $self ) = @_;
+ $self->{pos} = 0;
+}
+
+1;
+
+package main;
+
+use strict;
+use Test::More;
+use Config qw(%Config);
+
+BEGIN {
+ if (($Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
+ print "1..0 # Skip -- Perl configured without ByteLoader module\n";
+ exit 0;
+ }
+}
+
+use B::Asmdata qw( %insn_data );
+use B::Assembler qw( &assemble_fh );
+use B::Disassembler qw( &disassemble_fh &get_header );
+
+my( %opsByType, @code2name );
+my( $lineno, $dbg, $firstbadline, @descr );
+$dbg = 0; # debug switch
+
+# $SIG{__WARN__} handler to catch Assembler error messages
+#
+my $warnmsg;
+sub catchwarn($){
+ $warnmsg = $_[0];
+ print "error: $warnmsg\n" if $dbg;
+}
+
+# Callback for writing assembled bytes. This is where we check
+# that we do get an error.
+#
+sub putobj($){
+ if( ++$lineno >= $firstbadline ){
+ ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
+ undef( $warnmsg );
+ } else {
+ my $l = syswrite( OBJ, $_[0] );
+ }
+}
+
+# Callback for writing a disassembled statement.
+#
+sub putdis(@){
+ my $line = join( ' ', @_ );
+ ++$lineno;
+ print DIS "$line\n";
+ printf "%5d %s\n", $lineno, $line if $dbg;
+}
+
+# Generate assembler instructions from a hash of operand types: each
+# existing entry contains a list of good or bad operand values. The
+# corresponding opcodes can be found in %opsByType.
+#
+sub gen_type($$$){
+ my( $href, $descref, $text ) = @_;
+ for my $odt ( sort( keys( %opsByType ) ) ){
+ my $opcode = $opsByType{$odt}->[0];
+ my $sel = $odt;
+ $sel =~ s/^GET_//;
+ die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
+ if( defined( $href->{$sel} ) ){
+ if( @{$href->{$sel}} ){
+ for my $od ( @{$href->{$sel}} ){
+ ++$lineno;
+ $descref->[$lineno] = "$text: $code2name[$opcode] $od";
+ print ASM "$code2name[$opcode] $od\n";
+ printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
+ }
+ } else {
+ ++$lineno;
+ $descref->[$lineno] = "$text: $code2name[$opcode]";
+ print ASM "$code2name[$opcode]\n";
+ printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
+ }
+ }
+ }
+}
+
+# Interesting operand values
+#
+my %goodlist = (
+comment_t => [ '"a comment"' ], # no \n
+none => [],
+svindex => [ 0x7fffffff, 0 ],
+opindex => [ 0x7fffffff, 0 ],
+pvindex => [ 0x7fffffff, 0 ],
+U32 => [ 0xffffffff, 0 ],
+U8 => [ 0xff, 0 ],
+PV => [ '""', '"a string"', ],
+I32 => [ -0x80000000, 0x7fffffff ],
+IV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
+IV => $Config{ivsize} == 4 ?
+ [ -0x80000000, 0x7fffffff ] :
+ [ '0x000000000', '0x0ffffffff', '0x000000001' ],
+NV => [ 1.23456789E3 ],
+U16 => [ 0xffff, 0 ],
+pvcontents => [],
+strconst => [ '""', '"another string"' ], # no NUL
+op_tr_array => [ join( ',', 256, 0..255 ) ],
+PADOFFSET => undef,
+long => undef,
+ );
+
+# Erronous operand values
+#
+my %badlist = (
+comment_t => [ '"multi-line\ncomment"' ], # no \n
+none => [ '"spurious arg"' ],
+svindex => [ 0xffffffff * 2, -1 ],
+opindex => [ 0xffffffff * 2, -2 ],
+pvindex => [ 0xffffffff * 2, -3 ],
+U32 => [ 0xffffffff * 2, -4 ],
+U16 => [ 0x5ffff, -5 ],
+U8 => [ 0x6ff, -6 ],
+PV => [ 'no quote"' ],
+I32 => [ -0x80000001, 0x80000000 ],
+IV64 => undef, # PUT_IV64 doesn't check - no integrity there
+IV => $Config{ivsize} == 4 ?
+ [ -0x80000001, 0x80000000 ] : undef,
+NV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
+pvcontents => [ '"spurious arg"' ],
+strconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
+op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
+PADOFFSET => undef,
+long => undef,
+ );
+
+
+# Determine all operand types from %Asmdata::insn_data
+#
+for my $opname ( keys( %insn_data ) ){
+ my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
+ push( @{$opsByType{$getname}}, $opcode );
+ $code2name[$opcode] = $opname;
+}
+
+
+# Write instruction(s) for correct operand values each operand type class
+#
+$lineno = 0;
+tie( *ASM, 'VirtFile' );
+gen_type( \%goodlist, \@descr, 'round trip' );
+
+# Write one instruction for each opcode.
+#
+for my $opcode ( 0..$#code2name ){
+ next unless defined( $code2name[$opcode] );
+ my $sel = $insn_data{$code2name[$opcode]}->[2];
+ $sel =~ s/^GET_//;
+ die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
+ if( defined( $goodlist{$sel} ) ){
+ ++$lineno;
+ if( @{$goodlist{$sel}} ){
+ my $od = $goodlist{$sel}[0];
+ $descr[$lineno] = "round trip: $code2name[$opcode] $od";
+ print ASM "$code2name[$opcode] $od\n";
+ printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
+ } else {
+ $descr[$lineno] = "round trip: $code2name[$opcode]";
+ print ASM "$code2name[$opcode]\n";
+ printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
+ }
+ }
+}
+
+# Write instruction(s) for incorrect operand values each operand type class
+#
+$firstbadline = $lineno + 1;
+gen_type( \%badlist, \@descr, 'asm error' );
+
+# invalid opcode is an odd-man-out ;-)
+#
+++$lineno;
+$descr[$lineno] = "asm error: Gollum";
+print ASM "Gollum\n";
+printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
+
+close( ASM );
+
+# Now that we have defined all of our tests: plan
+#
+plan( tests => $lineno );
+print "firstbadline=$firstbadline\n" if $dbg;
+
+# assemble (guard against warnings and death from assembly errors)
+#
+$SIG{'__WARN__'} = \&catchwarn;
+
+$lineno = -1; # account for the assembly header
+tie( *OBJ, 'VirtFile' );
+eval { assemble_fh( \*ASM, \&putobj ); };
+print "eval: $@" if $dbg;
+close( ASM );
+close( OBJ );
+$SIG{'__WARN__'} = 'DEFAULT';
+
+# disassemble
+#
+print "--- disassembling ---\n" if $dbg;
+$lineno = 0;
+tie( *DIS, 'VirtFile' );
+disassemble_fh( \*OBJ, \&putdis );
+close( OBJ );
+close( DIS );
+
+# get header (for debugging only)
+#
+if( $dbg ){
+ my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
+ get_header();
+ printf "Magic: 0x%08x\n", $magic;
+ print "Architecture: $archname\n";
+ print "Byteloader V: $blversion\n";
+ print "ivsize: $ivsize\n";
+ print "ptrsize: $ptrsize\n";
+ print "Byteorder: $byteorder\n";
+}
+
+# check by comparing files line by line
+#
+print "--- checking ---\n" if $dbg;
+$lineno = 0;
+my( $asmline, $disline );
+while( defined( $asmline = <ASM> ) ){
+ $disline = <DIS>;
+ ++$lineno;
+ last if $lineno eq $firstbadline; # bail out where errors begin
+ ok( $asmline eq $disline, $descr[$lineno] );
+ printf "%5d %s\n", $lineno, $asmline if $dbg;
+}
+close( ASM );
+close( DIS );
+
+__END__
Added: B/t/b.t
==============================================================================
--- (empty file)
+++ B/t/b.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,149 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Test::More tests => 41;
+
+BEGIN { use_ok( 'B' ); }
+
+
+package Testing::Symtable;
+use vars qw($This @That %wibble $moo %moo);
+my $not_a_sym = 'moo';
+
+sub moo { 42 }
+sub car { 23 }
+
+
+package Testing::Symtable::Foo;
+sub yarrow { "Hock" }
+
+package Testing::Symtable::Bar;
+sub hock { "yarrow" }
+
+package main;
+use vars qw(%Subs);
+local %Subs = ();
+B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ },
+ 'Testing::Symtable::');
+
+sub B::GV::find_syms {
+ my($symbol) = @_;
+
+ $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++;
+}
+
+my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car
+ BEGIN);
+push @syms, "Testing::Symtable::Foo::yarrow";
+
+# Make sure we hit all the expected symbols.
+ok( join('', sort @syms) eq join('', sort keys %Subs), 'all symbols found' );
+
+# Make sure we only hit them each once.
+ok( (!grep $_ != 1, values %Subs), '...and found once' );
+
+# Tests for MAGIC / MOREMAGIC
+ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' );
+{
+ my $e = '';
+ local $SIG{__DIE__} = sub { $e = $_[0] };
+ # Used to dump core, bug #16828
+ eval { B::svref_2object(\$.)->MAGIC->MOREMAGIC->TYPE; };
+ like( $e, qr/Can't call method "TYPE" on an undefined value/,
+ '$. has no more magic' );
+}
+
+my $iv = 1;
+my $iv_ref = B::svref_2object(\$iv);
+is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object");
+is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT");
+# Flag tests are needed still
+#diag $iv_ref->FLAGS();
+my $iv_ret = $iv_ref->object_2svref();
+is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR");
+is($$iv_ret, $iv, "Test object_2svref()");
+is($iv_ref->int_value, $iv, "Test int_value()");
+is($iv_ref->IV, $iv, "Test IV()");
+is($iv_ref->IVX(), $iv, "Test IVX()");
+is($iv_ref->UVX(), $iv, "Test UVX()");
+
+my $pv = "Foo";
+my $pv_ref = B::svref_2object(\$pv);
+is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object");
+is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT");
+# Flag tests are needed still
+#diag $pv_ref->FLAGS();
+my $pv_ret = $pv_ref->object_2svref();
+is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR");
+is($$pv_ret, $pv, "Test object_2svref()");
+is($pv_ref->PV(), $pv, "Test PV()");
+eval { is($pv_ref->RV(), $pv, "Test RV()"); };
+ok($@, "Test RV()");
+is($pv_ref->PVX(), $pv, "Test PVX()");
+
+my $nv = 1.1;
+my $nv_ref = B::svref_2object(\$nv);
+is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object");
+is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT");
+# Flag tests are needed still
+#diag $nv_ref->FLAGS();
+my $nv_ret = $nv_ref->object_2svref();
+is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR");
+is($$nv_ret, $nv, "Test object_2svref()");
+is($nv_ref->NV, $nv, "Test NV()");
+is($nv_ref->NVX(), $nv, "Test NVX()");
+
+my $null = undef;
+my $null_ref = B::svref_2object(\$null);
+is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object");
+is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT");
+# Flag tests are needed still
+#diag $null_ref->FLAGS();
+my $null_ret = $nv_ref->object_2svref();
+is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR");
+is($$null_ret, $nv, "Test object_2svref()");
+
+my $cv = sub{ 1; };
+my $cv_ref = B::svref_2object(\$cv);
+is($cv_ref->REFCNT, 1, "Test B::RV->REFCNT");
+is(ref $cv_ref, "B::RV", "Test B::RV return from svref_2object - code");
+my $cv_ret = $cv_ref->object_2svref();
+is(ref $cv_ret, "REF", "Test object_2svref() return is REF");
+is($$cv_ret, $cv, "Test object_2svref()");
+
+my $av = [];
+my $av_ref = B::svref_2object(\$av);
+is(ref $av_ref, "B::RV", "Test B::RV return from svref_2object - array");
+
+my $hv = [];
+my $hv_ref = B::svref_2object(\$hv);
+is(ref $hv_ref, "B::RV", "Test B::RV return from svref_2object - hash");
+
+local *gv = *STDOUT;
+my $gv_ref = B::svref_2object(\*gv);
+is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object");
+ok(! $gv_ref->is_empty(), "Test is_empty()");
+is($gv_ref->NAME(), "gv", "Test NAME()");
+is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()");
+like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()");
Added: B/t/bblock.t
==============================================================================
--- (empty file)
+++ B/t/bblock.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,21 @@
+#!./perl -Tw
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 1;
+
+use_ok('B::Bblock', qw(find_leaders));
+
+# Someone who understands what this module does, please fill this out.
Added: B/t/bytecode.t
==============================================================================
--- (empty file)
+++ B/t/bytecode.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,167 @@
+#!./perl
+my $keep_plc = 0; # set it to keep the bytecode files
+my $keep_plc_fail = 1; # set it to keep the bytecode files on failures
+
+BEGIN {
+ if ($^O eq 'VMS') {
+ print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n";
+ exit 0;
+ }
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ use Config;
+ if (($Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ if ($Config{ccflags} =~ /-DPERL_COPY_ON_WRITE/) {
+ print "1..0 # skip - no COW for now\n";
+ exit 0;
+ }
+ require 'test.pl'; # for run_perl()
+}
+use strict;
+
+undef $/;
+my @tests = split /\n###+\n/, <DATA>;
+
+print "1..".($#tests+1)."\n";
+
+my $cnt = 1;
+my $test;
+
+for (@tests) {
+ my $got;
+ my ($script, $expect) = split />>>+\n/;
+ $expect =~ s/\n$//;
+ $test = "bytecode$cnt.pl";
+ open T, ">$test"; print T $script; close T;
+ $got = run_perl(switches => [ "-MO=Bytecode,-H,-o${test}c" ],
+ verbose => 0, # for debugging
+ stderr => 1, # to capture the "bytecode.pl syntax ok"
+ progfile => $test);
+ unless ($?) {
+ $got = run_perl(progfile => "${test}c"); # run the .plc
+ unless ($?) {
+ if ($got =~ /^$expect$/) {
+ print "ok $cnt\n";
+ next;
+ } else {
+ $keep_plc = $keep_plc_fail unless $keep_plc;
+ print <<"EOT"; next;
+not ok $cnt
+--------- SCRIPT
+$script
+--------- GOT
+$got
+--------- EXPECT
+$expect
+----------------
+
+EOT
+ }
+ }
+ }
+ print <<"EOT";
+not ok $cnt
+--------- SCRIPT
+$script
+--------- \$\? = $?
+$got
+EOT
+} continue {
+ 1 while unlink($test, $keep_plc ? () : "${test}c");
+ $cnt++;
+}
+
+__DATA__
+
+print 'hi'
+>>>>
+hi
+############################################################
+for (1,2,3) { print if /\d/ }
+>>>>
+123
+############################################################
+$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
+>>>>
+zzz2y2y2
+############################################################
+$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
+>>>>
+z2y2y2
+############################################################
+split /a/,"bananarama"; print @_
+>>>>
+bnnrm
+############################################################
+{ package P; sub x { print 'ya' } x }
+>>>>
+ya
+############################################################
+ at z = split /:/,"b:r:n:f:g"; print @z
+>>>>
+brnfg
+############################################################
+sub AUTOLOAD { print 1 } &{"a"}()
+>>>>
+1
+############################################################
+my $l = 3; $x = sub { print $l }; &$x
+>>>>
+3
+############################################################
+my $i = 1;
+my $foo = sub {$i = shift if @_};
+&$foo(3);
+print 'ok';
+>>>>
+ok
+############################################################
+$x="Cannot use"; print index $x, "Can"
+>>>>
+0
+############################################################
+my $i=6; eval "print \$i\n"
+>>>>
+6
+############################################################
+BEGIN { %h=(1=>2,3=>4) } print $h{3}
+>>>>
+4
+############################################################
+open our $T,"a";
+print 'ok';
+>>>>
+ok
+############################################################
+print <DATA>
+__DATA__
+a
+b
+>>>>
+a
+b
+############################################################
+BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } }
+print $a[1]
+>>>>
+1
+############################################################
+my $i=3; print 1 .. $i
+>>>>
+123
+############################################################
+my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h
+>>>>
+ba
+############################################################
+print sort { my $p; $b <=> $a } 1,4,3
+>>>>
+431
Added: B/t/concise-xs.t
==============================================================================
--- (empty file)
+++ B/t/concise-xs.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,284 @@
+#!./perl
+
+# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
+
+=head1 SYNOPSIS
+
+To verify that B::Concise properly reports whether functions are XS or
+perl, we test against 2 (currently) core packages which have lots of
+XS functions: B and Digest::MD5. They're listed in %$testpkgs, along
+with a list of functions that are (or are not) XS. For brevity, you
+can specify the shorter list; if they're non-xs routines, start list
+with a '!'. Data::Dumper is also tested, partly to prove the non-!
+usage.
+
+We demand-load each package, scan its stash for function names, and
+mark them as XS/not-XS according to the list given for each package.
+Then we test B::Concise's report on each.
+
+=head1 OPTIONS AND ARGUMENTS
+
+C<-v> and C<-V> trigger 2 levels of verbosity.
+
+C<-a> uses Module::CoreList to run all core packages through the test, which
+gives some interesting results.
+
+C<-c> causes the expected XS/non-XS results to be marked with
+corrections, which are then reported at program END, in a
+Data::Dumper statement
+
+C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
+results accordingly. The file is 'required', so @INC settings apply.
+
+If module-names are given as args, those packages are run through the
+test harness; this is handy for collecting further items to test, and
+may be useful otherwise (ie just to see).
+
+=head1 EXAMPLES
+
+All following examples avoid using PERL_CORE=1, since that changes @INC
+
+=over 4
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
+
+Tests Storable.pm for XS/non-XS routines, writes findings (along with
+test results) to stdout. You could edit results to produce a test
+file, as in next example
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
+
+Loads file, and uses it to set expectations, and run tests
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
+
+Gets module list from Module::Corelist, and runs them all through the
+test. Since -c is used, this generates corrections, which are saved
+in a file, which is edited down to produce ../all-xs
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
+
+This runs the tests specified in the file created in previous example.
+-c is used again, and stdout verifies that all the expected results
+given by -r ../all-xs are now seen.
+
+Looking at ../foo2, you'll see 34 occurrences of the following error:
+
+# err: Can't use an undefined value as a SCALAR reference at
+# lib/B/Concise.pm line 634, <DATA> line 1.
+
+=back
+
+=cut
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ unless ($Config::Config{useperlio}) {
+ print "1..0 # Skip -- Perl configured without perlio\n";
+ exit 0;
+ }
+}
+
+use Getopt::Std;
+use Carp;
+# One 5.009-only test to go when no 6; is integrated (25344)
+use Test::More tests => ( 1 * !!$Config::Config{useithreads}
+ + 1 * ($] > 5.009)
+ + 778);
+
+require_ok("B::Concise");
+
+my $testpkgs = {
+
+ Digest::MD5 => [qw/ ! import /],
+
+ B => [qw/ ! class clearsym compile_stats debug objsym parents
+ peekop savesym timing_info walkoptree_exec
+ walkoptree_slow walksymtable /],
+
+ Data::Dumper => [qw/ bootstrap Dumpxs /],
+
+ B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
+ CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
+ OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
+ OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
+ OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
+ OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
+ OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
+ OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
+ OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
+ OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
+ PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
+ PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
+ POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
+ SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
+ main_root main_start opnumber perlstring
+ svref_2object /],
+
+};
+
+############
+
+B::Concise::compile('-nobanner'); # set a silent default
+getopts('vaVcr:', \my %opts) or
+ die <<EODIE;
+
+usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
+ tests ability to discern XS funcs using Digest::MD5 package
+ -v : runs verbosely
+ -V : more verbosity
+ -a : runs all modules in CoreList
+ -c : writes test corrections as a Data::Dumper expression
+ -r <file> : reads file of tests, as written by -c
+ <args> : additional modules are loaded and tested
+ (will report failures, since no XS funcs are known aprior)
+
+EODIE
+ ;
+
+if (%opts) {
+ require Data::Dumper;
+ Data::Dumper->import('Dumper');
+ $Data::Dumper::Sortkeys = 1;
+}
+my @argpkgs = @ARGV;
+my %report;
+
+if ($opts{r}) {
+ my $refpkgs = require "$opts{r}";
+ $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
+}
+
+unless ($opts{a}) {
+ unless (@argpkgs) {
+ foreach $pkg (sort keys %$testpkgs) {
+ test_pkg($pkg, $testpkgs->{$pkg});
+ }
+ } else {
+ foreach $pkg (@argpkgs) {
+ test_pkg($pkg, $testpkgs->{$pkg});
+ }
+ }
+} else {
+ corecheck();
+}
+############
+
+sub test_pkg {
+ my ($pkg_name, $xslist) = @_;
+ require_ok($pkg_name);
+
+ unless (ref $xslist eq 'ARRAY') {
+ warn "no XS/non-XS function list given, assuming empty XS list";
+ $xslist = [''];
+ }
+
+ my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
+ $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
+
+ # build %stash: keys are func-names, vals: 1 if XS, 0 if not
+ my (%stash) = map
+ ( ($_ => $assumeXS)
+ => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
+ => grep !/__ANON__/ # but not anon subs
+ => keys %{$pkg_name.'::'} # from symbol table
+ ));
+
+ # now invert according to supplied list
+ $stash{$_} = int ! $assumeXS foreach @$xslist;
+
+ # and cleanup cruft (easier than preventing)
+ delete @stash{'!',''};
+
+ if ($opts{v}) {
+ diag("xslist: " => Dumper($xslist));
+ diag("$pkg_name stash: " => Dumper(\%stash));
+ }
+ my $err;
+ foreach $func_name (reverse sort keys %stash) {
+ my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
+ if (!$res) {
+ $stash{$func_name} ^= 1;
+ print "$func_name ";
+ $err++;
+ }
+ }
+ $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
+}
+
+sub checkXS {
+ my ($func_name, $wantXS) = @_;
+
+ my ($buf, $err) = render($func_name);
+ if ($wantXS) {
+ like($buf, qr/\Q$func_name is XS code/,
+ "XS code:\t $func_name");
+ } else {
+ unlike($buf, qr/\Q$func_name is XS code/,
+ "perl code:\t $func_name");
+ }
+ #returns like or unlike, whichever was called
+}
+
+sub render {
+ my ($func_name) = @_;
+
+ B::Concise::reset_sequence();
+ B::Concise::walk_output(\my $buf);
+
+ my $walker = B::Concise::compile($func_name);
+ eval { $walker->() };
+ diag("err: $@ $buf") if $@;
+ diag("verbose: $buf") if $opts{V};
+
+ return ($buf, $@);
+}
+
+sub corecheck {
+
+ eval { require Module::CoreList };
+ if ($@) {
+ warn "Module::CoreList not available on $]\n";
+ return;
+ }
+ my $mods = $Module::CoreList::version{'5.009002'};
+ $mods = [ sort keys %$mods ];
+ print Dumper($mods);
+
+ foreach my $pkgnm (@$mods) {
+ test_pkg($pkgnm);
+ }
+}
+
+END {
+ if ($opts{c}) {
+ # print "Corrections: ", Dumper(\%report);
+ print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
+ print "\$VAR1 = {\n";
+
+ foreach my $pkg (sort keys %report) {
+ my (@xs, @perl);
+ my $stash = $report{$pkg};
+
+ @xs = sort grep $stash->{$_} == 1, keys %$stash;
+ @perl = sort grep $stash->{$_} == 0, keys %$stash;
+
+ my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
+ print "\t$pkg => [qw/ @list /],\n";
+ }
+ print "};\n";
+ }
+}
+
+__END__
Added: B/t/concise.t
==============================================================================
--- (empty file)
+++ B/t/concise.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,390 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More
+ sub diag { print "# @_\n" } # but this is still handy
+}
+
+plan tests => 149;
+
+require_ok("B::Concise");
+
+$out = runperl(switches => ["-MO=Concise"], prog => '$a', stderr => 1);
+
+# If either of the next two tests fail, it probably means you need to
+# fix the section labeled 'fragile kludge' in Concise.pm
+
+($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m);
+
+is($op_base, 1, "Smallest OP sequence number");
+
+($op_base_p1, $cop_base)
+ = ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (-?\d+) /m);
+
+is($op_base_p1, 2, "Second-smallest OP sequence number");
+
+is($cop_base, 1, "Smallest COP sequence number");
+
+# test that with -exec B::Concise navigates past logops (bug #18175)
+
+$out = runperl(
+ switches => ["-MO=Concise,-exec"],
+ prog => q{$a=$b && print q/foo/},
+ stderr => 1,
+);
+#diag($out);
+like($out, qr/print/, "'-exec' option output has print opcode");
+
+######## API tests v.60
+
+use Config; # used for perlio check
+B::Concise->import(qw( set_style set_style_standard add_callback
+ add_style walk_output reset_sequence ));
+
+## walk_output argument checking
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo ("string", [], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects arg '$foo'");
+ $@=''; # clear the fail for next test
+}
+# test accessor mode when arg undefd or 0
+foreach my $foo (undef, 0) {
+ my $handle = walk_output($foo);
+ is ($handle, \*STDOUT, "walk_output set to STDOUT (default)");
+}
+
+{ # any object that can print should be ok for walk_output
+ package Hugo;
+ sub new { my $foo = bless {} };
+ sub print { CORE::print @_ }
+}
+my $foo = new Hugo; # suggested this API fix
+eval { walk_output($foo) };
+is ($@, '', "walk_output() accepts obj that can print");
+
+# test that walk_output accepts a HANDLE arg
+SKIP: {
+ skip("no perlio in this build", 4)
+ unless $Config::Config{useperlio};
+
+ foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts STD* " . ref $foo);
+ }
+
+ # now test a ref to scalar
+ eval { walk_output(\my $junk) };
+ is ($@, '', "walk_output() accepts ref-to-sprintf target");
+
+ $junk = "non-empty";
+ eval { walk_output(\$junk) };
+ is ($@, '', "walk_output() accepts ref-to-non-empty-scalar");
+}
+
+## add_style
+my @stylespec;
+$@='';
+eval { add_style ('junk_B' => @stylespec) };
+like ($@, 'expecting 3 style-format args',
+ "add_style rejects insufficient args");
+
+ at stylespec = (0,0,0); # right length, invalid values
+$@='';
+eval { add_style ('junk' => @stylespec) };
+is ($@, '', "add_style accepts: stylename => 3-arg-array");
+
+$@='';
+eval { add_style (junk => @stylespec) };
+like ($@, qr/style 'junk' already exists, choose a new name/,
+ "add_style correctly disallows re-adding same style-name" );
+
+# test new arg-checks on set_style
+$@='';
+eval { set_style (@stylespec) };
+is ($@, '', "set_style accepts 3 style-format args");
+
+ at stylespec = (); # bad style
+
+eval { set_style (@stylespec) };
+like ($@, qr/expecting 3 style-format args/,
+ "set_style rejects bad style-format args");
+
+#### for content with doc'd options
+
+our($a, $b);
+my $func = sub{ $a = $b+42 }; # canonical example asub
+
+sub render {
+ walk_output(\my $out);
+ eval { B::Concise::compile(@_)->() };
+ # diag "rendering $@\n";
+ return ($out, $@) if wantarray;
+ return $out;
+}
+
+SKIP: {
+ # tests output to GLOB, using perlio feature directly
+ skip "no perlio on this build", 127
+ unless $Config::Config{useperlio};
+
+ set_style_standard('concise'); # MUST CALL before output needed
+
+ @options = qw(
+ -basic -exec -tree -compact -loose -vt -ascii
+ -base10 -bigendian -littleendian
+ );
+ foreach $opt (@options) {
+ ($out) = render($opt, $func);
+ isnt($out, '', "got output with option $opt");
+ }
+
+ ## test output control via walk_output
+
+ my $treegen = B::Concise::compile('-basic', $func); # reused
+
+ { # test output into a package global string (sprintf-ish)
+ our $thing;
+ walk_output(\$thing);
+ $treegen->();
+ ok($thing, "walk_output to our SCALAR, output seen");
+ }
+
+ # test walkoutput acceptance of a scalar-bound IO handle
+ open (my $fh, '>', \my $buf);
+ walk_output($fh);
+ $treegen->();
+ ok($buf, "walk_output to GLOB, output seen");
+
+ ## test B::Concise::compile error checking
+
+ # call compile on non-CODE ref items
+ if (0) {
+ # pending STASH splaying
+
+ foreach my $ref ([], {}) {
+ my $typ = ref $ref;
+ walk_output(\my $out);
+ eval { B::Concise::compile('-basic', $ref)->() };
+ like ($@, qr/^err: not a coderef: $typ/,
+ "compile detects $typ-ref where expecting subref");
+ is($out,'', "no output when errd"); # announcement prints
+ }
+ }
+
+ # test against a bogus autovivified subref.
+ # in debugger, it should look like:
+ # 1 CODE(0x84840cc)
+ # -> &CODE(0x84840cc) in ???
+
+ my ($res,$err);
+ TODO: {
+ #local $TODO = "\tdoes this handling make sense ?";
+
+ sub declared_only;
+ ($res,$err) = render('-basic', \&declared_only);
+ like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
+ "'sub decl_only' seen as having no START");
+
+ sub defd_empty {};
+ ($res,$err) = render('-basic', \&defd_empty);
+ is(scalar split(/\n/, $res), 3,
+ "'sub defd_empty {}' seen as 3 liner");
+
+ is(1, $res =~ /leavesub/ && $res =~ /nextstate/,
+ "'sub defd_empty {}' seen as 2 ops: leavesub,nextstate");
+
+ ($res,$err) = render('-basic', \¬_even_declared);
+ like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
+ "'\¬_even_declared' seen as having no START");
+
+ {
+ package Bar;
+ our $AUTOLOAD = 'garbage';
+ sub AUTOLOAD { print "# in AUTOLOAD body: $AUTOLOAD\n" }
+ }
+ ($res,$err) = render('-basic', Bar::auto_func);
+ like ($res, qr/unknown function \(Bar::auto_func\)/,
+ "Bar::auto_func seen as unknown function");
+
+ ($res,$err) = render('-basic', \&Bar::auto_func);
+ like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
+ "'\&Bar::auto_func' seen as having no START");
+
+ ($res,$err) = render('-basic', \&Bar::AUTOLOAD);
+ like ($res, qr/in AUTOLOAD body: /, "found body of Bar::AUTOLOAD");
+
+ }
+ ($res,$err) = render('-basic', Foo::bar);
+ like ($res, qr/unknown function \(Foo::bar\)/,
+ "BC::compile detects fn-name as unknown function");
+
+ # v.62 tests
+
+ pass ("TEST POST-COMPILE OPTION-HANDLING IN WALKER SUBROUTINE");
+
+ my $sample;
+
+ my $walker = B::Concise::compile('-basic', $func);
+ walk_output(\$sample);
+ $walker->('-exec');
+ like($sample, qr/goto/m, "post-compile -exec");
+
+ walk_output(\$sample);
+ $walker->('-basic');
+ unlike($sample, qr/goto/m, "post-compile -basic");
+
+
+ # bang at it combinatorically
+ my %combos;
+ my @modes = qw( -basic -exec );
+ my @styles = qw( -concise -debug -linenoise -terse );
+
+ # prep samples
+ for $style (@styles) {
+ for $mode (@modes) {
+ walk_output(\$sample);
+ reset_sequence();
+ $walker->($style, $mode);
+ $combos{"$style$mode"} = $sample;
+ }
+ }
+ # crosscheck that samples are all text-different
+ @list = sort keys %combos;
+ for $i (0..$#list) {
+ for $j ($i+1..$#list) {
+ isnt ($combos{$list[$i]}, $combos{$list[$j]},
+ "combos for $list[$i] and $list[$j] are different, as expected");
+ }
+ }
+
+ # add samples with styles in different order
+ for $mode (@modes) {
+ for $style (@styles) {
+ reset_sequence();
+ walk_output(\$sample);
+ $walker->($mode, $style);
+ $combos{"$mode$style"} = $sample;
+ }
+ }
+ # test commutativity of flags, ie that AB == BA
+ for $mode (@modes) {
+ for $style (@styles) {
+ is ( $combos{"$style$mode"},
+ $combos{"$mode$style"},
+ "results for $style$mode vs $mode$style are the same" );
+ }
+ }
+
+ my %save = %combos;
+ %combos = (); # outputs for $mode=any($order) and any($style)
+
+ # add more samples with switching modes & sticky styles
+ for $style (@styles) {
+ walk_output(\$sample);
+ reset_sequence();
+ $walker->($style);
+ for $mode (@modes) {
+ walk_output(\$sample);
+ reset_sequence();
+ $walker->($mode);
+ $combos{"$style/$mode"} = $sample;
+ }
+ }
+ # crosscheck that samples are all text-different
+ @nm = sort keys %combos;
+ for $i (0..$#nm) {
+ for $j ($i+1..$#nm) {
+ isnt ($combos{$nm[$i]}, $combos{$nm[$j]},
+ "results for $nm[$i] and $nm[$j] are different, as expected");
+ }
+ }
+
+ # add samples with switching styles & sticky modes
+ for $mode (@modes) {
+ walk_output(\$sample);
+ reset_sequence();
+ $walker->($mode);
+ for $style (@styles) {
+ walk_output(\$sample);
+ reset_sequence();
+ $walker->($style);
+ $combos{"$mode/$style"} = $sample;
+ }
+ }
+ # test commutativity of flags, ie that AB == BA
+ for $mode (@modes) {
+ for $style (@styles) {
+ is ( $combos{"$style/$mode"},
+ $combos{"$mode/$style"},
+ "results for $style/$mode vs $mode/$style are the same" );
+ }
+ }
+
+
+ #now do double crosschecks: commutativity across stick / nostick
+ %combos = (%combos, %save);
+
+ # test commutativity of flags, ie that AB == BA
+ for $mode (@modes) {
+ for $style (@styles) {
+
+ is ( $combos{"$style$mode"},
+ $combos{"$style/$mode"},
+ "$style$mode VS $style/$mode are the same" );
+
+ is ( $combos{"$mode$style"},
+ $combos{"$mode/$style"},
+ "$mode$style VS $mode/$style are the same" );
+
+ is ( $combos{"$style$mode"},
+ $combos{"$mode/$style"},
+ "$style$mode VS $mode/$style are the same" );
+
+ is ( $combos{"$mode$style"},
+ $combos{"$style/$mode"},
+ "$mode$style VS $style/$mode are the same" );
+ }
+ }
+}
+
+
+# test proper NULLING of pointer, derefd by CvSTART, when a coderef is
+# undefd. W/o this, the pointer can dangle into freed and reused
+# optree mem, which no longer points to opcodes.
+
+# Using B::Concise to render Config::AUTOLOAD's optree at BEGIN-time
+# triggers this obscure bug, cuz AUTOLOAD has a bootstrap version,
+# which is used at load-time then undeffed. It is normally
+# re-vivified later, but not in time for this (BEGIN/CHECK)-time
+# rendering.
+
+$out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"],
+ prog => 'use Config; BEGIN { $Config{awk} }',
+ stderr => 1 );
+
+like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
+ "coderef properly undefined");
+
+$out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"],
+ prog => 'use Config; CHECK { $Config{awk} }',
+ stderr => 1 );
+
+like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
+ "coderef properly undefined");
+
+__END__
+
Added: B/t/debug.t
==============================================================================
--- (empty file)
+++ B/t/debug.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,79 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..3\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+$a = `$^X $path "-MO=Debug" -e 1 $redir`;
+print "not " unless $a =~
+/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
+ok;
+
+
+$a = `$^X $path "-MO=Terse" -e 1 $redir`;
+print "not " unless $a =~
+/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
+ok;
+
+$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
+$a =~ s/\(0x[^)]+\)//g;
+$a =~ s/\[[^\]]+\]//g;
+$a =~ s/-e syntax OK//;
+$a =~ s/[^a-z ]+//g;
+$a =~ s/\s+/ /g;
+$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
+$a =~ s/^\s+//;
+$a =~ s/\s+$//;
+my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
+if ($is_thread) {
+ $b=<<EOF;
+leave enter nextstate label leaveloop enterloop null and defined null
+threadsv readline gv lineseq nextstate aassign null pushmark split pushre
+threadsv const null pushmark rvav gv nextstate subst const unstack
+EOF
+} else {
+ $b=<<EOF;
+leave enter nextstate label leaveloop enterloop null and defined null
+null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
+null gvsv const null pushmark rvav gv nextstate subst const unstack
+EOF
+}
+$b=~s/\n/ /g;$b=~s/\s+/ /g;
+$b =~ s/\s+$//;
+print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
+ok;
+
Added: B/t/deparse.t
==============================================================================
--- (empty file)
+++ B/t/deparse.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,309 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use warnings;
+use strict;
+use Test::More tests => 42;
+
+use B::Deparse;
+my $deparse = B::Deparse->new();
+ok($deparse);
+
+# Tell B::Deparse about our ambient pragmas
+{ my ($hint_bits, $warning_bits);
+ BEGIN { ($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS}); }
+ $deparse->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[
+ );
+}
+
+$/ = "\n####\n";
+while (<DATA>) {
+ chomp;
+ s/#(.*)$//mg;
+ my ($num) = $1 =~ m/(\d+)/;
+ my ($input, $expected);
+ if (/(.*)\n>>>>\n(.*)/s) {
+ ($input, $expected) = ($1, $2);
+ }
+ else {
+ ($input, $expected) = ($_, $_);
+ }
+
+ my $coderef = eval "sub {$input}";
+
+ if ($@) {
+ ok(0, "$num deparsed: $@");
+ }
+ else {
+ my $deparsed = $deparse->coderef2text( $coderef );
+ my $regex = quotemeta($expected);
+ do {
+ no warnings 'misc';
+ $regex =~ s/\s+/\s+/g;
+ };
+ like($deparsed, qr/$regex/);
+ }
+}
+
+use constant 'c', 'stuff';
+is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
+
+my $a = 0;
+is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
+
+use constant cr => ['hello'];
+my $string = "sub " . $deparse->coderef2text(\&cr);
+my $val = (eval $string)->();
+ok( ref($val) eq 'ARRAY' && $val->[0] eq 'hello');
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path .= " -MMac::err=unix" if $Is_MacOS;
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
+$a =~ s/-e syntax OK\n//g;
+$a =~ s/.*possible typo.*\n//; # Remove warning line
+$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
+$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
+$b = <<'EOF';
+BEGIN { $^I = ".bak"; }
+BEGIN { $^W = 1; }
+BEGIN { $/ = "\n"; $\ = "\n"; }
+LINE: while (defined($_ = <ARGV>)) {
+ chomp $_;
+ our(@F) = split(" ", $_, 0);
+ '???';
+}
+EOF
+$b =~ s/(LINE:)/sub BEGIN {
+ 'MacPerl'->bootstrap;
+ 'OSA'->bootstrap;
+ 'XL'->bootstrap;
+}
+$1/ if $Is_MacOS;
+is($a, $b);
+
+#Re: perlbug #35857, patch #24505
+#handle warnings::register-ed packages properly.
+package B::Deparse::Wrapper;
+use strict;
+use warnings;
+use warnings::register;
+sub getcode {
+ my $deparser = B::Deparse->new();
+ return $deparser->coderef2text(shift);
+}
+
+package main;
+use strict;
+use warnings;
+sub test {
+ my $val = shift;
+ my $res = B::Deparse::Wrapper::getcode($val);
+ like( $res, qr/use warnings/);
+}
+my ($q,$p);
+my $x=sub { ++$q,++$p };
+test($x);
+eval <<EOFCODE and test($x);
+ package bar;
+ use strict;
+ use warnings;
+ use warnings::register;
+ package main;
+ 1
+EOFCODE
+
+__DATA__
+# 2
+1;
+####
+# 3
+{
+ no warnings;
+ '???';
+ 2;
+}
+####
+# 4
+my $test;
+++$test and $test /= 2;
+>>>>
+my $test;
+$test /= 2 if ++$test;
+####
+# 5
+-((1, 2) x 2);
+####
+# 6
+{
+ my $test = sub : lvalue {
+ my $x;
+ }
+ ;
+}
+####
+# 7
+{
+ my $test = sub : method {
+ my $x;
+ }
+ ;
+}
+####
+# 8
+{
+ my $test = sub : locked method {
+ my $x;
+ }
+ ;
+}
+####
+# 9
+{
+ 234;
+}
+continue {
+ 123;
+}
+####
+# 10
+my $x;
+print $main::x;
+####
+# 11
+my @x;
+print $main::x[1];
+####
+# 12
+my %x;
+$x{warn()};
+####
+# 13
+my $foo;
+$_ .= <ARGV> . <$foo>;
+####
+# 14
+my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
+####
+# 15
+s/x/'y';/e;
+####
+# 16 - various lypes of loop
+{ my $x; }
+####
+# 17
+while (1) { my $k; }
+####
+# 18
+my ($x, at a);
+$x=1 for @a;
+>>>>
+my($x, @a);
+$x = 1 foreach (@a);
+####
+# 19
+for (my $i = 0; $i < 2;) {
+ my $z = 1;
+}
+####
+# 20
+for (my $i = 0; $i < 2; ++$i) {
+ my $z = 1;
+}
+####
+# 21
+for (my $i = 0; $i < 2; ++$i) {
+ my $z = 1;
+}
+####
+# 22
+my $i;
+while ($i) { my $z = 1; } continue { $i = 99; }
+####
+# 23
+foreach my $i (1, 2) {
+ my $z = 1;
+}
+####
+# 24
+my $i;
+foreach $i (1, 2) {
+ my $z = 1;
+}
+####
+# 25
+my $i;
+foreach my $i (1, 2) {
+ my $z = 1;
+}
+####
+# 26
+foreach my $i (1, 2) {
+ my $z = 1;
+}
+####
+# 27
+foreach our $i (1, 2) {
+ my $z = 1;
+}
+####
+# 28
+my $i;
+foreach our $i (1, 2) {
+ my $z = 1;
+}
+####
+# 29
+my @x;
+print reverse sort(@x);
+####
+# 30
+my @x;
+print((sort {$b cmp $a} @x));
+####
+# 31
+my @x;
+print((reverse sort {$b <=> $a} @x));
+####
+# 32
+our @a;
+print $_ foreach (reverse @a);
+####
+# 33
+our @a;
+print $_ foreach (reverse 1, 2..5);
+####
+# 34
+my $bar;
+'Foo'->$bar('orz');
+####
+# 35
+'Foo'->bar('orz');
+####
+# 36
+'Foo'->bar;
Added: B/t/f_map
==============================================================================
--- (empty file)
+++ B/t/f_map Tue Jun 26 12:23:24 2007
@@ -0,0 +1,29 @@
+#!perl
+# examples shamelessly snatched from perldoc -f map
+
+# translates a list of numbers to the corresponding characters.
+ at chars = map(chr, @nums);
+
+%hash = map { getkey($_) => $_ } @array;
+
+{
+ %hash = ();
+ foreach $_ (@array) {
+ $hash{getkey($_)} = $_;
+ }
+}
+
+#%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong
+%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right
+
+%hash = map { ("\L$_", 1) } @array; # this also works
+
+%hash = map { lc($_), 1 } @array; # as does this.
+
+%hash = map +( lc($_), 1 ), @array; # this is EXPR and works!
+
+%hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array)
+
+ at hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end
+
+
Added: B/t/f_map.t
==============================================================================
--- (empty file)
+++ B/t/f_map.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,543 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ if (!$Config::Config{useperlio}) {
+ print "1..0 # Skip -- need perlio to walk the optree\n";
+ exit 0;
+ }
+ # require q(test.pl); # now done by OptreeCheck
+}
+use OptreeCheck;
+plan tests => 9;
+
+
+=head1 f_map.t
+
+Code test snippets here are adapted from `perldoc -f map`
+
+Due to a bleadperl optimization (Dave Mitchell, circa may 04), the
+(map|grep)(start|while) opcodes have different flags in 5.9, their
+private flags /1, /2 are gone in blead (for the cases covered)
+
+When the optree stuff was integrated into 5.8.6, these tests failed,
+and were todo'd. Theyre now done, by version-specific tweaking in
+mkCheckRex(), therefore the skip is removed too.
+
+=for gentest
+
+# chunk: #!perl
+# examples shamelessly snatched from perldoc -f map
+
+=cut
+
+=for gentest
+
+# chunk: # translates a list of numbers to the corresponding characters.
+ at chars = map(chr, @nums);
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@chars = map(chr, @nums); },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 475 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*nums] s
+# 5 <1> rv2av[t7] lKM/1
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t8] lK
+# 8 <#> gvsv[*_] s
+# 9 <1> chr[t5] sK/1
+# goto 7
+# a <0> pushmark s
+# b <#> gv[*chars] s
+# c <1> rv2av[t2] lKRM*/1
+# d <2> aassign[t9] KS/COMMON
+# e <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 559 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*nums) s
+# 5 <1> rv2av[t4] lKM/1
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t5] lK
+# 8 <$> gvsv(*_) s
+# 9 <1> chr[t3] sK/1
+# goto 7
+# a <0> pushmark s
+# b <$> gv(*chars) s
+# c <1> rv2av[t1] lKRM*/1
+# d <2> aassign[t6] KS/COMMON
+# e <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: %hash = map { getkey($_) => $_ } @array;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{%hash = map { getkey($_) => $_ } @array; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 476 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*array] s
+# 5 <1> rv2av[t8] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t9] lK
+# 8 <0> enter l
+# 9 <;> nextstate(main 475 (eval 10):1) v
+# a <0> pushmark s
+# b <0> pushmark s
+# c <#> gvsv[*_] s
+# d <#> gv[*getkey] s/EARLYCV
+# e <1> entersub[t5] lKS/TARG,1
+# f <#> gvsv[*_] s
+# g <@> list lK
+# h <@> leave lKP
+# goto 7
+# i <0> pushmark s
+# j <#> gv[*hash] s
+# k <1> rv2hv[t2] lKRM*/1
+# l <2> aassign[t10] KS/COMMON
+# m <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 560 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*array) s
+# 5 <1> rv2av[t3] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t4] lK
+# 8 <0> enter l
+# 9 <;> nextstate(main 559 (eval 15):1) v
+# a <0> pushmark s
+# b <0> pushmark s
+# c <$> gvsv(*_) s
+# d <$> gv(*getkey) s/EARLYCV
+# e <1> entersub[t2] lKS/TARG,1
+# f <$> gvsv(*_) s
+# g <@> list lK
+# h <@> leave lKP
+# goto 7
+# i <0> pushmark s
+# j <$> gv(*hash) s
+# k <1> rv2hv[t1] lKRM*/1
+# l <2> aassign[t5] KS/COMMON
+# m <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: {
+ %hash = ();
+ foreach $_ (@array) {
+ $hash{getkey($_)} = $_;
+ }
+}
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{{ %hash = (); foreach $_ (@array) { $hash{getkey($_)} = $_; } } },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 478 (eval 10):1) v
+# 2 <{> enterloop(next->u last->u redo->3)
+# 3 <;> nextstate(main 475 (eval 10):1) v
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <#> gv[*hash] s
+# 7 <1> rv2hv[t2] lKRM*/1
+# 8 <2> aassign[t3] vKS
+# 9 <;> nextstate(main 476 (eval 10):1) v
+# a <0> pushmark sM
+# b <#> gv[*array] s
+# c <1> rv2av[t6] sKRM/1
+# d <#> gv[*_] s
+# e <1> rv2gv sKRM/1
+# f <{> enteriter(next->q last->t redo->g) lKS
+# r <0> iter s
+# s <|> and(other->g) K/1
+# g <;> nextstate(main 475 (eval 10):1) v
+# h <#> gvsv[*_] s
+# i <#> gv[*hash] s
+# j <1> rv2hv sKR/1
+# k <0> pushmark s
+# l <#> gvsv[*_] s
+# m <#> gv[*getkey] s/EARLYCV
+# n <1> entersub[t10] sKS/TARG,1
+# o <2> helem sKRM*/2
+# p <2> sassign vKS/2
+# q <0> unstack s
+# goto r
+# t <2> leaveloop K/2
+# u <2> leaveloop K/2
+# v <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 562 (eval 15):1) v
+# 2 <{> enterloop(next->u last->u redo->3)
+# 3 <;> nextstate(main 559 (eval 15):1) v
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <$> gv(*hash) s
+# 7 <1> rv2hv[t1] lKRM*/1
+# 8 <2> aassign[t2] vKS
+# 9 <;> nextstate(main 560 (eval 15):1) v
+# a <0> pushmark sM
+# b <$> gv(*array) s
+# c <1> rv2av[t3] sKRM/1
+# d <$> gv(*_) s
+# e <1> rv2gv sKRM/1
+# f <{> enteriter(next->q last->t redo->g) lKS
+# r <0> iter s
+# s <|> and(other->g) K/1
+# g <;> nextstate(main 559 (eval 15):1) v
+# h <$> gvsv(*_) s
+# i <$> gv(*hash) s
+# j <1> rv2hv sKR/1
+# k <0> pushmark s
+# l <$> gvsv(*_) s
+# m <$> gv(*getkey) s/EARLYCV
+# n <1> entersub[t4] sKS/TARG,1
+# o <2> helem sKRM*/2
+# p <2> sassign vKS/2
+# q <0> unstack s
+# goto r
+# t <2> leaveloop K/2
+# u <2> leaveloop K/2
+# v <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: #%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong
+%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{%hash = map { +"\L$_", 1 } @array; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 476 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*array] s
+# 5 <1> rv2av[t7] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t9] lK
+# 8 <0> pushmark s
+# 9 <#> gvsv[*_] s
+# a <1> lc[t4] sK/1
+# b <@> stringify[t5] sK/1
+# c <$> const[IV 1] s
+# d <@> list lK
+# - <@> scope lK
+# goto 7
+# e <0> pushmark s
+# f <#> gv[*hash] s
+# g <1> rv2hv[t2] lKRM*/1
+# h <2> aassign[t10] KS/COMMON
+# i <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 560 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*array) s
+# 5 <1> rv2av[t4] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t5] lK
+# 8 <0> pushmark s
+# 9 <$> gvsv(*_) s
+# a <1> lc[t2] sK/1
+# b <@> stringify[t3] sK/1
+# c <$> const(IV 1) s
+# d <@> list lK
+# - <@> scope lK
+# goto 7
+# e <0> pushmark s
+# f <$> gv(*hash) s
+# g <1> rv2hv[t1] lKRM*/1
+# h <2> aassign[t6] KS/COMMON
+# i <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: %hash = map { ("\L$_", 1) } @array; # this also works
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{%hash = map { ("\L$_", 1) } @array; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 476 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*array] s
+# 5 <1> rv2av[t7] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t9] lK
+# 8 <0> pushmark s
+# 9 <#> gvsv[*_] s
+# a <1> lc[t4] sK/1
+# b <@> stringify[t5] sK/1
+# c <$> const[IV 1] s
+# d <@> list lKP
+# - <@> scope lK
+# goto 7
+# e <0> pushmark s
+# f <#> gv[*hash] s
+# g <1> rv2hv[t2] lKRM*/1
+# h <2> aassign[t10] KS/COMMON
+# i <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 560 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*array) s
+# 5 <1> rv2av[t4] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t5] lK
+# 8 <0> pushmark s
+# 9 <$> gvsv(*_) s
+# a <1> lc[t2] sK/1
+# b <@> stringify[t3] sK/1
+# c <$> const(IV 1) s
+# d <@> list lKP
+# - <@> scope lK
+# goto 7
+# e <0> pushmark s
+# f <$> gv(*hash) s
+# g <1> rv2hv[t1] lKRM*/1
+# h <2> aassign[t6] KS/COMMON
+# i <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: %hash = map { lc($_), 1 } @array; # as does this.
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{%hash = map { lc($_), 1 } @array; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 476 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*array] s
+# 5 <1> rv2av[t6] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t8] lK
+# 8 <0> pushmark s
+# 9 <#> gvsv[*_] s
+# a <1> lc[t4] sK/1
+# b <$> const[IV 1] s
+# c <@> list lK
+# - <@> scope lK
+# goto 7
+# d <0> pushmark s
+# e <#> gv[*hash] s
+# f <1> rv2hv[t2] lKRM*/1
+# g <2> aassign[t9] KS/COMMON
+# h <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 589 (eval 26):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*array) s
+# 5 <1> rv2av[t3] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t4] lK
+# 8 <0> pushmark s
+# 9 <$> gvsv(*_) s
+# a <1> lc[t2] sK/1
+# b <$> const(IV 1) s
+# c <@> list lK
+# - <@> scope lK
+# goto 7
+# d <0> pushmark s
+# e <$> gv(*hash) s
+# f <1> rv2hv[t1] lKRM*/1
+# g <2> aassign[t5] KS/COMMON
+# h <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: %hash = map +( lc($_), 1 ), @array; # this is EXPR and works!
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{%hash = map +( lc($_), 1 ), @array; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 475 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*array] s
+# 5 <1> rv2av[t6] lKM/1
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t7] lK
+# 8 <0> pushmark s
+# 9 <#> gvsv[*_] s
+# a <1> lc[t4] sK/1
+# b <$> const[IV 1] s
+# c <@> list lKP
+# goto 7
+# d <0> pushmark s
+# e <#> gv[*hash] s
+# f <1> rv2hv[t2] lKRM*/1
+# g <2> aassign[t8] KS/COMMON
+# h <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 593 (eval 28):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*array) s
+# 5 <1> rv2av[t3] lKM/1
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t4] lK
+# 8 <0> pushmark s
+# 9 <$> gvsv(*_) s
+# a <1> lc[t2] sK/1
+# b <$> const(IV 1) s
+# c <@> list lKP
+# goto 7
+# d <0> pushmark s
+# e <$> gv(*hash) s
+# f <1> rv2hv[t1] lKRM*/1
+# g <2> aassign[t5] KS/COMMON
+# h <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: %hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array)
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{%hash = map ( lc($_), 1 ), @array; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 475 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <$> const[IV 1] sM
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t5] lK
+# 8 <#> gvsv[*_] s
+# 9 <1> lc[t4] sK/1
+# goto 7
+# a <0> pushmark s
+# b <#> gv[*hash] s
+# c <1> rv2hv[t2] lKRM*/1
+# d <2> aassign[t6] KS/COMMON
+# e <#> gv[*array] s
+# f <1> rv2av[t8] K/1
+# g <@> list K
+# h <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 597 (eval 30):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <$> const(IV 1) sM
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t3] lK
+# 8 <$> gvsv(*_) s
+# 9 <1> lc[t2] sK/1
+# goto 7
+# a <0> pushmark s
+# b <$> gv(*hash) s
+# c <1> rv2hv[t1] lKRM*/1
+# d <2> aassign[t4] KS/COMMON
+# e <$> gv(*array) s
+# f <1> rv2av[t5] K/1
+# g <@> list K
+# h <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: @hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@hashes = map +{ lc($_), 1 }, @array },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 475 (eval 10):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*array] s
+# 5 <1> rv2av[t6] lKM/1
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t7] lK
+# 8 <0> pushmark s
+# 9 <#> gvsv[*_] s
+# a <1> lc[t4] sK/1
+# b <$> const[IV 1] s
+# c <@> anonhash sKRM/1
+# d <1> srefgen sK/1
+# goto 7
+# e <0> pushmark s
+# f <#> gv[*hashes] s
+# g <1> rv2av[t2] lKRM*/1
+# h <2> aassign[t8] KS/COMMON
+# i <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 601 (eval 32):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*array) s
+# 5 <1> rv2av[t3] lKM/1
+# 6 <@> mapstart lK
+# 7 <|> mapwhile(other->8)[t4] lK
+# 8 <0> pushmark s
+# 9 <$> gvsv(*_) s
+# a <1> lc[t2] sK/1
+# b <$> const(IV 1) s
+# c <@> anonhash sKRM/1
+# d <1> srefgen sK/1
+# goto 7
+# e <0> pushmark s
+# f <$> gv(*hashes) s
+# g <1> rv2av[t1] lKRM*/1
+# h <2> aassign[t5] KS/COMMON
+# i <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
Added: B/t/f_sort
==============================================================================
--- (empty file)
+++ B/t/f_sort Tue Jun 26 12:23:24 2007
@@ -0,0 +1,91 @@
+#!perl
+#examples poached from perldoc -f sort
+
+# sort lexically
+ at articles = sort @files;
+
+# same thing, but with explicit sort routine
+ at articles = sort {$a cmp $b} @files;
+
+# now case-insensitively
+ at articles = sort {uc($a) cmp uc($b)} @files;
+
+# same thing in reversed order
+ at articles = sort {$b cmp $a} @files;
+
+# sort numerically ascending
+ at articles = sort {$a <=> $b} @files;
+
+# sort numerically descending
+ at articles = sort {$b <=> $a} @files;
+
+# this sorts the %age hash by value instead of key
+# using an in-line function
+ at eldest = sort { $age{$b} <=> $age{$a} } keys %age;
+
+# sort using explicit subroutine name
+sub byage {
+ $age{$a} <=> $age{$b}; # presuming numeric
+}
+ at sortedclass = sort byage @class;
+
+sub backwards { $b cmp $a }
+ at harry = qw(dog cat x Cain Abel);
+ at george = qw(gone chased yz Punished Axed);
+print sort @harry;
+# prints AbelCaincatdogx
+print sort backwards @harry;
+# prints xdogcatCainAbel
+print sort @george, 'to', @harry;
+# prints AbelAxedCainPunishedcatchaseddoggonetoxyz
+
+# inefficiently sort by descending numeric compare using
+# the first integer after the first = sign, or the
+# whole record case-insensitively otherwise
+ at new = @old[ sort {
+ $nums[$b] <=> $nums[$a]
+ || $caps[$a] cmp $caps[$b]
+ } 0..$#old ];
+
+# same thing, but without any temps
+ at new = map { $_->[0] }
+sort { $b->[1] <=> $a->[1]
+ || $a->[2] cmp $b->[2]
+ } map { [$_, /=(\d+)/, uc($_)] } @old;
+
+# using a prototype allows you to use any comparison subroutine
+# as a sort subroutine (including other package's subroutines)
+package other;
+sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here
+package main;
+ at new = sort other::backwards @old;
+
+# repeat, condensed. $main::a and $b are unaffected
+sub other::backwards ($$) { $_[1] cmp $_[0]; }
+ at new = sort other::backwards @old;
+
+# guarantee stability, regardless of algorithm
+use sort 'stable';
+ at new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
+
+# force use of mergesort (not portable outside Perl 5.8)
+use sort '_mergesort';
+ at new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
+
+# you should have a good reason to do this!
+ at articles = sort {$FooPack::b <=> $FooPack::a} @files;
+
+# fancy
+ at result = sort { $a <=> $b } grep { $_ == $_ } @input;
+
+# void return context sort
+sort { $a <=> $b } @input;
+
+# more void context, propagating ?
+sort { $a <=> $b } grep { $_ == $_ } @input;
+
+# scalar return context sort
+$s = sort { $a <=> $b } @input;
+
+$s = sort { $a <=> $b } grep { $_ == $_ } @input;
+
Added: B/t/f_sort.t
==============================================================================
--- (empty file)
+++ B/t/f_sort.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,972 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ if (!$Config::Config{useperlio}) {
+ print "1..0 # Skip -- need perlio to walk the optree\n";
+ exit 0;
+ }
+ # require q(test.pl); # now done by OptreeCheck;
+}
+use OptreeCheck;
+plan tests => 20;
+
+=head1 f_sort.t
+
+Code test snippets here are adapted from `perldoc -f map`
+
+Due to a bleadperl optimization (Dave Mitchell, circa apr 04), the
+(map|grep)(start|while) opcodes have different flags in 5.9, their
+private flags /1, /2 are gone in blead (for the cases covered)
+
+When the optree stuff was integrated into 5.8.6, these tests failed,
+and were todo'd. Theyre now done, by version-specific tweaking in
+mkCheckRex(), therefore the skip is removed too.
+
+=head1 Test Notes
+
+# chunk: #!perl
+#examples poached from perldoc -f sort
+
+NOTE: name is no longer a required arg for checkOptree, as label is
+synthesized out of others. HOWEVER, if the test-code has newlines in
+it, the label must be overridden by an explicit name.
+
+This is because t/TEST is quite particular about the test output it
+processes, and multi-line labels violate its 1-line-per-test
+expectations.
+
+=for gentest
+
+# chunk: # sort lexically
+ at articles = sort @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 545 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t4] lK/1
+# 6 <@> sort lK
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t5] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 545 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t2] lK/1
+# 6 <@> sort lK
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t3] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # same thing, but with explicit sort routine
+ at articles = sort {$a cmp $b} @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort {$a cmp $b} @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t7] lK/1
+# 6 <@> sort lK
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t3] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t3] lK/1
+# 6 <@> sort lK
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t2] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # now case-insensitively
+ at articles = sort {uc($a) cmp uc($b)} @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort {uc($a) cmp uc($b)} @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t9] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t10] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t5] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t6] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # same thing in reversed order
+ at articles = sort {$b cmp $a} @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort {$b cmp $a} @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t7] lK/1
+# 6 <@> sort lK/DESC
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t3] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t3] lK/1
+# 6 <@> sort lK/DESC
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t2] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # sort numerically ascending
+ at articles = sort {$a <=> $b} @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort {$a <=> $b} @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t7] lK/1
+# 6 <@> sort lK/NUM
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t3] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t3] lK/1
+# 6 <@> sort lK/NUM
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t2] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # sort numerically descending
+ at articles = sort {$b <=> $a} @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort {$b <=> $a} @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 587 (eval 26):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t7] lK/1
+# 6 <@> sort lK/DESC,NUM
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t3] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t3] lK/1
+# 6 <@> sort lK/DESC,NUM
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t2] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # this sorts the %age hash by value instead of key
+# using an in-line function
+ at eldest = sort { $age{$b} <=> $age{$a} } keys %age;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@eldest = sort { $age{$b} <=> $age{$a} } keys %age; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 592 (eval 28):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*age] s
+# 5 <1> rv2hv[t9] lKRM/1
+# 6 <1> keys[t10] lK/1
+# 7 <@> sort lKS*
+# 8 <0> pushmark s
+# 9 <#> gv[*eldest] s
+# a <1> rv2av[t2] lKRM*/1
+# b <2> aassign[t11] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*age) s
+# 5 <1> rv2hv[t3] lKRM/1
+# 6 <1> keys[t4] lK/1
+# 7 <@> sort lKS*
+# 8 <0> pushmark s
+# 9 <$> gv(*eldest) s
+# a <1> rv2av[t1] lKRM*/1
+# b <2> aassign[t5] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # sort using explicit subroutine name
+sub byage {
+ $age{$a} <=> $age{$b}; # presuming numeric
+}
+ at sortedclass = sort byage @class;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{sub byage { $age{$a} <=> $age{$b}; } @sortedclass = sort byage @class; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 597 (eval 30):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> const[PV "byage"] s/BARE
+# 5 <#> gv[*class] s
+# 6 <1> rv2av[t4] lK/1
+# 7 <@> sort lKS
+# 8 <0> pushmark s
+# 9 <#> gv[*sortedclass] s
+# a <1> rv2av[t2] lKRM*/1
+# b <2> aassign[t5] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> const(PV "byage") s/BARE
+# 5 <$> gv(*class) s
+# 6 <1> rv2av[t2] lK/1
+# 7 <@> sort lKS
+# 8 <0> pushmark s
+# 9 <$> gv(*sortedclass) s
+# a <1> rv2av[t1] lKRM*/1
+# b <2> aassign[t3] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: sub backwards { $b cmp $a }
+ at harry = qw(dog cat x Cain Abel);
+ at george = qw(gone chased yz Punished Axed);
+print sort @harry;
+# prints AbelCaincatdogx
+print sort backwards @harry;
+# prints xdogcatCainAbel
+print sort @george, 'to', @harry;
+# prints AbelAxedCainPunishedcatchaseddoggonetoxyz
+
+=cut
+
+checkOptree(name => q{sort USERSUB LIST },
+ bcopts => q{-exec},
+ code => q{sub backwards { $b cmp $a }
+ @harry = qw(dog cat x Cain Abel);
+ @george = qw(gone chased yz Punished Axed);
+ print sort @harry; print sort backwards @harry;
+ print sort @george, 'to', @harry; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 602 (eval 32):2) v
+# 2 <0> pushmark s
+# 3 <$> const[PV "dog"] s
+# 4 <$> const[PV "cat"] s
+# 5 <$> const[PV "x"] s
+# 6 <$> const[PV "Cain"] s
+# 7 <$> const[PV "Abel"] s
+# 8 <0> pushmark s
+# 9 <#> gv[*harry] s
+# a <1> rv2av[t2] lKRM*/1
+# b <2> aassign[t3] vKS
+# c <;> nextstate(main 602 (eval 32):3) v
+# d <0> pushmark s
+# e <$> const[PV "gone"] s
+# f <$> const[PV "chased"] s
+# g <$> const[PV "yz"] s
+# h <$> const[PV "Punished"] s
+# i <$> const[PV "Axed"] s
+# j <0> pushmark s
+# k <#> gv[*george] s
+# l <1> rv2av[t5] lKRM*/1
+# m <2> aassign[t6] vKS
+# n <;> nextstate(main 602 (eval 32):4) v
+# o <0> pushmark s
+# p <0> pushmark s
+# q <#> gv[*harry] s
+# r <1> rv2av[t8] lK/1
+# s <@> sort lK
+# t <@> print vK
+# u <;> nextstate(main 602 (eval 32):4) v
+# v <0> pushmark s
+# w <0> pushmark s
+# x <$> const[PV "backwards"] s/BARE
+# y <#> gv[*harry] s
+# z <1> rv2av[t10] lK/1
+# 10 <@> sort lKS
+# 11 <@> print vK
+# 12 <;> nextstate(main 602 (eval 32):5) v
+# 13 <0> pushmark s
+# 14 <0> pushmark s
+# 15 <#> gv[*george] s
+# 16 <1> rv2av[t12] lK/1
+# 17 <$> const[PV "to"] s
+# 18 <#> gv[*harry] s
+# 19 <1> rv2av[t14] lK/1
+# 1a <@> sort lK
+# 1b <@> print sK
+# 1c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 602 (eval 32):2) v
+# 2 <0> pushmark s
+# 3 <$> const(PV "dog") s
+# 4 <$> const(PV "cat") s
+# 5 <$> const(PV "x") s
+# 6 <$> const(PV "Cain") s
+# 7 <$> const(PV "Abel") s
+# 8 <0> pushmark s
+# 9 <$> gv(*harry) s
+# a <1> rv2av[t1] lKRM*/1
+# b <2> aassign[t2] vKS
+# c <;> nextstate(main 602 (eval 32):3) v
+# d <0> pushmark s
+# e <$> const(PV "gone") s
+# f <$> const(PV "chased") s
+# g <$> const(PV "yz") s
+# h <$> const(PV "Punished") s
+# i <$> const(PV "Axed") s
+# j <0> pushmark s
+# k <$> gv(*george) s
+# l <1> rv2av[t3] lKRM*/1
+# m <2> aassign[t4] vKS
+# n <;> nextstate(main 602 (eval 32):4) v
+# o <0> pushmark s
+# p <0> pushmark s
+# q <$> gv(*harry) s
+# r <1> rv2av[t5] lK/1
+# s <@> sort lK
+# t <@> print vK
+# u <;> nextstate(main 602 (eval 32):4) v
+# v <0> pushmark s
+# w <0> pushmark s
+# x <$> const(PV "backwards") s/BARE
+# y <$> gv(*harry) s
+# z <1> rv2av[t6] lK/1
+# 10 <@> sort lKS
+# 11 <@> print vK
+# 12 <;> nextstate(main 602 (eval 32):5) v
+# 13 <0> pushmark s
+# 14 <0> pushmark s
+# 15 <$> gv(*george) s
+# 16 <1> rv2av[t7] lK/1
+# 17 <$> const(PV "to") s
+# 18 <$> gv(*harry) s
+# 19 <1> rv2av[t8] lK/1
+# 1a <@> sort lK
+# 1b <@> print sK
+# 1c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # inefficiently sort by descending numeric compare using
+# the first integer after the first = sign, or the
+# whole record case-insensitively otherwise
+ at new = @old[ sort {
+ $nums[$b] <=> $nums[$a]
+ || $caps[$a] cmp $caps[$b]
+ } 0..$#old ];
+
+=cut
+=for gentest
+
+# chunk: # same thing, but without any temps
+ at new = map { $_->[0] }
+sort { $b->[1] <=> $a->[1]
+ || $a->[2] cmp $b->[2]
+ } map { [$_, /=(\d+)/, uc($_)] } @old;
+
+=cut
+
+checkOptree(name => q{Compound sort/map Expression },
+ bcopts => q{-exec},
+ code => q{ @new = map { $_->[0] }
+ sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] }
+ map { [$_, /=(\d+)/, uc($_)] } @old; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 609 (eval 34):3) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <#> gv[*old] s
+# 7 <1> rv2av[t19] lKM/1
+# 8 <@> mapstart lK*
+# 9 <|> mapwhile(other->a)[t20] lK
+# a <0> enter l
+# b <;> nextstate(main 608 (eval 34):2) v
+# c <0> pushmark s
+# d <#> gvsv[*_] s
+# e </> match(/"=(\\d+)"/) l/RTIME
+# f <#> gvsv[*_] s
+# g <1> uc[t17] sK/1
+# h <@> anonlist sKRM/1
+# i <1> srefgen sK/1
+# j <@> leave lKP
+# goto 9
+# k <@> sort lKMS*
+# l <@> mapstart lK*
+# m <|> mapwhile(other->n)[t26] lK
+# n <#> gv[*_] s
+# o <1> rv2sv sKM/DREFAV,1
+# p <1> rv2av[t4] sKR/1
+# q <$> const[IV 0] s
+# r <2> aelem sK/2
+# - <@> scope lK
+# goto m
+# s <0> pushmark s
+# t <#> gv[*new] s
+# u <1> rv2av[t2] lKRM*/1
+# v <2> aassign[t27] KS/COMMON
+# w <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 609 (eval 34):3) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <$> gv(*old) s
+# 7 <1> rv2av[t10] lKM/1
+# 8 <@> mapstart lK*
+# 9 <|> mapwhile(other->a)[t11] lK
+# a <0> enter l
+# b <;> nextstate(main 608 (eval 34):2) v
+# c <0> pushmark s
+# d <$> gvsv(*_) s
+# e </> match(/"=(\\d+)"/) l/RTIME
+# f <$> gvsv(*_) s
+# g <1> uc[t9] sK/1
+# h <@> anonlist sKRM/1
+# i <1> srefgen sK/1
+# j <@> leave lKP
+# goto 9
+# k <@> sort lKMS*
+# l <@> mapstart lK*
+# m <|> mapwhile(other->n)[t12] lK
+# n <$> gv(*_) s
+# o <1> rv2sv sKM/DREFAV,1
+# p <1> rv2av[t2] sKR/1
+# q <$> const(IV 0) s
+# r <2> aelem sK/2
+# - <@> scope lK
+# goto m
+# s <0> pushmark s
+# t <$> gv(*new) s
+# u <1> rv2av[t1] lKRM*/1
+# v <2> aassign[t13] KS/COMMON
+# w <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # using a prototype allows you to use any comparison subroutine
+# as a sort subroutine (including other package's subroutines)
+package other;
+sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here
+package main;
+ at new = sort other::backwards @old;
+
+=cut
+
+checkOptree(name => q{sort other::sub LIST },
+ bcopts => q{-exec},
+ code => q{package other; sub backwards ($$) { $_[1] cmp $_[0]; }
+ package main; @new = sort other::backwards @old; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 614 (eval 36):2) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> const[PV "other::backwards"] s/BARE
+# 5 <#> gv[*old] s
+# 6 <1> rv2av[t4] lK/1
+# 7 <@> sort lKS
+# 8 <0> pushmark s
+# 9 <#> gv[*new] s
+# a <1> rv2av[t2] lKRM*/1
+# b <2> aassign[t5] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 614 (eval 36):2) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> const(PV "other::backwards") s/BARE
+# 5 <$> gv(*old) s
+# 6 <1> rv2av[t2] lK/1
+# 7 <@> sort lKS
+# 8 <0> pushmark s
+# 9 <$> gv(*new) s
+# a <1> rv2av[t1] lKRM*/1
+# b <2> aassign[t3] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # repeat, condensed. $main::a and $b are unaffected
+sub other::backwards ($$) { $_[1] cmp $_[0]; }
+ at new = sort other::backwards @old;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{sub other::backwards ($$) { $_[1] cmp $_[0]; } @new = sort other::backwards @old; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 619 (eval 38):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> const[PV "other::backwards"] s/BARE
+# 5 <#> gv[*old] s
+# 6 <1> rv2av[t4] lK/1
+# 7 <@> sort lKS
+# 8 <0> pushmark s
+# 9 <#> gv[*new] s
+# a <1> rv2av[t2] lKRM*/1
+# b <2> aassign[t5] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> const(PV "other::backwards") s/BARE
+# 5 <$> gv(*old) s
+# 6 <1> rv2av[t2] lK/1
+# 7 <@> sort lKS
+# 8 <0> pushmark s
+# 9 <$> gv(*new) s
+# a <1> rv2av[t1] lKRM*/1
+# b <2> aassign[t3] KS
+# c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # guarantee stability, regardless of algorithm
+use sort 'stable';
+ at new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 656 (eval 40):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*old] s
+# 5 <1> rv2av[t9] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <#> gv[*new] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t14] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 578 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*old) s
+# 5 <1> rv2av[t5] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <$> gv(*new) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t6] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # force use of mergesort (not portable outside Perl 5.8)
+use sort '_mergesort';
+ at new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 662 (eval 42):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*old] s
+# 5 <1> rv2av[t9] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <#> gv[*new] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t14] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 578 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*old) s
+# 5 <1> rv2av[t5] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <$> gv(*new) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t6] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # you should have a good reason to do this!
+ at articles = sort {$FooPack::b <=> $FooPack::a} @files;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@articles = sort {$FooPack::b <=> $FooPack::a} @files; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 667 (eval 44):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*files] s
+# 5 <1> rv2av[t7] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <#> gv[*articles] s
+# 9 <1> rv2av[t2] lKRM*/1
+# a <2> aassign[t8] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*files) s
+# 5 <1> rv2av[t3] lK/1
+# 6 <@> sort lKS*
+# 7 <0> pushmark s
+# 8 <$> gv(*articles) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t4] KS
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # fancy
+ at result = sort { $a <=> $b } grep { $_ == $_ } @input;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{@result = sort { $a <=> $b } grep { $_ == $_ } @input; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 673 (eval 46):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <#> gv[*input] s
+# 6 <1> rv2av[t9] lKM/1
+# 7 <@> grepstart lK*
+# 8 <|> grepwhile(other->9)[t10] lK
+# 9 <#> gvsv[*_] s
+# a <#> gvsv[*_] s
+# b <2> eq sK/2
+# - <@> scope sK
+# goto 8
+# c <@> sort lK/NUM
+# d <0> pushmark s
+# e <#> gv[*result] s
+# f <1> rv2av[t2] lKRM*/1
+# g <2> aassign[t3] KS/COMMON
+# h <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 547 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <$> gv(*input) s
+# 6 <1> rv2av[t3] lKM/1
+# 7 <@> grepstart lK*
+# 8 <|> grepwhile(other->9)[t4] lK
+# 9 <$> gvsv(*_) s
+# a <$> gvsv(*_) s
+# b <2> eq sK/2
+# - <@> scope sK
+# goto 8
+# c <@> sort lK/NUM
+# d <0> pushmark s
+# e <$> gv(*result) s
+# f <1> rv2av[t1] lKRM*/1
+# g <2> aassign[t2] KS/COMMON
+# h <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # void return context sort
+sort { $a <=> $b } @input;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{sort { $a <=> $b } @input; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 678 (eval 48):1) v
+# 2 <0> pushmark s
+# 3 <#> gv[*input] s
+# 4 <1> rv2av[t5] lK/1
+# 5 <@> sort K/NUM
+# 6 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <$> gv(*input) s
+# 4 <1> rv2av[t2] lK/1
+# 5 <@> sort K/NUM
+# 6 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # more void context, propagating ?
+sort { $a <=> $b } grep { $_ == $_ } @input;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{sort { $a <=> $b } grep { $_ == $_ } @input; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 684 (eval 50):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*input] s
+# 5 <1> rv2av[t7] lKM/1
+# 6 <@> grepstart lK*
+# 7 <|> grepwhile(other->8)[t8] lK
+# 8 <#> gvsv[*_] s
+# 9 <#> gvsv[*_] s
+# a <2> eq sK/2
+# - <@> scope sK
+# goto 7
+# b <@> sort K/NUM
+# c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 547 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*input) s
+# 5 <1> rv2av[t2] lKM/1
+# 6 <@> grepstart lK*
+# 7 <|> grepwhile(other->8)[t3] lK
+# 8 <$> gvsv(*_) s
+# 9 <$> gvsv(*_) s
+# a <2> eq sK/2
+# - <@> scope sK
+# goto 7
+# b <@> sort K/NUM
+# c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: # scalar return context sort
+$s = sort { $a <=> $b } @input;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{$s = sort { $a <=> $b } @input; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 689 (eval 52):1) v
+# 2 <0> pushmark s
+# 3 <#> gv[*input] s
+# 4 <1> rv2av[t6] lK/1
+# 5 <@> sort sK/NUM
+# 6 <#> gvsv[*s] s
+# 7 <2> sassign sKS/2
+# 8 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 546 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <$> gv(*input) s
+# 4 <1> rv2av[t2] lK/1
+# 5 <@> sort sK/NUM
+# 6 <$> gvsv(*s) s
+# 7 <2> sassign sKS/2
+# 8 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+=for gentest
+
+# chunk: $s = sort { $a <=> $b } grep { $_ == $_ } @input;
+
+=cut
+
+checkOptree(note => q{},
+ bcopts => q{-exec},
+ code => q{$s = sort { $a <=> $b } grep { $_ == $_ } @input; },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 695 (eval 54):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*input] s
+# 5 <1> rv2av[t8] lKM/1
+# 6 <@> grepstart lK*
+# 7 <|> grepwhile(other->8)[t9] lK
+# 8 <#> gvsv[*_] s
+# 9 <#> gvsv[*_] s
+# a <2> eq sK/2
+# - <@> scope sK
+# goto 7
+# b <@> sort sK/NUM
+# c <#> gvsv[*s] s
+# d <2> sassign sKS/2
+# e <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 547 (eval 15):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*input) s
+# 5 <1> rv2av[t2] lKM/1
+# 6 <@> grepstart lK*
+# 7 <|> grepwhile(other->8)[t3] lK
+# 8 <$> gvsv(*_) s
+# 9 <$> gvsv(*_) s
+# a <2> eq sK/2
+# - <@> scope sK
+# goto 7
+# b <@> sort sK/NUM
+# c <$> gvsv(*s) s
+# d <2> sassign sKS/2
+# e <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
Added: B/t/lint.t
==============================================================================
--- (empty file)
+++ B/t/lint.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,100 @@
+#!./perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ require 'test.pl';
+}
+
+plan tests => 15; # adjust also number of skipped tests !
+
+# Runs a separate perl interpreter with the appropriate lint options
+# turned on
+sub runlint ($$$;$) {
+ my ($opts,$prog,$result,$testname) = @_;
+ my $res = runperl(
+ switches => [ "-MO=Lint,$opts" ],
+ prog => $prog,
+ stderr => 1,
+ );
+ $res =~ s/-e syntax OK\n$//;
+ is( $res, $result, $testname || $opts );
+}
+
+runlint 'context', '$foo = @bar', <<'RESULT';
+Implicit scalar context for array in scalar assignment at -e line 1
+RESULT
+
+runlint 'context', '$foo = length @bar', <<'RESULT';
+Implicit scalar context for array in length at -e line 1
+RESULT
+
+runlint 'implicit-read', '/foo/', <<'RESULT';
+Implicit match on $_ at -e line 1
+RESULT
+
+runlint 'implicit-write', 's/foo/bar/', <<'RESULT';
+Implicit substitution on $_ at -e line 1
+RESULT
+
+SKIP : {
+
+ use Config;
+ skip("Doesn't work with threaded perls",11)
+ if $Config{useithreads} || ($] < 5.009 && $Config{use5005threads});
+
+ runlint 'implicit-read', '1 for @ARGV', <<'RESULT', 'implicit-read in foreach';
+Implicit use of $_ in foreach at -e line 1
+RESULT
+
+ runlint 'dollar-underscore', '$_ = 1', <<'RESULT';
+Use of $_ at -e line 1
+RESULT
+
+ runlint 'dollar-underscore', 'print', <<'RESULT', 'dollar-underscore in print';
+Use of $_ at -e line 1
+RESULT
+
+ runlint 'private-names', 'sub A::_f{};A::_f()', <<'RESULT';
+Illegal reference to private name _f at -e line 1
+RESULT
+
+ runlint 'private-names', '$A::_x', <<'RESULT';
+Illegal reference to private name _x at -e line 1
+RESULT
+
+ runlint 'private-names', 'sub A::_f{};A->_f()', <<'RESULT',
+Illegal reference to private method name _f at -e line 1
+RESULT
+ 'private-names (method)';
+
+ runlint 'undefined-subs', 'foo()', <<'RESULT';
+Undefined subroutine foo called at -e line 1
+RESULT
+
+ runlint 'regexp-variables', 'print $&', <<'RESULT';
+Use of regexp variable $& at -e line 1
+RESULT
+
+ runlint 'regexp-variables', 's/./$&/', <<'RESULT';
+Use of regexp variable $& at -e line 1
+RESULT
+
+ runlint 'bare-subs', 'sub bare(){1};$x=bare', '';
+
+ runlint 'bare-subs', 'sub bare(){1}; $x=[bare=>0]; $x=$y{bare}', <<'RESULT';
+Bare sub name 'bare' interpreted as string at -e line 1
+Bare sub name 'bare' interpreted as string at -e line 1
+RESULT
+
+}
Added: B/t/o.t
==============================================================================
--- (empty file)
+++ B/t/o.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,88 @@
+#!./perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', 'lib', '../lib');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ require 'test.pl';
+}
+
+use strict;
+use Config;
+use File::Spec;
+use File::Path;
+
+my $path = File::Spec->catdir( 'lib', 'B' );
+unless (-d $path) {
+ mkpath( $path ) or skip_all( 'Cannot create fake module path' );
+}
+
+my $file = File::Spec->catfile( $path, 'success.pm' );
+local *OUT;
+open(OUT, '>', $file) or skip_all( 'Cannot write fake backend module');
+print OUT while <DATA>;
+close *OUT;
+
+plan( 9 ); # And someone's responsible.
+
+# use() makes it difficult to avoid O::import()
+require_ok( 'O' );
+
+my @args = ('-Ilib', '-MO=success,foo,bar', '-e', '1' );
+my @lines = get_lines( @args );
+
+is( $lines[0], 'Compiling!', 'Output should not be saved without -q switch' );
+is( $lines[1], '(foo) <bar>', 'O.pm should call backend compile() method' );
+is( $lines[2], '[]', 'Nothing should be in $O::BEGIN_output without -q' );
+is( $lines[3], '-e syntax OK', 'O.pm should not munge perl output without -qq');
+
+$args[1] = '-MO=-q,success,foo,bar';
+ at lines = get_lines( @args );
+isnt( $lines[1], 'Compiling!', 'Output should not be printed with -q switch' );
+
+SKIP: {
+ skip( '-q redirection does not work without PerlIO', 2)
+ unless $Config{useperlio};
+ is( $lines[1], "[Compiling!", '... but should be in $O::BEGIN_output' );
+
+ $args[1] = '-MO=-qq,success,foo,bar';
+ @lines = get_lines( @args );
+ is( scalar @lines, 3, '-qq should suppress even the syntax OK message' );
+}
+
+$args[1] = '-MO=success,fail';
+ at lines = get_lines( @args );
+like( $lines[1], qr/fail at .eval/,
+ 'O.pm should die if backend compile() does not return a subref' );
+
+sub get_lines {
+ split(/[\r\n]+/, runperl( args => [ @_ ], stderr => 1 ));
+}
+
+END {
+ 1 while unlink($file);
+ rmdir($path); # not "1 while" since there might be more in there
+}
+
+__END__
+package B::success;
+
+$| = 1;
+print "Compiling!\n";
+
+sub compile {
+ return 'fail' if ($_[0] eq 'fail');
+ print "($_[0]) <$_[1]>\n";
+ return sub { print "[$O::BEGIN_output]\n" };
+}
+
+1;
Added: B/t/optree_check.t
==============================================================================
--- (empty file)
+++ B/t/optree_check.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,233 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+
+use OptreeCheck;
+
+=head1 OptreeCheck selftest harness
+
+This file is primarily to test services of OptreeCheck itself, ie
+checkOptree(). %gOpts provides test-state info, it is 'exported' into
+main::
+
+doing use OptreeCheck runs import(), which processes @ARGV to process
+cmdline args in 'standard' way across all clients of OptreeCheck.
+
+=cut
+
+my $tests = 5 + 15 + 16 * $gOpts{selftest}; # pass()s + $#tests
+plan tests => $tests;
+
+SKIP: {
+ skip "no perlio in this build", $tests
+ unless $Config::Config{useperlio};
+
+
+pass("REGEX TEST HARNESS SELFTEST");
+
+checkOptree ( name => "bare minimum opcode search",
+ bcopts => '-exec',
+ code => sub {my $a},
+ noanchors => 1, # unanchored match
+ expect => 'leavesub',
+ expect_nt => 'leavesub');
+
+checkOptree ( name => "found print opcode",
+ bcopts => '-exec',
+ code => sub {print 1},
+ noanchors => 1, # unanchored match
+ expect => 'print',
+ expect_nt => 'leavesub');
+
+checkOptree ( name => 'test skip itself',
+ skip => 'this is skip-reason',
+ bcopts => '-exec',
+ code => sub {print 1},
+ expect => 'dont-care, skipping',
+ expect_nt => 'this insures failure');
+
+# This test 'unexpectedly succeeds', but that is "expected". Theres
+# no good way to expect a successful todo, and inducing a failure
+# causes the harness to print verbose errors, which is NOT helpful.
+
+checkOptree ( name => 'test todo itself. suppressed, remove skip to test',
+ todo => "suppress todo test for now",
+ skip => 1,
+ bcopts => '-exec',
+ code => sub {print 1},
+ noanchors => 1, # unanchored match
+ expect => 'print',
+ expect_nt => 'print') if 0;
+
+checkOptree ( name => 'impossible match, remove skip to see failure',
+ todo => "see! it breaks!",
+ skip => 'skip the failure',
+ code => sub {print 1},
+ expect => 'look out ! Boy Wonder',
+ expect_nt => 'holy near earth asteroid Batman !');
+
+pass ("TEST FATAL ERRS");
+
+if (1) {
+ # test for fatal errors. Im unsettled on fail vs die.
+ # calling fail isnt good enough by itself.
+
+ $@='';
+ eval {
+ checkOptree ( name => 'test against empty expectations',
+ bcopts => '-exec',
+ code => sub {print 1},
+ expect => '',
+ expect_nt => '');
+ };
+ like($@, /no '\w+' golden-sample found/, "empty expectations prevented");
+
+ $@='';
+ eval {
+ checkOptree ( name => 'prevent whitespace only expectations',
+ bcopts => '-exec',
+ code => sub {my $a},
+ #skip => 1,
+ expect_nt => "\n",
+ expect => "\n");
+ };
+ like($@, /no '\w+' golden-sample found/,
+ "just whitespace expectations prevented");
+}
+
+pass ("TEST -e \$srcCode");
+
+checkOptree ( name => 'empty code or prog',
+ skip => 'or fails',
+ todo => "your excuse here ;-)",
+ code => '',
+ prog => '',
+ );
+
+checkOptree
+ ( name => "self strict, catch err",
+ prog => 'use strict; bogus',
+ errs => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.',
+ expect => "nextstate", # simple expectations
+ expect_nt => "nextstate",
+ noanchors => 1, # allow them to work
+ );
+
+checkOptree ( name => "sort lK - flag specific search",
+ prog => 'our (@a, at b); @b = sort @a',
+ noanchors => 1,
+ expect => '<@> sort lK ',
+ expect_nt => '<@> sort lK ');
+
+checkOptree ( name => "sort vK - flag specific search",
+ prog => 'sort our @a',
+ errs => 'Useless use of sort in void context at -e line 1.',
+ noanchors => 1,
+ expect => '<@> sort vK',
+ expect_nt => '<@> sort vK');
+
+checkOptree ( name => "'code' => 'sort our \@a'",
+ code => 'sort our @a',
+ noanchors => 1,
+ expect => '<@> sort K',
+ expect_nt => '<@> sort K');
+
+pass ("REFTEXT FIXUP TESTS");
+
+checkOptree ( name => 'fixup nextstate (in reftext)',
+ bcopts => '-exec',
+ code => sub {my $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v
+# 2 <0> padsv[$a:54,55] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 54 optree_concise.t:84) v
+# 2 <0> padsv[$a:54,55] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'fixup opcode args',
+ bcopts => '-exec',
+ #fail => 1, # uncomment to see real padsv args: [$a:491,492]
+ code => sub {my $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 56 optree_concise.t:96) v
+# 2 <0> padsv[$a:56,57] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 56 optree_concise.t:96) v
+# 2 <0> padsv[$a:56,57] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+#################################
+pass("CANONICAL B::Concise EXAMPLE");
+
+checkOptree ( name => 'canonical example w -basic',
+ bcopts => '-basic',
+ code => sub{$a=$b+42},
+ crossfail => 1,
+ debug => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->7
+# 1 <;> nextstate(main 380 optree_selftest.t:139) v ->2
+# 6 <2> sassign sKS/2 ->7
+# 4 <2> add[t3] sK/2 ->5
+# - <1> ex-rv2sv sK/1 ->3
+# 2 <#> gvsv[*b] s ->3
+# 3 <$> const[IV 42] s ->4
+# - <1> ex-rv2sv sKRM*/1 ->6
+# 5 <#> gvsv[*a] s ->6
+EOT_EOT
+# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->7
+# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
+# 6 <2> sassign sKS/2 ->7
+# 4 <2> add[t1] sK/2 ->5
+# - <1> ex-rv2sv sK/1 ->3
+# 2 <$> gvsv(*b) s ->3
+# 3 <$> const(IV 42) s ->4
+# - <1> ex-rv2sv sKRM*/1 ->6
+# 5 <$> gvsv(*a) s ->6
+EONT_EONT
+
+checkOptree ( code => '$a=$b+42',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 61 optree_concise.t:139) v
+# 2 <#> gvsv[*b] s
+# 3 <$> const[IV 42] s
+# 4 <2> add[t3] sK/2
+# 5 <#> gvsv[*a] s
+# 6 <2> sassign sKS/2
+# 7 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 61 optree_concise.t:139) v
+# 2 <$> gvsv(*b) s
+# 3 <$> const(IV 42) s
+# 4 <2> add[t1] sK/2
+# 5 <$> gvsv(*a) s
+# 6 <2> sassign sKS/2
+# 7 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+} # skip
+
+__END__
+
Added: B/t/optree_concise.t
==============================================================================
--- (empty file)
+++ B/t/optree_concise.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,470 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+
+# import checkOptree(), and %gOpts (containing test state)
+use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
+use Config;
+
+my $tests = 23;
+plan tests => $tests;
+SKIP: {
+skip "no perlio in this build", $tests unless $Config::Config{useperlio};
+
+$SIG{__WARN__} = sub {
+ my $err = shift;
+ $err =~ m/Subroutine re::(un)?install redefined/ and return;
+};
+#################################
+pass("CANONICAL B::Concise EXAMPLE");
+
+checkOptree ( name => 'canonical example w -basic',
+ bcopts => '-basic',
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->7
+# 1 <;> nextstate(foo bar) v ->2
+# 6 <2> sassign sKS/2 ->7
+# 4 <2> add[t3] sK/2 ->5
+# - <1> ex-rv2sv sK/1 ->3
+# 2 <#> gvsv[*b] s ->3
+# 3 <$> const[IV 42] s ->4
+# - <1> ex-rv2sv sKRM*/1 ->6
+# 5 <#> gvsv[*a] s ->6
+EOT_EOT
+# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->7
+# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
+# 6 <2> sassign sKS/2 ->7
+# 4 <2> add[t1] sK/2 ->5
+# - <1> ex-rv2sv sK/1 ->3
+# 2 <$> gvsv(*b) s ->3
+# 3 <$> const(IV 42) s ->4
+# - <1> ex-rv2sv sKRM*/1 ->6
+# 5 <$> gvsv(*a) s ->6
+EONT_EONT
+
+checkOptree ( name => 'canonical example w -exec',
+ bcopts => '-exec',
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 61 optree_concise.t:139) v
+# 2 <#> gvsv[*b] s
+# 3 <$> const[IV 42] s
+# 4 <2> add[t3] sK/2
+# 5 <#> gvsv[*a] s
+# 6 <2> sassign sKS/2
+# 7 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 61 optree_concise.t:139) v
+# 2 <$> gvsv(*b) s
+# 3 <$> const(IV 42) s
+# 4 <2> add[t1] sK/2
+# 5 <$> gvsv(*a) s
+# 6 <2> sassign sKS/2
+# 7 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+#################################
+pass("B::Concise OPTION TESTS");
+
+checkOptree ( name => '-base3 sticky-exec',
+ bcopts => '-base3',
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> dbstate(main 24 optree_concise.t:132) v
+2 <#> gvsv[*b] s
+10 <$> const[IV 42] s
+11 <2> add[t3] sK/2
+12 <#> gvsv[*a] s
+20 <2> sassign sKS/2
+21 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 62 optree_concise.t:161) v
+# 2 <$> gvsv(*b) s
+# 10 <$> const(IV 42) s
+# 11 <2> add[t1] sK/2
+# 12 <$> gvsv(*a) s
+# 20 <2> sassign sKS/2
+# 21 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sticky-base3, -basic over sticky-exec',
+ bcopts => '-basic',
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+21 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->21
+1 <;> nextstate(main 32 optree_concise.t:164) v ->2
+20 <2> sassign sKS/2 ->21
+11 <2> add[t3] sK/2 ->12
+- <1> ex-rv2sv sK/1 ->10
+2 <#> gvsv[*b] s ->10
+10 <$> const[IV 42] s ->11
+- <1> ex-rv2sv sKRM*/1 ->20
+12 <#> gvsv[*a] s ->20
+EOT_EOT
+# 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->21
+# 1 <;> nextstate(main 63 optree_concise.t:186) v ->2
+# 20 <2> sassign sKS/2 ->21
+# 11 <2> add[t1] sK/2 ->12
+# - <1> ex-rv2sv sK/1 ->10
+# 2 <$> gvsv(*b) s ->10
+# 10 <$> const(IV 42) s ->11
+# - <1> ex-rv2sv sKRM*/1 ->20
+# 12 <$> gvsv(*a) s ->20
+EONT_EONT
+
+checkOptree ( name => '-base4',
+ bcopts => [qw/ -basic -base4 /],
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+13 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->13
+1 <;> nextstate(main 26 optree_concise.t:145) v ->2
+12 <2> sassign sKS/2 ->13
+10 <2> add[t3] sK/2 ->11
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->10
+- <1> ex-rv2sv sKRM*/1 ->12
+11 <#> gvsv[*a] s ->12
+EOT_EOT
+# 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->13
+# 1 <;> nextstate(main 64 optree_concise.t:193) v ->2
+# 12 <2> sassign sKS/2 ->13
+# 10 <2> add[t1] sK/2 ->11
+# - <1> ex-rv2sv sK/1 ->3
+# 2 <$> gvsv(*b) s ->3
+# 3 <$> const(IV 42) s ->10
+# - <1> ex-rv2sv sKRM*/1 ->12
+# 11 <$> gvsv(*a) s ->12
+EONT_EONT
+
+checkOptree ( name => "restore -base36 default",
+ bcopts => [qw/ -basic -base36 /],
+ code => sub{$a},
+ crossfail => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> nextstate(main 27 optree_concise.t:161) v ->2
+- <1> ex-rv2sv sK/1 ->-
+2 <#> gvsv[*a] s ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 65 optree_concise.t:210) v ->2
+# - <1> ex-rv2sv sK/1 ->-
+# 2 <$> gvsv(*a) s ->3
+EONT_EONT
+
+checkOptree ( name => "terse basic",
+ bcopts => [qw/ -basic -terse /],
+ code => sub{$a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+UNOP (0x82b0918) leavesub [1]
+ LISTOP (0x82b08d8) lineseq
+ COP (0x82b0880) nextstate
+ UNOP (0x82b0860) null [15]
+ PADOP (0x82b0840) gvsv GV (0x82a818c) *a
+EOT_EOT
+# UNOP (0x8282310) leavesub [1]
+# LISTOP (0x82822f0) lineseq
+# COP (0x82822b8) nextstate
+# UNOP (0x812fc20) null [15]
+# SVOP (0x812fc00) gvsv GV (0x814692c) *a
+EONT_EONT
+
+checkOptree ( name => "sticky-terse exec",
+ bcopts => [qw/ -exec /],
+ code => sub{$a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+COP (0x82b0d70) nextstate
+PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
+UNOP (0x82b0e08) leavesub [1]
+EOT_EOT
+# COP (0x82828e0) nextstate
+# SVOP (0x82828a0) gvsv GV (0x814692c) *a
+# UNOP (0x8282938) leavesub [1]
+EONT_EONT
+
+pass("OPTIONS IN CMDLINE MODE");
+
+checkOptree ( name => 'cmdline invoke -basic works',
+ prog => 'sort @a',
+ errs => [ 'Useless use of sort in void context at -e line 1.',
+ 'Name "main::a" used only once: possible typo at -e line 1.',
+ ],
+ #bcopts => '-basic', # default
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 7 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 6 <@> sort vK ->7
+# 3 <0> pushmark s ->4
+# 5 <1> rv2av[t2] lK/1 ->6
+# 4 <#> gv[*a] s ->5
+EOT_EOT
+# 7 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 6 <@> sort vK ->7
+# 3 <0> pushmark s ->4
+# 5 <1> rv2av[t1] lK/1 ->6
+# 4 <$> gv(*a) s ->5
+EONT_EONT
+
+checkOptree ( name => 'cmdline invoke -exec works',
+ prog => 'sort @a',
+ errs => [ 'Useless use of sort in void context at -e line 1.',
+ 'Name "main::a" used only once: possible typo at -e line 1.',
+ ],
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> pushmark s
+4 <#> gv[*a] s
+5 <1> rv2av[t2] lK/1
+6 <@> sort vK
+7 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> pushmark s
+# 4 <$> gv(*a) s
+# 5 <1> rv2av[t1] lK/1
+# 6 <@> sort vK
+# 7 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+;
+
+checkOptree
+ ( name => 'cmdline self-strict compile err using prog',
+ prog => 'use strict; sort @a',
+ bcopts => [qw/ -basic -concise -exec /],
+ errs => 'Global symbol "@a" requires explicit package name at -e line 1.',
+ expect => 'nextstate',
+ expect_nt => 'nextstate',
+ noanchors => 1, # allow simple expectations to work
+ );
+
+checkOptree
+ ( name => 'cmdline self-strict compile err using code',
+ code => 'use strict; sort @a',
+ bcopts => [qw/ -basic -concise -exec /],
+ errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
+ note => 'this test relys on a kludge which copies $@ to rendering when empty',
+ expect => 'Global symbol',
+ expect_nt => 'Global symbol',
+ noanchors => 1, # allow simple expectations to work
+ );
+
+checkOptree
+ ( name => 'cmdline -basic -concise -exec works',
+ prog => 'our @a; sort @a',
+ bcopts => [qw/ -basic -concise -exec /],
+ errs => ['Useless use of sort in void context at -e line 1.'],
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <#> gv[*a] s
+# 4 <1> rv2av[t3] vK/OURINTR,1
+# 5 <;> nextstate(main 2 -e:1) v
+# 6 <0> pushmark s
+# 7 <#> gv[*a] s
+# 8 <1> rv2av[t5] lK/1
+# 9 <@> sort vK
+# a <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <$> gv(*a) s
+# 4 <1> rv2av[t2] vK/OURINTR,1
+# 5 <;> nextstate(main 2 -e:1) v
+# 6 <0> pushmark s
+# 7 <$> gv(*a) s
+# 8 <1> rv2av[t3] lK/1
+# 9 <@> sort vK
+# a <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+
+#################################
+pass("B::Concise STYLE/CALLBACK TESTS");
+
+use B::Concise qw( walk_output add_style set_style_standard add_callback );
+
+# new relative style, added by set_up_relative_test()
+ at stylespec =
+ ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
+ . "(x(;~=> #extra)x)\n" # new 'variable' used here
+
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ #. "(x(;~=> #extra)x)\n" # new 'variable' used here
+ );
+
+sub set_up_relative_test {
+ # add a new style, and a callback which adds an 'extra' property
+
+ add_style ( "relative" => @stylespec );
+ #set_style_standard ( "relative" );
+
+ add_callback
+ ( sub {
+ my ($h, $op, $format, $level, $style) = @_;
+
+ # callback marks up const ops
+ $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
+ $h->{extra} = '';
+
+ if ($lastnext and $$lastnext != $$op) {
+ $h->{goto} = ($h->{seq} eq '-')
+ ? 'unresolved' : $h->{seq};
+ }
+
+ # 2 style specific behaviors
+ if ($style eq 'relative') {
+ $h->{extra} = 'RELATIVE';
+ $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
+ }
+ elsif ($style eq 'scope') {
+ # supress printout entirely
+ $$format="" unless grep { $h->{name} eq $_ } @scopeops;
+ }
+ });
+}
+
+#################################
+set_up_relative_test();
+pass("set_up_relative_test, new callback installed");
+
+checkOptree ( name => 'callback used, independent of style',
+ bcopts => [qw/ -concise -exec /],
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 76 optree_concise.t:337) v
+2 <#> gvsv[*b] s
+3 <$> const[IV 42] CALLBACK s
+4 <2> add[t3] sK/2
+5 <#> gvsv[*a] s
+6 <2> sassign sKS/2
+7 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 455 optree_concise.t:328) v
+# 2 <$> gvsv(*b) s
+# 3 <$> const(IV 42) CALLBACK s
+# 4 <2> add[t1] sK/2
+# 5 <$> gvsv(*a) s
+# 6 <2> sassign sKS/2
+# 7 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => "new 'relative' style, -exec mode",
+ bcopts => [qw/ -basic -relative /],
+ code => sub{$a=$b+42},
+ crossfail => 1,
+ #retry => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
+- <@> lineseq KP ->7 => RELATIVE
+1 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
+6 <2> sassign sKS ->7 => RELATIVE
+4 <2> add[t3] sK ->5 => RELATIVE
+- <1> ex-rv2sv sK ->3 => RELATIVE
+2 <#> gvsv[*b] s ->3 => RELATIVE
+3 <$> const[IV 42] CALLBACK s ->4 => RELATIVE
+- <1> ex-rv2sv sKRM* ->6 => RELATIVE
+5 <#> gvsv[*a] s ->6 => RELATIVE
+EOT_EOT
+# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
+# - <@> lineseq KP ->7 => RELATIVE
+# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
+# 6 <2> sassign sKS ->7 => RELATIVE
+# 4 <2> add[t1] sK ->5 => RELATIVE
+# - <1> ex-rv2sv sK ->3 => RELATIVE
+# 2 <$> gvsv(*b) s ->3 => RELATIVE
+# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE
+# - <1> ex-rv2sv sKRM* ->6 => RELATIVE
+# 5 <$> gvsv(*a) s ->6 => RELATIVE
+EONT_EONT
+
+checkOptree ( name => "both -exec -relative",
+ bcopts => [qw/ -exec -relative /],
+ code => sub{$a=$b+42},
+ crossfail => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 50 optree_concise.t:326) v
+2 <#> gvsv[*b] s
+3 <$> const[IV 42] CALLBACK s
+4 <2> add[t3] sK
+5 <#> gvsv[*a] s
+6 <2> sassign sKS
+7 <1> leavesub RELATIVE[1 ref] K
+EOT_EOT
+# 1 <;> nextstate(main 78 optree_concise.t:371) v
+# 2 <$> gvsv(*b) s
+# 3 <$> const(IV 42) CALLBACK s
+# 4 <2> add[t1] sK
+# 5 <$> gvsv(*a) s
+# 6 <2> sassign sKS
+# 7 <1> leavesub RELATIVE[1 ref] K
+EONT_EONT
+
+#################################
+
+ at scopeops = qw( leavesub enter leave nextstate );
+add_style
+ ( 'scope' # concise copy
+ , "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+checkOptree ( name => "both -exec -scope",
+ bcopts => [qw/ -exec -scope /],
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 50 optree_concise.t:337) v
+7 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+1 <;> nextstate(main 75 optree_concise.t:396) v
+7 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+checkOptree ( name => "both -basic -scope",
+ bcopts => [qw/ -basic -scope /],
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+1 <;> nextstate(main 51 optree_concise.t:347) v ->2
+EOT_EOT
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+1 <;> nextstate(main 76 optree_concise.t:407) v ->2
+EONT_EONT
+
+} #skip
+
Added: B/t/optree_samples.t
==============================================================================
--- (empty file)
+++ B/t/optree_samples.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,665 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+use OptreeCheck;
+use Config;
+plan tests => 20;
+SKIP: {
+ skip "no perlio in this build", 20 unless $Config::Config{useperlio};
+
+pass("GENERAL OPTREE EXAMPLES");
+
+pass("IF,THEN,ELSE, ?:");
+
+checkOptree ( name => '-basic sub {if shift print then,else}',
+ bcopts => '-basic',
+ code => sub { if (shift) { print "then" }
+ else { print "else" }
+ },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->9
+# 1 <;> nextstate(main 426 optree.t:16) v ->2
+# - <1> null K/1 ->-
+# 5 <|> cond_expr(other->6) K/1 ->a
+# 4 <1> shift sK/1 ->5
+# 3 <1> rv2av[t2] sKRM/1 ->4
+# 2 <#> gv[*_] s ->3
+# - <@> scope K ->-
+# - <0> ex-nextstate v ->6
+# 8 <@> print sK ->9
+# 6 <0> pushmark s ->7
+# 7 <$> const[PV "then"] s ->8
+# f <@> leave KP ->9
+# a <0> enter ->b
+# b <;> nextstate(main 424 optree.t:17) v ->c
+# e <@> print sK ->f
+# c <0> pushmark s ->d
+# d <$> const[PV "else"] s ->e
+EOT_EOT
+# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->9
+# 1 <;> nextstate(main 427 optree_samples.t:18) v ->2
+# - <1> null K/1 ->-
+# 5 <|> cond_expr(other->6) K/1 ->a
+# 4 <1> shift sK/1 ->5
+# 3 <1> rv2av[t1] sKRM/1 ->4
+# 2 <$> gv(*_) s ->3
+# - <@> scope K ->-
+# - <0> ex-nextstate v ->6
+# 8 <@> print sK ->9
+# 6 <0> pushmark s ->7
+# 7 <$> const(PV "then") s ->8
+# f <@> leave KP ->9
+# a <0> enter ->b
+# b <;> nextstate(main 425 optree_samples.t:19) v ->c
+# e <@> print sK ->f
+# c <0> pushmark s ->d
+# d <$> const(PV "else") s ->e
+EONT_EONT
+
+checkOptree ( name => '-basic (see above, with my $a = shift)',
+ bcopts => '-basic',
+ code => sub { my $a = shift;
+ if ($a) { print "foo" }
+ else { print "bar" }
+ },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# d <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->d
+# 1 <;> nextstate(main 431 optree.t:68) v ->2
+# 6 <2> sassign vKS/2 ->7
+# 4 <1> shift sK/1 ->5
+# 3 <1> rv2av[t3] sKRM/1 ->4
+# 2 <#> gv[*_] s ->3
+# 5 <0> padsv[$a:431,435] sRM*/LVINTRO ->6
+# 7 <;> nextstate(main 435 optree.t:69) v ->8
+# - <1> null K/1 ->-
+# 9 <|> cond_expr(other->a) K/1 ->e
+# 8 <0> padsv[$a:431,435] s ->9
+# - <@> scope K ->-
+# - <0> ex-nextstate v ->a
+# c <@> print sK ->d
+# a <0> pushmark s ->b
+# b <$> const[PV "foo"] s ->c
+# j <@> leave KP ->d
+# e <0> enter ->f
+# f <;> nextstate(main 433 optree.t:70) v ->g
+# i <@> print sK ->j
+# g <0> pushmark s ->h
+# h <$> const[PV "bar"] s ->i
+EOT_EOT
+# d <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->d
+# 1 <;> nextstate(main 428 optree_samples.t:48) v ->2
+# 6 <2> sassign vKS/2 ->7
+# 4 <1> shift sK/1 ->5
+# 3 <1> rv2av[t2] sKRM/1 ->4
+# 2 <$> gv(*_) s ->3
+# 5 <0> padsv[$a:428,432] sRM*/LVINTRO ->6
+# 7 <;> nextstate(main 432 optree_samples.t:49) v ->8
+# - <1> null K/1 ->-
+# 9 <|> cond_expr(other->a) K/1 ->e
+# 8 <0> padsv[$a:428,432] s ->9
+# - <@> scope K ->-
+# - <0> ex-nextstate v ->a
+# c <@> print sK ->d
+# a <0> pushmark s ->b
+# b <$> const(PV "foo") s ->c
+# j <@> leave KP ->d
+# e <0> enter ->f
+# f <;> nextstate(main 430 optree_samples.t:50) v ->g
+# i <@> print sK ->j
+# g <0> pushmark s ->h
+# h <$> const(PV "bar") s ->i
+EONT_EONT
+
+checkOptree ( name => '-exec sub {if shift print then,else}',
+ bcopts => '-exec',
+ code => sub { if (shift) { print "then" }
+ else { print "else" }
+ },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 426 optree.t:16) v
+# 2 <#> gv[*_] s
+# 3 <1> rv2av[t2] sKRM/1
+# 4 <1> shift sK/1
+# 5 <|> cond_expr(other->6) K/1
+# 6 <0> pushmark s
+# 7 <$> const[PV "then"] s
+# 8 <@> print sK
+# goto 9
+# a <0> enter
+# b <;> nextstate(main 424 optree.t:17) v
+# c <0> pushmark s
+# d <$> const[PV "else"] s
+# e <@> print sK
+# f <@> leave KP
+# 9 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 436 optree_samples.t:123) v
+# 2 <$> gv(*_) s
+# 3 <1> rv2av[t1] sKRM/1
+# 4 <1> shift sK/1
+# 5 <|> cond_expr(other->6) K/1
+# 6 <0> pushmark s
+# 7 <$> const(PV "then") s
+# 8 <@> print sK
+# goto 9
+# a <0> enter
+# b <;> nextstate(main 434 optree_samples.t:124) v
+# c <0> pushmark s
+# d <$> const(PV "else") s
+# e <@> print sK
+# f <@> leave KP
+# 9 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '-exec (see above, with my $a = shift)',
+ bcopts => '-exec',
+ code => sub { my $a = shift;
+ if ($a) { print "foo" }
+ else { print "bar" }
+ },
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 423 optree.t:16) v
+# 2 <#> gv[*_] s
+# 3 <1> rv2av[t3] sKRM/1
+# 4 <1> shift sK/1
+# 5 <0> padsv[$a:423,427] sRM*/LVINTRO
+# 6 <2> sassign vKS/2
+# 7 <;> nextstate(main 427 optree.t:17) v
+# 8 <0> padsv[$a:423,427] s
+# 9 <|> cond_expr(other->a) K/1
+# a <0> pushmark s
+# b <$> const[PV "foo"] s
+# c <@> print sK
+# goto d
+# e <0> enter
+# f <;> nextstate(main 425 optree.t:18) v
+# g <0> pushmark s
+# h <$> const[PV "bar"] s
+# i <@> print sK
+# j <@> leave KP
+# d <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 437 optree_samples.t:112) v
+# 2 <$> gv(*_) s
+# 3 <1> rv2av[t2] sKRM/1
+# 4 <1> shift sK/1
+# 5 <0> padsv[$a:437,441] sRM*/LVINTRO
+# 6 <2> sassign vKS/2
+# 7 <;> nextstate(main 441 optree_samples.t:113) v
+# 8 <0> padsv[$a:437,441] s
+# 9 <|> cond_expr(other->a) K/1
+# a <0> pushmark s
+# b <$> const(PV "foo") s
+# c <@> print sK
+# goto d
+# e <0> enter
+# f <;> nextstate(main 439 optree_samples.t:114) v
+# g <0> pushmark s
+# h <$> const(PV "bar") s
+# i <@> print sK
+# j <@> leave KP
+# d <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '-exec sub { print (shift) ? "foo" : "bar" }',
+ code => sub { print (shift) ? "foo" : "bar" },
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 428 optree.t:31) v
+# 2 <0> pushmark s
+# 3 <#> gv[*_] s
+# 4 <1> rv2av[t2] sKRM/1
+# 5 <1> shift sK/1
+# 6 <@> print sK
+# 7 <|> cond_expr(other->8) K/1
+# 8 <$> const[PV "foo"] s
+# goto 9
+# a <$> const[PV "bar"] s
+# 9 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 442 optree_samples.t:144) v
+# 2 <0> pushmark s
+# 3 <$> gv(*_) s
+# 4 <1> rv2av[t1] sKRM/1
+# 5 <1> shift sK/1
+# 6 <@> print sK
+# 7 <|> cond_expr(other->8) K/1
+# 8 <$> const(PV "foo") s
+# goto 9
+# a <$> const(PV "bar") s
+# 9 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+pass ("FOREACH");
+
+checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }',
+ code => sub { foreach (1..10) {print "foo $_"} },
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 443 optree.t:158) v
+# 2 <0> pushmark s
+# 3 <$> const[IV 1] s
+# 4 <$> const[IV 10] s
+# 5 <#> gv[*_] s
+# 6 <{> enteriter(next->d last->g redo->7) lKS
+# e <0> iter s
+# f <|> and(other->7) K/1
+# 7 <;> nextstate(main 442 optree.t:158) v
+# 8 <0> pushmark s
+# 9 <$> const[PV "foo "] s
+# a <#> gvsv[*_] s
+# b <2> concat[t4] sK/2
+# c <@> print vK
+# d <0> unstack s
+# goto e
+# g <2> leaveloop K/2
+# h <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 444 optree_samples.t:182) v
+# 2 <0> pushmark s
+# 3 <$> const(IV 1) s
+# 4 <$> const(IV 10) s
+# 5 <$> gv(*_) s
+# 6 <{> enteriter(next->d last->g redo->7) lKS
+# e <0> iter s
+# f <|> and(other->7) K/1
+# 7 <;> nextstate(main 443 optree_samples.t:182) v
+# 8 <0> pushmark s
+# 9 <$> const(PV "foo ") s
+# a <$> gvsv(*_) s
+# b <2> concat[t3] sK/2
+# c <@> print vK
+# d <0> unstack s
+# goto e
+# g <2> leaveloop K/2
+# h <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }',
+ code => sub { print "foo $_" foreach (1..10) },
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# h <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->h
+# 1 <;> nextstate(main 445 optree.t:167) v ->2
+# 2 <;> nextstate(main 445 optree.t:167) v ->3
+# g <2> leaveloop K/2 ->h
+# 7 <{> enteriter(next->d last->g redo->8) lKS ->e
+# - <0> ex-pushmark s ->3
+# - <1> ex-list lK ->6
+# 3 <0> pushmark s ->4
+# 4 <$> const[IV 1] s ->5
+# 5 <$> const[IV 10] s ->6
+# 6 <#> gv[*_] s ->7
+# - <1> null K/1 ->g
+# f <|> and(other->8) K/1 ->g
+# e <0> iter s ->f
+# - <@> lineseq sK ->-
+# c <@> print vK ->d
+# 8 <0> pushmark s ->9
+# - <1> ex-stringify sK/1 ->c
+# - <0> ex-pushmark s ->9
+# b <2> concat[t2] sK/2 ->c
+# 9 <$> const[PV "foo "] s ->a
+# - <1> ex-rv2sv sK/1 ->b
+# a <#> gvsv[*_] s ->b
+# d <0> unstack s ->e
+EOT_EOT
+# h <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->h
+# 1 <;> nextstate(main 446 optree_samples.t:192) v ->2
+# 2 <;> nextstate(main 446 optree_samples.t:192) v ->3
+# g <2> leaveloop K/2 ->h
+# 7 <{> enteriter(next->d last->g redo->8) lKS ->e
+# - <0> ex-pushmark s ->3
+# - <1> ex-list lK ->6
+# 3 <0> pushmark s ->4
+# 4 <$> const(IV 1) s ->5
+# 5 <$> const(IV 10) s ->6
+# 6 <$> gv(*_) s ->7
+# - <1> null K/1 ->g
+# f <|> and(other->8) K/1 ->g
+# e <0> iter s ->f
+# - <@> lineseq sK ->-
+# c <@> print vK ->d
+# 8 <0> pushmark s ->9
+# - <1> ex-stringify sK/1 ->c
+# - <0> ex-pushmark s ->9
+# b <2> concat[t1] sK/2 ->c
+# 9 <$> const(PV "foo ") s ->a
+# - <1> ex-rv2sv sK/1 ->b
+# a <$> gvsv(*_) s ->b
+# d <0> unstack s ->e
+EONT_EONT
+
+checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}',
+ prog => 'foreach (1..10) {print qq{foo $_}}',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <0> enter
+# 2 <;> nextstate(main 2 -e:1) v
+# 3 <0> pushmark s
+# 4 <$> const[IV 1] s
+# 5 <$> const[IV 10] s
+# 6 <#> gv[*_] s
+# 7 <{> enteriter(next->e last->h redo->8) lKS
+# f <0> iter s
+# g <|> and(other->8) vK/1
+# 8 <;> nextstate(main 1 -e:1) v
+# 9 <0> pushmark s
+# a <$> const[PV "foo "] s
+# b <#> gvsv[*_] s
+# c <2> concat[t4] sK/2
+# d <@> print vK
+# e <0> unstack v
+# goto f
+# h <2> leaveloop vK/2
+# i <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 2 -e:1) v
+# 3 <0> pushmark s
+# 4 <$> const(IV 1) s
+# 5 <$> const(IV 10) s
+# 6 <$> gv(*_) s
+# 7 <{> enteriter(next->e last->h redo->8) lKS
+# f <0> iter s
+# g <|> and(other->8) vK/1
+# 8 <;> nextstate(main 1 -e:1) v
+# 9 <0> pushmark s
+# a <$> const(PV "foo ") s
+# b <$> gvsv(*_) s
+# c <2> concat[t3] sK/2
+# d <@> print vK
+# e <0> unstack v
+# goto f
+# h <2> leaveloop vK/2
+# i <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }',
+ code => sub { print "foo $_" foreach (1..10) },
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 445 optree.t:167) v
+# 2 <;> nextstate(main 445 optree.t:167) v
+# 3 <0> pushmark s
+# 4 <$> const[IV 1] s
+# 5 <$> const[IV 10] s
+# 6 <#> gv[*_] s
+# 7 <{> enteriter(next->d last->g redo->8) lKS
+# e <0> iter s
+# f <|> and(other->8) K/1
+# 8 <0> pushmark s
+# 9 <$> const[PV "foo "] s
+# a <#> gvsv[*_] s
+# b <2> concat[t2] sK/2
+# c <@> print vK
+# d <0> unstack s
+# goto e
+# g <2> leaveloop K/2
+# h <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 447 optree_samples.t:252) v
+# 2 <;> nextstate(main 447 optree_samples.t:252) v
+# 3 <0> pushmark s
+# 4 <$> const(IV 1) s
+# 5 <$> const(IV 10) s
+# 6 <$> gv(*_) s
+# 7 <{> enteriter(next->d last->g redo->8) lKS
+# e <0> iter s
+# f <|> and(other->8) K/1
+# 8 <0> pushmark s
+# 9 <$> const(PV "foo ") s
+# a <$> gvsv(*_) s
+# b <2> concat[t1] sK/2
+# c <@> print vK
+# d <0> unstack s
+# goto e
+# g <2> leaveloop K/2
+# h <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+pass("GREP: SAMPLES FROM PERLDOC -F GREP");
+
+checkOptree ( name => '@foo = grep(!/^\#/, @bar)',
+ code => '@foo = grep(!/^\#/, @bar)',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 496 (eval 20):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*bar] s
+# 5 <1> rv2av[t4] lKM/1
+# 6 <@> grepstart lK
+# 7 <|> grepwhile(other->8)[t5] lK
+# 8 </> match(/"^#"/) s/RTIME
+# 9 <1> not sK/1
+# goto 7
+# a <0> pushmark s
+# b <#> gv[*foo] s
+# c <1> rv2av[t2] lKRM*/1
+# d <2> aassign[t6] KS/COMMON
+# e <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 496 (eval 20):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*bar) s
+# 5 <1> rv2av[t2] lKM/1
+# 6 <@> grepstart lK
+# 7 <|> grepwhile(other->8)[t3] lK
+# 8 </> match(/"^\\#"/) s/RTIME
+# 9 <1> not sK/1
+# goto 7
+# a <0> pushmark s
+# b <$> gv(*foo) s
+# c <1> rv2av[t1] lKRM*/1
+# d <2> aassign[t4] KS/COMMON
+# e <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+pass("MAP: SAMPLES FROM PERLDOC -F MAP");
+
+checkOptree ( name => '%h = map { getkey($_) => $_ } @a',
+ code => '%h = map { getkey($_) => $_ } @a',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 501 (eval 22):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*a] s
+# 5 <1> rv2av[t8] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t9] lK
+# 8 <0> enter l
+# 9 <;> nextstate(main 500 (eval 22):1) v
+# a <0> pushmark s
+# b <0> pushmark s
+# c <#> gvsv[*_] s
+# d <#> gv[*getkey] s/EARLYCV
+# e <1> entersub[t5] lKS/TARG,1
+# f <#> gvsv[*_] s
+# g <@> list lK
+# h <@> leave lKP
+# goto 7
+# i <0> pushmark s
+# j <#> gv[*h] s
+# k <1> rv2hv[t2] lKRM*/1
+# l <2> aassign[t10] KS/COMMON
+# m <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 501 (eval 22):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*a) s
+# 5 <1> rv2av[t3] lKM/1
+# 6 <@> mapstart lK*
+# 7 <|> mapwhile(other->8)[t4] lK
+# 8 <0> enter l
+# 9 <;> nextstate(main 500 (eval 22):1) v
+# a <0> pushmark s
+# b <0> pushmark s
+# c <$> gvsv(*_) s
+# d <$> gv(*getkey) s/EARLYCV
+# e <1> entersub[t2] lKS/TARG,1
+# f <$> gvsv(*_) s
+# g <@> list lK
+# h <@> leave lKP
+# goto 7
+# i <0> pushmark s
+# j <$> gv(*h) s
+# k <1> rv2hv[t1] lKRM*/1
+# l <2> aassign[t5] KS/COMMON
+# m <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}',
+ code => '%h=(); for $_(@a){$h{getkey($_)} = $_}',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 505 (eval 24):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <#> gv[*h] s
+# 5 <1> rv2hv[t2] lKRM*/1
+# 6 <2> aassign[t3] vKS
+# 7 <;> nextstate(main 506 (eval 24):1) v
+# 8 <0> pushmark sM
+# 9 <#> gv[*a] s
+# a <1> rv2av[t6] sKRM/1
+# b <#> gv[*_] s
+# c <1> rv2gv sKRM/1
+# d <{> enteriter(next->o last->r redo->e) lKS
+# p <0> iter s
+# q <|> and(other->e) K/1
+# e <;> nextstate(main 505 (eval 24):1) v
+# f <#> gvsv[*_] s
+# g <#> gv[*h] s
+# h <1> rv2hv sKR/1
+# i <0> pushmark s
+# j <#> gvsv[*_] s
+# k <#> gv[*getkey] s/EARLYCV
+# l <1> entersub[t10] sKS/TARG,1
+# m <2> helem sKRM*/2
+# n <2> sassign vKS/2
+# o <0> unstack s
+# goto p
+# r <2> leaveloop K/2
+# s <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 505 (eval 24):1) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*h) s
+# 5 <1> rv2hv[t1] lKRM*/1
+# 6 <2> aassign[t2] vKS
+# 7 <;> nextstate(main 506 (eval 24):1) v
+# 8 <0> pushmark sM
+# 9 <$> gv(*a) s
+# a <1> rv2av[t3] sKRM/1
+# b <$> gv(*_) s
+# c <1> rv2gv sKRM/1
+# d <{> enteriter(next->o last->r redo->e) lKS
+# p <0> iter s
+# q <|> and(other->e) K/1
+# e <;> nextstate(main 505 (eval 24):1) v
+# f <$> gvsv(*_) s
+# g <$> gv(*h) s
+# h <1> rv2hv sKR/1
+# i <0> pushmark s
+# j <$> gvsv(*_) s
+# k <$> gv(*getkey) s/EARLYCV
+# l <1> entersub[t4] sKS/TARG,1
+# m <2> helem sKRM*/2
+# n <2> sassign vKS/2
+# o <0> unstack s
+# goto p
+# r <2> leaveloop K/2
+# s <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'map $_+42, 10..20',
+ code => 'map $_+42, 10..20',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 497 (eval 20):1) v
+# 2 <0> pushmark s
+# 3 <$> const[AV ] s
+# 4 <1> rv2av lKPM/1
+# 5 <@> mapstart K
+# 6 <|> mapwhile(other->7)[t5] K
+# 7 <#> gvsv[*_] s
+# 8 <$> const[IV 42] s
+# 9 <2> add[t2] sK/2
+# goto 6
+# a <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 511 (eval 26):1) v
+# 2 <0> pushmark s
+# 3 <$> const(AV ) s
+# 4 <1> rv2av lKPM/1
+# 5 <@> mapstart K
+# 6 <|> mapwhile(other->7)[t4] K
+# 7 <$> gvsv(*_) s
+# 8 <$> const(IV 42) s
+# 9 <2> add[t1] sK/2
+# goto 6
+# a <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+pass("CONSTANTS");
+
+checkOptree ( name => '-e use constant j => qq{junk}; print j',
+ prog => 'use constant j => qq{junk}; print j',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <0> enter
+# 2 <;> nextstate(main 71 -e:1) v
+# 3 <0> pushmark s
+# 4 <$> const[PV "junk"] s
+# 5 <@> print vK
+# 6 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 71 -e:1) v
+# 3 <0> pushmark s
+# 4 <$> const(PV "junk") s
+# 5 <@> print vK
+# 6 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+} # skip
+
+__END__
+
+#######################################################################
+
+checkOptree ( name => '-exec sub a { print (shift) ? "foo" : "bar" }',
+ code => sub { print (shift) ? "foo" : "bar" },
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ insert threaded reference here
+EOT_EOT
+ insert non-threaded reference here
+EONT_EONT
+
Added: B/t/optree_sort.t
==============================================================================
--- (empty file)
+++ B/t/optree_sort.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,306 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+use OptreeCheck;
+use Config;
+plan tests => 11;
+
+SKIP: {
+skip "no perlio in this build", 11 unless $Config::Config{useperlio};
+
+pass("SORT OPTIMIZATION");
+
+checkOptree ( name => 'sub {sort @a}',
+ code => sub {sort @a},
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 424 optree_sort.t:14) v
+# 2 <0> pushmark s
+# 3 <#> gv[*a] s
+# 4 <1> rv2av[t2] lK/1
+# 5 <@> sort K
+# 6 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 424 optree_sort.t:14) v
+# 2 <0> pushmark s
+# 3 <$> gv(*a) s
+# 4 <1> rv2av[t1] lK/1
+# 5 <@> sort K
+# 6 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sort @a',
+ prog => 'sort @a',
+ errs => [ 'Useless use of sort in void context at -e line 1.',
+ 'Name "main::a" used only once: possible typo at -e line 1.',
+ ],
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> pushmark s
+4 <#> gv[*a] s
+5 <1> rv2av[t2] lK/1
+6 <@> sort vK
+7 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> pushmark s
+# 4 <$> gv(*a) s
+# 5 <1> rv2av[t1] lK/1
+# 6 <@> sort vK
+# 7 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'sub {@a = sort @a}',
+ code => sub {@a = sort @a},
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main -438 optree.t:244) v
+2 <0> pushmark s
+3 <0> pushmark s
+4 <#> gv[*a] s
+5 <1> rv2av[t4] lK/1
+6 <@> sort lK
+7 <0> pushmark s
+8 <#> gv[*a] s
+9 <1> rv2av[t2] lKRM*/1
+a <2> aassign[t5] KS/COMMON
+b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 65 optree.t:311) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*a) s
+# 5 <1> rv2av[t2] lK/1
+# 6 <@> sort lK
+# 7 <0> pushmark s
+# 8 <$> gv(*a) s
+# 9 <1> rv2av[t1] lKRM*/1
+# a <2> aassign[t3] KS/COMMON
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '@a = sort @a',
+ prog => '@a = sort @a',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> pushmark s
+4 <0> pushmark s
+5 <#> gv[*a] s
+6 <1> rv2av[t4] lKRM*/1
+7 <@> sort lK/INPLACE
+8 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <$> gv(*a) s
+# 6 <1> rv2av[t2] lKRM*/1
+# 7 <@> sort lK/INPLACE
+# 8 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'sub {@a = sort @a; reverse @a}',
+ code => sub {@a = sort @a; reverse @a},
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main -438 optree.t:286) v
+2 <0> pushmark s
+3 <0> pushmark s
+4 <#> gv[*a] s
+5 <1> rv2av[t4] lKRM*/1
+6 <@> sort lK/INPLACE
+7 <;> nextstate(main -438 optree.t:288) v
+8 <0> pushmark s
+9 <#> gv[*a] s
+a <1> rv2av[t7] lK/1
+b <@> reverse[t8] K/1
+c <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 66 optree.t:345) v
+# 2 <0> pushmark s
+# 3 <0> pushmark s
+# 4 <$> gv(*a) s
+# 5 <1> rv2av[t2] lKRM*/1
+# 6 <@> sort lK/INPLACE
+# 7 <;> nextstate(main 66 optree.t:346) v
+# 8 <0> pushmark s
+# 9 <$> gv(*a) s
+# a <1> rv2av[t4] lK/1
+# b <@> reverse[t5] K/1
+# c <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '@a = sort @a; reverse @a',
+ prog => '@a = sort @a; reverse @a',
+ errs => ['Useless use of reverse in void context at -e line 1.'],
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> pushmark s
+4 <0> pushmark s
+5 <#> gv[*a] s
+6 <1> rv2av[t4] lKRM*/1
+7 <@> sort lK/INPLACE
+8 <;> nextstate(main 1 -e:1) v
+9 <0> pushmark s
+a <#> gv[*a] s
+b <1> rv2av[t7] lK/1
+c <@> reverse[t8] vK/1
+d <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> pushmark s
+# 4 <0> pushmark s
+# 5 <$> gv(*a) s
+# 6 <1> rv2av[t2] lKRM*/1
+# 7 <@> sort lK/INPLACE
+# 8 <;> nextstate(main 1 -e:1) v
+# 9 <0> pushmark s
+# a <$> gv(*a) s
+# b <1> rv2av[t4] lK/1
+# c <@> reverse[t5] vK/1
+# d <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'sub {my @a; @a = sort @a}',
+ code => sub {my @a; @a = sort @a},
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main -437 optree.t:254) v
+2 <0> padav[@a:-437,-436] vM/LVINTRO
+3 <;> nextstate(main -436 optree.t:256) v
+4 <0> pushmark s
+5 <0> pushmark s
+6 <0> padav[@a:-437,-436] l
+7 <@> sort lK
+8 <0> pushmark s
+9 <0> padav[@a:-437,-436] lRM*
+a <2> aassign[t2] KS/COMMON
+b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 427 optree_sort.t:172) v
+# 2 <0> padav[@a:427,428] vM/LVINTRO
+# 3 <;> nextstate(main 428 optree_sort.t:173) v
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <0> padav[@a:427,428] l
+# 7 <@> sort lK
+# 8 <0> pushmark s
+# 9 <0> padav[@a:427,428] lRM*
+# a <2> aassign[t2] KS/COMMON
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'my @a; @a = sort @a',
+ prog => 'my @a; @a = sort @a',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> padav[@a:1,2] vM/LVINTRO
+4 <;> nextstate(main 2 -e:1) v
+5 <0> pushmark s
+6 <0> pushmark s
+7 <0> padav[@a:1,2] lRM*
+8 <@> sort lK/INPLACE
+9 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> padav[@a:1,2] vM/LVINTRO
+# 4 <;> nextstate(main 2 -e:1) v
+# 5 <0> pushmark s
+# 6 <0> pushmark s
+# 7 <0> padav[@a:1,2] lRM*
+# 8 <@> sort lK/INPLACE
+# 9 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}',
+ code => sub {my @a; @a = sort @a; push @a, 1},
+ bcopts => '-exec',
+ debug => 0,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main -437 optree.t:325) v
+2 <0> padav[@a:-437,-436] vM/LVINTRO
+3 <;> nextstate(main -436 optree.t:325) v
+4 <0> pushmark s
+5 <0> pushmark s
+6 <0> padav[@a:-437,-436] lRM*
+7 <@> sort lK/INPLACE
+8 <;> nextstate(main -436 optree.t:325) v
+9 <0> pushmark s
+a <0> padav[@a:-437,-436] lRM
+b <$> const[IV 1] s
+c <@> push[t3] sK/2
+d <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 429 optree_sort.t:219) v
+# 2 <0> padav[@a:429,430] vM/LVINTRO
+# 3 <;> nextstate(main 430 optree_sort.t:220) v
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <0> padav[@a:429,430] lRM*
+# 7 <@> sort lK/INPLACE
+# 8 <;> nextstate(main 430 optree_sort.t:220) v
+# 9 <0> pushmark s
+# a <0> padav[@a:429,430] lRM
+# b <$> const(IV 1) s
+# c <@> push[t3] sK/2
+# d <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sub {my @a; @a = sort @a; 1}',
+ code => sub {my @a; @a = sort @a; 1},
+ bcopts => '-exec',
+ debug => 0,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main -437 optree.t:325) v
+2 <0> padav[@a:-437,-436] vM/LVINTRO
+3 <;> nextstate(main -436 optree.t:325) v
+4 <0> pushmark s
+5 <0> pushmark s
+6 <0> padav[@a:-437,-436] lRM*
+7 <@> sort lK/INPLACE
+8 <;> nextstate(main -436 optree.t:346) v
+9 <$> const[IV 1] s
+a <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 431 optree_sort.t:250) v
+# 2 <0> padav[@a:431,432] vM/LVINTRO
+# 3 <;> nextstate(main 432 optree_sort.t:251) v
+# 4 <0> pushmark s
+# 5 <0> pushmark s
+# 6 <0> padav[@a:431,432] lRM*
+# 7 <@> sort lK/INPLACE
+# 8 <;> nextstate(main 432 optree_sort.t:251) v
+# 9 <$> const(IV 1) s
+# a <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+} #skip
+
+__END__
+
Added: B/t/optree_specials.t
==============================================================================
--- (empty file)
+++ B/t/optree_specials.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,276 @@
+#!./perl
+
+# This tests the B:: module(s) with CHECK, BEGIN, END and INIT blocks. The
+# text excerpts below marked with "# " in front are the expected output. They
+# are there twice, EOT for threading, and EONT for a non-threading Perl. The
+# output is matched losely. If the match fails even though the "got" and
+# "expected" output look exactly the same, then watch for trailing, invisible
+# spaces.
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+
+# import checkOptree(), and %gOpts (containing test state)
+use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
+use Config;
+
+plan tests => 7;
+
+require_ok("B::Concise");
+
+my $out = runperl(
+ switches => ["-MO=Concise,BEGIN,CHECK,INIT,END,-exec"],
+ prog => q{$a=$b && print q/foo/},
+ stderr => 1 );
+
+#print "out:$out\n";
+
+my $src = q[our ($beg, $chk, $init, $end) = qq{'foo'}; BEGIN { $beg++ } CHECK { $chk++ } INIT { $init++ } END { $end++ }];
+
+
+my @warnings_todo;
+ at warnings_todo = (todo =>
+ "Change 23768 (Remove Carp from warnings.pm) alters expected output, not"
+ . "propagated to 5.8.x")
+ if $] < 5.009;
+
+
+checkOptree ( name => 'BEGIN',
+ bcopts => 'BEGIN',
+ prog => $src,
+ @warnings_todo,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# BEGIN 1:
+# b <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->b
+# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->2
+# 3 <1> require sK/1 ->4
+# 2 <$> const[PV "warnings.pm"] s/BARE ->3
+# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->5
+# - <@> lineseq K ->-
+# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2 ->6
+# a <1> entersub[t1] KS*/TARG,2 ->b
+# 6 <0> pushmark s ->7
+# 7 <$> const[PV "warnings"] sM ->8
+# 8 <$> const[PV "qw"] sM ->9
+# 9 <$> method_named[PVIV 1520340202] ->a
+# BEGIN 2:
+# f <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->f
+# c <;> nextstate(main 2 -e:1) v ->d
+# e <1> postinc[t3] sK/1 ->f
+# - <1> ex-rv2sv sKRM/1 ->e
+# d <#> gvsv[*beg] s ->e
+EOT_EOT
+# BEGIN 1:
+# b <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->b
+# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->2
+# 3 <1> require sK/1 ->4
+# 2 <$> const(PV "warnings.pm") s/BARE ->3
+# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->5
+# - <@> lineseq K ->-
+# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2 ->6
+# a <1> entersub[t1] KS*/TARG,2 ->b
+# 6 <0> pushmark s ->7
+# 7 <$> const(PV "warnings") sM ->8
+# 8 <$> const(PV "qw") sM ->9
+# 9 <$> method_named(PVIV 1520340202) ->a
+# BEGIN 2:
+# f <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->f
+# c <;> nextstate(main 2 -e:1) v ->d
+# e <1> postinc[t2] sK/1 ->f
+# - <1> ex-rv2sv sKRM/1 ->e
+# d <$> gvsv(*beg) s ->e
+EONT_EONT
+
+
+checkOptree ( name => 'END',
+ bcopts => 'END',
+ prog => $src,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# END 1:
+# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->4
+# 1 <;> nextstate(main 5 -e:6) v ->2
+# 3 <1> postinc[t3] sK/1 ->4
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <#> gvsv[*end] s ->3
+EOT_EOT
+# END 1:
+# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->4
+# 1 <;> nextstate(main 5 -e:6) v ->2
+# 3 <1> postinc[t2] sK/1 ->4
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <$> gvsv(*end) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'CHECK',
+ bcopts => 'CHECK',
+ prog => $src,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# CHECK 1:
+# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->4
+# 1 <;> nextstate(main 3 -e:4) v ->2
+# 3 <1> postinc[t3] sK/1 ->4
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <#> gvsv[*chk] s ->3
+EOT_EOT
+# CHECK 1:
+# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->4
+# 1 <;> nextstate(main 3 -e:4) v ->2
+# 3 <1> postinc[t2] sK/1 ->4
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <$> gvsv(*chk) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'INIT',
+ bcopts => 'INIT',
+ #todo => 'get working',
+ prog => $src,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# INIT 1:
+# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->4
+# 1 <;> nextstate(main 4 -e:5) v ->2
+# 3 <1> postinc[t3] sK/1 ->4
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <#> gvsv[*init] s ->3
+EOT_EOT
+# INIT 1:
+# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->4
+# 1 <;> nextstate(main 4 -e:5) v ->2
+# 3 <1> postinc[t2] sK/1 ->4
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <$> gvsv(*init) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'all of BEGIN END INIT CHECK -exec',
+ bcopts => [qw/ BEGIN END INIT CHECK -exec /],
+ prog => $src,
+ @warnings_todo,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# BEGIN 1:
+# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
+# 2 <$> const[PV "warnings.pm"] s/BARE
+# 3 <1> require sK/1
+# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
+# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2
+# 6 <0> pushmark s
+# 7 <$> const[PV "warnings"] sM
+# 8 <$> const[PV "qw"] sM
+# 9 <$> method_named[PVIV 1520340202]
+# a <1> entersub[t1] KS*/TARG,2
+# b <1> leavesub[1 ref] K/REFC,1
+# BEGIN 2:
+# c <;> nextstate(main 2 -e:1) v
+# d <#> gvsv[*beg] s
+# e <1> postinc[t3] sK/1
+# f <1> leavesub[1 ref] K/REFC,1
+# END 1:
+# g <;> nextstate(main 5 -e:1) v
+# h <#> gvsv[*end] s
+# i <1> postinc[t3] sK/1
+# j <1> leavesub[1 ref] K/REFC,1
+# INIT 1:
+# k <;> nextstate(main 4 -e:1) v
+# l <#> gvsv[*init] s
+# m <1> postinc[t3] sK/1
+# n <1> leavesub[1 ref] K/REFC,1
+# CHECK 1:
+# o <;> nextstate(main 3 -e:1) v
+# p <#> gvsv[*chk] s
+# q <1> postinc[t3] sK/1
+# r <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# BEGIN 1:
+# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
+# 2 <$> const(PV "warnings.pm") s/BARE
+# 3 <1> require sK/1
+# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
+# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2
+# 6 <0> pushmark s
+# 7 <$> const(PV "warnings") sM
+# 8 <$> const(PV "qw") sM
+# 9 <$> method_named(PVIV 1520340202)
+# a <1> entersub[t1] KS*/TARG,2
+# b <1> leavesub[1 ref] K/REFC,1
+# BEGIN 2:
+# c <;> nextstate(main 2 -e:1) v
+# d <$> gvsv(*beg) s
+# e <1> postinc[t2] sK/1
+# f <1> leavesub[1 ref] K/REFC,1
+# END 1:
+# g <;> nextstate(main 5 -e:1) v
+# h <$> gvsv(*end) s
+# i <1> postinc[t2] sK/1
+# j <1> leavesub[1 ref] K/REFC,1
+# INIT 1:
+# k <;> nextstate(main 4 -e:1) v
+# l <$> gvsv(*init) s
+# m <1> postinc[t2] sK/1
+# n <1> leavesub[1 ref] K/REFC,1
+# CHECK 1:
+# o <;> nextstate(main 3 -e:1) v
+# p <$> gvsv(*chk) s
+# q <1> postinc[t2] sK/1
+# r <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+
+# perl "-I../lib" -MO=Concise,BEGIN,CHECK,INIT,END,-exec -e '$a=$b && print q/foo/'
+
+
+
+checkOptree ( name => 'regression test for patch 25352',
+ bcopts => [qw/ BEGIN END INIT CHECK -exec /],
+ prog => 'print q/foo/',
+ @warnings_todo,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# BEGIN 1:
+# 1 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
+# 2 <$> const[PV "warnings.pm"] s/BARE
+# 3 <1> require sK/1
+# 4 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
+# 5 <;> nextstate(B::Concise -234 Concise.pm:359) /2
+# 6 <0> pushmark s
+# 7 <$> const[PV "warnings"] sM
+# 8 <$> const[PV "qw"] sM
+# 9 <$> method_named[PV "unimport"]
+# a <1> entersub[t1] KS*/TARG,2
+# b <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# BEGIN 1:
+# 1 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
+# 2 <$> const(PV "warnings.pm") s/BARE
+# 3 <1> require sK/1
+# 4 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
+# 5 <;> nextstate(B::Concise -234 Concise.pm:359) /2
+# 6 <0> pushmark s
+# 7 <$> const(PV "warnings") sM
+# 8 <$> const(PV "qw") sM
+# 9 <$> method_named(PV "unimport")
+# a <1> entersub[t1] KS*/TARG,2
+# b <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
Added: B/t/optree_varinit.t
==============================================================================
--- (empty file)
+++ B/t/optree_varinit.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,397 @@
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+use OptreeCheck;
+use Config;
+plan tests => 22;
+SKIP: {
+skip "no perlio in this build", 22 unless $Config::Config{useperlio};
+
+pass("OPTIMIZER TESTS - VAR INITIALIZATION");
+
+checkOptree ( name => 'sub {my $a}',
+ bcopts => '-exec',
+ code => sub {my $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 45 optree.t:23) v
+# 2 <0> padsv[$a:45,46] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 45 optree.t:23) v
+# 2 <0> padsv[$a:45,46] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => '-exec sub {my $a}',
+ bcopts => '-exec',
+ code => sub {my $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(main 49 optree.t:52) v
+# 2 <0> padsv[$a:49,50] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 49 optree.t:45) v
+# 2 <0> padsv[$a:49,50] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sub {our $a}',
+ bcopts => '-exec',
+ code => sub {our $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 21 optree.t:47) v
+2 <#> gvsv[*a] s/OURINTR
+3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 51 optree.t:56) v
+# 2 <$> gvsv(*a) s/OURINTR
+# 3 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sub {local $a}',
+ bcopts => '-exec',
+ code => sub {local $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 23 optree.t:57) v
+2 <#> gvsv[*a] s/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 53 optree.t:67) v
+# 2 <$> gvsv(*a) s/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'my $a',
+ prog => 'my $a',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 4 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4
+EOT_EOT
+# 4 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4
+EONT_EONT
+
+checkOptree ( name => 'our $a',
+ prog => 'our $a',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+4 <@> leave[1 ref] vKP/REFC ->(end)
+1 <0> enter ->2
+2 <;> nextstate(main 1 -e:1) v ->3
+- <1> ex-rv2sv vK/17 ->4
+3 <#> gvsv[*a] s/OURINTR ->4
+EOT_EOT
+# 4 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# - <1> ex-rv2sv vK/17 ->4
+# 3 <$> gvsv(*a) s/OURINTR ->4
+EONT_EONT
+
+checkOptree ( name => 'local $a',
+ prog => 'local $a',
+ errs => ['Name "main::a" used only once: possible typo at -e line 1.'],
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+4 <@> leave[1 ref] vKP/REFC ->(end)
+1 <0> enter ->2
+2 <;> nextstate(main 1 -e:1) v ->3
+- <1> ex-rv2sv vKM/129 ->4
+3 <#> gvsv[*a] s/LVINTRO ->4
+EOT_EOT
+# 4 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# - <1> ex-rv2sv vKM/129 ->4
+# 3 <$> gvsv(*a) s/LVINTRO ->4
+EONT_EONT
+
+pass("MY, OUR, LOCAL, BOTH SUB AND MAIN, = undef");
+
+checkOptree ( name => 'sub {my $a=undef}',
+ code => sub {my $a=undef},
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->5
+1 <;> nextstate(main 641 optree_varinit.t:130) v ->2
+4 <2> sassign sKS/2 ->5
+2 <0> undef s ->3
+3 <0> padsv[$a:641,642] sRM*/LVINTRO ->4
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 641 optree_varinit.t:130) v ->2
+# 4 <2> sassign sKS/2 ->5
+# 2 <0> undef s ->3
+# 3 <0> padsv[$a:641,642] sRM*/LVINTRO ->4
+EONT_EONT
+
+checkOptree ( name => 'sub {our $a=undef}',
+ code => sub {our $a=undef},
+ note => 'the global must be reset',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->5
+1 <;> nextstate(main 26 optree.t:109) v ->2
+4 <2> sassign sKS/2 ->5
+2 <0> undef s ->3
+- <1> ex-rv2sv sKRM*/17 ->4
+3 <#> gvsv[*a] s/OURINTR ->4
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 446 optree_varinit.t:137) v ->2
+# 4 <2> sassign sKS/2 ->5
+# 2 <0> undef s ->3
+# - <1> ex-rv2sv sKRM*/17 ->4
+# 3 <$> gvsv(*a) s/OURINTR ->4
+EONT_EONT
+
+checkOptree ( name => 'sub {local $a=undef}',
+ code => sub {local $a=undef},
+ note => 'local not used enough to bother',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->5
+1 <;> nextstate(main 28 optree.t:122) v ->2
+4 <2> sassign sKS/2 ->5
+2 <0> undef s ->3
+- <1> ex-rv2sv sKRM*/129 ->4
+3 <#> gvsv[*a] s/LVINTRO ->4
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 58 optree.t:141) v ->2
+# 4 <2> sassign sKS/2 ->5
+# 2 <0> undef s ->3
+# - <1> ex-rv2sv sKRM*/129 ->4
+# 3 <$> gvsv(*a) s/LVINTRO ->4
+EONT_EONT
+
+checkOptree ( name => 'my $a=undef',
+ prog => 'my $a=undef',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+6 <@> leave[1 ref] vKP/REFC ->(end)
+1 <0> enter ->2
+2 <;> nextstate(main 1 -e:1) v ->3
+5 <2> sassign vKS/2 ->6
+3 <0> undef s ->4
+4 <0> padsv[$a:1,2] sRM*/LVINTRO ->5
+EOT_EOT
+# 6 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 5 <2> sassign vKS/2 ->6
+# 3 <0> undef s ->4
+# 4 <0> padsv[$a:1,2] sRM*/LVINTRO ->5
+EONT_EONT
+
+checkOptree ( name => 'our $a=undef',
+ prog => 'our $a=undef',
+ note => 'global must be reassigned',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+6 <@> leave[1 ref] vKP/REFC ->(end)
+1 <0> enter ->2
+2 <;> nextstate(main 1 -e:1) v ->3
+5 <2> sassign vKS/2 ->6
+3 <0> undef s ->4
+- <1> ex-rv2sv sKRM*/17 ->5
+4 <#> gvsv[*a] s/OURINTR ->5
+EOT_EOT
+# 6 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 5 <2> sassign vKS/2 ->6
+# 3 <0> undef s ->4
+# - <1> ex-rv2sv sKRM*/17 ->5
+# 4 <$> gvsv(*a) s/OURINTR ->5
+EONT_EONT
+
+checkOptree ( name => 'local $a=undef',
+ prog => 'local $a=undef',
+ errs => ['Name "main::a" used only once: possible typo at -e line 1.'],
+ note => 'locals are rare, probly not worth doing',
+ bcopts => '-basic',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+6 <@> leave[1 ref] vKP/REFC ->(end)
+1 <0> enter ->2
+2 <;> nextstate(main 1 -e:1) v ->3
+5 <2> sassign vKS/2 ->6
+3 <0> undef s ->4
+- <1> ex-rv2sv sKRM*/129 ->5
+4 <#> gvsv[*a] s/LVINTRO ->5
+EOT_EOT
+# 6 <@> leave[1 ref] vKP/REFC ->(end)
+# 1 <0> enter ->2
+# 2 <;> nextstate(main 1 -e:1) v ->3
+# 5 <2> sassign vKS/2 ->6
+# 3 <0> undef s ->4
+# - <1> ex-rv2sv sKRM*/129 ->5
+# 4 <$> gvsv(*a) s/LVINTRO ->5
+EONT_EONT
+
+checkOptree ( name => 'sub {my $a=()}',
+ code => sub {my $a=()},
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main -439 optree.t:105) v
+2 <0> stub sP
+3 <0> padsv[$a:-439,-438] sRM*/LVINTRO
+4 <2> sassign sKS/2
+5 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 438 optree_varinit.t:247) v
+# 2 <0> stub sP
+# 3 <0> padsv[$a:438,439] sRM*/LVINTRO
+# 4 <2> sassign sKS/2
+# 5 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sub {our $a=()}',
+ code => sub {our $a=()},
+ #todo => 'probly not worth doing',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 31 optree.t:177) v
+2 <0> stub sP
+3 <#> gvsv[*a] s/OURINTR
+4 <2> sassign sKS/2
+5 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 440 optree_varinit.t:262) v
+# 2 <0> stub sP
+# 3 <$> gvsv(*a) s/OURINTR
+# 4 <2> sassign sKS/2
+# 5 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'sub {local $a=()}',
+ code => sub {local $a=()},
+ #todo => 'probly not worth doing',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <;> nextstate(main 33 optree.t:190) v
+2 <0> stub sP
+3 <#> gvsv[*a] s/LVINTRO
+4 <2> sassign sKS/2
+5 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 63 optree.t:225) v
+# 2 <0> stub sP
+# 3 <$> gvsv(*a) s/LVINTRO
+# 4 <2> sassign sKS/2
+# 5 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
+
+checkOptree ( name => 'my $a=()',
+ prog => 'my $a=()',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> stub sP
+4 <0> padsv[$a:1,2] sRM*/LVINTRO
+5 <2> sassign vKS/2
+6 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> stub sP
+# 4 <0> padsv[$a:1,2] sRM*/LVINTRO
+# 5 <2> sassign vKS/2
+# 6 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'our $a=()',
+ prog => 'our $a=()',
+ #todo => 'probly not worth doing',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> stub sP
+4 <#> gvsv[*a] s/OURINTR
+5 <2> sassign vKS/2
+6 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> stub sP
+# 4 <$> gvsv(*a) s/OURINTR
+# 5 <2> sassign vKS/2
+# 6 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'local $a=()',
+ prog => 'local $a=()',
+ errs => ['Name "main::a" used only once: possible typo at -e line 1.'],
+ #todo => 'probly not worth doing',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+1 <0> enter
+2 <;> nextstate(main 1 -e:1) v
+3 <0> stub sP
+4 <#> gvsv[*a] s/LVINTRO
+5 <2> sassign vKS/2
+6 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> stub sP
+# 4 <$> gvsv(*a) s/LVINTRO
+# 5 <2> sassign vKS/2
+# 6 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+checkOptree ( name => 'my ($a,$b)=()',
+ prog => 'my ($a,$b)=()',
+ #todo => 'probly not worth doing',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> pushmark s
+# 4 <0> pushmark sRM*/128
+# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
+# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
+# 7 <2> aassign[t3] vKS
+# 8 <@> leave[1 ref] vKP/REFC
+EOT_EOT
+# 1 <0> enter
+# 2 <;> nextstate(main 1 -e:1) v
+# 3 <0> pushmark s
+# 4 <0> pushmark sRM*/128
+# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
+# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
+# 7 <2> aassign[t3] vKS
+# 8 <@> leave[1 ref] vKP/REFC
+EONT_EONT
+
+} #skip
+
+__END__
+
Added: B/t/showlex.t
==============================================================================
--- (empty file)
+++ B/t/showlex.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,127 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ require 'test.pl';
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+use B::Showlex ();
+
+plan tests => 15;
+
+my $verbose = @ARGV; # set if ANY ARGS
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
+my $redir = $Is_MacOS ? "" : "2>&1";
+my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
+
+if ($is_thread) {
+ ok "# use5005threads: test skipped\n";
+} else {
+ $a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`;
+ like ($a, qr/sv_undef.*PVNV.*\@one.*sv_undef.*AV/s,
+ "canonical usage works");
+}
+
+# v1.01 tests
+
+my ($na,$nb,$nc); # holds regex-strs
+my ($out, $newlex); # output, option-flag
+
+sub padrep {
+ my ($varname,$newlex) = @_;
+ return ($newlex)
+ ? 'PVNV \(0x[0-9a-fA-F]+\) "\\'.$varname.'" = '
+ : "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n";
+}
+
+for $newlex ('', '-newlex') {
+
+ $out = runperl ( switches => ["-MO=Showlex,$newlex"],
+ prog => 'my ($a,$b)', stderr => 1 );
+ $na = padrep('$a',$newlex);
+ $nb = padrep('$b',$newlex);
+ like ($out, qr/1: $na/ms, 'found $a in "my ($a,$b)"');
+ like ($out, qr/2: $nb/ms, 'found $b in "my ($a,$b)"');
+
+ print $out if $verbose;
+
+SKIP: {
+ skip "no perlio in this build", 5
+ unless $Config::Config{useperlio};
+
+ our $buf = 'arb startval';
+ my $ak = B::Showlex::walk_output (\$buf);
+
+ my $walker = B::Showlex::compile( $newlex, sub{my($foo,$bar)} );
+ $walker->();
+ $na = padrep('$foo',$newlex);
+ $nb = padrep('$bar',$newlex);
+ like ($buf, qr/1: $na/ms, 'found $foo in "sub { my ($foo,$bar) }"');
+ like ($buf, qr/2: $nb/ms, 'found $bar in "sub { my ($foo,$bar) }"');
+
+ print $buf if $verbose;
+
+ $ak = B::Showlex::walk_output (\$buf);
+
+ my $src = 'sub { my ($scalar, at arr,%hash) }';
+ my $sub = eval $src;
+ $walker = B::Showlex::compile($sub);
+ $walker->();
+ $na = padrep('$scalar',$newlex);
+ $nb = padrep('@arr',$newlex);
+ $nc = padrep('%hash',$newlex);
+ like ($buf, qr/1: $na/ms, 'found $scalar in "'. $src .'"');
+ like ($buf, qr/2: $nb/ms, 'found @arr in "'. $src .'"');
+ like ($buf, qr/3: $nc/ms, 'found %hash in "'. $src .'"');
+
+ print $buf if $verbose;
+
+ # fibonacci function under test
+ my $asub = sub {
+ my ($self,%props)=@_;
+ my $total;
+ { # inner block vars
+ my (@fib)=(1,2);
+ for (my $i=2; $i<10; $i++) {
+ $fib[$i] = $fib[$i-2] + $fib[$i-1];
+ }
+ for my $i(0..10) {
+ $total += $i;
+ }
+ }
+ };
+ $walker = B::Showlex::compile($asub, $newlex, -nosp);
+ $walker->();
+ print $buf if $verbose;
+
+ $walker = B::Concise::compile($asub, '-exec');
+ $walker->();
+
+}
+}
Added: B/t/stash.t
==============================================================================
--- (empty file)
+++ B/t/stash.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,99 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..1\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+
+my $got;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+chomp($got = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
+
+$got =~ s/-u//g;
+
+print "# got = $got\n";
+
+my @got = map { s/^\S+ //; $_ }
+ sort { $a cmp $b }
+ map { lc($_) . " " . $_ }
+ split /,/, $got;
+
+print "# (after sorting)\n";
+print "# got = @got\n";
+
+ at got = grep { ! /^(PerlIO|open)(?:::\w+)?$/ } @got;
+
+print "# (after perlio censorings)\n";
+print "# got = @got\n";
+
+ at got = grep { ! /^Win32$/ } @got if $^O eq 'MSWin32';
+ at got = grep { ! /^NetWare$/ } @got if $^O eq 'NetWare';
+ at got = grep { ! /^(Cwd|File|File::Copy|OS2)$/ } @got if $^O eq 'os2';
+ at got = grep { ! /^(Cwd|Cygwin)$/ } @got if $^O eq 'cygwin';
+
+if ($Is_VMS) {
+ @got = grep { ! /^File(?:::Copy)?$/ } @got;
+ @got = grep { ! /^VMS(?:::Filespec)?$/ } @got;
+ @got = grep { ! /^vmsish$/ } @got;
+ # Socket is optional/compiler version dependent
+ @got = grep { ! /^Socket$/ } @got;
+}
+
+print "# (after platform censorings)\n";
+print "# got = @got\n";
+
+$got = "@got";
+
+my $expected = "attributes Carp Carp::Heavy DB Internals main Regexp utf8 version warnings";
+
+if ($] < 5.009) {
+ $expected =~ s/version //;
+ $expected =~ s/DB/DB Exporter Exporter::Heavy/;
+}
+
+{
+ no strict 'vars';
+ use vars '$OS2::is_aout';
+}
+
+if ((($Config{static_ext} eq ' ') || ($Config{static_ext} eq ''))
+ && !($^O eq 'os2' and $OS2::is_aout)
+ ) {
+ print "# got [$got]\n# vs.\n# expected [$expected]\nnot " if $got ne $expected;
+ ok;
+} else {
+ print "ok $test # skipped: one or more static extensions\n"; $test++;
+}
+
Added: B/t/terse.t
==============================================================================
--- (empty file)
+++ B/t/terse.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,123 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 16;
+
+use_ok( 'B::Terse' );
+
+# indent should return a string indented four spaces times the argument
+is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' );
+is( B::Terse::indent(), '', 'indent with no argument' );
+
+# this should fail without a reference
+eval { B::Terse::terse('scalar') };
+like( $@, qr/not a reference/, 'terse() fed bad parameters' );
+
+# now point it at a sub and see what happens
+sub foo {}
+
+my $sub;
+eval{ $sub = B::Terse::compile('', 'foo') };
+is( $@, '', 'compile()' );
+ok( defined &$sub, 'valid subref back from compile()' );
+
+# and point it at a real sub and hope the returned ops look alright
+my $out = tie *STDOUT, 'TieOut';
+$sub = B::Terse::compile('', 'bar');
+$sub->();
+
+# now build some regexes that should match the dumped ops
+my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
+my %ops = map { $_ => qr/$_ $hex$op/ }
+ qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP );
+
+# split up the output lines into individual ops (terse is, well, terse!)
+# use an array here so $_ is modifiable
+my @lines = split(/\n+/, $out->read);
+foreach (@lines) {
+ next unless /\S/;
+ s/^\s+//;
+ if (/^([A-Z]+)\s+/) {
+ my $op = $1;
+ next unless exists $ops{$op};
+ like( $_, $ops{$op}, "$op " );
+ s/$ops{$op}//;
+ delete $ops{$op};
+ redo if $_;
+ }
+}
+
+warn "# didn't find " . join(' ', keys %ops) if keys %ops;
+
+# XXX:
+# this tries to get at all tersified optypes in B::Terse
+# if you can think of a way to produce AV, NULL, PADOP, or SPECIAL,
+# add it to the regex above too. (PADOPs are currently only produced
+# under ithreads, though).
+#
+use vars qw( $a $b );
+sub bar {
+ # OP SVOP COP IV here or in sub definition
+ my @bar = (1, 2, 3);
+
+ # got a GV here
+ my $foo = $a + $b;
+
+ # NV here
+ $a = 1.234;
+
+ # this is awful, but it gives a PMOP
+ our @ary = split('', $foo);
+
+ # PVOP, LOOP
+ LOOP: for (1 .. 10) {
+ last LOOP if $_ % 2;
+ }
+
+ # make a PV
+ $foo = "a string";
+
+ # make an OP_SUBSTCONT
+ $foo =~ s/(a)/$1/;
+}
+
+# Schwern's example of finding an RV
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
+my $redir = $^O eq 'MacOS' ? '' : "2>&1";
+my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
+like( $items, qr/RV $hex \\42/, 'RV' );
+
+package TieOut;
+
+sub TIEHANDLE {
+ bless( \(my $out), $_[0] );
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub PRINTF {
+ my $self = shift;
+ $$self .= sprintf(@_);
+}
+
+sub read {
+ my $self = shift;
+ return substr($$self, 0, length($$self), '');
+}
Added: B/t/xref.t
==============================================================================
--- (empty file)
+++ B/t/xref.t Tue Jun 26 12:23:24 2007
@@ -0,0 +1,120 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+no warnings 'once';
+use Test::More tests => 14;
+
+# line 50
+use_ok( 'B::Xref' );
+
+my $file = 'xreftest.out';
+
+open SAVEOUT, ">&STDOUT" or diag $!;
+close STDOUT;
+# line 100
+our $compilesub = B::Xref::compile("-o$file");
+ok( ref $compilesub eq 'CODE', "compile() returns a coderef ($compilesub)" );
+$compilesub->(); # Compile this test script
+close STDOUT;
+open STDOUT, ">&SAVEOUT" or diag $!;
+
+# Now parse the output
+# line 200
+my ($curfile, $cursub, $curpack) = ('') x 3;
+our %xreftable = ();
+open XREF, $file or die "# Can't open $file: $!\n";
+while (<XREF>) {
+ chomp;
+ if (/^File (.*)/) {
+ $curfile = $1;
+ } elsif (/^ Subroutine (.*)/) {
+ $cursub = $1;
+ } elsif (/^ Package (.*)/) {
+ $curpack = $1;
+ } elsif ($curpack eq '?' && /^ (".*") +(.*)/
+ or /^ (\S+)\s+(.*)/) {
+ $xreftable{$curfile}{$cursub}{$curpack}{$1} = $2;
+ }
+}
+close XREF;
+my $thisfile = __FILE__;
+
+ok(
+ defined $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
+ '$compilesub present in main program'
+);
+like(
+ $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
+ qr/\bi100\b/,
+ '$compilesub introduced at line 100'
+);
+like(
+ $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
+ qr/&102\b/,
+ '$compilesub coderef called at line 102'
+);
+ok(
+ defined $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'},
+ '$curfile present in main program'
+);
+like(
+ $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'},
+ qr/\bi200\b/,
+ '$curfile introduced at line 200'
+);
+ok(
+ defined $xreftable{$thisfile}{'(main)'}{main}{'%xreftable'},
+ '$xreftable present in main program'
+);
+ok(
+ defined $xreftable{$thisfile}{'Testing::Xref::foo'}{main}{'%xreftable'},
+ '$xreftable used in subroutine bar'
+);
+is(
+ $xreftable{$thisfile}{'(main)'}{main}{'&use_ok'}, '&50',
+ 'use_ok called at line 50'
+);
+is(
+ $xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&foo'}, 's1001',
+ 'subroutine foo defined at line 1001'
+);
+is(
+ $xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&bar'}, 's1002',
+ 'subroutine bar defined at line 1002'
+);
+is(
+ $xreftable{$thisfile}{'Testing::Xref::bar'}{'Testing::Xref'}{'&foo'},
+ '&1002', 'subroutine foo called at line 1002 by bar'
+);
+is(
+ $xreftable{$thisfile}{'Testing::Xref::foo'}{'Testing::Xref'}{'*FOO'},
+ '1001', 'glob FOO used in subroutine foo'
+);
+
+END {
+ 1 while unlink $file;
+}
+
+# End of tests.
+# Now some stuff to feed B::Xref
+
+# line 1000
+package Testing::Xref;
+sub foo { print FOO %::xreftable; }
+sub bar { print FOO foo; }
+
Added: B/typemap
==============================================================================
--- (empty file)
+++ B/typemap Tue Jun 26 12:23:24 2007
@@ -0,0 +1,69 @@
+TYPEMAP
+
+B::OP T_OP_OBJ
+B::UNOP T_OP_OBJ
+B::BINOP T_OP_OBJ
+B::LOGOP T_OP_OBJ
+B::LISTOP T_OP_OBJ
+B::PMOP T_OP_OBJ
+B::SVOP T_OP_OBJ
+B::PADOP T_OP_OBJ
+B::PVOP T_OP_OBJ
+B::LOOP T_OP_OBJ
+B::COP T_OP_OBJ
+
+B::SV T_SV_OBJ
+B::PV T_SV_OBJ
+B::IV T_SV_OBJ
+B::NV T_SV_OBJ
+B::PVMG T_SV_OBJ
+B::PVLV T_SV_OBJ
+B::BM T_SV_OBJ
+B::RV T_SV_OBJ
+B::GV T_SV_OBJ
+B::CV T_SV_OBJ
+B::HV T_SV_OBJ
+B::AV T_SV_OBJ
+B::IO T_SV_OBJ
+B::FM T_SV_OBJ
+
+B::MAGIC T_MG_OBJ
+SSize_t T_IV
+STRLEN T_UV
+PADOFFSET T_UV
+
+INPUT
+T_OP_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_SV_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_MG_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+OUTPUT
+T_OP_OBJ
+ sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var));
+
+T_SV_OBJ
+ make_sv_object(aTHX_ ($arg), (SV*)($var));
+
+
+T_MG_OBJ
+ sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));
More information about the Jifty-commit
mailing list