r12205: Support 'TFS' command in conformance files
[samba.git] / source / pidl / lib / Parse / Pidl / Ethereal / Conformance.pm
1 ###################################################
2 # parse an ethereal conformance file
3 # Copyright jelmer@samba.org 2005
4 # released under the GNU GPL
5
6 =pod
7
8 =head1 NAME
9
10 Parse::Pidl::Ethereal::Conformance - Conformance file parser for Ethereal
11
12 =head1 DESCRIPTION
13
14 This module supports parsing Ethereal conformance files (*.cnf).
15
16 =head1 FILE FORMAT
17
18 Pidl needs additional data for ethereal output. This data is read from 
19 so-called conformance files. This section describes the format of these 
20 files.
21
22 Conformance files are simple text files with a single command on each line.
23 Empty lines and lines starting with a '#' character are ignored.
24 Arguments to commands are seperated by spaces.
25
26 The following commands are currently supported:
27
28 =over 4
29
30 =item I<TYPE> name dissector ft_type base_type mask valsstring alignment
31
32 Register new data type with specified name, what dissector function to call 
33 and what properties to give header fields for elements of this type.
34
35 =item I<NOEMIT> type
36
37 Suppress emitting a dissect_type function for the specified type
38
39 =item I<PARAM_VALUE> type param
40
41 Set parameter to specify to dissector function for given type.
42
43 =item I<HF_FIELD> hf title filter ft_type base_type valsstring mask description
44
45 Generate a custom header field with specified properties.
46
47 =item I<HF_RENAME> old_hf_name new_hf_name
48
49 Force the use of new_hf_name when the parser generator was going to 
50 use old_hf_name.
51
52 This can be used in conjunction with HF_FIELD in order to make more then 
53 one element use the same filter name.
54
55 =item I<STRIP_PREFIX> prefix
56
57 Remove the specified prefix from all function names (if present).
58         
59 =item I<PROTOCOL> longname shortname filtername
60
61 Change the short-, long- and filter-name for the current interface in
62 Ethereal.
63
64 =item I<FIELD_DESCRIPTION> field desc
65
66 Change description for the specified header field. `field' is the hf name of the field.
67
68 =item I<IMPORT> dissector code...
69
70 Code to insert when generating the specified dissector. @HF@ and 
71 @PARAM@ will be substituted.
72
73 =item I<TFS> hf_name "true string" "false string"
74
75 Override the text shown when a bitmap boolean value is enabled or disabled.
76
77 =back
78
79 =head1 EXAMPLE
80
81         INFO_KEY OpenKey.Ke
82
83 =cut
84
85 package Parse::Pidl::Ethereal::Conformance;
86
87 require Exporter;
88 use vars qw($VERSION);
89 $VERSION = '0.01';
90
91 @ISA = qw(Exporter);
92 @EXPORT_OK = qw(ReadConformance);
93
94 use strict;
95
96 use Parse::Pidl::Util qw(has_property);
97
98 sub handle_type($$$$$$$$$$)
99 {
100         my ($pos,$data,$name,$dissectorname,$ft_type,$base_type,$mask,$valsstring,$alignment) = @_;
101
102         unless(defined($alignment)) {
103                 print "$pos: error incomplete TYPE command\n";
104                 return;
105         }
106
107         unless ($dissectorname =~ /.*dissect_.*/) {
108                 print "$pos: warning: dissector name does not contain `dissect'\n";
109         }
110
111         unless(valid_ft_type($ft_type)) {
112                 print "$pos: warning: invalid FT_TYPE `$ft_type'\n";
113         }
114
115         unless (valid_base_type($base_type)) {
116                 print "$pos: warning: invalid BASE_TYPE `$base_type'\n";
117         }
118
119         $data->{types}->{$name} = {
120                 NAME => $name,
121                 POS => $pos,
122                 USED => 0,
123                 DISSECTOR_NAME => $dissectorname,
124                 FT_TYPE => $ft_type,
125                 BASE_TYPE => $base_type,
126                 MASK => $mask,
127                 VALSSTRING => $valsstring,
128                 ALIGNMENT => $alignment
129         };
130 }
131
132 sub handle_tfs($$$$$)
133 {
134         my ($pos,$data,$hf,$trues,$falses) = @_;
135
136         unless(defined($falses)) {
137                 print "$pos: error: incomplete TFS command\n";
138                 return;
139         }
140
141         $data->{tfs}->{$hf} = {
142                 TRUE_STRING => $trues,
143                 FALSE_STRING => $falses
144         };
145 }
146
147 sub handle_hf_rename($$$$)
148 {
149         my ($pos,$data,$old,$new) = @_;
150
151         unless(defined($new)) {
152                 print "$pos: error: incomplete HF_RENAME command\n";
153                 return;
154         }
155
156         $data->{hf_renames}->{$old} = {
157                 OLDNAME => $old,
158                 NEWNAME => $new,
159                 POS => $pos,
160                 USED => 0
161         };
162 }
163
164 sub handle_param_value($$$$)
165 {
166         my ($pos,$data,$dissector_name,$value) = @_;
167
168         unless(defined($value)) {
169                 print "$pos: error: incomplete PARAM_VALUE command\n";
170                 return;
171         }
172
173         $data->{dissectorparams}->{$dissector_name} = {
174                 DISSECTOR => $dissector_name,
175                 PARAM => $value,
176                 POS => $pos,
177                 USED => 0
178         };
179 }
180
181 sub valid_base_type($)
182 {
183         my $t = shift;
184         return 0 unless($t =~ /^BASE_.*/);
185         return 1;
186 }
187
188 sub valid_ft_type($)
189 {
190         my $t = shift;
191         return 0 unless($t =~ /^FT_.*/);
192         return 1;
193 }
194
195 sub handle_hf_field($$$$$$$$$$)
196 {
197         my ($pos,$data,$index,$name,$filter,$ft_type,$base_type,$valsstring,$mask,$blurb) = @_;
198
199         unless(defined($blurb)) {
200                 print "$pos: error: incomplete HF_FIELD command\n";
201                 return;
202         }
203
204         unless(valid_ft_type($ft_type)) {
205                 print "$pos: warning: invalid FT_TYPE `$ft_type'\n";
206         }
207
208         unless(valid_base_type($base_type)) {
209                 print "$pos: warning: invalid BASE_TYPE `$base_type'\n";
210         }
211
212         $data->{header_fields}->{$index} = {
213                 INDEX => $index,
214                 POS => $pos,
215                 USED => 0,
216                 NAME => $name,
217                 FILTER => $filter,
218                 FT_TYPE => $ft_type,
219                 BASE_TYPE => $base_type,
220                 VALSSTRING => $valsstring,
221                 MASK => $mask,
222                 BLURB => $blurb
223         };
224 }
225
226 sub handle_strip_prefix($$$)
227 {
228         my ($pos,$data,$x) = @_;
229
230         push (@{$data->{strip_prefixes}}, $x);
231 }
232
233 sub handle_noemit($$$)
234 {
235         my ($pos,$data) = @_;
236         my $type;
237
238         $type = shift if ($#_ == 1);
239
240         if (defined($type)) {
241             $data->{noemit}->{$type} = 1;
242         } else {
243             $data->{noemit_dissector} = 1;
244         }
245 }
246
247 sub handle_protocol($$$$$$)
248 {
249         my ($pos, $data, $name, $longname, $shortname, $filtername) = @_;
250
251         $data->{protocols}->{$name} = {
252                 LONGNAME => $longname,
253                 SHORTNAME => $shortname,
254                 FILTERNAME => $filtername
255         };
256 }
257
258 sub handle_fielddescription($$$$)
259 {
260         my ($pos,$data,$field,$desc) = @_;
261
262         $data->{fielddescription}->{$field} = {
263                 DESCRIPTION => $desc,
264                 POS => $pos,
265                 USED => 0
266         };
267 }
268
269 sub handle_import
270 {
271         my $pos = shift @_;
272         my $data = shift @_;
273         my $dissectorname = shift @_;
274
275         unless(defined($dissectorname)) {
276                 print "$pos: error: no dissectorname specified\n";
277                 return;
278         }
279
280         $data->{imports}->{$dissectorname} = {
281                 NAME => $dissectorname,
282                 DATA => join(' ', @_),
283                 USED => 0,
284                 POS => $pos
285         };
286 }
287
288 my %field_handlers = (
289         TYPE => \&handle_type,
290         NOEMIT => \&handle_noemit, 
291         PARAM_VALUE => \&handle_param_value, 
292         HF_FIELD => \&handle_hf_field, 
293         HF_RENAME => \&handle_hf_rename, 
294         TFS => \&handle_tfs,
295         STRIP_PREFIX => \&handle_strip_prefix,
296         PROTOCOL => \&handle_protocol,
297         FIELD_DESCRIPTION => \&handle_fielddescription,
298         IMPORT => \&handle_import
299 );
300
301 sub ReadConformance($$)
302 {
303         my ($f,$data) = @_;
304
305         $data->{override} = "";
306
307         my $incodeblock = 0;
308
309         open(IN,"<$f") or return undef;
310
311         my $ln = 0;
312
313         foreach (<IN>) {
314                 $ln++;
315                 next if (/^#.*$/);
316                 next if (/^$/);
317
318                 s/[\r\n]//g;
319
320                 if ($_ eq "CODE START") {
321                         $incodeblock = 1;
322                         next;
323                 } elsif ($incodeblock and $_ eq "CODE END") {
324                         $incodeblock = 0;
325                         next;
326                 } elsif ($incodeblock) {
327                         $data->{override}.="$_\n";
328                         next;
329                 }
330
331                 my @fields = /([^ "]+|"[^"]+")/g;
332
333                 my $cmd = $fields[0];
334
335                 shift @fields;
336
337                 if (not defined($field_handlers{$cmd})) {
338                         print "$f:$ln: Warning: Unknown command `$cmd'\n";
339                         next;
340                 }
341                 
342                 $field_handlers{$cmd}("$f:$ln", $data, @fields);
343         }
344
345         close(IN);
346 }
347
348 1;