#!/usr/bin/perl
# Run this from the top directory (where Ogre.pm is).
# Parses an XML file generated by `gccxml`,
# which is an XML representation of the C++ header file,
# for all the enums.
# 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');

# Don't change these
my $BEGINSTRING = 'GENERATED CONSTANTS BEGIN';
my $ENDSTRING = 'GENERATED CONSTANTS END';


main();
exit();


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

    my ($ns_members, $class_members, $enums) = parse_xml($xmlfile);

    # note: although there are 3 namespaces,
    # only 'Ogre' has enums (hopefully stays that way...)

    my $cwd = File::Spec->curdir;
    my $xsfile = File::Spec->catfile($cwd, 'Ogre.xs');
    my $pmfile = File::Spec->catfile($cwd, 'Ogre.pm');
    my $typemapfile = File::Spec->catfile($cwd, 'typemap');

    update_consts($ns_members, $class_members, $enums, $xsfile, \&print_enums_xs);
    update_consts($ns_members, $class_members, $enums, $typemapfile, \&print_enums_typemap);

    update_consts($ns_members->{Ogre}, undef, $enums, $pmfile, \&print_exports_pm, 'Ogre');

    foreach my $pkg (sort keys %$class_members) {
        # skip if this package has no enums
        next unless grep { exists($class_members->{$pkg}{$_}) } keys(%$enums);
        my @dirs = split(/::/, $pkg);
        $pmfile = File::Spec->catfile($cwd, @dirs) . '.pm';

        ensure_file_ready($pmfile, $pkg);
        update_consts(undef, $class_members->{$pkg}, $enums, $pmfile, \&print_exports_pm,
                      $pkg);
    }
}

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': $!";
}

sub update_consts {
    # $pkg added as a hack for print_exports_pm...
    my ($ns_members, $class_members, $enums, $newfile, $printer, $pkg) = @_;

    print STDERR "Updating $newfile... ";

    # backup old file
    my $oldfile = $newfile . '.bak~';
    unless (copy($newfile, $oldfile)) {
        print STDERR "Couldn't copy '$oldfile' '$newfile': $!\n";
        return;
    }

    my $gensection = 0;

    open(my $newfh, "> $newfile") || die "Can't open file '$newfile': $!";
    open(my $oldfh, $oldfile)     || die "Can't open file '$oldfile': $!";
    while (<$oldfh>) {
        if (m{$BEGINSTRING}) {
            $gensection = 1;
            print $newfh $_;
        }

        elsif (m{$ENDSTRING}) {
            # where the work actually is done,
            # updating the lines between the begin and end strings
            $printer->($newfh, 'namespace', $ns_members, $enums, $pkg)
              if defined $ns_members;
            $printer->($newfh, 'class', $class_members, $enums, $pkg)
              if defined $class_members;

            print $newfh $_;
            $gensection = 0;
        }

        elsif ($gensection) {
            next;
        }

        else {
            print $newfh $_;
        }
    }
    close($oldfh);
    close($newfh);

    print STDERR "done.\n";
}

sub print_enums_xs {
    my ($fh, $label, $members, $enums) = @_;

    foreach my $key (sort keys %$members) {
        (my $stash = "stash_$key") =~ tr/:/_/;
        (my $isa = "isa_$key") =~ tr/:/_/;

        my $enumstr = '';
        foreach my $memberid (keys %{ $members->{$key} }) {
            if (exists $enums->{$memberid}) {
                $enumstr .= "\n\t// enum: $enums->{$memberid}{name}\n";
                foreach my $valname (@{ $enums->{$memberid}{valname} }) {
                    $enumstr .= qq{\tnewCONSTSUB($stash, "$valname", newSViv(${key}::${valname}));\n};
                }
            }
        }

        if ($enumstr) {
            print $fh qq{\tHV *$stash = gv_stashpv("$key", TRUE);\n};

            # xxx: I was gonna try to implement %EXPORT_TAGS here,
            # but nah... :) It's going in the Perl modules.
            # print $fh qq{\tAV *$isa = get_av("${key}::ISA", TRUE);\n};
            # print $fh qq{\tav_push($isa, newSVpv("Exporter", 8));\n};

            print $fh "$enumstr\n";
        }
    }
}

sub print_enums_typemap {
    my ($fh, $label, $members, $enums) = @_;

    my %names = ();

    foreach my $key (keys %$members) {
        foreach my $memberid (keys %{ $members->{$key} }) {
            if (exists $enums->{$memberid}) {
                $names{$enums->{$memberid}{name}}++;
            }
        }
    }

    foreach my $name (sort keys %names) {
        print $fh "$name\tT_IV\n";
    }
}

sub print_exports_pm {
    # note: members is different here than in print_enums_xs,
    # only the particular package is passed.
    # $pkg was added for @ISA, etc. (to make this more flexible
    # in case @ISA is assigned to outside the generated part)
    my ($fh, $label, $members, $enums, $pkg) = @_;

    my $oldfh = select($fh);

    print q{require Exporter;} . $/;
    printf q{unshift @%s::ISA, 'Exporter';} . $/ . $/, $pkg;

    # xxx: this isn't quite done - instead of assigning to the hash,
    # should assign to its keys, otherwise this will overwrite any
    # assignments done outside the generated part
    printf q{%%%s::EXPORT_TAGS = (} . $/, $pkg;

    # should sort this by name rather than ID
    foreach my $memberid (sort keys %$members) {
        if (exists $enums->{$memberid}) {
            my $name = $enums->{$memberid}{name};
            print "\t'$name' => [qw(\n";

            foreach my $valname (@{ $enums->{$memberid}{valname} }) {
                print "\t\t$valname\n";
            }

            print "\t)],\n";
        }
    }
    print ");\n\n";

    printf q{$%s::EXPORT_TAGS{'all'} = [ map { @{ $%s::EXPORT_TAGS{$_} } } keys %%%s::EXPORT_TAGS ];} . $/, $pkg, $pkg, $pkg;
    printf q{@%s::EXPORT_OK = @{ $%s::EXPORT_TAGS{'all'} };} . $/, $pkg, $pkg;
    printf q{@%s::EXPORT = ();} . $/, $pkg;

    select($oldfh);
}

# make sure that
# 1) the file exists already
# 2) it's got the begin and end strings
sub ensure_file_ready {
    my ($file, $pkg) = @_;

    # it's there, not empty, so check if strings are there
    if (-r $file && -s _) {
        my @lines = read_file($file);

        # we're good
        return if grep { /$BEGINSTRING/ } @lines;

        for (@lines) {
            # find the last line and put the strings before it
            if (/^(1;|__END__)$/) {
                $_ = "########## $BEGINSTRING\n"
                  . "########## $ENDSTRING\n\n"
                  . $_;

                last;
            }
        }

        write_file($file, @lines);
        return;
    }

    # it's not there, or empty, so write a new file
    else {
        # xxx: should automate this too...
        print STDERR "MISSING: Add this to Ogre.pm and MANIFEST:\n";
        (my $manifest = $file) =~ s{^.*(Ogre/.+\.pm)$}{$1};
        print STDERR "use $pkg;\n$manifest\n";

        # make sure directory exists
        my (undef, $dirs) = File::Spec->splitpath($file);
        eval { mkpath($dirs) };
        if ($@) {
            print STDERR "SKIPPING: can't make dir '$dirs': $@";
            return;
        }

        open(my $fh, "> $file") || die "Can't create file '$file': $!";
        my $oldfh = select($fh);

        print "package $pkg;\n\nuse strict;\nuse warnings;\n\n\n";
        print "########## $BEGINSTRING\n########## $ENDSTRING\n";
        print "1;\n\n__END__\n";

        select($oldfh);
        close($fh);
    }
}

sub parse_xml {
    my ($file) = @_;

    my %ns_members = ();
    my %class_members = ();
    my %enums = ();
    my $enumid = '';

    print STDERR "Parsing XML... ";

    open(my $xml, $file) || die "Can't open '$file': $!";
    while (<$xml>) {
        # map 
        if (m{<Namespace }) {
            my ($name) = /\bdemangled="(Ogre[^"]*)"/;
            next unless defined($name) && $name =~ /^Ogre/;

            foreach my $member (map { split } /\bmembers="([^"]+)"/) {
                $ns_members{$name}{$member}++;
            }
        }

        elsif (m{<Class }) {
            my ($name) = /\bdemangled="(Ogre[^"]*)"/;
            next unless defined($name) && $name =~ /^Ogre/;

            # these are usually iterator classes (or template classes)
            next if $name =~ /_|&/;

            foreach my $member (map { split } /\bmembers="([^"]+)"/) {
                $class_members{$name}{$member}++;
            }
        }

        elsif (m{<Enumeration }) {
            # protected or private ones won't work...
            my ($access) = /\baccess="([^"]+)"/;
            if (defined($access) && ($access eq 'protected' or $access eq 'private')) {
                next;
            }

            ($enumid) = /\bid="([^"]+)"/;

            my ($enumname) = /\bname="([^"]+)"/;
            # note: there's one class enum without a name,
            # which gccxml calls "._100"
            # (has one value, Ogre::PatchSurface::AUTO_LEVEL)
            if ($enumname eq '._100') {
                $enumname = 'PatchAutoLevelType';
            }
            $enums{$enumid}{name} = $enumname;
        }

        elsif ($enumid) {
            if (m{</Enumeration}) {
                $enumid = '';
            }

            elsif (m{<EnumValue }) {
                my ($name) = /\bname="([^"]+)"/;
                push @{ $enums{$enumid}{valname} }, $name;
            }
        }
    }
    close($xml);

    print STDERR "done.\n";

    return(\%ns_members, \%class_members, \%enums);
}

