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