From 77d05524a99d9e8bb1239f4e39a5af80ef808a3f Mon Sep 17 00:00:00 2001 From: Dave Beazley Date: Wed, 29 Oct 2003 19:43:38 +0000 Subject: [PATCH] Fixed [ 827907 ] argout objects not being wrapped properly (PATH). git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@5213 626c5289-ae23-0410-ae9c-e8d60b6d4f22 --- Lib/perl5/perl5.swg | 8 +- Lib/perl5/perlrun.swg | 29 ++++- Lib/perl5/std_vector.i | 2 +- Source/Modules/perl5.cxx | 264 +++++++-------------------------------- 4 files changed, 81 insertions(+), 222 deletions(-) diff --git a/Lib/perl5/perl5.swg b/Lib/perl5/perl5.swg index ee0f42d7e..6221b5d4f 100644 --- a/Lib/perl5/perl5.swg +++ b/Lib/perl5/perl5.swg @@ -132,7 +132,7 @@ %typemap(out) SWIGTYPE *, SWIGTYPE [], SWIGTYPE & "ST(argvi) = sv_newmortal(); - SWIG_MakePtr(ST(argvi++), (void *) $1, $1_descriptor,0);"; + SWIG_MakePtr(ST(argvi++), (void *) $1, $1_descriptor, $shadow|$owner);"; %typemap(out) SWIGTYPE @@ -140,14 +140,14 @@ { $&1_ltype resultobj = new $1_ltype(($1_ltype &)$1); ST(argvi) = sv_newmortal(); - SWIG_MakePtr(ST(argvi++), (void *) resultobj, $&1_descriptor,0); + SWIG_MakePtr(ST(argvi++), (void *) resultobj, $&1_descriptor, $shadow|$owner); } #else { $&1_ltype resultobj = ($&1_ltype) malloc(sizeof($1_type)); memmove(resultobj, &$1, sizeof($1_type)); ST(argvi) = sv_newmortal(); - SWIG_MakePtr(ST(argvi++), (void *) resultobj, $&1_descriptor,0); + SWIG_MakePtr(ST(argvi++), (void *) resultobj, $&1_descriptor, $shadow|$owner); } #endif @@ -156,7 +156,7 @@ %typemap(out) SWIGTYPE *DYNAMIC, SWIGTYPE &DYNAMIC { swig_type_info *ty = SWIG_TypeDynamicCast($1_descriptor, (void **) &$1); ST(argvi) = sv_newmortal(); - SWIG_MakePtr(ST(argvi++), (void *) $1, ty,0); + SWIG_MakePtr(ST(argvi++), (void *) $1, ty, $shadow|$owner); } %typemap(out) void ""; diff --git a/Lib/perl5/perlrun.swg b/Lib/perl5/perlrun.swg index 095ddd996..9cc3d3355 100644 --- a/Lib/perl5/perlrun.swg +++ b/Lib/perl5/perlrun.swg @@ -119,6 +119,9 @@ typedef int (*SwigMagicFuncHack)(struct interpreter *, SV *, MAGIC *); extern "C" { #endif +#define SWIG_OWNER 1 +#define SWIG_SHADOW 2 + #ifdef SWIG_NOINCLUDE #ifndef PERL_OBJECT @@ -246,7 +249,31 @@ SWIGRUNTIME(void) SWIG_MakePtr_(CPerlObj *pPerl, SV *sv, void *ptr, swig_type_info *t, int flags) #endif { - sv_setref_pv(sv, (char *) t->name, ptr); + if (ptr && (flags & SWIG_SHADOW)) { + SV *self; + SV *obj=newSV(0); + HV *hash=newHV(); + HV *stash; + sv_setref_pv(obj, (char *) t->name, ptr); + stash=SvSTASH(SvRV(obj)); + if (flags & SWIG_OWNER) { + HV *hv; + GV *gv=*(GV**)hv_fetch(stash, "OWNER", 5, TRUE); + if (!isGV(gv)) + gv_init(gv, stash, "OWNER", 5, FALSE); + hv=GvHVn(gv); + hv_store_ent(hv, obj, newSViv(1), 0); + } + sv_magic((SV *)hash, (SV *)obj, PERL_MAGIC_tied, Nullch, 0); + SvREFCNT_dec(obj); + self=newRV_noinc((SV *)hash); + sv_setsv(sv, self); + SvREFCNT_dec((SV *)self); + sv_bless(sv, stash); + } + else { + sv_setref_pv(sv, (char *) t->name, ptr); + } } #endif diff --git a/Lib/perl5/std_vector.i b/Lib/perl5/std_vector.i index bb28cee2b..96d720e59 100644 --- a/Lib/perl5/std_vector.i +++ b/Lib/perl5/std_vector.i @@ -141,7 +141,7 @@ namespace std { for (unsigned int i=0; i$member_func();\n", + "}\n\n", + NIL); + + /* Output a STORE method. This is also common to all classes (might move to base class) */ + + Printv(base, + "sub STORE {\n", + tab4, "my ($self,$field,$newval) = @_;\n", + tab4, "my $member_func = \"swig_${field}_set\";\n", + tab4, "$self->$member_func($newval);\n", + "}\n\n", + NIL); + /* Output a 'this' method */ Printv(base, @@ -625,9 +644,21 @@ public: emit_action(n,f); if ((tm = Swig_typemap_lookup_new("out",n,"result",0))) { + SwigType *t = Getattr(n,"type"); Replaceall(tm,"$source","result"); Replaceall(tm,"$target","ST(argvi)"); Replaceall(tm,"$result", "ST(argvi)"); + if (is_shadow(t)) { + Replaceall(tm, "$shadow", "SWIG_SHADOW"); + } else { + Replaceall(tm, "$shadow", "0"); + } + if ((!SwigType_ispointer(t) && !SwigType_isreference(t)) + || Getattr(n,"feature:new")) { + Replaceall(tm,"$owner","SWIG_OWNER"); + } else { + Replaceall(tm,"$owner","0"); + } Printf(f->code, "%s\n", tm); } else { Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number, @@ -720,56 +751,9 @@ public: * -------------------------------------------------------------------- */ if ((blessed) && (!member_func)) { - int need_stub = 0; - String *func = NewString(""); - - /* We'll make a stub since we may need it anyways */ - - Printv(func, "sub ", iname, " {\n", - tab4, "my @args = @_;\n", - NIL); - - Printv(func, tab4, "my $result = ", cmodule, "::", iname, "(@args);\n", NIL); - - /* Now check to see what kind of return result was found. - * If this function is returning a result by 'value', SWIG did an - * implicit malloc/new. We'll mark the object like it was created - * in Perl so we can garbage collect it. */ - - if (is_shadow(d)) { - Printv(func, tab4, "return undef if (!defined($result));\n", NIL); - - /* If we're returning an object by value, put it's reference - into our local hash table */ - - if ((!SwigType_ispointer(d) && !SwigType_isreference(d)) || Getattr(n,"feature:new")) { - Printv(func, tab4, "$", is_shadow(d), "::OWNER{$result} = 1;\n", NIL); - } - - /* We're returning a Perl "object" of some kind. Turn it into a tied hash */ - Printv(func, - tab4, "my %resulthash;\n", - tab4, "tie %resulthash, ref($result), $result;\n", - tab4, "return bless \\%resulthash, ref($result);\n", - "}\n", - NIL); - - need_stub = 1; - } else { - /* Hmmm. This doesn't appear to be anything I know about */ - Printv(func, tab4, "return $result;\n", "}\n", NIL); - } - - /* Now check if we needed the stub. If so, emit it, otherwise - * Emit code to hack Perl's symbol table instead */ - - if (need_stub) { - Printf(func_stubs,"%s",func); - } else { - Printv(func_stubs,"*", iname, " = *", cmodule, "::", iname, ";\n", NIL); - } - Delete(func); + Printv(func_stubs,"*", iname, " = *", cmodule, "::", iname, ";\n", NIL); } + } Delete(cleanup); Delete(outarg); @@ -1116,7 +1100,7 @@ public: } real_classname = Getattr(n,"name"); pcode = NewString(""); - blessedmembers = NewString(""); + // blessedmembers = NewString(""); } /* Emit all of the members */ @@ -1178,11 +1162,6 @@ public: /* Dump out a hash table containing the pointers that we own */ Printf(pm, "%%OWNER = ();\n"); - if (have_data_members) { - Printv(pm, - "%BLESSEDMEMBERS = (\n", blessedmembers, ");\n\n", - NIL); - } if (have_data_members || have_destructor) Printf(pm, "%%ITERATORS = ();\n"); @@ -1198,48 +1177,16 @@ public: tab4, "my $self = shift;\n", tab4, "my $ptr = tied(%$self);\n", tab4, "delete $OWNER{$ptr};\n", - tab4, "};\n\n", + "}\n\n", "sub ACQUIRE {\n", tab4, "my $self = shift;\n", tab4, "my $ptr = tied(%$self);\n", tab4, "$OWNER{$ptr} = 1;\n", - tab4, "};\n\n", + "}\n\n", NIL); /* Only output the following methods if a class has member data */ - if (have_data_members) { - - /* Output a FETCH method. This is actually common to all classes */ - Printv(pm, - "sub FETCH {\n", - tab4, "my ($self,$field) = @_;\n", - tab4, "my $member_func = \"swig_${field}_get\";\n", - tab4, "my $val = $self->$member_func();\n", - tab4, "if (exists $BLESSEDMEMBERS{$field}) {\n", - tab8, "return undef if (!defined($val));\n", - tab8, "my %retval;\n", - tab8, "tie %retval,$BLESSEDMEMBERS{$field},$val;\n", - tab8, "return bless \\%retval, $BLESSEDMEMBERS{$field};\n", - tab4, "}\n", - tab4, "return $val;\n", - "}\n\n", - NIL); - - /* Output a STORE method. This is also common to all classes (might move to base class) */ - - Printv(pm, - "sub STORE {\n", - tab4, "my ($self,$field,$newval) = @_;\n", - tab4, "my $member_func = \"swig_${field}_set\";\n", - tab4, "if (exists $BLESSEDMEMBERS{$field}) {\n", - tab8, "$self->$member_func(tied(%{$newval}));\n", - tab4, "} else {\n", - tab8, "$self->$member_func($newval);\n", - tab4, "}\n", - "}\n\n", - NIL); - } Delete(operators); operators = 0; } return SWIG_OK; @@ -1251,20 +1198,12 @@ public: virtual int memberfunctionHandler(Node *n) { String *symname = Getattr(n,"sym:name"); - SwigType *t = Getattr(n,"type"); - - String *func; - int need_wrapper = 0; member_func = 1; Language::memberfunctionHandler(n); member_func = 0; if ((blessed) && (!Getattr(n,"sym:nextSibling"))) { - func = NewString(""); - - /* Now emit a Perl wrapper function around our member function, we might need - to patch up some arguments along the way */ if (Strstr(symname, "operator") == symname) { if (Strstr(symname, "operator_equal_to")) { @@ -1282,58 +1221,7 @@ public: // fprintf(stderr,"Found member_func operator: %s\n", symname); } - Printv(func, - "sub ", symname, " {\n", - tab4, "my @args = @_;\n", - NIL); - - /* Okay. We've made argument adjustments, now call into the package */ - - Printv(func, - tab4, "my $result = ", cmodule, "::", Swig_name_member(class_name,symname), - "(@args);\n", - NIL); - - /* Now check to see what kind of return result was found. - * If this function is returning a result by 'value', SWIG did an - * implicit malloc/new. We'll mark the object like it was created - * in Perl so we can garbage collect it. */ - - if (is_shadow(t)) { - Printv(func,tab4, "return undef if (!defined($result));\n", NIL); - - /* If we're returning an object by value, put it's reference - into our local hash table */ - - if ((!SwigType_ispointer(t) && !SwigType_isreference(t)) || Getattr(n,"feature:new")) { - Printv(func, tab4, "$", is_shadow(t), "::OWNER{$result} = 1; \n", NIL); - } - - /* We're returning a Perl "object" of some kind. Turn it into - a tied hash */ - - Printv(func, - tab4, "my %resulthash;\n", - tab4, "tie %resulthash, ref($result), $result;\n", - tab4, "return bless \\%resulthash, ref($result);\n", - "}\n", - NIL); - - need_wrapper = 1; - } else { - - /* Hmmm. This doesn't appear to be anything I know about so just - return it unmodified */ - - Printv(func, tab4,"return $result;\n", "}\n", NIL); - } - - if (need_wrapper) { - Printv(pcode,func,NIL); - } else { - Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL); - } - Delete(func); + Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL); } return SWIG_OK; } @@ -1341,24 +1229,13 @@ public: /* ------------------------------------------------------------ * membervariableHandler() * - * Adds an instance member. This is a little hairy because data members are - * really added with a tied-hash table that is attached to the object. - * - * On the low level, we will emit a pair of get/set functions to retrieve - * values just like before. These will then be encapsulated in a FETCH/STORE - * method associated with the tied-hash. - * - * In the event that a member is an object that we have already wrapped, then - * we need to retrieve the data a tied-hash as opposed to what SWIG normally - * returns. To determine this, we build an internal hash called 'BLESSEDMEMBERS' - * that contains the names and types of tied data members. If a member name - * is in the list, we tie it, otherwise, we just return the normal SWIG value. + * Adds an instance member. * ----------------------------------------------------------------------------- */ virtual int membervariableHandler(Node *n) { String *symname = Getattr(n,"sym:name"); - SwigType *t = Getattr(n,"type"); + /* SwigType *t = Getattr(n,"type"); */ /* Emit a pair of get/set functions for the variable */ @@ -1373,15 +1250,16 @@ public: /* Now we need to generate a little Perl code for this */ - if (is_shadow(t)) { + /* if (is_shadow(t)) { - /* This is a Perl object that we have already seen. Add an - entry to the members list*/ + *//* This is a Perl object that we have already seen. Add an + entry to the members list*//* Printv(blessedmembers, tab4, symname, " => '", is_shadow(t), "',\n", NIL); } + */ } have_data_members++; return SWIG_OK; @@ -1412,17 +1290,10 @@ public: Printv(pcode, "sub ", Swig_name_construct(symname), " () {\n", NIL); } - Printv(pcode, tab4, "my $pkg = shift;\n", - tab4, "my @args = @_;\n", NIL); - Printv(pcode, - tab4, "my $self = ", cmodule, "::", Swig_name_construct(symname), "(@args);\n", - tab4, "return undef if (!defined($self));\n", - /* tab4, "bless $self, \"", fullclassname, "\";\n", */ - tab4, "$OWNER{$self} = 1;\n", - tab4, "my %retval;\n", - tab4, "tie %retval, \"", fullclassname, "\", $self;\n", - tab4, "return bless \\%retval, $pkg;\n", + tab4, "my $pkg = shift;\n", + tab4, "my $self = ", cmodule, "::", Swig_name_construct(symname), "(@_);\n", + tab4, "bless $self, $pkg if defined($self);\n", "}\n\n", NIL); @@ -1468,46 +1339,7 @@ public: member_func = 0; if ((blessed) && (!Getattr(n,"sym:nextSibling"))) { String *symname = Getattr(n,"sym:name"); - SwigType *t = Getattr(n,"type"); - if (is_shadow(t)) { - Printv(pcode, - "sub ", symname, " {\n", - tab4, "my @args = @_;\n", - NIL); - - /* Okay. We've made argument adjustments, now call into the package */ - - Printv(pcode, - tab4, "my $result = ", cmodule, "::", Swig_name_member(class_name,symname), - "(@args);\n", - NIL); - - /* Now check to see what kind of return result was found. - * If this function is returning a result by 'value', SWIG did an - * implicit malloc/new. We'll mark the object like it was created - * in Perl so we can garbage collect it. */ - - Printv(pcode,tab4, "return undef if (!defined($result));\n", NIL); - - /* If we're returning an object by value, put it's reference - into our local hash table */ - - if ((!SwigType_ispointer(t) && !SwigType_isreference(t)) || Getattr(n,"feature:new")) { - Printv(pcode, tab4, "$", is_shadow(t), "::OWNER{$result} = 1; \n", NIL); - } - - /* We're returning a Perl "object" of some kind. Turn it into - a tied hash */ - - Printv(pcode, - tab4, "my %resulthash;\n", - tab4, "tie %resulthash, ref($result), $result;\n", - tab4, "return bless \\%resulthash, ref($result);\n", - "}\n", - NIL); - } else { - Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL); - } + Printv(pcode,"*",symname," = *", cmodule, "::", Swig_name_member(class_name,symname), ";\n", NIL); } return SWIG_OK; }