t/lib/DBIC/SqlMakerTest.pm

   1 package # hide from PAUSE
   2   DBIC::SqlMakerTest;
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/Test::Builder::Module Exporter/;
   8
   9 use Exporter;
  10
  11 our @EXPORT = qw/
  12   &is_same_sql_bind
  13   &eq_sql
  14   &eq_bind
  15 /;
  16
  17
  18 {
  19   package # hide from PAUSE
  20     DBIC::SqlMakerTest::SQLATest;
  21
  22   # replacement for SQL::Abstract::Test if not available
  23
  24   use strict;
  25   use warnings;
  26
  27   use base qw/Test::Builder::Module Exporter/;
  28
  29   use Scalar::Util qw(looks_like_number blessed reftype);
  30   use Data::Dumper;
  31
  32   our $tb = __PACKAGE__->builder;
  33
  34   sub is_same_sql_bind
  35   {
  36     my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  37
  38     my $same_sql = eq_sql($sql1, $sql2);
  39     my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  40
  41     $tb->ok($same_sql && $same_bind, $msg);
  42
  43     if (!$same_sql) {
  44       $tb->diag("SQL expressions differ\n"
  45         . "     got: $sql1\n"
  46         . "expected: $sql2\n"
  47       );
  48     }
  49     if (!$same_bind) {
  50       $tb->diag("BIND values differ\n"
  51         . "     got: " . Dumper($bind_ref1)
  52         . "expected: " . Dumper($bind_ref2)
  53       );
  54     }
  55   }
  56
  57   sub eq_sql
  58   {
  59     my ($left, $right) = @_;
  60
  61     $left =~ s/\s+//g;
  62     $right =~ s/\s+//g;
  63
  64     return $left eq $right;
  65   }
  66
  67   # lifted from SQL::Abstract::Test
  68   sub eq_bind
  69   {
  70     my ($bind_ref1, $bind_ref2) = @_;
  71
  72     my $ref1 = ref $bind_ref1;
  73     my $ref2 = ref $bind_ref2;
  74
  75     return 0 if $ref1 ne $ref2;
  76
  77     if ($ref1 eq 'SCALAR' || $ref1 eq 'REF') {
  78       return eq_bind($$bind_ref1, $$bind_ref2);
  79     } elsif ($ref1 eq 'ARRAY') {
  80       return 0 if scalar @$bind_ref1 != scalar @$bind_ref2;
  81       for (my $i = 0; $i < @$bind_ref1; $i++) {
  82         return 0 if !eq_bind($bind_ref1->[$i], $bind_ref2->[$i]);
  83       }
  84       return 1;
  85     } elsif ($ref1 eq 'HASH') {
  86         return
  87           eq_bind(
  88             [sort keys %$bind_ref1],
  89             [sort keys %$bind_ref2]
  90           )
  91           && eq_bind(
  92             [map { $bind_ref1->{$_} } sort keys %$bind_ref1],
  93             [map { $bind_ref2->{$_} } sort keys %$bind_ref2]
  94           );
  95     } else {
  96       if (!defined $bind_ref1 || !defined $bind_ref2) {
  97         return !(defined $bind_ref1 ^ defined $bind_ref2);
  98       } elsif (blessed($bind_ref1) || blessed($bind_ref2)) {
  99         return 0 if (blessed($bind_ref1) || "") ne (blessed($bind_ref2) || "");
 100         return 1 if $bind_ref1 == $bind_ref2;  # uses overloaded '=='
 101         # fallback: compare the guts of the object
 102         my $reftype1 = reftype $bind_ref1;
 103         my $reftype2 = reftype $bind_ref2;
 104         return 0 if $reftype1 ne $reftype2;
 105         if ($reftype1 eq 'SCALAR' || $reftype1 eq 'REF') {
 106           $bind_ref1 = $$bind_ref1;
 107           $bind_ref2 = $$bind_ref2;
 108         } elsif ($reftype1 eq 'ARRAY') {
 109           $bind_ref1 = [@$bind_ref1];
 110           $bind_ref2 = [@$bind_ref2];
 111         } elsif ($reftype1 eq 'HASH') {
 112           $bind_ref1 = {%$bind_ref1};
 113           $bind_ref2 = {%$bind_ref2};
 114         } else {
 115           return 0;
 116         }
 117         return eq_bind($bind_ref1, $bind_ref2);
 118       } elsif (looks_like_number($bind_ref1) && looks_like_number($bind_ref2)) {
 119         return $bind_ref1 == $bind_ref2;
 120       } else {
 121         return $bind_ref1 eq $bind_ref2;
 122       }
 123     }
 124   }
 125 }
 126
 127 eval "use SQL::Abstract::Test;";
 128 if ($@ eq '') {
 129   # SQL::Abstract::Test available
 130
 131   *is_same_sql_bind = \&SQL::Abstract::Test::is_same_sql_bind;
 132   *eq_sql = \&SQL::Abstract::Test::eq_sql;
 133   *eq_bind = \&SQL::Abstract::Test::eq_bind;
 134 } else {
 135   # old SQL::Abstract
 136
 137   *is_same_sql_bind = \&DBIC::SqlMakerTest::SQLATest::is_same_sql_bind;
 138   *eq_sql = \&DBIC::SqlMakerTest::SQLATest::eq_sql;
 139   *eq_bind = \&DBIC::SqlMakerTest::SQLATest::eq_bind;
 140 }
 141
 142
 143 1;
 144
 145 __END__
 146
 147
 148 =head1 NAME
 149
 150 DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC
 151
 152 =head1 SYNOPSIS
 153
 154   use Test::More;
 155   use DBIC::SqlMakerTest;
 156
 157   my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
 158   is_same_sql_bind(
 159     $sql, \@bind,
 160     $expected_sql, \@expected_bind,
 161     'foo bar works'
 162   );
 163
 164 =head1 DESCRIPTION
 165
 166 Exports functions that can be used to compare generated SQL and bind values.
 167
 168 If L<SQL::Abstract::Test> (packaged in L<SQL::Abstract> versions 1.50 and
 169 above) is available, then it is used to perform the comparisons (all functions
 170 are delegated to id). Otherwise uses simple string comparison for the SQL
 171 statements and simple L<Data::Dumper>-like recursive stringification for
 172 comparison of bind values.
 173
 174
 175 =head1 FUNCTIONS
 176
 177 =head2 is_same_sql_bind
 178
 179   is_same_sql_bind(
 180     $given_sql, \@given_bind,
 181     $expected_sql, \@expected_bind,
 182     $test_msg
 183   );
 184
 185 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 186 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
 187
 188 =head2 eq_sql
 189
 190   my $is_same = eq_sql($given_sql, $expected_sql);
 191
 192 Compares the two SQL statements. Returns true IFF they are equivalent.
 193
 194 =head2 eq_bind
 195
 196   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 197
 198 Compares two lists of bind values. Returns true IFF their values are the same.
 199
 200
 201 =head1 SEE ALSO
 202
 203 L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>.
 204
 205 =head1 AUTHOR
 206
 207 Norbert Buchmuller, <norbi@nix.hu>
 208
 209 =head1 COPYRIGHT AND LICENSE
 210
 211 Copyright 2008 by Norbert Buchmuller.
 212
 213 This library is free software; you can redistribute it and/or modify
 214 it under the same terms as Perl itself.