File Coverage

blib/lib/SQL/Abstract/FromQuery.pm

Criterion	Covered	Total	%
statement	164	165	99.3
branch	35	44	79.5
condition	14	18	77.7
subroutine	36	36	100.0
pod	2	14	14.2
total	251	277	90.6

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.11';

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




     \A (?:

         |
         |
         |
         )
         (?: \Z |  )


       (*COMMIT) (?:  |  )


       (*COMMIT) (?:  |  )


        <[value]>+ % , # list of scalars separated by ','


      BETWEEN (*COMMIT) (?:  AND  |  )


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


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



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


      NULL


       T?


        \.\.
      | --


      :(?::)?


       //


       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; # subclasses that refine the root grammar should override this method
}

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

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;
    }
  }

  # 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;

  return $self->finalize(\%result);
}


sub finalize { # subclasses may override this to modify the result
  my ($self, $result) = @_;
  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;
}

#======================================================================
# 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 Regexp::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 datetime {
  my ($self, $h) = @_;
  return join "T", $h->{date}, $h->{time};
}

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 regexp {
  my ($self, $h) = @_;

  # There is no standard SQL syntax for regexp matching. So here we
  # just return a datastructure for the SQL::Abstract instance, assuming
  # that this instance will have a 'special operator' implementing regexp
  # behaviour. If the special operator is not present, an error will be
  # generated
  return {-regexp => [$h->{regexp}, $h->{flags}]};

  # die "this grammar has no regexp() method; need a DBMS-specific component "
  #   . "to implement this behaviour";
}


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

  # if the string contains any '*', substitute by '%' and make it a
  # "-like" operator
  my $is_pattern = $s =~ tr/*/%/;
    # NOTE : a reentrant =~ s/../../ would segfault, 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__