#!/usr/bin/env perl
use warnings;
use strict;
use PPI;
use Data::Dump;

my $code = <<'ENDCODE';
print "Hello, ";
sub Fee {
	return <<__Fee__;
World
__Fee__
}
sub Blah {
	return <<'FOO';
	Hello
FOO
}
print Fee;
ENDCODE

my $doc = PPI::Document->new(\$code);

for my $sub (@{ $doc->find('PPI::Statement::Sub') }) {
	# insert the stub (BUT doesn't preserve prototype, attributes, etc.)
	$sub->insert_after(
		PPI::Document::Fragment->new(\("sub ".$sub->name." {...}"))
			->find_first('PPI::Statement::Sub')->remove );
	my $subdoc = PPI::Document::Fragment->new;
	$subdoc->add_element($sub->remove);
	print "SUB<<", $subdoc->serialize, ">>\n";
}

print "DOC<<", $doc->serialize, ">>\n";

__END__

SUB<<sub Fee {
	return <<__Fee__;
World
__Fee__
}>>
SUB<<sub Blah {
	return <<'FOO';
	Hello
FOO
}>>
DOC<<print "Hello, ";
sub Fee {...}
sub Blah {...}
print Fee;
>>

##</code><code>##

#!/usr/bin/env perl
use warnings;
use strict;
use PPR;

# Some complicated code
my $code = <<'ENDCODE';
sub MODIFY_CODE_ATTRIBUTES {
	my ($class,$code,@attrs) = @_;
	return grep { !/^Foo\(?/ } @attrs;
}
sub Bar ($);
sub Baz : Foo(sub bar {"bar"}) { 'Baz' }
print Foo('Bar');
Bar(Baz);
	sub Bar ($) { print "Quz $_[0]\n" }
use experimental 'signatures';
sub Foo ($x = sub { <<"sub xyz {"
Hello!
sub xyz {
}) {
	return ref $x ? $x->() : sub { <<"}";
Foo $x
}
}->()
}
print Foo;
sub x {"x"} sub y {"y"} { print "I'm just a block\n" }
DESTROY { warn "Blam\n" }  
ENDCODE

# Debuggging stuff
use Data::Dump qw/dd pp/;
#print $code,"----- -----\n";
# exec code to check for syntax errors
eval "$code; 1" or die $@;
print "-----\n";

# Regexes based on and using PPR
my $docre = qr{ # based on PPR's PerlDocument
	(?>(?&PerlOWS)) (?>(?&PerlStatement)) (?&PerlOWS) $PPR::GRAMMAR }msx;
my $subre = qr{ \A (?>(?&PerlOWS)) # based on PPR's PerlSubroutineDeclaration
	(?> sub \b (?>(?&PerlOWS)) (?<name>(?>(?&PerlOldQualifiedIdentifier)))
		| (?<name>AUTOLOAD) | (?<name>DESTROY) )
	\b .* \K (?> (?<block>(?>(?&PerlBlock))) (?= (?&PerlOWS) \z ) )
	$PPR::GRAMMAR }msx;

# Convert sub blocks to stubs
my ($stubcode,%subs);
while ( $code=~/\G($docre)/gc ) {
	my $stmt = $1;
	if ( $stmt =~ s/$subre/{...}/ ) {
		die "sub $+{name} found twice" if exists $subs{$+{name}};
		$subs{$+{name}} = $+{block};
	}
	$stubcode .= $stmt;
}
pos($code)==length($code) or die "Failed to parse code";
print $stubcode, "-----\n", pp(\%subs), "\n"; # Debug

# Convert stubs back to blocks
my $unstubcode;
while ( $stubcode=~/\G($docre)/gc ) {
	my $stmt = $1;
	$stmt =~ s{$subre}{
		die "sub $+{name} wasn't a stub" unless $+{block} eq '{...}';
		$subs{$+{name}} or die "Don't have code for stub $+{name}"
		}e;
	$unstubcode .= $stmt;
}
pos($stubcode)==length($stubcode)
	or die "Failed to parse stubcode";
$unstubcode eq $code or die "MISMATCH: $unstubcode"; # Debug

__END__

Foo Bar
Quz Baz
Hello!
I'm just a block
-----
sub MODIFY_CODE_ATTRIBUTES {...}
sub Bar ($);
sub Baz : Foo(sub bar {"bar"}) {...}
print Foo('Bar');
Bar(Baz);
	sub Bar ($) {...}
use experimental 'signatures';
sub Foo ($x = sub { <<"sub xyz {"
Hello!
sub xyz {
}) {...}
print Foo;
sub x {...} sub y {...} { print "I'm just a block\n" }
DESTROY {...}  
-----
{
  Bar => "{ print \"Quz \$_[0]\\n\" }",
  Baz => "{ 'Baz' }",
  DESTROY => "{ warn \"Blam\\n\" }",
  Foo => "{\n\treturn ref \$x ? \$x->() : sub { <<\"}\";\nFoo \$x\n}\n}->()\n}",
  MODIFY_CODE_ATTRIBUTES => "{\n\tmy (\$class,\$code,\@attrs) = \@_;\n\treturn grep { !/^Foo\\(?/ } \@attrs;\n}",
  x => "{\"x\"}",
  y => "{\"y\"}",
}