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.0100 );
  17 use constant PERL5101 => ( $] >= 5.0101 );
  18
  19 use Hints_test qw(
  20     fail_on_empty fail_on_false fail_on_undef
  21 );
  22
  23 use autodie qw(fail_on_empty fail_on_false fail_on_undef);
  24
  25 diag("Sub::Identify ", exists( $INC{'Sub/Identify.pm'} ) ? "is" : "is not",
  26      " loaded") if (! $ENV{PERL_CORE});
  27
  28 my $hints = "autodie::hints";
  29
  30 # Basic hinting tests
  31
  32 is( $hints->sub_fullname(\&copy), 'File::Copy::copy' , "Id: copy" );
  33 is(
  34     $hints->sub_fullname(\&cp),
  35     PERL5101 ? 'File::Copy::cp' : 'File::Copy::copy' , "Id: cp"
  36 );
  37
  38 is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" );
  39 is( $hints->sub_fullname(\&mv),
  40     PERL5101 ? 'File::Copy::mv' : 'File::Copy::move' , "Id: mv"
  41 );
  42
  43 if (PERL510) {
  44     ok( $hints->get_hints_for(\&copy)->{scalar}->(0) ,
  45         "copy() hints should fail on 0 for scalars."
  46     );
  47     ok( $hints->get_hints_for(\&copy)->{list}->(0) ,
  48         "copy() hints should fail on 0 for lists."
  49     );
  50 }
  51
  52 # Scalar context test
  53
  54 eval {
  55     use autodie qw(copy);
  56
  57     my $scalar_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
  58 };
  59
  60 isnt("$@", "", "Copying in scalar context should throw an error.");
  61 isa_ok($@, "autodie::exception");
  62
  63 is($@->function, "File::Copy::copy", "Function should be original name");
  64
  65 SKIP: {
  66     skip("File::Copy is weird on Win32 before 5.10.1", 1)
  67         if ( ! PERL5101 and $^O eq "MSWin32" );
  68
  69     is($@->return, 0, "File::Copy returns zero on failure");
  70 }
  71
  72 is($@->context, "scalar", "File::Copy called in scalar context");
  73
  74 # List context test.
  75
  76 eval {
  77     use autodie qw(copy);
  78
  79     my @list_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
  80 };
  81
  82 isnt("$@", "", "Copying in list context should throw an error.");
  83 isa_ok($@, "autodie::exception");
  84
  85 is($@->function, "File::Copy::copy", "Function should be original name");
  86
  87 SKIP: {
  88     skip("File::Copy is weird on Win32 before 5.10.1", 1)
  89         if ( ! PERL5101 and $^O eq "MSWin32" );
  90
  91     is_deeply($@->return, [0], "File::Copy returns zero on failure");
  92 }
  93 is($@->context, "list", "File::Copy called in list context");
  94
  95 # Tests on loaded funcs.
  96
  97 my %tests = (
  98
  99     # Test code             # Exception expected?
 100
 101     'fail_on_empty()'       => 1,
 102     'fail_on_empty(0)'      => 0,
 103     'fail_on_empty(undef)'  => 0,
 104     'fail_on_empty(1)'      => 0,
 105
 106     'fail_on_false()'       => 1,
 107     'fail_on_false(0)'      => 1,
 108     'fail_on_false(undef)'  => 1,
 109     'fail_on_false(1)'      => 0,
 110
 111     'fail_on_undef()'       => 1,
 112     'fail_on_undef(0)'      => 0,
 113     'fail_on_undef(undef)'  => 1,
 114     'fail_on_undef(1)'      => 0,
 115
 116 );
 117
 118 # On Perl 5.8, autodie doesn't correctly propagate into string evals.
 119 # The following snippet forces the use of autodie inside the eval if
 120 # we really really have to.  For 5.10+, we don't want to include this
 121 # fix, because the tests will act as a canary if we screw up string
 122 # eval propagation.
 123
 124 my $perl58_fix = (
 125     $] >= 5.010 ?
 126     "" :
 127     "use autodie qw(fail_on_empty fail_on_false fail_on_undef); "
 128 );
 129
 130 while (my ($test, $exception_expected) = each %tests) {
 131     eval "
 132         $perl58_fix
 133         my \@array = $test;
 134     ";
 135
 136
 137     if ($exception_expected) {
 138         isnt("$@", "", $test);
 139     }
 140     else {
 141         is($@, "", $test);
 142     }
 143 }
 144
 145 1;