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