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