diff --git a/NEWS.md b/NEWS.md index bbac9a13..b555a184 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # rsconnect 0.8.30 (development version) +* Locale detection has been improved on windows (#233). + * `deployApp()` will now warn if `appFiles` or `appManifestFiles` contain files that don't exist, rather than silently ignoring them (#706). diff --git a/R/locale.R b/R/locale.R index f2d8b6bf..4f8620ce 100644 --- a/R/locale.R +++ b/R/locale.R @@ -1,84 +1,26 @@ -overrideWindowsLocale <- function(locale) { - map <- list() - map[["el_EL"]] <- "el_GR" - if (locale %in% names(map)) { - locale <- map[[locale]] - } - return(locale) -} - detectLocale <- function() { - sysName <- Sys.info()[["sysname"]] - if (identical(sysName, "Windows")) { - locale <- detectLocale.Windows() - } else { - locale <- detectLocale.Unix() - } - return(locale) -} - -detectLocale.Unix <- function() { - unlist(strsplit(Sys.getlocale("LC_CTYPE"), ".", fixed = TRUE))[1] -} - -detectLocale.Windows <- function(useCache = - getOption("rsconnect.locale.cache", TRUE)) { - - # default locale - locale <- "en_US" - - cacheFile <- localeCacheFile() - if (file.exists(cacheFile) && useCache) { - - # get chached - cache <- as.list(readDcf(cacheFile, all = TRUE)) - - locale <- unlist(cache$locale) - - } else { - - tryCatch({ - - # get system locale - locale <- systemLocale() - - # write the user info - write.dcf(list(locale = locale), - cacheFile, - width = 100) - - }, error = function(e) { - warning(paste0("Error detecting locale: ", e, - " (Using default: ", locale, ")"), call. = FALSE) - }) - } - return(overrideWindowsLocale(locale)) -} - -localeCacheFile <- function() { - normalizePath(file.path(rsconnectConfigDir(), "locale.dcf"), mustWork = FALSE) -} - -systemLocale <- function() { - message("Detecting system locale ... ", appendLF = FALSE) - - # get system locale - info <- systemInfo() - raw <- as.character(info[[20]]) - parts <- strsplit(unlist(strsplit(raw, ";", fixed = TRUE)), "-", fixed = TRUE) - - if (length(parts[[1]]) >= 2) { - # normalize locale to something like en_US - locale <- paste(tolower(parts[[1]][1]), toupper(parts[[1]][2]), sep = "_") + if (!isWindows()) { + locales <- strsplit(Sys.getlocale("LC_CTYPE"), ".", fixed = TRUE)[[1]] + locales[[1]] } else { - locale <- paste(tolower(parts[[1]][1]), toupper(parts[[1]][1]), sep = "_") + locale <- HCU_registry_key("Control Panel\\International\\User Profile")$Languages[[1]] + if (is.null(locale)) { + # Try approach that works on Windows 7 + locales <- HCU_registry_key("Control Panel\\International")$LocaleName + if (is.null(locale)) { + # Otherwise fall back US English + locale <- "en-US" + } + } + gsub("-", "_", locale) } - message(locale) - return(locale) } -systemInfo <- function() { - raw <- system("systeminfo /FO csv", intern = TRUE, wait = TRUE) - info <- read.csv(textConnection(raw)) - return(info) +HCU_registry_key <- function(key, default = NULL) { + tryCatch( + utils::readRegistry(key, hive = "HCU"), + error = function(err) { + default + } + ) } diff --git a/tests/testthat/test-locale.R b/tests/testthat/test-locale.R new file mode 100644 index 00000000..c34241bd --- /dev/null +++ b/tests/testthat/test-locale.R @@ -0,0 +1,4 @@ +test_that("locale is en_US on GHA", { + skip_if_not(identical(Sys.getenv("GITHUB_ACTIONS"), "true")) + expect_equal(detectLocale(), "en_US") +})