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

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use lib 't/lib';
   7 use TestCommon;
   8
   9 use File::KDBX::Error;
  10 use File::KDBX;
  11 use Test::More;
  12
  13 subtest 'Errors' => sub {
  14     my $error = exception {
  15         local $! = 1;
  16         $@ = 'last exception';
  17         throw 'uh oh', foo => 'bar';
  18     };
  19     like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
  20
  21     $error = exception { $error->throw };
  22     like $error, qr/uh oh/, 'Errors can be rethrown';
  23
  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';
  27
  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';
  31
  32     {
  33         local $ENV{DEBUG} = '';
  34         like "$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace';
  35     }
  36
  37     {
  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';
  41     }
  42
  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';
  46
  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';
  51 };
  52
  53 subtest 'Warnings' => sub {
  54     my $warning = warning {
  55         local $! = 1;
  56         $@ = 'last exception';
  57         alert 'uh oh', foo => 'bar';
  58     };
  59     like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning;
  60
  61     SKIP: {
  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';
  67     };
  68
  69     $warning = warning { File::KDBX::Error->warn('uh oh') };
  70     like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
  71     SKIP: {
  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';
  74     };
  75
  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';
  79     SKIP: {
  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';
  82     };
  83
  84     {
  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);
  89     }
  90
  91     SKIP: {
  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);
  97     }
  98
  99     SKIP: {
 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';
 104     }
 105
 106     {
 107         my $warning;
 108         local $SIG{__WARN__} = sub { $warning = shift };
 109         alert 'uh oh';
 110         like $warning, qr/uh oh/, 'Warnings can be caught';
 111     }
 112 };
 113
 114 done_testing;