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