steals python directors and adapts to perl5

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()');

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");

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;
+}

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();
+}

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;
+

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/;

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';

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;

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);

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');

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');

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');
+}

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()');

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;

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";

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();
+}
+

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/;

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";

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");

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);
+