1#!/usr/bin/perl -w
2use strict;
3use warnings;
4use autodie::hints;
5use Test::More;
6
7use constant PERL510 => ( $] >= 5.010 );
8
9BEGIN {
10    if (not PERL510) {
11        plan skip_all => "Only subroutine hints supported in 5.8.x";
12    }
13    else {
14        plan 'no_plan';
15    }
16}
17
18use FindBin;
19use lib "$FindBin::Bin/lib";
20use Hints_pod_examples qw(
21	undef_scalar false_scalar zero_scalar empty_list default_list
22	empty_or_false_list undef_n_error_list foo re_fail bar
23	think_positive my_system
24);
25use autodie qw( !
26	undef_scalar false_scalar zero_scalar empty_list default_list
27	empty_or_false_list undef_n_error_list foo re_fail bar
28	think_positive my_system
29);
30
31my %scalar_tests = (
32
33    # Test code             # Exception expected?
34
35    'undef_scalar()'        => 1,
36    'undef_scalar(1)',      => 0,
37    'undef_scalar(0)',      => 0,
38    'undef_scalar("")',     => 0,
39
40    'false_scalar(0)',      => 1,
41    'false_scalar()',       => 1,
42    'false_scalar(undef)',  => 1,
43    'false_scalar("")',     => 1,
44    'false_scalar(1)',      => 0,
45    'false_scalar("1")',    => 0,
46
47    'zero_scalar("0")',     => 1,
48    'zero_scalar(0)',       => 1,
49    'zero_scalar(1)',       => 0,
50    'zero_scalar(undef)',   => 0,
51    'zero_scalar("")',      => 0,
52
53    'foo(0)',	            => 1,
54    'foo(undef)',	    => 0,
55    'foo(1)',	            => 0,
56
57    'bar(0)',	            => 1,
58    'bar(undef)',	    => 0,
59    'bar(1)',	            => 0,
60
61    're_fail(-1)',          => 0,
62    're_fail("FAIL")',      => 1,
63    're_fail("_FAIL")',     => 1,
64    're_fail("_fail")',     => 0,
65    're_fail("fail")',      => 0,
66
67    'think_positive(-1)'    => 1,
68    'think_positive(-2)'    => 1,
69    'think_positive(0)'     => 0,
70    'think_positive(1)'     => 0,
71    'think_positive(2)'     => 0,
72
73    'my_system(1)'          => 1,
74    'my_system(2)'          => 1,
75    'my_system(0)'          => 0,
76
77);
78
79my %list_tests = (
80
81    'empty_list()',         => 1,
82    'empty_list(())',       => 1,
83    'empty_list([])',       => 0,
84    'empty_list(0)',        => 0,
85    'empty_list("")',       => 0,
86    'empty_list(undef)',    => 0,
87
88    'default_list()',       => 1,
89    'default_list(0)',      => 0,
90    'default_list("")',     => 0,
91    'default_list(undef)',  => 1,
92    'default_list(1)',      => 0,
93    'default_list("str")',  => 0,
94    'default_list(1, 2)',   => 0,
95
96    'empty_or_false_list()',     => 1,
97    'empty_or_false_list(())',   => 1,
98    'empty_or_false_list(0)',    => 1,
99    'empty_or_false_list(undef)',=> 1,
100    'empty_or_false_list("")',   => 1,
101    'empty_or_false_list("0")',  => 1,
102    'empty_or_false_list(1,2)',  => 0,
103    'empty_or_false_list("a")',  => 0,
104
105    'undef_n_error_list(undef, 1)'   => 1,
106    'undef_n_error_list(undef, "a")' => 1,
107    'undef_n_error_list()'           => 0,
108    'undef_n_error_list(0, 1)'       => 0,
109    'undef_n_error_list("", 1)'      => 0,
110    'undef_n_error_list(1)'          => 0,
111
112    'foo(0)',	            => 1,
113    'foo(undef)',	    => 0,
114    'foo(1)',	            => 0,
115
116    'bar(0)',	            => 1,
117    'bar(undef)',	    => 0,
118    'bar(1)',	            => 0,
119
120    're_fail(-1)',          => 1,
121    're_fail("FAIL")',      => 0,
122    're_fail("_FAIL")',     => 0,
123    're_fail("_fail")',     => 0,
124    're_fail("fail")',      => 0,
125
126    'think_positive(-1)'    => 1,
127    'think_positive(-2)'    => 1,
128    'think_positive(0)'     => 0,
129    'think_positive(1)'     => 0,
130    'think_positive(2)'     => 0,
131
132    'my_system(1)'          => 1,
133    'my_system(2)'          => 1,
134    'my_system(0)'          => 0,
135
136);
137
138# On Perl 5.8, autodie doesn't correctly propagate into string evals.
139# The following snippet forces the use of autodie inside the eval if
140# we really really have to.  For 5.10+, we don't want to include this
141# fix, because the tests will act as a canary if we screw up string
142# eval propagation.
143
144my $perl58_fix = (
145    PERL510 ?
146    q{} :
147    q{use autodie qw(
148	undef_scalar false_scalar zero_scalar empty_list default_list
149	empty_or_false_list undef_n_error_list foo re_fail bar
150	think_positive my_system bizarro_system
151    );}
152);
153
154# Some of the tests provide different hints for scalar or list context
155# NOTE: these tests are sensitive to order (not sure why) therefore
156# this loop must use a sorted list of keys . Otherwise there is an occasional
157# failure like this:
158#
159#   Failed test 'scalar test - zero_scalar("")'
160#   at cpan/autodie/t/hints_pod_examples.t line 168.
161#          got: 'Can't zero_scalar(''):  at cpan/autodie/t/hints_pod_examples.t line 157
162# '
163#     expected: ''
164#
165#
166#         my $scalar = zero_scalar("");
167#         1;
168
169
170foreach my $test (sort keys %scalar_tests) {
171    my $exception_expected= $scalar_tests{$test};
172    my $ok= eval(my $code= "
173        $perl58_fix
174        my \$scalar = $test;
175        1;
176    ");
177
178    if ($exception_expected) {
179        isnt($ok ? "" : "$@", "", "scalar test - $test")
180            or diag($code);
181    }
182    else {
183        is($ok ? "" : "$@", "", "scalar test - $test")
184            or diag($code);
185    }
186}
187
188
189# this set of test is not *known* to be order dependent however we sort it anyway out caution
190foreach my $test (sort keys %list_tests) {
191    my $exception_expected= $list_tests{$test};
192    eval "
193        $perl58_fix
194        my \@array = $test;
195    ";
196
197    if ($exception_expected) {
198        isnt("$@", "", "array test - $test");
199    }
200    else {
201        is($@, "", "array test - $test");
202    }
203}
204
2051;
206