File Coverage

blib/lib/SQL/Abstract/FromQuery.pm

Criterion	Covered	Total	%
statement	178	186	95.7
branch	44	58	75.8
condition	15	23	65.2
subroutine	34	35	97.1
pod	2	12	16.6
total	273	314	86.9

package SQL::Abstract::FromQuery;

use strict;
use warnings;
use Scalar::Util     qw/refaddr reftype blessed/;
use List::MoreUtils  qw/mesh/;
use Module::Load     qw/load/;
use Params::Validate qw/validate SCALAR SCALARREF CODEREF ARRAYREF HASHREF
                                 UNDEF  BOOLEAN/;
use UNIVERSAL::DOES  qw/does/;
use Digest::MD5      qw/md5_base64/;
use mro 'c3';

use namespace::clean;

our $VERSION = '0.09';

# root grammar (will be inherited by subclasses)
my $root_grammar = do {
  use Regexp::Grammars 1.038;
  qr{
    #




     \A (?:

         |
         |
         |
         )
         (?: \Z |  )


       (*COMMIT) (?:  |  )


       (*COMMIT) (?:  |  )


        <[value]>+ % ,


      BETWEEN (*COMMIT) (?:  AND  |  )


       \<= | \< | \>= | \>


        \<\> | -(?!\d) | != | !



      |
      |
      |
      # |  # removed from "standard" value because it might
                       # interfere with other codes like gender M/F


      NULL


        \.\.
      | --


      :(?::)?


       Y(?:ES)?     (?{ $MATCH = 1 })
     | T(?:RUE)?    (?{ $MATCH = 1 })
     | N(?:O)?      (?{ $MATCH = 0 })
     | F(?:ALSE)?   (?{ $MATCH = 0 })



     |


       '(.*?)' (*COMMIT)  (?{ $MATCH = $CAPTURE })
     | "(.*?)" (*COMMIT)  (?{ $MATCH = $CAPTURE })


     [^\s,]+(?:\s+[^\s,]+)*?

  }xms;
};



#======================================================================
# CLASS METHODS
#======================================================================
sub sub_grammar {
  my $class = shift;
  return; # should redefine method in subclasses that refine the root grammar
}

my %params_for_new = (
  -components    => {type => ARRAYREF, optional => 1  },
  -fields        => {type => HASHREF,  default  => {} },
  -multicols_sep => {type => SCALAR,   optional => 1  },
);

sub new {
  my $class = shift;
  my $self  = {};
  my %args  = validate(@_, \%params_for_new);

  # load optional components
  if ($args{-components}) {
    # deactivate strict refs because we'll be playing with symbol tables
    no strict 'refs';

    my @components;
    foreach my $component (@{$args{-components}}) {
      $component =~ s/^\+//
        or $component = __PACKAGE__ . "::$component";
      load $component;
      push @components, $component;
      my @sub_grammar = $component->sub_grammar;
      push @{$self->{grammar_ISA}}, @sub_grammar if @sub_grammar;
    }

    # a new anonymous class will inherit from all components
    $class .= "::_ANON_::" . md5_base64(join ",", @components);
    unless (@{$class . "::ISA"}) {
      # dynamically create that class and use 'c3' inheritance in it
      push @{$class . "::ISA"}, @components;
      mro::set_mro($class, 'c3');
    }
  }

  # use root grammar if no derived grammar was installed by components
  $self->{grammar_ISA} ||= [ 'SQL::Abstract::FromQuery' ];

  # setup fields info
  foreach my $type (keys %{$args{-fields}}) {
    if ($type eq 'IGNORE') {
      ref $args{-fields}{IGNORE} eq 'Regexp'
        or die "IGNORE should be associated with a qr/.../ regular expression";
      $self->{IGNORE} = $args{-fields}{IGNORE};
    }
    else {
      my $fields_aref = $args{-fields}{$type};
      does($fields_aref, 'ARRAY')
        or die "list of fields for type $type should be an arrayref";
      $self->{field}{$_} = $type foreach @$fields_aref;
    }
  }

  # other args are just copied into $self (at the moment, only one such arg)
  $self->{$_} = $args{-$_} for qw/multicols_sep/;

  # return the blessed object
  bless $self, $class;
}

sub _error_handler {
  my $class = shift;
  return 'INCORRECT INPUT', sub {
    my ($error, $rule, $context)  = @_;
    my $msg = {
      negated_values => 'Expected a value after negation',
      op_and_value   => 'Expected a value after comparison operator',
      between        => 'Expected min and max after "BETWEEN"',
      standard       => 'Unexpected input after initial value',
    }->{$rule};
    $msg //= "Could not parse rule '$rule'";
    $msg  .= " ('$context')" if $context;
    return $msg;
  };
}


#======================================================================
# INSTANCE METHODS
#======================================================================


sub _grammar {
  my ($self, $rule) = @_;

  my $extends = join "", map {"\n"} @{$self->{grammar_ISA}};
  my $grammar = "<$rule>\n$extends";

  # compile this grammar. NOTE : since Regexp::Grammars uses a very
  # special form of operator overloading, we must go through an eval
  # so that qr/../ receives a string without variable interpolation;
  # do {use Regexp::Grammars; qr{$grammar}x;} would seem logical but won't work.
  local $@;
  my $compiled_grammar = eval "use Regexp::Grammars; qr{$grammar}x"
    or die "INVALID GRAMMAR: $@";

  return $compiled_grammar;
}




sub parse {
  my ($self, $data) = @_;
  my $class = ref $self;

  # if $data is an object with ->param() method, transform into plain hashref
  $data = $self->_flatten_into_hashref($data) if blessed $data
                                              && $data->can('param');

  # set error translator for grammars
  my ($err_msg, $err_translator) = $self->_error_handler;
  my $tmp = Regexp::Grammars::set_error_translator($err_translator);

  # parse each field within $data
  my %result;
  my %errors;
 FIELD:
  foreach my $field (keys %$data) {
    # ignore fields in exclusion list or fields without any data
    !$self->{IGNORE} or $field !~ $self->{IGNORE} or next FIELD;
    my $val = $data->{$field}                     or next FIELD;

    # decide which grammar to apply
    my $rule    = $self->{field}{$field}  ||  'standard';
    my $grammar = $self->{grammar}{$rule} ||= $self->_grammar($rule);

    # invoke grammar on field content
    if ($val =~ $grammar->with_actions($self)) {
      $result{$field} = $/{$rule};
    }
    else {
      $errors{$field} = [@!];
    }
  }

  # report errors, if any
  SQL::Abstract::FromQuery::_Exception->throw($err_msg, %errors) if %errors;

  # otherwise fix multicolumns and then return result
  $self->distribute_multicols_criteria(\%result) if $self->{multicols_sep};
  return \%result;
}


sub _flatten_into_hashref {
  my ($self, $data) = @_;
  my %h;
  foreach my $field ($data->param()) {
    my @vals = $data->param($field);
    my $val = join ",", @vals; # TOO simple-minded - should make it more abstract
    $h{$field} = $val;
  }
  return \%h;
}




sub distribute_multicols_criteria {
  my ($self, $criteria) = @_;

  my $sep = qr[$self->{multicols_sep}];
  my @and_conditions;

  # loop over keys that contain the multicol separator character
  foreach my $multi_cols_key (grep /$sep/, sort keys %$criteria) {

    # separate individual columns
    my @cols       = split $sep, $multi_cols_key;

    # remove the entry from the hash and keep the multi-value
    my $vals       = delete $criteria->{$multi_cols_key};

    # extract the distributed conditions
    my $conditions = $self->_build_conditions(\@cols, $vals);

    # add that to the list of conditions
    my $new_cond = @$conditions > 1 ? {-or => $conditions} : $conditions->[0];
    push @and_conditions, $new_cond;
  }

  # assemble conditions and put them back into the criteria hash
  my $previous_and = $criteria->{-and};
  push @and_conditions, $previous_and if $previous_and;
  $criteria->{-and} = \@and_conditions if @and_conditions;
}


sub _build_conditions {
  my ($self, $cols, $val) = @_;

  # is this a SQL::Abstract '-in' clause ?
  my $ref   = ref $val || '';
  my $is_in = $ref eq 'HASH' && join('', keys %$val) eq '-in';

  # for easyness of the algorithm, an '-in' clause or a plain scalar
  # are both treated as a list
  my @vals = $is_in ? @{$val->{-in}}
           : $ref   ? die "unexpected ref value for multi_cols_key"
           :          ($val);

  # for each multi-columns value, we build a "condition" (hashref col=>val)
  my @conditions;
  my $sep = qr[$self->{multicols_sep}];
  foreach my $val (@vals) {
    my @single_vals = split $sep, $val;
    @$cols == @single_vals
      or die "inconsistent number of values for multi_cols_key";
    my %condition = mesh @$cols, @single_vals;
    push @conditions, \%condition;
  }

  # the result is a list of conditions that will be 'OR-ed' by the caller
  return \@conditions;
}



#======================================================================
# ACTIONS HOOKED TO THE GRAMMAR
#======================================================================

sub negated_values {
  my ($self, $h) = @_;
  my $vals = $h->{values};
  if (ref $vals) {
    ref $vals eq 'HASH' or die 'unexpected reference in negation';
    my ($op, $val, @others) = %$vals;
    not @others         or die 'unexpected hash size in negation';
    if    ($op eq '-in') {return {-not_in => $val}                   }
    elsif ($op eq '='  ) {return {'<>'    => $val}                   }
    else                 {die "unexpected operator '$op' in negation"}
  }
  else {
    return {'<>' => $vals};
  }
}


sub null {
  my ($self, $h) = @_;
  return {'=' => undef};
  # Note: unfortunately, we can't return just undef at this stage,
  # because Regex::Grammars would interpret it as a parse failure.
}


sub op_and_value {
  my ($self, $h) = @_;
  return {$h->{compare} => $h->{value}};
}


sub between {
  my ($self, $h) = @_;
  return {-between => [$h->{min}, $h->{max}]};
}



sub values {
  my ($self, $h) = @_;
  my $n_values = @{$h->{value}};
  return $n_values > 1 ? {-in => $h->{value}}
                       : $h->{value}[0];
}


sub date {
  my ($self, $h) = @_;
  $h->{year} += 2000 if length($h->{year}) < 3;
  return sprintf "%04d-%02d-%02d", @{$h}{qw/year month day/};
}


sub time {
  my ($self, $h) = @_;
  $h->{seconds} ||= 0;
  return sprintf "%02d:%02d:%02d", @{$h}{qw/hour minutes seconds/};
}


sub string {
  my ($self, $s) = @_;

  # if any '*', substitute by '%' and make it a "-like" operator
  my $is_pattern = $s =~ tr/*/%/;
    # NOTE : a reentrant =~ s/../../ would core dump, but tr/../../ is OK

  return $is_pattern ? {-like => $s} : $s;
}


#======================================================================
# PRIVATE CLASS FOR REPORTING PARSE EXCEPTIONS
#======================================================================

package
  SQL::Abstract::FromQuery::_Exception;
use strict;
use warnings;

use overload
  '""' => sub {
    my $self = shift;
    my $msg = $self->{err_msg};
    for my $field (sort keys %{$self->{errors}}) {
      my $field_errors = $self->{errors}{$field};
      $msg .= "\n$field : " . join ", ", @$field_errors;
    }

    return $msg;
  },
  fallback => 1,
  ;


sub throw {
  my ($class, $err_msg, %errors) = @_;
  my $self = bless {err_msg => $err_msg, errors => \%errors}, $class;
  die $self;
}


#======================================================================
1; # End of SQL::Abstract::FromQuery
#======================================================================

__END__