1#!/usr/bin/perl -w
2use strict;
3use warnings;
4use autodie::hints;
5
6use FindBin;
7use lib "$FindBin::Bin/lib";
8
9use File::Copy qw(copy move cp mv);
10
11use Test::More 'no_plan';
12
13use constant NO_SUCH_FILE  => "this_file_had_better_not_exist";
14use constant NO_SUCH_FILE2 => "this_file_had_better_not_exist_xyzzy";
15
16use constant PERL510  => ( $] >= 5.0100 );
17use constant PERL5101 => ( $] >= 5.0101 );
18use 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
26use constant WEIRDO_FILE_COPY =>
27    ( ! PERL5102 and ( $^O eq "MSWin32" or $^O eq "VMS" ));
28
29use Hints_test qw(
30    fail_on_empty fail_on_false fail_on_undef
31);
32
33use autodie qw(fail_on_empty fail_on_false fail_on_undef);
34
35diag("Sub::Identify ", exists( $INC{'Sub/Identify.pm'} ) ? "is" : "is not",
36     " loaded") if (! $ENV{PERL_CORE});
37
38my $hints = "autodie::hints";
39
40# Basic hinting tests
41
42is( $hints->sub_fullname(\&copy), 'File::Copy::copy' , "Id: copy" );
43is(
44    $hints->sub_fullname(\&cp),
45    PERL5101 ? 'File::Copy::cp' : 'File::Copy::copy' , "Id: cp"
46);
47
48is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" );
49is( $hints->sub_fullname(\&mv),
50    PERL5101 ? 'File::Copy::mv' : 'File::Copy::move' , "Id: mv"
51);
52
53if (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
64eval {
65    use autodie qw(copy);
66
67    my $scalar_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
68};
69
70isnt("$@", "", "Copying in scalar context should throw an error.");
71isa_ok($@, "autodie::exception");
72
73is($@->function, "File::Copy::copy", "Function should be original name");
74
75SKIP: {
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
82is($@->context, "scalar", "File::Copy called in scalar context");
83
84# List context test.
85
86eval {
87    use autodie qw(copy);
88
89    my @list_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
90};
91
92isnt("$@", "", "Copying in list context should throw an error.");
93isa_ok($@, "autodie::exception");
94
95is($@->function, "File::Copy::copy", "Function should be original name");
96
97SKIP: {
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}
103is($@->context, "list", "File::Copy called in list context");
104
105# Tests on loaded funcs.
106
107my %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
134my $perl58_fix = (
135    $] >= 5.010 ?
136    "" :
137    "use autodie qw(fail_on_empty fail_on_false fail_on_undef); "
138);
139
140while (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
1551;
156