--- /dev/null
+blib*
+pm_to_blib*
+
+Makefile
+Makefile.old
+Build
+_build*
+
+*.tar.gz
+B-RecDeparse-*
+
+core.*
+*.[co]
+*.so
+*.bs
+*.out
+*.def
+*.exp
+
+cover_db
+*.gcda
+*.gcov
+*.gcno
--- /dev/null
+Revision history for B-RecDeparse
+
+0.01 2008-07-28 10:35 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/B/RecDeparse.pm
+samples/brd.pl
+t/00-load.t
+t/02-can.t
+t/10-obj.t
+t/11-args.t
+t/12-level.t
+t/13-prototypes.t
+t/14-refs.t
+t/20-compile.t
+t/90-boilerplate.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+--- #YAML:1.0
+name: B-RecDeparse
+version: 0.01
+abstract: Deparse recursively into subroutines.
+license: perl
+author:
+ - Vincent Pit <perl@profvince.com>
+generated_by: ExtUtils::MakeMaker version 6.42
+distribution_type: module
+requires:
+ B::Deparse: 0
+ Carp: 0
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+build_requires:
+ ExtUtils::MakeMaker: 0
+ Test::More: 0
--- /dev/null
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+my $BUILD_REQUIRES = {
+ 'ExtUtils::MakeMaker' => 0,
+ 'Test::More' => 0,
+};
+
+sub build_req {
+ my $tometa = ' >> $(DISTVNAME)/META.yml;';
+ my $build_req = 'echo "build_requires:" ' . $tometa;
+ foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) {
+ my $ver = $BUILD_REQUIRES->{$mod};
+ $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa;
+ }
+ return $build_req;
+}
+
+WriteMakefile(
+ NAME => 'B::RecDeparse',
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => 'lib/B/RecDeparse.pm',
+ ABSTRACT_FROM => 'lib/B/RecDeparse.pm',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'Carp' => 0,
+ 'B::Deparse' => 0
+ },
+ dist => {
+ PREOP => 'pod2text lib/Variable/Magic.pm > $(DISTVNAME)/README; '
+ . build_req,
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+ },
+ clean => { FILES => 'B-RecDeparse-* *.gcov *.gcda *.gcno cover_db' }
+);
--- /dev/null
+package B::RecDeparse;
+
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+
+use base qw/B::Deparse/;
+
+=head1 NAME
+
+B::RecDeparse - Deparse recursively into subroutines.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+ perl -MO=RecDeparse,deparse,[@B__Deparse_opts],level,-1 [ -e '...' | bleh.pl ]
+
+ # Or as a module :
+ use B::RecDeparse;
+
+ my $brd = B::RecDeparse->new(deparse => [ @b__deparse_opts ], level => $level);
+ my $code = $brd->coderef2text(sub { ... });
+
+=head1 DESCRIPTION
+
+This module extends L<B::Deparse> by making you recursively replace subroutine calls encountered when deparsing.
+
+Please refer to L<B::Deparse> documentation for what to do and how to do it. Besides the constructor syntax, everything should work the same for the two modules.
+
+=head1 METHODS
+
+=head2 C<< new < deparse => [ @B__Deparse_opts ], level => $level > >>
+
+The L<B::RecDeparse> object constructor. You can specify the underlying L<B::Deparse> constructor arguments by passing a string or an array reference as the value of the C<deparse> key. The C<level> option expects an integer that specifies how many levels of recursions are allowed : L<-1> means infinite while L<0> means none and match L<B::Deparse> behaviour.
+
+=cut
+
+sub _parse_args {
+ croak 'Optional arguments must be passed as key/value pairs' if @_ % 2;
+ my %args = @_;
+ my $deparse = $args{deparse};
+ if (defined $deparse) {
+ if (!ref $deparse) {
+ $deparse = [ $deparse ];
+ } elsif (ref $deparse ne 'ARRAY') {
+ $deparse = [ ];
+ }
+ } else {
+ $deparse = [ ];
+ }
+ my $level = $args{level};
+ $level = -1 unless defined $level;
+ $level = int $level;
+ return $deparse, $level;
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class || __PACKAGE__;
+ my ($deparse, $level) = _parse_args(@_);
+ my $self = bless $class->SUPER::new(@$deparse), $class;
+ $self->{brd_level} = $level;
+ return $self;
+}
+
+sub _recurse {
+ return $_[0]->{brd_level} >= 0 && $_[0]->{brd_cur} >= $_[0]->{brd_level}
+}
+
+sub compile {
+ my $bd = B::Deparse->new();
+ my @args = @_;
+ my ($deparse, $level) = _parse_args(@args);
+ my $compiler = $bd->coderef2text(B::Deparse::compile(@$deparse));
+ $compiler =~ s/
+ ['"]? B::Deparse ['"]? \s* -> \s* (new) \s* \( ([^\)]*) \)
+ /B::RecDeparse->$1(deparse => [ $2 ], level => $level)/gx;
+ $compiler = eval 'sub ' . $compiler;
+ die if $@;
+ return $compiler;
+}
+
+sub init {
+ my $self = shift;
+ $self->{brd_cur} = 0;
+ $self->{brd_sub} = 0;
+ $self->SUPER::init(@_);
+}
+
+my $key = $; . __PACKAGE__ . $;;
+
+# p31268 made pp_entersub call single_delim
+if ($^V ge v5.9.5) {
+ my $oldsd = *B::Deparse::single_delim{CODE};
+ no warnings 'redefine';
+ *B::Deparse::single_delim = sub {
+ my $body = $_[2];
+ if ($body =~ s/^$key//) {
+ return $body;
+ } else {
+ $oldsd->(@_);
+ }
+ }
+}
+
+sub pp_entersub {
+ my $self = shift;
+ $self->{brd_sub} = 1;
+ my $body = $self->SUPER::pp_entersub(@_);
+ $self->{brd_sub} = 0;
+ $body =~ s/^&\s*(\w)/$1/ if not $self->_recurse;
+ return $body;
+}
+
+sub pp_refgen {
+ my $self = shift;
+ $self->{brd_sub} = 0;
+ my $body = $self->SUPER::pp_refgen(@_);
+ $self->{brd_sub} = 1;
+ return $body;
+}
+
+sub pp_gv {
+ my $self = shift;
+ my $body;
+ if ($self->{brd_sub} <= 0 || $self->_recurse) {
+ $body = $self->SUPER::pp_gv(@_);
+ } else {
+ my $gv = $self->gv_or_padgv($_[0]);
+ ++$self->{brd_cur};
+ $body = 'sub ' . $self->indent($self->deparse_sub($gv->CV));
+ --$self->{brd_cur};
+ if ($^V lt v5.9.5) {
+ $body .= '->';
+ } else {
+ $body = $key . $body;
+ }
+ }
+ return $body;
+}
+
+=head2 C<compile>
+
+=head2 C<init>
+
+=head2 C<pp_entersub>
+
+=head2 C<pp_refgen>
+
+=head2 C<pp_gv>
+
+Functions and methods from L<B::Deparse> overriden by this module. Never call them directly.
+
+Otherwise, L<B::RecDeparse> inherits all methods from L<B::Deparse>.
+
+=head1 EXPORT
+
+An object-oriented module shouldn't export any function, and so does this one.
+
+=head1 DEPENDENCIES
+
+L<Carp> (standard since perl 5), L<B::Deparse> (since perl 5.005).
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-b-recdeparse at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=B-RecDeparse>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc B::RecDeparse
+
+Tests code coverage report is available at L<http://www.profvince.com/perl/cover/B-RecDeparse>.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of B::RecDeparse
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use lib qw{blib/lib};
+use B::RecDeparse;
+# use B::Deparse;
+
+my $deparser = B::RecDeparse->new(deparse => [ '-sCi0v1' ], level => 1);
+# my $deparser = B::Deparse->new('-sCi0v1');
+
+sub spec (&) {
+ return unless defined $_[0] and ref $_[0] eq 'CODE';
+ my $deparsed = $deparser->coderef2text($_[0]);
+ print STDERR "$deparsed\n";
+ my $code = eval 'sub ' . $deparsed;
+ die if $@;
+ $code;
+}
+
+sub add ($$) { $_[0] + $_[1] }
+
+sub mul ($$) { $_[0] * $_[1] }
+
+sub fma ($$$) { add +(mul $_[0], $_[1]), $_[2] }
+
+print STDERR '### ', fma(1, 3, 2), "\n";
+my $sfma = spec sub { my $x = \&mul; fma $_[0], 3, $_[1] };
+print STDERR '### ', $sfma->(1, 2), "\n";
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'B::RecDeparse' );
+}
+
+diag( "Testing B::RecDeparse $B::RecDeparse::VERSION, Perl $], $^X" );
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+require B::RecDeparse;
+
+for (qw/new init pp_gv pp_entersub pp_const coderef2text/) {
+ ok(B::RecDeparse->can($_), 'BRD can ' . $_);
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+
+use B::RecDeparse;
+
+my $brd = new B::RecDeparse;
+ok(defined $brd, 'BRD object is defined');
+is(ref $brd, 'B::RecDeparse', 'BRD object is valid');
+ok($brd->isa('B::Deparse'), 'BRD is a BD');
+
+my $brd2 = $brd->new;
+ok(defined $brd2, 'BRD::new called as an object method works' );
+is(ref $brd2, 'B::RecDeparse', 'BRD::new called as an object method works is valid');
+ok($brd2->isa('B::Deparse'), 'BRD is a BD');
+
+my $brd3 = B::RecDeparse::new();
+ok(defined $brd3, 'BRD::new called as a function works ');
+is(ref $brd3, 'B::RecDeparse', 'BRD::new called as a functions returns a B::RecDeparse object');
+ok($brd3->isa('B::Deparse'), 'BRD is a BD');
+
+eval { $brd2 = new B::RecDeparse qw/a b c/ };
+like($@, qr/Optional\s+arguments/, 'BRD::new gets parameters as key => value pairs');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 * 4 + 4 * 2;
+
+use B::Deparse;
+use B::RecDeparse;
+
+sub add ($$) { $_[0] + $_[1] }
+sub mul { $_[0] * $_[1] }
+sub fma { add mul($_[0], $_[1]), $_[2] }
+sub wut { fma $_[0], 2, $_[1] }
+
+my @br_args = ('', '-sCi0v1');
+my @brd_args = ({ }, { deparse => undef }, { deparse => { } }, { deparse => [ ] });
+
+my $br = B::Deparse->new();
+my $reference = $br->coderef2text(\&wut);
+my $i = 1;
+for (@brd_args) {
+ my $brd = B::RecDeparse->new(%$_, level => 0);
+ my $code = $brd->coderef2text(\&wut);
+ is($code, $reference, "empty deparse and level 0 does the same thing as B::Deparse ($i)");
+ $code = eval 'sub ' . $code;
+ is($@, '', "result compiles ($i)");
+ is_deeply( [ defined $code, ref $code ], [ 1, 'CODE' ], "result compiles to a code reference ($i)");
+ is($code->(1, 3), wut(1, 3), "result compiles to the good thing ($i)");
+ ++$i;
+}
+
+my $br_opts = '-sCi0v1';
+@brd_args = ({ deparse => $br_opts }, { deparse => [ $br_opts ] });
+for (@brd_args) {
+ $br = B::Deparse->new($br_opts);
+ my $brd = B::RecDeparse->new(%$_, level => 0);
+ my $code = $brd->coderef2text(\&wut);
+ is($code, $br->coderef2text(\&wut), "B::RecDeparse->new(deparse => '$br_opts' ), level => 0) does the same thing as B::Deparse->new('$br_opts') ($i)");
+ $code = eval 'sub ' . $code;
+ is($@, '', "result compiles ($i)");
+ is_deeply( [ defined $code, ref $code ], [ 1, 'CODE' ], "result compiles to a code reference ($i)");
+ is($code->(1, 3), wut(1, 3), "result compiles to the good thing ($i)");
+ ++$i;
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (3 + 3) * 5;
+
+use B::Deparse;
+use B::RecDeparse;
+
+sub add { $_[0] + $_[1] }
+sub mul { $_[0] * $_[1] }
+sub fma { add mul($_[0], $_[1]), $_[2] }
+sub wut { fma $_[0], 2, $_[1] }
+
+sub which {
+ my ($brd, $yes, $no, $l) = @_;
+ my $code = $brd->coderef2text(\&wut);
+ for (@$yes) {
+ like($code, qr/\b$_\b/, "expansion at level $l contains $_");
+ }
+ for (@$no) {
+ unlike($code, qr/\b$_\b/, "expansion at level $l does not contain $_");
+ }
+ $code = eval 'sub ' . $code;
+ is($@, '', "result compiles at level $l");
+ is_deeply( [ defined $code, ref $code ], [ 1, 'CODE' ], "result compiles to a code reference at level $l");
+ is($code->(1, 3), wut(1, 3), "result compiles to the good thing at level $l");
+}
+
+my $br_args = '-sCi0v1';
+
+my $brd = B::RecDeparse->new(deparse => [ $br_args ], level => -1);
+which $brd, [ ], [ qw/add mul fma/ ], -1;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 0);
+which $brd, [ qw/fma/ ], [ qw/add mul/ ], 0;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 1);
+which $brd, [ qw/add mul/ ], [ qw/fma/ ], 1;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 2);
+which $brd, [ ], [ qw/add mul fma/ ], 2;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 3);
+which $brd, [ ], [ qw/add mul fma/ ], 2;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (3 + 3) * 5;
+
+use B::Deparse;
+use B::RecDeparse;
+
+sub add ($$) { $_[0] + $_[1] }
+sub mul ($$) { $_[0] * $_[1] }
+sub fma { add mul($_[0], $_[1]), $_[2] }
+sub wut ($$) { fma $_[0], 2, $_[1] }
+
+sub which {
+ my ($brd, $yes, $no, $l) = @_;
+ my $code = $brd->coderef2text(\&wut);
+ for (@$yes) {
+ like($code, qr/\b$_\b/, "expansion at level $l contains $_");
+ }
+ for (@$no) {
+ unlike($code, qr/\b$_\b/, "expansion at level $l does not contain $_");
+ }
+ $code = eval 'sub ' . $code;
+ is($@, '', "result compiles at level $l");
+ is_deeply( [ defined $code, ref $code ], [ 1, 'CODE' ], "result compiles to a code reference at level $l");
+ is($code->(1, 3), wut(1, 3), "result compiles to the good thing at level $l");
+}
+
+my $br_args = '-sCi0v1';
+
+my $brd = B::RecDeparse->new(deparse => [ $br_args ], level => -1);
+which $brd, [ ], [ qw/add mul fma/ ], -1;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 0);
+which $brd, [ qw/fma/ ], [ qw/add mul/ ], 0;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 1);
+which $brd, [ qw/add mul/ ], [ qw/fma/ ], 1;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 2);
+which $brd, [ ], [ qw/add mul fma/ ], 2;
+
+$brd = B::RecDeparse->new(deparse => [ $br_args ], level => 3);
+which $brd, [ ], [ qw/add mul fma/ ], 2;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 2 * (4 + 3) * 4;
+
+use B::RecDeparse;
+
+sub dummy { }
+sub add { $_[0] + $_[1] }
+sub call ($$$) { my $x = \&dummy; $_[0]->($_[1], $_[2]) }
+sub foo { call(\&add, $_[0], 1); }
+sub bar { my $y = \&call; $y->(\&add, $_[0], 1); }
+
+sub which {
+ my ($brd, $coderef, $yfunc, $yref, $nfunc, $nref, $l) = @_;
+ my $code = $brd->coderef2text($coderef);
+ for (@$yfunc) {
+ like($code, qr/\b(?<!\\&)$_\b/, "expansion at level $l contains the function $_");
+ }
+ for (@$yref) {
+ like($code, qr/\b(?<=\\&)$_\b/, "expansion at level $l contains the ref $_");
+ }
+ for (@$nfunc) {
+ unlike($code, qr/\b(?<!\\&)$_\b/, "expansion at level $l does not contain the function $_");
+ }
+ for (@$nref) {
+ unlike($code, qr/\b(?<=\\&)$_\b/, "expansion at level $l does not contain the ref $_");
+ }
+ $code = eval 'sub ' . $code;
+ is($@, '', "result compiles at level $l");
+ is_deeply( [ defined $code, ref $code ], [ 1, 'CODE' ], "result compiles to a code reference at level $l");
+ is($code->(2), $coderef->(2), "result compiles to the good thing at level $l");
+}
+
+my $br_args = '-sCi0v1';
+
+my $brd = B::RecDeparse->new(deparse => $br_args, level => -1);
+which $brd, \&foo, [ ], [ qw/add dummy/ ], [ qw/add call/ ], [ ], -1;
+which $brd, \&bar, [ ], [ qw/add call/ ], [ qw/add call/ ], [ ], -1;
+
+$brd = B::RecDeparse->new(deparse => $br_args, level => 0);
+which $brd, \&foo, [ qw/call/ ], [ qw/add/ ], [ qw/add/ ], [ qw/dummy/ ], 0;
+which $brd, \&bar, [ ], [ qw/add call/ ], [ qw/add/ ], [ qw/dummy/ ], 0;
+
+$brd = B::RecDeparse->new(deparse => $br_args, level => 1);
+which $brd, \&foo, [ ], [ qw/add dummy/ ], [ qw/add call/ ], [ ], 1;
+which $brd, \&bar, [ ], [ qw/add call/ ], [ qw/add call/ ], [ ], 1;
+
+$brd = B::RecDeparse->new(deparse => $br_args, level => 2);
+which $brd, \&foo, [ ], [ qw/add dummy/ ], [ qw/add call/ ], [ ], 2;
+which $brd, \&bar, [ ], [ qw/add call/ ], [ qw/add call/ ], [ ], 2;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+use B::RecDeparse;
+
+my $cr = eval { B::RecDeparse::compile(deparse => '-sCi0v1', level => 1) };
+is(defined $cr, 1, 'compile() returns a defined thingy');
+is(ref $cr, 'CODE', 'compile() returns a code reference');
+is($@, '', 'compile() re-evaluated without dieing');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open( my $fh, '<', $filename )
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+);
+
+module_boilerplate_ok('lib/B/RecDeparse.pm');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Portability::Files";
+plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@;
+run_tests();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
projects / perl / modules / B-RecDeparse.git / commitdiff