#!/usr/bin/perl
#
# ggcov - A GTK frontend for exploring gcov coverage data
# Copyright (c) 2006-2020 Greg Banks <gnb@fastmail.fm>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#
#
# Generate a C data structure which maps names to function pointers
# for all the GLADE_CALLBACKS in the given C source files.
#
# Usage: ./gencallbacks.pl *.[cC] > callbacks.c
#

my $debug = 0;
my @functions;
my %seen_tramp;

sub balanced_parentheses($)
{
    my $str = shift;

    my $lefts = $str;
    $lefts =~ s/[^(]//g;

    my $rights = $str;
    $rights =~ s/[^)]//g;

    print STDERR "balanced_parentheses: lefts=\"$lefts\" rights=\"$rights\"\n" if ($debug > 1);

    return (length($lefts) == length($rights));
}

sub scan_file($)
{
    my $filename = shift;

    open FH, "<$filename"
	or die "Can't open $filename for reading";

    my $state = 0;
    my $return_type;
    my $function;
    my $arguments;

    while (<FH>)
    {
	chomp;
	s/\s+$//;

	print STDERR "[$state] $_\n" if ($debug > 1);

	if ($state == 1)
	{
	    ($class, $function, $arguments) = m/^([a-z_]+::)?([a-z_][a-z0-9_]*)(\(.*)$/;
	    $class =~ s/::$// if defined $class;
	    if (defined($function))
	    {
		print STDERR "Found: \"$function\"\n" if ($debug);
		print STDERR "    in class \"$class\"\n" if ($debug && defined $class);
	    }
	    # collapse whitespace in args
	    $arguments =~ s/\s+/ /g;

	    # check for end of arguments
	    if (balanced_parentheses($arguments))
	    {
		$state = 0; # finished
		push(@functions, {
			return_type => $return_type,
			class => $class,
			name => $function,
			arguments => $arguments,
			filename => $filename});
	    }
	    else
	    {
		$state = 2; # keep scanning lines for args
	    }
	}
	elsif ($state == 2)
	{
	    # collapse whitespace
	    s/^\s+//;
	    s/\s+/ /g;

	    # append to the arguments string
	    my $sep = ' ';
	    $sep = '' if ($arguments =~ m/\($/);
	    $arguments .= $sep . $_;

	    # check for end of arguments
	    if (balanced_parentheses($arguments))
	    {
		$state = 0; # finished
		push(@functions, {
			return_type => $return_type,
			class => $class,
			name => $function,
			arguments => $arguments,
			filename => $filename});
	    }
	}
	elsif (m/^GLADE_CALLBACK/)
	{
	    s/^GLADE_CALLBACK\s+//;
	    $return_type = $_;
	    $state = 1;
	    next;
	}
    }

    close FH;
}

sub dump_functions()
{
    print STDERR "return-type|class|name|arguments|filename\n";
    foreach my $f (@functions)
    {
	printf STDERR "%s|%s|%s|%s|%s\n",
		$f->{return_type},
		$f->{class},
		$f->{name},
		$f->{arguments},
		$f->{filename};
    }
}

sub write_header()
{
    print "/* generated by gencallbacks.pl, do not edit */\n";
    print "#include \"ui.h\"\n";
}

sub do_trampoline
{
    my ($fn) = @_;

    my %rt_abbrevs = (
	void => 'v',
	gboolean => 'b',
    );
    my $rt = $rt_abbrevs{$fn->{return_type}};
    die "Cannot abbreviate return type $fn->{return_type} for $fn->{class}::$fn->{name}\n"
	unless defined $rt;

    my $aa = $fn->{arguments};
    $aa =~ s/^\(//;
    $aa =~ s/\)$//;
    my (@ta) = map
    {
	s/^\s+//;			# remove leading WS
	s/\s+$//;			# remove trailing WS
	s/\s+/ /g;			# normalise any other WS
	s/[a-zA-Z][a-zA-Z_0-9]*$//;	# remove variable name
	s/\s*\*\s*/*/g;			# cuddle '*' characters
	$_;
    } split(/,/, $aa);

    my $cbargs = join(', ', @ta);
    my $trargs = join(', ', ('GtkWidget*', @ta, 'gpointer'));
    my $tramp = "($fn->{return_type} (*)($trargs))&trampoline_$rt";

    if (!defined $seen_tramp{$tramp})
    {
	$seen_tramp{$tramp} = 1;

	my $n = 0;
	# Rebuild $trargs to include argument names
	$trargs = join(', ', (
	    'GtkWidget* w',
	    (map
	    {
		$n++;
		"$_ a$n";
	    } @ta),
	    'gpointer closure'
	));
	$n = 0;
	my $passem = join(', ', map { $n++; "a$n"; } @ta);
	printf "static %s trampoline_%s(%s)\n", $fn->{return_type}, $rt, $trargs;
	printf "{\n";
	printf "    ui_class_callback_t *cb = (ui_class_callback_t *)closure;\n";
	printf "    window_t *win = window_t::from_widget(w);\n";
        printf "    %s (window_t::*handler)(%s) = (%s (window_t::*)(%s))cb->func;\n",
		    $fn->{return_type}, $cbargs,
		    $fn->{return_type}, $cbargs;
        printf "    %s(win->*handler)(%s);\n",
		    ($rt eq 'v' ? '' : 'return '), $passem;
	printf "}\n";
    };

    $fn->{trampoline} = $tramp;
}

sub write_class_functions()
{
    # extract the class functions
    my @fns = grep { defined $_->{class} } @functions;
    @fns = sort {
	    $a->{class} cmp $b->{class} ||
	    $a->{name} cmp $b->{name}
	   } @fns;

    # generate fake class declarations
    my $class;
    foreach my $fn (@fns)
    {
	if (!defined $class || $class ne $fn->{class})
	{
	    print "};\n" if defined $class;
	    print "/* $fn->{filename} */\n";
	    print "class $fn->{class} {\npublic:\n";
	    # horrible hack :(
	    print "static window_t *from_widget(GtkWidget *);\n"
		if ($fn->{class} eq 'window_t');
	    $class = $fn->{class};
	}
	print "$fn->{return_type} $fn->{name}$fn->{arguments};\n";
    }
    print "};\n" if defined $class;

    # generate callback trampolines
    foreach my $fn (@fns)
    {
	do_trampoline($fn);
    }

    # generate namelist data structure
    print "ui_class_callback_t ui_class_callbacks[] =\n{\n";
    foreach my $fn (@fns)
    {
	my $nm = "$fn->{class}::$fn->{name}";
	print "    {\"$nm\", (void (window_t::*)(void))&$nm, (GCallback)$fn->{trampoline}},\n";
    }
    print "    {0,0}\n";
    print "};\n";
}

sub write_simple_functions()
{
    # extract the simple functions
    my @fns = grep { !defined $_->{class} } @functions;
    @fns = sort {
	    $a->{filename} cmp $b->{filename} ||
	    $a->{name} cmp $b->{name}
	   } @fns;

    my $filename;
    # generate extern declarations
    foreach my $fn (@fns)
    {
	if (!defined $filename || $filename ne $fn->{filename})
	{
	    print "/* $fn->{filename} */\n";
	    $filename = $fn->{filename};
	}
	print "GLADE_CALLBACK $fn->{return_type} $fn->{name}$fn->{arguments};\n";
    }

    # generate namelist data structure
    print "ui_simple_callback_t ui_simple_callbacks[] =\n{\n";
    foreach my $fn (@fns)
    {
	print "    {\"$fn->{name}\", (GCallback) $fn->{name}},\n";
    }
    print "    {0,0}\n";
    print "};\n";
}

foreach my $filename (@ARGV)
{
    if ($filename =~ m/\.[Cc]$/)
    {
	print STDERR "Scanning $filename\n" if ($debug);
	scan_file($filename);
    }
    else
    {
	print STDERR "Skipping $filename\n" if ($debug);
    }
}

dump_functions() if $debug;
write_header();
write_class_functions();
write_simple_functions();
