From 55e5c730361b5f2640f155aef4518ca69c4fc1b4 Mon Sep 17 00:00:00 2001 From: Timothy Pearson Date: Sun, 1 Jan 2012 18:34:03 -0600 Subject: Move Qt files --- PerlTQt/Qt.pm | 1109 ---------------------------- PerlTQt/Qt.pod | 42 -- PerlTQt/Qt.xs | 2198 ------------------------------------------------------- PerlTQt/TQt.pm | 1109 ++++++++++++++++++++++++++++ PerlTQt/TQt.pod | 42 ++ PerlTQt/TQt.xs | 2198 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 3349 insertions(+), 3349 deletions(-) delete mode 100644 PerlTQt/Qt.pm delete mode 100644 PerlTQt/Qt.pod delete mode 100644 PerlTQt/Qt.xs create mode 100644 PerlTQt/TQt.pm create mode 100644 PerlTQt/TQt.pod create mode 100644 PerlTQt/TQt.xs (limited to 'PerlTQt') diff --git a/PerlTQt/Qt.pm b/PerlTQt/Qt.pm deleted file mode 100644 index 69bcbca..0000000 --- a/PerlTQt/Qt.pm +++ /dev/null @@ -1,1109 +0,0 @@ -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; diff --git a/PerlTQt/Qt.pod b/PerlTQt/Qt.pod deleted file mode 100644 index 2feceeb..0000000 --- a/PerlTQt/Qt.pod +++ /dev/null @@ -1,42 +0,0 @@ - -=head1 NAME - -PerlTQt - Perl interface to the TQt GUI Widget toolkit - -=head1 TQt - -Given the huge size of the TQt module -(more than 400 classes and 13000 methods) -it doesn't have any formal documentation. - -Instead, it provides two introspection tools - -=over 4 - -=item * pqtapi: - -a command line PerlTQt API introspector - -=item * pqtsh: - -a graphical PerlTQt shell - -=back - -and a detailed B with comprehensive -explanations. -This is where anyone new to PerlTQt -should start. - -The tutorial has been originally installed -on this system in C, in both B and -B format. - -For a complete IDE allowing RAD and visual programming, -check the pqt-designer package. - ---- The PerlTQt team - -http://perlqt.sf.net - PerlTQt Project Homepage - -=cut diff --git a/PerlTQt/Qt.xs b/PerlTQt/Qt.xs deleted file mode 100644 index 22a66de..0000000 --- a/PerlTQt/Qt.xs +++ /dev/null @@ -1,2198 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include "smoke.h" - -#undef DEBUG -#ifndef _GNU_SOURCE -#define _GNU_SOURCE -#endif -#ifndef __USE_POSIX -#define __USE_POSIX -#endif -#ifndef __USE_XOPEN -#define __USE_XOPEN -#endif -#ifdef _BOOL -#define HAS_BOOL -#endif -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef TQT_VERSION_STR -#define TQT_VERSION_STR "Unknown" -#endif - -#undef free -#undef malloc - -#include "marshall.h" -#include "perlqt.h" -#include "smokeperl.h" - -#ifndef IN_BYTES -#define IN_BYTES IN_BYTE -#endif - -#ifndef IN_LOCALE -#define IN_LOCALE (PL_curcop->op_private & HINT_LOCALE) -#endif - -extern Smoke *qt_Smoke; -extern void init_qt_Smoke(); - -int do_debug = qtdb_none; - -HV *pointer_map = 0; -SV *sv_qapp = 0; -int object_count = 0; -void *_current_object = 0; // TODO: ask myself if this is stupid - -bool temporary_virtual_function_success = false; - -static TQAsciiDict *methcache = 0; -static TQAsciiDict *classcache = 0; - -SV *sv_this = 0; - -Smoke::Index _current_object_class = 0; -Smoke::Index _current_method = 0; -/* - * Type handling by moc is simple. - * - * If the type name matches /^(?:const\s+)?\Q$types\E&?$/, use the - * static_TQUType, where $types is join('|', qw(bool int double char* TQString); - * - * Everything else is passed as a pointer! There are types which aren't - * Smoke::tf_ptr but will have to be passed as a pointer. Make sure to keep - * track of what's what. - */ - -/* - * Simply using typeids isn't enough for signals/slots. It will be possible - * to declare signals and slots which use arguments which can't all be - * found in a single smoke object. Instead, we need to store smoke => typeid - * pairs. We also need additional informatation, such as whether we're passing - * a pointer to the union element. - */ - -enum MocArgumentType { - xmoc_ptr, - xmoc_bool, - xmoc_int, - xmoc_double, - xmoc_charstar, - xmoc_TQString -}; - -struct MocArgument { - // smoke object and associated typeid - SmokeType st; - MocArgumentType argType; -}; - - -extern TypeHandler TQt_handlers[]; -void install_handlers(TypeHandler *); - -void *sv_to_ptr(SV *sv) { // ptr on success, null on fail - smokeperl_object *o = sv_obj_info(sv); - return o ? o->ptr : 0; -} - -bool isTQObject(Smoke *smoke, Smoke::Index classId) { - if(!strcmp(smoke->classes[classId].className, "TQObject")) - return true; - for(Smoke::Index *p = smoke->inheritanceList + smoke->classes[classId].parents; - *p; - p++) { - if(isTQObject(smoke, *p)) - return true; - } - return false; -} - -int isDerivedFrom(Smoke *smoke, Smoke::Index classId, Smoke::Index baseId, int cnt) { - if(classId == baseId) - return cnt; - cnt++; - for(Smoke::Index *p = smoke->inheritanceList + smoke->classes[classId].parents; - *p; - p++) { - if(isDerivedFrom(smoke, *p, baseId, cnt) != -1) - return cnt; - } - return -1; -} - -int isDerivedFrom(Smoke *smoke, const char *className, const char *baseClassName, int cnt) { - if(!smoke || !className || !baseClassName) - return -1; - Smoke::Index idClass = smoke->idClass(className); - Smoke::Index idBase = smoke->idClass(baseClassName); - return isDerivedFrom(smoke, idClass, idBase, cnt); -} - -SV *getPointerObject(void *ptr) { - HV *hv = pointer_map; - SV *keysv = newSViv((IV)ptr); - STRLEN len; - char *key = SvPV(keysv, len); - SV **svp = hv_fetch(hv, key, len, 0); - if(!svp){ - SvREFCNT_dec(keysv); - return 0; - } - if(!SvOK(*svp)){ - hv_delete(hv, key, len, G_DISCARD); - SvREFCNT_dec(keysv); - return 0; - } - return *svp; -} - -void unmapPointer(smokeperl_object *o, Smoke::Index classId, void *lastptr) { - HV *hv = pointer_map; - void *ptr = o->smoke->cast(o->ptr, o->classId, classId); - if(ptr != lastptr) { - lastptr = ptr; - SV *keysv = newSViv((IV)ptr); - STRLEN len; - char *key = SvPV(keysv, len); - if(hv_exists(hv, key, len)) - hv_delete(hv, key, len, G_DISCARD); - SvREFCNT_dec(keysv); - } - for(Smoke::Index *i = o->smoke->inheritanceList + o->smoke->classes[classId].parents; - *i; - i++) { - unmapPointer(o, *i, lastptr); - } -} - -// Store pointer in pointer_map hash : "pointer_to_TQt_object" => weak ref to associated Perl object -// Recurse to store it also as casted to its parent classes. - -void mapPointer(SV *obj, smokeperl_object *o, HV *hv, Smoke::Index classId, void *lastptr) { - void *ptr = o->smoke->cast(o->ptr, o->classId, classId); - if(ptr != lastptr) { - lastptr = ptr; - SV *keysv = newSViv((IV)ptr); - STRLEN len; - char *key = SvPV(keysv, len); - SV *rv = newSVsv(obj); - sv_rvweaken(rv); // weak reference! - hv_store(hv, key, len, rv, 0); - SvREFCNT_dec(keysv); - } - for(Smoke::Index *i = o->smoke->inheritanceList + o->smoke->classes[classId].parents; - *i; - i++) { - mapPointer(obj, o, hv, *i, lastptr); - } -} - -Marshall::HandlerFn getMarshallFn(const SmokeType &type); - -class VirtualMethodReturnValue : public Marshall { - Smoke *_smoke; - Smoke::Index _method; - Smoke::Stack _stack; - SmokeType _st; - SV *_retval; -public: - const Smoke::Method &method() { return _smoke->methods[_method]; } - SmokeType type() { return _st; } - Marshall::Action action() { return Marshall::FromSV; } - Smoke::StackItem &item() { return _stack[0]; } - SV *var() { return _retval; } - void unsupported() { - croak("Cannot handle '%s' as return-type of virtual method %s::%s", - type().name(), - _smoke->className(method().classId), - _smoke->methodNames[method().name]); - } - Smoke *smoke() { return _smoke; } - void next() {} - bool cleanup() { return false; } - VirtualMethodReturnValue(Smoke *smoke, Smoke::Index meth, Smoke::Stack stack, SV *retval) : - _smoke(smoke), _method(meth), _stack(stack), _retval(retval) { - _st.set(_smoke, method().ret); - Marshall::HandlerFn fn = getMarshallFn(type()); - (*fn)(this); - } -}; - -class VirtualMethodCall : public Marshall { - Smoke *_smoke; - Smoke::Index _method; - Smoke::Stack _stack; - GV *_gv; - int _cur; - Smoke::Index *_args; - SV **_sp; - bool _called; - SV *_savethis; - -public: - SmokeType type() { return SmokeType(_smoke, _args[_cur]); } - Marshall::Action action() { return Marshall::ToSV; } - Smoke::StackItem &item() { return _stack[_cur + 1]; } - SV *var() { return _sp[_cur]; } - const Smoke::Method &method() { return _smoke->methods[_method]; } - void unsupported() { - croak("Cannot handle '%s' as argument of virtual method %s::%s", - type().name(), - _smoke->className(method().classId), - _smoke->methodNames[method().name]); - } - Smoke *smoke() { return _smoke; } - void callMethod() { - dSP; - if(_called) return; - _called = true; - SP = _sp + method().numArgs - 1; - PUTBACK; - int count = call_sv((SV*)GvCV(_gv), G_SCALAR); - SPAGAIN; - VirtualMethodReturnValue r(_smoke, _method, _stack, POPs); - PUTBACK; - FREETMPS; - LEAVE; - } - void next() { - int oldcur = _cur; - _cur++; - while(!_called && _cur < method().numArgs) { - Marshall::HandlerFn fn = getMarshallFn(type()); - (*fn)(this); - _cur++; - } - callMethod(); - _cur = oldcur; - } - bool cleanup() { return false; } // is this right? - VirtualMethodCall(Smoke *smoke, Smoke::Index meth, Smoke::Stack stack, SV *obj, GV *gv) : - _smoke(smoke), _method(meth), _stack(stack), _gv(gv), _cur(-1), _sp(0), _called(false) { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - EXTEND(SP, method().numArgs); - _savethis = sv_this; - sv_this = newSVsv(obj); - _sp = SP + 1; - for(int i = 0; i < method().numArgs; i++) - _sp[i] = sv_newmortal(); - _args = _smoke->argumentList + method().args; - } - ~VirtualMethodCall() { - SvREFCNT_dec(sv_this); - sv_this = _savethis; - } -}; - -class MethodReturnValue : public Marshall { - Smoke *_smoke; - Smoke::Index _method; - SV *_retval; - Smoke::Stack _stack; -public: - MethodReturnValue(Smoke *smoke, Smoke::Index method, Smoke::Stack stack, SV *retval) : - _smoke(smoke), _method(method), _retval(retval), _stack(stack) { - Marshall::HandlerFn fn = getMarshallFn(type()); - (*fn)(this); - } - const Smoke::Method &method() { return _smoke->methods[_method]; } - SmokeType type() { return SmokeType(_smoke, method().ret); } - Marshall::Action action() { return Marshall::ToSV; } - Smoke::StackItem &item() { return _stack[0]; } - SV *var() { return _retval; } - void unsupported() { - croak("Cannot handle '%s' as return-type of %s::%s", - type().name(), - _smoke->className(method().classId), - _smoke->methodNames[method().name]); - } - Smoke *smoke() { return _smoke; } - void next() {} - bool cleanup() { return false; } -}; - -class MethodCall : public Marshall { - int _cur; - Smoke *_smoke; - Smoke::Stack _stack; - Smoke::Index _method; - Smoke::Index *_args; - SV **_sp; - int _items; - SV *_retval; - bool _called; -public: - MethodCall(Smoke *smoke, Smoke::Index method, SV **sp, int items) : - _smoke(smoke), _method(method), _sp(sp), _items(items), _cur(-1), _called(false) { - _args = _smoke->argumentList + _smoke->methods[_method].args; - _items = _smoke->methods[_method].numArgs; - _stack = new Smoke::StackItem[items + 1]; - _retval = newSV(0); - } - ~MethodCall() { - delete[] _stack; - SvREFCNT_dec(_retval); - } - SmokeType type() { return SmokeType(_smoke, _args[_cur]); } - Marshall::Action action() { return Marshall::FromSV; } - Smoke::StackItem &item() { return _stack[_cur + 1]; } - SV *var() { - if(_cur < 0) return _retval; - SvGETMAGIC(*(_sp + _cur)); - return *(_sp + _cur); - } - inline const Smoke::Method &method() { return _smoke->methods[_method]; } - void unsupported() { - croak("Cannot handle '%s' as argument to %s::%s", - type().name(), - _smoke->className(method().classId), - _smoke->methodNames[method().name]); - } - Smoke *smoke() { return _smoke; } - inline void callMethod() { - if(_called) return; - _called = true; - Smoke::ClassFn fn = _smoke->classes[method().classId].classFn; - void *ptr = _smoke->cast( - _current_object, - _current_object_class, - method().classId - ); - _items = -1; - (*fn)(method().method, ptr, _stack); - MethodReturnValue r(_smoke, _method, _stack, _retval); - } - void next() { - int oldcur = _cur; - _cur++; - - while(!_called && _cur < _items) { - Marshall::HandlerFn fn = getMarshallFn(type()); - (*fn)(this); - _cur++; - } - - callMethod(); - _cur = oldcur; - } - bool cleanup() { return true; } -}; - -class UnencapsulatedTQObject : public TQObject { -public: - TQConnectionList *public_receivers(int signal) const { return receivers(signal); } - void public_activate_signal(TQConnectionList *clist, TQUObject *o) { activate_signal(clist, o); } -}; - -class EmitSignal : public Marshall { - UnencapsulatedTQObject *_qobj; - int _id; - MocArgument *_args; - SV **_sp; - int _items; - int _cur; - Smoke::Stack _stack; - bool _called; -public: - EmitSignal(TQObject *qobj, int id, int items, MocArgument *args, SV **sp) : - _qobj((UnencapsulatedTQObject*)qobj), _id(id), _items(items), _args(args), - _sp(sp), _cur(-1), _called(false) { - _stack = new Smoke::StackItem[_items]; - } - ~EmitSignal() { - delete[] _stack; - } - const MocArgument &arg() { return _args[_cur]; } - SmokeType type() { return arg().st; } - Marshall::Action action() { return Marshall::FromSV; } - Smoke::StackItem &item() { return _stack[_cur]; } - SV *var() { return _sp[_cur]; } - void unsupported() { - croak("Cannot handle '%s' as signal argument", type().name()); - } - Smoke *smoke() { return type().smoke(); } - void emitSignal() { - if(_called) return; - _called = true; - - TQConnectionList *clist = _qobj->public_receivers(_id); - if(!clist) return; - - TQUObject *o = new TQUObject[_items + 1]; - for(int i = 0; i < _items; i++) { - TQUObject *po = o + i + 1; - Smoke::StackItem *si = _stack + i; - switch(_args[i].argType) { - case xmoc_bool: - static_TQUType_bool.set(po, si->s_bool); - break; - case xmoc_int: - static_TQUType_int.set(po, si->s_int); - break; - case xmoc_double: - static_TQUType_double.set(po, si->s_double); - break; - case xmoc_charstar: - static_TQUType_charstar.set(po, (char*)si->s_voidp); - break; - case xmoc_TQString: - static_TQUType_TQString.set(po, *(TQString*)si->s_voidp); - break; - default: - { - const SmokeType &t = _args[i].st; - void *p; - switch(t.elem()) { - case Smoke::t_bool: - p = &si->s_bool; - break; - case Smoke::t_char: - p = &si->s_char; - break; - case Smoke::t_uchar: - p = &si->s_uchar; - break; - case Smoke::t_short: - p = &si->s_short; - break; - case Smoke::t_ushort: - p = &si->s_ushort; - break; - case Smoke::t_int: - p = &si->s_int; - break; - case Smoke::t_uint: - p = &si->s_uint; - break; - case Smoke::t_long: - p = &si->s_long; - break; - case Smoke::t_ulong: - p = &si->s_ulong; - break; - case Smoke::t_float: - p = &si->s_float; - break; - case Smoke::t_double: - p = &si->s_double; - break; - case Smoke::t_enum: - { - // allocate a new enum value - Smoke::EnumFn fn = SmokeClass(t).enumFn(); - if(!fn) { - warn("Unknown enumeration %s\n", t.name()); - p = new int((int)si->s_enum); - break; - } - Smoke::Index id = t.typeId(); - (*fn)(Smoke::EnumNew, id, p, si->s_enum); - (*fn)(Smoke::EnumFromLong, id, p, si->s_enum); - // FIXME: MEMORY LEAK - } - break; - case Smoke::t_class: - case Smoke::t_voidp: - p = si->s_voidp; - break; - default: - p = 0; - break; - } - static_TQUType_ptr.set(po, p); - } - } - } - - _qobj->public_activate_signal(clist, o); - delete[] o; - } - void next() { - int oldcur = _cur; - _cur++; - - while(!_called && _cur < _items) { - Marshall::HandlerFn fn = getMarshallFn(type()); - (*fn)(this); - _cur++; - } - - emitSignal(); - _cur = oldcur; - } - bool cleanup() { return true; } -}; - -class InvokeSlot : public Marshall { - TQObject *_qobj; - GV *_gv; - int _items; - MocArgument *_args; - TQUObject *_o; - int _cur; - bool _called; - SV **_sp; - Smoke::Stack _stack; -public: - const MocArgument &arg() { return _args[_cur]; } - SmokeType type() { return arg().st; } - Marshall::Action action() { return Marshall::ToSV; } - Smoke::StackItem &item() { return _stack[_cur]; } - SV *var() { return _sp[_cur]; } - Smoke *smoke() { return type().smoke(); } - bool cleanup() { return false; } - void unsupported() { - croak("Cannot handle '%s' as slot argument\n", type().name()); - } - void copyArguments() { - for(int i = 0; i < _items; i++) { - TQUObject *o = _o + i + 1; - switch(_args[i].argType) { - case xmoc_bool: - _stack[i].s_bool = static_TQUType_bool.get(o); - break; - case xmoc_int: - _stack[i].s_int = static_TQUType_int.get(o); - break; - case xmoc_double: - _stack[i].s_double = static_TQUType_double.get(o); - break; - case xmoc_charstar: - _stack[i].s_voidp = static_TQUType_charstar.get(o); - break; - case xmoc_TQString: - _stack[i].s_voidp = &static_TQUType_TQString.get(o); - break; - default: // case xmoc_ptr: - { - const SmokeType &t = _args[i].st; - void *p = static_TQUType_ptr.get(o); - switch(t.elem()) { - case Smoke::t_bool: - _stack[i].s_bool = *(bool*)p; - break; - case Smoke::t_char: - _stack[i].s_char = *(char*)p; - break; - case Smoke::t_uchar: - _stack[i].s_uchar = *(unsigned char*)p; - break; - case Smoke::t_short: - _stack[i].s_short = *(short*)p; - break; - case Smoke::t_ushort: - _stack[i].s_ushort = *(unsigned short*)p; - break; - case Smoke::t_int: - _stack[i].s_int = *(int*)p; - break; - case Smoke::t_uint: - _stack[i].s_uint = *(unsigned int*)p; - break; - case Smoke::t_long: - _stack[i].s_long = *(long*)p; - break; - case Smoke::t_ulong: - _stack[i].s_ulong = *(unsigned long*)p; - break; - case Smoke::t_float: - _stack[i].s_float = *(float*)p; - break; - case Smoke::t_double: - _stack[i].s_double = *(double*)p; - break; - case Smoke::t_enum: - { - Smoke::EnumFn fn = SmokeClass(t).enumFn(); - if(!fn) { - warn("Unknown enumeration %s\n", t.name()); - _stack[i].s_enum = *(int*)p; - break; - } - Smoke::Index id = t.typeId(); - (*fn)(Smoke::EnumToLong, id, p, _stack[i].s_enum); - } - break; - case Smoke::t_class: - case Smoke::t_voidp: - _stack[i].s_voidp = p; - break; - } - } - } - } - } - void invokeSlot() { - dSP; - if(_called) return; - _called = true; - - SP = _sp + _items - 1; - PUTBACK; - int count = call_sv((SV*)GvCV(_gv), G_SCALAR); - SPAGAIN; - SP -= count; - PUTBACK; - FREETMPS; - LEAVE; - } - void next() { - int oldcur = _cur; - _cur++; - - while(!_called && _cur < _items) { - Marshall::HandlerFn fn = getMarshallFn(type()); - (*fn)(this); - _cur++; - } - - invokeSlot(); - _cur = oldcur; - } - InvokeSlot(TQObject *qobj, GV *gv, int items, MocArgument *args, TQUObject *o) : - _qobj(qobj), _gv(gv), _items(items), _args(args), _o(o), _cur(-1), _called(false) { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - EXTEND(SP, items); - PUTBACK; - _sp = SP + 1; - for(int i = 0; i < _items; i++) - _sp[i] = sv_newmortal(); - _stack = new Smoke::StackItem[_items]; - copyArguments(); - } - ~InvokeSlot() { - delete[] _stack; - } - -}; - -class TQtSmokeBinding : public SmokeBinding { -public: - TQtSmokeBinding(Smoke *s) : SmokeBinding(s) {} - void deleted(Smoke::Index classId, void *ptr) { - SV *obj = getPointerObject(ptr); - smokeperl_object *o = sv_obj_info(obj); - if(do_debug && (do_debug & qtdb_gc)) { - fprintf(stderr, "%p->~%s()\n", ptr, smoke->className(classId)); - } - if(!o || !o->ptr) { - return; - } - unmapPointer(o, o->classId, 0); - o->ptr = 0; - } - bool callMethod(Smoke::Index method, void *ptr, Smoke::Stack args, bool isAbstract) { - SV *obj = getPointerObject(ptr); - smokeperl_object *o = sv_obj_info(obj); - if(do_debug && (do_debug & qtdb_virtual)) fprintf(stderr, "virtual %p->%s::%s() called\n", ptr, - smoke->classes[smoke->methods[method].classId].className, - smoke->methodNames[smoke->methods[method].name] - ); - - if(!o) { - if(!PL_dirty && (do_debug && (do_debug & qtdb_virtual)) ) // if not in global destruction - fprintf(stderr, "Cannot find object for virtual method\n"); - return false; - } - HV *stash = SvSTASH(SvRV(obj)); - if(*HvNAME(stash) == ' ') - stash = gv_stashpv(HvNAME(stash) + 1, TRUE); - const char *methodName = smoke->methodNames[smoke->methods[method].name]; - GV *gv = gv_fetchmethod_autoload(stash, methodName, 0); - if(!gv) return false; - - VirtualMethodCall c(smoke, method, args, obj, gv); - // exception variable, just temporary - temporary_virtual_function_success = true; - c.next(); - bool ret = temporary_virtual_function_success; - temporary_virtual_function_success = true; - return ret; - } - char *className(Smoke::Index classId) { - const char *className = smoke->className(classId); - char *buf = new char[strlen(className) + 6]; - strcpy(buf, " TQt::"); - strcat(buf, className + 1); - return buf; - } -}; - -// ---------------- Helpers ------------------- - -SV *catArguments(SV** sp, int n) -{ - SV* r=newSVpvf(""); - for(int i = 0; i < n; i++) { - if(i) sv_catpv(r, ", "); - if(!SvOK(sp[i])) { - sv_catpv(r, "undef"); - } else if(SvROK(sp[i])) { - smokeperl_object *o = sv_obj_info(sp[i]); - if(o) - sv_catpv(r, o->smoke->className(o->classId)); - else - sv_catsv(r, sp[i]); - } else { - bool isString = SvPOK(sp[i]); - STRLEN len; - char *s = SvPV(sp[i], len); - if(isString) sv_catpv(r, "'"); - sv_catpvn(r, s, len > 10 ? 10 : len); - if(len > 10) sv_catpv(r, "..."); - if(isString) sv_catpv(r, "'"); - } - } - return r; -} - -Smoke::Index package_classid(const char *p) -{ - Smoke::Index *item = classcache->find(p); - if(item) - return *item; - char *nisa = new char[strlen(p)+6]; - strcpy(nisa, p); - strcat(nisa, "::ISA"); - AV* isa=get_av(nisa, true); - delete[] nisa; - for(int i=0; i<=av_len(isa); i++) { - SV** np = av_fetch(isa, i, 0); - if(np) { - Smoke::Index ix = package_classid(SvPV_nolen(*np)); - if(ix) { - classcache->insert(p, new Smoke::Index(ix)); - return ix; - } - } - } - return (Smoke::Index) 0; -} - -char *get_SVt(SV *sv) -{ - char *r; - if(!SvOK(sv)) - r = "u"; - else if(SvIOK(sv)) - r = "i"; - else if(SvNOK(sv)) - r = "n"; - else if(SvPOK(sv)) - r = "s"; - else if(SvROK(sv)) { - smokeperl_object *o = sv_obj_info(sv); - if(!o) { - switch (SvTYPE(SvRV(sv))) { - case SVt_PVAV: - r = "a"; - break; -// case SVt_PV: -// case SVt_PVMG: -// r = "p"; - default: - r = "r"; - } - } - else - r = (char*)o->smoke->className(o->classId); - } - else - r = "U"; - return r; -} - -SV *prettyPrintMethod(Smoke::Index id) { - SV *r = newSVpvf(""); - Smoke::Method &meth = qt_Smoke->methods[id]; - const char *tname = qt_Smoke->types[meth.ret].name; - if(meth.flags & Smoke::mf_static) sv_catpv(r, "static "); - sv_catpvf(r, "%s ", (tname ? tname:"void")); - sv_catpvf(r, "%s::%s(", qt_Smoke->classes[meth.classId].className, qt_Smoke->methodNames[meth.name]); - for(int i = 0; i < meth.numArgs; i++) { - if(i) sv_catpv(r, ", "); - tname = qt_Smoke->types[qt_Smoke->argumentList[meth.args+i]].name; - sv_catpv(r, (tname ? tname:"void")); - } - sv_catpv(r, ")"); - if(meth.flags & Smoke::mf_const) sv_catpv(r, " const"); - return r; -} - -// --------------- Unary Keywords && Attributes ------------------ - - -// implements unary 'this' -XS(XS_this) { - dXSARGS; - ST(0) = sv_this; - XSRETURN(1); -} - -// implements unary attributes: 'foo' means 'this->{foo}' -XS(XS_attr) { - dXSARGS; - char *key = GvNAME(CvGV(cv)); - U32 klen = strlen(key); - SV **svp = 0; - if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) { - HV *hv = (HV*)SvRV(sv_this); - svp = hv_fetch(hv, key, klen, 1); - } - if(svp) { - ST(0) = *svp; - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -// implements unary SUPER attribute: 'SUPER' means ${(CopSTASH)::_INTERNAL_STATIC_}{SUPER} -XS(XS_super) { - dXSARGS; - char *key = "SUPER"; - U32 klen = strlen(key); - SV **svp = 0; - if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) { - HV *cs = (HV*)CopSTASH(PL_curcop); - if(!cs) XSRETURN_UNDEF; - svp = hv_fetch(cs, "_INTERNAL_STATIC_", 17, 0); - if(!svp) XSRETURN_UNDEF; - cs = GvHV((GV*)*svp); - if(!cs) XSRETURN_UNDEF; - svp = hv_fetch(cs, "SUPER", 5, 0); - } - if(svp) { - ST(0) = *svp; - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -//---------- XS Autoload (for all functions except fully qualified statics & enums) --------- - -static inline bool isTQt(char *p) { - return (p[0] == 'Q' && p[1] && p[1] == 't' && ((p[2] && p[2] == ':') || !p[2])); -} - -bool avoid_fetchmethod = false; -XS(XS_AUTOLOAD) { - // Err, XS autoload is borked. Lets try... - dXSARGS; - SV *sv = get_sv("TQt::AutoLoad::AUTOLOAD", TRUE); - char *package = SvPV_nolen(sv); - char *method = 0; - for(char *s = package; *s ; s++) - if(*s == ':') method = s; - if(!method) XSRETURN_NO; - *(method++ - 1) = 0; // sorry for showing off. :) - int withObject = (*package == ' ') ? 1 : 0; - int isSuper = 0; - if(withObject) { - package++; - if(*package == ' ') { - isSuper = 1; - char *super = new char[strlen(package) + 7]; - package++; - strcpy(super, package); - strcat(super, "::SUPER"); - package = super; - } - } else if( isTQt(package) ) - avoid_fetchmethod = true; - - HV *stash = gv_stashpv(package, TRUE); - - if(do_debug && (do_debug & qtdb_autoload)) - warn("In XS Autoload for %s::%s()\n", package, method); - - // check for user-defined methods in the REAL stash; skip prefix - GV *gv = 0; - if(avoid_fetchmethod) - avoid_fetchmethod = false; - else - gv = gv_fetchmethod_autoload(stash, method, 0); - - // If we've made it here, we need to set sv_this - if(gv) { - if(do_debug && (do_debug & qtdb_autoload)) - warn("\tfound in %s's Perl stash\n", package); - - // call the defined Perl method with new 'this' - SV *old_this; - if(withObject && !isSuper) { - old_this = sv_this; - sv_this = newSVsv(ST(0)); - } - - ENTER; - SAVETMPS; - PUSHMARK(SP - items + withObject); - PUTBACK; - int count = call_sv((SV*)GvCV(gv), G_SCALAR|G_EVAL); - SPAGAIN; - SV *ret = newSVsv(TOPs); - SP -= count; - PUTBACK; - FREETMPS; - LEAVE; - - if(withObject && !isSuper) { - SvREFCNT_dec(sv_this); - sv_this = old_this; - } - else if(isSuper) - delete[] package; - - if(SvTRUE(ERRSV)) - croak(SvPV_nolen(ERRSV)); - ST(0) = sv_2mortal(ret); - XSRETURN(1); - } - else if(!strcmp(method, "DESTROY")) { - SV *old_this; - if(withObject && !isSuper) { - old_this = sv_this; - sv_this = newSVsv(ST(0)); - } - smokeperl_object *o = sv_obj_info(sv_this); - - if(!(o && o->ptr && (o->allocated || getPointerObject(o->ptr)))) { - if(isSuper) - delete[] package; - if(withObject && !isSuper) { - SvREFCNT_dec(sv_this); - sv_this = old_this; - } - XSRETURN_YES; - } - const char *key = "has been hidden"; - U32 klen = 15; - SV **svp = 0; - if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) { - HV *hv = (HV*)SvRV(sv_this); - svp = hv_fetch(hv, key, klen, 0); - } - if(svp) { - if(isSuper) - delete[] package; - if(withObject && !isSuper) { - SvREFCNT_dec(sv_this); - sv_this = old_this; - } - XSRETURN_YES; - } - gv = gv_fetchmethod_autoload(stash, "ON_DESTROY", 0); - if( !gv ) - croak( "Couldn't find ON_DESTROY method for %s=%p\n", package, o->ptr); - PUSHMARK(SP); - call_sv((SV*)GvCV(gv), G_SCALAR|G_NOARGS); - SPAGAIN; - int ret = POPi; - PUTBACK; - if(withObject && !isSuper) { - SvREFCNT_dec(sv_this); - sv_this = old_this; - } - if( do_debug && ret && (do_debug & qtdb_gc) ) - fprintf(stderr, "Increasing refcount in DESTROY for %s=%p (still has a parent)\n", package, o->ptr); - } else { - - if( items > 18 ) XSRETURN_NO; // current max number of args in TQt is 13. - - // save the stack -- we'll need it - SV **savestack = new SV*[items+1]; - SV *saveobj = ST(0); - SV *old_this; - - Copy(SP - items + 1 + withObject, savestack, items-withObject, SV*); - - // Get the classid (eventually converting SUPER to the right TQt class) - Smoke::Index cid = package_classid(package); - // Look in the cache - char *cname = (char*)qt_Smoke->className(cid); - int lcname = strlen(cname); - int lmethod = strlen(method); - char mcid[256]; - strncpy(mcid, cname, lcname); - char *ptr = mcid + lcname; - *(ptr++) = ';'; - strncpy(ptr, method, lmethod); - ptr += lmethod; - for(int i=withObject ; ifind(mcid); - - if(rcid) { - // Got a hit - _current_method = *rcid; - if(withObject && !isSuper) { - old_this = sv_this; - sv_this = newSVsv(ST(0)); - } - } - else { - - // Find the C++ method to call. I'll do that from Perl for now - - ENTER; - SAVETMPS; - PUSHMARK(SP - items + withObject); - EXTEND(SP, 3); - PUSHs(sv_2mortal(newSViv((IV)cid))); - PUSHs(sv_2mortal(newSVpv(method, 0))); - PUSHs(sv_2mortal(newSVpv(package, 0))); - PUTBACK; - if(withObject && !isSuper) { - old_this = sv_this; - sv_this = newSVsv(saveobj); - } - call_pv("TQt::_internal::do_autoload", G_DISCARD|G_EVAL); - FREETMPS; - LEAVE; - - // Restore sv_this on error, so that eval{ } works - if(SvTRUE(ERRSV)) { - if(withObject && !isSuper) { - SvREFCNT_dec(sv_this); - sv_this = old_this; - } - else if(isSuper) - delete[] package; - delete[] savestack; - croak(SvPV_nolen(ERRSV)); - } - - // Success. Cache result. - methcache->insert(mcid, new Smoke::Index(_current_method)); - } - // FIXME: I shouldn't have to set the current object - { - smokeperl_object *o = sv_obj_info(sv_this); - if(o && o->ptr) { - _current_object = o->ptr; - _current_object_class = o->classId; - } else { - _current_object = 0; - } - } - // honor debugging channels - if(do_debug && (do_debug & qtdb_calls)) { - warn("Calling method\t%s\n", SvPV_nolen(sv_2mortal(prettyPrintMethod(_current_method)))); - if(do_debug & qtdb_verbose) - warn("with arguments (%s)\n", SvPV_nolen(sv_2mortal(catArguments(savestack, items-withObject)))); - } - MethodCall c(qt_Smoke, _current_method, savestack, items-withObject); - c.next(); - if(savestack) - delete[] savestack; - - if(withObject && !isSuper) { - SvREFCNT_dec(sv_this); - sv_this = old_this; - } - else if(isSuper) - delete[] package; - - SV *ret = c.var(); - SvREFCNT_inc(ret); - ST(0) = sv_2mortal(ret); - XSRETURN(1); - } - if(isSuper) - delete[] package; - XSRETURN_YES; -} - - -//----------------- Sig/Slot ------------------ - - -MocArgument *getmetainfo(GV *gv, const char *name, int &offset, int &index, int &argcnt) { - char *signalname = GvNAME(gv); - HV *stash = GvSTASH(gv); - - // $meta = $stash->{META} - SV **svp = hv_fetch(stash, "META", 4, 0); - if(!svp) return 0; - HV *hv = GvHV((GV*)*svp); - if(!hv) return 0; - - // $metaobject = $meta->{object} - // aka. Class->staticMetaObject - svp = hv_fetch(hv, "object", 6, 0); - if(!svp) return 0; - smokeperl_object *ometa = sv_obj_info(*svp); - if(!ometa) return 0; - TQMetaObject *metaobject = (TQMetaObject*)ometa->ptr; - - offset = metaobject->signalOffset(); - - // $signals = $meta->{signal} - U32 len = strlen(name); - svp = hv_fetch(hv, name, len, 0); - if(!svp) return 0; - HV *signalshv = (HV*)SvRV(*svp); - - // $signal = $signals->{$signalname} - len = strlen(signalname); - svp = hv_fetch(signalshv, signalname, len, 0); - if(!svp) return 0; - HV *signalhv = (HV*)SvRV(*svp); - - // $index = $signal->{index} - svp = hv_fetch(signalhv, "index", 5, 0); - if(!svp) return 0;; - index = SvIV(*svp); - - // $argcnt = $signal->{argcnt} - svp = hv_fetch(signalhv, "argcnt", 6, 0); - if(!svp) return 0; - argcnt = SvIV(*svp); - - // $mocargs = $signal->{mocargs} - svp = hv_fetch(signalhv, "mocargs", 7, 0); - if(!svp) return 0; - MocArgument *args = (MocArgument*)SvIV(*svp); - - return args; -} - -MocArgument *getslotinfo(GV *gv, int id, char *&slotname, int &index, int &argcnt, bool isSignal = false) { - HV *stash = GvSTASH(gv); - - // $meta = $stash->{META} - SV **svp = hv_fetch(stash, "META", 4, 0); - if(!svp) return 0; - HV *hv = GvHV((GV*)*svp); - if(!hv) return 0; - - // $metaobject = $meta->{object} - // aka. Class->staticMetaObject - svp = hv_fetch(hv, "object", 6, 0); - if(!svp) return 0; - smokeperl_object *ometa = sv_obj_info(*svp); - if(!ometa) return 0; - TQMetaObject *metaobject = (TQMetaObject*)ometa->ptr; - - int offset = isSignal ? metaobject->signalOffset() : metaobject->slotOffset(); - - index = id - offset; // where we at - // FIXME: make slot inheritance work - if(index < 0) return 0; - // $signals = $meta->{signal} - const char *key = isSignal ? "signals" : "slots"; - svp = hv_fetch(hv, key, strlen(key), 0); - if(!svp) return 0; - AV *signalsav = (AV*)SvRV(*svp); - svp = av_fetch(signalsav, index, 0); - if(!svp) return 0; - HV *signalhv = (HV*)SvRV(*svp); - // $argcnt = $signal->{argcnt} - svp = hv_fetch(signalhv, "argcnt", 6, 0); - if(!svp) return 0; - argcnt = SvIV(*svp); - // $mocargs = $signal->{mocargs} - svp = hv_fetch(signalhv, "mocargs", 7, 0); - if(!svp) return 0; - MocArgument *args = (MocArgument*)SvIV(*svp); - - svp = hv_fetch(signalhv, "name", 4, 0); - if(!svp) return 0; - slotname = SvPV_nolen(*svp); - - return args; -} - -XS(XS_signal) { - dXSARGS; - - smokeperl_object *o = sv_obj_info(sv_this); - TQObject *qobj = (TQObject*)o->smoke->cast( - o->ptr, - o->classId, - o->smoke->idClass("TQObject") - ); - if(qobj->signalsBlocked()) XSRETURN_UNDEF; - - int offset; - int index; - int argcnt; - MocArgument *args; - - args = getmetainfo(CvGV(cv), "signal", offset, index, argcnt); - if(!args) XSRETURN_UNDEF; - - // Okay, we have the signal info. *whew* - if(items < argcnt) - croak("Insufficient arguments to emit signal"); - - EmitSignal signal(qobj, offset + index, argcnt, args, &ST(0)); - signal.next(); - - XSRETURN_UNDEF; -} - -XS(XS_qt_invoke) { - dXSARGS; - // Arguments: int id, TQUObject *o - int id = SvIV(ST(0)); - TQUObject *_o = (TQUObject*)SvIV(SvRV(ST(1))); - - smokeperl_object *o = sv_obj_info(sv_this); - TQObject *qobj = (TQObject*)o->smoke->cast( - o->ptr, - o->classId, - o->smoke->idClass("TQObject") - ); - - // Now, I need to find out if this means me - int index; - char *slotname; - int argcnt; - MocArgument *args; - bool isSignal = !strcmp(GvNAME(CvGV(cv)), "qt_emit"); - args = getslotinfo(CvGV(cv), id, slotname, index, argcnt, isSignal); - if(!args) { - // throw an exception - evil style - temporary_virtual_function_success = false; - XSRETURN_UNDEF; - } - HV *stash = GvSTASH(CvGV(cv)); - GV *gv = gv_fetchmethod_autoload(stash, slotname, 0); - if(!gv) XSRETURN_UNDEF; - InvokeSlot slot(qobj, gv, argcnt, args, _o); - slot.next(); - - XSRETURN_UNDEF; -} - -// ------------------- Tied types ------------------------ - -MODULE = TQt PACKAGE = TQt::_internal::TQString -PROTOTYPES: DISABLE - -SV* -FETCH(obj) - SV* obj - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQString *s = (TQString*) tmp; - RETVAL = newSV(0); - if( s ) - { - if(!(IN_BYTES)) - { - sv_setpv_mg(RETVAL, (const char *)s->utf8()); - SvUTF8_on(RETVAL); - } - else if(IN_LOCALE) - sv_setpv_mg(RETVAL, (const char *)s->local8Bit()); - else - sv_setpv_mg(RETVAL, (const char *)s->latin1()); - } - else - sv_setsv_mg(RETVAL, &PL_sv_undef); - OUTPUT: - RETVAL - -void -STORE(obj,what) - SV* obj - SV* what - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQString *s = (TQString*) tmp; - s->truncate(0); - if(SvOK(what)) { - if(SvUTF8(what)) - s->append(TQString::fromUtf8(SvPV_nolen(what))); - else if(IN_LOCALE) - s->append(TQString::fromLocal8Bit(SvPV_nolen(what))); - else - s->append(TQString::fromLatin1(SvPV_nolen(what))); - } - -void -DESTROY(obj) - SV* obj - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQString *s = (TQString*) tmp; - delete s; - -MODULE = TQt PACKAGE = TQt::_internal::TQByteArray -PROTOTYPES: DISABLE - -SV* -FETCH(obj) - SV* obj - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQByteArray *s = (TQByteArray*) tmp; - RETVAL = newSV(0); - if( s ) - { - sv_setpvn_mg(RETVAL, s->data(), s->size()); - } - else - sv_setsv_mg(RETVAL, &PL_sv_undef); - OUTPUT: - RETVAL - -void -STORE(obj,what) - SV* obj - SV* what - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQByteArray *s = (TQByteArray*) tmp; - - if(SvOK(what)) { - STRLEN len; - char* tmp2 = SvPV(what, len); - s->resize(len); - Copy((void*)tmp2, (void*)s->data(), len, char); - } else - s->truncate(0); - -void -DESTROY(obj) - SV* obj - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQByteArray *s = (TQByteArray*) tmp; - delete s; - -MODULE = TQt PACKAGE = TQt::_internal::TQRgbStar -PROTOTYPES: DISABLE - -SV* -FETCH(obj) - SV* obj - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQRgb *s = (TQRgb*) tmp; - AV* ar = newAV(); - RETVAL = newRV_noinc((SV*)ar); - for(int i=0; s[i] ; i++) - { - SV *item = newSViv((IV)s[i]); - if(!av_store(ar, (I32)i, item)) - SvREFCNT_dec( item ); - } - OUTPUT: - RETVAL - -void -STORE(obj,sv) - SV* obj - SV* sv - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQRgb *s = (TQRgb*) tmp; - if(!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV || - av_len((AV*)SvRV(sv)) < 0) { - s = new TQRgb[1]; - s[0] = 0; - sv_setref_pv(obj, "TQt::_internal::TQRgbStar", (void*)s); - return; - } - AV *list = (AV*)SvRV(sv); - int count = av_len(list); - s = new TQRgb[count + 2]; - int i; - for(i = 0; i <= count; i++) { - SV **item = av_fetch(list, i, 0); - if(!item || !SvOK(*item)) { - s[i] = 0; - continue; - } - s[i] = SvIV(*item); - } - s[i] = 0; - sv_setref_pv(obj, "TQt::_internal::TQRgbStar", (void*)s); - -void -DESTROY(obj) - SV* obj - CODE: - if (!SvROK(obj)) - croak("?"); - IV tmp = SvIV((SV*)SvRV(obj)); - TQRgb *s = (TQRgb*) tmp; - delete[] s; - -# --------------- XSUBS for TQt::_internal::* helpers ---------------- - - -MODULE = TQt PACKAGE = TQt::_internal -PROTOTYPES: DISABLE - -void -getMethStat() - PPCODE: - XPUSHs(sv_2mortal(newSViv((int)methcache->size()))); - XPUSHs(sv_2mortal(newSViv((int)methcache->count()))); - -void -getClassStat() - PPCODE: - XPUSHs(sv_2mortal(newSViv((int)classcache->size()))); - XPUSHs(sv_2mortal(newSViv((int)classcache->count()))); - -void -getIsa(classId) - int classId - PPCODE: - Smoke::Index *parents = - qt_Smoke->inheritanceList + - qt_Smoke->classes[classId].parents; - while(*parents) - XPUSHs(sv_2mortal(newSVpv(qt_Smoke->classes[*parents++].className, 0))); - -void -dontRecurse() - CODE: - avoid_fetchmethod = true; - -void * -sv_to_ptr(sv) - SV* sv - -void * -allocateMocArguments(count) - int count - CODE: - RETVAL = (void*)new MocArgument[count + 1]; - OUTPUT: - RETVAL - -void -setMocType(ptr, idx, name, static_type) - void *ptr - int idx - char *name - char *static_type - CODE: - Smoke::Index typeId = qt_Smoke->idType(name); - if(!typeId) XSRETURN_NO; - MocArgument *arg = (MocArgument*)ptr; - arg[idx].st.set(qt_Smoke, typeId); - if(!strcmp(static_type, "ptr")) - arg[idx].argType = xmoc_ptr; - else if(!strcmp(static_type, "bool")) - arg[idx].argType = xmoc_bool; - else if(!strcmp(static_type, "int")) - arg[idx].argType = xmoc_int; - else if(!strcmp(static_type, "double")) - arg[idx].argType = xmoc_double; - else if(!strcmp(static_type, "char*")) - arg[idx].argType = xmoc_charstar; - else if(!strcmp(static_type, "TQString")) - arg[idx].argType = xmoc_TQString; - XSRETURN_YES; - -void -installsignal(name) - char *name - CODE: - char *file = __FILE__; - newXS(name, XS_signal, file); - -void -installqt_invoke(name) - char *name - CODE: - char *file = __FILE__; - newXS(name, XS_qt_invoke, file); - -void -setDebug(on) - int on - CODE: - do_debug = on; - -int -debug() - CODE: - RETVAL = do_debug; - OUTPUT: - RETVAL - -char * -getTypeNameOfArg(method, idx) - int method - int idx - CODE: - Smoke::Method &m = qt_Smoke->methods[method]; - Smoke::Index *args = qt_Smoke->argumentList + m.args; - RETVAL = (char*)qt_Smoke->types[args[idx]].name; - OUTPUT: - RETVAL - -int -classIsa(className, base) - char *className - char *base - CODE: - RETVAL = isDerivedFrom(qt_Smoke, className, base, 0); - OUTPUT: - RETVAL - -void -insert_pclassid(p, ix) - char *p - int ix - CODE: - classcache->insert(p, new Smoke::Index((Smoke::Index)ix)); - -int -find_pclassid(p) - char *p - CODE: - Smoke::Index *r = classcache->find(p); - if(r) - RETVAL = (int)*r; - else - RETVAL = 0; - OUTPUT: - RETVAL - -void -insert_mcid(mcid, ix) - char *mcid - int ix - CODE: - methcache->insert(mcid, new Smoke::Index((Smoke::Index)ix)); - -int -find_mcid(mcid) - char *mcid - CODE: - Smoke::Index *r = methcache->find(mcid); - if(r) - RETVAL = (int)*r; - else - RETVAL = 0; - OUTPUT: - RETVAL - -char * -getSVt(sv) - SV *sv - CODE: - RETVAL=get_SVt(sv); - OUTPUT: - RETVAL - -void * -make_TQUParameter(name, type, extra, inout) - char *name - char *type - SV *extra - int inout - CODE: - TQUParameter *p = new TQUParameter; - p->name = new char[strlen(name) + 1]; - strcpy((char*)p->name, name); - if(!strcmp(type, "bool")) - p->type = &static_TQUType_bool; - else if(!strcmp(type, "int")) - p->type = &static_TQUType_int; - else if(!strcmp(type, "double")) - p->type = &static_TQUType_double; - else if(!strcmp(type, "char*") || !strcmp(type, "const char*")) - p->type = &static_TQUType_charstar; - else if(!strcmp(type, "TQString") || !strcmp(type, "TQString&") || - !strcmp(type, "const TQString") || !strcmp(type, "const TQString&")) - p->type = &static_TQUType_TQString; - else - p->type = &static_TQUType_ptr; - // Lacking support for several types. Evil. - p->inOut = inout; - p->typeExtra = 0; - RETVAL = (void*)p; - OUTPUT: - RETVAL - -void * -make_TQMetaData(name, method) - char *name - void *method - CODE: - TQMetaData *m = new TQMetaData; // will be deleted - m->name = new char[strlen(name) + 1]; - strcpy((char*)m->name, name); - m->method = (TQUMethod*)method; - m->access = TQMetaData::Public; - RETVAL = m; - OUTPUT: - RETVAL - -void * -make_TQUMethod(name, params) - char *name - SV *params - CODE: - TQUMethod *m = new TQUMethod; // permanent memory allocation - m->name = new char[strlen(name) + 1]; // this too - strcpy((char*)m->name, name); - m->count = 0; - m->parameters = 0; - if(SvOK(params) && SvRV(params)) { - AV *av = (AV*)SvRV(params); - m->count = av_len(av) + 1; - if(m->count > 0) { - m->parameters = new TQUParameter[m->count]; - for(int i = 0; i < m->count; i++) { - SV *sv = av_shift(av); - if(!SvOK(sv)) - croak("Invalid paramater for TQUMethod\n"); - TQUParameter *p = (TQUParameter*)SvIV(sv); - SvREFCNT_dec(sv); - ((TQUParameter*)m->parameters)[i] = *p; - delete p; - } - } else - m->count = 0; - } - RETVAL = m; - OUTPUT: - RETVAL - -void * -make_TQMetaData_tbl(list) - SV *list - CODE: - RETVAL = 0; - if(SvOK(list) && SvRV(list)) { - AV *av = (AV*)SvRV(list); - int count = av_len(av) + 1; - TQMetaData *m = new TQMetaData[count]; - for(int i = 0; i < count; i++) { - SV *sv = av_shift(av); - if(!SvOK(sv)) - croak("Invalid metadata\n"); - TQMetaData *old = (TQMetaData*)SvIV(sv); - SvREFCNT_dec(sv); - m[i] = *old; - delete old; - } - RETVAL = (void*)m; - } - OUTPUT: - RETVAL - -SV * -make_metaObject(className, parent, slot_tbl, slot_count, signal_tbl, signal_count) - char *className - SV *parent - void *slot_tbl - int slot_count - void *signal_tbl - int signal_count - CODE: - smokeperl_object *po = sv_obj_info(parent); - if(!po || !po->ptr) croak("Cannot create metaObject\n"); - TQMetaObject *meta = TQMetaObject::new_metaobject( - className, (TQMetaObject*)po->ptr, - (const TQMetaData*)slot_tbl, slot_count, // slots - (const TQMetaData*)signal_tbl, signal_count, // signals - 0, 0, // properties - 0, 0, // enums - 0, 0); - - // this object-creation code is so, so wrong here - HV *hv = newHV(); - SV *obj = newRV_noinc((SV*)hv); - - smokeperl_object o; - o.smoke = qt_Smoke; - o.classId = qt_Smoke->idClass("TQMetaObject"); - o.ptr = meta; - o.allocated = true; - sv_magic((SV*)hv, sv_qapp, '~', (char*)&o, sizeof(o)); - MAGIC *mg = mg_find((SV*)hv, '~'); - mg->mg_virtual = &vtbl_smoke; - char *buf = qt_Smoke->binding->className(o.classId); - sv_bless(obj, gv_stashpv(buf, TRUE)); - delete[] buf; - RETVAL = obj; - OUTPUT: - RETVAL - -void -dumpObjects() - CODE: - hv_iterinit(pointer_map); - HE *e; - while(e = hv_iternext(pointer_map)) { - STRLEN len; - SV *sv = HeVAL(e); - printf("key = %s, refcnt = %d, weak = %d, ref? %d\n", HePV(e, len), SvREFCNT(sv), SvWEAKREF(sv), SvROK(sv)?1:0); - if(SvRV(sv)) - printf("REFCNT = %d\n", SvREFCNT(SvRV(sv))); - //SvREFCNT_dec(HeVAL(e)); - //HeVAL(e) = &PL_sv_undef; - } - -void -dangle(obj) - SV *obj - CODE: - if(SvRV(obj)) - SvREFCNT_inc(SvRV(obj)); - -void -setAllocated(obj, b) - SV *obj - bool b - CODE: - smokeperl_object *o = sv_obj_info(obj); - if(o) { - o->allocated = b; - } - -void -setqapp(obj) - SV *obj - CODE: - if(!obj || !SvROK(obj)) - croak("Invalid TQt::Application object. Couldn't set TQt::app()\n"); - sv_qapp = SvRV(obj); - -void -setThis(obj) - SV *obj - CODE: - sv_setsv_mg(sv_this, obj); - -void -deleteObject(obj) - SV *obj - CODE: - smokeperl_object *o = sv_obj_info(obj); - if(!o) { XSRETURN_EMPTY; } - TQObject *qobj = (TQObject*)o->smoke->cast(o->ptr, o->classId, o->smoke->idClass("TQObject")); - delete qobj; - -void -mapObject(obj) - SV *obj - CODE: - smokeperl_object *o = sv_obj_info(obj); - if(!o) - XSRETURN_EMPTY; - SmokeClass c( o->smoke, o->classId ); - if(!c.hasVirtual() ) { - XSRETURN_EMPTY; - } - mapPointer(obj, o, pointer_map, o->classId, 0); - -bool -isTQObject(obj) - SV *obj - CODE: - RETVAL = 0; - smokeperl_object *o = sv_obj_info(obj); - if(o && isTQObject(o->smoke, o->classId)) - RETVAL = 1; - OUTPUT: - RETVAL - -bool -isValidAllocatedPointer(obj) - SV *obj - CODE: - RETVAL = 0; - smokeperl_object *o = sv_obj_info(obj); - if(o && o->ptr && o->allocated) - RETVAL = 1; - OUTPUT: - RETVAL - -SV* -findAllocatedObjectFor(obj) - SV *obj - CODE: - RETVAL = &PL_sv_undef; - smokeperl_object *o = sv_obj_info(obj); - SV *ret; - if(o && o->ptr && (ret = getPointerObject(o->ptr))) - RETVAL = ret; - OUTPUT: - RETVAL - -SV * -getGV(cv) - SV *cv - CODE: - RETVAL = (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) ? - SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef); - OUTPUT: - RETVAL - -int -idClass(name) - char *name - CODE: - RETVAL = qt_Smoke->idClass(name); - OUTPUT: - RETVAL - -int -idMethodName(name) - char *name - CODE: - RETVAL = qt_Smoke->idMethodName(name); - OUTPUT: - RETVAL - -int -idMethod(idclass, idmethodname) - int idclass - int idmethodname - CODE: - RETVAL = qt_Smoke->idMethod(idclass, idmethodname); - OUTPUT: - RETVAL - -void -findMethod(c, name) - char *c - char *name - PPCODE: - Smoke::Index meth = qt_Smoke->findMethod(c, name); -// printf("DAMNIT on %s::%s => %d\n", c, name, meth); - if(!meth) { - // empty list - } else if(meth > 0) { - Smoke::Index i = qt_Smoke->methodMaps[meth].method; - if(!i) { // shouldn't happen - croak("Corrupt method %s::%s", c, name); - } else if(i > 0) { // single match - PUSHs(sv_2mortal(newSViv( - (IV)qt_Smoke->methodMaps[meth].method - ))); - } else { // multiple match - i = -i; // turn into ambiguousMethodList index - while(qt_Smoke->ambiguousMethodList[i]) { - PUSHs(sv_2mortal(newSViv( - (IV)qt_Smoke->ambiguousMethodList[i] - ))); - i++; - } - } - } - -void -findMethodFromIds(idclass, idmethodname) - int idclass - int idmethodname - PPCODE: - Smoke::Index meth = qt_Smoke->findMethod(idclass, idmethodname); - if(!meth) { - // empty list - } else if(meth > 0) { - Smoke::Index i = qt_Smoke->methodMaps[meth].method; - if(i >= 0) { // single match - PUSHs(sv_2mortal(newSViv((IV)i))); - } else { // multiple match - i = -i; // turn into ambiguousMethodList index - while(qt_Smoke->ambiguousMethodList[i]) { - PUSHs(sv_2mortal(newSViv( - (IV)qt_Smoke->ambiguousMethodList[i] - ))); - i++; - } - } - } - -# findAllMethods(classid [, startingWith]) : returns { "mungedName" => [index in methods, ...], ... } - -HV* -findAllMethods(classid, ...) - SV* classid - CODE: - RETVAL=newHV(); - if(SvIOK(classid)) { - Smoke::Index c = (Smoke::Index) SvIV(classid); - char * pat = 0L; - if(items > 1 && SvPOK(ST(1))) - pat = SvPV_nolen(ST(1)); - Smoke::Index imax = qt_Smoke->numMethodMaps; - Smoke::Index imin = 0, icur = -1, methmin = 0, methmax = 0; - int icmp = -1; - while(imax >= imin) { - icur = (imin + imax) / 2; - icmp = qt_Smoke->leg(qt_Smoke->methodMaps[icur].classId, c); - if(!icmp) { - Smoke::Index pos = icur; - while(icur && qt_Smoke->methodMaps[icur-1].classId == c) - icur --; - methmin = icur; - icur = pos; - while(icur < imax && qt_Smoke->methodMaps[icur+1].classId == c) - icur ++; - methmax = icur; - break; - } - if (icmp > 0) - imax = icur - 1; - else - imin = icur + 1; - } - if(!icmp) { - for(Smoke::Index i=methmin ; i <= methmax ; i++) { - Smoke::Index m = qt_Smoke->methodMaps[i].name; - if(!pat || !strncmp(qt_Smoke->methodNames[m], pat, strlen(pat))) { - Smoke::Index ix= qt_Smoke->methodMaps[i].method; - AV* meths = newAV(); - if(ix >= 0) { // single match - av_push(meths, newSViv((IV)ix)); - } else { // multiple match - ix = -ix; // turn into ambiguousMethodList index - while(qt_Smoke->ambiguousMethodList[ix]) { - av_push(meths, newSViv((IV)qt_Smoke->ambiguousMethodList[ix])); - ix++; - } - } - hv_store(RETVAL, qt_Smoke->methodNames[m],strlen(qt_Smoke->methodNames[m]),newRV_inc((SV*)meths),0); - } - } - } - } - OUTPUT: - RETVAL - -SV * -dumpCandidates(rmeths) - SV *rmeths - CODE: - if(SvROK(rmeths) && SvTYPE(SvRV(rmeths)) == SVt_PVAV) { - AV *methods = (AV*)SvRV(rmeths); - SV *errmsg = newSVpvf(""); - for(int i = 0; i <= av_len(methods); i++) { - sv_catpv(errmsg, "\t"); - IV id = SvIV(*(av_fetch(methods, i, 0))); - Smoke::Method &meth = qt_Smoke->methods[id]; - const char *tname = qt_Smoke->types[meth.ret].name; - if(meth.flags & Smoke::mf_static) sv_catpv(errmsg, "static "); - sv_catpvf(errmsg, "%s ", (tname ? tname:"void")); - sv_catpvf(errmsg, "%s::%s(", qt_Smoke->classes[meth.classId].className, qt_Smoke->methodNames[meth.name]); - for(int i = 0; i < meth.numArgs; i++) { - if(i) sv_catpv(errmsg, ", "); - tname = qt_Smoke->types[qt_Smoke->argumentList[meth.args+i]].name; - sv_catpv(errmsg, (tname ? tname:"void")); - } - sv_catpv(errmsg, ")"); - if(meth.flags & Smoke::mf_const) sv_catpv(errmsg, " const"); - sv_catpv(errmsg, "\n"); - } - RETVAL=errmsg; - } - else - RETVAL=newSVpvf(""); - OUTPUT: - RETVAL - -SV * -catArguments(r_args) - SV* r_args - CODE: - RETVAL=newSVpvf(""); - if(SvROK(r_args) && SvTYPE(SvRV(r_args)) == SVt_PVAV) { - AV* args=(AV*)SvRV(r_args); - for(int i = 0; i <= av_len(args); i++) { - SV **arg=av_fetch(args, i, 0); - if(i) sv_catpv(RETVAL, ", "); - if(!arg || !SvOK(*arg)) { - sv_catpv(RETVAL, "undef"); - } else if(SvROK(*arg)) { - smokeperl_object *o = sv_obj_info(*arg); - if(o) - sv_catpv(RETVAL, o->smoke->className(o->classId)); - else - sv_catsv(RETVAL, *arg); - } else { - bool isString = SvPOK(*arg); - STRLEN len; - char *s = SvPV(*arg, len); - if(isString) sv_catpv(RETVAL, "'"); - sv_catpvn(RETVAL, s, len > 10 ? 10 : len); - if(len > 10) sv_catpv(RETVAL, "..."); - if(isString) sv_catpv(RETVAL, "'"); - } - } - } - OUTPUT: - RETVAL - -SV * -callMethod(...) - PPCODE: - if(_current_method) { - MethodCall c(qt_Smoke, _current_method, &ST(0), items); - c.next(); - SV *ret = c.var(); - SvREFCNT_inc(ret); - PUSHs(sv_2mortal(ret)); - } else - PUSHs(sv_newmortal()); - -bool -isObject(obj) - SV *obj - CODE: - RETVAL = sv_to_ptr(obj) ? TRUE : FALSE; - OUTPUT: - RETVAL - -void -setCurrentMethod(meth) - int meth - CODE: - // FIXME: damn, this is lame, and it doesn't handle ambiguous methods - _current_method = meth; //qt_Smoke->methodMaps[meth].method; - -SV * -getClassList() - CODE: - AV *av = newAV(); - for(int i = 1; i <= qt_Smoke->numClasses; i++) { -//printf("%s => %d\n", qt_Smoke->classes[i].className, i); - av_push(av, newSVpv(qt_Smoke->classes[i].className, 0)); -// hv_store(hv, qt_Smoke->classes[i].className, 0, newSViv(i), 0); - } - RETVAL = newRV((SV*)av); - OUTPUT: - RETVAL - -void -installthis(package) - char *package - CODE: - if(!package) XSRETURN_EMPTY; - char *name = new char[strlen(package) + 7]; - char *file = __FILE__; - strcpy(name, package); - strcat(name, "::this"); - // *{ $name } = sub () : lvalue; - CV *thissub = newXS(name, XS_this, file); - sv_setpv((SV*)thissub, ""); // sub this () : lvalue; - delete[] name; - -void -installattribute(package, name) - char *package - char *name - CODE: - if(!package || !name) XSRETURN_EMPTY; - char *attr = new char[strlen(package) + strlen(name) + 3]; - sprintf(attr, "%s::%s", package, name); - char *file = __FILE__; - // *{ $attr } = sub () : lvalue; - CV *attrsub = newXS(attr, XS_attr, file); - sv_setpv((SV*)attrsub, ""); - CvLVALUE_on(attrsub); - CvNODEBUG_on(attrsub); - delete[] attr; - -void -installsuper(package) - char *package - CODE: - if(!package) XSRETURN_EMPTY; - char *attr = new char[strlen(package) + 8]; - sprintf(attr, "%s::SUPER", package); - char *file = __FILE__; - CV *attrsub = newXS(attr, XS_super, file); - sv_setpv((SV*)attrsub, ""); - delete[] attr; - -void -installautoload(package) - char *package - CODE: - if(!package) XSRETURN_EMPTY; - char *autoload = new char[strlen(package) + 11]; - strcpy(autoload, package); - strcat(autoload, "::_UTOLOAD"); - char *file = __FILE__; - // *{ $package."::AUTOLOAD" } = XS_AUTOLOAD - newXS(autoload, XS_AUTOLOAD, file); - delete[] autoload; - -# ----------------- XSUBS for TQt:: ----------------- - -MODULE = TQt PACKAGE = TQt - -SV * -this() - CODE: - RETVAL = newSVsv(sv_this); - OUTPUT: - RETVAL - -SV * -app() - CODE: - RETVAL = newRV_inc(sv_qapp); - OUTPUT: - RETVAL - -SV * -version() - CODE: - RETVAL = newSVpv(TQT_VERSION_STR,0); - OUTPUT: - RETVAL - -BOOT: - init_qt_Smoke(); - qt_Smoke->binding = new TQtSmokeBinding(qt_Smoke); - install_handlers(TQt_handlers); - pointer_map = newHV(); - sv_this = newSV(0); - methcache = new TQAsciiDict(1187); - classcache = new TQAsciiDict(827); - methcache->setAutoDelete(1); - classcache->setAutoDelete(1); 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[\*&]?| + 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; diff --git a/PerlTQt/TQt.pod b/PerlTQt/TQt.pod new file mode 100644 index 0000000..2feceeb --- /dev/null +++ b/PerlTQt/TQt.pod @@ -0,0 +1,42 @@ + +=head1 NAME + +PerlTQt - Perl interface to the TQt GUI Widget toolkit + +=head1 TQt + +Given the huge size of the TQt module +(more than 400 classes and 13000 methods) +it doesn't have any formal documentation. + +Instead, it provides two introspection tools + +=over 4 + +=item * pqtapi: + +a command line PerlTQt API introspector + +=item * pqtsh: + +a graphical PerlTQt shell + +=back + +and a detailed B with comprehensive +explanations. +This is where anyone new to PerlTQt +should start. + +The tutorial has been originally installed +on this system in C, in both B and +B format. + +For a complete IDE allowing RAD and visual programming, +check the pqt-designer package. + +--- The PerlTQt team + +http://perlqt.sf.net - PerlTQt Project Homepage + +=cut diff --git a/PerlTQt/TQt.xs b/PerlTQt/TQt.xs new file mode 100644 index 0000000..22a66de --- /dev/null +++ b/PerlTQt/TQt.xs @@ -0,0 +1,2198 @@ +#include +#include +#include +#include +#include +#include +#include "smoke.h" + +#undef DEBUG +#ifndef _GNU_SOURCE +#define _GNU_SOURCE +#endif +#ifndef __USE_POSIX +#define __USE_POSIX +#endif +#ifndef __USE_XOPEN +#define __USE_XOPEN +#endif +#ifdef _BOOL +#define HAS_BOOL +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef TQT_VERSION_STR +#define TQT_VERSION_STR "Unknown" +#endif + +#undef free +#undef malloc + +#include "marshall.h" +#include "perlqt.h" +#include "smokeperl.h" + +#ifndef IN_BYTES +#define IN_BYTES IN_BYTE +#endif + +#ifndef IN_LOCALE +#define IN_LOCALE (PL_curcop->op_private & HINT_LOCALE) +#endif + +extern Smoke *qt_Smoke; +extern void init_qt_Smoke(); + +int do_debug = qtdb_none; + +HV *pointer_map = 0; +SV *sv_qapp = 0; +int object_count = 0; +void *_current_object = 0; // TODO: ask myself if this is stupid + +bool temporary_virtual_function_success = false; + +static TQAsciiDict *methcache = 0; +static TQAsciiDict *classcache = 0; + +SV *sv_this = 0; + +Smoke::Index _current_object_class = 0; +Smoke::Index _current_method = 0; +/* + * Type handling by moc is simple. + * + * If the type name matches /^(?:const\s+)?\Q$types\E&?$/, use the + * static_TQUType, where $types is join('|', qw(bool int double char* TQString); + * + * Everything else is passed as a pointer! There are types which aren't + * Smoke::tf_ptr but will have to be passed as a pointer. Make sure to keep + * track of what's what. + */ + +/* + * Simply using typeids isn't enough for signals/slots. It will be possible + * to declare signals and slots which use arguments which can't all be + * found in a single smoke object. Instead, we need to store smoke => typeid + * pairs. We also need additional informatation, such as whether we're passing + * a pointer to the union element. + */ + +enum MocArgumentType { + xmoc_ptr, + xmoc_bool, + xmoc_int, + xmoc_double, + xmoc_charstar, + xmoc_TQString +}; + +struct MocArgument { + // smoke object and associated typeid + SmokeType st; + MocArgumentType argType; +}; + + +extern TypeHandler TQt_handlers[]; +void install_handlers(TypeHandler *); + +void *sv_to_ptr(SV *sv) { // ptr on success, null on fail + smokeperl_object *o = sv_obj_info(sv); + return o ? o->ptr : 0; +} + +bool isTQObject(Smoke *smoke, Smoke::Index classId) { + if(!strcmp(smoke->classes[classId].className, "TQObject")) + return true; + for(Smoke::Index *p = smoke->inheritanceList + smoke->classes[classId].parents; + *p; + p++) { + if(isTQObject(smoke, *p)) + return true; + } + return false; +} + +int isDerivedFrom(Smoke *smoke, Smoke::Index classId, Smoke::Index baseId, int cnt) { + if(classId == baseId) + return cnt; + cnt++; + for(Smoke::Index *p = smoke->inheritanceList + smoke->classes[classId].parents; + *p; + p++) { + if(isDerivedFrom(smoke, *p, baseId, cnt) != -1) + return cnt; + } + return -1; +} + +int isDerivedFrom(Smoke *smoke, const char *className, const char *baseClassName, int cnt) { + if(!smoke || !className || !baseClassName) + return -1; + Smoke::Index idClass = smoke->idClass(className); + Smoke::Index idBase = smoke->idClass(baseClassName); + return isDerivedFrom(smoke, idClass, idBase, cnt); +} + +SV *getPointerObject(void *ptr) { + HV *hv = pointer_map; + SV *keysv = newSViv((IV)ptr); + STRLEN len; + char *key = SvPV(keysv, len); + SV **svp = hv_fetch(hv, key, len, 0); + if(!svp){ + SvREFCNT_dec(keysv); + return 0; + } + if(!SvOK(*svp)){ + hv_delete(hv, key, len, G_DISCARD); + SvREFCNT_dec(keysv); + return 0; + } + return *svp; +} + +void unmapPointer(smokeperl_object *o, Smoke::Index classId, void *lastptr) { + HV *hv = pointer_map; + void *ptr = o->smoke->cast(o->ptr, o->classId, classId); + if(ptr != lastptr) { + lastptr = ptr; + SV *keysv = newSViv((IV)ptr); + STRLEN len; + char *key = SvPV(keysv, len); + if(hv_exists(hv, key, len)) + hv_delete(hv, key, len, G_DISCARD); + SvREFCNT_dec(keysv); + } + for(Smoke::Index *i = o->smoke->inheritanceList + o->smoke->classes[classId].parents; + *i; + i++) { + unmapPointer(o, *i, lastptr); + } +} + +// Store pointer in pointer_map hash : "pointer_to_TQt_object" => weak ref to associated Perl object +// Recurse to store it also as casted to its parent classes. + +void mapPointer(SV *obj, smokeperl_object *o, HV *hv, Smoke::Index classId, void *lastptr) { + void *ptr = o->smoke->cast(o->ptr, o->classId, classId); + if(ptr != lastptr) { + lastptr = ptr; + SV *keysv = newSViv((IV)ptr); + STRLEN len; + char *key = SvPV(keysv, len); + SV *rv = newSVsv(obj); + sv_rvweaken(rv); // weak reference! + hv_store(hv, key, len, rv, 0); + SvREFCNT_dec(keysv); + } + for(Smoke::Index *i = o->smoke->inheritanceList + o->smoke->classes[classId].parents; + *i; + i++) { + mapPointer(obj, o, hv, *i, lastptr); + } +} + +Marshall::HandlerFn getMarshallFn(const SmokeType &type); + +class VirtualMethodReturnValue : public Marshall { + Smoke *_smoke; + Smoke::Index _method; + Smoke::Stack _stack; + SmokeType _st; + SV *_retval; +public: + const Smoke::Method &method() { return _smoke->methods[_method]; } + SmokeType type() { return _st; } + Marshall::Action action() { return Marshall::FromSV; } + Smoke::StackItem &item() { return _stack[0]; } + SV *var() { return _retval; } + void unsupported() { + croak("Cannot handle '%s' as return-type of virtual method %s::%s", + type().name(), + _smoke->className(method().classId), + _smoke->methodNames[method().name]); + } + Smoke *smoke() { return _smoke; } + void next() {} + bool cleanup() { return false; } + VirtualMethodReturnValue(Smoke *smoke, Smoke::Index meth, Smoke::Stack stack, SV *retval) : + _smoke(smoke), _method(meth), _stack(stack), _retval(retval) { + _st.set(_smoke, method().ret); + Marshall::HandlerFn fn = getMarshallFn(type()); + (*fn)(this); + } +}; + +class VirtualMethodCall : public Marshall { + Smoke *_smoke; + Smoke::Index _method; + Smoke::Stack _stack; + GV *_gv; + int _cur; + Smoke::Index *_args; + SV **_sp; + bool _called; + SV *_savethis; + +public: + SmokeType type() { return SmokeType(_smoke, _args[_cur]); } + Marshall::Action action() { return Marshall::ToSV; } + Smoke::StackItem &item() { return _stack[_cur + 1]; } + SV *var() { return _sp[_cur]; } + const Smoke::Method &method() { return _smoke->methods[_method]; } + void unsupported() { + croak("Cannot handle '%s' as argument of virtual method %s::%s", + type().name(), + _smoke->className(method().classId), + _smoke->methodNames[method().name]); + } + Smoke *smoke() { return _smoke; } + void callMethod() { + dSP; + if(_called) return; + _called = true; + SP = _sp + method().numArgs - 1; + PUTBACK; + int count = call_sv((SV*)GvCV(_gv), G_SCALAR); + SPAGAIN; + VirtualMethodReturnValue r(_smoke, _method, _stack, POPs); + PUTBACK; + FREETMPS; + LEAVE; + } + void next() { + int oldcur = _cur; + _cur++; + while(!_called && _cur < method().numArgs) { + Marshall::HandlerFn fn = getMarshallFn(type()); + (*fn)(this); + _cur++; + } + callMethod(); + _cur = oldcur; + } + bool cleanup() { return false; } // is this right? + VirtualMethodCall(Smoke *smoke, Smoke::Index meth, Smoke::Stack stack, SV *obj, GV *gv) : + _smoke(smoke), _method(meth), _stack(stack), _gv(gv), _cur(-1), _sp(0), _called(false) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + EXTEND(SP, method().numArgs); + _savethis = sv_this; + sv_this = newSVsv(obj); + _sp = SP + 1; + for(int i = 0; i < method().numArgs; i++) + _sp[i] = sv_newmortal(); + _args = _smoke->argumentList + method().args; + } + ~VirtualMethodCall() { + SvREFCNT_dec(sv_this); + sv_this = _savethis; + } +}; + +class MethodReturnValue : public Marshall { + Smoke *_smoke; + Smoke::Index _method; + SV *_retval; + Smoke::Stack _stack; +public: + MethodReturnValue(Smoke *smoke, Smoke::Index method, Smoke::Stack stack, SV *retval) : + _smoke(smoke), _method(method), _retval(retval), _stack(stack) { + Marshall::HandlerFn fn = getMarshallFn(type()); + (*fn)(this); + } + const Smoke::Method &method() { return _smoke->methods[_method]; } + SmokeType type() { return SmokeType(_smoke, method().ret); } + Marshall::Action action() { return Marshall::ToSV; } + Smoke::StackItem &item() { return _stack[0]; } + SV *var() { return _retval; } + void unsupported() { + croak("Cannot handle '%s' as return-type of %s::%s", + type().name(), + _smoke->className(method().classId), + _smoke->methodNames[method().name]); + } + Smoke *smoke() { return _smoke; } + void next() {} + bool cleanup() { return false; } +}; + +class MethodCall : public Marshall { + int _cur; + Smoke *_smoke; + Smoke::Stack _stack; + Smoke::Index _method; + Smoke::Index *_args; + SV **_sp; + int _items; + SV *_retval; + bool _called; +public: + MethodCall(Smoke *smoke, Smoke::Index method, SV **sp, int items) : + _smoke(smoke), _method(method), _sp(sp), _items(items), _cur(-1), _called(false) { + _args = _smoke->argumentList + _smoke->methods[_method].args; + _items = _smoke->methods[_method].numArgs; + _stack = new Smoke::StackItem[items + 1]; + _retval = newSV(0); + } + ~MethodCall() { + delete[] _stack; + SvREFCNT_dec(_retval); + } + SmokeType type() { return SmokeType(_smoke, _args[_cur]); } + Marshall::Action action() { return Marshall::FromSV; } + Smoke::StackItem &item() { return _stack[_cur + 1]; } + SV *var() { + if(_cur < 0) return _retval; + SvGETMAGIC(*(_sp + _cur)); + return *(_sp + _cur); + } + inline const Smoke::Method &method() { return _smoke->methods[_method]; } + void unsupported() { + croak("Cannot handle '%s' as argument to %s::%s", + type().name(), + _smoke->className(method().classId), + _smoke->methodNames[method().name]); + } + Smoke *smoke() { return _smoke; } + inline void callMethod() { + if(_called) return; + _called = true; + Smoke::ClassFn fn = _smoke->classes[method().classId].classFn; + void *ptr = _smoke->cast( + _current_object, + _current_object_class, + method().classId + ); + _items = -1; + (*fn)(method().method, ptr, _stack); + MethodReturnValue r(_smoke, _method, _stack, _retval); + } + void next() { + int oldcur = _cur; + _cur++; + + while(!_called && _cur < _items) { + Marshall::HandlerFn fn = getMarshallFn(type()); + (*fn)(this); + _cur++; + } + + callMethod(); + _cur = oldcur; + } + bool cleanup() { return true; } +}; + +class UnencapsulatedTQObject : public TQObject { +public: + TQConnectionList *public_receivers(int signal) const { return receivers(signal); } + void public_activate_signal(TQConnectionList *clist, TQUObject *o) { activate_signal(clist, o); } +}; + +class EmitSignal : public Marshall { + UnencapsulatedTQObject *_qobj; + int _id; + MocArgument *_args; + SV **_sp; + int _items; + int _cur; + Smoke::Stack _stack; + bool _called; +public: + EmitSignal(TQObject *qobj, int id, int items, MocArgument *args, SV **sp) : + _qobj((UnencapsulatedTQObject*)qobj), _id(id), _items(items), _args(args), + _sp(sp), _cur(-1), _called(false) { + _stack = new Smoke::StackItem[_items]; + } + ~EmitSignal() { + delete[] _stack; + } + const MocArgument &arg() { return _args[_cur]; } + SmokeType type() { return arg().st; } + Marshall::Action action() { return Marshall::FromSV; } + Smoke::StackItem &item() { return _stack[_cur]; } + SV *var() { return _sp[_cur]; } + void unsupported() { + croak("Cannot handle '%s' as signal argument", type().name()); + } + Smoke *smoke() { return type().smoke(); } + void emitSignal() { + if(_called) return; + _called = true; + + TQConnectionList *clist = _qobj->public_receivers(_id); + if(!clist) return; + + TQUObject *o = new TQUObject[_items + 1]; + for(int i = 0; i < _items; i++) { + TQUObject *po = o + i + 1; + Smoke::StackItem *si = _stack + i; + switch(_args[i].argType) { + case xmoc_bool: + static_TQUType_bool.set(po, si->s_bool); + break; + case xmoc_int: + static_TQUType_int.set(po, si->s_int); + break; + case xmoc_double: + static_TQUType_double.set(po, si->s_double); + break; + case xmoc_charstar: + static_TQUType_charstar.set(po, (char*)si->s_voidp); + break; + case xmoc_TQString: + static_TQUType_TQString.set(po, *(TQString*)si->s_voidp); + break; + default: + { + const SmokeType &t = _args[i].st; + void *p; + switch(t.elem()) { + case Smoke::t_bool: + p = &si->s_bool; + break; + case Smoke::t_char: + p = &si->s_char; + break; + case Smoke::t_uchar: + p = &si->s_uchar; + break; + case Smoke::t_short: + p = &si->s_short; + break; + case Smoke::t_ushort: + p = &si->s_ushort; + break; + case Smoke::t_int: + p = &si->s_int; + break; + case Smoke::t_uint: + p = &si->s_uint; + break; + case Smoke::t_long: + p = &si->s_long; + break; + case Smoke::t_ulong: + p = &si->s_ulong; + break; + case Smoke::t_float: + p = &si->s_float; + break; + case Smoke::t_double: + p = &si->s_double; + break; + case Smoke::t_enum: + { + // allocate a new enum value + Smoke::EnumFn fn = SmokeClass(t).enumFn(); + if(!fn) { + warn("Unknown enumeration %s\n", t.name()); + p = new int((int)si->s_enum); + break; + } + Smoke::Index id = t.typeId(); + (*fn)(Smoke::EnumNew, id, p, si->s_enum); + (*fn)(Smoke::EnumFromLong, id, p, si->s_enum); + // FIXME: MEMORY LEAK + } + break; + case Smoke::t_class: + case Smoke::t_voidp: + p = si->s_voidp; + break; + default: + p = 0; + break; + } + static_TQUType_ptr.set(po, p); + } + } + } + + _qobj->public_activate_signal(clist, o); + delete[] o; + } + void next() { + int oldcur = _cur; + _cur++; + + while(!_called && _cur < _items) { + Marshall::HandlerFn fn = getMarshallFn(type()); + (*fn)(this); + _cur++; + } + + emitSignal(); + _cur = oldcur; + } + bool cleanup() { return true; } +}; + +class InvokeSlot : public Marshall { + TQObject *_qobj; + GV *_gv; + int _items; + MocArgument *_args; + TQUObject *_o; + int _cur; + bool _called; + SV **_sp; + Smoke::Stack _stack; +public: + const MocArgument &arg() { return _args[_cur]; } + SmokeType type() { return arg().st; } + Marshall::Action action() { return Marshall::ToSV; } + Smoke::StackItem &item() { return _stack[_cur]; } + SV *var() { return _sp[_cur]; } + Smoke *smoke() { return type().smoke(); } + bool cleanup() { return false; } + void unsupported() { + croak("Cannot handle '%s' as slot argument\n", type().name()); + } + void copyArguments() { + for(int i = 0; i < _items; i++) { + TQUObject *o = _o + i + 1; + switch(_args[i].argType) { + case xmoc_bool: + _stack[i].s_bool = static_TQUType_bool.get(o); + break; + case xmoc_int: + _stack[i].s_int = static_TQUType_int.get(o); + break; + case xmoc_double: + _stack[i].s_double = static_TQUType_double.get(o); + break; + case xmoc_charstar: + _stack[i].s_voidp = static_TQUType_charstar.get(o); + break; + case xmoc_TQString: + _stack[i].s_voidp = &static_TQUType_TQString.get(o); + break; + default: // case xmoc_ptr: + { + const SmokeType &t = _args[i].st; + void *p = static_TQUType_ptr.get(o); + switch(t.elem()) { + case Smoke::t_bool: + _stack[i].s_bool = *(bool*)p; + break; + case Smoke::t_char: + _stack[i].s_char = *(char*)p; + break; + case Smoke::t_uchar: + _stack[i].s_uchar = *(unsigned char*)p; + break; + case Smoke::t_short: + _stack[i].s_short = *(short*)p; + break; + case Smoke::t_ushort: + _stack[i].s_ushort = *(unsigned short*)p; + break; + case Smoke::t_int: + _stack[i].s_int = *(int*)p; + break; + case Smoke::t_uint: + _stack[i].s_uint = *(unsigned int*)p; + break; + case Smoke::t_long: + _stack[i].s_long = *(long*)p; + break; + case Smoke::t_ulong: + _stack[i].s_ulong = *(unsigned long*)p; + break; + case Smoke::t_float: + _stack[i].s_float = *(float*)p; + break; + case Smoke::t_double: + _stack[i].s_double = *(double*)p; + break; + case Smoke::t_enum: + { + Smoke::EnumFn fn = SmokeClass(t).enumFn(); + if(!fn) { + warn("Unknown enumeration %s\n", t.name()); + _stack[i].s_enum = *(int*)p; + break; + } + Smoke::Index id = t.typeId(); + (*fn)(Smoke::EnumToLong, id, p, _stack[i].s_enum); + } + break; + case Smoke::t_class: + case Smoke::t_voidp: + _stack[i].s_voidp = p; + break; + } + } + } + } + } + void invokeSlot() { + dSP; + if(_called) return; + _called = true; + + SP = _sp + _items - 1; + PUTBACK; + int count = call_sv((SV*)GvCV(_gv), G_SCALAR); + SPAGAIN; + SP -= count; + PUTBACK; + FREETMPS; + LEAVE; + } + void next() { + int oldcur = _cur; + _cur++; + + while(!_called && _cur < _items) { + Marshall::HandlerFn fn = getMarshallFn(type()); + (*fn)(this); + _cur++; + } + + invokeSlot(); + _cur = oldcur; + } + InvokeSlot(TQObject *qobj, GV *gv, int items, MocArgument *args, TQUObject *o) : + _qobj(qobj), _gv(gv), _items(items), _args(args), _o(o), _cur(-1), _called(false) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + EXTEND(SP, items); + PUTBACK; + _sp = SP + 1; + for(int i = 0; i < _items; i++) + _sp[i] = sv_newmortal(); + _stack = new Smoke::StackItem[_items]; + copyArguments(); + } + ~InvokeSlot() { + delete[] _stack; + } + +}; + +class TQtSmokeBinding : public SmokeBinding { +public: + TQtSmokeBinding(Smoke *s) : SmokeBinding(s) {} + void deleted(Smoke::Index classId, void *ptr) { + SV *obj = getPointerObject(ptr); + smokeperl_object *o = sv_obj_info(obj); + if(do_debug && (do_debug & qtdb_gc)) { + fprintf(stderr, "%p->~%s()\n", ptr, smoke->className(classId)); + } + if(!o || !o->ptr) { + return; + } + unmapPointer(o, o->classId, 0); + o->ptr = 0; + } + bool callMethod(Smoke::Index method, void *ptr, Smoke::Stack args, bool isAbstract) { + SV *obj = getPointerObject(ptr); + smokeperl_object *o = sv_obj_info(obj); + if(do_debug && (do_debug & qtdb_virtual)) fprintf(stderr, "virtual %p->%s::%s() called\n", ptr, + smoke->classes[smoke->methods[method].classId].className, + smoke->methodNames[smoke->methods[method].name] + ); + + if(!o) { + if(!PL_dirty && (do_debug && (do_debug & qtdb_virtual)) ) // if not in global destruction + fprintf(stderr, "Cannot find object for virtual method\n"); + return false; + } + HV *stash = SvSTASH(SvRV(obj)); + if(*HvNAME(stash) == ' ') + stash = gv_stashpv(HvNAME(stash) + 1, TRUE); + const char *methodName = smoke->methodNames[smoke->methods[method].name]; + GV *gv = gv_fetchmethod_autoload(stash, methodName, 0); + if(!gv) return false; + + VirtualMethodCall c(smoke, method, args, obj, gv); + // exception variable, just temporary + temporary_virtual_function_success = true; + c.next(); + bool ret = temporary_virtual_function_success; + temporary_virtual_function_success = true; + return ret; + } + char *className(Smoke::Index classId) { + const char *className = smoke->className(classId); + char *buf = new char[strlen(className) + 6]; + strcpy(buf, " TQt::"); + strcat(buf, className + 1); + return buf; + } +}; + +// ---------------- Helpers ------------------- + +SV *catArguments(SV** sp, int n) +{ + SV* r=newSVpvf(""); + for(int i = 0; i < n; i++) { + if(i) sv_catpv(r, ", "); + if(!SvOK(sp[i])) { + sv_catpv(r, "undef"); + } else if(SvROK(sp[i])) { + smokeperl_object *o = sv_obj_info(sp[i]); + if(o) + sv_catpv(r, o->smoke->className(o->classId)); + else + sv_catsv(r, sp[i]); + } else { + bool isString = SvPOK(sp[i]); + STRLEN len; + char *s = SvPV(sp[i], len); + if(isString) sv_catpv(r, "'"); + sv_catpvn(r, s, len > 10 ? 10 : len); + if(len > 10) sv_catpv(r, "..."); + if(isString) sv_catpv(r, "'"); + } + } + return r; +} + +Smoke::Index package_classid(const char *p) +{ + Smoke::Index *item = classcache->find(p); + if(item) + return *item; + char *nisa = new char[strlen(p)+6]; + strcpy(nisa, p); + strcat(nisa, "::ISA"); + AV* isa=get_av(nisa, true); + delete[] nisa; + for(int i=0; i<=av_len(isa); i++) { + SV** np = av_fetch(isa, i, 0); + if(np) { + Smoke::Index ix = package_classid(SvPV_nolen(*np)); + if(ix) { + classcache->insert(p, new Smoke::Index(ix)); + return ix; + } + } + } + return (Smoke::Index) 0; +} + +char *get_SVt(SV *sv) +{ + char *r; + if(!SvOK(sv)) + r = "u"; + else if(SvIOK(sv)) + r = "i"; + else if(SvNOK(sv)) + r = "n"; + else if(SvPOK(sv)) + r = "s"; + else if(SvROK(sv)) { + smokeperl_object *o = sv_obj_info(sv); + if(!o) { + switch (SvTYPE(SvRV(sv))) { + case SVt_PVAV: + r = "a"; + break; +// case SVt_PV: +// case SVt_PVMG: +// r = "p"; + default: + r = "r"; + } + } + else + r = (char*)o->smoke->className(o->classId); + } + else + r = "U"; + return r; +} + +SV *prettyPrintMethod(Smoke::Index id) { + SV *r = newSVpvf(""); + Smoke::Method &meth = qt_Smoke->methods[id]; + const char *tname = qt_Smoke->types[meth.ret].name; + if(meth.flags & Smoke::mf_static) sv_catpv(r, "static "); + sv_catpvf(r, "%s ", (tname ? tname:"void")); + sv_catpvf(r, "%s::%s(", qt_Smoke->classes[meth.classId].className, qt_Smoke->methodNames[meth.name]); + for(int i = 0; i < meth.numArgs; i++) { + if(i) sv_catpv(r, ", "); + tname = qt_Smoke->types[qt_Smoke->argumentList[meth.args+i]].name; + sv_catpv(r, (tname ? tname:"void")); + } + sv_catpv(r, ")"); + if(meth.flags & Smoke::mf_const) sv_catpv(r, " const"); + return r; +} + +// --------------- Unary Keywords && Attributes ------------------ + + +// implements unary 'this' +XS(XS_this) { + dXSARGS; + ST(0) = sv_this; + XSRETURN(1); +} + +// implements unary attributes: 'foo' means 'this->{foo}' +XS(XS_attr) { + dXSARGS; + char *key = GvNAME(CvGV(cv)); + U32 klen = strlen(key); + SV **svp = 0; + if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(sv_this); + svp = hv_fetch(hv, key, klen, 1); + } + if(svp) { + ST(0) = *svp; + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +// implements unary SUPER attribute: 'SUPER' means ${(CopSTASH)::_INTERNAL_STATIC_}{SUPER} +XS(XS_super) { + dXSARGS; + char *key = "SUPER"; + U32 klen = strlen(key); + SV **svp = 0; + if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) { + HV *cs = (HV*)CopSTASH(PL_curcop); + if(!cs) XSRETURN_UNDEF; + svp = hv_fetch(cs, "_INTERNAL_STATIC_", 17, 0); + if(!svp) XSRETURN_UNDEF; + cs = GvHV((GV*)*svp); + if(!cs) XSRETURN_UNDEF; + svp = hv_fetch(cs, "SUPER", 5, 0); + } + if(svp) { + ST(0) = *svp; + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +//---------- XS Autoload (for all functions except fully qualified statics & enums) --------- + +static inline bool isTQt(char *p) { + return (p[0] == 'Q' && p[1] && p[1] == 't' && ((p[2] && p[2] == ':') || !p[2])); +} + +bool avoid_fetchmethod = false; +XS(XS_AUTOLOAD) { + // Err, XS autoload is borked. Lets try... + dXSARGS; + SV *sv = get_sv("TQt::AutoLoad::AUTOLOAD", TRUE); + char *package = SvPV_nolen(sv); + char *method = 0; + for(char *s = package; *s ; s++) + if(*s == ':') method = s; + if(!method) XSRETURN_NO; + *(method++ - 1) = 0; // sorry for showing off. :) + int withObject = (*package == ' ') ? 1 : 0; + int isSuper = 0; + if(withObject) { + package++; + if(*package == ' ') { + isSuper = 1; + char *super = new char[strlen(package) + 7]; + package++; + strcpy(super, package); + strcat(super, "::SUPER"); + package = super; + } + } else if( isTQt(package) ) + avoid_fetchmethod = true; + + HV *stash = gv_stashpv(package, TRUE); + + if(do_debug && (do_debug & qtdb_autoload)) + warn("In XS Autoload for %s::%s()\n", package, method); + + // check for user-defined methods in the REAL stash; skip prefix + GV *gv = 0; + if(avoid_fetchmethod) + avoid_fetchmethod = false; + else + gv = gv_fetchmethod_autoload(stash, method, 0); + + // If we've made it here, we need to set sv_this + if(gv) { + if(do_debug && (do_debug & qtdb_autoload)) + warn("\tfound in %s's Perl stash\n", package); + + // call the defined Perl method with new 'this' + SV *old_this; + if(withObject && !isSuper) { + old_this = sv_this; + sv_this = newSVsv(ST(0)); + } + + ENTER; + SAVETMPS; + PUSHMARK(SP - items + withObject); + PUTBACK; + int count = call_sv((SV*)GvCV(gv), G_SCALAR|G_EVAL); + SPAGAIN; + SV *ret = newSVsv(TOPs); + SP -= count; + PUTBACK; + FREETMPS; + LEAVE; + + if(withObject && !isSuper) { + SvREFCNT_dec(sv_this); + sv_this = old_this; + } + else if(isSuper) + delete[] package; + + if(SvTRUE(ERRSV)) + croak(SvPV_nolen(ERRSV)); + ST(0) = sv_2mortal(ret); + XSRETURN(1); + } + else if(!strcmp(method, "DESTROY")) { + SV *old_this; + if(withObject && !isSuper) { + old_this = sv_this; + sv_this = newSVsv(ST(0)); + } + smokeperl_object *o = sv_obj_info(sv_this); + + if(!(o && o->ptr && (o->allocated || getPointerObject(o->ptr)))) { + if(isSuper) + delete[] package; + if(withObject && !isSuper) { + SvREFCNT_dec(sv_this); + sv_this = old_this; + } + XSRETURN_YES; + } + const char *key = "has been hidden"; + U32 klen = 15; + SV **svp = 0; + if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(sv_this); + svp = hv_fetch(hv, key, klen, 0); + } + if(svp) { + if(isSuper) + delete[] package; + if(withObject && !isSuper) { + SvREFCNT_dec(sv_this); + sv_this = old_this; + } + XSRETURN_YES; + } + gv = gv_fetchmethod_autoload(stash, "ON_DESTROY", 0); + if( !gv ) + croak( "Couldn't find ON_DESTROY method for %s=%p\n", package, o->ptr); + PUSHMARK(SP); + call_sv((SV*)GvCV(gv), G_SCALAR|G_NOARGS); + SPAGAIN; + int ret = POPi; + PUTBACK; + if(withObject && !isSuper) { + SvREFCNT_dec(sv_this); + sv_this = old_this; + } + if( do_debug && ret && (do_debug & qtdb_gc) ) + fprintf(stderr, "Increasing refcount in DESTROY for %s=%p (still has a parent)\n", package, o->ptr); + } else { + + if( items > 18 ) XSRETURN_NO; // current max number of args in TQt is 13. + + // save the stack -- we'll need it + SV **savestack = new SV*[items+1]; + SV *saveobj = ST(0); + SV *old_this; + + Copy(SP - items + 1 + withObject, savestack, items-withObject, SV*); + + // Get the classid (eventually converting SUPER to the right TQt class) + Smoke::Index cid = package_classid(package); + // Look in the cache + char *cname = (char*)qt_Smoke->className(cid); + int lcname = strlen(cname); + int lmethod = strlen(method); + char mcid[256]; + strncpy(mcid, cname, lcname); + char *ptr = mcid + lcname; + *(ptr++) = ';'; + strncpy(ptr, method, lmethod); + ptr += lmethod; + for(int i=withObject ; ifind(mcid); + + if(rcid) { + // Got a hit + _current_method = *rcid; + if(withObject && !isSuper) { + old_this = sv_this; + sv_this = newSVsv(ST(0)); + } + } + else { + + // Find the C++ method to call. I'll do that from Perl for now + + ENTER; + SAVETMPS; + PUSHMARK(SP - items + withObject); + EXTEND(SP, 3); + PUSHs(sv_2mortal(newSViv((IV)cid))); + PUSHs(sv_2mortal(newSVpv(method, 0))); + PUSHs(sv_2mortal(newSVpv(package, 0))); + PUTBACK; + if(withObject && !isSuper) { + old_this = sv_this; + sv_this = newSVsv(saveobj); + } + call_pv("TQt::_internal::do_autoload", G_DISCARD|G_EVAL); + FREETMPS; + LEAVE; + + // Restore sv_this on error, so that eval{ } works + if(SvTRUE(ERRSV)) { + if(withObject && !isSuper) { + SvREFCNT_dec(sv_this); + sv_this = old_this; + } + else if(isSuper) + delete[] package; + delete[] savestack; + croak(SvPV_nolen(ERRSV)); + } + + // Success. Cache result. + methcache->insert(mcid, new Smoke::Index(_current_method)); + } + // FIXME: I shouldn't have to set the current object + { + smokeperl_object *o = sv_obj_info(sv_this); + if(o && o->ptr) { + _current_object = o->ptr; + _current_object_class = o->classId; + } else { + _current_object = 0; + } + } + // honor debugging channels + if(do_debug && (do_debug & qtdb_calls)) { + warn("Calling method\t%s\n", SvPV_nolen(sv_2mortal(prettyPrintMethod(_current_method)))); + if(do_debug & qtdb_verbose) + warn("with arguments (%s)\n", SvPV_nolen(sv_2mortal(catArguments(savestack, items-withObject)))); + } + MethodCall c(qt_Smoke, _current_method, savestack, items-withObject); + c.next(); + if(savestack) + delete[] savestack; + + if(withObject && !isSuper) { + SvREFCNT_dec(sv_this); + sv_this = old_this; + } + else if(isSuper) + delete[] package; + + SV *ret = c.var(); + SvREFCNT_inc(ret); + ST(0) = sv_2mortal(ret); + XSRETURN(1); + } + if(isSuper) + delete[] package; + XSRETURN_YES; +} + + +//----------------- Sig/Slot ------------------ + + +MocArgument *getmetainfo(GV *gv, const char *name, int &offset, int &index, int &argcnt) { + char *signalname = GvNAME(gv); + HV *stash = GvSTASH(gv); + + // $meta = $stash->{META} + SV **svp = hv_fetch(stash, "META", 4, 0); + if(!svp) return 0; + HV *hv = GvHV((GV*)*svp); + if(!hv) return 0; + + // $metaobject = $meta->{object} + // aka. Class->staticMetaObject + svp = hv_fetch(hv, "object", 6, 0); + if(!svp) return 0; + smokeperl_object *ometa = sv_obj_info(*svp); + if(!ometa) return 0; + TQMetaObject *metaobject = (TQMetaObject*)ometa->ptr; + + offset = metaobject->signalOffset(); + + // $signals = $meta->{signal} + U32 len = strlen(name); + svp = hv_fetch(hv, name, len, 0); + if(!svp) return 0; + HV *signalshv = (HV*)SvRV(*svp); + + // $signal = $signals->{$signalname} + len = strlen(signalname); + svp = hv_fetch(signalshv, signalname, len, 0); + if(!svp) return 0; + HV *signalhv = (HV*)SvRV(*svp); + + // $index = $signal->{index} + svp = hv_fetch(signalhv, "index", 5, 0); + if(!svp) return 0;; + index = SvIV(*svp); + + // $argcnt = $signal->{argcnt} + svp = hv_fetch(signalhv, "argcnt", 6, 0); + if(!svp) return 0; + argcnt = SvIV(*svp); + + // $mocargs = $signal->{mocargs} + svp = hv_fetch(signalhv, "mocargs", 7, 0); + if(!svp) return 0; + MocArgument *args = (MocArgument*)SvIV(*svp); + + return args; +} + +MocArgument *getslotinfo(GV *gv, int id, char *&slotname, int &index, int &argcnt, bool isSignal = false) { + HV *stash = GvSTASH(gv); + + // $meta = $stash->{META} + SV **svp = hv_fetch(stash, "META", 4, 0); + if(!svp) return 0; + HV *hv = GvHV((GV*)*svp); + if(!hv) return 0; + + // $metaobject = $meta->{object} + // aka. Class->staticMetaObject + svp = hv_fetch(hv, "object", 6, 0); + if(!svp) return 0; + smokeperl_object *ometa = sv_obj_info(*svp); + if(!ometa) return 0; + TQMetaObject *metaobject = (TQMetaObject*)ometa->ptr; + + int offset = isSignal ? metaobject->signalOffset() : metaobject->slotOffset(); + + index = id - offset; // where we at + // FIXME: make slot inheritance work + if(index < 0) return 0; + // $signals = $meta->{signal} + const char *key = isSignal ? "signals" : "slots"; + svp = hv_fetch(hv, key, strlen(key), 0); + if(!svp) return 0; + AV *signalsav = (AV*)SvRV(*svp); + svp = av_fetch(signalsav, index, 0); + if(!svp) return 0; + HV *signalhv = (HV*)SvRV(*svp); + // $argcnt = $signal->{argcnt} + svp = hv_fetch(signalhv, "argcnt", 6, 0); + if(!svp) return 0; + argcnt = SvIV(*svp); + // $mocargs = $signal->{mocargs} + svp = hv_fetch(signalhv, "mocargs", 7, 0); + if(!svp) return 0; + MocArgument *args = (MocArgument*)SvIV(*svp); + + svp = hv_fetch(signalhv, "name", 4, 0); + if(!svp) return 0; + slotname = SvPV_nolen(*svp); + + return args; +} + +XS(XS_signal) { + dXSARGS; + + smokeperl_object *o = sv_obj_info(sv_this); + TQObject *qobj = (TQObject*)o->smoke->cast( + o->ptr, + o->classId, + o->smoke->idClass("TQObject") + ); + if(qobj->signalsBlocked()) XSRETURN_UNDEF; + + int offset; + int index; + int argcnt; + MocArgument *args; + + args = getmetainfo(CvGV(cv), "signal", offset, index, argcnt); + if(!args) XSRETURN_UNDEF; + + // Okay, we have the signal info. *whew* + if(items < argcnt) + croak("Insufficient arguments to emit signal"); + + EmitSignal signal(qobj, offset + index, argcnt, args, &ST(0)); + signal.next(); + + XSRETURN_UNDEF; +} + +XS(XS_qt_invoke) { + dXSARGS; + // Arguments: int id, TQUObject *o + int id = SvIV(ST(0)); + TQUObject *_o = (TQUObject*)SvIV(SvRV(ST(1))); + + smokeperl_object *o = sv_obj_info(sv_this); + TQObject *qobj = (TQObject*)o->smoke->cast( + o->ptr, + o->classId, + o->smoke->idClass("TQObject") + ); + + // Now, I need to find out if this means me + int index; + char *slotname; + int argcnt; + MocArgument *args; + bool isSignal = !strcmp(GvNAME(CvGV(cv)), "qt_emit"); + args = getslotinfo(CvGV(cv), id, slotname, index, argcnt, isSignal); + if(!args) { + // throw an exception - evil style + temporary_virtual_function_success = false; + XSRETURN_UNDEF; + } + HV *stash = GvSTASH(CvGV(cv)); + GV *gv = gv_fetchmethod_autoload(stash, slotname, 0); + if(!gv) XSRETURN_UNDEF; + InvokeSlot slot(qobj, gv, argcnt, args, _o); + slot.next(); + + XSRETURN_UNDEF; +} + +// ------------------- Tied types ------------------------ + +MODULE = TQt PACKAGE = TQt::_internal::TQString +PROTOTYPES: DISABLE + +SV* +FETCH(obj) + SV* obj + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQString *s = (TQString*) tmp; + RETVAL = newSV(0); + if( s ) + { + if(!(IN_BYTES)) + { + sv_setpv_mg(RETVAL, (const char *)s->utf8()); + SvUTF8_on(RETVAL); + } + else if(IN_LOCALE) + sv_setpv_mg(RETVAL, (const char *)s->local8Bit()); + else + sv_setpv_mg(RETVAL, (const char *)s->latin1()); + } + else + sv_setsv_mg(RETVAL, &PL_sv_undef); + OUTPUT: + RETVAL + +void +STORE(obj,what) + SV* obj + SV* what + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQString *s = (TQString*) tmp; + s->truncate(0); + if(SvOK(what)) { + if(SvUTF8(what)) + s->append(TQString::fromUtf8(SvPV_nolen(what))); + else if(IN_LOCALE) + s->append(TQString::fromLocal8Bit(SvPV_nolen(what))); + else + s->append(TQString::fromLatin1(SvPV_nolen(what))); + } + +void +DESTROY(obj) + SV* obj + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQString *s = (TQString*) tmp; + delete s; + +MODULE = TQt PACKAGE = TQt::_internal::TQByteArray +PROTOTYPES: DISABLE + +SV* +FETCH(obj) + SV* obj + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQByteArray *s = (TQByteArray*) tmp; + RETVAL = newSV(0); + if( s ) + { + sv_setpvn_mg(RETVAL, s->data(), s->size()); + } + else + sv_setsv_mg(RETVAL, &PL_sv_undef); + OUTPUT: + RETVAL + +void +STORE(obj,what) + SV* obj + SV* what + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQByteArray *s = (TQByteArray*) tmp; + + if(SvOK(what)) { + STRLEN len; + char* tmp2 = SvPV(what, len); + s->resize(len); + Copy((void*)tmp2, (void*)s->data(), len, char); + } else + s->truncate(0); + +void +DESTROY(obj) + SV* obj + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQByteArray *s = (TQByteArray*) tmp; + delete s; + +MODULE = TQt PACKAGE = TQt::_internal::TQRgbStar +PROTOTYPES: DISABLE + +SV* +FETCH(obj) + SV* obj + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQRgb *s = (TQRgb*) tmp; + AV* ar = newAV(); + RETVAL = newRV_noinc((SV*)ar); + for(int i=0; s[i] ; i++) + { + SV *item = newSViv((IV)s[i]); + if(!av_store(ar, (I32)i, item)) + SvREFCNT_dec( item ); + } + OUTPUT: + RETVAL + +void +STORE(obj,sv) + SV* obj + SV* sv + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQRgb *s = (TQRgb*) tmp; + if(!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV || + av_len((AV*)SvRV(sv)) < 0) { + s = new TQRgb[1]; + s[0] = 0; + sv_setref_pv(obj, "TQt::_internal::TQRgbStar", (void*)s); + return; + } + AV *list = (AV*)SvRV(sv); + int count = av_len(list); + s = new TQRgb[count + 2]; + int i; + for(i = 0; i <= count; i++) { + SV **item = av_fetch(list, i, 0); + if(!item || !SvOK(*item)) { + s[i] = 0; + continue; + } + s[i] = SvIV(*item); + } + s[i] = 0; + sv_setref_pv(obj, "TQt::_internal::TQRgbStar", (void*)s); + +void +DESTROY(obj) + SV* obj + CODE: + if (!SvROK(obj)) + croak("?"); + IV tmp = SvIV((SV*)SvRV(obj)); + TQRgb *s = (TQRgb*) tmp; + delete[] s; + +# --------------- XSUBS for TQt::_internal::* helpers ---------------- + + +MODULE = TQt PACKAGE = TQt::_internal +PROTOTYPES: DISABLE + +void +getMethStat() + PPCODE: + XPUSHs(sv_2mortal(newSViv((int)methcache->size()))); + XPUSHs(sv_2mortal(newSViv((int)methcache->count()))); + +void +getClassStat() + PPCODE: + XPUSHs(sv_2mortal(newSViv((int)classcache->size()))); + XPUSHs(sv_2mortal(newSViv((int)classcache->count()))); + +void +getIsa(classId) + int classId + PPCODE: + Smoke::Index *parents = + qt_Smoke->inheritanceList + + qt_Smoke->classes[classId].parents; + while(*parents) + XPUSHs(sv_2mortal(newSVpv(qt_Smoke->classes[*parents++].className, 0))); + +void +dontRecurse() + CODE: + avoid_fetchmethod = true; + +void * +sv_to_ptr(sv) + SV* sv + +void * +allocateMocArguments(count) + int count + CODE: + RETVAL = (void*)new MocArgument[count + 1]; + OUTPUT: + RETVAL + +void +setMocType(ptr, idx, name, static_type) + void *ptr + int idx + char *name + char *static_type + CODE: + Smoke::Index typeId = qt_Smoke->idType(name); + if(!typeId) XSRETURN_NO; + MocArgument *arg = (MocArgument*)ptr; + arg[idx].st.set(qt_Smoke, typeId); + if(!strcmp(static_type, "ptr")) + arg[idx].argType = xmoc_ptr; + else if(!strcmp(static_type, "bool")) + arg[idx].argType = xmoc_bool; + else if(!strcmp(static_type, "int")) + arg[idx].argType = xmoc_int; + else if(!strcmp(static_type, "double")) + arg[idx].argType = xmoc_double; + else if(!strcmp(static_type, "char*")) + arg[idx].argType = xmoc_charstar; + else if(!strcmp(static_type, "TQString")) + arg[idx].argType = xmoc_TQString; + XSRETURN_YES; + +void +installsignal(name) + char *name + CODE: + char *file = __FILE__; + newXS(name, XS_signal, file); + +void +installqt_invoke(name) + char *name + CODE: + char *file = __FILE__; + newXS(name, XS_qt_invoke, file); + +void +setDebug(on) + int on + CODE: + do_debug = on; + +int +debug() + CODE: + RETVAL = do_debug; + OUTPUT: + RETVAL + +char * +getTypeNameOfArg(method, idx) + int method + int idx + CODE: + Smoke::Method &m = qt_Smoke->methods[method]; + Smoke::Index *args = qt_Smoke->argumentList + m.args; + RETVAL = (char*)qt_Smoke->types[args[idx]].name; + OUTPUT: + RETVAL + +int +classIsa(className, base) + char *className + char *base + CODE: + RETVAL = isDerivedFrom(qt_Smoke, className, base, 0); + OUTPUT: + RETVAL + +void +insert_pclassid(p, ix) + char *p + int ix + CODE: + classcache->insert(p, new Smoke::Index((Smoke::Index)ix)); + +int +find_pclassid(p) + char *p + CODE: + Smoke::Index *r = classcache->find(p); + if(r) + RETVAL = (int)*r; + else + RETVAL = 0; + OUTPUT: + RETVAL + +void +insert_mcid(mcid, ix) + char *mcid + int ix + CODE: + methcache->insert(mcid, new Smoke::Index((Smoke::Index)ix)); + +int +find_mcid(mcid) + char *mcid + CODE: + Smoke::Index *r = methcache->find(mcid); + if(r) + RETVAL = (int)*r; + else + RETVAL = 0; + OUTPUT: + RETVAL + +char * +getSVt(sv) + SV *sv + CODE: + RETVAL=get_SVt(sv); + OUTPUT: + RETVAL + +void * +make_TQUParameter(name, type, extra, inout) + char *name + char *type + SV *extra + int inout + CODE: + TQUParameter *p = new TQUParameter; + p->name = new char[strlen(name) + 1]; + strcpy((char*)p->name, name); + if(!strcmp(type, "bool")) + p->type = &static_TQUType_bool; + else if(!strcmp(type, "int")) + p->type = &static_TQUType_int; + else if(!strcmp(type, "double")) + p->type = &static_TQUType_double; + else if(!strcmp(type, "char*") || !strcmp(type, "const char*")) + p->type = &static_TQUType_charstar; + else if(!strcmp(type, "TQString") || !strcmp(type, "TQString&") || + !strcmp(type, "const TQString") || !strcmp(type, "const TQString&")) + p->type = &static_TQUType_TQString; + else + p->type = &static_TQUType_ptr; + // Lacking support for several types. Evil. + p->inOut = inout; + p->typeExtra = 0; + RETVAL = (void*)p; + OUTPUT: + RETVAL + +void * +make_TQMetaData(name, method) + char *name + void *method + CODE: + TQMetaData *m = new TQMetaData; // will be deleted + m->name = new char[strlen(name) + 1]; + strcpy((char*)m->name, name); + m->method = (TQUMethod*)method; + m->access = TQMetaData::Public; + RETVAL = m; + OUTPUT: + RETVAL + +void * +make_TQUMethod(name, params) + char *name + SV *params + CODE: + TQUMethod *m = new TQUMethod; // permanent memory allocation + m->name = new char[strlen(name) + 1]; // this too + strcpy((char*)m->name, name); + m->count = 0; + m->parameters = 0; + if(SvOK(params) && SvRV(params)) { + AV *av = (AV*)SvRV(params); + m->count = av_len(av) + 1; + if(m->count > 0) { + m->parameters = new TQUParameter[m->count]; + for(int i = 0; i < m->count; i++) { + SV *sv = av_shift(av); + if(!SvOK(sv)) + croak("Invalid paramater for TQUMethod\n"); + TQUParameter *p = (TQUParameter*)SvIV(sv); + SvREFCNT_dec(sv); + ((TQUParameter*)m->parameters)[i] = *p; + delete p; + } + } else + m->count = 0; + } + RETVAL = m; + OUTPUT: + RETVAL + +void * +make_TQMetaData_tbl(list) + SV *list + CODE: + RETVAL = 0; + if(SvOK(list) && SvRV(list)) { + AV *av = (AV*)SvRV(list); + int count = av_len(av) + 1; + TQMetaData *m = new TQMetaData[count]; + for(int i = 0; i < count; i++) { + SV *sv = av_shift(av); + if(!SvOK(sv)) + croak("Invalid metadata\n"); + TQMetaData *old = (TQMetaData*)SvIV(sv); + SvREFCNT_dec(sv); + m[i] = *old; + delete old; + } + RETVAL = (void*)m; + } + OUTPUT: + RETVAL + +SV * +make_metaObject(className, parent, slot_tbl, slot_count, signal_tbl, signal_count) + char *className + SV *parent + void *slot_tbl + int slot_count + void *signal_tbl + int signal_count + CODE: + smokeperl_object *po = sv_obj_info(parent); + if(!po || !po->ptr) croak("Cannot create metaObject\n"); + TQMetaObject *meta = TQMetaObject::new_metaobject( + className, (TQMetaObject*)po->ptr, + (const TQMetaData*)slot_tbl, slot_count, // slots + (const TQMetaData*)signal_tbl, signal_count, // signals + 0, 0, // properties + 0, 0, // enums + 0, 0); + + // this object-creation code is so, so wrong here + HV *hv = newHV(); + SV *obj = newRV_noinc((SV*)hv); + + smokeperl_object o; + o.smoke = qt_Smoke; + o.classId = qt_Smoke->idClass("TQMetaObject"); + o.ptr = meta; + o.allocated = true; + sv_magic((SV*)hv, sv_qapp, '~', (char*)&o, sizeof(o)); + MAGIC *mg = mg_find((SV*)hv, '~'); + mg->mg_virtual = &vtbl_smoke; + char *buf = qt_Smoke->binding->className(o.classId); + sv_bless(obj, gv_stashpv(buf, TRUE)); + delete[] buf; + RETVAL = obj; + OUTPUT: + RETVAL + +void +dumpObjects() + CODE: + hv_iterinit(pointer_map); + HE *e; + while(e = hv_iternext(pointer_map)) { + STRLEN len; + SV *sv = HeVAL(e); + printf("key = %s, refcnt = %d, weak = %d, ref? %d\n", HePV(e, len), SvREFCNT(sv), SvWEAKREF(sv), SvROK(sv)?1:0); + if(SvRV(sv)) + printf("REFCNT = %d\n", SvREFCNT(SvRV(sv))); + //SvREFCNT_dec(HeVAL(e)); + //HeVAL(e) = &PL_sv_undef; + } + +void +dangle(obj) + SV *obj + CODE: + if(SvRV(obj)) + SvREFCNT_inc(SvRV(obj)); + +void +setAllocated(obj, b) + SV *obj + bool b + CODE: + smokeperl_object *o = sv_obj_info(obj); + if(o) { + o->allocated = b; + } + +void +setqapp(obj) + SV *obj + CODE: + if(!obj || !SvROK(obj)) + croak("Invalid TQt::Application object. Couldn't set TQt::app()\n"); + sv_qapp = SvRV(obj); + +void +setThis(obj) + SV *obj + CODE: + sv_setsv_mg(sv_this, obj); + +void +deleteObject(obj) + SV *obj + CODE: + smokeperl_object *o = sv_obj_info(obj); + if(!o) { XSRETURN_EMPTY; } + TQObject *qobj = (TQObject*)o->smoke->cast(o->ptr, o->classId, o->smoke->idClass("TQObject")); + delete qobj; + +void +mapObject(obj) + SV *obj + CODE: + smokeperl_object *o = sv_obj_info(obj); + if(!o) + XSRETURN_EMPTY; + SmokeClass c( o->smoke, o->classId ); + if(!c.hasVirtual() ) { + XSRETURN_EMPTY; + } + mapPointer(obj, o, pointer_map, o->classId, 0); + +bool +isTQObject(obj) + SV *obj + CODE: + RETVAL = 0; + smokeperl_object *o = sv_obj_info(obj); + if(o && isTQObject(o->smoke, o->classId)) + RETVAL = 1; + OUTPUT: + RETVAL + +bool +isValidAllocatedPointer(obj) + SV *obj + CODE: + RETVAL = 0; + smokeperl_object *o = sv_obj_info(obj); + if(o && o->ptr && o->allocated) + RETVAL = 1; + OUTPUT: + RETVAL + +SV* +findAllocatedObjectFor(obj) + SV *obj + CODE: + RETVAL = &PL_sv_undef; + smokeperl_object *o = sv_obj_info(obj); + SV *ret; + if(o && o->ptr && (ret = getPointerObject(o->ptr))) + RETVAL = ret; + OUTPUT: + RETVAL + +SV * +getGV(cv) + SV *cv + CODE: + RETVAL = (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) ? + SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef); + OUTPUT: + RETVAL + +int +idClass(name) + char *name + CODE: + RETVAL = qt_Smoke->idClass(name); + OUTPUT: + RETVAL + +int +idMethodName(name) + char *name + CODE: + RETVAL = qt_Smoke->idMethodName(name); + OUTPUT: + RETVAL + +int +idMethod(idclass, idmethodname) + int idclass + int idmethodname + CODE: + RETVAL = qt_Smoke->idMethod(idclass, idmethodname); + OUTPUT: + RETVAL + +void +findMethod(c, name) + char *c + char *name + PPCODE: + Smoke::Index meth = qt_Smoke->findMethod(c, name); +// printf("DAMNIT on %s::%s => %d\n", c, name, meth); + if(!meth) { + // empty list + } else if(meth > 0) { + Smoke::Index i = qt_Smoke->methodMaps[meth].method; + if(!i) { // shouldn't happen + croak("Corrupt method %s::%s", c, name); + } else if(i > 0) { // single match + PUSHs(sv_2mortal(newSViv( + (IV)qt_Smoke->methodMaps[meth].method + ))); + } else { // multiple match + i = -i; // turn into ambiguousMethodList index + while(qt_Smoke->ambiguousMethodList[i]) { + PUSHs(sv_2mortal(newSViv( + (IV)qt_Smoke->ambiguousMethodList[i] + ))); + i++; + } + } + } + +void +findMethodFromIds(idclass, idmethodname) + int idclass + int idmethodname + PPCODE: + Smoke::Index meth = qt_Smoke->findMethod(idclass, idmethodname); + if(!meth) { + // empty list + } else if(meth > 0) { + Smoke::Index i = qt_Smoke->methodMaps[meth].method; + if(i >= 0) { // single match + PUSHs(sv_2mortal(newSViv((IV)i))); + } else { // multiple match + i = -i; // turn into ambiguousMethodList index + while(qt_Smoke->ambiguousMethodList[i]) { + PUSHs(sv_2mortal(newSViv( + (IV)qt_Smoke->ambiguousMethodList[i] + ))); + i++; + } + } + } + +# findAllMethods(classid [, startingWith]) : returns { "mungedName" => [index in methods, ...], ... } + +HV* +findAllMethods(classid, ...) + SV* classid + CODE: + RETVAL=newHV(); + if(SvIOK(classid)) { + Smoke::Index c = (Smoke::Index) SvIV(classid); + char * pat = 0L; + if(items > 1 && SvPOK(ST(1))) + pat = SvPV_nolen(ST(1)); + Smoke::Index imax = qt_Smoke->numMethodMaps; + Smoke::Index imin = 0, icur = -1, methmin = 0, methmax = 0; + int icmp = -1; + while(imax >= imin) { + icur = (imin + imax) / 2; + icmp = qt_Smoke->leg(qt_Smoke->methodMaps[icur].classId, c); + if(!icmp) { + Smoke::Index pos = icur; + while(icur && qt_Smoke->methodMaps[icur-1].classId == c) + icur --; + methmin = icur; + icur = pos; + while(icur < imax && qt_Smoke->methodMaps[icur+1].classId == c) + icur ++; + methmax = icur; + break; + } + if (icmp > 0) + imax = icur - 1; + else + imin = icur + 1; + } + if(!icmp) { + for(Smoke::Index i=methmin ; i <= methmax ; i++) { + Smoke::Index m = qt_Smoke->methodMaps[i].name; + if(!pat || !strncmp(qt_Smoke->methodNames[m], pat, strlen(pat))) { + Smoke::Index ix= qt_Smoke->methodMaps[i].method; + AV* meths = newAV(); + if(ix >= 0) { // single match + av_push(meths, newSViv((IV)ix)); + } else { // multiple match + ix = -ix; // turn into ambiguousMethodList index + while(qt_Smoke->ambiguousMethodList[ix]) { + av_push(meths, newSViv((IV)qt_Smoke->ambiguousMethodList[ix])); + ix++; + } + } + hv_store(RETVAL, qt_Smoke->methodNames[m],strlen(qt_Smoke->methodNames[m]),newRV_inc((SV*)meths),0); + } + } + } + } + OUTPUT: + RETVAL + +SV * +dumpCandidates(rmeths) + SV *rmeths + CODE: + if(SvROK(rmeths) && SvTYPE(SvRV(rmeths)) == SVt_PVAV) { + AV *methods = (AV*)SvRV(rmeths); + SV *errmsg = newSVpvf(""); + for(int i = 0; i <= av_len(methods); i++) { + sv_catpv(errmsg, "\t"); + IV id = SvIV(*(av_fetch(methods, i, 0))); + Smoke::Method &meth = qt_Smoke->methods[id]; + const char *tname = qt_Smoke->types[meth.ret].name; + if(meth.flags & Smoke::mf_static) sv_catpv(errmsg, "static "); + sv_catpvf(errmsg, "%s ", (tname ? tname:"void")); + sv_catpvf(errmsg, "%s::%s(", qt_Smoke->classes[meth.classId].className, qt_Smoke->methodNames[meth.name]); + for(int i = 0; i < meth.numArgs; i++) { + if(i) sv_catpv(errmsg, ", "); + tname = qt_Smoke->types[qt_Smoke->argumentList[meth.args+i]].name; + sv_catpv(errmsg, (tname ? tname:"void")); + } + sv_catpv(errmsg, ")"); + if(meth.flags & Smoke::mf_const) sv_catpv(errmsg, " const"); + sv_catpv(errmsg, "\n"); + } + RETVAL=errmsg; + } + else + RETVAL=newSVpvf(""); + OUTPUT: + RETVAL + +SV * +catArguments(r_args) + SV* r_args + CODE: + RETVAL=newSVpvf(""); + if(SvROK(r_args) && SvTYPE(SvRV(r_args)) == SVt_PVAV) { + AV* args=(AV*)SvRV(r_args); + for(int i = 0; i <= av_len(args); i++) { + SV **arg=av_fetch(args, i, 0); + if(i) sv_catpv(RETVAL, ", "); + if(!arg || !SvOK(*arg)) { + sv_catpv(RETVAL, "undef"); + } else if(SvROK(*arg)) { + smokeperl_object *o = sv_obj_info(*arg); + if(o) + sv_catpv(RETVAL, o->smoke->className(o->classId)); + else + sv_catsv(RETVAL, *arg); + } else { + bool isString = SvPOK(*arg); + STRLEN len; + char *s = SvPV(*arg, len); + if(isString) sv_catpv(RETVAL, "'"); + sv_catpvn(RETVAL, s, len > 10 ? 10 : len); + if(len > 10) sv_catpv(RETVAL, "..."); + if(isString) sv_catpv(RETVAL, "'"); + } + } + } + OUTPUT: + RETVAL + +SV * +callMethod(...) + PPCODE: + if(_current_method) { + MethodCall c(qt_Smoke, _current_method, &ST(0), items); + c.next(); + SV *ret = c.var(); + SvREFCNT_inc(ret); + PUSHs(sv_2mortal(ret)); + } else + PUSHs(sv_newmortal()); + +bool +isObject(obj) + SV *obj + CODE: + RETVAL = sv_to_ptr(obj) ? TRUE : FALSE; + OUTPUT: + RETVAL + +void +setCurrentMethod(meth) + int meth + CODE: + // FIXME: damn, this is lame, and it doesn't handle ambiguous methods + _current_method = meth; //qt_Smoke->methodMaps[meth].method; + +SV * +getClassList() + CODE: + AV *av = newAV(); + for(int i = 1; i <= qt_Smoke->numClasses; i++) { +//printf("%s => %d\n", qt_Smoke->classes[i].className, i); + av_push(av, newSVpv(qt_Smoke->classes[i].className, 0)); +// hv_store(hv, qt_Smoke->classes[i].className, 0, newSViv(i), 0); + } + RETVAL = newRV((SV*)av); + OUTPUT: + RETVAL + +void +installthis(package) + char *package + CODE: + if(!package) XSRETURN_EMPTY; + char *name = new char[strlen(package) + 7]; + char *file = __FILE__; + strcpy(name, package); + strcat(name, "::this"); + // *{ $name } = sub () : lvalue; + CV *thissub = newXS(name, XS_this, file); + sv_setpv((SV*)thissub, ""); // sub this () : lvalue; + delete[] name; + +void +installattribute(package, name) + char *package + char *name + CODE: + if(!package || !name) XSRETURN_EMPTY; + char *attr = new char[strlen(package) + strlen(name) + 3]; + sprintf(attr, "%s::%s", package, name); + char *file = __FILE__; + // *{ $attr } = sub () : lvalue; + CV *attrsub = newXS(attr, XS_attr, file); + sv_setpv((SV*)attrsub, ""); + CvLVALUE_on(attrsub); + CvNODEBUG_on(attrsub); + delete[] attr; + +void +installsuper(package) + char *package + CODE: + if(!package) XSRETURN_EMPTY; + char *attr = new char[strlen(package) + 8]; + sprintf(attr, "%s::SUPER", package); + char *file = __FILE__; + CV *attrsub = newXS(attr, XS_super, file); + sv_setpv((SV*)attrsub, ""); + delete[] attr; + +void +installautoload(package) + char *package + CODE: + if(!package) XSRETURN_EMPTY; + char *autoload = new char[strlen(package) + 11]; + strcpy(autoload, package); + strcat(autoload, "::_UTOLOAD"); + char *file = __FILE__; + // *{ $package."::AUTOLOAD" } = XS_AUTOLOAD + newXS(autoload, XS_AUTOLOAD, file); + delete[] autoload; + +# ----------------- XSUBS for TQt:: ----------------- + +MODULE = TQt PACKAGE = TQt + +SV * +this() + CODE: + RETVAL = newSVsv(sv_this); + OUTPUT: + RETVAL + +SV * +app() + CODE: + RETVAL = newRV_inc(sv_qapp); + OUTPUT: + RETVAL + +SV * +version() + CODE: + RETVAL = newSVpv(TQT_VERSION_STR,0); + OUTPUT: + RETVAL + +BOOT: + init_qt_Smoke(); + qt_Smoke->binding = new TQtSmokeBinding(qt_Smoke); + install_handlers(TQt_handlers); + pointer_map = newHV(); + sv_this = newSV(0); + methcache = new TQAsciiDict(1187); + classcache = new TQAsciiDict(827); + methcache->setAutoDelete(1); + classcache->setAutoDelete(1); -- cgit v1.2.3