dfhack/plugins/ruby/codegen.pl

597 lines
17 KiB
Perl

2012-03-26 06:37:18 -06:00
#!/usr/bin/perl
use strict;
use warnings;
use XML::LibXML;
our @lines_rb;
2012-04-03 08:09:29 -06:00
my @lines_cpp;
my @include_cpp;
my %offsets;
2012-03-26 06:37:18 -06:00
sub indent_rb(&) {
my ($sub) = @_;
my @lines;
{
local @lines_rb;
$sub->();
@lines = map { " " . $_ } @lines_rb;
}
push @lines_rb, @lines
}
sub rb_ucase {
my ($name) = @_;
2012-03-31 17:33:30 -06:00
return $name if ($name eq uc($name));
2012-03-26 06:37:18 -06:00
return join("", map { ucfirst $_ } (split('_', $name)));
}
2012-04-02 11:00:38 -06:00
my %global_type_renderer = (
2012-03-31 17:33:30 -06:00
'enum-type' => \&render_global_enum,
'struct-type' => \&render_global_class,
'class-type' => \&render_global_class,
'bitfield-type' => \&render_global_bitfield,
);
2012-04-02 11:00:38 -06:00
my %item_renderer = (
2012-03-31 17:33:30 -06:00
'global' => \&render_item_global,
2012-04-02 11:00:38 -06:00
'number' => \&render_item_number,
2012-03-31 17:33:30 -06:00
'container' => \&render_item_container,
'compound' => \&render_item_compound,
2012-04-02 11:00:38 -06:00
'pointer' => \&render_item_pointer,
'static-array' => \&render_item_staticarray,
'primitive' => \&render_item_primitive,
'bytes' => \&render_item_bytes,
2012-03-26 06:37:18 -06:00
);
my %global_types;
2012-04-02 11:00:38 -06:00
2012-03-26 06:37:18 -06:00
sub render_global_enum {
my ($name, $type) = @_;
my $rbname = rb_ucase($name);
push @lines_rb, "class $rbname";
2012-03-26 06:37:18 -06:00
indent_rb {
2012-03-31 17:33:30 -06:00
render_enum_fields($type);
2012-03-26 06:37:18 -06:00
};
push @lines_rb, "end\n";
2012-03-26 06:37:18 -06:00
}
2012-03-31 17:33:30 -06:00
sub render_enum_fields {
my ($type) = @_;
my $value = -1;
my $idxname = 'ENUM';
push @lines_rb, "$idxname = Hash.new";
my %attr_type;
for my $attr ($type->findnodes('child::enum-attr')) {
my $rbattr = rb_ucase($attr->getAttribute('name'));
my $typeattr = $attr->getAttribute('type-name');
2012-04-26 12:55:52 -06:00
# find how we need to encode the attribute values: string, symbol (for enums), raw (number, bool)
if ($typeattr) {
if ($global_types{$typeattr}) {
$attr_type{$rbattr} = 'symbol';
} else {
$attr_type{$rbattr} = 'naked';
}
} else {
$attr_type{$rbattr} = 'quote';
}
my $def = $attr->getAttribute('default-value');
if ($def) {
$def = ":$def" if ($attr_type{$rbattr} eq 'symbol');
2012-04-26 12:55:52 -06:00
$def =~ s/'/\\'/g if ($attr_type{$rbattr} eq 'quote');
$def = "'$def'" if ($attr_type{$rbattr} eq 'quote');
push @lines_rb, "$rbattr = Hash.new($def)";
} else {
push @lines_rb, "$rbattr = Hash.new";
}
}
2012-03-31 17:33:30 -06:00
for my $item ($type->findnodes('child::enum-item')) {
$value = $item->getAttribute('value') || ($value+1);
my $elemname = $item->getAttribute('name'); # || "unk_$value";
if ($elemname) {
my $rbelemname = rb_ucase($elemname);
push @lines_rb, "$rbelemname = $value ; ${idxname}[$value] = :$rbelemname";
for my $iattr ($item->findnodes('child::item-attr')) {
my $ian = $iattr->getAttribute('name');
my $iav = $iattr->getAttribute('value');
my $rbattr = rb_ucase($ian);
$iav = ":$iav" if ($attr_type{$rbattr} eq 'symbol');
2012-04-26 12:55:52 -06:00
$iav =~ s/'/\\'/g if ($attr_type{$rbattr} eq 'quote');
$iav = "'$iav'" if ($attr_type{$rbattr} eq 'quote');
$lines_rb[$#lines_rb] .= " ; ${rbattr}[$value] = $iav";
}
2012-03-31 17:33:30 -06:00
}
}
}
2012-04-02 11:00:38 -06:00
2012-03-26 06:37:18 -06:00
sub render_global_bitfield {
my ($name, $type) = @_;
my $rbname = rb_ucase($name);
push @lines_rb, "class $rbname < MemHack::Compound";
2012-03-26 06:37:18 -06:00
indent_rb {
2012-03-31 17:33:30 -06:00
render_bitfield_fields($type);
2012-03-26 06:37:18 -06:00
};
push @lines_rb, "end\n";
2012-03-26 06:37:18 -06:00
}
2012-03-31 17:33:30 -06:00
sub render_bitfield_fields {
my ($type) = @_;
push @lines_rb, "field(:_whole, 0) {";
indent_rb {
render_item_number($type, '');
};
push @lines_rb, "}";
2012-03-31 17:33:30 -06:00
my $shift = 0;
for my $field ($type->findnodes('child::ld:field')) {
my $count = $field->getAttribute('count') || 1;
my $name = $field->getAttribute('name');
2012-04-26 12:55:52 -06:00
my $type = $field->getAttribute('type-name');
my $enum = rb_ucase($type) if ($type and $global_types{$type});
2012-03-31 17:33:30 -06:00
$name = $field->getAttribute('ld:anon-name') if (!$name);
print "bitfield $name !number\n" if (!($field->getAttribute('ld:meta') eq 'number'));
if ($count == 1) {
2012-04-06 11:30:58 -06:00
push @lines_rb, "field(:$name, 0) { bit $shift }" if ($name);
2012-04-26 12:55:52 -06:00
} elsif ($enum) {
push @lines_rb, "field(:$name, 0) { bits $shift, $count, :$enum }" if ($name);
2012-03-31 17:33:30 -06:00
} else {
2012-04-06 11:30:58 -06:00
push @lines_rb, "field(:$name, 0) { bits $shift, $count }" if ($name);
2012-03-31 17:33:30 -06:00
}
$shift += $count;
}
}
2012-04-02 11:00:38 -06:00
my $cpp_var_counter = 0;
2012-04-06 11:30:58 -06:00
my %seen_class;
2012-03-26 06:37:18 -06:00
sub render_global_class {
my ($name, $type) = @_;
2012-04-06 11:30:58 -06:00
my $rbname = rb_ucase($name);
# ensure pre-definition of ancestors
my $parent = $type->getAttribute('inherits-from');
render_global_class($parent, $global_types{$parent}) if ($parent and !$seen_class{$parent});
return if $seen_class{$name};
$seen_class{$name}++;
2012-04-27 06:13:44 -06:00
my $rtti_name;
if ($type->getAttribute('ld:meta') eq 'class-type') {
$rtti_name = $type->getAttribute('original-name') ||
$type->getAttribute('type-name') ||
$name;
}
my $rbparent = ($parent ? rb_ucase($parent) : 'MemHack::Compound');
2012-04-06 11:30:58 -06:00
2012-04-21 13:20:51 -06:00
my $cppns = "df::$name";
push @lines_cpp, "}" if @include_cpp;
push @lines_cpp, "void cpp_$name(FILE *fout) {";
2012-04-03 08:09:29 -06:00
push @include_cpp, $name;
2012-03-26 06:37:18 -06:00
2012-04-06 11:30:58 -06:00
push @lines_rb, "class $rbname < $rbparent";
2012-03-26 06:37:18 -06:00
indent_rb {
2012-04-21 13:20:51 -06:00
my $sz = query_cpp("sizeof($cppns)");
push @lines_rb, "sizeof $sz";
2012-04-27 06:13:44 -06:00
push @lines_rb, "rtti_classname :$rtti_name" if $rtti_name;
2012-04-21 13:20:51 -06:00
render_struct_fields($type, "$cppns");
2012-03-26 06:37:18 -06:00
};
push @lines_rb, "end\n";
2012-03-26 06:37:18 -06:00
}
2012-04-02 11:00:38 -06:00
sub render_struct_fields {
2012-04-21 13:20:51 -06:00
my ($type, $cppns) = @_;
2012-03-26 06:37:18 -06:00
2012-04-02 11:00:38 -06:00
for my $field ($type->findnodes('child::ld:field')) {
my $name = $field->getAttribute('name');
$name = $field->getAttribute('ld:anon-name') if (!$name);
if (!$name and $field->getAttribute('ld:anon-compound')) {
2012-04-21 13:20:51 -06:00
render_struct_fields($field, $cppns);
}
2012-04-02 11:00:38 -06:00
next if (!$name);
2012-04-21 13:20:51 -06:00
my $offset = get_offset($cppns, $name);
2012-03-31 17:33:30 -06:00
2012-04-02 11:00:38 -06:00
push @lines_rb, "field(:$name, $offset) {";
2012-03-31 17:33:30 -06:00
indent_rb {
2012-04-21 13:20:51 -06:00
render_item($field, "$cppns");
2012-03-31 17:33:30 -06:00
};
2012-04-02 11:00:38 -06:00
push @lines_rb, "}";
2012-03-31 17:33:30 -06:00
}
2012-03-26 06:37:18 -06:00
}
sub render_global_objects {
my (@objects) = @_;
my @global_objects;
my $sname = 'global_objects';
my $rbname = rb_ucase($sname);
push @lines_cpp, "}" if @include_cpp;
push @lines_cpp, "void cpp_$sname(FILE *fout) {";
push @include_cpp, $sname;
push @lines_rb, "class $rbname < MemHack::Compound";
indent_rb {
for my $obj (@objects) {
my $oname = $obj->getAttribute('name');
my $addr = "DFHack.get_global_address('$oname')";
push @lines_rb, "addr = $addr";
push @lines_rb, "if addr != 0";
indent_rb {
push @lines_rb, "field(:$oname, addr) {";
my $item = $obj->findnodes('child::ld:item')->[0];
indent_rb {
render_item($item, 'df::global');
};
push @lines_rb, "}";
};
push @lines_rb, "end";
push @global_objects, $oname;
}
};
push @lines_rb, "end";
indent_rb {
push @lines_rb, "Global = GlobalObjects.new._at(0)";
for my $obj (@global_objects) {
push @lines_rb, "def self.$obj ; Global.$obj ; end";
push @lines_rb, "def self.$obj=(v) ; Global.$obj = v ; end";
}
};
}
2012-04-02 11:00:38 -06:00
sub render_item {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-04-02 11:00:38 -06:00
return if (!$item);
my $meta = $item->getAttribute('ld:meta');
my $renderer = $item_renderer{$meta};
if ($renderer) {
2012-04-21 13:20:51 -06:00
$renderer->($item, $pns);
2012-03-26 06:37:18 -06:00
} else {
2012-04-02 11:00:38 -06:00
print "no render item $meta\n";
2012-03-26 06:37:18 -06:00
}
}
2012-04-02 11:00:38 -06:00
sub render_item_global {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-31 17:33:30 -06:00
2012-04-02 11:00:38 -06:00
my $typename = $item->getAttribute('type-name');
my $subtype = $item->getAttribute('ld:subtype');
2012-03-31 17:33:30 -06:00
if ($subtype and $subtype eq 'enum') {
2012-04-21 13:20:51 -06:00
render_item_number($item, $pns);
} else {
my $rbname = rb_ucase($typename);
push @lines_rb, "global :$rbname";
}
2012-03-31 17:33:30 -06:00
}
2012-04-02 11:00:38 -06:00
sub render_item_number {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-31 17:33:30 -06:00
2012-04-02 11:00:38 -06:00
my $subtype = $item->getAttribute('ld:subtype');
my $initvalue = $item->getAttribute('init-value');
2012-04-26 12:55:52 -06:00
my $typename = $item->getAttribute('type-name');
$typename = rb_ucase($typename) if $typename;
$typename = $pns if (!$typename and $subtype eq 'enum'); # compound enum
$initvalue = 1 if ($initvalue and $initvalue eq 'true');
2012-04-26 12:55:52 -06:00
$initvalue = ":$initvalue" if ($initvalue and $typename and $initvalue =~ /[a-zA-Z]/);
$initvalue ||= 'nil' if $typename;
$subtype = $item->getAttribute('base-type') if (!$subtype or $subtype eq 'enum' or $subtype eq 'bitfield');
2012-04-02 11:00:38 -06:00
$subtype = 'int32_t' if (!$subtype);
if ($subtype eq 'int64_t') {
push @lines_rb, 'number 64, true';
} elsif ($subtype eq 'uint32_t') {
push @lines_rb, 'number 32, false';
} elsif ($subtype eq 'int32_t') {
push @lines_rb, 'number 32, true';
} elsif ($subtype eq 'uint16_t') {
push @lines_rb, 'number 16, false';
} elsif ($subtype eq 'int16_t') {
push @lines_rb, 'number 16, true';
} elsif ($subtype eq 'uint8_t') {
push @lines_rb, 'number 8, false';
} elsif ($subtype eq 'int8_t') {
push @lines_rb, 'number 8, false';
} elsif ($subtype eq 'bool') {
push @lines_rb, 'number 8, true';
} elsif ($subtype eq 's-float') {
push @lines_rb, 'float';
return;
2012-03-31 17:33:30 -06:00
} else {
2012-04-02 11:00:38 -06:00
print "no render number $subtype\n";
return;
2012-03-31 17:33:30 -06:00
}
$lines_rb[$#lines_rb] .= ", $initvalue" if ($initvalue);
2012-04-26 12:55:52 -06:00
$lines_rb[$#lines_rb] .= ", :$typename" if ($typename);
2012-03-31 17:33:30 -06:00
}
2012-04-02 11:00:38 -06:00
sub render_item_compound {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-31 17:33:30 -06:00
2012-04-21 13:20:51 -06:00
my $cppns = $pns . '::' . $item->getAttribute('ld:typedef-name');
2012-04-02 11:00:38 -06:00
my $subtype = $item->getAttribute('ld:subtype');
if (!$subtype || $subtype eq 'bitfield') {
push @lines_rb, "compound {";
indent_rb {
if (!$subtype) {
2012-04-21 13:20:51 -06:00
render_struct_fields($item, $cppns);
2012-04-02 11:00:38 -06:00
} else {
render_bitfield_fields($item);
}
};
push @lines_rb, "}"
} elsif ($subtype eq 'enum') {
2012-04-26 12:55:52 -06:00
my @namecomponents = split('::', $cppns);
shift @namecomponents;
my $enumclassname = join('_', map { rb_ucase($_) } @namecomponents);
push @lines_rb, "class ::DFHack::$enumclassname";
indent_rb {
# declare constants
render_enum_fields($item);
};
push @lines_rb, "end\n";
2012-04-02 11:00:38 -06:00
# actual field
2012-04-26 12:55:52 -06:00
render_item_number($item, $enumclassname);
2012-03-31 17:33:30 -06:00
} else {
2012-04-02 11:00:38 -06:00
print "no render compound $subtype\n";
2012-03-31 17:33:30 -06:00
}
}
2012-04-02 11:00:38 -06:00
sub render_item_container {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-26 06:37:18 -06:00
2012-04-02 11:00:38 -06:00
my $subtype = $item->getAttribute('ld:subtype');
my $rbmethod = join('_', split('-', $subtype));
my $tg = $item->findnodes('child::ld:item')->[0];
my $indexenum = $item->getAttribute('index-enum');
if ($tg) {
if ($rbmethod eq 'df_linked_list') {
push @lines_rb, "$rbmethod {";
} else {
2012-04-21 13:20:51 -06:00
my $tglen = get_tglen($tg, $pns);
push @lines_rb, "$rbmethod($tglen) {";
}
2012-04-02 11:00:38 -06:00
indent_rb {
2012-04-21 13:20:51 -06:00
render_item($tg, $pns);
2012-04-02 11:00:38 -06:00
};
push @lines_rb, "}";
} elsif ($indexenum) {
$indexenum = rb_ucase($indexenum);
push @lines_rb, "$rbmethod(:$indexenum)";
2012-04-02 11:00:38 -06:00
} else {
push @lines_rb, "$rbmethod";
2012-03-26 06:37:18 -06:00
}
}
2012-04-02 11:00:38 -06:00
sub render_item_pointer {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-31 17:33:30 -06:00
2012-04-02 11:00:38 -06:00
my $tg = $item->findnodes('child::ld:item')->[0];
my $ary = $item->getAttribute('is-array');
if ($ary and $ary eq 'true') {
2012-04-21 13:20:51 -06:00
my $tglen = get_tglen($tg, $pns);
push @lines_rb, "pointer_ary($tglen) {";
} else {
push @lines_rb, "pointer {";
}
2012-04-02 11:00:38 -06:00
indent_rb {
2012-04-21 13:20:51 -06:00
render_item($tg, $pns);
2012-04-02 11:00:38 -06:00
};
push @lines_rb, "}";
2012-03-31 17:33:30 -06:00
}
2012-04-02 11:00:38 -06:00
sub render_item_staticarray {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-31 17:33:30 -06:00
2012-04-02 11:00:38 -06:00
my $count = $item->getAttribute('count');
my $tg = $item->findnodes('child::ld:item')->[0];
2012-04-21 13:20:51 -06:00
my $tglen = get_tglen($tg, $pns);
my $indexenum = $item->getAttribute('index-enum');
if ($indexenum) {
$indexenum = rb_ucase($indexenum);
push @lines_rb, "static_array($count, $tglen, :$indexenum) {";
} else {
push @lines_rb, "static_array($count, $tglen) {";
}
2012-04-02 11:00:38 -06:00
indent_rb {
2012-04-21 13:20:51 -06:00
render_item($tg, $pns);
2012-04-02 11:00:38 -06:00
};
push @lines_rb, "}";
2012-03-31 17:33:30 -06:00
}
sub render_item_primitive {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-31 17:33:30 -06:00
my $subtype = $item->getAttribute('ld:subtype');
if ($subtype eq 'stl-string') {
2012-04-02 11:00:38 -06:00
push @lines_rb, "stl_string";
2012-03-31 17:33:30 -06:00
} else {
2012-04-02 11:00:38 -06:00
print "no render primitive $subtype\n";
2012-03-31 17:33:30 -06:00
}
}
2012-04-02 11:00:38 -06:00
sub render_item_bytes {
2012-04-21 13:20:51 -06:00
my ($item, $pns) = @_;
2012-03-26 06:37:18 -06:00
2012-04-02 11:00:38 -06:00
my $subtype = $item->getAttribute('ld:subtype');
if ($subtype eq 'padding') {
} elsif ($subtype eq 'static-string') {
my $size = $item->getAttribute('size');
push @lines_rb, "static_string($size)";
2012-03-31 17:33:30 -06:00
} else {
2012-04-02 11:00:38 -06:00
print "no render bytes $subtype\n";
2012-03-31 17:33:30 -06:00
}
}
2012-04-03 08:09:29 -06:00
sub get_offset {
2012-04-21 13:20:51 -06:00
my ($cppns, $fname) = @_;
2012-04-03 08:09:29 -06:00
2012-04-21 13:20:51 -06:00
return query_cpp("offsetof($cppns, $fname)");
2012-04-03 08:09:29 -06:00
}
2012-04-02 11:00:38 -06:00
sub get_tglen {
2012-04-21 13:20:51 -06:00
my ($tg, $cppns) = @_;
2012-04-03 08:09:29 -06:00
if (!$tg) {
return 'nil';
2012-04-03 08:09:29 -06:00
}
2012-03-31 17:33:30 -06:00
2012-04-02 11:00:38 -06:00
my $meta = $tg->getAttribute('ld:meta');
if ($meta eq 'number') {
return $tg->getAttribute('ld:bits')/8;
} elsif ($meta eq 'pointer') {
return 4;
2012-04-21 13:20:51 -06:00
} elsif ($meta eq 'container') {
my $subtype = $tg->getAttribute('ld:subtype');
if ($subtype eq 'stl-vector') {
return query_cpp("sizeof(std::vector<int>)");
} elsif ($subtype eq 'df-linked-list') {
return 12;
} else {
print "cannot tglen container $subtype\n";
}
} elsif ($meta eq 'compound') {
my $cname = $tg->getAttribute('ld:typedef-name');
return query_cpp("sizeof(${cppns}::$cname)");
} elsif ($meta eq 'static-array') {
my $count = $tg->getAttribute('count');
my $ttg = $tg->findnodes('child::ld:item')->[0];
my $ttgl = get_tglen($ttg, $cppns);
if ($ttgl =~ /^\d+$/) {
return $count * $ttgl;
} else {
return "$count*$ttgl";
}
} elsif ($meta eq 'global') {
my $typename = $tg->getAttribute('type-name');
my $subtype = $tg->getAttribute('ld:subtype');
if ($subtype and $subtype eq 'enum') {
my $base = $tg->getAttribute('base-type') || 'int32_t';
if ($base eq 'int32_t') {
return 4;
} elsif ($base eq 'int16_t') {
return 2;
} elsif ($base eq 'int8_t') {
return 1;
} else {
print "cannot tglen enum $base\n";
}
} else {
return query_cpp("sizeof(df::$typename)");
}
} elsif ($meta eq 'primitive') {
my $subtype = $tg->getAttribute('ld:subtype');
if ($subtype eq 'stl-string') {
return query_cpp("sizeof(std::string)");
} else {
print "cannot tglen primitive $subtype\n";
}
2012-03-31 17:33:30 -06:00
} else {
2012-04-21 13:20:51 -06:00
print "cannot tglen $meta\n";
2012-03-31 17:33:30 -06:00
}
}
2012-03-26 06:37:18 -06:00
2012-04-21 13:20:51 -06:00
my %query_cpp_cache;
2012-04-03 08:09:29 -06:00
sub query_cpp {
my ($query) = @_;
my $ans = $offsets{$query};
return $ans if (defined($ans));
2012-04-03 08:09:29 -06:00
2012-04-21 13:20:51 -06:00
my $cached = $query_cpp_cache{$query};
return $cached if (defined($cached));
$query_cpp_cache{$query} = 1;
push @lines_cpp, " fprintf(fout, \"%s = %d\\n\", \"$query\", $query);";
2012-04-03 08:09:29 -06:00
return "'$query'";
}
2012-03-26 06:37:18 -06:00
my $input = $ARGV[0] || '../../library/include/df/codegen.out.xml';
2012-04-03 08:09:29 -06:00
# run once with output = 'ruby-autogen.cpp'
# compile
# execute, save output to 'ruby-autogen.offsets'
# re-run this script with output = 'ruby-autogen.rb' and offsetfile = 'ruby-autogen.offsets'
# delete binary
# delete offsets
my $output = $ARGV[1] or die "need output file";
my $offsetfile = $ARGV[2];
2012-04-06 11:59:11 -06:00
my $memstruct = $ARGV[3];
2012-04-03 08:09:29 -06:00
if ($offsetfile) {
2012-04-05 08:46:07 -06:00
open OF, "<$offsetfile";
while (my $line = <OF>) {
chomp($line);
my ($key, $val) = split(' = ', $line);
$offsets{$key} = $val;
2012-04-03 08:09:29 -06:00
}
2012-04-05 08:46:07 -06:00
close OF;
2012-04-03 08:09:29 -06:00
}
2012-03-26 06:37:18 -06:00
my $doc = XML::LibXML->new()->parse_file($input);
$global_types{$_->getAttribute('type-name')} = $_ foreach $doc->findnodes('/ld:data-definition/ld:global-type');
for my $name (sort { $a cmp $b } keys %global_types) {
my $type = $global_types{$name};
my $meta = $type->getAttribute('ld:meta');
2012-04-02 11:00:38 -06:00
my $renderer = $global_type_renderer{$meta};
2012-03-26 06:37:18 -06:00
if ($renderer) {
$renderer->($name, $type);
} else {
print "no render global type $meta\n";
}
}
render_global_objects($doc->findnodes('/ld:data-definition/ld:global-object'));
2012-03-26 06:37:18 -06:00
2012-04-03 08:09:29 -06:00
open FH, ">$output";
if ($output =~ /\.cpp$/) {
2012-04-05 08:46:07 -06:00
print FH "#include \"DataDefs.h\"\n";
print FH "#include \"df/$_.h\"\n" for @include_cpp;
print FH "#include <stdio.h>\n";
2012-04-21 13:20:51 -06:00
print FH "#include <stddef.h>\n";
print FH "$_\n" for @lines_cpp;
print FH "}\n";
2012-04-05 08:46:07 -06:00
print FH "int main(int argc, char **argv) {\n";
print FH " FILE *fout;\n";
2012-04-05 08:46:07 -06:00
print FH " if (argc < 2) return 1;\n";
print FH " fout = fopen(argv[1], \"w\");\n";
print FH " cpp_$_(fout);\n" for @include_cpp;
print FH " fclose(fout);\n";
2012-04-05 08:46:07 -06:00
print FH " return 0;\n";
2012-04-03 08:09:29 -06:00
print FH "}\n";
2012-04-03 08:09:29 -06:00
} else {
2012-04-06 11:59:11 -06:00
if ($memstruct) {
open MH, "<$memstruct";
print FH "$_" while(<MH>);
close MH;
}
print FH "module DFHack\n";
2012-04-03 08:09:29 -06:00
print FH "$_\n" for @lines_rb;
2012-04-06 11:30:58 -06:00
print FH "end\n";
2012-04-03 08:09:29 -06:00
}
2012-03-26 06:37:18 -06:00
close FH;