X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FError.pm;h=86442f3bdc306a071a2101cb462e6f3b9dbfbd2b;hb=331a54019664704eb4a10186cb4abd7a2a722f30;hp=f80155796f4ae40e8d17afcda9dd8b0c8bdfce39;hpb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;p=chaz%2Fp5-File-KDBX

diff --git a/lib/File/KDBX/Error.pm b/lib/File/KDBX/Error.pm
index f801557..86442f3 100644
--- a/lib/File/KDBX/Error.pm
+++ b/lib/File/KDBX/Error.pm
@@ -5,7 +5,7 @@ use warnings;
 use strict;
 
 use Exporter qw(import);
-use Scalar::Util qw(blessed);
+use Scalar::Util qw(blessed looks_like_number);
 use namespace::clean -except => 'import';
 
 our $VERSION = '999.999'; # VERSION
@@ -15,7 +15,19 @@ our @EXPORT = qw(alert error throw);
 my $WARNINGS_CATEGORY;
 BEGIN {
     $WARNINGS_CATEGORY = 'File::KDBX';
-    warnings::register_categories($WARNINGS_CATEGORY) if warnings->can('register_categories');
+    if (warnings->can('register_categories')) {
+        warnings::register_categories($WARNINGS_CATEGORY);
+    }
+    else {
+        eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval
+    }
+
+    my $debug = $ENV{DEBUG};
+    $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
+    *DEBUG = $debug == 1 ? sub() { 1 } :
+             $debug == 2 ? sub() { 2 } :
+             $debug == 3 ? sub() { 3 } :
+             $debug == 4 ? sub() { 4 } : sub() { 0 };
 }
 
 use overload '""' => 'to_string', cmp => '_cmp';
@@ -34,7 +46,7 @@ sub new {
 
     my $error = delete $args{_error};
     my $e = $error;
-    # $e =~ s/ at \H+ line \d+.*//g;
+    $e =~ s/ at \H+ line \d+.*//g;
 
     my $self = bless {
         details     => \%args,
@@ -65,7 +77,7 @@ passed will be forwarded to L</new> to create a new error object.
 This can be convenient for error handling when you're not sure what the exception is but you want to treat it
 as a B<File::KDBX::Error>. Example:
 
-    eval { .... };
+    eval { ... };
     if (my $error = error(@_)) {
         if ($error->type eq 'key.missing') {
             handle_missing_key($error);
@@ -78,10 +90,11 @@ as a B<File::KDBX::Error>. Example:
 =cut
 
 sub error {
+    my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
     my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
         ? shift
-        : (@_ && $_[0] eq __PACKAGE__)
-            ? shift->new(@_)
+        : $class
+            ? $class->new(@_)
             : __PACKAGE__->new(@_);
     return $self;
 }
@@ -102,13 +115,30 @@ sub details {
     return $details;
 }
 
-sub errno { $_[0]->{errno} }
+=attr errno
 
-sub previous { $_[0]->{previous} }
+Get the value of C<errno> when the exception was created.
 
-sub trace { $_[0]->{trace} // [] }
+=attr previous
 
-sub type { $_[0]->details->{type} // '' }
+Get the value of C<$@> (i.e. latest exception) at the time the exception was created.
+
+=attr trace
+
+Get a stack trace indicating where in the code the exception was created.
+
+=cut
+
+=attr type
+
+Get the exception type, if any.
+
+=cut
+
+sub errno    { $_[0]->{errno} }
+sub previous { $_[0]->{previous} }
+sub trace    { $_[0]->{trace} // [] }
+sub type     { $_[0]->details->{type} // '' }
 
 =method to_string
 
@@ -124,17 +154,11 @@ variable to truthy to stringify the whole error object.
 
 sub _cmp { "$_[0]" cmp "$_[1]" }
 
-sub PROPAGATE {
-    'wat';
-}
-
 sub to_string {
     my $self = shift;
-    # return "uh oh\n";
     my $msg = "$self->{trace}[0]";
-    $msg .= '.' if $msg !~ /[\.\!\?]$/; # Why does this cause infinite recursion on some perls?
-    # $msg .= '.' if $msg !~ /(?:\.|!|\?)$/;
-    if ($ENV{DEBUG}) {
+    $msg .= '.' if $msg !~ /[\.\!\?]$/;
+    if (2 <= DEBUG) {
         require Data::Dumper;
         local $Data::Dumper::Indent = 1;
         local $Data::Dumper::Quotekeys = 0;