Merge pull request #1519 from llaniewski/main

Unwrapping extptr stored in capsules

NEWS.md

@@ -1,5 +1,9 @@
 # reticulate (development version)
 
+- R external pointers (EXTPTRSXP objects) now round-trip through 
+  `py_to_r(r_to_py(x))` successfully.
+  (reported in #1511, fixed in #1519, contributed by @llaniewski).
+
 - Fixed issue where `virtualenv_create()` would error on Ubuntu 22.04 when
   using the system python as a base. (#1495, fixed in #1496).
 

src/python.cpp

@@ -107,6 +107,7 @@ SEXP py_fetch_error(bool maybe_reuse_cached_r_trace = false);
 
 
 const char *r_object_string = "r_object";
+const char *r_extptr_string = "r_extptr";
 
 // wrap an R object in a longer-lived python object "capsule"
 SEXP py_capsule_read(PyObject* capsule) {
@@ -121,6 +122,14 @@ SEXP py_capsule_read(PyObject* capsule) {
 
 }
 
+// for a extptr stored in a capsule, use the R object stored in the capsule's context
+SEXP py_extptr_capsule_read(PyObject* capsule) {
+  SEXP object = (SEXP) PyCapsule_GetContext(capsule);
+  if (object == NULL)
+    throw PythonException(py_fetch_error());
+  return TAG(object);
+}
+
 tthread::thread::id s_main_thread = 0;
 bool is_main_thread() {
   if (s_main_thread == 0)
@@ -192,6 +201,10 @@ bool is_r_object_capsule(PyObject* capsule) {
   return PyCapsule_IsValid(capsule, r_object_string);
 }
 
+bool is_r_extptr_capsule(PyObject* capsule) {
+  return PyCapsule_IsValid(capsule, r_extptr_string);
+}
+
 // helper class for ensuring decref of PyObject in the current scope
 template <typename T>
 class PyPtr {
@@ -1405,6 +1418,11 @@ SEXP py_to_r(PyObject* x, bool convert) {
     return py_capsule_read(x);
   }
 
+  // external pointer
+  else if (is_r_extptr_capsule(x)) {
+    return py_extptr_capsule_read(x);
+  }
+
   // default is to return opaque wrapper to python object. we pass convert = true
   // because if we hit this code then conversion has been either implicitly
   // or explicitly requested.
@@ -1708,7 +1726,7 @@ static PyObject* r_extptr_capsule(SEXP sexp) {
 
   sexp = Rcpp_precious_preserve(sexp);
 
-  PyObject* capsule = PyCapsule_New(ptr, NULL, free_r_extptr_capsule);
+  PyObject* capsule = PyCapsule_New(ptr, r_extptr_string, free_r_extptr_capsule);
   PyCapsule_SetContext(capsule, (void*)sexp);
   return capsule;
 

tests/testthat/test-r-extptr-capsule.R

@@ -0,0 +1,49 @@
+test_that("py_to_r(<r_extptr_capsule>) returns the extptr", {
+
+  # Mock class for testing
+  Rcpp::sourceCpp(code='
+#include <Rcpp.h>
+using namespace Rcpp;
+
+class AClass {
+public:
+  AClass() {
+    Rprintf("AClass created");
+  }
+  ~AClass() {
+    Rprintf("AClass destroyed");
+  }
+};
+
+// [[Rcpp::export]]
+SEXP getA() {
+  AClass* ptr = new AClass;
+  return Rcpp::XPtr< AClass >(ptr);
+}
+', env = environment())
+
+  expect_output(x <- getA(), "AClass created")
+  expect_output({
+    xpy <- r_to_py(x)
+    x_ <- py_to_r(xpy)
+  }, NA)
+  expect_reference(x, x_) # same memory address
+
+  # test that gc()ing the py capsule doesn't gc() the extptr if there is
+  # a live R reference to it
+  expect_output({ rm(x, xpy); for(i in 1:3) gc(full = TRUE) }, NA)
+  expect_output({ rm(x_)    ; for(i in 1:3) gc(full = TRUE) }, "AClass destroyed")
+
+
+  # test that gc()ing the R ref to the extptr doesn't actuall gc() the extptr
+  # object if the py capsule has a live reference to it.
+  expect_output(x <- getA(), "AClass created")
+  expect_output({
+    xpy <- r_to_py(x)
+    x_ <- py_to_r(xpy)
+  }, NA)
+  expect_reference(x, x_) # same memory address
+  expect_output({ rm(x, x_); for(i in 1:3) gc(full = TRUE) }, NA)
+  expect_output({ rm(xpy)  ; for(i in 1:3) gc(full = TRUE) }, "AClass destroyed")
+
+})