Implement xml_name.xml_nodeset() in C

r-lib · Aug 23, 2023 · 8f19086 · 8f19086
1 parent ef2310b
commit 8f19086
Show file tree

Hide file tree

Showing 5 changed files with 55 additions and 2 deletions.
diff --git a/R/utils.R b/R/utils.R
@@ -80,3 +80,14 @@ xml2_example <- function(path = NULL) {
     system.file("extdata", path, package = "xml2", mustWork = TRUE)
   }
 }
+
+sample_nodeset <- function() {
+  x <- read_xml("<body>
+    <p>Some <b>text</b>.</p>
+    <p>Some <i>other</i>.</p>
+    <p>No bold text</p>
+    </body>")
+
+  children <- xml_children(x)
+  xml_find_first(children, ".//b|.//i")
+}
diff --git a/R/xml_name.R b/R/xml_name.R
@@ -28,7 +28,7 @@ xml_name.xml_missing <- function(x, ns = character()) {
 
 #' @export
 xml_name.xml_nodeset <- function(x, ns = character()) {
-  vapply(x, xml_name, ns = ns, FUN.VALUE = character(1))
+  .Call(nodeset_name, x, ns)
 }
 
 #' @export

diff --git a/src/init.c b/src/init.c
@@ -38,6 +38,7 @@ extern SEXP node_copy(SEXP);
 extern SEXP node_has_children(SEXP, SEXP);
 extern SEXP node_length(SEXP, SEXP);
 extern SEXP node_name(SEXP, SEXP);
+extern SEXP nodeset_name(SEXP, SEXP);
 extern SEXP node_new(SEXP);
 extern SEXP node_new_dtd(SEXP, SEXP, SEXP, SEXP);
 extern SEXP node_new_ns(SEXP, SEXP);
@@ -103,6 +104,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"node_has_children",         (DL_FUNC) &node_has_children,         2},
     {"node_length",               (DL_FUNC) &node_length,               2},
     {"node_name",                 (DL_FUNC) &node_name,                 2},
+    {"nodeset_name",              (DL_FUNC) &nodeset_name,              2},
     {"node_new",                  (DL_FUNC) &node_new,                  1},
     {"node_new_dtd",              (DL_FUNC) &node_new_dtd,              4},
     {"node_new_ns",               (DL_FUNC) &node_new_ns,               2},

diff --git a/src/xml2_node.cpp b/src/xml2_node.cpp
@@ -37,6 +37,36 @@ extern "C" SEXP node_name(SEXP node_sxp, SEXP nsMap) {
   END_CPP
 }
 
+// [[export]]
+extern "C" SEXP nodeset_name(SEXP node_sxp, SEXP nsMap) {
+  BEGIN_CPP
+
+  int n = Rf_xlength(node_sxp);
+
+  SEXP out = PROTECT(Rf_allocVector(STRSXP, n));
+
+  for (int i = 0; i < n; ++i) {
+    SEXP node_sxp_i = VECTOR_ELT(node_sxp, i);
+
+    if (Rf_inherits(node_sxp_i, "xml_node")) {
+      SEXP node_field_i = VECTOR_ELT(node_sxp_i, 0);
+      XPtrNode node_i(node_field_i);
+      std::string name_i = nodeName(node_i.checked_get(), nsMap);
+      SET_STRING_ELT(out, i, Rf_mkCharLenCE(name_i.c_str(), name_i.size(), CE_UTF8));
+    } else if (Rf_inherits(node_sxp_i, "xml_missing")) {
+      SET_STRING_ELT(out, i, NA_STRING);
+    } else {
+      // xml_nodeset can't appear
+      Rf_error("Unexpected node type");
+    }
+  }
+
+  UNPROTECT(1);
+  return out;
+
+  END_CPP
+}
+
 // [[export]]
 extern "C" SEXP node_set_name(SEXP node_sxp, SEXP value) {
   BEGIN_CPP

diff --git a/tests/testthat/test-xml_name.R b/tests/testthat/test-xml_name.R
@@ -1,3 +1,13 @@
+test_that("xml_name() returns the name", {
+  x <- sample_nodeset()
+
+  expect_equal(xml_name(x[[1]]), "b")
+  expect_equal(xml_name(x[[2]]), "i")
+  expect_equal(xml_name(x[[3]]), NA_character_)
+
+  expect_equal(xml_name(x), c("b", "i", NA_character_))
+})
+
 test_that("qualified names returned when ns given", {
   x <- read_xml(test_path("ns-multiple-default.xml"))
   ns <- xml_ns(x)
@@ -12,7 +22,7 @@ test_that("error if missing ns spec", {
   ns <- xml_ns(x)[1]
 
   bars <- xml_children(xml_children(x))
-  expect_error(xml_name(bars, ns), "Couldn't find prefix")
+  expect_snapshot_error(xml_name(bars, ns))
 })
 
 test_that("xml_name<- modifies the name", {