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