#!/usr/bin/perl -w
#
# $Id: genservice,v 1.6 2004/10/13 19:29:12 andrzej Exp $
#
# This script is used to generate invocation service marshaller and
# unmarshaller classes based on invocation service interface definitions.

use strict;
use Getopt::Long;
use Template;
use File::Basename;
use POSIX qw(strftime);

# use Dumpvalue;

my $usage = "Usage: $0 [--verbose] [--force] [--classpath classpath] " .
"[--sourcedir sourcedir] <sourcedir/foo/bar/FooService.java> [...]\n";

# get our options
my $verbose;
my $force;
my $classpath;
my $sourcedir = ".";
GetOptions("verbose" => \$verbose,
           "force" => \$force,
           "classpath=s" => \$classpath,
           "sourcedir=s" => \$sourcedir,
           );

# some standard business
my $ISVC_CNAME = "com.threerings.presents.client.InvocationService";

# make sure we have at least one source file argument
die $usage unless (@ARGV);

# locate a few necessary other files
my $script = basename($0);
my $rootdir = dirname($0); $rootdir =~ s:bin$:.:g;
my $marshtmpl = "$rootdir/lib/marshaller.tmpl";
my $disptmpl = "$rootdir/lib/dispatcher.tmpl";

# now process our source files
my %imports;
my $srcfile;
my $spackage;

while ($srcfile = shift) {
    # do a quick check to see if the marshaller file is newer than the
    # service file in which case we can stop now
    my $tpath = $srcfile;
    $tpath =~ s/Service/Marshaller/;
    $tpath =~ s:/client/:/data/:;
    my $dmtime = (stat($tpath))[9];
    my $smtime = (stat($srcfile))[9];
    if (!$force && (defined $dmtime) && ($dmtime > $smtime)) {
        my @foo = split(/\//, $srcfile);
        my $rfile = pop @foo;
        warn "Skipping ...$rfile as generated files are up to date.\n"
            if ($verbose);
        next;
    }

    # convert the source file given on the command line to a class name
    open(SRC, "$srcfile") or die "$script: Unable to read '$srcfile': $!\n";
    while (<SRC>) {
        if (/^package (\S+);/) {
            $spackage = $1;
        }
    }
    $srcfile =~ m:/([^/]+)\.java$:;
    my $class = "$spackage.$1";

    # run javap on the interface class
    my $jpcp = (defined $classpath) ? "-classpath $classpath" : "";
    my $jpcmd = "/usr/local/j2sdk1.4.1/bin/javap $jpcp $class";

    # clear out the imports table
    %imports = ();

    my $ifcname;
    my @methods;
    my @listeners;
    my $listener;

    my $methcount = 1;
    my $lmethcount = 0;

    open(JPO, "$jpcmd|") or die "$script: Can't invoke '$jpcmd': $!\n";
    while (<JPO>) {
        if (/^public interface (\S+) extends ([^, ]+)/) {
            $ifcname = $1;
            $imports{$ifcname} = 1;
            my $sname = $2;

            # if this interface does not extend InvocationService, we
            # don't want to do nothin'
            die "$script: $ifcname does not extend " .
                "InvocationService\n (extends $sname).\n"
                if ($sname ne $ISVC_CNAME);

        } elsif (/^    public abstract void (\S+)\(([^\)]*)\)/) {
            my $methname = $1;
            my $rawargs = $2; $rawargs =~ s:\$:.:g;
            my @methargs = split(/, /, $rawargs);
            grab_imports(@methargs);
            my @trimmed_args = trim_args(@methargs);
            my @unwrap_args = @trimmed_args;
            shift @unwrap_args;
            push @methods, {
                "mname" => $methname,
                "mcode" => to_caps($methname),
                "mcodeval" => $methcount++,
                "arglist" => gen_arglist(@trimmed_args),
                "wrapped_args" => wrap_arglist(1, @trimmed_args),
                "unwrapped_args" => unwrap_arglist(@unwrap_args),
                "listener_args" => gen_listener_args(@trimmed_args),
            };

        } elsif (/^\s+public static interface \S+\. (\S+) extends (\S+)\. (\S+)/) {
            my $inner = $1;
            my $eouter = $2;
            my $einner = $3;

            if ($eouter ne $ISVC_CNAME) {
                warn "Unrecognized inner interface $inner (extends $2.$3). " .
                    "Skipping.\n";
                undef $listener;
                next;
            }

            die "$script: Invalid callback interface name $inner.\n" .
                "Must be of the form <foo>Listener\n"
                if ($inner !~ m/Listener$/);

            # create a new listener table to hold info on this listener class
            $inner =~ s:Listener$::;
            my @lmethods = ();
            $listener = {
                "name" => $inner,
                "methods" => \@lmethods,
            };
            push @listeners, $listener;
            $lmethcount = 0;

        } elsif (/^        public abstract void (\S+)\(([^\)]*)\)/) {
            my $methname = $1;
            my $rawargs = $2; $rawargs =~ s:\$:.:g;
            my @methargs = split(/, /, $rawargs);

            # skip this method declaration if we're not parsing a valid
            # listener inner interface declaration
            next unless (defined $listener);

            grab_imports(@methargs);
            my @trimmed_args = trim_args(@methargs);
            my $lmethod = {
                "mname" => $methname,
                "mcode" => to_caps($methname),
                "mcodeval" => ++$lmethcount,
                "arglist" => gen_arglist(@trimmed_args),
                "wrapped_args" => wrap_arglist(0, @trimmed_args),
                "unwrapped_args" => unwrap_arglist(@trimmed_args),
            };
            push @{$listener->{"methods"}}, $lmethod;

        } elsif (/^Compiled from/ ||
                 /ACC_SUPER/ ||
                 /^\s*[{}]\s*$/) {
            # skip it

        } else {
            warn "$script: ?: $_";
        }
    }

    die "$script: Unable to parse primary interface definition.\n"
        unless (defined $ifcname);

    print "$script: Processing $ifcname...\n";

    # extract the package name
    my $ifcpkg = $ifcname;
    $ifcpkg =~ s/\.[^.]*$//g;

    # extract the service name
    my $svcname = substr($ifcname, length($ifcpkg)+1);
    $svcname =~ s/Service$//g;
    die "$script: Unable to discern service name from $ifcname.\n".
        "Service interface definitions should be named <foo>Service.\n"
        if ($svcname eq $ifcname);

    # assume everything's in the same package to start
    my $marshpkg = $ifcpkg;
    my $disppkg = $ifcpkg;

    # if the interface is in a 'client' package, we'll put the marshaller
    # in the associated 'data' package and the dispatcher in the 'server'
    # package
    if ($ifcpkg =~ m/\.client$/) {
        $marshpkg =~ s/\.client$/.data/g;
        $disppkg =~ s/\.client$/.server/g;
    }

    # create a template processor
    my $ttconfig = {
        RELATIVE => 1,
        ABSOLUTE => 1,
        };
    my $tt = Template->new($ttconfig);
    my $genstamp = strftime("%T %D", localtime);

    # now we generate the <foo>Marshaller class definition
    my $marshpath = $marshpkg;
    $marshpath =~ s:\.:/:g;
    $marshpath = "$sourcedir/$marshpath/$svcname" . "Marshaller.java";

    print "$script: Generating marshaller:\n" .
        "  $marshpkg.${svcname}Marshaller in\n" .
        "  $marshpath\n" if ($verbose);

    # populate a data table with all the data we'll need to fill out our
    # marshaller template file
    my %mimports = %imports;
    $mimports{"com.threerings.presents.client.Client"} = 1;
    $mimports{"com.threerings.presents.data.InvocationMarshaller"} = 1;
    $mimports{"com.threerings.presents.dobj.InvocationResponseEvent"} = 1;
    my @mimportsl = sort keys %mimports;
    my %mdata = ( "idstr" => slurp_idstr($marshpath),
                  "imports" => \@mimportsl,
                  "name" => $svcname,
                  "package" => $marshpkg,
                  "listeners" => \@listeners,
                  "methods" => \@methods,
                  "genstamp" => $genstamp,
                  );

    # my $dumper = Dumpvalue->new;
    # $dumper->dumpValue(\%mdata);

    $tt->process($marshtmpl, \%mdata, $marshpath) or
        die "$script: Unable to process template file '$marshtmpl': " .
        $tt->error() . "\n";

    # now we generate the <foo>Dispatcher class definition
    my $disppath = $disppkg;
    $disppath =~ s:\.:/:g;
    $disppath = "$sourcedir/$disppath/$svcname" . "Dispatcher.java";

    print "$script: Generating dispatcher:\n" .
        "  $disppkg.${svcname}Dispatcher in\n" .
        "  $disppath\n" if ($verbose);

    # populate a data table with all the data we'll need to fill out our
    # dispatcher template file
    my %dimports = %imports;
    $dimports{"com.threerings.presents.data.ClientObject"} = 1;
    $dimports{"com.threerings.presents.data.InvocationMarshaller"} = 1;
    $dimports{"com.threerings.presents.server.InvocationDispatcher"} = 1;
    $dimports{"com.threerings.presents.server.InvocationException"} = 1;
    $dimports{"$marshpkg.${svcname}Marshaller"} = 1;
    my @dimportsl = sort keys %dimports;
    my %ddata = ( "idstr" => slurp_idstr($disppath),
                  "imports" => \@dimportsl,
                  "name" => $svcname,
                  "package" => $disppkg,
                  "listeners" => \@listeners,
                  "methods" => \@methods,
                  "genstamp" => $genstamp,
                  );

    # my $dumper = Dumpvalue->new;
    # $dumper->dumpValue(\%ddata);

    $tt->process($disptmpl, \%ddata, $disppath) or
        die "$script: Unable to process template file '$disptmpl': " .
        $tt->error() . "\n";
}

#
# Extracts the imports from the supplied list of arguments.
#
sub grab_imports {
    my $class;
    foreach $class (@_) {
        # skip classes in java.lang
        next if ($class =~ m/^java\.lang\.[^.]+$/);
        # skip primitive types
        next unless ($class =~ m/\./);

        # trim array delimiters
        my $tclass = $class;
        $tclass =~ s:[\[\]]::g;

        # stuff the class into our import table
        $imports{$tclass} = 1;

        # if this class is a listener and not in the same package as the
        # service class we're currently processing, we need to import its
        # marshaller as well
        if ($tclass =~ m/Listener$/ &&
            $tclass !~ m/^$spackage/ &&
            $tclass !~ $ISVC_CNAME) {
            my $mclass = $tclass;
            $mclass =~ s:\.client\.:.data.:g;
            $mclass =~ s:Listener:Marshaller:g;
            $mclass =~ s:Service:Marshaller:g;
            $imports{$mclass} = 1;
        }
    }
}

#
# Strips the package name from the method argument types.
#
sub trim_args {
    my @targs;
    my $arg;
    foreach $arg (@_) {
        $arg =~ s/^.*\.([^.]+)$/$1/;
        push @targs, $arg;
    }
    return @targs;
}

#
# Converts a mixed case name to uppercase with underscores.
#
sub to_caps {
    my ($fcode) = @_;
    $fcode =~ s/([a-z])([A-Z])/$1_$2/g;
    $fcode =~ tr/a-z/A-Z/;
    return $fcode;
}

#
# Generates an argument list with argument names from a list of argument
# types.
#
sub gen_arglist {
    my $arg;
    my $arglist = "";
    my $i = 1;
    foreach $arg (@_) {
        $arglist .= ", " if (length($arglist) > 0);
        $arglist .= "$arg arg$i";
        $i++;
    }
    return $arglist;
}

#
# Converts the supplied argument type list into a list of values suitable
# for use in an Object array initializer (meaning object types are used as
# is and primitive types are wrapped).
#
sub wrap_arglist {
    my $skip = shift @_;
    my $argvals = "";
    my $i = 0;
    my $arg;
    foreach $arg (@_) {
        $i++;
        next if ($i <= $skip);
        $argvals .= ", " if (length($argvals) > 0);
        if ($arg eq "boolean") {
            $argvals .= "new Boolean(arg$i)";
        } elsif ($arg eq "byte") {
            $argvals .= "new Byte(arg$i)";
        } elsif ($arg eq "short") {
            $argvals .= "new Short(arg$i)";
        } elsif ($arg eq "char") {
            $argvals .= "new Char(arg$i)";
        } elsif ($arg eq "int") {
            $argvals .= "new Integer(arg$i)";
        } elsif ($arg eq "long") {
            $argvals .= "new Long(arg$i)";
        } elsif ($arg eq "float") {
            $argvals .= "new Float(arg$i)";
        } elsif ($arg eq "double") {
            $argvals .= "new Double(arg$i)";
        } elsif ($arg =~ /Listener$/) {
            $argvals .= "listener$i";
        } else {
            $argvals .= "arg$i";
        }
    }
    return $argvals;
}

#
# Converts the supplied argument type list into a list of values which
# represent the unwrapped value of each element.
#
sub unwrap_arglist {
    my $argvals = "";
    my $i = 0;
    my $arg;
    foreach $arg (@_) {
        $argvals .= ", " if (length($argvals) > 0);
        if ($arg eq "boolean") {
            $argvals .= "((Boolean)args[$i]).booleanValue()";
        } elsif ($arg eq "byte") {
            $argvals .= "((Byte)args[$i]).byteValue()";
        } elsif ($arg eq "short") {
            $argvals .= "((Short)args[$i]).shortValue()";
        } elsif ($arg eq "char") {
            $argvals .= "((Char)args[$i]).charValue()";
        } elsif ($arg eq "int") {
            $argvals .= "((Integer)args[$i]).intValue()";
        } elsif ($arg eq "long") {
            $argvals .= "((Long)args[$i]).longValue()";
        } elsif ($arg eq "float") {
            $argvals .= "((Float)args[$i]).floatValue()";
        } elsif ($arg eq "double") {
            $argvals .= "((Double)args[$i]).doubleValue()";
        } else {
            $argvals .= "($arg)args[$i]";
        }
        $i++;
    }
    return $argvals;
}

#
# Generates the necessary data to wrap listeners in listener marshaller
# instances.
#
sub gen_listener_args {
    my $arg;
    my @listener_args = ();
    my $i = 0;
    foreach $arg (@_) {
        $i++;
        next unless ($arg =~ /Listener$/);

        my $mtype = $arg;
        if ($mtype eq "InvocationListener") {
            $mtype = "ListenerMarshaller";
        } else {
            $mtype =~ s:Listener$:Marshaller:;
        }

        push (@listener_args, { "mtype" => $mtype,
                                "aname" => "listener$i",
                                "oaname" => "arg$i" });
    }
    return \@listener_args;
}

#
# If the specified file exists, it is opened and its RCS Id string is read
# and returned.
#
sub slurp_idstr {
    my ($path) = @_;
    my $idstr = "\$Id\$";
    if (-f $path && open(IN, "$path")) {
        while (<IN>) {
            if (/(\$[I][d]: .*\$)/) {
                $idstr = $1;
                last;
            }
        }
        close(IN);
    }
    return $idstr;
}