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   519 use 5.010;
  27         84  
5 27     27   143 use warnings;
  27         42  
  27         547  
6 27     27   117 use strict;
  27         54  
  27         668  
7              
8 27     27   139 use Exporter qw(import);
  27         49  
  27         795  
9 27     27   157 use Scalar::Util qw(blessed looks_like_number);
  27         78  
  27         2491  
10 27     27   10529 use namespace::clean -except => 'import';
  27         363164  
  27         160  
11              
12             our $VERSION = '0.906'; # VERSION
13              
14             our @EXPORT = qw(alert error throw);
15              
16             my $WARNINGS_CATEGORY;
17             BEGIN {
18 27     27   10266 $WARNINGS_CATEGORY = 'File::KDBX';
19 27 50       309 if (warnings->can('register_categories')) {
20 27         2688 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         94 my $debug = $ENV{DEBUG};
27 27 50       137 $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       896 $debug == 4 ? sub() { 4 } : sub() { 0 };
    50          
    50          
    50          
32             }
33              
34 27     27   28037 use overload '""' => 'to_string', cmp => '_cmp';
  27         23194  
  27         196  
35              
36              
37             sub new {
38 429     429 1 1270 my $class = shift;
39 429 50       1595 my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
40              
41 429         812 my $error = delete $args{_error};
42 429         573 my $e = $error;
43 429         1024 $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 429   50     1070 trace => do {
51 429         1981 require Carp;
52 429         934 local $Carp::CarpInternal{''.__PACKAGE__} = 1;
53 429 100       42317 my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error);
54 429 50       141864 [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
  5322         58830  
55             },
56             }, $class;
57 429         2023 chomp $self->{error};
58 429         914 return $self;
59             }
60              
61              
62             sub error {
63 431 100 66 431 1 1522 my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
64 431 100 66     2436 my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
    100          
65             ? shift
66             : $class
67             ? $class->new(@_)
68             : __PACKAGE__->new(@_);
69 431         661 return $self;
70             }
71              
72              
73             sub details {
74 2     2 1 842 my $self = shift;
75 2         6 my %args = @_;
76 2   50     8 my $details = $self->{details} //= {};
77 2         5 @$details{keys %args} = values %args;
78 2         9 return $details;
79             }
80              
81              
82              
83 2     2 1 13 sub errno { $_[0]->{errno} }
84 2     2 1 9 sub previous { $_[0]->{previous} }
85 6   50 6 1 1711 sub trace { $_[0]->{trace} // [] }
86 0   0 0 1 0 sub type { $_[0]->details->{type} // '' }
87              
88              
89 5     5   27 sub _cmp { "$_[0]" cmp "$_[1]" }
90              
91             sub to_string {
92 118     118 1 14782 my $self = shift;
93 118         279 my $msg = "$self->{trace}[0]";
94 118 50       569 $msg .= '.' if $msg !~ /[\.\!\?]$/;
95 118         171 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       305 $msg .= "\n" if $msg !~ /\n$/;
106 118         927 return $msg;
107             }
108              
109              
110             sub throw {
111 416     416 1 4571 my $self = error(@_);
112 416         2467 die $self;
113             }
114              
115              
116             sub warn {
117 14 100 100 14 1 697 return if !($File::KDBX::WARNINGS // 1);
118              
119 13         43 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       123 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       161 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       1055 warn $self if $enabled->($WARNINGS_CATEGORY);
135             }
136             else {
137 0         0 warn $self;
138             }
139 13         86 return $self;
140             }
141              
142              
143 13     13 1 7119 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__