################################################################################
#
# Copyright (C) 1998-2000, 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.
#

package SigSlot;
use Exporter;
use strict;
use vars qw(@ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw(&GenerateSignalSlotTemplate);

my(%Typemap) = (
    'void*' => [
	qw(PIG_PROTO_OBJECT
	   PIG_PROTO_STRING
	   PIG_PROTO_SCALAR
	   PIG_PROTO_SCALARREF
	   PIG_PROTO_HVSCALAR
	   PIG_PROTO_AVSCALAR
	   PIG_PROTO_LIST)
    ],
    'long' => [ 'PIG_PROTO_LONG' ],
    'short' => [ 'PIG_PROTO_SHORT' ],
    'int' => [ 'PIG_PROTO_INT' ],
    'float' => [ 'PIG_PROTO_FLOAT' ],
    'double' => [ 'PIG_PROTO_DOUBLE' ],
    'long double' => [ 'PIG_PROTO_LDOUBLE' ],
    'bool' => [ 'PIG_PROTO_BOOL' ],
);

my(%From) = (
    'PIG_PROTO_BOOL' => 'pig_type_bool_push(*(bool*)&$var)',
    'PIG_PROTO_LONG' => 'pig_type_long_push(*(long*)&$var)',
    'PIG_PROTO_INT' => 'pig_type_int_push(*(int*)&$var)',
    'PIG_PROTO_SHORT' => 'pig_type_short_push(*(short*)&$var)',
    'PIG_PROTO_FLOAT' => 'pig_type_float_push(*(float*)&$var)',
    'PIG_PROTO_DOUBLE' => 'pig_type_double_push(*(double*)&$var)',
    'PIG_PROTO_LDOUBLE' => 'pig_type_long_double_push(*(long double*)&$var)',
    'PIG_PROTO_STRING' => 'pig_type_cstring_push(*(char**)&$var)',
    'PIG_PROTO_OBJECT' => 'pig_type_qtobject_push(*(void**)&$var,$ptr+1)',
    'PIG_PROTO_AVSCALAR' => 'pig_type_ptr_push(*(void**)&$var)',
    'PIG_PROTO_HVSCALAR' => 'pig_type_ptr_push(*(void**)&$var)',
    'PIG_PROTO_SCALARREF' => 'pig_type_ptr_push(*(void**)&$var)',
    'PIG_PROTO_SCALAR' => 'pig_type_ptr_push(*(void**)&$var)',
    'PIG_PROTO_LIST' => 'pig_type_ptr_push(*(void**)&$var)',
);

my(%To) = (
    'PIG_PROTO_BOOL' => 'pig_type_bool_argument()',
    'PIG_PROTO_LONG' => 'pig_type_long_argument()',
    'PIG_PROTO_INT' => 'pig_type_int_argument()',
    'PIG_PROTO_SHORT' => 'pig_type_short_argument()',
    'PIG_PROTO_FLOAT' => 'pig_type_float_argument()',
    'PIG_PROTO_DOUBLE' => 'pig_type_double_argument()',
    'PIG_PROTO_LDOUBLE' => 'pig_type_long_double_argument()',
    'PIG_PROTO_SCALAR' => 'pig_type_ptr_argument()',
    'PIG_PROTO_SCALARREF' => 'pig_type_ptr_argument()',
    'PIG_PROTO_HVSCALAR' => 'pig_type_ptr_argument()',
    'PIG_PROTO_AVSCALAR' => 'pig_type_ptr_argument()',
    'PIG_PROTO_LIST' => 'pig_type_ptr_argument()',
    'PIG_PROTO_STRING' => 'pig_type_cstring_argument()',
    'PIG_PROTO_OBJECT' => 'pig_type_qtobject_argument($ptr+1)'
);

my %sizeof;
my @size;
my @types;
my $header = "_pigsigslot.h";
my $source = "_pigsigslot.c";
my $typefile = "types";
my $count = 3;
my $shclass = "pig_S";
my $shmethod = "s";
my(@argv) = ('long', 'short', 'int', 'bool', 'void*', 'float', 'double');

sub output {
    print @_;
}

sub init_data_type_sizes {
    open SIZES, $typefile 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 close_header_file {
    close STDOUT;
}

sub output_headers {
    output <<HEADERS;
#include <qobject.h>
#include <qmetaobject.h>

HEADERS

}

sub output_defines {
    output <<DEFINES;
#define PIG_SIGSLOT_MAX_ARGS $count
DEFINES

    my $n;
    @types = sort { $sizeof{$a} <=> $sizeof{$b} } @types;
    for $n (@types) {
	output "typedef $n b$sizeof{$n};";
    }
    output "";
}

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;
#undef $shclass
#undef $shmethod
class $shclass : public QObject {
public:
    class pig_slot_data *pigsd;

    $shclass();
    virtual ~$shclass();

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

    void ${shclass}_destroyed();

SLOT_CLASS

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

	output "    void $shmethod(@args);";

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

    output "";

    declare_signals();

    output "};";
}

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

sub close_source_file {
    close STDOUT;
}

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

sub output_global_stacks {
    for(@types) {
	my $a = $sizeof{$_};
	output "static b$a pig_sigslot_stack_$a\[PIG_SIGSLOT_MAX_ARGS];";
    }
    output "";
}

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

QObject *pig_signal_object;
QMember *pig_signal_member;
VARIABLES
}

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

    output "int pig_sigslot_typeidx(char pig1) {";
    output "    switch(pig1) {";
    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 pig_slot_matrix[] = {";

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

	output "    (QMember)((void ($shclass\::*)(@args))&$shclass\::$shmethod),";

	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 pig_push_slot_arguments(const char *pigcrypt) {";

    for my $x (@types) {
	output "    int pig_sigslot_idx_$sizeof{$x} = 0;";
    }

    output <<METHOD;
    pig_sigslot_argument_iterator pigiter(pigcrypt);
    int pigi;

    for(pigi = 0; pigi < *pigcrypt; pigi++) {
        const char *pigc = ++pigiter;
METHOD

    output "\tswitch(*pigc) {";

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

sub output_signal_helper {
    output "void pig_pop_signal_arguments(const char *pigcrypt) {";

    for my $x (@types) {
	output "    int pig_sigslot_idx_$sizeof{$x} = 0;";
    }

    output <<METHOD;
    pig_sigslot_argument_iterator pigiter(pigcrypt);
    int pigi;

    for(pigi = 0; pigi < *pigcrypt; pigi++) {
        const char *pigc = ++pigiter;
METHOD

    output "\tswitch(*pigc) {";

    for my $type (@types) {
	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 pigx = ($var)$f";
		$f =~ s/\$ptr/pigc/g;
	        output "\t\t    $f;";
		$f = "pig_sigslot_stack_$sizeof{$type}\[pig_sigslot_idx_$sizeof{$type}++] = *(($type *)&pigx)";
	        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, "b$sizeof{$types[$_]}";
		$arglist[$#arglist] .= " pig$#arglist";
	    }
	}
	output "void $shclass\::$shmethod(@arglist) {";

	%indices = map { $_ => 0 } @args;
	my $a = 0;
	for(@args) {
	    output "    pig_sigslot_stack_$sizeof{$_}\[$indices{$_}] = pig$a;";
	    $a++;
	    $indices{$_}++;
	}
	output "    pigslot(this);";
	output "}\n";

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

sub declare_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[$_];
		push @args, $a;
		push @arglist, $types[$_];
	    }
	}
	%indices = map { $_ => 0 } @args;
	for(@args) {
	    push @stack, "pig_sigslot_stack_sizeof{$_}\[$indices{$_}]";
	    $indices{$_}++;
	}

	my @sizes = map { $sizeof{$_} } @args;
	output "    static void " . join("_", "s_", @sizes) . "();";

	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[$_];
		push @args, $a;
		push @arglist, "b$sizeof{$types[$_]}";
	    }
	}
	%indices = map { $_ => 0 } @args;
	for(@args) {
	    push @stack, "pig_sigslot_stack_$sizeof{$_}\[$indices{$_}]";
	    $indices{$_}++;
	}

	my @sizes = map { $sizeof{$_} } @args;
	output "void $shclass\::" . join("_", "s_", @sizes) . "() {";
	output "    typedef void (QObject::**PIG)(@arglist);";
	output "    (pig_signal_object->*pig_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 "pig_signal pig_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 "    &$shclass\::" . join("_", "s_", @sizes) . ",";
	for(my $i = 0; $i < @index; $i++) {
	    last if ++$index[$i] < @types;
	    last INF if $i == $#index;
	    $index[$i] = 0;
	}
    }

    output "};\n";
}

sub myprint {
    local $\ = undef;
    select((select(STDSAVE),$|=1)[0]);
    print STDSAVE @_;
}

sub GenerateSignalSlotTemplate {
    my(%args) = @_;
    local $\ = "\n";
    local $" = ", ";
    local $| = 1;

    open(STDSAVE, ">&STDOUT");
    myprint "Generating Signal/Slot templates...";

    $source = $args{'SOURCE'} if exists $args{'SOURCE'};
    $header = $args{'HEADER'} if exists $args{'HEADER'};
    $count = $args{'ARGUMENTS'} if exists $args{'ARGUMENTS'};
    $typefile = $args{'TYPESIZELIST'} if exists $args{'TYPESIZELIST'};
    @argv = @{$args{'TYPES'}} if exists $args{'TYPES'};

    init_data_type_sizes();
    make_data_type_list();

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

    myprint ".";

    open_source_file();
#    output_includes();
    output_global_stacks();
#    output_global_variables();
    output_signal_helper();
    output_slot_helper();
    output_pig_hash();
    define_slots();
    myprint ".";
    define_signals();
    myprint ".";
    output_slot_matrix();
    output_signal_matrix();
    close_source_file();

    myprint "\n";
    open(STDOUT, ">&STDSAVE");
}

1;