1
2##  Copyright (C) 2021  Iñaki Ucar
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
25mkv <- "PKG_CPPFLAGS = -DRCPP_USE_GLOBAL_ROSTREAM"
26cfg <- "
27#ifndef RCPP_USE_GLOBAL_ROSTREAM
28#define RCPP_USE_GLOBAL_ROSTREAM
29#endif
30#include <Rcpp.h>
31using namespace Rcpp;"
32ptr <- "
33// [[Rcpp::export]]
34CharacterVector ptr%s() {
35    CharacterVector out(2);
36    std::ostringstream Rcout_address, Rcerr_address;
37    Rcout_address << (void const *)(&Rcout);
38    Rcerr_address << (void const *)(&Rcerr);
39    out[0] = Rcout_address.str();
40    out[1] = Rcerr_address.str();
41    return out;
42}"
43alig <- "
44// [[Rcpp::export]]
45void toLeft() {
46    Rcout << std::left;
47    Rcerr << std::left;
48}
49// [[Rcpp::export]]
50void toRight() {
51    Rcout << std::right;
52    Rcerr << std::right;
53}"
54print <- '
55// [[Rcpp::export]]
56void something() {
57    Rcout << std::setw(20) << "somethingRcout" << std::endl;
58    Rcerr << std::setw(20) << "somethingRcerr" << std::endl;
59}'
60
61# create package and write functions into separate translation units
62pkg_name <- "fooRostream"
63path <- tempdir()
64pkg_path <- file.path(path, pkg_name)
65src_path <- file.path(pkg_path, "src")
66
67if (dir.exists(pkg_path)) unlink(pkg_path)
68Rcpp.package.skeleton(
69    pkg_name, path=path, environment=environment(), example_code=FALSE)
70writeLines(c(cfg, sprintf(ptr, "A")), file.path(src_path, "ptrA.cpp"))
71writeLines(c(cfg, sprintf(ptr, "B")), file.path(src_path, "ptrB.cpp"))
72writeLines(c(cfg, alig), file.path(src_path, "alig.cpp"))
73writeLines(c(cfg, print), file.path(src_path, "print.cpp"))
74writeLines(mkv, file.path(src_path, "Makevars"))
75compileAttributes(pkg_path)
76
77# tests
78testRostream <- function() {
79    captureFun <- function(...) {
80        err <- capture.output(
81            out <- capture.output(..., type="output"), type="message")
82        c(out, err)
83    }
84    res <- all(ptrA() == ptrB())
85    res <- c(res, all(grepl("^ ", captureFun(something()))))
86    toLeft() # change alignment globally
87    res <- c(res, all(grepl("^s", captureFun(something()))))
88    toRight() # restore
89    res
90}
91
92# test package
93lib_path <- file.path(path, "templib")
94dir.create(lib_path)
95install.packages(pkg_path, lib_path, repos=NULL, type="source")
96expect_true(require("fooRostream", lib.loc=lib_path, character.only=TRUE))
97expect_true(all(testRostream()))
98
99# test sourceCpp
100sourceCpp(file.path(src_path, "ptrA.cpp"))
101sourceCpp(file.path(src_path, "ptrB.cpp"))
102sourceCpp(file.path(src_path, "alig.cpp"))
103sourceCpp(file.path(src_path, "print.cpp"))
104expect_true(all(testRostream()))
105
106# cleanup
107on.exit(unlink(pkg_path, recursive=TRUE), add=TRUE)
108on.exit(unlink(lib_path, recursive=TRUE), add=TRUE)
109