Get locale name from registry

Fixes #233

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).
 

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
+    }
+  )
 }

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")
+})