6 use Scalar::Util 'refaddr';
7 use Storable 'nfreeze';
9 BEGIN { $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} = 0 }
11 use SQL::Abstract qw(is_plain_value is_literal_value);
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 );
22 # *DELIBERATELY* unspecified
24 bool => sub { ${$_[0]} },
28 SQLATest::SillyBool::Subclass;
30 our @ISA = 'SQLATest::SillyBool';
38 # *DELIBERATELY* unspecified
40 '0+' => sub { ${$_[0]} },
44 SQLATest::SillyInt::Subclass;
46 our @ISA = 'SQLATest::SillyInt';
58 SQLATest::SillierInt::Subclass;
61 '0+' => sub { ${$_[0]} },
62 '+' => sub { ${$_[0]} + $_[1] },
65 our @ISA = 'SQLATest::SillierInt';
74 '0+' => sub { ${$_[0]} },
78 SQLATest::AnalInt::Subclass;
81 '0+' => sub { ${$_[0]} },
84 our @ISA = 'SQLATest::AnalInt';
89 SQLATest::ReasonableInt;
91 # make it match JSON::PP::Boolean
93 '0+' => sub { ${$_[0]} },
94 '++' => sub { $_[0] = ${$_[0]} + 1 },
95 '--' => sub { $_[0] = ${$_[0]} - 1 },
100 SQLATest::ReasonableInt::Subclass;
102 our @ISA = 'SQLATest::ReasonableInt';
107 SQLATest::ReasonableString;
109 # somewhat like DateTime
112 '""' => sub { "${$_[0]}" },
113 '-' => sub { ${$_[0]} - $_[1] },
114 '+' => sub { ${$_[0]} + $_[1] },
118 SQLATest::ReasonableString::Subclass;
120 our @ISA = 'SQLATest::ReasonableString';
124 { class => 'SQLATest::SillyBool', can_math => 0, should_str => 1 },
125 { class => 'SQLATest::SillyBool::Subclass', can_math => 0, should_str => 1 },
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 },
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 },
138 my $num = bless( \do { my $foo = 42 }, $case->{class} );
140 my $can_str = eval { "$num" eq 42 } || 0;
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 };
147 my $can_math = eval { ($num + 1) == 43 } ? 1 : 0;
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 };
154 my $can_cmp = eval { my $dum = ($num eq "nope"); 1 } || 0;
160 ok $num, 'bool ctx works';
162 if (STRINGIFIER_CAN_RETURN_IVS and $can_cmp) {
166 "stringification detected on $case->{class}",
167 ) || diag explain $case;
170 # is_deeply does not do nummify/stringify cmps properly
171 # but we can always compare the ice
173 ( nfreeze( is_plain_value $num ) eq nfreeze( \$num ) ),
174 "stringification without cmp capability detected on $case->{class}"
175 ) || diag explain $case;
179 refaddr( ${is_plain_value($num)} ),
181 "Same reference (blessed object) returned",
185 is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" )
186 || diag explain $case;
189 if ($case->{can_math}) {
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');
202 'fallback stringification detected'
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';
210 is_plain_value { -value => [] },
219 'nonvalues correctly recognized'
223 for (undef, { -value => undef }) {
227 'NULL -value recognized'
232 is_literal_value \'sql',
234 'literal correctly recognized and unpacked'
238 is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ],
239 [ 'sql', 'bind1', [ {} => 'bind2' ] ],
240 'literal with binds correctly recognized and unpacked'
244 for ([], {}, \'', undef) {
246 is_literal_value { -ident => $_ },
248 'illegal -ident does not trip up detection'