lib/SQL/Abstract/Test.pm

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