Dogcows Code - chaz/p5-File-KDBX/blob - t/error.t

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5
   6 BEGIN { delete $ENV{DEBUG} }
   7
   8 use lib 't/lib';
   9 use TestCommon;
  10
  11 use File::KDBX::Error;
  12 use File::KDBX;
  13 use Test::More;
  14
  15 subtest 'Errors' => sub {
  16     my $error = exception {
  17         local $! = 1;
  18         $@ = 'last exception';
  19         throw 'uh oh', foo => 'bar';
  20     };
  21     like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
  22
  23     $error = exception { $error->throw };
  24     like $error, qr/uh oh/, 'Errors can be rethrown';
  25
  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';
  29
  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';
  33
  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';
  37
  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';
  42 };
  43
  44 subtest 'Warnings' => sub {
  45     my $warning = warning {
  46         local $! = 1;
  47         $@ = 'last exception';
  48         alert 'uh oh', foo => 'bar';
  49     };
  50     like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning;
  51
  52     SKIP: {
  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';
  58     };
  59
  60     $warning = warning { File::KDBX::Error->warn('uh oh') };
  61     like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
  62     SKIP: {
  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';
  65     };
  66
  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';
  70     SKIP: {
  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';
  73     };
  74
  75     {
  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);
  80     }
  81
  82     SKIP: {
  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);
  88     }
  89
  90     SKIP: {
  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';
  95     }
  96
  97     {
  98         my $warning;
  99         local $SIG{__WARN__} = sub { $warning = shift };
 100         alert 'uh oh';
 101         like $warning, qr/uh oh/, 'Warnings can be caught';
 102     }
 103 };
 104
 105 done_testing;