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