[Jifty-commit] r5347 - in B-Decompile: t

Jifty commits jifty-commit at lists.jifty.org
Wed Apr 30 08:56:04 EDT 2008


Author: clkao
Date: Wed Apr 30 08:56:03 2008
New Revision: 5347

Added:
   B-Decompile/lib/B/Simple/
   B-Decompile/lib/B/Simple/Inflate.pm
      - copied, changed from r5346, /B-Decompile/lib/B/Decompile.pm
   B-Decompile/t/basic.t

Log:
Simple B::Simple::Inflate. trivial inflate_coderef for now.

Copied: B-Decompile/lib/B/Simple/Inflate.pm (from r5346, /B-Decompile/lib/B/Decompile.pm)
==============================================================================
--- /B-Decompile/lib/B/Decompile.pm	(original)
+++ B-Decompile/lib/B/Simple/Inflate.pm	Wed Apr 30 08:56:03 2008
@@ -1,12 +1,4 @@
-# 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::Decompile;
+package B::Simple::Inflate;
 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
@@ -19,275 +11,12 @@
          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;
+
+$VERSION = 0.01;
 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";
@@ -665,6 +394,16 @@
     }
 }
 
+sub inflate_coderef {
+    my $self = shift;
+    my $sub = shift;
+    croak "Usage: ->inflate_coderef(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
+
+    $self->init();
+
+    return $self->inflate_sub( svref_2object($sub) );
+}
+
 sub coderef2text {
     my $self = shift;
     my $sub = shift;
@@ -870,6 +609,62 @@
     return $proto ."{\n\t$body\n\b}" ."\n";
 }
 
+sub inflate_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);
+	}
+        return { node => 'SubDefinition', proto => $proto, bodytext => $body };
+    }
+    else {
+	my $sv = $cv->const_sv;
+	if ($$sv) {
+	    # uh-oh. inlinable sub... format it differently
+            return { node => 'SubDefinition', proto => $proto, body => { $self->const($sv, 0) } };
+	    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;

Added: B-Decompile/t/basic.t
==============================================================================
--- (empty file)
+++ B-Decompile/t/basic.t	Wed Apr 30 08:56:03 2008
@@ -0,0 +1,86 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 1;
+
+use B;
+use B::Simple::Inflate;
+sub bar {}
+
+sub foo {
+    bar(1, "two", bar(2));
+}
+
+my $deparser = B::Simple::Inflate->new();
+warn Dumper($deparser->inflate_coderef(\&foo)) ; use Data::Dumper;
+
+__END__
+
+=begin comment
+
+b  <1> leavesub[1 ref] K/REFC,1 ->(end)
+-     <@> lineseq KP ->b
+1        <;> nextstate(main -369 basic.t:10) v/2 ->2
+a        <1> entersub[t4] KS/TARG,3 ->b
+-           <1> ex-list K ->a
+2              <0> pushmark s ->3
+3              <$> const[IV 1] sM ->4
+4              <$> const[PV "two"] sM ->5
+8              <1> entersub[t3] lKMS/NO(),TARG,INARGS,3 ->9
+-                 <1> ex-list lK ->8
+5                    <0> pushmark s ->6
+6                    <$> const[IV 2] sM ->7
+-                    <1> ex-rv2cv sK/3 ->-
+7                       <#> gv[*bar] s ->8
+-              <1> ex-rv2cv sK/3 ->-
+9                 <#> gv[*bar] s ->a
+
+=cut
+
+SubDefinition(
+          body => Seq(
+                      __op => \lineseq, # is it a real op?
+                      __first => \a, # the enter sub
+                      __last => \a,
+                      statements => [
+                                     Subcall(
+                                             __op => \a,
+                                             args => List(
+                                                          __op => \2, # pushmark
+                                                          __first => \3, # const 1
+                                                          __last  => \8, # entersub
+                                                          elements => [
+                                                                       Const(value => 1, __op => \3),
+                                                                       Const(value => "two", __op => \4),
+                                                                       Subcall(
+                                                                               __op => \8,
+                                                                               args => List(
+                                                                                            __op => \5, # the pushmark
+                                                                                            __first => \6,
+                                                                                            __last => \6,
+                                                                                            elements => [ Const(value => 2)]
+                                                                                           ),
+                                                                               sub => Var::Dynamic(
+                                                                                                   __op => \exlist # note that its optimized away
+                                                                                                   __real_op => \7
+                                                                                                   name => '&bar'
+                                                                                                  )
+                                                                              )
+                                                                      ],
+                                                         ),
+                                             sub => Var::Dynamic(
+                                                                 __op => \exlist, # note that its optimized away
+                                                                 __real_op => \9
+                                                                 name = '&bar',
+                                                                )
+                                             )
+                      ]
+          )
+)
+
+use B::Concise qw(set_style add_callback);
+use B::Terse;
+
+my $walker = B::Concise::compile(\&foo);
+
+$walker->();
+#warn "foo";


More information about the Jifty-commit mailing list