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