#' Serialise and unserialise objects
#'
#' These functions are equivalent to [base::serialize()] and
#' [base::unserialize()] but try to preserve the enclosure of
#' closures, formulas, and quosures. It works by detecting which
#' environment or package attached on the search path at
#' serialisation-time are required by the function or quosure. The
#' relevant environments are then reconstructed in a fake search path
#' when the object is unserialised. The fake search path is specific
#' to each closure and quosure.
#'
#' @param x An object to serialise.
#' @param global_env Whether to include a stripped version of the
#' global environment as part of the fake search path constructed
#' around closures.
#' @export
serialise_bytes <- function(x, global_env = FALSE) {
UseMethod("serialise_bytes")
}
#' @rdname serialise_bytes
#' @export
serialise_bytes.default <- function(x, global_env = FALSE) {
if (has_search_path(x)) {
path_bindings <- clo_trace_path(x, global_env)
path_nms <- map_chr(path_bindings, attr, which = "path_name")
path_attached <- keep(path_bindings, `==`, "attached")
if (length(path_nms) && path_nms == ".GlobalEnv") {
global <- new_environment(attr(path_bindings[[1]], "objects"))
} else {
global <- NULL
}
if (length(path_nms)) {
x <- set_attrs(x,
class = "serialised_path",
path = path_nms,
attached = path_attached,
global = global
)
}
}
serialize(x, NULL)
}
#' @rdname serialise_bytes
#' @param bytes A raw vector to unserialise.
#' @export
bytes_unserialise <- function(bytes) {
UseMethod("bytes_unserialise")
}
#' @rdname serialise_bytes
#' @export
bytes_unserialise.default <- function(bytes) {
x <- unserialize(bytes)
if (!inherits(x, "serialised_path")) {
return(x)
}
path <- as_list(attr(x, "path"))
if (path[[1]] == ".GlobalEnv") {
path[[1]] <- attr(x, "global")
}
path <- map_if(path, is_package_name, new_package_env)
path <- map_if(path, is_string, function(x) abort("TODO"))
# Make sure to keep the local environments if they exist
old_enclosure <- get_env(x)
new_enclosure <- envs_link(path)
if (is_reference(old_enclosure, global_env())) {
x <- set_env(x, new_enclosure)
} else {
tail <- env_tail(x, sentinel = global_env())
mut_env_parent(tail, new_enclosure)
}
# FIXME: Wrap serialisation attributes in a single object
set_attrs(x, class = NULL, attached = NULL, path = NULL, global = NULL)
}
has_enclosure <- function(x) {
is_closure(x) || is_formulaish(x)
}
has_search_path <- function(x) {
env <- get_env(x, default = return(FALSE))
if (is_namespace(env)) {
return(FALSE)
}
while (!is_empty_env(env)) {
if (identical(env, global_env())) {
return(TRUE)
}
env <- env_parent(env)
}
FALSE
}
clo_trace_path <- function(clo, global_env) {
stopifnot(has_enclosure(clo))
expr <- get_expr(clo)
env <- get_env(clo)
# Find all bindings scoped in the search path
bindings <- clo_search_bindings(clo)
# Gather all references to global object together
bindings <- merge_globals(bindings)
# Discard redundant environments
bindings <- unname(compact(bindings))
bindings <- bindings[!duplicated(bindings)]
# Keep only environments on the search path
if (global_env) {
serialised_types <- c("global", "package", "scoped")
} else {
serialised_types <- c("package", "scoped")
}
path_attached <- keep(bindings, `%in%`, serialised_types)
path_names <- map_chr(path_attached, attr, which = "path_name")
order <- order(match(path_names, search()))
path_attached[order]
}
merge_globals <- function(bindings) {
is_global <- bindings == "global"
globals <- bindings[is_global]
if (length(globals)) {
global <- globals[[1]]
objects <- set_names(names(globals))
objects <- map(objects, env_get, env = global_env())
global <- set_attrs(global, objects = objects)
bindings <- c(list(global), bindings[!is_global])
}
bindings
}
# Using environment for constant-time insertion
clo_search_bindings <- function(clo) {
stopifnot(has_enclosure(clo))
syms <- new_environment()
syms <- search_expr_bindings(syms, get_expr(clo), get_env(clo))
as_list(syms)
}
search_expr_bindings <- function(syms, expr, env) {
switch_type(expr,
symbol = search_symbol_bindings(syms, expr, env),
language = search_language_bindings(syms, expr, env),
pairlist = search_pairlist_bindings(syms, expr, env)
)
invisible(syms)
}
search_symbol_bindings <- function(syms, expr, env) {
nm <- as_string(expr)
if (nchar(nm) > 0) {
syms[[nm]] <- env_type(binding_env(nm, env))
}
}
search_language_bindings <- function(syms, expr, env) {
car <- node_car(expr)
if (is_symbol(car)) {
nm <- as_string(car)
syms[[nm]] <- env_type(binding_env(nm, env))
} else if (is_language(car)) {
search_expr_bindings(syms, car, env)
}
search_expr_bindings(syms, node_cdr(expr), env)
}
search_pairlist_bindings <- function(syms, expr, env) {
while (!is_null(expr)) {
search_expr_bindings(syms, node_car(expr), env)
expr <- node_cdr(expr)
}
}
binding_env <- function(nm, env) {
while(!identical(env, empty_env()) && !env_has(env, nm)) {
env <- env_parent(env)
}
env
}
#' @rdname serialise_bytes
#' @export
serialize_bytes <- serialise_bytes
#' @rdname serialise_bytes
#' @export
bytes_unserialize <- bytes_unserialise
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.