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