jyapayne/swig
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

steals python directors and adapts to perl5

Browse source
This commit is contained in:
Robert Stone 2013-11-12 12:45:03 -08:00
commit 0901a3e867
23 changed files with 1741 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

62
Examples/test-suite/perl5/director_abstract_runme.pl Normal file
View file

@ -0,0 +1,62 @@
use strict;
use warnings;
use Test::More tests => 13;
BEGIN { use_ok('director_abstract') }
require_ok('director_abstract');
{
package MyFoo;
use base 'director_abstract::Foo';
sub ping {
return 'MyFoo::ping()';
}
}
my $f = MyFoo->new();
is($f->ping, "MyFoo::ping()");
is($f->pong(),"Foo::pong();MyFoo::ping()");
{
package MyExample1;
use base 'director_abstract::Example1';
sub Color { my($self, $r, $g, $b) = @_;
return $r;
}
}
{
package MyExample2;
use base 'director_abstract::Example2';
sub Color { my($self, $r, $g, $b) = @_;
return $g;
}
}
{
package MyExample3;
use base 'director_abstract::Example3_i';
sub Color { my($self, $r, $g, $b) = @_;
return $b;
}
}
my $me1 = MyExample1->new();
isa_ok($me1, 'MyExample1');
is(director_abstract::Example1::get_color($me1, 1, 2, 3), 1, 'me1');
my $me2 = MyExample2->new(1,2);
isa_ok($me2, 'MyExample2');
is(director_abstract::Example2::get_color($me2, 1, 2, 3), 2, 'me2');
my $me3 = MyExample3->new();
isa_ok($me3, 'MyExample3');
is(director_abstract::Example3_i::get_color($me3, 1, 2, 3), 3, 'me3');
eval { $me1 = director_abstract::Example1->new() };
like($@, qr/\babstract\b/i, 'E1.new()');
eval { $me2 = director_abstract::Example2->new() };
like($@, qr/Example2/, 'E2.new()');
eval { $me3 = director_abstract::Example3_i->new() };
like($@, qr/\babstract\b/i, 'E3.new()');

8
Examples/test-suite/perl5/director_alternating_runme.pl Normal file
View file

@ -0,0 +1,8 @@
use strict;
use warnings;
use Test::More tests => 3;
BEGIN { use_ok('director_alternating') }
require_ok('director_alternating');
my $id = director_alternating::getBar()->id();
is($id, director_alternating::idFromGetBar(), "got Bar id");

57
Examples/test-suite/perl5/director_basic_runme.pl Normal file
View file

@ -0,0 +1,57 @@
use strict;
use warnings;
use Test::More tests => 12;
BEGIN { use_ok 'director_basic' }
require_ok 'director_basic';
{
package MyFoo;
use base 'director_basic::Foo';
sub ping {
return 'MyFoo::ping()';
}
}
{
package MyOverriddenClass;
use base 'director_basic::MyClass';
use fields qw(expectNull nonNullReceived);
sub new {
my $self = shift->SUPER::new(@_);
$self->{expectNull} = undef;
$self->{nonNullReceived} = undef;
return $self;
}
sub pmethod { my($self, $b) = @_;
die "null not received as expected"
if $self->{expectNull} and defined $b;
return $b;
}
}
{
my $a = MyFoo->new();
isa_ok $a, 'MyFoo';
is $a->ping(), 'MyFoo::ping()', 'a.ping()';
is $a->pong(), 'Foo::pong();MyFoo::ping()', 'a.pong()';
my $b = director_basic::Foo->new();
isa_ok $b, 'director_basic::Foo';
is $b->ping(), 'Foo::ping()', 'b.ping()';
is $b->pong(), 'Foo::pong();Foo::ping()', 'b.pong()';
my $a1 = director_basic::A1->new(1, undef);
isa_ok $a1, 'director_basic::A1';
is $a1->rg(2), 2, 'A1.rg';
my $my = MyOverriddenClass->new();
$my->{expectNull} = 1;
is(director_basic::MyClass::call_pmethod($my, undef), undef,
'null pointer marshalling');
my $myBar = director_basic::Bar->new();
$my->{expectNull} = undef;
my $myNewBar = director_basic::MyClass::call_pmethod($my, $myBar);
isnt($myNewBar, undef, 'non-null pointer marshalling');
$myNewBar->{x} = 10;
}

70
Examples/test-suite/perl5/director_classes_runme.pl Normal file
View file

@ -0,0 +1,70 @@
use strict;
use warnings;
use Test::More tests => 29;
BEGIN { use_ok 'director_classes' }
require_ok 'director_classes';
{
package PerlDerived;
use base 'director_classes::Base';
sub Val { $_[1] }
sub Ref { $_[1] }
sub Ptr { $_[1] }
sub FullyOverloaded {
my $rv = shift->SUPER::FullyOverloaded(@_);
$rv =~ s/Base/__PACKAGE__/sge;
return $rv;
}
sub SemiOverloaded {
# this is going to be awkward because we can't really
# semi-overload in Perl, but we can sort of fake it.
return shift->SUPER::SemiOverloaded(@_) unless $_[0] =~ /^\d+/;
my $rv = shift->SUPER::SemiOverloaded(@_);
$rv =~ s/Base/__PACKAGE__/sge;
return $rv;
}
sub DefaultParms {
my $rv = shift->SUPER::DefaultParms(@_);
$rv =~ s/Base/__PACKAGE__/sge;
return $rv;
}
}
{
my $c = director_classes::Caller->new();
makeCalls($c, director_classes::Base->new(100.0));
makeCalls($c, director_classes::Derived->new(200.0));
makeCalls($c, PerlDerived->new(300.0));
}
sub makeCalls { my($caller, $base) = @_;
my $bname = ref $base;
$bname = $1 if $bname =~ /^director_classes::(.*)$/;
$caller->set($base);
my $dh = director_classes::DoubleHolder->new(444.555);
is($caller->ValCall($dh)->{val}, $dh->{val}, "$bname.Val");
is($caller->RefCall($dh)->{val}, $dh->{val}, "$bname.Ref");
is($caller->PtrCall($dh)->{val}, $dh->{val}, "$bname.Ptr");
is($caller->FullyOverloadedCall(1),
"${bname}::FullyOverloaded(int)",
"$bname.FullyOverloaded(int)");
is($caller->FullyOverloadedCall(''),
"${bname}::FullyOverloaded(bool)",
"$bname.FullyOverloaded(bool)");
TODO: {
local $TODO = 'investigation needed here' if $bname eq 'PerlDerived';
is($caller->SemiOverloadedCall(-678),
"${bname}::SemiOverloaded(int)",
"$bname.SemiOverloaded(int)");
}
is($caller->SemiOverloadedCall(''),
"Base::SemiOverloaded(bool)",
"$bname.SemiOverloaded(bool)");
is($caller->DefaultParmsCall(10, 2.2),
"${bname}::DefaultParms(int, double)",
"$bname.DefaultParms(int, double)");
is($caller->DefaultParmsCall(10),
"${bname}::DefaultParms(int)",
"$bname.DefaultParms(int)");
$caller->reset();
}

128
Examples/test-suite/perl5/director_classic_runme.pl Normal file
View file

@ -0,0 +1,128 @@
use strict;
use warnings;
use Test::More tests => 41;
BEGIN { use_ok('director_classic') }
require_ok('director_classic');
{
package TargetLangPerson;
use base 'director_classic::Person';
sub id { return 'TargetLangPerson' }
}
{
package TargetLangChild;
use base 'director_classic::Child';
sub id { return 'TargetLangChild' }
}
{
package TargetLangGrandChild;
use base 'director_classic::GrandChild';
sub id { return 'TargetLangGrandChild' }
}
# Semis - don't override id() in target language
{
package TargetLangSemiPerson;
use base 'director_classic::Person';
# No id() override
}
{
package TargetLangSemiChild;
use base 'director_classic::Child';
# No id() override
}
{
package TargetLangSemiGrandChild;
use base 'director_classic::GrandChild';
# No id() override
}
# Orphans - don't override id() in C++
{
package TargetLangOrphanPerson;
use base 'director_classic::OrphanPerson';
sub id { return "TargetLangOrphanPerson" }
}
{
package TargetLangOrphanChild;
use base 'director_classic::OrphanChild';
sub id { return "TargetLangOrphanChild" }
}
sub check { my($person, $expected) = @_;
# Normal target language polymorphic call
is($person->id(), $expected, "$expected from Perl");
# Polymorphic call from C++
my $caller = director_classic::Caller->new();
$caller->setCallback($person);
is($caller->call(), $expected, "$expected from C++");
# Polymorphic call of object created in target language and passed to C++ and back again
my $baseclass = $caller->baseClass();
is($baseclass->id(), $expected, "$expected after bounce");
$caller->resetCallback();
}
my $person;
$person = director_classic::Person->new();
check($person, "Person");
undef $person;
$person = director_classic::Child->new();
check($person, "Child");
undef $person;
$person = director_classic::GrandChild->new();
check($person, "GrandChild");
undef $person;
$person = TargetLangPerson->new();
check($person, "TargetLangPerson");
undef $person;
$person = TargetLangChild->new();
check($person, "TargetLangChild");
undef $person;
$person = TargetLangGrandChild->new();
check($person, "TargetLangGrandChild");
undef $person;
# Semis - don't override id() in target language
$person = TargetLangSemiPerson->new();
check($person, "Person");
undef $person;
$person = TargetLangSemiChild->new();
check($person, "Child");
undef $person;
$person = TargetLangSemiGrandChild->new();
check($person, "GrandChild");
undef $person;
# Orphans - don't override id() in C++
$person = director_classic::OrphanPerson->new();
check($person, "Person");
undef $person;
$person = director_classic::OrphanChild->new();
check($person, "Child");
undef $person;
$person = TargetLangOrphanPerson->new();
check($person, "TargetLangOrphanPerson");
undef $person;
$person = TargetLangOrphanChild->new();
check($person, "TargetLangOrphanChild");
undef $person;

46
Examples/test-suite/perl5/director_constructor_runme.pl Normal file
View file

@ -0,0 +1,46 @@
use strict;
use warnings;
use Test::More tests => 9;
BEGIN { use_ok 'director_constructor' }
require_ok 'director_constructor';
{
package Test;
use base 'director_constructor::Foo';
sub doubleit { my($self) = @_;
$self->{a} *= 2;
}
sub test { 3 }
}
my $t = Test->new(5);
isa_ok $t, 'Test';
is $t->getit, 5;
is $t->do_test, 3;
$t->doubleit();
is $t->getit, 10;
{
package Wrong;
use base 'director_constructor::Foo';
sub doubleit { my($self) = @_;
# calling this should trigger a type error on attribute
# assignment
$self->{a} = {};
}
sub test {
# if c++ calls this, retval copyout should trigger a type error
return bless {}, 'TotallyBogus';
}
}
# TODO: these TypeErrors in director classes should be more detailed
my $w = Wrong->new(12);
is eval { $w->doubleit() }, undef;
like $@, qr/TypeError/;
is $w->getit(), 12, 'W.a should be unaffected';
# TODO: this is giving an unhandled C++ exception right now
#is eval { $W->do_test() }, undef;
#like $@, qr/TypeError/;

18
Examples/test-suite/perl5/director_default_runme.pl Normal file
View file

@ -0,0 +1,18 @@
use strict;
use warnings;
use Test::More tests => 6;
BEGIN { use_ok 'director_default' }
require_ok 'director_default';
my $f;
$f = director_default::Foo->new();
isa_ok $f, 'director_default::Foo';
$f = director_default::Foo->new(1);
isa_ok $f, 'director_default::Foo';
$f = director_default::Bar->new();
isa_ok $f, 'director_default::Bar';
$f = director_default::Bar->new(1);
isa_ok $f, 'director_default::Bar';

45
Examples/test-suite/perl5/director_detect_runme.pl Normal file
View file

@ -0,0 +1,45 @@
use strict;
use warnings;
use Test::More tests => 9;
BEGIN { use_ok 'director_detect' }
require_ok 'director_detect';
{
package MyBar;
use base 'director_detect::Bar';
sub new { my $class = shift;
my $val = @_ ? shift : 2;
my $self = $class->SUPER::new();
$self->{val} = $val;
return $self;
}
sub get_value { my($self) = @_;
$self->{val}++;
return $self->{val};
}
sub get_class { my($self) = @_;
$self->{val}++;
return director_detect::A->new();
}
sub just_do_it { my($self) = @_;
$self->{val}++;
}
sub clone { my($self) = @_;
MyBar->new($self->{val});
}
}
my $b = MyBar->new();
isa_ok $b, 'MyBar';
my $f = $b->baseclass();
isa_ok $f, 'director_detect::Foo';
is $f->get_value(), 3;
isa_ok $f->get_class(), 'director_detect::A';
$f->just_do_it();
my $c = $b->clone();
isa_ok $c, 'MyBar';
is $b->{val}, 5;
is $c->get_value(), 6;

21
Examples/test-suite/perl5/director_enum_runme.pl Normal file
View file

@ -0,0 +1,21 @@
use strict;
use warnings;
use Test::More tests => 5;
BEGIN { use_ok 'director_enum' }
require_ok 'director_enum';
{
package MyFoo;
use base 'director_enum::Foo';
sub say_hi { my($self, $val) = @_;
return $val;
}
}
my $b = director_enum::Foo->new();
isa_ok $b, 'director_enum::Foo';
my $a = MyFoo->new();
isa_ok $a, 'MyFoo';
is $a->say_hi($director_enum::hello),
$a->say_hello($director_enum::hi);

57
Examples/test-suite/perl5/director_exception_runme.pl Normal file
View file

@ -0,0 +1,57 @@
use strict;
use warnings;
use Test::More tests => 7;
BEGIN { use_ok 'director_exception' }
require_ok 'director_exception';
{
package MyFoo;
use base 'director_exception::Foo';
sub ping {
die "MyFoo::ping() EXCEPTION";
}
}
{
package MyFoo2;
use base 'director_exception::Foo';
sub ping {
# error should return a string
return bless [ 1 ], 'main';
}
}
{
package MyFoo3;
use base 'director_exception::Foo';
sub ping {
# error should return a string
return sub { 1 }
}
}
{
my $a = MyFoo->new();
my $b = director_exception::launder($a);
eval { $b->pong() };
like($@, qr/\bMyFoo::ping\(\) EXCEPTION\b/,
'MyFoo.pong() error content preserved');
}
{
my $a = MyFoo2->new();
my $b = director_exception::launder($a);
eval { $b->pong() };
like($@, qr/\bTypeError\b/,
'MyFoo2.pong() error content preserved');
}
{
my $a = MyFoo3->new();
my $b = director_exception::launder($a);
eval { $b->pong() };
like($@, qr/\bTypeError\b/,
'MyFoo2.pong() error content preserved');
}
eval { die director_exception::Exception1->new() };
isa_ok($@, 'director_exception::Exception1', 'Exception1');
eval { die director_exception::Exception2->new() };
isa_ok($@, 'director_exception::Exception2', 'Exception2');

16
Examples/test-suite/perl5/director_extend_runme.pl Normal file
View file

@ -0,0 +1,16 @@
use strict;
use warnings;
use Test::More tests => 5;
BEGIN { use_ok 'director_extend' }
require_ok 'director_extend';
{
package MyObject;
use base 'director_extend::SpObject';
sub getFoo { 123 }
}
my $m = MyObject->new();
isa_ok $m, 'MyObject';
is($m->dummy(), 666, '1st call');
is($m->dummy(), 666, '2nd call');

83
Examples/test-suite/perl5/director_finalizer_runme.pl Normal file
View file

@ -0,0 +1,83 @@
use strict;
use warnings;
use Test::More tests => 13;
BEGIN { use_ok('director_finalizer') }
require_ok('director_finalizer');
{
package MyFoo;
use base 'director_finalizer::Foo';
sub DIRECTOR_DESTROY { my($self) = @_;
$self->orStatus(2);
}
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
undef $f;
is(director_finalizer::getStatus(), 3, 'shadow release fires destructor');
}
{ # again, this time with DESTROY
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DESTROY();
is(director_finalizer::getStatus(), 3, 'DESTROY method fires destructor');
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
director_finalizer::launder($f);
is(director_finalizer::getStatus(), 0, 'wrap release does not fire destructor');
undef $f;
is(director_finalizer::getStatus(), 3, 'shadow release still fires destructor');
}
{ # again, this time with DESTROY
director_finalizer::resetStatus();
my $f = MyFoo->new();
director_finalizer::launder($f);
is(director_finalizer::getStatus(), 0, 'wrap release does not fire destructor');
$f->DESTROY();
is(director_finalizer::getStatus(), 3, 'DESTROY method still fires destructor');
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DISOWN();
is(director_finalizer::getStatus(), 0, 'shadow release does not fire destructor of disowned object');
director_finalizer::deleteFoo($f);
is(director_finalizer::getStatus(), 3, 'c++ release fires destructors of disowned object');
}
{ # again, this time with DESTROY
my $f = MyFoo->new();
$f->DISOWN();
director_finalizer::deleteFoo($f);
director_finalizer::resetStatus();
$f->DESTROY();
is(director_finalizer::getStatus(), 0, 'DESTROY method does not fire destructor of disowned object');
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DISOWN();
my $g = director_finalizer::launder($f);
undef $f;
director_finalizer::deleteFoo($g);
is(director_finalizer::getStatus(), 3, 'c++ release fires destructors on disowned opaque object');
}
{ # again, this time with DESTROY
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DISOWN();
my $g = director_finalizer::launder($f);
$f->DESTROY();
director_finalizer::deleteFoo($g);
is(director_finalizer::getStatus(), 3, 'c++ release fires destructors on disowned opaque object after DESTROY');
}

10
Examples/test-suite/perl5/director_frob_runme.pl Normal file
View file

@ -0,0 +1,10 @@
use strict;
use warnings;
use Test::More tests => 4;
BEGIN { use_ok 'director_frob' }
require_ok 'director_frob';
my $foo = director_frob::Bravo->new();
isa_ok $foo, 'director_frob::Bravo';
is($foo->abs_method(), 'Bravo::abs_method()');

25
Examples/test-suite/perl5/director_ignore_runme.pl Normal file
View file

@ -0,0 +1,25 @@
use strict;
use warnings;
use Test::More tests => 6;
BEGIN { use_ok 'director_ignore' }
require_ok 'director_ignore';
{
package DIgnoresDerived;
use base 'director_ignore::DIgnores';
sub PublicMethod1 {
return 18.75;
}
}
{
package DAbstractIgnoresDerived;
use base 'director_ignore::DAbstractIgnores';
}
my $a = DIgnoresDerived->new();
isa_ok $a, 'DIgnoresDerived';
is $a->Triple(5), 15;
my $b = DAbstractIgnoresDerived->new();
isa_ok $b, 'DAbstractIgnoresDerived';
is $b->Quadruple(5), 20;

59
Examples/test-suite/perl5/director_nested_runme.pl Normal file
View file

@ -0,0 +1,59 @@
use strict;
use warnings;
use Test::More tests => 9;
BEGIN { use_ok 'director_nested' }
require_ok 'director_nested';
{
package A;
use base 'director_nested::FooBar_int';
sub do_step { 'A::do_step;' }
sub get_value { 'A::get_value' }
}
my $a = A->new();
isa_ok $a, 'A';
is $a->step(), "Bar::step;Foo::advance;Bar::do_advance;A::do_step;",
'A virtual resolution';
{
package B;
use base 'director_nested::FooBar_int';
sub do_advance { my($self) = @_;
return "B::do_advance;" . $self->do_step();
}
sub do_step { "B::do_step;" }
sub get_value { 1 }
}
my $b = B->new();
isa_ok $b, 'B';
is $b->step(), "Bar::step;Foo::advance;B::do_advance;B::do_step;",
'B virtual resolution';
{
package C;
use base 'director_nested::FooBar_int';
our $in_do_advance = 0;
sub do_advance { my($self) = @_;
# found a case where upcall didn't happen right in a perl space
# SUPER:: call.
die "SUPERCALL RESOLVE FAILURE" if $in_do_advance;
local $in_do_advance = 1;
return "C::do_advance;" .
$self->SUPER::do_advance();
}
sub do_step { "C::do_step;" }
sub get_value { 2 }
sub get_name { my($self) = @_;
return $self->director_nested::FooBar_int::get_name() . " hello";
}
}
my $cc = C->new();
isa_ok $cc, 'C';
my $c = director_nested::FooBar_int::get_self($cc);
$c->advance();
is $c->get_name(), "FooBar::get_name hello";
is $c->name(), "FooBar::get_name hello";

68
Examples/test-suite/perl5/director_primitives_runme.pl Normal file
View file

@ -0,0 +1,68 @@
use strict;
use warnings;
use Test::More tests => 27;
BEGIN { use_ok 'director_primitives' }
require_ok 'director_primitives';
{
package PerlDerived;
use base 'director_primitives::Base';
sub NoParmsMethod {
}
sub BoolMethod { my($self, $x) = @_;
return $x;
}
sub IntMethod { my($self, $x) = @_;
return $x;
}
sub UIntMethod { my($self, $x) = @_;
return $x;
}
sub FloatMethod { my($self, $x) = @_;
return $x;
}
sub CharPtrMethod { my($self, $x) = @_;
return $x;
}
sub ConstCharPtrMethod { my($self, $x) = @_;
return $x;
}
sub EnumMethod { my($self, $x) = @_;
return $x;
}
sub ManyParmsMethod {
}
}
my $myCaller = director_primitives::Caller->new();
isa_ok $myCaller, 'director_primitives::Caller';
{
my $myBase = director_primitives::Base->new(100.0);
makeCalls($myCaller, $myBase);
}
{
my $myBase = director_primitives::Derived->new(200.0);
makeCalls($myCaller, $myBase);
}
{
my $myBase = PerlDerived->new(300.0);
makeCalls($myCaller, $myBase);
}
sub makeCalls { my($myCaller, $myBase) = @_;
$myCaller->set($myBase);
$myCaller->NoParmsMethodCall();
is $myCaller->BoolMethodCall(1), '1';
is $myCaller->BoolMethodCall(0), '';
is $myCaller->IntMethodCall(-123), -123;
is $myCaller->UIntMethodCall(123), 123;
is $myCaller->FloatMethodCall(-123 / 128), -0.9609375;
is $myCaller->CharPtrMethodCall("test string"), "test string";
is $myCaller->ConstCharPtrMethodCall("another string"), "another string";
is $myCaller->EnumMethodCall($director_primitives::HShadowHard), $director_primitives::HShadowHard;
$myCaller->ManyParmsMethodCall(1, -123, 123, 123.456, "test string", "another string", $director_primitives::HShadowHard);
$myCaller->NotOverriddenMethodCall();
$myCaller->reset();
}

48
Examples/test-suite/perl5/director_protected_runme.pl Normal file
View file

@ -0,0 +1,48 @@
use strict;
use warnings;
use Test::More tests => 19;
BEGIN { use_ok 'director_protected' }
require_ok 'director_protected';
{
package FooBar;
use base 'director_protected::Bar';
sub ping { 'FooBar::ping();' }
}
{
package FooBar2;
use base 'director_protected::Bar';
sub ping { 'FooBar2::ping();' }
sub pang { 'FooBar2::pang();' }
}
my $b = director_protected::Bar->new();
isa_ok $b, 'director_protected::Bar';
my $f = $b->create();
my $fb = FooBar->new();
isa_ok $fb, 'FooBar';
my $fb2 = FooBar2->new();
isa_ok $fb2, 'FooBar2';
is $b->used(), "Foo::pang();Bar::pong();Foo::pong();Bar::ping();";
eval { $f->used() };
like $@, qr/protected member/;
is $fb->used(), "Foo::pang();Bar::pong();Foo::pong();FooBar::ping();";
is $fb2->used(), "FooBar2::pang();Bar::pong();Foo::pong();FooBar2::ping();";
is $b->pong(), "Bar::pong();Foo::pong();Bar::ping();";
is $f->pong(), "Bar::pong();Foo::pong();Bar::ping();";
is $fb->pong(), "Bar::pong();Foo::pong();FooBar::ping();";
is $fb2->pong(), "Bar::pong();Foo::pong();FooBar2::ping();";
eval { $b->ping() };
like $@, qr/protected member/;
eval { $f->ping () };
like $@, qr/protected member/;
is $fb->ping(), 'FooBar::ping();';
is $fb2->ping(), 'FooBar2::ping();';
eval { $b->pang() };
like $@, qr/protected member/;
eval { $f->pang() };
like $@, qr/protected member/;

34
Examples/test-suite/perl5/director_string_runme.pl Normal file
View file

@ -0,0 +1,34 @@
use strict;
use warnings;
use Test::More tests => 5;
BEGIN { use_ok 'director_string' }
require_ok 'director_string';
{
package B;
use base 'director_string::A';
our $in_first = 0;
sub get_first { my($self) = @_;
die "SUPER RESOLVE BAD" if $in_first;
local $in_first = 1;
return $self->SUPER::get_first() . " world!";
}
our $in_process_text = 0;
sub process_text { my($self, $string) = @_;
die "SUPER RESOLVE BAD" if $in_process_text;
local $in_process_text = 1;
$self->SUPER::process_text($string);
$self->{'smem'} = "hello";
}
}
my $b = B->new("hello");
isa_ok $b, 'B';
$b->get(0);
is $b->get_first(), "hello world!";
$b->call_process_func();
is $b->{'smem'}, "hello";

17
Examples/test-suite/perl5/director_unroll_runme.pl Normal file
View file

@ -0,0 +1,17 @@
use strict;
use warnings;
use Test::More tests => 3;
BEGIN { use_ok 'director_unroll' };
require_ok 'director_unroll';
{
package MyFoo;
use base 'director_unroll::Foo';
sub ping { "MyFoo::ping()" }
}
$a = MyFoo->new();
$b = director_unroll::Bar->new();
$b->set($a);
my $c = $b->get();
is(${$a->this}, ${$c->this}, "unrolling");

53
Examples/test-suite/perl5/director_wombat_runme.pl Normal file
View file

@ -0,0 +1,53 @@
use strict;
use warnings;
use Test::More tests => 9;
BEGIN { use_ok 'director_wombat' }
require_ok 'director_wombat';
{
package director_wombat_Foo_integers_derived;
use base 'director_wombat::Foo_integers';
sub meth { my($self, $param) = @_;
return $param + 2;
}
}
{
package director_wombat_Foo_integers_derived_2;
use base 'director_wombat::Foo_integers';
}
{
package director_wombat_Bar_derived_1;
use base 'director_wombat::Bar';
sub foo_meth_ref { my($self, $foo_obj, $param) = @_;
die "foo_obj in foo_meth_ref is not director_wombat_Foo_integers_derived_2"
unless $foo_obj->isa('director_wombat_Foo_integers_derived_2');
}
sub foo_meth_ptr { my($self, $foo_obj, $param) = @_;
die "foo_obj in foo_meth_ptr is not director_wombat_Foo_integers_derived_2"
unless $foo_obj->isa('director_wombat_Foo_integers_derived_2');
}
sub foo_meth_val { my($self, $foo_obj, $param) = @_;
die "foo_obj in foo_meth_val is not director_wombat_Foo_integers_derived_2"
unless $foo_obj->isa('director_wombat_Foo_integers_derived_2');
}
}
my $b = director_wombat::Bar->new();
isa_ok $b, 'director_wombat::Bar';
my $a = $b->meth();
is $a->meth(49), 49;
$a = director_wombat_Foo_integers_derived->new();
isa_ok $a, 'director_wombat_Foo_integers_derived';
is $a->meth(62), 62 + 2;
$a = director_wombat_Foo_integers_derived_2->new();
isa_ok $a, 'director_wombat_Foo_integers_derived_2';
is $a->meth(37), 37;
$b = director_wombat_Bar_derived_1->new();
isa_ok $b, 'director_wombat_Bar_derived_1';
$b->foo_meth_ref($a, 0);
$b->foo_meth_ptr($a, 1);
$b->foo_meth_val($a, 2);

3
Lib/perl5/perlrun.swg
View file

@ -20,6 +20,7 @@
#define SWIG_ConvertPtr(obj, pp, type, flags) SWIG_Perl_ConvertPtr(SWIG_PERL_OBJECT_CALL obj, pp, type, flags)
#define SWIG_ConvertPtrAndOwn(obj, pp, type, flags,own) SWIG_Perl_ConvertPtrAndOwn(SWIG_PERL_OBJECT_CALL obj, pp, type, flags, own)
#define SWIG_NewPointerObj(p, type, flags) SWIG_Perl_NewPointerObj(SWIG_PERL_OBJECT_CALL p, type, flags)
#define swig_owntype int
/* for raw packed data */
#define SWIG_ConvertPacked(obj, p, s, type) SWIG_Perl_ConvertPacked(SWIG_PERL_OBJECT_CALL obj, p, s, type)
@ -288,7 +289,7 @@ SWIG_Perl_ConvertPtrAndOwn(SWIG_MAYBE_PERL_OBJECT SV *sv, void **ptr, swig_type_
/* Now see if the types match */
char *_c = HvNAME(SvSTASH(SvRV(sv)));
tc = SWIG_TypeProxyCheck(_c,_t);
if (!tc) {
if (!tc && !sv_derived_from(sv,SWIG_Perl_TypeProxyName(_t))) {
return SWIG_ERROR;
}
{

6
Lib/perl5/perltypemaps.swg
View file

@ -35,9 +35,9 @@
* Unified typemap section
* ------------------------------------------------------------ */
/* No director supported in Perl */
#ifdef SWIG_DIRECTOR_TYPEMAPS
#undef SWIG_DIRECTOR_TYPEMAPS
/* director support in Perl is experimental */
#ifndef SWIG_DIRECTOR_TYPEMAPS
#define SWIG_DIRECTOR_TYPEMAPS
#endif

812
Source/Modules/perl5.cxx
View file

@ -79,8 +79,11 @@ static String *variable_tab = 0;
static File *f_begin = 0;
static File *f_runtime = 0;
static File *f_runtime_h = 0;
static File *f_header = 0;
static File *f_wrappers = 0;
static File *f_directors = 0;
static File *f_directors_h = 0;
static File *f_init = 0;
static File *f_pm = 0;
static String *pm; /* Package initialization code */
@ -124,6 +127,7 @@ public:
Printv(argc_template_string, "items", NIL);
Clear(argv_template_string);
Printv(argv_template_string, "ST(%d)", NIL);
director_language = 1;
}
/* Test to see if a type corresponds to something wrapped with a shadow class */
@ -219,9 +223,68 @@ public:
* ------------------------------------------------------------ */
virtual int top(Node *n) {
/* check if directors are enabled for this module. note: this
* is a "master" switch, without which no director code will be
* emitted. %feature("director") statements are also required
* to enable directors for individual classes or methods.
*
* use %module(directors="1") modulename at the start of the
* interface file to enable director generation.
*
* TODO: directors are disallowed in conjunction with many command
* line options. Some of them are probably safe, but it will take
* some effort to validate each one.
*/
{
Node *mod = Getattr(n, "module");
if (mod) {
Node *options = Getattr(mod, "options");
if (options) {
int dirprot = 0;
if (Getattr(options, "dirprot"))
dirprot = 1;
if (Getattr(options, "nodirprot"))
dirprot = 0;
if (Getattr(options, "directors")) {
int allow = 1;
if (export_all) {
Printv(stderr,
"*** directors are not supported with -exportall\n", NIL);
allow = 0;
}
if (staticoption) {
Printv(stderr,
"*** directors are not supported with -static\n", NIL);
allow = 0;
}
if (!blessed) {
Printv(stderr,
"*** directors are not supported with -noproxy\n", NIL);
allow = 0;
}
if (no_pmfile) {
Printv(stderr,
"*** directors are not supported with -nopm\n", NIL);
allow = 0;
}
if (compat) {
Printv(stderr,
"*** directors are not supported with -compat\n", NIL);
allow = 0;
}
if (allow) {
allow_directors();
if (dirprot)
allow_dirprot();
}
}
}
}
}
/* Initialize all of the output files */
String *outfile = Getattr(n, "outfile");
String *outfile_h = Getattr(n, "outfile_h");
f_begin = NewFile(outfile, "w", SWIG_output_files());
if (!f_begin) {
@ -232,6 +295,16 @@ public:
f_init = NewString("");
f_header = NewString("");
f_wrappers = NewString("");
f_directors_h = NewString("");
f_directors = NewString("");
if (directorsEnabled()) {
f_runtime_h = NewFile(outfile_h, "w", SWIG_output_files());
if (!f_runtime_h) {
FileErrorDisplay(outfile_h);
SWIG_exit(EXIT_FAILURE);
}
}
/* Register file targets with the SWIG file handler */
Swig_register_filebyname("header", f_header);
@ -239,6 +312,8 @@ public:
Swig_register_filebyname("begin", f_begin);
Swig_register_filebyname("runtime", f_runtime);
Swig_register_filebyname("init", f_init);
Swig_register_filebyname("director", f_directors);
Swig_register_filebyname("director_h", f_directors_h);
classlist = NewList();
@ -259,6 +334,9 @@ public:
Printf(f_runtime, "\n");
Printf(f_runtime, "#define SWIGPERL\n");
if (directorsEnabled()) {
Printf(f_runtime, "#define SWIG_DIRECTORS\n");
}
Printf(f_runtime, "#define SWIG_CASTRANK_MODE\n");
Printf(f_runtime, "\n");
@ -269,6 +347,27 @@ public:
Node *options = Getattr(mod, "options");
module = Copy(Getattr(n,"name"));
if (directorsEnabled()) {
Swig_banner(f_directors_h);
Printf(f_directors_h, "\n");
Printf(f_directors_h, "#ifndef SWIG_%s_WRAP_H_\n", module);
Printf(f_directors_h, "#define SWIG_%s_WRAP_H_\n\n", module);
if (dirprot_mode()) {
Printf(f_directors_h, "#include <map>\n");
Printf(f_directors_h, "#include <string>\n\n");
}
Printf(f_directors, "\n\n");
Printf(f_directors, "/* ---------------------------------------------------\n");
Printf(f_directors, " * C++ director class methods\n");
Printf(f_directors, " * --------------------------------------------------- */\n\n");
if (outfile_h) {
String *filename = Swig_file_filename(outfile_h);
Printf(magic, "#include \"%s\"\n\n", filename);
Delete(filename);
}
}
if (verbose > 0) {
fprintf(stdout, "top: using module: %s\n", Char(module));
}
@ -374,6 +473,11 @@ public:
/* emit wrappers */
Language::top(n);
if (directorsEnabled()) {
// Insert director runtime into the f_runtime file (make it occur before %header section)
Swig_insert_file("director.swg", f_runtime);
}
String *base = NewString("");
/* Dump out variable wrappers */
@ -526,11 +630,21 @@ public:
/* Close all of the files */
Dump(f_runtime, f_begin);
Dump(f_header, f_begin);
if (directorsEnabled()) {
Dump(f_directors_h, f_runtime_h);
Printf(f_runtime_h, "\n");
Printf(f_runtime_h, "#endif\n");
Dump(f_directors, f_begin);
}
Dump(f_wrappers, f_begin);
Wrapper_pretty_print(f_init, f_begin);
Delete(f_header);
Delete(f_wrappers);
Delete(f_init);
Delete(f_directors);
Delete(f_directors_h);
Delete(f_runtime);
Delete(f_begin);
return SWIG_OK;
@ -560,6 +674,7 @@ public:
SwigType *d = Getattr(n, "type");
ParmList *l = Getattr(n, "parms");
String *overname = 0;
int director_method = 0;
Parm *p;
int i;
@ -720,11 +835,36 @@ public:
Wrapper_add_localv(f, "_saved", "SV *", temp, NIL);
}
director_method = is_member_director(n) && !is_smart_pointer() && 0 != Cmp(nodeType(n), "destructor");
if (director_method) {
Wrapper_add_local(f, "director", "Swig::Director *director = 0");
Append(f->code, "director = SWIG_DIRECTOR_CAST(arg1);\n");
if (dirprot_mode() && !is_public(n)) {
Printf(f->code, "if (!director || !(director->swig_get_inner(\"%s\"))) {\n", name);
Printf(f->code, "SWIG_exception_fail(SWIG_RuntimeError, \"accessing protected member %s\");\n", name);
Append(f->code, "}\n");
}
Wrapper_add_local(f, "upcall", "bool upcall = false");
Printf(f->code, "upcall = director && SvSTASH(SvRV(ST(0))) == gv_stashpv(director->swig_get_class(), 0);\n");
}
/* Emit the function call */
if (director_method) {
Append(f->code, "try {\n");
}
/* Now write code to make the function call */
Swig_director_emit_dynamic_cast(n, f);
String *actioncode = emit_action(n);
if (director_method) {
Append(actioncode, "} catch (Swig::DirectorException& swig_err) {\n");
Append(actioncode, " sv_setsv(ERRSV, swig_err.getNative());\n");
Append(actioncode, " SWIG_fail;\n");
Append(actioncode, "}\n");
}
if ((tm = Swig_typemap_lookup_out("out", n, Swig_cresult_name(), f, actioncode))) {
SwigType *t = Getattr(n, "type");
Replaceall(tm, "$source", Swig_cresult_name());
@ -1335,17 +1475,67 @@ public:
/* Output methods for managing ownership */
String *director_disown;
if (Getattr(n, "perl5:directordisown")) {
director_disown = NewStringf("%s%s($self);\n",
tab4, Getattr(n, "perl5:directordisown"));
} else {
director_disown = NewString("");
}
Printv(pm,
"sub DISOWN {\n",
tab4, "my $self = shift;\n",
director_disown,
tab4, "my $ptr = tied(%$self);\n",
tab4, "delete $OWNER{$ptr};\n",
"}\n\n", "sub ACQUIRE {\n", tab4, "my $self = shift;\n", tab4, "my $ptr = tied(%$self);\n", tab4, "$OWNER{$ptr} = 1;\n", "}\n\n", NIL);
Delete(director_disown);
/* Only output the following methods if a class has member data */
Delete(operators);
operators = 0;
if (Swig_directorclass(n)) {
/* director classes need a way to recover subclass instance attributes */
Node *get_attr = NewHash();
String *mrename;
String *symname = Getattr(n, "sym:name");
mrename = Swig_name_disown(NSPACE_TODO, symname);
Replaceall(mrename, "disown", "swig_get_attr");
String *type = NewString(getClassType());
String *name = NewString("self");
SwigType_add_pointer(type);
Parm *p = NewParm(type, name, n);
Delete(name);
Delete(type);
type = NewString("SV");
SwigType_add_pointer(type);
String *action = NewString("");
Printv(action, "{\n", " Swig::Director *director = SWIG_DIRECTOR_CAST(arg1);\n", " result = sv_newmortal();\n" " if (director) sv_setsv(result, director->swig_get_self());\n", "}\n", NIL);
Setfile(get_attr, Getfile(n));
Setline(get_attr, Getline(n));
Setattr(get_attr, "wrap:action", action);
Setattr(get_attr, "name", mrename);
Setattr(get_attr, "sym:name", mrename);
Setattr(get_attr, "type", type);
Setattr(get_attr, "parms", p);
Delete(action);
Delete(type);
Delete(p);
member_func = 1;
functionWrapper(get_attr);
member_func = 0;
Delete(get_attr);
Printv(pm, "sub FETCH {\n", tab4, "my ($self,$field) = @_;\n", tab4, "my $member_func = \"swig_${field}_get\";\n", tab4,
"if (not $self->can(\"$member_func\")) {\n", tab4, tab4, "my $h = ", cmodule, "::", mrename, "($self);\n", tab4, tab4,
"return $h->{$field} if $h;\n", tab4, "}\n", tab4, "return $self->$member_func;\n", "}\n", "\n", "sub STORE {\n", tab4,
"my ($self,$field,$newval) = @_;\n", tab4, "my $member_func = \"swig_${field}_set\";\n", tab4,
"if (not $self->can(\"$member_func\")) {\n", tab4, tab4, "my $h = ", cmodule, "::", mrename, "($self);\n", tab4, tab4,
"return $h->{$field} = $newval if $h;\n", tab4, "}\n", tab4, "return $self->$member_func($newval);\n", "}\n", NIL);
Delete(mrename);
}
}
return SWIG_OK;
}
@ -1494,7 +1684,41 @@ public:
String *symname = Getattr(n, "sym:name");
member_func = 1;
Swig_save("perl5:constructorHandler", n, "parms", NIL);
if (Swig_directorclass(n)) {
Parm *parms = Getattr(n, "parms");
Parm *self;
String *name = NewString("self");
String *type = NewString("SV");
SwigType_add_pointer(type);
self = NewParm(type, name, n);
Delete(type);
Delete(name);
Setattr(self, "lname", "O");
if (parms)
set_nextSibling(self, parms);
Setattr(n, "parms", self);
Setattr(n, "wrap:self", "1");
Setattr(n, "hidden", "1");
Delete(self);
}
String *saved_nc = none_comparison;
none_comparison = NewStringf("strcmp(SvPV_nolen(ST(0)), \"%s::%s\") != 0", module, class_name);
String *saved_director_prot_ctor_code = director_prot_ctor_code;
director_prot_ctor_code = NewStringf(
"if ($comparison) { /* subclassed */\n"
" $director_new\n"
"} else {\n"
" SWIG_exception_fail(SWIG_RuntimeError, \"accessing abstract class or protected constructor\");\n"
"}\n");
Language::constructorHandler(n);
Delete(none_comparison);
none_comparison = saved_nc;
Delete(director_prot_ctor_code);
director_prot_ctor_code = saved_director_prot_ctor_code;
Swig_restore(n);
if ((blessed) && (!Getattr(n, "sym:nextSibling"))) {
if (Getattr(n, "feature:shadow")) {
@ -1512,8 +1736,9 @@ public:
Printv(pcode, "sub ", Swig_name_construct(NSPACE_TODO, symname), " {\n", NIL);
}
const char *pkg = getCurrentClass() && Swig_directorclass(getCurrentClass()) ? "$_[0]" : "shift";
Printv(pcode,
tab4, "my $pkg = shift;\n",
tab4, "my $pkg = ", pkg, ";\n",
tab4, "my $self = ", cmodule, "::", Swig_name_construct(NSPACE_TODO, symname), "(@_);\n", tab4, "bless $self, $pkg if defined($self);\n", "}\n\n", NIL);
have_constructor = 1;
@ -1752,6 +1977,591 @@ public:
String *defaultExternalRuntimeFilename() {
return NewString("swigperlrun.h");
}
virtual int classDirectorInit(Node *n) {
String *declaration = Swig_director_declaration(n);
Printf(f_directors_h, "\n");
Printf(f_directors_h, "%s\n", declaration);
Printf(f_directors_h, "public:\n");
Delete(declaration);
return Language::classDirectorInit(n);
}
virtual int classDirectorEnd(Node *n) {
if (dirprot_mode()) {
/*
This implementation uses a std::map<std::string,int>.
It should be possible to rewrite it using a more elegant way,
like copying the Java approach for the 'override' array.
But for now, this seems to be the least intrusive way.
*/
Printf(f_directors_h, "\n\n");
Printf(f_directors_h, "/* Internal Director utilities */\n");
Printf(f_directors_h, "public:\n");
Printf(f_directors_h, " bool swig_get_inner(const char* swig_protected_method_name) const {\n");
Printf(f_directors_h, " std::map<std::string, bool>::const_iterator iv = swig_inner.find(swig_protected_method_name);\n");
Printf(f_directors_h, " return (iv != swig_inner.end() ? iv->second : false);\n");
Printf(f_directors_h, " }\n\n");
Printf(f_directors_h, " void swig_set_inner(const char* swig_protected_method_name, bool val) const\n");
Printf(f_directors_h, " { swig_inner[swig_protected_method_name] = val;}\n\n");
Printf(f_directors_h, "private:\n");
Printf(f_directors_h, " mutable std::map<std::string, bool> swig_inner;\n");
}
Printf(f_directors_h, "};\n");
return Language::classDirectorEnd(n);
}
virtual int classDirectorConstructor(Node *n) {
Node *parent = Getattr(n, "parentNode");
String *sub = NewString("");
String *decl = Getattr(n, "decl");
String *supername = Swig_class_name(parent);
String *classname = NewString("");
Printf(classname, "SwigDirector_%s", supername);
/* insert self parameter */
Parm *p;
ParmList *superparms = Getattr(n, "parms");
ParmList *parms = CopyParmList(superparms);
String *type = NewString("SV");
SwigType_add_pointer(type);
p = NewParm(type, NewString("self"), n);
set_nextSibling(p, parms);
parms = p;
if (!Getattr(n, "defaultargs")) {
/* constructor */
{
Wrapper *w = NewWrapper();
String *call;
String *basetype = Getattr(parent, "classtype");
String *target = Swig_method_decl(0, decl, classname, parms, 0, 0);
call = Swig_csuperclass_call(0, basetype, superparms);
Printf(w->def, "%s::%s: %s, Swig::Director(self) { \n", classname, target, call);
Printf(w->def, " SWIG_DIRECTOR_RGTR((%s *)this, this); \n", basetype);
Append(w->def, "}\n");
Delete(target);
Wrapper_print(w, f_directors);
Delete(call);
DelWrapper(w);
}
/* constructor header */
{
String *target = Swig_method_decl(0, decl, classname, parms, 0, 1);
Printf(f_directors_h, " %s;\n", target);
Delete(target);
}
}
Delete(sub);
Delete(classname);
Delete(supername);
Delete(parms);
return Language::classDirectorConstructor(n);
}
virtual int classDirectorMethod(Node *n, Node *parent, String *super) {
int is_void = 0;
int is_pointer = 0;
String *decl = Getattr(n, "decl");
String *name = Getattr(n, "name");
String *classname = Getattr(parent, "sym:name");
String *c_classname = Getattr(parent, "name");
String *symname = Getattr(n, "sym:name");
String *declaration = NewString("");
ParmList *l = Getattr(n, "parms");
Wrapper *w = NewWrapper();
String *tm;
String *wrap_args = NewString("");
String *returntype = Getattr(n, "type");
String *value = Getattr(n, "value");
String *storage = Getattr(n, "storage");
bool pure_virtual = false;
int status = SWIG_OK;
int idx;
bool ignored_method = GetFlag(n, "feature:ignore") ? true : false;
int addfail = 0;
if (Cmp(storage, "virtual") == 0) {
if (Cmp(value, "0") == 0) {
pure_virtual = true;
}
}
/* determine if the method returns a pointer */
is_pointer = SwigType_ispointer_return(decl);
is_void = (!Cmp(returntype, "void") && !is_pointer);
/* virtual method definition */
String *target;
String *pclassname = NewStringf("SwigDirector_%s", classname);
String *qualified_name = NewStringf("%s::%s", pclassname, name);
SwigType *rtype = Getattr(n, "conversion_operator") ? 0 : Getattr(n, "classDirectorMethods:type");
target = Swig_method_decl(rtype, decl, qualified_name, l, 0, 0);
Printf(w->def, "%s", target);
Delete(qualified_name);
Delete(target);
/* header declaration */
target = Swig_method_decl(rtype, decl, name, l, 0, 1);
Printf(declaration, " virtual %s", target);
Delete(target);
// Get any exception classes in the throws typemap
ParmList *throw_parm_list = 0;
if ((throw_parm_list = Getattr(n, "throws")) || Getattr(n, "throw")) {
Parm *p;
int gencomma = 0;
Append(w->def, " throw(");
Append(declaration, " throw(");
if (throw_parm_list)
Swig_typemap_attach_parms("throws", throw_parm_list, 0);
for (p = throw_parm_list; p; p = nextSibling(p)) {
if (Getattr(p, "tmap:throws")) {
if (gencomma++) {
Append(w->def, ", ");
Append(declaration, ", ");
}
String *str = SwigType_str(Getattr(p, "type"), 0);
Append(w->def, str);
Append(declaration, str);
Delete(str);
}
}
Append(w->def, ")");
Append(declaration, ")");
}
Append(w->def, " {");
Append(declaration, ";\n");
/* declare method return value
* if the return value is a reference or const reference, a specialized typemap must
* handle it, including declaration of c_result ($result).
*/
if (!is_void) {
if (!(ignored_method && !pure_virtual)) {
String *cres = SwigType_lstr(returntype, "c_result");
Printf(w->code, "%s;\n", cres);
Delete(cres);
String *pres = NewStringf("SV *%s", Swig_cresult_name());
Wrapper_add_local(w, Swig_cresult_name(), pres);
Delete(pres);
}
}
//if (builtin) {
// Printv(w->code, "PyObject *self = NULL;\n", NIL);
// Printv(w->code, "(void)self;\n", NIL);
//}
if (ignored_method) {
if (!pure_virtual) {
if (!is_void)
Printf(w->code, "return ");
String *super_call = Swig_method_call(super, l);
Printf(w->code, "%s;\n", super_call);
Delete(super_call);
} else {
Printf(w->code, "Swig::DirectorPureVirtualException::raise(\"Attempted to invoke pure virtual method %s::%s\");\n", SwigType_namestr(c_classname),
SwigType_namestr(name));
}
} else {
/* attach typemaps to arguments (C/C++ -> Perl) */
String *arglist = NewString("");
String *parse_args = NewString("");
String *pstack = NewString("");
Swig_director_parms_fixup(l);
/* remove the wrapper 'w' since it was producing spurious temps */
Swig_typemap_attach_parms("in", l, 0);
Swig_typemap_attach_parms("directorin", l, 0);
Swig_typemap_attach_parms("directorargout", l, w);
Wrapper_add_local(w, "SP", "dSP");
{
String *ptype = Copy(getClassType());
SwigType_add_pointer(ptype);
String *mangle = SwigType_manglestr(ptype);
Wrapper_add_local(w, "self", "SV *self");
Printf(w->code, "self = SWIG_NewPointerObj(SWIG_as_voidptr(this), SWIGTYPE%s, SWIG_SHADOW);\n", mangle);
Printf(w->code, "sv_bless(self, gv_stashpv(swig_get_class(), 0));\n");
Delete(mangle);
Delete(ptype);
Append(pstack, "XPUSHs(self);\n");
}
Parm *p;
char source[256];
int outputs = 0;
if (!is_void)
outputs++;
/* build argument list and type conversion string */
idx = 0;
p = l;
int use_parse = 0;
while (p) {
if (checkAttribute(p, "tmap:in:numinputs", "0")) {
p = Getattr(p, "tmap:in:next");
continue;
}
/* old style? caused segfaults without the p!=0 check
in the for() condition, and seems dangerous in the
while loop as well.
while (Getattr(p, "tmap:ignore")) {
p = Getattr(p, "tmap:ignore:next");
}
*/
if (Getattr(p, "tmap:directorargout") != 0)
outputs++;
String *pname = Getattr(p, "name");
String *ptype = Getattr(p, "type");
Putc(',', arglist);
if ((tm = Getattr(p, "tmap:directorin")) != 0) {
String *parse = Getattr(p, "tmap:directorin:parse");
if (!parse) {
sprintf(source, "obj%d", idx++);
String *input = NewString(source);
Setattr(p, "emit:directorinput", input);
Replaceall(tm, "$input", input);
Delete(input);
Replaceall(tm, "$owner", "0");
Replaceall(tm, "$shadow", "0");
/* Wrapper_add_localv(w, source, "SV *", source, "= 0", NIL); */
Printv(wrap_args, "SV *", source, ";\n", NIL);
Printv(wrap_args, tm, "\n", NIL);
Printv(arglist, "(PyObject *)", source, NIL);
Putc('O', parse_args);
Printv(pstack, "XPUSHs(", source, ");\n", NIL);
} else {
use_parse = 1;
Append(parse_args, parse);
Setattr(p, "emit:directorinput", pname);
Replaceall(tm, "$input", pname);
Replaceall(tm, "$owner", "0");
Replaceall(tm, "$shadow", "0");
if (Len(tm) == 0)
Append(tm, pname);
Append(arglist, tm);
}
p = Getattr(p, "tmap:directorin:next");
continue;
} else if (Cmp(ptype, "void")) {
/* special handling for pointers to other C++ director classes.
* ideally this would be left to a typemap, but there is currently no
* way to selectively apply the dynamic_cast<> to classes that have
* directors. in other words, the type "SwigDirector_$1_lname" only exists
* for classes with directors. we avoid the problem here by checking
* module.wrap::directormap, but it's not clear how to get a typemap to
* do something similar. perhaps a new default typemap (in addition
* to SWIGTYPE) called DIRECTORTYPE?
*/
if (SwigType_ispointer(ptype) || SwigType_isreference(ptype)) {
Node *module = Getattr(parent, "module");
Node *target = Swig_directormap(module, ptype);
sprintf(source, "obj%d", idx++);
String *nonconst = 0;
/* strip pointer/reference --- should move to Swig/stype.c */
String *nptype = NewString(Char(ptype) + 2);
/* name as pointer */
String *ppname = Copy(pname);
if (SwigType_isreference(ptype)) {
Insert(ppname, 0, "&");
}
/* if necessary, cast away const since Python doesn't support it! */
if (SwigType_isconst(nptype)) {
nonconst = NewStringf("nc_tmp_%s", pname);
String *nonconst_i = NewStringf("= const_cast< %s >(%s)", SwigType_lstr(ptype, 0), ppname);
Wrapper_add_localv(w, nonconst, SwigType_lstr(ptype, 0), nonconst, nonconst_i, NIL);
Delete(nonconst_i);
Swig_warning(WARN_LANG_DISCARD_CONST, input_file, line_number,
"Target language argument '%s' discards const in director method %s::%s.\n",
SwigType_str(ptype, pname), SwigType_namestr(c_classname), SwigType_namestr(name));
} else {
nonconst = Copy(ppname);
}
Delete(nptype);
Delete(ppname);
String *mangle = SwigType_manglestr(ptype);
if (target) {
String *director = NewStringf("director_%s", mangle);
Wrapper_add_localv(w, director, "Swig::Director *", director, "= 0", NIL);
Wrapper_add_localv(w, source, "swig::SwigVar_PyObject", source, "= 0", NIL);
Printf(wrap_args, "%s = SWIG_DIRECTOR_CAST(%s);\n", director, nonconst);
Printf(wrap_args, "if (!%s) {\n", director);
Printf(wrap_args, "%s = SWIG_InternalNewPointerObj(%s, SWIGTYPE%s, 0);\n", source, nonconst, mangle);
Append(wrap_args, "} else {\n");
Printf(wrap_args, "%s = %s->swig_get_self();\n", source, director);
Printf(wrap_args, "Py_INCREF((PyObject *)%s);\n", source);
Append(wrap_args, "}\n");
Delete(director);
Printv(arglist, source, NIL);
} else {
Wrapper_add_localv(w, source, "SV *", source, "= 0", NIL);
Printf(wrap_args, "%s = SWIG_NewPointerObj(%s, SWIGTYPE%s, 0);\n", source, nonconst, mangle);
Printf(pstack, "XPUSHs(sv_2mortal(%s));\n", source);
//Printf(wrap_args, "%s = SWIG_NewPointerObj(%s, SWIGTYPE_p_%s, 0);\n",
// source, nonconst, base);
Printv(arglist, source, NIL);
}
Putc('O', parse_args);
Delete(mangle);
Delete(nonconst);
} else {
Swig_warning(WARN_TYPEMAP_DIRECTORIN_UNDEF, input_file, line_number,
"Unable to use type %s as a function argument in director method %s::%s (skipping method).\n", SwigType_str(ptype, 0),
SwigType_namestr(c_classname), SwigType_namestr(name));
status = SWIG_NOWRAP;
break;
}
}
p = nextSibling(p);
}
/* add the method name as a PyString */
String *pyname = Getattr(n, "sym:name");
//int allow_thread = threads_enable(n);
//
//if (allow_thread) {
// thread_begin_block(n, w->code);
// Append(w->code, "{\n");
//}
/* wrap complex arguments to PyObjects */
Printv(w->code, wrap_args, NIL);
/* pass the method call on to the Python object */
if (dirprot_mode() && !is_public(n)) {
Printf(w->code, "swig_set_inner(\"%s\", true);\n", name);
}
Append(w->code, "ENTER;\n");
Append(w->code, "SAVETMPS;\n");
Append(w->code, "PUSHMARK(SP);\n");
Append(w->code, pstack);
Delete(pstack);
Append(w->code, "PUTBACK;\n");
Printf(w->code, "call_method(\"%s\", G_EVAL | G_SCALAR);\n", pyname);
if (dirprot_mode() && !is_public(n))
Printf(w->code, "swig_set_inner(\"%s\", false);\n", name);
/* exception handling */
tm = Swig_typemap_lookup("director:except", n, Swig_cresult_name(), 0);
if (!tm) {
tm = Getattr(n, "feature:director:except");
if (tm)
tm = Copy(tm);
}
Append(w->code, "if (SvTRUE(ERRSV)) {\n");
Append(w->code, " PUTBACK;\n FREETMPS;\n LEAVE;\n");
if ((tm) && Len(tm) && (Strcmp(tm, "1") != 0)) {
Replaceall(tm, "$error", "error");
Printv(w->code, Str(tm), "\n", NIL);
} else {
Printf(w->code, " Swig::DirectorMethodException::raise(ERRSV);\n", classname, pyname);
}
Append(w->code, "}\n");
Delete(tm);
/*
* Python method may return a simple object, or a tuple.
* for in/out aruments, we have to extract the appropriate PyObjects from the tuple,
* then marshal everything back to C/C++ (return value and output arguments).
*
*/
/* marshal return value and other outputs (if any) from PyObject to C/C++ type */
String *cleanup = NewString("");
String *outarg = NewString("");
if (outputs > 1) {
Wrapper_add_local(w, "output", "PyObject *output");
Printf(w->code, "if (!PyTuple_Check(%s)) {\n", Swig_cresult_name());
Printf(w->code, " Swig::DirectorTypeMismatchException::raise(\"Python method %s.%sfailed to return a tuple.\");\n", classname, pyname);
Append(w->code, "}\n");
}
idx = 0;
/* marshal return value */
if (!is_void) {
Append(w->code, "SPAGAIN;\n");
Printf(w->code, "%s = POPs;\n", Swig_cresult_name());
tm = Swig_typemap_lookup("directorout", n, Swig_cresult_name(), w);
if (tm != 0) {
if (outputs > 1) {
Printf(w->code, "output = PyTuple_GetItem(%s, %d);\n", Swig_cresult_name(), idx++);
Replaceall(tm, "$input", "output");
} else {
Replaceall(tm, "$input", Swig_cresult_name());
}
char temp[24];
sprintf(temp, "%d", idx);
Replaceall(tm, "$argnum", temp);
/* TODO check this */
if (Getattr(n, "wrap:disown")) {
Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN");
} else {
Replaceall(tm, "$disown", "0");
}
//if (Getattr(n, "tmap:directorout:implicitconv")) {
// Replaceall(tm, "$implicitconv", get_implicitconv_flag(n));
//}
Replaceall(tm, "$result", "c_result");
Printv(w->code, tm, "\n", NIL);
Delete(tm);
} else {
Swig_print_node(n);
Swig_warning(WARN_TYPEMAP_DIRECTOROUT_UNDEF, input_file, line_number,
"Unable to use return type %s in director method %s::%s (skipping method).\n", SwigType_str(returntype, 0), SwigType_namestr(c_classname),
SwigType_namestr(name));
status = SWIG_ERROR;
}
}
/* marshal outputs */
for (p = l; p;) {
if ((tm = Getattr(p, "tmap:directorargout")) != 0) {
if (outputs > 1) {
Printf(w->code, "output = PyTuple_GetItem(%s, %d);\n", Swig_cresult_name(), idx++);
Replaceall(tm, "$result", "output");
} else {
Replaceall(tm, "$result", Swig_cresult_name());
}
Replaceall(tm, "$input", Getattr(p, "emit:directorinput"));
Printv(w->code, tm, "\n", NIL);
p = Getattr(p, "tmap:directorargout:next");
} else {
p = nextSibling(p);
}
}
/* any existing helper functions to handle this? */
//if (allow_thread) {
// Append(w->code, "}\n");
// thread_end_block(n, w->code);
//}
Delete(parse_args);
Delete(arglist);
Delete(cleanup);
Delete(outarg);
}
if (!ignored_method) {
Append(w->code, "PUTBACK;\n");
Append(w->code, "FREETMPS;\n");
Append(w->code, "LEAVE;\n");
}
if (!is_void) {
if (!(ignored_method && !pure_virtual)) {
String *rettype = SwigType_str(returntype, 0);
if (!SwigType_isreference(returntype)) {
Printf(w->code, "return (%s) c_result;\n", rettype);
} else {
Printf(w->code, "return (%s) *c_result;\n", rettype);
}
Delete(rettype);
}
}
if (addfail) {
Append(w->code, "fail:\n");
Printf(w->code, " Swig::DirectorMethodException::raise(\"Error detected when calling '%s->%s'\");\n", classname, Getattr(n, "sym:name"));
}
Append(w->code, "}\n");
// We expose protected methods via an extra public inline method which makes a straight call to the wrapped class' method
String *inline_extra_method = NewString("");
if (dirprot_mode() && !is_public(n) && !pure_virtual) {
Printv(inline_extra_method, declaration, NIL);
String *extra_method_name = NewStringf("%sSwigPublic", name);
Replaceall(inline_extra_method, name, extra_method_name);
Replaceall(inline_extra_method, ";\n", " {\n ");
if (!is_void)
Printf(inline_extra_method, "return ");
String *methodcall = Swig_method_call(super, l);
Printv(inline_extra_method, methodcall, ";\n }\n", NIL);
Delete(methodcall);
Delete(extra_method_name);
}
/* emit the director method */
if (status == SWIG_OK) {
if (!Getattr(n, "defaultargs")) {
Replaceall(w->code, "$symname", symname);
Wrapper_print(w, f_directors);
Printv(f_directors_h, declaration, NIL);
Printv(f_directors_h, inline_extra_method, NIL);
}
}
/* clean up */
Delete(wrap_args);
Delete(pclassname);
DelWrapper(w);
return status;
}
int classDirectorDisown(Node *n) {
int rv;
member_func = 1;
rv = Language::classDirectorDisown(n);
member_func = 0;
if(rv == SWIG_OK && Swig_directorclass(n)) {
String *symname = Getattr(n, "sym:name");
String *disown = Swig_name_disown(NSPACE_TODO, symname);
Setattr(n, "perl5:directordisown", NewStringf("%s::%s", cmodule, disown));
}
return rv;
}
int classDirectorDestructor(Node *n) {
/* TODO: it would be nice if this didn't have to copy the body of Language::classDirectorDestructor() */
String *DirectorClassName = directorClassName(getCurrentClass());
String *body = NewString("\n");
String *ptype = Copy(getClassType());
SwigType_add_pointer(ptype);
String *mangle = SwigType_manglestr(ptype);
Printv(body, tab4, "dSP;\n", tab4, "SV *self = SWIG_NewPointerObj(SWIG_as_voidptr(this), SWIGTYPE", mangle, ", SWIG_SHADOW);\n", tab4, "\n", tab4,
"sv_bless(self, gv_stashpv(swig_get_class(), 0));\n", tab4, "ENTER;\n", tab4, "SAVETMPS;\n", tab4, "PUSHMARK(SP);\n", tab4, "XPUSHs(self);\n",
tab4, "PUTBACK;\n", tab4, "call_method(\"DIRECTOR_DESTROY\", G_EVAL | G_VOID);\n", tab4, "FREETMPS;\n", tab4, "LEAVE;\n", NIL);
Delete(mangle);
Delete(ptype);
if (Getattr(n, "throw")) {
Printf(f_directors_h, " virtual ~%s() throw ();\n", DirectorClassName);
Printf(f_directors, "%s::~%s() throw () {%s}\n\n", DirectorClassName, DirectorClassName, body);
} else {
Printf(f_directors_h, " virtual ~%s();\n", DirectorClassName);
Printf(f_directors, "%s::~%s() {%s}\n\n", DirectorClassName, DirectorClassName, body);
}
return SWIG_OK;
}
};
/* -----------------------------------------------------------------------------