TPG TVB Parser Generator

Given a bnf-like grammar generate a set of helpers for a dissector

It's not working yet, however I need this checkin as a cheeckpoint

(I'll write the doc when it starts to be ready)


svn path=/trunk/; revision=16021

1 files changed, 320 insertions, 0 deletions

diff --git a/tools/tpg/tpg.yp b/tools/tpg/tpg.yp
new file mode 100644
index 0000000000..81bcb4137b
--- /dev/null
+++ b/tools/tpg/tpg.yp
@@ -0,0 +1,320 @@
+%{
+#!/usr/bin/perl
+#
+# TPG TVB Parser Generator Grammar
+#
+# Given a bnf like grammar generate a parser for text based tvbs
+#
+# $Id $
+#
+# Ethereal - Network traffic analyzer
+# By Gerald Combs <gerald@ethereal.com>
+# 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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, 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 chars_control {
+    $_ = $_[0];
+    s/([a-zA-Z0-9])-([a-zA-Z0-9])/from_to($1,$2)/ge;
+    "\"$_\"";
+}
+
+%}
+
+%%
+
+start: statements {$parser_info} ;
+
+statements:
+    #empty { $parser_info = {}; }
+    |   statements statement
+    ;
+
+statement:
+    rule_statement {
+        my $rulename = ${$_[1]}{name};
+
+        if (exists ${${$parser_info}{rules}}{$rulename}) {
+
+            my $rule = ${${$parser_info}{rules}}{$rulename};
+            if (exists ${${$parser_info}{rules}}{root}) {
+                # a root rule exists already add this to its subrules
+                push @{${${$parser_info}{rules}}{subrules}}, $_[1];
+            } else {
+                # this rule becomes the first subrule of a choice
+                ${${$parser_info}{rules}}{$rulename} =  {
+                    root=>'',
+                    type=>'choice',
+                    subrules=>[$rule,\$_[1]],
+                    name=>${$_[1]}{name},
+                }
+            }
+        } else {
+            ${${$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];
+    }
+    ;
+
+rule_statement:
+'%rule' LOWERCASE '=' rule '.' rule_body {
+        my $r = hj($_[4],$_[6]);
+        ${$r}{name} = $_[2];
+        $r;
+    }
+    ;
+
+rule_body:
+    #empty {{}}
+    | '{' rule_const rule_item_type tree code '}' {
+        my $r = {};
+        ${$r}{'const'} = $_[2] if $_[2];
+        ${$r}{'item'} = $_[3] if $_[3];
+        ${$r}{'tree'} = $_[4] if $_[4];
+        ${$r}{'code'} = $_[5] if $_[5];
+        $r;
+    }
+    ;
+
+rule_const:
+    #empty { "NULL" }
+    | '%const' CODE {$_[2]}
+    ;
+
+rule_item_type:
+    #empty { undef }
+    | '%item_type' CODE {$_[2]}
+    ;
+
+code:
+    #empty { undef }
+    | '%code' CODE {$_[2]}
+    ;
+
+tree:
+    #empty {undef}
+    | '%root' LOWERCASE {$_[2]}
+    ;
+
+rule:
+    complete_rule
+    | sequence {{subrules=>$_[1],type=>'seq'}};
+
+
+complete_rule:
+    base_rule cardinality qualification {hj($_[1],hj($_[2],$_[3]))}
+    ;
+
+base_rule:
+    '(' sequence ')' { {subrules=>$_[2],type=>'seq'}}
+    | '(' choice ')' {{subrules=>$_[2],type=>'choice'}}
+    | until_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'}}
+    | LOWERCASE {{control=>$_[1],type=>'named'}} 
+    ;
+
+until_rule:
+    '...' qualification '{' rule '}'  { @{$_[2]}{'type','subrule'} = ('until',$_[4]); $_[2] }
+    ;
+
+choice:
+    complete_rule '|' complete_rule { [$_[1],$_[3]] }
+    | choice '|' complete_rule { push @{$_[1]}, $_[3]; $_[1] }
+    ;
+
+sequence:
+    complete_rule complete_rule { [$_[1],$_[2]] }
+    | sequence complete_rule { push @{$_[1]}, $_[2]; $_[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]} = undef; $_[1] }
+    | LOWERCASE { my $e = {}; ${$e}{$_[1]} = undef; $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 QUOTED { [ $_[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
+    ;
+
+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
+    ;
+
+quoted: DQUOTED | SQUOTED ;
+
+%%
+
+