#!/usr/bin/perl

use Getopt::Std;
getopt('n', \%args);

$source = 'sigslot.cpp';
$header = 'sigslot.h';
$count = exists $args{'n'} ? $args{'n'} : 2;

%Typemap = (
    'void*' => [
	qw(PQT_OBJECT
	   PQT_STRING
	   PQT_SCALAR
	   PQT_SCALAR_REF
	   PQT_HASH_REF
	   PQT_ARRAY_REF
	   PQT_DOT_DOT_DOT)
    ],
    'long' => [ 'PQT_LONG' ],
    'short' => [ 'PQT_SHORT' ],
    'int' => [ 'PQT_INT' ],
    'float' => [ 'PQT_FLOAT' ],
    'double' => [ 'PQT_DOUBLE' ],
    'long double' => [ 'PQT_LONG_DOUBLE' ],
    'bool' => [ 'PQT_BOOL' ],
);

%From = (
    'PQT_BOOL' => 'newSVsv(boolSV(*(bool*)&$var))',
    'PQT_LONG' => 'newSViv((IV)*(long*)&$var)',
    'PQT_INT' => 'newSViv((IV)*(int*)&$var)',
    'PQT_SHORT' => 'newSViv((IV)*(short*)&$var)',
    'PQT_FLOAT' => 'newSVnv((double)*(float*)&$var)',
    'PQT_DOUBLE' => 'newSVnv((double)*(double*)&$var)',
    'PQT_LONG_DOUBLE' => 'newSVnv((double)*(long double*)&$var)',
    'PQT_STRING' => 'newSVpv(*(char**)&$var,0)',
    'PQT_OBJECT' => 'objectify_ptr(*(void**)&$var,$ptr+1)',

    'PQT_ARRAY_REF' => '$return(sv_mortalcopy(*(SV**)&$var))',
    'PQT_HASH_REF' => '$return(sv_mortalcopy(*(SV**)&$var))',
    'PQT_SCALAR_REF' => '$return(sv_mortalcopy(*(SV**)&$var))',
    'PQT_SCALAR' => '$return(sv_mortalcopy(*(SV**)&$var))',

    'PQT_DOT_DOT_DOT' => 'AV *pqt_av = *(AV **)&$var; SV *pqt_sv; while((pqt_sv = av_shift(pqt_av))) $return(sv_mortalcopy(pqt_sv))'
);

%To = (
    'PQT_BOOL' => '($cast)SvTRUE($var)',
    'PQT_LONG PQT_INT PQT_SHORT' => '($cast)SvIV($var)',
    'PQT_FLOAT' => '$cache = ($type)SvNV($var); $return *($cast *)&$cache',
    'PQT_DOUBLE' => '$cache = ($type)SvNV($var); $return *($cast *)&$cache',
    'PQT_LONG_DOUBLE' => '$cache = ($type)SvNV($var); $return *($cast*)&$cache',
    'PQT_SCALAR PQT_SCALAR_REF PQT_HASH_REF PQT_ARRAY_REF PQT_DOT_DOT_DOT' =>
        '($cast)$var',
    'PQT_STRING' => '($cast)SvPV($var, na)',
    'PQT_OBJECT' => '($cast)extract_ptr($var)',
);

$\ = "\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();
output_argument_type_enum();
output_global_variable_declarations();

open_source_file();
output_includes();
output_argument_iteration_class();
output_global_stacks();
output_stack_increment_class();
output_global_variables();
output_pqt_hash();
output_slot_matrix();
define_slot_class();
define_slots();
define_signals();
output_signal_matrix();
output_gimmie();
output_stub();

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 <pqobject.h>
#include <qmetaobj.h>

const char *reverse_proto(const char *);
SV *reverse_proto(SV *);

HEADERS
}

sub output_defines {
    output <<DEFINES
#define PQT_MAX_ARGUMENT_COUNT $count
#define pqt_func (*((PQT)pqt_m))
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_Slot : public QObject {
    QObject *object;
    SV *objectsv;
    const char *name, *crypt;
    QString proto;

    void slot();

protected:
    void initMetaObject();

public:
    pqt_Slot(SV *, const char *);
    ~pqt_Slot();

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

    static QMember stub(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 output_argument_type_enum {
    output "enum pqt_ArgType {";
    for(qw(PQT_CONST
	   PQT_OBJECT
	   PQT_LONG
	   PQT_SHORT
	   PQT_INT
	   PQT_FLOAT
	   PQT_DOUBLE
	   PQT_LONG_DOUBLE
	   PQT_BOOL
	   PQT_STRING
	   PQT_SCALAR
	   PQT_SCALAR_REF
	   PQT_HASH_REF
	   PQT_ARRAY_REF
	   PQT_DOT_DOT_DOT)) {
	output "    $_,";
    }
    output "};\n";
}

sub output_global_variable_declarations {
    output <<EXTERN;
extern HV *Crypt, *Signals;
extern XS(pqt_signal_stub);
EXTERN
}


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

sub output_includes {
    output <<INCLUDES;
#include "$header"
INCLUDES
}

sub output_argument_iteration_class {
    output <<ARGUMENT_ITERATOR;
class pqt_ArgumentIterator {
    const char *args;
    int cnt;
public:
    pqt_ArgumentIterator() { args = NULL; cnt = 0; }
    pqt_ArgumentIterator(const char *p) {
	args = p;
	cnt = *args;
	args += args[1] + 2;
    }
    const char *operator ++();
};

const char *pqt_ArgumentIterator::operator ++() {
    const char *ret = (--cnt < 0) ? 0 : args++;

// Yes, that NULL pointer is intentionally dereferenced here

    if(*ret == PQT_CONST) ret = args++;
    if(*ret == PQT_OBJECT) args += *args;
    return ret;
}
ARGUMENT_ITERATOR
}

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

    output <<STACK_INCREMENT;
class pqt_ArgumentStack {
    int @variables;
STACK_INCREMENT

    output "public:";
    output "    pqt_ArgumentStack() {";
    for(@variables) { output "\t$_ = 0;" }
    output "    }";

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

	output <<INC;
    int inc_$a() { return pqt$a++; }
    void inc_$a($t p) { pqt_${a}_stack[inc_$a()] = p; }
INC
    }
    output "};\n";
}

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

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

static QSenderObject *pqt_obj;
static QMember *pqt_m;
static pqt_ArgumentIterator pqt_GlobalArgumentIterator;

HV *Crypt = NULL, *Signals = NULL;
VARIABLES
}

sub output_pqt_hash {
    my(@table) = (1);
    for(1..$count) { push @table, scalar(@types)**$_ }
    output "static int pqt_exp_tab[] = { @table };";

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

    output <<PQT_HASH;
int pqt_hash(const char *p) {
    int ret = 0, cnt = *p;
    pqt_ArgumentIterator argit(p);

    for(int i = 0; i < cnt; i++)
	ret += pqt_exp_tab[cnt - (i+1)] * pqt_typeidx(*++argit);
    return ret;
}
PQT_HASH
}

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_Slot::*)(@args))&pqt_Slot::s),";

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

    output "};\n";
}

sub define_slot_class {
    output <<CONSTRUCTOR;
pqt_Slot::pqt_Slot(SV *o, const char *p) {
    objectsv = newRV_noinc((SV *)obj_check(o));
    object = (QObject *)extract_ptr(objectsv, "QObject");
    crypt = reverse_proto(p);
    name = crypt + 2;
    proto = p;
}
CONSTRUCTOR

    output <<DESTRUCTOR;
pqt_Slot::~pqt_Slot() {
    SvFLAGS(objectsv) = (SvFLAGS(objectsv) & ~SVTYPEMASK) | SVt_NULL;
    SvREFCNT_dec(objectsv);
}
DESTRUCTOR

    output <<Q_OBJECT;
void pqt_Slot::initMetaObject() {}

const char *pqt_Slot::className() const {
    return object->className();
}

QMetaObject *pqt_Slot::metaObject() const {
    return object->metaObject();
}
Q_OBJECT

    output <<STUB;
QMember pqt_Slot::stub(const char *p) {
    return pqt_slot_matrix[pqt_hash(reverse_proto(p))];
}
STUB

    output <<SLOT;
void pqt_Slot::slot() {
    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    XPUSHs(sv_mortalcopy(objectsv));		// is the mortal copy wasteful?

    pqt_ArgumentStack stack;
    pqt_ArgumentIterator iter(crypt);

    for(int i = 0; i < *crypt; i++) {
	const char *c = ++iter;
	switch(*c) {
SLOT

    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{$_};
		$f =~ s/\$var/pqt_${a}_stack[stack.inc_${a}()]/;
		$f =~ s/\$ptr/c/g;
		if($f =~ s/\$return/XPUSHs/) {
		    output "\t\t{$f;}";
		} else {
		    output "\t\tXPUSHs(sv_2mortal($f));";
		}
		output "\t\tbreak;";
	    }
	}
    }

    output <<ENDSLOT;
	}
    }

    PUTBACK;

    perl_call_sv(
	(SV *)GvCV(
	    gv_fetchmethod(SvSTASH(SvRV(objectsv)), (char *)name)
	), G_DISCARD
    );

    FREETMPS;
    LEAVE;
}
ENDSLOT
}

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_Slot::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{$_}++;
	}

	output "void " . join("_", "pqt_call", @args) . "() {";
	output "    typedef void (QObject::**PQT)(@arglist);";
	output "    (pqt_obj->*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 }
	output "    " . join("_", "pqt_call", @args) . ",";
	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }

    output "};\n";
}

sub output_gimmie {
    for my $type (@types) {
	my %reverse;
	my @names;
	my $size = $sizeof{$type};
	for my $t (@{$size[$size]}) {
	    if(exists $Typemap{$t}) {
		for(@{$Typemap{$t}}) {
		    push @names, $_;
		    $reverse{$_} = $t;
		}
	    }
	}

	my $a = $type;
	$a =~ s/\W//g;
	my $args = "char";
	$args .= " c" if @names > 1;

	output <<GIMMIE;
$type pqt_gimmie_$a($args) {
    dSP;
    $type ret;
GIMMIE

	if(@names == 1) {
	    my $name = $names[0];
	    my $conv;

CHANCE:
	    for(keys %To) {
		for my $n (split) {
		    if($n eq $name) {
			$conv = $To{$_};
			last CHANCE;
		    }
		}
	    }

	    $conv =~ s/\$type/$reverse{$name}/g;
	    $conv =~ s/\$cast/$type/g;
	    $conv =~ s/\$var/POPs/;
	    if($conv =~ s/\$return/ret =/g) {
		$conv =~ s/\$cache/pqt_cache_tmp/g;
		output "    $reverse{$name} pqt_cache_tmp;";
		output "    $conv;";
	    } else {
		output "    ret = $conv;";
	    }

	    output "    PUTBACK;";
	    output "    return ret;";
	    output "}\n";
	} else {
	    output <<SWITCH;
    SV *arg = POPs;
    PUTBACK;

    switch(c) {
SWITCH

	    my $out;
	    for(keys %To) {
		$out = 0;
		for my $name (split) {
		    if(exists $reverse{$name}) {
			output "\tcase $name:";
			$out = 1;
		    }
		}
		if($out) {
		    my $conv = $To{$_};
		    $conv =~ s/\$cast/$type/g;
		    $conv =~ s/\$var/arg/g;
		    $conv =~ s/\$type/$reverse{$_}/g if exists $reverse{$_};

		    if($conv =~ s/\$return/ret =/g) {
			$conv =~ s/\$cache/pqt_cache_tmp/g;

			output "\t{";
			output "\t    $reverse{$_} pqt_cache_tmp;";
			output "\t    $conv;";
			output "\t    break;";
			output "\t}";
		    } else {
			output "\t    ret = $conv;";
			output "\t    break;";
		    }
		}
	    }
	    output "    }";
	    output "    return ret;";
	    output "}\n";
	}
    }
}

sub output_stub {
    output <<TOP;
XS(pqt_signal_stub) {
    dXSARGS;
    char *stashname = HvNAME(GvSTASH(CvGV(cv)));
    char *funcname = GvNAME(CvGV(cv));
    char *proto =
	SvPV(
	    safe_hv_fetch(
		(HV *)rv_check(
		    safe_hv_fetch(Signals, stashname, "Signals tampered")
		),
		funcname, "Signals tampered badly"
	    ), na
	);
    const char *crypt = reverse_proto(proto);

    if(items - 1 != *crypt)
	croak("Recieved %d arguments instead of %d for signal '%s'",
	      items - 1, *crypt, proto);

    pqt_ArgumentIterator local(crypt);
    pqt_ArgumentStack stack;
    pqt_signal pqt_hash_table[@{[$count+1]}];
    pqt_hash_table[0] = pqt_signal_matrix[0];

    const char *arg;
    int tot = 0;
    for(int i = 1; i <= *crypt; i++) {
	arg = ++local;
	tot += pqt_exp_tab[*crypt - i] * pqt_typeidx(*arg);
	pqt_hash_table[i] = pqt_signal_matrix[tot];

	switch(*arg) {
TOP

    for my $type (@types) {
	for my $t (grep { exists $Typemap{$_} } @{$size[$sizeof{$type}]}) {
	    for(@{$Typemap{$t}}) {
		output "\t    case $_:";
	    }
	}
	my $a = $type;
	$a =~ s/\W//g;
	output "\t\tstack.inc_$a(pqt_gimmie_$a(*arg));";
	output "\t\tbreak;";
    }

    output <<BOTTOM;
	}
    }

    QObject *self = pQ(0, QObject);
    QConnectionList *clist = ((PQObject *)self)->receivers(proto);
    if(!clist || self->signalsBlocked()) XSRETURN_EMPTY;
    QConnectionListIt it(*clist);
    QConnection *c;
    while((c = it.current())) {
	++it;
	pqt_obj = (QSenderObject *)c->object();
	pqt_obj->setSender(self);
	pqt_m = c->member();
	(*pqt_hash_table[c->numArgs()])();
    }
    XSRETURN_EMPTY;
}
BOTTOM
}
