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