Commit | Line | Data |
949172b0 |
1 | package # hide from PAUSE |
2 | DBIC::SqlMakerTest; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use base qw/Test::Builder::Module Exporter/; |
8 | |
9 | use Exporter; |
949172b0 |
10 | |
11 | our @EXPORT = qw/ |
12 | &is_same_sql_bind |
13 | &eq_sql |
14 | &eq_bind |
15 | /; |
16 | |
17 | |
18 | { |
19 | package # hide from PAUSE |
20 | DBIC::SqlMakerTest::SQLATest; |
21 | |
22 | # replacement for SQL::Abstract::Test if not available |
23 | |
24 | use strict; |
25 | use warnings; |
26 | |
27 | use base qw/Test::Builder::Module Exporter/; |
28 | |
2564f119 |
29 | use Scalar::Util qw(looks_like_number blessed reftype); |
949172b0 |
30 | use Data::Dumper; |
31 | |
32 | our $tb = __PACKAGE__->builder; |
33 | |
34 | sub is_same_sql_bind |
35 | { |
36 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; |
37 | |
38 | my $same_sql = eq_sql($sql1, $sql2); |
39 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
40 | |
41 | $tb->ok($same_sql && $same_bind, $msg); |
42 | |
43 | if (!$same_sql) { |
44 | $tb->diag("SQL expressions differ\n" |
45 | . " got: $sql1\n" |
46 | . "expected: $sql2\n" |
47 | ); |
48 | } |
49 | if (!$same_bind) { |
50 | $tb->diag("BIND values differ\n" |
51 | . " got: " . Dumper($bind_ref1) |
52 | . "expected: " . Dumper($bind_ref2) |
53 | ); |
54 | } |
55 | } |
56 | |
57 | sub eq_sql |
58 | { |
59 | my ($left, $right) = @_; |
60 | |
61 | $left =~ s/\s+//g; |
62 | $right =~ s/\s+//g; |
63 | |
64 | return $left eq $right; |
65 | } |
66 | |
2564f119 |
67 | # lifted from SQL::Abstract::Test |
949172b0 |
68 | sub eq_bind |
69 | { |
70 | my ($bind_ref1, $bind_ref2) = @_; |
71 | |
2564f119 |
72 | my $ref1 = ref $bind_ref1; |
73 | my $ref2 = ref $bind_ref2; |
74 | |
75 | return 0 if $ref1 ne $ref2; |
76 | |
77 | if ($ref1 eq 'SCALAR' || $ref1 eq 'REF') { |
78 | return eq_bind($$bind_ref1, $$bind_ref2); |
79 | } elsif ($ref1 eq 'ARRAY') { |
80 | return 0 if scalar @$bind_ref1 != scalar @$bind_ref2; |
81 | for (my $i = 0; $i < @$bind_ref1; $i++) { |
82 | return 0 if !eq_bind($bind_ref1->[$i], $bind_ref2->[$i]); |
83 | } |
84 | return 1; |
85 | } elsif ($ref1 eq 'HASH') { |
86 | return |
87 | eq_bind( |
88 | [sort keys %$bind_ref1], |
89 | [sort keys %$bind_ref2] |
90 | ) |
91 | && eq_bind( |
92 | [map { $bind_ref1->{$_} } sort keys %$bind_ref1], |
93 | [map { $bind_ref2->{$_} } sort keys %$bind_ref2] |
94 | ); |
95 | } else { |
96 | if (!defined $bind_ref1 || !defined $bind_ref2) { |
97 | return !(defined $bind_ref1 ^ defined $bind_ref2); |
98 | } elsif (blessed($bind_ref1) || blessed($bind_ref2)) { |
99 | return 0 if (blessed($bind_ref1) || "") ne (blessed($bind_ref2) || ""); |
100 | return 1 if $bind_ref1 == $bind_ref2; # uses overloaded '==' |
101 | # fallback: compare the guts of the object |
102 | my $reftype1 = reftype $bind_ref1; |
103 | my $reftype2 = reftype $bind_ref2; |
104 | return 0 if $reftype1 ne $reftype2; |
105 | if ($reftype1 eq 'SCALAR' || $reftype1 eq 'REF') { |
106 | $bind_ref1 = $$bind_ref1; |
107 | $bind_ref2 = $$bind_ref2; |
108 | } elsif ($reftype1 eq 'ARRAY') { |
109 | $bind_ref1 = [@$bind_ref1]; |
110 | $bind_ref2 = [@$bind_ref2]; |
111 | } elsif ($reftype1 eq 'HASH') { |
112 | $bind_ref1 = {%$bind_ref1}; |
113 | $bind_ref2 = {%$bind_ref2}; |
114 | } else { |
115 | return 0; |
116 | } |
117 | return eq_bind($bind_ref1, $bind_ref2); |
118 | } elsif (looks_like_number($bind_ref1) && looks_like_number($bind_ref2)) { |
119 | return $bind_ref1 == $bind_ref2; |
120 | } else { |
121 | return $bind_ref1 eq $bind_ref2; |
122 | } |
949172b0 |
123 | } |
124 | } |
125 | } |
126 | |
127 | eval "use SQL::Abstract::Test;"; |
128 | if ($@ eq '') { |
129 | # SQL::Abstract::Test available |
130 | |
131 | *is_same_sql_bind = \&SQL::Abstract::Test::is_same_sql_bind; |
132 | *eq_sql = \&SQL::Abstract::Test::eq_sql; |
133 | *eq_bind = \&SQL::Abstract::Test::eq_bind; |
134 | } else { |
135 | # old SQL::Abstract |
136 | |
137 | *is_same_sql_bind = \&DBIC::SqlMakerTest::SQLATest::is_same_sql_bind; |
138 | *eq_sql = \&DBIC::SqlMakerTest::SQLATest::eq_sql; |
139 | *eq_bind = \&DBIC::SqlMakerTest::SQLATest::eq_bind; |
140 | } |
141 | |
142 | |
143 | 1; |
144 | |
145 | __END__ |
146 | |
147 | |
148 | =head1 NAME |
149 | |
150 | DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC |
151 | |
152 | =head1 SYNOPSIS |
153 | |
154 | use Test::More; |
155 | use DBIC::SqlMakerTest; |
156 | |
157 | my ($sql, @bind) = $schema->storage->sql_maker->select(%args); |
158 | is_same_sql_bind( |
159 | $sql, \@bind, |
160 | $expected_sql, \@expected_bind, |
161 | 'foo bar works' |
162 | ); |
163 | |
164 | =head1 DESCRIPTION |
165 | |
166 | Exports functions that can be used to compare generated SQL and bind values. |
167 | |
168 | If L<SQL::Abstract::Test> (packaged in L<SQL::Abstract> versions 1.50 and |
169 | above) is available, then it is used to perform the comparisons (all functions |
170 | are delegated to id). Otherwise uses simple string comparison for the SQL |
171 | statements and simple L<Data::Dumper>-like recursive stringification for |
172 | comparison of bind values. |
173 | |
174 | |
175 | =head1 FUNCTIONS |
176 | |
177 | =head2 is_same_sql_bind |
178 | |
179 | is_same_sql_bind( |
180 | $given_sql, \@given_bind, |
181 | $expected_sql, \@expected_bind, |
182 | $test_msg |
183 | ); |
184 | |
185 | Compares given and expected pairs of C<($sql, \@bind)>, and calls |
186 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. |
187 | |
188 | =head2 eq_sql |
189 | |
190 | my $is_same = eq_sql($given_sql, $expected_sql); |
191 | |
192 | Compares the two SQL statements. Returns true IFF they are equivalent. |
193 | |
194 | =head2 eq_bind |
195 | |
196 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
197 | |
198 | Compares two lists of bind values. Returns true IFF their values are the same. |
199 | |
200 | |
201 | =head1 SEE ALSO |
202 | |
203 | L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>. |
204 | |
205 | =head1 AUTHOR |
206 | |
207 | Norbert Buchmuller, <norbi@nix.hu> |
208 | |
209 | =head1 COPYRIGHT AND LICENSE |
210 | |
211 | Copyright 2008 by Norbert Buchmuller. |
212 | |
213 | This library is free software; you can redistribute it and/or modify |
214 | it under the same terms as Perl itself. |