#!/usr/bin/perl
################################################################################
#
# Copyright (C) 1998, Ashley Winters <jql@accessone.com> - All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
use Getopt::Std;
getopt('n', \%args);

$source = 'libpqt/sigslot.c';
$header = 'include/sigslot.h';
$count = exists $args{'n'} ? $args{'n'} : 2;

%Typemap = (
    'void*' => [
	qw(PQT_PROTO_OBJECT
	   PQT_PROTO_STRING
	   PQT_PROTO_SCALAR
	   PQT_PROTO_SCALARREF
	   PQT_PROTO_HVSCALAR
	   PQT_PROTO_AVSCALAR
	   PQT_PROTO_LIST)
    ],
    'long' => [ 'PQT_PROTO_LONG' ],
    'short' => [ 'PQT_PROTO_SHORT' ],
    'int' => [ 'PQT_PROTO_INT' ],
    'float' => [ 'PQT_PROTO_FLOAT' ],
    'double' => [ 'PQT_PROTO_DOUBLE' ],
    'long double' => [ 'PQT_PROTO_LONG_DOUBLE' ],
    'bool' => [ 'PQT_PROTO_BOOL' ],
);

%From = (
    'PQT_PROTO_BOOL' => 'pqt_push_bool(*(bool*)&$var)',
    'PQT_PROTO_LONG' => 'pqt_push_long(*(long*)&$var)',
    'PQT_PROTO_INT' => 'pqt_push_int(*(int*)&$var)',
    'PQT_PROTO_SHORT' => 'pqt_push_short(*(short*)&$var)',
    'PQT_PROTO_FLOAT' => 'pqt_push_float(*(float*)&$var)',
    'PQT_PROTO_DOUBLE' => 'pqt_push_double(*(double*)&$var)',
    'PQT_PROTO_LONG_DOUBLE' => 'pqt_push_long_double((double)*(long double*)&$var)',
    'PQT_PROTO_STRING' => 'pqt_push_cstring(*(char**)&$var)',
    'PQT_PROTO_OBJECT' => 'pqt_push_class(*(void**)&$var,$ptr+1)',
    'PQT_PROTO_AVSCALAR' => 'pqt_push_sv(*(void**)&$var)',
    'PQT_PROTO_HVSCALAR' => 'pqt_push_sv(*(void**)&$var)',
    'PQT_PROTO_SCALARREF' => 'pqt_push_sv(*(void**)&$var)',
    'PQT_PROTO_SCALAR' => 'pqt_push_sv(*(void**)&$var)',
    'PQT_PROTO_LIST' => 'pqt_push_sv_from_av(*(void**)&$var)',
);

%To = (
    'PQT_PROTO_BOOL' => 'pqt_argument_bool()',
    'PQT_PROTO_LONG' => 'pqt_argument_long()',
    'PQT_PROTO_INT' => 'pqt_argument_int()',
    'PQT_PROTO_SHORT' => 'pqt_argument_short()',
    'PQT_PROTO_FLOAT' => 'pqt_argument_float()',
    'PQT_PROTO_DOUBLE' => 'pqt_argument_double()',
    'PQT_PROTO_LONG_DOUBLE' => 'pqt_argument_long_double()',
    'PQT_PROTO_SCALAR' => 'pqt_argument_sv()',
    'PQT_PROTO_SCALARREF' => 'pqt_argument_sv()',
    'PQT_PROTO_HVSCALAR' => 'pqt_argument_sv()',
    'PQT_PROTO_AVSCALAR' => 'pqt_argument_sv()',
    'PQT_PROTO_LIST' => 'pqt_argument_av_as_list()',
    'PQT_PROTO_STRING' => 'pqt_argument_cstring()',
    'PQT_PROTO_OBJECT' => 'pqt_argument_class(0)'
);

$\ = "\n";
$" = ", ";

sub output {
    print @_;
}

init_data_type_sizes();
make_data_type_list();

open_header_file();
output_headers();
output_defines();
output_stolen_moc_header();
declare_slot_class();

open_source_file();
output_includes();
output_global_stacks();
output_global_variables();
output_signal_helper();
output_slot_helper();
output_pqt_hash();
define_slots();
define_signals();
output_slot_matrix();
output_signal_matrix();

sub init_data_type_sizes {
    open SIZES, "./types |" or die "piped open: $!";
    while(<SIZES>) {
	chomp;
	/^(.*)\s+\=\s+(.*)$/;
	$sizeof{$1} = $2;
    }
    close SIZES;
    for(keys %sizeof) { push @{$size[$sizeof{$_}]}, $_ }
}

sub make_data_type_list {
    for my $type (@ARGV) {
	die "Invalid type: $type" unless exists $sizeof{$type};
	push @types, $type
	    unless grep { $sizeof{$_} == $sizeof{$type} } @types;
    }
}


sub open_header_file {
    open STDOUT, ">$header" or die "open $header: $!";
}

sub output_headers {
    output <<HEADERS;
#include "perlqt.h"
#include <qobject.h>
#include <qmetaobj.h>

HEADERS
}

sub output_defines {
    output <<DEFINES
#define PQT_PROTO_MAX_ARGUMENT_COUNT $count
#define pqt_func (*((PQT)pqt_signal_member))
DEFINES
}

sub output_stolen_moc_header {
    output <<MOC_HEADER;
#if !defined(Q_MOC_CONNECTIONLIST_DECLARED)
#define Q_MOC_CONNECTIONLIST_DECLARED
#include <qlist.h>
#if defined(Q_DECLARE)
Q_DECLARE(QListM,QConnection);
Q_DECLARE(QListIteratorM,QConnection);
#else
declare(QListM,QConnection);
declare(QListIteratorM,QConnection);
#endif
#endif
MOC_HEADER
}

sub declare_slot_class {
    output <<SLOT_CLASS;
class pqt_S : public QObject {
    pqt_extra_slot_data *pqt_slot;

    void slot();

//private slots:
//connect(pqt_receiver, SIGNAL(destroyed()), SLOT(objectDestroyed()));
    void objectDestroyed();   
protected:
    void initMetaObject();

public:
    pqt_S(SV *, SV *);
    ~pqt_S();

    const char *className() const;
    QMetaObject *metaObject() const;

    static QMember stub(SV *);
    static int hash(const char *);
SLOT_CLASS

    my @index;
    for(1..$count) { $index[$_ - 1] = -1 }
INF:
    while(1) {
	my @args;
	for(reverse @index) { push @args, $types[$_] if $_ >= 0 }

	output "    void s(@args);";

	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }

    output "};\n";
}

sub open_source_file {
    open STDOUT, ">$source" or die "open $source: $!";
}

sub output_includes {
    output <<INCLUDES;
#include "sigslot.h"
INCLUDES
}

sub output_global_stacks {
    for(@types) {
	my $a = $_;
	$a =~ s/\W//g;
	output "static $_ pqt_${a}_stack[$count];";
    }
    output "";
}

sub output_global_variables {
    output <<VARIABLES;
typedef void (*pqt_signal)();

QObject *pqt_signal_object;
QMember *pqt_signal_member;
VARIABLES
}

sub output_pqt_hash {
    my(@table) = (1);
    for my $x (1..$count) { push @table, scalar(@types)**$x }
    output "int pqt_exp_table[] = { @table };\n";

    output "int pqt_typeidx(char pqt1) {";
    output "    switch(pqt1) {";
    for my $i (0..$#types) {
	for my $t (@{$size[$sizeof{$types[$i]}]}) {
	    for my $x (@{$Typemap{$t}}) { output "\tcase $x:" }
	}
	output "\t    return $i + 1;";
    }
    output "\tdefault:";
    output "\t    return 0;";
    output "    }";
    output "}\n";
}

sub output_slot_matrix {
    output "QMember pqt_slot_matrix[] = {";

    my @index;
    for(1..$count) { $index[$_ - 1] = -1 }
INF:
    while(1) {
	my @args;
	for(reverse @index) { push @args, $types[$_] if $_ >= 0 }

	output "    (QMember)((void (pqt_S::*)(@args))&pqt_S::s),";

	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }

    output "};\n";
}

sub output_slot_helper {
    output "void pqt_push_slot_arguments(const char *pqtcrypt) {";

    my(@t) = map { my $a = $_; $a =~ s/\W//g; ($a) } @types;

    for my $i (0..$#types) {
        my $a = $t[$i];
        my $t = $types[$i];

	output "    int pqt_${a}_idx = 0;";
    }

    output <<METHOD;
    pqt_argument_iterator pqtiter(pqtcrypt);
    int pqti;

    for(pqti = 0; pqti < *pqtcrypt; pqti++) {
        const char *pqtc = ++pqtiter;
METHOD

    output "\tswitch(*pqtc) {";

    for my $type (@types) {
	my $a = $type;
	$a =~ s/\W//g;
	for my $t (@{$size[$sizeof{$type}]}) {
            for(@{$Typemap{$t}}) {
		output "\t    case $_:";
		my $f = $From{$_};
		next unless $f;
		$f =~ s/\$var/pqt_${a}_stack[pqt_${a}_idx++]/;
		$f =~ s/\$ptr/pqtc/g;
	        output "\t\t$f;";
		output "\t\tbreak;";
	    }
	}
    }
    output "\t}";
    output "    }";
    output "}\n";
}

sub output_signal_helper {
    output "void pqt_pop_signal_arguments(const char *pqtcrypt) {";

    my(@t) = map { my $a = $_; $a =~ s/\W//g; ($a) } @types;

    for my $i (0..$#types) {
        my $a = $t[$i];
        my $t = $types[$i];

	output "    int pqt_${a}_idx = 0;";
    }

    output <<METHOD;
    pqt_argument_iterator pqtiter(pqtcrypt);
    int pqti;

    for(pqti = 0; pqti < *pqtcrypt; pqti++) {
        const char *pqtc = ++pqtiter;
METHOD

    output "\tswitch(*pqtc) {";

    for my $type (@types) {
	my $a = $type;
	$a =~ s/\W//g;
	for my $t (@{$size[$sizeof{$type}]}) {
            for(@{$Typemap{$t}}) {
		output "\t    case $_:";
		output "\t\t{";
		my $f = $To{$_};
		my $var;
		next unless $f;
FINDTYPE:	for my $e (keys %Typemap) {
		    for my $f (@{$Typemap{$e}}) {
			if($f eq $_) { $var = $e; last FINDTYPE }
		    }
		}
		$f = "$var pqtx = ($var)$f";
		$f =~ s/\$ptr/pqtc/g;
	        output "\t\t    $f;";
		$f = "pqt_${a}_stack[pqt_${a}_idx++] = *(($type *)&pqtx)";
	        output "\t\t    $f;";
		output "\t\t}";
		output "\t\tbreak;";
	    }
	}
    }
    output "\t}";
    output "    }";
    output "}\n";
}

sub define_slots {
    my %indices;
    my @index;
    for(1..$count) { $index[$_ - 1] = -1 }
INF:
    while(1) {
	my(@arglist, @args);
	for(reverse @index) {
	    if($_ >= 0) {
		push @args, $types[$_];
		push @arglist, $types[$_];
		$arglist[$#arglist] .= " pqt$#arglist";
	    }
	}
	output "void pqt_S::s(@arglist) {";

	%indices = map { $_ => 0 } @args;
	my $a = 0;
	for(@args) {
	    output "    pqt_${_}_stack[$indices{$_}] = pqt$a;";
	    $a++;
	    $indices{$_}++;
	}
	output "    slot();";
	output "}\n";

	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }
}

sub define_signals {
    my %indices;
    my @index;

    for(1..$count) { $index[$_ - 1] = -1 }
INF:
    while(1) {
	my(@arglist, @args, @stack);
	for(reverse @index) {
	    if($_ >= 0) {
		my $a = $types[$_];
		$a =~ s/\W//g;
		push @args, $a;
		push @arglist, $types[$_];
	    }
	}
	%indices = map { $_ => 0 } @args;
	for(@args) {
	    push @stack, "pqt_${_}_stack[$indices{$_}]";
	    $indices{$_}++;
	}

	my @sizes = map { $sizeof{$_} } @args;
	output "static void " . join("_", "pqt_call", @sizes) . "() {";
	output "    typedef void (QObject::**PQT)(@arglist);";
	output "    (pqt_signal_object->*pqt_func)(@stack);";
	output "}\n";

	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }
}

sub output_signal_matrix {
    output "pqt_signal pqt_signal_matrix[] = {";

    my @index;
    for(1..$count) { $index[$_ - 1] = -1 }
INF:
    while(1) {
	my @args;
	for(reverse @index) { push @args, $types[$_] if $_ >= 0 }
        my @sizes = map { $sizeof{$_} } @args;
	output "    " . join("_", "pqt_call", @sizes) . ",";
	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }

    output "};\n";
}
