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   44 use vars qw($VERSION);
  8         11  
  8         374  
8 8     8   48 use strict;
  8         21  
  8         4098  
9              
10             $VERSION = '3.480';
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 347 my $class = shift;
19 213         979 my $self = {
20             _warnings => 0,
21             _errors => 0,
22             _error_unlink_files => {},
23             @_
24             };
25 213         455 bless $self, $class;
26 213         2410 return $self;
27             }
28              
29             ######################################################################
30             #### Accessors
31              
32             sub errors {
33 219     219 0 305 my $self = shift;
34 219 50       527 $self->{_errors} = shift if $#_>=0;
35 219         1060 return $self->{_errors};
36             }
37             sub warnings {
38 219     219 0 303 my $self = shift;
39 219 50       458 $self->{_warnings} = shift if $#_>=0;
40 219         523 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 11 my $self = shift;
68 8         16 my %params = @_;
69 8   50     34 my $allow = $params{allow} || "";
70 8 50 33     28 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         18 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   369 my $self = shift;
92 203   33     1007 my $has_err = $? || $self->errors || $self->warnings;
93 203 50       2289 if ($has_err) {
94 0           $self->error_unlink;
95             }
96             }
97              
98             ######################################################################
99             #### Package return
100             1;
101             __END__