lib/SQL/Abstract/Test.pm

   1 package SQL::Abstract::Test; # see doc at end of file
   2
   3 use strict;
   4 use warnings;
   5 use base qw(Test::Builder::Module Exporter);
   6 use Data::Dumper;
   7 use Test::Builder;
   8 use Test::Deep ();
   9 use SQL::Abstract::Tree;
  10
  11 our @EXPORT_OK = qw(
  12   is_same_sql_bind is_same_sql is_same_bind
  13   eq_sql_bind eq_sql eq_bind dumper diag_where
  14   $case_sensitive $sql_differ
  15 );
  16
  17 my $sqlat = SQL::Abstract::Tree->new;
  18
  19 our $case_sensitive = 0;
  20 our $parenthesis_significant = 0;
  21 our $order_by_asc_significant = 0;
  22
  23 our $sql_differ; # keeps track of differing portion between SQLs
  24 our $tb = __PACKAGE__->builder;
  25
  26 sub is_same_sql_bind {
  27   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  28
  29   # compare
  30   my $same_sql  = eq_sql($sql1, $sql2);
  31   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  32
  33   # call Test::Builder::ok
  34   my $ret = $tb->ok($same_sql && $same_bind, $msg);
  35
  36   # add debugging info
  37   if (!$same_sql) {
  38     _sql_differ_diag($sql1, $sql2);
  39   }
  40   if (!$same_bind) {
  41     _bind_differ_diag($bind_ref1, $bind_ref2);
  42   }
  43
  44   # pass ok() result further
  45   return $ret;
  46 }
  47
  48 sub is_same_sql {
  49   my ($sql1, $sql2, $msg) = @_;
  50
  51   # compare
  52   my $same_sql  = eq_sql($sql1, $sql2);
  53
  54   # call Test::Builder::ok
  55   my $ret = $tb->ok($same_sql, $msg);
  56
  57   # add debugging info
  58   if (!$same_sql) {
  59     _sql_differ_diag($sql1, $sql2);
  60   }
  61
  62   # pass ok() result further
  63   return $ret;
  64 }
  65
  66 sub is_same_bind {
  67   my ($bind_ref1, $bind_ref2, $msg) = @_;
  68
  69   # compare
  70   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  71
  72   # call Test::Builder::ok
  73   my $ret = $tb->ok($same_bind, $msg);
  74
  75   # add debugging info
  76   if (!$same_bind) {
  77     _bind_differ_diag($bind_ref1, $bind_ref2);
  78   }
  79
  80   # pass ok() result further
  81   return $ret;
  82 }
  83
  84 sub dumper {
  85   Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)->Values([@_])->Dump;
  86 }
  87
  88 sub diag_where{
  89   $tb->diag( "Search term:\n" . &dumper );
  90 }
  91
  92 sub _sql_differ_diag {
  93   my ($sql1, $sql2) = @_;
  94
  95   $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
  96        "SQL expressions differ\n"
  97       ."     got: $sql1\n"
  98       ."expected: $sql2\n"
  99       ."differing in :\n$sql_differ\n"
 100   );
 101 }
 102
 103 sub _bind_differ_diag {
 104   my ($bind_ref1, $bind_ref2) = @_;
 105
 106   $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
 107        "BIND values differ\n"
 108       ."     got: " . dumper($bind_ref1)
 109       ."expected: " . dumper($bind_ref2)
 110       );
 111 }
 112
 113 sub eq_sql_bind {
 114   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
 115
 116   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
 117 }
 118
 119
 120 sub eq_bind { goto &Test::Deep::eq_deeply };
 121
 122 sub eq_sql {
 123   my ($sql1, $sql2) = @_;
 124
 125   # parse
 126   my $tree1 = $sqlat->parse($sql1);
 127   my $tree2 = $sqlat->parse($sql2);
 128
 129   undef $sql_differ;
 130   return 1 if _eq_sql($tree1, $tree2);
 131 }
 132
 133 sub _eq_sql {
 134   my ($left, $right) = @_;
 135
 136   # one is defined the other not
 137   if ( (defined $left) xor (defined $right) ) {
 138     $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
 139     return 0;
 140   }
 141
 142   # one is undefined, then so is the other
 143   elsif (not defined $left) {
 144     return 1;
 145   }
 146
 147   # both are empty
 148   elsif (@$left == 0 and @$right == 0) {
 149     return 1;
 150   }
 151
 152   # one is empty
 153   if (@$left == 0 or @$right == 0) {
 154     $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
 155     return 0;
 156   }
 157
 158   # one is a list, the other is an op with a list
 159   elsif (ref $left->[0] xor ref $right->[0]) {
 160     $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
 161       { ref $_ ? $sqlat->unparse ($_) : $_ }
 162       ($left->[0], $right->[0], $left, $right)
 163     );
 164     return 0;
 165   }
 166
 167   # both are lists
 168   elsif (ref $left->[0]) {
 169     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
 170       if (not _eq_sql ($left->[$i], $right->[$i]) ) {
 171         if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
 172           $sql_differ ||= '';
 173           $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
 174           $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
 175         }
 176         return 0;
 177       }
 178     }
 179     return 1;
 180   }
 181
 182   # both are ops
 183   else {
 184
 185     # unroll parenthesis if possible/allowed
 186     unless ( $parenthesis_significant ) {
 187       $sqlat->_parenthesis_unroll($_) for $left, $right;
 188     }
 189
 190     # unroll ASC order by's
 191     unless ($order_by_asc_significant) {
 192       $sqlat->_strip_asc_from_order_by($_) for $left, $right;
 193     }
 194
 195     if ( $left->[0] ne $right->[0] ) {
 196       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 197         $sqlat->unparse($left),
 198         $sqlat->unparse($right)
 199       ;
 200       return 0;
 201     }
 202
 203     # literals have a different arg-sig
 204     elsif ($left->[0] eq '-LITERAL') {
 205       (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
 206       (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
 207       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 208       $sql_differ = "[$l] != [$r]\n" if not $eq;
 209       return $eq;
 210     }
 211
 212     # if operators are identical, compare operands
 213     else {
 214       my $eq = _eq_sql($left->[1], $right->[1]);
 215       $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
 216       return $eq;
 217     }
 218   }
 219 }
 220
 221 sub parse { $sqlat->parse(@_) }
 222 1;
 223
 224
 225 __END__
 226
 227 =head1 NAME
 228
 229 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 230
 231 =head1 SYNOPSIS
 232
 233   use SQL::Abstract;
 234   use Test::More;
 235   use SQL::Abstract::Test import => [qw/
 236     is_same_sql_bind is_same_sql is_same_bind
 237     eq_sql_bind eq_sql eq_bind
 238   /];
 239
 240   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 241
 242   is_same_sql_bind($given_sql,    \@given_bind,
 243                    $expected_sql, \@expected_bind, $test_msg);
 244
 245   is_same_sql($given_sql, $expected_sql, $test_msg);
 246   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 247
 248   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 249                             $expected_sql, \@expected_bind);
 250
 251   my $sql_same = eq_sql($given_sql, $expected_sql);
 252   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 253
 254 =head1 DESCRIPTION
 255
 256 This module is only intended for authors of tests on
 257 L<SQL::Abstract|SQL::Abstract> and related modules;
 258 it exports functions for comparing two SQL statements
 259 and their bound values.
 260
 261 The SQL comparison is performed on I<abstract syntax>,
 262 ignoring differences in spaces or in levels of parentheses.
 263 Therefore the tests will pass as long as the semantics
 264 is preserved, even if the surface syntax has changed.
 265
 266 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 267 A lot of effort goes into distinguishing significant from
 268 non-significant parenthesis, including AND/OR operator associativity.
 269 Currently this module does not support commutativity and more
 270 intelligent transformations like Morgan laws, etc.
 271
 272 For a good overview of what this test framework is capable of refer
 273 to C<t/10test.t>
 274
 275 =head1 FUNCTIONS
 276
 277 =head2 is_same_sql_bind
 278
 279   is_same_sql_bind($given_sql,    \@given_bind,
 280                    $expected_sql, \@expected_bind, $test_msg);
 281
 282 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 283 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 284 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 285 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 286 L</is_same_bind>) that needs to be imported.
 287
 288 =head2 is_same_sql
 289
 290   is_same_sql($given_sql, $expected_sql, $test_msg);
 291
 292 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 293 the result, with C<$test_msg> as message. If the test fails, a detailed
 294 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 295 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 296 that needs to be imported.
 297
 298 =head2 is_same_bind
 299
 300   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 301
 302 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 303 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 304 is printed. For clients which use L<Test::More>, this is the one of the three
 305 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 306 to be imported.
 307
 308 =head2 eq_sql_bind
 309
 310   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 311                             $expected_sql, \@expected_bind);
 312
 313 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 314 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 315 diagnostics or talk to L<Test::Builder>.
 316
 317 =head2 eq_sql
 318
 319   my $is_same = eq_sql($given_sql, $expected_sql);
 320
 321 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 322 but it just returns a boolean value and does not print diagnostics or talk to
 323 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 324 will contain the SQL portion where a difference was encountered; this is useful
 325 for printing diagnostics.
 326
 327 =head2 eq_bind
 328
 329   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 330
 331 Compares two lists of bind values, taking into account the fact that some of
 332 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 333 L</is_same_bind>, but it just returns a boolean value and does not print
 334 diagnostics or talk to L<Test::Builder>.
 335
 336 =head1 GLOBAL VARIABLES
 337
 338 =head2 $case_sensitive
 339
 340 If true, SQL comparisons will be case-sensitive. Default is false;
 341
 342 =head2 $parenthesis_significant
 343
 344 If true, SQL comparison will preserve and report difference in nested
 345 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
 346 Defaults to false;
 347
 348 =head2 $order_by_asc_significant
 349
 350 If true SQL comparison will consider C<ORDER BY foo ASC> and
 351 C<ORDER BY foo> to be different. Default is false;
 352
 353 =head2 $sql_differ
 354
 355 When L</eq_sql> returns false, the global variable
 356 C<$sql_differ> contains the SQL portion
 357 where a difference was encountered.
 358
 359
 360 =head1 SEE ALSO
 361
 362 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 363
 364 =head1 AUTHORS
 365
 366 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 367
 368 Norbert Buchmuller <norbi@nix.hu>
 369
 370 Peter Rabbitson <ribasushi@cpan.org>
 371
 372 =head1 COPYRIGHT AND LICENSE
 373
 374 Copyright 2008 by Laurent Dami.
 375
 376 This library is free software; you can redistribute it and/or modify
 377 it under the same terms as Perl itself.