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