line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package SQL::Abstract::Test; # see doc at end of file |
2
|
|
|
|
|
|
|
|
3
|
14
|
|
|
14
|
|
790490
|
use strict; |
|
14
|
|
|
|
|
117
|
|
|
14
|
|
|
|
|
371
|
|
4
|
14
|
|
|
14
|
|
70
|
use warnings; |
|
14
|
|
|
|
|
21
|
|
|
14
|
|
|
|
|
403
|
|
5
|
14
|
|
|
14
|
|
70
|
use base qw(Test::Builder::Module Exporter); |
|
14
|
|
|
|
|
36
|
|
|
14
|
|
|
|
|
2093
|
|
6
|
14
|
|
|
14
|
|
97
|
use Test::Builder; |
|
14
|
|
|
|
|
25
|
|
|
14
|
|
|
|
|
320
|
|
7
|
14
|
|
|
14
|
|
8442
|
use Test::Deep (); |
|
14
|
|
|
|
|
138092
|
|
|
14
|
|
|
|
|
439
|
|
8
|
14
|
|
|
14
|
|
7021
|
use SQL::Abstract::Tree; |
|
14
|
|
|
|
|
90
|
|
|
14
|
|
|
|
|
16928
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
11
|
|
|
|
|
|
|
is_same_sql_bind is_same_sql is_same_bind |
12
|
|
|
|
|
|
|
eq_sql_bind eq_sql eq_bind dumper diag_where |
13
|
|
|
|
|
|
|
$case_sensitive $sql_differ |
14
|
|
|
|
|
|
|
); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
my $sqlat = SQL::Abstract::Tree->new; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $case_sensitive = 0; |
19
|
|
|
|
|
|
|
our $parenthesis_significant = 0; |
20
|
|
|
|
|
|
|
our $order_by_asc_significant = 0; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
our $sql_differ; # keeps track of differing portion between SQLs |
23
|
|
|
|
|
|
|
our $tb = __PACKAGE__->builder; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub _unpack_arrayrefref { |
26
|
|
|
|
|
|
|
|
27
|
537
|
|
|
537
|
|
808
|
my @args; |
28
|
537
|
|
|
|
|
1160
|
for (1,2) { |
29
|
1074
|
|
|
|
|
1758
|
my $chunk = shift @_; |
30
|
|
|
|
|
|
|
|
31
|
1074
|
100
|
66
|
|
|
2606
|
if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') { |
32
|
3
|
|
|
|
|
8
|
my ($sql, @bind) = @$$chunk; |
33
|
3
|
|
|
|
|
9
|
push @args, ($sql, \@bind); |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
else { |
36
|
1071
|
|
|
|
|
2295
|
push @args, $chunk, shift @_; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# maybe $msg and ... stuff |
42
|
537
|
|
|
|
|
854
|
push @args, @_; |
43
|
|
|
|
|
|
|
|
44
|
537
|
|
|
|
|
1623
|
@args; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub is_same_sql_bind { |
48
|
533
|
|
|
533
|
1
|
129988
|
my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# compare |
51
|
533
|
|
|
|
|
1419
|
my $same_sql = eq_sql($sql1, $sql2); |
52
|
533
|
|
|
|
|
1309
|
my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# call Test::Builder::ok |
55
|
533
|
|
33
|
|
|
719056
|
my $ret = $tb->ok($same_sql && $same_bind, $msg); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# add debugging info |
58
|
533
|
50
|
|
|
|
164940
|
if (!$same_sql) { |
59
|
0
|
|
|
|
|
0
|
_sql_differ_diag($sql1, $sql2); |
60
|
|
|
|
|
|
|
} |
61
|
533
|
50
|
|
|
|
1191
|
if (!$same_bind) { |
62
|
0
|
|
|
|
|
0
|
_bind_differ_diag($bind_ref1, $bind_ref2); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# pass ok() result further |
66
|
533
|
|
|
|
|
3580
|
return $ret; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub is_same_sql { |
70
|
35
|
|
|
35
|
1
|
4189
|
my ($sql1, $sql2, $msg) = @_; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# compare |
73
|
35
|
|
|
|
|
77
|
my $same_sql = eq_sql($sql1, $sql2); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# call Test::Builder::ok |
76
|
35
|
|
|
|
|
139
|
my $ret = $tb->ok($same_sql, $msg); |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# add debugging info |
79
|
35
|
50
|
|
|
|
9728
|
if (!$same_sql) { |
80
|
0
|
|
|
|
|
0
|
_sql_differ_diag($sql1, $sql2); |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# pass ok() result further |
84
|
35
|
|
|
|
|
113
|
return $ret; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub is_same_bind { |
88
|
1
|
|
|
1
|
1
|
4
|
my ($bind_ref1, $bind_ref2, $msg) = @_; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# compare |
91
|
1
|
|
|
|
|
3
|
my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# call Test::Builder::ok |
94
|
1
|
|
|
|
|
869
|
my $ret = $tb->ok($same_bind, $msg); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# add debugging info |
97
|
1
|
50
|
|
|
|
235
|
if (!$same_bind) { |
98
|
0
|
|
|
|
|
0
|
_bind_differ_diag($bind_ref1, $bind_ref2); |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# pass ok() result further |
102
|
1
|
|
|
|
|
3
|
return $ret; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub dumper { |
106
|
|
|
|
|
|
|
# FIXME |
107
|
|
|
|
|
|
|
# if we save the instance, we will end up with $VARx references |
108
|
|
|
|
|
|
|
# no time to figure out how to avoid this (Deepcopy is *not* an option) |
109
|
0
|
|
|
0
|
0
|
0
|
require Data::Dumper; |
110
|
0
|
|
|
|
|
0
|
Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0) |
111
|
|
|
|
|
|
|
->Values([@_])->Dump; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub diag_where{ |
115
|
0
|
|
|
0
|
0
|
0
|
$tb->diag("Search term:\n" . &dumper); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub _sql_differ_diag { |
119
|
0
|
|
0
|
0
|
|
0
|
my $sql1 = shift || ''; |
120
|
0
|
|
0
|
|
|
0
|
my $sql2 = shift || ''; |
121
|
|
|
|
|
|
|
|
122
|
0
|
0
|
|
|
|
0
|
$tb->${\($tb->in_todo ? 'note' : 'diag')} ( |
|
0
|
|
|
|
|
0
|
|
123
|
|
|
|
|
|
|
"SQL expressions differ\n" |
124
|
|
|
|
|
|
|
." got: $sql1\n" |
125
|
|
|
|
|
|
|
."want: $sql2\n" |
126
|
|
|
|
|
|
|
."\nmismatch around\n$sql_differ\n" |
127
|
|
|
|
|
|
|
); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub _bind_differ_diag { |
131
|
0
|
|
|
0
|
|
0
|
my ($bind_ref1, $bind_ref2) = @_; |
132
|
|
|
|
|
|
|
|
133
|
0
|
0
|
|
|
|
0
|
$tb->${\($tb->in_todo ? 'note' : 'diag')} ( |
|
0
|
|
|
|
|
0
|
|
134
|
|
|
|
|
|
|
"BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 }) |
135
|
|
|
|
|
|
|
); |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub eq_sql_bind { |
139
|
4
|
|
|
4
|
1
|
3016
|
my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref; |
140
|
|
|
|
|
|
|
|
141
|
4
|
|
100
|
|
|
12
|
return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
|
145
|
666
|
|
|
666
|
1
|
243866
|
sub eq_bind { goto &Test::Deep::eq_deeply }; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub eq_sql { |
148
|
2210
|
|
|
2210
|
1
|
604255
|
my ($sql1, $sql2) = @_; |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# parse |
151
|
2210
|
|
|
|
|
7952
|
my $tree1 = $sqlat->parse($sql1); |
152
|
2210
|
|
|
|
|
6640
|
my $tree2 = $sqlat->parse($sql2); |
153
|
|
|
|
|
|
|
|
154
|
2210
|
|
|
|
|
4913
|
undef $sql_differ; |
155
|
2210
|
100
|
|
|
|
5361
|
return 1 if _eq_sql($tree1, $tree2); |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
sub _eq_sql { |
159
|
39536
|
|
|
39536
|
|
57048
|
my ($left, $right) = @_; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# one is defined the other not |
162
|
39536
|
100
|
100
|
|
|
149929
|
if ((defined $left) xor (defined $right)) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
163
|
21
|
100
|
|
|
|
63
|
$sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) ); |
|
42
|
|
|
|
|
221
|
|
164
|
21
|
|
|
|
|
73
|
return 0; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# one is undefined, then so is the other |
168
|
|
|
|
|
|
|
elsif (not defined $left) { |
169
|
1044
|
|
|
|
|
2002
|
return 1; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
# both are empty |
173
|
|
|
|
|
|
|
elsif (@$left == 0 and @$right == 0) { |
174
|
18
|
|
|
|
|
35
|
return 1; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# one is empty |
178
|
38453
|
100
|
100
|
|
|
164245
|
if (@$left == 0 or @$right == 0) { |
|
|
50
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
179
|
9
|
100
|
|
|
|
19
|
$sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) ); |
|
18
|
|
|
|
|
62
|
|
180
|
9
|
|
|
|
|
22
|
return 0; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# one is a list, the other is an op with a list |
184
|
|
|
|
|
|
|
elsif (ref $left->[0] xor ref $right->[0]) { |
185
|
|
|
|
|
|
|
$sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map |
186
|
0
|
0
|
|
|
|
0
|
{ ref $_ ? $sqlat->unparse($_) : $_ } |
|
0
|
|
|
|
|
0
|
|
187
|
|
|
|
|
|
|
($left->[0], $right->[0], $left, $right) |
188
|
|
|
|
|
|
|
); |
189
|
0
|
|
|
|
|
0
|
return 0; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# both are lists |
193
|
|
|
|
|
|
|
elsif (ref $left->[0]) { |
194
|
14371
|
|
100
|
|
|
34810
|
for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { |
195
|
23058
|
100
|
|
|
|
39769
|
if (not _eq_sql ($left->[$i], $right->[$i]) ) { |
196
|
4348
|
100
|
66
|
|
|
20468
|
if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) { |
197
|
886
|
|
50
|
|
|
2125
|
$sql_differ ||= ''; |
198
|
886
|
50
|
|
|
|
3561
|
$sql_differ .= "\n" unless $sql_differ =~ /\n\z/; |
199
|
886
|
|
|
|
|
2301
|
$sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ); |
|
1772
|
|
|
|
|
4830
|
|
200
|
|
|
|
|
|
|
} |
201
|
4348
|
|
|
|
|
29281
|
return 0; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
} |
204
|
10023
|
|
|
|
|
25711
|
return 1; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# both are ops |
208
|
|
|
|
|
|
|
else { |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# unroll parenthesis if possible/allowed |
211
|
24073
|
100
|
|
|
|
38332
|
unless ($parenthesis_significant) { |
212
|
23816
|
|
|
|
|
57477
|
$sqlat->_parenthesis_unroll($_) for $left, $right; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# unroll ASC order by's |
216
|
24073
|
100
|
|
|
|
40882
|
unless ($order_by_asc_significant) { |
217
|
24055
|
|
|
|
|
51953
|
$sqlat->_strip_asc_from_order_by($_) for $left, $right; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
24073
|
100
|
|
|
|
52441
|
if ($left->[0] ne $right->[0]) { |
|
|
100
|
|
|
|
|
|
221
|
378
|
|
|
|
|
1714
|
$sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
222
|
|
|
|
|
|
|
$sqlat->unparse($left), |
223
|
|
|
|
|
|
|
$sqlat->unparse($right) |
224
|
|
|
|
|
|
|
; |
225
|
378
|
|
|
|
|
1275
|
return 0; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# literals have a different arg-sig |
229
|
|
|
|
|
|
|
elsif ($left->[0] eq '-LITERAL') { |
230
|
9427
|
|
|
|
|
48064
|
(my $l = " $left->[1][0] " ) =~ s/\s+/ /g; |
231
|
9427
|
|
|
|
|
34197
|
(my $r = " $right->[1][0] ") =~ s/\s+/ /g; |
232
|
9427
|
50
|
|
|
|
23086
|
my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); |
233
|
9427
|
100
|
|
|
|
17315
|
$sql_differ = "[$l] != [$r]\n" if not $eq; |
234
|
9427
|
|
|
|
|
37610
|
return $eq; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
# if operators are identical, compare operands |
238
|
|
|
|
|
|
|
else { |
239
|
14268
|
|
|
|
|
26782
|
my $eq = _eq_sql($left->[1], $right->[1]); |
240
|
14268
|
100
|
33
|
|
|
24501
|
$sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq; |
|
0
|
|
|
|
|
0
|
|
241
|
14268
|
|
|
|
|
37681
|
return $eq; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
0
|
|
|
0
|
0
|
|
sub parse { $sqlat->parse(@_) } |
247
|
|
|
|
|
|
|
1; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
__END__ |