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   $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
 123        "SQL expressions differ\n"
 124       ." got: $sql1\n"
 125       ."want: $sql2\n"
 126       ."\nmismatch around\n$sql_differ\n"
 127   );
 128 }
 129
 130 sub _bind_differ_diag {
 131   my ($bind_ref1, $bind_ref2) = @_;
 132
 133   $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
 134     "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
 135   );
 136 }
 137
 138 sub eq_sql_bind {
 139   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
 140
 141   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
 142 }
 143
 144
 145 sub eq_bind { goto &Test::Deep::eq_deeply };
 146
 147 sub eq_sql {
 148   my ($sql1, $sql2) = @_;
 149
 150   # parse
 151   my $tree1 = $sqlat->parse($sql1);
 152   my $tree2 = $sqlat->parse($sql2);
 153
 154   undef $sql_differ;
 155   return 1 if _eq_sql($tree1, $tree2);
 156 }
 157
 158 sub _eq_sql {
 159   my ($left, $right) = @_;
 160
 161   # one is defined the other not
 162   if ( (defined $left) xor (defined $right) ) {
 163     $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
 164     return 0;
 165   }
 166
 167   # one is undefined, then so is the other
 168   elsif (not defined $left) {
 169     return 1;
 170   }
 171
 172   # both are empty
 173   elsif (@$left == 0 and @$right == 0) {
 174     return 1;
 175   }
 176
 177   # one is empty
 178   if (@$left == 0 or @$right == 0) {
 179     $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
 180     return 0;
 181   }
 182
 183   # one is a list, the other is an op with a list
 184   elsif (ref $left->[0] xor ref $right->[0]) {
 185     $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
 186       { ref $_ ? $sqlat->unparse ($_) : $_ }
 187       ($left->[0], $right->[0], $left, $right)
 188     );
 189     return 0;
 190   }
 191
 192   # both are lists
 193   elsif (ref $left->[0]) {
 194     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
 195       if (not _eq_sql ($left->[$i], $right->[$i]) ) {
 196         if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
 197           $sql_differ ||= '';
 198           $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
 199           $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
 200         }
 201         return 0;
 202       }
 203     }
 204     return 1;
 205   }
 206
 207   # both are ops
 208   else {
 209
 210     # unroll parenthesis if possible/allowed
 211     unless ( $parenthesis_significant ) {
 212       $sqlat->_parenthesis_unroll($_) for $left, $right;
 213     }
 214
 215     # unroll ASC order by's
 216     unless ($order_by_asc_significant) {
 217       $sqlat->_strip_asc_from_order_by($_) for $left, $right;
 218     }
 219
 220     if ( $left->[0] ne $right->[0] ) {
 221       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 222         $sqlat->unparse($left),
 223         $sqlat->unparse($right)
 224       ;
 225       return 0;
 226     }
 227
 228     # literals have a different arg-sig
 229     elsif ($left->[0] eq '-LITERAL') {
 230       (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
 231       (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
 232       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 233       $sql_differ = "[$l] != [$r]\n" if not $eq;
 234       return $eq;
 235     }
 236
 237     # if operators are identical, compare operands
 238     else {
 239       my $eq = _eq_sql($left->[1], $right->[1]);
 240       $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
 241       return $eq;
 242     }
 243   }
 244 }
 245
 246 sub parse { $sqlat->parse(@_) }
 247 1;
 248
 249
 250 __END__
 251
 252 =head1 NAME
 253
 254 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 255
 256 =head1 SYNOPSIS
 257
 258   use SQL::Abstract;
 259   use Test::More;
 260   use SQL::Abstract::Test import => [qw/
 261     is_same_sql_bind is_same_sql is_same_bind
 262     eq_sql_bind eq_sql eq_bind
 263   /];
 264
 265   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 266
 267   is_same_sql_bind($given_sql,    \@given_bind,
 268                    $expected_sql, \@expected_bind, $test_msg);
 269
 270   is_same_sql($given_sql, $expected_sql, $test_msg);
 271   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 272
 273   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 274                             $expected_sql, \@expected_bind);
 275
 276   my $sql_same = eq_sql($given_sql, $expected_sql);
 277   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 278
 279 =head1 DESCRIPTION
 280
 281 This module is only intended for authors of tests on
 282 L<SQL::Abstract|SQL::Abstract> and related modules;
 283 it exports functions for comparing two SQL statements
 284 and their bound values.
 285
 286 The SQL comparison is performed on I<abstract syntax>,
 287 ignoring differences in spaces or in levels of parentheses.
 288 Therefore the tests will pass as long as the semantics
 289 is preserved, even if the surface syntax has changed.
 290
 291 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 292 A lot of effort goes into distinguishing significant from
 293 non-significant parenthesis, including AND/OR operator associativity.
 294 Currently this module does not support commutativity and more
 295 intelligent transformations like L<De Morgan's laws
 296 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
 297
 298 For a good overview of what this test framework is currently capable of refer
 299 to C<t/10test.t>
 300
 301 =head1 FUNCTIONS
 302
 303 =head2 is_same_sql_bind
 304
 305   is_same_sql_bind(
 306     $given_sql, \@given_bind,
 307     $expected_sql, \@expected_bind,
 308     $test_msg
 309   );
 310
 311   is_same_sql_bind(
 312     \[$given_sql, @given_bind],
 313     \[$expected_sql, @expected_bind],
 314     $test_msg
 315   );
 316
 317   is_same_sql_bind(
 318     $dbic_rs->as_query
 319     $expected_sql, \@expected_bind,
 320     $test_msg
 321   );
 322
 323 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
 324 as shown in the examples above and passing the arguments to L</eq_sql> and
 325 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
 326 C<$test_msg> as message.
 327 If the test fails, a detailed diagnostic is printed.
 328
 329 =head2 is_same_sql
 330
 331   is_same_sql(
 332     $given_sql,
 333     $expected_sql,
 334     $test_msg
 335   );
 336
 337 Compares given and expected SQL statements via L</eq_sql>, and calls
 338 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
 339 If the test fails, a detailed diagnostic is printed.
 340
 341 =head2 is_same_bind
 342
 343   is_same_bind(
 344     \@given_bind,
 345     \@expected_bind,
 346     $test_msg
 347   );
 348
 349 Compares given and expected bind values via L</eq_bind>, and calls
 350 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
 351 If the test fails, a detailed diagnostic is printed.
 352
 353 =head2 eq_sql_bind
 354
 355   my $is_same = eq_sql_bind(
 356     $given_sql, \@given_bind,
 357     $expected_sql, \@expected_bind,
 358   );
 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     $dbic_rs->as_query
 367     $expected_sql, \@expected_bind,
 368   );
 369
 370 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
 371 L</eq_bind>, returning their combined result.
 372
 373 =head2 eq_sql
 374
 375   my $is_same = eq_sql($given_sql, $expected_sql);
 376
 377 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 378 but it just returns a boolean value and does not print diagnostics or talk to
 379 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 380 will contain the SQL portion where a difference was encountered; this is useful
 381 for printing diagnostics.
 382
 383 =head2 eq_bind
 384
 385   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 386
 387 Compares two lists of bind values, taking into account the fact that some of
 388 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 389 L</is_same_bind>, but it just returns a boolean value and does not print
 390 diagnostics or talk to L<Test::Builder>.
 391
 392 =head1 GLOBAL VARIABLES
 393
 394 =head2 $case_sensitive
 395
 396 If true, SQL comparisons will be case-sensitive. Default is false;
 397
 398 =head2 $parenthesis_significant
 399
 400 If true, SQL comparison will preserve and report difference in nested
 401 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
 402 Defaults to false;
 403
 404 =head2 $order_by_asc_significant
 405
 406 If true SQL comparison will consider C<ORDER BY foo ASC> and
 407 C<ORDER BY foo> to be different. Default is false;
 408
 409 =head2 $sql_differ
 410
 411 When L</eq_sql> returns false, the global variable
 412 C<$sql_differ> contains the SQL portion
 413 where a difference was encountered.
 414
 415 =head1 SEE ALSO
 416
 417 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 418
 419 =head1 AUTHORS
 420
 421 Laurent Dami <laurent.dami AT etat  geneve  ch>
 422
 423 Norbert Buchmuller <norbi@nix.hu>
 424
 425 Peter Rabbitson <ribasushi@cpan.org>
 426
 427 =head1 COPYRIGHT AND LICENSE
 428
 429 Copyright 2008 by Laurent Dami.
 430
 431 This library is free software; you can redistribute it and/or modify
 432 it under the same terms as Perl itself.