Use option parting infrastucture for xml_read options as well

jimhester · jimhester · commit 43a1ce9024f4 · 2016-12-21T11:56:52.000-05:00
diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -5,6 +5,10 @@ read_connection_ <- function(con, chunk_size = 64 * 1024L) {
     .Call('xml2_read_connection_', PACKAGE = 'xml2', con, chunk_size)
 }
 
+xml_parse_options <- function() {
+    .Call('xml2_xml_parse_options', PACKAGE = 'xml2')
+}
+
 doc_parse_file <- function(path, encoding = "", as_html = FALSE, options = 0L) {
     .Call('xml2_doc_parse_file', PACKAGE = 'xml2', path, encoding, as_html, options)
 }
diff --git a/R/utils.R b/R/utils.R
@@ -40,3 +40,29 @@ describe_options <- function(x) {
     paste0("  \\item{", names(x), "}{", attr(x, "description"), "}", collapse = "\n"),
   "\n}")
 }
+
+s_quote <- function(x) paste0("'", x, "'")
+
+# Similar to match.arg, but returns character() with NULL or empty input and
+# errors if any of the inputs are not found (fixing
+# https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16659)
+parse_options <- function(arg, options) {
+  if (is.numeric(arg)) {
+    return(as.integer(arg))
+  }
+
+  if (is.null(arg) || !nzchar(arg)) {
+    return(0L)
+  }
+
+  # set duplicates.ok = TRUE so any duplicates are counted differently than
+  # non-matches, then take only unique results
+  i <- pmatch(arg, names(options), duplicates.ok = TRUE)
+  if (any(is.na(i))) {
+    stop(sprintf("`options` %s is not a valid option, should be one of %s",
+      s_quote(arg[is.na(i)][1L]),
+      paste(s_quote(names(options)), collapse = ", ")),
+      call. = FALSE)
+  }
+  sum(options[unique(i)])
+}
diff --git a/R/xml_parse.R b/R/xml_parse.R
@@ -22,33 +22,8 @@
 #'    iteration. Defaults to 64kb.
 #' @param verbose When reading from a slow connection, this prints some
 #'    output on every iteration so you know its working.
-#' @param options Set parsing options for the libxml2 parser. These are
-#' specified as a character vector of options to set. Available values are
-#' \describe{
-#'   \item{RECOVER}{recover on errors}
-#'   \item{NOENT}{substitute entities}
-#'   \item{DTDLOAD}{load the external subset}
-#'   \item{DTDATTR}{default DTD attributes}
-#'   \item{DTDVALID}{validate with the DTD}
-#'   \item{NOERROR}{suppress error reports}
-#'   \item{NOWARNING}{suppress warning reports}
-#'   \item{PEDANTIC}{pedantic error reporting}
-#'   \item{NOBLANKS}{remove blank nodes}
-#'   \item{SAX1}{use the SAX1 interface internally}
-#'   \item{XINCLUDE}{Implement XInclude substitition}
-#'   \item{NONET}{Forbid network access}
-#'   \item{NODICT}{Do not reuse the context dictionary}
-#'   \item{NSCLEAN}{remove redundant namespaces declarations}
-#'   \item{NOCDATA}{merge CDATA as text nodes}
-#'   \item{NOXINCNODE}{do not generate XINCLUDE START/END nodes}
-#'   \item{COMPACT}{compact small text nodes; no modification of the tree allowed afterwards (will possibly crash if you try to modify the tree)}
-#'   \item{OLD10}{parse using XML-1.0 before update 5}
-#'   \item{NOBASEFIX}{do not fixup XINCLUDE xml:base uris}
-#'   \item{HUGE}{relax any hardcoded limit from the parser}
-#'   \item{OLDSAX}{parse using SAX2 interface before 2.7.0}
-#'   \item{IGNORE_ENC}{ignore internal document encoding hint}
-#'   \item{BIG_LINES}{Store big lines numbers in text PSVI field}
-#' }
+#' @param options Set parsing options for the libxml2 parser. Zero of more of
+#' \Sexpr[results=rd]{xml2:::describe_options(xml2:::xml_parse_options())}
 #' @return An XML document. HTML is normalised to valid XML - this may not
 #'   be exactly the same transformation performed by the browser, but it's
 #'   a reasonable approximation.
@@ -77,6 +52,8 @@ read_html <- function(x, encoding = "", ..., options = c("RECOVER", "NOERROR", "
 
 #' @export
 read_html.default <- function(x, encoding = "", ..., options = c("RECOVER", "NOERROR", "NOBLANKS")) {
+  options <- parse_options(options, xml_parse_options())
+
   suppressWarnings(read_xml(x, encoding = encoding, ..., as_html = TRUE, options = options))
 }
 
@@ -85,6 +62,7 @@ read_html.response <- function(x, encoding = "", options = c("RECOVER",
     "NOERROR", "NOBLANKS"), ...) {
   need_package("httr")
 
+  options <- parse_options(options, xml_parse_options())
   content <- httr::content(x, as = "raw")
   xml2::read_html(content, encoding = encoding, options = options, ...)
 }
@@ -94,7 +72,7 @@ read_html.response <- function(x, encoding = "", options = c("RECOVER",
 read_xml.character <- function(x, encoding = "", ..., as_html = FALSE,
                                options = "NOBLANKS") {
 
-  options <- parse_options(options)
+  options <- parse_options(options, xml_parse_options())
   if (grepl("<|>", x)) {
     read_xml.raw(charToRaw(enc2utf8(x)), "UTF-8", ..., as_html = as_html, options = options)
   } else {
@@ -114,7 +92,7 @@ read_xml.character <- function(x, encoding = "", ..., as_html = FALSE,
 #' @rdname read_xml
 read_xml.raw <- function(x, encoding = "", base_url = "", ...,
                          as_html = FALSE, options = "NOBLANKS") {
-  options <- parse_options(options)
+  options <- parse_options(options, xml_parse_options())
 
   doc <- doc_parse_raw(x, encoding = encoding, base_url = base_url,
     as_html = as_html, options = options)
@@ -126,6 +104,8 @@ read_xml.raw <- function(x, encoding = "", base_url = "", ...,
 read_xml.connection <- function(x, encoding = "", n = 64 * 1024,
                                 verbose = FALSE, ..., base_url = "",
                                 as_html = FALSE, options = "NOBLANKS") {
+  options <- parse_options(options, xml_parse_options())
+
   if (!isOpen(x)) {
     open(x, "rb")
     on.exit(close(x))
@@ -141,48 +121,8 @@ read_xml.response <- function(x, encoding = "", base_url = "", ...,
                               as_html = FALSE, options = "NOBLANKS") {
   need_package("httr")
 
+  options <- parse_options(options, xml_parse_options())
   content <- httr::content(x, as = "raw")
   xml2::read_xml(content, encoding = encoding, base_url = base_url,
     as_html = as_html, option = options, ...)
 }
-
-`%<<%` <- function(a, n) bitwShiftL(a, n)
-
-# http://xmlsoft.org/html/libxml-parser.html#xmlParserOption
-parser_options <- c(
-  "RECOVER" = 1 %<<% 0,
-  "NOENT" = 1 %<<% 1,
-  "DTDLOAD" = 1 %<<% 2,
-  "DTDATTR" = 1 %<<% 3,
-  "DTDVALID" = 1 %<<% 4,
-  "NOERROR" = 1 %<<% 5,
-  "NOWARNING" = 1 %<<% 6,
-  "PEDANTIC" = 1 %<<% 7,
-  "NOBLANKS" = 1 %<<% 8,
-  "SAX1" = 1 %<<% 9,
-  "XINCLUDE" = 1 %<<% 10,
-  "NONET" = 1 %<<% 11,
-  "NODICT" = 1 %<<% 12,
-  "NSCLEAN" = 1 %<<% 13,
-  "NOCDATA" = 1 %<<% 14,
-  "NOXINCNODE" = 1 %<<% 15,
-  "COMPACT" = 1 %<<% 16,
-  "OLD10" = 1 %<<% 17,
-  "NOBASEFIX" = 1 %<<% 18,
-  "HUGE" = 1 %<<% 19,
-  "OLDSAX" = 1 %<<% 20,
-  "OLDSAX" = 1 %<<% 20,
-  "IGNORE_ENC" = 1 %<<% 21,
-  "BIG_LINES" = 1 %<<% 22)
-
-parse_options <- function(options) {
-  if (is.numeric(options)) {
-     return(options)
-  }
-  mtch <- pmatch(options, names(parser_options))
-  if (any(is.na(mtch))) {
-    stop("`options` ", options[is.na(mtch)][1L], " is not a valid option", call. = FALSE)
-  }
-
-  sum(parser_options[mtch])
-}
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
@@ -18,6 +18,16 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// xml_parse_options
+Rcpp::IntegerVector xml_parse_options();
+RcppExport SEXP xml2_xml_parse_options() {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    rcpp_result_gen = Rcpp::wrap(xml_parse_options());
+    return rcpp_result_gen;
+END_RCPP
+}
 // doc_parse_file
 XPtrDoc doc_parse_file(std::string path, std::string encoding, bool as_html, int options);
 RcppExport SEXP xml2_doc_parse_file(SEXP pathSEXP, SEXP encodingSEXP, SEXP as_htmlSEXP, SEXP optionsSEXP) {
diff --git a/src/xml2_doc.cpp b/src/xml2_doc.cpp
@@ -6,6 +6,102 @@ using namespace Rcpp;
 #include "xml2_types.h"
 #include "xml2_utils.h"
 
+// [[Rcpp::export]]
+Rcpp::IntegerVector xml_parse_options() {
+  const char * names[] = {
+    "RECOVER",
+    "NOENT",
+    "DTDLOAD",
+    "DTDATTR",
+    "DTDVALID",
+    "NOERROR",
+    "NOWARNING",
+    "PEDANTIC",
+    "NOBLANKS",
+    "SAX1",
+    "XINCLUDE",
+    "NONET",
+    "NODICT",
+    "NSCLEAN",
+    "NOCDATA",
+    "NOXINCNODE",
+    "COMPACT",
+    "OLD10",
+    "NOBASEFIX",
+    "HUGE",
+    "OLDSAX",
+    "IGNORE_ENC",
+    "BIG_LINES",
+  };
+
+  const int values[] = {
+    XML_PARSE_RECOVER,
+    XML_PARSE_NOENT,
+    XML_PARSE_DTDLOAD,
+    XML_PARSE_DTDATTR,
+    XML_PARSE_DTDVALID,
+    XML_PARSE_NOERROR,
+    XML_PARSE_NOWARNING,
+    XML_PARSE_PEDANTIC,
+    XML_PARSE_NOBLANKS,
+    XML_PARSE_SAX1,
+    XML_PARSE_XINCLUDE,
+    XML_PARSE_NONET,
+    XML_PARSE_NODICT,
+    XML_PARSE_NSCLEAN,
+    XML_PARSE_NOCDATA,
+    XML_PARSE_NOXINCNODE,
+    XML_PARSE_COMPACT,
+    XML_PARSE_OLD10,
+    XML_PARSE_NOBASEFIX,
+    XML_PARSE_HUGE,
+    XML_PARSE_OLDSAX,
+    XML_PARSE_IGNORE_ENC,
+    XML_PARSE_BIG_LINES,
+  };
+
+  const char * descriptions[] = {
+    "recover on errors",
+    "substitute entities",
+    "load the external subset",
+    "default DTD attributes",
+    "validate with the DTD",
+    "suppress error reports",
+    "suppress warning reports",
+    "pedantic error reporting",
+    "remove blank nodes",
+    "use the SAX1 interface internally",
+    "Implement XInclude substitition",
+    "Forbid network access",
+    "Do not reuse the context dictionary",
+    "remove redundant namespaces declarations",
+    "merge CDATA as text nodes",
+    "do not generate XINCLUDE START/END nodes",
+    "compact small text nodes; no modification of the tree allowed afterwards (will possibly crash if you try to modify the tree)",
+    "parse using XML-1.0 before update 5",
+    "do not fixup XINCLUDE xml:base uris",
+    "relax any hardcoded limit from the parser",
+    "parse using SAX2 interface before 2.7.0",
+    "ignore internal document encoding hint",
+    "Store big lines numbers in text PSVI field",
+  };
+
+  size_t size = sizeof(values) / sizeof(values[0]);
+
+  Rcpp::IntegerVector out_values = Rcpp::IntegerVector(size);
+  Rcpp::CharacterVector out_names = Rcpp::CharacterVector(size);
+  Rcpp::CharacterVector out_descriptions = Rcpp::CharacterVector(size);
+  for (int i = 0; i < size; ++i) {
+    out_values[i] = values[i];
+    out_names[i] = names[i];
+    out_descriptions[i] = descriptions[i];
+  }
+  out_values.attr("names") = out_names;
+  out_values.attr("descriptions") = out_descriptions;
+
+  return out_values;
+}
+
 // [[Rcpp::export]]
 XPtrDoc doc_parse_file(std::string path,
                             std::string encoding = "",
diff --git a/tests/testthat/test-read-xml.R b/tests/testthat/test-read-xml.R
@@ -6,11 +6,22 @@ test_that("read_html correctly parses malformed document", {
 })
 
 test_that("parse_options errors when given an invalid option", {
-  expect_error(parse_options("INVALID"),
-    "`options` INVALID is not a valid option")
+  expect_error(parse_options("INVALID", xml_parse_options()),
+    "`options` 'INVALID' is not a valid option")
 
   expect_error(read_html("lego.html.bz2", options = "INVALID"),
-    "`options` INVALID is not a valid option")
+    "`options` 'INVALID' is not a valid option")
+
+  # Empty inputs returned as 0
+  expect_identical(0L, parse_options("", xml_parse_options()))
+  expect_identical(0L, parse_options(NULL, xml_parse_options()))
+
+  # Numerics returned as integers
+  expect_identical(12L, parse_options(12L, xml_parse_options()))
+  expect_identical(12L, parse_options(12, xml_parse_options()))
+
+  # Multiple inputs summed
+  expect_identical(3L, parse_options(c("RECOVER", "NOENT"), xml_parse_options()))
 })
 
 test_that("read_html properly passes parser arguments", {

Original file line number	Diff line number	Diff line change
`@@ -5,6 +5,10 @@ read_connection_ <- function(con, chunk_size = 64 * 1024L) {`
`5`	`5`	`.Call('xml2_read_connection_', PACKAGE = 'xml2', con, chunk_size)`
`6`	`6`	`}`
`7`	`7`
	`8`	`+xml_parse_options <- function() {`
	`9`	`+ .Call('xml2_xml_parse_options', PACKAGE = 'xml2')`
	`10`	`+}`
	`11`	`+`
`8`	`12`	`doc_parse_file <- function(path, encoding = "", as_html = FALSE, options = 0L) {`
`9`	`13`	`.Call('xml2_doc_parse_file', PACKAGE = 'xml2', path, encoding, as_html, options)`
`10`	`14`	`}`