]>
Dogcows Code - chaz/p5-File-KDBX/blob - error.t
2caab016bec28de11d39c874ebc169a38dc35701
13 subtest
'Errors' => sub {
14 my $error = exception
{
16 $@ = 'last exception';
17 throw
'uh oh', foo
=> 'bar';
19 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
21 $error = exception
{ $error->throw };
22 like
$error, qr/uh oh/, 'Errors can be rethrown';
24 is $error->details->{foo
}, 'bar', 'Errors can have details';
25 is $error->errno+0, 1, 'Errors record copy of errno when thrown';
26 is $error->previous, 'last exception', 'Warnings record copy of the last exception';
28 my $trace = $error->trace;
29 ok
0 < @$trace, 'Errors record a stacktrace';
30 like
$trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
33 local $ENV{DEBUG
} = '';
34 like
"$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace';
38 local $ENV{DEBUG
} = '1';
39 like
"$error", qr!^uh oh at \H+error\.t line \d+\.\nbless!,
40 'Errors stringify with stacktrace when DEBUG environment variable is set';
43 $error = exception
{ File
::KDBX
::Error-
>throw('uh oh') };
44 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor';
45 like
$error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
47 $error = File
::KDBX
::Error-
>new('uh oh');
48 $error = exception
{ $error->throw };
49 like
$error, qr/uh oh/, 'Errors can be thrown using the "throw" method';
50 like
$error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
53 subtest
'Warnings' => sub {
54 my $warning = warning
{
56 $@ = 'last exception';
57 alert
'uh oh', foo
=> 'bar';
59 like
$warning, qr/uh oh/, 'Warnings are enabled by default' or diag
'Warnings: ', explain
$warning;
62 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
63 is $warning->details->{foo
}, 'bar', 'Warnings can have details';
64 is $warning->errno+0, 1, 'Warnings record copy of errno when logged';
65 is $warning->previous, 'last exception', 'Warnings record copy of the last exception';
66 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
69 $warning = warning
{ File
::KDBX
::Error-
>warn('uh oh') };
70 like
$warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
72 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
73 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
76 my $error = File
::KDBX
::Error-
>new('uh oh');
77 $warning = warning
{ $error->alert };
78 like
$warning, qr/uh oh/, 'Warnings can be logged using the "alert" method';
80 skip
'Warning object requires Perl 5.14 or later' if $] < 5.014;
81 like
$warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
85 local $File::KDBX
::WARNINGS
= 0;
86 my @warnings = warnings
{ alert
'uh oh' };
87 is @warnings, 0, 'Warnings can be disabled locally'
88 or diag
'Warnings: ', explain
(\
@warnings);
92 skip
'warnings::warnif_at_level is required', 1 if !warnings-
>can('warnif_at_level');
93 no warnings
'File::KDBX';
94 my @warnings = warnings
{ alert
'uh oh' };
95 is @warnings, 0, 'Warnings can be disabled lexically'
96 or diag
'Warnings: ', explain
(\
@warnings);
100 skip
'warnings::fatal_enabled_at_level is required', 1 if !warnings-
>can('fatal_enabled_at_level');
101 use warnings FATAL
=> 'File::KDBX';
102 my $exception = exception
{ alert
'uh oh' };
103 like
$exception, qr/uh oh/, 'Warnings can be fatal';
108 local $SIG{__WARN__
} = sub { $warning = shift };
110 like
$warning, qr/uh oh/, 'Warnings can be caught';
This page took 0.041312 seconds and 3 git commands to generate.