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