File Coverage

blib/lib/SQL/Abstract/Test.pm
Criterion Covered Total %
statement 87 106 82.0
branch 41 54 75.9
condition 25 38 65.7
subroutine 14 19 73.6
pod 6 9 66.6
total 173 226 76.5


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__