package Image::DS9::Parser;

# ABSTRACT: Parser driver

use strict;
use warnings;

our $VERSION = '0.188';

use Carp;
use Data::Dumper;

use Image::DS9::PConsts;

use namespace::clean;

sub parse_spec
{
  my $command = shift;
  my $specs = shift;

  # keep the rest of the args in @_, so don't copy data

  my %match;

  my $max_match = 0;
  my $nmatch = 0;

 SPEC:
  for my $spec ( @$specs )
  {
    $max_match = $nmatch if $max_match < $nmatch;

    my $iarg = 0;

    $nmatch = 0;

    $match{cmds} = [];

    next if @_ < @{$spec->[0]};

    foreach my $icmd ( 0 .. @{$spec->[0]}-1 )
    {
      # input arguments must have at least the number of
      # sub command slots.

      if ( my ( $tag, $valref, $extra ) =
           match( $_[$iarg++], $spec->[0][$icmd] ) )
      {
        push @{$match{cmds}}, [ $tag, $valref, $extra ];
        $nmatch++;
      }
      else  {
        next SPEC ;
      }

    }

    $match{spec} = $spec;


    # if we've come this far, we CANNOT match any further specs.  why?
    # well, because the person setting up the spec list is supposed to
    # ensure that!
    $max_match = $nmatch if $max_match < $nmatch;

    my $s_nmatch = $nmatch;
    my $s_iarg = $iarg;

  ARGLIST:
    for my $argl ( @{$spec}[ 1 .. @{$spec}-1] )
    {

      # this may get adjusted if there's an attribute hash, and will
      # need to be reinitialized if this arglist doesn't match
      # and we do another ARGLIST goround
      my $nargs = @_ - @{$spec->[0]};

      # have to reset pointer into passed arguments for each attempt
      # at matching another argument list
      $iarg = $s_iarg;

      $max_match = $nmatch if $max_match < $nmatch;
      $nmatch = $s_nmatch;

      # default is to query, no args.
      $argl->{query} = QYES unless exists $argl->{query};

      # make sure there's an array there, even if empty
      $argl->{args} ||= [];

      # number of return values in case of a query; the grammar
      # need only specify it if it's not the same as the number
      # of arguments
      $argl->{rvals} = $argl->{args}
        unless defined $argl->{rvals};

      # adjust things if attributes are ok and we found one at the
      # end of the argument list
      my $found_attrs = 0;
      if ( exists $argl->{attrs} && 'HASH' eq ref $_[-1] )
      {
        $found_attrs = 1;
        # so we don't stumble across 'em
        $nargs--;
      }

      # if we have no passed arguments, and the spec is query only or
      # query possible, we have a match!

      if ( ! $nargs && $argl->{query} && !( $argl->{query} & QARGS ))
      {
        $match{argl} = $argl;

        # the number of returned values. set to number of possible
        # arguments if not explicitly specified.
        $match{query} = @{$argl->{rvals}} || @{$argl->{args}} || 1;
      }

      # correct number of arguments.
      elsif ( $nargs == @{$argl->{args}} )
      {
        $match{args} = [];

        foreach my $arg ( @{$argl->{args}} )
        {
          # $extra is not yet supported for args
          if ( my ( $tag, $valref, $extra ) =
               match( $_[$iarg++], $arg ) )
          {
            push @{$match{args}}, [ $tag, $valref, $extra ];
            $nmatch++;
          }
          else {
            next ARGLIST ;
          }

        }

        $match{argl} = $argl;

        # the number of returned values. set to number of possible
        # arguments if not explicitly specified.
        $match{query} = $argl->{query} & QARGS ?
          @{$argl->{rvals}} || @{$argl->{args}} || 1 : 0;
      }

      else
      {
        next ARGLIST;
      }

      if ( $found_attrs )
      {
        # we need to make a copy,
        $match{attrs} = parse_attr( $command, $_[-1], $argl->{attrs} );

        croak( __PACKAGE__,
               ": $command: cannot specify attributes with this query" )
          if $match{query} && ! ($argl->{query} & QATTR);

      }

      # we found it, $match{argl} will have been set.
      last SPEC;
    }

    last SPEC;
  }

  $max_match += $nmatch + 1;

  croak( __PACKAGE__,
         ": $command: missing, unexpected, or illegal value for argument #$max_match" )
    unless defined $match{argl};

#  print Dumper \%match;

  \%match;
}

sub parse_attr
{
  my ( $command, $uattr, $specs ) = @_;

  my %attr;

  # need to make a local copy of the specs array, as _parse_attr
  # destroys the array
  my @specs = @$specs;

  _parse_attr( $command, \%attr, $uattr, \@specs );

  my @unknown = grep { ! exists $attr{$_} } keys %$uattr;

  croak( __PACKAGE__, ": $command: unknown attribute(s): ",
         join( ', ', @unknown ) ) if @unknown;

  \%attr;
}

sub _parse_attr
{
  my ( $command, $attr, $uattr, $specs ) = @_;

  my $nmatch;
  my @res;

  while ( my $spec = shift @$specs )
  {
    if ( $spec =~ /^-(o|a)/ )
    {
      my $op = $1;

      my ($sres, $smatch) = _parse_attr( $command, $attr, $uattr, shift @$specs );

      if ( 'a' eq $op )
      {

        # no matches? record and continue
        unless ( $smatch )
        {
          push @res, { what => $sres, match => 0 };
          next;
        }

        # number of matches should equal number of attrs
        unless ( $smatch == @$sres )
        {
          croak( __PACKAGE__, ": $command: missing attributes: ",
                dump_attr_chk( [ { what => $sres, match => 1, op => $op }] ) );
        }

        push @res, { what => $sres, match => 1, op => $op };
        $nmatch++;
      }

      elsif ( 'o' eq $op )
      {

        # no matches? record and continue
        unless ( $smatch )
        {
          push @res, { what => $sres, match => 0 };
          next;
        }

        # only should have one match
        unless ( $smatch == 1 )
        {
          croak( __PACKAGE__, ": $command: too many attributes: ",
                dump_attr_chk( [ { what => $sres, match => 1, op => $op }] ) );
        }

        push @res, { what => $sres, match => 1, op => $op };
        $nmatch++;
      }

    }
    else
    {
      my $match = chk_attr( $command, $spec, shift(@$specs), $attr, $uattr );
      $nmatch++ if $match;

      push @res, { what => $spec,
                   match => $match };
    }
  }
  \@res, $nmatch;
}

sub dump_attr_chk
{
  my ( $chks, $sep ) = @_;

  $sep ||= ' , ';

  my $msg;

  for my $res ( @$chks )
  {

    if    ( 'ARRAY' eq ref($res->{what}) )
    {
      my $msep =
        'a' eq $res->{op} ? ' & ' :
        'o' eq $res->{op} ? ' | ' :
          croak( __PACKAGE__, "::dump_attr_chk: internal error" );

      my $nmsg = dump_attr_chk( $res->{what}, $msep );
      $msg .= "($nmsg)$sep";
    }
    else
    {
      $msg .= $res->{what} . ($res->{match} ? '' : '?' ) . $sep;
    }
  }

  $sep =~ s/(\W)/\\$1/g;
  $msg =~ s/$sep$//;

  $msg;
}

sub chk_attr
{
  my ( $command, $key, $type, $attr, $uattr ) = @_;

  if ( exists $uattr->{$key} )
  {
    # $extra is not yet supported for attrs
    if ( my ( $tag, $valref, $extra )
         = match( $uattr->{$key}, $type ) )
    {
      $attr->{$key} = { tag => $tag, valref => $valref, extra => $extra };
    }
    else
    {
      croak( __PACKAGE__, ": $command: attribute `$key': illegal value. perhaps the wrong type or array length?" );
    }

    return 1;
  }

  0;
}

# ( $tag, $valref, $extra ) = match( $value, $type )
#
sub match
{
# don't do this! we need to pass by reference to avoid copying tons
# of data
#  my ( $value, $type ) = @_;

  my $type = $_[1];
  my $tag = T_OTHER;
  my $extra;

  my $valref = ref($_[0]) ? $_[0] : \( $_[0] );

  # if the type is an array, the first element is a tag for the
  # type, the second is what to match, the third is just plain extra
  if ( 'ARRAY' eq ref $type )
  {
    $tag   = $type->[0];
    $extra = $type->[2] if exists $type->[2];
    $type  = $type->[1];
  }

  if ( 'Regexp' eq ref($type) )
  {
    return $_[0] =~ /^($type)$/ ? ( $tag, \( my $x = $1 ), $extra ) : ();
  }

  elsif ( 'CODE' eq ref($type) )
  {
    return $type->($_[0], $valref) ?
      ( $tag, $valref, $extra) : ();
  }

  else
  {
    return $type eq $_[0] ? ( $tag, $valref, $extra ) : ();
  }

  ();
}

#
# This file is part of Image-DS9
#
# This software is Copyright (c) 2017 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

1;

=pod

=head1 NAME

Image::DS9::Parser - Parser driver

=head1 VERSION

version 0.188

=head2 Command specification structure.

Commands may have "sub-commands" and arguments.  A given sub-command
is allowed to have alternate argument lists.  Sub-commands may be
queries as well as directives, and thus will return information.

Commands are specified as arrays.  Each element in the array is a
separate sub-command.  Sub-commands are specified via arrays,
the first element of which defines the sub-command tokens, the rest
the alternate argument lists.

Sub-command tokens are presented as an array of strings or regular
expressions.  If there is more than one, the input list of tokens
must match exactly in order.

An argument list is a hash which describes the order and type of
arguments and whether and how the sub-command can be queried with
the specified argument list.

In detail, here's what a sub-command specification looks like:

=over 8

=item Subcommand

This is an arrayref which contains strings or RE's to match.  all must
match, in the specified order. It may be empty.

=item Argument list

A hashref with the following possible keys:

=over 8

=item args

An array of argument types.  The types may be strings, regular
expressions (generated with the B<qr> operator), or subroutine refs.
The arguments must match the types, in the specified order.

=item query

This determines how and if the sub-command with the specified
arguments may be queried.  It may have the following values:

=over 8

=item QNONE

This sub-command with the specified argument list may not be queried.

=item QARGS

This sub-command with the specified argument list may only be
queried. All of the arguments must specified.

=item QONLY

This sub-command may only be queried.  No arguments may be specified.

=item QYES

This sub-command may be queried.  No arguments may be specified for the query.
This is the default if B<query> isn't specified.

=back

=item bufarg

The last argument passed to the command should be sent via the XPASet buf
argument.

=item cvt

If true (the default) returned results are converted if their type has
a conversion routine available.  The list of arguments is used
to determine the return types.

=item retref

If true, a reference to the queried value is returned if
the user queries the command in a scalar context.

=item attrs

If this is present and the last element in the argument list is a
hashref, it will be scanned for attributes which will modify the query
or directive.  Attributes are command specific, typed, and may be
specified in combination or exclusion.  Attributes are specified in
an array as keyword/type pairs.  Attributes which must appear together
should be in their own array, preceded by the token C<-a>.
Attributes which must not appear together should be in their own
array, preceded by the token C<-o>.  Such clauses may be nested.

For example:

=over 8

=item C<ydim> and C<xdim> must both be specified:

 -a => [ xdim => FLOAT, ydim => FLOAT ]

=item C<night> and C<day> must not both be specified:

 -o => [ night => BOOL, day => BOOL ]

=item C<ydim> and C<xdim> must both be specified, but cannot
be specified with C<dim>:

 -o => [ ( -a => [ xdim => FLOAT, ydim => FLOAT ] ),
         ( dim => FLOAT ) ]

=back

Note that all clauses are evaluated, to catch possibly typos by the user.

=back

=back

=head1 BUGS AND LIMITATIONS

You can make new bug reports, and view existing ones, through the
web interface at L<https://rt.cpan.org/Public/Dist/Display.html?Name=Image-DS9>.

=head1 SEE ALSO

Please see those modules/websites for more information related to this module.

=over 4

=item *

L<Image::DS9|Image::DS9>

=back

=head1 AUTHOR

Diab Jerius <djerius@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2017 by Smithsonian Astrophysical Observatory.

This is free software, licensed under:

  The GNU General Public License, Version 3, June 2007

=cut

__END__


#pod =pod
#pod
#pod =head2 Command specification structure.
#pod
#pod Commands may have "sub-commands" and arguments.  A given sub-command
#pod is allowed to have alternate argument lists.  Sub-commands may be
#pod queries as well as directives, and thus will return information.
#pod
#pod Commands are specified as arrays.  Each element in the array is a
#pod separate sub-command.  Sub-commands are specified via arrays,
#pod the first element of which defines the sub-command tokens, the rest
#pod the alternate argument lists.
#pod
#pod Sub-command tokens are presented as an array of strings or regular
#pod expressions.  If there is more than one, the input list of tokens
#pod must match exactly in order.
#pod
#pod An argument list is a hash which describes the order and type of
#pod arguments and whether and how the sub-command can be queried with
#pod the specified argument list.
#pod
#pod In detail, here's what a sub-command specification looks like:
#pod
#pod =over 8
#pod
#pod =item Subcommand
#pod
#pod This is an arrayref which contains strings or RE's to match.  all must
#pod match, in the specified order. It may be empty.
#pod
#pod =item Argument list
#pod
#pod A hashref with the following possible keys:
#pod
#pod =over 8
#pod
#pod =item args
#pod
#pod An array of argument types.  The types may be strings, regular
#pod expressions (generated with the B<qr> operator), or subroutine refs.
#pod The arguments must match the types, in the specified order.
#pod
#pod =item query
#pod
#pod This determines how and if the sub-command with the specified
#pod arguments may be queried.  It may have the following values:
#pod
#pod =over 8
#pod
#pod =item QNONE
#pod
#pod This sub-command with the specified argument list may not be queried.
#pod
#pod =item QARGS
#pod
#pod This sub-command with the specified argument list may only be
#pod queried. All of the arguments must specified.
#pod
#pod =item QONLY
#pod
#pod This sub-command may only be queried.  No arguments may be specified.
#pod
#pod =item QYES
#pod
#pod This sub-command may be queried.  No arguments may be specified for the query.
#pod This is the default if B<query> isn't specified.
#pod
#pod =back
#pod
#pod =item bufarg
#pod
#pod The last argument passed to the command should be sent via the XPASet buf
#pod argument.
#pod
#pod =item cvt
#pod
#pod If true (the default) returned results are converted if their type has
#pod a conversion routine available.  The list of arguments is used
#pod to determine the return types.
#pod
#pod =item retref
#pod
#pod If true, a reference to the queried value is returned if
#pod the user queries the command in a scalar context.
#pod
#pod =item attrs
#pod
#pod If this is present and the last element in the argument list is a
#pod hashref, it will be scanned for attributes which will modify the query
#pod or directive.  Attributes are command specific, typed, and may be
#pod specified in combination or exclusion.  Attributes are specified in
#pod an array as keyword/type pairs.  Attributes which must appear together
#pod should be in their own array, preceded by the token C<-a>.
#pod Attributes which must not appear together should be in their own
#pod array, preceded by the token C<-o>.  Such clauses may be nested.
#pod
#pod For example:
#pod
#pod =over 8
#pod
#pod =item C<ydim> and C<xdim> must both be specified:
#pod
#pod  -a => [ xdim => FLOAT, ydim => FLOAT ]
#pod
#pod =item C<night> and C<day> must not both be specified:
#pod
#pod  -o => [ night => BOOL, day => BOOL ]
#pod
#pod =item C<ydim> and C<xdim> must both be specified, but cannot
#pod be specified with C<dim>:
#pod
#pod  -o => [ ( -a => [ xdim => FLOAT, ydim => FLOAT ] ),
#pod          ( dim => FLOAT ) ]
#pod
#pod =back
#pod
#pod Note that all clauses are evaluated, to catch possibly typos by the user.
#pod
#pod =back
#pod
#pod =back