File Coverage

blib/lib/SQL/Abstract/Test.pm

Criterion	Covered	Total	%
statement	90	112	80.3
branch	41	54	75.9
condition	28	56	50.0
subroutine	14	19	73.6
pod	6	9	66.6
total	179	250	71.6

package SQL::Abstract::Test; # see doc at end of file

use strict;
use warnings;
use base qw(Test::Builder::Module);
use Test::Builder;
use Test::Deep ();
use SQL::Abstract::Tree;

our @EXPORT_OK = qw(
  is_same_sql_bind is_same_sql is_same_bind
  eq_sql_bind eq_sql eq_bind dumper diag_where
  $case_sensitive $sql_differ
);

my $sqlat = SQL::Abstract::Tree->new;

our $case_sensitive = 0;
our $parenthesis_significant = 0;
our $order_by_asc_significant = 0;

our $sql_differ; # keeps track of differing portion between SQLs
our $tb; # not documented, but someone might be overriding it anyway

sub _unpack_arrayrefref {

  my @args;
  for (1,2) {
    my $chunk = shift @_;

    if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
      my ($sql, @bind) = @$$chunk;
      push @args, ($sql, \@bind);
    }
    else {
      push @args, $chunk, shift @_;
    }

  }

  # maybe $msg and ... stuff
  push @args, @_;

  @args;
}

sub is_same_sql_bind {
  my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;

  # compare
  my $same_sql  = eq_sql($sql1, $sql2);
  my $same_bind = eq_bind($bind_ref1, $bind_ref2);

  # call Test::Builder::ok
  my $tb = $tb || __PACKAGE__->builder;
  my $ret = $tb->ok($same_sql && $same_bind, $msg);

  # add debugging info
  if (!$same_sql) {
    _sql_differ_diag($sql1, $sql2);
  }
  if (!$same_bind) {
    _bind_differ_diag($bind_ref1, $bind_ref2);
  }

  # pass ok() result further
  return $ret;
}

sub is_same_sql {
  my ($sql1, $sql2, $msg) = @_;

  # compare
  my $same_sql = eq_sql($sql1, $sql2);

  # call Test::Builder::ok
  my $tb = $tb || __PACKAGE__->builder;
  my $ret = $tb->ok($same_sql, $msg);

  # add debugging info
  if (!$same_sql) {
    _sql_differ_diag($sql1, $sql2);
  }

  # pass ok() result further
  return $ret;
}

sub is_same_bind {
  my ($bind_ref1, $bind_ref2, $msg) = @_;

  # compare
  my $same_bind = eq_bind($bind_ref1, $bind_ref2);

  # call Test::Builder::ok
  my $tb = $tb || __PACKAGE__->builder;
  my $ret = $tb->ok($same_bind, $msg);

  # add debugging info
  if (!$same_bind) {
    _bind_differ_diag($bind_ref1, $bind_ref2);
  }

  # pass ok() result further
  return $ret;
}

sub dumper {
  # FIXME
  # if we save the instance, we will end up with $VARx references
  # no time to figure out how to avoid this (Deepcopy is *not* an option)
  require Data::Dumper;
  Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
    ->Values([@_])->Dump;
}

sub diag_where{
  my $tb = $tb || __PACKAGE__->builder;
  $tb->diag("Search term:\n" . &dumper);
}

sub _sql_differ_diag {
  my $sql1 = shift || '';
  my $sql2 = shift || '';

  my $tb = $tb || __PACKAGE__->builder;
  $tb->${\($tb->in_todo ? 'note' : 'diag')} (
       "SQL expressions differ\n"
      ." got: $sql1\n"
      ."want: $sql2\n"
      ."\nmismatch around\n$sql_differ\n"
  );
}

sub _bind_differ_diag {
  my ($bind_ref1, $bind_ref2) = @_;

  my $tb = $tb || __PACKAGE__->builder;
  $tb->${\($tb->in_todo ? 'note' : 'diag')} (
    "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
  );
}

sub eq_sql_bind {
  my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;

  return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
}


sub eq_bind { goto &Test::Deep::eq_deeply };

sub eq_sql {
  my ($sql1, $sql2) = @_;

  # parse
  my $tree1 = $sqlat->parse($sql1);
  my $tree2 = $sqlat->parse($sql2);

  undef $sql_differ;
  return 1 if _eq_sql($tree1, $tree2);
}

sub _eq_sql {
  my ($left, $right) = @_;

  # one is defined the other not
  if ((defined $left) xor (defined $right)) {
    $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
    return 0;
  }

  # one is undefined, then so is the other
  elsif (not defined $left) {
    return 1;
  }

  # both are empty
  elsif (@$left == 0 and @$right == 0) {
    return 1;
  }

  # one is empty
  if (@$left == 0 or @$right == 0) {
    $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
    return 0;
  }

  # one is a list, the other is an op with a list
  elsif (ref $left->[0] xor ref $right->[0]) {
    $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
      { ref $_ ? $sqlat->unparse($_) : $_ }
      ($left->[0], $right->[0], $left, $right)
    );
    return 0;
  }

  # both are lists
  elsif (ref $left->[0]) {
    for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
      if (not _eq_sql ($left->[$i], $right->[$i]) ) {
        if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
          $sql_differ ||= '';
          $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
          $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
        }
        return 0;
      }
    }
    return 1;
  }

  # both are ops
  else {

    # unroll parenthesis if possible/allowed
    unless ($parenthesis_significant) {
      $sqlat->_parenthesis_unroll($_) for $left, $right;
    }

    # unroll ASC order by's
    unless ($order_by_asc_significant) {
      $sqlat->_strip_asc_from_order_by($_) for $left, $right;
    }

    if ($left->[0] ne $right->[0]) {
      $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
        $sqlat->unparse($left),
        $sqlat->unparse($right)
      ;
      return 0;
    }

    # literals have a different arg-sig
    elsif ($left->[0] eq '-LITERAL') {
      (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
      (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
      my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
      $sql_differ = "[$l] != [$r]\n" if not $eq;
      return $eq;
    }

    # if operators are identical, compare operands
    else {
      my $eq = _eq_sql($left->[1], $right->[1]);
      $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
      return $eq;
    }
  }
}

sub parse { $sqlat->parse(@_) }
1;


__END__