#pragma once #include // for snprintf #include // for strcmp #include // for string, basic_string #include // for forward #include "cpp11/R.hpp" // for SEXP, SEXPREC, CDR, Rf_install, SETCAR #include "cpp11/as.hpp" // for as_sexp #include "cpp11/named_arg.hpp" // for named_arg #include "cpp11/protect.hpp" // for protect, protect::function, safe, stop #include "cpp11/sexp.hpp" // for sexp #ifdef CPP11_USE_FMT #define FMT_HEADER_ONLY #include "fmt/core.h" #endif namespace cpp11 { class function { public: function(SEXP data) : data_(data) {} template sexp operator()(Args&&... args) const { // Size of the arguments plus one for the function name itself R_xlen_t num_args = sizeof...(args) + 1; sexp call(safe[Rf_allocVector](LANGSXP, num_args)); construct_call(call, data_, std::forward(args)...); return safe[Rf_eval](call, R_GlobalEnv); } private: sexp data_; template void construct_call(SEXP val, const named_arg& arg, Args&&... args) const { SETCAR(val, arg.value()); SET_TAG(val, safe[Rf_install](arg.name())); val = CDR(val); construct_call(val, std::forward(args)...); } // Construct the call recursively, each iteration adds an Arg to the pairlist. template void construct_call(SEXP val, const T& arg, Args&&... args) const { SETCAR(val, as_sexp(arg)); val = CDR(val); construct_call(val, std::forward(args)...); } // Base case, just return void construct_call(SEXP val) const {} }; class package { public: package(const char* name) : data_(get_namespace(name)) {} package(const std::string& name) : data_(get_namespace(name.c_str())) {} function operator[](const char* name) { return safe[Rf_findFun](safe[Rf_install](name), data_); } function operator[](const std::string& name) { return operator[](name.c_str()); } private: static SEXP get_namespace(const char* name) { if (strcmp(name, "base") == 0) { return R_BaseEnv; } SEXP env = safe[detail::r_ns_env](name); if (env == R_NilValue) { stop("Can't find namespace: '%s'.", name); } return env; } // Either base env or in namespace registry, so no protection needed SEXP data_; }; namespace detail { // Special internal way to call `base::message()` // // - Pure C, so call with `safe[]` // - Holds a `static SEXP` for the `base::message` function protected with // `R_PreserveObject()` // // We don't use a `static cpp11::function` because that will infinitely retain a cell in // our preserve list, which can throw off our counts in the preserve list tests. inline void r_message(const char* x) { static SEXP fn = NULL; if (fn == NULL) { fn = Rf_findFun(Rf_install("message"), R_BaseEnv); R_PreserveObject(fn); } SEXP x_char = PROTECT(Rf_mkCharCE(x, CE_UTF8)); SEXP x_string = PROTECT(Rf_ScalarString(x_char)); SEXP call = PROTECT(Rf_lang2(fn, x_string)); Rf_eval(call, R_GlobalEnv); UNPROTECT(3); } } // namespace detail inline void message(const char* fmt_arg) { #ifdef CPP11_USE_FMT std::string msg = fmt::format(fmt::runtime(fmt_arg)); safe[detail::r_message](msg.c_str()); #else char buff[1024]; int msg; msg = std::snprintf(buff, 1024, "%s", fmt_arg); if (msg >= 0 && msg < 1024) { safe[detail::r_message](buff); } #endif } template void message(const char* fmt_arg, Args... args) { #ifdef CPP11_USE_FMT std::string msg = fmt::format(fmt::runtime(fmt_arg), args...); safe[detail::r_message](msg.c_str()); #else char buff[1024]; int msg; msg = std::snprintf(buff, 1024, fmt_arg, args...); if (msg >= 0 && msg < 1024) { safe[detail::r_message](buff); } #endif } inline void message(const std::string& fmt_arg) { message(fmt_arg.c_str()); } template void message(const std::string& fmt_arg, Args... args) { message(fmt_arg.c_str(), args...); } } // namespace cpp11