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

Merge branch 'perl5-directors-minimal' of https://github.com/talby-/swig into talby--perl5-directors-minimal

Browse source 
* 'perl5-directors-minimal' of https://github.com/talby-/swig:
  try adding travis ci to this branch
  ran "beautify-file" make target over perl5.cxx patch hunks and rewrote callback and extend examples in the style of existing examples
  prefer polymorphism on existing destructor over custom destructor method
  fix string mangled by tidy
  eliminate dead director code and convert remaining blocks
  mitigate ConvertPtr director cost when directors are not enabled
  steals python director docs and adapts to perl5
  adds "callback" and "extend" examples
  don't forget the most important part
  steals python directors and adapts to perl5
This commit is contained in:
William S Fulton 2013-12-23 07:30:37 +00:00
commit d1bb451eab
40 changed files with 2740 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

20
Examples/perl5/callback/Makefile Normal file
View file

@ -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

4
Examples/perl5/callback/example.cxx Normal file
View file

@ -0,0 +1,4 @@
/* File : example.cxx */
#include "example.h"

23
Examples/perl5/callback/example.h Normal file
View file

@ -0,0 +1,23 @@
/* File : example.h */
#include <cstdio>
#include <iostream>
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(); }
};

17
Examples/perl5/callback/example.i Normal file
View file

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

20
Examples/perl5/callback/index.html Normal file
View file

@ -0,0 +1,20 @@
<html>
<head>
<title>SWIG:Examples:perl5:callback</title>
</head>
<body bgcolor="#ffffff">
<tt>SWIG/Examples/perl/callback/</tt>
<hr>
<H2>Implementing C++ callbacks in Perl</H2>
<p>
This example illustrates how to use directors to implement C++ callbacks.
</p>
<hr>
</body>
</html>

48
Examples/perl5/callback/runme.pl Normal file
View file

@ -0,0 +1,48 @@
# file: runme.pl
# This file illustrates the cross language polymorphism using directors.
use example;
{
package PlCallback;
use base 'example::Callback';
sub run {
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";
$callback = example::Callback->new();
$callback->DISOWN();
$caller->setCallback($callback);
$caller->call();
$caller->delCallback();
print
print "Adding and calling a Perl callback\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();
# All done.
print "\n";
print "perl exit\n";

3
Examples/perl5/check.list
View file

@ -4,7 +4,6 @@ constants
constants2
funcptr
import
java
multimap
multiple_inheritance
pointer
@ -12,3 +11,5 @@ reference
simple
value
variables
callback
extend

20
Examples/perl5/extend/Makefile Normal file
View file

@ -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

4
Examples/perl5/extend/example.cxx Normal file
View file

@ -0,0 +1,4 @@
/* File : example.cxx */
#include "example.h"

56
Examples/perl5/extend/example.h Normal file
View file

@ -0,0 +1,56 @@
/* File : example.h */
#include <cstdio>
#include <iostream>
#include <vector>
#include <string>
#include <cmath>
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<Employee*> 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<Employee*>::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<Employee*>::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;
}
};

20
Examples/perl5/extend/example.i Normal file
View file

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

19
Examples/perl5/extend/index.html Normal file
View file

@ -0,0 +1,19 @@
<html>
<head>
<title>SWIG:Examples:perl5:extend</title>
</head>
<body bgcolor="#ffffff">
<tt>SWIG/Examples/perl5/extend/</tt>
<hr>
<H2>Extending a simple C++ class</H2>
<p>
This example illustrates the extending of a C++ class with cross language polymorphism.
<hr>
</body>
</html>

79
Examples/perl5/extend/runme.pl Normal file
View file

@ -0,0 +1,79 @@
# file: runme.pl
# This file illustrates the cross language polymorphism using directors.
use example;
# CEO class, which overrides Employee::getPosition().
{
package CEO;
use base 'example::Manager';
sub getPosition {
return "CEO";
}
}
# 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.
$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, 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, 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 (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 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";
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 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";

2
Examples/perl5/index.html
View file

@ -20,6 +20,8 @@ certain C declarations are turned into constants.
<li><a href="reference/index.html">reference</a>. C++ references.
<li><a href="pointer/index.html">pointer</a>. Simple pointer handling.
<li><a href="funcptr/index.html">funcptr</a>. Pointers to functions.
<li><a href="callback/index.html">callback</a>. C++ callbacks using directors.
<li><a href="extend/index.html">extend</a>. Extending a simple C++ class.
</ul>
<h2>Compilation Issues</h2>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -0,0 +1,84 @@
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 DESTROY { my($self, $final) = @_;
$self->orStatus(2) if $final;
shift->SUPER::DESTROY(@_);
}
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
undef $f;
is(director_finalizer::getStatus(), 3, 'shadow release fires destructor');
}
{ # again, this time with DESTROY
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DESTROY();
is(director_finalizer::getStatus(), 3, 'DESTROY method fires destructor');
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
director_finalizer::launder($f);
is(director_finalizer::getStatus(), 0, 'wrap release does not fire destructor');
undef $f;
is(director_finalizer::getStatus(), 3, 'shadow release still fires destructor');
}
{ # again, this time with DESTROY
director_finalizer::resetStatus();
my $f = MyFoo->new();
director_finalizer::launder($f);
is(director_finalizer::getStatus(), 0, 'wrap release does not fire destructor');
$f->DESTROY();
is(director_finalizer::getStatus(), 3, 'DESTROY method still fires destructor');
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DISOWN();
is(director_finalizer::getStatus(), 0, 'shadow release does not fire destructor of disowned object');
director_finalizer::deleteFoo($f);
is(director_finalizer::getStatus(), 3, 'c++ release fires destructors of disowned object');
}
{ # again, this time with DESTROY
my $f = MyFoo->new();
$f->DISOWN();
director_finalizer::deleteFoo($f);
director_finalizer::resetStatus();
$f->DESTROY();
is(director_finalizer::getStatus(), 0, 'DESTROY method does not fire destructor of disowned object');
}
{
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DISOWN();
my $g = director_finalizer::launder($f);
undef $f;
director_finalizer::deleteFoo($g);
is(director_finalizer::getStatus(), 3, 'c++ release fires destructors on disowned opaque object');
}
{ # again, this time with DESTROY
director_finalizer::resetStatus();
my $f = MyFoo->new();
$f->DISOWN();
my $g = director_finalizer::launder($f);
$f->DESTROY();
director_finalizer::deleteFoo($g);
is(director_finalizer::getStatus(), 3, 'c++ release fires destructors on disowned opaque object after DESTROY');
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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