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