1 package File
::KDBX
::Error
;
2 # ABSTRACT: Represents something bad that happened
7 use Exporter
qw(import);
8 use Scalar
::Util
qw(blessed looks_like_number);
9 use namespace
::clean
-except
=> 'import';
11 our $VERSION = '999.999'; # VERSION
13 our @EXPORT = qw(alert error throw);
15 my $WARNINGS_CATEGORY;
17 $WARNINGS_CATEGORY = 'File::KDBX';
18 if (warnings-
>can('register_categories')) {
19 warnings
::register_categories
($WARNINGS_CATEGORY);
22 eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval
25 my $debug = $ENV{DEBUG
};
26 $debug = looks_like_number
($debug) ? (0 + $debug) : ($debug ? 1 : 0);
27 *_DEBUG
= $debug == 1 ? sub() { 1 } :
28 $debug == 2 ? sub() { 2 } :
29 $debug == 3 ? sub() { 3 } :
30 $debug == 4 ? sub() { 4 } : sub() { 0 };
33 use overload
'""' => 'to_string', cmp => '_cmp';
37 $error = File
::KDBX
::Error-
>new($message, %details);
39 Construct a new error
.
45 my %args = @_ % 2 == 0 ? @_ : (_error
=> shift, @_);
47 my $error = delete $args{_error
};
49 $e =~ s/ at \H+ line \d+.*//g;
53 error
=> $e // 'Something happened',
58 local $Carp::CarpInternal
{''.__PACKAGE__
} = 1;
59 my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp
::longmess
($error);
60 [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
69 $error = error
($error);
70 $error = error
($message, %details);
71 $error = File
::KDBX
::Error-
>error($error);
72 $error = File
::KDBX
::Error-
>error($message, %details);
74 Wrap a thing to make it an error object
. If the thing
is already an error
, it gets returned
. Otherwise what
is
75 passed will be forwarded to L
</new
> to create a new error object
.
77 This can be convenient
for error handling
when you
're not sure what the exception is but you want to treat it
78 as a B<File::KDBX::Error>. Example:
81 if (my $error = error(@_)) {
82 if ($error->type eq 'key
.missing
') {
83 handle_missing_key($error);
86 handle_other_error($error);
93 my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
94 my $self = (blessed($_[0]) && $_[0]->isa('File
::KDBX
::Error
'))
98 : __PACKAGE__->new(@_);
104 \%details = $error->details;
106 Get the error details.
113 my $details = $self->{details} //= {};
114 @$details{keys %args} = values %args;
120 Get the value of C<errno> when the exception was created.
124 Get the value of C<$@> (i.e. latest exception) at the time the exception was created.
128 Get a stack trace indicating where in the code the exception was created.
134 Get the exception type, if any.
138 sub errno { $_[0]->{errno} }
139 sub previous { $_[0]->{previous} }
140 sub trace { $_[0]->{trace} // [] }
141 sub type { $_[0]->details->{type} // '' }
145 $message = $error->to_string;
150 This does not contain a stack trace, but you can set the C<DEBUG> environment variable to at least 2 to
151 stringify the whole error object.
155 sub _cmp { "$_[0]" cmp "$_[1]" }
159 my $msg = "$self->{trace}[0]";
160 $msg .= '.' if $msg !~ /[\.\!\?]$/;
162 require Data::Dumper;
163 local $Data::Dumper::Indent = 1;
164 local $Data::Dumper::Quotekeys = 0;
165 local $Data::Dumper::Sortkeys = 1;
166 local $Data::Dumper::Terse = 1;
167 local $Data::Dumper::Trailingcomma = 1;
168 local $Data::Dumper::Useqq = 1;
169 $msg .= "\n" . Data::Dumper::Dumper $self;
171 $msg .= "\n" if $msg !~ /\n$/;
177 File::KDBX::Error::throw($message, %details);
185 my $self = error(@_);
191 File::KDBX::Error::warn($message, %details);
199 return if !($File::KDBX::WARNINGS // 1);
201 my $self = error(@_);
203 # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
204 # error to the warning signal handler (perl 5.34). Maybe that's a warnings
.pm bug
?
206 if (my $fatal = warnings-
>can('fatal_enabled_at_level')) {
207 my $blame = _find_blame_frame
();
208 die $self if $fatal->($WARNINGS_CATEGORY, $blame);
211 if (my $enabled = warnings-
>can('enabled_at_level')) {
212 my $blame = _find_blame_frame
();
213 warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
215 elsif ($enabled = warnings-
>can('enabled')) {
216 warn $self if $enabled->($WARNINGS_CATEGORY);
228 Importable alias
for L
</warn>.
232 sub alert
{ goto &warn }
234 sub _find_blame_frame
{
237 my ($package) = caller($frame);
239 return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;