summaryrefslogtreecommitdiffstats
path: root/PerlTQt/TQt.pm
diff options
context:
space:
mode:
Diffstat (limited to 'PerlTQt/TQt.pm')
-rw-r--r--PerlTQt/TQt.pm1109
1 files changed, 1109 insertions, 0 deletions
diff --git a/PerlTQt/TQt.pm b/PerlTQt/TQt.pm
new file mode 100644
index 0000000..69bcbca
--- /dev/null
+++ b/PerlTQt/TQt.pm
@@ -0,0 +1,1109 @@
+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 . '::qt_invoke')
+ if( !defined &{ $class. '::qt_invoke' } && exists $meta->{slots} && @{ $meta->{slots} });
+ TQt::_internal::installqt_invoke($class . '::qt_emit')
+ if( !defined &{ $class. '::qt_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{'KDE_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;
generated by cgit v1.2.1 (git 2.18.0) at 2024-06-05 05:48:51 +0000