File Coverage

blib/lib/Mail/Reporter.pm
Criterion Covered Total %
statement 92 103 89.3
branch 34 42 80.9
condition 7 16 43.7
subroutine 20 22 90.9
pod 12 13 92.3
total 165 196 84.1


line stmt bran cond sub pod time code
1             # Copyrights 2001-2021 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Reporter;
10 53     53   1904 use vars '$VERSION';
  53         121  
  53         2658  
11             $VERSION = '3.011';
12              
13              
14 53     53   355 use strict;
  53         97  
  53         1288  
15 53     53   277 use warnings;
  53         111  
  53         1952  
16              
17 53     53   425 use Carp;
  53         122  
  53         4480  
18 53     53   476 use Scalar::Util 'dualvar';
  53         114  
  53         37849  
19              
20              
21             my @levelname = (undef, qw(DEBUG NOTICE PROGRESS WARNING ERROR NONE INTERNAL));
22              
23             my %levelprio = (ERRORS => 5, WARNINGS => 4, NOTICES => 2);
24             for(my $l = 1; $l < @levelname; $l++)
25             { $levelprio{$levelname[$l]} = $l;
26             $levelprio{$l} = $l;
27             }
28              
29             sub new(@)
30 728     728 1 7454 { my $class = shift;
31             #confess "Parameter list has odd length: @_" if @_ % 2;
32 728         4933 (bless {MR_log => 1, MR_trace => 1}, $class)->init({@_});
33             }
34              
35             my($default_log, $default_trace, $trace_callback);
36             sub init($)
37 710     710 0 1288 { my ($self, $args) = @_;
38 710   66     6321 $self->{MR_log} = $levelprio{$args->{log} || $default_log};
39 710   66     2547 $self->{MR_trace} = $levelprio{$args->{trace} || $default_trace};
40 710         1577 $self;
41             }
42              
43             #------------------------------------------
44              
45              
46             sub _trace_warn($$$)
47 2     2   4 { my ($who, $level, $text) = @_;
48 2         17 warn "$level: $text\n";
49             }
50              
51             sub defaultTrace(;$$)
52 58     58 1 6087 { my $thing = shift;
53              
54 58 100       293 return ($default_log, $default_trace)
55             unless @_;
56              
57 57         105 my $level = shift;
58 57 50       165 my $prio = $thing->logPriority($level)
59             or croak "Unknown trace-level $level.";
60              
61 57 100       246 if( ! @_)
    100          
62 54         117 { $default_log = $default_trace = $prio;
63 54         121 $trace_callback = \&_trace_warn;
64             }
65             elsif(ref $_[0])
66 1         4 { $default_log = $thing->logPriority('NONE');
67 1         3 $default_trace = $prio;
68 1         2 $trace_callback = shift;
69             }
70             else
71 2         5 { $default_log = $prio;
72 2         4 $default_trace = $thing->logPriority(shift);
73 2         6 $trace_callback = \&_trace_warn;
74             }
75              
76 57         167 ($default_log, $default_trace);
77             }
78              
79             __PACKAGE__->defaultTrace('WARNINGS');
80              
81             #------------------------------------------
82              
83              
84             sub trace(;$$)
85 4     4 1 1606 { my $self = shift;
86              
87             return $self->logPriority($self->{MR_trace})
88 4 100       14 unless @_;
89              
90 1         2 my $level = shift;
91 1 50       5 my $prio = $levelprio{$level}
92             or croak "Unknown trace-level $level.";
93              
94 1         5 $self->{MR_trace} = $prio;
95             }
96              
97             #------------------------------------------
98              
99              
100             # Implementation detail: the Mail::Box::Parser::C code avoids calls back
101             # to Perl by checking the trace-level itself. In the perl code of this
102             # module however, just always call the log() method, and let it check
103             # whether or not to display it.
104              
105             sub log(;$@)
106 42     42 1 5363 { my $thing = shift;
107              
108 42 100       122 if(ref $thing) # instance call
109             { return $thing->logPriority($thing->{MR_log})
110 40 100       135 unless @_;
111              
112 37         55 my $level = shift;
113 37 50       127 my $prio = $levelprio{$level}
114             or croak "Unknown log-level $level";
115              
116 37 50       80 return $thing->{MR_log} = $prio
117             unless @_;
118              
119 37         93 my $text = join '', @_;
120             $trace_callback->($thing, $level, $text)
121 37 100       109 if $prio >= $thing->{MR_trace};
122 53     53   952 use Carp;
  53         166  
  53         45472  
123 37 50       99 $thing->{MR_trace} or confess;
124              
125 6         14 push @{$thing->{MR_report}[$prio]}, $text
126 37 100       111 if $prio >= $thing->{MR_log};
127             }
128             else # class method
129 2         5 { my $level = shift;
130 2 50       10 my $prio = $levelprio{$level}
131             or croak "Unknown log-level $level";
132              
133 2 100       12 $trace_callback->($thing, $level, join('',@_))
134             if $prio >= $default_trace;
135             }
136              
137 39         93 $thing;
138             }
139              
140              
141             #------------------------------------------
142              
143              
144             sub report(;$)
145 11     11 1 731 { my $self = shift;
146 11   50     23 my $reports = $self->{MR_report} || return ();
147              
148 11 100       32 if(@_)
149 7         10 { my $level = shift;
150 7 50       13 my $prio = $levelprio{$level}
151             or croak "Unknown report level $level.";
152              
153 7 50       15 return $reports->[$prio] ? @{$reports->[$prio]} : ();
  7         35  
154             }
155              
156 4         6 my @reports;
157 4         10 for(my $prio = 1; $prio < @$reports; $prio++)
158 20 100       35 { next unless $reports->[$prio];
159 9         12 my $level = $levelname[$prio];
160 9         9 push @reports, map { [ $level, $_ ] } @{$reports->[$prio]};
  12         30  
  9         17  
161             }
162              
163 4         10 @reports;
164             }
165              
166             #-------------------------------------------
167              
168              
169             sub addReport($)
170 8     8 1 23 { my ($self, $other) = @_;
171 8   100     31 my $reports = $other->{MR_report} || return ();
172              
173 1         4 for(my $prio = 1; $prio < @$reports; $prio++)
174 5 100       10 { push @{$self->{MR_report}[$prio]}, @{$reports->[$prio]}
  3         4  
  3         7  
175             if exists $reports->[$prio];
176             }
177 1         2 $self;
178             }
179            
180             #-------------------------------------------
181              
182              
183             sub reportAll(;$)
184 2     2 1 1691 { my $self = shift;
185 2         5 map { [ $self, @$_ ] } $self->report(@_);
  8         17  
186             }
187              
188             #-------------------------------------------
189              
190              
191 1     1 1 2540 sub errors(@) {shift->report('ERRORS')}
192              
193             #-------------------------------------------
194              
195              
196 1     1 1 3 sub warnings(@) {shift->report('WARNINGS')}
197              
198             #-------------------------------------------
199              
200              
201             sub notImplemented(@)
202 0     0 1 0 { my $self = shift;
203 0   0     0 my $package = ref $self || $self;
204 0         0 my $sub = (caller 1)[3];
205              
206 0         0 $self->log(ERROR => "Package $package does not implement $sub.");
207 0         0 confess "Please warn the author, this shouldn't happen.";
208             }
209              
210             #------------------------------------------
211              
212              
213             sub logPriority($)
214 71 100   71 1 3302 { my $level = $levelprio{$_[1]} or return undef;
215 69         566 dualvar $level, $levelname[$level];
216             }
217              
218             #-------------------------------------------
219              
220              
221             sub logSettings()
222 128     128 1 229 { my $self = shift;
223 128         739 (log => $self->{MR_log}, trace => $self->{MR_trace});
224             }
225              
226             #-------------------------------------------
227              
228              
229             sub AUTOLOAD(@)
230 0     0   0 { my $thing = shift;
231 0         0 our $AUTOLOAD;
232 0   0     0 my $class = ref $thing || $thing;
233 0         0 (my $method = $AUTOLOAD) =~ s/^.*\:\://;
234              
235 0         0 $Carp::MaxArgLen=20;
236 0         0 confess "Method $method() is not defined for a $class.\n";
237             }
238              
239             #-------------------------------------------
240              
241              
242             #-------------------------------------------
243              
244              
245 3142     3142   69558 sub DESTROY {shift}
246              
247             1;