Dogcows Code - chaz/p5-File-KDBX/blob - 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 looks_like_number);
   9 use namespace::clean -except => 'import';
  10
  11 our $VERSION = '0.900'; # 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     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 };
  31 }
  32
  33 use overload '""' => 'to_string', cmp => '_cmp';
  34
  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
  61 sub error {
  62     my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
  63     my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
  64         ? shift
  65         : $class
  66             ? $class->new(@_)
  67             : __PACKAGE__->new(@_);
  68     return $self;
  69 }
  70
  71
  72 sub details {
  73     my $self = shift;
  74     my %args = @_;
  75     my $details = $self->{details} //= {};
  76     @$details{keys %args} = values %args;
  77     return $details;
  78 }
  79
  80
  81
  82 sub errno    { $_[0]->{errno} }
  83 sub previous { $_[0]->{previous} }
  84 sub trace    { $_[0]->{trace} // [] }
  85 sub type     { $_[0]->details->{type} // '' }
  86
  87
  88 sub _cmp { "$_[0]" cmp "$_[1]" }
  89
  90 sub to_string {
  91     my $self = shift;
  92     my $msg = "$self->{trace}[0]";
  93     $msg .= '.' if $msg !~ /[\.\!\?]$/;
  94     if (2 <= _DEBUG) {
  95         require Data::Dumper;
  96         local $Data::Dumper::Indent = 1;
  97         local $Data::Dumper::Quotekeys = 0;
  98         local $Data::Dumper::Sortkeys = 1;
  99         local $Data::Dumper::Terse = 1;
 100         local $Data::Dumper::Trailingcomma = 1;
 101         local $Data::Dumper::Useqq = 1;
 102         $msg .= "\n" . Data::Dumper::Dumper $self;
 103     }
 104     $msg .= "\n" if $msg !~ /\n$/;
 105     return $msg;
 106 }
 107
 108
 109 sub throw {
 110     my $self = error(@_);
 111     die $self;
 112 }
 113
 114
 115 sub warn {
 116     return if !($File::KDBX::WARNINGS // 1);
 117
 118     my $self = error(@_);
 119
 120     # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
 121     # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug?
 122
 123     if (my $fatal = warnings->can('fatal_enabled_at_level')) {
 124         my $blame = _find_blame_frame();
 125         die $self if $fatal->($WARNINGS_CATEGORY, $blame);
 126     }
 127
 128     if (my $enabled = warnings->can('enabled_at_level')) {
 129         my $blame = _find_blame_frame();
 130         warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
 131     }
 132     elsif ($enabled = warnings->can('enabled')) {
 133         warn $self if $enabled->($WARNINGS_CATEGORY);
 134     }
 135     else {
 136         warn $self;
 137     }
 138     return $self;
 139 }
 140
 141
 142 sub alert { goto &warn }
 143
 144 sub _find_blame_frame {
 145     my $frame = 1;
 146     while (1) {
 147         my ($package) = caller($frame);
 148         last if !$package;
 149         return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
 150         $frame++;
 151     }
 152     return 0;
 153 }
 154
 155 1;
 156
 157 __END__
 158
 159 =pod
 160
 161 =encoding UTF-8
 162
 163 =head1 NAME
 164
 165 File::KDBX::Error - Represents something bad that happened
 166
 167 =head1 VERSION
 168
 169 version 0.900
 170
 171 =head1 ATTRIBUTES
 172
 173 =head2 details
 174
 175     \%details = $error->details;
 176
 177 Get the error details.
 178
 179 =head2 errno
 180
 181 Get the value of C<errno> when the exception was created.
 182
 183 =head2 previous
 184
 185 Get the value of C<$@> (i.e. latest exception) at the time the exception was created.
 186
 187 =head2 trace
 188
 189 Get a stack trace indicating where in the code the exception was created.
 190
 191 =head2 type
 192
 193 Get the exception type, if any.
 194
 195 =head1 METHODS
 196
 197 =head2 new
 198
 199     $error = File::KDBX::Error->new($message, %details);
 200
 201 Construct a new error.
 202
 203 =head2 error
 204
 205     $error = error($error);
 206     $error = error($message, %details);
 207     $error = File::KDBX::Error->error($error);
 208     $error = File::KDBX::Error->error($message, %details);
 209
 210 Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is
 211 passed will be forwarded to L</new> to create a new error object.
 212
 213 This can be convenient for error handling when you're not sure what the exception is but you want to treat it
 214 as a B<File::KDBX::Error>. Example:
 215
 216     eval { ... };
 217     if (my $error = error(@_)) {
 218         if ($error->type eq 'key.missing') {
 219             handle_missing_key($error);
 220         }
 221         else {
 222             handle_other_error($error);
 223         }
 224     }
 225
 226 =head2 to_string
 227
 228     $message = $error->to_string;
 229     $message = "$error";
 230
 231 Stringify an error.
 232
 233 This does not contain a stack trace, but you can set the C<DEBUG> environment variable to at least 2 to
 234 stringify the whole error object.
 235
 236 =head2 throw
 237
 238     File::KDBX::Error::throw($message, %details);
 239     $error->throw;
 240
 241 Throw an error.
 242
 243 =head2 warn
 244
 245     File::KDBX::Error::warn($message, %details);
 246     $error->warn;
 247
 248 Log a warning.
 249
 250 =head2 alert
 251
 252     alert $error;
 253
 254 Importable alias for L</warn>.
 255
 256 =head1 BUGS
 257
 258 Please report any bugs or feature requests on the bugtracker website
 259 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 260
 261 When submitting a bug or request, please include a test-file or a
 262 patch to an existing test-file that illustrates the bug or desired
 263 feature.
 264
 265 =head1 AUTHOR
 266
 267 Charles McGarvey <ccm@cpan.org>
 268
 269 =head1 COPYRIGHT AND LICENSE
 270
 271 This software is copyright (c) 2022 by Charles McGarvey.
 272
 273 This is free software; you can redistribute it and/or modify it under
 274 the same terms as the Perl 5 programming language system itself.
 275
 276 =cut