libtqt-perl/PerlTQt/TQt.pm

package TQt::base;
use strict;

sub this () {}

sub new {
    no strict 'refs';
    my $t = this;
    shift->NEW(@_);
    my $ret = this;
    TQt::_internal::setThis($t);
    return $ret;
}

package TQt::base::_overload;
use strict;

no strict 'refs';
use overload
    "fallback" => 1,
    "==" => "TQt::base::_overload::op_equal",
    "!=" => "TQt::base::_overload::op_not_equal",
    "+=" => "TQt::base::_overload::op_plus_equal",
    "-=" => "TQt::base::_overload::op_minus_equal",
    "*=" => "TQt::base::_overload::op_mul_equal",
    "/=" => "TQt::base::_overload::op_div_equal",
    ">>" => "TQt::base::_overload::op_shift_right",
    "<<" => "TQt::base::_overload::op_shift_left",
    "<=" => "TQt::base::_overload::op_lesser_equal",
    ">=" => "TQt::base::_overload::op_greater_equal",
    "^=" => "TQt::base::_overload::op_xor_equal",
    "|=" => "TQt::base::_overload::op_or_equal",
    ">"  => "TQt::base::_overload::op_greater",
    "<"  => "TQt::base::_overload::op_lesser",
    "+"  => "TQt::base::_overload::op_plus",
    "-"  => "TQt::base::_overload::op_minus",
    "*"  => "TQt::base::_overload::op_mul",
    "/"  => "TQt::base::_overload::op_div",
    "^"  => "TQt::base::_overload::op_xor",
    "|"  => "TQt::base::_overload::op_or",
    "--" => "TQt::base::_overload::op_decrement",
    "++" => "TQt::base::_overload::op_increment",
    "neg"=> "TQt::base::_overload::op_negate";

sub op_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator==';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator==';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret
}

sub op_not_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator!=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator!=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret
}

sub op_plus_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator+=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator+=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret
}

sub op_minus_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator-=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator-=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_mul_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator*=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator*=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_div_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator/=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator/=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_shift_right {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator>>';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator>>';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_shift_left {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator<<';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator<<';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret
}

sub op_lesser_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator<=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    $TQt::_internal::strictArgMatch = 0;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator<=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_greater_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator>=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator>=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_xor_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator^=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator^=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_or_equal {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator|=';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return ($_[2] ? $_[1] : $_[0]) unless $err = $@;
    my $ret;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator|=';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@; 
    $ret
}

sub op_greater {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator>';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator>';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_lesser {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator<';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator<';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_plus {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator+';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator+';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_minus {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator-';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator-';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_mul {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator*';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator*';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret     
}

sub op_div {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator/';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator/';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret     
}

sub op_negate {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator-';
    my $autoload = ref($_[0])."::AUTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->($_[0]) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator-';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload($_[0]) };
    die $err.$@ if $@;
    $ret
}

sub op_xor {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator^';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator^';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_or {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator|';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my ($ret, $err);
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $ret = $autoload->(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    $TQt::_internal::strictArgMatch = 0;
    return $ret unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator|';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; $ret = &$autoload(($_[2] ? (@_)[1,0] : (@_)[0,1])) };
    die $err.$@ if $@;
    $ret    
}

sub op_increment {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator++';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->($_[0]) };
    $TQt::_internal::strictArgMatch = 0;
    return $_[0] unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator++';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; &$autoload($_[0]) };
    die $err.$@ if $@; 
    $_[0]
}

sub op_decrement {
    $TQt::AutoLoad::AUTOLOAD = ref($_[0]).'::operator--';
    my $autoload = ref($_[0])."::_UTOLOAD";
    my $err;
    $TQt::_internal::strictArgMatch = 1;
    eval { local $SIG{'__DIE__'}; $autoload->($_[0]) };
    $TQt::_internal::strictArgMatch = 0;
    return $_[0] unless $err = $@;
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GlobalSpace::operator--';
    $autoload = "TQt::GlobalSpace::_UTOLOAD";
    eval { local $SIG{'__DIE__'}; &$autoload($_[0]) };
    die $err.$@ if $@;
    $_[0]
}

package TQt::_internal;

use strict;

our $Classes;
our %CppName;
our @IdClass;

our @PersistentObjects;   # objects which need a "permanent" reference in Perl
our @sigslots;
our $strictArgMatch = 0;

sub this () {}


sub init_class {
    no strict 'refs';
    my $c = shift;
    my $class = $c;
    $class =~ s/^Q(?=[A-Z])/TQt::/;
    my $classId = TQt::_internal::idClass($c);
    insert_pclassid($class, $classId);

    $IdClass[$classId] = $class;
    $CppName{$class} = $c;
    TQt::_internal::installautoload("$class");
    {
	package TQt::AutoLoad;   # this package holds $AUTOLOAD
	my $closure = \&{ "$class\::_UTOLOAD" };
	*{ $class . "::AUTOLOAD" } =  sub{ &$closure };
    }

    my @isa = TQt::_internal::getIsa($classId);
    for my $super (@isa) {
	$super =~ s/^Q(?=[A-Z])/TQt::/;
    }
    # the general base class is TQt::base.
    # implicit new(@_) calls are forwarded there.
    @isa = ("TQt::base") unless @isa;
    *{ "$class\::ISA" } = \@isa;

    TQt::_internal::installautoload(" $class");
    {
	package TQt::AutoLoad;
	# do lookup at compile-time
	my $autosub = \&{ " $class\::_UTOLOAD" };
	*{ " $class\::AUTOLOAD" } = sub { &$autosub };
    }

    *{ " $class\::ISA" } = ["TQt::base::_overload"];

    *{ "$class\::NEW" } = sub {
	my $class = shift;
	$TQt::AutoLoad::AUTOLOAD = "$class\::$c";
	my $autoload = " $class\::_UTOLOAD";
        {
            no warnings;
            # the next line triggers a warning on SuSE's Perl 5.6.1 (?)
	    setThis(bless &$autoload, " $class");
        }
        setAllocated(this, 1);
	mapObject(this);
    } unless defined &{"$class\::NEW"};

    *{ $class } = sub {
	$class->new(@_);
    } unless defined &{ $class };
}

sub argmatch {
    my $methods = shift;
    my $args = shift;
    my $i = shift;
    my %match;
    my $argtype = getSVt($args->[$i]);
    for my $methix(0..$#$methods) {
	my $method = $$methods[$methix];
	my $typename = getTypeNameOfArg($method, $i);
	if($argtype eq 'i') {
	    if($typename =~ /^(?:bool|(?:(?:un)?signed )?(?:int|long)|uint)[*&]?$/) {
		$match{$method} = [0,$methix];
	    }
	} elsif($argtype eq 'n') {
	    if($typename =~ /^(?:float|double)$/) {
		$match{$method} = [0,$methix];
	    }
	} elsif($argtype eq 's') {
	    if($typename =~ /^(?:(?:const )?u?char\*|(?:const )?(?:(Q(C?)String)|TQByteArray)[*&]?)$/) {
		# the below read as: is it a (Q(C)String) ? ->priority 1
		# is it a (TQString)  ? -> priority 2
		# neither: normal priority
		# Watch the capturing parens vs. non-capturing (?:)
		$match{$method}[0] = defined $2 && $2 ? 1 : ( defined $1 ? 2 : 0 );
		$match{$method}[1] = $methix
	    }
	} elsif($argtype eq 'a') {
            # FIXME: shouldn't be hardcoded. Installed handlers should tell what perl type they expect.
            if($typename =~ /^(?:
                                const\ TQCOORD\*|
                                (?:const\ )?
                                (?:
                                  Q(?:String|Widget|Object|FileInfo|CanvasItem)List[\*&]?|
                                  TQValueList<int>[\*&]?|
                                  TQPtrList<Q(?:Tab|ToolBar|DockWindow|NetworkOperation)>|
                                  TQRgb\*|
                                  char\*\*
                                )
                              )$/x) {
                $match{$method} = [0,$methix];
            }
	} elsif($argtype eq 'r' or $argtype eq 'U') {
	    $match{$method} = [0,$methix];
	} else {
	    my $t = $typename;
	    $t =~ s/^const\s+//;
	    $t =~ s/(?<=\w)[&*]$//;
	    my $isa = classIsa($argtype, $t);
	    if($isa != -1) {
		$match{$method} = [-$isa,$methix];
	    }
	}
    }
    return sort { $match{$b}[0] <=> $match{$a}[0] or $match{$a}[1] <=> $match{$b}[1] } keys %match;
}

sub objmatch {
    my $method = shift;
    my $args = shift;
    for my $i(0..$#$args) {
	my $argtype = getSVt($$args[$i]);
	my $t = getTypeNameOfArg($method, $i);
	next if length $argtype == 1;
	$t =~ s/^const\s+//;
	$t =~ s/(?<=\w)[&*]$//;
	return 0 unless classIsa($argtype, $t) != -1;
    }
    1;
}

sub do_autoload {
    my $package = pop;
    my $method = pop;
    my $classId = pop;

    my $class = $CppName{$IdClass[$classId]};
    my @methods = ($method);
    for my $arg (@_) {
	unless(defined $arg) {
	    @methods = map { $_ . '?', $_ . '#', $_ . '$' } @methods;
	} elsif(isObject($arg)) {
	    @methods = map { $_ . '#' } @methods;
	} elsif(ref $arg) {
	    @methods = map { $_ . '?' } @methods;
	} else {
	    @methods = map { $_ . '$' } @methods;
	}
    }
    my @methodids = map { findMethod($class, $_) } @methods;
#   @methodids = map { findMethod('TQGlobalSpace', $_) } @methods 
#			if (!@methodids and $withObject || $class eq 'TQt');

    if(@methodids > 1) {
	# ghetto method resolution
	my $count = scalar @_;
	for my $i (0..$count-1) {
	    my @matching = argmatch(\@methodids, \@_, $i);
	    @methodids = @matching if @matching or $strictArgMatch;
	}
        do {
            my $c = ($method eq $class)? 4:2;
            warn "Ambiguous method call for :\n".
                "\t${class}::${method}(".catArguments(\@_).")".
             ((debug() && (debug() & $TQt::debug::channel{'verbose'})) ?
             "\nCandidates are:\n".dumpCandidates(\@methodids).
             "\nTaking first one...\nat " : "").
             (caller($c))[1]." line ".(caller($c))[2].".\n"
        } if debug() && @methodids > 1 && (debug() & $TQt::debug::channel{'ambiguous'});

    }
    elsif( @methodids == 1 and @_ ) {
	@methodids = () unless objmatch($methodids[0], \@_)
    }
    unless(@methodids) {
	if(@_) {
	    @methodids = findMethod($class, $method);
	    do {
                do {
                    my $c = ($method eq $class)? 4:2;
                    warn "Lookup for ${class}::${method}(".catArguments(\@_).
                         ")\ndid not yeld any result.\n".
                         ((debug() && (debug() & $TQt::debug::channel{'verbose'})) ?
                         "Might be a call for an enumerated value (enum).\n":"").
                         "Trying ${class}::${method}() with no arguments\nat ".
                         (caller($c))[1]." line ".(caller($c))[2].".\n"
                } if debug() && @_ > 1 && (debug() & $TQt::debug::channel{'ambiguous'});
                @_ = ()
            } if @methodids;
	}
	do{
            my $verbose = "";
            if(debug() && (debug() & $TQt::debug::channel{'verbose'})) {
                my $alt = findAllMethods( $classId );
                getAllParents($classId, \my @sup);
                for my $s(@sup)
                {
                    my $h = findAllMethods( $s );
                    map { $alt->{$_} = $h->{$_} } keys %$h
                }
                my $pat1 = my $pat2 = $method;
                my @near = ();
                while(!@near && length($pat1)>2) {
                    @near = map { /$pat1|$pat2/i ? @{ $$alt{$_} }:() } sort keys %$alt;
                    chop $pat1;
                    substr($pat2,-1,1)= "";
                }
                $verbose = @near ? ("\nCloser candidates are :\n".dumpCandidates(\@near)) :
                                    "\nNo close candidate found.\n";
            }
            my $c = ($method eq $class)? 4:2;

            die "--- No method to call for :\n\t${class}::${method}(".
            catArguments(\@_).")".$verbose."\nat ".(caller($c))[1].
            " line ".(caller($c))[2].".\n";
          } unless @methodids;
    }
    setCurrentMethod($methodids[0]);
    return 1;
}

sub init {
    no warnings;
    installthis(__PACKAGE__);
    installthis("TQt::base");
    $Classes = getClassList();
    for my $c (@$Classes) {
	init_class($c);
    }
}

sub splitUnnested {
        my $string = shift;
        my(%open) = (
            '[' => ']',
            '(' => ')',
            '<' => '>',
            '{' => '}',
        );
        my(%close) = reverse %open;
        my @ret;
        my $depth = 0;
        my $start = 0;
        $string =~ tr/"'//;
        while($string =~ /([][}{)(><,])/g) {
            my $c = $1;
            if(!$depth and $c eq ',') {
                my $len = pos($string) - $start - 1;
                my $ret = substr($string, $start, $len);
                $ret =~ s/^\s*(.*?)\s*$/$1/;
                push @ret, $ret;
                $start = pos($string);
            } elsif($open{$c}) {
                $depth++;
            } elsif($close{$c}) {
                $depth--;
            }
        }
        my $subs = substr($string, $start);
        $subs =~ s/^\s*(.*?)\s*$/$1/;
        push @ret, $subs if ($subs);
        return @ret;
}

sub getSubName
{
    my $glob = getGV( shift );
    return ( $glob =~ /^.*::(.*)$/ )[0];
}

sub TQt::Application::NEW {
    my $class = shift;
    my $argv = shift;
    unshift @$argv, $0;
    my $count = scalar @$argv;
    setThis( bless TQt::Application::TQApplication($count, $argv, @_), " $class" );
    mapObject(this);
    setAllocated(this, 1);
    setqapp(this);
    shift @$argv;
}

sub TQt::Image::NEW {
    no strict 'refs';
    # another ugly hack, whee
    my $class = shift;
    if(@_ == 6) {
	my $colortable = $_[4];
	my $numColors = (ref $colortable eq 'ARRAY') ? @$colortable : 0;
	splice(@_, 5, 0, $numColors);
    }

    # FIXME: this is evil
    $TQt::AutoLoad::AUTOLOAD = 'TQt::Image::TQImage';
    my $autoload = " TQt::Image::_UTOLOAD";
    dontRecurse();
    setThis( $autoload->(@_) );
    setAllocated(this, 1);
}

sub makeMetaData {
    my $data = shift;
    my @tbl;
    for my $entry (@$data) {
	my @params;
	my $argcnt = scalar @{ $entry->{arguments} };
	for my $arg (@{ $entry->{arguments} }) {
	    push @params, make_TQUParameter($arg->{name}, $arg->{type}, 0, 1);
	}
	my $method = make_TQUMethod($entry->{name}, \@params);
	push @tbl, make_TQMetaData($entry->{prototype}, $method);
    }
    my $count = scalar @tbl;
    my $metadata = make_TQMetaData_tbl(\@tbl);
    return ($metadata, $count);
}

# This is the key function for signal/slots...
# All META hash entries have been defined by /lib/TQt/slots.pm and /lib/TQt/signals.pm
# Thereafter, /lib/TQt/isa.pm build the MetaObject by calling this function
# Here is the structure of the META hash:
# META { 'slot' => { $slotname-1 => { name      =>  $slotname-1,
#                                     arguments => xxx,
#                                     prototype => xxx,
#                                     returns   => xxx,
#                                     method    => xxx,
#                                     index     => <index in 'slots' array>,
#                                     mocargs   => xxx,
#                                     argcnt    => xxx },
#                     ... ,
#                    $slotname-n => ...
#                  },
#       'slots' => [ slot1-hash, slot2-hash...slot-n-hash ],
#       'signal' => ibidem,
#       'signals' => ibidem,
#       'superClass' => ["classname1", .."classname-n"] # inherited
#     }

sub getMetaObject {
    no strict 'refs';
    my $class = shift;
    my $meta = \%{ $class . '::META' };
    return $meta->{object} if $meta->{object} and !$meta->{changed};
    updateSigSlots() if( @sigslots );
    inheritSuperSigSlots($class);
    my($slot_tbl, $slot_tbl_count) = makeMetaData($meta->{slots});
    my($signal_tbl, $signal_tbl_count) = makeMetaData($meta->{signals});
    $meta->{object} = make_metaObject($class, TQt::this()->staticMetaObject,
		$slot_tbl, $slot_tbl_count,
		$signal_tbl, $signal_tbl_count);
    $meta->{changed} = 0;
    return $meta->{object};
}

sub updateSigSlots
{
    require TQt::signals;
    require TQt::slots;
    for my $i (@sigslots) {
        no strict 'refs';
        my $mod = "TQt::" . lc($$i[0]) . ( substr($$i[0], 0, 1) eq 'S' ? 's' : '' ) . "::import";
        $mod->( $$i[1], getSubName($$i[2]) => $$i[3] );
    }
    @sigslots = ();
}

sub inheritSuperSigSlots {
    no strict 'refs';
    my $class = shift;
    my $meta = \%{ $class . '::META' };
    if(defined $meta->{'superClass'} && @{ $meta->{'superClass'} }) {
        for my $super(@{$meta->{'superClass'}}) {
            inheritSuperSigSlots($super);
            for my $ssn(keys %{${$super.'::META'}{slot}}) {
               if(!exists $meta->{slot}->{"$ssn"}) {
                   my %ss = %{${$super.'::META'}{slot}{$ssn}};
                   push @{$meta->{slots}}, \%ss;
                   $meta->{slot}->{$ssn} = \%ss;
                   $ss{index} = $#{ $meta->{slots} };
               }
            }
            for my $ssn(keys %{${$super.'::META'}{signal}}) {
               if(!exists $meta->{signal}->{"$ssn"}) {
                   my %ss = %{${$super.'::META'}{signal}{$ssn}};
                   push @{$meta->{signals}}, \%ss;
                   $meta->{signal}->{$ssn} = \%ss;
                   $ss{index} = $#{ $meta->{signals} };
                   TQt::_internal::installsignal("$class\::$ssn");
               }
            }
            TQt::_internal::installqt_invoke($class . '::tqt_invoke')
                if( !defined &{ $class. '::tqt_invoke' } && exists $meta->{slots} && @{ $meta->{slots} });
            TQt::_internal::installqt_invoke($class . '::tqt_emit')
                if( !defined &{ $class. '::tqt_emit' } && exists $meta->{signals} && @{ $meta->{signals} });
        }
    }
}

sub getAllParents
{
   my $classId = shift;
   my $res = shift;
   my @classes = TQt::_internal::getIsa( $classId );
   for my $s( @classes )
   {
       my $c = TQt::_internal::idClass($s);
       push @{ $res }, $c;
       getAllParents($c, $res)
   }
}

sub TQt::PointArray::setPoints {
    my $points = $_[0];
    no strict 'refs';
    # what a horrible, horrible way to do this
    $TQt::AutoLoad::AUTOLOAD = 'TQt::PointArray::setPoints';
    my $autoload = " TQt::PointArray::_UTOLOAD";
    dontRecurse();
    $autoload->(scalar(@$points)/2, $points);
}

sub TQt::GridLayout::addMultiCellLayout {
    # yet another hack. Turnaround for a bug in TQt < 3.1
    # (addMultiCellLayout doesn't reparent its TQLayout argument)
    no strict 'refs';
    if(!defined $_[0]->{'has been hidden'})
    {
        push @{ this()->{'hidden children'} }, $_[0];
        $_[0]->{'has been hidden'} = 1;
    }
    $TQt::AutoLoad::AUTOLOAD = 'TQt::GridLayout::addMultiCellLayout';
    my $autoload = " TQt::GridLayout::_UTOLOAD";
    dontRecurse();
    $autoload->(@_);
}

package TQt::Object;
use strict;

sub  MODIFY_CODE_ATTRIBUTES
{
    package TQt::_internal;
    my ($package, $coderef, @attrs ) = @_;
    my @reject;
    foreach my $attr( @attrs )
    {
        if( $attr !~ /^ (SIGNAL|SLOT|DCOP) \(( .* )\) $/x )
        {
             push @reject, $attr;
             next;
        }
        push @sigslots,
             [ $1, $package, $coderef, [ splitUnnested( $2 ) ] ];
    }
    if( @sigslots )
    {
        no strict 'refs';
        my $meta = \%{ $package . '::META' };
        $meta->{ 'changed' } = 1;
    }
    return @reject;
}

package TQt;

use 5.006;
use strict;
use warnings;
use XSLoader;

require Exporter;

our $VERSION = '3.008';

our @EXPORT = qw(&TQT_SIGNAL &TQT_SLOT &CAST &emit &min &max);

XSLoader::load 'TQt', $VERSION;

# try to avoid KDE's buggy malloc
# only works for --enable-fast-malloc,
# not when --enable-fast-malloc=full
$ENV{'TDE_MALLOC'} = 0;

TQt::_internal::init();

# In general, I'm not a fan of prototypes.
# However, I'm also not a fan of parentheses

sub TQT_SIGNAL ($) { '2' . $_[0] }
sub TQT_SLOT ($) { '1' . $_[0] }
sub CAST ($$) { bless $_[0], " $_[1]" }
sub emit (@) { pop @_ }
sub min ($$) { $_[0] < $_[1] ? $_[0] : $_[1] }
sub max ($$) { $_[0] > $_[1] ? $_[0] : $_[1] }

sub import { goto &Exporter::import }

sub TQt::base::ON_DESTROY { 0 };

sub TQt::Object::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->parent;
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
        this()->{"has been hidden"} = 1;
        return 1
    }
    return 0
}

sub TQt::Application::ON_DESTROY { 0 }

# we need to solve an ambiguity for Q*Items: they aren't TQObjects,
# and are meant to be created on the heap / destroyed manually.
# On the one hand, we don't want to delete them if they are still owned by a TQObject hierarchy
# but on the other hand, what can we do if the user DOES need to destroy them?
#
# So the solution adopted here is to use the takeItem() method when it exists
# to lower the refcount and allow explicit destruction/removal.

sub TQt::ListViewItem::ON_DESTROY {
    package TQt::_internal;
    my $parent = this()->listView();
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this) } = this();
        this()->{"has been hidden"} = 1;
        setAllocated( this(), 0 );
        return 1
    }
    setAllocated( this(), 1 );
    return 0
}

sub TQt::ListViewItem::takeItem
{
    package TQt::_internal;
    delete ${ this()->{"hidden children"} } { sv_to_ptr($_[0]) };
    delete $_[0]->{"has been hidden"};
    setAllocated( $_[0], 1 );
    no strict 'refs';
    $TQt::AutoLoad::AUTOLOAD = 'TQt::ListViewItem::takeItem';
    my $autoload = " TQt::ListViewItem::_UTOLOAD";
    dontRecurse();
    $autoload->( $_[0] );
}

sub TQt::ListView::takeItem
{
    package TQt::_internal;
    delete ${ this()->{"hidden children"} } { sv_to_ptr($_[0]) };
    delete $_[0]->{"has been hidden"};
    setAllocated( $_[0], 1 );
    no strict 'refs';
    $TQt::AutoLoad::AUTOLOAD = 'TQt::ListView::takeItem';
    my $autoload = " TQt::ListView::_UTOLOAD";
    dontRecurse();
    $autoload->( $_[0] );
}

sub TQt::IconViewItem::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->iconView;
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
        this()->{"has been hidden"} = 1;
        setAllocated( this(), 0 );
        return 1
    }
    setAllocated( this(), 1 );
    return 0
}

sub TQt::IconView::takeItem
{
    package TQt::_internal;
    delete ${ this()->{"hidden children"} } { sv_to_ptr($_[0]) };
    delete $_[0]->{"has been hidden"};
    setAllocated( $_[0], 1 );
    no strict 'refs';
    $TQt::AutoLoad::AUTOLOAD = 'TQt::IconView::takeItem';
    my $autoload = " TQt::IconView::_UTOLOAD";
    TQt::_internal::dontRecurse();
    $autoload->( $_[0] );
}


sub TQt::ListBoxItem::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->listBox();
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
        this()->{"has been hidden"} = 1;
        setAllocated( this(), 0 );
        return 1
    }
    setAllocated( this(), 1 );
    return 0
}

sub TQt::ListBox::takeItem
{
    # Unfortunately, takeItem() won't reset the Item's listBox() pointer to 0.
    # That's a TQt bug (I reported it and it got fixed as of TQt 3.2b2)
    package TQt::_internal;
    delete ${ this()->{"hidden children"} } { sv_to_ptr($_[0]) };
    delete $_[0]->{"has been hidden"};
    setAllocated( $_[0], 1 );
    no strict 'refs';
    $TQt::Autoload::AUTOLOAD = 'TQt::ListBox::takeItem';
    my $autoload = " TQt::ListBox::_UTOLOAD";
    dontRecurse();
    $autoload->( $_[0] );
}

sub TQt::TableItem::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->table;
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
        this()->{"has been hidden"} = 1;
        setAllocated( this(), 0 );
        return 1
    }
    setAllocated( this(), 1 );
    return 0
}

sub TQt::Table::takeItem
{
    package TQt::_internal;
    delete ${ this()->{"hidden children"} } { sv_to_ptr($_[0]) };
    delete $_[0]->{"has been hidden"};
    setAllocated( $_[0], 1 );
    no strict 'refs';
    $TQt::AutoLoad::AUTOLOAD = 'TQt::Table::takeItem';
    my $autoload = " TQt::Table::_UTOLOAD";
    dontRecurse();
    $autoload->( $_[0] );
}

sub TQt::LayoutItem::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->widget() || this()->layout();
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
    }
    else # a SpacerItem...
    {
        push @PersistentObjects, this();
    }
    this()->{"has been hidden"} = 1;
    setAllocated( this(), 0 );
    return 1
}

sub TQt::Layout::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->mainWidget() || this()->parent();
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
        this()->{"has been hidden"} = 1;
        return 1
    }
    return 0
}

sub TQt::StyleSheetItem::ON_DESTROY
{
    package TQt::_internal;
    my $parent = this()->styleSheet();
    if( $parent )
    {
        ${ $parent->{"hidden children"} } { sv_to_ptr(this()) } = this();
        this()->{"has been hidden"} = 1;
        setAllocated( this(), 0 );
        return 1
    }
    setAllocated( this(), 1 );
    return 0
}

sub TQt::SqlCursor::ON_DESTROY
{
    package TQt::_internal;
    push @PersistentObjects, this();
    this()->{"has been hidden"} = 1;
    setAllocated( this(), 0 );
    return 1
}

1;