Rcpp/inst/tinytest/test_global_rostream.R at master · RcppCore/Rcpp · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108

##  Copyright (C) 2021  Iñaki Ucar
##
##  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" && Sys.getenv("RunVerboseRcppTests") == "yes"

if (! .runThisTest) exit_file("Set 'RunVerboseRcppTests' and 'RunAllRcppTests' to 'yes' to run.")

library(Rcpp)

mkv <- "PKG_CPPFLAGS = -DRCPP_USE_GLOBAL_ROSTREAM"
cfg <- "
#ifndef RCPP_USE_GLOBAL_ROSTREAM
#define RCPP_USE_GLOBAL_ROSTREAM
#endif
#include <Rcpp.h>
using namespace Rcpp;"
ptr <- "
// [[Rcpp::export]]
CharacterVector ptr%s() {
    CharacterVector out(2);
    std::ostringstream Rcout_address, Rcerr_address;
    Rcout_address << (void const *)(&Rcout);
    Rcerr_address << (void const *)(&Rcerr);
    out[0] = Rcout_address.str();
    out[1] = Rcerr_address.str();
    return out;
}"
alig <- "
// [[Rcpp::export]]
void toLeft() {
    Rcout << std::left;
    Rcerr << std::left;
}
// [[Rcpp::export]]
void toRight() {
    Rcout << std::right;
    Rcerr << std::right;
}"
print <- '
// [[Rcpp::export]]
void something() {
    Rcout << std::setw(20) << "somethingRcout" << std::endl;
    Rcerr << std::setw(20) << "somethingRcerr" << std::endl;
}'

# create package and write functions into separate translation units
pkg_name <- "fooRostream"
path <- tempdir()
pkg_path <- file.path(path, pkg_name)
src_path <- file.path(pkg_path, "src")

if (dir.exists(pkg_path)) unlink(pkg_path)
Rcpp.package.skeleton(
    pkg_name, path=path, environment=environment(), example_code=FALSE)
writeLines(c(cfg, sprintf(ptr, "A")), file.path(src_path, "ptrA.cpp"))
writeLines(c(cfg, sprintf(ptr, "B")), file.path(src_path, "ptrB.cpp"))
writeLines(c(cfg, alig), file.path(src_path, "alig.cpp"))
writeLines(c(cfg, print), file.path(src_path, "print.cpp"))
writeLines(mkv, file.path(src_path, "Makevars"))
compileAttributes(pkg_path)

# tests
testRostream <- function() {
    captureFun <- function(...) {
        err <- capture.output(
            out <- capture.output(..., type="output"), type="message")
        c(out, err)
    }
    res <- all(ptrA() == ptrB())
    res <- c(res, all(grepl("^ ", captureFun(something()))))
    toLeft() # change alignment globally
    res <- c(res, all(grepl("^s", captureFun(something()))))
    toRight() # restore
    res
}

# test package
lib_path <- file.path(path, "templib")
dir.create(lib_path)
install.packages(pkg_path, lib_path, repos=NULL, type="source")
expect_true(require("fooRostream", lib.loc=lib_path, character.only=TRUE))
expect_true(all(testRostream()))

# test sourceCpp
sourceCpp(file.path(src_path, "ptrA.cpp"))
sourceCpp(file.path(src_path, "ptrB.cpp"))
sourceCpp(file.path(src_path, "alig.cpp"))
sourceCpp(file.path(src_path, "print.cpp"))
expect_true(all(testRostream()))

# cleanup
on.exit(unlink(pkg_path, recursive=TRUE), add=TRUE)
on.exit(unlink(lib_path, recursive=TRUE), add=TRUE)