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

* 'perl5-directors-minimal' of https://github.com/talby-/swig:
  try adding travis ci to this branch
  ran "beautify-file" make target over perl5.cxx patch hunks and rewrote callback and extend examples in the style of existing examples
  prefer polymorphism on existing destructor over custom destructor method
  fix string mangled by tidy
  eliminate dead director code and convert remaining blocks
  mitigate ConvertPtr director cost when directors are not enabled
  steals python director docs and adapts to perl5
  adds "callback" and "extend" examples
  don't forget the most important part
  steals python directors and adapts to perl5

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

Examples/perl5/callback/example.cxx

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

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

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

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>

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

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

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

Examples/perl5/extend/example.cxx

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

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

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

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>

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

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>

Examples/test-suite/perl5/director_abstract_runme.pl

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

Examples/test-suite/perl5/director_alternating_runme.pl

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

Examples/test-suite/perl5/director_basic_runme.pl

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

Examples/test-suite/perl5/director_classes_runme.pl

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

Examples/test-suite/perl5/director_classic_runme.pl

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

Examples/test-suite/perl5/director_constructor_runme.pl

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