]>
Dogcows Code - chaz/p5-File-KDBX/blob - t/error.t
ae467f262b09ef207484cefb10e4ddb08945f050
12 BEGIN { use_ok
'File::KDBX::Error' }
14 subtest
'Errors' => sub {
15 my $error = exception
{
17 $@ = 'last exception';
18 throw
'uh oh', foo
=> 'bar';
20 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
22 $error = exception
{ $error->throw };
23 like
$error, qr/uh oh/, 'Errors can be rethrown';
25 is $error->details->{foo
}, 'bar', 'Errors can have details';
26 is $error->errno+0, 1, 'Errors record copy of errno when thrown';
27 is $error->previous, 'last exception', 'Warnings record copy of the last exception';
29 my $trace = $error->trace;
30 ok
0 < @$trace, 'Errors record a stacktrace';
31 like
$trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
34 local $ENV{DEBUG
} = '';
35 like
"$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace';
39 local $ENV{DEBUG
} = '1';
40 like
"$error", qr!^uh oh at \H+error\.t line \d+\.\nbless!,
41 'Errors stringify with stacktrace when DEBUG environment variable is set';
44 $error = exception
{ File
::KDBX
::Error-
>throw('uh oh') };
45 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor';
46 like
$error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
48 $error = File
::KDBX
::Error-
>new('uh oh');
49 $error = exception
{ $error->throw };
50 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" method';
51 like
$error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
54 subtest
'Warnings' => sub {
55 my $warning = warning
{
57 $@ = 'last exception';
58 alert
'uh oh', foo
=> 'bar';
60 like
$warning, qr/uh oh/, 'Warnings are enabled by default' or diag
'Warnings: ', explain
$warning;
63 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
64 is $warning->details->{foo
}, 'bar', 'Warnings can have details';
65 is $warning->errno+0, 1, 'Warnings record copy of errno when logged';
66 is $warning->previous, 'last exception', 'Warnings record copy of the last exception';
67 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
70 $warning = warning
{ File
::KDBX
::Error-
>warn('uh oh') };
71 like
$warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
73 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
74 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
77 my $error = File
::KDBX
::Error-
>new('uh oh');
78 $warning = warning
{ $error->alert };
79 like
$warning, qr/uh oh/, 'Warnings can be logged using the "alert" method';
81 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
82 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
86 local $File::KDBX
::WARNINGS
= 0;
87 my @warnings = warnings
{ alert
'uh oh' };
88 is @warnings, 0, 'Warnings can be disabled locally'
89 or diag
'Warnings: ', explain
(\
@warnings);
93 skip
'warnings::warnif_at_level is required', 1 if !warnings-
>can('warnif_at_level');
94 no warnings
'File::KDBX';
95 my @warnings = warnings
{ alert
'uh oh' };
96 is @warnings, 0, 'Warnings can be disabled lexically'
97 or diag
'Warnings: ', explain
(\
@warnings);
101 skip
'warnings::fatal_enabled_at_level is required', 1 if !warnings-
>can('fatal_enabled_at_level');
102 use warnings FATAL
=> 'File::KDBX';
103 my $exception = exception
{ alert
'uh oh' };
104 like
$exception, qr/uh oh/, 'Warnings can be fatal';
109 local $SIG{__WARN__
} = sub { $warning = shift };
111 like
$warning, qr/uh oh/, 'Warnings can be caught';
This page took 0.042982 seconds and 3 git commands to generate.