#!/usr/bin/perl
# Parses an XML file generated by `gccxml`,
# which is an XML representation of the C++ header file,
# to find all the methods of all the classes.
# Big thanks to Vladimir Olenin for pointing out `gccxml`,
# which made life much easier.

use strict;
use warnings;

use Cwd;
use File::Copy;
use File::Path;
use File::Slurp;
use File::Spec;

# Change this to the directory where Ogre.h is located on your system.
# (maybe could get this from `pkg-config --cflags OGRE`)
my $INCDIR = File::Spec->catdir(File::Spec->rootdir, 'usr', 'include', 'OGRE');


main();
exit();


sub main {
#    my $xmlfile = File::Spec->catfile(File::Spec->tmpdir, 'Ogre.xml');
    my $xmlfile = File::Spec->catfile('Ogre.xml');
    generate_xml($xmlfile);

    show_methods(parse_xml($xmlfile));
}

sub show_methods {
    my ($ns, $classes, $methods, $types) = @_;

    # note: there's really only one namespace
    foreach my $nsid (sort keys %$ns) {
        # class ids schwartzed by class name
        # and skipping ones not in the namespace
        my @cids = map {$_->[0]}
          sort {$a->[1] cmp $b->[1]}
          map {[$_, $classes->{$_}{demangled}]}
          grep { exists $ns->{$nsid}{members}{$_} }
          keys %$classes;

        foreach my $cid (@cids) {
            my $class = $classes->{$cid};
            print "CLASS $class->{demangled}\n";

            # class method ids schwartzed by name,
            # by happy coincidence this usually puts constructors first
            my @methids = map {$_->[0]}
              sort {$a->[1] cmp $b->[1]}
              map {[$_, $methods->{$_}->{name}]}
              grep { exists $methods->{$_} }
              keys %{ $class->{members} };

            foreach my $methid (@methids) {
                my $meth = $methods->{$methid};

                print "METHOD: $meth->{demangled}\n";
                print "NAME: $meth->{name}\n";
                if (exists $meth->{args}) {
                    print "ARGS:\n";
#                    foreach my $arg (@{ $meth->{args} }) {
                    for my $i (0 .. @{ $meth->{args} } - 1) {
                        my $arg = $meth->{args}[$i];
                        my $type = get_type($arg->{type}, $types, $classes);
                        my $name = exists($arg->{name}) ? $arg->{name} : "arg$i";
                        print "\t$name; type=$type";
                        print '; default=', $arg->{default}
                          if exists($arg->{default});
                        print $/;
                    }
                }
                if (exists $meth->{returns}) {
                    my $type = get_type($meth->{returns}, $types, $classes);
                    print "RETURNS: $type\n";
                }
                if (exists $meth->{access}) {
                    print "ACCESS: $meth->{access}\n";
                }
                print "CONST: $meth->{const}\n";
                print "STATIC: $meth->{static}\n";
            }
        }
    }
}

sub generate_xml {
    my ($xmlfile) = @_;

    return if -r $xmlfile;

    my $orig_dir = getcwd();
    chdir($INCDIR) || die "Can't chdir to '$INCDIR': $!";

    # xxx: I'm not even sure gccxml is available on non-unix systems...

    my @args = ('gccxml', 'Ogre.h', qq{-fxml=$xmlfile});
    print STDERR "Generating XML... \n";
    print STDERR qq{(note: an error about missing OgrePrerequisites is "normal")\n};
    # rather than check system's return value,
    # which would normally make sense....
    # check for the existence of the XML file
    system(@args);
    unless (-r $xmlfile && -s _) {
        die "system @args failed: $?";
    }
    print "done\n";

    chdir($orig_dir) || die "Can't chdir to '$orig_dir': $!";
}

# Types are really tricky...
sub get_type {
    my ($typeid, $types, $classes, @types_pointed) = @_;

    # Class or Struct
    if (exists $classes->{$typeid}) {
        my $ret = lc($classes->{$typeid}{label}) . ' ' . $classes->{$typeid}{demangled};
        $ret .= ' [' . join(', ', @types_pointed) . ']'
          if @types_pointed;
        return $ret;
    }

    if (exists $types->{$typeid}) {
        my $label = $types->{$typeid}{label};

        if ($label eq 'FundamentalType' or $label eq 'Typedef' or $label eq 'Enumeration') {
            my $ret = $types->{$typeid}{name};
            $ret .= ' [' . join(', ', @types_pointed) . ']'
              if @types_pointed;
            return $ret;
        }

        if ($label eq 'FunctionType') {
            my $ret = $label;
            $ret .= ' [' . join(', ', @types_pointed) . ']'
              if @types_pointed;
            return $ret;
        }

        # anything that points to another type
        if (exists $types->{$typeid}{type}) {
            push @types_pointed, $types->{$typeid}{label};
            return get_type($types->{$typeid}{type}, $types, $classes)
        }
    }

    print "WARN: unresolved type ID '$typeid'";
    print ' [' . join(', ', @types_pointed) . ']' if @types_pointed;
    print $/;
    return $typeid;
}

# This is probably the worst-implemented xml parser ever.
# You'd think I'd use a SAX parser, but no....
sub parse_xml {
    my ($file) = @_;

    my %ns = ();
    my %classes = ();
    my %methods = ();
    my $method_id = '';
    my %types = ();
    my $functiontype_id = '';

    print STDERR "Parsing XML... ";

    open(my $xml, $file) || die "Can't open '$file': $!";
    while (<$xml>) {
        if (m{<Namespace }) {
            my $attr = get_attrs($_);

            # I only get the Ogre namespace
            # (there are two other *Command namespaces,
            # but I can do them manually if necessary)
            next unless exists($attr->{demangled}) && $attr->{demangled} eq 'Ogre';

            $ns{$attr->{id}}{demangled} = $attr->{demangled};

            # members is a list of 'id' numbers
            # which point to any member of the namespace ('Ogre').
            # This is just used to narrow down the ids so they
            # don't include any non-members.
            foreach my $member (map { split } $attr->{members}) {
                $ns{$attr->{id}}{members}{$member}++;
            }
        }

        elsif (m{<(Class|Struct) }) {
            my $label = $1;
            my $attr = get_attrs($_);

            # To resolve some types, we apparently need Classes outside the Ogre namespace
            # (e.g. class type_info....), so I commented out these `next'

            # next unless exists($attr->{demangled}) && $attr->{demangled} =~ /^Ogre/;

            # these are usually iterator or template classes,
            # so I skip them (maybe shouldn't skip the template ones)
            # next if $attr->{demangled} =~ /_|&/;

            # an empty class? useless
            # next unless exists($attr->{members});

            $classes{$attr->{id}}{label} = $label;

            $classes{$attr->{id}}{demangled} = $attr->{demangled};

            # like Namespace, this members is a list of ids
            $classes{$attr->{id}}{members} = {};
            $attr->{members} = [] unless exists $attr->{members};     # ugh
            foreach my $member_id (map { split } $attr->{members}) {
                $classes{$attr->{id}}{members}{$member_id}++;
            }
        }

        elsif (m{<(\w+Type|Typedef|Enumeration) }) {
            my $label = $1;
            my $attr = get_attrs($_);

            $types{$attr->{id}}{label} = $label;

            # Enumeration doesn't have a type attr
            $types{$attr->{id}}{type} = $attr->{type} if exists($attr->{type});

            # Typedef
            $types{$attr->{id}}{name} = $attr->{name} if exists($attr->{name});

            # FunctionType
            if ($label eq 'FunctionType') {
                $functiontype_id = $attr->{id};
            }
        }

        # note: there's also Destructor
        elsif (m{<(Method|Constructor) }) {
            my $attr = get_attrs($_);

            # private ones won't work...
            next unless exists($attr->{name});
            next if $attr->{name} =~ /^_/;
            next if exists($attr->{access}) && $attr->{access} eq 'private';

            $method_id = $attr->{id};
            $methods{$method_id}{demangled} = $attr->{demangled};

            if (exists($attr->{access})) {
                $methods{$method_id}{access} = $attr->{access};
            }

            if (exists($attr->{returns})) {
                $methods{$method_id}{returns} = $attr->{returns};
            }

            $methods{$method_id}{name} = $attr->{name};
            $methods{$method_id}{const} = exists($attr->{const}) ? 'yes' : 'no';
            $methods{$method_id}{static} = exists($attr->{static}) ? 'yes' : 'no';

            # empty tag
            if (m{/>$}) {
                # there won't be a separate end tag, so no Arguments
                $method_id = '';
            }
        }

        elsif ($method_id or $functiontype_id) {
            if (m{</(Method|Constructor)}) {
                # done with that method
                $method_id = '';
            }

            elsif (m{</FunctionType}) {
                $functiontype_id = '';
            }

            elsif (m{<Argument }) {
                my $attr = get_attrs($_);
                my %arg = (
                    type => $attr->{type},    # an ID
                );
                $arg{name} = $attr->{name} if exists($attr->{name});   # not for FunctionType,
                $arg{default} = $attr->{default} if exists($attr->{default});

                if ($method_id) {
                    push @{ $methods{$method_id}{args} }, \%arg;
                }
                elsif ($functiontype_id) {
                    push @{ $types{$functiontype_id}{args} }, \%arg;
                }
            }
        }

        else {
            # print STDERR "WTF: $_\n" if /Typedef/;
        }
    }
    close($xml);

    print STDERR "done.\n";

    return(\%ns, \%classes, \%methods, \%types);
}

sub xml_unescape {
    for ($_[0]) {
        s{&lt;}{<}g;
        s{&gt;}{>}g;
        s{&amp;}{&}g;
        s{&quot;}{"}g;
        s{&apos;}{'}g;
    }
    return $_[0];
}

sub get_attrs {
    my %attrs = map { xml_unescape($_) } $_[0] =~ / (\w+)="([^"]*)"/g;
    return \%attrs;
}
