%{
#!/usr/bin/perl
#
# TPG TVB Parser Generator Grammar
#
# Given a bnf like grammar generate a parser for text based tvbs
#
# Wireshark - Network traffic analyzer
# By Gerald Combs <gerald@wireshark.org>
# Copyright 2004 Gerald Combs
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    
    use V2P;
    
    my $parser_info;

sub hj {
    ${$_[0]}{$_} = ${$_[1]}{$_} for (keys %{$_[1]});
    return $_[0];
}

sub abort {
    my $line = ${$_[0]->YYData->{DATA}};
    
    die "$_[1] at $line";
}

sub from_to {
    my $f = unpack "C", shift;
    my $t = unpack "C", shift;
    my $b = '';
    for ($f..$t) {
        $b .= pack("C",$_);
    }
    $b;
}


sub to_hexesc {
    sprintf "\\x%.2x", unpack("C",$_[0]);
}

sub chars_control {
    $_ = $_[0];
    s/([a-zA-Z0-9])-([a-zA-Z0-9])/from_to($1,$2)/ge;
    s/"/\\"/g;
    s/\\(.)/to_hexesc($1)/ge;
    "\"$_\"";
}

%}

%%

start: statements {$parser_info} ;

statements:
    #empty { $parser_info = {}; }
    |   statements statement
    ;

statement:
    rule_statement {
        my $rulename = ${$_[1]}{name};

        abort($_[0],"%rule $rulename already defined") if exists ${${$parser_info}{rules}}{$rulename};
        
        ${${$parser_info}{rules}}{$rulename} = $_[1];
    }
    |  parser_name_statement {
        abort($_[0],"%parser_name already defined") if exists ${$parser_info}{name};
        ${$parser_info}{proto_name} = $_[1];
    }
    | proto_desc_statement {
        abort($_[0],"%proto_desc already defined") if exists ${$parser_info}{proto_desc};
        ${$parser_info}{proto_desc} = $_[1];
    }
    | header_head_statement {
        ${$parser_info}{header_head} .= $_[1];
    }
    | code_head_statement {
        ${$parser_info}{head} .= $_[1];
    }
    | header_tail_statement {
        ${$parser_info}{header_tail} .= $_[1];
    }
    | code_tail_statement {
        ${$parser_info}{tail} .= $_[1];
    }
    | static_field_statement {
        abort($_[0],"%field '${$_[1]}{name}' already defined") if (exists ${${$parser_info}{fields}}{${$_[1]}{name}});
        ${${$parser_info}{fields}}{${$_[1]}{name}} = $_[1];
    }
    | parser_data_statement {
        abort($_[0],"%tt_type already defined") if exists ${$parser_info}{pdata};
        ${$parser_info}{pdata} = $_[1];
    }
    | export_statement {
        abort($_[0],"%export already defined") if exists ${$parser_info}{export};
        ${$parser_info}{export} = $_[1];
    }
    | value_string_statement {
        my $name = ${$_[1]}{name};
        abort($_[0],"%value_string $name already defined") if exists ${${$parser_info}{vs}}{$name};
        ${${$parser_info}{vs}}{$name} = $_[1];
    }
    | ignore_statement {
        ${$parser_info}{ignore} = $_[1]; 
    }   
    ;

ignore_statement:
    '%ignore' LOWERCASE {$_[2]}
    ;

rule_statement:
    '%sequence' tree LOWERCASE '=' sequence_rule '.' qualification code {
        my $r = hj($_[5],$_[7]);
        ${$r}{name} = $_[3];
        ${$r}{code} = $_[8] if defined $_[8];
        ${$r}{tree} = 1 if defined $_[2];
        $r;
    }
    | '%choice' tree LOWERCASE '=' choice_rule '.' qualification code {
        my $r = hj($_[5],$_[7]);
        ${$r}{name} = $_[3];
        ${$r}{code} = $_[8] if defined $_[8];
        ${$r}{tree} = 1 if defined $_[2];
        $r;
    }
    | '%rule' LOWERCASE '=' complete_rule '.' code {
        my $r = $_[4];
        ${$r}{name} = $_[2];
        ${$r}{code} = $_[6] if defined $_[6];
        $r;
    }
    ;

code:
    #empty { undef }
    | CODE
    ;

tree:
    #empty {undef}
    | '%tree'
    ;


complete_rule:
    base_rule cardinality qualification {hj($_[1],hj($_[2],$_[3]))}
    | named_rule cardinality { hj($_[1],$_[2]) } 
    | until_rule
    ;

named_rule: LOWERCASE {{control=>$_[1],type=>'named'}} ;

base_rule:
    | CHARS {{control=>chars_control($_[1]),type=>'chars'}}
    | NOTCHARS {{control=>chars_control($_[1]),type=>'not_chars'}}
    | DQUOTED {{control=>"\"$_[1]\"",type=>'string'}}
    | SQUOTED {{control=>"\"$_[1]\"",type=>'caseless'}}
    ;

until_rule:
    '...' qualification '(' last_rule include_mode ')'  { @{$_[2]}{'type','subrule','inc_mode'} = ('until',$_[4],$_[5]); $_[2] }
    ;

last_rule: base_rule | named_rule;

include_mode:
    #empty { 'TP_UNTIL_SPEND' }
    | '%spend' { 'TP_UNTIL_SPEND' }
    | '%include' { 'TP_UNTIL_INCLUDE' }
    | '%leave' { 'TP_UNTIL_LEAVE' }
    ;

choice_rule: choice {{subrules=>$_[1],type=>'choice'}} ;

choice:
    complete_rule '|' complete_rule { [$_[1],$_[3]] }
    | choice '|' complete_rule { push @{$_[1]}, $_[3]; $_[1] }
    ;

sequence_rule: sequence { {subrules=>$_[1],type=>'seq'}} ;

sequence:
    complete_rule { [$_[1]] }
    | sequence '&' complete_rule { push @{$_[1]}, $_[3]; $_[1] }
    ;

cardinality:
    #empty { my %c; @c{'min','max'} = (1,1); \%c  }
    | '+' { my %c; @c{'min','max'} = (1,"0xffffffff"); \%c  }
    | '?' { my %c; @c{'min','max'} = (0,1); \%c  }
    | '*' { my %c; @c{'min','max'} = (0,"0xffffffff"); \%c  }
    | '{' NUMBER ',' NUMBER '}' { my %c; @c{'min','max'} = ($_[2],$_[4]); \%c  }
    | '{' NUMBER '}' { my %c; @c{'min','max'} = ($_[2],$_[2]); \%c  }
    | '{' ',' NUMBER '}' { my %c; @c{'min','max'} = (0,$_[3]); \%c  }
    | '{' NUMBER ',' '}' { my %c; @c{'min','max'} = ($_[2],"0xffffffff"); \%c  }
    ;

qualification:
    #empty {{}}
    | '<' qualifiers '>' {$_[2]}
    ;

qualifiers:
    qualifier { my $p = {}; ${$p} { ${$_[1]}[0] } = ${$_[1]}[1]; $p }
    | qualifiers ':' qualifier { ${$_[1]} { ${$_[3]}[0] } = ${$_[3]}[1]; $_[1] } 
    ;

qualifier:
    | LOWERCASE { ['field',$_[1]] }
    | UPPERCASE { ['var',$_[1]] }
    | '%plain_text' { ['plain_text',1] }
    ;

proto_desc_statement:
    '%proto_desc' quoted '.' { "\"$_[2]\"" } 
    ;

header_head_statement: 
    '%header_head' CODE { $_[2] }
    ;

header_tail_statement: 
    '%header_tail' CODE {  $_[2] }
    ;

code_head_statement: 
    '%head' CODE { $_[2] }
    ;

code_tail_statement: 
    '%tail' CODE {  $_[2] }
    ;

parser_name_statement:
    '%parser_name' LOWERCASE '.' {$_[2]}
    ;

parser_data_statement:
    '%tt_type' CODE { $_[2] }
    ;

export_statement:
    '%export' exports '.' { $_[2] }
    ;

exports:
    exports LOWERCASE { ${$_[1]}{$_[2]} = 1; $_[1] }
    | LOWERCASE { my $e = {}; ${$e}{$_[1]} = 1; $e }
    ;

value_string_statement:
    '%value_string' LOWERCASE value_string_items { my $v = {}; ${$v}{name} = $_[2]; ${$v}{items} = $_[3]; $v }
    ;

value_string_items:
    value_string_items value_string_item { push @{$_[1]}, $_[2] }
    | value_string_item { [$_[1]]}
    ;

value_string_item:
    NUMBER DQUOTED { [ $_[1], "\"$_[2]\"" ] }
    ;

static_field_statement:
    '%field' LOWERCASE DOTEDNAME field_name field_type field_base field_value_string field_description '.' {
        my $field = {};
        @{$field}{'name','abbr','pname','type','base','vs','desc'} = ($_[2],"\"$_[3]\"",$_[4],$_[5],$_[6],$_[7],$_[8]);
        return $field;
    }
    ;

field_name:
    #empty {undef}
    | DQUOTED { "\"$_[1]\""}
    ;

field_type:
    #empty { 'FT_STRING' }
    | FT
    ;

field_base:
    #empty { 'BASE_NONE' }
    | BASE
    ;

field_value_string:
    #empty { 'NULL' }
    | CODE { $_[1] =~ s/#line.*?\n//ms; $_[1] =~ s/\n//msg; $_[1] =~ s@/\*eocode\*/@@; $_[1] }
    ;

field_description:
    #empty {'""'}
    | SQUOTED { "\"$_[1]\""}
    ;

quoted: DQUOTED | SQUOTED ;

%%