]> Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Error.pm
Remove objects from deleted objects when added
[chaz/p5-File-KDBX] / lib / File / KDBX / Error.pm
1 package File::KDBX::Error;
2 # ABSTRACT: Represents something bad that happened
3
4 use warnings;
5 use strict;
6
7 use Exporter qw(import);
8 use Scalar::Util qw(blessed);
9 use namespace::clean -except => 'import';
10
11 our $VERSION = '999.999'; # VERSION
12
13 our @EXPORT = qw(alert error throw);
14
15 my $WARNINGS_CATEGORY;
16 BEGIN {
17 $WARNINGS_CATEGORY = 'File::KDBX';
18 if (warnings->can('register_categories')) {
19 warnings::register_categories($WARNINGS_CATEGORY);
20 }
21 else {
22 eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval
23 }
24 }
25
26 use overload '""' => 'to_string', cmp => '_cmp';
27
28 =method new
29
30 $error = File::KDBX::Error->new($message, %details);
31
32 Construct a new error.
33
34 =cut
35
36 sub new {
37 my $class = shift;
38 my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
39
40 my $error = delete $args{_error};
41 my $e = $error;
42 $e =~ s/ at \H+ line \d+.*//g;
43
44 my $self = bless {
45 details => \%args,
46 error => $e // 'Something happened',
47 errno => $!,
48 previous => $@,
49 trace => do {
50 require Carp;
51 local $Carp::CarpInternal{''.__PACKAGE__} = 1;
52 my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error);
53 [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
54 },
55 }, $class;
56 chomp $self->{error};
57 return $self;
58 }
59
60 =method error
61
62 $error = error($error);
63 $error = error($message, %details);
64 $error = File::KDBX::Error->error($error);
65 $error = File::KDBX::Error->error($message, %details);
66
67 Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is
68 passed will be forwarded to L</new> to create a new error object.
69
70 This can be convenient for error handling when you're not sure what the exception is but you want to treat it
71 as a B<File::KDBX::Error>. Example:
72
73 eval { ... };
74 if (my $error = error(@_)) {
75 if ($error->type eq 'key.missing') {
76 handle_missing_key($error);
77 }
78 else {
79 handle_other_error($error);
80 }
81 }
82
83 =cut
84
85 sub error {
86 my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
87 my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
88 ? shift
89 : $class
90 ? $class->new(@_)
91 : __PACKAGE__->new(@_);
92 return $self;
93 }
94
95 =attr details
96
97 \%details = $error->details;
98
99 Get the error details.
100
101 =cut
102
103 sub details {
104 my $self = shift;
105 my %args = @_;
106 my $details = $self->{details} //= {};
107 @$details{keys %args} = values %args;
108 return $details;
109 }
110
111 =attr errno
112
113 Get the value of C<errno> when the exception was created.
114
115 =attr previous
116
117 Get the value of C<$@> (i.e. latest exception) at the time the exception was created.
118
119 =attr trace
120
121 Get a stack trace indicating where in the code the exception was created.
122
123 =cut
124
125 =attr type
126
127 Get the exception type, if any.
128
129 =cut
130
131 sub errno { $_[0]->{errno} }
132 sub previous { $_[0]->{previous} }
133 sub trace { $_[0]->{trace} // [] }
134 sub type { $_[0]->details->{type} // '' }
135
136 =method to_string
137
138 $message = $error->to_string;
139 $message = "$error";
140
141 Stringify an error.
142
143 This does not contain a stack trace, but you can set the C<DEBUG> environment
144 variable to truthy to stringify the whole error object.
145
146 =cut
147
148 sub _cmp { "$_[0]" cmp "$_[1]" }
149
150 sub to_string {
151 my $self = shift;
152 my $msg = "$self->{trace}[0]";
153 $msg .= '.' if $msg !~ /[\.\!\?]$/;
154 if ($ENV{DEBUG}) {
155 require Data::Dumper;
156 local $Data::Dumper::Indent = 1;
157 local $Data::Dumper::Quotekeys = 0;
158 local $Data::Dumper::Sortkeys = 1;
159 local $Data::Dumper::Terse = 1;
160 local $Data::Dumper::Trailingcomma = 1;
161 local $Data::Dumper::Useqq = 1;
162 $msg .= "\n" . Data::Dumper::Dumper $self;
163 }
164 $msg .= "\n" if $msg !~ /\n$/;
165 return $msg;
166 }
167
168 =method throw
169
170 File::KDBX::Error::throw($message, %details);
171 $error->throw;
172
173 Throw an error.
174
175 =cut
176
177 sub throw {
178 my $self = error(@_);
179 die $self;
180 }
181
182 =method warn
183
184 File::KDBX::Error::warn($message, %details);
185 $error->warn;
186
187 Log a warning.
188
189 =cut
190
191 sub warn {
192 return if !($File::KDBX::WARNINGS // 1);
193
194 my $self = error(@_);
195
196 # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
197 # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug?
198
199 if (my $fatal = warnings->can('fatal_enabled_at_level')) {
200 my $blame = _find_blame_frame();
201 die $self if $fatal->($WARNINGS_CATEGORY, $blame);
202 }
203
204 if (my $enabled = warnings->can('enabled_at_level')) {
205 my $blame = _find_blame_frame();
206 warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
207 }
208 elsif ($enabled = warnings->can('enabled')) {
209 warn $self if $enabled->($WARNINGS_CATEGORY);
210 }
211 else {
212 warn $self;
213 }
214 return $self;
215 }
216
217 =method alert
218
219 alert $error;
220
221 Importable alias for L</warn>.
222
223 =cut
224
225 sub alert { goto &warn }
226
227 sub _find_blame_frame {
228 my $frame = 1;
229 while (1) {
230 my ($package) = caller($frame);
231 last if !$package;
232 return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
233 $frame++;
234 }
235 return 0;
236 }
237
238 1;
This page took 0.054292 seconds and 4 git commands to generate.