File Coverage

xdr.yp

Criterion	Covered	Total	%
statement	78	122	63.9
branch	18	30	60.0
condition	3	5	60.0
subroutine	37	61	60.6
pod	2	2	100.0
total	138	220	62.7

%start specification

%{

%}


%%

specification:
    definitions
    | definitions TRAILING_COMMENT { [ @{ $_[1] }, $_[2] ] }
;

definitions:
    definition               { [ $_[1] ] }
    | definition definitions { unshift @{$_[2]}, $_[1]; $_[2] }
;

definition:
    PASSTHROUGH              { +{ def => 'passthrough', value => $_[1] } }
    | PREPROC                { +{ def => 'preprocessor', value => $_[1] } }
    | typeDef
    | constantDef
;

typeDef:
    'typedef' declaration ';'       {
                  +{ def => 'typedef',
                     name => delete $_[2]->{name},
                     definition => $_[2],
                     comments => $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[3]->{comments} } }
    | 'enum' IDENT enumBody ';'     {
                  +{ def => 'enum',
                     name => $_[2],
                     definition => {
                         type => { spec => 'enum', declaration => $_[3] }
                     },
                     comments => $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[4]->{comments} } }
    | 'struct' IDENT structBody ';' {
                  +{ def => 'struct',
                     name => $_[2],
                     definition => {
                         type => { spec => 'struct', declaration => $_[3] }
                     },
                     comments => delete $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[4]->{comments} } }
    | 'union' IDENT switch ';'   {
                  +{ def => 'union',
                     name => $_[2],
                     definition => {
                         type => { spec => 'union', declaration => $_[3] }
                     },
                     comments => $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[4]->{comments} } }
;

constantDef:
    'const' IDENT '=' CONST ';'      {
                  # What to do with comments before the '=' sign?
                  +{ def => 'const',
                     name => $_[2],
                     value => $_[4],
                     type => 'numeric',
                     comments => $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[5]->{comments} } }
    | 'const' IDENT '=' IDENT ';'    {
                  # What to do with comments before the '=' sign?
                  +{ def => 'const',
                     name => $_[2],
                     value => $_[4],
                     type => 'symbolic',
                     comments => $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[5]->{comments} } }
;

switch:
    'switch' '(' declaration ')' '{' caseBody '}' {
                  +{ discriminator => {
                        name => delete $_[3]->{name},
                        declaration => $_[3],
                        comments => $_[2]->{comments},
                        trailing_comments => $_[4]->{comments}
                     },
                     members => {
                        cases => $_[6]->{clauses},
                        default => $_[6]->{default},
                        comments => $_[5]->{comments},
                        location => $_[5]->{location},
                        trailing_comments => $_[7]->{comments}
                     },
                     comments => $_[1]->{comments},
                     location => $_[1]->{location},
                     trailing_comments => $_[7]->{comments} } }
;

caseBody:
    caseClauses                 { +{ clauses => $_[1] } }
    | caseClauses defaultClause { +{ clauses => $_[1], default => $_[2] } }
;

caseClauses:
    caseClause                  { [ $_[1] ] }
    | caseClause caseClauses    { unshift @{ $_[2] }, $_[1]; $_[2] }
;

caseClause:
    'case' value ':' declaration ';' {
            $_[2]->{trailing_comments} = $_[3]->{comments};
            +{ value => $_[2],
               name => delete $_[4]->{name},
               declaration => $_[4],
               comments => $_[1]->{comments},
               location => $_[1]->{location},
               trailing_comments => $_[5]->{comments} } }
;

defaultClause:
    'default' ':' declaration ';'    {
            # What to do with comments on the ':'?
            +{ name => delete $_[3]->{name},
               declaration => $_[3],
               comments => $_[1]->{comments},
               location => $_[1]->{location},
               trailing_comments => $_[4]->{comments} } }
;

structBody:
    '{' structItems '}'         { +{ members => $_[2],
                                     comments => $_[1]->{comments},
                                     location => $_[1]->{location},
                                     trailing_comments => $_[3]->{comments} } }
;

structItems:
    structItem                  { [ $_[1] ] }
    | structItem structItems    { unshift @{ $_[2] }, $_[1]; $_[2] }
;

structItem:
    declaration ';'             {
            +{ name => delete $_[1]->{name},
               declaration => $_[1],
               trailing_comments => $_[2]->{comments} } }
;

enumBody:
    '{' enumItems '}'           { +{ elements => $_[2],
                                     comments => $_[1]->{comments},
                                     location => $_[1]->{location},
                                     trailing_comments => $_[3]->{comments} } }
;

enumItems:
    enumItem                    { [ $_[1] ] }
    | enumItem ',' enumItems    { $_[1]->{trailing_comments} = $_[2]->{comments};
                                  unshift @{ $_[3] }, $_[1]; $_[3] }
;

enumItem:
    IDENT '=' value             {
        # What to do with comments on the '=' sign?
        $_[1]->{trailing_comments} = $_[2]->{comments};
        +{ name => $_[1],
           value => $_[3],
           comments => delete $_[1]->{comments},
           location => $_[1]->{location} } }
;

typeSpecifier:
    'int'                      { +{ spec => 'primitive', name => 'int', unsigned => 0, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'unsigned'               { +{ spec => 'primitive', name => 'int', unsigned => 1, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'unsigned' 'int'         { +{ spec => 'primitive', name => 'int', unsigned => 1, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'char'                   { +{ spec => 'primitive', name => 'char', unsigned => 0, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'unsigned' 'char'        { +{ spec => 'primitive', name => 'char', unsigned => 1, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'short'                  { +{ spec => 'primitive', name => 'short', unsigned => 0, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'unsigned' 'short'       { +{ spec => 'primitive', name => 'short', unsigned => 1, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'long'                   { +{ spec => 'primitive', name => 'long', unsigned => 0, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'unsigned' 'long'        { +{ spec => 'primitive', name => 'long', unsigned => 1, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'hyper'                  { +{ spec => 'primitive', name => 'hyper', unsigned => 0, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'unsigned' 'hyper'       { +{ spec => 'primitive', name => 'hyper', unsigned => 1, comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'float'                  { +{ spec => 'primitive', name => 'float', comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'double'                 { +{ spec => 'primitive', name => 'double', comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'quadruple'              { +{ spec => 'primitive', name => 'quadruple', comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'bool'                   { +{ spec => 'primitive', name => 'bool', comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
    | 'enum' enumBody          { +{ spec => 'enum', declaration => $_[2], comments => $_[1]->{comments}, location => $_[1]->{location} } }
    | 'struct' structBody      { +{ spec => 'struct', declaration => $_[2], comments => $_[1]->{comments}, location => $_[1]->{location} } }
    | 'union' switch           { +{ spec => 'union', declaration => $_[2], comments => $_[1]->{comments}, location => $_[1]->{location} } }
    | IDENT                    { +{ spec => 'named', name => $_[1], comments => delete $_[1]->{comments}, location => $_[1]->{location} } }
;

value:
   CONST
   | IDENT
;

declaration:
   typeSpecifier IDENT                 {
            +{ name => $_[2],
               type => $_[1],
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | typeSpecifier IDENT '[' value ']' {
            +{ name => $_[2],
               type => $_[1],
               array => 1,
               count => $_[4],
               variable => 0,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | typeSpecifier IDENT '<' '>'       {
            +{ name => $_[2],
               type => $_[1],
               array => 1,
               max  => undef,
               variable => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | typeSpecifier IDENT '<' value '>' {
            +{ name => $_[2],
               type => $_[1],
               array => 1,
               max  => $_[4],
               variable => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | 'opaque' IDENT '[' value ']'      {
            +{ name => $_[2],
               type => { spec => 'primitive', name => $_[1] },
               count => $_[4],
               variable => 0,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | 'opaque' IDENT '<' '>'            {
            +{ name => $_[2],
               type => { spec => 'primitive', name => $_[1] },
               max  => undef,
               variable => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | 'opaque' IDENT '<' value '>'      {
            +{ name => $_[2],
               type => { spec => 'primitive', name => $_[1] },
               max  => $_[4],
               variable => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | 'string' IDENT '<' '>'            {
            +{ name => $_[2],
               type => { spec => 'primitive', name => $_[1] },
               max  => undef,
               variable => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | 'string' IDENT '<' value '>'      {
            +{ name => $_[2],
               type => { spec => 'primitive', name => $_[1] },
               max  => $_[4],
               variable => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | typeSpecifier '*' IDENT           {
            +{ name => $_[3],
               type => $_[1],
               pointer => 1,
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
   | 'void'                            {
            +{ type => { spec => 'primitive', name => $_[1] },
               comments => delete $_[1]->{comments},
               location => $_[1]->{location} } }
;


%%


sub _Lexer {
  my ($fh, $parser) = @_;
  my $yydata = $parser->YYData;
  my @comments;
  my $comment;
  my $comment_start;

  $yydata->{LINENO} //= 0;
  while (1) {
    unless ($yydata->{INPUT}) {
       $yydata->{INPUT} = <$fh>;
       $yydata->{LINENO}++;
       $yydata->{COLNO} = 1;

       if (@comments and not $yydata->{INPUT}) {
           return ('TRAILING_COMMENT', {
               content => '',
               comments => \@comments,
               location => $comment_start
           });
       }

       return ('', undef) unless $yydata->{INPUT};

       if ($yydata->{INPUT} =~ s/^(%.*)//) {
           return ('PASSTHROUGH', {
               content => $1,
               comments => \@comments,
               location => [ $yydata->{LINENO}, 1 ]
           });
       }
       if ($yydata->{INPUT} =~ s/^(#.*)//) {
           return ('PREPROC', {
               content => $1,
               comments => \@comments,
               location => [ $yydata->{LINENO}, 1 ]
           });
       }
    }

    $yydata->{INPUT} =~ s/^\s+//;
    $yydata->{COLNO} += length($&);
    next unless $yydata->{INPUT};

    my $token_start = [ $yydata->{LINENO}, $yydata->{COLNO} ];
    if ($yydata->{INPUT} =~ s|^/\*||) { # strip comments
       $yydata->{COLNO} += length($&);
       $comment = '';
       while (1) {
          if ($yydata->{INPUT} =~ s|(.*?)\*/||) {
            $yydata->{COLNO} += length($&);
            push @comments, { content => $comment . $1, location => $token_start };
            last;
          }
          $comment .= $yydata->{INPUT};
          $yydata->{INPUT} = <$fh>;
          $yydata->{LINENO}++;
          $yydata->{COLNO} = 1;
          die "Unclosed comment" unless $yydata->{INPUT};
       }
    }
    elsif ($yydata->{INPUT} =~ s/^(const|typedef|enum|union|struct|switch|case|default|unsigned|int|char|short|long|hyper|float|string|double|quadruple|bool|opaque|void)\b(?!_)//) {
      $yydata->{COLNO} += length($&);
      return ($1, {
          content => $1,
          comments => \@comments,
          location => $token_start
      });
    }
    elsif ($yydata->{INPUT} =~ s/^([a-z][a-z0-9_]*)//i) {
      $yydata->{COLNO} += length($&);
      return ('IDENT', {
          content => $1,
          comments => \@comments,
          location => $token_start
      });
    }
    elsif ($yydata->{INPUT} =~ s/^(-?\d+|0x[0-9a-f]+)(?=\b|$)//i) {
      $yydata->{COLNO} += length($&);
      return ('CONST', {
          content => $1,
          comments => \@comments,
          location => $token_start
      });
    }
    elsif ($yydata->{INPUT} =~ s/^(.)//) {
     $yydata->{COLNO} += length($&);
     return ($1, {
          content => $1,
          comments => \@comments,
          location => $token_start
      });
    }
    else {
      die "Remaining input: '$yydata->{INPUT}'";
    }
  }
}

sub _Error {
   my $tok = $_[0]->YYCurtok;
   my $val = $_[0]->YYCurval;
   my $line = $tok ? "line: $val->{location}->[0]" : 'at ';

   print STDERR "Parse error at '$val->{content}' (line: $line)\n";
}

sub parse {
  my ($self, $fh) = @_;

  $self->YYParse( yylex   => sub { _Lexer( $fh, @_ ); },
                  yyerror => \&_Error );
}

=head1 NAME

XDR::Parse - Creation of an AST of an XDR specification (RFC4506)

=head1 SYNOPSIS

  use XDR::Parse;
  use Data::Dumper;

  my $p = XDR::Parse->new;
  print Dumper( $p->parse( \*STDIN ) );

=head1 DESCRIPTION

This module contains a parser for the XDR (eXternal Data Representation)
language as defined in RFC4506.  The result is an abstract syntax tree
(AST) which can be used for further processing.

This module extends the supported integer types with C, C and
C, all of which seem to be supported by C, the tool consuming
XDR to generate remote applications.

=head2 AST

At the top level, the AST is an array of nodes which can be one of the
following, distinguished by the C key in the node's hash:

=over 8

=item * a 'pass through' instruction (C)

This type of nodes contains a line which starts with '%'; the instruction
to C to copy that line to output verbatim

=item * a preprocessor instruction (C)

This type of nodes contains a line which starts with '#'; C typically
invokes C to preprocess its input -- this module simply takes input and
parses that; input which hasn't been preprocessed may contain this type of node

=item * constant declarations (C)

=item * type declarations

Type definitions come in four subtypes C, C, C
and C

=item * trailing comment

Comments in the input are linked to the first syntax node following the comment;
files having comments between the last syntax and the end of the file, will
contain a special C node, which doesn't model syntax, but is
required to prevent loosing the last comments in the file.

=back

Each node in the tree -not just the toplevel - is a hash which may have any or
all of the following keys:

=over 8

=item * comments

Is an array containing all comments following the previous syntax node and
preceeding the one to which the comment(s) are attached

=item * location

Is an array of two elements: the line and column number of the beginning of the
syntax captured by that node

=item * trailing_comments

Trailing comments happen when a node encloses a scope with a termination which
itself is not included in the AST representation.  E.g. the closing ';' in a
C:

   typedef string our_string<> /* trailing comment */ ;

=back

=head3 Constant declarations

Constant declarations exist in two types, distinguished by the C key in
the node's hash:

=over 8

=item * C

  const my_const = 0x123;     # hexadecimal
  const my_other_const = 123; # decimal
  const my_third_const = 012; # octal

=item * C

  const the_const = my_other_const;

=back

=head3 Type declarations

Top level nodes with a C key valued C, C, C or
C define types of the named language construct. These nodes share the
following keys, in addition to the keys shared by all nodes:

=over 8

=item * name

Name of the type being defined.

=item * definition

The node making up the definition of the type, holding a C node with
two keys, C and C. The value of the C key is one of
C, C or C. The elements are specified by the content of
the C key.

=back

=head4 'typedef' declarations

This node is a 'declaration' node as documented in the section
'declaration' nodes below.

=head4 'enum' declarations

The C node of C definitions has a single key (C):
an array of nodes with C and C keys, one for each value defined
in the enum type.

=head4 'struct' declarations

Th C node of C definitions has a single key (C):
an array of nodes with C and C keys describing the members
of the struct type. For more details on the C node, see below.

=head4 'union' declarations

The C node of C definitions has a single key (C):
itself a node which contains a C and a C key.  The
discriminator node has a C and a C key; the C node
contains one or two keys: C and optionally C.  C is an
array of nodes defining the members of the union; each element consists of
three keys: C, C and . C is the value
associated with the discriminator, to indicate the current definition.
C is the name of the member. C contains the type declaration
for the member.

=head4 'declaration' nodes

These nodes contain a C key specifying the basic type of the declaration
as documented below under L,
with a number of modifiers:

=over 8

=item * pointer

Optional. Mutually exclusive with the C indicator.

=item * array

Optional. Mutually exclusive with the C indicator.

When the C boolean is true, the following additional keys may exist:

=over 8

=item * variable

Indicates whether the array is of variable length.

=item * max

Indicates the maximum number of items in the array. May be C, if no
maximum was specified.

Note: this value may be specified using symbolic constant.

=item * count

Indicates the exact number of items in the array, when C is false
or absent.

Note: this value may be specified using symbolic constant.

=back

=back

=head4 'type' nodes in declarations

These nodes either define an inline C, C or C, or refer to any
of the types defined in the standard or at the toplevel, as indiceted by the C
key using these values:

=over 8

=item * primitive

The value in the C key refers to a built-in type. When the named type is one
of the integer type (C, C, C, C or C), the type hash
contains the additional key C.

The primitive types C and C support the same additional keys as
arrays (C, C and C).  These apply to the data within them
and do not mean to define arrays of strings/"opaques".

=item * named

The value in the C key refers to a defined type.

=item * enum

Defines an inline enum through the type's C key.

=item * struct

Defines an inline struct through the type's C key.

=item * union

Defines an inline union through the type's C key.

=back

The node in the C key of the inline C, C and C
members follow the same pattern as documented in the respective sections on
declarations above.

=head1 METHODS

=head2 new

  my $parser = XDR::Parse->new;

=head2 parse

  my $ast = $parser->parse( \*STDIN );

=head2 YYParse (inherited)

=head1 LICENSE

This distribution may be used under the same terms as Perl itself.

=head1 AUTHOR

=over 8

=item * Erik Huelsmann

=back

=head1 SEE ALSO

L, L

=cut