File Coverage

blib/lib/File/KDBX/Error.pm
Criterion Covered Total %
statement 66 80 82.5
branch 25 48 52.0
condition 9 16 56.2
subroutine 19 21 90.4
pod 11 11 100.0
total 130 176 73.8


line stmt bran cond sub pod time code
1             package File::KDBX::Error;
2             # ABSTRACT: Represents something bad that happened
3              
4 27     27   522 use 5.010;
  27         88  
5 27     27   116 use warnings;
  27         39  
  27         550  
6 27     27   122 use strict;
  27         53  
  27         726  
7              
8 27     27   138 use Exporter qw(import);
  27         53  
  27         797  
9 27     27   141 use Scalar::Util qw(blessed looks_like_number);
  27         94  
  27         2456  
10 27     27   10631 use namespace::clean -except => 'import';
  27         360269  
  27         154  
11              
12             our $VERSION = '0.905'; # VERSION
13              
14             our @EXPORT = qw(alert error throw);
15              
16             my $WARNINGS_CATEGORY;
17             BEGIN {
18 27     27   9959 $WARNINGS_CATEGORY = 'File::KDBX';
19 27 50       286 if (warnings->can('register_categories')) {
20 27         2597 warnings::register_categories($WARNINGS_CATEGORY);
21             }
22             else {
23 0         0 eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval
24             }
25              
26 27         92 my $debug = $ENV{DEBUG};
27 27 50       149 $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
    50          
28             *_DEBUG = $debug == 1 ? sub() { 1 } :
29             $debug == 2 ? sub() { 2 } :
30             $debug == 3 ? sub() { 3 } :
31 27 50       906 $debug == 4 ? sub() { 4 } : sub() { 0 };
    50          
    50          
    50          
32             }
33              
34 27     27   27872 use overload '""' => 'to_string', cmp => '_cmp';
  27         22348  
  27         139  
35              
36              
37             sub new {
38 373     373 1 1226 my $class = shift;
39 373 50       1379 my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
40              
41 373         637 my $error = delete $args{_error};
42 373         478 my $e = $error;
43 373         889 $e =~ s/ at \H+ line \d+.*//g;
44              
45             my $self = bless {
46             details => \%args,
47             error => $e // 'Something happened',
48             errno => $!,
49             previous => $@,
50 373   50     840 trace => do {
51 373         1612 require Carp;
52 373         817 local $Carp::CarpInternal{''.__PACKAGE__} = 1;
53 373 100       37226 my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error);
54 373 50       109815 [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
  4464         48005  
55             },
56             }, $class;
57 373         1769 chomp $self->{error};
58 373         824 return $self;
59             }
60              
61              
62             sub error {
63 375 100 66 375 1 1228 my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
64 375 100 66     2079 my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
    100          
65             ? shift
66             : $class
67             ? $class->new(@_)
68             : __PACKAGE__->new(@_);
69 375         602 return $self;
70             }
71              
72              
73             sub details {
74 2     2 1 987 my $self = shift;
75 2         6 my %args = @_;
76 2   50     11 my $details = $self->{details} //= {};
77 2         9 @$details{keys %args} = values %args;
78 2         13 return $details;
79             }
80              
81              
82              
83 2     2 1 16 sub errno { $_[0]->{errno} }
84 2     2 1 12 sub previous { $_[0]->{previous} }
85 6   50 6 1 2379 sub trace { $_[0]->{trace} // [] }
86 0   0 0 1 0 sub type { $_[0]->details->{type} // '' }
87              
88              
89 5     5   28 sub _cmp { "$_[0]" cmp "$_[1]" }
90              
91             sub to_string {
92 118     118 1 15052 my $self = shift;
93 118         287 my $msg = "$self->{trace}[0]";
94 118 50       574 $msg .= '.' if $msg !~ /[\.\!\?]$/;
95 118         172 if (2 <= _DEBUG) {
96             require Data::Dumper;
97             local $Data::Dumper::Indent = 1;
98             local $Data::Dumper::Quotekeys = 0;
99             local $Data::Dumper::Sortkeys = 1;
100             local $Data::Dumper::Terse = 1;
101             local $Data::Dumper::Trailingcomma = 1;
102             local $Data::Dumper::Useqq = 1;
103             $msg .= "\n" . Data::Dumper::Dumper $self;
104             }
105 118 50       308 $msg .= "\n" if $msg !~ /\n$/;
106 118         885 return $msg;
107             }
108              
109              
110             sub throw {
111 360     360 1 4958 my $self = error(@_);
112 360         2024 die $self;
113             }
114              
115              
116             sub warn {
117 14 100 100 14 1 2190 return if !($File::KDBX::WARNINGS // 1);
118              
119 13         48 my $self = error(@_);
120              
121             # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
122             # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug?
123              
124 13 50       121 if (my $fatal = warnings->can('fatal_enabled_at_level')) {
125 0         0 my $blame = _find_blame_frame();
126 0 0       0 die $self if $fatal->($WARNINGS_CATEGORY, $blame);
127             }
128              
129 13 50       131 if (my $enabled = warnings->can('enabled_at_level')) {
    50          
130 0         0 my $blame = _find_blame_frame();
131 0 0       0 warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
132             }
133             elsif ($enabled = warnings->can('enabled')) {
134 13 50       1065 warn $self if $enabled->($WARNINGS_CATEGORY);
135             }
136             else {
137 0         0 warn $self;
138             }
139 13         92 return $self;
140             }
141              
142              
143 13     13 1 7504 sub alert { goto &warn }
144              
145             sub _find_blame_frame {
146 0     0     my $frame = 1;
147 0           while (1) {
148 0           my ($package) = caller($frame);
149 0 0         last if !$package;
150 0 0         return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
151 0           $frame++;
152             }
153 0           return 0;
154             }
155              
156             1;
157              
158             __END__