
package LedgerSMB::Request::Helper::ParameterMap;

=head1 NAME

LedgerSMB::Request::Helper::ParameterMap - Map flat namespace to a hierarchy

=head1 SYNOPSIS


  use Data::Dumper;
  my $map = input_map([ qr/^(?<foo>bar|baz)$/ => '%map:%<foo>' ]);
  print Dumper($map->({ bar => 1, baz => 2 }));

  # prints:
  # $VAR1 = {
  #    map => {
  #      bar => 1,
  #      baz => 2
  #    }
  # }

  $map = input_map([ qr/^(?<foo>d|e|f)$/ => '%<foo>' ],
             [ qr/^(?<bar>a|b|c)_(?<id>\d+)$/ => '@rows<id>:%<bar>' ]
  print Dumper($map->(
     {
        a_1 => 100,
        b_1 => 99,
        d => 12,
        a_2 => 102,
        b_2 => 199
    }));

  # prints:
  # $VAR1 = {
  #   d => 12,
  #   rows => [
  #      {
  #         __row_id => 1,
  #         a => 100,
  #         b => 99
  #      },
  #      {
  #         __row_id => 2,
  #         a => 102,
  #         b => 199
  #      }
  #   ]
  # };


=head1 DESCRIPTION

This module implements the infrastructure to map input from a flat
namespace (e.g. the parameter hash as generated by POST requests
from 'old code' or traditional (non-ajax/xhr) templates) to a hierarchical
structure such as could have been submitted by a POST request with a JSON
structure in the POST body.

The mapping specification consists of a series of regular expressions
used to match the names of the parameters and a 'path' specification
which indicates where in the target data structure the value associated
with the parameter should be stored. The regex can use named matches
(using the C<<(?<>)>> regex operator) in order to name parts of the path.

A path in the target structure consists of one or more segments, where
every segment specifies either a key in a hash or a row (hashref) in an array.
A hash key segment can specify either a static hash key name or a
dynamic hash key name using one of the named matches from the regex.
Rows in an array segment are identified by a named match from the regex
as well.

When multiple regular expressions are used to specify the mapping, the
first matching regular expression is used to identify the target path
specification.

Keys in the source namespace which don't match any of regular expressions
and keys which match a regular expression with a target path specification
equal to C<!> will be ignored.

Examples of path specifications:

=over

=item C<%target>

Specifies a static key called C<target> at which to store the
value associated with the matched key, returning a datastructure
including:

   {
      target => $value
   }

=item C<%target:%path>

Specifies a path consisting of 2 consecutive static segments,
returning a datastructure including:

  {
     target => {
        path => $value
     }
  }

=item C<%<match_name>>

Specifies a path consisting of a single segment identifying a
dynamic hash key name. Assuming that C<match_name> equals C<foo>,
returns a datastructure including:

  {
     foo => $value
  }

=item C<@rows<match_name>:%target>

Specifies a path of 2 segments with the first segment specifying
an array row identified by the value of the named match C<match_name>.
Assuming C<match_name> equals C<foo>, returns a data structure including:

  {
    rows => [
      {
         __row_id => 'foo',
         target => $value
      }
    ]
  }

=back

=cut

use warnings;
use strict;
use parent qw(Exporter);

use Carp;


our @EXPORT = ## no critic
    qw( input_map spec_for_dynatable );



=head1 METHODS

This module declares no methods.

=head1 FUNCTIONS

=head2 spec_for_dynatable(path => 'path', attributes => \%attribs, columns => \@columns)

Builds an C<input_map> specification for mapping parameters from a
dynatable used as a form input.

C<path> should specify a table mapping, optionally preceded by a (fixed)
prefix path. I.e. a minimal C<path> value would be C<'@dyna'>, which maps
the values of the dynatable into the C<dyna> key of the hash returned by
the generated input mapper.

The C<attributes> should be the same as those passed to the dynatable. The
same applies for the column specification C<columns>.

Dynatable adds a hidden column C<row> to each generated table. This function
parses that hidden column into the return value by adding that same column to
the column mapping instructions.

=cut

my %dyna_inputs = (
    input_text        => 1,
    checkbox          => 1,
    hidden            => 1,
    radio             => 1,
    boolean_checkmark => 1,
    select            => 1,
    );

sub spec_for_dynatable {
    my %args = @_;
    my $path = $args{path};
    my $attr = $args{attributes};
    my $col  = $args{columns};

    my $prefix = $attr->{input_prefix} // '';
    my @spec_cols = grep { $dyna_inputs{$_->{type}} } @$col;

    push @spec_cols, { col_id => 'row' };
    my $regex =
        "^$prefix(?<fld>(" . join('|',
                                  map { $_->{col_id} } @spec_cols)
        . '))_(?<rn>\d+)$';
    return [ $regex => "$path<rn>:%<fld>" ];
}

=head2 input_map([ qr/regex1/ => 'path1' ], [ qr/regex2/ => 'path2' ], ...)

This function takes as its arguments a series of arrayrefs each with as
the first value a regular expression and the second value a path specification.

The function compiles the series of regex/path combinations into a
mapping which can be applied to (the keys of) a hashref, resulting
in a hierarchical data structure.

The regular expressions are tested in argument-order against the keys
of the key/value pairs in a hash. The path specification of the first
regex matching the key is used to determine where in the target
structure to store the value.

=cut



# _find_row($ref, $array, $row_id)
#
# Lookup function to resolve the row identified by $row_id from the
# arrayref found at $ref->{$array}.
#
# If no such row exists, a row is created and pushed into the array.
# If $ref->{$array} doesn't contain an arrayref, one is created.

sub _find_row {
    my ($ref, $arr, $row_id) = @_;

    if (! defined $ref->{$arr}) {
        $ref->{$arr} = [];
    }

    my $row_ref;
    for my $row (@{$ref->{$arr}}) {
        $row_ref = $row
            if $row->{__row_id} eq $row_id;
    }
    if (! defined $row_ref) {
        $row_ref = {
            __row_id => $row_id
        };
        push @{$ref->{$arr}}, $row_ref;
    }

    return $row_ref;
}


# _compile_spec($target_path)
#
# Returns a Perl code fragment which traverses the path specification
# $target_path, creating the hierarchical structure upon traversal.
#
# Assumes the following variables are defined in the lexical scope
# in which the fragment is included:
#  - $matches
#    hashref containing the named matches from the associated regex
#  - $r
#    hashref containing the 'flat' namespace to be mapped
#  - $key
#    hash key under consideration; matches the regex associated with the path
#  - $deref
#    on entry, the root hashref value of the target structure to be returned
#    (destructively modified)

sub _compile_spec {
    my ($target_spec) = @_;

    return '' if $target_spec eq '!'; # ignore
    my $code = '';

    my @lookup_steps = split(/:/, $target_spec);
    for my $stepnum (0 ..  $#lookup_steps) {
        my $step = $lookup_steps[$stepnum];

        my $deref = substr($step, 0, 1);
        if (substr($step, 0, 2) eq '%<') {
            my $var = substr($step, 2, length($step) - 3);
            if ($stepnum != $#lookup_steps) {
                $code .= qq{
      \$deref = (\$deref->{\$matches->{"$var"}} //= {});};
            }
            else {
                $code .= qq{
      \$deref->{\$matches->{"$var"}} = \$r->{\$key};}
            }
        }
        elsif ($deref eq '%') {
            my $var = substr($step, 1, length($step) - 1);
            if ($stepnum != $#lookup_steps) {
                $code .= qq{
      \$deref = (\$deref->{"$var"} //= {});};
            }
            else {
                $code .= qq{
      \$deref->{"$var"} = \$r->{\$key};};
            }
        }
        elsif ($deref eq '@') {
            $step =~ /\@(?<arr>[^<]+)\<(?<matchvar>.+)\>/;
            my $var = $+{matchvar};
            my $arr = $+{arr};
            if ($stepnum != $#lookup_steps) {
                $code .= qq{
      \$deref = _find_row(\$deref, "$arr", \$matches->{"$var"});};
            }
            else {
                die q{Can't assign directly to the array};
            }
        }
        else {
            croak 'Unsupported targetspec definition';
        }
    }

    return $code;
}


# _compile_match([$match_re, $target_spec])
#
# Returns a code fragment which matches $match_re against $key
# and upon match, traverses $target_spec and sets the endpoint to
# the value $r->{$key}.
#
# Assumes the following variables are defined in the lexical scope
# in which the fragment is included:
#  - $r
#    hashref containing the 'flat' namespace to be mapped
#  - $key
#    hash key under consideration; matches the regex associated with the path
#  - $deref
#    on entry, the root hashref value of the target structure to be returned
#    (destructively modified)
#

sub _compile_match {
    my ($matcher) = @_;
    my ($match_re, $tgt_spec) = @$matcher;

    return qq,
    # $tgt_spec
    if (\$key =~ /$match_re/) {
      my \$matches = \\\%+;
, . _compile_spec($tgt_spec) . q,

      delete $r->{"$key"};
      next;
    }
,;

}

sub input_map {
    my @rules = @_;

    # Generate Perl code from the mapping rules:
    # The reason to do so lies in the assumption that the
    # mapper will cause 'path traversals' to be called in
    # tight loops (many times for each flat->hierarchy conversion)
    # and that running Perl code interpreting the path traversals
    # will be too slow.
    # The solution is to generate Perl code and convert that into
    # Perl bytecode getting the benefit of the (optimized) Perl
    # code interpretation.
    # The return value of this eval statement is a coderef ("compiled"
    # Perl function)
    my $code = eval
q,
sub {
 my ($r) = @_; # flat input 'request' record

 my $rv = {};
 for my $key (keys %$r) {
    my $deref = $rv;
, .
    join('', map { _compile_match($_) } @rules)
. q,
 }
 return $rv;
}
,;

    if (not defined $code and defined $@) {
        # Did we have compilation errors?
        croak $@;
    }
    return $code;
}



=head1 LICENSE AND COPYRIGHT

Copyright (C) 2018 The LedgerSMB Core Team

This file is licensed under the GNU General Public License version 2, or at your
option any later version.  A copy of the license should have been included with
your software.

=cut


1;
