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;
  10 use Test::More;
  11
  12 BEGIN { use_ok 'File::KDBX::Error' }
  13
  14 subtest 'Errors' => sub {
  15     my $error = exception {
  16         local $! = 1;
  17         $@ = 'last exception';
  18         throw 'uh oh', foo => 'bar';
  19     };
  20     like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
  21
  22     $error = exception { $error->throw };
  23     like $error, qr/uh oh/, 'Errors can be rethrown';
  24
  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';
  28
  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';
  32
  33     {
  34         local $ENV{DEBUG} = '';
  35         like "$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace';
  36     }
  37
  38     {
  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';
  42     }
  43
  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';
  47
  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';
  52 };
  53
  54 subtest 'Warnings' => sub {
  55     my $warning = warning {
  56         local $! = 1;
  57         $@ = 'last exception';
  58         alert 'uh oh', foo => 'bar';
  59     };
  60     like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning;
  61
  62     SKIP: {
  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';
  68     };
  69
  70     $warning = warning { File::KDBX::Error->warn('uh oh') };
  71     like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
  72     SKIP: {
  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';
  75     };
  76
  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';
  80     SKIP: {
  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';
  83     };
  84
  85     {
  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);
  90     }
  91
  92     SKIP: {
  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);
  98     }
  99
 100     SKIP: {
 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';
 105     }
 106
 107     {
 108         my $warning;
 109         local $SIG{__WARN__} = sub { $warning = shift };
 110         alert 'uh oh';
 111         like $warning, qr/uh oh/, 'Warnings can be caught';
 112     }
 113 };
 114
 115 done_testing;