[Swig-cvs] SF.net SVN: swig:[11146] branches/talby-perl5-improvements

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 454-5900

Revision: 11146
          http://swig.svn.sourceforge.net/swig/?rev=11146&view=rev
Author:   talby
Date:     2009-03-10 00:07:55 +0000 (Tue, 10 Mar 2009)

Log Message:
-----------
fine tuning
 * %feature("shadow") support returns
 * refcounts better in most cases
 * object ownership management progress
 * ->DISOWN/->ACQUIRE support returns
 * most perl warnings in testcases resolved
 * all test cases now leverage Test::More
remaining:
 * better ownership/lifetime management
 * sane destructor handling
 * reverse compat issues should be enumerated and addressed
 * as always, more testcases

Modified Paths:
--------------
    branches/talby-perl5-improvements/Examples/test-suite/perl5/disown_runme.pl
    branches/talby-perl5-improvements/Examples/test-suite/perl5/imports_runme.pl
    branches/talby-perl5-improvements/Examples/test-suite/perl5/overload_copy_runme.pl
    branches/talby-perl5-improvements/Examples/test-suite/perl5/template_ref_type_runme.pl
    branches/talby-perl5-improvements/Examples/test-suite/perl5/voidtest_runme.pl
    branches/talby-perl5-improvements/Lib/perl5/perlrun.swg
    branches/talby-perl5-improvements/Source/Modules/perl5.cxx

Added Paths:
-----------
    branches/talby-perl5-improvements/Examples/test-suite/perl5/typedef_funcptr_runme.pl

Modified: branches/talby-perl5-improvements/Examples/test-suite/perl5/disown_runme.pl
===================================================================

--- branches/talby-perl5-improvements/Examples/test-suite/perl5/disown_runme.pl	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Examples/test-suite/perl5/disown_runme.pl	2009-03-10 00:07:55 UTC (rev 11146)
@@ -1,10 +1,25 @@
-use disown;
+use strict;
+use warnings;
+use Test::More tests => 9;
+BEGIN { use_ok 'disown' }
+require_ok 'disown';
 
-if (1) {
-    $a = new disown::A();
-    $b = new disown::B();    
-    $c = $b->acquire($a);   
+my $k;
+{
+    my $a = disown::A->new();
+    is(exists $disown::A::OWNER{$a->this()}, 1, 'A initial ownership');
+    $a->DISOWN();
+    is(exists $disown::A::OWNER{$a->this()}, '', 'A release');
+    $a->ACQUIRE();
+    is(exists $disown::A::OWNER{$a->this()}, 1, 'A take ownership');
+    $k = $a->this();
 }
-
-
-
+is(exists $disown::A::OWNER{$k}, '', 'swig drops A');
+{
+    my $a = disown::A->new();
+    my $b = disown::B->new();
+    $k = $b->this();
+    is(exists $disown::B::OWNER{$k}, 1, 'B initial ownership');
+    is($b->acquire($a), 5, 'return 5');
+    is(exists $disown::A::OWNER{$a->this()}, '', 'B took A');
+}

Modified: branches/talby-perl5-improvements/Examples/test-suite/perl5/imports_runme.pl
===================================================================
--- branches/talby-perl5-improvements/Examples/test-suite/perl5/imports_runme.pl	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Examples/test-suite/perl5/imports_runme.pl	2009-03-10 00:07:55 UTC (rev 11146)
@@ -1,5 +1,85 @@
-use imports_a;
-use imports_b;
+use strict;
+use warnings;
+use Test::More tests => 38;
+BEGIN { use_ok 'imports_a' }
+require_ok 'imports_a';
+BEGIN { use_ok 'imports_b' }
+require_ok 'imports_b';
 
-$x = imports_b::B->new();
-$x->imports_a::A::hello();
+my $x = imports_a::A->new();
+isa_ok($x, 'imports_a::A');
+my $y = imports_b::B->new();
+isa_ok($y, 'imports_b::B'); 
+my $z = imports_b::C->new();
+isa_ok($z, 'imports_b::C'); 
+
+is($y->imports_a::A::hello(), undef, 'cross module dispatch');
+
+# baseline enum checks
+is(imports_a::global_test($imports_a::globalenum1),
+        $imports_a::globalenum1, 'baseline ge1');
+is(imports_a::global_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'baseline ge2');
+
+is($x->global_virtual_test($imports_a::globalenum1),
+        $imports_a::globalenum1, 'baseling A gvt1');
+is($x->global_virtual_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'baseline A gvt2');
+is($x->member_virtual_test($imports_a::A::memberenum1),
+        $imports_a::A::memberenum1, 'baseline A mvt1');
+is($x->member_virtual_test($imports_a::A::memberenum2),
+        $imports_a::A::memberenum2, 'baseline A mvt2');
+
+is($y->global_virtual_test($imports_a::globalenum1),
+        $imports_a::globalenum2, 'baseline B gvt1');
+is($y->global_virtual_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'baseline B gvt2');
+is($y->member_virtual_test($imports_a::A::memberenum1),
+        $imports_a::A::memberenum2, 'baseline B mvt1');
+is($y->member_virtual_test($imports_a::A::memberenum2),
+        $imports_a::A::memberenum2, 'baseline B mvt2');
+
+
+my $x1 = $z->get_a($x);
+isa_ok($x1, 'imports_a::A');
+is($x1->global_virtual_test($imports_a::globalenum1),
+        $imports_a::globalenum1, 'z.get_a(x).gvt1');
+is($x1->global_virtual_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'z.get_a(x).gvt2');
+is($x1->member_virtual_test($imports_a::A::memberenum1),
+        $imports_a::A::memberenum1, 'z.get_a(x).mvt1');
+is($x1->member_virtual_test($imports_a::A::memberenum2),
+        $imports_a::A::memberenum2, 'z.get_a(x).mvt2');
+
+my $x2 = $z->get_a_type($x);
+isa_ok($x2, 'imports_a::A');
+is($x2->global_virtual_test($imports_a::globalenum1),
+        $imports_a::globalenum1, 'z.get_a_type(x).gvt1');
+is($x2->global_virtual_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'z.get_a_type(x).gvt2');
+is($x2->member_virtual_test($imports_a::A::memberenum1),
+        $imports_a::A::memberenum1, 'z.get_a_type(x).mvt1');
+is($x2->member_virtual_test($imports_a::A::memberenum2),
+        $imports_a::A::memberenum2, 'z.get_a_type(x).mvt2');
+
+my $y1 = $z->get_a($y);
+isa_ok($y1, 'imports_a::A');
+is($y1->global_virtual_test($imports_a::globalenum1),
+        $imports_a::globalenum2, 'z.get_a(y).gvt1');
+is($y1->global_virtual_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'z.get_a(y).gvt2');
+is($y1->member_virtual_test($imports_a::A::memberenum1),
+        $imports_a::A::memberenum2, 'z.get_a(y).mvt1');
+is($y1->member_virtual_test($imports_a::A::memberenum2),
+        $imports_a::A::memberenum2, 'z.get_a(y).mvt2');
+
+my $y2 = $z->get_a_type($y);
+isa_ok($y1, 'imports_a::A');
+is($y2->global_virtual_test($imports_a::globalenum1),
+        $imports_a::globalenum2, 'z.get_a_type(y).gvt1');
+is($y2->global_virtual_test($imports_a::globalenum2),
+        $imports_a::globalenum2, 'z.get_a_type(y).gvt2');
+is($y2->member_virtual_test($imports_a::A::memberenum1),
+        $imports_a::A::memberenum2, 'z.get_a_type(y).mvt1');
+is($y2->member_virtual_test($imports_a::A::memberenum2),
+        $imports_a::A::memberenum2, 'z.get_a_type(y).mvt2');

Modified: branches/talby-perl5-improvements/Examples/test-suite/perl5/overload_copy_runme.pl
===================================================================
--- branches/talby-perl5-improvements/Examples/test-suite/perl5/overload_copy_runme.pl	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Examples/test-suite/perl5/overload_copy_runme.pl	2009-03-10 00:07:55 UTC (rev 11146)
@@ -1,5 +1,10 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+BEGIN{ use_ok 'overload_copy' }
+require_ok 'overload_copy';
 
-use overload_copy;
-
-$f = new overload_copy::Foo();
-$g = new overload_copy::Foo($f);
+my $f = overload_copy::Foo->new();
+isa_ok($f, 'overload_copy::Foo');
+my $g = overload_copy::Foo->new($f);
+isa_ok($g, 'overload_copy::Foo');

Modified: branches/talby-perl5-improvements/Examples/test-suite/perl5/template_ref_type_runme.pl
===================================================================
--- branches/talby-perl5-improvements/Examples/test-suite/perl5/template_ref_type_runme.pl	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Examples/test-suite/perl5/template_ref_type_runme.pl	2009-03-10 00:07:55 UTC (rev 11146)
@@ -1,6 +1,13 @@
-use template_ref_type;
+use strict;
+use warnings;
+use Test::More tests => 5;
+BEGIN { use_ok 'template_ref_type' }
+require_ok 'template_ref_type';
 
+
 my $xr = template_ref_type::XC->new();
+isa_ok($xr, 'template_ref_type::XC');
 my $y = template_ref_type::Y->new();
+isa_ok($y, 'template_ref_type::Y');
 
-$y->find($xr);
+is($y->find($xr), '', 'template ref');

Added: branches/talby-perl5-improvements/Examples/test-suite/perl5/typedef_funcptr_runme.pl
===================================================================
--- branches/talby-perl5-improvements/Examples/test-suite/perl5/typedef_funcptr_runme.pl	                        (rev 0)
+++ branches/talby-perl5-improvements/Examples/test-suite/perl5/typedef_funcptr_runme.pl	2009-03-10 00:07:55 UTC (rev 11146)
@@ -0,0 +1,10 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More tests => 5;
+BEGIN { use_ok('typedef_funcptr') }
+require_ok('typedef_funcptr');
+
+can_ok('typedef_funcptr', 'do_op');
+is(typedef_funcptr::do_op(9, 5, $typedef_funcptr::subf), 4, 'subf');
+is(typedef_funcptr::do_op(9, 5, $typedef_funcptr::addf), 14, 'addf');

Modified: branches/talby-perl5-improvements/Examples/test-suite/perl5/voidtest_runme.pl
===================================================================
--- branches/talby-perl5-improvements/Examples/test-suite/perl5/voidtest_runme.pl	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Examples/test-suite/perl5/voidtest_runme.pl	2009-03-10 00:07:55 UTC (rev 11146)
@@ -1,20 +1,24 @@
 use strict;
 use warnings;
-use Test::More tests => 7;
+use Test::More tests => 10;
 BEGIN { use_ok('voidtest') }
 require_ok('voidtest');
 
-# adapted from ../python/voidtest_runme.py
+can_ok('voidtest', 'globalfunc');
 voidtest::globalfunc();
+can_ok('voidtest::Foo', 'new', 'staticmemberfunc');
 my $f = voidtest::Foo->new();
+can_ok($f, 'memberfunc');
 is($f->memberfunc(), undef);
-{ local $TODO = "opaque pointers hidden behind layer of indirection";
+
 my $v1 = voidtest::vfunc1($f);
 my $v2 = voidtest::vfunc2($f);
 is($v1, $v2);
+
 my $v3 = voidtest::vfunc3($v1);
+my $v4 = voidtest::vfunc4($f);
+is($v3, $v4);
 is($v3->this, $f->this);
-my $v4 = voidtest::vfunc4($f);
+{ local $TODO = "not sure this should work, but maybe void* is special";
 is($v1, $v4);
 }
-ok(1, "done");

Modified: branches/talby-perl5-improvements/Lib/perl5/perlrun.swg
===================================================================
--- branches/talby-perl5-improvements/Lib/perl5/perlrun.swg	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Lib/perl5/perlrun.swg	2009-03-10 00:07:55 UTC (rev 11146)
@@ -173,14 +173,16 @@
   return ent ? HeVAL(ent) : 0;
 }
 SWIGINTERN void SWIG_Perl_RememberPtr(swig_perl_wrap *wrap, SV *impl) {
-  /*warn("store (%s:%p)\n", HvNAME(wrap->stash), wrap->ptr);*/
+  SV *ref = newSVsv(impl);
+  sv_rvweaken(ref);
+  /*warn("store (%s:%p) = %p\n", HvNAME(wrap->stash), wrap->ptr, SvRV(impl));*/
   hv_store_ent(SWIG_Perl_OwnerTbl(wrap->stash),
-    sv_2mortal(newSViv(PTR2IV(wrap->ptr))), impl, 0);
+    sv_2mortal(newSViv(PTR2IV(wrap->ptr))), ref, 0);
 }
 SWIGINTERN void SWIG_Perl_ForgetPtr(swig_perl_wrap *wrap) {
   /*warn("delete(%s:%p)\n", HvNAME(wrap->stash), wrap->ptr);*/
   hv_delete_ent(SWIG_Perl_OwnerTbl(wrap->stash),
-    sv_2mortal(newSViv(PTR2IV(wrap->ptr))), G_DISCARD, 0);
+    sv_2mortal(newSViv(PTR2IV(wrap->ptr))), 0, 0);
 }
 SWIGINTERN int
 SWIG_Perl_vtbl_svt_free(pTHX_ SV *sv, MAGIC *mg) {
@@ -188,8 +190,8 @@
   wrap->refcnt--;
   if(wrap->refcnt <= 0) {
     SWIG_Perl_ForgetPtr(wrap);
+    /*warn("free(%p)\n", wrap);*/
     /*Safefree(wrap);*/
-    warn("free(%p)\n", wrap);
     free(wrap);
   }
   return 0;
@@ -238,8 +240,11 @@
 
 SWIGRUNTIME int
 SWIG_Perl_ConvertMg(MAGIC *mg, void **ptr, swig_type_info *t, int flags) {
-  /* TODO: this is incomplete */
-  *ptr = ((swig_perl_wrap *)mg->mg_ptr)->ptr;
+  swig_perl_wrap *wrap = (swig_perl_wrap *)mg->mg_ptr;
+  if(flags & SWIG_POINTER_DISOWN)
+    SWIG_Perl_ForgetPtr(wrap);
+  /* TODO: other flags? */
+  *ptr = wrap->ptr;
   return SWIG_OK;
 }
 SWIGRUNTIME int
@@ -309,7 +314,7 @@
   stash = gv_stashpv(SWIG_Perl_TypeProxyName(t), GV_ADD);
 
   if ((impl = SWIG_Perl_LookupPtr(stash, ptr))) {
-    SvSetSV(sv, sv_2mortal(newRV_inc(impl)));
+    SvSetSV(sv, impl);
     return sv;
   }
   ext = (swig_perl_type_ext *)t->clientdata;
@@ -350,11 +355,11 @@
     PUTBACK;
 
     SvSetSV(sv, impl);
-    SvREFCNT_inc(SvRV(sv));
 
     FREETMPS;
     LEAVE;
 
+    sv_2mortal(SvRV(sv));
     vtbl = &ext->vtbl;
     if(ext->attr) { /* populate object attribute stubs */
       int i;
@@ -383,7 +388,7 @@
       do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
       warn("}");*/
 #endif
-  SWIG_Perl_RememberPtr(wrap, SvRV(sv));
+  SWIG_Perl_RememberPtr(wrap, sv);
   return sv;
 }
 
@@ -482,26 +487,57 @@
   dXSARGS;
   SV *self;
   MAGIC *mg;
-  if (items != 1) {
+
+  if (items != 1)
     SWIG_croak("Usage: $obj->this();");
-  }
   self = ST(0);
-  if (SvROK(self)) {
-    mg = mg_find(SvRV(self), PERL_MAGIC_ext);
-    if (mg) {
-      ST(0) = newSViv(PTR2IV(((swig_perl_wrap *)mg->mg_ptr)->ptr));
-      XSRETURN(1);
-    } else {
-      SWIG_croak("self not magical");
-    }
-  } else {
+  if (!SvROK(self))
     SWIG_croak("self not an object");
-  }
+  mg = mg_find(SvRV(self), PERL_MAGIC_ext);
+  if (!mg)
+    SWIG_croak("self not magical");
+  ST(0) = newSViv(PTR2IV(((swig_perl_wrap *)mg->mg_ptr)->ptr));
+  XSRETURN(1);
 fail:
   SWIG_croak_null();
 }
+XS(SWIG_Perl_Disown) {
+  dXSARGS;
+  SV *self;
+  MAGIC *mg;
 
+  if (items != 1)
+    SWIG_croak("Usage: $obj->DISOWN()");
+  self = ST(0);
+  if (!SvROK(self))
+    SWIG_croak("self not an object");
+  mg = mg_find(SvRV(self), PERL_MAGIC_ext);
+  if (!mg)
+    SWIG_croak("self not magical");
+  SWIG_Perl_ForgetPtr(((swig_perl_wrap *)mg->mg_ptr));
+  XSRETURN(0);
+fail:
+  SWIG_croak_null();
+}
+XS(SWIG_Perl_Acquire) {
+  dXSARGS;
+  SV *self;
+  MAGIC *mg;
 
+  if (items != 1)
+    SWIG_croak("Usage: $obj->ACQUIRE()");
+  self = ST(0);
+  if (!SvROK(self))
+    SWIG_croak("self not an object");
+  mg = mg_find(SvRV(self), PERL_MAGIC_ext);
+  if (!mg)
+    SWIG_croak("self not magical");
+  SWIG_Perl_RememberPtr(((swig_perl_wrap *)mg->mg_ptr), self);
+  XSRETURN(0);
+fail:
+  SWIG_croak_null();
+}
+
 #ifdef __cplusplus
 }
 #endif

Modified: branches/talby-perl5-improvements/Source/Modules/perl5.cxx
===================================================================
--- branches/talby-perl5-improvements/Source/Modules/perl5.cxx	2009-03-06 04:38:06 UTC (rev 11145)
+++ branches/talby-perl5-improvements/Source/Modules/perl5.cxx	2009-03-10 00:07:55 UTC (rev 11146)
@@ -898,7 +898,7 @@
       Setattr(n, "perl5:vtbl", vtbl);
 
       Printf(f_init,
-          "SWIG_Perl_WrapVar(get_sv(\"%s::%s\", 1), &%s, 0);\n",
+          "SWIG_Perl_WrapVar(get_sv(\"%s::%s\", TRUE | GV_ADDMULTI), &%s, 0);\n",
           namespace_module, pname, vtbl);
     }
     return SWIG_OK;
@@ -1137,22 +1137,8 @@
 
     Node *outer_class = CurrentClass;
     CurrentClass = n;
-    {
-      /* prefill memberVariables list with parent vars */
-      List *member_variables = NewList();
-      Setattr(n, "perl5:memberVariables", member_variables);
-      List *bases = Getattr(n, "bases");
-      if (bases) {
-        for (Iterator b = First(bases); b.item; b = Next(b)) {
-          List *parent_members = Getattr(b.item, "perl5:memberVariables");
-          for (Iterator v = First(parent_members); v.item; v = Next(v)) {
-            Append(member_variables, v.item);
-          }
-        }
-      }
-    }
+    Setattr(n, "perl5:memberVariables", NewList());
 
-
     if (blessed) {
       have_operators = 0;
       operators = NewHash();
@@ -1209,35 +1195,53 @@
          * is needed for is in typesys/symbol management. */
         if (!mangle_seen) mangle_seen = NewHash();
         if (!Getattr(mangle_seen, mang)) {
+
+        /* declare attribute bindings */
+        int nattr = 0;
+        int nfield = 0;
+        List *bases = Getattr(n, "bases");
+        if(bases) bases = Copy(bases);
+        else      bases = NewList();
+        Insert(bases, 0, n);
         Printv(pm, "use fields (", NIL);
-        int nattr = 0;
-        for (Iterator i = First(Getattr(n, "perl5:memberVariables"));
-            i.item; i = Next(i)) {
-          Node *ch = i.item;
-          String *vtbl = Getattr(ch, "perl5:vtbl");
-          if(vtbl) {
-            vtbl = Copy(vtbl);
-          } else {
-            String *getf = Getattr(ch, "perl5:getter");
-            if (!getf) continue;
-            String *setf = Getattr(ch, "perl5:setter");
-            vtbl = NewStringf("SWIG_Perl_VTBL(%s, %s)",
-              getf, setf ? setf : "0");
+        for (int i = Len(bases); i > 0; i--) {
+          Node *iclass = Getitem(bases, i - 1);
+          for (Iterator j = First(Getattr(iclass,
+              "perl5:memberVariables")); j.item; j = Next(j)) {
+            Node *ch = j.item;
+            /* XS side */
+            String *vtbl = Getattr(ch, "perl5:vtbl");
+            if(vtbl) {
+              vtbl = Copy(vtbl);
+            } else {
+              String *getf = Getattr(ch, "perl5:getter");
+              if (!getf) continue;
+              String *setf = Getattr(ch, "perl5:setter");
+              vtbl = NewStringf("SWIG_Perl_VTBL(%s, %s)",
+                  getf, setf ? setf : "0");
+            }
+            String *chn = Getattr(ch, "sym:name");
+            if (nattr == 0) {
+              Printv(f_wrappers, "static swig_perl_type_ext_var "
+                  "_swigt_ext_var_", mang, "[] = {\n", NIL);
+            } else {
+              Append(f_wrappers, ",\n");
+            }
+            Printf(f_wrappers,
+                "  { \"%s\", %s }", chn, vtbl);
+            Delete(vtbl);
+            nattr++;
+            /* Perl side */
+            if (iclass == n || Strncmp(chn, "_", 1) == 0) {
+              /* fields.pm handles leading underscore a bit special */
+              if (nfield)
+                Append(pm, ", ");
+              Printf(pm, "'%s'", chn);
+              nfield++;
+            }
           }
-          String *chn = Getattr(ch, "sym:name");
-          if (nattr == 0) {
-            Printv(f_wrappers, "static swig_perl_type_ext_var "
-              "_swigt_ext_var_", mang, "[] = {\n", NIL);
-          } else {
-            Append(f_wrappers, ",\n");
-            Append(pm, ", ");
-          }
-          Printf(f_wrappers,
-            "  { \"%s\", %s }", chn, vtbl);
-          Printf(pm, "'%s'", chn);
-          Delete(vtbl);
-          nattr++;
         }
+        Append(pm, ");\n");
         if (nattr) {
           Printf(f_wrappers, "\n};\n"
             "static swig_perl_type_ext _swigt_ext_%s = "
@@ -1249,7 +1253,7 @@
             "SWIG_Perl_TypeExt(\"%s\", 0, 0);\n\n",
             mang, fullclassname);
         }
-        Append(pm, ");\n");
+        Delete(bases);
         String *tmp = NewStringf("&_swigt_ext_%s", mang);
         SwigType_remember_clientdata(ct, tmp);
         Setattr(mangle_seen, mang, "1");
@@ -1324,31 +1328,22 @@
 	Printv(pm, tab4, "\"fallback\" => 1;\n", NIL);
       }
       // make use strict happy
-      Printv(pm, "use vars qw(%OWNER %ITERATORS %BLESSEDMEMBERS);\n", NIL);
+      Printv(pm, "use vars qw(%OWNER);\n", NIL);
 
       /* Dump out a hash table containing the pointers that we own */
       Printf(pm, "%%OWNER = ();\n");
-      if (First(Getattr(n, "perl5:memberVariables")).item ||
-          Getattr(n, "perl5:destructor"))
-        Printf(pm, "%%ITERATORS = ();\n");
 
       /* Dump out the package methods */
-
       Printv(pm, pcode, NIL);
       Delete(pcode);
 
-      /* Output methods for managing ownership */
-
-      Printv(pm,
-	     "sub DISOWN {\n",
-	     tab4, "my $self = shift;\n",
-	     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);
-
-      /* bind a 'this' method */
+      /* bind core swig class methods */
       Printf(f_init, "newXS(\"%s::%s::this\", SWIG_Perl_This, __FILE__);\n",
           namespace_module, ClassName);
+      Printf(f_init, "newXS(\"%s::%s::DISOWN\", SWIG_Perl_Disown, __FILE__);\n",
+          namespace_module, ClassName);
+      Printf(f_init, "newXS(\"%s::%s::ACQUIRE\", SWIG_Perl_Acquire, __FILE__);\n",
+          namespace_module, ClassName);
 
       Delete(operators);
       operators = 0;
@@ -1358,13 +1353,40 @@
   }
 
   /* ------------------------------------------------------------
+   * memberfunctionCommon()
+   *
+   * Just hoisting the common bits of member function wrapping into a
+   * common place to ease code consistency and readability
+   * ------------------------------------------------------------ */
+  virtual int memberfunctionCommon(Node *n, int shadow = 1) {
+    if (blessed) {
+      String *symname = Getattr(n, "sym:name");
+      String *pname;
+      String *pfunc = 0;
+
+      if(shadow)
+        pfunc = Getattr(n, "feature:shadow");
+      pname = NewStringf("%s%s",
+          pfunc ? "_swig_" : "",
+          Equal(nodeType(n), "constructor") &&
+            Equal(symname, ClassName) ? "new" : symname);
+      if(pfunc) {
+        String *pname_ref = NewStringf("do { \\&%s }", pname);
+        Replaceall(pfunc, "$action", pname_ref);
+        Delete(pname_ref);
+        Append(pcode, pfunc);
+      }
+      Setattr(n, "perl5:name", NewStringf("%s::%s", ClassName, pname));
+    }
+    return SWIG_OK;
+  }
+
+  /* ------------------------------------------------------------
    * memberfunctionHandler()
    * ------------------------------------------------------------ */
 
   virtual int memberfunctionHandler(Node *n) {
-    if (blessed)
-      Setattr(n, "perl5:name", NewStringf("%s::%s", ClassName,
-            Getattr(n, "sym:name")));
+    memberfunctionCommon(n);
     if (blessed && !Getattr(n, "sym:nextSibling")) {
       String *symname = Getattr(n, "sym:name");
 
@@ -1458,11 +1480,8 @@
    * ------------------------------------------------------------ */
 
   virtual int constructorHandler(Node *n) {
+    memberfunctionCommon(n);
     if (blessed) {
-      String *symname = Getattr(n, "sym:name");
-      Setattr(n, "perl5:name", NewStringf("%s::%s", ClassName,
-            Equal(symname, ClassName) ? "new" : symname));
-
       String *type = NewString("SV");
       SwigType_add_pointer(type);
       Parm *p = NewParm(type, "proto");
@@ -1478,9 +1497,7 @@
    * ------------------------------------------------------------ */
 
   virtual int destructorHandler(Node *n) {
-    if (blessed)
-      Setattr(n, "perl5:name", NewStringf("%s::%s",
-            ClassName, "_swig_DESTROY"));
+    memberfunctionCommon(n);
     Setattr(n, "perl5:destructor", n);
     return Language::destructorHandler(n);
   }
@@ -1490,19 +1507,15 @@
    * ------------------------------------------------------------ */
 
   virtual int staticmemberfunctionHandler(Node *n) {
-    if (blessed) {
-      Setattr(n, "perl5:name", NewStringf("%s::%s",
-            ClassName, Getattr(n, "sym:name")));
-
-      if(!GetFlag(n, "allocate:smartpointeraccess")) {
-        /* proto is probably only appropriate if directors are enabled */
-        String *type = NewString("SV");
-        SwigType_add_pointer(type);
-        Parm *p = NewParm(type, "proto");
-        Delete(type);
-        Setattr(n, "perl5:implicits", p);
-        Delete(p);
-      }
+    memberfunctionCommon(n);
+    if (blessed && !GetFlag(n, "allocate:smartpointeraccess")) {
+      /* proto is probably only appropriate if directors are enabled */
+      String *type = NewString("SV");
+      SwigType_add_pointer(type);
+      Parm *p = NewParm(type, "proto");
+      Delete(type);
+      Setattr(n, "perl5:implicits", p);
+      Delete(p);
     }
     return Language::staticmemberfunctionHandler(n);
   }
@@ -1512,9 +1525,7 @@
    * ------------------------------------------------------------ */
 
   virtual int staticmembervariableHandler(Node *n) {
-    if (blessed)
-      Setattr(n, "perl5:name", NewStringf("%s::%s",
-            ClassName, Getattr(n, "sym:name")));
+    memberfunctionCommon(n, 0);
     Append(Getattr(CurrentClass, "perl5:memberVariables"), n);
     return Language::staticmembervariableHandler(n);
   }
@@ -1524,9 +1535,7 @@
    * ------------------------------------------------------------ */
 
   virtual int memberconstantHandler(Node *n) {
-    if (blessed)
-      Setattr(n, "perl5:name", NewStringf("%s::%s",
-            ClassName, Getattr(n, "sym:name")));
+    memberfunctionCommon(n, 0);
     return Language::memberconstantHandler(n);
   }
 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.




[Swig-cvs] SF.net SVN: swig:[11146] branches/talby-perl5-improvements

A code generator for connecting C/C++ with other programming languages

[Swig-cvs] SF.net SVN: swig:[11146] branches/talby-perl5-improvements