File Coverage

blib/lib/Hardware/Vhdl/Tidy.pm

Criterion	Covered	Total	%
statement	141	197	71.5
branch	88	120	73.3
condition	53	102	51.9
subroutine	12	13	92.3
pod	3	3	100.0
total	297	435	68.2

package Hardware::Vhdl::Tidy;

# TO DO:
#  Tidier directives in source code to set stack
#  setting to control whether we include whitespace at start of empty lines
#  check whether there are any other 'loop' forms
#  put underscore at start of names of internal routines
#  implement PBP generally

use Hardware::Vhdl::Lexer;
use Getopt::Long;
use Carp;
use Exporter 'import';

use strict;
use warnings;

sub parse_commandline;
sub tidy_vhdl_file;
sub tidy_vhdl;

our $VERSION = 0.80;

#our @EXPORT=();
our @EXPORT_OK=qw/ tidy_vhdl_file tidy_vhdl /;

our $debug = 0;

our %default_args = (
    indent_spaces        => 4, # integer value, >= 0
    cont_spaces          => 2, # integer value, >= 0
    tab_spaces           => 0, # integer value, >= 0
    starting_indentation => 0, # integer value, >= 0
    preprocessor_prefix  => '#', # string
    indent_preprocessor  => 0, # boolean
);

sub parse_commandline {
    # parse command-line args
    # for example, for an in-place tidy of a vhd file:
    #   perl -MHardware::Vhdl::Tidy -e "Hardware::Vhdl::Tidy::parse_commandline" -- -b <$file>
    my $inplace = 0;
    my $bext    = '.bak';
    my %args    = %default_args;
    my $result  = GetOptions(
        "b"      => \$inplace,
        "bext=s" => \$bext,
        "i|indentation=i" => \$args{indent_spaces},
        "ci|continuation-indentation=i" => \$args{cont_spaces},
        "t|tab_spaces=i" => \$args{tab_spaces},
        "sil|starting-indentation-level=i" => \$args{starting_indentation},
        "ppp|preprocessor-prefix=s" => \$args{preprocessor_prefix},
        "ipp|indent-preprocessor" => \$args{indent_preprocessor},
    );

    # any args not matched are taken to be input filenames
    for my $afile (@ARGV) {
        if ($inplace) {
            # change in-place: rename the original file and then make the old filename the destination
            rename $afile, $afile . $bext || die "Could not rename $afile: $!\n";
            tidy_vhdl_file( source => $afile . $bext, destination => $afile, %args );
        } else {
            # not in-place: output to STDOUT
            tidy_vhdl_file( source => $afile, %args );
        }
    }

    return;
}

sub tidy_vhdl_file {
    # reads from STDIN if source filename not specified
    # writes to STDOUT if destination filename not specified
    my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

    my $fhi;
    if ( defined $args{source} ) {
        open $fhi, '<', $args{source} || die "Could not read $args{source}: $!\n";
    } else {
        open $fhi, '-' || die "Could not read from STDIN: $!\n";
    }
    binmode $fhi;
    $args{source} = $fhi;

    my $fho;
    if ( defined $args{destination} ) {
        open $fho, '>', $args{destination} || die "Could not write $args{destination}: $!\n";
    } else {
        open $fho, '>-' || die "Could not write to STDOUT: $!\n";
    }
    binmode $fho;
    $args{destination} = $fho;

    eval {
        tidy_vhdl(\%args);
    };
    if ($@) {
        my $err=$@;
        $err =~ s/ tidy_vhdl /tidy_vhdl_file/xmsg;
        croak $err;
    }
    return;
}

#                   label   is  name    end_t   end_name/label
# entity            n       y   y       o       o
# architecture      n       y   y       o       o
# configuration     n       y   y       o       o
# package [body]    n       y   y       o       o
# function          n       y   y       o       o
# procedure         n       y   y       o       o

# component         n       o   y       y       o
# for (in config)   n       n   u       y       n

# case              o       y   n       y       o
# process           o       o   n       y       o
# if (...then)      o       n   n       y       o
# for (...loop)     o       n   n       y       o
# loop              o       n   n       y       o

# block             y       o   n       y       o
# if (...generate)  y       n   n       y       o
# for (...generate) y       n   n       y       o

# NB: functions can be marked as pure or impure
#   processes can be marked as postponed

sub tidy_vhdl {
    # parse and check arguments
    my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
    croak "tidy_vhdl requires a 'source' parameter"      unless defined $args{source};
    croak "tidy_vhdl requires a 'destination' parameter" unless defined $args{destination};
    for my $opt (keys %default_args) {
        if ( !defined $args{$opt} ) { $args{$opt} = $default_args{$opt} }
    }

    my $output_func;
    {
        my $outobj  = $args{destination};
        my $outtype = ref $outobj;
        if ( $outtype eq q{} ) {
            croak "tidy_vhdl 'destination' parameter is not of a valid type (it is not a reference)";
        } elsif ( $outtype eq 'GLOB' ) {
            $output_func = sub { print $outobj shift }
        } elsif ( $outtype eq 'SCALAR' ) {
            $output_func = sub { $$outobj .= shift }
        } elsif ( $outtype eq 'ARRAY' ) {
            $output_func = sub { push @$outobj, shift }
        } elsif ( $outtype eq 'CODE' ) {
            $output_func = $outobj;
        } elsif (eval {$outobj->can('addtokens')} && !$@) {
            $output_func = sub { $outobj->addtokens(shift) }
        } else {
            croak "tidy_vhdl 'destination' parameter is not of a valid type (type is '$outtype')";
        }
    }

    my $lexer;
    eval {
        $lexer = Hardware::Vhdl::Lexer->new({ linesource => $args{source} });
    };
    if ($@) {
        my $err=$@;
        $err =~ s/ Hardware::Vhdl::Lexer->new /tidy_vhdl/xmsg;
        $err =~ s/ linesource /source/xmsg;
        croak $err;
    }

    my $indent = $args{starting_indentation}; # current indentation level
    my $bracks = 0;   # how many () brackets deep are we?
    my $line = '';    # current line of code tokens (a syntax line, nothing to do with newlines)
    my @stack;        # a list of the indented things we are inside
    my $ln = 1;       # source line num
    my @outline;      # list of tokens to go on the output line
    my ( $token, $type );
    while ( ( ( $token, $type ) = $lexer->get_next_token ) && defined $type ) {
        #print "\n# input token type $type, '".&escape($token)."'\n";
        my $indnext   = 0;
        my $bracknext = 0;
        my $linestart = $line eq '';                  # is this the first token of a syntax line?
        my $toplevel  = @stack ? $stack[0][0] : '';
        my $botlevel  = @stack ? $stack[-1][0] : '';
        if ( substr( $type, 0, 1 ) eq 'c' ) {
            if ( @outline == 0 && $args{preprocessor_prefix} ne '' && substr($token,0,length $args{preprocessor_prefix}) eq $args{preprocessor_prefix}) {
                # this is a preprocessor line: don't attempt to understand it, just emit the whole line unchanged
                my $t;
                while ( ( ( $t, $type ) = $lexer->get_next_token ) && defined $type) {
                    my $lastchar = substr($token, -1, 1);
                    $token .= $t;
                    if ($type eq 'wn') {
                        if ($lastchar eq "\\") {
                            $ln++;
                        }
                        else {
                            last;
                        }
                    }
                }
                $type = 'pp';
            }
            elsif ( $token eq '(' ) { push @stack, [ '(', $ln ]; $indnext = 1; $bracknext = 1 }
            elsif ( $token eq ')' ) { pop @stack; $indent--; $bracks-- }
            elsif ( $bracks == 0 ) {
                my $lctoken = lc $token;
                $line .= ( $lctoken =~ m!^\\.*\\$! ) ? 'xid ' : $lctoken . ' ';

                if ( $lctoken eq ';' ) {
                    if (
                        # configuration spec: 'for' closed by a ';' rather than an 'end'
                        ( $toplevel eq 'architecture' && $line =~ /^for .* : / )
                        # a function declaration is completed by "return ;"
                        || ( $line =~ /^(pure |impure |)function \S+ return .* ; $/ && $line !~ / is / )
                        # a procedure declaration is completed by a ";" after the procedure name and optional parameter list
                        || ( $line =~ /^procedure \S+ ; $/ )
                        # an access type declaration is closed by a ';'
                        || ( $botlevel eq 'type-access')
                      ) {
                        pop @stack;
                        $indnext--;
                    }
                    # semicolon always finishes a syntax line
                    $line = '';
                }

                # standard 'end' completes an indented section
                elsif ( $lctoken eq 'end' && $linestart ) {
                    if ( $botlevel eq 'case=>' ) { pop @stack; $indent--; }
                    pop @stack;
                    $indent--;
                }

                # 'begin' and 'elsif' give a temporary outdent, and finish a syntax line
                elsif ( $lctoken =~ /^(begin|elsif)$/ ) { $indent--; $indnext = 1; $line = ''; $linestart = 1; }
                # 'else' gives a temporary outdent, but check we are in an if/then rather than a "x<=y when..."
                elsif ( $lctoken eq 'else' && @stack && $botlevel eq 'if' ) {
                    $indent--;
                    $indnext = 1;
                    $line    = '';
                }

                # 'is' finishes a syntax line if associated with an indenting token that takes an 'is'
                elsif (    $lctoken eq 'is'
                    && $line =~
                    /^ (entity|architecture|configuration|package|((im)?pure \s )?function|procedure) \s /xms ) {
                    $line = '';
                } elsif ( $lctoken eq 'is' && $line =~ /^(\S+ : )?case / ) {
                    $line = '';
                } elsif (  $lctoken ne 'is'
                    && $line =~ /^ (\S+ \s : \s )?(component|block|(postponed \s )?process) \s (is \s )?\S+ \s $/xms ) {
                    # this is meant to deal with the case where an optional 'is' is missing -
                    #  but it also messes up recognition of component instantiations with the 'component' keyword included
                    $linestart = 1;
                    $line      = $lctoken . ' ';
                }
                # 'loop' finishes a syntax line if associated with an indenting 'for' or 'while'
                elsif ( $lctoken eq 'loop' && $line =~ /^(\S+ : )?(for|while) / ) {
                    $line = '';
                }
                # in a configuration declaration or specification, a 'use' starts a new syntax line
                elsif ( $lctoken eq 'use' ) { $linestart = 1 }
                # 'then' or 'generate' finishes a syntax line
                elsif ( $lctoken =~ /^ (then|generate) $/xms ) { $line = '' }

                # in a configuration declaration, a 'for' always starts a new syntax line and indents,
                #  unless it's an 'end for';
                elsif (    $lctoken eq 'for'
                    && $toplevel eq 'configuration'
                    && $line !~ /^end for $/
                    && $line !~ / end for $/ ) {
                    push @stack, [ $lctoken, $ln, $2 ];
                    $indnext   = 1;
                    $linestart = 1;
                    $line      = 'for ';
                }
                # endable, indenting keywords which start a syntax line (optional label allowed)
                elsif ( $lctoken =~ /^(case|if|for|while|loop)$/ && $line =~ /^((\S+) : )?\S+ $/ ) {
                    push @stack, [ $lctoken, $ln, $2 ];
                    $indnext = 1;
                    if ($lctoken eq 'loop') { $line = '' }
                } elsif ( $lctoken eq 'process' && $line =~ /^((\S+) : )?(postponed )?process $/ ) {
                    push @stack, [ $lctoken, $ln, $2 ];
                    $indnext = 1;
                }

                # code to be executed when a case option is matched
                elsif ( $lctoken eq '=>' && $botlevel eq 'case' && $line =~ /^when / ) {
                    push @stack, [ 'case=>', $ln ];
                    $indnext = 1;
                    $line    = '';
                }
                # the end of the code to be executed when a case option is matched, start of another option
                elsif ( $lctoken eq 'when' && $linestart && $botlevel eq 'case=>' ) {
                    pop @stack;
                    $indent--;
                }

                # endable, indenting keywords which start a syntax line (no label allowed)
                elsif ( $line =~ /^(im)?pure function $/ ) { push @stack, [ $lctoken, $ln ]; $indnext = 1; }
                elsif ( $lctoken =~
                    /^(entity|architecture|configuration|package|function|procedure|component|units)$/
                    && $linestart ) {
                    push @stack, [ $lctoken, $ln ];
                    $indnext = 1;
                }
                # endable, indenting keywords which start a syntax line (label required)
                elsif ( $lctoken =~ /^(block)$/ && $line =~ /^(\S+) : \S+ $/ ) {
                    push @stack, [ $lctoken, $ln, $1 ];
                    $indnext = 1;
                }

                elsif ( $line =~ /^type / && $lctoken =~ /^(access|units|record)$/) {
                    push @stack, [ 'type-'.$lctoken, $ln, $1 ];
                    $indnext = 1;
                    $line    = '';
                }

            }

            if ( $indent < 0 ) { $indent = 0; warn "negative indent, source line $ln" }
            if ( $bracks < 0 ) { $bracks = 0; warn "negative bracket count, source line $ln" }

            if ( $debug & 1 ) {
                # debug dump
                print "# ";
                print "    " x $indent;
                print "  " if $bracks == 0 && !$linestart;
                print $token;
                print " \t\t\tstart=$linestart stack=" . join( ', ', map { $_->[0] . '@' . $_->[1] } @stack );
                print " line='$line'";
                print "\n";
            }
        }

        if ( @outline == 0 ) {
            if ( $type ne 'ws' ) {
                #print "# emitting indent and token '".&escape($token)."'\n";
                if ($type eq 'pp' && !$args{indent_preprocessor}) {
                    # preprocessor command: left-align
                    @outline = ( $token );
                } else {
                    # work out the number of spaces to indent by
                    my $nsp = $indent * $args{indent_spaces};
                    $nsp += $args{cont_spaces} if $bracks == 0 && !$linestart;
                    # create a tab+space sequence to give the correct indent
                    my $ws;
                    if ( $args{tab_spaces} > 0 ) {
                        $ws = ( "\t" x int( $nsp / $args{tab_spaces} ) ) . ( ' ' x ( $nsp % $args{tab_spaces} ) );
                    } else {
                        $ws = ' ' x $nsp;
                    }
                    @outline = ( $ws, $token );
                }
            }
        } else {
            #print "# emitting token '".&escape($token)."'\n";
            push @outline, $token;
        }
        if ( $type =~ /^(wn|pp)$/ ) {
            &$output_func( join( '', @outline ) );
            $ln++;
            @outline = ();
        }

        $indent += $indnext;
        $bracks += $bracknext;
    }
    &$output_func( join( '', @outline ) ) if @outline;
    print "\n" if $debug;
    return;
}

1;

__END__