#!/usr/bin/perl
#############################################################################
## Crytek Source File
## Copyright (C) 2006, Crytek Studios
##
## Creator: Sascha Demetrio
## Date: Jul 13, 2007
## Description: GNU-make based build system
#############################################################################

# This script reads an element file written by the CryCG utility and
# extracts/converts information for the make environment.

# Description of the element file format read by the script:
#
# All lines consisting only of whitespace and lines where the first
# non-whitespace character is a hash ('#', comment lines) are ignored.
#
# A line containing an element definition starts with a single alphanumeric
# character indicating the type of element.  The following element types are
# recognized:
#
# V  External variable.
# v  Static variable.
# I  Instance variable.
# i  Class variable.
# F  External function.
# f  Static function.
# M  Instance method.
# m  Class method.
# C  Compound type (class, struct, or union).
# E  Enum type.
# T  Typedef type.
# U  A translation unit.  Translation units are a special case with a unique
#    parameter format, see below.
#
# Following the element type, 9 positional parameters follow.  These
# positional parameters are either scalar or lists of scalars.  A list of
# scalars is enclosed in curly braces.  Scalars are either integers,
# strings, or enumerated identitiers.  All integers are signed.
#
# Element parameters:
# - The element ID.  This is a unique integer value (within the associated
#   index file) identifying the element.
# - The element name.
# - A list of element dependencies.  Every dependency is represented as a
#   dependency type enumeration constant followed by the element ID of the
#   element.  The dependency type is one of the following:
#   LL - DECL/DECL dependency.
#   LF - DECL/DEF dependency.
#   FL - DEF/DECL dependency.
#   FF - DEF/DEF dependency.
# - The ID of the associated translation unit.
# - The ID of the tree node within the associated translation unit.
# - The element ID of the context of the element.  -1 if the element does not
#   have a context element.
# - A list of children of the element.  The list contains the element IDs of
#   the children.
# - A flag string.  The presence of a flag character in the string indicating
#   that the associated flag is set.  The following flag character may appear
#   in the string:
#   D - A definition of the element is available.
#   C - A CFG (control flow graph) of the element is available (relevant only
#       for functions and methods).
#   P - A function or method is considered primitive.
#   T - The element is being traced for debugging.
# - A list of attribute strings.  Attribute strings are formed as
#   "KEY=VALUE", where KEY is a valid C/C++ identitier and VALUE is arbitrary
#   (typically a comma separated string).  Note: The only KEY supported at
#   present is 'entry' (indicating an entry point of an SPU job).
#
# Translation unit parameters:
# - The ID of the translation unit.  This ID is unique within the generated
#   element file and is used only for the purpose of referring to translation
#   units.  It is otherwise meaningless.
# - The name of the C/C++ source file associated with the translation unit.
# - The name of the CryCG translation unit file.
#
# Integer scalars are encoded in plain decimal, string are encoded using the
# notation 'sLENGTH(STRING)' where LENGTH is the length of the string (in
# decimal) and STRING is the raw (unquoted) string.
#
# In an element file, all translation units are listed before any other
# elements.

use warnings;
use strict;

use Getopt::Std;

##############################################################################
# Module boilerplate.

BEGIN
{
  use Exporter ();
  our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

  $VERSION = 1.00;
  @ISA = qw(Exporter);
  @EXPORT = qw(&Element::new);
  %EXPORT_TAGS = ( );
  @EXPORT_OK = qw();
}
our @EXPORT_OK;

END { }

##############################################################################
# Parser utility functions.

# Get a decoded string.
#
# Parameters:
# - The string to be parsed.
#
# Returns:
# - The decoded string, or 'undef' in case of an error.
# - The suffix of the parsed string.
sub getString ($)
{
  my $string = shift;

  if ($string =~ /^\s*s([0-9]+)\(/)
  {
    my $length = $1;
    my $prefix = $&;
    my $value = substr($string, length $prefix, $length);
    $string = substr($string, length($prefix) + $length + 1);
    return $value, $string;
  }
  else
  {
    return undef, $string;
  }
}

# Get a token.
#
# Parameters:
# - The string to be parsed.
#
# Returns:
# - The token string, or 'undef' in case of an error.
# - The suffix of the parsed string.
sub getToken ($)
{
  my $string = shift;

  if ($string =~ /^\s*(\w+)/)
  {
    my $match = $&;
    my $value = $1;
    $string = substr($string, length($match));
    return $value, $string;
  }
  else
  {
    return undef, $string;
  }
}

# Get a number.
#
# Parameters:
# - The string to be parsed.
#
# Returns:
# - The number, or 'undef' in case of an error.
# - The suffix of the parsed string.
sub getNumber ($)
{
  my $string = shift;

  if ($string =~ /^\s*(-?\d+)/)
  {
    my $match = $&;
    my $value = $1 + 0;
    $string = substr($string, length($match));
    return $value, $string;
  }
  else
  {
    return undef, $string;
  }
}

# Get a sub-attribute from an attribute string.
#
# Parameters:
# - The attribute string.
# - The name of the requested sub-attribute.
#
# Returns:
# The value of the requested sub-attribute or 'undef' if the attribute is not
# found.
sub getSubAttr ($$)
{
  my $attrString = shift;
  my $attrName = shift;
  my @attrList = split /\s*,\s*/, $attrString;
  my $attr;

  foreach $attr (@attrList)
  {
    $attr =~ /^\s*(\w+)\s*=\s*(.+)$/;
    my ($name, $value) = ($1, $2);
    if ($name eq $attrName) { return $value; }
  }
  return undef;
}

##############################################################################
# Class 'Unit' represents a translation unit.

sub Unit::new ($$)
{
  my $class = shift;
  my $spec = shift;
  my $self = { };

  $self->{ID} = undef;
  $self->{SOURCE_FILE} = undef;
  $self->{UNIT_FILE} = undef;
  bless($self, $class);
  $self->init($spec);
  return $self;
}

sub Unit::init ($$)
{
  my $self = shift;
  my $spec = shift;
  my ($token, $id, $sourceFileName, $unitFileName);

  ($token, $spec) = getToken $spec;
  defined $token or die "invalid unit spec line '$spec' (token)";
  $token eq 'U' or die "spec line '$spec' not a unit spec";

  ($id, $spec) = getNumber $spec;
  defined $id or die "invalid unit spec line '$spec' (id)";

  ($sourceFileName, $spec) = getString $spec;
  defined $sourceFileName
    or die "invalid unit spec line '$spec' (source file)";

  ($unitFileName, $spec) = getString $spec;
  defined $unitFileName
    or die "invalid unit spec line '$spec' (unit file)";

  $self->{ID} = $id;
  $self->{SOURCE_FILE} = $sourceFileName;
  $self->{UNIT_FILE} = $unitFileName;
  return $self;
}

sub Unit::id ($) { return shift->{ID}; }
sub Unit::sourceFile ($) { return shift->{SOURCE_FILE}; }
sub Unit::unitFile ($) { return shift->{UNIT_FILE}; }

##############################################################################
# Class 'Element' represents an element within the translation unit.
#
# Instance of the 'Element' class only contain a subset of all fields provided
# in the element file.  More fields will be added as needed.

# Enumeration of element types.
my (
  $ET_NONE,
  $ET_EXTERNAL_VARIABLE,
  $ET_STATIC_VARIABLE,
  $ET_INSTANCE_VARIABLE,
  $ET_CLASS_VARIABLE,
  $ET_EXTERNAL_FUNCTION,
  $ET_STATIC_FUNCTION,
  $ET_INSTANCE_METHOD,
  $ET_CLASS_METHOD,
  $ET_COMPOUND_TYPE,
  $ET_ENUM_TYPE,
  $ET_TYPEDEF_TYPE
) = ( 0 .. 11 );

my %_Element_typeMap = (
  'V' => $ET_EXTERNAL_VARIABLE,
  'v' => $ET_STATIC_VARIABLE,
  'I' => $ET_INSTANCE_VARIABLE,
  'i' => $ET_CLASS_VARIABLE,
  'F' => $ET_EXTERNAL_FUNCTION,
  'f' => $ET_STATIC_FUNCTION,
  'M' => $ET_INSTANCE_METHOD,
  'm' => $ET_CLASS_METHOD,
  'C' => $ET_COMPOUND_TYPE,
  'E' => $ET_ENUM_TYPE,
  'T' => $ET_TYPEDEF_TYPE
);

sub Element::new ($$$)
{
  my $class = shift;
  my $spec = shift;
	my $unitSet = shift;
  my $self = { };

  $self->{TYPE} = undef;
  $self->{ID} = undef;
  $self->{NAME} = undef;
  $self->{ATTRS} = ( );
	$self->{UNIT} = undef;
  $self->{ET_MAP} = \%_Element_typeMap;
  bless($self, $class);
  $self->init($spec, $unitSet);
  return $self;
}

sub Element::init ($$$)
{
  my $self = shift;
  my $spec = shift;
	my $unitSet = shift;
  my ($token, $type, $id, $name, $unitId, $unit, %attributes, $value);
  my $typeMap = $self->{ET_MAP};

  ($token, $spec) = getToken $spec;
  defined $token or die "invalid element spec line '$spec' (token)";
  defined $typeMap->{$token}
    or die "unrecognized token '$token' in element spec line '$spec'";
  $type = $typeMap->{$token};

  ($id, $spec) = getNumber $spec;
  defined $id or die "invalid element spec line '$spec' (id)";

  ($name, $spec) = getString $spec;
  defined $name or die "invalid element spec line '$spec' (name)";

  $spec =~ s/^\s*\{[^}]*\}//
    or die "invalid element spec line '$spec' (deps)";

  ($unitId, $spec) = getNumber $spec;
  defined $unitId or die "invalid element spec line '$spec' (unit)";
	$unit = $unitSet->getUnit($unitId);
	defined $unit or die "invalid unit ID in spec line '$spec'";

  ($value, $spec) = getNumber $spec;
  defined $value or die "invalid element spec line '$spec' (node)";

  ($value, $spec) = getNumber $spec;
  defined $value or die "invalid element spec line '$spec' (context)";

  $spec =~ s/^\s*\{[^}]*\}//
    or die "invalid element spec line '$spec' (children)";

  ($value, $spec) = getString $spec;
  defined $value or die "invalid element spec line '$spec' (flags)";

  $spec =~ s/^\s*\{//
    or die "invalid element spec line '$spec' (attrs)";
  %attributes = ( );
  while (not $spec =~ s/^\s*\}//)
  {
    my $attr;
    ($attr, $spec) = getString $spec;
    defined $attr or die "invalid element spec line '%spec' (attrs)";
    $attr =~ /(\w+)=(.*)$/ or die "malformed element attribute '$attr'";
    my ($key, $value) = ($1, $2);
    $attributes{$key} = $value;
  }

  $self->{TYPE} = $type;
  $self->{ID} = $id;
  $self->{NAME} = $name;
	$self->{UNIT} = $unit;
  $self->{ATTRS} = \%attributes;
  return $self;
}

sub Element::type ($) { return shift->{TYPE}; }
sub Element::id ($) { return shift->{ID}; }
sub Element::name ($) { return shift->{NAME}; }
sub Element::unit ($) { return shift->{UNIT}; }
sub Element::attrs ($) { return shift->{ATTRS}; }

##############################################################################
# Class 'UnitSet' represents a set of translation units.

sub UnitSet::new ($)
{
  my $class = shift;
  my $self = { };

  $self->{INDEX_FILE} = undef;
  $self->{UNIT_MAP} = { };
  $self->{ELEMENT_MAP} = { };
  bless($self, $class);
  return $self;
}

sub UnitSet::load ($$)
{
  my $self = shift;
  my $elementFileName = shift;
  local *IN;

  open(IN, '<', $elementFileName)
    or die "Can not open element file '$elementFileName': $!";
  while (<IN>)
  {
    chomp;
    next if (/^\s*$/ or /^\s*#/);
    my $initial = substr($_, 0, 1);
    if ($initial eq 'U')
    {
      my $unit = Unit->new($_);
      $self->{UNIT_MAP}{$unit->id} = $unit;
    }
    else
    {
      my $element = Element->new($_, $self);
      $self->{ELEMENT_MAP}{$element->id} = $element;
    }
  }
}

# Get a list of function/method elements.
sub UnitSet::getFunctionElements ($)
{
  my $self = shift;
  my $element;
  my @list = ( );
  my $elementMap = $self->{ELEMENT_MAP};

  foreach $element (values %$elementMap)
  {
    my $type = $element->type;
    if ($type == $ET_EXTERNAL_FUNCTION
      or $type == $ET_STATIC_FUNCTION
      or $type == $ET_INSTANCE_METHOD
      or $type == $ET_CLASS_METHOD)
    {
      push @list, $element;
    }
  }
  return @list;
}

# Get a translation unit by ID.
sub UnitSet::getUnit ($$)
{
	my $self = shift;
	my $unitId = shift;
	my $unitMap = $self->{UNIT_MAP};

	if (not defined $unitMap->{$unitId}) { return undef; }
	return $unitMap->{$unitId};
}

# Tools/Elements.pm
# vim:ts=2:sw=2

