Add Tcl support for std::unique_ptr and std::auto_ptr

Equivalent to Ruby/Python implementations.

CHANGES.current

@@ -7,6 +7,10 @@ the issue number to the end of the URL: https://github.com/swig/swig/issues/
 Version 4.1.0 (in progress)
 ===========================
 
+2022-07-30: wsfulton
+            [Tcl] Add support for std::unique_ptr in std_unique_ptr.i.
+            Add support for std::auto_ptr in std_auto_ptr.i.
+
 2022-07-27: ZackerySpytz, olly
 	    #1678 Support parsing C++20 templated lambdas.
 

Examples/test-suite/cpp11_std_unique_ptr.i

@@ -1,6 +1,6 @@
 %module cpp11_std_unique_ptr
 
-#if defined(SWIGCSHARP) || defined(SWIGJAVA) || defined(SWIGPYTHON) || defined(SWIGRUBY) || defined(SWIGPERL)
+#if defined(SWIGCSHARP) || defined(SWIGJAVA) || defined(SWIGPYTHON) || defined(SWIGRUBY) || defined(SWIGPERL) || defined(SWIGTCL)
 
 %include "std_string.i"
 %include "std_unique_ptr.i"

Examples/test-suite/li_std_auto_ptr.i

@@ -12,7 +12,7 @@
 #endif
 %}
 
-#if defined(SWIGCSHARP) || defined(SWIGJAVA) || defined(SWIGPYTHON) || defined(SWIGRUBY) || defined(SWIGPERL)
+#if defined(SWIGCSHARP) || defined(SWIGJAVA) || defined(SWIGPYTHON) || defined(SWIGRUBY) || defined(SWIGPERL) || defined(SWIGTCL)
 
 %include "std_string.i"
 %include "std_auto_ptr.i"

Examples/test-suite/tcl/cpp11_std_unique_ptr_runme.tcl

@@ -0,0 +1,140 @@
+
+if [ catch { load ./cpp11_std_unique_ptr[info sharedlibextension] cpp11_std_unique_ptr} err_msg ] {
+	puts stderr "Could not load shared object:\n$err_msg"
+}
+
+
+proc checkCount {expected_count} {
+  set actual_count [Klass_getTotal_count]
+  if {$actual_count != $expected_count} {
+    error "Counts incorrect, expected: $expected_count actual: $actual_count"
+  }
+}
+
+################################# Tcl pointer recycling bug start
+#
+# ### Possibly related to premature object deletion problem mentioned in newobject1_runme.tcl. ###
+#
+# While this won't be repeatable on all machines, the following caused the underlying C++
+# pointer value for k1 to be reused for k4.
+#
+# If the C/C++ memory allocator uses the same pointer value again, then a command name that
+# contains a pointer encoding, such as, _b09b1148bd550000_p_Klass (not a variable name) will be
+# re-used in SWIG_Tcl_NewInstanceObj. The command should have disappeared from the Tcl side when
+# the object was deleted, but there is some sort of bug preventing this from happening in this
+# scenario as follows:
+#
+# Below creates a struct via the call to Tcl_CreateObjCommand in
+# SWIG_Tcl_NewInstanceObj (creates a command name with a pointer encoding such as
+# _50fb3608ce550000_p_Klass) which also makes a second call to Tcl_CreateObjCommand in
+# SWIG_Tcl_ObjectConstructor (creates a command name with the name k1).
+Klass k1 "one"
+# Line below calls Tcl_DeleteCommandFromToken but is only called for the command created in the
+# second call (k1) and not the first call to Tcl_CreateObjCommand.
+k1 -delete
+set k2 [makeKlassUniquePtr "two"]
+set k3 [makeKlassUniquePtr "three"]
+$k2 -delete
+# If the memory allocator uses the same pointer value, then SWIG_Tcl_NewInstanceObj will find
+# the undeleted command _50fb3608ce550000_p_Klass and re-use it. This command should surely
+# have been deleted !??
+set k4 [makeKlassUniquePtr "four"]
+$k3 -delete
+$k4 -delete
+checkCount 0
+################################# Tcl pointer recycling bug end
+
+
+# unique_ptr as input
+Klass kin "KlassInput"
+checkCount 1
+set s [takeKlassUniquePtr kin]
+checkCount 0
+if {[kin cget -thisown]} {
+  error "thisown should be false"
+}
+if {$s != "KlassInput"} {
+  error "Incorrect string: $s"
+}
+if {![is_nullptr kin]} {
+  error "is_nullptr failed"
+}
+kin -delete # Should not fail, even though already deleted
+checkCount 0
+
+Klass kin "KlassInput"
+checkCount 1
+set s [takeKlassUniquePtr kin]
+checkCount 0
+if {[kin cget -thisown]} {
+  error "thisown should be false"
+}
+if {$s != "KlassInput"} {
+  error "Incorrect string: $s"
+}
+if {![is_nullptr kin]} {
+  error "is_nullptr failed"
+}
+set exception_thrown 0
+if [ catch { set s [takeKlassUniquePtr kin] } e ] {
+  if {[string first "cannot release ownership as memory is not owned" $e] == -1} {
+    error "incorrect exception message: $e"
+  }
+  set exception_thrown 1
+}
+if {!$exception_thrown} {
+  error "double usage of takeKlassUniquePtr should have been an error"
+}
+kin -delete # Should not fail, even though already deleted
+checkCount 0
+
+Klass kin "KlassInput"
+set exception_thrown 0
+if [ catch {
+  set notowned [get_not_owned_ptr kin]
+  takeKlassUniquePtr notowned
+} ] {
+  set exception_thrown 1
+}
+if {!$exception_thrown} {
+  error "Should have thrown 'Cannot release ownership as memory is not owned' error"
+}
+kin -delete
+checkCount 0
+
+KlassInheritance kini "KlassInheritanceInput"
+checkCount 1
+set s [takeKlassUniquePtr kini]
+checkCount 0
+if {[kini cget -thisown]} {
+  error "thisown should be false"
+}
+if {$s != "KlassInheritanceInput"} {
+  error "Incorrect string: $s"
+}
+if {![is_nullptr kini]} {
+  error "is_nullptr failed"
+}
+kini -delete # Should not fail, even though already deleted
+checkCount 0
+
+# unique_ptr as output
+set k1 [makeKlassUniquePtr "first"]
+set k2 [makeKlassUniquePtr "second"]
+if {[Klass_getTotal_count] != 2} {
+  error "number of objects should be 2"
+}
+
+$k1 -delete
+if {[Klass_getTotal_count] != 1} {
+  error "number of objects should be 1"
+}
+
+if {[$k2 getLabel] != "second"} {
+  error "wrong object label"
+}
+
+$k2 -delete
+if {[Klass_getTotal_count] != 0} {
+  error "no objects should be left"
+}

Examples/test-suite/tcl/li_std_auto_ptr_runme.tcl

@@ -0,0 +1,111 @@
+
+if [ catch { load ./li_std_auto_ptr[info sharedlibextension] li_std_auto_ptr} err_msg ] {
+	puts stderr "Could not load shared object:\n$err_msg"
+}
+
+
+proc checkCount {expected_count} {
+  set actual_count [Klass_getTotal_count]
+  if {$actual_count != $expected_count} {
+    error "Counts incorrect, expected: $expected_count actual: $actual_count"
+  }
+}
+
+################################# Tcl pointer recycling bug start
+# Not copied from cpp11_std_unique_ptr_runme.tcl
+################################# Tcl pointer recycling bug end
+
+
+# auto_ptr as input
+Klass kin "KlassInput"
+checkCount 1
+set s [takeKlassAutoPtr kin]
+checkCount 0
+if {[kin cget -thisown]} {
+  error "thisown should be false"
+}
+if {$s != "KlassInput"} {
+  error "Incorrect string: $s"
+}
+if {![is_nullptr kin]} {
+  error "is_nullptr failed"
+}
+kin -delete # Should not fail, even though already deleted
+checkCount 0
+
+Klass kin "KlassInput"
+checkCount 1
+set s [takeKlassAutoPtr kin]
+checkCount 0
+if {[kin cget -thisown]} {
+  error "thisown should be false"
+}
+if {$s != "KlassInput"} {
+  error "Incorrect string: $s"
+}
+if {![is_nullptr kin]} {
+  error "is_nullptr failed"
+}
+set exception_thrown 0
+if [ catch { set s [takeKlassAutoPtr kin] } e ] {
+  if {[string first "cannot release ownership as memory is not owned" $e] == -1} {
+    error "incorrect exception message: $e"
+  }
+  set exception_thrown 1
+}
+if {!$exception_thrown} {
+  error "double usage of takeKlassAutoPtr should have been an error"
+}
+kin -delete # Should not fail, even though already deleted
+checkCount 0
+
+Klass kin "KlassInput"
+set exception_thrown 0
+if [ catch {
+  set notowned [get_not_owned_ptr kin]
+  takeKlassAutoPtr notowned
+} ] {
+  set exception_thrown 1
+}
+if {!$exception_thrown} {
+  error "Should have thrown 'Cannot release ownership as memory is not owned' error"
+}
+kin -delete
+checkCount 0
+
+KlassInheritance kini "KlassInheritanceInput"
+checkCount 1
+set s [takeKlassAutoPtr kini]
+checkCount 0
+if {[kini cget -thisown]} {
+  error "thisown should be false"
+}
+if {$s != "KlassInheritanceInput"} {
+  error "Incorrect string: $s"
+}
+if {![is_nullptr kini]} {
+  error "is_nullptr failed"
+}
+kini -delete # Should not fail, even though already deleted
+checkCount 0
+
+# auto_ptr as output
+set k1 [makeKlassAutoPtr "first"]
+set k2 [makeKlassAutoPtr "second"]
+if {[Klass_getTotal_count] != 2} {
+  error "number of objects should be 2"
+}
+
+$k1 -delete
+if {[Klass_getTotal_count] != 1} {
+  error "number of objects should be 1"
+}
+
+if {[$k2 getLabel] != "second"} {
+  error "wrong object label"
+}
+
+$k2 -delete
+if {[Klass_getTotal_count] != 0} {
+  error "no objects should be left"
+}

Lib/tcl/std_auto_ptr.i

@@ -0,0 +1,33 @@
+/* -----------------------------------------------------------------------------
+ * std_auto_ptr.i
+ *
+ * SWIG library file for handling std::auto_ptr.
+ * Memory ownership is passed from the std::auto_ptr C++ layer to the proxy
+ * class when returning a std::auto_ptr from a function.
+ * Memory ownership is passed from the proxy class to the std::auto_ptr in the
+ * C++ layer when passed as a parameter to a wrapped function.
+ * ----------------------------------------------------------------------------- */
+
+%define %auto_ptr(TYPE)
+%typemap(in, noblock=1) std::auto_ptr< TYPE > (void *argp = 0, int res = 0) {
+  res = SWIG_ConvertPtr($input, &argp, $descriptor(TYPE *), SWIG_POINTER_RELEASE | %convertptr_flags);
+  if (!SWIG_IsOK(res)) {
+    if (res == SWIG_ERROR_RELEASE_NOT_OWNED) {
+      %releasenotowned_fail(res, "TYPE *", $symname, $argnum);
+    } else {
+      %argument_fail(res, "TYPE *", $symname, $argnum);
+    }
+  }
+  $1.reset((TYPE *)argp);
+}
+
+%typemap (out) std::auto_ptr< TYPE > %{
+  Tcl_SetObjResult(interp, SWIG_NewInstanceObj($1.release(), $descriptor(TYPE *), SWIG_POINTER_OWN));
+%}
+
+%template() std::auto_ptr< TYPE >;
+%enddef
+
+namespace std {
+  template <class T> class auto_ptr {};
+}

Lib/tcl/std_unique_ptr.i

@@ -0,0 +1,33 @@
+/* -----------------------------------------------------------------------------
+ * std_unique_ptr.i
+ *
+ * SWIG library file for handling std::unique_ptr.
+ * Memory ownership is passed from the std::unique_ptr C++ layer to the proxy
+ * class when returning a std::unique_ptr from a function.
+ * Memory ownership is passed from the proxy class to the std::unique_ptr in the
+ * C++ layer when passed as a parameter to a wrapped function.
+ * ----------------------------------------------------------------------------- */
+
+%define %unique_ptr(TYPE)
+%typemap(in, noblock=1) std::unique_ptr< TYPE > (void *argp = 0, int res = 0) {
+  res = SWIG_ConvertPtr($input, &argp, $descriptor(TYPE *), SWIG_POINTER_RELEASE | %convertptr_flags);
+  if (!SWIG_IsOK(res)) {
+    if (res == SWIG_ERROR_RELEASE_NOT_OWNED) {
+      %releasenotowned_fail(res, "TYPE *", $symname, $argnum);
+    } else {
+      %argument_fail(res, "TYPE *", $symname, $argnum);
+    }
+  }
+  $1.reset((TYPE *)argp);
+}
+
+%typemap (out) std::unique_ptr< TYPE > %{
+  Tcl_SetObjResult(interp, SWIG_NewInstanceObj($1.release(), $descriptor(TYPE *), SWIG_POINTER_OWN));
+%}
+
+%template() std::unique_ptr< TYPE >;
+%enddef
+
+namespace std {
+  template <class T> class unique_ptr {};
+}

Lib/tcl/tclrun.swg

@@ -122,6 +122,7 @@ SWIG_Tcl_Disown(void *ptr) {
 SWIGRUNTIME int
 SWIG_Tcl_ConvertPtrFromString(Tcl_Interp *interp, const char *c, void **ptr, swig_type_info *ty, int flags) {
   swig_cast_info *tc;
+  const char *cmd_name;
   /* Pointer values must start with leading underscore */
   while (*c != '_') {
     *ptr = (void *) 0;
@@ -157,23 +158,42 @@ SWIG_Tcl_ConvertPtrFromString(Tcl_Interp *interp, const char *c, void **ptr, swi
 
     c = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL);
   }
+  cmd_name = c;
 
   c++;
   c = SWIG_UnpackData(c,ptr,sizeof(void *));
+
   if (ty) {
     tc = c ? SWIG_TypeCheck(c,ty) : 0;
-    if (!tc) {
+    if (tc) {
+      Tcl_CmdInfo info;
+      if (Tcl_GetCommandInfo(interp, cmd_name, &info)) {
+        swig_instance *inst = (swig_instance *)info.objClientData;
+        if (!inst->thisvalue) {
+          *ptr = 0;
+        }
+        assert(inst->thisvalue == *ptr);
+        if (((flags & SWIG_POINTER_RELEASE) == SWIG_POINTER_RELEASE) && !SWIG_Thisown(inst->thisvalue)) {
+          return SWIG_ERROR_RELEASE_NOT_OWNED;
+        } else {
+          if (flags & SWIG_POINTER_DISOWN) {
+            SWIG_Disown((void *) *ptr);
+          }
+          if (flags & SWIG_POINTER_CLEAR) {
+            inst->thisvalue = 0;
+          }
+          {
+            int newmemory = 0;
+            *ptr = SWIG_TypeCast(tc,(void *) *ptr,&newmemory);
+            assert(!newmemory); /* newmemory handling not yet implemented */
+          }
+        }
+      }
+    } else {
       return SWIG_ERROR;
     }
-    if (flags & SWIG_POINTER_DISOWN) {
-      SWIG_Disown((void *) *ptr);
-    }
-    {
-      int newmemory = 0;
-      *ptr = SWIG_TypeCast(tc,(void *) *ptr,&newmemory);
-      assert(!newmemory); /* newmemory handling not yet implemented */
-    }
   }
+
   return SWIG_OK;
 }
 
@@ -490,9 +510,11 @@ SWIG_Tcl_NewInstanceObj(Tcl_Interp *interp, void *thisvalue, swig_type_info *typ
   /* Check to see if this pointer belongs to a class or not */
   if (thisvalue && (type->clientdata) && (interp)) {
     Tcl_CmdInfo    ci;
+    int has_command;
     char          *name;
     name = Tcl_GetStringFromObj(robj,NULL);
-    if (!Tcl_GetCommandInfo(interp,name, &ci) || (flags)) {
+    has_command = Tcl_GetCommandInfo(interp, name, &ci);
+    if (!has_command || flags) {
       swig_instance *newinst = (swig_instance *) malloc(sizeof(swig_instance));
       newinst->thisptr = Tcl_DuplicateObj(robj);
       Tcl_IncrRefCount(newinst->thisptr);
@@ -503,6 +525,15 @@ SWIG_Tcl_NewInstanceObj(Tcl_Interp *interp, void *thisvalue, swig_type_info *typ
       if (flags) {
         SWIG_Acquire(thisvalue);
       }
+    } else {
+      swig_instance *inst = (swig_instance *)ci.objClientData;
+      /* Restore thisvalue as SWIG_POINTER_CLEAR may have been used to set it to zero.
+         Occurs when the C pointer is re-used by the memory allocator and the command has
+         been created and not destroyed - bug?? - see cpp11_std_unique_ptr_runme.tcl test. */
+      if (inst->thisvalue != thisvalue) {
+        assert(inst->thisvalue == 0);
+        inst->thisvalue = thisvalue;
+      }
     }
   }
   return robj;