Get locale name from registry (#715)

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,27 @@
-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()
+  if (!isWindows()) {
+    locales <- strsplit(Sys.getlocale("LC_CTYPE"), ".", fixed = TRUE)[[1]]
+    locales[[1]]
   } else {
-    locale <- detectLocale.Unix()
+    tryCatch(windowsLocale(), error = function(err) "en_US")
   }
-  return(locale)
 }
 
-detectLocale.Unix <- function() {
-  unlist(strsplit(Sys.getlocale("LC_CTYPE"), ".", fixed = TRUE))[1]
+# Possible values
+# listed at https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-lcid
+windowsLocale <- function() {
+  key <- utils::readRegistry("Control Panel\\International", hive = "HCU")
+  normalizeLocale(key$LocaleName)
 }
 
-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)
+# Remove script tag, if present
+normalizeLocale <- function(x) {
+  pieces <- strsplit(x, "-")[[1]]
+  all_upper <- pieces[pieces == toupper(pieces)]
 
+  if (length(all_upper) == 0) {
+    pieces[[1]]
   } 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)
-    })
+    paste0(pieces[[1]], "_", all_upper[[1]])
   }
-  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 = "_")
-  } else {
-    locale <- paste(tolower(parts[[1]][1]), toupper(parts[[1]][1]), sep = "_")
-  }
-  message(locale)
-  return(locale)
-}
-
-systemInfo <- function() {
-  raw <- system("systeminfo /FO csv", intern = TRUE, wait = TRUE)
-  info <- read.csv(textConnection(raw))
-  return(info)
 }

tests/testthat/test-locale.R

@@ -0,0 +1,19 @@
+test_that("locale is en_US on mac GHA", {
+  skip_on_os(c("linux", "windows"))
+  skip_if_not(identical(Sys.getenv("GITHUB_ACTIONS"), "true"))
+
+  expect_equal(detectLocale(), "en_US")
+})
+
+test_that("locale is en_US on mac GHA", {
+  skip_on_os(c("linux", "mac"))
+  skip_if_not(identical(Sys.getenv("GITHUB_ACTIONS"), "true"))
+
+  expect_equal(windowsLocale(), "en_US")
+})
+
+test_that("normalizeLocale handles common forms", {
+  expect_equal(normalizeLocale("en-US"), "en_US")
+  expect_equal(normalizeLocale("az-Cyrl"), "az")
+  expect_equal(normalizeLocale("az-Cyrl-AZ"), "az_AZ")
+})