#!/usr/bin/perl -w

use strict;
use MDK::Common;

my ($current_package, $current_prefix, $current_name);

sub is_blacklisted {
    my ($name) = @_;
    member($name, qw(can cmp isa print use));
}


my %l;
sub get_paras {
    my ($name, $para) = @_;
    $name =~ s/\Q$current_prefix//;
    # remove empty prototypes from functions (it's possible we see it using shift later):
    $name =~ s/\(\)//;
    $current_name = $name;
    # perl_checker don't like those:
    return if is_blacklisted($name);
    # handle special case "sub foobar { shift->method_call(...) }
    if ($para =~ /shift->\S+\(.*\@_\b.*\)/) {
	$l{$current_package}{$name} = [ '$_self', '@_more_paras' ];
	return;
    }
    $l{$current_package}{$name} = [ map {
	if (/\Q.../) {
            # C code:
	    '@_more_paras';
	} elsif (/[%@]\w+.* = \@_/) {
            # perl code:
	    '@_more_paras';
	} else {
	    my ($optional) = s/=(.*)//;
	    my $s = /.*\W(\w+)/ ? $1 : $_;
	    # so that perl_checker doesn't complain about fake packages themselves:
	    # (also tag as optionnal)
	    '$_' . ($optional ? 'o_' : '') . $s;
	}
    } grep { !/OUTLIST/ } split(',', $para) ];
}

sub parse_xs {
    my ($file) = @_;
    warn "parse_xs $file\n";
    my $state = 'waiting_for_type';
    ($current_package, $current_prefix) = ('', '');
    my $multi_line;
    my $c;
    foreach (cat_($file)) {
	$c++;
	next if /^=/ ... /^=cut/;
	next if /^BOOT/ ... /^$/;
	chomp;
	my $orig_line = $_;

	if (/^\s*#/ || (m!^\s*/\*! .. m!\*/!)) {
	    # forget it
	} elsif ($state eq 'multi_line') {
	    if (/(.*)\)/) {
		get_paras($current_name, $multi_line . $1);
		$state = 'waiting_for_end';
	    } else {
		$multi_line .= $_;
	    }
#	} elsif (/^\s*gperl_set_isa\s*\("(.*)", ".*"\)\s*;/) {
	} elsif (/MODULE\s*=\s*\S+\s+PACKAGE\s*=\s*(\S+)\s+PREFIX\s*=\s*(\S+)/) {
	    ($current_package, $current_prefix) = ($1, $2);
	} elsif (/MODULE\s*=\s*\S+\s+PACKAGE\s*=\s*(\S+)/) {
	    ($current_package, $current_prefix) = ($1, '');
	} elsif (!$current_package) {
	    # waiting for the MODULE line
	} elsif (/^\s*$/) {
	    $state = 'waiting_for_type';
	} elsif (/^\w[^\(]*$/ && $state eq 'waiting_for_type') {
	    $state = 'waiting_for_function' if !/^BOOT:/ && !/;/;
	} elsif (/^\s*ALIAS:\s*$/) {
	    $state = 'alias';
	} elsif ($state eq 'alias') {
	    if (my ($f) = /^\s*(\S+)\s*=\s*\w+\s*$/) {
		my $pkg = $f =~ s/(.*)::// ? $1 : $current_package;
		$l{$pkg}{$f} ||= $l{$current_package}{$current_name};
	    } else {
		warn "bad line #$c $orig_line (state: $state)\n" if !/^\s*\w+:\s*$/ && !/^\s*$/;
		$state = 'waiting_for_end';
	    }
	} elsif ($state eq 'waiting_for_type' && s/^(const\s*)?\w+\s*(\*\s*)?// || 
		 $state eq 'waiting_for_function' && /^\w+/) {
	    if (my ($name, $para) = /^(\S+)\s*\((.*)\)\s*;?\s*$/) {
		get_paras($name, $para);
		$state = 'waiting_for_end';
	    } elsif (($name, $para) = /^(\S+)\s*\((.*)$/) {
		$multi_line = $para;
		$current_name = $name;
		$state = 'multi_line';
	    } else {
		warn "bad line #$c $orig_line (state: $state)\n";
	    }
	} else {
	    warn "bad line #$c $orig_line (state: $state)\n" if 
	      !(($state eq 'waiting_for_end' || $state eq 'waiting_for_type') && 
		(/^\s/ || /^[{}]\s*$/ || /^(CODE|OUTPUT):\s*$/));
	}
    }
}

sub parse_pm {
    my ($file) = @_;
    warn "parse_pm $file\n";
    my $state = 'waiting_for_type';
    my $name;
    $current_package = '';
    my $c;
    my $magic_value = 'MAGEIA_MAGIC_STOP';
    foreach (cat_($file), $magic_value, $magic_value) {
	$c++;
	next if /^=/ .. /^=cut|^$magic_value/;
	next if /^$magic_value/;
	chomp;
	my $orig_line = $_;

	if (/^\s*#/ || (m!^\s*/\*! .. m!\*/!)) {
	    # forget it
	} elsif (/^package\s*(\S+)\s*;/) {
	    $current_package = $1;
	} elsif (!$current_package) {
	    # waiting for the package line
	} elsif (/^sub\s*(\S*);/ && !/;.*\)/) {
	    # forget it
	} elsif (/^sub\s*(\S*)/) {
            $name = $1;
            # handle functions without spacing before opening "{" (eg: "sub set_color_fg{")
            $name =~ s/{$//;
            $l{$current_package}{$name} = [] if !defined($l{$current_package}{$name}) && !is_blacklisted($name);
	    $state = 'waiting_for_param';
            get_paras($name, $_) if /shift->/;
	} elsif ($state eq 'waiting_for_param' && /=\s*\@_/) {
            get_paras($name, $_);
            $state = 'waiting_for_end';
	} else {
	    warn "bad line2 #$c $orig_line (state: $state)\n" if 0 &&
	      !(($state eq 'waiting_for_end' || $state eq 'waiting_for_type') && 
		(/^\s/ || /^[{}]\s*$/ || /^(CODE|OUTPUT):\s*$/));
	}
    }
}

my ($pkg_name, $dir) = @ARGV;
my @xs_files = chomp_(`find $dir -name "*.xs"`);
# ignore test suites, inc/ and ext/ :
my @pm_files = chomp_(`find $dir -name "*.pm" | egrep -v '/(ext|inc|t)/'`);
@ARGV == 2 && (@xs_files || @pm_files) or die "usage: gen.pl <Gtk2 or Glib> <dir where Gtk2's or Glib's *.xs are>\n";

parse_xs($_) foreach @xs_files;
parse_pm($_) foreach @pm_files;

print "package $pkg_name;\nuse Glib;\n" if $pkg_name eq 'Gtk2';

foreach my $pkg (sort keys %l) {
    print "\npackage $pkg;\n";
    print "our \@ISA = qw();\n";
    foreach my $name (sort keys %{$l{$pkg}}) {
	my $xs_name = $name . "__XS";
	my $para = $l{$pkg}{$xs_name} || $l{$pkg}{$name};
	$name = $pkg . '::' . $name if $name =~ /^(ne|eq|foreach|format|ge|length|sub|x|xor|y)$/;
	if (@$para) {
	    print "sub $name { my (", join(", ", @$para), ") = \@_ }\n";
	} elsif ($name =~ /\(/) {
	    print "sub $name {}\n";
	} else {
	    print "sub $name() {}\n";
	}
    }
}