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