[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