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     warnings::register_categories($WARNINGS_CATEGORY) if warnings->can('register_categories');
  19 }
  20
  21 use overload '""' => 'to_string', cmp => '_cmp';
  22
  23 =method new
  24
  25     $error = File::KDBX::Error->new($message, %details);
  26
  27 Construct a new error.
  28
  29 =cut
  30
  31 sub new {
  32     my $class = shift;
  33     my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
  34
  35     my $error = delete $args{_error};
  36     my $e = $error;
  37     # $e =~ s/ at \H+ line \d+.*//g;
  38
  39     my $self = bless {
  40         details     => \%args,
  41         error      => $e // 'Something happened',
  42         errno      => $!,
  43         previous   => $@,
  44         trace      => do {
  45             require Carp;
  46             local $Carp::CarpInternal{''.__PACKAGE__} = 1;
  47             my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error);
  48             [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
  49         },
  50     }, $class;
  51     chomp $self->{error};
  52     return $self;
  53 }
  54
  55 =method error
  56
  57     $error = error($error);
  58     $error = error($message, %details);
  59     $error = File::KDBX::Error->error($error);
  60     $error = File::KDBX::Error->error($message, %details);
  61
  62 Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is
  63 passed will be forwarded to L</new> to create a new error object.
  64
  65 This can be convenient for error handling when you're not sure what the exception is but you want to treat it
  66 as a B<File::KDBX::Error>. Example:
  67
  68     eval { .... };
  69     if (my $error = error(@_)) {
  70         if ($error->type eq 'key.missing') {
  71             handle_missing_key($error);
  72         }
  73         else {
  74             handle_other_error($error);
  75         }
  76     }
  77
  78 =cut
  79
  80 sub error {
  81     my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
  82     my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
  83         ? shift
  84         : $class
  85             ? $class->new(@_)
  86             : __PACKAGE__->new(@_);
  87     return $self;
  88 }
  89
  90 =attr details
  91
  92     \%details = $error->details;
  93
  94 Get the error details.
  95
  96 =cut
  97
  98 sub details {
  99     my $self = shift;
 100     my %args = @_;
 101     my $details = $self->{details} //= {};
 102     @$details{keys %args} = values %args;
 103     return $details;
 104 }
 105
 106 sub errno { $_[0]->{errno} }
 107
 108 sub previous { $_[0]->{previous} }
 109
 110 sub trace { $_[0]->{trace} // [] }
 111
 112 sub type { $_[0]->details->{type} // '' }
 113
 114 =method to_string
 115
 116     $message = $error->to_string;
 117     $message = "$error";
 118
 119 Stringify an error.
 120
 121 This does not contain a stack trace, but you can set the C<DEBUG> environment
 122 variable to truthy to stringify the whole error object.
 123
 124 =cut
 125
 126 sub _cmp { "$_[0]" cmp "$_[1]" }
 127
 128 sub PROPAGATE {
 129     'wat';
 130 }
 131
 132 sub to_string {
 133     my $self = shift;
 134     # return "uh oh\n";
 135     my $msg = "$self->{trace}[0]";
 136     $msg .= '.' if $msg !~ /[\.\!\?]$/; # Why does this cause infinite recursion on some perls?
 137     # $msg .= '.' if $msg !~ /(?:\.|!|\?)$/;
 138     if ($ENV{DEBUG}) {
 139         require Data::Dumper;
 140         local $Data::Dumper::Indent = 1;
 141         local $Data::Dumper::Quotekeys = 0;
 142         local $Data::Dumper::Sortkeys = 1;
 143         local $Data::Dumper::Terse = 1;
 144         local $Data::Dumper::Trailingcomma = 1;
 145         local $Data::Dumper::Useqq = 1;
 146         $msg .= "\n" . Data::Dumper::Dumper $self;
 147     }
 148     $msg .= "\n" if $msg !~ /\n$/;
 149     return $msg;
 150 }
 151
 152 =method throw
 153
 154     File::KDBX::Error::throw($message, %details);
 155     $error->throw;
 156
 157 Throw an error.
 158
 159 =cut
 160
 161 sub throw {
 162     my $self = error(@_);
 163     die $self;
 164 }
 165
 166 =method warn
 167
 168     File::KDBX::Error::warn($message, %details);
 169     $error->warn;
 170
 171 Log a warning.
 172
 173 =cut
 174
 175 sub warn {
 176     return if !($File::KDBX::WARNINGS // 1);
 177
 178     my $self = error(@_);
 179
 180     # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
 181     # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug?
 182
 183     if (my $fatal = warnings->can('fatal_enabled_at_level')) {
 184         my $blame = _find_blame_frame();
 185         die $self if $fatal->($WARNINGS_CATEGORY, $blame);
 186     }
 187
 188     if (my $enabled = warnings->can('enabled_at_level')) {
 189         my $blame = _find_blame_frame();
 190         warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
 191     }
 192     elsif ($enabled = warnings->can('enabled')) {
 193         warn $self if $enabled->($WARNINGS_CATEGORY);
 194     }
 195     else {
 196         warn $self;
 197     }
 198     return $self;
 199 }
 200
 201 =method alert
 202
 203     alert $error;
 204
 205 Importable alias for L</warn>.
 206
 207 =cut
 208
 209 sub alert { goto &warn }
 210
 211 sub _find_blame_frame {
 212     my $frame = 1;
 213     while (1) {
 214         my ($package) = caller($frame);
 215         last if !$package;
 216         return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
 217         $frame++;
 218     }
 219     return 0;
 220 }
 221
 222 1;