You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1110 lines
35 KiB
1110 lines
35 KiB
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;
|