#!/usr/bin/perl -w
#
# $Id: gendobj,v 1.12 2002/04/11 19:11:07 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 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 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 (!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])/_$1/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])/_$1/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 (Object 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;
}