File Coverage

blib/lib/Hardware/Vhdl/Lexer.pm

Criterion	Covered	Total	%
statement	72	75	96.0
branch	52	54	96.3
condition	2	3	66.6
subroutine	16	17	94.1
pod	2	3	66.6
total	144	152	94.7

package Hardware::Vhdl::Lexer;

use Class::Std;
use Carp;
use Readonly;
use strict;
use warnings;
#use diagnostics;

=for To do:
'use charnames' instead of \012 and \015
test get_nhistory and get_linesource
use regexp-generating module for number-matching regexps

=cut

our $VERSION = "1.00";

# Create storage for object attributes...
my %nhistory    :ATTR( :default<1>       :get   :init_arg );
my %linesource  :ATTR( :default   :get  );
my %line        :ATTR( :default                     );
my %source_func :ATTR;
my %history     :ATTR;

sub START {
    my ($self, $obj_ID, $arg_ref) = @_;
    my $class = ref($self);

    # check that a linesource was specified
    croak "$class constructor requires a linesource to be specified"
        if !defined $arg_ref->{linesource};

    {
        my $sourcetype = ref $arg_ref->{linesource};
	# store the source of lines as a subroutine reference
	$source_func{$obj_ID} =
        $sourcetype eq q{}      ? croak "${class}->new 'linesource' parameter is not of a valid type (it is not a reference)" :
        $sourcetype eq 'GLOB'   ? sub { readline( $arg_ref->{linesource} ) }  :
        $sourcetype eq 'ARRAY'  ? _arrayref_to_sub($arg_ref->{linesource})      :
        $sourcetype eq 'SCALAR' ? _scalarref_to_sub($arg_ref->{linesource})     :
        $sourcetype eq 'CODE'   ?  $arg_ref->{linesource}                       :
        #~ $sourcetype ne 'REF' &&
        eval "$sourcetype->can('get_next_line')"
                                ? sub { $arg_ref->{linesource}->get_next_line } :
                                  croak "${class}->new 'linesource' parameter is not of a valid type (type is '$sourcetype')";

    }

    # set up initial history values
    for my $i ( 1 .. $self->get_nhistory ) { $history{$obj_ID}->[ $i - 1 ] = q{} }
    #@{ $history{$obj_ID} } = q{} x $self->get_nhistory;

    pos($line{$obj_ID}) = 0;

    return $self;
}

sub _arrayref_to_sub {
    # given an array ref, return a ref to a sub which returns the lines in sequence and then returns undef
    my $array_ref = shift;
    my $i = 0;
    return sub {
        return $array_ref->[ $i++ ];
    };
}

sub _scalarref_to_sub {
    # given a scalar ref, return a ref to a sub which returns the line and then returns undef
    my $scalar_ref = shift;
    my $i = 0;
    return sub {
        return $i++ == 0 ? ${ $scalar_ref } : undef;
    };
}

# after use charnames qw( :full );
#  \N{CR} is character 13 = 015
#  \N{LF} is character 10 = 012
#my $NEW_LINE           = qr/ \N{CR}\N{LF}? | \N{LF}\N{CR}? /xms;
my Readonly $NEW_LINE           = qr/ \015\012? | \012\015? /xms;
my Readonly $WHITESPACE         = qr/ [^\S\012\015]+ /xms;
my Readonly $COMMENT            = qr/ -- [^\015\012]* /xms;
my Readonly $BIT_VECTOR_LITERAL = qr/ [BOX] ".+?" /xms;
my Readonly $BASED_NUMBER       = qr/
                             (?: [23456789] | 1[0123456] ) # the base (2-16)
                             \# [\d_A-F]+ \#               # the number
                           /xmsi;
my Readonly $BASE10_REAL        = qr/ -? \d [\d_]* (?: \. \d*)? (?: E -? \d+)? /xmsi;
my Readonly $IDENTIFIER         = qr/ (?: \\ [^\\]+ \\) | (?: \w+ ) /xms;
my Readonly $PUNCTUATION        = qr{
                              [:<>/]= | => | <> | \*\* # 2-character punctuations
                              | [ \.\,\+\-\*\=\:\;\&\'\(\)\<\>\|\/ ]
                            }xms;
my Readonly $DBL_QUOTED         = qr/
                              "          # opening quote
                              .*?        # contents of the quotes
                              (?
                              (?:\\\\)*  # an even number of backslashes
                              "          # closing quote
                           /xms;
my Readonly $CHAR_LITERAL       = qr/
    '.'              # a character in single-quotes
    (?=              # followed by...
        (?: .'.' )*  # any number of following character literals
        (?! .'   )   # without leaving us with an unmatched single-quote
        .*           # and anything that follows
    )
  /xms;

sub _as_str :STRINGIFY {
    my $self = shift;
    return scalar $self->get_next_token();
}

sub get_next_token {
    my $self = shift;
    my $obj_ID = ident $self;

    # get another line from the line-source if needed
    if ( defined $line{$obj_ID} && pos($line{$obj_ID}) >= length $line{$obj_ID} ) {
        $line{$obj_ID} = &{ $source_func{$obj_ID} };
        pos($line{$obj_ID}) = 0 if defined $line{$obj_ID};
    }
    # an undef line means the end of the VHDL source - no more tokens
    return if !defined $line{$obj_ID};

    my ($token, $match) =
        $line{$obj_ID} =~ m/\G ($NEW_LINE)           /gcxms ? ($1, 'wn') : # newline
        $line{$obj_ID} =~ m/\G ($WHITESPACE)         /gcxms ? ($1, 'ws') : # whitespace
        substr( $line{$obj_ID}, pos($line{$obj_ID}), 1 ) eq q{"}
                                      ? ($self->_dquoted_string(), 'cs') : # string literal
        $line{$obj_ID} =~ m/\G ($COMMENT)            /gcxms ? ($1, 'r' ) : # comment
        $line{$obj_ID} =~ m/\G ($CHAR_LITERAL)       /gcxms ? ($1, 'cc') : # single-character literal
        $line{$obj_ID} =~ m/\G ($BIT_VECTOR_LITERAL) /gcxms ? ($1, 'cb') : # bit_vector literal
        $line{$obj_ID} =~ m/\G ($BASED_NUMBER)       /gcxms ? ($1, 'cn') : # specified-base integer numeric literal
        $line{$obj_ID} =~ m/\G ($BASE10_REAL)        /gcxms ? ($1, 'cn') : # base-10 numeric literal
        $line{$obj_ID} =~ m/\G ($IDENTIFIER)         /gcxms ? ($1, 'ci') : # extended identifier or keyword
        $line{$obj_ID} =~ m/\G ($PUNCTUATION)        /gcxms ? ($1, 'cp') : # punctuation
        $line{$obj_ID} =~ m/\G (.)                   /gcxms ? ($1, 'cu') : # unexpected character
                    croak "Internal error (token failed to match anything): "
                        . "Please file a bug report, showing what input caused this error\n";

    if ( substr( $match, 0, 1 ) eq 'c' ) {

        # not whitespace or comment, so add it to the code history
        push @{ $history{$obj_ID} }, $token;
        while ( @{ $history{$obj_ID} } > $self->get_nhistory ) {
            shift @{ $history{$obj_ID} };
        }
    }

    return wantarray ? ( $token, $match ) : $token;
}

sub _dquoted_string {
    my $self = shift;
    my $obj_ID = ident $self;
    # this method should only be called when we already know we have an open-quote at the match-start point of $line{$obj_ID}
    while (1) {
        if ( $line{$obj_ID} =~ /\G ($DBL_QUOTED) /gcxms ) {
            return $1;
        }

        # can't match a closing quote - get another line from the source
        my $nextline = &{ $source_func{$obj_ID} };
        if ( !defined $nextline ) {
            # reached EOF without finding closing quote: we're done
            my $start_pos = pos $line{$obj_ID};
            pos $line{$obj_ID} = length $line{$obj_ID};
            return substr $line{$obj_ID}, $start_pos;
        }
        $line{$obj_ID} .= $nextline;
    }
}

sub history {
    my $self = shift;
    my $age  = shift;
    my $obj_ID = ident $self;

    croak "more (" . ( $age + 1 ),
        ") history requested than has been stored ("
        . ( $nhistory{$obj_ID} ) . ")"
        if $age >= @{ $history{$obj_ID} };
    return $history{$obj_ID}->[ -1 - $age ];
}

1;    # End of Hardware::Vhdl::Lexer

__END__