getopt.pm

Verilog Parser in Perl

# See copyright, etc in below POD section.
######################################################################

package Verilog::Getopt;
require 5.000;
require Exporter;

use strict;
use vars qw($VERSION $Debug %Skip_Basenames);
use Carp;
use IO::File;
use File::Basename;
use File::Spec;
use Cwd;

######################################################################
#### Configuration Section

$VERSION = '3.120';

# Basenames we should ignore when recursing directories,
# Because they contain large files of no relevance
foreach ( '.', '..',
	  'CVS',
	  '.svn',
	  '.snapshot',
	  'blib',
	  ) {
    $Skip_Basenames{$_} = 1;
}

#######################################################################
#######################################################################
#######################################################################

sub new {
    @_ >= 1 or croak 'usage: Verilog::Getopt->new ({options})';
    my $class = shift;		# Class (Getopt Element)
    $class ||= "Verilog::Getopt";

    my $self = {defines => {},
		incdir => ['.', ],
		module_dir => ['.', ],
		libext => ['.v', ],
		library => [ ],
		gcc_style => 1,
		vcs_style => 1,
		fileline => 'Command_Line',
		unparsed => [],
		define_warnings => 1,
		depend_files => {},
		@_
		};
    bless $self, $class;
    return $self;
}

#######################################################################
# Option parsing

sub parameter_file {
    my $self = shift;
    my $filename = shift;

    print "*parameter_file $filename\n" if $Debug;
    my $fh = IO::File->new("<$filename") or die "%Error: ".$self->fileline().": $! $filename\n";
    my $hold_fileline = $self->fileline();
    while (my $line = $fh->getline()) {
	chomp $line;
	$line =~ s/\/\/.*$//;
	next if $line =~ /^\s*$/;
	$self->fileline ("$filename:$.");
	my @p = (split /\s+/,"$line ");
	$self->_parameter_parse(@p);
    }
    $fh->close();
    $self->fileline($hold_fileline);
}

sub parameter {
    my $self = shift;
    # Parse VCS like parameters, and perform standard setup based on it
    # Return list of leftover parameters
    @{$self->{unparsed}} = ();
    $self->_parameter_parse(@_);
    return @{$self->{unparsed}};
}

sub _parameter_parse {
    my $self = shift;
    # Internal: Parse list of VCS like parameters, and perform standard setup based on it
    foreach my $param (@_) {
	next if ($param =~ /^\s*$/);
	print " parameter($param)\n" if $Debug;

	### GCC & VCS style
	if ($param eq '-f') {
	    $self->{_parameter_next} = $param;
	}

	### VCS style
	elsif (($param eq '-v'
		|| $param eq '-y') && $self->{vcs_style}) {
	    $self->{_parameter_next} = $param;
	}
	elsif ($param =~ /^\+libext\+(.*)$/ && $self->{vcs_style}) {
	    my $ext = $1;
	    foreach (split /\+/, $ext) {
		$self->libext($_);
	    }
	}
	elsif ($param =~ /^\+incdir\+(.*)$/ && $self->{vcs_style}) {
	    $self->incdir($1);
	}
	elsif (($param =~ /^\+define\+([^+=]*)[+=](.*)$/
		|| $param =~ /^\+define\+(.*?)()$/) && $self->{vcs_style}) {
	    $self->define ($1, $2);
	}
	# Ignored
	elsif ($param =~ /^\+librescan$/ && $self->{vcs_style}) {
	}

	### GCC style
	elsif (($param =~ /^-D([^=]*)=(.*)$/
		|| $param =~ /^-D([^=]*)()$/) && $self->{gcc_style}) {
	    $self->define($1,$2);
	}
	elsif (($param =~ /^-U([^=]*)$/) && $self->{gcc_style}) {
	    $self->undef($1);
	}
	elsif ($param =~ /^-I(.*)$/ && $self->{gcc_style}) {
	    $self->incdir($1);
	}

	# Second parameters
	elsif ($self->{_parameter_next}) {
	    my $pn = $self->{_parameter_next};
	    $self->{_parameter_next} = undef;
	    if ($pn eq '-f') {
		$self->parameter_file ($self->file_substitute($param));
	    }
	    elsif ($pn eq '-v') {
		$self->library ($param);
	    }
	    elsif ($pn eq '-y') {
		$self->module_dir ($param);
	    }
	    else {
		die "%Error: ".$self->fileline().": Bad internal next param ".$pn;
	    }
	}

	else { # Unknown
	    push @{$self->{unparsed}}, $param;
	}
    }
}

#######################################################################
# Accessors

sub fileline {
    my $self = shift;
    if (@_) { $self->{fileline} = shift; }
    return ($self->{fileline});
}
sub incdir {
    my $self = shift;
    if (@_) {
	my $token = shift;
	print "incdir $token\n" if $Debug;
	if (ref $token) {
	    @{$self->{incdir}} = @{$token};
	} else {
	    push @{$self->{incdir}}, $self->file_abs($token);
	}
	$self->file_path_cache_flush();
    }
    return (wantarray ? @{$self->{incdir}} : $self->{incdir});
}
sub libext {
    my $self = shift;
    if (@_) {
	my $token = shift;
	print "libext $token\n" if $Debug;
	if (ref $token) {
	    @{$self->{libext}} = @{$token};
	} else {
	    push @{$self->{libext}}, $token;
	}
	$self->file_path_cache_flush();
    }
    return (wantarray ? @{$self->{libext}} : $self->{libext});
}
sub library {
    my $self = shift;
    if (@_) {
	my $token = shift;
	print "library $token\n" if $Debug;
	if (ref $token) {
	    @{$self->{library}} = @{$token};
	} else {
	    push @{$self->{library}}, $self->file_abs($token);
	}
    }
    return (wantarray ? @{$self->{library}} : $self->{library});
}
sub module_dir {
    my $self = shift;
    if (@_) {
	my $token = shift;
	print "module_dir $token\n" if $Debug;
	if (ref $token) {
	    @{$self->{module_dir}} = @{$token};
	} else {
	    push @{$self->{module_dir}}, $self->file_abs($token);
	}
	$self->file_path_cache_flush();
    }
    return (wantarray ? @{$self->{module_dir}} : $self->{module_dir});
}
sub depend_files {
    my $self = shift;
    if (@_) {
	if (ref $_[0]) {
	    $self->{depend_files} = {};
	    foreach my $fn (@{$_[0]}) {
		$self->{depend_files}{$fn} = 1;
	    }
	} else {
	    foreach my $fn (@_) {
		print "depend_files $fn\n" if $Debug;
		$self->{depend_files}{$fn} = 1;
	    }
	}
    }
    my @list = (sort (keys %{$self->{depend_files}}));
    return (wantarray ? @list : \@list);
}

sub get_parameters {
    my $self = shift;
    my %args = (gcc_stlyle => $self->{gcc_style},);
    # Defines
    my @params = ();
    foreach my $def (sort (keys %{$self->{defines}})) {
	my $defvalue = $self->defvalue($def);
	$defvalue = "=".($defvalue||"") if (defined $defvalue && $defvalue ne "");
	if ($args{gcc_style}) {
	    push @params, "-D${def}${defvalue}";
	} else {
	    push @params, "+define+${def}${defvalue}";
	}
    }
    # Put all libexts on one line, else NC-Verilog will bitch
    my $exts="";
    foreach my $ext ($self->libext()) {
	$exts = "+libext" if !$exts;
	$exts .= "+$ext";
    }
    push @params, $exts if $exts;
    # Includes...
    foreach my $dir ($self->incdir()) {
	if ($args{gcc_style}) {
	    push @params, "-I${dir}";
	} else {
	    push @params, "+incdir+${dir}";
	}
    }
    foreach my $dir ($self->module_dir()) {
	push @params, "-y", $dir;
    }
    foreach my $dir ($self->library()) {
	push @params, "-v", $dir;
    }
    return (@params);
}

sub write_parameters_file {
    my $self = shift;
    my $filename = shift;
    # Write get_parameters to a file
    my $fh = IO::File->new(">$filename") or croak "%Error: $! writing $filename,";
    my @opts = $self->get_parameters();
    print $fh join("\n",@opts);
    $fh->close;
}

#######################################################################
# Utility functions

sub remove_duplicates {
    my $self = ref $_[0] && shift;
    # return list in same order, with any duplicates removed
    my @rtn;
    my %hit;
    foreach (@_) { push @rtn, $_ unless $hit{$_}++; }
    return @rtn;
}

sub file_skip_special {
    my $self = shift;
    my $filename = shift;
    $filename =~ s!.*[/\\]!!;
    return $Skip_Basenames{$filename};
}

sub file_abs {
    my $self = shift;
    my $filename = shift;
    # return absolute filename
    # If the user doesn't want this absolutification, they can just
    # make their own derived class and override this function.
    #
    # We don't absolutify files that don't have any path,
    # as file_path() will probably be used to resolve them.
    return $filename;
    return $filename if ("" eq dirname($filename));
    return $filename if File::Spec->file_name_is_absolute($filename);
    # Cwd::abspath() requires files to exist.  Too annoying...
    $filename = File::Spec->canonpath(File::Spec->catdir(Cwd::getcwd(),$filename));
    return $filename;
}

sub file_substitute {
    my $self = shift;
    my $filename = shift;
    my $out = $filename;
    while ($filename =~ /\$([A-Za-z_0-9]+)\b/g) {
	my $var = $1;
	if (defined $ENV{$var}) {
	    $out =~ s/\$$var\b/$ENV{$var}/g;
	}
    }
    return $out;
}

sub file_path_cache_flush {
    my $self = shift;
    # Clear out a file_path cache, needed if the incdir/module_dirs change
    $self->{_file_path_cache} = {};
}