Control whether exceptions include the call and C++ stack with a macros (#868)

* Support for configuring default value for include_call parameter of Rcpp exceptions.

* Also use RCPP_DEFAULT_INCLUDE_CALL for exception classes other than Rcpp::exception

use Shelter instead of Shield because e.g. the result of get_last_call() would not be protected long enough.

rework exception_to_r_condition and rcpp_exception_to_r_condition so that they share the same code via a template

* Additional tests for Rcpp::exception and eval_error. Trsting that they don't include call and cppstack when RCPP_DEFAULT_INCLUDE_CALL is defined to false

* using namespace Rcpp;

* s/eval_error/eval_error_no_call/ for disambiguation

Author: romainfrancois

inst/include/Rcpp/exceptions.h

@@ -24,19 +24,22 @@
 
 #include <Rversion.h>
 
+#ifndef RCPP_DEFAULT_INCLUDE_CALL
+#define RCPP_DEFAULT_INCLUDE_CALL true
+#endif
 
 #define GET_STACKTRACE() stack_trace( __FILE__, __LINE__ )
 
 namespace Rcpp {
 
     class exception : public std::exception {
     public:
-        explicit exception(const char* message_, bool include_call = true) :	// #nocov start
+        explicit exception(const char* message_, bool include_call = RCPP_DEFAULT_INCLUDE_CALL) :	// #nocov start
             message(message_),
             include_call_(include_call){
             rcpp_set_stack_trace(Shield<SEXP>(stack_trace()));
         }
-        exception(const char* message_, const char*, int, bool include_call = true) :
+        exception(const char* message_, const char*, int, bool include_call = RCPP_DEFAULT_INCLUDE_CALL) :
             message(message_),
             include_call_(include_call){
             rcpp_set_stack_trace(Shield<SEXP>(stack_trace()));
@@ -306,34 +309,32 @@ inline SEXP make_condition(const std::string& ex_msg, SEXP call, SEXP cppstack,
     return res ;
 }
 
+template <typename Exception>
+inline SEXP exception_to_condition_template( const Exception& ex, bool include_call) {
+  std::string ex_class = demangle( typeid(ex).name() ) ;
+  std::string ex_msg   = ex.what() ;
+
+  Rcpp::Shelter<SEXP> shelter;
+  SEXP call, cppstack;
+  if (include_call) {
+      call = shelter(get_last_call());
+      cppstack = shelter(rcpp_get_stack_trace());
+  } else {
+      call = R_NilValue;
+      cppstack = R_NilValue;
+  }
+  SEXP classes = shelter( get_exception_classes(ex_class) );
+  SEXP condition = shelter( make_condition( ex_msg, call, cppstack, classes) );
+  rcpp_set_stack_trace( R_NilValue ) ;
+  return condition ;
+}
+
 inline SEXP rcpp_exception_to_r_condition(const Rcpp::exception& ex) {
-    std::string ex_class = demangle( typeid(ex).name() ) ;
-    std::string ex_msg   = ex.what() ;
-
-    SEXP call, cppstack;
-    if (ex.include_call()) {
-        call = Rcpp::Shield<SEXP>(get_last_call());
-        cppstack = Rcpp::Shield<SEXP>( rcpp_get_stack_trace());
-    } else {
-        call = R_NilValue;
-        cppstack = R_NilValue;
-    }
-    Rcpp::Shield<SEXP> classes( get_exception_classes(ex_class) );
-    Rcpp::Shield<SEXP> condition( make_condition( ex_msg, call, cppstack, classes) );
-    rcpp_set_stack_trace( R_NilValue ) ;
-    return condition ;
+  return exception_to_condition_template(ex, ex.include_call());
 }
 
 inline SEXP exception_to_r_condition( const std::exception& ex){
-    std::string ex_class = demangle( typeid(ex).name() ) ;
-    std::string ex_msg   = ex.what() ;
-
-    Rcpp::Shield<SEXP> cppstack( rcpp_get_stack_trace() );
-    Rcpp::Shield<SEXP> call( get_last_call() );
-    Rcpp::Shield<SEXP> classes( get_exception_classes(ex_class) );
-    Rcpp::Shield<SEXP> condition( make_condition( ex_msg, call, cppstack, classes) );
-    rcpp_set_stack_trace( R_NilValue ) ;
-    return condition ;
+  return exception_to_condition_template(ex, RCPP_DEFAULT_INCLUDE_CALL);
 }
 
 inline SEXP string_to_try_error( const std::string& str){

inst/unitTests/cpp/Exceptions_nocall.cpp

@@ -0,0 +1,13 @@
+#define RCPP_DEFAULT_INCLUDE_CALL false
+#include <Rcpp.h>
+using namespace Rcpp;
+
+// [[Rcpp::export]]
+void Rcpp_exception(){
+    throw Rcpp::exception("ouch");
+}
+
+// [[Rcpp::export]]
+void eval_error_no_call(){
+    Rcpp_eval(Rf_lang1(Rf_install("ouch")), R_EmptyEnv);
+}

inst/unitTests/runit.Exceptions_nocall.R

@@ -0,0 +1,40 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2018  Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
+
+.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
+
+if (.runThisTest) {
+
+    .setUp <- Rcpp:::unitTestSetup("Exceptions_nocall.cpp")
+
+    test.Rcpp_exception <- function() {
+        tryCatch(Rcpp_exception(), error = function(e){
+            checkTrue(is.null(e$call))
+            checkTrue(is.null(e$cppstack))
+        })
+    }
+
+    test.eval_error <- function() {
+        tryCatch(eval_error_no_call(), error = function(e){
+            checkTrue(is.null(e$call))
+            checkTrue(is.null(e$cppstack))
+        })
+    }
+
+}