mirror of
https://gitlab.com/libvirt/libvirt.git
synced 2024-09-09 09:14:57 +00:00
In many files there are header comments that contain an Author: statement, supposedly reflecting who originally wrote the code. In a large collaborative project like libvirt, any non-trivial file will have been modified by a large number of different contributors. IOW, the Author: comments are quickly out of date, omitting people who have made significant contribitions. In some places Author: lines have been added despite the person merely being responsible for creating the file by moving existing code out of another file. IOW, the Author: lines give an incorrect record of authorship. With this all in mind, the comments are useless as a means to identify who to talk to about code in a particular file. Contributors will always be better off using 'git log' and 'git blame' if they need to find the author of a particular bit of code. This commit thus deletes all Author: comments from the source and adds a rule to prevent them reappearing. The Copyright headers are similarly misleading and inaccurate, however, we cannot delete these as they have legal meaning, despite being largely inaccurate. In addition only the copyright holder is permitted to change their respective copyright statement. Reviewed-by: Erik Skultety <eskultet@redhat.com> Signed-off-by: Daniel P. Berrangé <berrange@redhat.com>
1014 lines
28 KiB
Perl
Executable File
1014 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 http://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;
|
|
|
|
# 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 $ENV{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($ENV{PWD}, 'libvirt', "$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;
|
|
}
|
|
|
|
# Followings 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;
|
|
}
|