mirror of
https://gitlab.com/libvirt/libvirt.git
synced 2024-08-28 11:31:16 +00:00
Reviewed-by: Peter Krempa <pkrempa@redhat.com> Signed-off-by: Daniel P. Berrangé <berrange@redhat.com>
1017 lines
28 KiB
Perl
Executable File
1017 lines
28 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
# genxdrstub.pl --- Generate C header file which used by packet-libvirt.[ch]
|
|
#
|
|
# Copyright (C) 2013 Yuto KAWAMURA(kawamuray) <kawamuray.dadada@gmail.com>
|
|
#
|
|
# This library is free software; you can redistribute it and/or
|
|
# modify it under the terms of the GNU Lesser General Public
|
|
# License as published by the Free Software Foundation; either
|
|
# version 2.1 of the License, or (at your option) any later version.
|
|
#
|
|
# This library is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
# Lesser General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU Lesser General Public
|
|
# License along with this library. If not, see
|
|
# <http://www.gnu.org/licenses/>.
|
|
#
|
|
#
|
|
# For XDR syntax, see https://tools.ietf.org/html/rfc4506#section-6.3
|
|
# This script does not strictly check syntax of xdr protocol specification.
|
|
# Make sure the specification files you have are correctly compilable with rpcgen(1).
|
|
# If something fails with this script in spite of you had confirmed that the `make' with libvirt was succeed,
|
|
# please report your error output to kawamuray<kawamuray.dadada@gmail.com>.
|
|
use strict;
|
|
use warnings;
|
|
use File::Spec;
|
|
|
|
my $DEBUG = 0; # Enable if you want to see debug output
|
|
sub dbg { print STDERR @_ if $DEBUG }
|
|
|
|
die "ERROR: No arguments" unless @ARGV >= 3;
|
|
|
|
my $libvirt_version = shift;
|
|
my $builddir = shift;
|
|
|
|
# Context object referenced from entire this script
|
|
my $c = Context->new;
|
|
|
|
for my $proto (@ARGV) {
|
|
# We need to do this heuristic parsing to determine
|
|
# variable name of enum <protocol>_procedures.
|
|
my ($name) = $proto =~ m{(?:vir)?([^/]+?)_?protocol\.x$};
|
|
unless ($name) {
|
|
warn "WARNING: Cannot extract protocol name from $proto, skipping.";
|
|
next;
|
|
}
|
|
$c->add_to_set(progs => $name);
|
|
|
|
my $source;
|
|
{
|
|
open my $fh, '<', $proto
|
|
or die "Cannot open $proto: $!";
|
|
local $/;
|
|
$source = <$fh>;
|
|
close $fh;
|
|
}
|
|
|
|
$c->add_header_file($name, sub {
|
|
dbg "*** Start parsing $proto\n";
|
|
|
|
$c->print("extern int hf_libvirt_unknown;\n");
|
|
|
|
my @lexs = Lexicalizer->parse($source);
|
|
for my $lex (@lexs) {
|
|
next if $lex->ident eq "enum $name\_procedure";
|
|
|
|
if ($lex->isa('Sym::Variable')) {
|
|
$c->print(sprintf "#define %s (%s)\n", $lex->ident, $lex->value);
|
|
} elsif ($lex->isa('Sym::Type')) {
|
|
# Top level of name path is type identification of itself
|
|
$lex->define_dissector($lex->idstrip);
|
|
} else {
|
|
die "Unknown lexical appeared: $lex";
|
|
}
|
|
}
|
|
|
|
my $procs = $c->symbol("enum $name\_procedure")
|
|
or die "Cannot find procedures enumeration: enum $name\_procedure";
|
|
# Procedure numbers are expected to be containing gaps, but needed to be sorted in ascending order.
|
|
my @procedures = sort { $a->value <=> $b->value } @{ $procs->members };
|
|
my @dissectors = map {
|
|
(my $ident = lc($_->ident)) =~ s/^$name\_proc/$name/;
|
|
+{
|
|
value => $_->value,
|
|
map { $_ => $c->rinc($c->symbols->{"$ident\_$_"} ? "dissect_xdr_$ident\_$_" : 'NULL') }
|
|
qw{ args ret msg }
|
|
};
|
|
} @procedures;
|
|
$c->print(PT->render('code.dissectorlist', {
|
|
name => $name,
|
|
dissectors => \@dissectors,
|
|
}));
|
|
$c->print(PT->render('code.procedure_strings', {
|
|
name => $name,
|
|
procedures => \@procedures,
|
|
}));
|
|
});
|
|
}
|
|
|
|
$c->add_header_file('protocol', sub {
|
|
for my $prog (@{ $c->get_set('progs') }) {
|
|
$c->print("#include \"libvirt/$prog.h\"\n");
|
|
}
|
|
|
|
# hf_ variables set
|
|
$c->print(PT->render('macro.hfvars', {
|
|
programs => $c->get_set('progs'),
|
|
hfvars => [ grep $_->{segment}{refcnt}, @{ $c->get_set('hfvars') } ],
|
|
}));
|
|
# ett_ variables set
|
|
$c->print(PT->render('macro.ettvars', {
|
|
ettvars => [ map $_->{sym}, grep $_->{refcnt}, @{ $c->get_set('ettvars') } ],
|
|
}));
|
|
# value_string program_strings
|
|
$c->print(PT->render('code.program_strings', { programs => $c->get_set('progs') }));
|
|
$c->print("static int hf_$_\_procedure = -1;\n") for @{ $c->get_set('progs') };
|
|
$c->print(PT->render('code.program_data', { programs => $c->get_set('progs') }));
|
|
});
|
|
|
|
$c->finalize; exit 0;
|
|
|
|
# Used for handy class building
|
|
sub register_profile {
|
|
my %prof = @_;
|
|
my $caller = caller;
|
|
no strict 'refs';
|
|
if ($prof{isa}) {
|
|
push @{ "$caller\::ISA" }, $prof{isa};
|
|
}
|
|
while (my ($name, $v) = each %{ $prof{consts} || {} }) {
|
|
*{ "$caller\::$name" } = sub { $v };
|
|
}
|
|
for my $attr (@{ $prof{attrs} || [] }) {
|
|
*{ "$caller\::$attr" } = sub {
|
|
if (@_ > 1) { $_[0]->{$attr} = $_[1]; $_[0] }
|
|
else { $_[0]->{$attr} }
|
|
};
|
|
}
|
|
while (my ($klass, $meths) = each %{ $prof{roles} || {} }) {
|
|
for my $meth (@$meths) {
|
|
# This assignment cannot be like: *{ "$caller\::$meth" } = \&{ "$klass\::$meth" }.
|
|
# "$klass\::$meth" maybe not defined yet(e.g. Methods defined by PT)
|
|
*{ "$caller\::$meth" } = sub { goto &{ "$klass\::$meth" } };
|
|
}
|
|
}
|
|
}
|
|
|
|
# Minimal template engine for code generating
|
|
package PT; # is PicoTemplate
|
|
our $Token;
|
|
our %Templates;
|
|
INIT { # Load templates from __END__ section
|
|
$Token = join '', map { chr(65 + rand(26)) } 1..64;
|
|
my $current;
|
|
while (my $l = <main::DATA>) {
|
|
if ($l =~ /^\@\@\s*(.+)/) {
|
|
$current = \($Templates{$1} = '');
|
|
} else {
|
|
$$current .= $l if $current;
|
|
}
|
|
}
|
|
for my $name (keys %Templates) {
|
|
$Templates{$name} = __PACKAGE__->compile($Templates{$name});
|
|
if ($name =~ /^([\w:]+)#([^#]+)$/) {
|
|
no strict 'refs';
|
|
my $meth = "$1\::$2";
|
|
unless (defined &$meth) {
|
|
*$meth = $Templates{$name};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
sub compile {
|
|
my ($class, $tmpl) = @_;
|
|
|
|
$tmpl =~ s{<%(=)?(.*?)%>\n?|((?:(?!<%).)+)}{
|
|
$2 ? $1 ? "\$$Token .= qq{\@{[do{ $2 }]}};" : $2
|
|
: "\$$Token .= substr <<$Token, 0, -1;\n".quotemeta($3)."\n$Token\n";
|
|
}gse;
|
|
eval "sub { my \$$Token = ''; $tmpl \$$Token }"
|
|
or die "ERROR: Cannot compile template: $@";
|
|
}
|
|
sub render {
|
|
my ($class, $name, $vars, @args) = @_;
|
|
local $_ = $vars || {};
|
|
my $renderer = $Templates{$name}
|
|
or die "No such template: $name";
|
|
$renderer->(@args);
|
|
}
|
|
# / package PT
|
|
|
|
package Sym;
|
|
BEGIN{::register_profile(
|
|
attrs => [qw[ ident ]],
|
|
)}
|
|
|
|
sub new {
|
|
my ($class, %args) = @_;
|
|
|
|
CORE::bless \%args, $class;
|
|
}
|
|
|
|
sub bless {
|
|
my ($self, $klass) = @_;
|
|
|
|
CORE::bless $self, "Sym::$klass"
|
|
if ref($self) ne "Sym::$klass";
|
|
$self;
|
|
}
|
|
|
|
sub idstrip {
|
|
my $ident = shift()->ident;
|
|
$ident =~ s/^(?:struct|enum|union)\s+// if $ident;
|
|
$ident;
|
|
}
|
|
# / package Sym
|
|
|
|
package Sym::Type;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym',
|
|
attrs => [qw[ alias ]],
|
|
)}
|
|
|
|
sub is_primitive { !(shift)->alias }
|
|
|
|
sub dealias {
|
|
my ($self) = @_;
|
|
|
|
$self->is_primitive ? $self : $self->alias->dealias;
|
|
}
|
|
|
|
sub xdr_type {
|
|
my ($self) = @_;
|
|
|
|
if (!$self->is_primitive) {
|
|
return $self->dealias->xdr_type;
|
|
}
|
|
|
|
my $type = ref $self;
|
|
if ($type eq __PACKAGE__) {
|
|
$type = $self->ident;
|
|
} else {
|
|
$type =~ s/^.*:://;
|
|
}
|
|
uc($type);
|
|
}
|
|
|
|
sub render_caller {
|
|
my ($self, $hfid) = @_;
|
|
my $name = $c->rinc( 'dissect_xdr_'.($self->idstrip || lc($self->xdr_type)) );
|
|
"$name(tvb, tree, xdrs, hf)";
|
|
}
|
|
|
|
sub ft_type {
|
|
my ($self) = @_;
|
|
return $self->dealias->ft_type unless $self->is_primitive;
|
|
my $xt = $self->xdr_type;
|
|
+{
|
|
INT => 'INT32',
|
|
U_INT => 'UINT32',
|
|
SHORT => 'INT16',
|
|
U_SHORT => 'UINT16',
|
|
CHAR => 'INT8',
|
|
U_CHAR => 'UINT8',
|
|
HYPER => 'INT64',
|
|
U_HYPER => 'UINT64',
|
|
BOOL => 'BOOLEAN',
|
|
}->{$xt} || $xt;
|
|
}
|
|
|
|
sub hf_base {
|
|
my ($self) = @_;
|
|
$self->is_primitive
|
|
? $self->ft_type =~ /INT/ ? 'DEC' : 'NONE'
|
|
: $self->dealias->hf_base;
|
|
}
|
|
|
|
sub define_dissector {
|
|
my ($self, @path) = @_;
|
|
$self->declare_hfvar(@path);
|
|
my $path = join '__', @path;
|
|
my $code = $self->render_dissector($path);
|
|
$c->print({ sym => "dissect_xdr_$path", body => $code })
|
|
if $code;
|
|
}
|
|
|
|
sub declare_hfvar {
|
|
my ($self, @path) = @_;
|
|
my $path = join '__', @path;
|
|
$c->add_to_set(hfvars => {
|
|
segment => $c->print({
|
|
sym => "hf_$path",
|
|
body => "static int hf_$path = -1;\n"
|
|
}),
|
|
name => $path[-1],
|
|
abbrev => join('.', @path),
|
|
ft_type => $self->ft_type,
|
|
hf_base => $self->hf_base,
|
|
});
|
|
}
|
|
# / package Sym
|
|
|
|
package Sym::Type::HasAnonTypes; # Types which possibly have anonymous subtypes
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
)}
|
|
|
|
sub declare_anontypes {
|
|
my ($self, @path) = @_;
|
|
|
|
for my $m (@{ $self->members }) {
|
|
unless (defined $m->type->ident) {
|
|
$m->type->ident(join '__', @path, $m->ident);
|
|
}
|
|
$m->type->define_dissector(@path, $m->ident);
|
|
}
|
|
}
|
|
|
|
sub define_dissector {
|
|
my ($self, @path) = @_;
|
|
|
|
$self->declare_anontypes(@path);
|
|
$self->SUPER::define_dissector(@path);
|
|
}
|
|
|
|
package Sym::Type::HasSubtree; # Types which should be declare ett variables
|
|
|
|
sub declare_ettvar {
|
|
my ($self) = @_;
|
|
my $ettvar = 'ett_'.$self->idstrip;
|
|
$c->add_to_set(ettvars => $c->print({
|
|
sym => $ettvar,
|
|
body => "static gint $ettvar = -1;\n",
|
|
}));
|
|
}
|
|
|
|
package Sym::Type::HasReference; # Types which references subtype
|
|
BEGIN{::register_profile(
|
|
attrs => [qw[ reftype ]],
|
|
consts => { ft_type => 'NONE' },
|
|
)}
|
|
|
|
sub render_caller {
|
|
my ($self) = @_;
|
|
my ($klass) = ref($self) =~ /([^:]+)$/;
|
|
sprintf '%s(tvb, tree, xdrs, hf, %s)',
|
|
$c->rinc('dissect_xdr_'.lc($klass)),
|
|
$c->rinc('dissect_xdr_'.$self->reftype->idstrip);
|
|
}
|
|
|
|
package Sym::Type::HasLength; # Types which has length attribute
|
|
BEGIN{::register_profile(
|
|
attrs => [qw[ length ]],
|
|
consts => { ft_type => 'NONE' },
|
|
)}
|
|
|
|
sub render_caller {
|
|
my ($self, $hfid) = @_;
|
|
my ($klass) = ref($self) =~ /([^:]+)$/;
|
|
sprintf '%s(tvb, tree, xdrs, hf, %s)',
|
|
$c->rinc('dissect_xdr_'.lc($klass)), $self->length || '~0';
|
|
}
|
|
|
|
package Sym::Type::Struct;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
attrs => [qw[ members ]],
|
|
consts => { ft_type => 'NONE' },
|
|
roles => {
|
|
'Sym::Type::HasAnonTypes' => [qw[ declare_anontypes ]],
|
|
'Sym::Type::HasSubtree' => [qw[ declare_ettvar ]],
|
|
},
|
|
)}
|
|
|
|
sub define_dissector {
|
|
my ($self, @path) = @_;
|
|
$self->declare_anontypes(@path);
|
|
$self->declare_ettvar;
|
|
$self->SUPER::define_dissector(@path);
|
|
}
|
|
|
|
package Sym::Type::Enum;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
attrs => [qw[ members ]],
|
|
consts => { ft_type => 'UINT32' },
|
|
)}
|
|
package Sym::Type::Union;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
attrs => [qw[ decl case_specs ]],
|
|
consts => { ft_type => 'NONE' },
|
|
roles => {
|
|
'Sym::Type::HasAnonTypes' => [qw[ declare_anontypes define_dissector ]],
|
|
},
|
|
)}
|
|
sub members {
|
|
my ($self) = @_;
|
|
[ map { $_->[1] } @{ $self->case_specs } ];
|
|
}
|
|
|
|
package Sym::Type::String;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
consts => { ft_type => 'STRING' },
|
|
roles => {
|
|
'Sym::Type::HasLength' => [qw[ length render_caller ]],
|
|
},
|
|
)}
|
|
package Sym::Type::Opaque;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
consts => { ft_type => 'BYTES' },
|
|
roles => {
|
|
'Sym::Type::HasLength' => [qw[ length render_caller ]],
|
|
},
|
|
)}
|
|
package Sym::Type::Bytes;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
consts => { ft_type => 'BYTES' },
|
|
roles => {
|
|
'Sym::Type::HasLength' => [qw[ length render_caller ]],
|
|
},
|
|
)}
|
|
package Sym::Type::Pointer;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
roles => {
|
|
'Sym::Type::HasReference' => [qw[ reftype render_caller ]],
|
|
},
|
|
)}
|
|
sub ft_type { (shift)->reftype->ft_type }
|
|
|
|
package Sym::Type::Array; # a.k.a Variable-Length Array
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
roles => {
|
|
'Sym::Type::HasLength' => [qw[ length ft_type ]],
|
|
'Sym::Type::HasReference' => [qw[ reftype ]],
|
|
'Sym::Type::HasSubtree' => [qw[ declare_ettvar ]],
|
|
},
|
|
)}
|
|
|
|
sub render_caller {
|
|
my ($self, $hfid) = @_;
|
|
my ($pname) = reverse split /__/, $hfid;
|
|
sprintf 'dissect_xdr_array(tvb, tree, xdrs, hf, %s, %s, "%s", %s, %s)',
|
|
$c->rinc('ett_'.$self->idstrip),
|
|
$c->rinc("hf_$hfid\__$pname"),
|
|
$self->reftype->idstrip,
|
|
$self->length || '~0',
|
|
$c->rinc('dissect_xdr_'.$self->reftype->idstrip);
|
|
}
|
|
|
|
sub define_dissector {
|
|
my ($self, @path) = @_;
|
|
$self->reftype->declare_hfvar(@path, $path[-1]);
|
|
$self->declare_ettvar;
|
|
$self->SUPER::define_dissector(@path);
|
|
}
|
|
|
|
package Sym::Type::Vector; # a.k.a Fixed-Length Array
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym::Type',
|
|
roles => {
|
|
'Sym::Type::HasLength' => [qw[ length ft_type ]],
|
|
'Sym::Type::HasReference' => [qw[ reftype ]],
|
|
'Sym::Type::Array' => [qw[ define_dissector ]],
|
|
'Sym::Type::HasSubtree' => [qw[ declare_ettvar ]],
|
|
},
|
|
)}
|
|
|
|
sub render_caller {
|
|
my ($self, $hfid) = @_;
|
|
my ($pname) = reverse split /__/, $hfid;
|
|
sprintf 'dissect_xdr_vector(tvb, tree, xdrs, hf, %s, %s, "%s", %s, %s)',
|
|
$c->rinc('ett_'.$self->idstrip),
|
|
$c->rinc("hf_$hfid\__$pname"),
|
|
$self->reftype->idstrip,
|
|
$self->length || '~0',
|
|
$c->rinc('dissect_xdr_'.$self->reftype->idstrip);
|
|
}
|
|
|
|
package Sym::Variable;
|
|
BEGIN{::register_profile(
|
|
isa => 'Sym',
|
|
attrs => [qw[ type value ]],
|
|
)}
|
|
|
|
package Context;
|
|
BEGIN{::register_profile(
|
|
attrs => [qw[ symbols ]],
|
|
)}
|
|
|
|
sub new {
|
|
my ($class) = @_;
|
|
|
|
bless {
|
|
symbols => {},
|
|
segments => {},
|
|
}, $class;
|
|
}
|
|
|
|
sub symbol {
|
|
my ($self, $ident) = @_;
|
|
my $sym = $self->symbols->{$ident} ||= Sym->new;
|
|
$sym->ident($ident);
|
|
# In XDR syntax specification, defining struct/enum/union will automatically
|
|
# create alias having symbol which excludes its prefix type specifier.
|
|
# e.g:
|
|
# struct foo { int bar; }; will convert to:
|
|
# struct foo { int bar; }; typedef struct foo foo;
|
|
if ($ident =~ s/^(?:struct|enum|union)\s+//) {
|
|
$self->symbol($ident)->bless('Type')->alias($sym);
|
|
}
|
|
$sym;
|
|
}
|
|
|
|
sub add_to_set {
|
|
my ($self, $set, @elems) = @_;
|
|
$self->{sets} ||= {};
|
|
$self->{sets}{$set} ||= [];
|
|
push @{ $self->{sets}{$set} }, @elems;
|
|
}
|
|
|
|
sub get_set {
|
|
my ($self, $set) = @_;
|
|
$self->{sets}{$set} || [];
|
|
}
|
|
|
|
# $c->print(...string...); # Does work as regular 'print'
|
|
# $c->print({ sym => symbol, body => ...string... });
|
|
# Does treat segment as code block should be referenced.
|
|
# It will not printed unless it is referenced from other code by $c->rinc();
|
|
sub print {
|
|
my $self = shift;
|
|
my $content;
|
|
if (ref $_[0]) {
|
|
$content = $self->{segments}{ $_[0]{sym} } ||= $_[0];
|
|
$content->{refcnt} //= 0;
|
|
$content->{body} = $_[0]{body};
|
|
} else {
|
|
$content = join '', @_;
|
|
}
|
|
push @{ $self->{header_contents} }, $content;
|
|
$content;
|
|
}
|
|
|
|
sub rinc {
|
|
my ($self, $sym) = @_;
|
|
($self->{segments}{$sym} ||= { sym => $sym, refcnt => 0 })->{refcnt}++;
|
|
$sym;
|
|
}
|
|
|
|
sub add_header_file {
|
|
my ($self, $name, $block) = @_;
|
|
|
|
$self->{headers} ||= [];
|
|
|
|
local $self->{header_contents} = [];
|
|
$self->print("/* *DO NOT MODIFY* this file directly.\n");
|
|
$self->print(" * This file was generated by $0 from libvirt version $libvirt_version */\n");
|
|
my $ucname = uc $name;
|
|
$self->print("#ifndef _$ucname\_H_\n");
|
|
$self->print("#define _$ucname\_H_\n");
|
|
$block->();
|
|
$self->print("#endif /* _$ucname\_H_ */");
|
|
push @{ $self->{headers} }, [ $name, delete $self->{header_contents} ];
|
|
}
|
|
|
|
sub finalize {
|
|
my ($self) = @_;
|
|
|
|
# Referenced from macro defined in packet-libvirt.h
|
|
$self->rinc('dissect_xdr_remote_error');
|
|
|
|
for my $header (@{ $self->{headers} || [] }) {
|
|
my ($name, $contents) = @$header;
|
|
my $file = File::Spec->catfile($builddir, "$name.h");
|
|
open my $fh, '>', $file
|
|
or die "Cannot open file $file: $!";
|
|
CORE::print $fh map { ref($_) ? ($_->{refcnt} ? $_->{body} : ()) : $_ } @$contents;
|
|
CORE::print $fh "\n";
|
|
close $fh;
|
|
}
|
|
}
|
|
# / package Context
|
|
|
|
package Lexicalizer;
|
|
our $Depth;
|
|
|
|
INIT { # Wrap all lexicalizer subroutine by debugger function
|
|
$Depth = 0;
|
|
no strict 'refs';
|
|
no warnings 'redefine';
|
|
for my $name (keys %{ __PACKAGE__.'::' }) {
|
|
next if $name =~ /^(?:parse|adv)$/;
|
|
my $fullname = __PACKAGE__."::$name";
|
|
next unless defined &$fullname;
|
|
my $sub = \&$fullname;
|
|
*$fullname = sub {
|
|
my (undef, undef, $line) = caller;
|
|
::dbg ' 'x($Depth*2), "$name L$line", "\n";
|
|
local $Depth = $Depth + 1;
|
|
$sub->(@_);
|
|
};
|
|
}
|
|
}
|
|
|
|
# Check if passed regexp does match to next token and advance position.
|
|
# Return matched string if matched. Die else.
|
|
sub adv {
|
|
my ($rx) = @_;
|
|
::dbg ' 'x($Depth*2+1), "- adv( $rx ) = ";
|
|
# Remove Comments Comments C++ style, PP directives
|
|
s{\A(?:\s*(?:/\*.*?\*/|(?://|%).*?(?:\n+|\z)))*\s*}{}s;
|
|
if (s/^(?:$rx)//s) {
|
|
::dbg "'$&'\n";
|
|
return $&;
|
|
}
|
|
::dbg "UNMATCH\n";
|
|
die;
|
|
}
|
|
|
|
sub lexor {
|
|
my $snapshot = $_;
|
|
while (my $handler = shift) {
|
|
my $ret = eval { $handler->() };
|
|
if (defined $ret) {
|
|
return $ret;
|
|
}
|
|
$_ = $snapshot;
|
|
}
|
|
die;
|
|
}
|
|
|
|
sub decimal_constant {
|
|
adv '\-?[0-9]+';
|
|
}
|
|
|
|
sub hexadecimal_constant {
|
|
adv '\-?0x[0-9A-Fa-f]+';
|
|
}
|
|
|
|
sub octal_constant {
|
|
adv '\-?0[0-9]+';
|
|
}
|
|
|
|
sub constant {
|
|
lexor \&hexadecimal_constant, \&octal_constant, \&decimal_constant;
|
|
}
|
|
|
|
sub identifier {
|
|
adv '[_a-zA-Z][_a-zA-Z0-9]*';
|
|
}
|
|
|
|
sub value {
|
|
lexor \&constant, \&identifier;
|
|
}
|
|
|
|
sub enum_type_spec {
|
|
adv 'enum';
|
|
my $body = lexor \&enum_body, \&identifier;
|
|
if (ref $body eq 'ARRAY') {
|
|
Sym::Type::Enum->new(members => $body);
|
|
} else {
|
|
$c->symbol("enum $body")->bless('Type::Enum');
|
|
}
|
|
}
|
|
|
|
sub enum_body {
|
|
adv '{';
|
|
my @members;
|
|
do {
|
|
my $ident = identifier();
|
|
adv '=';
|
|
my $value = value();
|
|
push @members, $c->symbol($ident)->bless('Variable')->value($value);
|
|
} while adv('[},]') eq ',';
|
|
\@members;
|
|
}
|
|
|
|
sub struct_type_spec {
|
|
adv 'struct';
|
|
my $body = lexor \&struct_body, \&identifier;
|
|
if (ref $body eq 'ARRAY') {
|
|
Sym::Type::Struct->new(members => $body);
|
|
} else {
|
|
$c->symbol("struct $body")->bless('Type::Struct');
|
|
}
|
|
}
|
|
|
|
sub struct_body {
|
|
adv '{';
|
|
local $c->{symbols} = { %{ $c->{symbols} } };
|
|
my @members;
|
|
while (my $decl = lexor \&declaration, sub { adv('}') }) {
|
|
last if $decl eq '}';
|
|
adv ';';
|
|
push @members, $decl;
|
|
}
|
|
\@members;
|
|
}
|
|
|
|
sub case_spec {
|
|
my @cases;
|
|
while (my $case = eval { adv 'case' }) {
|
|
push @cases, value();
|
|
adv ':';
|
|
}
|
|
my $decl = declaration();
|
|
adv ';';
|
|
[ \@cases, $decl ];
|
|
}
|
|
|
|
sub union_type_spec {
|
|
adv 'union';
|
|
local $c->{symbols} = { %{ $c->{symbols} } };
|
|
my $body = lexor \&union_body, \&identifier;
|
|
if (ref $body eq 'ARRAY') {
|
|
Sym::Type::Union->new(decl => $body->[0], case_specs => $body->[1]);
|
|
} else {
|
|
$c->symbol("union $body")->bless('Type::Union');
|
|
}
|
|
}
|
|
|
|
sub union_body {
|
|
adv 'switch'; adv '\(';
|
|
my $decl = declaration();
|
|
adv '\)'; adv '{';
|
|
my @case_specs;
|
|
while (my $spec = eval { case_spec() }) {
|
|
push @case_specs, $spec;
|
|
}
|
|
# TODO: parse default
|
|
adv '}';
|
|
[ $decl, \@case_specs ];
|
|
}
|
|
|
|
sub constant_def {
|
|
adv 'const';
|
|
my $ident = identifier();
|
|
adv '=';
|
|
my $value = lexor \&constant, \&identifier;
|
|
adv ';';
|
|
|
|
$c->symbol($ident)->bless('Variable')->value($value);
|
|
}
|
|
|
|
sub type_def {
|
|
my $ret = lexor sub {
|
|
adv 'typedef';
|
|
my $var = declaration();
|
|
my $type = $var->type;
|
|
$var->bless('Type')->alias($type);
|
|
}, sub {
|
|
adv 'enum';
|
|
my $ident = identifier();
|
|
my $body = enum_body();
|
|
$c->symbol("enum $ident")->bless('Type::Enum')->members($body);
|
|
}, sub {
|
|
adv 'struct';
|
|
my $ident = identifier();
|
|
my $body = struct_body();
|
|
$c->symbol("struct $ident")->bless('Type::Struct')->members($body);
|
|
}, sub {
|
|
adv 'union';
|
|
my $ident = identifier();
|
|
my $body = union_body();
|
|
$c->symbol("union $ident")->bless('Type::Union')
|
|
->decl($body->[0])->case_specs($body->[1]);
|
|
};
|
|
adv ';';
|
|
$ret;
|
|
}
|
|
|
|
sub type_specifier {
|
|
lexor sub {
|
|
my $ts = adv '(?:unsigned\s+)?(?:int|hyper|char|short)|float|double|quadruple|bool';
|
|
$ts =~ s/^unsigned\s+/u_/;
|
|
$c->symbol($ts)->bless('Type');
|
|
}, \&enum_type_spec, \&struct_type_spec, \&union_type_spec, sub {
|
|
my $ident = identifier();
|
|
$c->symbol($ident)->bless('Type');
|
|
};
|
|
}
|
|
|
|
sub declaration {
|
|
lexor sub {
|
|
my $type = lexor sub {
|
|
my $type = adv 'opaque|string';
|
|
my $klass = ucfirst $type;
|
|
"Sym::Type::$klass"->new;
|
|
}, \&type_specifier;
|
|
my $ident = identifier();
|
|
# I know that type 'string' does not accept '[]'(fixed length), but I don't care about that
|
|
if (my $ex = eval { adv '[<\[]' }) {
|
|
my $value = eval { value() };
|
|
die if !$value && $ex ne '<'; # Length could be null if it is variable length
|
|
|
|
adv($ex eq '<' ? '>' : '\]');
|
|
if (ref($type) eq 'Sym::Type') { # Expect Array or Vector
|
|
my $vtype = ($ex eq '<') ? 'Array' : 'Vector';
|
|
$type = "Sym::Type::$vtype"->new(length => $value, reftype => $type);
|
|
} else {
|
|
$type->length($value);
|
|
$type->bless('Type::Bytes') if $type->isa('Sym::Type::Opaque') && $ex eq '<';
|
|
}
|
|
} elsif ($type->can('length')) { # Found String or Opaque but not followed by length specifier
|
|
die;
|
|
}
|
|
|
|
$c->symbol($ident)->bless('Variable')->type($type);
|
|
}, sub {
|
|
my $type = type_specifier();
|
|
adv '\*';
|
|
my $ident = identifier();
|
|
|
|
$c->symbol($ident)->bless('Variable')->type(
|
|
Sym::Type::Pointer->new(reftype => $type));
|
|
}, sub {
|
|
adv 'void';
|
|
$c->symbol('void')->bless('Type');
|
|
};
|
|
}
|
|
|
|
sub definition {
|
|
lexor \&type_def, \&constant_def;
|
|
}
|
|
|
|
sub parse {
|
|
my ($class, $source) = @_;
|
|
|
|
my $nlines = @{[$source =~ /\n/g]};
|
|
my @lexs;
|
|
while ($source =~ /\S/s) {
|
|
(local $_ = $source) =~ s/\A\s*//s;
|
|
my $lex = eval { definition() };
|
|
if (!$lex) {
|
|
my $line = $nlines - @{[/\n/g]} + 1;
|
|
my ($near) = /\A((?:.+?\n){0,5})/s;
|
|
die "ERROR: Unexpected character near line $line.\n",
|
|
"Please check debug output by enabling \$DEBUG flag at top of script.\n",
|
|
join("\n", map { ">> $_" } split /\n/, $near);
|
|
}
|
|
::dbg ' 'x($Depth*2), sprintf "*** Found %s<%s>\n", ref($lex), $lex->ident;
|
|
push @lexs, $lex;
|
|
$source = $_;
|
|
}
|
|
@lexs;
|
|
}
|
|
|
|
# Following are code templates handled by PT
|
|
__END__<<DUMMY # Dummy heredoc to disable perl syntax highlighting
|
|
@@ Sym::Type#render_dissector
|
|
<%
|
|
my ($self, $ident) = @_;
|
|
return if $self->is_primitive;
|
|
%>
|
|
static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
|
|
{
|
|
return <%= $self->dealias->render_caller($self->ident eq $ident ? undef : $ident) %>;
|
|
}
|
|
@@ Sym::Type::Struct#render_dissector
|
|
<% my ($self, $ident) = @_;
|
|
my $hfvar = $c->rinc('hf_'.$self->idstrip);
|
|
%>
|
|
static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
|
|
{
|
|
goffset start;
|
|
proto_item *ti;
|
|
|
|
start = xdr_getpos(xdrs);
|
|
if (hf == -1) {
|
|
ti = proto_tree_add_item(tree, <%= $hfvar %>, tvb, start, -1, ENC_NA);
|
|
} else {
|
|
header_field_info *hfinfo;
|
|
hfinfo = proto_registrar_get_nth(<%= $hfvar %>);
|
|
ti = proto_tree_add_item(tree, hf, tvb, start, -1, ENC_NA);
|
|
proto_item_append_text(ti, " :: %s", hfinfo->name);
|
|
}
|
|
tree = proto_item_add_subtree(ti, <%= $c->rinc('ett_'.$self->idstrip) %>);
|
|
<% for my $m (@{ $self->members }) { %>
|
|
|
|
hf = <%= $c->rinc('hf_'.$ident.'__'.$m->ident) %>;
|
|
if (!<%= $m->type->render_caller($ident.'__'.$m->ident) %>) return FALSE;
|
|
<% } %>
|
|
proto_item_set_len(ti, xdr_getpos(xdrs) - start);
|
|
return TRUE;
|
|
}
|
|
@@ Sym::Type::Enum#render_dissector
|
|
<% my ($self, $ident) = @_; %>
|
|
static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
|
|
{
|
|
goffset start;
|
|
enum { DUMMY } es;
|
|
|
|
start = xdr_getpos(xdrs);
|
|
if (xdr_enum(xdrs, (enum_t *)&es)) {
|
|
switch ((guint)es) {
|
|
<% for my $m (@{ $self->members }) { %>
|
|
case <%= $m->value %>:
|
|
proto_tree_add_uint_format_value(tree, hf, tvb, start, xdr_getpos(xdrs) - start, (guint)es, "<%= $m->idstrip %>(<%= $m->value %>)");
|
|
return TRUE;
|
|
<% } %>
|
|
}
|
|
} else {
|
|
proto_tree_add_item(tree, hf_libvirt_unknown, tvb, start, -1, ENC_NA);
|
|
}
|
|
return FALSE;
|
|
}
|
|
@@ Sym::Type::Union#render_dissector
|
|
<%
|
|
my ($self, $ident) = @_;
|
|
my $decl_type = $self->decl->type->idstrip;
|
|
%>
|
|
static gboolean dissect_xdr_<%= $ident %>(tvbuff_t *tvb, proto_tree *tree, XDR *xdrs, int hf)
|
|
{
|
|
gboolean rc = TRUE;
|
|
goffset start;
|
|
<%= $decl_type %> type = 0;
|
|
|
|
start = xdr_getpos(xdrs);
|
|
if (!xdr_<%= $decl_type %>(xdrs, &type))
|
|
return FALSE;
|
|
switch (type) {
|
|
<% for my $cs (@{ $self->case_specs }) {
|
|
my ($vals, $decl) = @$cs;
|
|
%>
|
|
<% for my $v (@$vals) { %>
|
|
case <%= $v %>:
|
|
<% } %>
|
|
hf = <%= $c->rinc('hf_'.$ident.'__'.$decl->ident) %>;
|
|
rc = <%= $decl->type->render_caller($ident.'__'.$decl->ident) %>; break;
|
|
<% } %>
|
|
}
|
|
if (!rc) {
|
|
proto_tree_add_item(tree, hf_libvirt_unknown, tvb, start, -1, ENC_NA);
|
|
}
|
|
return rc;
|
|
}
|
|
@@ macro.hfvars
|
|
#define VIR_DYNAMIC_HFSET \
|
|
<% for my $prog (@{ $_->{programs} }) { %>
|
|
{ &hf_<%= $prog %>_procedure,\
|
|
{ "procedure", "libvirt.procedure",\
|
|
FT_INT32, BASE_DEC,\
|
|
VALS(<%= $prog %>_procedure_strings), 0x0,\
|
|
NULL, HFILL}\
|
|
},\
|
|
<% } %>
|
|
<% for my $hf (@{ $_->{hfvars} }) { %>
|
|
{ &<%= $hf->{segment}{sym} %>,\
|
|
{ "<%= $hf->{name} %>", "libvirt.<%= $hf->{abbrev} %>",\
|
|
FT_<%= $hf->{ft_type} %>, BASE_<%= $hf->{hf_base} %>,\
|
|
NULL, 0x0,\
|
|
NULL, HFILL}\
|
|
},\
|
|
<% } %>
|
|
/* End of #define VIR_DYNAMIC_HFSET */
|
|
|
|
@@ macro.ettvars
|
|
#define VIR_DYNAMIC_ETTSET \
|
|
<% for my $ett (@{ $_->{ettvars} }) { %>
|
|
&<%= $ett %>,\
|
|
<% } %>
|
|
/* End of #define VIR_DYNAMIC_ETTSET */
|
|
|
|
@@ code.dissectorlist
|
|
static const vir_dissector_index_t <%= $_->{name} %>_dissectors[] = {
|
|
<% for my $d (@{ $_->{dissectors} }) { %>
|
|
{ <%= $d->{value} %>, <%= $d->{args} %>, <%= $d->{ret} %>, <%= $d->{msg} %> },
|
|
<% } %>
|
|
};
|
|
static const gsize <%= $_->{name} %>_dissectors_len = array_length(<%= $_->{name} %>_dissectors);
|
|
@@ code.procedure_strings
|
|
static const value_string <%= $_->{name} %>_procedure_strings[] = {
|
|
<% for my $proc (@{ $_->{procedures} }) {
|
|
my $ident = $proc->ident;
|
|
$ident =~ s/^$_->{name}_proc_//i;
|
|
%>
|
|
{ <%= $proc->value %>, "<%= $ident %>" },
|
|
<% } %>
|
|
{ 0, NULL }
|
|
};
|
|
@@ code.program_strings
|
|
static const value_string program_strings[] = {
|
|
<% for my $prog (map uc, @{ $_->{programs} }) { %>
|
|
{ <%= $c->symbol("$prog\_PROGRAM")->value %>, "<%= $prog %>" },
|
|
<% } %>
|
|
{ 0, NULL }
|
|
};
|
|
@@ code.program_data
|
|
static const void *program_data[][VIR_PROGRAM_LAST] = {
|
|
<% for my $p (@{ $_->{programs} }) { %>
|
|
{ &hf_<%= $p %>_procedure, <%= $p %>_procedure_strings, <%= $p %>_dissectors, &<%= $p %>_dissectors_len },
|
|
<% } %>
|
|
};
|
|
|
|
static const void *
|
|
get_program_data(guint32 prog, enum vir_program_data_index index)
|
|
{
|
|
if (index < VIR_PROGRAM_LAST) {
|
|
switch (prog) {
|
|
<% my $i = 0; %>
|
|
<% for my $prog (@{ $_->{programs} }) { %>
|
|
case <%= uc($prog) %>_PROGRAM:
|
|
return program_data[<%= $i++ %>][index];
|
|
<% } %>
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|