]>
Dogcows Code - chaz/p5-File-KDBX/blob - t/error.t
6 BEGIN { delete $ENV{DEBUG
} }
11 use File
::KDBX
::Error
;
15 subtest
'Errors' => sub {
16 my $error = exception
{
18 $@ = 'last exception';
19 throw
'uh oh', foo
=> 'bar';
21 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
23 $error = exception
{ $error->throw };
24 like
$error, qr/uh oh/, 'Errors can be rethrown';
26 is $error->details->{foo
}, 'bar', 'Errors can have details';
27 is $error->errno+0, 1, 'Errors record copy of errno when thrown';
28 is $error->previous, 'last exception', 'Warnings record copy of the last exception';
30 my $trace = $error->trace;
31 ok
0 < @$trace, 'Errors record a stacktrace';
32 like
$trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
34 $error = exception
{ File
::KDBX
::Error-
>throw('uh oh') };
35 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor';
36 like
$error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
38 $error = File
::KDBX
::Error-
>new('uh oh');
39 $error = exception
{ $error->throw };
40 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" method';
41 like
$error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
44 subtest
'Warnings' => sub {
45 my $warning = warning
{
47 $@ = 'last exception';
48 alert
'uh oh', foo
=> 'bar';
50 like
$warning, qr/uh oh/, 'Warnings are enabled by default' or diag
'Warnings: ', explain
$warning;
53 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
54 is $warning->details->{foo
}, 'bar', 'Warnings can have details';
55 is $warning->errno+0, 1, 'Warnings record copy of errno when logged';
56 is $warning->previous, 'last exception', 'Warnings record copy of the last exception';
57 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
60 $warning = warning
{ File
::KDBX
::Error-
>warn('uh oh') };
61 like
$warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
63 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
64 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
67 my $error = File
::KDBX
::Error-
>new('uh oh');
68 $warning = warning
{ $error->alert };
69 like
$warning, qr/uh oh/, 'Warnings can be logged using the "alert" method';
71 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
72 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
76 local $File::KDBX
::WARNINGS
= 0;
77 my @warnings = warnings
{ alert
'uh oh' };
78 is @warnings, 0, 'Warnings can be disabled locally'
79 or diag
'Warnings: ', explain
(\
@warnings);
83 skip
'warnings::warnif_at_level is required', 1 if !warnings
::->can('warnif_at_level');
84 no warnings
'File::KDBX';
85 my @warnings = warnings
{ alert
'uh oh' };
86 is @warnings, 0, 'Warnings can be disabled lexically'
87 or diag
'Warnings: ', explain
(\
@warnings);
91 skip
'warnings::fatal_enabled_at_level is required', 1 if !warnings
::->can('fatal_enabled_at_level');
92 use warnings FATAL
=> 'File::KDBX';
93 my $exception = exception
{ alert
'uh oh' };
94 like
$exception, qr/uh oh/, 'Warnings can be fatal';
99 local $SIG{__WARN__
} = sub { $warning = shift };
101 like
$warning, qr/uh oh/, 'Warnings can be caught';
This page took 0.043353 seconds and 4 git commands to generate.