perl; use warnings; use strict; use IO::All; my $code =join('',); print extract_method($code); sub extract_method { my $code = shift; write_file($code); my $err = 1; my @args = (); while ($err) { $err = 0; open( my $perl, "-|", 'perl -C /tmp/code.txt 2>&1' ) || die $@; while ( my $item = <$perl> ) { if ( $item =~ /Global symbol "(.*)" requires explicit package name/ ) { $err = 1; push @args, $1 unless (grep {$1 eq $_} @args); } } write_file($code, @args); } return codegen($code,'final',@args); } sub write_file { my $code = shift; my @args = (@_); codegen($code, 'test', @args) > io('/tmp/code.txt'); } sub codegen { my $code = shift; my $mode = shift; my @args = (@_); my $selforthis_signature = qr/^(\$self|\$this)$/; my ($class_obj) = grep { $_ =~ /$selforthis_signature/ } @args; my @params = grep { $_ !~ /$selforthis_signature/ } @args; my $method_body = generate_signature( $class_obj, \@params, $code ); my $subname = 'mysub_' . int( rand(1000) ); my $invocation; if ($class_obj) { $invocation = $class_obj . "->" . $subname; } else { $invocation = $subname; } my $ret = "$invocation(" . join( ',', map { $_ =~ /^(\%|\@)/ ? '\\' . $_ : $_ } @params ) . ");\n"; $ret .= "sub $subname { \n" . ( $mode eq 'test' ? "use strict;\n" : '' ) . $method_body . "\n}"; return $ret; } sub generate_signature { my $class_obj = shift; my @params = @{(shift)}; my $code = shift; my $ret = join( "\n", ( $class_obj ? ' my '.$class_obj." = shift;" :""), map { my $var = $_; if ( $var =~ /^(\%|\@)(.*)$/) { my $sigil = $1; my $name = $2; " my ".$var." = ".$sigil."{(shift)};"; } else { " my $var = shift;"; } } @params ) . "\n\n" . $code; return $ret; }