File Coverage

blib/lib/GD/Graph/Error.pm
Criterion Covered Total %
statement 58 81 71.6
branch 19 38 50.0
condition 8 16 50.0
subroutine 10 14 71.4
pod 4 5 80.0
total 99 154 64.2


line stmt bran cond sub pod time code
1             #==========================================================================
2             # Copyright (c) 1995-2000 Martien Verbruggen
3             #--------------------------------------------------------------------------
4             #
5             # Name:
6             # GD::Graph::Error.pm
7             #
8             # $Id: Error.pm,v 1.8 2005/12/14 04:08:05 ben Exp $
9             #
10             #==========================================================================
11              
12             package GD::Graph::Error;
13              
14             ($GD::Graph::Error::VERSION) = '$Revision: 1.8 $' =~ /\s([\d.]+)/;
15              
16 2     2   4466 use strict;
  2         2  
  2         51  
17 2     2   6 use Carp;
  2         3  
  2         121  
18              
19             my %Errors;
20 2     2   10 use vars qw( $Debug $ErrorLevel $CriticalLevel );
  2         3  
  2         1824  
21              
22             $Debug = 0;
23              
24             # Warnings from 0 to 4, Errors from 5 to 9, and Critical 10 and above.
25             $ErrorLevel = 5;
26             $CriticalLevel = 10;
27              
28             =head1 NAME
29              
30             GD::Graph::Error - Error handling for GD::Graph classes
31              
32             =head1 SYNOPSIS
33              
34             use GD::Graph::Error_subclass;
35              
36             =head1 DESCRIPTION
37              
38             This class is a parent for all GD::Graph classes, including
39             GD::Graph::Data, and offers error and warning handling and some
40             debugging control.
41              
42             Errors are stored in a lexical hash in this package, so the
43             implementation of the subclass should be irrelevant.
44              
45             =head1 PUBLIC METHODS
46              
47             These methods can be used by users of any of the subclasses of
48             GD::Graph::Error to get at the errors of objects or classes.
49              
50             =head2 $object->error() OR Class->error()
51              
52             Returns a list of all the errors that the current object has
53             accumulated. In scalar context, returns the last error. If called as a
54             class method it works at a class level. This is handy when a constructor
55             fails, for example:
56              
57             my $data = GD::Graph::Data->new()
58             or die GD::Graph::Data->error;
59             $data->read(file => '/foo/bar.data')
60             or die $data->error;
61              
62             or if you really are only interested in the last error:
63              
64             $data->read(file => '/foo/bar.data')
65             or die scalar $data->error;
66              
67             This implementation does not clear the error list, so if you don't die
68             on errors, you will need to make sure to never ask for anything but the
69             last error (put this in scalar context) or to call C now
70             and again.
71              
72             Errors are more verbose about where the errors originated if the
73             $GD::Graph::Error::Debug variable is set to a true value, and even more
74             verbose if this value is larger than 5.
75              
76             If $Debug is larger than 3, both of these will always return the
77             full list of errors and warnings (although the meaning of C
78             and C does not change).
79              
80             =cut
81              
82             sub _error
83             {
84 1     1   2 my $self = shift;
85 1   50     2 my $min_level = shift || 0;
86 1   50     11 my $max_level = shift || 1 << 31;
87 1 50       3 return unless exists $Errors{$self};
88 1         1 my $error = $Errors{$self};
89              
90 1         2 my @return;
91              
92             @return =
93             map {
94 1 50       12 ($Debug > 3 ? "[$_->{level}] " : '') .
    50          
    50          
95             "$_->{msg}" .
96             ($Debug ? " at $_->{whence}[1] line $_->{whence}[2]" : '') .
97             ($Debug > 5 ? " => $_->{caller}[0]($_->{caller}[2])" : '') .
98             "\n"
99             }
100 1 50       2 grep { $_->{level} >= $min_level && $_->{level} <= $max_level }
  1         5  
101             @$error;
102              
103 1 50 33     11 wantarray && @return > 1 and
      33        
104             $return[-1] =~ s/\n/\n\t/ or
105             $return[-1] =~ s/\n//;
106              
107 1 50       178 return wantarray ? @return : $return[-1];
108             }
109              
110             sub error
111             {
112 1     1 1 1 my $self = shift;
113 1 50       3 $Debug > 3 and return $self->_error();
114 1         4 $self->_error($ErrorLevel);
115             }
116              
117             sub warning
118             {
119 0     0 0 0 my $self = shift;
120 0 0       0 $Debug > 3 and return $self->_error();
121 0         0 $self->_error(0, $ErrorLevel - 1);
122             }
123              
124             =head2 $object->has_error() OR Class->has_error()
125              
126             =head2 $object->has_warning() OR Class->has_warning()
127              
128             Returns true if there are pending errors (warnings) for the object
129             (or class). To be more precise, it returns a list of errors in list
130             context, and the number of errors in scalar context.
131              
132             This allows you to check for errors and warnings after a large number of
133             operations which each might fail:
134              
135             $data->read(file => '/foo/bar.data') or die $data->error;
136             while (my @foo = $sth->fetchrow_array)
137             {
138             $data->add_point(@foo);
139             }
140             $data->set_x(12, 'Foo');
141             $data->has_warning and warn $data->warning;
142             $data->has_error and die $data->error;
143              
144             The reason to call this, instead of just calling C or
145             C and looking at its return value, is that this method is
146             much more efficient and fast.
147              
148             If you want to count anything as bad, just set $ErrorLevel to 0, after
149             which you only need to call C.
150              
151             =cut
152              
153             sub has_error
154             {
155 5     5 1 452 my $self = shift;
156 5 100       21 return unless exists $Errors{$self};
157 3         3 grep { $_->{level} >= $ErrorLevel } @{$Errors{$self}};
  8         20  
  3         7  
158             }
159              
160             sub has_warning
161             {
162 5     5 1 275 my $self = shift;
163 5 100       17 return unless exists $Errors{$self};
164 3         3 grep { $_->{level} < $ErrorLevel } @{$Errors{$self}};
  8         17  
  3         6  
165             }
166              
167             =head2 $object->clear_errors() or Class->clear_errors()
168              
169             Clears all outstanding errors.
170              
171             =cut
172              
173             sub clear_errors
174             {
175 13     13 1 153 my $self = shift;
176 13         146 delete $Errors{$self};
177             }
178              
179             =head1 PROTECTED METHODS
180              
181             These methods are only to be called from within this class and its
182             Subclasses.
183              
184             =head2 $object->_set_error(I) or Class->_set_error(I)
185              
186             =head2 $object->_set_warning(I) or Class->_set_warning(I)
187              
188             Subclasses call this to set an error. The argument can be a reference
189             to an array, of which the first element should be the error level, and
190             the second element the error message. Alternatively, it can just be the
191             message, in which case the error level will be assumed to be
192             $ErrorLevel.
193              
194             If the error level is >= $CriticalLevel the program will die, using
195             Carp::croak to display the current message, as well as all the other
196             error messages pending.
197              
198             In the current implementation these are almost identical when called
199             with a scalar argument, except that the default error level is
200             different. When called with an array reference, they are identical in
201             function. This may change in the future. They're mainly here for code
202             clarity.
203              
204             =cut
205              
206             # Private, for construction of error hash. This should probably be an
207             # object, but that's too much work right now.
208             sub __error_hash
209             {
210 6     6   7 my $caller = shift;
211 6         5 my $default = shift;
212 6         4 my $msg = shift;
213              
214 6         16 my %error = (caller => $caller);
215              
216 6 100 66     48 if (ref($msg) && ref($msg) eq 'ARRAY' && @{$msg} >= 2)
  5 50 66     24  
217             {
218             # Array reference
219 5         7 $error{level} = $msg->[0];
220 5         6 $error{msg} = $msg->[1];
221             }
222             elsif (ref($_[0]) eq '')
223             {
224             # simple scalar
225 1         2 $error{level} = $default;
226 1         3 $error{msg} = $msg;
227             }
228             else
229             {
230             # something else, which I can't deal with
231 0         0 warn "Did you read the documentation for GD::Graph::Error?";
232 0         0 return;
233             }
234              
235 6         5 my $lvl = 1;
236 6         30 while (my @c = caller($lvl))
237             {
238 9         17 $error{whence} = [@c[0..2]];
239 9         30 $lvl++;
240             }
241              
242 6         16 return \%error;
243             }
244              
245             sub _set_error
246             {
247 4     4   5 my $self = shift;
248 4 50       10 return unless @_;
249              
250 4         8 while (@_)
251             {
252 6 50       20 my $e_h = __error_hash([caller], $ErrorLevel, shift) or return;
253 6         5 push @{$Errors{$self}}, $e_h;
  6         13  
254 6 100       21 croak $self->error if $e_h->{level} >= $CriticalLevel;
255             }
256 3         6 return;
257             }
258              
259             sub _set_warning
260             {
261 0     0     my $self = shift;
262 0 0         return unless @_;
263              
264 0           while (@_)
265             {
266 0 0         my $e_h = __error_hash([caller], $ErrorLevel, shift) or return;
267 0           push @{$Errors{$self}}, $e_h;
  0            
268 0 0         croak $self->error if $e_h->{level} >= $CriticalLevel;
269             }
270 0           return;
271             }
272              
273             =head2 $object->_move_errors
274              
275             Move errors from an object into the class it belongs to. This can be
276             useful if something nasty happens in the constructor, while
277             instantiating one of these objects, and you need to move these errors
278             into the class space before returning. (see GD::Graph::Data::new for an
279             example)
280              
281             =cut
282              
283             sub _move_errors
284             {
285 0     0     my $self = shift;
286 0           my $class = ref($self);
287 0           push @{$Errors{$class}}, @{$Errors{$self}};
  0            
  0            
288 0           return;
289             }
290              
291             sub _dump
292             {
293 0     0     my $self = shift;
294 0           require Data::Dumper;
295 0           my $dd = Data::Dumper->new([$self], ['me']);
296 0           $dd->Dumpxs;
297             }
298              
299             =head1 VARIABLES
300              
301             =head2 $GD::Graph::Error::Debug
302              
303             The higher this value, the more verbose error messages will be. At the
304             moment, any true value will cause the line number and source file of the
305             caller at the top of the stack to be included, a value of more than 2
306             will include the error severity, and a value of more than 5 will also
307             include the direct caller's (i.e. the spot where the error message was
308             generated) line number and package. Default: 0.
309              
310             =head2 $GD::Graph::Error::ErrorLevel
311              
312             Errors levels below this value will be counted as warnings, and error
313             levels above (and inclusive) up to $CriticalLevel will be counted as
314             errors. This is also the default error level for the C<_set_error()>
315             method. This value should be 0 or larger, and smaller than
316             $CriticalLevel. Default: 5.
317              
318             =head2 $GD::Graph::Error::CriticalLevel
319              
320             Any errorlevel of or above this level will immediately cause the program
321             to die with the specified message, using Carp::croak. Default: 10.
322              
323             =head1 NOTES
324              
325             As with all Modules for Perl: Please stick to using the interface. If
326             you try to fiddle too much with knowledge of the internals of this
327             module, you could get burned. I may change them at any time.
328              
329             =head1 AUTHOR
330              
331             Martien Verbruggen Emgjv@tradingpost.com.auE
332              
333             =head2 Copyright
334              
335             (c) Martien Verbruggen.
336              
337             All rights reserved. This package is free software; you can redistribute
338             it and/or modify it under the same terms as Perl itself.
339              
340             =head1 SEE ALSO
341              
342             L, L
343              
344             =cut
345              
346             "Just another true value";