Factor out binop construction

[dbsrgits/Data-Query.git] / lib / Data / Query / ExprBuilder.pm

package Data::Query::ExprBuilder;

use strictures 1;
use Scalar::Util ();
use Data::Query::ExprHelpers qw(perl_scalar_value perl_operator);

sub _perl_binop {
  return perl_operator(
    shift,
    map {
      (Scalar::Util::blessed($_)
      && $_->isa('Data::Query::ExprBuilder'))
        ? $_->{expr}
        : perl_scalar_value($_)
       # we're called with ($left, $right, 0) or ($right, $left, 1)
    } $_[2] ? @_[1,0] : @_[0,1]
  );
}

use overload (
  # unary operators
  (map {
    my $op = $_;
    $op => sub {
      Data::Query::ExprBuilder->new({
        expr => perl_operator($op => $_[0]->{expr})
      });
    }
  } qw(! neg)),
  # binary operators
  (map {
    my ($overload, $as) = ref($_) ? @$_ : ($_, $_);
    $overload => sub {
      Data::Query::ExprBuilder->new({
        expr => _perl_binop($as, @_),
      });
    }
  }
    qw(+ - * / % ** << >> . < > lt le gt ge ),

    # since 'and' and 'or' aren't operators we borrow the bitwise ops
    [ '&' => 'and' ], [ '|' => 'or' ],
  ),

  # equality operators (need undef maping)
  (map {
    my $op = $_;
    $op => sub {
      Data::Query::ExprBuilder->new({
        expr => grep(!defined, @_[0,1])
          ? (map { $op =~ /==|eq/ ? perl_operator(not => $_) : $_ }
              perl_operator(defined => map { defined($_) ? $_->{expr} : () } @_[0,1]))
          : _perl_binop($op, @_),
      });
    }
  }
    qw(== != eq ne)

  ),
  # unsupported
  (map {
    my $op = $_;
    $op => sub { die "Can't use operator $op on a ".ref($_[0]) }
   } qw(<=> cmp x ^ ~)
  ),
  fallback => 1,
); 

sub new {
  bless({ %{$_[1]} }, (ref($_[0])||$_[0]));
}

1;