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