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