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