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/xio;
  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 a single non-mathop child with a single
 273       # PAREN grandchild which would indicate mathop ( nonmathop ( ... ) )
 274       elsif (
 275         @{$child->[1]} == 1
 276           and
 277         @{$child->[1][0][1]} == 1
 278           and
 279         $child->[1][0][1][0][0] eq 'PAREN'
 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       ) {
 285         push @children, $child->[1][0];
 286         $changes++;
 287       }
 288
 289
 290       # otherwise no more mucking for this pass
 291       else {
 292         push @children, $child;
 293       }
 294     }
 295
 296     $ast->[1] = \@children;
 297
 298   } while ($changes);
 299
 300 }
 301
 302 sub parse { $sqlat->parse(@_) }
 303 1;
 304
 305
 306 __END__
 307
 308 =head1 NAME
 309
 310 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 311
 312 =head1 SYNOPSIS
 313
 314   use SQL::Abstract;
 315   use Test::More;
 316   use SQL::Abstract::Test import => [qw/
 317     is_same_sql_bind is_same_sql is_same_bind
 318     eq_sql_bind eq_sql eq_bind
 319   /];
 320
 321   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 322
 323   is_same_sql_bind($given_sql,    \@given_bind,
 324                    $expected_sql, \@expected_bind, $test_msg);
 325
 326   is_same_sql($given_sql, $expected_sql, $test_msg);
 327   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 328
 329   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 330                             $expected_sql, \@expected_bind);
 331
 332   my $sql_same = eq_sql($given_sql, $expected_sql);
 333   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 334
 335 =head1 DESCRIPTION
 336
 337 This module is only intended for authors of tests on
 338 L<SQL::Abstract|SQL::Abstract> and related modules;
 339 it exports functions for comparing two SQL statements
 340 and their bound values.
 341
 342 The SQL comparison is performed on I<abstract syntax>,
 343 ignoring differences in spaces or in levels of parentheses.
 344 Therefore the tests will pass as long as the semantics
 345 is preserved, even if the surface syntax has changed.
 346
 347 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 348 A lot of effort goes into distinguishing significant from
 349 non-significant parenthesis, including AND/OR operator associativity.
 350 Currently this module does not support commutativity and more
 351 intelligent transformations like Morgan laws, etc.
 352
 353 For a good overview of what this test framework is capable of refer
 354 to C<t/10test.t>
 355
 356 =head1 FUNCTIONS
 357
 358 =head2 is_same_sql_bind
 359
 360   is_same_sql_bind($given_sql,    \@given_bind,
 361                    $expected_sql, \@expected_bind, $test_msg);
 362
 363 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 364 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 365 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 366 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 367 L</is_same_bind>) that needs to be imported.
 368
 369 =head2 is_same_sql
 370
 371   is_same_sql($given_sql, $expected_sql, $test_msg);
 372
 373 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 374 the result, with C<$test_msg> as message. If the test fails, a detailed
 375 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 376 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 377 that needs to be imported.
 378
 379 =head2 is_same_bind
 380
 381   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 382
 383 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 384 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 385 is printed. For clients which use L<Test::More>, this is the one of the three
 386 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 387 to be imported.
 388
 389 =head2 eq_sql_bind
 390
 391   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 392                             $expected_sql, \@expected_bind);
 393
 394 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 395 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 396 diagnostics or talk to L<Test::Builder>.
 397
 398 =head2 eq_sql
 399
 400   my $is_same = eq_sql($given_sql, $expected_sql);
 401
 402 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 403 but it just returns a boolean value and does not print diagnostics or talk to
 404 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 405 will contain the SQL portion where a difference was encountered; this is useful
 406 for printing diagnostics.
 407
 408 =head2 eq_bind
 409
 410   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 411
 412 Compares two lists of bind values, taking into account the fact that some of
 413 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 414 L</is_same_bind>, but it just returns a boolean value and does not print
 415 diagnostics or talk to L<Test::Builder>.
 416
 417 =head1 GLOBAL VARIABLES
 418
 419 =head2 $case_sensitive
 420
 421 If true, SQL comparisons will be case-sensitive. Default is false;
 422
 423 =head2 $parenthesis_significant
 424
 425 If true, SQL comparison will preserve and report difference in nested
 426 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
 427
 428 =head2 $sql_differ
 429
 430 When L</eq_sql> returns false, the global variable
 431 C<$sql_differ> contains the SQL portion
 432 where a difference was encountered.
 433
 434
 435 =head1 SEE ALSO
 436
 437 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 438
 439 =head1 AUTHORS
 440
 441 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 442
 443 Norbert Buchmuller <norbi@nix.hu>
 444
 445 Peter Rabbitson <ribasushi@cpan.org>
 446
 447 =head1 COPYRIGHT AND LICENSE
 448
 449 Copyright 2008 by Laurent Dami.
 450
 451 This library is free software; you can redistribute it and/or modify
 452 it under the same terms as Perl itself.