File Coverage

blib/lib/Net/DRI/Exception.pm
Criterion Covered Total %
statement 47 48 97.9
branch 14 22 63.6
condition 3 6 50.0
subroutine 18 19 94.7
pod 0 16 0.0
total 82 111 73.8


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Encapsulatng errors (fatal or not) as exceptions in an OO way
2             ##
3             ## Copyright (c) 2005,2007-2013,2015 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Exception;
16              
17 93     93   13713 use strict;
  93         94  
  93         2078  
18 93     93   272 use warnings;
  93         86  
  93         1700  
19              
20 93     93   265 use Carp;
  93         146  
  93         61983  
21              
22             =pod
23              
24             =head1 NAME
25              
26             Net::DRI::Exception - Class to store all exceptions inside Net::DRI
27              
28             =head1 SYNOPSIS
29              
30             my $s=Net::DRI::Exception->new(0,'area',500,'message');
31             die($s);
32             ## OR
33             Net::DRI::Exception->die(0,'area',500,'message');
34              
35             $s->is_error(); ## gives 0 or 1, first argument of new/die
36             ## (internal error that should not happen are 1, others are 0)
37              
38             $s->area(); ## gives back the area (second argument of new/die)
39              
40             $s->code(); ## gives back the code (third argument of new/die)
41              
42             $s->msg(); ## gives back the message (fourth argument of new/die)
43              
44             $s->as_string(); ## gives back a nicely formatted full backtrace
45              
46             =head1 SUPPORT
47              
48             For now, support questions should be sent to:
49              
50             Enetdri@dotandco.comE
51              
52             Please also see the SUPPORT file in the distribution.
53              
54             =head1 SEE ALSO
55              
56             Ehttp://www.dotandco.com/services/software/Net-DRI/E
57              
58             =head1 AUTHOR
59              
60             Patrick Mevzek, Enetdri@dotandco.comE
61              
62             =head1 COPYRIGHT
63              
64             Copyright (c) 2005,2007-2013,2015 Patrick Mevzek . All rights reserved.
65              
66             This program is free software; you can redistribute it and/or modify
67             it under the terms of the GNU General Public License as published by
68             the Free Software Foundation; either version 2 of the License, or
69             (at your option) any later version.
70              
71             See the LICENSE file that comes with this distribution for more details.
72              
73             =cut
74              
75             ####################################################################################################
76              
77             sub new
78             {
79 82     82 0 521 my ($class,$error,$area,$code,$msg)=@_;
80 82 50 50     776 my $self={ is_error => (defined $error ? $error : 1 ),
      50        
      50        
81             area => $area || '?',
82             code => $code || 0,
83             msg => $msg || '',
84             };
85              
86 82         22393 $self->{bt}=Carp::longmess();
87              
88 82         14010 bless $self,$class;
89 82         990 return $self;
90             }
91              
92 80     80 0 2220 sub die { die(new(@_)); } ## no critic (Subroutines::ProhibitBuiltinHomonyms Subroutines::RequireArgUnpacking)
93              
94 8     8 0 2831 sub is_error { return shift->{is_error}; }
95 73     73 0 513 sub area { return shift->{area}; }
96 73     73 0 255 sub code { return shift->{code}; }
97 73     73 0 142 sub msg { return shift->{msg}; }
98              
99             sub backtrace
100             {
101 65     65 0 100 my $self=shift;
102 65         269 my $m=$self->{bt};
103 65         92 my (@bt1,@bt2);
104 65 100       1026 foreach (split(/\n/,$m)) { if (/^\s*Net::DRI::(?:BaseClass|Exception)::/) { push @bt1,$_; } else { push @bt2,$_; } }
  565         1271  
  125         184  
  440         546  
105              
106 65 50       381 shift(@bt2) if ($bt2[0]=~m!Net/DRI/BaseClass!);
107 65 100       425 shift(@bt2) if ($bt2[0]=~m|Net/DRI/Exception(?!\.t)|);
108 65         91 my ($f,$l);
109 65 100       156 if (@bt1)
110             {
111 63         496 ($f,$l)=(pop(@bt1)=~m/ called at (\S+) line (\d+)\.?\s*$/);
112             } else
113             {
114 2         9 ($f,$l)=(shift(@bt2)=~m/ at (\S+) line (\d+)\.?\s*$/);
115             }
116 65         112 my @b;
117 65         259 push @b,sprintf('EXCEPTION %d@%s from line %d of file %s:',$self->code(),$self->area(),$l,$f);
118 65         226 push @b,$self->msg();
119 65         4944 return (@b,@bt2);
120             }
121              
122             ## Do not parse result of this call. If needed, use accessors above (is_error(), area(), code(), msg())
123 65     65 0 261 sub as_string { return join("\n",shift->backtrace())."\n"; }
124 0     0 0 0 sub print { print shift->as_string(); } ## no critic (Subroutines::ProhibitBuiltinHomonyms Subroutines::RequireFinalReturn)
125              
126             ####################################################################################################
127              
128 67 50   67 0 182 sub err_failed_load_module { my ($w,$m,$e)=@_; Net::DRI::Exception->die(1,$w,8,'Failed to load Perl module '.$m.' : '.(ref($e)? $e->as_string() : $e)); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
  67         770  
129 1 50   1 0 8 sub err_insufficient_parameters { Net::DRI::Exception->die(1,'internal',2,'Insufficient parameters'.($_[0]? ': '.$_[0] : '')); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
130 1 50   1 0 7 sub err_invalid_parameters { Net::DRI::Exception->die(1,'internal',3,'Invalid parameters'.($_[0]? ': '.$_[0] : '')); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
131              
132 1 50   1 0 8 sub usererr_insufficient_parameters { Net::DRI::Exception->die(0,'internal',2,'Insufficient parameters'.($_[0]? ': '.$_[0] : '')); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
133 3 50   3 0 28 sub usererr_invalid_parameters { Net::DRI::Exception->die(0,'internal',3,'Invalid parameters'.($_[0]? ': '.$_[0] : '')); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
134              
135 1 50   1 0 7 sub err_assert { Net::DRI::Exception->die(1,'internal',4,'Assert failed'.($_[0]? ': '.$_[0] : '')); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
136              
137             sub method_not_implemented ## no critic (Subroutines::RequireFinalReturn)
138             {
139 1     1 0 2 my ($m,$w)=@_;
140 1         3 ($w)=split(/=/,$w);
141 1         8 Net::DRI::Exception->die(1,'internal',1,sprintf('Method "%s" not implemented in "%s"',$m,$w));
142             }
143              
144             ####################################################################################################
145             1;