diff options
Diffstat (limited to 'PerlTQt/lib/Qt')
| -rw-r--r-- | PerlTQt/lib/Qt/GlobalSpace.pm | 25 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/attributes.pm | 51 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/constants.pm | 62 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/debug.pm | 36 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/enumerations.pm | 15 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/isa.pm | 81 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/properties.pm | 14 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/signals.pm | 77 | ||||
| -rw-r--r-- | PerlTQt/lib/Qt/slots.pm | 84 |
9 files changed, 445 insertions, 0 deletions
diff --git a/PerlTQt/lib/Qt/GlobalSpace.pm b/PerlTQt/lib/Qt/GlobalSpace.pm new file mode 100644 index 0000000..75f30a2 --- /dev/null +++ b/PerlTQt/lib/Qt/GlobalSpace.pm @@ -0,0 +1,25 @@ +package TQt::GlobalSpace; +use strict; +require TQt; +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT; +our $allMeth = TQt::_internal::findAllMethods( TQt::_internal::idClass("TQGlobalSpace") ); +no strict 'refs'; + +for my $proto( keys %$allMeth ) +{ + next if $proto =~ /operator\W/; # skip operators + $proto =~ s/[\#\$\?]+$//; + *{ $proto } = sub + { + $TQt::_internal::autoload::AUTOLOAD = "TQt::GlobalSpace\::$proto"; + goto &TQt::GlobalSpace::AUTOLOAD + } unless defined &$proto; + push @EXPORT, $proto; +} + +our %EXPORT_TAGS = ( "all" => [@EXPORT] ); + +1;
\ No newline at end of file diff --git a/PerlTQt/lib/Qt/attributes.pm b/PerlTQt/lib/Qt/attributes.pm new file mode 100644 index 0000000..4398fa5 --- /dev/null +++ b/PerlTQt/lib/Qt/attributes.pm @@ -0,0 +1,51 @@ +package TQt::attributes; +# +# I plan to support public/protected/private attributes. here goes. +# Attributes default to protected. +# +# package MyBase; +# use TQt::attributes qw( +# private: +# foo +# protected: +# bar +# public: +# baz +# ); +# +# package MyDerived; +# use TQt::isa qw(MyBase); +# +# sub foo { +# # 1 way to access private attributes from derived class +# # +# # this->{$class} contains private attributes for $class +# # I specify it to always work that way, +# # so feel free to use it in code. +# this->{MyBase}{foo} = 10; +# +# # 2 ways to access protected attributes +# bar = 10; +# this->{bar} = 10; +# +# # 3 ways to access public attributes +# baz = 10; +# this->{baz} = 10; +# this->baz = 10; +# } +# +# Attributes override any method with the same name, so you may want +# to prefix them with _ to prevent conflicts. +# +sub import { + my $class = shift; + my $caller = (caller)[0]; + + for my $attribute (@_) { + exists ${ ${$caller . '::META'}{'attributes'} }{$attribute} and next; + TQt::_internal::installattribute($caller, $attribute); + ${ ${$caller . '::META'}{'attributes'} }{$attribute} = 1; + } +} + +1; diff --git a/PerlTQt/lib/Qt/constants.pm b/PerlTQt/lib/Qt/constants.pm new file mode 100644 index 0000000..5bdeed0 --- /dev/null +++ b/PerlTQt/lib/Qt/constants.pm @@ -0,0 +1,62 @@ +package TQt::constants; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw( + IO_Direct + IO_Sequential + IO_Combined + IO_TypeMask + IO_Raw + IO_Async + IO_ReadOnly + IO_WriteOnly + IO_ReadWrite + IO_Append + IO_Truncate + IO_Translate + IO_ModeMask + IO_Open + IO_StateMask + IO_Ok + IO_ReadError + IO_WriteError + IO_FatalError + IO_ResourceError + IO_OpenError + IO_ConnectError + IO_AbortError + IO_TimeOutError + IO_UnspecifiedError +); + +our %EXPORT_TAGS = ( 'IO' => [ @EXPORT ] ); + +sub IO_Direct () { 0x0100 } +sub IO_Sequential () { 0x0200 } +sub IO_Combined () { 0x0300 } +sub IO_TypeMask () { 0x0f00 } +sub IO_Raw () { 0x0040 } +sub IO_Async () { 0x0080 } +sub IO_ReadOnly () { 0x0001 } +sub IO_WriteOnly () { 0x0002 } +sub IO_ReadWrite () { 0x0003 } +sub IO_Append () { 0x0004 } +sub IO_Truncate () { 0x0008 } +sub IO_Translate () { 0x0010 } +sub IO_ModeMask () { 0x00ff } +sub IO_Open () { 0x1000 } +sub IO_StateMask () { 0xf000 } +sub IO_Ok () { 0 } +sub IO_ReadError () { 1 } +sub IO_WriteError () { 2 } +sub IO_FatalError () { 3 } +sub IO_ResourceError () { 4 } +sub IO_OpenError () { 5 } +sub IO_ConnectError () { 5 } +sub IO_AbortError () { 6 } +sub IO_TimeOutError () { 7 } +sub IO_UnspecifiedError() { 8 } + +1;
\ No newline at end of file diff --git a/PerlTQt/lib/Qt/debug.pm b/PerlTQt/lib/Qt/debug.pm new file mode 100644 index 0000000..a0f4e19 --- /dev/null +++ b/PerlTQt/lib/Qt/debug.pm @@ -0,0 +1,36 @@ +package TQt::debug; +use TQt; + +our %channel = ( + 'ambiguous' => 0x01, + 'autoload' => 0x02, + 'calls' => 0x04, + 'gc' => 0x08, + 'virtual' => 0x10, + 'verbose' => 0x20, + 'all' => 0xffff +); + +sub import { + shift; + my $db = (@_)? 0x0000 : (0x01|0x20); + my $usage = 0; + for my $ch(@_) { + if( exists $channel{$ch}) { + $db |= $channel{$ch}; + } else { + warn "Unknown debugging channel: $ch\n"; + $usage++; + } + } + TQt::_internal::setDebug($db); + print "Available channels: \n\t". + join("\n\t", sort keys %channel). + "\n" if $usage; +} + +sub unimport { + TQt::_internal::setDebug(0); +} + +1;
\ No newline at end of file diff --git a/PerlTQt/lib/Qt/enumerations.pm b/PerlTQt/lib/Qt/enumerations.pm new file mode 100644 index 0000000..9fea98f --- /dev/null +++ b/PerlTQt/lib/Qt/enumerations.pm @@ -0,0 +1,15 @@ +package TQt::enumerations; +# +# Proposed usage: +# +# package MyWidget; +# +# use TQt::enumerations MyInfo => { +# Foo => 1, +# Bar => 10, +# Baz => 64 +# }; +# +# use TQt::enumerations MyInfo => [qw(Foo Bar Baz)]; +# +1; diff --git a/PerlTQt/lib/Qt/isa.pm b/PerlTQt/lib/Qt/isa.pm new file mode 100644 index 0000000..71e9391 --- /dev/null +++ b/PerlTQt/lib/Qt/isa.pm @@ -0,0 +1,81 @@ +package TQt::isa; +use strict; + +sub import { + no strict 'refs'; + my $class = shift; + my $caller = (caller)[0]; + + # Trick 'use' into believing the file for this class has been read + my $pm = $caller . ".pm"; + $pm =~ s!::!/!g; + unless(exists $::INC{$pm}) { + $::INC{$pm} = $::INC{"TQt/isa.pm"}; + } + + for my $super (@_) { + push @{ $caller . '::ISA' }, $super; + push @{ ${$caller . '::META'}{'superClass'} }, $super; # if isa(TQObject)? + } + + *{ $caller . '::className' } = sub { # closure on $caller + return $caller; + }; + + ${ $caller. '::_INTERNAL_STATIC_'}{'SUPER'} = bless {}, " $caller"; + TQt::_internal::installsuper($caller) unless defined &{ $caller.'::SUPER' }; + + *{ $caller . '::metaObject' } = sub { + TQt::_internal::getMetaObject($caller); + }; + + *{ $caller . '::import' } = sub { + my $name = shift; # classname = function-name + my $incaller = (caller)[0]; + $incaller = (caller(1))[0] if $incaller eq 'if'; # work-around bug in package 'if' pre 0.02 + (my $cname = $name) =~ s/.*::// and do + { + *{ "$name" } = sub { + $name->new(@_); + } unless defined &{ "$name" }; + }; + my $p = defined $&? $&:''; + $p eq ($incaller=~/.*::/?($p?$&:''):'') and + *{ "$incaller\::$cname" } = sub { + $name->new(@_); + }; + + if(defined @{ ${$caller.'::META'}{'superClass'} } && + @{ ${$caller.'::META'}{'superClass'} } ) + { + # attributes inheritance + for my $attribute( keys %{ ${$caller.'::META'}{'attributes'} } ) + { + if(! defined &{$incaller.'::'.$attribute }) + { + TQt::_internal::installattribute($incaller, $attribute); + ${ ${$incaller .'::META'}{'attributes'} }{$attribute} = 1; + } + } + } + }; + + TQt::_internal::installautoload(" $caller"); + TQt::_internal::installautoload(" $caller"); + TQt::_internal::installautoload($caller); + { + package TQt::AutoLoad; + my $autosub = \&{ " $caller\::_UTOLOAD" }; + *{ " $caller\::AUTOLOAD" } = sub { &$autosub }; + $autosub = \&{ " $caller\::_UTOLOAD" }; + *{ " $caller\::AUTOLOAD" } = sub { &$autosub }; + $autosub = \&{ "$caller\::_UTOLOAD" }; + *{ "$caller\::AUTOLOAD" } = sub { &$autosub }; + } + TQt::_internal::installthis($caller); + + # operator overloading + *{ " $caller\::ISA" } = ["TQt::base::_overload"]; +} + +1; diff --git a/PerlTQt/lib/Qt/properties.pm b/PerlTQt/lib/Qt/properties.pm new file mode 100644 index 0000000..951cdb6 --- /dev/null +++ b/PerlTQt/lib/Qt/properties.pm @@ -0,0 +1,14 @@ +package TQt::properties; +# +# Proposed usage: +# +# use TQt::properties foo => { +# TYPE => 'bool', +# READ => 'getFoo', +# WRITE => 'setFoo', +# STORED => 0, +# RESET => 'unsetFoo', +# DESIGNABLE => 0 +# }; +# +1; diff --git a/PerlTQt/lib/Qt/signals.pm b/PerlTQt/lib/Qt/signals.pm new file mode 100644 index 0000000..1f454c1 --- /dev/null +++ b/PerlTQt/lib/Qt/signals.pm @@ -0,0 +1,77 @@ +package TQt::signals; +use Carp; +# +# Proposed usage: +# +# use TQt::signals fooActivated => ['int']; +# +# use TQt::signals fooActivated => { +# name => 'fooActivated(int)', +# args => ['int'] +# }; +# +# sub whatever { emit fooActivated(10); } +# + +sub import { + no strict 'refs'; + my $self = shift; + my $caller = $self eq "TQt::signals" ? (caller)[0] : $self; + my $parent = ${ $caller . '::ISA' }[0]; + my $parent_qt_emit = $parent . '::qt_emit'; + + TQt::_internal::installqt_invoke($caller . '::qt_emit') unless defined &{ $caller. '::qt_emit' }; + +# *{ $caller . '::qt_emit' } = sub { +# my $meta = \%{ $caller . '::META' }; +# die unless $meta->{object}; +# my $offset = $_[0] - $meta->{object}->signalOffset; +# if($offset >= 0) { +# TQt::_internal::invoke(TQt::this(), $meta->{signals}[$offset], $_[1]); +# return 1; +# } else { +# TQt::this()->$parent_qt_emit(@_); +# } +# } unless defined &{ $caller . '::qt_emit' }; + + my $meta = \%{ $caller . '::META' }; + croak "Odd number of arguments in signal declaration" if @_%2; + my(%signals) = @_; + for my $signalname (keys %signals) { + my $signal = { name => $signalname }; + my $args = $signals{$signalname}; + $signal->{arguments} = [map { s/\s(?=[*&])//; { type => $_, name => "" } } @$args]; + my $arglist = join ',', @$args; + $signal->{prototype} = $signalname . "($arglist)"; + $signal->{returns} = 'void'; + $signal->{method} = $signalname; + push @{$meta->{signals}}, $signal; + my $signal_index = $#{ $meta->{signals} }; + + my $argcnt = scalar @$args; + my $mocargs = TQt::_internal::allocateMocArguments($argcnt); + my $i = 0; + for my $arg (@$args) { + my $a = $arg; + $a =~ s/^const\s+//; + if($a =~ /^(bool|int|double|char\*|TQString)&?$/) { + $a = $1; + } else { + $a = 'ptr'; + } + my $valid = TQt::_internal::setMocType($mocargs, $i, $arg, $a); + die "Invalid type for signal argument ($arg)\n" unless $valid; + $i++; + } + + $meta->{signal}{$signalname} = $signal; + $signal->{index} = $signal_index; + $signal->{mocargs} = $mocargs; + $signal->{argcnt} = $argcnt; + + TQt::_internal::installsignal("$caller\::$signalname"); + } + @_ and $meta->{changed} = 1; +} + +1; diff --git a/PerlTQt/lib/Qt/slots.pm b/PerlTQt/lib/Qt/slots.pm new file mode 100644 index 0000000..c12990e --- /dev/null +++ b/PerlTQt/lib/Qt/slots.pm @@ -0,0 +1,84 @@ +package TQt::slots; +use Carp; +# +# Proposed usage: +# +# use TQt::slots changeSomething => ['int']; +# +# use TQt::slots 'changeSomething(int)' => { +# args => ['int'], +# call => 'changeSomething' +# }; +# + +sub import { + no strict 'refs'; + my $self = shift; + my $caller = $self eq "TQt::slots" ? (caller)[0] : $self; + my $parent = ${ $caller . '::ISA' }[0]; + my $parent_qt_invoke = $parent . '::qt_invoke'; + + TQt::_internal::installqt_invoke($caller . '::qt_invoke') unless defined &{ $caller. '::qt_invoke' }; + +# *{ $caller . '::qt_invoke' } = sub { +# my $meta = \%{ $caller . '::META' }; +# die unless $meta->{object}; +# my $offset = $_[0] - $meta->{object}->slotOffset; +# if($offset >= 0) { +# TQt::_internal::invoke(TQt::this(), $meta->{slots}[$offset], $_[1]); +# return 1; +# } else { +# TQt::this()->$parent_qt_invoke(@_); +# } +# } unless defined &{ $caller . '::qt_invoke' }; + + my $meta = \%{ $caller . '::META' }; + croak "Odd number of arguments in slot declaration" if @_%2; + my(%slots) = @_; + for my $slotname (keys %slots) { + my $slot = { name => $slotname }; + my $args = $slots{$slotname}; + $slot->{arguments} = [map { s/\s(?=[*&])//; { type => $_, name => "" } } @$args]; + my $arglist = join ',', @$args; + + $slot->{prototype} = $slotname . "($arglist)"; + if ( exists $meta->{slot}{$slotname} ) { + (my $s1 = $slot->{prototype}) =~ s/\s+//g; + (my $s2 = $meta->{slot}{$slotname}{prototype}) =~ s/\s+//g; + if( $s1 ne $s2 ) { + warn( "Slot declaration:\n\t$slot->{prototype}\nwill override ". + "previous declaration:\n\t$meta->{slot}{$slotname}{prototype}"); + } else { + next; + } + } + $slot->{returns} = 'void'; + $slot->{method} = $slotname; + push @{$meta->{slots}}, $slot; + my $slot_index = $#{ $meta->{slots} }; + + my $argcnt = scalar @$args; + my $mocargs = TQt::_internal::allocateMocArguments($argcnt); + my $i = 0; + for my $arg (@$args) { + my $a = $arg; + $a =~ s/^const\s+//; + if($a =~ /^(bool|int|double|char\*|TQString)&?$/) { + $a = $1; + } else { + $a = 'ptr'; + } + my $valid = TQt::_internal::setMocType($mocargs, $i, $arg, $a); + die "Invalid type for slot argument ($arg)\n" unless $valid; + $i++; + } + + $meta->{slot}{$slotname} = $slot; + $slot->{index} = $slot_index; + $slot->{mocargs} = $mocargs; + $slot->{argcnt} = $argcnt; + } + @_ and $meta->{changed} = 1; +} + +1; |