#!/usr/bin/perl
# Sloppy script to generate XSUBs for nsI* interfaces.
#
# Given the name of a Mozilla DOM interface header file,
# this generates XSUBs for a Mozilla::DOM package. For example,
#
#   for f in `find /usr/include/mozilla -name 'nsIDOMHTML*Element.h'`;
#   do echo $f; ./gendomxsubs.pl $f; done
#
# will create a file in a 'genxsubs' directory for each header file,
# each containing its own MODULE/PACKAGE line.
#
# Note: if the header file name is inconsistent with the interface
# (e.g. nsIDOMHTMLTableSectionElement is nsIDOMHTMLTableSectionElem.h)
# you'll have to copy the file or symlink to it.

use strict;
use warnings;

# This only works on interface headers
unless (@ARGV == 1 && $ARGV[0] =~ /nsI.+\.h$/) {
    die "Usage: $0 /path/nsISomething.h\n";
}

# This gets output for pasting convenience
my @wrappercode = ();

my $headerfile = $ARGV[0];
(my $iface = $headerfile) =~ s{.*/([^.]+)\.h}{$1};

my $pkgbase = 'Mozilla::DOM';
(my $pkgname = $iface) =~ s/^nsI(DOM)?//;
my $pkg = "$pkgbase\::$pkgname";
my $outfile = "genxsubs/$iface.xs";

push @wrappercode, "cat $outfile >> xs/DOM.xs\n";
push @wrappercode, qq{#include "$iface.h" (mozilladom2perl.h)\n};
push @wrappercode, "MOZDOM_DECL_DOM_TYPEMAPPERS($pkgname) (mozilladom2perl.h)\n";
push @wrappercode, "MOZDOM_DEF_DOM_TYPEMAPPERS($pkgname) (xs/DOM.xs)\n";

(my $obj = lc($iface)) =~ s/^nsi(dom)?//i;
unless (defined $1) {
    $wrappercode[-1] =~ s/_DOM_/_I_/;
    $wrappercode[-2] =~ s/_DOM_/_I_/;
}
push @wrappercode, "$iface *\t\tT_MOZDOM_GENERIC_WRAPPER  (mozilladom.typemap)\n";
push @wrappercode, "$iface\t\t$pkg  (doctypes)\n";
push @wrappercode, "add an entry to QueryInterface\n";
push @wrappercode, "do ISA in DOM.pm\n";
push @wrappercode, "add POD file\n";
push @wrappercode, "update ChangeLog, MANIFEST\n";

print $_ for @wrappercode;


my $prefix = 'moz_dom_';
my $parentclass = '';
my $inapi = 0;

my $incomment = 0;
my $classcomment = '';
my $gotclasscomment = 0;
my $raisecomment = '';

my @methods = ();
my $getiid = '';

my @enums = ();


# Gather information from header file
while (<>) {
    ## Comments

    if ($incomment) {
        # Trying to look for the class's main comment.
        # (Unfortunately this doesn't always have a '@status' in it,
        # but I didn't know what else to do.)
        if (/\@status/) {
            $gotclasscomment = 1;
            $classcomment .= $_;
        } elsif (m{\*/}) {
            $incomment = 0;
        } else {
            $classcomment .= $_;
        }
    } elsif (m{/\*}) {
        if (m{\*/}) {
            # Make a note if the method raises an exception
            # (I grepped all headers for 'raises' comments,
            # and all of them were contained on a single line)
            if (/(raises\s*\([^)]\))/) {
                $raisecomment = "/* $1 */";
            }
        } else {
            # Start of a comment
            $incomment = 1;
            # Erase previous comment if it wasn't a class comment
            $classcomment = '' unless $gotclasscomment;
        }
    }

    ## Class API

    if (/^\s*class .*$iface\s*:\s*public \s*([^\s]+)/) {
        # Beginning of class declaration
        if (defined $1) {
            $parentclass = $1;
            $parentclass =~ s/^nsI(DOM)?//;
        } else {
            die "no parent class found\n";
        }
        $inapi = 1;
    } elsif ($inapi) {
        next unless /\S/;

        if (/^\s*}\s*;/) {
            # End of class declaration
            $inapi = 0;
            last;
        } elsif (/(NS_DEFINE_STATIC_IID_[^)]+\))/) {
            # The GetIID() class method (only put in a comment)
            $getiid = $1;
        } elsif (/NS_IMETHOD\s*([^\s(]+)\s*\(\s*([^)]+)\s*\)/) {
            # Parse a method declaration

            my $signature = $2;

            my %method = (
                orig => "$1\($2)",
                name => $1,
                inputs => [],
            );

            # print $method{orig}, $/;

            if ($raisecomment) {
                $method{raises} = $raisecomment;
                $raisecomment = '';
            }

            foreach my $arg (split(/\s*,\s*/, $signature)) {
                if ($arg eq 'void') {
                    # nothing to do
                } elsif ($arg =~ /^(.+)\s*\b(\w+)$/) {
                    my $type = $1;
                    my $name = $2;

                    die "unknown type '$type' in method signature\n"
                      unless $type =~ /(nsAC?String|nsI|PR[BIU].*|DOMTimeStamp|const char \*)/;

#                    $name =~ s/_//g;
#                    $name =~ s/^[a-z]([A-Z])/$1/;
#                    $name = lc $name;

                    if ($type =~ s/\*\s*\*$/*/
                          or $type =~ s/(PR(?:Bool|Uint16|Uint32|Int16|Int32))\s*\*/$1/)
                    {
                        # It's an output argument like 'nsIDOMAttr **'
                        # or 'PRBool *'
                        $method{output} = { type => $type, name => $name };
                    } elsif ($type !~ /const/ and $type =~ /nsA(C?String)/) {
                        # It's an output argument like 'nsAString &'
                        $type = "nsEmbed$1";
                        $method{output} = { type => $type, name => $name };
                    } else {
                        # It's an input argument
                        if ($type =~ /nsA(C?String)/) {
                            $type = "nsEmbed$1";
                        }
                        push @{ $method{inputs} }, { type => $type, name => $name };
                    }
                } else {
                    die "unknown argument '$arg' in method signature\n";
                }
            }

            push @methods, \%method;
        } elsif (/enum\s*{\s*(\w+)\s*=\s*(\d+)U?/) {
            push @enums, { name => $1, value => $2 };
        }
    }
}

$classcomment = '' unless $gotclasscomment;


# Write out the XS file
mkdir 'genxsubs';

open(OUT, ">$outfile") || die "can't open $outfile: $!";

print OUT <<EOH;
# -----------------------------------------------------------------------------

MODULE = $pkgbase	PACKAGE = $pkg	PREFIX = $prefix

# $headerfile

EOH

print OUT <<EOG;
## $getiid
static nsIID
$iface\::GetIID()
    CODE:
	const nsIID &id = $iface\::GetIID();
	RETVAL = (nsIID) id;
    OUTPUT:
	RETVAL

EOG

my @pod = ();
foreach my $method (@methods) {
    # Ugh, this is horrible

    my $pret = '';
    if (exists $method->{output}) {
        if ($method->{output}{type} =~ /bool/i) {
            $pret .= '$bool = ';
        } else {
            my $name = $method->{output}{name};
            $name =~ s/_//g;
            $name =~ s/^[a-z]([A-Z])/$1/;
            $name = lc $name;

            $pret .= "\$$name = ";
        }
    }
    my $psig = join(', ', map {
        my $name = $_->{name};
        $name =~ s/_//g;
        $name =~ s/^[a-z]([A-Z])/$1/;
        $name = lc $name;
        "\$$name"
    } @{ $method->{inputs} });

    my $xsret = (exists $method->{output})
      ? $method->{output}{type}
      : 'void';
    my $xssig = join(', ', ($obj, map {$_->{name}} @{ $method->{inputs} }));;
    my $xssigdecl = (@{ $method->{inputs} })
      ? (join(";\n", map {"\t$_->{type} $_->{name}"} @{ $method->{inputs} })
          . ";\n")
      : '';
    my $xspre = (exists $method->{output})
      ? "    PREINIT:\n\t$method->{output}{type} $method->{output}{name};\n"
      : '';
    my $xsout = (exists $method->{output})
      ? "\tRETVAL = $method->{output}{name};\n    OUTPUT:\n\tRETVAL\n"
      : '';

    my $ccode = "    CODE:\n";
    $ccode .= "\t/* $method->{raises} */\n" if exists $method->{raises};
    $ccode .= "\t$obj\->$method->{name}\(";
    # return value is assumed last
    $ccode .= join(', ', map {$_->{name}} @{ $method->{inputs} });
    if (exists $method->{output}) {
        $ccode .= ', ' if @{ $method->{inputs} };
        $ccode .= '&' unless $method->{output}{type} =~ /nsEmbedC?String/;
        $ccode .= $method->{output}{name};
    }
    $ccode .= ');';

    my $pod = "=head2 $pret\$$obj\->B<$method->{name}>\($psig)\n\n";
    if (@{ $method->{inputs} }) {
        $pod .= "Input:\n\n=over\n\n";
        foreach my $input (@{ $method->{inputs} }) {
            my $name = '$' . $input->{name};
            my $type = $input->{type};
            if ($type =~ s/^nsI(?:DOM)//) {
                $type = 'Mozilla::DOM::' . $type;
            }
            $type =~ s/\s*\*\s*$//;
            $type = 'int' if $type =~ /PR.*int/i;
            $type = 'string' if $type =~ /string/i;
            $type = 'bool' if $type =~ /bool/i;
            $pod .= "=item $name ($type)\n\n";
        }
        $pod .= "=back\n\n";
    }
    if (exists $method->{output}) {
        $pod .= "Output:\n\n=over\n\n";

        my $name = $method->{output}{name};
        my $type = $method->{output}{type};

        $name =~ s/_//g;
        $name =~ s/^[a-z]([A-Z])/$1/;
        $name = lc $name;
        $name = 'bool' if $type =~ /bool/i;
        $name = '$' . $name;

        if ($type =~ s/^nsI(?:DOM)//) {
            $type = 'Mozilla::DOM::' . $type;
        }
        $type =~ s/\s*\*\s*$//;
        $type = 'int' if $type =~ /PR.*int/i;
        $type = 'string' if $type =~ /string/i;
        $type = 'bool' if $type =~ /bool/i;
        $pod .= "=item $name ($type)\n\n";

        $pod .= "=back\n\n";
    }
    push @pod, $pod;

    print OUT <<EOM;
## $method->{orig}
$xsret
${prefix}$method->{name} \($xssig)
	$iface *$obj;
$xssigdecl$xspre$ccode
$xsout
EOM
}

close(OUT);


# output POD to separate file

my $podfile = "genxsubs/$pkgname.pod";
open(POUT, ">$podfile") || die "can't open $podfile: $!";

print POUT <<HEAD;
=head1 NAME

$pkg

=for object $pkg

$pkg is a wrapper around an instance of Mozilla's
$iface interface. This class inherits from
L\<$parentclass|$pkgbase\::$parentclass>.

HEAD

print POUT "$classcomment\n\n" if $classcomment;

if (@enums) {
    print POUT "The following constants are available.\n\n",
      "=over 4\n\n";

    foreach my $enum (@enums) {
        print POUT "=item $enum->{name} => $enum->{value}\n\n";
    }

    print POUT "=back\n\n";
}

print POUT <<POD;
=head1 CLASS METHODS

=head2 \$iid = $pkg\->B\<GetIID>()

Pass this to QueryInterface.

=head1 METHODS

POD

foreach my $pod (@pod) {
    print POUT $pod;
}

print POUT <<FOOT;
=head1 SEE ALSO

L<Mozilla::DOM>

=head1 COPYRIGHT

Copyright (C) 2005, Scott Lanning

This software is licensed under the LGPL.  See L<Mozilla::DOM> for a full notice.

=cut

FOOT

close(POUT);