Commit | Line | Data |
9b657a62 |
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 | |
eb8d423f |
16 | use constant PERL510 => ( $] >= 5.0100 ); |
17 | use constant PERL5101 => ( $] >= 5.0101 ); |
14564ebe |
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" )); |
9b657a62 |
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", |
6c4f9c52 |
36 | " loaded") if (! $ENV{PERL_CORE}); |
9b657a62 |
37 | |
38 | my $hints = "autodie::hints"; |
39 | |
40 | # Basic hinting tests |
41 | |
42 | is( $hints->sub_fullname(\©), 'File::Copy::copy' , "Id: copy" ); |
eb8d423f |
43 | is( |
44 | $hints->sub_fullname(\&cp), |
45 | PERL5101 ? 'File::Copy::cp' : 'File::Copy::copy' , "Id: cp" |
46 | ); |
9b657a62 |
47 | |
48 | is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" ); |
eb8d423f |
49 | is( $hints->sub_fullname(\&mv), |
50 | PERL5101 ? 'File::Copy::mv' : 'File::Copy::move' , "Id: mv" |
51 | ); |
9b657a62 |
52 | |
53 | if (PERL510) { |
54 | ok( $hints->get_hints_for(\©)->{scalar}->(0) , |
55 | "copy() hints should fail on 0 for scalars." |
56 | ); |
eb8d423f |
57 | ok( $hints->get_hints_for(\©)->{list}->(0) , |
58 | "copy() hints should fail on 0 for lists." |
59 | ); |
9b657a62 |
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 | |
eb8d423f |
73 | is($@->function, "File::Copy::copy", "Function should be original name"); |
6c4f9c52 |
74 | |
75 | SKIP: { |
14564ebe |
76 | skip("File::Copy is weird on Win32/VMS before 5.10.1", 1) |
77 | if WEIRDO_FILE_COPY; |
6c4f9c52 |
78 | |
79 | is($@->return, 0, "File::Copy returns zero on failure"); |
80 | } |
81 | |
eb8d423f |
82 | is($@->context, "scalar", "File::Copy called in scalar context"); |
83 | |
9b657a62 |
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 | |
eb8d423f |
95 | is($@->function, "File::Copy::copy", "Function should be original name"); |
6c4f9c52 |
96 | |
97 | SKIP: { |
14564ebe |
98 | skip("File::Copy is weird on Win32/VMS before 5.10.1", 1) |
99 | if WEIRDO_FILE_COPY; |
6c4f9c52 |
100 | |
101 | is_deeply($@->return, [0], "File::Copy returns zero on failure"); |
102 | } |
eb8d423f |
103 | is($@->context, "list", "File::Copy called in list context"); |
104 | |
9b657a62 |
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; |