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[\*&]?| TQPtrList| 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 => , # 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;