1
2##  Copyright (C) 2018 - 2019  RStudio
3##
4##  This file is part of Rcpp.
5##
6##  Rcpp is free software: you can redistribute it and/or modify it
7##  under the terms of the GNU General Public License as published by
8##  the Free Software Foundation, either version 2 of the License, or
9##  (at your option) any later version.
10##
11##  Rcpp is distributed in the hope that it will be useful, but
12##  WITHOUT ANY WARRANTY; without even the implied warranty of
13##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14##  GNU General Public License for more details.
15##
16##  You should have received a copy of the GNU General Public License
17##  along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
18
19.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes" && Sys.getenv("RunVerboseRcppTests") == "yes"
20
21if (! .runThisTest) exit_file("Set 'RunVerboseRcppTests' and 'RunAllRcppTests' to 'yes' to run.")
22
23library(Rcpp)
24
25build_package <- function(name, lib_path, tempdir = getwd(),
26                          config = character()) {
27    file.copy(system.file("tinytest", name, package = "Rcpp"),
28              getwd(),
29              recursive = TRUE)
30
31    src_path <- file.path(tempdir, name)
32    Rcpp::compileAttributes(src_path)
33    writeLines(config, file.path(src_path, "src", "config.h"))
34
35    install.packages(
36        src_path,
37        lib_path,
38        repos = NULL,
39        type = "source",
40        INSTALL_opts = "--install-tests"
41    )
42}
43
44#    test.interface.unwind <- function() {
45exporter_name <- "testRcppInterfaceExporter"
46user_name <- "testRcppInterfaceUser"
47
48tempdir <- tempfile()
49dir.create(tempdir)
50old_wd <- setwd(tempdir)
51
52lib_path <- file.path(tempdir, "templib")
53dir.create(lib_path)
54
55old_lib_paths <- .libPaths()
56on.exit(.libPaths(old_lib_paths), add = TRUE)
57.libPaths(c(lib_path, old_lib_paths))
58
59## Without this testInstalledPackage() won't find installed
60## packages even though we've passed `lib.loc`
61old_libs_envvar <- Sys.getenv("R_LIBS")
62on.exit(Sys.setenv(R_LIBS = old_libs_envvar), add = TRUE)
63
64sys_sep <- if (.Platform$OS.type == "windows") ";" else ":"
65Sys.setenv(R_LIBS = paste(c(lib_path, old_lib_paths), collapse = sys_sep))
66
67cfg <- "#define RCPP_USE_UNWIND_PROTECT"
68build_package(exporter_name, lib_path, config = cfg)
69build_package(user_name, lib_path, config = cfg)
70
71result <- tools::testInstalledPackage(user_name, lib.loc = lib_path, types = "test")
72
73## Be verbose if tests were not successful
74if (result) {
75    log <- file.path(paste0(user_name, "-tests"), "tests.Rout.fail")
76    cat(">> PROTECTED tests.Rout.fail", readLines(log), sep = "\n", file = stderr())
77}
78
79expect_equal(result, 0L)
80
81
82## Now test client package without protected evaluation
83unlink(user_name, recursive = TRUE)
84unlink(paste0(user_name, "-tests"), recursive = TRUE)
85build_package(user_name, lib_path, config = character())
86
87result <- tools::testInstalledPackage(user_name, lib.loc = lib_path, types = "test")
88
89if (result) {
90    log <- file.path(paste0(user_name, "-tests"), "tests.Rout.fail")
91    cat(">> UNPROTECTED tests.Rout.fail", readLines(log), sep = "\n", file = stderr())
92}
93
94expect_equal(result, 0L)
95
96on.exit({
97    setwd(old_wd)
98    unlink(tempdir, recursive = TRUE)
99})
100