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

1
.travis.yml
View file

@ -57,3 +57,4 @@ script:
branches:
only:
- master
- perl5-directors-minimal

366
Doc/Manual/Perl5.html
View file

@ -68,6 +68,15 @@
<li><a href="#Perl5_nn46">Modifying the proxy methods</a>
</ul>
<li><a href="#Perl5_nn47">Adding additional Perl code</a>
<li><a href="#Perl5_directors">Cross language polymorphism</a>
<ul>
<li><a href="#Perl5_nn48">Enabling directors</a>
<li><a href="#Perl5_nn49">Director classes</a>
<li><a href="#Perl5_nn50">Ownership and object destruction</a>
<li><a href="#Perl5_nn51">Exception unrolling</a>
<li><a href="#Perl5_nn52">Overhead and code bloat</a>
<li><a href="#Perl5_nn53">Typemaps</a>
</ul>
</ul>
</div>
<!-- INDEX -->
@ -2993,6 +3002,363 @@ set_transform($im, $a);
</pre>
</div>
<H2><a name="Perl5_directors"></a>31.11 Cross language polymorphism</H2>
<p>
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.
</p>
<p>
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.
</p>
<p>
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.
</p>
<H3><a name="Perl5_nn48"></a>31.11.1 Enabling directors</H3>
<p>
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:
</p>
<div class="code">
<pre>
%module(directors="1") modulename
</pre>
</div>
<p>
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:
</p>
<div class="code">
<pre>
// generate directors for all classes that have virtual methods
%feature("director");
// generate directors for all virtual methods in class Foo
%feature("director") Foo;
</pre>
</div>
<p>
You can use the %feature("nodirector") directive to turn off
directors for specific classes or methods. So for example,
</p>
<div class="code">
<pre>
%feature("director") Foo;
%feature("nodirector") Foo::bar;
</pre>
</div>
<p>
will generate directors for all virtual methods of class Foo except
bar().
</p>
<p>
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()):
</p>
<div class="code">
<pre>
%feature("director") Foo;
class Foo {
public:
Foo(int foo);
virtual void one();
virtual void two();
};
class Bar: public Foo {
public:
virtual void three();
};
</pre>
</div>
<p>
then at the Perl side you can define
</p>
<div class="targetlang">
<pre>
use mymodule;
package MyFoo;
use base 'mymodule::Foo';
sub one {
print "one from Perl\n";
}
</pre>
</div>
<H3><a name="Perl5_nn49"></a>31.11.2 Director classes</H3>
<p>
For each class that has directors enabled, SWIG generates a new class
that derives from both the class in question and a special
<tt>Swig::Director</tt> 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.
</p>
<p>
For simplicity let's ignore the <tt>Swig::Director</tt> 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.
</p>
<p>
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).
</p>
<p>
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.
</p>
<p>
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 <i>derived</i> 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.
</p>
<H3><a name="Perl5_nn50"></a>31.11.3 Ownership and object destruction</H3>
<p>
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.
</p>
<p>
This relationship can be reversed by calling the special
<tt>DISOWN()</tt> 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.
</p>
<p>
Also note that due to the proxy implementation, the <tt>DESTROY()</tt>
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 <tt>DESTROY()</tt>
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:
</p>
<div class="targetlang">
<pre>
sub DESTROY {
my($self, $final) = @_;
if($final) {
# real teardown code
}
shift-&gt;SUPER::DESTROY(@_);
}
</pre>
</div>
<H3><a name="Perl5_nn51"></a>31.11.4 Exception unrolling</H3>
<p>
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:
</p>
<div class="code">
<pre>
%feature("director:except") {
if ($error != NULL) {
throw Swig::DirectorMethodException();
}
}
</pre>
</div>
<p>
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.
</p>
<p>
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
<tt>director:except</tt> handler shown above. Here is an example of a
suitable exception handler:
</p>
<div class="code">
<pre>
%exception {
try { $action }
catch (Swig::DirectorException &amp;e) { SWIG_fail; }
}
</pre>
</div>
<p>
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.
</p>
<H3><a name="Perl5_nn52"></a>31.11.5 Overhead and code bloat</H3>
<p>
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++.
</p>
<p>
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.
</p>
<p>
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.
</p>
<H3><a name="Perl5_nn53"></a>31.11.6 Typemaps</H3>
<p>
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.
</p>
</body>

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

352
Lib/perl5/director.swg Normal file
View file

@ -0,0 +1,352 @@
/* -----------------------------------------------------------------------------
* 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 <string>
#include <iostream>
#include <exception>
#include <vector>
#include <map>
/*
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 <map>
namespace Swig {
class Director;
SWIGINTERN std::map<void*,Director*>& get_rtdir_map() {
static std::map<void*,Director*> 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<void*,Director*>::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<void*>(ARG))
# define SWIG_DIRECTOR_RGTR(ARG1, ARG2) Swig::set_rtdir(static_cast<void*>(ARG1), ARG2)
#else
# define SWIG_DIRECTOR_CAST(ARG) dynamic_cast<Swig::Director *>(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 <typename Type>
struct GCItem_T : GCItem
{
GCItem_T(Type *ptr) : _ptr(ptr)
{
}
virtual ~GCItem_T()
{
delete _ptr;
}
private:
Type *_ptr;
};
template <typename Type>
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 = sv_mortalcopy(ERRSV))
: 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);
}
};
/* 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<void*, GCItem_var> swig_ownership_map;
mutable swig_ownership_map swig_owner;
public:
template <typename Type>
void swig_acquire_ownership_array(Type *vptr) const
{
if (vptr) {
swig_owner[vptr] = new GCArray_T<Type>(vptr);
}
}
template <typename Type>
void swig_acquire_ownership(Type *vptr) const
{
if (vptr) {
swig_owner[vptr] = new GCItem_T<Type>(vptr);
}
}
void swig_acquire_ownership_obj(void *vptr, int own) const
{
if (vptr && own) {
swig_owner[vptr] = new GCItem_Object(own);
}
}
int swig_release_ownership(void *vptr) const
{
int own = 0;
if (vptr) {
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;
}
};
}
#endif /* __cplusplus */
#endif

5
Lib/perl5/perlrun.swg
View file

@ -20,6 +20,7 @@
#define SWIG_ConvertPtr(obj, pp, type, flags) SWIG_Perl_ConvertPtr(SWIG_PERL_OBJECT_CALL obj, pp, type, flags)
#define SWIG_ConvertPtrAndOwn(obj, pp, type, flags,own) SWIG_Perl_ConvertPtrAndOwn(SWIG_PERL_OBJECT_CALL obj, pp, type, flags, own)
#define SWIG_NewPointerObj(p, type, flags) SWIG_Perl_NewPointerObj(SWIG_PERL_OBJECT_CALL p, type, flags)
#define swig_owntype int
/* for raw packed data */
#define SWIG_ConvertPacked(obj, p, s, type) SWIG_Perl_ConvertPacked(SWIG_PERL_OBJECT_CALL obj, p, s, type)
@ -288,7 +289,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;
}
{

6
Lib/perl5/perltypemaps.swg
View file

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

754
Source/Modules/perl5.cxx
View file

@ -79,8 +79,11 @@ static String *variable_tab = 0;
static File *f_begin = 0;
static File *f_runtime = 0;
static File *f_runtime_h = 0;
static File *f_header = 0;
static File *f_wrappers = 0;
static File *f_directors = 0;
static File *f_directors_h = 0;
static File *f_init = 0;
static File *f_pm = 0;
static String *pm; /* Package initialization code */
@ -124,6 +127,7 @@ public:
Printv(argc_template_string, "items", NIL);
Clear(argv_template_string);
Printv(argv_template_string, "ST(%d)", NIL);
director_language = 1;
}
/* Test to see if a type corresponds to something wrapped with a shadow class */
@ -219,9 +223,63 @@ 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 +290,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 +307,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 +329,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 +342,27 @@ public:
Node *options = Getattr(mod, "options");
module = Copy(Getattr(n,"name"));
if (directorsEnabled()) {
Swig_banner(f_directors_h);
Printf(f_directors_h, "\n");
Printf(f_directors_h, "#ifndef SWIG_%s_WRAP_H_\n", module);
Printf(f_directors_h, "#define SWIG_%s_WRAP_H_\n\n", module);
if (dirprot_mode()) {
Printf(f_directors_h, "#include <map>\n");
Printf(f_directors_h, "#include <string>\n\n");
}
Printf(f_directors, "\n\n");
Printf(f_directors, "/* ---------------------------------------------------\n");
Printf(f_directors, " * C++ director class methods\n");
Printf(f_directors, " * --------------------------------------------------- */\n\n");
if (outfile_h) {
String *filename = Swig_file_filename(outfile_h);
Printf(magic, "#include \"%s\"\n\n", filename);
Delete(filename);
}
}
if (verbose > 0) {
fprintf(stdout, "top: using module: %s\n", Char(module));
}
@ -374,6 +468,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 +625,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 +669,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 +830,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 +1470,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", 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);
}
}
return SWIG_OK;
}
@ -1494,7 +1679,37 @@ 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 +1727,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 +1968,542 @@ public:
String *defaultExternalRuntimeFilename() {
return NewString("swigperlrun.h");
}
virtual int classDirectorInit(Node *n) {
String *declaration = Swig_director_declaration(n);
Printf(f_directors_h, "\n");
Printf(f_directors_h, "%s\n", declaration);
Printf(f_directors_h, "public:\n");
Delete(declaration);
return Language::classDirectorInit(n);
}
virtual int classDirectorEnd(Node *n) {
if (dirprot_mode()) {
/*
This implementation uses a std::map<std::string,int>.
It should be possible to rewrite it using a more elegant way,
like copying the Java approach for the 'override' array.
But for now, this seems to be the least intrusive way.
*/
Printf(f_directors_h, "\n\n");
Printf(f_directors_h, "/* Internal Director utilities */\n");
Printf(f_directors_h, "public:\n");
Printf(f_directors_h, " bool swig_get_inner(const char* swig_protected_method_name) const {\n");
Printf(f_directors_h, " std::map<std::string, bool>::const_iterator iv = swig_inner.find(swig_protected_method_name);\n");
Printf(f_directors_h, " return (iv != swig_inner.end() ? iv->second : false);\n");
Printf(f_directors_h, " }\n\n");
Printf(f_directors_h, " void swig_set_inner(const char* swig_protected_method_name, bool val) const\n");
Printf(f_directors_h, " { swig_inner[swig_protected_method_name] = val;}\n\n");
Printf(f_directors_h, "private:\n");
Printf(f_directors_h, " mutable std::map<std::string, bool> swig_inner;\n");
}
Printf(f_directors_h, "};\n");
return Language::classDirectorEnd(n);
}
virtual int classDirectorConstructor(Node *n) {
Node *parent = Getattr(n, "parentNode");
String *sub = NewString("");
String *decl = Getattr(n, "decl");
String *supername = Swig_class_name(parent);
String *classname = NewString("");
Printf(classname, "SwigDirector_%s", supername);
/* insert self parameter */
Parm *p;
ParmList *superparms = Getattr(n, "parms");
ParmList *parms = CopyParmList(superparms);
String *type = NewString("SV");
SwigType_add_pointer(type);
p = NewParm(type, NewString("self"), n);
set_nextSibling(p, parms);
parms = p;
if (!Getattr(n, "defaultargs")) {
/* constructor */
{
Wrapper *w = NewWrapper();
String *call;
String *basetype = Getattr(parent, "classtype");
String *target = Swig_method_decl(0, decl, classname, parms, 0, 0);
call = Swig_csuperclass_call(0, basetype, superparms);
Printf(w->def, "%s::%s: %s, Swig::Director(self) { \n", classname, target, call);
Printf(w->def, " SWIG_DIRECTOR_RGTR((%s *)this, this); \n", basetype);
Append(w->def, "}\n");
Delete(target);
Wrapper_print(w, f_directors);
Delete(call);
DelWrapper(w);
}
/* constructor header */
{
String *target = Swig_method_decl(0, decl, classname, parms, 0, 1);
Printf(f_directors_h, " %s;\n", target);
Delete(target);
}
}
Delete(sub);
Delete(classname);
Delete(supername);
Delete(parms);
return Language::classDirectorConstructor(n);
}
virtual int classDirectorMethod(Node *n, Node *parent, String *super) {
int is_void = 0;
int is_pointer = 0;
String *decl = Getattr(n, "decl");
String *name = Getattr(n, "name");
String *classname = Getattr(parent, "sym:name");
String *c_classname = Getattr(parent, "name");
String *symname = Getattr(n, "sym:name");
String *declaration = NewString("");
ParmList *l = Getattr(n, "parms");
Wrapper *w = NewWrapper();
String *tm;
String *wrap_args = NewString("");
String *returntype = Getattr(n, "type");
String *value = Getattr(n, "value");
String *storage = Getattr(n, "storage");
bool pure_virtual = false;
int status = SWIG_OK;
int idx;
bool ignored_method = GetFlag(n, "feature:ignore") ? true : false;
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 (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 *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;
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");
if ((tm = Getattr(p, "tmap:directorin")) != 0) {
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);
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);
}
/* add the method name as a PyString */
String *pyname = Getattr(n, "sym:name");
/* 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", "ERRSV");
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", "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");
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);
/* 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);
}
}
Delete(parse_args);
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);
}
}
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, "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);
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;
}
};
/* -----------------------------------------------------------------------------