Michael Bayne
56b0012782
git-svn-id: svn+ssh://src.earth.threerings.net/narya/trunk@2290 542714f4-19e9-0310-aa3c-eee0fc999fb1
307 lines
8.6 KiB
Perl
Executable File
307 lines
8.6 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
#
|
|
# $Id: gendobj,v 1.15 2003/02/26 17:54:55 mdb Exp $
|
|
#
|
|
# gendobj is used to generate DObject source file definitons basded on
|
|
# abbreviated declarations. Because DObject fields all have standard
|
|
# setter methods which automatically generate events in the distributed
|
|
# object system, it is convenient to generate these methods rather than
|
|
# implement them by hand.
|
|
|
|
use strict;
|
|
use Getopt::Long;
|
|
|
|
my $usage = "Usage: $0 [--verbose] [--force] <dobj_decl_files>\n";
|
|
|
|
# get our options
|
|
my $verbose;
|
|
my $force;
|
|
GetOptions("verbose" => \$verbose,
|
|
"force" => \$force);
|
|
|
|
die $usage unless (@ARGV);
|
|
|
|
my $source;
|
|
while ($source = shift) {
|
|
# massage the source file name into the destination file name
|
|
my $dest = $source;
|
|
$dest =~ s/.dobj$/.java/;
|
|
if ($dest !~ /.java$/) {
|
|
warn "Unable to infer target file name from original: $source\n";
|
|
next;
|
|
}
|
|
|
|
# if the destination file is newer than the source file, do nothing
|
|
my $dmtime = (stat($dest))[9];
|
|
my $smtime = (stat($source))[9];
|
|
if (!$force && (defined $dmtime) && ($dmtime > $smtime)) {
|
|
warn "Skipping $source as source is newer.\n" if ($verbose);
|
|
next;
|
|
}
|
|
|
|
# if the destination file already exists, slurp the existing CVS Id
|
|
# information out of it so that we can slip that into the new one
|
|
my $idstr;
|
|
if (-f $dest && open(IN, "$dest")) {
|
|
while (<IN>) {
|
|
if (/(\$[I][d]: .*\$)/) {
|
|
$idstr = $1;
|
|
}
|
|
}
|
|
close(IN);
|
|
}
|
|
|
|
if (!open(IN, "$source")) {
|
|
warn "Unable to open $source for reading: $!\n";
|
|
next;
|
|
}
|
|
|
|
print "Processing $source...\n" if ($verbose);
|
|
|
|
my @preamble;
|
|
my @classdecl;
|
|
my @classbody;
|
|
my @fields;
|
|
my $mode = "preamble";
|
|
|
|
while (<IN>) {
|
|
# swap in the parsed Id string if we have one
|
|
$_ =~ s/(\$[I][d]: .*\$)/$idstr/ if (defined $idstr);
|
|
|
|
if ($mode eq "preamble") {
|
|
# look to see if we're transitioning from the preamble to the
|
|
# class declaration
|
|
if (/^public class [A-Za-z]*/) {
|
|
$mode = "classbody";
|
|
|
|
# keep adding to classdecl until we find a line that
|
|
# contains a {
|
|
push(@classdecl, $_);
|
|
while ($_ !~ /{/) {
|
|
$_ = <IN>;
|
|
last if (! defined $_);
|
|
push(@classdecl, $_);
|
|
}
|
|
|
|
} else {
|
|
push (@preamble, $_);
|
|
}
|
|
|
|
} elsif ($mode eq "classbody") {
|
|
# if we've reached a line with just a } at the beginning, we
|
|
# stop reading the file
|
|
last if (/^}\s*$/);
|
|
|
|
# everything goes into the body
|
|
push (@classbody, $_);
|
|
|
|
# check to see if we're seeing a DObject field declaration
|
|
if (/^\s*public ([A-Za-z]+(\[\])*) ([A-Za-z]+)( = .*)?;\s*$/) {
|
|
print "Matched field [type=$1, field=$3]\n" if ($verbose);
|
|
push (@fields, [$1, $3]);
|
|
}
|
|
}
|
|
}
|
|
|
|
close(IN);
|
|
|
|
# generate the output file
|
|
if (!open(OUT, ">$dest")) {
|
|
warn "Unable to open $dest for writing: $!\n";
|
|
next;
|
|
}
|
|
|
|
print "Writing output to $dest...\n" if ($verbose);
|
|
|
|
print OUT join("", @preamble);
|
|
print OUT join("", @classdecl);
|
|
|
|
my $field;
|
|
foreach $field (@fields) {
|
|
print_dobj_constant($field->[0], $field->[1]);
|
|
}
|
|
|
|
print OUT join("", @classbody);
|
|
|
|
foreach $field (@fields) {
|
|
print_dobj_setters($field->[0], $field->[1]);
|
|
}
|
|
|
|
print OUT "}\n";
|
|
|
|
close(OUT);
|
|
}
|
|
|
|
sub print_dobj_constant
|
|
{
|
|
my ($type, $field) = @_;
|
|
|
|
# convert mixed case to upper with underscores
|
|
my $fcode = $field;
|
|
$fcode =~ s/([a-z])([A-Z])/$1_$2/g;
|
|
$fcode =~ tr/a-z/A-Z/;
|
|
|
|
print OUT <<EOF;
|
|
/** The field name of the <code>$field</code> field. */
|
|
public static final String $fcode = "$field";
|
|
|
|
EOF
|
|
}
|
|
|
|
sub print_dobj_setters
|
|
{
|
|
my ($type, $field) = @_;
|
|
|
|
# convert mixed case to upper with underscores
|
|
my $fcode = $field;
|
|
$fcode =~ s/([a-z])([A-Z])/$1_$2/g;
|
|
$fcode =~ tr/a-z/A-Z/;
|
|
|
|
my $cfield = $field;
|
|
$cfield =~ s/(\w)/\U$1/;
|
|
|
|
# some known types have special setters
|
|
if ($type =~ ".*Set") {
|
|
print OUT <<EOF;
|
|
|
|
/**
|
|
* Requests that the specified entry be added to the
|
|
* <code>$field</code> set. The set will not change until the event is
|
|
* actually propagated through the system.
|
|
*/
|
|
public void addTo$cfield (DSet.Entry elem)
|
|
{
|
|
requestEntryAdd($fcode, elem);
|
|
}
|
|
|
|
/**
|
|
* Requests that the entry matching the supplied key be removed from
|
|
* the <code>$field</code> set. The set will not change until the
|
|
* event is actually propagated through the system.
|
|
*/
|
|
public void removeFrom$cfield (Comparable key)
|
|
{
|
|
requestEntryRemove($fcode, key);
|
|
}
|
|
|
|
/**
|
|
* Requests that the specified entry be updated in the
|
|
* <code>$field</code> set. The set will not change until the event is
|
|
* actually propagated through the system.
|
|
*/
|
|
public void update$cfield (DSet.Entry elem)
|
|
{
|
|
requestEntryUpdate($fcode, elem);
|
|
}
|
|
|
|
/**
|
|
* Requests that the <code>$field</code> field be set to the
|
|
* specified value. Generally one only adds, updates and removes
|
|
* entries of a distributed set, but certain situations call for a
|
|
* complete replacement of the set value. The local value will be
|
|
* updated immediately and an event will be propagated through the
|
|
* system to notify all listeners that the attribute did
|
|
* change. Proxied copies of this object (on clients) will apply the
|
|
* value change when they received the attribute changed notification.
|
|
*/
|
|
public void set$cfield ($type $field)
|
|
{
|
|
this.$field = $field;
|
|
requestAttributeChange($fcode, $field);
|
|
}
|
|
EOF
|
|
|
|
} elsif ($type eq "OidList") {
|
|
print OUT <<EOF;
|
|
|
|
/**
|
|
* Requests that the specified oid be added to the
|
|
* <code>$field</code> oid list. The list will not change until the
|
|
* event is actually propagated through the system.
|
|
*/
|
|
public void addTo$cfield (int oid)
|
|
{
|
|
requestOidAdd($fcode, oid);
|
|
}
|
|
|
|
/**
|
|
* Requests that the specified oid be removed from the
|
|
* <code>$field</code> oid list. The list will not change until the
|
|
* event is actually propagated through the system.
|
|
*/
|
|
public void removeFrom$cfield (int oid)
|
|
{
|
|
requestOidRemove($fcode, oid);
|
|
}
|
|
EOF
|
|
|
|
} else {
|
|
my $value = wrap($type, $field);
|
|
print OUT <<EOF;
|
|
|
|
/**
|
|
* Requests that the <code>$field</code> field be set to the specified
|
|
* value. The local value will be updated immediately and an event
|
|
* will be propagated through the system to notify all listeners that
|
|
* the attribute did change. Proxied copies of this object (on
|
|
* clients) will apply the value change when they received the
|
|
* attribute changed notification.
|
|
*/
|
|
public void set$cfield ($type $field)
|
|
{
|
|
this.$field = $field;
|
|
requestAttributeChange($fcode, $value);
|
|
}
|
|
EOF
|
|
|
|
# add an element setter if this field is an array
|
|
if ($type =~ m:\[\]$:) {
|
|
my $etype = $type;
|
|
$etype =~ s:\[\]$::g;
|
|
my $value = wrap($etype, "value");
|
|
# this is perl; we're allowed to hack
|
|
my $cfieldat = $cfield . "At";
|
|
print OUT <<EOF;
|
|
|
|
/**
|
|
* Requests that the <code>index</code>th element of
|
|
* <code>$field</code> field be set to the specified value. The local
|
|
* value will be updated immediately and an event will be propagated
|
|
* through the system to notify all listeners that the attribute did
|
|
* change. Proxied copies of this object (on clients) will apply the
|
|
* value change when they received the attribute changed notification.
|
|
*/
|
|
public void set$cfieldat ($etype value, int index)
|
|
{
|
|
this.$field\[index\] = value;
|
|
requestElementUpdate($fcode, $value, index);
|
|
}
|
|
EOF
|
|
}
|
|
}
|
|
}
|
|
|
|
# we may need to wrap the field for certain types
|
|
sub wrap
|
|
{
|
|
my ($type, $field) = @_;
|
|
|
|
if ($type eq "boolean") {
|
|
return "new Boolean($field)";
|
|
} elsif ($type eq "byte") {
|
|
return "new Byte($field)";
|
|
} elsif ($type eq "short") {
|
|
return "new Short($field)";
|
|
} elsif ($type eq "int") {
|
|
return "new Integer($field)";
|
|
} elsif ($type eq "long") {
|
|
return "new Long($field)";
|
|
} elsif ($type eq "float") {
|
|
return "new Float($field)";
|
|
} elsif ($type eq "double") {
|
|
return "new Double($field)";
|
|
}
|
|
|
|
return $field;
|
|
}
|