# Copyright (c) 2005  Joshua Hoblitt
#
# $Id#

package PS::IPP::Metadata::Config;

use strict;
use warnings FATAL => qw( all );

our $VERSION = '0.01';

use Carp qw( carp );
use Parse::RecDescent;
#use Data::Dumper;

use base qw( Class::Accessor::Fast );
__PACKAGE__->mk_accessors( qw( overwrite ) );

#$::RD_TRACE = 1;
#$::RD_HINT = 1;

my $grammar = do{ local $/; <DATA> };

sub new {
    my $class = shift;

    my $myparser = Parse::RecDescent->new( $grammar );

    my $self = { _parser => $myparser };

    bless $self, $class;

    $self->overwrite( undef );

    return $self;
}

sub parse {
    my ( $self, $metadata ) = @_;

    my $tree = $self->{_parser}->startrule( $metadata );

    # remove comment only lines
    $self->_strip_comments( $tree ) or return undef;

    # handle multi-declare lines
    $self->_merge_multi_declares( $tree ) or return undef;

    # look for duplicate names, there should be none after processing the
    # multi-declares
    $self->_merge_duplicates( $tree ) or return undef;

    return $tree;
}

sub _strip_comments {
    my ( $self, $tree ) = @_;

    # Iteratate through the AoH structure and remove the hashes that have a
    # class key equal to "comment_line".
    for (my $i = 0; $i < @{$tree}; $i++) {
        my $elem = $tree->[$i];

        if ( $elem->{class} eq "comment_line" ) {
            # delete element from array
            splice @$tree, $i, 1;

            # the list just got shorter by one element so we don't want to
            # increment the cursor
            redo;
        }
    }

    return 1;
}

sub _merge_multi_declares {
    my ( $self, $tree ) = @_;

    # list of valid multi-declares
    my %multis;

    # Iteratate through the AoH structure looking for multi-declare
    # declarations.  This is done in a single pass so multi-declares must
    # actually be 'declared' before any member elements appear.  
    for (my $i = 0; $i < @{$tree}; $i++) {
        my $elem = $tree->[$i];

        if ( $elem->{class} eq "multi_declare" ) {
            # construct a valid parse spec
            my $node = {
                class   => 'vector',
                name    => $elem->{name},
                type    => 'STR',   # only strings are allowed
                value   => [],
            };

            # add to list of valid multi-declares
            $multis{ $elem->{name} } = $node;

            # delete mult-declare hash from the array and replace it with the
            # valid spec
            splice @$tree, $i, 1, $node;

            next;
        }

        if ( my $node = $multis{ $elem->{name} } ) {
            if ( ! $elem->{type} =~ /STR|STRING/ ) {
                carp "multi-declare element, ",
                     $elem->{name},
                     "has type of ",
                     $elem->{type},
                     "instead of STR|STRING\n";
                return undef;
            }

            # add element value to the appropriate multi-declare element
            my $vec = $node->{value};
            push( @$vec, $elem->{value} );

            # delete element from array
            splice @$tree, $i, 1;

            # the list just got shorter by one element so we don't want to
            # increment the cursor
            redo;
        }
    }

    return 1;
}

sub _merge_duplicates {
    my ( $self, $tree ) = @_;

    # encountered names
    my %names;

    for (my $i = 0; $i < @{$tree}; $i++) {
        my $elem = $tree->[$i];

        if ( exists $names{ $elem->{name} } ) {
            carp "duplicate element name, ", $elem->{name}, "\n";

            if ( $self->{overwrite} ) {
                # remove the previous occurance
                splice @{$tree}, $names{ $elem->{name} }, 1;
            } else {
                # remove the current occurance
                splice @{$tree}, $i, 1;
            }
        }

        # add element name and location to record of previously seen names
        $names{ $elem->{name} } = $i;
    }

    return 1;
}

1;

__DATA__

startrule:
    statement(s) /\z/
        { $item[1 .. -1] }

statement:
    scalar
    | vector
    | multi_declare
    | comment_line

comment_line:
    comment
        {{
            class   => 'comment_line',
            comment => $item{comment}
        }}

comment:
    '#' end_of_line
        { $item{end_of_line} }

scalar:
    name type value comment
        {{
            class   => 'scalar',
            name    => $item{name},
            type    => $item{type},
            value   => $item{value},
            comment => $item{comment}
         }}
    | name type value 
        {{
            class   => 'scalar',
            name    => $item{name},
            type    => $item{type},
            value   => $item{value},
        }}

vector:
    vname vtype vvalue comment
        {{
            class   => 'vector',
            name    => $item{vname},
            type    => $item{vtype},
            value   => $item{vvalue},
            comment => $item{comment}
         }}
    | vname vtype vvalue 
        {{
            class   => 'vector',
            name    => $item{vname},
            type    => $item{vtype},
            value   => $item{vvalue},
         }}

multi_declare:
    name '*' end_of_line
        {{
            class   => 'multi_declare',
            name    => $item{name}, 
            comment => $item{end_of_line},
        }}

name:
    /[a-z][.\w]*/i

vname:
    /\@[a-z][.\w]*/i

type: 
    vtype | 'STR' | 'STRING'

vtype: 
    'S8'
    | 'S16'
    | 'S32'
    | 'S64'
    | 'U8' 
    | 'U16'
    | 'U32'
    | 'U64'
    | 'F32'
    | 'F64'
    | 'C32'
    | 'C64'
    | 'BOOL'

value:
    primitive | string


vvalue:
    vvalue_(s)
        { [ map { @$_ } @{$item[1]} ] }

# backtracking optimization
vvalue_:
    primitive vector_sep(?)
        { [ $item[1] ] }

vector_sep:
    /,|\s+/

primitive:
    bool | float | int

int:
    # $RE{num}{int} from Regexp::Common::number
    /(?:(?:[+-]?)(?:[0-9]+))/

float:
    # based on $RE{num}{real} from Regexp::Common::number
    /(?:(?i)(?:[+-]?)(?:(?=[0-9]|[.])(?:[0-9]*)(?:(?:[.])(?:[0-9]{0,}))?)(?:(?:[Ee])(?:(?:[+-]?)(?:[0-9]+))|))/

bool:
    /[tf]\s+?/i
        { $item[1] =~ /t/i ? 1 : 0 }

string:
    /\S[^#\n]*/

end_of_line:
    /[^\n]*/
