From 0901a3e867a733cbede8b034f92c964025c38c8a Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Tue, 12 Nov 2013 12:45:03 -0800 Subject: [PATCH 01/10] steals python directors and adapts to perl5 --- .../perl5/director_abstract_runme.pl | 62 ++ .../perl5/director_alternating_runme.pl | 8 + .../test-suite/perl5/director_basic_runme.pl | 57 ++ .../perl5/director_classes_runme.pl | 70 ++ .../perl5/director_classic_runme.pl | 128 +++ .../perl5/director_constructor_runme.pl | 46 + .../perl5/director_default_runme.pl | 18 + .../test-suite/perl5/director_detect_runme.pl | 45 + .../test-suite/perl5/director_enum_runme.pl | 21 + .../perl5/director_exception_runme.pl | 57 ++ .../test-suite/perl5/director_extend_runme.pl | 16 + .../perl5/director_finalizer_runme.pl | 83 ++ .../test-suite/perl5/director_frob_runme.pl | 10 + .../test-suite/perl5/director_ignore_runme.pl | 25 + .../test-suite/perl5/director_nested_runme.pl | 59 ++ .../perl5/director_primitives_runme.pl | 68 ++ .../perl5/director_protected_runme.pl | 48 ++ .../test-suite/perl5/director_string_runme.pl | 34 + .../test-suite/perl5/director_unroll_runme.pl | 17 + .../test-suite/perl5/director_wombat_runme.pl | 53 ++ Lib/perl5/perlrun.swg | 3 +- Lib/perl5/perltypemaps.swg | 6 +- Source/Modules/perl5.cxx | 812 +++++++++++++++++- 23 files changed, 1741 insertions(+), 5 deletions(-) create mode 100644 Examples/test-suite/perl5/director_abstract_runme.pl create mode 100644 Examples/test-suite/perl5/director_alternating_runme.pl create mode 100644 Examples/test-suite/perl5/director_basic_runme.pl create mode 100644 Examples/test-suite/perl5/director_classes_runme.pl create mode 100644 Examples/test-suite/perl5/director_classic_runme.pl create mode 100644 Examples/test-suite/perl5/director_constructor_runme.pl create mode 100644 Examples/test-suite/perl5/director_default_runme.pl create mode 100644 Examples/test-suite/perl5/director_detect_runme.pl create mode 100644 Examples/test-suite/perl5/director_enum_runme.pl create mode 100644 Examples/test-suite/perl5/director_exception_runme.pl create mode 100644 Examples/test-suite/perl5/director_extend_runme.pl create mode 100644 Examples/test-suite/perl5/director_finalizer_runme.pl create mode 100644 Examples/test-suite/perl5/director_frob_runme.pl create mode 100644 Examples/test-suite/perl5/director_ignore_runme.pl create mode 100644 Examples/test-suite/perl5/director_nested_runme.pl create mode 100644 Examples/test-suite/perl5/director_primitives_runme.pl create mode 100644 Examples/test-suite/perl5/director_protected_runme.pl create mode 100644 Examples/test-suite/perl5/director_string_runme.pl create mode 100644 Examples/test-suite/perl5/director_unroll_runme.pl create mode 100644 Examples/test-suite/perl5/director_wombat_runme.pl diff --git a/Examples/test-suite/perl5/director_abstract_runme.pl b/Examples/test-suite/perl5/director_abstract_runme.pl new file mode 100644 index 000000000..d369eac17 --- /dev/null +++ b/Examples/test-suite/perl5/director_abstract_runme.pl @@ -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()'); diff --git a/Examples/test-suite/perl5/director_alternating_runme.pl b/Examples/test-suite/perl5/director_alternating_runme.pl new file mode 100644 index 000000000..83d30af6d --- /dev/null +++ b/Examples/test-suite/perl5/director_alternating_runme.pl @@ -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"); diff --git a/Examples/test-suite/perl5/director_basic_runme.pl b/Examples/test-suite/perl5/director_basic_runme.pl new file mode 100644 index 000000000..55e70dc9c --- /dev/null +++ b/Examples/test-suite/perl5/director_basic_runme.pl @@ -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; +} diff --git a/Examples/test-suite/perl5/director_classes_runme.pl b/Examples/test-suite/perl5/director_classes_runme.pl new file mode 100644 index 000000000..a4fddeed9 --- /dev/null +++ b/Examples/test-suite/perl5/director_classes_runme.pl @@ -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(); +} diff --git a/Examples/test-suite/perl5/director_classic_runme.pl b/Examples/test-suite/perl5/director_classic_runme.pl new file mode 100644 index 000000000..2fa4fde56 --- /dev/null +++ b/Examples/test-suite/perl5/director_classic_runme.pl @@ -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; + diff --git a/Examples/test-suite/perl5/director_constructor_runme.pl b/Examples/test-suite/perl5/director_constructor_runme.pl new file mode 100644 index 000000000..c990fc3a1 --- /dev/null +++ b/Examples/test-suite/perl5/director_constructor_runme.pl @@ -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/; diff --git a/Examples/test-suite/perl5/director_default_runme.pl b/Examples/test-suite/perl5/director_default_runme.pl new file mode 100644 index 000000000..281c8ebd3 --- /dev/null +++ b/Examples/test-suite/perl5/director_default_runme.pl @@ -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'; diff --git a/Examples/test-suite/perl5/director_detect_runme.pl b/Examples/test-suite/perl5/director_detect_runme.pl new file mode 100644 index 000000000..3e2c652cb --- /dev/null +++ b/Examples/test-suite/perl5/director_detect_runme.pl @@ -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; diff --git a/Examples/test-suite/perl5/director_enum_runme.pl b/Examples/test-suite/perl5/director_enum_runme.pl new file mode 100644 index 000000000..6d58b376e --- /dev/null +++ b/Examples/test-suite/perl5/director_enum_runme.pl @@ -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); diff --git a/Examples/test-suite/perl5/director_exception_runme.pl b/Examples/test-suite/perl5/director_exception_runme.pl new file mode 100644 index 000000000..62c103b6c --- /dev/null +++ b/Examples/test-suite/perl5/director_exception_runme.pl @@ -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'); diff --git a/Examples/test-suite/perl5/director_extend_runme.pl b/Examples/test-suite/perl5/director_extend_runme.pl new file mode 100644 index 000000000..c3d7fb934 --- /dev/null +++ b/Examples/test-suite/perl5/director_extend_runme.pl @@ -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'); diff --git a/Examples/test-suite/perl5/director_finalizer_runme.pl b/Examples/test-suite/perl5/director_finalizer_runme.pl new file mode 100644 index 000000000..bb6e1fa71 --- /dev/null +++ b/Examples/test-suite/perl5/director_finalizer_runme.pl @@ -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'); +} diff --git a/Examples/test-suite/perl5/director_frob_runme.pl b/Examples/test-suite/perl5/director_frob_runme.pl new file mode 100644 index 000000000..0faf440c5 --- /dev/null +++ b/Examples/test-suite/perl5/director_frob_runme.pl @@ -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()'); diff --git a/Examples/test-suite/perl5/director_ignore_runme.pl b/Examples/test-suite/perl5/director_ignore_runme.pl new file mode 100644 index 000000000..9566f4bb3 --- /dev/null +++ b/Examples/test-suite/perl5/director_ignore_runme.pl @@ -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; diff --git a/Examples/test-suite/perl5/director_nested_runme.pl b/Examples/test-suite/perl5/director_nested_runme.pl new file mode 100644 index 000000000..e6c19665a --- /dev/null +++ b/Examples/test-suite/perl5/director_nested_runme.pl @@ -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"; diff --git a/Examples/test-suite/perl5/director_primitives_runme.pl b/Examples/test-suite/perl5/director_primitives_runme.pl new file mode 100644 index 000000000..e70f39166 --- /dev/null +++ b/Examples/test-suite/perl5/director_primitives_runme.pl @@ -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(); +} + diff --git a/Examples/test-suite/perl5/director_protected_runme.pl b/Examples/test-suite/perl5/director_protected_runme.pl new file mode 100644 index 000000000..07ed1563e --- /dev/null +++ b/Examples/test-suite/perl5/director_protected_runme.pl @@ -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/; diff --git a/Examples/test-suite/perl5/director_string_runme.pl b/Examples/test-suite/perl5/director_string_runme.pl new file mode 100644 index 000000000..4d996ef0f --- /dev/null +++ b/Examples/test-suite/perl5/director_string_runme.pl @@ -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"; diff --git a/Examples/test-suite/perl5/director_unroll_runme.pl b/Examples/test-suite/perl5/director_unroll_runme.pl new file mode 100644 index 000000000..572b99834 --- /dev/null +++ b/Examples/test-suite/perl5/director_unroll_runme.pl @@ -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"); diff --git a/Examples/test-suite/perl5/director_wombat_runme.pl b/Examples/test-suite/perl5/director_wombat_runme.pl new file mode 100644 index 000000000..81f34e71b --- /dev/null +++ b/Examples/test-suite/perl5/director_wombat_runme.pl @@ -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); + diff --git a/Lib/perl5/perlrun.swg b/Lib/perl5/perlrun.swg index ebc4fecd5..4e31c4754 100644 --- a/Lib/perl5/perlrun.swg +++ b/Lib/perl5/perlrun.swg @@ -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; } { diff --git a/Lib/perl5/perltypemaps.swg b/Lib/perl5/perltypemaps.swg index fc7100e89..f47a5ef82 100644 --- a/Lib/perl5/perltypemaps.swg +++ b/Lib/perl5/perltypemaps.swg @@ -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 diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx index 09500b23b..182835645 100644 --- a/Source/Modules/perl5.cxx +++ b/Source/Modules/perl5.cxx @@ -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 \n"); + Printf(f_directors_h, "#include \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. + + 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::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 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; + } }; /* ----------------------------------------------------------------------------- From 34c374d7ae201a2a9902f721e4e31a2ad785b557 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Tue, 12 Nov 2013 12:48:21 -0800 Subject: [PATCH 02/10] don't forget the most important part --- Lib/perl5/director.swg | 479 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 479 insertions(+) create mode 100644 Lib/perl5/director.swg diff --git a/Lib/perl5/director.swg b/Lib/perl5/director.swg new file mode 100644 index 000000000..937b727a4 --- /dev/null +++ b/Lib/perl5/director.swg @@ -0,0 +1,479 @@ +/* ----------------------------------------------------------------------------- + * director.swg + * + * This file contains support for director classes that proxy + * method calls from C++ to Python extensions. + * ----------------------------------------------------------------------------- */ + +#ifndef SWIG_DIRECTOR_PERL_HEADER_ +#define SWIG_DIRECTOR_PERL_HEADER_ + +#ifdef __cplusplus + +#include +#include +#include +#include +#include + + +/* + Use -DSWIG_PYTHON_DIRECTOR_NO_VTABLE if you don't want to generate a 'virtual + table', and avoid multiple GetAttr calls to retrieve the python + methods. +*/ + +#ifndef SWIG_PERL_DIRECTOR_NO_VTABLE +#ifndef SWIG_PERL_DIRECTOR_VTABLE +#define SWIG_PERL_DIRECTOR_VTABLE +#endif +#endif + + + +/* + Use -DSWIG_DIRECTOR_NO_UEH if you prefer to avoid the use of the + Undefined Exception Handler provided by swig. +*/ +#ifndef SWIG_DIRECTOR_NO_UEH +#ifndef SWIG_DIRECTOR_UEH +#define SWIG_DIRECTOR_UEH +#endif +#endif + + +/* + Use -DSWIG_DIRECTOR_STATIC if you prefer to avoid the use of the + 'Swig' namespace. This could be useful for multi-modules projects. +*/ +#ifdef SWIG_DIRECTOR_STATIC +/* Force anonymous (static) namespace */ +#define Swig +#endif + + +/* + Use -DSWIG_DIRECTOR_NORTTI if you prefer to avoid the use of the + native C++ RTTI and dynamic_cast<>. But be aware that directors + could stop working when using this option. +*/ +#ifdef SWIG_DIRECTOR_NORTTI +/* + When we don't use the native C++ RTTI, we implement a minimal one + only for Directors. +*/ +# ifndef SWIG_DIRECTOR_RTDIR +# define SWIG_DIRECTOR_RTDIR +#include + +namespace Swig { + class Director; + SWIGINTERN std::map& get_rtdir_map() { + static std::map rtdir_map; + return rtdir_map; + } + + SWIGINTERNINLINE void set_rtdir(void *vptr, Director *rtdir) { + get_rtdir_map()[vptr] = rtdir; + } + + SWIGINTERNINLINE Director *get_rtdir(void *vptr) { + std::map::const_iterator pos = get_rtdir_map().find(vptr); + Director *rtdir = (pos != get_rtdir_map().end()) ? pos->second : 0; + return rtdir; + } +} +# endif /* SWIG_DIRECTOR_RTDIR */ + +# define SWIG_DIRECTOR_CAST(ARG) Swig::get_rtdir(static_cast(ARG)) +# define SWIG_DIRECTOR_RGTR(ARG1, ARG2) Swig::set_rtdir(static_cast(ARG1), ARG2) + +#else + +# define SWIG_DIRECTOR_CAST(ARG) dynamic_cast(ARG) +# define SWIG_DIRECTOR_RGTR(ARG1, ARG2) + +#endif /* SWIG_DIRECTOR_NORTTI */ + +extern "C" { + struct swig_type_info; +} + +namespace Swig { + + /* memory handler */ + struct GCItem + { + virtual ~GCItem() {} + + virtual int get_own() const + { + return 0; + } + }; + + struct GCItem_var + { + GCItem_var(GCItem *item = 0) : _item(item) + { + } + + GCItem_var& operator=(GCItem *item) + { + GCItem *tmp = _item; + _item = item; + delete tmp; + return *this; + } + + ~GCItem_var() + { + delete _item; + } + + GCItem * operator->() const + { + return _item; + } + + private: + GCItem *_item; + }; + + struct GCItem_Object : GCItem + { + GCItem_Object(int own) : _own(own) + { + } + + virtual ~GCItem_Object() + { + } + + int get_own() const + { + return _own; + } + + private: + int _own; + }; + + template + struct GCItem_T : GCItem + { + GCItem_T(Type *ptr) : _ptr(ptr) + { + } + + virtual ~GCItem_T() + { + delete _ptr; + } + + private: + Type *_ptr; + }; + + template + struct GCArray_T : GCItem + { + GCArray_T(Type *ptr) : _ptr(ptr) + { + } + + virtual ~GCArray_T() + { + delete[] _ptr; + } + + private: + Type *_ptr; + }; + + /* base class for director exceptions */ + class DirectorException { + public: + virtual const char *getMessage() const = 0; + virtual SV *getNative() const = 0; + }; + /* exceptions emitted by Perl */ + class DirectorMethodException : public Swig::DirectorException { + protected: + SV *err; + public: + DirectorMethodException(SV *sv) + : err(sv) + { + SvREFCNT_inc(err); + } + ~DirectorMethodException() + { + SvREFCNT_dec(err); + } + const char *getMessage() const + { + return SvPV_nolen(err); + } + SV *getNative() const + { + return sv_2mortal(newSVsv(err)); + } + static void raise(SV *sv) + { + throw DirectorMethodException(sv); + } + }; + /* exceptions emitted by wrap code */ + class DirectorWrapException : public Swig::DirectorException { + protected: + std::string msg; + DirectorWrapException(const char *str) + : msg(str) + { + } + public: + virtual const char *getMessage() const + { + return msg.c_str(); + } + virtual SV *getNative() const { + return sv_2mortal(newSVpvn(msg.data(), msg.size())); + } + }; + class DirectorTypeMismatchException : public Swig::DirectorWrapException { + public: + DirectorTypeMismatchException(const char *str) + : DirectorWrapException(str) + { + } + static void raise(const char *type, const char *msg) + { + std::string err = std::string(type); + err += ": "; + err += msg; + throw DirectorTypeMismatchException(err.c_str()); + } + }; + class DirectorPureVirtualException : public Swig::DirectorWrapException { + public: + DirectorPureVirtualException(const char *name) + : DirectorWrapException("SWIG director pure virtual method called: ") + { + msg += name; + } + static void raise(const char *name) + { + throw DirectorPureVirtualException(name); + } + }; +// /* unknown exception handler */ +// class UnknownExceptionHandler +// { +//#ifdef SWIG_DIRECTOR_UEH +// static void handler() { +// try { +// throw; +// } catch (DirectorException& e) { +// std::cerr << "SWIG Director exception caught:" << std::endl +// << e.getMessage() << std::endl; +// } catch (std::exception& e) { +// std::cerr << "std::exception caught: "<< e.what() << std::endl; +// } catch (...) { +// std::cerr << "Unknown exception caught." << std::endl; +// } +// +// //std::cerr << std::endl +// // << "Python interpreter traceback:" << std::endl; +// //PyErr_Print(); +// //std::cerr << std::endl; +// +// std::cerr << "This exception was caught by the SWIG unexpected exception handler." << std::endl +// << "Try using %feature(\"director:except\") to avoid reaching this point." << std::endl +// << std::endl +// << "Exception is being re-thrown, program will likely abort/terminate." << std::endl; +// throw; +// } +// +// public: +// +// std::unexpected_handler old; +// UnknownExceptionHandler(std::unexpected_handler nh = handler) +// { +// old = std::set_unexpected(nh); +// } +// +// ~UnknownExceptionHandler() +// { +// std::set_unexpected(old); +// } +//#endif +// }; + +#if defined(SWIG_PYTHON_THREADS) +/* __THREAD__ is the old macro to activate some thread support */ +# if !defined(__THREAD__) +# define __THREAD__ 1 +# endif +#endif + +#ifdef __THREAD__ +# include "pythread.h" + class Guard + { + PyThread_type_lock & mutex_; + + public: + Guard(PyThread_type_lock & mutex) : mutex_(mutex) + { + PyThread_acquire_lock(mutex_, WAIT_LOCK); + } + + ~Guard() + { + PyThread_release_lock(mutex_); + } + }; +# define SWIG_GUARD(mutex) Guard _guard(mutex) +#else +# define SWIG_GUARD(mutex) +#endif + + /* director base class */ + class Director { + private: + /* pointer to the wrapped perl object */ + SV *swig_self; + /* class of wrapped perl object */ + std::string swig_class; + /* flag indicating whether the object is owned by perl or c++ */ + mutable bool swig_disown_flag; + + /* decrement the reference count of the wrapped perl object */ + void swig_decref() const { + if (swig_disown_flag) { + SvREFCNT_dec(swig_self); + } + } + + public: + /* wrap a python object, optionally taking ownership */ + Director(SV *pkg) : swig_disown_flag(false) { + STRLEN len; + char *str = SvPV(pkg, len); + swig_class = std::string(str, len); + swig_self = newRV_inc((SV *)newHV()); + swig_incref(); + } + + + /* discard our reference at destruction */ + virtual ~Director() { + swig_decref(); + } + + + /* return a pointer to the wrapped python object */ + SV *swig_get_self() const { + return swig_self; + } + + const char *swig_get_class() const { + return swig_class.c_str(); + } + + /* acquire ownership of the wrapped python object (the sense of "disown" + * is from python) */ + void swig_disown() const { + if (!swig_disown_flag) { + swig_disown_flag=true; + swig_incref(); + } + } + + /* increase the reference count of the wrapped python object */ + void swig_incref() const { + if (swig_disown_flag) { + SvREFCNT_inc(swig_self); + } + } + + /* methods to implement pseudo protected director members */ + virtual bool swig_get_inner(const char* /* swig_protected_method_name */) const { + return true; + } + + virtual void swig_set_inner(const char* /* swig_protected_method_name */, bool /* swig_val */) const { + } + + /* ownership management */ + private: + typedef std::map swig_ownership_map; + mutable swig_ownership_map swig_owner; +#ifdef __THREAD__ + static PyThread_type_lock swig_mutex_own; +#endif + + public: + template + void swig_acquire_ownership_array(Type *vptr) const + { + if (vptr) { + SWIG_GUARD(swig_mutex_own); + swig_owner[vptr] = new GCArray_T(vptr); + } + } + + template + void swig_acquire_ownership(Type *vptr) const + { + if (vptr) { + SWIG_GUARD(swig_mutex_own); + swig_owner[vptr] = new GCItem_T(vptr); + } + } + + void swig_acquire_ownership_obj(void *vptr, int own) const + { + if (vptr && own) { + SWIG_GUARD(swig_mutex_own); + swig_owner[vptr] = new GCItem_Object(own); + } + } + + int swig_release_ownership(void *vptr) const + { + int own = 0; + if (vptr) { + SWIG_GUARD(swig_mutex_own); + swig_ownership_map::iterator iter = swig_owner.find(vptr); + if (iter != swig_owner.end()) { + own = iter->second->get_own(); + swig_owner.erase(iter); + } + } + return own; + } + + //template + //static PyObject* swig_pyobj_disown(PyObject *pyobj, PyObject *SWIGUNUSEDPARM(args)) + //{ + // SwigPyObject *sobj = (SwigPyObject *)pyobj; + // sobj->own = 0; + // Director *d = SWIG_DIRECTOR_CAST(reinterpret_cast(sobj->ptr)); + // if (d) + // d->swig_disown(); + // return PyWeakref_NewProxy(pyobj, NULL); + //} + + }; + +#ifdef __THREAD__ + PyThread_type_lock Director::swig_mutex_own = PyThread_allocate_lock(); +#endif +} + +#endif /* __cplusplus */ + + +#endif From 73e2de7538f5439aab14a7163df7c00310ea3201 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Tue, 12 Nov 2013 13:03:49 -0800 Subject: [PATCH 03/10] adds "callback" and "extend" examples --- Examples/perl5/callback/Makefile | 20 +++++++++ Examples/perl5/callback/example.cxx | 4 ++ Examples/perl5/callback/example.h | 23 ++++++++++ Examples/perl5/callback/example.i | 17 ++++++++ Examples/perl5/callback/index.html | 20 +++++++++ Examples/perl5/callback/runme.pl | 40 ++++++++++++++++++ Examples/perl5/check.list | 3 +- Examples/perl5/extend/Makefile | 20 +++++++++ Examples/perl5/extend/example.cxx | 4 ++ Examples/perl5/extend/example.h | 56 +++++++++++++++++++++++++ Examples/perl5/extend/example.i | 20 +++++++++ Examples/perl5/extend/index.html | 19 +++++++++ Examples/perl5/extend/runme.pl | 65 +++++++++++++++++++++++++++++ Examples/perl5/index.html | 2 + 14 files changed, 312 insertions(+), 1 deletion(-) create mode 100644 Examples/perl5/callback/Makefile create mode 100644 Examples/perl5/callback/example.cxx create mode 100644 Examples/perl5/callback/example.h create mode 100644 Examples/perl5/callback/example.i create mode 100644 Examples/perl5/callback/index.html create mode 100644 Examples/perl5/callback/runme.pl create mode 100644 Examples/perl5/extend/Makefile create mode 100644 Examples/perl5/extend/example.cxx create mode 100644 Examples/perl5/extend/example.h create mode 100644 Examples/perl5/extend/example.i create mode 100644 Examples/perl5/extend/index.html create mode 100644 Examples/perl5/extend/runme.pl diff --git a/Examples/perl5/callback/Makefile b/Examples/perl5/callback/Makefile new file mode 100644 index 000000000..544d13642 --- /dev/null +++ b/Examples/perl5/callback/Makefile @@ -0,0 +1,20 @@ +TOP = ../.. +SWIG = $(TOP)/../preinst-swig +CXXSRCS = example.cxx +TARGET = example +INTERFACE = example.i +LIBS = -lm + +check: build + $(MAKE) -f $(TOP)/Makefile perl5_run + +build: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='$(TARGET)' INTERFACE='$(INTERFACE)' perl5_cpp + +static: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='myperl' INTERFACE='$(INTERFACE)' perl5_cpp_static + +clean: + $(MAKE) -f $(TOP)/Makefile perl5_clean diff --git a/Examples/perl5/callback/example.cxx b/Examples/perl5/callback/example.cxx new file mode 100644 index 000000000..450d75608 --- /dev/null +++ b/Examples/perl5/callback/example.cxx @@ -0,0 +1,4 @@ +/* File : example.cxx */ + +#include "example.h" + diff --git a/Examples/perl5/callback/example.h b/Examples/perl5/callback/example.h new file mode 100644 index 000000000..1a0e8c432 --- /dev/null +++ b/Examples/perl5/callback/example.h @@ -0,0 +1,23 @@ +/* File : example.h */ + +#include +#include + +class Callback { +public: + virtual ~Callback() { std::cout << "Callback::~Callback()" << std:: endl; } + virtual void run() { std::cout << "Callback::run()" << std::endl; } +}; + + +class Caller { +private: + Callback *_callback; +public: + Caller(): _callback(0) {} + ~Caller() { delCallback(); } + void delCallback() { delete _callback; _callback = 0; } + void setCallback(Callback *cb) { delCallback(); _callback = cb; } + void call() { if (_callback) _callback->run(); } +}; + diff --git a/Examples/perl5/callback/example.i b/Examples/perl5/callback/example.i new file mode 100644 index 000000000..5f9072e61 --- /dev/null +++ b/Examples/perl5/callback/example.i @@ -0,0 +1,17 @@ +/* File : example.i */ +%module(directors="1") example +%{ +#include "example.h" +%} + +%include "std_string.i" + +/* turn on director wrapping Callback */ +%feature("director") Callback; + +/* Caller::setCallback(Callback *cb) gives ownership of the cb to the + * Caller object. The wrapper code should understand this. */ +%apply SWIGTYPE *DISOWN { Callback *cb }; + +%include "example.h" + diff --git a/Examples/perl5/callback/index.html b/Examples/perl5/callback/index.html new file mode 100644 index 000000000..82f5e972a --- /dev/null +++ b/Examples/perl5/callback/index.html @@ -0,0 +1,20 @@ + + +SWIG:Examples:perl5:callback + + + + + +SWIG/Examples/perl/callback/ +
+ +

Implementing C++ callbacks in Perl

+ +

+This example illustrates how to use directors to implement C++ callbacks. +

+ +
+ + diff --git a/Examples/perl5/callback/runme.pl b/Examples/perl5/callback/runme.pl new file mode 100644 index 000000000..9471d74e8 --- /dev/null +++ b/Examples/perl5/callback/runme.pl @@ -0,0 +1,40 @@ +#!/usr/bin/perl +use strict; +use warnings; +use example; + +{ + package PerlCallback; + use base 'example::Callback'; + sub run { + print "PerlCallback.run()\n"; + } +} + +print "Adding and calling a normal C++ callback\n"; +print "----------------------------------------\n"; + +my $caller = example::Caller->new(); +my $callback = example::Callback->new(); + +$caller->setCallback($callback); +$caller->call(); +$caller->delCallback(); + +$callback = PerlCallback->new(); + +print "\n"; +print "Adding and calling a Perl callback\n"; +print "------------------------------------\n"; + +$caller->setCallback($callback); +$caller->call(); +$caller->delCallback(); + +# Note that letting go of $callback will not attempt to destroy the +# object, ownership passed to $caller in the ->setCallback() call, and +# $callback was already destroyed in ->delCallback(). +undef $callback; + +print "\n"; +print "perl exit\n"; diff --git a/Examples/perl5/check.list b/Examples/perl5/check.list index e15f02e18..925bd263f 100644 --- a/Examples/perl5/check.list +++ b/Examples/perl5/check.list @@ -4,7 +4,6 @@ constants constants2 funcptr import -java multimap multiple_inheritance pointer @@ -12,3 +11,5 @@ reference simple value variables +callback +extend diff --git a/Examples/perl5/extend/Makefile b/Examples/perl5/extend/Makefile new file mode 100644 index 000000000..544d13642 --- /dev/null +++ b/Examples/perl5/extend/Makefile @@ -0,0 +1,20 @@ +TOP = ../.. +SWIG = $(TOP)/../preinst-swig +CXXSRCS = example.cxx +TARGET = example +INTERFACE = example.i +LIBS = -lm + +check: build + $(MAKE) -f $(TOP)/Makefile perl5_run + +build: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='$(TARGET)' INTERFACE='$(INTERFACE)' perl5_cpp + +static: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='myperl' INTERFACE='$(INTERFACE)' perl5_cpp_static + +clean: + $(MAKE) -f $(TOP)/Makefile perl5_clean diff --git a/Examples/perl5/extend/example.cxx b/Examples/perl5/extend/example.cxx new file mode 100644 index 000000000..450d75608 --- /dev/null +++ b/Examples/perl5/extend/example.cxx @@ -0,0 +1,4 @@ +/* File : example.cxx */ + +#include "example.h" + diff --git a/Examples/perl5/extend/example.h b/Examples/perl5/extend/example.h new file mode 100644 index 000000000..b27ab9711 --- /dev/null +++ b/Examples/perl5/extend/example.h @@ -0,0 +1,56 @@ +/* File : example.h */ + +#include +#include +#include +#include +#include + +class Employee { +private: + std::string name; +public: + Employee(const char* n): name(n) {} + virtual std::string getTitle() { return getPosition() + " " + getName(); } + virtual std::string getName() { return name; } + virtual std::string getPosition() const { return "Employee"; } + virtual ~Employee() { printf("~Employee() @ %p\n", this); } +}; + + +class Manager: public Employee { +public: + Manager(const char* n): Employee(n) {} + virtual std::string getPosition() const { return "Manager"; } +}; + + +class EmployeeList { + std::vector list; +public: + EmployeeList() { + list.push_back(new Employee("Bob")); + list.push_back(new Employee("Jane")); + list.push_back(new Manager("Ted")); + } + void addEmployee(Employee *p) { + list.push_back(p); + std::cout << "New employee added. Current employees are:" << std::endl; + std::vector::iterator i; + for (i=list.begin(); i!=list.end(); i++) { + std::cout << " " << (*i)->getTitle() << std::endl; + } + } + const Employee *get_item(int i) { + return list[i]; + } + ~EmployeeList() { + std::vector::iterator i; + std::cout << "~EmployeeList, deleting " << list.size() << " employees." << std::endl; + for (i=list.begin(); i!=list.end(); i++) { + delete *i; + } + std::cout << "~EmployeeList empty." << std::endl; + } +}; + diff --git a/Examples/perl5/extend/example.i b/Examples/perl5/extend/example.i new file mode 100644 index 000000000..f5e142b88 --- /dev/null +++ b/Examples/perl5/extend/example.i @@ -0,0 +1,20 @@ +/* File : example.i */ +%module(directors="1") example +%{ +#include "example.h" +%} + +%include "std_vector.i" +%include "std_string.i" + +/* turn on director wrapping for Manager */ +%feature("director") Employee; +%feature("director") Manager; + +/* EmployeeList::addEmployee(Employee *p) gives ownership of the + * employee to the EmployeeList object. The wrapper code should + * understand this. */ +%apply SWIGTYPE *DISOWN { Employee *p }; + +%include "example.h" + diff --git a/Examples/perl5/extend/index.html b/Examples/perl5/extend/index.html new file mode 100644 index 000000000..e9d886bcf --- /dev/null +++ b/Examples/perl5/extend/index.html @@ -0,0 +1,19 @@ + + +SWIG:Examples:perl5:extend + + + + + +SWIG/Examples/perl5/extend/ +
+ +

Extending a simple C++ class

+ +

+This example illustrates the extending of a C++ class with cross language polymorphism. + +

+ + diff --git a/Examples/perl5/extend/runme.pl b/Examples/perl5/extend/runme.pl new file mode 100644 index 000000000..43c9ce125 --- /dev/null +++ b/Examples/perl5/extend/runme.pl @@ -0,0 +1,65 @@ +#!/usr/bin/perl +use strict; +use warnings; +use example; +# This file illustrates the cross language polymorphism using directors. + +{ + # CEO class, which overrides Employee::getPosition(). + package CEO; + use base 'example::Manager'; + sub getPosition { + return 'CEO'; + } +} + + +# Create an instance of CEO, a class derived from the Java proxy of the +# underlying C++ class. The calls to getName() and getPosition() are standard, +# the call to getTitle() uses the director wrappers to call CEO.getPosition(). +my $e = CEO->new('Alice'); +print "${\ $e->getName } is a ${\ $e->getPosition() }\n"; +print "Just call her \"${\ $e->getTitle() }\"\n"; +print "----------------------\n"; + + +# Create a new EmployeeList instance. This class does not have a C++ +# director wrapper, but can be used freely with other classes that do. + +my $list = example::EmployeeList->new(); + +$list->addEmployee($e); +print "----------------------\n"; + +# Now we access the first four items in list (three are C++ objects that +# EmployeeList's constructor adds, the last is our CEO). The virtual +# methods of all these instances are treated the same. For items 0, 1, and +# 2, all methods resolve in C++. For item 3, our CEO, getTitle calls +# getPosition which resolves in Perl. The call to getPosition is +# slightly different, however, because of the overidden getPosition() call, since +# now the object reference has been "laundered" by passing through +# EmployeeList as an Employee*. Previously, Perl resolved the call +# immediately in CEO, but now Perl thinks the object is an instance of +# class Employee. So the call passes through the +# Employee proxy class and on to the C wrappers and C++ director, +# eventually ending up back at the Perl CEO implementation of getPosition(). +# The call to getTitle() for item 3 runs the C++ Employee::getTitle() +# method, which in turn calls getPosition(). This virtual method call +# passes down through the C++ director class to the Perl implementation +# in CEO. All this routing takes place transparently. + +print "(position, title) for items 0-3:\n"; + +print " ${\ $list->get_item(0)->getPosition() }, \"${\ $list->get_item(0)->getTitle() }\"\n"; +print " ${\ $list->get_item(1)->getPosition() }, \"${\ $list->get_item(1)->getTitle() }\"\n"; +print " ${\ $list->get_item(2)->getPosition() }, \"${\ $list->get_item(2)->getTitle() }\"\n"; +print " ${\ $list->get_item(3)->getPosition() }, \"${\ $list->get_item(3)->getTitle() }\"\n"; +print "----------------------\n"; + +# Time to delete the EmployeeList, which will delete all the Employee* +# items it contains. The last item is our CEO, which gets destroyed as well. +undef $list; +print "----------------------\n"; + +# All done. +print "perl exit\n"; diff --git a/Examples/perl5/index.html b/Examples/perl5/index.html index db46023c4..23c8ff658 100644 --- a/Examples/perl5/index.html +++ b/Examples/perl5/index.html @@ -20,6 +20,8 @@ certain C declarations are turned into constants.
  • reference. C++ references.
  • pointer. Simple pointer handling.
  • funcptr. Pointers to functions. +
  • callback. C++ callbacks using directors. +
  • extend. Extending a simple C++ class.

    Compilation Issues

    From 35dc86f064382f4f85b79c4138cc1222beab9011 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Tue, 12 Nov 2013 14:13:30 -0800 Subject: [PATCH 04/10] steals python director docs and adapts to perl5 --- Doc/Manual/Perl5.html | 342 +++++++++++++++++++++++++++++++++++++++++ Lib/perl5/director.swg | 2 +- 2 files changed, 343 insertions(+), 1 deletion(-) diff --git a/Doc/Manual/Perl5.html b/Doc/Manual/Perl5.html index 49e8965fa..00284783f 100644 --- a/Doc/Manual/Perl5.html +++ b/Doc/Manual/Perl5.html @@ -68,6 +68,15 @@
  • Modifying the proxy methods
  • Adding additional Perl code +
  • Cross language polymorphism + @@ -2993,6 +3002,339 @@ set_transform($im, $a); +

    31.11 Cross language polymorphism

    + + +

    +Proxy classes provide a more natural, object-oriented way to access +extension classes. As described above, each proxy instance has an +associated C++ instance, and method calls to the proxy are passed to the +C++ instance transparently via C wrapper functions. +

    + +

    +This arrangement is asymmetric in the sense that no corresponding +mechanism exists to pass method calls down the inheritance chain from +C++ to Perl. In particular, if a C++ class has been extended in Perl +(by extending the proxy class), these extensions will not be visible +from C++ code. Virtual method calls from C++ are thus not able access +the lowest implementation in the inheritance chain. +

    + +

    +Changes have been made to SWIG to address this problem and +make the relationship between C++ classes and proxy classes more +symmetric. To achieve this goal, new classes called directors are +introduced at the bottom of the C++ inheritance chain. The job of the +directors is to route method calls correctly, either to C++ +implementations higher in the inheritance chain or to Perl +implementations lower in the inheritance chain. The upshot is that C++ +classes can be extended in Perl and from C++ these extensions look +exactly like native C++ classes. Neither C++ code nor Perl code needs +to know where a particular method is implemented: the combination of +proxy classes, director classes, and C wrapper functions takes care of +all the cross-language method routing transparently. +

    + +

    31.11.1 Enabling directors

    + + +

    +The director feature is disabled by default. To use directors you +must make two changes to the interface file. First, add the "directors" +option to the %module directive, like this: +

    + +
    +
    +%module(directors="1") modulename
+
    +
    + +

    +Without this option no director code will be generated. Second, you +must use the %feature("director") directive to tell SWIG which classes +and methods should get directors. The %feature directive can be applied +globally, to specific classes, and to specific methods, like this: +

    + +
    +
    +// generate directors for all classes that have virtual methods
+%feature("director");         
+
+// generate directors for all virtual methods in class Foo
+%feature("director") Foo;      
+
    +
    + +

    +You can use the %feature("nodirector") directive to turn off +directors for specific classes or methods. So for example, +

    + +
    +
    +%feature("director") Foo;
+%feature("nodirector") Foo::bar;
+
    +
    + +

    +will generate directors for all virtual methods of class Foo except +bar(). +

    + +

    +Directors can also be generated implicitly through inheritance. +In the following, class Bar will get a director class that handles +the methods one() and two() (but not three()): +

    + +
    +
    +%feature("director") Foo;
+class Foo {
+public:
+    Foo(int foo);
+    virtual void one();
+    virtual void two();
+};
+
+class Bar: public Foo {
+public:
+    virtual void three();
+};
+
    +
    + +

    +then at the Perl side you can define +

    + +
    +
    +use mymodule;
+
+package MyFoo;
+use base 'mymodule::Foo';
+
+sub one {
+  print "one from Perl\n";
+}
+
    +
    + + +

    31.11.2 Director classes

    + + + + + +

    +For each class that has directors enabled, SWIG generates a new class +that derives from both the class in question and a special +Swig::Director class. These new classes, referred to as director +classes, can be loosely thought of as the C++ equivalent of the Perl +proxy classes. The director classes store a pointer to their underlying +Perl object and handle various issues related to object ownership. +

    + +

    +For simplicity let's ignore the Swig::Director class and refer to the +original C++ class as the director's base class. By default, a director +class extends all virtual methods in the inheritance chain of its base +class (see the preceding section for how to modify this behavior). +Thus all virtual method calls, whether they originate in C++ or in +Perl via proxy classes, eventually end up in at the implementation in +the director class. The job of the director methods is to route these +method calls to the appropriate place in the inheritance chain. By +"appropriate place" we mean the method that would have been called if +the C++ base class and its extensions in Perl were seamlessly +integrated. That seamless integration is exactly what the director +classes provide, transparently skipping over all the messy extension API +glue that binds the two languages together. +

    + +

    +In reality, the "appropriate place" is one of only two possibilities: +C++ or Perl. Once this decision is made, the rest is fairly easy. If +the correct implementation is in C++, then the lowest implementation of +the method in the C++ inheritance chain is called explicitly. If the +correct implementation is in Perl, the Perl API is used to call the +method of the underlying Perl object (after which the usual virtual +method resolution in Perl automatically finds the right +implementation). +

    + +

    +Now how does the director decide which language should handle the method call? +The basic rule is to handle the method in Perl, unless there's a good +reason not to. The reason for this is simple: Perl has the most +"extended" implementation of the method. This assertion is guaranteed, +since at a minimum the Perl proxy class implements the method. If the +method in question has been extended by a class derived from the proxy +class, that extended implementation will execute exactly as it should. +If not, the proxy class will route the method call into a C wrapper +function, expecting that the method will be resolved in C++. The wrapper +will call the virtual method of the C++ instance, and since the director +extends this the call will end up right back in the director method. Now +comes the "good reason not to" part. If the director method were to blindly +call the Perl method again, it would get stuck in an infinite loop. We avoid this +situation by adding special code to the C wrapper function that tells +the director method to not do this. The C wrapper function compares the +pointer to the Perl object that called the wrapper function to the +pointer stored by the director. If these are the same, then the C +wrapper function tells the director to resolve the method by calling up +the C++ inheritance chain, preventing an infinite loop. +

    + +

    +One more point needs to be made about the relationship between director +classes and proxy classes. When a proxy class instance is created in +Perl, SWIG creates an instance of the original C++ class. +This is exactly what happens without directors and +is true even if directors are enabled for the particular class in +question. When a class derived from a proxy class is created, +however, SWIG then creates an instance of the corresponding C++ director +class. The reason for this difference is that user-defined subclasses +may override or extend methods of the original class, so the director +class is needed to route calls to these methods correctly. For +unmodified proxy classes, all methods are ultimately implemented in C++ +so there is no need for the extra overhead involved with routing the +calls through Perl. +

    + +

    31.11.3 Ownership and object destruction

    + + +

    +Memory management issues are slightly more complicated with directors +than for proxy classes alone. Perl instances hold a pointer to the +associated C++ director object, and the director in turn holds a pointer +back to a Perl object. By default, proxy classes own their C++ +director object and take care of deleting it when they are garbage +collected. +

    + +

    +This relationship can be reversed by calling the special +DISOWN() method of the proxy class. After calling this +method the director +class increments the reference count of the Perl object. When the +director class is deleted it decrements the reference count. Assuming no +outstanding references to the Perl object remain, the Perl object +will be destroyed at the same time. This is a good thing, since +directors and proxies refer to each other and so must be created and +destroyed together. Destroying one without destroying the other will +likely cause your program to segfault. +

    + +

    31.11.4 Exception unrolling

    + + +

    +With directors routing method calls to Perl, and proxies routing them +to C++, the handling of exceptions is an important concern. By default, the +directors ignore exceptions that occur during method calls that are +resolved in Perl. To handle such exceptions correctly, it is necessary +to temporarily translate them into C++ exceptions. This can be done with +the %feature("director:except") directive. The following code should +suffice in most cases: +

    + +
    +
    +%feature("director:except") {
+    if ($error != NULL) {
+        throw Swig::DirectorMethodException();
+    }
+}
+
    +
    + +

    +This code will check the Perl error state after each method call from +a director into Perl, and throw a C++ exception if an error occurred. +This exception can be caught in C++ to implement an error handler. +

    + +

    +It may be the case that a method call originates in Perl, travels up +to C++ through a proxy class, and then back into Perl via a director +method. If an exception occurs in Perl at this point, it would be nice +for that exception to find its way back to the original caller. This can +be done by combining a normal %exception directive with the +director:except handler shown above. Here is an example of a +suitable exception handler: +

    + +
    +
    +%exception {
+    try { $action }
+    catch (Swig::DirectorException &e) { SWIG_fail; }
+}
+
    +
    + +

    +The class Swig::DirectorException used in this example is actually a +base class of Swig::DirectorMethodException, so it will trap this +exception. Because the Perl error state is still set when +Swig::DirectorMethodException is thrown, Perl will register the +exception as soon as the C wrapper function returns. +

    + +

    31.11.5 Overhead and code bloat

    + + +

    +Enabling directors for a class will generate a new director method for +every virtual method in the class' inheritance chain. This alone can +generate a lot of code bloat for large hierarchies. Method arguments +that require complex conversions to and from target language types can +result in large director methods. For this reason it is recommended that +you selectively enable directors only for specific classes that are +likely to be extended in Perl and used in C++. +

    + +

    +Compared to classes that do not use directors, the call routing in the +director methods does add some overhead. In particular, at least one +dynamic cast and one extra function call occurs per method call from +Perl. Relative to the speed of Perl execution this is probably +completely negligible. For worst case routing, a method call that +ultimately resolves in C++ may take one extra detour through Perl in +order to ensure that the method does not have an extended Perl +implementation. This could result in a noticeable overhead in some cases. +

    + +

    +Although directors make it natural to mix native C++ objects with Perl +objects (as director objects) via a common base class pointer, one +should be aware of the obvious fact that method calls to Perl objects +will be much slower than calls to C++ objects. This situation can be +optimized by selectively enabling director methods (using the %feature +directive) for only those methods that are likely to be extended in +Perl. +

    + +

    31.11.6 Typemaps

    + + +

    +Typemaps for input and output of most of the basic types from director +classes have been written. These are roughly the reverse of the usual +input and output typemaps used by the wrapper code. The typemap +operation names are 'directorin', 'directorout', and 'directorargout'. +The director code does not currently use any of the other kinds of typemaps. +It is not clear at this point which kinds are appropriate and +need to be supported. +

    + + diff --git a/Lib/perl5/director.swg b/Lib/perl5/director.swg index 937b727a4..6b03fc26c 100644 --- a/Lib/perl5/director.swg +++ b/Lib/perl5/director.swg @@ -202,7 +202,7 @@ namespace Swig { protected: SV *err; public: - DirectorMethodException(SV *sv) + DirectorMethodException(SV *sv = sv_mortalcopy(ERRSV)) : err(sv) { SvREFCNT_inc(err); From 3e91ae7db7829f1a45ffd443514f5f19a14e7cf8 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Tue, 12 Nov 2013 18:43:56 -0800 Subject: [PATCH 05/10] mitigate ConvertPtr director cost when directors are not enabled --- Lib/perl5/perlrun.swg | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Lib/perl5/perlrun.swg b/Lib/perl5/perlrun.swg index 4e31c4754..876fae268 100644 --- a/Lib/perl5/perlrun.swg +++ b/Lib/perl5/perlrun.swg @@ -289,7 +289,11 @@ 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); +#ifdef SWIG_DIRECTORS if (!tc && !sv_derived_from(sv,SWIG_Perl_TypeProxyName(_t))) { +#else + if (!tc) { +#endif return SWIG_ERROR; } { From 7d80d9b59eef51e78d794bf68e53c899c3213b65 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Wed, 13 Nov 2013 12:38:04 -0800 Subject: [PATCH 06/10] eliminate dead director code and convert remaining blocks --- Lib/perl5/director.swg | 127 --------------------------------------- Source/Modules/perl5.cxx | 100 +++++++----------------------- 2 files changed, 23 insertions(+), 204 deletions(-) diff --git a/Lib/perl5/director.swg b/Lib/perl5/director.swg index 6b03fc26c..5acc4fd15 100644 --- a/Lib/perl5/director.swg +++ b/Lib/perl5/director.swg @@ -17,41 +17,6 @@ #include -/* - Use -DSWIG_PYTHON_DIRECTOR_NO_VTABLE if you don't want to generate a 'virtual - table', and avoid multiple GetAttr calls to retrieve the python - methods. -*/ - -#ifndef SWIG_PERL_DIRECTOR_NO_VTABLE -#ifndef SWIG_PERL_DIRECTOR_VTABLE -#define SWIG_PERL_DIRECTOR_VTABLE -#endif -#endif - - - -/* - Use -DSWIG_DIRECTOR_NO_UEH if you prefer to avoid the use of the - Undefined Exception Handler provided by swig. -*/ -#ifndef SWIG_DIRECTOR_NO_UEH -#ifndef SWIG_DIRECTOR_UEH -#define SWIG_DIRECTOR_UEH -#endif -#endif - - -/* - Use -DSWIG_DIRECTOR_STATIC if you prefer to avoid the use of the - 'Swig' namespace. This could be useful for multi-modules projects. -*/ -#ifdef SWIG_DIRECTOR_STATIC -/* Force anonymous (static) namespace */ -#define Swig -#endif - - /* Use -DSWIG_DIRECTOR_NORTTI if you prefer to avoid the use of the native C++ RTTI and dynamic_cast<>. But be aware that directors @@ -267,77 +232,6 @@ namespace Swig { throw DirectorPureVirtualException(name); } }; -// /* unknown exception handler */ -// class UnknownExceptionHandler -// { -//#ifdef SWIG_DIRECTOR_UEH -// static void handler() { -// try { -// throw; -// } catch (DirectorException& e) { -// std::cerr << "SWIG Director exception caught:" << std::endl -// << e.getMessage() << std::endl; -// } catch (std::exception& e) { -// std::cerr << "std::exception caught: "<< e.what() << std::endl; -// } catch (...) { -// std::cerr << "Unknown exception caught." << std::endl; -// } -// -// //std::cerr << std::endl -// // << "Python interpreter traceback:" << std::endl; -// //PyErr_Print(); -// //std::cerr << std::endl; -// -// std::cerr << "This exception was caught by the SWIG unexpected exception handler." << std::endl -// << "Try using %feature(\"director:except\") to avoid reaching this point." << std::endl -// << std::endl -// << "Exception is being re-thrown, program will likely abort/terminate." << std::endl; -// throw; -// } -// -// public: -// -// std::unexpected_handler old; -// UnknownExceptionHandler(std::unexpected_handler nh = handler) -// { -// old = std::set_unexpected(nh); -// } -// -// ~UnknownExceptionHandler() -// { -// std::set_unexpected(old); -// } -//#endif -// }; - -#if defined(SWIG_PYTHON_THREADS) -/* __THREAD__ is the old macro to activate some thread support */ -# if !defined(__THREAD__) -# define __THREAD__ 1 -# endif -#endif - -#ifdef __THREAD__ -# include "pythread.h" - class Guard - { - PyThread_type_lock & mutex_; - - public: - Guard(PyThread_type_lock & mutex) : mutex_(mutex) - { - PyThread_acquire_lock(mutex_, WAIT_LOCK); - } - - ~Guard() - { - PyThread_release_lock(mutex_); - } - }; -# define SWIG_GUARD(mutex) Guard _guard(mutex) -#else -# define SWIG_GUARD(mutex) -#endif /* director base class */ class Director { @@ -410,16 +304,12 @@ namespace Swig { private: typedef std::map swig_ownership_map; mutable swig_ownership_map swig_owner; -#ifdef __THREAD__ - static PyThread_type_lock swig_mutex_own; -#endif public: template void swig_acquire_ownership_array(Type *vptr) const { if (vptr) { - SWIG_GUARD(swig_mutex_own); swig_owner[vptr] = new GCArray_T(vptr); } } @@ -428,7 +318,6 @@ namespace Swig { void swig_acquire_ownership(Type *vptr) const { if (vptr) { - SWIG_GUARD(swig_mutex_own); swig_owner[vptr] = new GCItem_T(vptr); } } @@ -436,7 +325,6 @@ namespace Swig { void swig_acquire_ownership_obj(void *vptr, int own) const { if (vptr && own) { - SWIG_GUARD(swig_mutex_own); swig_owner[vptr] = new GCItem_Object(own); } } @@ -445,7 +333,6 @@ namespace Swig { { int own = 0; if (vptr) { - SWIG_GUARD(swig_mutex_own); swig_ownership_map::iterator iter = swig_owner.find(vptr); if (iter != swig_owner.end()) { own = iter->second->get_own(); @@ -455,22 +342,8 @@ namespace Swig { return own; } - //template - //static PyObject* swig_pyobj_disown(PyObject *pyobj, PyObject *SWIGUNUSEDPARM(args)) - //{ - // SwigPyObject *sobj = (SwigPyObject *)pyobj; - // sobj->own = 0; - // Director *d = SWIG_DIRECTOR_CAST(reinterpret_cast(sobj->ptr)); - // if (d) - // d->swig_disown(); - // return PyWeakref_NewProxy(pyobj, NULL); - //} - }; -#ifdef __THREAD__ - PyThread_type_lock Director::swig_mutex_own = PyThread_allocate_lock(); -#endif } #endif /* __cplusplus */ diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx index 182835645..06b4c4ae9 100644 --- a/Source/Modules/perl5.cxx +++ b/Source/Modules/perl5.cxx @@ -1707,12 +1707,8 @@ public: 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"); + 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; @@ -2084,7 +2080,6 @@ public: 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) { @@ -2157,11 +2152,6 @@ public: } } - //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) @@ -2175,7 +2165,6 @@ public: } } else { /* attach typemaps to arguments (C/C++ -> Perl) */ - String *arglist = NewString(""); String *parse_args = NewString(""); String *pstack = NewString(""); @@ -2211,7 +2200,6 @@ public: /* 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"); @@ -2232,35 +2220,20 @@ public: 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); + 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); - } + Printv(wrap_args, tm, "\n", NIL); + Putc('O', parse_args); + Printv(pstack, "XPUSHs(", source, ");\n", NIL); p = Getattr(p, "tmap:directorin:next"); continue; } else if (Cmp(ptype, "void")) { @@ -2303,23 +2276,19 @@ public: 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); + Wrapper_add_localv(w, source, "SV *", 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); + Printf(wrap_args, "%s = SWIG_NewPointerObj(%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); + Printf(wrap_args, "SvREFCNT_inc((SV *)%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); @@ -2338,13 +2307,6 @@ public: /* 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); @@ -2374,7 +2336,7 @@ public: 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"); + Replaceall(tm, "$error", "ERRSV"); Printv(w->code, Str(tm), "\n", NIL); } else { Printf(w->code, " Swig::DirectorMethodException::raise(ERRSV);\n", classname, pyname); @@ -2395,9 +2357,9 @@ public: 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); + Wrapper_add_local(w, "output", "SV *output"); + Printf(w->code, "if (count != %d) {\n", outputs); + Printf(w->code, " Swig::DirectorTypeMismatchException::raise(\"Perl method %s.%sfailed to return a list.\");\n", classname, pyname); Append(w->code, "}\n"); } @@ -2410,7 +2372,7 @@ public: 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++); + Printf(w->code, "output = POPs;\n"); Replaceall(tm, "$input", "output"); } else { Replaceall(tm, "$input", Swig_cresult_name()); @@ -2425,14 +2387,10 @@ public: } 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)); @@ -2444,7 +2402,7 @@ public: 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++); + Printf(w->code, "output = POPs;\n"); Replaceall(tm, "$result", "output"); } else { Replaceall(tm, "$result", Swig_cresult_name()); @@ -2457,14 +2415,7 @@ public: } } - /* 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); } @@ -2487,11 +2438,6 @@ public: } } - 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 From 055cbc85de4625e6b53e840cd753e0d01bae5d9e Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Wed, 13 Nov 2013 15:04:18 -0800 Subject: [PATCH 07/10] fix string mangled by tidy --- Source/Modules/perl5.cxx | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx index 06b4c4ae9..f59994cd7 100644 --- a/Source/Modules/perl5.cxx +++ b/Source/Modules/perl5.cxx @@ -1707,8 +1707,8 @@ public: 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"); + 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; From e0789366e7dccf28c31c04e9d82d35abead5f78c Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Thu, 14 Nov 2013 07:29:28 -0800 Subject: [PATCH 08/10] prefer polymorphism on existing destructor over custom destructor method --- Doc/Manual/Perl5.html | 24 +++++++++++++++++++ .../perl5/director_finalizer_runme.pl | 5 ++-- Source/Modules/perl5.cxx | 15 ++++++------ 3 files changed, 35 insertions(+), 9 deletions(-) diff --git a/Doc/Manual/Perl5.html b/Doc/Manual/Perl5.html index 00284783f..db8c0e602 100644 --- a/Doc/Manual/Perl5.html +++ b/Doc/Manual/Perl5.html @@ -3231,6 +3231,30 @@ destroyed together. Destroying one without destroying the other will likely cause your program to segfault.

    +

    +Also note that due to the proxy implementation, the DESTROY() +method on directors can be called for several reasons, many of which +have little to do with the teardown of an object instance. To help +disambiguate this, a second argument is added to the DESTROY() +call when a C++ director object is being released. So, to avoid running +your clean-up code when an object is not really going away, or after it +has already been reclaimed, it is suggested that custom destructors in +Perl subclasses looks something like: +

    + +
    +
    +sub DESTROY {
+  my($self, $final) = @_;
+  if($final) {
+    # real teardown code
+  }
+  shift->SUPER::DESTROY(@_);
+}
+
    +
    + +

    31.11.4 Exception unrolling

    diff --git a/Examples/test-suite/perl5/director_finalizer_runme.pl b/Examples/test-suite/perl5/director_finalizer_runme.pl index bb6e1fa71..bcb4002ec 100644 --- a/Examples/test-suite/perl5/director_finalizer_runme.pl +++ b/Examples/test-suite/perl5/director_finalizer_runme.pl @@ -7,8 +7,9 @@ require_ok('director_finalizer'); { package MyFoo; use base 'director_finalizer::Foo'; - sub DIRECTOR_DESTROY { my($self) = @_; - $self->orStatus(2); + sub DESTROY { my($self, $final) = @_; + $self->orStatus(2) if $final; + shift->SUPER::DESTROY(@_); } } diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx index f59994cd7..530ed07ed 100644 --- a/Source/Modules/perl5.cxx +++ b/Source/Modules/perl5.cxx @@ -1529,11 +1529,11 @@ public: 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); + "if (not $self->can($member_func)) {\n", tab8, "my $h = ", cmodule, "::", mrename, "($self);\n", tab8, "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", tab8, "my $h = ", cmodule, "::", mrename, + "($self);\n", tab8, "return $h->{$field} = $newval if $h;\n", tab4, "}\n", tab4, "return $self->$member_func($newval);\n", "}\n", NIL); + Delete(mrename); } } @@ -2493,8 +2493,9 @@ public: 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); + "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, "XPUSHs(&PL_sv_yes);\n", tab4, "PUTBACK;\n", tab4, "call_method(\"DESTROY\", G_EVAL | G_VOID);\n", tab4, + "FREETMPS;\n", tab4, "LEAVE;\n", NIL); Delete(mangle); Delete(ptype); From 43aefba9eed6fc06334ccef5e5652664aa8ea570 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Thu, 14 Nov 2013 09:22:23 -0800 Subject: [PATCH 09/10] ran "beautify-file" make target over perl5.cxx patch hunks and rewrote callback and extend examples in the style of existing examples --- Examples/perl5/callback/runme.pl | 40 +-- Examples/perl5/extend/runme.pl | 58 ++-- Source/Modules/perl5.cxx | 439 +++++++++++++++---------------- 3 files changed, 277 insertions(+), 260 deletions(-) diff --git a/Examples/perl5/callback/runme.pl b/Examples/perl5/callback/runme.pl index 9471d74e8..a6b80d988 100644 --- a/Examples/perl5/callback/runme.pl +++ b/Examples/perl5/callback/runme.pl @@ -1,40 +1,48 @@ -#!/usr/bin/perl -use strict; -use warnings; +# file: runme.pl + +# This file illustrates the cross language polymorphism using directors. + use example; + { - package PerlCallback; + package PlCallback; use base 'example::Callback'; sub run { - print "PerlCallback.run()\n"; + print "PlCallback->run()\n"; } } +# Create an Caller instance + +$caller = example::Caller->new(); + +# Add a simple C++ callback (caller owns the callback, so +# we disown it first by clearing the .thisown flag). + print "Adding and calling a normal C++ callback\n"; print "----------------------------------------\n"; -my $caller = example::Caller->new(); -my $callback = example::Callback->new(); - +$callback = example::Callback->new(); +$callback->DISOWN(); $caller->setCallback($callback); $caller->call(); $caller->delCallback(); -$callback = PerlCallback->new(); - -print "\n"; +print print "Adding and calling a Perl callback\n"; -print "------------------------------------\n"; +print "----------------------------------\n"; +# Add a Perl callback (caller owns the callback, so we +# disown it first by calling DISOWN). + +$callback = PlCallback->new(); +$callback->DISOWN(); $caller->setCallback($callback); $caller->call(); $caller->delCallback(); -# Note that letting go of $callback will not attempt to destroy the -# object, ownership passed to $caller in the ->setCallback() call, and -# $callback was already destroyed in ->delCallback(). -undef $callback; +# All done. print "\n"; print "perl exit\n"; diff --git a/Examples/perl5/extend/runme.pl b/Examples/perl5/extend/runme.pl index 43c9ce125..76ee849a4 100644 --- a/Examples/perl5/extend/runme.pl +++ b/Examples/perl5/extend/runme.pl @@ -1,48 +1,56 @@ -#!/usr/bin/perl -use strict; -use warnings; -use example; +# file: runme.pl + # This file illustrates the cross language polymorphism using directors. +use example; + + +# CEO class, which overrides Employee::getPosition(). + { - # CEO class, which overrides Employee::getPosition(). package CEO; use base 'example::Manager'; sub getPosition { - return 'CEO'; + return "CEO"; } } -# Create an instance of CEO, a class derived from the Java proxy of the -# underlying C++ class. The calls to getName() and getPosition() are standard, -# the call to getTitle() uses the director wrappers to call CEO.getPosition(). -my $e = CEO->new('Alice'); -print "${\ $e->getName } is a ${\ $e->getPosition() }\n"; -print "Just call her \"${\ $e->getTitle() }\"\n"; +# Create an instance of our employee extension class, CEO. The calls to +# getName() and getPosition() are standard, the call to getTitle() uses +# the director wrappers to call CEO->getPosition. $e = CEO->new("Alice") + +$e = CEO->new("Alice"); +print $e->getName(), " is a ", $e->getPosition(), "\n"; +printf "Just call her \"%s\"\n", $e->getTitle(); print "----------------------\n"; # Create a new EmployeeList instance. This class does not have a C++ # director wrapper, but can be used freely with other classes that do. -my $list = example::EmployeeList->new(); +$list = example::EmployeeList->new(); +# EmployeeList owns its items, so we must surrender ownership of objects +# we add. This involves calling the DISOWN method to tell the +# C++ director to start reference counting. + +$e->DISOWN(); $list->addEmployee($e); print "----------------------\n"; # Now we access the first four items in list (three are C++ objects that # EmployeeList's constructor adds, the last is our CEO). The virtual # methods of all these instances are treated the same. For items 0, 1, and -# 2, all methods resolve in C++. For item 3, our CEO, getTitle calls +# 2, both all methods resolve in C++. For item 3, our CEO, getTitle calls # getPosition which resolves in Perl. The call to getPosition is -# slightly different, however, because of the overidden getPosition() call, since +# slightly different, however, from the $e->getPosition() call above, since # now the object reference has been "laundered" by passing through # EmployeeList as an Employee*. Previously, Perl resolved the call # immediately in CEO, but now Perl thinks the object is an instance of -# class Employee. So the call passes through the +# class Employee (actually EmployeePtr). So the call passes through the # Employee proxy class and on to the C wrappers and C++ director, -# eventually ending up back at the Perl CEO implementation of getPosition(). +# eventually ending up back at the CEO implementation of getPosition(). # The call to getTitle() for item 3 runs the C++ Employee::getTitle() # method, which in turn calls getPosition(). This virtual method call # passes down through the C++ director class to the Perl implementation @@ -50,16 +58,22 @@ print "----------------------\n"; print "(position, title) for items 0-3:\n"; -print " ${\ $list->get_item(0)->getPosition() }, \"${\ $list->get_item(0)->getTitle() }\"\n"; -print " ${\ $list->get_item(1)->getPosition() }, \"${\ $list->get_item(1)->getTitle() }\"\n"; -print " ${\ $list->get_item(2)->getPosition() }, \"${\ $list->get_item(2)->getTitle() }\"\n"; -print " ${\ $list->get_item(3)->getPosition() }, \"${\ $list->get_item(3)->getTitle() }\"\n"; +printf " %s, \"%s\"\n", $list->get_item(0)->getPosition(), $list->get_item(0)->getTitle(); +printf " %s, \"%s\"\n", $list->get_item(1)->getPosition(), $list->get_item(1)->getTitle(); +printf " %s, \"%s\"\n", $list->get_item(2)->getPosition(), $list->get_item(2)->getTitle(); +printf " %s, \"%s\"\n", $list->get_item(3)->getPosition(), $list->get_item(3)->getTitle(); print "----------------------\n"; # Time to delete the EmployeeList, which will delete all the Employee* -# items it contains. The last item is our CEO, which gets destroyed as well. +# items it contains. The last item is our CEO, which gets destroyed as its +# reference count goes to zero. The Perl destructor runs, and is still +# able to call self.getName() since the underlying C++ object still +# exists. After this destructor runs the remaining C++ destructors run as +# usual to destroy the object. + undef $list; print "----------------------\n"; # All done. + print "perl exit\n"; diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx index 530ed07ed..d7a131aa2 100644 --- a/Source/Modules/perl5.cxx +++ b/Source/Modules/perl5.cxx @@ -238,47 +238,42 @@ public: { 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(); - } - } - } + 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(); + } + } + } } } @@ -301,8 +296,8 @@ public: if (directorsEnabled()) { f_runtime_h = NewFile(outfile_h, "w", SWIG_output_files()); if (!f_runtime_h) { - FileErrorDisplay(outfile_h); - SWIG_exit(EXIT_FAILURE); + FileErrorDisplay(outfile_h); + SWIG_exit(EXIT_FAILURE); } } @@ -1477,8 +1472,7 @@ public: String *director_disown; if (Getattr(n, "perl5:directordisown")) { - director_disown = NewStringf("%s%s($self);\n", - tab4, Getattr(n, "perl5:directordisown")); + director_disown = NewStringf("%s%s($self);\n", tab4, Getattr(n, "perl5:directordisown")); } else { director_disown = NewString(""); } @@ -1511,7 +1505,8 @@ public: 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); + 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); @@ -1534,7 +1529,7 @@ public: "my $member_func = \"swig_${field}_set\";\n", tab4, "if (not $self->can($member_func)) {\n", tab8, "my $h = ", cmodule, "::", mrename, "($self);\n", tab8, "return $h->{$field} = $newval if $h;\n", tab4, "}\n", tab4, "return $self->$member_func($newval);\n", "}\n", NIL); - Delete(mrename); + Delete(mrename); } } return SWIG_OK; @@ -1707,8 +1702,8 @@ public: 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"); + 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; @@ -1732,7 +1727,7 @@ public: Printv(pcode, "sub ", Swig_name_construct(NSPACE_TODO, symname), " {\n", NIL); } - const char *pkg = getCurrentClass() && Swig_directorclass(getCurrentClass()) ? "$_[0]" : "shift"; + const char *pkg = getCurrentClass() && Swig_directorclass(getCurrentClass())? "$_[0]" : "shift"; Printv(pcode, 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); @@ -2083,7 +2078,7 @@ public: if (Cmp(storage, "virtual") == 0) { if (Cmp(value, "0") == 0) { - pure_virtual = true; + pure_virtual = true; } } @@ -2116,18 +2111,18 @@ public: Append(declaration, " throw("); if (throw_parm_list) - Swig_typemap_attach_parms("throws", throw_parm_list, 0); + 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); - } + 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, ")"); @@ -2143,9 +2138,9 @@ public: */ if (!is_void) { if (!(ignored_method && !pure_virtual)) { - String *cres = SwigType_lstr(returntype, "c_result"); - Printf(w->code, "%s;\n", cres); - Delete(cres); + 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); @@ -2154,14 +2149,14 @@ public: 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); + 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)); + 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) */ @@ -2195,32 +2190,32 @@ public: int outputs = 0; if (!is_void) - outputs++; + outputs++; /* build argument list and type conversion string */ idx = 0; p = l; while (p) { - if (checkAttribute(p, "tmap:in:numinputs", "0")) { - p = Getattr(p, "tmap:in:next"); - continue; - } + 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"); - } - */ + /* 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++; + if (Getattr(p, "tmap:directorargout") != 0) + outputs++; - String *pname = Getattr(p, "name"); - String *ptype = Getattr(p, "type"); + String *pname = Getattr(p, "name"); + String *ptype = Getattr(p, "type"); - if ((tm = Getattr(p, "tmap:directorin")) != 0) { + if ((tm = Getattr(p, "tmap:directorin")) != 0) { sprintf(source, "obj%d", idx++); String *input = NewString(source); Setattr(p, "emit:directorinput", input); @@ -2234,74 +2229,74 @@ public: Printv(wrap_args, tm, "\n", NIL); Putc('O', parse_args); Printv(pstack, "XPUSHs(", source, ");\n", NIL); - 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, "SV *", 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_NewPointerObj(%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, "SvREFCNT_inc((SV *)%s);\n", source); - Append(wrap_args, "}\n"); - Delete(director); - } 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); - } - 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); + 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, "SV *", 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_NewPointerObj(%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, "SvREFCNT_inc((SV *)%s);\n", source); + Append(wrap_args, "}\n"); + Delete(director); + } 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); + } + 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 */ @@ -2312,7 +2307,7 @@ public: /* 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); + Printf(w->code, "swig_set_inner(\"%s\", true);\n", name); } Append(w->code, "ENTER;\n"); @@ -2324,22 +2319,22 @@ public: 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); + 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); + 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", "ERRSV"); - Printv(w->code, Str(tm), "\n", NIL); + Replaceall(tm, "$error", "ERRSV"); + Printv(w->code, Str(tm), "\n", NIL); } else { - Printf(w->code, " Swig::DirectorMethodException::raise(ERRSV);\n", classname, pyname); + Printf(w->code, " Swig::DirectorMethodException::raise(ERRSV);\n", classname, pyname); } Append(w->code, "}\n"); Delete(tm); @@ -2357,62 +2352,62 @@ public: String *outarg = NewString(""); if (outputs > 1) { - Wrapper_add_local(w, "output", "SV *output"); - Printf(w->code, "if (count != %d) {\n", outputs); - Printf(w->code, " Swig::DirectorTypeMismatchException::raise(\"Perl method %s.%sfailed to return a list.\");\n", classname, pyname); - Append(w->code, "}\n"); + Wrapper_add_local(w, "output", "SV *output"); + Printf(w->code, "if (count != %d) {\n", outputs); + Printf(w->code, " Swig::DirectorTypeMismatchException::raise(\"Perl method %s.%sfailed to return a list.\");\n", classname, pyname); + Append(w->code, "}\n"); } idx = 0; /* marshal return value */ if (!is_void) { - Append(w->code, "SPAGAIN;\n"); + 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 = POPs;\n"); - Replaceall(tm, "$input", "output"); - } else { - Replaceall(tm, "$input", Swig_cresult_name()); - } - char temp[24]; - sprintf(temp, "%d", idx); - Replaceall(tm, "$argnum", temp); + tm = Swig_typemap_lookup("directorout", n, Swig_cresult_name(), w); + if (tm != 0) { + if (outputs > 1) { + Printf(w->code, "output = POPs;\n"); + 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"); - } - Replaceall(tm, "$result", "c_result"); - Printv(w->code, tm, "\n", NIL); - Delete(tm); - } else { - 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; - } + /* TODO check this */ + if (Getattr(n, "wrap:disown")) { + Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN"); + } else { + Replaceall(tm, "$disown", "0"); + } + Replaceall(tm, "$result", "c_result"); + Printv(w->code, tm, "\n", NIL); + Delete(tm); + } else { + 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 = POPs;\n"); - 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); - } + if ((tm = Getattr(p, "tmap:directorargout")) != 0) { + if (outputs > 1) { + Printf(w->code, "output = POPs;\n"); + 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); + } } Delete(parse_args); @@ -2428,13 +2423,13 @@ public: 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); + 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); } } @@ -2448,7 +2443,7 @@ public: Replaceall(inline_extra_method, name, extra_method_name); Replaceall(inline_extra_method, ";\n", " {\n "); if (!is_void) - Printf(inline_extra_method, "return "); + Printf(inline_extra_method, "return "); String *methodcall = Swig_method_call(super, l); Printv(inline_extra_method, methodcall, ";\n }\n", NIL); Delete(methodcall); @@ -2458,10 +2453,10 @@ public: /* 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); + Replaceall(w->code, "$symname", symname); + Wrapper_print(w, f_directors); + Printv(f_directors_h, declaration, NIL); + Printv(f_directors_h, inline_extra_method, NIL); } } @@ -2476,7 +2471,7 @@ public: member_func = 1; rv = Language::classDirectorDisown(n); member_func = 0; - if(rv == SWIG_OK && Swig_directorclass(n)) { + 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)); From 16d40c14f946055f7516697091c5758cba9de883 Mon Sep 17 00:00:00 2001 From: Robert Stone Date: Fri, 15 Nov 2013 10:49:34 -0800 Subject: [PATCH 10/10] try adding travis ci to this branch --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 26758304f..0a3aa1893 100644 --- a/.travis.yml +++ b/.travis.yml @@ -56,3 +56,4 @@ script: branches: only: - master + - perl5-directors-minimal