File Coverage

blib/lib/Verilog/Netlist/Logger.pm
Criterion Covered Total %
statement 24 45 53.3
branch 4 8 50.0
condition 4 11 36.3
subroutine 7 12 58.3
pod 5 9 55.5
total 44 85 51.7


line stmt bran cond sub pod time code
1             # Verilog - Verilog Perl Interface
2             # See copyright, etc in below POD section.
3             ######################################################################
4              
5             package Verilog::Netlist::Logger;
6             require Exporter;
7 8     8   51 use vars qw($VERSION);
  8         13  
  8         353  
8 8     8   49 use strict;
  8         12  
  8         5159  
9              
10             $VERSION = '3.476';
11              
12             # We don't use Verilog::Netlist::Subclass, as this is called from it!
13              
14             ######################################################################
15             #### Constructors
16              
17             sub new {
18 213     213 0 407 my $class = shift;
19 213         1115 my $self = {
20             _warnings => 0,
21             _errors => 0,
22             _error_unlink_files => {},
23             @_
24             };
25 213         473 bless $self, $class;
26 213         2803 return $self;
27             }
28              
29             ######################################################################
30             #### Accessors
31              
32             sub errors {
33 219     219 0 316 my $self = shift;
34 219 50       620 $self->{_errors} = shift if $#_>=0;
35 219         1243 return $self->{_errors};
36             }
37             sub warnings {
38 219     219 0 382 my $self = shift;
39 219 50       480 $self->{_warnings} = shift if $#_>=0;
40 219         564 return $self->{_warnings};
41             }
42              
43             ######################################################################
44             #### Error Handling
45              
46             sub info {
47 0     0 1 0 my $self = shift;
48 0         0 my $objref = shift;
49 0         0 CORE::warn "-Info: ".$objref->fileline.": ".join('',@_);
50             }
51              
52             sub warn {
53 0     0 1 0 my $self = shift;
54 0         0 my $objref = shift;
55 0         0 CORE::warn "%Warning: ".$objref->fileline.": ".join('',@_);
56 0         0 $self->warnings($self->warnings+1);
57             }
58              
59             sub error {
60 0     0 1 0 my $self = shift;
61 0         0 my $objref = shift;
62 0         0 CORE::warn "%Error: ".$objref->fileline.": ".join('',@_);
63 0         0 $self->errors($self->errors+1);
64             }
65              
66             sub exit_if_error {
67 8     8 1 24 my $self = shift;
68 8         21 my %params = @_;
69 8   50     44 my $allow = $params{allow} || "";
70 8 50 33     31 if ($self->errors || ($self->warnings && $allow !~ /warning/)) {
      33        
71 0         0 CORE::warn "Exiting due to errors\n";
72 0         0 exit(10);
73             }
74 8         22 return ($self->errors + $self->warnings);
75             }
76              
77             sub unlink_if_error {
78 0     0 1 0 my $self = shift;
79 0         0 $self->{_error_unlink_files}{$_[0]} = 1;
80             }
81              
82             sub error_unlink {
83 0     0 0 0 my $self = shift;
84 0         0 foreach my $file (keys %{$self->{_error_unlink_files}}) {
  0         0  
85 0         0 unlink $file;
86 0         0 delete $self->{_error_unlink_files}{$file};
87             }
88             }
89              
90             sub DESTROY {
91 203     203   378 my $self = shift;
92 203   33     1183 my $has_err = $? || $self->errors || $self->warnings;
93 203 50       1208 if ($has_err) {
94 0           $self->error_unlink;
95             }
96             }
97              
98             ######################################################################
99             #### Package return
100             1;
101             __END__