Codebase list r-cran-bindrcpp / lintian-fixes/main src / test.cpp
lintian-fixes/main

Tree @lintian-fixes/main (Download .tar.gz)

test.cpp @lintian-fixes/mainraw · history · blame

#include <Rcpp.h>

#include <bindrcpp.h>

#include <plogr.h>

#include <algorithm>
#include <string>

using namespace Rcpp;

using namespace bindrcpp;

// [[Rcpp::export(rng = FALSE)]]
SEXP callback_string_typed(Symbol name, bindrcpp::GETTER_FUNC_STRING_TYPED fun, bindrcpp::PAYLOAD payload) {
  LOG_VERBOSE << type2name(name);
  LOG_VERBOSE << payload.p;

  String name_string = name.c_str();
  name_string.set_encoding(CE_NATIVE);

  return fun(name_string, payload);
}

// [[Rcpp::export(rng = FALSE)]]
SEXP callback_symbol_typed(Symbol name, bindrcpp::GETTER_FUNC_SYMBOL_TYPED fun, bindrcpp::PAYLOAD payload) {
  LOG_VERBOSE << type2name(name);
  LOG_VERBOSE << payload.p;

  return fun(name, payload);
}

// [[Rcpp::export(rng = FALSE)]]
SEXP callback_string_wrapped(Symbol name, bindrcpp::GETTER_FUNC_STRING_WRAPPED fun, List payload) {
  LOG_VERBOSE << type2name(name);

  String name_string = name.c_str();
  name_string.set_encoding(CE_NATIVE);

  return fun(name_string, payload);
}

// [[Rcpp::export(rng = FALSE)]]
SEXP callback_symbol_wrapped(Symbol name, bindrcpp::GETTER_FUNC_SYMBOL_WRAPPED fun, List payload) {
  LOG_VERBOSE << type2name(name);

  return fun(name, payload);
}

class CallbackTester {
  enum { MAGIC = 20161014 };
  const int magic;

public:
  CallbackTester() : magic(MAGIC) { LOG_VERBOSE; }
  ~CallbackTester() { LOG_VERBOSE; }

  static SEXP tolower_static(const Rcpp::String& name, List payload) {
    XPtr<CallbackTester> p = payload[0];
    CallbackTester* this_ = p.get();
    LOG_VERBOSE << this_;
    return this_->tolower(name);
  }

  static SEXP toupper_static(const Rcpp::String& name, List payload) {
    XPtr<CallbackTester> p = payload[0];
    CallbackTester* this_ = p.get();
    LOG_VERBOSE << this_;
    return this_->toupper(name);
  }

private:
  SEXP tolower(Rcpp::String name) {
    LOG_VERBOSE << magic;
    if (magic != MAGIC)
      stop("payload lost");
    std::string name_string = name;
    std::transform(name_string.begin(), name_string.end(), name_string.begin(), ::tolower);
    return CharacterVector(name_string);
  }

  SEXP toupper(Rcpp::String name) {
    LOG_VERBOSE << magic;
    if (magic != MAGIC)
      stop("payload lost");
    std::string name_string = name;
    std::transform(name_string.begin(), name_string.end(), name_string.begin(), ::toupper);
    return CharacterVector(name_string);
  }
};

// [[Rcpp::export]]
Environment do_test_create_environment(CharacterVector names, String xform, Environment parent) {
  List payload = List::create(_["callback"] = XPtr<CallbackTester>(new CallbackTester));

  if (xform == "tolower") {
    return bindrcpp::create_env_string_wrapped(
      names, &CallbackTester::tolower_static, payload, parent);
  }
  else if (xform == "toupper") {
    return bindrcpp::create_env_string_wrapped(
      names, &CallbackTester::toupper_static, payload, parent);
  }
  else
    stop("unknown xform");
}