Image::DS9::Parser

package Image::DS9::Parser;

use strict;
use warnings;

use Carp;
use Data::Dumper;

use Image::DS9::PConsts;



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 ) : ();
  }

  ();
}

1;
__END__