グローバル変数だらけのスクリプトをできるだけ安全に eval して再利用するこころみ

MySourceFilterLegacyCode.pm

package My::SourceFilter::LegacyCode;
use strict;
use warnings;

BEGIN {
    use Exporter ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    @ISA = qw/Exporter/;
    @EXPORT = qw/$printCode/;
    @EXPORT_OK = qw/&eval_code/; 
}

our $printCode = 0;

sub eval_code {
    my $code = shift;
    $code =~ s/[\r\n]/\n/g;
    my @args = @_;
    
    my %opened_fhs;
    my %vars;
    
    my @lines = split /\n/, $code;
    
    my $linenum = -1;
    for my $line (@lines) {
        $linenum++;
        next if ($line =~ /^\s*\#/);
        if ($line =~ s/open(\s*\(\s*|\s+)(?!my\s*)([\w\d\_]+)\s*\,/open$1\$$2,/) {
            my $sym = $2;
            my $var = '$'.$sym;
            $opened_fhs{$var} = 1;
            $vars{$var} = 2;
            $lines[$linenum] = $line;
        }
    }
    
    $linenum = -1;
    for my $line (@lines) {
        $linenum++;
        next if ($line =~ /^\s*\#/);

        if ($line =~ /my\s*([\$\@\%])\{?\s*([\w\_\d]+)\s*\}?/) {
            $vars{$1.$2} = 1;
            next;
        }
        
        my $line_bak = $line;
        while ($line =~ s/([\$\@\%])\{?([\w\_\d]+)\s*\}?\s*([\[\{]?)//) {
            my $sigil = $1;
            my $sym = $2;
            my $br = $3;
            if ($br) {
                if ($br eq '[') {
                    $sigil = '@';
                }
                elsif ($br eq '{') {
                    $sigil = '%';
                }
            }
            my $var = $sigil.$sym;
            if (!$vars{$var}) {
                $vars{$var} = 2;
            }
        }
        $line = $line_bak;
        
        if (
            $line =~ s/print(\s*\(\s*|\s+)([\w\d\_]+)(\s|\s*\W)/print$1\$$2 /
            || $line =~ s/(\<\s*)([\w\d\_]+)\s*\>/<\$$2>/
        ) {
            my $sym = $2;
            my $var = '$'.$sym;
            if (!$opened_fhs{$var}) {
                $line = '#'.$line;
            }
            $lines[$linenum] = $line;
        }
    }
    
    my $code_new = join "\n",
        (
            (
                map {"my $_;"}
                grep {$vars{$_} == 2 && ( !/^\$_$/ || !/^\$\W/)}
                keys %vars),
            @lines
        );
    
    
    my $line_num = 0;
    my $code_print = join "\n",
        map {sprintf "%4d %s", ++$line_num, $_;} (
            (map {"my $_;"} grep {$vars{$_} == 2} keys %vars),
            @lines
        );
    
    if ($printCode) {
        print STDERR $code_print;
        return;
    }
    
    my $result;
    do {
        no warnings;
        local @ARGV = @args;
        return eval $code_new;
    };
}

1;

test.pl

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

use My::SourceFilter::LegacyCode qw/$printCode/;

my $file = shift; # <- legacy_code.pl
die 'no file' unless (-e $file);

my $code = do {
    my $text = '';
    open my $fh, '<', $file;
    $text .= $_ while (<$fh>);
    close $fh;
    $text;
};

$My::SourceFilter::LegacyCode::printCode = 1;
My::SourceFilter::LegacyCode::eval_code($code, @ARGV);