Add unit tests for jumping across cpp interfaces

Author: lionel-

ChangeLog

@@ -1,4 +1,13 @@
 
+2018-06-01  Lionel Henry  <[email protected]>
+
+        * inst/unitTests/runit.interface.R: New tests for interfaces and unwind.
+        These tests build two packages, and that exports a function via
+        Rcpp::interfaces(cpp) and the other that calls it. The attributes are
+        regenerated and the packages rebuilt each time the tests are run. The
+        tests check in particular that the C++ stack is properly unwound when a
+        long jump occurs.
+
 2018-05-31  Lionel Henry  <[email protected]>
 
         * inst/include/Rcpp/api/meat/Rcpp_eval.h: Fix protected evaluation.

inst/unitTests/runit.interface.R

@@ -0,0 +1,87 @@
+#!/usr/bin/env r
+# -*- mode: R; tab-width: 4; -*-
+#
+# Copyright (C) 2018  RStudio
+#
+# 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) {
+
+    test.interface.unwind <- function() {
+        exporter_name <- "testRcppInterfaceExporter"
+        user_name <- "testRcppInterfaceUser"
+
+        tempdir <- tempfile()
+        dir.create(tempdir)
+        old_wd <- setwd(tempdir)
+        on.exit({
+            setwd(old_wd)
+            unlink(tempdir, recursive = TRUE)
+        })
+
+        file.copy(system.file("unitTests", exporter_name, package = "Rcpp"),
+                  tempdir,
+                  recursive = TRUE)
+        file.copy(system.file("unitTests", user_name, package = "Rcpp"),
+                  tempdir,
+                  recursive = TRUE)
+
+        exporter_path <- file.path(tempdir, exporter_name)
+        user_path <- file.path(tempdir, user_name)
+
+        Rcpp::compileAttributes(exporter_path)
+        Rcpp::compileAttributes(user_path)
+
+        lib_path <- file.path(tempdir, "templib")
+        dir.create(lib_path)
+
+        install <- function(path, lib_path) {
+            install.packages(
+                path,
+                lib_path,
+                repos = NULL,
+                type = "source",
+                INSTALL_opts = "--install-tests"
+            )
+        }
+        install(exporter_path, lib_path)
+        install(user_path, lib_path)
+
+        old_lib_paths <- .libPaths()
+        on.exit(.libPaths(old_lib_paths))
+        .libPaths(lib_path)
+
+        # Without this testInstalledPackage() won't find installed
+        # packages even though we've passed `lib.loc`
+        old_libs_envvar <- Sys.getenv("R_LIBS")
+        on.exit(Sys.setenv(R_LIBS = old_libs_envvar), add = TRUE)
+
+        sys_sep <- if (.Platform$OS.type == "windows") ";" else ":"
+        Sys.setenv(R_LIBS = paste(c(lib_path, old_lib_paths), collapse = sys_sep))
+
+        result <- tools::testInstalledPackage(user_name, lib.loc = lib_path, types = "test")
+
+        # Be verbose if tests were not successful
+        if (result) {
+            log <- file.path(paste0(user_name, "-tests"), "tests.Rout.fail")
+            cat(">> tests.Rout.fail", readLines(log), sep = "\n", file = stderr())
+        }
+
+        checkEquals(result, 0L)
+    }
+
+}

inst/unitTests/testRcppInterfaceExporter/DESCRIPTION

@@ -0,0 +1,12 @@
+Package: testRcppInterfaceExporter
+Title: Exports c++ function via the cpp interface
+Version: 0.1.0
+Authors@R: 'Lionel Henry <[email protected]> [aut, cre]'
+Description: The API package.
+Depends:
+    R (>= 3.1.0)
+Imports:
+    Rcpp
+LinkingTo:
+    Rcpp
+License: GPL-3

inst/unitTests/testRcppInterfaceExporter/NAMESPACE

@@ -0,0 +1,7 @@
+# Generated by roxygen2: do not edit by hand
+
+export(peek_flag)
+export(reset_flags)
+export(test_cpp_interface)
+importFrom(Rcpp,sourceCpp)
+useDynLib(testRcppInterfaceExporter, .registration = TRUE)

inst/unitTests/testRcppInterfaceExporter/R/exporter.R

@@ -0,0 +1,18 @@
+#' @useDynLib testRcppInterfaceExporter, .registration = TRUE
+#' @importFrom Rcpp sourceCpp
+NULL
+
+flags <- new.env(parent = emptyenv())
+
+#' @export
+reset_flags <- function() {
+  flags$cpp_interface_upstream <- FALSE
+}
+.onLoad <- function(lib, pkg) {
+  reset_flags()
+}
+
+#' @export
+peek_flag <- function(name) {
+  flags[[name]]
+}

inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp

@@ -0,0 +1,13 @@
+#define RCPP_PROTECTED_EVAL
+
+#include <Rcpp.h>
+#include "unwound.h"
+
+// [[Rcpp::interfaces(r, cpp)]]
+
+//' @export
+// [[Rcpp::export]]
+SEXP test_cpp_interface(SEXP x) {
+  unwound_t stack_obj("cpp_interface_upstream");
+  return Rcpp::Rcpp_fast_eval(x, R_GlobalEnv);
+}

inst/unitTests/testRcppInterfaceExporter/src/unwound.h

@@ -0,0 +1,27 @@
+#ifndef UNWOUND_H
+#define UNWOUND_H
+
+
+#include <Rcpp.h>
+
+#define PKG_NAME "testRcppInterfaceExporter"
+
+struct unwound_t {
+  unwound_t(std::string flag_) {
+    flag = flag_;
+    Rcpp::Rcout << "Initialising " << flag << std::endl;
+    Rcpp::Environment ns = Rcpp::Environment::namespace_env(PKG_NAME);
+    flags_env = ns["flags"];
+    flags_env[flag] = false;
+  }
+  ~unwound_t() {
+    Rcpp::Rcout << "Unwinding " << flag << std::endl;
+    flags_env[flag] = true;
+  }
+
+  std::string flag;
+  Rcpp::Environment flags_env;
+};
+
+
+#endif

inst/unitTests/testRcppInterfaceUser/DESCRIPTION

@@ -0,0 +1,13 @@
+Package: testRcppInterfaceUser
+Title: Calls exported c++ function of testRcppInterfaceExporter
+Version: 0.1.0
+Authors@R: 'Lionel Henry <[email protected]> [aut, cre]'
+Description: The client package.
+Depends:
+    R (>= 3.1.0)
+Imports:
+    Rcpp
+LinkingTo:
+    testRcppInterfaceExporter,
+    Rcpp
+License: GPL-3

inst/unitTests/testRcppInterfaceUser/NAMESPACE

@@ -0,0 +1,7 @@
+# Generated by roxygen2: do not edit by hand
+
+export(peek_flag)
+export(reset_flags)
+export(use_cpp_interface)
+importFrom(Rcpp,sourceCpp)
+useDynLib(testRcppInterfaceUser, .registration = TRUE)

inst/unitTests/testRcppInterfaceUser/R/user.R

@@ -0,0 +1,18 @@
+#' @useDynLib testRcppInterfaceUser, .registration = TRUE
+#' @importFrom Rcpp sourceCpp
+NULL
+
+flags <- new.env(parent = emptyenv())
+
+#' @export
+reset_flags <- function() {
+  flags$cpp_interface_downstream <- FALSE
+}
+.onLoad <- function(lib, pkg) {
+  reset_flags()
+}
+
+#' @export
+peek_flag <- function(name) {
+  flags[[name]]
+}