Commit | Line | Data |
0da0fe34 |
1 | use warnings; |
2 | use strict; |
3 | |
4 | use Test::More; |
5 | use Test::Exception; |
d0ecdb28 |
6 | use Scalar::Util 'refaddr'; |
7 | use Storable 'nfreeze'; |
0da0fe34 |
8 | |
9 | use SQL::Abstract qw(is_plain_value is_literal_value); |
10 | |
a2bd8f87 |
11 | # fallback setting is inheriting starting p5 50853fa9 (run up to 5.17.0) |
12 | use constant OVERLOAD_FALLBACK_INHERITS => ( ($] < 5.017) ? 0 : 1 ); |
13 | use constant STRINGIFIER_CAN_RETURN_IVS => ( ($] < 5.008) ? 0 : 1 ); |
14 | |
0da0fe34 |
15 | { |
16 | package # hideee |
17 | SQLATest::SillyInt; |
18 | |
19 | use overload |
20 | # *DELIBERATELY* unspecified |
21 | #fallback => 1, |
22 | '0+' => sub { ${$_[0]} }, |
23 | ; |
24 | |
25 | package # hideee |
26 | SQLATest::SillyInt::Subclass; |
27 | |
28 | our @ISA = 'SQLATest::SillyInt'; |
29 | } |
30 | |
31 | { |
32 | package # hideee |
33 | SQLATest::SillierInt; |
34 | |
35 | use overload |
36 | fallback => 0, |
37 | ; |
38 | |
39 | package # hideee |
40 | SQLATest::SillierInt::Subclass; |
41 | |
42 | use overload |
43 | '0+' => sub { ${$_[0]} }, |
44 | '+' => sub { ${$_[0]} + $_[1] }, |
45 | ; |
46 | |
47 | our @ISA = 'SQLATest::SillierInt'; |
48 | } |
49 | |
0da0fe34 |
50 | { |
a2bd8f87 |
51 | package # hideee |
52 | SQLATest::AnalInt; |
53 | |
54 | use overload |
55 | fallback => 0, |
56 | '0+' => sub { ${$_[0]} }, |
57 | ; |
58 | |
59 | package # hideee |
60 | SQLATest::AnalInt::Subclass; |
61 | |
62 | use overload |
63 | '0+' => sub { ${$_[0]} }, |
64 | ; |
65 | |
66 | our @ISA = 'SQLATest::AnalInt'; |
67 | } |
68 | |
69 | { |
ad5ca8e9 |
70 | package # hidee |
71 | SQLATest::ReasonableInt; |
72 | |
73 | # make it match JSON::PP::Boolean |
74 | use overload |
75 | '0+' => sub { ${$_[0]} }, |
76 | '++' => sub { $_[0] = ${$_[0]} + 1 }, |
77 | '--' => sub { $_[0] = ${$_[0]} - 1 }, |
78 | fallback => 1, |
79 | ; |
a2bd8f87 |
80 | |
81 | package # hideee |
82 | SQLATest::ReasonableInt::Subclass; |
83 | |
84 | our @ISA = 'SQLATest::ReasonableInt'; |
85 | } |
86 | |
87 | { |
88 | package # hidee |
89 | SQLATest::ReasonableString; |
90 | |
91 | # somewhat like DateTime |
92 | use overload |
93 | 'fallback' => 1, |
94 | '""' => sub { "${$_[0]}" }, |
95 | '-' => sub { ${$_[0]} - $_[1] }, |
96 | '+' => sub { ${$_[0]} + $_[1] }, |
97 | ; |
98 | |
99 | package # hideee |
100 | SQLATest::ReasonableString::Subclass; |
101 | |
102 | our @ISA = 'SQLATest::ReasonableString'; |
ad5ca8e9 |
103 | } |
104 | |
105 | for my $case ( |
106 | { class => 'SQLATest::SillyInt', can_math => 0, should_str => 1 }, |
107 | { class => 'SQLATest::SillyInt::Subclass', can_math => 0, should_str => 1 }, |
108 | { class => 'SQLATest::SillierInt', can_math => 0, should_str => 0 }, |
a2bd8f87 |
109 | { class => 'SQLATest::SillierInt::Subclass',can_math => 1, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, |
110 | { class => 'SQLATest::AnalInt', can_math => 0, should_str => 0 }, |
111 | { class => 'SQLATest::AnalInt::Subclass', can_math => 0, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, |
112 | { class => 'SQLATest::ReasonableInt', can_math => 1, should_str => 1 }, |
113 | { class => 'SQLATest::ReasonableInt::Subclass', can_math => 1, should_str => 1 }, |
114 | { class => 'SQLATest::ReasonableString', can_math => 1, should_str => 1 }, |
115 | { class => 'SQLATest::ReasonableString::Subclass',can_math => 1, should_str => 1 }, |
ad5ca8e9 |
116 | ) { |
117 | |
118 | my $num = bless( \do { my $foo = 42 }, $case->{class} ); |
119 | |
120 | my $can_str = eval { "$num" eq 42 } || 0; |
121 | |
122 | ok ( |
123 | !($can_str xor $case->{should_str}), |
124 | "should_str setting for $case->{class} matches perl behavior", |
125 | ) || diag explain { %$case, can_str => $can_str }; |
126 | |
127 | my $can_math = eval { ($num + 1) == 43 } ? 1 : 0; |
128 | |
129 | ok ( |
130 | !($can_math xor $case->{can_math}), |
131 | "can_math setting for $case->{class} matches perl behavior", |
132 | ) || diag explain { %$case, actual_can_math => $can_math }; |
133 | |
a2bd8f87 |
134 | my $can_cmp = eval { my $dum = ($num eq "nope"); 1 } || 0; |
ad5ca8e9 |
135 | |
136 | for (1,2) { |
137 | |
138 | if ($can_str) { |
139 | |
140 | ok $num, 'bool ctx works'; |
141 | |
a2bd8f87 |
142 | if (STRINGIFIER_CAN_RETURN_IVS and $can_cmp) { |
ad5ca8e9 |
143 | is_deeply( |
144 | is_plain_value $num, |
966200cc |
145 | \$num, |
ad5ca8e9 |
146 | "stringification detected on $case->{class}", |
147 | ) || diag explain $case; |
148 | } |
149 | else { |
150 | # is_deeply does not do nummify/stringify cmps properly |
151 | # but we can always compare the ice |
152 | ok( |
966200cc |
153 | ( nfreeze( is_plain_value $num ) eq nfreeze( \$num ) ), |
ad5ca8e9 |
154 | "stringification without cmp capability detected on $case->{class}" |
155 | ) || diag explain $case; |
156 | } |
157 | |
158 | is ( |
966200cc |
159 | refaddr( ${is_plain_value($num)} ), |
ad5ca8e9 |
160 | refaddr $num, |
161 | "Same reference (blessed object) returned", |
162 | ); |
163 | } |
164 | else { |
165 | is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" ) |
166 | || diag explain $case; |
167 | } |
168 | |
169 | if ($case->{can_math}) { |
170 | is ($num+1, 43); |
171 | } |
d0ecdb28 |
172 | } |
0da0fe34 |
173 | } |
174 | |
ad5ca8e9 |
175 | lives_ok { |
176 | my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' ); |
177 | cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly'); |
178 | cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly'); |
179 | is_deeply( |
180 | is_plain_value $num, |
966200cc |
181 | \23, |
ad5ca8e9 |
182 | 'fallback stringification detected' |
183 | ); |
184 | cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly'); |
185 | cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly'); |
186 | } 'overload testing lives'; |
187 | |
188 | |
0da0fe34 |
189 | is_deeply |
190 | is_plain_value { -value => [] }, |
966200cc |
191 | \[], |
0da0fe34 |
192 | '-value recognized' |
193 | ; |
194 | |
195 | for ([], {}, \'') { |
196 | is |
197 | is_plain_value $_, |
198 | undef, |
199 | 'nonvalues correctly recognized' |
200 | ; |
201 | } |
202 | |
203 | for (undef, { -value => undef }) { |
204 | is_deeply |
205 | is_plain_value $_, |
966200cc |
206 | \undef, |
0da0fe34 |
207 | 'NULL -value recognized' |
208 | ; |
209 | } |
210 | |
211 | is_deeply |
212 | is_literal_value { -ident => 'foo' }, |
213 | [ 'foo' ], |
214 | '-ident recognized as literal' |
215 | ; |
216 | |
217 | is_deeply |
218 | is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ], |
219 | [ 'sql', 'bind1', [ {} => 'bind2' ] ], |
220 | 'literal correctly unpacked' |
221 | ; |
222 | |
223 | |
224 | for ([], {}, \'', undef) { |
225 | is |
226 | is_literal_value { -ident => $_ }, |
227 | undef, |
228 | 'illegal -ident does not trip up detection' |
229 | ; |
230 | } |
231 | |
232 | done_testing; |