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 = '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     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 =method new
  36
  37     $error = File::KDBX::Error->new($message, %details);
  38
  39 Construct a new error.
  40
  41 =cut
  42
  43 sub new {
  44     my $class = shift;
  45     my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
  46
  47     my $error = delete $args{_error};
  48     my $e = $error;
  49     $e =~ s/ at \H+ line \d+.*//g;
  50
  51     my $self = bless {
  52         details     => \%args,
  53         error      => $e // 'Something happened',
  54         errno      => $!,
  55         previous   => $@,
  56         trace      => do {
  57             require Carp;
  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)];
  61         },
  62     }, $class;
  63     chomp $self->{error};
  64     return $self;
  65 }
  66
  67 =method error
  68
  69     $error = error($error);
  70     $error = error($message, %details);
  71     $error = File::KDBX::Error->error($error);
  72     $error = File::KDBX::Error->error($message, %details);
  73
  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.
  76
  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:
  79
  80     eval { ... };
  81     if (my $error = error(@_)) {
  82         if ($error->type eq 'key.missing') {
  83             handle_missing_key($error);
  84         }
  85         else {
  86             handle_other_error($error);
  87         }
  88     }
  89
  90 =cut
  91
  92 sub error {
  93     my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
  94     my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
  95         ? shift
  96         : $class
  97             ? $class->new(@_)
  98             : __PACKAGE__->new(@_);
  99     return $self;
 100 }
 101
 102 =attr details
 103
 104     \%details = $error->details;
 105
 106 Get the error details.
 107
 108 =cut
 109
 110 sub details {
 111     my $self = shift;
 112     my %args = @_;
 113     my $details = $self->{details} //= {};
 114     @$details{keys %args} = values %args;
 115     return $details;
 116 }
 117
 118 =attr errno
 119
 120 Get the value of C<errno> when the exception was created.
 121
 122 =attr previous
 123
 124 Get the value of C<$@> (i.e. latest exception) at the time the exception was created.
 125
 126 =attr trace
 127
 128 Get a stack trace indicating where in the code the exception was created.
 129
 130 =cut
 131
 132 =attr type
 133
 134 Get the exception type, if any.
 135
 136 =cut
 137
 138 sub errno    { $_[0]->{errno} }
 139 sub previous { $_[0]->{previous} }
 140 sub trace    { $_[0]->{trace} // [] }
 141 sub type     { $_[0]->details->{type} // '' }
 142
 143 =method to_string
 144
 145     $message = $error->to_string;
 146     $message = "$error";
 147
 148 Stringify an error.
 149
 150 This does not contain a stack trace, but you can set the C<DEBUG> environment
 151 variable to truthy to stringify the whole error object.
 152
 153 =cut
 154
 155 sub _cmp { "$_[0]" cmp "$_[1]" }
 156
 157 sub to_string {
 158     my $self = shift;
 159     my $msg = "$self->{trace}[0]";
 160     $msg .= '.' if $msg !~ /[\.\!\?]$/;
 161     if (2 <= DEBUG) {
 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;
 170     }
 171     $msg .= "\n" if $msg !~ /\n$/;
 172     return $msg;
 173 }
 174
 175 =method throw
 176
 177     File::KDBX::Error::throw($message, %details);
 178     $error->throw;
 179
 180 Throw an error.
 181
 182 =cut
 183
 184 sub throw {
 185     my $self = error(@_);
 186     die $self;
 187 }
 188
 189 =method warn
 190
 191     File::KDBX::Error::warn($message, %details);
 192     $error->warn;
 193
 194 Log a warning.
 195
 196 =cut
 197
 198 sub warn {
 199     return if !($File::KDBX::WARNINGS // 1);
 200
 201     my $self = error(@_);
 202
 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?
 205
 206     if (my $fatal = warnings->can('fatal_enabled_at_level')) {
 207         my $blame = _find_blame_frame();
 208         die $self if $fatal->($WARNINGS_CATEGORY, $blame);
 209     }
 210
 211     if (my $enabled = warnings->can('enabled_at_level')) {
 212         my $blame = _find_blame_frame();
 213         warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
 214     }
 215     elsif ($enabled = warnings->can('enabled')) {
 216         warn $self if $enabled->($WARNINGS_CATEGORY);
 217     }
 218     else {
 219         warn $self;
 220     }
 221     return $self;
 222 }
 223
 224 =method alert
 225
 226     alert $error;
 227
 228 Importable alias for L</warn>.
 229
 230 =cut
 231
 232 sub alert { goto &warn }
 233
 234 sub _find_blame_frame {
 235     my $frame = 1;
 236     while (1) {
 237         my ($package) = caller($frame);
 238         last if !$package;
 239         return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
 240         $frame++;
 241     }
 242     return 0;
 243 }
 244
 245 1;