validate module objects before converting them to c++ classes (#1524)

* validate module objects before converting them to c++ classes

* use regex patterns instead of fixed = TRUE, unsupported by tinytest < 1.3.1

Author: kevinushey

ChangeLog

@@ -25,6 +25,16 @@
 	element, which it is not once coverage tools have instrumented the body
 	* R/00_classes.R (.cppfunction_set_external_args): New helper
 	* inst/tinytest/test_module.R: Test it with an instrumented body
+	* inst/include/Rcpp/api/meat/as.h (as_module_object_internal): Check
+	that the argument is a live module object, raising an error for
+	deserialized, uninitialized and non-module objects instead of handing
+	out a NULL or garbage address; a new overload taking the expected C++
+	type also requires the object's class to be that type or one that
+	derives() from it (#1523)
+	* inst/include/Rcpp/as.h: Use the new overload when converting to
+	module classes
+	* inst/tinytest/cpp/Module.cpp: Add a class deriving from another
+	* inst/tinytest/test_module.R: Test the new checks
 
 2026-10-23  Dirk Eddelbuettel  <edd@debian.org>
 

inst/include/Rcpp/api/meat/as.h

@@ -21,10 +21,100 @@
 namespace Rcpp{
 namespace internal{
 
+    // the address of the C++ object held by the module object whose
+    // environment is env (see cpp_object_initializer() in R/Module.R)
+    inline void* module_object_address(const Environment& env){
+        SEXP xp = env.get(".pointer") ;
+        if( xp == R_NilValue )
+            throw not_compatible( "Expecting a C++ module object" ) ;
+
+        // the dummy object of a class without a default constructor
+        if( TYPEOF(xp) != EXTPTRSXP )
+            throw not_initialized() ;
+
+        // e.g. a deserialized object
+        void* ptr = R_ExternalPtrAddr(xp) ;
+        if( ptr == NULL )
+            throw ::Rcpp::exception( "external pointer is not valid" ) ;
+
+        return ptr ;
+    }
+
+#ifndef RCPP_NO_MODULES
+    // whether the module class cl is the C++ class typeinfo_name, or derives
+    // from it through class_::derives(), which records each parent by its R
+    // class name, "Rcpp_" followed by its name in the module
+    inline bool module_class_is( class_Base* cl, Module* module, const char* typeinfo_name ){
+        if( cl->has_typeinfo_name(typeinfo_name) )
+            return true ;
+
+        std::vector<class_Base*> todo(1, cl) ;
+        std::set<class_Base*> seen ;
+        while( module && !todo.empty() ){
+            class_Base* current = todo.back() ;
+            todo.pop_back() ;
+            if( !seen.insert(current).second )
+                continue ;
+
+            if( current->has_typeinfo_name(typeinfo_name) )
+                return true ;
+
+            for( size_t i = 0; i < current->parents.size(); i++ ){
+                const std::string& parent = current->parents[i] ;
+                if( parent.compare(0, 5, "Rcpp_") != 0 )
+                    continue ;
+                std::string name = parent.substr(5) ;
+                if( module->has_class(name) )
+                    todo.push_back( module->get_class_pointer(name) ) ;
+            }
+        }
+        return false ;
+    }
+#endif
+
+    // packages call this one directly, so it stays; it cannot check the class
     inline void* as_module_object_internal(SEXP obj){
+        if( !Rf_isS4(obj) )
+            throw not_compatible( "Expecting a C++ module object" ) ;
         Environment env(obj) ;
-        SEXP xp = env.get(".pointer") ;
-        return R_ExternalPtrAddr(xp );
+        return module_object_address(env) ;
+    }
+
+    inline void* as_module_object_internal(SEXP obj, const char* typeinfo_name){
+        if( !Rf_isS4(obj) ){
+            throw not_compatible(
+                "Expecting an object of C++ class '%s'",
+                demangle(typeinfo_name)
+            ) ;
+        }
+        Environment env(obj) ;
+        void* ptr = module_object_address(env) ;
+
+#ifndef RCPP_NO_MODULES
+        SEXP cppclass = env.get(".cppclass") ;
+        if( TYPEOF(cppclass) != EXTPTRSXP || R_ExternalPtrAddr(cppclass) == NULL ){
+            throw not_compatible(
+                "Expecting an object of C++ class '%s'",
+                demangle(typeinfo_name)
+            ) ;
+        }
+        class_Base* cl = reinterpret_cast<class_Base*>( R_ExternalPtrAddr(cppclass) ) ;
+
+        SEXP module_xp = env.get(".module") ;
+        Module* module = NULL ;
+        if( TYPEOF(module_xp) == EXTPTRSXP )
+            module = reinterpret_cast<Module*>( R_ExternalPtrAddr(module_xp) ) ;
+
+        if( !module_class_is(cl, module, typeinfo_name) ){
+            throw not_compatible(
+                "Expecting an object of C++ class '%s', got an object of class '%s'",
+                demangle(typeinfo_name),
+                cl->name
+            ) ;
+        }
+#endif
+
+        return ptr ;
     }
 
 }

inst/include/Rcpp/as.h

@@ -89,15 +89,17 @@ namespace Rcpp {
         }
 
         void* as_module_object_internal(SEXP obj);
+        void* as_module_object_internal(SEXP obj, const char* typeinfo_name);
 
         template <typename T> object<T> as_module_object(SEXP x) {
-            return (T*) as_module_object_internal(x);
+            return (T*) as_module_object_internal(x, typeid(T).name());
         }
 
         /** handling object<T> */
         template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_module_object_const_pointer_tag) {
             typedef typename Rcpp::traits::remove_const<T>::type T_NON_CONST;
-            return const_cast<T>((T_NON_CONST)as_module_object_internal(x));
+            typedef typename Rcpp::traits::un_pointer<T>::type CLASS;
+            return const_cast<T>((T_NON_CONST)as_module_object_internal(x, typeid(CLASS).name()));
         }
 
         template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_module_object_pointer_tag) {

inst/tinytest/cpp/Module.cpp

@@ -155,6 +155,24 @@ double Test_get_x_pointer(ModuleTest* x) {
     return x->value;
 }
 
+class ModuleBase {
+public:
+    ModuleBase() : value(1.0) {}
+    virtual ~ModuleBase() {}
+    double value;
+};
+
+class ModuleDerived : public ModuleBase {
+public:
+    ModuleDerived() { value = 2.0; }
+};
+
+RCPP_EXPOSED_CLASS_NODECL(ModuleBase)
+
+double ModuleBase_value(const ModuleBase& x) {
+    return x.value;
+}
+
 class ModuleGadget {
 public:
     ModuleGadget() {}
@@ -254,6 +272,17 @@ RCPP_MODULE(demoModule) {
         .method("get" , &ModuleRandomizer::get)
         ;
 
+    class_<ModuleBase>("ModuleBase")
+        .constructor()
+        ;
+
+    class_<ModuleDerived>("ModuleDerived")
+        .derives<ModuleBase>("ModuleBase")
+        .constructor()
+        ;
+
+    function("ModuleBase_value", &ModuleBase_value);
+
     class_<ModuleGadget>("ModuleGadget")
         .constructor()
         .method("value", static_cast<void (ModuleGadget::*)(int)>(&ModuleGadget::value))

inst/tinytest/test_module.R

@@ -90,6 +90,24 @@ expect_equal( attr_Test_get_x_const_pointer(test), 3.0 )
 expect_equal( attr_Test_get_x_ref(test), 3.0 )
 expect_equal( attr_Test_get_x_pointer(test), 3.0 )
 
+## module object arguments are validated before their address is handed to
+## C++, instead of reinterpreting or dereferencing whatever is there (#1523);
+## patterns are regular expressions, as tinytest < 1.3.1 has no 'fixed'
+expect_error( Test_get_x_const_ref( new( ModuleWorld ) ),
+             "Expecting an object of C\\+\\+ class 'ModuleTest', got an object of class 'ModuleWorld'" )
+expect_error( attr_Test_get_x_ref( new( ModuleWorld ) ),
+             "got an object of class 'ModuleWorld'" )
+expect_error( Test_get_x_pointer( unserialize( serialize( test, NULL ) ) ),
+             "external pointer is not valid" )
+uninitialized <- new( ModuleTest )
+expect_error( Test_get_x_ref( uninitialized ), "not initialized" )
+expect_error( Test_get_x_const_pointer( 1 ),
+             "Expecting an object of C\\+\\+ class 'ModuleTest'" )
+
+## objects of a class that derives() from the expected one are accepted
+expect_equal( ModuleBase_value( new( ModuleBase ) ), 1.0 )
+expect_equal( ModuleBase_value( new( ModuleDerived ) ), 2.0 )
+
 #    test.Module.property <- function(){
 w <- new( ModuleNum )
 expect_equal( w$x, 0.0 )