From be29609043baf574381846d3e505151b9fa781f8 Mon Sep 17 00:00:00 2001 From: Aaron Lun Date: Tue, 29 Aug 2023 16:11:47 -0700 Subject: [PATCH] Support parsing and writing of base and empty environments. (#8) --- include/rds2cpp/Environment.hpp | 3 +- include/rds2cpp/SharedWriteInfo.hpp | 4 +- include/rds2cpp/parse_environment.hpp | 17 +++++- include/rds2cpp/parse_object.hpp | 6 ++ include/rds2cpp/write_object.hpp | 2 + tests/src/parse.cpp | 21 ++++++- tests/src/write.cpp | 12 +++- tests/tests/testthat/test-environment.R | 77 +++++++++++++++++++++++++ 8 files changed, 135 insertions(+), 7 deletions(-) diff --git a/include/rds2cpp/Environment.hpp b/include/rds2cpp/Environment.hpp index d454db2..857b012 100644 --- a/include/rds2cpp/Environment.hpp +++ b/include/rds2cpp/Environment.hpp @@ -30,12 +30,13 @@ struct Environment { /** * Type of the parent environment. + * This is usually one of `SEXPType::ENV`, `SEXPType::GLOBALENV_`, `SEXPType::BASEENV_` or `SEXPType::EMPTYENV_`. */ SEXPType parent_type = SEXPType::GLOBALENV_; /** * Index of the parent environment. - * This should only be used if `parent_type` is `ENV`. + * This should only be used if `parent_type` is `SEXPType::ENV`. */ size_t parent = -1; diff --git a/include/rds2cpp/SharedWriteInfo.hpp b/include/rds2cpp/SharedWriteInfo.hpp index 8294006..1171cf9 100644 --- a/include/rds2cpp/SharedWriteInfo.hpp +++ b/include/rds2cpp/SharedWriteInfo.hpp @@ -138,9 +138,9 @@ struct SharedWriteInfo { auto index = ptr->index; auto env_type = ptr->env_type; - if (env_type == SEXPType::GLOBALENV_) { + if (env_type == SEXPType::GLOBALENV_ || env_type == SEXPType::BASEENV_ || env_type == SEXPType::EMPTYENV_) { buffer.clear(); - inject_header(SEXPType::GLOBALENV_, buffer); + inject_header(env_type, buffer); writer.write(buffer.data(), buffer.size()); return; } diff --git a/include/rds2cpp/parse_environment.hpp b/include/rds2cpp/parse_environment.hpp index f8085a9..9585ad1 100644 --- a/include/rds2cpp/parse_environment.hpp +++ b/include/rds2cpp/parse_environment.hpp @@ -15,8 +15,15 @@ template PairList parse_pairlist_body(Reader&, std::vector&, SharedParseInfo&); inline EnvironmentIndex parse_global_environment_body() { - // Rely on default constructor. - return EnvironmentIndex(); + return EnvironmentIndex(SEXPType::GLOBALENV_); +} + +inline EnvironmentIndex parse_base_environment_body() { + return EnvironmentIndex(SEXPType::BASEENV_); +} + +inline EnvironmentIndex parse_empty_environment_body() { + return EnvironmentIndex(SEXPType::EMPTYENV_); } template @@ -54,6 +61,12 @@ EnvironmentIndex parse_new_environment_body(Reader& reader, std::vector(SEXPType::GLOBALENV_)) { new_env.parent_type = SEXPType::GLOBALENV_; + } else if (lastbit == static_cast(SEXPType::BASEENV_)) { + new_env.parent_type = SEXPType::BASEENV_; + + } else if (lastbit == static_cast(SEXPType::EMPTYENV_)) { + new_env.parent_type = SEXPType::EMPTYENV_; + } else { throw std::runtime_error("could not resolve the parent environment"); } diff --git a/include/rds2cpp/parse_object.hpp b/include/rds2cpp/parse_object.hpp index 7df1e00..d6f8fef 100644 --- a/include/rds2cpp/parse_object.hpp +++ b/include/rds2cpp/parse_object.hpp @@ -68,6 +68,12 @@ std::unique_ptr parse_object(Reader& reader, std::vector } else if (sexp_type == static_cast(SEXPType::GLOBALENV_)) { pointerize_(parse_global_environment_body()); + } else if (sexp_type == static_cast(SEXPType::BASEENV_)) { + pointerize_(parse_base_environment_body()); + + } else if (sexp_type == static_cast(SEXPType::EMPTYENV_)) { + pointerize_(parse_empty_environment_body()); + } else if (sexp_type == static_cast(SEXPType::REF)) { output = shared.resolve_reference(details); diff --git a/include/rds2cpp/write_object.hpp b/include/rds2cpp/write_object.hpp index e4d803b..b5c1fab 100644 --- a/include/rds2cpp/write_object.hpp +++ b/include/rds2cpp/write_object.hpp @@ -65,6 +65,8 @@ void write_object(const RObject* object, Writer& writer, std::vectortype() == rds2cpp::SEXPType::GLOBALENV_) { return Rcpp::List::create(Rcpp::Named("environment_id") = Rcpp::IntegerVector::create(-1)); + + } else if (input->type() == rds2cpp::SEXPType::BASEENV_) { + return Rcpp::List::create(Rcpp::Named("environment_id") = Rcpp::IntegerVector::create(-2)); + + } else if (input->type() == rds2cpp::SEXPType::EMPTYENV_) { + return Rcpp::List::create(Rcpp::Named("environment_id") = Rcpp::IntegerVector::create(-3)); } return R_NilValue; @@ -201,9 +207,22 @@ Rcpp::RObject parse(std::string file_name) { } vars.attr("names") = varnames; + int parent_code = 0; + if (env.parent_type == rds2cpp::SEXPType::ENV) { + parent_code = static_cast(env.parent); + } else if (env.parent_type == rds2cpp::SEXPType::GLOBALENV_) { + parent_code = -1; + } else if (env.parent_type == rds2cpp::SEXPType::BASEENV_) { + parent_code = -2; + } else if (env.parent_type == rds2cpp::SEXPType::EMPTYENV_) { + parent_code = -3; + } else { + throw std::runtime_error("oops, don't know how to handle a parent type of " + std::to_string(static_cast(env.parent_type))); + } + auto curout = Rcpp::List::create( Rcpp::Named("variables") = vars, - Rcpp::Named("parent") = Rcpp::IntegerVector::create(env.parent_type == rds2cpp::SEXPType::GLOBALENV_ ? -1 : static_cast(env.parent)), + Rcpp::Named("parent") = parent_code, Rcpp::Named("locked") = env.locked ); add_attributes(env.attributes, curout); diff --git a/tests/src/write.cpp b/tests/src/write.cpp index 72f38ba..6f668f9 100644 --- a/tests/src/write.cpp +++ b/tests/src/write.cpp @@ -169,8 +169,18 @@ std::unique_ptr unconvert(const Rcpp::RObject& x, rds2cpp::Rds } else if (static_cast(index) > globals.environments.size()) { throw std::runtime_error("environment index out of range"); } - } else { + + } else if (index == -1) { ptr->env_type = rds2cpp::SEXPType::GLOBALENV_; + + } else if (index == -2) { + ptr->env_type = rds2cpp::SEXPType::BASEENV_; + + } else if (index == -3) { + ptr->env_type = rds2cpp::SEXPType::EMPTYENV_; + + } else { + throw std::runtime_error("unknown special environment index " + std::to_string(index)); } } else if (vec.hasAttribute("pretend-to-be-a-builtin")) { diff --git a/tests/tests/testthat/test-environment.R b/tests/tests/testthat/test-environment.R index 552eac9..95d9885 100644 --- a/tests/tests/testthat/test-environment.R +++ b/tests/tests/testthat/test-environment.R @@ -50,6 +50,52 @@ test_that("empty environment writing works as expected", { expect_identical(roundtrip, .GlobalEnv) }) +test_that("base environment loading works as expected", { + tmp <- tempfile(fileext=".rds") + y <- baseenv() + saveRDS(y, file=tmp) + + roundtrip <- rds2cpp:::parse(tmp) + expect_identical(roundtrip$value$environment_id, -2L) + expect_identical(length(roundtrip$environments), 0L) + + # Adding the baseenv as a parent. + tmp <- tempfile(fileext=".rds") + y <- new.env(parent=baseenv()) + y$AA <- 1:5 + saveRDS(y, file=tmp) + roundtrip <- rds2cpp:::parse(tmp) + + expect_identical(roundtrip$value$environment_id, 0L) + expect_identical(length(roundtrip$environments), 1L) + expect_identical(roundtrip$environments[[1]]$parent, -2L) + expect_identical(ls(roundtrip$environments[[1]]$variables), "AA") + expect_false(roundtrip$environments[[1]]$locked) +}) + +test_that("empty environment loading works as expected", { + tmp <- tempfile(fileext=".rds") + y <- emptyenv() + saveRDS(y, file=tmp) + + roundtrip <- rds2cpp:::parse(tmp) + expect_identical(roundtrip$value$environment_id, -3L) + expect_identical(length(roundtrip$environments), 0L) + + # Adding the emptyenv as a parent. + tmp <- tempfile(fileext=".rds") + y <- new.env(parent=emptyenv()) + y$AA <- 1:5 + saveRDS(y, file=tmp) + roundtrip <- rds2cpp:::parse(tmp) + + expect_identical(roundtrip$value$environment_id, 0L) + expect_identical(length(roundtrip$environments), 1L) + expect_identical(roundtrip$environments[[1]]$parent, -3L) + expect_identical(ls(roundtrip$environments[[1]]$variables), "AA") + expect_false(roundtrip$environments[[1]]$locked) +}) + test_that("locked environment loading works as expected", { # local() is needed to deal with the fact that the parent # environment is mangled somewhat by testthat. @@ -402,6 +448,37 @@ test_that("environment parenthood works as expected when writing", { expect_identical(roundtrip$third$maya, z$third$maya) }) +test_that("writers work with the special environments", { + z <- list( + first = { + y <- list() + attr(y, "pretend-to-be-an-environment") <- TRUE + attr(y, "environment-index") <- -1L + y + }, + second = { + y <- list() + attr(y, "pretend-to-be-an-environment") <- TRUE + attr(y, "environment-index") <- -2L + y + }, + third = { + y <- list() + attr(y, "pretend-to-be-an-environment") <- TRUE + attr(y, "environment-index") <- -3L + y + } + ) + + tmp <- tempfile(fileext=".rds") + rds2cpp::write(z, file=tmp) + roundtrip <- readRDS(tmp) + + expect_identical(roundtrip$first, .GlobalEnv) + expect_identical(roundtrip$second, baseenv()) + expect_identical(roundtrip$third, emptyenv()) +}) + test_that("self-references are properly resolved", { output <- local({ y <- new.env()