tests/testthat/helper-encoding.R

In hadley/dplyr: A Grammar of Data Manipulation

get_lang_strings <- function() {
  lang_strings <- c(
    de = "Gl\u00fcck",
    cn = "\u5e78\u798f",
    ru = "\u0441\u0447\u0430\u0441\u0442\u044c\u0435",
    ko = "\ud589\ubcf5"
  )

  native_lang_strings <- enc2native(lang_strings)

  same <- (lang_strings == native_lang_strings)

  list(
    same = lang_strings[same],
    different = lang_strings[!same]
  )
}

get_native_lang_string <- function() {
  lang_strings <- get_lang_strings()
  if (length(lang_strings$same) == 0) testthat::skip("No native language string available")
  lang_strings$same[[1L]]
}

get_alien_lang_string <- function() {
  lang_strings <- get_lang_strings()
  if (length(lang_strings$different) == 0) testthat::skip("No alien language string available")
  lang_strings$different[[1L]]
}

has_locale <- function(locale, category) {
  original <- Sys.getlocale(category = category)
  on.exit(Sys.setlocale(category = category, locale = original), add = TRUE)

  tryCatch(
    expr = {
      Sys.setlocale(category = category, locale = locale)
      TRUE
    },
    warning = function(w) FALSE,
    error = function(e) FALSE
  )
}
has_collate_locale <- function(locale) {
  has_locale(locale = locale, category = "LC_COLLATE")
}
has_ctype_locale <- function(enc) {
  has_locale(locale = enc, category = "LC_CTYPE")
}

non_utf8_encoding <- function(enc = NULL) {
  if (!l10n_info()$`UTF-8`) {
    return(Sys.getlocale("LC_CTYPE"))
  }
  enc <- enc %||% c(
    "en_US.ISO8859-1",
    "en_US.ISO8859-15",
    "fr_CH.ISO8859-1",
    "fr_CH.ISO8859-15"
  )
  available <- vapply(enc, has_ctype_locale, logical(1))
  if (any(available)) {
    enc[available][1]
  } else {
    NULL
  }
}

local_non_utf8_encoding <- function(enc = NULL, env = parent.frame()) {
  non_utf8 <- non_utf8_encoding(enc)
  if (is.null(non_utf8)) {
    skip("Can't set a non-UTF-8 encoding")
  } else {
    withr::local_locale(c(LC_CTYPE = non_utf8), .local_envir = env)
  }
}