1#!/usr/bin/env perl
2# genxdrstub.pl --- Generate C header file which used by packet-libvirt.[ch]
3#
4# Copyright (C) 2013 Yuto KAWAMURA(kawamuray) <kawamuray.dadada@gmail.com>
5#
6# This library is free software; you can redistribute it and/or
7# modify it under the terms of the GNU Lesser General Public
8# License as published by the Free Software Foundation; either
9# version 2.1 of the License, or (at your option) any later version.
10#
11# This library is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14# Lesser General Public License for more details.
15#
16# You should have received a copy of the GNU Lesser General Public
17# License along with this library.  If not, see
18# <http://www.gnu.org/licenses/>.
19#
20#
21# For XDR syntax, see https://tools.ietf.org/html/rfc4506#section-6.3
22# This script does not strictly check syntax of xdr protocol specification.
23# Make sure the specification files you have are correctly compilable with rpcgen(1).
24# If something fails with this script in spite of you had confirmed that the `make' with libvirt was succeed,
25# please report your error output to kawamuray<kawamuray.dadada@gmail.com>.
26use strict;
27use warnings;
28use File::Spec;
29
30my $DEBUG = 0; # Enable if you want to see debug output
31sub dbg { print STDERR @_ if $DEBUG }
32
33die "ERROR: No arguments" unless @ARGV >= 3;
34
35my $libvirt_version = shift;
36my $builddir = shift;
37
38# Context object referenced from entire this script
39my $c = Context->new;
40
41for my $proto (@ARGV) {
42    # We need to do this heuristic parsing to determine
43    # variable name of enum <protocol>_procedures.
44    my ($name) = $proto =~ m{(?:vir)?([^/]+?)_?protocol\.x$};
45    unless ($name) {
46        warn "WARNING: Cannot extract protocol name from $proto, skipping.";
47        next;
48    }
49    $c->add_to_set(progs => $name);
50
51    my $source;
52    {
53        open my $fh, '<', $proto
54            or die "Cannot open $proto: $!";
55        local $/;
56        $source = <$fh>;
57        close $fh;
58    }
59
60    $c->add_header_file($name, sub {
61        dbg "*** Start parsing $proto\n";
62
63        $c->print("extern int hf_libvirt_unknown;\n");
64
65        my @lexs = Lexicalizer->parse($source);
66        for my $lex (@lexs) {
67            next if $lex->ident eq "enum $name\_procedure";
68
69            if ($lex->isa('Sym::Variable')) {
70                $c->print(sprintf "#define %s (%s)\n", $lex->ident, $lex->value);
71            } elsif ($lex->isa('Sym::Type')) {
72                # Top level of name path is type identification of itself
73                $lex->define_dissector($lex->idstrip);
74            } else {
75                die "Unknown lexical appeared: $lex";
76            }
77        }
78
79        my $procs = $c->symbol("enum $name\_procedure")
80            or die "Cannot find procedures enumeration: enum $name\_procedure";
81        # Procedure numbers are expected to be containing gaps, but needed to be sorted in ascending order.
82        my @procedures = sort { $a->value <=> $b->value } @{ $procs->members };
83        my @dissectors = map {
84            (my $ident = lc($_->ident)) =~ s/^$name\_proc/$name/;
85            +{
86                value => $_->value,
87                map { $_ => $c->rinc($c->symbols->{"$ident\_$_"} ? "dissect_xdr_$ident\_$_" : 'NULL') }
88                    qw{ args ret msg }
89            };
90        } @procedures;
91        $c->print(PT->render('code.dissectorlist', {
92            name       => $name,
93            dissectors => \@dissectors,
94        }));
95        $c->print(PT->render('code.procedure_strings', {
96            name       => $name,
97            procedures => \@procedures,
98        }));
99    });
100}
101
102$c->add_header_file('protocol', sub {
103    for my $prog (@{ $c->get_set('progs') }) {
104        $c->print("#include \"libvirt/$prog.h\"\n");
105    }
106
107    # hf_ variables set
108    $c->print(PT->render('macro.hfvars', {
109        programs => $c->get_set('progs'),
110        hfvars   => [ grep $_->{segment}{refcnt}, @{ $c->get_set('hfvars') } ],
111    }));
112    # ett_ variables set
113    $c->print(PT->render('macro.ettvars', {
114        ettvars => [ map $_->{sym}, grep $_->{refcnt}, @{ $c->get_set('ettvars') } ],
115    }));
116    # value_string program_strings
117    $c->print(PT->render('code.program_strings', { programs => $c->get_set('progs') }));
118    $c->print("static int hf_$_\_procedure = -1;\n") for @{ $c->get_set('progs') };
119    $c->print(PT->render('code.program_data', { programs => $c->get_set('progs') }));
120});
121
122$c->finalize; exit 0;
123
124# Used for handy class building
125sub register_profile {
126    my %prof = @_;
127    my $caller = caller;
128    no strict 'refs';
129    if ($prof{isa}) {
130        push @{ "$caller\::ISA" }, $prof{isa};
131    }
132    while (my ($name, $v) = each %{ $prof{consts} || {} }) {
133        *{ "$caller\::$name" } = sub { $v };
134    }
135    for my $attr (@{ $prof{attrs} || [] }) {
136        *{ "$caller\::$attr" } = sub {
137            if (@_ > 1) { $_[0]->{$attr} = $_[1]; $_[0] }
138            else        { $_[0]->{$attr} }
139        };
140    }
141    while (my ($klass, $meths) = each %{ $prof{roles} || {} }) {
142        for my $meth (@$meths) {
143            # This assignment cannot be like: *{ "$caller\::$meth" } = \&{ "$klass\::$meth" }.
144            # "$klass\::$meth" maybe not defined yet(e.g. Methods defined by PT)
145            *{ "$caller\::$meth" } = sub { goto &{ "$klass\::$meth" } };
146        }
147    }
148}
149
150# Minimal template engine for code generating
151package PT; # is PicoTemplate
152our $Token;
153our %Templates;
154INIT { # Load templates from __END__ section
155    $Token = join '', map { chr(65 + rand(26)) } 1..64;
156    my $current;
157    while (my $l = <main::DATA>) {
158        if ($l =~ /^\@\@\s*(.+)/) {
159            $current = \($Templates{$1} = '');
160        } else {
161            $$current .= $l if $current;
162        }
163    }
164    for my $name (keys %Templates) {
165        $Templates{$name} = __PACKAGE__->compile($Templates{$name});
166        if ($name =~ /^([\w:]+)#([^#]+)$/) {
167            no strict 'refs';
168            my $meth = "$1\::$2";
169            unless (defined &$meth) {
170                *$meth = $Templates{$name};
171            }
172        }
173    }
174}
175sub compile {
176    my ($class, $tmpl) = @_;
177
178    $tmpl =~ s{<%(=)?(.*?)%>\n?|((?:(?!<%).)+)}{
179        $2 ? $1 ? "\$$Token .= qq{\@{[do{ $2 }]}};" : $2
180           : "\$$Token .= substr <<$Token, 0, -1;\n".quotemeta($3)."\n$Token\n";
181    }gse;
182    eval "sub { my \$$Token = ''; $tmpl \$$Token }"
183        or die "ERROR: Cannot compile template: $@";
184}
185sub render {
186    my ($class, $name, $vars, @args) = @_;
187    local $_ = $vars || {};
188    my $renderer = $Templates{$name}
189        or die "No such template: $name";
190    $renderer->(@args);
191}
192# / package PT
193
194package Sym;
195BEGIN{::register_profile(
196    attrs => [qw[ ident ]],
197)}
198
199sub new {
200    my ($class, %args) = @_;
201
202    CORE::bless \%args, $class;
203}
204
205sub bless {
206    my ($self, $klass) = @_;
207
208    CORE::bless $self, "Sym::$klass"
209        if ref($self) ne "Sym::$klass";
210    $self;
211}
212
213sub idstrip {
214    my $ident = shift()->ident;
215    $ident =~ s/^(?:struct|enum|union)\s+// if $ident;
216    $ident;
217}
218# / package Sym
219
220package Sym::Type;
221BEGIN{::register_profile(
222    isa   => 'Sym',
223    attrs => [qw[ alias ]],
224)}
225
226sub is_primitive { !(shift)->alias }
227
228sub dealias {
229    my ($self) = @_;
230
231    $self->is_primitive ? $self : $self->alias->dealias;
232}
233
234sub xdr_type {
235    my ($self) = @_;
236
237    if (!$self->is_primitive) {
238        return $self->dealias->xdr_type;
239    }
240
241    my $type = ref $self;
242    if ($type eq __PACKAGE__) {
243        $type = $self->ident;
244    } else {
245        $type =~ s/^.*:://;
246    }
247    uc($type);
248}
249
250sub render_caller {
251    my ($self, $hfid) = @_;
252    my $name = $c->rinc( 'dissect_xdr_'.($self->idstrip || lc($self->xdr_type)) );
253    "$name(tvb, tree, xdrs, hf)";
254}
255
256sub ft_type {
257    my ($self) = @_;
258    return $self->dealias->ft_type unless $self->is_primitive;
259    my $xt = $self->xdr_type;
260    +{
261        INT     => 'INT32',
262        U_INT   => 'UINT32',
263        SHORT   => 'INT16',
264        U_SHORT => 'UINT16',
265        CHAR    => 'INT8',
266        U_CHAR  => 'UINT8',
267        HYPER   => 'INT64',
268        U_HYPER => 'UINT64',
269        BOOL    => 'BOOLEAN',
270    }->{$xt} || $xt;
271}
272
273sub hf_base {
274    my ($self) = @_;
275    $self->is_primitive
276        ? $self->ft_type =~ /INT/ ? 'DEC' : 'NONE'
277        : $self->dealias->hf_base;
278}
279
280sub define_dissector {
281    my ($self, @path) = @_;
282    $self->declare_hfvar(@path);
283    my $path = join '__', @path;
284    my $code = $self->render_dissector($path);
285    $c->print({ sym => "dissect_xdr_$path", body => $code })
286        if $code;
287}
288
289sub declare_hfvar {
290    my ($self, @path) = @_;
291    my $path = join '__', @path;
292    $c->add_to_set(hfvars => {
293        segment => $c->print({
294            sym  => "hf_$path",
295            body => "static int hf_$path = -1;\n"
296        }),
297        name    => $path[-1],
298        abbrev  => join('.', @path),
299        ft_type => $self->ft_type,
300        hf_base => $self->hf_base,
301    });
302}
303# / package Sym
304
305package Sym::Type::HasAnonTypes; # Types which possibly have anonymous subtypes
306BEGIN{::register_profile(
307    isa => 'Sym::Type',
308)}
309
310sub declare_anontypes {
311    my ($self, @path) = @_;
312
313    for my $m (@{ $self->members }) {
314        unless (defined $m->type->ident) {
315            $m->type->ident(join '__', @path, $m->ident);
316        }
317        $m->type->define_dissector(@path, $m->ident);
318    }
319}
320
321sub define_dissector {
322    my ($self, @path) = @_;
323
324    $self->declare_anontypes(@path);
325    $self->SUPER::define_dissector(@path);
326}
327
328package Sym::Type::HasSubtree; # Types which should be declare ett variables
329
330sub declare_ettvar {
331    my ($self) = @_;
332    my $ettvar = 'ett_'.$self->idstrip;
333    $c->add_to_set(ettvars => $c->print({
334        sym  => $ettvar,
335        body => "static gint $ettvar = -1;\n",
336    }));
337}
338
339package Sym::Type::HasReference; # Types which references subtype
340BEGIN{::register_profile(
341    attrs  => [qw[ reftype ]],
342    consts => { ft_type => 'NONE' },
343)}
344
345sub render_caller {
346    my ($self) = @_;
347    my ($klass) = ref($self) =~ /([^:]+)$/;
348    sprintf '%s(tvb, tree, xdrs, hf, %s)',
349        $c->rinc('dissect_xdr_'.lc($klass)),
350        $c->rinc('dissect_xdr_'.$self->reftype->idstrip);
351}
352
353package Sym::Type::HasLength; # Types which has length attribute
354BEGIN{::register_profile(
355    attrs  => [qw[ length ]],
356    consts => { ft_type => 'NONE' },
357)}
358
359sub render_caller {
360    my ($self, $hfid) = @_;
361    my ($klass) = ref($self) =~ /([^:]+)$/;
362    sprintf '%s(tvb, tree, xdrs, hf, %s)',
363        $c->rinc('dissect_xdr_'.lc($klass)), $self->length || '~0';
364}
365
366package Sym::Type::Struct;
367BEGIN{::register_profile(
368    isa    => 'Sym::Type',
369    attrs  => [qw[ members ]],
370    consts => { ft_type => 'NONE' },
371    roles  => {
372        'Sym::Type::HasAnonTypes' => [qw[ declare_anontypes ]],
373        'Sym::Type::HasSubtree'   => [qw[ declare_ettvar ]],
374    },
375)}
376
377sub define_dissector {
378    my ($self, @path) = @_;
379    $self->declare_anontypes(@path);
380    $self->declare_ettvar;
381    $self->SUPER::define_dissector(@path);
382}
383
384package Sym::Type::Enum;
385BEGIN{::register_profile(
386    isa    => 'Sym::Type',
387    attrs  => [qw[ members ]],
388    consts => { ft_type => 'UINT32' },
389)}
390package Sym::Type::Union;
391BEGIN{::register_profile(
392    isa    => 'Sym::Type',
393    attrs  => [qw[ decl case_specs ]],
394    consts => { ft_type => 'NONE' },
395    roles  => {
396        'Sym::Type::HasAnonTypes' => [qw[ declare_anontypes define_dissector ]],
397    },
398)}
399sub members {
400    my ($self) = @_;
401    [ map { $_->[1] } @{ $self->case_specs } ];
402}
403
404package Sym::Type::String;
405BEGIN{::register_profile(
406    isa    => 'Sym::Type',
407    consts => { ft_type => 'STRING' },
408    roles  => {
409        'Sym::Type::HasLength' => [qw[ length render_caller ]],
410    },
411)}
412package Sym::Type::Opaque;
413BEGIN{::register_profile(
414    isa    => 'Sym::Type',
415    consts => { ft_type => 'BYTES' },
416    roles  => {
417        'Sym::Type::HasLength' => [qw[ length render_caller ]],
418    },
419)}
420package Sym::Type::Bytes;
421BEGIN{::register_profile(
422    isa    => 'Sym::Type',
423    consts => { ft_type => 'BYTES' },
424    roles  => {
425        'Sym::Type::HasLength' => [qw[ length render_caller ]],
426    },
427)}
428package Sym::Type::Pointer;
429BEGIN{::register_profile(
430    isa    => 'Sym::Type',
431    roles  => {
432        'Sym::Type::HasReference' => [qw[ reftype render_caller ]],
433    },
434)}
435sub ft_type { (shift)->reftype->ft_type }
436
437package Sym::Type::Array; # a.k.a Variable-Length Array
438BEGIN{::register_profile(
439    isa   => 'Sym::Type',
440    roles => {
441        'Sym::Type::HasLength'    => [qw[ length ft_type ]],
442        'Sym::Type::HasReference' => [qw[ reftype ]],
443        'Sym::Type::HasSubtree'   => [qw[ declare_ettvar ]],
444    },
445)}
446
447sub render_caller {
448    my ($self, $hfid) = @_;
449    my ($pname) = reverse split /__/, $hfid;
450    sprintf 'dissect_xdr_array(tvb, tree, xdrs, hf, %s, %s, "%s", %s, %s)',
451        $c->rinc('ett_'.$self->idstrip),
452        $c->rinc("hf_$hfid\__$pname"),
453        $self->reftype->idstrip,
454        $self->length || '~0',
455        $c->rinc('dissect_xdr_'.$self->reftype->idstrip);
456}
457
458sub define_dissector {
459    my ($self, @path) = @_;
460    $self->reftype->declare_hfvar(@path, $path[-1]);
461    $self->declare_ettvar;
462    $self->SUPER::define_dissector(@path);
463}
464
465package Sym::Type::Vector; # a.k.a Fixed-Length Array
466BEGIN{::register_profile(
467    isa   => 'Sym::Type',
468    roles => {
469        'Sym::Type::HasLength'    => [qw[ length ft_type ]],
470        'Sym::Type::HasReference' => [qw[ reftype ]],
471        'Sym::Type::Array'        => [qw[ define_dissector ]],
472        'Sym::Type::HasSubtree'   => [qw[ declare_ettvar ]],
473    },
474)}
475
476sub render_caller {
477    my ($self, $hfid) = @_;
478    my ($pname) = reverse split /__/, $hfid;
479    sprintf 'dissect_xdr_vector(tvb, tree, xdrs, hf, %s, %s, "%s", %s, %s)',
480        $c->rinc('ett_'.$self->idstrip),
481        $c->rinc("hf_$hfid\__$pname"),
482        $self->reftype->idstrip,
483        $self->length || '~0',
484        $c->rinc('dissect_xdr_'.$self->reftype->idstrip);
485}
486
487package Sym::Variable;
488BEGIN{::register_profile(
489    isa   => 'Sym',
490    attrs => [qw[ type value ]],
491)}
492
493package Context;
494BEGIN{::register_profile(
495    attrs => [qw[ symbols ]],
496)}
497
498sub new {
499    my ($class) = @_;
500
501    bless {
502        symbols  => {},
503        segments => {},
504    }, $class;
505}
506
507sub symbol {
508    my ($self, $ident) = @_;
509    my $sym = $self->symbols->{$ident} ||= Sym->new;
510    $sym->ident($ident);
511    # In XDR syntax specification, defining struct/enum/union will automatically
512    # create alias having symbol which excludes its prefix type specifier.
513    # e.g:
514    #      struct foo { int bar; }; will convert to:
515    #      struct foo { int bar; }; typedef struct foo foo;
516    if ($ident =~ s/^(?:struct|enum|union)\s+//) {
517        $self->symbol($ident)->bless('Type')->alias($sym);
518    }
519    $sym;
520}
521
522sub add_to_set {
523    my ($self, $set, @elems) = @_;
524    $self->{sets} ||= {};
525    $self->{sets}{$set} ||= [];
526    push @{ $self->{sets}{$set} }, @elems;
527}
528
529sub get_set {
530    my ($self, $set) = @_;
531    $self->{sets}{$set} || [];
532}
533
534# $c->print(...string...); # Does work as regular 'print'
535# $c->print({ sym => symbol, body => ...string... });
536#  Does treat segment as code block should be referenced.
537#  It will not printed unless it is referenced from other code by $c->rinc();
538sub print {
539    my $self = shift;
540    my $content;
541    if (ref $_[0]) {
542        $content = $self->{segments}{ $_[0]{sym} } ||= $_[0];
543        $content->{refcnt} //= 0;
544        $content->{body} = $_[0]{body};
545    } else {
546        $content = join '', @_;
547    }
548    push @{ $self->{header_contents} }, $content;
549    $content;
550}
551
552sub rinc {
553    my ($self, $sym) = @_;
554    ($self->{segments}{$sym} ||= { sym => $sym, refcnt => 0 })->{refcnt}++;
555    $sym;
556}
557
558sub add_header_file {
559    my ($self, $name, $block) = @_;
560
561    $self->{headers} ||= [];
562
563    local $self->{header_contents} = [];
564    $self->print("/* *DO NOT MODIFY* this file directly.\n");
565    $self->print(" * This file was generated by $0 from libvirt version $libvirt_version */\n");
566    my $ucname = uc $name;
567    $self->print("#ifndef _$ucname\_H_\n");
568    $self->print("#define _$ucname\_H_\n");
569    $block->();
570    $self->print("#endif /* _$ucname\_H_ */");
571    push @{ $self->{headers} }, [ $name, delete $self->{header_contents} ];
572}
573
574sub finalize {
575    my ($self) = @_;
576
577    # Referenced from macro defined in packet-libvirt.h
578    $self->rinc('dissect_xdr_remote_error');
579
580    for my $header (@{ $self->{headers} || [] }) {
581        my ($name, $contents) = @$header;
582        my $file = File::Spec->catfile($builddir, "$name.h");
583        open my $fh, '>', $file
584            or die "Cannot open file $file: $!";
585        CORE::print $fh map { ref($_) ? ($_->{refcnt} ? $_->{body} : ()) : $_ } @$contents;
586        CORE::print $fh "\n";
587        close $fh;
588    }
589}
590# / package Context
591
592package Lexicalizer;
593our $Depth;
594
595INIT { # Wrap all lexicalizer subroutine by debugger function
596    $Depth = 0;
597    no strict 'refs';
598    no warnings 'redefine';
599    for my $name (keys %{ __PACKAGE__.'::' }) {
600        next if $name =~ /^(?:parse|adv)$/;
601        my $fullname = __PACKAGE__."::$name";
602        next unless defined &$fullname;
603        my $sub = \&$fullname;
604        *$fullname = sub {
605            my (undef, undef, $line) = caller;
606            ::dbg ' 'x($Depth*2), "$name L$line", "\n";
607            local $Depth = $Depth + 1;
608            $sub->(@_);
609        };
610    }
611}
612
613# Check if passed regexp does match to next token and  advance position.
614# Return matched string if matched. Die else.
615sub adv {
616    my ($rx) = @_;
617    ::dbg ' 'x($Depth*2+1), "- adv( $rx ) = ";
618    # Remove  Comments     Comments C++ style, PP directives
619    s{\A(?:\s*(?:/\*.*?\*/|(?://|%).*?(?:\n+|\z)))*\s*}{}s;
620    if (s/^(?:$rx)//s) {
621        ::dbg "'$&'\n";
622        return $&;
623    }
624    ::dbg "UNMATCH\n";
625    die;
626}
627
628sub lexor {
629    my $snapshot = $_;
630    while (my $handler = shift) {
631        my $ret = eval { $handler->() };
632        if (defined $ret) {
633            return $ret;
634        }
635        $_ = $snapshot;
636    }
637    die;
638}
639
640sub decimal_constant {
641    adv '\-?[0-9]+';
642}
643
644sub hexadecimal_constant {
645    adv '\-?0x[0-9A-Fa-f]+';
646}
647
648sub octal_constant {
649    adv '\-?0[0-9]+';
650}
651
652sub constant {
653    lexor \&hexadecimal_constant, \&octal_constant, \&decimal_constant;
654}
655
656sub identifier {
657    adv '[_a-zA-Z][_a-zA-Z0-9]*';
658}
659
660sub value {
661    lexor \&constant, \&identifier;
662}
663
664sub enum_type_spec {
665    adv 'enum';
666    my $body = lexor \&enum_body, \&identifier;
667    if (ref $body eq 'ARRAY') {
668        Sym::Type::Enum->new(members => $body);
669    } else {
670        $c->symbol("enum $body")->bless('Type::Enum');
671    }
672}
673
674sub enum_body {
675    adv '{';
676    my @members;
677    do {
678        my $ident = identifier();
679        adv '=';
680        my $value = value();
681        push @members, $c->symbol($ident)->bless('Variable')->value($value);
682    } while adv('[},]') eq ',';
683    \@members;
684}
685
686sub struct_type_spec {
687    adv 'struct';
688    my $body = lexor \&struct_body, \&identifier;
689    if (ref $body eq 'ARRAY') {
690        Sym::Type::Struct->new(members => $body);
691    } else {
692        $c->symbol("struct $body")->bless('Type::Struct');
693    }
694}
695
696sub struct_body {
697    adv '{';
698    local $c->{symbols} = { %{ $c->{symbols} } };
699    my @members;
700    while (my $decl = lexor \&declaration, sub { adv('}') }) {
701        last if $decl eq '}';
702        adv ';';
703        push @members, $decl;
704    }
705    \@members;
706}
707
708sub case_spec {
709    my @cases;
710    while (my $case = eval { adv 'case' }) {
711        push @cases, value();
712        adv ':';
713    }
714    my $decl = declaration();
715    adv ';';
716    [ \@cases, $decl ];
717}
718
719sub union_type_spec {
720    adv 'union';
721    local $c->{symbols} = { %{ $c->{symbols} } };
722    my $body = lexor \&union_body, \&identifier;
723    if (ref $body eq 'ARRAY') {
724        Sym::Type::Union->new(decl => $body->[0], case_specs => $body->[1]);
725    } else {
726        $c->symbol("union $body")->bless('Type::Union');
727    }
728}
729
730sub union_body {
731    adv 'switch'; adv '\(';
732    my $decl = declaration();
733    adv '\)'; adv '{';
734    my @case_specs;
735    while (my $spec = eval { case_spec() }) {
736        push @case_specs, $spec;
737    }
738    # TODO: parse default
739    adv '}';
740    [ $decl, \@case_specs ];
741}
742
743sub constant_def {
744    adv 'const';
745    my $ident = identifier();
746    adv '=';
747    my $value = lexor \&constant, \&identifier;
748    adv ';';
749
750    $c->symbol($ident)->bless('Variable')->value($value);
751}
752
753sub type_def {
754    my $ret = lexor sub {
755        adv 'typedef';
756        my $var = declaration();
757        my $type = $var->type;
758        $var->bless('Type')->alias($type);
759    }, sub {
760        adv 'enum';
761        my $ident = identifier();
762        my $body = enum_body();
763        $c->symbol("enum $ident")->bless('Type::Enum')->members($body);
764    }, sub {
765        adv 'struct';
766        my $ident = identifier();
767        my $body = struct_body();
768        $c->symbol("struct $ident")->bless('Type::Struct')->members($body);
769    }, sub {
770        adv 'union';
771        my $ident = identifier();
772        my $body = union_body();
773        $c->symbol("union $ident")->bless('Type::Union')
774            ->decl($body->[0])->case_specs($body->[1]);
775    };
776    adv ';';
777    $ret;
778}
779
780sub type_specifier {
781    lexor sub {
782        my $ts = adv '(?:unsigned\s+)?(?:int|hyper|char|short)|float|double|quadruple|bool';
783        $ts =~ s/^unsigned\s+/u_/;
784        $c->symbol($ts)->bless('Type');
785    }, \&enum_type_spec, \&struct_type_spec, \&union_type_spec, sub {
786        my $ident = identifier();
787        $c->symbol($ident)->bless('Type');
788    };
789}
790
791sub declaration {
792    lexor sub {
793        my $type = lexor sub {
794            my $type = adv 'opaque|string';
795            my $klass = ucfirst $type;
796            "Sym::Type::$klass"->new;
797        }, \&type_specifier;
798        my $ident = identifier();
799        # I know that type 'string' does not accept '[]'(fixed length), but I don't care about that
800        if (my $ex = eval { adv '[<\[]' }) {
801            my $value = eval { value() };
802            die if !$value && $ex ne '<'; # Length could be null if it is variable length
803
804            adv($ex eq '<' ? '>' : '\]');
805            if (ref($type) eq 'Sym::Type') { # Expect Array or Vector
806                my $vtype = ($ex eq '<') ? 'Array' : 'Vector';
807                $type = "Sym::Type::$vtype"->new(length => $value, reftype => $type);
808            } else {
809                $type->length($value);
810                $type->bless('Type::Bytes') if $type->isa('Sym::Type::Opaque') && $ex eq '<';
811            }
812        } elsif ($type->can('length')) { # Found String or Opaque but not followed by length specifier
813            die;
814        }
815
816        $c->symbol($ident)->bless('Variable')->type($type);
817    }, sub {
818        my $type = type_specifier();
819        adv '\*';
820        my $ident = identifier();
821
822        $c->symbol($ident)->bless('Variable')->type(
823            Sym::Type::Pointer->new(reftype => $type));
824    }, sub {
825        adv 'void';
826        $c->symbol('void')->bless('Type');
827    };
828}
829
830sub definition {
831    lexor \&type_def, \&constant_def;
832}
833
834sub parse {
835    my ($class, $source) = @_;
836
837    my $nlines = @{[$source =~ /\n/g]};
838    my @lexs;
839    while ($source =~ /\S/s) {
840        (local $_ = $source) =~ s/\A\s*//s;
841        my $lex = eval { definition() };
842        if (!$lex) {
843            my $line = $nlines - @{[/\n/g]} + 1;
844            my ($near) = /\A((?:.+?\n){0,5})/s;
845            die "ERROR: Unexpected character near line $line.\n",
846                "Please check debug output by enabling \$DEBUG flag at top of script.\n",
847                join("\n", map { ">> $_" } split /\n/, $near);
848        }
849        ::dbg ' 'x($Depth*2), sprintf "*** Found %s<%s>\n", ref($lex), $lex->ident;
850        push @lexs, $lex;
851        $source = $_;
852    }
853    @lexs;
854}
855
856# Following are code templates handled by PT
857__END__<<DUMMY # Dummy heredoc to disable perl syntax highlighting
858@@ Sym::Type#render_dissector
859<%
860my ($self, $ident) = @_;
861return if $self->is_primitive;
862%>
863static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
864{
865    return <%= $self->dealias->render_caller($self->ident eq $ident ? undef : $ident) %>;
866}
867@@ Sym::Type::Struct#render_dissector
868<% my ($self, $ident) = @_;
869   my $hfvar = $c->rinc('hf_'.$self->idstrip);
870%>
871static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
872{
873    goffset start;
874    proto_item *ti;
875
876    start = xdr_getpos(xdrs);
877    if (hf == -1) {
878        ti = proto_tree_add_item(tree, <%= $hfvar %>, tvb, start, -1, ENC_NA);
879    } else {
880        header_field_info *hfinfo;
881        hfinfo = proto_registrar_get_nth(<%= $hfvar %>);
882        ti = proto_tree_add_item(tree, hf, tvb, start, -1, ENC_NA);
883        proto_item_append_text(ti, " :: %s", hfinfo->name);
884    }
885    tree = proto_item_add_subtree(ti, <%= $c->rinc('ett_'.$self->idstrip) %>);
886<% for my $m (@{ $self->members }) { %>
887
888    hf = <%= $c->rinc('hf_'.$ident.'__'.$m->ident) %>;
889    if (!<%= $m->type->render_caller($ident.'__'.$m->ident) %>) return FALSE;
890<% } %>
891    proto_item_set_len(ti, xdr_getpos(xdrs) - start);
892    return TRUE;
893}
894@@ Sym::Type::Enum#render_dissector
895<% my ($self, $ident) = @_; %>
896static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
897{
898    goffset start;
899    enum { DUMMY } es;
900
901    start = xdr_getpos(xdrs);
902    if (xdr_enum(xdrs, (enum_t *)&es)) {
903        switch ((guint)es) {
904<% for my $m (@{ $self->members }) { %>
905        case <%= $m->value %>:
906            proto_tree_add_uint_format_value(tree, hf, tvb, start, xdr_getpos(xdrs) - start, (guint)es, "<%= $m->idstrip %>(<%= $m->value %>)");
907            return TRUE;
908<% } %>
909        }
910    } else {
911        proto_tree_add_item(tree, hf_libvirt_unknown, tvb, start, -1, ENC_NA);
912    }
913    return FALSE;
914}
915@@ Sym::Type::Union#render_dissector
916<%
917my ($self, $ident) = @_;
918my $decl_type = $self->decl->type->idstrip;
919%>
920static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
921{
922    gboolean rc = TRUE;
923    goffset start;
924    <%= $decl_type %> type = 0;
925
926    start = xdr_getpos(xdrs);
927    if (!xdr_<%= $decl_type %>(xdrs, &type))
928        return FALSE;
929    switch (type) {
930<% for my $cs (@{ $self->case_specs }) {
931       my ($vals, $decl) = @$cs;
932%>
933<% for my $v (@$vals) { %>
934    case <%= $v %>:
935<% } %>
936        hf = <%= $c->rinc('hf_'.$ident.'__'.$decl->ident) %>;
937        rc = <%= $decl->type->render_caller($ident.'__'.$decl->ident) %>; break;
938<% } %>
939    }
940    if (!rc) {
941        proto_tree_add_item(tree, hf_libvirt_unknown, tvb, start, -1, ENC_NA);
942    }
943    return rc;
944}
945@@ macro.hfvars
946#define VIR_DYNAMIC_HFSET \
947<% for my $prog (@{ $_->{programs} }) { %>
948        { &hf_<%= $prog %>_procedure,\
949          { "procedure", "libvirt.procedure",\
950            FT_INT32, BASE_DEC,\
951            VALS(<%= $prog %>_procedure_strings), 0x0,\
952            NULL, HFILL}\
953        },\
954<% } %>
955<% for my $hf (@{ $_->{hfvars} }) { %>
956        { &<%= $hf->{segment}{sym} %>,\
957          { "<%= $hf->{name} %>", "libvirt.<%= $hf->{abbrev} %>",\
958            FT_<%= $hf->{ft_type} %>, BASE_<%= $hf->{hf_base} %>,\
959            NULL, 0x0,\
960            NULL, HFILL}\
961        },\
962<% } %>
963/* End of #define VIR_DYNAMIC_HFSET */
964
965@@ macro.ettvars
966#define VIR_DYNAMIC_ETTSET \
967<% for my $ett (@{ $_->{ettvars} }) { %>
968&<%= $ett %>,\
969<% } %>
970/* End of #define VIR_DYNAMIC_ETTSET */
971
972@@ code.dissectorlist
973static const vir_dissector_index_t <%= $_->{name} %>_dissectors[] = {
974<% for my $d (@{ $_->{dissectors} }) { %>
975    { <%= $d->{value} %>, <%= $d->{args} %>, <%= $d->{ret} %>, <%= $d->{msg} %> },
976<% } %>
977};
978static const gsize <%= $_->{name} %>_dissectors_len = array_length(<%= $_->{name} %>_dissectors);
979@@ code.procedure_strings
980static const value_string <%= $_->{name} %>_procedure_strings[] = {
981<% for my $proc (@{ $_->{procedures} }) {
982       my $ident = $proc->ident;
983       $ident =~ s/^$_->{name}_proc_//i;
984%>
985    { <%= $proc->value %>, "<%= $ident %>" },
986<% } %>
987    { 0, NULL }
988};
989@@ code.program_strings
990static const value_string program_strings[] = {
991<% for my $prog (map uc, @{ $_->{programs} }) { %>
992    { <%= $c->symbol("$prog\_PROGRAM")->value %>, "<%= $prog %>" },
993<% } %>
994    { 0, NULL }
995};
996@@ code.program_data
997static const void *program_data[][VIR_PROGRAM_LAST] = {
998<% for my $p (@{ $_->{programs} }) { %>
999    { &hf_<%= $p %>_procedure, <%= $p %>_procedure_strings, <%= $p %>_dissectors, &<%= $p %>_dissectors_len },
1000<% } %>
1001};
1002
1003static const void *
1004get_program_data(guint32 prog, enum vir_program_data_index index)
1005{
1006    if (index < VIR_PROGRAM_LAST) {
1007        switch (prog) {
1008<% my $i = 0; %>
1009<% for my $prog (@{ $_->{programs} }) { %>
1010        case <%= uc($prog) %>_PROGRAM:
1011            return program_data[<%= $i++ %>][index];
1012<% } %>
1013        }
1014    }
1015    return NULL;
1016}
1017