diff options
40 files changed, 2740 insertions, 5 deletions
diff --git a/.travis.yml b/.travis.yml index 70cbb2f27..2b860cc9e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -57,3 +57,4 @@ script: branches: only: - master + - perl5-directors-minimal diff --git a/Doc/Manual/Perl5.html b/Doc/Manual/Perl5.html index 49e8965fa..db8c0e602 100644 --- a/Doc/Manual/Perl5.html +++ b/Doc/Manual/Perl5.html @@ -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->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 &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> diff --git a/Examples/perl5/callback/Makefile b/Examples/perl5/callback/Makefile new file mode 100644 index 000000000..544d13642 --- /dev/null +++ b/Examples/perl5/callback/Makefile @@ -0,0 +1,20 @@ +TOP = ../.. +SWIG = $(TOP)/../preinst-swig +CXXSRCS = example.cxx +TARGET = example +INTERFACE = example.i +LIBS = -lm + +check: build + $(MAKE) -f $(TOP)/Makefile perl5_run + +build: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='$(TARGET)' INTERFACE='$(INTERFACE)' perl5_cpp + +static: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='myperl' INTERFACE='$(INTERFACE)' perl5_cpp_static + +clean: + $(MAKE) -f $(TOP)/Makefile perl5_clean diff --git a/Examples/perl5/callback/example.cxx b/Examples/perl5/callback/example.cxx new file mode 100644 index 000000000..450d75608 --- /dev/null +++ b/Examples/perl5/callback/example.cxx @@ -0,0 +1,4 @@ +/* File : example.cxx */ + +#include "example.h" + diff --git a/Examples/perl5/callback/example.h b/Examples/perl5/callback/example.h new file mode 100644 index 000000000..1a0e8c432 --- /dev/null +++ b/Examples/perl5/callback/example.h @@ -0,0 +1,23 @@ +/* File : example.h */ + +#include <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(); } +}; + diff --git a/Examples/perl5/callback/example.i b/Examples/perl5/callback/example.i new file mode 100644 index 000000000..5f9072e61 --- /dev/null +++ b/Examples/perl5/callback/example.i @@ -0,0 +1,17 @@ +/* File : example.i */ +%module(directors="1") example +%{ +#include "example.h" +%} + +%include "std_string.i" + +/* turn on director wrapping Callback */ +%feature("director") Callback; + +/* Caller::setCallback(Callback *cb) gives ownership of the cb to the + * Caller object. The wrapper code should understand this. */ +%apply SWIGTYPE *DISOWN { Callback *cb }; + +%include "example.h" + diff --git a/Examples/perl5/callback/index.html b/Examples/perl5/callback/index.html new file mode 100644 index 000000000..82f5e972a --- /dev/null +++ b/Examples/perl5/callback/index.html @@ -0,0 +1,20 @@ +<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> diff --git a/Examples/perl5/callback/runme.pl b/Examples/perl5/callback/runme.pl new file mode 100644 index 000000000..a6b80d988 --- /dev/null +++ b/Examples/perl5/callback/runme.pl @@ -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"; diff --git a/Examples/perl5/check.list b/Examples/perl5/check.list index e15f02e18..925bd263f 100644 --- a/Examples/perl5/check.list +++ b/Examples/perl5/check.list @@ -4,7 +4,6 @@ constants constants2 funcptr import -java multimap multiple_inheritance pointer @@ -12,3 +11,5 @@ reference simple value variables +callback +extend diff --git a/Examples/perl5/extend/Makefile b/Examples/perl5/extend/Makefile new file mode 100644 index 000000000..544d13642 --- /dev/null +++ b/Examples/perl5/extend/Makefile @@ -0,0 +1,20 @@ +TOP = ../.. +SWIG = $(TOP)/../preinst-swig +CXXSRCS = example.cxx +TARGET = example +INTERFACE = example.i +LIBS = -lm + +check: build + $(MAKE) -f $(TOP)/Makefile perl5_run + +build: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='$(TARGET)' INTERFACE='$(INTERFACE)' perl5_cpp + +static: + $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \ + TARGET='myperl' INTERFACE='$(INTERFACE)' perl5_cpp_static + +clean: + $(MAKE) -f $(TOP)/Makefile perl5_clean diff --git a/Examples/perl5/extend/example.cxx b/Examples/perl5/extend/example.cxx new file mode 100644 index 000000000..450d75608 --- /dev/null +++ b/Examples/perl5/extend/example.cxx @@ -0,0 +1,4 @@ +/* File : example.cxx */ + +#include "example.h" + diff --git a/Examples/perl5/extend/example.h b/Examples/perl5/extend/example.h new file mode 100644 index 000000000..b27ab9711 --- /dev/null +++ b/Examples/perl5/extend/example.h @@ -0,0 +1,56 @@ +/* File : example.h */ + +#include <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; + } +}; + diff --git a/Examples/perl5/extend/example.i b/Examples/perl5/extend/example.i new file mode 100644 index 000000000..f5e142b88 --- /dev/null +++ b/Examples/perl5/extend/example.i @@ -0,0 +1,20 @@ +/* File : example.i */ +%module(directors="1") example +%{ +#include "example.h" +%} + +%include "std_vector.i" +%include "std_string.i" + +/* turn on director wrapping for Manager */ +%feature("director") Employee; +%feature("director") Manager; + +/* EmployeeList::addEmployee(Employee *p) gives ownership of the + * employee to the EmployeeList object. The wrapper code should + * understand this. */ +%apply SWIGTYPE *DISOWN { Employee *p }; + +%include "example.h" + diff --git a/Examples/perl5/extend/index.html b/Examples/perl5/extend/index.html new file mode 100644 index 000000000..e9d886bcf --- /dev/null +++ b/Examples/perl5/extend/index.html @@ -0,0 +1,19 @@ +<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> diff --git a/Examples/perl5/extend/runme.pl b/Examples/perl5/extend/runme.pl new file mode 100644 index 000000000..76ee849a4 --- /dev/null +++ b/Examples/perl5/extend/runme.pl @@ -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"; diff --git a/Examples/perl5/index.html b/Examples/perl5/index.html index db46023c4..23c8ff658 100644 --- a/Examples/perl5/index.html +++ b/Examples/perl5/index.html @@ -20,6 +20,8 @@ certain C declarations are turned into constants. <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> diff --git a/Examples/test-suite/perl5/director_abstract_runme.pl b/Examples/test-suite/perl5/director_abstract_runme.pl new file mode 100644 index 000000000..d369eac17 --- /dev/null +++ b/Examples/test-suite/perl5/director_abstract_runme.pl @@ -0,0 +1,62 @@ +use strict; +use warnings; +use Test::More tests => 13; +BEGIN { use_ok('director_abstract') } +require_ok('director_abstract'); + +{ + package MyFoo; + use base 'director_abstract::Foo'; + sub ping { + return 'MyFoo::ping()'; + } +} + +my $f = MyFoo->new(); + +is($f->ping, "MyFoo::ping()"); + +is($f->pong(),"Foo::pong();MyFoo::ping()"); + +{ + package MyExample1; + use base 'director_abstract::Example1'; + sub Color { my($self, $r, $g, $b) = @_; + return $r; + } +} +{ + package MyExample2; + use base 'director_abstract::Example2'; + sub Color { my($self, $r, $g, $b) = @_; + return $g; + } +} +{ + package MyExample3; + use base 'director_abstract::Example3_i'; + sub Color { my($self, $r, $g, $b) = @_; + return $b; + } +} + +my $me1 = MyExample1->new(); +isa_ok($me1, 'MyExample1'); +is(director_abstract::Example1::get_color($me1, 1, 2, 3), 1, 'me1'); + +my $me2 = MyExample2->new(1,2); +isa_ok($me2, 'MyExample2'); +is(director_abstract::Example2::get_color($me2, 1, 2, 3), 2, 'me2'); + +my $me3 = MyExample3->new(); +isa_ok($me3, 'MyExample3'); +is(director_abstract::Example3_i::get_color($me3, 1, 2, 3), 3, 'me3'); + +eval { $me1 = director_abstract::Example1->new() }; +like($@, qr/\babstract\b/i, 'E1.new()'); + +eval { $me2 = director_abstract::Example2->new() }; +like($@, qr/Example2/, 'E2.new()'); + +eval { $me3 = director_abstract::Example3_i->new() }; +like($@, qr/\babstract\b/i, 'E3.new()'); diff --git a/Examples/test-suite/perl5/director_alternating_runme.pl b/Examples/test-suite/perl5/director_alternating_runme.pl new file mode 100644 index 000000000..83d30af6d --- /dev/null +++ b/Examples/test-suite/perl5/director_alternating_runme.pl @@ -0,0 +1,8 @@ +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok('director_alternating') } +require_ok('director_alternating'); + +my $id = director_alternating::getBar()->id(); +is($id, director_alternating::idFromGetBar(), "got Bar id"); diff --git a/Examples/test-suite/perl5/director_basic_runme.pl b/Examples/test-suite/perl5/director_basic_runme.pl new file mode 100644 index 000000000..55e70dc9c --- /dev/null +++ b/Examples/test-suite/perl5/director_basic_runme.pl @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More tests => 12; +BEGIN { use_ok 'director_basic' } +require_ok 'director_basic'; + +{ + package MyFoo; + use base 'director_basic::Foo'; + sub ping { + return 'MyFoo::ping()'; + } +} + +{ + package MyOverriddenClass; + use base 'director_basic::MyClass'; + use fields qw(expectNull nonNullReceived); + sub new { + my $self = shift->SUPER::new(@_); + $self->{expectNull} = undef; + $self->{nonNullReceived} = undef; + return $self; + } + sub pmethod { my($self, $b) = @_; + die "null not received as expected" + if $self->{expectNull} and defined $b; + return $b; + } +} + +{ + my $a = MyFoo->new(); + isa_ok $a, 'MyFoo'; + is $a->ping(), 'MyFoo::ping()', 'a.ping()'; + is $a->pong(), 'Foo::pong();MyFoo::ping()', 'a.pong()'; + + my $b = director_basic::Foo->new(); + isa_ok $b, 'director_basic::Foo'; + is $b->ping(), 'Foo::ping()', 'b.ping()'; + is $b->pong(), 'Foo::pong();Foo::ping()', 'b.pong()'; + + my $a1 = director_basic::A1->new(1, undef); + isa_ok $a1, 'director_basic::A1'; + is $a1->rg(2), 2, 'A1.rg'; + + my $my = MyOverriddenClass->new(); + $my->{expectNull} = 1; + is(director_basic::MyClass::call_pmethod($my, undef), undef, + 'null pointer marshalling'); + + my $myBar = director_basic::Bar->new(); + $my->{expectNull} = undef; + my $myNewBar = director_basic::MyClass::call_pmethod($my, $myBar); + isnt($myNewBar, undef, 'non-null pointer marshalling'); + $myNewBar->{x} = 10; +} diff --git a/Examples/test-suite/perl5/director_classes_runme.pl b/Examples/test-suite/perl5/director_classes_runme.pl new file mode 100644 index 000000000..a4fddeed9 --- /dev/null +++ b/Examples/test-suite/perl5/director_classes_runme.pl @@ -0,0 +1,70 @@ +use strict; +use warnings; +use Test::More tests => 29; +BEGIN { use_ok 'director_classes' } +require_ok 'director_classes'; + +{ + package PerlDerived; + use base 'director_classes::Base'; + sub Val { $_[1] } + sub Ref { $_[1] } + sub Ptr { $_[1] } + sub FullyOverloaded { + my $rv = shift->SUPER::FullyOverloaded(@_); + $rv =~ s/Base/__PACKAGE__/sge; + return $rv; + } + sub SemiOverloaded { + # this is going to be awkward because we can't really + # semi-overload in Perl, but we can sort of fake it. + return shift->SUPER::SemiOverloaded(@_) unless $_[0] =~ /^\d+/; + my $rv = shift->SUPER::SemiOverloaded(@_); + $rv =~ s/Base/__PACKAGE__/sge; + return $rv; + } + sub DefaultParms { + my $rv = shift->SUPER::DefaultParms(@_); + $rv =~ s/Base/__PACKAGE__/sge; + return $rv; + } +} + +{ + my $c = director_classes::Caller->new(); + makeCalls($c, director_classes::Base->new(100.0)); + makeCalls($c, director_classes::Derived->new(200.0)); + makeCalls($c, PerlDerived->new(300.0)); +} + +sub makeCalls { my($caller, $base) = @_; + my $bname = ref $base; + $bname = $1 if $bname =~ /^director_classes::(.*)$/; + $caller->set($base); + my $dh = director_classes::DoubleHolder->new(444.555); + is($caller->ValCall($dh)->{val}, $dh->{val}, "$bname.Val"); + is($caller->RefCall($dh)->{val}, $dh->{val}, "$bname.Ref"); + is($caller->PtrCall($dh)->{val}, $dh->{val}, "$bname.Ptr"); + is($caller->FullyOverloadedCall(1), + "${bname}::FullyOverloaded(int)", + "$bname.FullyOverloaded(int)"); + is($caller->FullyOverloadedCall(''), + "${bname}::FullyOverloaded(bool)", + "$bname.FullyOverloaded(bool)"); +TODO: { + local $TODO = 'investigation needed here' if $bname eq 'PerlDerived'; + is($caller->SemiOverloadedCall(-678), + "${bname}::SemiOverloaded(int)", + "$bname.SemiOverloaded(int)"); +} + is($caller->SemiOverloadedCall(''), + "Base::SemiOverloaded(bool)", + "$bname.SemiOverloaded(bool)"); + is($caller->DefaultParmsCall(10, 2.2), + "${bname}::DefaultParms(int, double)", + "$bname.DefaultParms(int, double)"); + is($caller->DefaultParmsCall(10), + "${bname}::DefaultParms(int)", + "$bname.DefaultParms(int)"); + $caller->reset(); +} diff --git a/Examples/test-suite/perl5/director_classic_runme.pl b/Examples/test-suite/perl5/director_classic_runme.pl new file mode 100644 index 000000000..2fa4fde56 --- /dev/null +++ b/Examples/test-suite/perl5/director_classic_runme.pl @@ -0,0 +1,128 @@ +use strict; +use warnings; +use Test::More tests => 41; +BEGIN { use_ok('director_classic') } +require_ok('director_classic'); + +{ + package TargetLangPerson; + use base 'director_classic::Person'; + sub id { return 'TargetLangPerson' } +} + +{ + package TargetLangChild; + use base 'director_classic::Child'; + sub id { return 'TargetLangChild' } +} + +{ + package TargetLangGrandChild; + use base 'director_classic::GrandChild'; + sub id { return 'TargetLangGrandChild' } +} + +# Semis - don't override id() in target language +{ + package TargetLangSemiPerson; + use base 'director_classic::Person'; + # No id() override +} + +{ + package TargetLangSemiChild; + use base 'director_classic::Child'; + # No id() override +} + +{ + package TargetLangSemiGrandChild; + use base 'director_classic::GrandChild'; + # No id() override +} + +# Orphans - don't override id() in C++ +{ + package TargetLangOrphanPerson; + use base 'director_classic::OrphanPerson'; + sub id { return "TargetLangOrphanPerson" } +} + +{ + package TargetLangOrphanChild; + use base 'director_classic::OrphanChild'; + sub id { return "TargetLangOrphanChild" } +} + +sub check { my($person, $expected) = @_; + # Normal target language polymorphic call + is($person->id(), $expected, "$expected from Perl"); + + # Polymorphic call from C++ + my $caller = director_classic::Caller->new(); + $caller->setCallback($person); + is($caller->call(), $expected, "$expected from C++"); + + # Polymorphic call of object created in target language and passed to C++ and back again + my $baseclass = $caller->baseClass(); + is($baseclass->id(), $expected, "$expected after bounce"); + + $caller->resetCallback(); +} + +my $person; + +$person = director_classic::Person->new(); +check($person, "Person"); +undef $person; + +$person = director_classic::Child->new(); +check($person, "Child"); +undef $person; + +$person = director_classic::GrandChild->new(); +check($person, "GrandChild"); +undef $person; + +$person = TargetLangPerson->new(); +check($person, "TargetLangPerson"); +undef $person; + +$person = TargetLangChild->new(); +check($person, "TargetLangChild"); +undef $person; + +$person = TargetLangGrandChild->new(); +check($person, "TargetLangGrandChild"); +undef $person; + +# Semis - don't override id() in target language +$person = TargetLangSemiPerson->new(); +check($person, "Person"); +undef $person; + +$person = TargetLangSemiChild->new(); +check($person, "Child"); +undef $person; + +$person = TargetLangSemiGrandChild->new(); +check($person, "GrandChild"); +undef $person; + +# Orphans - don't override id() in C++ +$person = director_classic::OrphanPerson->new(); +check($person, "Person"); +undef $person; + +$person = director_classic::OrphanChild->new(); +check($person, "Child"); +undef $person; + +$person = TargetLangOrphanPerson->new(); +check($person, "TargetLangOrphanPerson"); +undef $person; + +$person = TargetLangOrphanChild->new(); +check($person, "TargetLangOrphanChild"); +undef $person; + diff --git a/Examples/test-suite/perl5/director_constructor_runme.pl b/Examples/test-suite/perl5/director_constructor_runme.pl new file mode 100644 index 000000000..c990fc3a1 --- /dev/null +++ b/Examples/test-suite/perl5/director_constructor_runme.pl @@ -0,0 +1,46 @@ +use strict; +use warnings; +use Test::More tests => 9; +BEGIN { use_ok 'director_constructor' } +require_ok 'director_constructor'; + +{ + package Test; + use base 'director_constructor::Foo'; + sub doubleit { my($self) = @_; + $self->{a} *= 2; + } + sub test { 3 } +} +my $t = Test->new(5); +isa_ok $t, 'Test'; +is $t->getit, 5; +is $t->do_test, 3; + +$t->doubleit(); + +is $t->getit, 10; + +{ + package Wrong; + use base 'director_constructor::Foo'; + sub doubleit { my($self) = @_; + # calling this should trigger a type error on attribute + # assignment + $self->{a} = {}; + } + sub test { + # if c++ calls this, retval copyout should trigger a type error + return bless {}, 'TotallyBogus'; + } +} + +# TODO: these TypeErrors in director classes should be more detailed +my $w = Wrong->new(12); +is eval { $w->doubleit() }, undef; +like $@, qr/TypeError/; +is $w->getit(), 12, 'W.a should be unaffected'; + +# TODO: this is giving an unhandled C++ exception right now +#is eval { $W->do_test() }, undef; +#like $@, qr/TypeError/; diff --git a/Examples/test-suite/perl5/director_default_runme.pl b/Examples/test-suite/perl5/director_default_runme.pl new file mode 100644 index 000000000..281c8ebd3 --- /dev/null +++ b/Examples/test-suite/perl5/director_default_runme.pl @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More tests => 6; +BEGIN { use_ok 'director_default' } +require_ok 'director_default'; + +my $f; + +$f = director_default::Foo->new(); +isa_ok $f, 'director_default::Foo'; +$f = director_default::Foo->new(1); +isa_ok $f, 'director_default::Foo'; + + +$f = director_default::Bar->new(); +isa_ok $f, 'director_default::Bar'; +$f = director_default::Bar->new(1); +isa_ok $f, 'director_default::Bar'; diff --git a/Examples/test-suite/perl5/director_detect_runme.pl b/Examples/test-suite/perl5/director_detect_runme.pl new file mode 100644 index 000000000..3e2c652cb --- /dev/null +++ b/Examples/test-suite/perl5/director_detect_runme.pl @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More tests => 9; +BEGIN { use_ok 'director_detect' } +require_ok 'director_detect'; + +{ + package MyBar; + use base 'director_detect::Bar'; + sub new { my $class = shift; + my $val = @_ ? shift : 2; + my $self = $class->SUPER::new(); + $self->{val} = $val; + return $self; + } + sub get_value { my($self) = @_; + $self->{val}++; + return $self->{val}; + } + sub get_class { my($self) = @_; + $self->{val}++; + return director_detect::A->new(); + } + sub just_do_it { my($self) = @_; + $self->{val}++; + } + sub clone { my($self) = @_; + MyBar->new($self->{val}); + } +} + +my $b = MyBar->new(); +isa_ok $b, 'MyBar'; + +my $f = $b->baseclass(); +isa_ok $f, 'director_detect::Foo'; +is $f->get_value(), 3; + +isa_ok $f->get_class(), 'director_detect::A'; +$f->just_do_it(); + +my $c = $b->clone(); +isa_ok $c, 'MyBar'; +is $b->{val}, 5; +is $c->get_value(), 6; diff --git a/Examples/test-suite/perl5/director_enum_runme.pl b/Examples/test-suite/perl5/director_enum_runme.pl new file mode 100644 index 000000000..6d58b376e --- /dev/null +++ b/Examples/test-suite/perl5/director_enum_runme.pl @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok 'director_enum' } +require_ok 'director_enum'; + +{ + package MyFoo; + use base 'director_enum::Foo'; + sub say_hi { my($self, $val) = @_; + return $val; + } +} + +my $b = director_enum::Foo->new(); +isa_ok $b, 'director_enum::Foo'; +my $a = MyFoo->new(); +isa_ok $a, 'MyFoo'; + +is $a->say_hi($director_enum::hello), + $a->say_hello($director_enum::hi); diff --git a/Examples/test-suite/perl5/director_exception_runme.pl b/Examples/test-suite/perl5/director_exception_runme.pl new file mode 100644 index 000000000..62c103b6c --- /dev/null +++ b/Examples/test-suite/perl5/director_exception_runme.pl @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More tests => 7; +BEGIN { use_ok 'director_exception' } +require_ok 'director_exception'; + +{ + package MyFoo; + use base 'director_exception::Foo'; + sub ping { + die "MyFoo::ping() EXCEPTION"; + } +} +{ + package MyFoo2; + use base 'director_exception::Foo'; + sub ping { + # error should return a string + return bless [ 1 ], 'main'; + } +} +{ + package MyFoo3; + use base 'director_exception::Foo'; + sub ping { + # error should return a string + return sub { 1 } + } +} + +{ + my $a = MyFoo->new(); + my $b = director_exception::launder($a); + eval { $b->pong() }; + like($@, qr/\bMyFoo::ping\(\) EXCEPTION\b/, + 'MyFoo.pong() error content preserved'); +} +{ + my $a = MyFoo2->new(); + my $b = director_exception::launder($a); + eval { $b->pong() }; + like($@, qr/\bTypeError\b/, + 'MyFoo2.pong() error content preserved'); +} +{ + my $a = MyFoo3->new(); + my $b = director_exception::launder($a); + eval { $b->pong() }; + like($@, qr/\bTypeError\b/, + 'MyFoo2.pong() error content preserved'); +} + +eval { die director_exception::Exception1->new() }; +isa_ok($@, 'director_exception::Exception1', 'Exception1'); + +eval { die director_exception::Exception2->new() }; +isa_ok($@, 'director_exception::Exception2', 'Exception2'); diff --git a/Examples/test-suite/perl5/director_extend_runme.pl b/Examples/test-suite/perl5/director_extend_runme.pl new file mode 100644 index 000000000..c3d7fb934 --- /dev/null +++ b/Examples/test-suite/perl5/director_extend_runme.pl @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok 'director_extend' } +require_ok 'director_extend'; + +{ + package MyObject; + use base 'director_extend::SpObject'; + sub getFoo { 123 } +} + +my $m = MyObject->new(); +isa_ok $m, 'MyObject'; +is($m->dummy(), 666, '1st call'); +is($m->dummy(), 666, '2nd call'); diff --git a/Examples/test-suite/perl5/director_finalizer_runme.pl b/Examples/test-suite/perl5/director_finalizer_runme.pl new file mode 100644 index 000000000..bcb4002ec --- /dev/null +++ b/Examples/test-suite/perl5/director_finalizer_runme.pl @@ -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'); +} diff --git a/Examples/test-suite/perl5/director_frob_runme.pl b/Examples/test-suite/perl5/director_frob_runme.pl new file mode 100644 index 000000000..0faf440c5 --- /dev/null +++ b/Examples/test-suite/perl5/director_frob_runme.pl @@ -0,0 +1,10 @@ +use strict; +use warnings; +use Test::More tests => 4; +BEGIN { use_ok 'director_frob' } +require_ok 'director_frob'; + +my $foo = director_frob::Bravo->new(); +isa_ok $foo, 'director_frob::Bravo'; + +is($foo->abs_method(), 'Bravo::abs_method()'); diff --git a/Examples/test-suite/perl5/director_ignore_runme.pl b/Examples/test-suite/perl5/director_ignore_runme.pl new file mode 100644 index 000000000..9566f4bb3 --- /dev/null +++ b/Examples/test-suite/perl5/director_ignore_runme.pl @@ -0,0 +1,25 @@ +use strict; +use warnings; +use Test::More tests => 6; +BEGIN { use_ok 'director_ignore' } +require_ok 'director_ignore'; + +{ + package DIgnoresDerived; + use base 'director_ignore::DIgnores'; + sub PublicMethod1 { + return 18.75; + } +} +{ + package DAbstractIgnoresDerived; + use base 'director_ignore::DAbstractIgnores'; +} + +my $a = DIgnoresDerived->new(); +isa_ok $a, 'DIgnoresDerived'; +is $a->Triple(5), 15; + +my $b = DAbstractIgnoresDerived->new(); +isa_ok $b, 'DAbstractIgnoresDerived'; +is $b->Quadruple(5), 20; diff --git a/Examples/test-suite/perl5/director_nested_runme.pl b/Examples/test-suite/perl5/director_nested_runme.pl new file mode 100644 index 000000000..e6c19665a --- /dev/null +++ b/Examples/test-suite/perl5/director_nested_runme.pl @@ -0,0 +1,59 @@ +use strict; +use warnings; +use Test::More tests => 9; +BEGIN { use_ok 'director_nested' } +require_ok 'director_nested'; + +{ + package A; + use base 'director_nested::FooBar_int'; + sub do_step { 'A::do_step;' } + sub get_value { 'A::get_value' } +} + +my $a = A->new(); +isa_ok $a, 'A'; + +is $a->step(), "Bar::step;Foo::advance;Bar::do_advance;A::do_step;", + 'A virtual resolution'; + +{ + package B; + use base 'director_nested::FooBar_int'; + sub do_advance { my($self) = @_; + return "B::do_advance;" . $self->do_step(); + } + sub do_step { "B::do_step;" } + sub get_value { 1 } +} + +my $b = B->new(); +isa_ok $b, 'B'; +is $b->step(), "Bar::step;Foo::advance;B::do_advance;B::do_step;", + 'B virtual resolution'; + +{ + package C; + use base 'director_nested::FooBar_int'; + our $in_do_advance = 0; + sub do_advance { my($self) = @_; + # found a case where upcall didn't happen right in a perl space + # SUPER:: call. + die "SUPERCALL RESOLVE FAILURE" if $in_do_advance; + local $in_do_advance = 1; + return "C::do_advance;" . + $self->SUPER::do_advance(); + } + sub do_step { "C::do_step;" } + sub get_value { 2 } + sub get_name { my($self) = @_; + return $self->director_nested::FooBar_int::get_name() . " hello"; + } +} + +my $cc = C->new(); +isa_ok $cc, 'C'; +my $c = director_nested::FooBar_int::get_self($cc); +$c->advance(); +is $c->get_name(), "FooBar::get_name hello"; +is $c->name(), "FooBar::get_name hello"; diff --git a/Examples/test-suite/perl5/director_primitives_runme.pl b/Examples/test-suite/perl5/director_primitives_runme.pl new file mode 100644 index 000000000..e70f39166 --- /dev/null +++ b/Examples/test-suite/perl5/director_primitives_runme.pl @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More tests => 27; +BEGIN { use_ok 'director_primitives' } +require_ok 'director_primitives'; + +{ + package PerlDerived; + use base 'director_primitives::Base'; + sub NoParmsMethod { + } + sub BoolMethod { my($self, $x) = @_; + return $x; + } + sub IntMethod { my($self, $x) = @_; + return $x; + } + sub UIntMethod { my($self, $x) = @_; + return $x; + } + sub FloatMethod { my($self, $x) = @_; + return $x; + } + sub CharPtrMethod { my($self, $x) = @_; + return $x; + } + sub ConstCharPtrMethod { my($self, $x) = @_; + return $x; + } + sub EnumMethod { my($self, $x) = @_; + return $x; + } + sub ManyParmsMethod { + } +} + +my $myCaller = director_primitives::Caller->new(); +isa_ok $myCaller, 'director_primitives::Caller'; + +{ + my $myBase = director_primitives::Base->new(100.0); + makeCalls($myCaller, $myBase); +} +{ + my $myBase = director_primitives::Derived->new(200.0); + makeCalls($myCaller, $myBase); +} +{ + my $myBase = PerlDerived->new(300.0); + makeCalls($myCaller, $myBase); +} + +sub makeCalls { my($myCaller, $myBase) = @_; + $myCaller->set($myBase); + $myCaller->NoParmsMethodCall(); + is $myCaller->BoolMethodCall(1), '1'; + is $myCaller->BoolMethodCall(0), ''; + is $myCaller->IntMethodCall(-123), -123; + is $myCaller->UIntMethodCall(123), 123; + is $myCaller->FloatMethodCall(-123 / 128), -0.9609375; + is $myCaller->CharPtrMethodCall("test string"), "test string"; + is $myCaller->ConstCharPtrMethodCall("another string"), "another string"; + is $myCaller->EnumMethodCall($director_primitives::HShadowHard), $director_primitives::HShadowHard; + $myCaller->ManyParmsMethodCall(1, -123, 123, 123.456, "test string", "another string", $director_primitives::HShadowHard); + $myCaller->NotOverriddenMethodCall(); + $myCaller->reset(); +} + diff --git a/Examples/test-suite/perl5/director_protected_runme.pl b/Examples/test-suite/perl5/director_protected_runme.pl new file mode 100644 index 000000000..07ed1563e --- /dev/null +++ b/Examples/test-suite/perl5/director_protected_runme.pl @@ -0,0 +1,48 @@ +use strict; +use warnings; +use Test::More tests => 19; +BEGIN { use_ok 'director_protected' } +require_ok 'director_protected'; + +{ + package FooBar; + use base 'director_protected::Bar'; + sub ping { 'FooBar::ping();' } +} +{ + package FooBar2; + use base 'director_protected::Bar'; + sub ping { 'FooBar2::ping();' } + sub pang { 'FooBar2::pang();' } +} + +my $b = director_protected::Bar->new(); +isa_ok $b, 'director_protected::Bar'; +my $f = $b->create(); +my $fb = FooBar->new(); +isa_ok $fb, 'FooBar'; +my $fb2 = FooBar2->new(); +isa_ok $fb2, 'FooBar2'; + +is $b->used(), "Foo::pang();Bar::pong();Foo::pong();Bar::ping();"; +eval { $f->used() }; +like $@, qr/protected member/; +is $fb->used(), "Foo::pang();Bar::pong();Foo::pong();FooBar::ping();"; +is $fb2->used(), "FooBar2::pang();Bar::pong();Foo::pong();FooBar2::ping();"; + +is $b->pong(), "Bar::pong();Foo::pong();Bar::ping();"; +is $f->pong(), "Bar::pong();Foo::pong();Bar::ping();"; +is $fb->pong(), "Bar::pong();Foo::pong();FooBar::ping();"; +is $fb2->pong(), "Bar::pong();Foo::pong();FooBar2::ping();"; + +eval { $b->ping() }; +like $@, qr/protected member/; +eval { $f->ping () }; +like $@, qr/protected member/; +is $fb->ping(), 'FooBar::ping();'; +is $fb2->ping(), 'FooBar2::ping();'; + +eval { $b->pang() }; +like $@, qr/protected member/; +eval { $f->pang() }; +like $@, qr/protected member/; diff --git a/Examples/test-suite/perl5/director_string_runme.pl b/Examples/test-suite/perl5/director_string_runme.pl new file mode 100644 index 000000000..4d996ef0f --- /dev/null +++ b/Examples/test-suite/perl5/director_string_runme.pl @@ -0,0 +1,34 @@ +use strict; +use warnings; +use Test::More tests => 5; +BEGIN { use_ok 'director_string' } +require_ok 'director_string'; + +{ + package B; + use base 'director_string::A'; + our $in_first = 0; + sub get_first { my($self) = @_; + die "SUPER RESOLVE BAD" if $in_first; + local $in_first = 1; + return $self->SUPER::get_first() . " world!"; + } + our $in_process_text = 0; + sub process_text { my($self, $string) = @_; + die "SUPER RESOLVE BAD" if $in_process_text; + local $in_process_text = 1; + $self->SUPER::process_text($string); + $self->{'smem'} = "hello"; + } +} + +my $b = B->new("hello"); +isa_ok $b, 'B'; + +$b->get(0); + +is $b->get_first(), "hello world!"; + +$b->call_process_func(); + +is $b->{'smem'}, "hello"; diff --git a/Examples/test-suite/perl5/director_unroll_runme.pl b/Examples/test-suite/perl5/director_unroll_runme.pl new file mode 100644 index 000000000..572b99834 --- /dev/null +++ b/Examples/test-suite/perl5/director_unroll_runme.pl @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More tests => 3; +BEGIN { use_ok 'director_unroll' }; +require_ok 'director_unroll'; + +{ + package MyFoo; + use base 'director_unroll::Foo'; + sub ping { "MyFoo::ping()" } +} + +$a = MyFoo->new(); +$b = director_unroll::Bar->new(); +$b->set($a); +my $c = $b->get(); +is(${$a->this}, ${$c->this}, "unrolling"); diff --git a/Examples/test-suite/perl5/director_wombat_runme.pl b/Examples/test-suite/perl5/director_wombat_runme.pl new file mode 100644 index 000000000..81f34e71b --- /dev/null +++ b/Examples/test-suite/perl5/director_wombat_runme.pl @@ -0,0 +1,53 @@ +use strict; +use warnings; +use Test::More tests => 9; +BEGIN { use_ok 'director_wombat' } +require_ok 'director_wombat'; + +{ + package director_wombat_Foo_integers_derived; + use base 'director_wombat::Foo_integers'; + sub meth { my($self, $param) = @_; + return $param + 2; + } +} +{ + package director_wombat_Foo_integers_derived_2; + use base 'director_wombat::Foo_integers'; +} +{ + package director_wombat_Bar_derived_1; + use base 'director_wombat::Bar'; + sub foo_meth_ref { my($self, $foo_obj, $param) = @_; + die "foo_obj in foo_meth_ref is not director_wombat_Foo_integers_derived_2" + unless $foo_obj->isa('director_wombat_Foo_integers_derived_2'); + } + sub foo_meth_ptr { my($self, $foo_obj, $param) = @_; + die "foo_obj in foo_meth_ptr is not director_wombat_Foo_integers_derived_2" + unless $foo_obj->isa('director_wombat_Foo_integers_derived_2'); + } + sub foo_meth_val { my($self, $foo_obj, $param) = @_; + die "foo_obj in foo_meth_val is not director_wombat_Foo_integers_derived_2" + unless $foo_obj->isa('director_wombat_Foo_integers_derived_2'); + } +} + +my $b = director_wombat::Bar->new(); +isa_ok $b, 'director_wombat::Bar'; +my $a = $b->meth(); +is $a->meth(49), 49; + +$a = director_wombat_Foo_integers_derived->new(); +isa_ok $a, 'director_wombat_Foo_integers_derived'; +is $a->meth(62), 62 + 2; + +$a = director_wombat_Foo_integers_derived_2->new(); +isa_ok $a, 'director_wombat_Foo_integers_derived_2'; +is $a->meth(37), 37; + +$b = director_wombat_Bar_derived_1->new(); +isa_ok $b, 'director_wombat_Bar_derived_1'; +$b->foo_meth_ref($a, 0); +$b->foo_meth_ptr($a, 1); +$b->foo_meth_val($a, 2); + diff --git a/Lib/perl5/director.swg b/Lib/perl5/director.swg new file mode 100644 index 000000000..5acc4fd15 --- /dev/null +++ b/Lib/perl5/director.swg @@ -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 diff --git a/Lib/perl5/perlrun.swg b/Lib/perl5/perlrun.swg index ebc4fecd5..876fae268 100644 --- a/Lib/perl5/perlrun.swg +++ b/Lib/perl5/perlrun.swg @@ -20,6 +20,7 @@ #define SWIG_ConvertPtr(obj, pp, type, flags) SWIG_Perl_ConvertPtr(SWIG_PERL_OBJECT_CALL obj, pp, type, flags) #define SWIG_ConvertPtrAndOwn(obj, pp, type, flags,own) SWIG_Perl_ConvertPtrAndOwn(SWIG_PERL_OBJECT_CALL obj, pp, type, flags, own) #define SWIG_NewPointerObj(p, type, flags) SWIG_Perl_NewPointerObj(SWIG_PERL_OBJECT_CALL p, type, flags) +#define swig_owntype int /* for raw packed data */ #define SWIG_ConvertPacked(obj, p, s, type) SWIG_Perl_ConvertPacked(SWIG_PERL_OBJECT_CALL obj, p, s, type) @@ -288,7 +289,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; } { diff --git a/Lib/perl5/perltypemaps.swg b/Lib/perl5/perltypemaps.swg index fc7100e89..f47a5ef82 100644 --- a/Lib/perl5/perltypemaps.swg +++ b/Lib/perl5/perltypemaps.swg @@ -35,9 +35,9 @@ * Unified typemap section * ------------------------------------------------------------ */ -/* No director supported in Perl */ -#ifdef SWIG_DIRECTOR_TYPEMAPS -#undef SWIG_DIRECTOR_TYPEMAPS +/* director support in Perl is experimental */ +#ifndef SWIG_DIRECTOR_TYPEMAPS +#define SWIG_DIRECTOR_TYPEMAPS #endif diff --git a/Source/Modules/perl5.cxx b/Source/Modules/perl5.cxx index 09500b23b..d7a131aa2 100644 --- a/Source/Modules/perl5.cxx +++ b/Source/Modules/perl5.cxx @@ -79,8 +79,11 @@ static String *variable_tab = 0; static File *f_begin = 0; static File *f_runtime = 0; +static File *f_runtime_h = 0; static File *f_header = 0; static File *f_wrappers = 0; +static File *f_directors = 0; +static File *f_directors_h = 0; static File *f_init = 0; static File *f_pm = 0; static String *pm; /* Package initialization code */ @@ -124,6 +127,7 @@ public: Printv(argc_template_string, "items", NIL); Clear(argv_template_string); Printv(argv_template_string, "ST(%d)", NIL); + director_language = 1; } /* Test to see if a type corresponds to something wrapped with a shadow class */ @@ -219,9 +223,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; + } }; /* ----------------------------------------------------------------------------- |