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