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