lib/autodie/t/hints.t

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use warnings;
   4 use autodie::hints;
   5
   6 use FindBin;
   7 use lib "$FindBin::Bin/lib";
   8
   9 use File::Copy qw(copy move cp mv);
  10
  11 use Test::More 'no_plan';
  12
  13 use constant NO_SUCH_FILE  => "this_file_had_better_not_exist";
  14 use constant NO_SUCH_FILE2 => "this_file_had_better_not_exist_xyzzy";
  15
  16 use constant PERL510 => ( $] >= 5.010 );
  17
  18 use Hints_test qw(
  19     fail_on_empty fail_on_false fail_on_undef
  20 );
  21
  22 use autodie qw(fail_on_empty fail_on_false fail_on_undef);
  23
  24 diag("Sub::Identify ", exists( $INC{'Sub/Identify.pm'} ) ? "is" : "is not",
  25      " loaded");
  26
  27 my $hints = "autodie::hints";
  28
  29 # Basic hinting tests
  30
  31 is( $hints->sub_fullname(\&copy), 'File::Copy::copy' , "Id: copy" );
  32 is( $hints->sub_fullname(\&cp),   'File::Copy::copy' , "Id: cp"   );
  33
  34 is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" );
  35 is( $hints->sub_fullname(\&mv),   'File::Copy::move' , "Id: mv"   );
  36
  37 if (PERL510) {
  38     ok( $hints->get_hints_for(\&copy)->{scalar}->(0) ,
  39         "copy() hints should fail on 0 for scalars."
  40     );
  41 }
  42
  43 # Scalar context test
  44
  45 eval {
  46     use autodie qw(copy);
  47
  48     my $scalar_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
  49 };
  50
  51 isnt("$@", "", "Copying in scalar context should throw an error.");
  52 isa_ok($@, "autodie::exception");
  53
  54 # List context test.
  55
  56 eval {
  57     use autodie qw(copy);
  58
  59     my @list_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
  60 };
  61
  62 isnt("$@", "", "Copying in list context should throw an error.");
  63 isa_ok($@, "autodie::exception");
  64
  65 # Tests on loaded funcs.
  66
  67 my %tests = (
  68
  69     # Test code             # Exception expected?
  70
  71     'fail_on_empty()'       => 1,
  72     'fail_on_empty(0)'      => 0,
  73     'fail_on_empty(undef)'  => 0,
  74     'fail_on_empty(1)'      => 0,
  75
  76     'fail_on_false()'       => 1,
  77     'fail_on_false(0)'      => 1,
  78     'fail_on_false(undef)'  => 1,
  79     'fail_on_false(1)'      => 0,
  80
  81     'fail_on_undef()'       => 1,
  82     'fail_on_undef(0)'      => 0,
  83     'fail_on_undef(undef)'  => 1,
  84     'fail_on_undef(1)'      => 0,
  85
  86 );
  87
  88 # On Perl 5.8, autodie doesn't correctly propagate into string evals.
  89 # The following snippet forces the use of autodie inside the eval if
  90 # we really really have to.  For 5.10+, we don't want to include this
  91 # fix, because the tests will act as a canary if we screw up string
  92 # eval propagation.
  93
  94 my $perl58_fix = (
  95     $] >= 5.010 ?
  96     "" :
  97     "use autodie qw(fail_on_empty fail_on_false fail_on_undef); "
  98 );
  99
 100 while (my ($test, $exception_expected) = each %tests) {
 101     eval "
 102         $perl58_fix
 103         my \@array = $test;
 104     ";
 105
 106
 107     if ($exception_expected) {
 108         isnt("$@", "", $test);
 109     }
 110     else {
 111         is($@, "", $test);
 112     }
 113 }
 114
 115 1;