File Coverage

blib/lib/Neo4j/Cypher/Abstract/Peeler.pm

Criterion	Covered	Total	%
statement	214	264	81.0
branch	125	178	70.2
condition	67	154	43.5
subroutine	29	33	87.8
pod	6	21	28.5
total	441	650	67.8

package Neo4j::Cypher::Abstract::Peeler;
use Carp;
use List::Util 1.33 qw(any);
use Scalar::Util qw(looks_like_number blessed);
use strict;
use warnings;

# issues to solve:
#  quoting
#  parens
#  param binding

# quoting logic:
# if config:bind = true
# if anon_placeholder (like ?) is in config, then return literals without
# quoting in array $obj->bind_values, and the placeholder in the statement
# if anon_placeholder is undef, then return literals quoted directly in the
# statement; return named parameters in $obj->parameters
#
# if config:bind false
# leave tokens and identifiers as-is, no bind_values or parameters

our $VERSION = '0.1001';
our $VERSION = '0.1001';
my $SQL_ABSTRACT = 1;

sub puke(@);
sub belch(@);

my %config = (
  bind => 1,
  anon_placeholder => undef, # '?',
  hash_op => '-and',
  array_op => '-or',
  list_braces => '[]',
  ineq_op => '<>',
  implicit_eq_op => '=',
  quote_lit => "'",
  esc_quote_lit => "\\",
  parameter_sigil => qw/^([:$?])|({[^}]+}$)/,
  quote_fld => undef,
  safe_identifier => qw/[a-zA-Z_.]+/
);

# for each operator type (key in %type_table), there
# should be a handler with the same name

my %type_table = (
  infix_binary => [qw{ - / %  =~ = <> < > <= >=
		       -contains -starts_with -ends_with}],
  infix_listarg => [qw{ -in } ],
  infix_distributable => [qw{ + * -and -or }],
  prefix => [qw{ -not }],
  postfix => [qw{ -is_null -is_not_null }],
  function => [qw{
		   ()
		   -abs -ceil -floor -rand -round -sign -degrees
		   -e -exp -log -log10 -sqrt -acos -asin -atan -atan2
		   -cos -cot -haversin -pi -radians -sin -tan
		   -exists -toInt
		   -left -lower -ltrim -replace -reverse -right
		   -rtrim -split -substring -toString -trim -upper
		   -length -size -type -id -coalesce -head -last
		   -labels -nodes -relationships -keys -tail -range
		   -collect -count -max -min -percentileCont
		   -percentileDisc -stDev -stDevP -sum
		   -shortestPath -allShortestPaths
	       }],
  predicate => [qw{ -all -any -none -single -filter}],
  extract => [qw{ -extract }],
  reduce => [qw{ -reduce }],
  list => [qw( -list )], # returns args in list format
  bind => [qw( -bind )], # handles parameters and literal quoting
  thing => [qw( -thing )], # the literal thing itself
 );

my %dispatch;
foreach my $type (keys %type_table) {
  no strict 'refs';
  my @ops = @{$type_table{$type}};
  @dispatch{@ops} = ( *${type}{CODE} ) x @ops;
}

sub new {
  my $class = shift;
  my %args = @_;
  if ($args{dispatch} and !(ref $args{dispatch} eq 'HASH')) {
    puke "dispatch must be hashref mapping operators to coderefs (or absent)"
  }
  if ($args{config} and !(ref $args{config} eq 'HASH')) {
    puke "config must be hashref defining peeler options"
  }
  my $self = {
    dispatch => $args{dispatch} || \%dispatch,
    config => $args{config} || \%config
   };
  # update config elts according to constructor args
  if (length scalar keys %args) {
    for (keys %config) {
      defined $args{$_} and $self->{config}{$_} = $args{$_};
    }
  }
  bless $self, $class;
}

sub belch (@) {
  my($func) = (caller(1))[3];
  Carp::carp "[$func] Warning: ", @_;
}

sub puke (@) {
  my($func) = (caller(1))[3];
  Carp::croak "[$func] Fatal: ", @_;
}

sub bind_values { $_[0]->{bind_values} ? @{$_[0]->{bind_values}} : return ; }
sub parameters { $_[0]->{parameters} ? @{$_[0]->{parameters}} : return ; }

sub _dispatch {
  $_[0]->{dispatch}{$_[1]}->(@_);
}

sub _quote_lit {
  my $arg = "$_[1]";
  my $q = $_[0]->{config}{quote_lit};
  if (looks_like_number $arg or
	$arg =~ /^\s*$q(.*)$q\s*$/ or
	$arg =~ $_[0]->{config}{parameter_sigil} or
	blessed($_[1])
       ) {
    # numeric, already quoted, a parameter, or an object
    return "$arg";
  }
  else {
    my $e = $_[0]->{config}{esc_quote_lit};
    $arg =~ s/$q/$e$q/g;
    return "$q$arg$q";
  }
}

sub _quote_fld { # noop
  return $_[1];
}

sub express {
  my $self = shift;
  my $x = $_[0];
  if ($SQL_ABSTRACT) {
    $x = $self->canonize($x);
  }
  return $self->peel($x);
}

sub config {
  my $self = shift;
  my ($key, $val) = @_;
  if (!defined $key) {
    return %{$self->{config}};
  }
  elsif (!defined $val) {
    return $self->{config}{$key};
  }
  else {
    return $self->{config}{$key} = $val;
  }
}


# canonize - rewrite mixed hash/array expressions in canonical lispy
# array format - interpret like SQL::A
sub canonize {
  my $self = shift;
  my ($expr) = @_;
  my $ret = [];
  my ($do,$is_op);
  $is_op = sub {
    if (!defined $_[0] || ref $_[0]) {
      return 0;
    }
    if (!$_[1]) {
      if (defined $self->{dispatch}{$_[0]}) {
	1;
      }
      else {
	puke "Unknown operator '$_[0]'" if (
	  $_[0] !~ /$$self{config}{safe_identifier}/ and
	  $_[0]=~/^-|[[:punct:]]/ and !looks_like_number($_[0])
	 );
	0;
      }
    }
    else {
      grep /^\Q$_[0]\E$/, @{$type_table{$_[1]}};
    }
  };
  my $level=0;
  $do = sub {
    my ($expr, $lhs, $arg_of) = @_;
    for (ref $expr) {
      ($_ eq '' or blessed($expr)) && do {
	if (defined $expr) {
	  # literal (value?)
	  return $self->{config}{bind} ? [ -bind => $expr ] : $expr;
	}
	else {
	  puke "undef not interpretable";
	}
      };
      /REF|SCALAR/ && do { # literals
	if ($_ eq 'SCALAR') {
	  return [-thing => $$expr] ; # never bind
	}
	elsif (ref $$expr eq 'ARRAY') {
	  # very SQL:A thing, but we'll do it
	  my @a = @$$expr;
	  my $thing = shift @a;
	  @a = map { $self->_quote_lit($_) } @a;
	  if ($self->{config}{bind}) {
	    push @{$self->{bind_values}}, @a;
	  }
	  else {
	    if ($self->{config}{anon_placeholder}) {
	      ($thing =~ s/\Q$$self{config}{anon_placeholder}\E/$_/) for @a;
	    }
	  }
	  return $lhs ? [-thing => $lhs, [-thing => $thing]] : [-thing => $thing];
	}
      };
      /ARRAY/ && do {
	if ($is_op->($$expr[0],'infix_distributable')) {
	  # handle implicit equality pairs in an array
	  my $op = shift @$expr;
	  my (@args,@flat);
	  # flatten
	  if (@$expr == 1) {
	    for (ref($$expr[0])) {
	      /ARRAY/ && do {
		@flat = @{$$expr[0]};
		last;
	      };
	      /HASH/ && do {
		@flat = %{$$expr[0]};
		last;
	      };
	      puke 'Huh?';
	    };
	  }
	  else {
	    @flat = @$expr; # already flat
	  }
	  while (@flat) {
	    my $elt = shift @flat;
#	    $DB::single=1 if !defined($elt);
	    if (!ref $elt) { # scalar means lhs of a pair or another op
	      push @args, $do->({$elt => shift @flat},$lhs,$op);
	    }
	    else {
	      next if (ref $elt eq 'ARRAY') && ! scalar @$elt or
		(ref $elt eq 'HASH') && ! scalar %$elt;
	      push @args, $do->($elt,$lhs,$op);
	    }
	  }
 	  return [$op => @args];
	}
	if ($is_op->($$expr[0]) and !$is_op->($$expr[0],'infix_distributable')) {
	  # some other op
	  return [ $$expr[0] => map {
	    $do->($_,undef,$$expr[0])
	  } @$expr[1..$#$expr] ];
	}
	elsif (ref $$expr[0] eq 'HASH') { #?
	  return [ $self->{config}{array_op} =>
		     map { $do->($_,$lhs,$self->{config}{array_op}) } @$expr ];
	}
	else { # is a plain list
	  if ($lhs) {
	    # implicit equality over array default op
	    return [ $self->{config}{array_op} => map {
	      defined() ?
		[ $self->{config}{implicit_eq_op} => $lhs,
		  $do->($_,undef,$self->{config}{implicit_eq_op}) ] :
		[ -is_null => $lhs ]
	    } @$expr ];
	  }
	  else {
	    if ($arg_of and any { $is_op->($arg_of, $_) }
		  qw/function infix_listarg predicate reduce/
	       ) {
	      # function argument - return list itself
	      return [ -list => map { $do->($_) } @$expr ];
	    }
	    else {
	      # distribute $array_op over implicit equality
	      return $do->([ $self->{config}{array_op} => @$expr ]);
	    }
	  }
	}
      };
      /HASH/ && do {
	my @k = keys %$expr;
	#######
	if (@k == 1) {
	  my $k = $k[0];
	  # single hashpair
	  if ($is_op->($k)) {
	    $is_op->($k,'infix_binary') && do {
	      puke "Expected LHS for $k" unless $lhs;
	      if (ref $$expr{$k} eq 'ARRAY') {
		# apply binary operator and join with array default op
		return [ $self->{config}{array_op} => map {
		  defined() ?
		    [ $k => $lhs, $do->($_)] :
		    { $self->{config}{ineq_op} => [-is_not_null => $lhs],
		      $self->{config}{implicit_eq_op} => [-is_null => $lhs]
		     }->{$k}
		   } @{$$expr{$k}} ]
	      }
	      elsif (defined $$expr{$k}) {
		return [ $k => $lhs, $do->($$expr{$k},undef,$k) ]; #?
	      }
	      else { # IS (NOT) NULL
		$k eq $self->{config}{ineq_op} && do {
		  return [ -is_not_null => $lhs ];
		};
		$k eq $self->{config}{implicit_eq_op} && do {
		  return [ -is_null => $lhs ];
		};
		puke "Can't handle undef as argument to $k";
	      }
	    };
	    $is_op->($k,'function') && do {
	      return [ $k => $do->($$expr{$k},undef,$k) ];
	    };
	    $is_op->($k,'infix_listarg') && do {
	      return [ $k => $lhs, $do->($$expr{$k},undef,$k) ];
	    };
	    $is_op->($k,'prefix') && do {
	      return [ $k => $do->($$expr{$k}) ];
	    };
	    $is_op->($k,'infix_distributable') && do {
	      if (!ref $$expr{$k} && $lhs) {
		return [ $k => $lhs, $do->($$expr{$k}) ];
	      }
	      elsif ( ref $$expr{$k} eq 'HASH' ) {
		my @ar = %{$$expr{$k}};
		return $do->([$k=>@ar]); #?
	      }
	      elsif ( ref $$expr{$k} eq 'ARRAY') {
		return  $do->([$k => $$expr{$k}]);
	      }
	      else {
		puke "arg type '".ref($$expr{$k})."' not expected for op '$k'";
	      }
	    };
	    $is_op->($k,'predicate') && do {
	      puke "predicate function '$k' requires an length 3 arrayref argument"
		unless ref $$expr{$k} eq 'ARRAY' and @{$$expr{$k}} == 3;
	      return [ $k => [-thing => $$expr{$k}->[0]],
			      $do->($$expr{$k}->[1], undef, $k),
			      $do->($$expr{$k}->[2], undef, $k) ];
	    };
	    $is_op->($k,'reduce') && do {
	      puke "reduce function '$k' requires an length 5 arrayref argument"
		unless ref $$expr{$k} eq 'ARRAY' and @{$$expr{$k}} == 5;
	      return [ $k => [-thing => $$expr{$k}->[0]],
		       $do->($$expr{$k}->[1], undef, $k),
		       [-thing => $$expr{$k}->[2]],
		       $do->($$expr{$k}->[3], undef, $k),
		       $do->($$expr{$k}->[4], undef, $k)];
	    };
	    puke "Operator $k not expected";
	  }
	  elsif (ref($$expr{$k}) && ref($$expr{$k}) ne 'SCALAR') {
	    # $k is an LHS
	    return $do->($$expr{$k}, $k, undef);
	  }
	  else {
	    # implicit equality
	    return defined $$expr{$k} ?
	      [ $self->{config}{implicit_eq_op} => $k,
		$do->($$expr{$k},undef,$self->{config}{implicit_eq_op}) ] :
	      [ -is_null => $k ];
	  }
	}
	#######
	else {
	  # >1 hashpair
	  my @args;
	  for my $k (@k) {
	    # all keys are ops, or none is - otherwise barf
	    if ( $is_op->($k, 'infix_binary') ) {
	      puke "No LHS provided for implicit $$self{config}{hash_op}" unless defined $lhs;
	      push @args, $do->({$k => $$expr{$k}},$lhs);
	    }
	    elsif ( $is_op->($k, 'prefix') || $is_op->($k,'function') ) {
		push @args, [ $k => $do->($$expr{$k},undef, $k) ];
	      }
	      elsif (!$is_op->($k)) {
		push @args, $do->({$k => $$expr{$k}});
	      }
	    else {
	      puke "Problem handling operator '$k'";
	    }
	  }
	  return [ $self->{config}{hash_op} => @args ];
	}
      };
    }
  };
  $ret = $do->($expr);
  return $ret;
}

# peel - recurse $args = [ -op, @args ] to create complete production
sub peel {
  my ($self, $args) = @_;

  if (!defined $args) {
    return '';
  }
  elsif (!ref $args or blessed($args)) { # single literal argument
    return $args;
  }
  elsif (ref $args eq 'ARRAY') {
    return '' unless (@$args);
    my $op = shift @$args;
    puke "'$op' : unknown operator" unless $self->{dispatch}{$op};
    my $expr = $self->_dispatch( $op, [map { $self->peel($_) } @$args] );
    if (grep /\Q$op\E/, @{$type_table{infix_distributable}}) {
      # group
      return "($expr)"
    }
    else {
      return $expr;
    }
  }
  else {
    puke "Can only peel() arrayrefs, scalars or literals";
  }
}

### writers

sub infix_binary {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  unless ( @$args == 2 ) {
    puke "For $op, arg2 must have length 2";
  }
  return '('.join(" ", $$args[0], _write_op($op), $$args[1]).')';
}

sub infix_listarg { infix_binary(@_) }

sub infix_distributable {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  $op = _write_op($op);
  return join(" $op ", @$args);
}

sub prefix {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  unless (@$args == 1) {
    puke "For $op, arg2 must have length 1"
  }
  return _write_op($op)." ".$$args[0];
}

sub postfix {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  unless (@$args == 1) {
    puke "For $op, arg2 must have length 1"
  }
  return $$args[0]." "._write_op($op);
}

sub function {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  return _write_op($op).'('.join(',',@$args).')';
}

sub predicate {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  unless ( @$args == 3 ) {
    puke "For $op, arg2 must have length 3";
  }
  return _write_op($op)."("."$$args[0] IN $$args[1] WHERE $$args[2]".")";
}

sub extract {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  unless ( @$args == 3 ) {
    puke "For $op, arg2 must have length 3";
  }
  return _write_op($op)."("."$$args[0] IN $$args[1] | $$args[2]".")";
}

sub reduce {
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  unless ( @$args == 5 ) {
    puke "For $op, arg2 must have length 5";
  }
  return _write_op($op)."("."$$args[0] = $$args[1], $$args[2] IN $$args[3] | $$args[4]".")";
}

# bind either:
# - pulls out literals, pushes them into {bind_values}, and replaces them
#   with '?' in the produced statement (a la SQL:A), -or-
# - identifies named parameters in the expression and pushes these into
#   {parameters}, leaving them in the produced statement
sub bind { # special
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  if ($$args[0] =~ $self->{config}{parameter_sigil}) {
    push @{$self->{parameters}}, $$args[0];
  }
  else {
    push @{$self->{bind_values}},
      $self->{config}{anon_placeholder} ? $$args[0] :
      $self->_quote_lit($$args[0]);
  }
  return $self->{config}{anon_placeholder} ?
    $self->{config}{anon_placeholder} :
    $self->_quote_lit($$args[0]);
}

sub list { # special
  my ($self, $op, $args) = @_;
  unless ($op and $args and !ref($op)
	    and ref($args) eq 'ARRAY'){
    puke "arg1 must be scalar, arg2 must be arrayref";
  }
  my ($l,$r) = split '',$self->{config}{list_braces};
  return $l.join(',',@$args).$r;
}

sub thing { # special
  my ($self, $op, $args) = @_;
  return join(' ',@$args);
}

sub _write_op {
  my ($op) = @_;
  $op =~ s/^-//;
  my $c = (caller(1))[3];
  return '' if ($op eq '()');
  return join(' ', map { ($c=~/infix|prefix|postfix/) ? uc $_ : $_ } split /_/,$op);
}

=head1 NAME

Neo4j::Cypher::Abstract::Peeler - Parse Perl structures as expressions

=head1 SYNOPSIS

=head1 DESCRIPTION

C allows the user to write L
Cypher|https://neo4j.com/docs/developer-manual/current/cypher/> query
language expressions as Perl data structures. The interpretation of
data structures follows L very closely, but attempts to
be more systematic and general.

C only produces expressions, typically used as arguments to
C clauses. It is integrated into L,
which produces full Cypher statements.

Like L, C translates scalars, scalar refs,
array refs, and hash refs syntactically to create expression
components such as functions and operators. The contents of the
scalars or references are generally operators or the arguments to
operators or functions.

Contents of scalar references are always treated as literals and
inserted into the expression verbatim.

=over

=item * Functions

Ordinary functions in Cypher are written as the name of the function
preceded by a dash. They can be expressed as follows:

 { -func => $arg }
 [ -func => $arg ]
 \"func($arg)"

 { -sin => $pi/2 }
 # returns sin(/2)

=item * Infix Operators

Infix operators, like equality (C<=>), inequality (CE>),
binary operations (C<+,-,*,/>), and certain string operators
(C<-contains>, C<-starts_with>, C) are expressed as follows:

 { $expr1 => { $infix_op => $expr2 } }

 { 'n.name'  => { '<>' => 'Fred' } }
 # returns n.name <> "Fred"

This may seem like overkill, but comes in handy for...

=item * AND and OR

C implements the L convention that hash refs
represent conditions joined by C and array refs represent
conditions joined by C. Key-value pairs and array value pairs are
interpreted as an implicit equalities to be ANDed or ORed.

 { $lhs1 => $rhs1, $lhs2 => $rhs2 }
 { al => 'king', 'eddie' => 'prince', vicky => 'queen' }
 # returns al = "king" AND eddie = "prince" AND vicky = "queen"

 [ $lhs1 => $rhs1, $lhs2 => $rhs2 ]
 [ 'a.name' => 'Fred', 'a.name' => 'Barney']
 # returns a.name = "Fred" OR a.name = "Barney"

A single left-hand side can be "distributed" over a set of conditions,
with corresponding conjunction:

 { zzyxx => [ 'narf', 'boog', 'frelb' ] } # implicit equality, OR
 # returns zzyxx = "narf" OR zzyxx = "boog" OR zzyxx = "frelb"
 { zzyxx => { '<>' =>  'narf', '<>' => 'boog' } } # explicit infix, AND
 # returns zzyxx <> "narf" AND zzyxx <> "boog"
 { zzyxx => [ '<>' =>  'narf', -contains => 'boog' ] } # explicit infix, OR
 # returns zzyxx <> "narf" OR zzyxx CONTAINS "boog"

=item * Expressing null

C can be used to express NULL mostly as in L so
that the following are equivalent

 { a.name => { '<>' => undef}, b.name => undef}
 { -is_not_null => 'a.name', -is_null => 'b.name' }
 # returns a.name IS NOT NULL  AND b.name IS NULL

=item * Predicates: -all, -any, -none, -single, -filter

These Cypher functions have the form

 func(variable IN list WHERE predicate)

To render these, provide an array ref of the three arguments in order:

 { -all => ['x', [1,2,3], {'x' => 3}] }
 # returns all(x IN [1,2,3] WHERE x = 3)

=item * List arguments

For cypher expressions that accept lists (arrays in square brackets), use arrayrefs:

 { 'n.name' => { -in => ['fred','wilma','pebbles'] }}
 # returns n.name IN ['fred','wilma','pebbles']

=back

=head2 Parameters and Bind Values

Cypher parameters (which use the '$' sigil) may be included in
expressions (with the dollar sign appropriately escaped). These are
collected during parsing and can be reported in order with the the
C method.

L automatically collects literal values and replaces
them with anonymous placeholders (C), returning an array of values
for binding in L. C will collect values and report them
with the C method. If the config key
C is set:

 $peeler->{config}{anon_placeholder} = '?'

then C will also do the replacement in the final expression
production like L.

The real reason to pay attention to literal values is to be able to
appropriately quote them in the final production. When
C is not set (default), then an attempt is made to
correctly quote string values and such.

=head1 GUTS

 TBD

=head2 The config hash

 TBD

=head1 METHODS

=over

=item express()

Canonize, then peel.

=item canonize()

Render SQL:A-like expression into a canonical lisp-like array tree.

=item peel()

Render a canonical tree as a Cypher string expression

=item parameters()

Get a list in order of all named parameters.

=item bind_values()

Get a list of bind values in order that were replaced by the anonymous
placeholder.

=back

=head1 SEE ALSO

L, L.

=head1 AUTHOR

 Mark A. Jensen
 CPAN: MAJENSEN
 majensen -at- cpan -dot- org

=head1 COPYRIGHT

 (c) 2017 Mark A. Jensen

=cut

1;