tools/tpg/tpg.yp

   1 %{
   2 #!/usr/bin/perl
   3 #
   4 # TPG TVB Parser Generator Grammar
   5 #
   6 # Given a bnf like grammar generate a parser for text based tvbs
   7 #
   8 # $Id$
   9 #
  10 # Wireshark - Network traffic analyzer
  11 # By Gerald Combs <gerald@wireshark.org>
  12 # Copyright 2004 Gerald Combs
  13 #
  14 # This program is free software; you can redistribute it and/or
  15 # modify it under the terms of the GNU General Public License
  16 # as published by the Free Software Foundation; either version 2
  17 # of the License, or (at your option) any later version.
  18 #
  19 # This program is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with this program; if not, write to the Free Software
  26 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  27
  28     use V2P;
  29
  30     my $parser_info;
  31
  32 sub hj {
  33     ${$_[0]}{$_} = ${$_[1]}{$_} for (keys %{$_[1]});
  34     return $_[0];
  35 }
  36
  37 sub abort {
  38     my $line = ${$_[0]->YYData->{DATA}};
  39
  40     die "$_[1] at $line";
  41 }
  42
  43 sub from_to {
  44     my $f = unpack "C", shift;
  45     my $t = unpack "C", shift;
  46     my $b = '';
  47     for ($f..$t) {
  48         $b .= pack("C",$_);
  49     }
  50     $b;
  51 }
  52
  53
  54 sub to_hexesc {
  55     sprintf "\\x%.2x", unpack("C",$_[0]);
  56 }
  57
  58 sub chars_control {
  59     $_ = $_[0];
  60     s/([a-zA-Z0-9])-([a-zA-Z0-9])/from_to($1,$2)/ge;
  61     s/"/\\"/g;
  62     s/\\(.)/to_hexesc($1)/ge;
  63     "\"$_\"";
  64 }
  65
  66 %}
  67
  68 %%
  69
  70 start: statements {$parser_info} ;
  71
  72 statements:
  73     #empty { $parser_info = {}; }
  74     |   statements statement
  75     ;
  76
  77 statement:
  78     rule_statement {
  79         my $rulename = ${$_[1]}{name};
  80
  81         abort($_[0],"%rule $rulename already defined") if exists ${${$parser_info}{rules}}{$rulename};
  82
  83         ${${$parser_info}{rules}}{$rulename} = $_[1];
  84     }
  85     |  parser_name_statement {
  86         abort($_[0],"%parser_name already defined") if exists ${$parser_info}{name};
  87         ${$parser_info}{proto_name} = $_[1];
  88     }
  89     | proto_desc_statement {
  90         abort($_[0],"%proto_desc already defined") if exists ${$parser_info}{proto_desc};
  91         ${$parser_info}{proto_desc} = $_[1];
  92     }
  93     | header_head_statement {
  94         ${$parser_info}{header_head} .= $_[1];
  95     }
  96     | code_head_statement {
  97         ${$parser_info}{head} .= $_[1];
  98     }
  99     | header_tail_statement {
 100         ${$parser_info}{header_tail} .= $_[1];
 101     }
 102     | code_tail_statement {
 103         ${$parser_info}{tail} .= $_[1];
 104     }
 105     | static_field_statement {
 106         abort($_[0],"%field '${$_[1]}{name}' already defined") if (exists ${${$parser_info}{fields}}{${$_[1]}{name}});
 107         ${${$parser_info}{fields}}{${$_[1]}{name}} = $_[1];
 108     }
 109     | parser_data_statement {
 110         abort($_[0],"%tt_type already defined") if exists ${$parser_info}{pdata};
 111         ${$parser_info}{pdata} = $_[1];
 112     }
 113     | export_statement {
 114         abort($_[0],"%export already defined") if exists ${$parser_info}{export};
 115         ${$parser_info}{export} = $_[1];
 116     }
 117     | value_string_statement {
 118         my $name = ${$_[1]}{name};
 119         abort($_[0],"%value_string $name already defined") if exists ${${$parser_info}{vs}}{$name};
 120         ${${$parser_info}{vs}}{$name} = $_[1];
 121     }
 122     | ignore_statement {
 123         ${$parser_info}{ignore} = $_[1];
 124     }
 125     ;
 126
 127 ignore_statement:
 128     '%ignore' LOWERCASE {$_[2]}
 129     ;
 130
 131 rule_statement:
 132     '%sequence' tree LOWERCASE '=' sequence_rule '.' qualification code {
 133         my $r = hj($_[5],$_[7]);
 134         ${$r}{name} = $_[3];
 135         ${$r}{code} = $_[8] if defined $_[8];
 136         ${$r}{tree} = 1 if defined $_[2];
 137         $r;
 138     }
 139     | '%choice' tree LOWERCASE '=' choice_rule '.' qualification code {
 140         my $r = hj($_[5],$_[7]);
 141         ${$r}{name} = $_[3];
 142         ${$r}{code} = $_[8] if defined $_[8];
 143         ${$r}{tree} = 1 if defined $_[2];
 144         $r;
 145     }
 146     | '%rule' LOWERCASE '=' complete_rule '.' code {
 147         my $r = $_[4];
 148         ${$r}{name} = $_[2];
 149         ${$r}{code} = $_[6] if defined $_[6];
 150         $r;
 151     }
 152     ;
 153
 154 code:
 155     #empty { undef }
 156     | CODE
 157     ;
 158
 159 tree:
 160     #empty {undef}
 161     | '%tree'
 162     ;
 163
 164
 165 complete_rule:
 166     base_rule cardinality qualification {hj($_[1],hj($_[2],$_[3]))}
 167     | named_rule cardinality { hj($_[1],$_[2]) }
 168     | until_rule
 169     ;
 170
 171 named_rule: LOWERCASE {{control=>$_[1],type=>'named'}} ;
 172
 173 base_rule:
 174     | CHARS {{control=>chars_control($_[1]),type=>'chars'}}
 175     | NOTCHARS {{control=>chars_control($_[1]),type=>'not_chars'}}
 176     | DQUOTED {{control=>"\"$_[1]\"",type=>'string'}}
 177     | SQUOTED {{control=>"\"$_[1]\"",type=>'caseless'}}
 178     ;
 179
 180 until_rule:
 181     '...' qualification '(' last_rule include_mode ')'  { @{$_[2]}{'type','subrule','inc_mode'} = ('until',$_[4],$_[5]); $_[2] }
 182     ;
 183
 184 last_rule: base_rule | named_rule;
 185
 186 include_mode:
 187     #empty { 'TP_UNTIL_SPEND' }
 188     | '%spend' { 'TP_UNTIL_SPEND' }
 189     | '%include' { 'TP_UNTIL_INCLUDE' }
 190     | '%leave' { 'TP_UNTIL_LEAVE' }
 191     ;
 192
 193 choice_rule: choice {{subrules=>$_[1],type=>'choice'}} ;
 194
 195 choice:
 196     complete_rule '|' complete_rule { [$_[1],$_[3]] }
 197     | choice '|' complete_rule { push @{$_[1]}, $_[3]; $_[1] }
 198     ;
 199
 200 sequence_rule: sequence { {subrules=>$_[1],type=>'seq'}} ;
 201
 202 sequence:
 203     complete_rule { [$_[1]] }
 204     | sequence '&' complete_rule { push @{$_[1]}, $_[3]; $_[1] }
 205     ;
 206
 207 cardinality:
 208     #empty { my %c; @c{'min','max'} = (1,1); \%c  }
 209     | '+' { my %c; @c{'min','max'} = (1,"0xffffffff"); \%c  }
 210     | '?' { my %c; @c{'min','max'} = (0,1); \%c  }
 211     | '*' { my %c; @c{'min','max'} = (0,"0xffffffff"); \%c  }
 212     | '{' NUMBER ',' NUMBER '}' { my %c; @c{'min','max'} = ($_[2],$_[4]); \%c  }
 213     | '{' NUMBER '}' { my %c; @c{'min','max'} = ($_[2],$_[2]); \%c  }
 214     | '{' ',' NUMBER '}' { my %c; @c{'min','max'} = (0,$_[3]); \%c  }
 215     | '{' NUMBER ',' '}' { my %c; @c{'min','max'} = ($_[2],"0xffffffff"); \%c  }
 216     ;
 217
 218 qualification:
 219     #empty {{}}
 220     | '<' qualifiers '>' {$_[2]}
 221     ;
 222
 223 qualifiers:
 224     qualifier { my $p = {}; ${$p} { ${$_[1]}[0] } = ${$_[1]}[1]; $p }
 225     | qualifiers ':' qualifier { ${$_[1]} { ${$_[3]}[0] } = ${$_[3]}[1]; $_[1] }
 226     ;
 227
 228 qualifier:
 229     | LOWERCASE { ['field',$_[1]] }
 230     | UPPERCASE { ['var',$_[1]] }
 231     | '%plain_text' { ['plain_text',1] }
 232     ;
 233
 234 proto_desc_statement:
 235     '%proto_desc' quoted '.' { "\"$_[2]\"" }
 236     ;
 237
 238 header_head_statement:
 239     '%header_head' CODE { $_[2] }
 240     ;
 241
 242 header_tail_statement:
 243     '%header_tail' CODE {  $_[2] }
 244     ;
 245
 246 code_head_statement:
 247     '%head' CODE { $_[2] }
 248     ;
 249
 250 code_tail_statement:
 251     '%tail' CODE {  $_[2] }
 252     ;
 253
 254 parser_name_statement:
 255     '%parser_name' LOWERCASE '.' {$_[2]}
 256     ;
 257
 258 parser_data_statement:
 259     '%tt_type' CODE { $_[2] }
 260     ;
 261
 262 export_statement:
 263     '%export' exports '.' { $_[2] }
 264     ;
 265
 266 exports:
 267     exports LOWERCASE { ${$_[1]}{$_[2]} = 1; $_[1] }
 268     | LOWERCASE { my $e = {}; ${$e}{$_[1]} = 1; $e }
 269     ;
 270
 271 value_string_statement:
 272     '%value_string' LOWERCASE value_string_items { my $v = {}; ${$v}{name} = $_[2]; ${$v}{items} = $_[3]; $v }
 273     ;
 274
 275 value_string_items:
 276     value_string_items value_string_item { push @{$_[1]}, $_[2] }
 277     | value_string_item { [$_[1]]}
 278     ;
 279
 280 value_string_item:
 281     NUMBER DQUOTED { [ $_[1], "\"$_[2]\"" ] }
 282     ;
 283
 284 static_field_statement:
 285     '%field' LOWERCASE DOTEDNAME field_name field_type field_base field_value_string field_description '.' {
 286         my $field = {};
 287         @{$field}{'name','abbr','pname','type','base','vs','desc'} = ($_[2],"\"$_[3]\"",$_[4],$_[5],$_[6],$_[7],$_[8]);
 288         return $field;
 289     }
 290     ;
 291
 292 field_name:
 293     #empty {undef}
 294     | DQUOTED { "\"$_[1]\""}
 295     ;
 296
 297 field_type:
 298     #empty { 'FT_STRING' }
 299     | FT
 300     ;
 301
 302 field_base:
 303     #empty { 'BASE_NONE' }
 304     | BASE
 305     ;
 306
 307 field_value_string:
 308     #empty { 'NULL' }
 309     | CODE { $_[1] =~ s/#line.*?\n//ms; $_[1] =~ s/\n//msg; $_[1] =~ s@/\*eocode\*/@@; $_[1] }
 310     ;
 311
 312 field_description:
 313     #empty {'""'}
 314     | SQUOTED { "\"$_[1]\""}
 315     ;
 316
 317 quoted: DQUOTED | SQUOTED ;
 318
 319 %%
 320
 321