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