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

5 files changed, 1084 insertions, 0 deletions

diff --git a/tools/tpg/Makefile.am b/tools/tpg/Makefile.am
new file mode 100644
index 0000000000..e2a40f154d
--- /dev/null
+++ b/tools/tpg/Makefile.am
@@ -0,0 +1,50 @@
+# Makefile.am
+#
+# $Id$
+#
+# Ethereal - Network traffic analyzer
+# By Gerald Combs <gerald@zing.org>
+# Copyright 2001 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.
+
+# We produce an archive library. In the future, when libethereal is a
+# shared library, this will be linked into libethereal. While libethereal
+# is an archive library, any executable linking against libethereal will
+# also need to link against libftypes.
+
+CLEANFILES = \
+	*~
+
+MAINTAINERCLEANFILES = \
+	Makefile.in \
+	tpg.output \
+	TPG.pm
+
+EXTRA_DIST = \
+	tpg.yp		\
+	V2P.pl			\
+	TPG.pm			\
+	tpg.pl			\
+	Makefile.nmake		\
+	README
+
+TPG.pm: tpg.yp
+	yapp -v -m TPG tpg.yp
+
+tpg.pl: TPG.pm
+
+all: tpg.pl
diff --git a/tools/tpg/Makefile.nmake b/tools/tpg/Makefile.nmake
new file mode 100644
index 0000000000..a3010c1999
--- /dev/null
+++ b/tools/tpg/Makefile.nmake
@@ -0,0 +1,17 @@
+## Makefile for building ethereal.exe with Microsoft C and nmake
+## Use: $(MAKE) /$(MAKEFLAGS) -f makefile.nmake
+#
+# $Id$
+
+include ..\..\config.nmake
+
+CFLAGS=-D_U_="" $(LOCAL_CFLAGS)
+
+all : TPG.pm
+
+clean:
+	rm -f TPG.pm tpg.output
+
+distclean: clean
+
+maintainer-clean: distclean
diff --git a/tools/tpg/V2P.pm b/tools/tpg/V2P.pm
new file mode 100644
index 0000000000..e2f4fb8df2
--- /dev/null
+++ b/tools/tpg/V2P.pm
@@ -0,0 +1,106 @@
+#!/usr/bin/perl
+#
+#  a function that prints a complex variable such that the output is a
+# valid perl representation of that variable (does not handle blessed objects)
+#
+# (c) 2002, Luis E. Garcia Ontanon <luis.ontanon@gmail.com>
+#
+# $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.
+
+package V2P;
+use strict;
+
+
+my $_v2p_columns = 120;
+
+sub var2perl { # converts a complex variable reference into perl code
+	__v2p(0,@_);
+}
+
+sub __v2p {
+    my $d = shift ;
+    my $i = '';
+    my $buf = '';
+    
+    if ( $d gt 0) {
+        $i .= " " for (0..$d);
+    }
+    
+    if (scalar @_ <= 1) {
+        my $what = ref $_[0];
+#~ print "! $_[0] '$what'\n";
+        
+        if ( $what ) {
+            if ($what eq 'ARRAY') {
+                $buf .=  "[\n";
+                $buf .=  "$i " . __v2p($d+1,$_) . ",\n" for (@{$_[0]});
+                $buf =~ s/,\n$//msi;
+                    $buf .= "\n$i]\n";
+            }
+            elsif ($what eq 'HASH') {
+                $buf .=  "{\n";
+                $buf .=   "$i " . __v2p($d+1,$_) . " =>" . __v2p($d+1,${$_[0]}{$_}) . ",\n" for (keys %{$_[0]});
+                $buf =~ s/,\n$//msi;
+                    $buf .=  "\n$i}\n";
+            }
+            elsif ($what eq 'SCALAR') {
+                $buf .=  "\\" . __v2p($d+1,$_[0]);
+            }
+            elsif ($what eq 'REF') {
+                $buf .=  "\\" . __v2p($d+1,\$_);
+            }
+            elsif ($what eq 'GLOB') {
+                $buf .=  "*" . __v2p($d+1,\$_);
+            }
+            elsif ($what eq 'LVALUE') {
+                $buf .=  'lvalue';
+            }
+            elsif ($what eq 'CODE') {
+                $buf .=  'sub { "sorry I cannot do perl code"; }';
+            }
+            else {
+                $buf .=  "what's '$what'?";
+            }
+        } else {
+            return "undef" unless defined $_[0];
+            return "''" if $_[0] eq '';
+            return "'$_[0]'" unless $_[0]=~ /^[0-9]+[\.][0-9]*?$/
+                or $_[0]=~ /^[0-9]+$/
+                or $_[0]=~ /^[0-9]*[\.][0-9]+?$/;
+            return $_[0];
+        }
+    } else {
+        $buf = $i . "( ";
+        $buf .= "$i , " .  __v2p($d+1,$_) for (@_);
+        $buf .= " )\n";
+        $buf =~ s/^\( , /\( /;
+    }
+
+$buf =~ s/\n,/,/msg;
+if (length $buf < $_v2p_columns)  {
+    $buf =~ s/\n//msg;
+    $buf =~ s/$i//msg;
+    $buf = $i . $buf;
+}
+return $buf;
+}
+
+1;
diff --git a/tools/tpg/tpg.pl b/tools/tpg/tpg.pl
new file mode 100644
index 0000000000..7d035bac17
--- /dev/null
+++ b/tools/tpg/tpg.pl
@@ -0,0 +1,591 @@
+#!/usr/bin/perl
+#
+# TPG TVB Parser Generator
+#
+# 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 TPG;
+use V2P;
+use strict;
+
+my $DEBUG = 0;
+
+my $b = '';
+
+while(<>) {
+    $b .= $_;
+}
+
+my @T = @{tokenizer()};
+my $linenum = 1;
+my %CODE = ();
+my $codenum = 0;
+
+
+$b =~ s/\%\{(.*?)\%\}/add_code($1)/egms;
+
+$b =~ s/#.*?\n/\n/gms;
+
+my $parser = new TPG();
+my $last_token = '';
+
+$parser->YYData->{DATA}=\$linenum;
+
+my $parser_info = $parser->YYParse(yylex => \&next_token, yyerror => \&error_sub); #yydebug => 0x1f
+
+die "failed parsing" unless defined $parser_info;
+
+if ($DEBUG > 3) {
+    warn "\n=========================== parser_info ===========================\n";
+    warn V2P::var2perl( $parser_info );
+    warn "\n=========================== ======== ===========================\n" ;
+}
+
+my $proto_name =  ${$parser_info}{proto_name};
+my $upper_name = $proto_name;
+$upper_name =~ tr/a-z/A-Z/;
+
+warn "parser_data_type: ${$parser_info}{pdata}\n" if $DEBUG;
+
+my %exports = %{${$parser_info}{export}};
+
+my $field_num = 0;
+
+my $init_function =  "void tpg_$proto_name\_init(void) {\n";
+
+for my $fieldname (keys %{${$parser_info}{fields}}) {
+    my $f = ${${$parser_info}{fields}}{$fieldname};
+    
+    my $vs = defined ${$f}{vs} ? 'VALS(' . ${$f}{vs}. ')' : "NULL" ;
+           
+    ${$f}{vname} = "$proto_name\_hfis.${$f}{name}" unless defined ${$f}{vname};
+    ${$f}{base} = 'BASE_NONE' unless defined ${$f}{base};
+    ${$f}{desc} = '""' unless defined ${$f}{desc};
+    ${$f}{structname} .= "\tint ${$f}{name};\n";
+    $init_function .= "\t${$f}{vname} = -1;\n";
+    ${$f}{hfi} .= "{ &${$f}{vname}, { ${$f}{pname}, ${$f}{abbr}, ${$f}{type}, ${$f}{base}, $vs, 0x0, ${$f}{desc}, HFILL }},";
+                                               
+# warn "\nFIELD:$fieldname " . V2P::var2perl($f);
+
+}
+
+my $tt_type = ${$parser_info}{pdata};
+
+$tt_type =~ s/\n#line.*?\n//ms;
+$tt_type =~ s@\n/\*eocode\*/\n@@ms;
+
+my $ett_arr = "#define ETT_$upper_name\_PARSER \\\n";
+my $ett_decl = '';
+my $ett_init = '';
+for my $rulename ( keys %{${$parser_info}{rules}} ) {
+    my $r = ${${$parser_info}{rules}}{$rulename};
+
+    make_rule($r,0);
+    
+# warn "\nRULE:$rulename " . V2P::var2perl($r);
+}
+
+$ett_arr =~ s/,\\\n$//ms;
+
+my $hfarr = "/* field array */\n#define HF_$upper_name\_PARSER \\\n";
+my $hfstruct = "struct _$proto_name\_hfis_t {\n";
+for my $fieldname (sort keys %{${$parser_info}{fields}}) {
+    my $f = ${${$parser_info}{fields}}{$fieldname};
+    $hfarr .=  ${$f}{hfi} . "\\\n";
+    $hfstruct .= ${$f}{structname} ;
+}
+$hfstruct .= $ett_decl . "};";
+$hfarr =~ s/,\\\n$/\n/msi;
+
+my $c_file = '';
+my $h_file = '';
+
+$c_file .= <<"__C_HEAD";
+/*
+    $proto_name-parser.c
+    automagically generated by $0 from $ARGV
+    DO NOT MODIFY.
+*/
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include "$proto_name-parser.h" 
+
+/* begin %head */
+${$parser_info}{head}
+/* end %head */
+__C_HEAD
+
+$h_file .= <<"__H_HEAD";
+/*
+ $proto_name-parser.h
+ automagically generated by $0 from $ARGV
+ DO NOT MODIFY.
+ */
+
+#ifndef _H_$upper_name\_PARSER
+#define _H_$upper_name\_PARSER
+#include <epan/tpg.h>
+
+
+/* begin %header_head */
+${$parser_info}{header_head}
+/* end %header_head */
+
+extern void tpg_$proto_name\_init(void);
+
+__H_HEAD
+
+
+$h_file .= "\n/* hfids export container */\n$hfstruct\n";
+$h_file .= "\n/* hfids container */\nextern struct _$proto_name\_hfis_t $proto_name\_hfis;\n\n";
+$h_file .= $hfarr . "\n\n" . $ett_arr ."\n\n";
+
+$c_file .= "\n/* hfids container */\nextern struct _$proto_name\_hfis_t  $proto_name\_hfis;\n\n";
+$h_file .= "/* parser declarations */\n";
+$c_file .= "/* parser declarations */\n";
+
+for my $rulename (sort keys %{${$parser_info}{rules}} ) {
+    my $r = ${${$parser_info}{rules}}{$rulename};
+    
+    if (exists $exports{$rulename}) {
+        $h_file .= ${$r}{declaration_code};
+    } else {
+        $c_file .= ${$r}{declaration_code};
+    }
+}
+
+$c_file .= "\n\n/* parser definitions */\n";
+
+for my $rulename (sort keys %{${$parser_info}{rules}} ) {
+    my $r = ${${$parser_info}{rules}}{$rulename};
+        
+    
+        $c_file .= "\n\n/* definitions for rule $rulename */\n";
+        $c_file .= ${$r}{before_cb_code} . "\n";
+        $c_file .= ${$r}{after_cb_def} . "\n";
+        $c_file .= ${$r}{definition_code} . "\n\n";
+}
+
+
+$h_file .= <<"__H_TAIL";
+
+/* begin %header_tail */
+${$parser_info}{header_tail}
+/* end %header_tail */
+
+#endif /* _H_$upper_name\_PARSER */
+__H_TAIL
+
+$c_file .= <<"__C_TAIL";
+
+$init_function
+$ett_init
+}
+
+/* begin %tail */
+${$parser_info}{tail}
+/* end %tail */
+
+__C_TAIL
+
+my $c_buf = '';
+my $c_line = 3;
+while($c_file =~ s/^([^\n]*)\n//ms) {
+    my $line = $1;
+
+    $c_line += 2 if $line =~ s@/\*eocode\*/@\n#line $c_line \"$proto_name-parser.c\"\n@;
+    $c_buf .= $line . "\n";
+    $c_line++;
+}
+
+my $h_buf = '';
+my $h_line = 3;
+while($h_file =~ s/^([^\n]*)\n//ms) {
+      my $line = $1;
+      
+      $h_line += 2 if $line =~ s@/\*eocode\*/@\n#line $h_line \"$proto_name-parser.h\"\n@;
+      $h_buf .= $line . "\n";
+      $h_line++;
+}
+
+
+open C, "> $proto_name-parser.c";
+open H, "> $proto_name-parser.h";
+print C $c_buf;
+print H $h_buf;
+close C;
+close H;
+
+exit;
+
+sub make_rule {
+    my $r = shift;
+    my $dd = shift;
+    
+    my $rule_id = "0";    
+    my $code = \${$r}{definition_code};
+    my $indent;
+    
+
+    
+    for (0..$dd) {
+        $indent .= "\t";
+    }
+    
+    my $indent_more = $indent . "\t";
+    
+    my $min;
+    my $max;
+
+    if (exists ${$r}{min}) {
+        $min = ${$r}{min};
+    } else {
+        $min = ${$r}{min} = 1;
+    }
+
+    if (exists ${$r}{max}) {
+        $max = ${$r}{max};
+    } else {
+        $max = ${$r}{max} = 1;
+    }
+    
+    if ($dd == 0) {
+        my %VARS = ();
+
+        if (exists $exports{${$r}{name}}) {
+            ${$r}{definition_code} = 'extern ';
+            ${$r}{declaration_code} = '' ;
+        } else { 
+            ${$r}{definition_code} = 'static ';
+            ${$r}{declaration_code} = 'static ';
+        }
+    
+        ${$code} .= "tvbparse_wanted_t* wanted_$proto_name\_${$r}{name}(void) {\n\treturn ";
+        ${$r}{declaration_code} .= "tvbparse_wanted_t* wanted_$proto_name\_${$r}{name}(void);\n";
+        
+        $VARS{"TT_DATA"} = "TPG_DATA(tpg,$tt_type)" if defined $tt_type;
+            
+            make_vars(\%VARS,$r,"elem");
+        
+#        warn "VARS::${$r}{name} " . V2P::var2perl(\%VARS);
+                
+        
+        my $tree_code_head = "";
+        my $tree_code_body = "";
+        my $tree_code_after = "";
+        
+        make_tree_code($r,\$tree_code_head,\$tree_code_body,\$tree_code_after,"elem");
+        
+        if (length $tree_code_body ) {
+            my $cb_name = ${$r}{before_cb_name} = "${$r}{name}\_before_cb";
+            ${$r}{before_cb_code} = "static void $cb_name(void* tpg _U_, const void* wd _U_, struct _tvbparse_elem_t* elem _U_) {\n$tree_code_head\n$tree_code_body\n}";
+            ${$r}{code} .= $tree_code_after;
+        }
+        
+        my $tree_code = \${$r}{tree_code};
+                
+
+        if (${$r}{code}) {
+            my $after = ${$r}{code};
+            
+            ${$r}{after_cb_name} = "${$r}{name}_after\_cb";
+            
+            ${$r}{after_cb_def} = "static void ${$r}{after_cb_name}(void* tpg _U_, const void* wd _U_, struct _tvbparse_elem_t* elem _U_) {\n";
+            
+            for (keys %VARS) {
+                $after =~ s/($_)([A-Z]?)/$VARS{$1}$2/msg;
+            }
+                        
+            ${$r}{after_cb_def} .= $after . "\n}\n";
+        }
+        
+    }
+    
+    my $after_fn = ${$r}{after_cb_name} ? ${$r}{after_cb_name} : "NULL";
+    my $before_fn = ${$r}{before_cb_name} ? ${$r}{before_cb_name} : "NULL";
+
+    my $wd_data = "NULL";
+
+    if (exists ${$r}{field}) {
+        my $field = ${${$parser_info}{fields}}{${$r}{field}};
+        die "field ${$r}{field} does not exists\n" . V2P::var2perl(${$parser_info}{fields}) unless defined $field;
+        
+        my $ett = exists ${$r}{ett} ? ${$r}{ett} : "NULL";
+        
+        my $wd_data = 'tpg_wd(${$field}{vname},$ett,NULL)';
+        
+    }
+    
+    my $control = ${$r}{control};
+    
+    if (${$r}{type} eq 'chars' || ${$r}{type} eq 'not_chars') {
+        if (! ($min == 1 && $max == 1) ) {
+            ${$code} .= $indent . "tvbparse_${$r}{type}($rule_id,$min,$max,$control,$wd_data,$before_fn,$after_fn)"
+        } else {
+            my $rn = ${$r}{type};
+            $rn =~ s/.$//;
+                ${$code} .= $indent . "tvbparse_$rn($rule_id,$control,$wd_data,$before_fn,$after_fn)"
+        }
+    } else {
+        if (! ($min == 1 && $max == 1))  {
+            ${$code} .= $indent . "tvbparse_some(0,$min,$max,NULL,NULL,NULL,\n";
+        }
+            
+        if (${$r}{type} eq 'string') {
+            
+            ${$code} .= $indent . "tvbparse_string($rule_id,$control,$wd_data,$before_fn,$after_fn)";
+            
+        } elsif (${$r}{type} eq 'caseless') {
+            
+            ${$code} .= $indent . "tvbparse_casestring($rule_id,$control,$wd_data,$before_fn,$after_fn)";
+            
+        } elsif (${$r}{type} eq 'named') {
+            
+            ${$code} .= $indent . "wanted_$proto_name\_$control()";
+            
+        } elsif (${$r}{type} eq 'seq') {
+            
+            ${$code} .= $indent . "tvbparse_set_seq($rule_id,$wd_data,$before_fn,$after_fn,\n";
+            
+            for ( @{${$r}{subrules}}) {
+                $dd++;
+                ${$code} .= $indent_more . make_rule($_,$dd) . ",\n";
+                $dd--;
+            }
+            
+            ${$code} .= $indent . " NULL)"
+                
+        } elsif (${$r}{type} eq 'choice') {
+            
+            ${$code} .= $indent . "tvbparse_set_oneof($rule_id,$wd_data,$before_fn,$after_fn,\n";
+            
+            for (@{${$r}{subrules}}) {
+                $dd++;
+                ${$code} .= $indent_more . make_rule($_,$dd) . ",\n";
+                $dd--;
+            }
+            
+            ${$code} .= $indent . " NULL)"
+                
+        } elsif (${$r}{type} eq 'until') {
+            ${$code} .= $indent ."tvbparse_until(0,$wd_data,$before_fn,$after_fn,\n";
+            $dd++;
+            ${$code} .= $indent_more . make_rule(${$r}{subrule},$dd) . ", TRUE)";
+            $dd--;
+        }
+        
+        if (! ($min == 1 && $max == 1) ) {
+            ${$code} .= ")";
+        }    
+    }
+
+    if ($dd == 0) {
+        ${$code} .= ";\n}\n";
+#        warn "RULE::${$r}{name} " . V2P::var2perl($r);
+    }
+
+    ${$code};
+}
+
+
+sub make_vars {
+    my $v = shift;
+    my $r = shift;
+    my $base = shift;
+    
+    if (exists ${$r}{var}) {
+        ${$v}{${$r}{var}} = $base;
+    }
+
+    if (! ( ${$r}{type} =~ /chars$/ ) && ! (${$r}{min} == 1 && ${$r}{max} == 1) ) {
+        $base .= "->sub";
+    }
+    
+    if (exists ${$r}{subrule} ) {
+        make_vars($v,${$r}{subrule},"$base->sub");
+    }
+    
+    
+    if (exists ${$r}{subrules} ) {
+        my $sub_base = "$base->sub";
+        for my $rule (@{${$r}{subrules}}) {
+            make_vars($v,$rule,$sub_base);
+            $sub_base .= "->next";
+        }
+    }
+}
+
+sub make_tree_code {
+    my $r = shift;
+    my $head = shift;
+    my $body = shift;
+    my $after = shift;
+    my $elem = shift;    
+    
+    if (exists ${$r}{field}) {
+        my $fieldname = ${$r}{field};
+        my $f = ${${$parser_info}{fields}}{$fieldname};
+
+        my $root_var = '';
+        
+        if (exists ${$r}{tree}) {
+            $root_var = "root_$fieldname";
+            ${$head} .= "\tproto_item* $root_var;\n";
+            ${$body} .= "\t$root_var = ";
+            $ett_arr .= "\t&$proto_name\_hfis.ett_$fieldname,\\\n";
+            $ett_decl .= "\tguint ett_$fieldname; \n";
+            $ett_init .= "\t$proto_name\_hfis.ett_$fieldname = -1;\n";
+            ${$r}{ett} = "$proto_name\_hfis.ett_$fieldname";
+        } else {
+            ${$body} .= "\t";
+        }
+        
+        if (${$f}{type} eq 'FT_STRING') {
+            ${$body} .= "TPG_ADD_STRING(tpg,${$f}{vname},$elem);\n";
+        } elsif (${$f}{type} =~ /^FT_UINT/) {
+            my $fieldvar = "tpg_uint_$fieldname";
+            ${$head} .= "\tguint $fieldvar = TPG_UINT($elem);\n";
+            ${$body} .= "TPG_ADD_UINT(tpg,${$f}{vname},$elem,$fieldvar);\n";
+        } elsif (${$f}{type} =~ /^FT_INT/) {
+            my $fieldvar = "tpg_int_$fieldname";
+            ${$head} .= "\tgint $fieldvar = TPG_INT($elem);\n";
+            ${$body} .= "TPG_ADD_INT(tpg,${$f}{vname},$elem,$fieldvar);\n";
+        } elsif (${$f}{type} eq 'FT_IPV4') {
+            my $fieldvar = "tpg_ipv4_$fieldname";
+            ${$head} .= "\tguint32 $fieldvar = TPG_IPV4($elem);\n";
+            ${$body} .= "TPG_ADD_IPV4(tpg,${$f}{vname},$elem,$fieldvar);\n";
+        } elsif (${$f}{type} eq 'FT_IPV6') {
+            my $fieldvar = "tpg_ipv6_$fieldname";
+            ${$head} .= "\tguint8* $fieldvar = TPG_IPV6($elem);\n";
+            ${$body} .= "TPG_ADD_IPV6(tpg,${$f}{vname},$elem,$fieldvar);\n";
+        } else {
+            ${$body} .= "TPG_ADD_TEXT(tpg,$elem);\n";
+        }
+        
+        if (exists ${$r}{tree}) {
+            ${$body} .=  "\tTPG_PUSH(tpg,$root_var,${$r}{ett});\n";
+        }
+    }
+    
+    
+    if (! ( ${$r}{type} =~ /chars$/ ) && ! (${$r}{min} == 1 && ${$r}{max} == 1) ) {
+        $elem .= "->sub";
+    }
+    
+        
+    if (exists ${$r}{subrule} ) {
+        make_tree_code(${$r}{subrule},$head,$body,$after,"$elem->sub");
+    }
+    
+    if (exists ${$r}{subrules} ) {
+        my $sub_base = "$elem->sub";            
+        for my $rule (@{${$r}{subrules}}) {
+            make_tree_code($rule,$head,$body,$after,$sub_base);
+            $sub_base .= "->next";
+        }
+    }
+
+    if (exists ${$r}{field}) {
+        if (exists ${$r}{tree}) {
+            ${$after} .=  "\n\t/* tree after code */\n\tTPG_POP(tpg);\n";
+        }
+        
+    }
+}
+sub tokenizer {
+    [
+        [ '(FT_(UINT(8|16|24|32)|STRING|INT(8|16|24|32)|IPV[46]|ETH|BOOLEAN|DOUBLE|FLOAT|(ABSOLUTE|RELATIVE)_TIME|BYTES))' , sub { [ 'FT', $_[0] ] } ],
+        [ '(BASE_(NONE|DEC|HEX))', sub { [ 'BASE', $_[0] ] }],
+        [ '([a-z]+\\.[a-z0-9_\\.]*[a-z])', sub { [ 'DOTEDNAME', $_[0] ] }], 
+        [ '([a-z][a-z0-9_]*)', sub { [ 'LOWERCASE', $_[0] ] }], 
+        [ '([A-Z][A-Z0-9_]*)', sub { [ 'UPPERCASE', $_[0] ] }],
+        [ '([0-9]+|0x[0-9a-fA-F]+)', sub { [ 'NUMBER', $_[0] ] }],
+        [ '(\%\%[0-9]+\%\%)', \&c_code ],
+        [ "('(\\\\'|[^'])*')", sub { [ 'SQUOTED', $_[0] ] }], 
+        [ '\[\^((\\\\\\]|[^\\]])*)\]', sub { [ 'NOTCHARS', $_[0] ] }], 
+        [ '\[((\\\\\\]|[^\\]])*)\]', sub { [ 'CHARS', $_[0] ] }], 
+        [ '("(\\\\"|[^"])*")', sub { [ 'DQUOTED', $_[0] ] }], 
+        [ '(\%[a-z_]+|\%[A-Z][A-Z-]*|\=|\.\.\.|\.|\:|\;|\(|\)|\{|\}|\+|\*|\?|\<|\>|\|)', sub { [  $_[0], $_[0] ] }], 
+    ]
+}
+
+sub next_token {
+    
+    if ($b =~ s/^([\r\n\s]+)// )  {
+        my $l = $1;
+        while ( $l =~ s/\n//ms ) {
+                $linenum++;
+        }
+    }
+
+    return (undef,'') unless length $b;
+
+    for (@T) {
+        my ($re,$ac) = @{$_};
+        
+        if( $b =~ s/^$re//ms) {
+            $a = &{$ac}($1);
+            $last_token = ${$a}[1];
+#warn "=($linenum)=> ${$a}[0]   ${$a}[1]\n";
+            return (${$a}[0],${$a}[1]);
+        }
+    }
+
+    die "unrecognized token at line $linenum after '$last_token'";
+}
+
+sub error_sub {
+    my @a = $_[0]->YYExpect;
+    my $t = $_[0]->YYCurtok;
+    
+    die "error at $linenum after '$last_token' expecting (@a)";
+}
+
+
+sub add_code {
+    my $k = "%%$codenum%%";
+    $CODE{$k} = $_[0];
+    $codenum++;
+    return $k;
+}
+
+sub c_code {
+    my $k = $_[0];
+    my $t = $CODE{$k};
+    my $start = $linenum;
+    $linenum++ while ( $t =~ s/\n// );
+    return [ 'CODE', "\n#line $start \"$ARGV\"\n$CODE{$k}\n/*eocode*/\n"];
+}
+
+
+__END__
+
+do {
+    ($type,$value) = @{next_token()};
+    last if not defined $type;
+} while(1);
+
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 ;
+
+%%
+
+