2ba82e1cc9f2ac3f57054ad19970e2a76d2617af
[obnox/wireshark/wip.git] / tools / tpg / tpg.pl
1 #!/usr/bin/perl
2 #
3 # TPG TVB Parser Generator
4 #
5 # Given a bnf like grammar generate a parser for text based tvbs
6 #
7 # $Id $
8 #
9 # Ethereal - Network traffic analyzer
10 # By Gerald Combs <gerald@ethereal.com>
11 # Copyright 2004 Gerald Combs
12 #
13 # This program is free software; you can redistribute it and/or
14 # modify it under the terms of the GNU General Public License
15 # as published by the Free Software Foundation; either version 2
16 # of the License, or (at your option) any later version.
17 #
18 # This program is distributed in the hope that it will be useful,
19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21 # GNU General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
26
27
28 use TPG;
29 use V2P;
30 use strict;
31
32 my $DEBUG = 0;
33
34 my $b = '';
35
36 while(<>) {
37     $b .= $_;
38 }
39
40 my @T = @{tokenizer()};
41 my $linenum = 1;
42 my %CODE = ();
43 my $codenum = 0;
44
45
46 $b =~ s/\%\{(.*?)\%\}/add_code($1)/egms;
47
48 $b =~ s/#.*?\n/\n/gms;
49
50 my $parser = new TPG();
51 my $last_token = '';
52
53 $parser->YYData->{DATA}=\$linenum;
54
55 my $parser_info = $parser->YYParse(yylex => \&next_token, yyerror => \&error_sub);#,yydebug => 0x1f);
56
57 die "failed parsing" unless defined $parser_info;
58
59 if ($DEBUG > 3) {
60     warn "\n=========================== parser_info ===========================\n";
61     warn V2P::var2perl( $parser_info );
62     warn "\n=========================== ======== ===========================\n" ;
63 }
64
65 my $proto_name =  ${$parser_info}{proto_name};
66 my $upper_name = $proto_name;
67 $upper_name =~ tr/a-z/A-Z/;
68 my $global_struct = "$proto_name\_tpg_data";
69
70 warn "parser_data_type: ${$parser_info}{pdata}\n" if $DEBUG;
71
72 my %exports = %{${$parser_info}{export}};
73
74 my $field_num = 0;
75
76 my $tt_type = ${$parser_info}{pdata};
77
78 $tt_type =~ s/\n#line.*?\n//ms;
79 $tt_type =~ s@\n/\*eocode\*/\n@@ms;
80
81 my $init_function_hfs = "\n/* initialize hfids */\n";
82 my $init_function_etts = "\n/* initialize etts */\n"; 
83 my $init_function_wanted_decl = "\n/* declare private wanted elements */\n";
84 my $init_function_wanted = "\n/* initialize wanted elements  */\n";
85 my $callback_definitions = "\n/* callback definitions */\n";
86 my $datastruct_ett = "\n/* etts */\n";
87 my $datastruct_hf = "\n/* hfis */\n";
88 my $datastruct_wanted = "\n/* wanted elems */\n";
89
90 my $hfarr = "/* field array */\n#define HF_$upper_name\_PARSER \\\n";
91 my $ett_arr = "#define ETT_$upper_name\_PARSER \\\n";
92
93 for my $fieldname (keys %{${$parser_info}{fields}}) {
94     my $f = ${${$parser_info}{fields}}{$fieldname};
95     
96     my $vs = defined ${$f}{vs} ? 'VALS(' . ${$f}{vs}. ')' : "NULL" ;
97            
98     ${$f}{vname} = "$global_struct.hf_${$f}{name}" unless defined ${$f}{vname};
99     ${$f}{base} = 'BASE_NONE' unless defined ${$f}{base};
100     ${$f}{desc} = '""' unless defined ${$f}{desc};
101     $datastruct_hf .= "\tint hf_${$f}{name};\n";
102     $init_function_hfs .= "\t${$f}{vname} = -1;\n";
103     $hfarr .= "{ &${$f}{vname}, { ${$f}{pname}, ${$f}{abbr}, ${$f}{type}, ${$f}{base}, $vs, 0x0, ${$f}{desc}, HFILL }},\\\n";
104                                                
105 # warn "\nFIELD:$fieldname " . V2P::var2perl($f);
106
107 }
108
109 $hfarr =~ s/,\\\n$/\n/msi;
110
111
112 for my $rulename ( keys %{${$parser_info}{rules}} ) {
113     my $r = ${${$parser_info}{rules}}{$rulename};
114
115 # warn "\nRULE BEFORE:$rulename " . V2P::var2perl($r);
116
117     make_rule($r,0);
118
119 # warn "\nRULE AFTER:$rulename " . V2P::var2perl($r);
120
121 }
122
123 $ett_arr =~ s/,\\\n$//ms;
124
125 for my $rulename (sort keys %{${$parser_info}{rules}} ) {
126     my $r = ${${$parser_info}{rules}}{$rulename};
127     
128     
129     $callback_definitions .= "\n\n/* callback definitions for rule $rulename */\n";
130     $callback_definitions .= ${$r}{before_cb_code} . "\n";
131     $callback_definitions .= ${$r}{after_cb_def} . "\n";
132     $init_function_wanted .= ${$r}{definition_code} . "\n\n";
133 }
134
135
136
137
138 my $h_file = <<"__H_HEAD";
139 /*
140  $proto_name-parser.h
141  automagically generated by $0 from $ARGV
142  DO NOT MODIFY.
143  */
144
145 #ifndef _H_$upper_name\_PARSER
146 #define _H_$upper_name\_PARSER
147 #include <epan/tpg.h>
148
149
150 /* begin %header_head */
151 ${$parser_info}{header_head}
152 /* end %header_head */
153
154 extern void tpg_${proto_name}_init(void);
155
156 struct _${proto_name}_tpg_data_t {
157 $datastruct_ett
158 $datastruct_hf
159 $datastruct_wanted
160 };
161
162
163 extern struct _${global_struct}_t  $global_struct;
164
165 $hfarr
166
167
168 $ett_arr
169
170
171 #endif
172 __H_HEAD
173
174
175 my $c_file = <<"__C_FILE";
176 /*
177  $proto_name-parser.c
178  automagically generated by $0 from $ARGV
179  DO NOT MODIFY.
180  */
181
182 #ifdef HAVE_CONFIG_H
183 #include "config.h"
184 #endif
185
186 #include "$proto_name-parser.h" 
187
188 /* begin %head */
189 ${$parser_info}{head}
190 /* end %head */
191
192 /* hfids container */
193
194 struct _${proto_name}_tpg_data_t  $global_struct;
195
196
197 $callback_definitions
198 /* end callback definitions */
199
200 void tpg_$proto_name\_init(void) {
201     $init_function_wanted_decl
202     $init_function_hfs
203     $init_function_etts 
204     $init_function_wanted
205 }
206
207 /* begin %tail */
208 ${$parser_info}{tail}
209 /* end %tail */
210
211 __C_FILE
212
213 my $c_buf = '';
214 my $c_line = 3;
215 while($c_file =~ s/^([^\n]*)\n//ms) {
216     my $line = $1;
217
218     $c_line += 2 if $line =~ s@/\*eocode\*/@\n#line $c_line \"$proto_name-parser.c\"\n@;
219     $c_buf .= $line . "\n";
220     $c_line++;
221 }
222
223 my $h_buf = '';
224 my $h_line = 3;
225 while($h_file =~ s/^([^\n]*)\n//ms) {
226       my $line = $1;
227       
228       $h_line += 2 if $line =~ s@/\*eocode\*/@\n#line $h_line \"$proto_name-parser.h\"\n@;
229       $h_buf .= $line . "\n";
230       $h_line++;
231 }
232
233
234 open C, "> $proto_name-parser.c";
235 open H, "> $proto_name-parser.h";
236 print C $c_buf;
237 print H $h_buf;
238 close C;
239 close H;
240
241 exit;
242
243 sub make_rule {
244     my $r = shift;
245     my $dd = shift;
246     
247     my $rule_id = "0";    
248     my $code = \${$r}{definition_code};
249     my $indent;
250     
251
252     
253     for (0..$dd) {
254         $indent .= "\t";
255     }
256     
257     my $indent_more = $indent . "\t";
258     
259     my $min;
260     my $max;
261
262     if (exists ${$r}{min}) {
263         $min = ${$r}{min};
264     } else {
265         $min = ${$r}{min} = 1;
266     }
267
268     if (exists ${$r}{max}) {
269         $max = ${$r}{max};
270     } else {
271         $max = ${$r}{max} = 1;
272     }
273     
274     if ($dd == 0) {
275         my %VARS = ();
276     
277         if ( exists $exports{${$r}{name}}) {
278             ${$code} = "\t$global_struct.";
279             $datastruct_wanted .= "\ttvbparse_wanted_t* wanted_$proto_name\_${$r}{name};\n"
280         } else {
281             ${$code} = "\t";
282             $init_function_wanted_decl .=  "\tstatic tvbparse_wanted_t* wanted_$proto_name\_${$r}{name};\n"
283         }
284         
285         ${$code} .= "wanted_$proto_name\_${$r}{name} = ";
286         
287         $VARS{"TT_DATA"} = "TPG_DATA(tpg,$tt_type)" if defined $tt_type;
288             
289             make_vars(\%VARS,$r,"elem");
290         
291 #        warn "VARS::${$r}{name} " . V2P::var2perl(\%VARS);
292                 
293         
294         my $tree_code_head = "";
295         my $tree_code_body = "";
296         my $tree_code_after = "";
297         
298         make_tree_code($r,\$tree_code_head,\$tree_code_body,\$tree_code_after,"elem");
299         
300         if (length $tree_code_body ) {
301             my $cb_name = ${$r}{before_cb_name} = "${$r}{name}\_before_cb";
302             ${$r}{before_cb_code} = "static void $cb_name(void* tpg _U_, const void* wd _U_, struct _tvbparse_elem_t* elem _U_) {\n\tproto_item* pi;\n$tree_code_head\n$tree_code_body\n}";
303             ${$r}{code} .= $tree_code_after;
304         }
305         
306         my $tree_code = \${$r}{tree_code};
307                 
308
309         if (${$r}{code}) {
310             my $after = ${$r}{code};
311             
312             ${$r}{after_cb_name} = "${$r}{name}_after\_cb";
313             
314             ${$r}{after_cb_def} = "static void ${$r}{after_cb_name}(void* tpg _U_, const void* wd _U_, struct _tvbparse_elem_t* elem _U_) {\n";
315             
316             for (keys %VARS) {
317                 $after =~ s/($_)([A-Z]?)/$VARS{$1}$2/msg;
318             }
319                         
320             ${$r}{after_cb_def} .= $after . "\n}\n";
321         }
322         
323     }
324     
325     my $after_fn = ${$r}{after_cb_name} ? ${$r}{after_cb_name} : "NULL";
326     my $before_fn = ${$r}{before_cb_name} ? ${$r}{before_cb_name} : "NULL";
327
328     my $wd_data = "NULL";
329
330     if (exists ${$r}{field}) {
331         my $field = ${${$parser_info}{fields}}{${$r}{field}};
332         die "field ${$r}{field} does not exists\n" . V2P::var2perl(${$parser_info}{fields}) unless defined $field;
333         
334         my $ett = exists ${$r}{ett} ? ${$r}{ett} : "NULL";
335         
336         my $wd_data = 'tpg_wd(${$field}{vname},$ett,NULL)';
337         
338     }
339     
340     my $control = ${$r}{control};
341     
342     if (${$r}{type} eq 'chars' || ${$r}{type} eq 'not_chars') {
343         if (! ($min == 1 && $max == 1) ) {
344             ${$code} .= $indent . "tvbparse_${$r}{type}($rule_id,$min,$max,$control,$wd_data,$before_fn,$after_fn)"
345         } else {
346             my $rn = ${$r}{type};
347             $rn =~ s/.$//;
348                 ${$code} .= $indent . "tvbparse_$rn($rule_id,$control,$wd_data,$before_fn,$after_fn)"
349         }
350     } else {
351         if (! ($min == 1 && $max == 1))  {
352             ${$code} .= $indent . "tvbparse_some(0,$min,$max,NULL,NULL,NULL,\n";
353         }
354             
355         if (${$r}{type} eq 'string') {
356             
357             ${$code} .= $indent . "tvbparse_string($rule_id,$control,$wd_data,$before_fn,$after_fn)";
358             
359         } elsif (${$r}{type} eq 'caseless') {
360             
361             ${$code} .= $indent . "tvbparse_casestring($rule_id,$control,$wd_data,$before_fn,$after_fn)";
362             
363         } elsif (${$r}{type} eq 'named') {
364             if(exists $exports{$control}) {
365                 ${$code} .= $indent . "tvbparse_handle(&$global_struct.wanted_$proto_name\_$control)";
366             } else {
367                 ${$code} .= $indent . "tvbparse_handle(&wanted_$proto_name\_$control)";                
368             }
369         } elsif (${$r}{type} eq 'seq') {
370             
371             ${$code} .= $indent . "tvbparse_set_seq($rule_id,$wd_data,$before_fn,$after_fn,\n";
372             
373             for ( @{${$r}{subrules}}) {
374                 $dd++;
375                 ${$code} .= $indent_more . make_rule($_,$dd) . ",\n";
376                 $dd--;
377             }
378             
379             ${$code} .= $indent . " NULL)"
380                 
381         } elsif (${$r}{type} eq 'choice') {
382             
383             ${$code} .= $indent . "tvbparse_set_oneof($rule_id,$wd_data,$before_fn,$after_fn,\n";
384             
385             for (@{${$r}{subrules}}) {
386                 $dd++;
387                 ${$code} .= $indent_more . make_rule($_,$dd) . ",\n";
388                 $dd--;
389             }
390             
391             ${$code} .= $indent . " NULL)"
392                 
393         } elsif (${$r}{type} eq 'until') {
394             
395             ${$r}{inc_mode} =  'TP_UNTIL_SPEND' unless defined ${$r}{inc_mode};
396             
397             ${$code} .= $indent ."tvbparse_until(0,$wd_data,$before_fn,$after_fn,\n";
398             $dd++;
399             ${$code} .= $indent_more . make_rule(${$r}{subrule},$dd) . ", ${$r}{inc_mode})";
400             $dd--;
401         }
402         
403         if (! ($min == 1 && $max == 1) ) {
404             ${$code} .= ")";
405         }    
406     }
407
408     if ($dd == 0) {
409         ${$code} .= ";\n";
410 #        warn "RULE::${$r}{name} " . V2P::var2perl($r);
411     }
412
413     ${$code};
414 }
415
416
417 sub make_vars {
418     my $v = shift;
419     my $r = shift;
420     my $base = shift;
421
422     if (exists ${$r}{var}) {
423         ${$v}{${$r}{var}} = $base;
424     }
425
426     if (! ( ${$r}{type} =~ /chars$/ ) && ! (${$r}{min} == 1 && ${$r}{max} == 1) ) {
427         $base .= "->sub";
428     }
429     
430     if (exists ${$r}{subrule} ) {
431         make_vars($v,${$r}{subrule},"$base->sub");
432     }
433     
434     
435     if (exists ${$r}{subrules} ) {
436         my $sub_base = "$base->sub";
437         for my $rule (@{${$r}{subrules}}) {
438             make_vars($v,$rule,$sub_base);
439             $sub_base .= "->next";
440         }
441     }
442 }
443
444 sub make_tree_code {
445     my $r = shift;
446     my $head = shift;
447     my $body = shift;
448     my $after = shift;
449     my $elem = shift;    
450     
451     if (exists ${$r}{field}) {
452         my $fieldname = ${$r}{field};
453         my $f = ${${$parser_info}{fields}}{$fieldname};
454
455         my $root_var = '';
456         
457         if (exists ${$r}{tree}) {
458             $root_var = "root_$fieldname";
459             ${$head} .= "\tproto_item* $root_var;\n\n";
460             ${$body} .= "\t$root_var = ";
461             $ett_arr .= "\t&$global_struct.ett_$fieldname,\\\n";
462             $datastruct_ett .= "\tguint ett_$fieldname; \n";
463             $init_function_etts .= "\t$global_struct.ett_$fieldname = -1;\n";
464             ${$r}{ett} = "$global_struct.ett_$fieldname";
465         } else {
466             ${$body} .= "\t";
467         }
468
469         
470         if (${$f}{type} eq 'FT_STRING') {
471             ${$body} .= "\tpi = TPG_ADD_STRING(tpg,${$f}{vname},$elem);\n";
472         } elsif (${$f}{type} =~ /^FT_UINT/) {
473             my $fieldvar = "tpg_uint_$fieldname";
474             ${$head} .= "\tguint $fieldvar = TPG_UINT($elem);\n";
475             ${$body} .= "\tpi = TPG_ADD_UINT(tpg,${$f}{vname},$elem,$fieldvar);\n";
476         } elsif (${$f}{type} =~ /^FT_INT/) {
477             my $fieldvar = "tpg_int_$fieldname";
478             ${$head} .= "\tgint $fieldvar = TPG_INT($elem);\n";
479             ${$body} .= "\tpi = TPG_ADD_INT(tpg,${$f}{vname},$elem,$fieldvar);\n";
480         } elsif (${$f}{type} eq 'FT_IPV4') {
481             my $fieldvar = "tpg_ipv4_$fieldname";
482             ${$head} .= "\tguint32 $fieldvar = TPG_IPV4($elem);\n";
483             ${$body} .= "\tpi = TPG_ADD_IPV4(tpg,${$f}{vname},$elem,$fieldvar);\n";
484         } elsif (${$f}{type} eq 'FT_IPV6') {
485             my $fieldvar = "tpg_ipv6_$fieldname";
486             ${$head} .= "\tguint8* $fieldvar = TPG_IPV6($elem);\n";
487             ${$body} .= "\tpi = TPG_ADD_IPV6(tpg,${$f}{vname},$elem,$fieldvar);\n";
488         } else {
489             ${$body} .= "\tpi = TPG_ADD_TEXT(tpg,$elem);\n";
490         }
491         
492         if (exists ${$r}{plain_text}) {
493             ${$body} .= "\tTPG_SET_TEXT(pi,$elem);\n"
494         }
495         
496         if (exists ${$r}{tree}) {
497             ${$body} .=  "\tTPG_PUSH(tpg,$root_var,${$r}{ett});\n";
498         }
499     }
500     
501     
502     if (! ( ${$r}{type} =~ /chars$/ ) && ! (${$r}{min} == 1 && ${$r}{max} == 1) ) {
503         $elem .= "->sub";
504     }
505     
506         
507     if (exists ${$r}{subrule} ) {
508         make_tree_code(${$r}{subrule},$head,$body,$after,"$elem->sub");
509     }
510     
511     if (exists ${$r}{subrules} ) {
512         my $sub_base = "$elem->sub";            
513         for my $rule (@{${$r}{subrules}}) {
514             make_tree_code($rule,$head,$body,$after,$sub_base);
515             $sub_base .= "->next";
516         }
517     }
518
519     if (exists ${$r}{field}) {
520         if (exists ${$r}{tree}) {
521             ${$after} .=  "\n\t/* tree after code */\n\tTPG_POP(tpg);\n";
522         }
523         
524     }
525 }
526 sub tokenizer {
527     [
528         [ '(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] ] } ],
529         [ '(BASE_(NONE|DEC|HEX))', sub { [ 'BASE', $_[0] ] }],
530         [ '([a-z]+\\.[a-z0-9_\\.]*[a-z])', sub { [ 'DOTEDNAME', $_[0] ] }], 
531         [ '([a-z][a-z0-9_]*)', sub { [ 'LOWERCASE', $_[0] ] }], 
532         [ '([A-Z][A-Z0-9_]*)', sub { [ 'UPPERCASE', $_[0] ] }],
533         [ '([0-9]+|0x[0-9a-fA-F]+)', sub { [ 'NUMBER', $_[0] ] }],
534         [ '(\%\%[0-9]+\%\%)', \&c_code ],
535         [ "'((\\\\'|[^'])*)'", sub { [ 'SQUOTED', $_[0] ] }], 
536         [ '\[\^((\\\\\\]|[^\\]])*)\]', sub { [ 'NOTCHARS', $_[0] ] }], 
537         [ '\[((\\\\\\]|[^\\]])*)\]', sub { [ 'CHARS', $_[0] ] }], 
538         [ '"((\\\\"|[^"])*)"', sub { [ 'DQUOTED', $_[0] ] }], 
539         [ '(\%[a-z_]+|\%[A-Z][A-Z-]*|\&|\=|\.\.\.|\.|\:|\;|\(|\)|\{|\}|\+|\*|\?|\<|\>|\|)', sub { [  $_[0], $_[0] ] }], 
540     ]
541 }
542
543 sub next_token {
544     
545     if ($b =~ s/^([\r\n\s]+)// )  {
546         my $l = $1;
547         while ( $l =~ s/\n//ms ) {
548                 $linenum++;
549         }
550     }
551
552     return (undef,'') unless length $b;
553
554     for (@T) {
555         my ($re,$ac) = @{$_};
556         
557         if( $b =~ s/^$re//ms) {
558             $a = &{$ac}($1);
559             $last_token = ${$a}[1];
560 #warn "=($linenum)=> ${$a}[0]   ${$a}[1]\n";
561             return (${$a}[0],${$a}[1]);
562         }
563     }
564
565     die "unrecognized token at line $linenum after '$last_token'";
566 }
567
568 sub error_sub {
569     my @a = $_[0]->YYExpect;
570     my $t = $_[0]->YYCurtok;
571     
572     die "error at $linenum after '$last_token' expecting (@a)";
573 }
574
575
576 sub add_code {
577     my $k = "%%$codenum%%";
578     $CODE{$k} = $_[0];
579     $codenum++;
580     return $k;
581 }
582
583 sub c_code {
584     my $k = $_[0];
585     my $t = $CODE{$k};
586     my $start = $linenum;
587     $linenum++ while ( $t =~ s/\n// );
588     return [ 'CODE', "\n#line $start \"$ARGV\"\n$CODE{$k}\n/*eocode*/\n"];
589 }
590
591
592 __END__
593
594 do {
595     ($type,$value) = @{next_token()};
596     last if not defined $type;
597 } while(1);
598