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

ran "beautify-file" make target over perl5.cxx patch hunks and rewrote callback and extend examples in the style of existing examples

Browse source
This commit is contained in:
Robert Stone 2013-11-14 09:22:23 -08:00
commit 43aefba9ee
3 changed files with 277 additions and 260 deletions
Download patch file Download diff file Expand all files Collapse all files

40
Examples/perl5/callback/runme.pl
View file

@ -1,40 +1,48 @@
#!/usr/bin/perl # file: runme.pl
use strict;
use warnings; # This file illustrates the cross language polymorphism using directors.
use example; use example;
{ {
package PerlCallback; package PlCallback;
use base 'example::Callback'; use base 'example::Callback';
sub run { sub run {
print "PerlCallback.run()\n"; 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 "Adding and calling a normal C++ callback\n";
print "----------------------------------------\n"; print "----------------------------------------\n";
my $caller = example::Caller->new(); $callback = example::Callback->new();
my $callback = example::Callback->new(); $callback->DISOWN();
$caller->setCallback($callback); $caller->setCallback($callback);
$caller->call(); $caller->call();
$caller->delCallback(); $caller->delCallback();
$callback = PerlCallback->new(); print
print "\n";
print "Adding and calling a Perl callback\n"; print "Adding and calling a Perl callback\n";
print "------------------------------------\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->setCallback($callback);
$caller->call(); $caller->call();
$caller->delCallback(); $caller->delCallback();
# Note that letting go of $callback will not attempt to destroy the # All done.
# object, ownership passed to $caller in the ->setCallback() call, and
# $callback was already destroyed in ->delCallback().
undef $callback;
print "\n"; print "\n";
print "perl exit\n"; print "perl exit\n";

58
Examples/perl5/extend/runme.pl
View file

@ -1,48 +1,56 @@
#!/usr/bin/perl # file: runme.pl
use strict;
use warnings;
use example;
# This file illustrates the cross language polymorphism using directors. # This file illustrates the cross language polymorphism using directors.
use example;
# CEO class, which overrides Employee::getPosition().
{ {
# CEO class, which overrides Employee::getPosition().
package CEO; package CEO;
use base 'example::Manager'; use base 'example::Manager';
sub getPosition { sub getPosition {
return 'CEO'; return "CEO";
} }
} }
# Create an instance of CEO, a class derived from the Java proxy of the # Create an instance of our employee extension class, CEO. The calls to
# underlying C++ class. The calls to getName() and getPosition() are standard, # getName() and getPosition() are standard, the call to getTitle() uses
# the call to getTitle() uses the director wrappers to call CEO.getPosition(). # the director wrappers to call CEO->getPosition. $e = CEO->new("Alice")
my $e = CEO->new('Alice');
print "${\ $e->getName } is a ${\ $e->getPosition() }\n"; $e = CEO->new("Alice");
print "Just call her \"${\ $e->getTitle() }\"\n"; print $e->getName(), " is a ", $e->getPosition(), "\n";
printf "Just call her \"%s\"\n", $e->getTitle();
print "----------------------\n"; print "----------------------\n";
# Create a new EmployeeList instance. This class does not have a C++ # Create a new EmployeeList instance. This class does not have a C++
# director wrapper, but can be used freely with other classes that do. # director wrapper, but can be used freely with other classes that do.
my $list = example::EmployeeList->new(); $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); $list->addEmployee($e);
print "----------------------\n"; print "----------------------\n";
# Now we access the first four items in list (three are C++ objects that # 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 # 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 # methods of all these instances are treated the same. For items 0, 1, and
# 2, all methods resolve in C++. For item 3, our CEO, getTitle calls # 2, both all methods resolve in C++. For item 3, our CEO, getTitle calls
# getPosition which resolves in Perl. The call to getPosition is # getPosition which resolves in Perl. The call to getPosition is
# slightly different, however, because of the overidden getPosition() call, since # slightly different, however, from the $e->getPosition() call above, since
# now the object reference has been "laundered" by passing through # now the object reference has been "laundered" by passing through
# EmployeeList as an Employee*. Previously, Perl resolved the call # EmployeeList as an Employee*. Previously, Perl resolved the call
# immediately in CEO, but now Perl thinks the object is an instance of # immediately in CEO, but now Perl thinks the object is an instance of
# class Employee. So the call passes through the # class Employee (actually EmployeePtr). So the call passes through the
# Employee proxy class and on to the C wrappers and C++ director, # Employee proxy class and on to the C wrappers and C++ director,
# eventually ending up back at the Perl CEO implementation of getPosition(). # eventually ending up back at the CEO implementation of getPosition().
# The call to getTitle() for item 3 runs the C++ Employee::getTitle() # The call to getTitle() for item 3 runs the C++ Employee::getTitle()
# method, which in turn calls getPosition(). This virtual method call # method, which in turn calls getPosition(). This virtual method call
# passes down through the C++ director class to the Perl implementation # passes down through the C++ director class to the Perl implementation
@ -50,16 +58,22 @@ print "----------------------\n";
print "(position, title) for items 0-3:\n"; print "(position, title) for items 0-3:\n";
print " ${\ $list->get_item(0)->getPosition() }, \"${\ $list->get_item(0)->getTitle() }\"\n"; printf " %s, \"%s\"\n", $list->get_item(0)->getPosition(), $list->get_item(0)->getTitle();
print " ${\ $list->get_item(1)->getPosition() }, \"${\ $list->get_item(1)->getTitle() }\"\n"; printf " %s, \"%s\"\n", $list->get_item(1)->getPosition(), $list->get_item(1)->getTitle();
print " ${\ $list->get_item(2)->getPosition() }, \"${\ $list->get_item(2)->getTitle() }\"\n"; printf " %s, \"%s\"\n", $list->get_item(2)->getPosition(), $list->get_item(2)->getTitle();
print " ${\ $list->get_item(3)->getPosition() }, \"${\ $list->get_item(3)->getTitle() }\"\n"; printf " %s, \"%s\"\n", $list->get_item(3)->getPosition(), $list->get_item(3)->getTitle();
print "----------------------\n"; print "----------------------\n";
# Time to delete the EmployeeList, which will delete all the Employee* # Time to delete the EmployeeList, which will delete all the Employee*
# items it contains. The last item is our CEO, which gets destroyed as well. # 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; undef $list;
print "----------------------\n"; print "----------------------\n";
# All done. # All done.
print "perl exit\n"; print "perl exit\n";

31
Source/Modules/perl5.cxx
View file

@ -248,28 +248,23 @@ public:
if (Getattr(options, "directors")) { if (Getattr(options, "directors")) {
int allow = 1; int allow = 1;
if (export_all) { if (export_all) {
Printv(stderr, Printv(stderr, "*** directors are not supported with -exportall\n", NIL);
"*** directors are not supported with -exportall\n", NIL);
allow = 0; allow = 0;
} }
if (staticoption) { if (staticoption) {
Printv(stderr, Printv(stderr, "*** directors are not supported with -static\n", NIL);
"*** directors are not supported with -static\n", NIL);
allow = 0; allow = 0;
} }
if (!blessed) { if (!blessed) {
Printv(stderr, Printv(stderr, "*** directors are not supported with -noproxy\n", NIL);
"*** directors are not supported with -noproxy\n", NIL);
allow = 0; allow = 0;
} }
if (no_pmfile) { if (no_pmfile) {
Printv(stderr, Printv(stderr, "*** directors are not supported with -nopm\n", NIL);
"*** directors are not supported with -nopm\n", NIL);
allow = 0; allow = 0;
} }
if (compat) { if (compat) {
Printv(stderr, Printv(stderr, "*** directors are not supported with -compat\n", NIL);
"*** directors are not supported with -compat\n", NIL);
allow = 0; allow = 0;
} }
if (allow) { if (allow) {
@ -1477,8 +1472,7 @@ public:
String *director_disown; String *director_disown;
if (Getattr(n, "perl5:directordisown")) { if (Getattr(n, "perl5:directordisown")) {
director_disown = NewStringf("%s%s($self);\n", director_disown = NewStringf("%s%s($self);\n", tab4, Getattr(n, "perl5:directordisown"));
tab4, Getattr(n, "perl5:directordisown"));
} else { } else {
director_disown = NewString(""); director_disown = NewString("");
} }
@ -1511,7 +1505,8 @@ public:
type = NewString("SV"); type = NewString("SV");
SwigType_add_pointer(type); SwigType_add_pointer(type);
String *action = NewString(""); 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); 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)); Setfile(get_attr, Getfile(n));
Setline(get_attr, Getline(n)); Setline(get_attr, Getline(n));
Setattr(get_attr, "wrap:action", action); Setattr(get_attr, "wrap:action", action);
@ -1707,7 +1702,7 @@ public:
String *saved_nc = none_comparison; String *saved_nc = none_comparison;
none_comparison = NewStringf("strcmp(SvPV_nolen(ST(0)), \"%s::%s\") != 0", module, class_name); none_comparison = NewStringf("strcmp(SvPV_nolen(ST(0)), \"%s::%s\") != 0", module, class_name);
String *saved_director_prot_ctor_code = director_prot_ctor_code; String *saved_director_prot_ctor_code = director_prot_ctor_code;
director_prot_ctor_code = NewStringf( "if ($comparison) { /* subclassed */\n" " $director_new\n" "} else {\n" 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"); "SWIG_exception_fail(SWIG_RuntimeError, \"accessing abstract class or protected constructor\");\n" "}\n");
Language::constructorHandler(n); Language::constructorHandler(n);
Delete(none_comparison); Delete(none_comparison);
@ -1732,7 +1727,7 @@ public:
Printv(pcode, "sub ", Swig_name_construct(NSPACE_TODO, symname), " {\n", NIL); Printv(pcode, "sub ", Swig_name_construct(NSPACE_TODO, symname), " {\n", NIL);
} }
const char *pkg = getCurrentClass() && Swig_directorclass(getCurrentClass()) ? "$_[0]" : "shift"; const char *pkg = getCurrentClass() && Swig_directorclass(getCurrentClass())? "$_[0]" : "shift";
Printv(pcode, Printv(pcode,
tab4, "my $pkg = ", pkg, ";\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); tab4, "my $self = ", cmodule, "::", Swig_name_construct(NSPACE_TODO, symname), "(@_);\n", tab4, "bless $self, $pkg if defined($self);\n", "}\n\n", NIL);
@ -2392,8 +2387,8 @@ public:
Delete(tm); Delete(tm);
} else { } else {
Swig_warning(WARN_TYPEMAP_DIRECTOROUT_UNDEF, input_file, line_number, 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), "Unable to use return type %s in director method %s::%s (skipping method).\n", SwigType_str(returntype, 0),
SwigType_namestr(name)); SwigType_namestr(c_classname), SwigType_namestr(name));
status = SWIG_ERROR; status = SWIG_ERROR;
} }
} }
@ -2476,7 +2471,7 @@ public:
member_func = 1; member_func = 1;
rv = Language::classDirectorDisown(n); rv = Language::classDirectorDisown(n);
member_func = 0; member_func = 0;
if(rv == SWIG_OK && Swig_directorclass(n)) { if (rv == SWIG_OK && Swig_directorclass(n)) {
String *symname = Getattr(n, "sym:name"); String *symname = Getattr(n, "sym:name");
String *disown = Swig_name_disown(NSPACE_TODO, symname); String *disown = Swig_name_disown(NSPACE_TODO, symname);
Setattr(n, "perl5:directordisown", NewStringf("%s::%s", cmodule, disown)); Setattr(n, "perl5:directordisown", NewStringf("%s::%s", cmodule, disown));