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);
   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;