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