Hadley's snapshot experiments

.github/workflows/R-CMD-check.yaml

@@ -21,11 +21,11 @@ jobs:
       fail-fast: false
       matrix:
         config:
-          - {os: macOS-latest,   r: 'release'}
+          # - {os: macOS-latest,   r: 'release'}
           - {os: windows-latest, r: 'release'}
-          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          # - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,   r: 'release'}
-          - {os: ubuntu-latest,   r: 'oldrel-1'}
+          # - {os: ubuntu-latest,   r: 'oldrel-1'}
 
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}

DESCRIPTION

@@ -21,12 +21,14 @@ Imports:
 Suggests: 
     crayon,
     knitr,
+    mockery,
     rmarkdown,
     testthat (>= 3.0.0),
     withr
 VignetteBuilder: 
     knitr
 Config/testthat/edition: 3
+Remotes: r-lib/testthat
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.1.2

R/find_fuzzy_messages.R

@@ -2,21 +2,21 @@ find_fuzzy_messages <- function(message_data, lang_file) {
   old_message_data = get_po_messages(lang_file)
 
   if (any(idx <- old_message_data$fuzzy == 2L)) {
-    messagef('Found %d translations marked as deprecated in %s.', sum(idx), lang_file)
+    messagef('Found %d translations marked as deprecated in ./po/%s.', sum(idx), basename(lang_file))
     message('Typically, this means the corresponding error messages have been refactored.')
     message('Reproducing these messages here for your reference since they might still provide some utility.')
 
     dashes = strrep('-', .9*getOption('width'))
     old_message_data[idx & type == 'singular', {
       if (.N > 0L) {
         message(' ** SINGULAR MESSAGES **')
-        cat(rbind(dashes, msgid, msgstr), sep='\n')
+        writeLines(rbind(dashes, msgid, msgstr), useBytes=TRUE)
       }
     }]
     old_message_data[idx & type == 'plural', {
       if (.N > 0L) {
         message(' ** PLURAL MESSAGES **')
-        cat(do.call(rbind, c(list(dashes), msgid_plural, msgstr_plural)), sep='\n')
+        writeLines(do.call(rbind, c(list(dashes), msgid_plural, msgstr_plural)), useBytes=TRUE)
       }
     }]
 

R/get_po_messages.R

@@ -123,12 +123,14 @@ get_po_messages <- function(po_file) {
     msg_j = msg_j + 1L
   }
 
-  # somewhat hacky approach -- strip the comment markers & recurse
-  writeLines(
+  # somewhat hacky approach -- strip the comment markers & recurse.
+  # beware of potential encoding dragons.
+
+  tmp_conn <- write_utf8(
     gsub("^#~ ", "", grep("^#~ ", po_lines, value = TRUE)),
     tmp <- tempfile()
   )
-  on.exit(unlink(tmp))
+  on.exit({ close(tmp_conn); unlink(tmp) })
   deprecated = get_po_messages(tmp)
   if (nrow(deprecated) > 0L) {
     set(deprecated, NULL, 'fuzzy', 2L)

R/msgmerge.R

@@ -27,43 +27,47 @@ run_msgmerge <- function(po_file, pot_file, previous = FALSE, verbose = TRUE) {
 }
 
 run_msgfmt = function(po_file, mo_file, verbose) {
-  use_stats <- if (verbose) '--statistics' else ''
-
   po_file <- path.expand(po_file)
   mo_file <- path.expand(mo_file)
 
-  # See #218. Solaris msgfmt doesn't support -c or --statistics
-  if (Sys.info()[["sysname"]] == "SunOS") {
-    cmd = glue("msgfmt -o {shQuote(mo_file)} {shQuote(po_file)}") # nocov
-  } else {
-    cmd = glue("msgfmt -c {use_stats} -o {shQuote(mo_file)} {shQuote(po_file)}")
+  # See #218. Solaris msgfmt (non-GNU on CRAN) doesn't support --check or --statistics;
+  #   see also https://bugs.r-project.org/show_bug.cgi?id=18150
+  args = character()
+  if (is_gnu_gettext()) {
+    args = c("--check", if (verbose) '--statistics')
   }
-  if (system(cmd) != 0L) {
+
+  val = system2("msgfmt", c(args, "-o", shQuote(mo_file), shQuote(po_file)), stdout = TRUE, stderr = TRUE)
+  if (!identical(attr(val, "status", exact = TRUE), NULL)) {
     warningf(
-      "running msgfmt on %s failed.\nHere is the po file:\n%s",
-      basename(po_file), paste(readLines(po_file), collapse = "\n"),
+      "running msgfmt on %s failed; output:\n  %s\nHere is the po file:\n%s",
+      basename(po_file), paste(val, collapse = "\n"), paste(readLines(po_file), collapse = "\n"),
       immediate. = TRUE
     )
+  } else if (verbose) {
+    messagef(
+      "running msgfmt on %s succeeded; output:\n  %s",
+      basename(po_file), paste(val, collapse = "\n")
+    )
   }
   return(invisible())
 }
 
-
-
 update_en_quot_mo_files <- function(dir, verbose) {
   pot_files <- list.files(file.path(dir, "po"), pattern = "\\.pot$", full.names = TRUE)
   mo_dir <- file.path(dir, "inst", "po", "en@quot", "LC_MESSAGES")
   dir.create(mo_dir, recursive = TRUE, showWarnings = FALSE)
   for (pot_file in pot_files) {
-    po_file <- tempfile()
+    # don't use tempfile() -- want a static basename() to keep verbose output non-random
+    po_file <- file.path(tempdir(), if (startsWith(basename(pot_file), "R-")) "[email protected]" else "[email protected]")
+    on.exit(unlink(po_file))
     # tools:::en_quote is blocked, but we still need it for now
     get("en_quote", envir=asNamespace("tools"))(pot_file, po_file)
     run_msgfmt(
       po_file = po_file,
       mo_file = file.path(mo_dir, gsub("\\.pot$", ".mo", basename(pot_file))),
       verbose = verbose
     )
-    unlink(po_file)
   }
   return(invisible())
 }

R/onLoad.R

@@ -20,20 +20,18 @@ globalVariables(
 )
 
 .potools = new.env()
-
-if (requireNamespace('crayon', quietly = TRUE)) {
-  call_color = getOption('potools.call_color', crayon::green)
-  file_color = getOption('potools.file_color', crayon::white)
-  msgid_color = getOption('potools.msgid_color', crayon::red)
-  language_color = getOption('potools.language_color', crayon::cyan)
-  replacement_color = getOption('potools.replacement_color', crayon::blue)
-  plural_range_color = getOption('potools.plural_range_color', crayon::yellow)
-} else {
-  call_color = file_color = msgid_color = language_color = replacement_color = plural_range_color = identity
-}
+call_color = file_color = msgid_color = language_color = replacement_color = plural_range_color = identity
 
 # nocov start
 .onLoad = function(libname, pkgname) {
   .potools$base_package_names = get(".get_standard_package_names", envir=asNamespace("tools"), mode="function")()$base
+  if (getOption('potools.use_colors', requireNamespace('crayon', quietly = TRUE))) {
+    utils::assignInMyNamespace("call_color", getOption('potools.call_color', crayon::green))
+    utils::assignInMyNamespace("file_color", getOption('potools.file_color', crayon::white))
+    utils::assignInMyNamespace("msgid_color", getOption('potools.msgid_color', crayon::red))
+    utils::assignInMyNamespace("language_color", getOption('potools.language_color', crayon::cyan))
+    utils::assignInMyNamespace("replacement_color", getOption('potools.replacement_color', crayon::blue))
+    utils::assignInMyNamespace("plural_range_color", getOption('potools.plural_range_color', crayon::yellow))
+  }
 }
 # nocov end

R/translate_package.R

@@ -347,7 +347,7 @@ translate_package = function(
       messagef(
         "Updating translation template for package '%s' (last updated %s)",
         package,
-        format(file.info(r_potfile)$atime)
+        get_atime(r_potfile)
       )
     } else {
       messagef("Starting translations for package '%s'", package)
@@ -412,11 +412,11 @@ translate_package = function(
     if (update && file.exists(lang_file)) {
       if (verbose) {
         messagef(
-          'Found existing R translations for %s (%s/%s) in %s. Running msgmerge...',
-          language, metadata$full_name_eng, metadata$full_name_native, lang_file
+          'Found existing R translations for %s (%s/%s) in ./po/%s. Running msgmerge...',
+          language, metadata$full_name_eng, metadata$full_name_native, basename(lang_file)
         )
       }
-      run_msgmerge(lang_file, r_potfile)
+      run_msgmerge(lang_file, r_potfile, verbose)
 
       find_fuzzy_messages(message_data, lang_file)
     } else {
@@ -427,11 +427,11 @@ translate_package = function(
     if (update && file.exists(lang_file)) {
       if (verbose) {
         messagef(
-          'Found existing src translations for %s (%s/%s) in %s. Running msgmerge...',
-          language, metadata$full_name_eng, metadata$full_name_native, lang_file
+          'Found existing src translations for %s (%s/%s) in ./po/%s. Running msgmerge...',
+          language, metadata$full_name_eng, metadata$full_name_native, basename(lang_file)
         )
       }
-      run_msgmerge(lang_file, src_potfile)
+      run_msgmerge(lang_file, src_potfile, verbose)
 
       find_fuzzy_messages(message_data, lang_file)
     } else {
@@ -551,39 +551,35 @@ invisible({
   gettext("when n is not 1")
 })
 
-# take from those present in r-devel:
-# ls -1 ~/svn/R-devel/src/library/*/po/*.po | \
-#   awk -F"[./]" '{print $10}' | \
-#   sed -r 's/^R(Gui)?-//g' | sort -u | \
-#   awk '{print "  ", $1, " = ,"}'
-# alternatively, a more complete list can be found on some websites:
-#   https://saimana.com/list-of-country-locale-code/
-# nplurals,plural info from https://l10n.gnome.org/teams/<language>
-# NB: looks may be deceiving for right-to-left scripts (e.g. Farsi), where the
-#   displayed below might not be in the order it is parsed.
-# assign to .potools, not a package env, to keep more readily mutable inside update_metadata()
-.potools$KNOWN_LANGUAGES = fread(system.file('extdata', 'language_metadata.csv', package='potools'), key='code')
-
-# the 'plural' column above is designed for computers;
-#   translate that to something human-legible here.
-# NB: 'plural' is 0-based (like in the .po file), but
-#   'plural_index' is 1-based (to match the above R-level code).
-# assign to .potools, not a package env, to keep more readily mutable inside update_metadata()
-.potools$PLURAL_RANGE_STRINGS = fread(
-  system.file('extdata', 'plurals_metadata.csv', package='potools'),
-  key = c('plural', 'plural_index')
-)
-
 # for testing; unexported
-# nocov start
 reset_language_metadata = function() {
+  # initially taken from those present in r-devel:
+  # ls -1 ~/svn/R-devel/src/library/*/po/*.po | \
+  #   awk -F"[./]" '{print $10}' | \
+  #   sed -r 's/^R(Gui)?-//g' | sort -u | \
+  #   awk '{print "  ", $1, " = ,"}'
+  # for extension, a more complete list can be found on some websites:
+  #   https://saimana.com/list-of-country-locale-code/
+  # nplurals,plural info from https://l10n.gnome.org/teams/<language>
+  # NB: looks may be deceiving for right-to-left scripts (e.g. Farsi), where the
+  #   displayed below might not be in the order it is parsed.
+  # assign to .potools, not a package env, to keep more readily mutable
+  #   inside update_metadata() & elsewhere
   .potools$KNOWN_LANGUAGES = fread(
     system.file('extdata', 'language_metadata.csv', package='potools'),
-    key='code'
+    # encoding is required for the full_name_native field to display well on Windows
+    encoding = "UTF-8",
+    key = 'code'
   )
+  # the 'plural' column above is designed for computers;
+  #   translate that to something human-legible here.
+  # NB: 'plural' is 0-based (like in the .po file), but
+  #   'plural_index' is 1-based (to match the above R-level code).
+  # assign to .potools, not a package env, to keep more readily mutable inside update_metadata()
   .potools$PLURAL_RANGE_STRINGS = fread(
     system.file('extdata', 'plurals_metadata.csv', package='potools'),
     key = c('plural', 'plural_index')
   )
 }
-# nocov end
+
+reset_language_metadata()

R/utils.R

@@ -187,3 +187,23 @@ is_outdated <- function(src, dst) {
 }
 
 is_testing = function() identical(Sys.getenv("TESTTHAT"), "true")
+
+is_gnu_gettext = function() any(grepl("GNU gettext", system('gettext --version', intern=TRUE)))
+
+# wrapper function to facilitate mocking, else tests --> stochastic output
+get_atime <- function(f) format(file.info(f, extra_cols = FALSE)$atime) # nocov. Always mocked in tests.
+
+# a safer version of writeLines that's better at avoiding encoding hell
+# cat seems to fail at writing UTF-8 on Windows; useBytes should do the trick instead:
+#   https://stackoverflow.com/q/10675360
+# "native.enc" supplied explicitly thanks to:
+#   https://kevinushey.github.io/blog/2018/02/21/string-encoding-and-r/
+write_utf8 <- function(lines, file, open = "w+") {
+  if (!inherits(file, "connection")) {
+    file <- file(file, open, encoding = "native.enc")
+  }
+
+  writeLines(lines, file, useBytes = TRUE)
+  # don't necessarily close; let calling env do so
+  return(file)
+}

R/write_po_file.R

@@ -158,6 +158,7 @@ write_po_files <- function(message_data, po_dir, params, template = FALSE, use_b
 #'   tmp_po <- tempfile(fileext = '.po'),
 #'   metadata
 #' )
+#' # NB: in general, beware of encoding in this snippet
 #' writeLines(readLines(tmp_po))
 #'
 #' # write .pot template
@@ -181,18 +182,14 @@ write_po_file <- function(
 
   template = endsWith(po_file, ".pot")
 
-  # cat seems to fail at writing UTF-8 on Windows; useBytes should do the trick instead:
-  #   https://stackoverflow.com/q/10675360
-  po_conn = file(po_file, "wb")
-  on.exit(close(po_conn))
-
   po_header = format(
     metadata,
     template = template,
     use_plurals = any(message_data$type == "plural")
   )
 
-  writeLines(con=po_conn, useBytes=TRUE, po_header)
+  po_conn <- write_utf8(po_header, po_file, "wb")
+  on.exit(close(po_conn))
 
   # drop untranslated strings, collapse duplicates, drop unneeded data.
   #   for now, treating R & src separately so they can be treated differently; eventually this should
@@ -286,7 +283,7 @@ write_po_file <- function(
       )
     }
 
-    writeLines(con=po_conn, useBytes=TRUE, out_lines)
+    write_utf8(out_lines, po_conn)
   }]
 }
 

tests/testthat.R

@@ -1,4 +1,13 @@
+library(withr)
 library(testthat)
+old = options(
+  potools.use_colors = FALSE,
+  width = 80L,
+  warnPartialMatchArgs = TRUE,
+  warnPartialMatchAttr = TRUE,
+  warnPartialMatchDollar = TRUE
+)
+withr::local_envvar("_R_CHECK_LENGTH_1_CONDITION_" = "true")
 library(potools)
 
 # Failed on Solaris because the command-line tools are missing there (which means tools doesn't work there), #186
@@ -8,3 +17,4 @@ if (isTRUE(check_potools_sys_reqs())) {
 } else {
   writeLines("Skipping tests on system without gettext installed")
 }
+options(old)