File Coverage

blib/lib/ModelSim/List.pm

Criterion	Covered	Total	%
statement	125	140	89.2
branch	49	60	81.6
condition	13	15	86.6
subroutine	11	12	91.6
pod	5	5	100.0
total	203	232	87.5

package ModelSim::List;

use strict;
use warnings;

our $VERSION = '0.06';
our $error;

sub new ($) {
    my $class = ref $_[0] ? ref shift : shift;
    return bless {}, $class;
}

sub parse ($$) {
    my ($self, $file) = @_;
    my ($ast, $fh);
    unless(open $fh, $file) {
        $error = "file error - Can't open $file for reading: $!\n";
        return undef;
    }
    $_ = <$fh>;
    if (/^\@/o) {
        $ast = _parse_event_list($fh, $file);
    } else {
        $ast = _parse_normal_list($fh, $file);
    }
    close $fh;
    return undef unless $ast;
    %$self = %$ast;
    return 1;
}

sub _parse_normal_list ($$) {
    my ($fh, $file) = @_;
    my $ast = {};
    my (%cols, @cols);
    my $state = 0;
    do {{
        next if /^\s*$/o;
        if ($state == 0) {
            if (/\b\/\w+|\bdelta\b|\bns\b/o) {
                # process signal name list:
                while (/[\w\/]+/go) {
                    $cols{$+[0]} = $&;
                    #warn "$& - ", $+[0], "\n";
                }
            } else {
                # process the first data line:
                @cols = _sort_cols(%cols);
                undef %cols;
                _parse_data_line($ast, @cols);
                $state = 1;
            }
        } elsif ($state == 1) {
            # process data line:
            _parse_data_line($ast, @cols);
        } else {
            chomp;
            $error =  "file error - Syntax error: line $.: $_\n";
            return undef;
        }
    }} while (<$fh>);
    #die Data::Dumper->Dump([$ast], [qw(self)]);
    return $ast;
}

# used in sub _parse_normal_list:
sub _parse_data_line {
    my ($ast, @cols) = @_;
    s/^\s+//;
    my @data = split(/\s+/, $_);
    my $time = $data[0];
    for(my $i = 1; $i < @data; $i++) {
        my $sig = $cols[$i];
        my $val = $data[$i];
        #warn "@cols", " -> ", $sig, "\n";
        #warn "@data", " -> ", $val, "\n";
        next if $sig eq 'delta';
        $ast->{$sig} = [] unless ref $ast->{$sig};
        if (@{$ast->{$sig}} and ${$ast->{$sig}}[-2] eq $val) {
            next;
        }
        if (@{$ast->{$sig}} and ${$ast->{$sig}}[-1] eq $time) {
            ${$ast->{$sig}}[-2] = $val;
            next;
        }
        push @{$ast->{$sig}}, $val, $time;
    }
}

# used in sub _parse_normal_list:
sub _sort_cols {
    my %cols = @_;
    my @cols;
    foreach my $colnum (sort keys %cols) {
        push @cols, $cols{$colnum};
    }
    return @cols;
}

sub _parse_event_list {
    my ($fh, $file) = @_;
    my $ast = {};
    my $time;
    do {{
        next if /^\s*$/;
        if (/^\@(\d+)/) {
            $time = $1;
            next;
        }
        unless (defined $time) {
            $error = "file error - $file: Invalid file format\n";
            return undef;
        }
        if (/^([\w\/]+)\s+(\w+)\s*$/) {
            my ($sig, $val) = ($1, $2);
            $ast->{$sig} = [] unless ref $ast->{$sig};
            if (@{$ast->{$sig}} and ${$ast->{$sig}}[-1] eq $time) {
                ${$ast->{$sig}}[-2] = $val;
                next;
            }
            push @{$ast->{$sig}}, $val, $time;
            next;
        }
        $error = "file error - $file: Invalid file format\n";
        return undef;
    }} while (<$fh>);
    #die Data::Dumper->Dump([$ast], [qw(self)]);
    return $ast;
}

sub strobe {
    my ($self, $signal, $time) = @_;
    unless ($self->{$signal}) {
        $error = "strobe error - $signal: No such signal name.\n";
        return undef;
    }
    my @events = @{$self->{$signal}};
    if ($time < $events[1]) {
        $error = "strobe error - $signal: time $time underflow.\n";
        return undef;
    }
    my $value;
    while (@events) {
        my $val = shift @events;
        my $tm  = shift @events;

        if ($time < $tm) {
            return $value;
        } else {
            $value = $val;
        }
    }
    return $value;
}

sub _val_eq {
    my ($val, $pat) = @_;
    return $val =~ $pat if (ref($pat) eq 'Regexp');
    return $val eq $pat;
}

sub time_of {
    my ($self, $signal, $value, $start, $end) = @_;
    $start = 0 unless defined $start;
    if (defined $start and defined $end) {
        if ($start > $end) {
            $error = "time_of error - Starting time $start greater than the ".
                "ending time $end\n";
            return undef;
        }
    }
    unless ($self->{$signal}) {
        $error = "time_of error - $signal: No such signal name.\n";
        return undef;
    }
    my @events = @{$self->{$signal}};
    my $time;
    return $start if _val_eq($self->strobe($signal, $start), $value);
    while (@events) {
        my $val = shift @events;
        my $tm  = shift @events;

        if ($tm < $start) {
            next;
        }
        if (_val_eq $val, $value) {
            if (defined $end and $tm > $end) {
                $error = "time_of warning - $signal: Never achieved value $value ".
                    "during the time interval specified.\n";
                return undef;
            }
            return $tm;
        }
    }
    $error = "time_of warning - $signal: Never achieved value $value ".
        "during the time interval specified.\n";
    return undef;
}

# Return the error info:
sub error {
    return $error;
}

1;
__END__