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