在verilog中嵌入perl脚本

写了个可以处理嵌入到systemverilog文件中的perl的脚本.

# expand
./embaded_perl.pl -e -i test.sv [-nochk]
# clean
./embaded_perl.pl -c -i test.sv

// Perl sub: sub_name
// ...perl scripts print something to stdout...
// Perl sub end: sub_name
// generated contents
// Perl sub generation end: sub_name

#!/bin/perl
use strict;
use feature qw(switch);
no warnings "experimental::smartmatch";

use Data::Dumper;
use Tie::File;
use Getopt::Long;


# Perl sub: sub_name
# /*sub definition*/
# Perl sub end: sub_name
# /*generated contents*/
# Perl sub generation end: sub_name
#
my $debug_on = 0;

my $opt_infile;

my $opt_expand;
my $opt_nochk;

my $opt_clean;

GetOptions(
    "i=s"     => \$opt_infile,
    "e:s"     => \$opt_expand,
    "nochk:s" => \$opt_nochk,
    "c:s"     => \$opt_clean
) or die "Error in command line arguments\n";
&check_args;


my $begin_regex = '^\s*\/\/\s*Perl sub:\s*([a-zA-Z]\w*)\s*$';
my $end_regex = '^\s*\/\/\s*Perl sub end:\s*([a-zA-Z]\w*)\s*$';
my $end_generation_regex = '^\s*\/\/\s*Perl sub generation end:\s*([a-zA-Z]\w*)\s*$';

# the subs founded in the input file
my @subs;
my %subs_info;

my @contents;
tie @contents, 'Tie::File', $opt_infile or die "Fail to tie to [$opt_infile]\n";


if (defined $opt_expand) {
    &expand_all;
}

if (defined $opt_clean) {
    &clean_all;
}


sub traverse {
    my $state = 0;
    # 0: idle
    # 1: found begin
    # 2: found end

    my $current_sub_name = "";
    my $lineno = 0;
    for my $line (@contents) {
        $lineno++;
        given ($state) {
            when(1) { # found begin
                unless ($line =~ /$end_regex/) {
                    push @{$subs_info{$current_sub_name}->{sub_contents}}, $line;
                    next;
                }
                die "Expect sub end of [$current_sub_name]. Get sub end of [$1]\n"
                    if ($1 ne $current_sub_name);
                $state = 2;
                $subs_info{$current_sub_name}->{end_lineno} = $lineno;
                $subs_info{$current_sub_name}->{valid} = 1;
            }
            when(2) { # found end
                given($line) {
                    when(/$end_generation_regex/) {
                        die "Expect sub generation end of [$current_sub_name]. Get sub generation end of [$1]\n"
                            if ($1 ne $current_sub_name);
                        $subs_info{$current_sub_name}->{expanded} = 1;
                        $subs_info{$current_sub_name}->{generation_end_lineno} = $lineno;
                        $current_sub_name = "";
                        $state = 0;
                    }
                    when(/$begin_regex/) {
                        die "Repeat definition of [$1]\n" if (defined $subs_info{$1});
                        $current_sub_name = $1;
                        my $idx = scalar(@subs);
                        push @subs, $current_sub_name;
                        $subs_info{$current_sub_name} = {
                            idx          => $idx,
                            valid        => 0,
                            expanded     => 0,
                            begin_lineno => $lineno,
                            sub_contents => [],
                        };
                        $state = 1;
                    }
                }
            }
            default {
                if ($line =~ /$begin_regex/) {
                    die "Repeat definition of [$1]\n" if (defined $subs_info{$1});
                    $current_sub_name = $1;
                    my $idx = scalar(@subs);
                    push @subs, $current_sub_name;
                    $subs_info{$current_sub_name} = {
                        idx          => $idx,
                        valid        => 0,
                        expanded     => 0,
                        begin_lineno => $lineno,
                        sub_contents => [],
                    };
                    $state = 1;
                }
            }
        }
    } # end for

    if ($debug_on) {
        print Dumper(\@subs);
        print Dumper(\%subs_info);
    }
}

# expand
#------------------------------------------------------------------------------#
sub expand_all {
    &traverse;
    for (my $i = $#subs; $i >= 0; $i--) {
        my $name = $subs[$i];
        my $info = $subs_info{$name};
        if ($info->{valid} and not $info->{expanded}) {
            &expand($name, $info);
        }
    }
}

sub expand {
    my ($name, $info) = (shift, shift);
    my @tmp_script;
    for (@{$info->{sub_contents}}) {
        $_ =~ s/^\s*\/\/ ?//;
        push @tmp_script, $_;
    }
    open FH, ">tmp.$name.pl" or die "Fail to create [tmp.$name.pl]\n";
    print FH "#!/bin/perl\n";
    print FH "use strict;\n";
    print FH join("\n", @tmp_script);
    close FH;
    
    chmod 0700, "tmp.$name.pl";
    system("./tmp.$name.pl > tmp.$name.output");
    

    open FH, "<tmp.$name.output" or die "Fail to open [tmp.$name.output]\n";
    my @tmp_output = <FH>;
    close FH;
    push @tmp_output, ("\n", "// Perl sub generation end: $name", "\n");
    system("rm -rf tmp.$name.pl tmp.$name.output");

    if (defined $opt_nochk) {
        splice @contents, $info->{end_lineno}, 0, @tmp_output;
    } else { # default print the output for checking
        print @tmp_output, "\n";
    }
}

# clean
#------------------------------------------------------------------------------#
sub clean_all {
    &traverse;
    for (my $i = $#subs; $i >= 0; $i--) {
        my $name = $subs[$i];
        my $info = $subs_info{$name};
        if ($info->{valid} and $info->{expanded}) {
            &clean($name, $info);
        }
    }
}

sub clean {
    my ($name, $info) = (shift, shift);
    my $clean_length = $info->{generation_end_lineno}-$info->{end_lineno};
    splice @contents, $info->{end_lineno}, $clean_length;
}

# check_args
#------------------------------------------------------------------------------#
sub check_args {
    if (defined $opt_expand and defined $opt_clean) {
        die "Can't use -e and -c at the same time\n";
    }
}