Fix ...$ to : $
[obnox/wireshark/wip.git] / 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 # Ethereal - Network traffic analyzer
11 # By Gerald Combs <gerald@ethereal.com>
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, 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