1#' Modify a tree by inserting, replacing or removing nodes 2#' 3#' `xml_add_sibling()` and `xml_add_child()` are used to insert a node 4#' as a sibling or a child. `xml_add_parent()` adds a new parent in 5#' between the input node and the current parent. `xml_replace()` 6#' replaces an existing node with a new node. `xml_remove()` removes a 7#' node from the tree. 8#' 9#' @details Care needs to be taken when using `xml_remove()`, 10#' @param .x a document, node or nodeset. 11#' @param .copy whether to copy the `.value` before replacing. If this is `FALSE` 12#' then the node will be moved from it's current location. 13#' @param .where to add the new node, for `xml_add_child` the position 14#' after which to add, use `0` for the first child. For 15#' `xml_add_sibling` either \sQuote{"before"} or \sQuote{"after"} 16#' indicating if the new node should be before or after `.x`. 17#' @param ... If named attributes or namespaces to set on the node, if unnamed 18#' text to assign to the node. 19#' @param .value node to insert. 20#' @param free When removing the node also free the memory used for that node. 21#' Note if you use this option you cannot use any existing objects pointing to 22#' the node or its children, it is likely to crash R or return garbage. 23#' @export 24xml_replace <- function(.x, .value, ..., .copy = TRUE) { 25 UseMethod("xml_replace") 26} 27 28#' @export 29xml_replace.xml_node <- function(.x, .value, ..., .copy = TRUE) { 30 31 node <- create_node(.value, .parent = .x, .copy = .copy, ...) 32 33 .x$node <- .Call(node_replace, .x$node, node$node) 34 node 35} 36 37#' @export 38xml_replace.xml_nodeset <- function(.x, .value, ..., .copy = TRUE) { 39 40 if (length(.x) == 0) { 41 return(.x) 42 } 43 44 # Need to wrap this in a list if a bare xml_node so it is recycled properly 45 if (inherits(.value, "xml_node")) { 46 .value <- list(.value) 47 } 48 49 Map(xml_replace, .x, .value, ..., .copy = .copy) 50} 51 52#' @export 53xml_replace.xml_missing <- function(.x, .value, ..., .copy = TRUE) { 54 .x 55} 56 57#' @rdname xml_replace 58#' @export 59xml_add_sibling <- function(.x, .value, ..., .where = c("after", "before"), .copy = TRUE) { 60 UseMethod("xml_add_sibling") 61} 62 63#' @export 64xml_add_sibling.xml_node <- function(.x, .value, ..., .where = c("after", "before"), .copy = inherits(.value, "xml_node")) { 65 .where <- match.arg(.where) 66 67 node <- create_node(.value, .parent = .x, .copy = .copy, ...) 68 69 .x$node <- switch(.where, 70 before = .Call(node_prepend_sibling, .x$node, node$node), 71 after = .Call(node_append_sibling, .x$node, node$node)) 72 73 invisible(.x) 74} 75 76#' @export 77xml_add_sibling.xml_nodeset <- function(.x, .value, ..., .where = c("after", "before"), .copy = TRUE) { 78 if (length(.x) == 0) { 79 return(.x) 80 } 81 82 .where <- match.arg(.where) 83 84 # Need to wrap this in a list if a bare xml_node so it is recycled properly 85 if (inherits(.value, "xml_node")) { 86 .value <- list(.value) 87 } 88 89 invisible(Map(xml_add_sibling, rev(.x), rev(.value), ..., .where = .where, .copy = .copy)) 90} 91 92#' @export 93xml_add_sibling.xml_missing <- function(.x, .value, ..., .where = c("after", "before"), .copy = TRUE) { 94 .x 95} 96 97# Helper function used in the xml_add* methods 98create_node <- function(.value, ..., .parent, .copy) { 99 if (inherits(.value, "xml_node")) { 100 if (isTRUE(.copy)) { 101 .value$node <- .Call(node_copy, .value$node) 102 } 103 return(.value) 104 } 105 106 if (inherits(.value, "xml_cdata")) { 107 return(xml_node(.Call(node_cdata_new, .parent$doc, .value), doc = .parent$doc)) 108 } 109 110 if (inherits(.value, "xml_comment")) { 111 return(xml_node(.Call(node_comment_new, .value), doc = .parent$doc)) 112 } 113 114 if (inherits(.value, "xml_dtd")) { 115 .Call(node_new_dtd, .parent$doc, .value$name, .value$external_id, .value$system_id) 116 return() 117 } 118 119 if (!is.character(.value)) { 120 stop("`.value` must be a character", call. = FALSE) 121 } 122 123 parts <- strsplit(.value, ":")[[1]] 124 if (length(parts) == 2 && !is.null(.parent$node)) { 125 namespace <- .Call(ns_lookup, .parent$doc, .parent$node, parts[[1]]) 126 node <- structure(list(node = .Call(node_new_ns, parts[[2]], namespace), doc = .parent$doc), class = "xml_node") 127 } else { 128 node <- structure(list(node = .Call(node_new, .value), doc = .parent$doc), class = "xml_node") 129 } 130 131 args <- list(...) 132 named <- has_names(args) 133 xml_attrs(node) <- args[named] 134 xml_text(node) <- paste(args[!named], collapse = "") 135 136 node 137} 138 139#' @rdname xml_replace 140#' @export 141xml_add_child <- function(.x, .value, ..., .where = length(xml_children(.x)), .copy = TRUE) { 142 UseMethod("xml_add_child") 143} 144 145#' @export 146xml_add_child.xml_node <- function(.x, .value, ..., .where = length(xml_children(.x)), .copy = inherits(.value, "xml_node")) { 147 148 node <- create_node(.value, .parent = .x, .copy = .copy, ...) 149 150 if (.where == 0L) { 151 if(.Call(node_has_children, .x$node, TRUE)) { 152 .Call(node_prepend_child, .x$node, node$node) 153 } 154 else { 155 .Call(node_append_child, .x$node, node$node) 156 } 157 } else { 158 num_children <- length(xml_children(.x)) 159 if (.where >= num_children) { 160 .Call(node_append_child, .x$node, node$node) 161 } else 162 .Call(node_append_sibling, xml_child(.x, search = .where)$node, node$node) 163 } 164 165 invisible(node) 166} 167 168#' @export 169xml_add_child.xml_document <- function(.x, .value, ..., .where = length(xml_children(.x)), .copy = inherits(.value, "xml_node")) { 170 if (inherits(.x, "xml_node")) { 171 NextMethod("xml_add_child") 172 } else { 173 node <- create_node(.value, .parent = .x, .copy = .copy, ...) 174 if (!is.null(node)) { 175 if (!.Call(doc_has_root, .x$doc)) { 176 .Call(doc_set_root, .x$doc, node$node) 177 } 178 .Call(node_append_child, .Call(doc_root, .x$doc), node$node) 179 } 180 invisible(xml_document(.x$doc)) 181 } 182} 183 184#' @export 185xml_add_child.xml_nodeset <- function(.x, .value, ..., .where = length(xml_children(.x)), .copy = TRUE) { 186 if (length(.x) == 0) { 187 return(.x) 188 } 189 190 # Need to wrap this in a list if a bare xml_node so it is recycled properly 191 if (inherits(.value, "xml_node")) { 192 .value <- list(.value) 193 } 194 195 res <- Map(xml_add_child, .x, .value, ..., .where = .where, .copy = .copy) 196 invisible(make_nodeset(res, res[[1]]$doc)) 197} 198 199#' @export 200xml_add_child.xml_missing <- function(.x, .value, ..., .copy = TRUE) { 201 .x 202} 203 204#' @rdname xml_replace 205#' @export 206xml_add_parent <- function(.x, .value, ...) { 207 UseMethod("xml_add_parent") 208} 209 210#' @export 211xml_add_parent.xml_node <- function(.x, .value, ...) { 212 new_parent <- xml_replace(.x, .value = .value, ..., .copy = FALSE) 213 node <- xml_add_child(new_parent, .value = .x, .copy = FALSE) 214 215 invisible(node) 216} 217 218#' @export 219xml_add_parent.xml_nodeset <- function(.x, .value, ...) { 220 if (length(.x) == 0) { 221 return(.x) 222 } 223 224 # Need to wrap this in a list if a bare xml_node so it is recycled properly 225 if (inherits(.value, "xml_node")) { 226 .value <- list(.value) 227 } 228 229 res <- Map(xml_add_parent, .x, .value, ...) 230 invisible(make_nodeset(res, res[[1]]$doc)) 231} 232 233#' @export 234xml_add_parent.xml_missing <- function(.x, .value, ..., .copy = TRUE) { 235 invisible(.x) 236} 237 238#' @rdname xml_replace 239#' @export 240xml_remove <- function(.x, free = FALSE) { 241 UseMethod("xml_remove") 242} 243 244#' @export 245xml_remove.xml_node <- function(.x, free = FALSE) { 246 .Call(node_remove, .x$node, free) 247 248 invisible(.x) 249} 250 251#' @export 252xml_remove.xml_nodeset <- function(.x, free = FALSE) { 253 if (length(.x) == 0) { 254 return(invisible(.x)) 255 } 256 257 invisible(Map(xml_remove, rev(.x), free = free)) 258} 259 260#' @export 261xml_remove.xml_missing <- function(.x, free = FALSE) { 262 invisible(.x) 263} 264 265#' Set the node's namespace 266#' 267#' The namespace to be set must be already defined in one of the node's 268#' ancestors. 269#' @param .x a node 270#' @param prefix The namespace prefix to use 271#' @param uri The namespace URI to use 272#' @return the node (invisibly) 273#' @export 274xml_set_namespace <- function(.x, prefix = "", uri = "") { 275 stopifnot(inherits(.x, "xml_node")) 276 277 if (nzchar(uri)) { 278 .Call(node_set_namespace_uri, .x$doc, .x$node, uri) 279 } else { 280 .Call(node_set_namespace_prefix, .x$doc, .x$node, prefix) 281 } 282 invisible(.x) 283} 284 285#' Create a new document, possibly with a root node 286#' 287#' `xml_new_document` creates only a new document without a root node. In 288#' most cases you should instead use `xml_new_root`, which creates a new 289#' document and assigns the root node in one step. 290#' @param version The version number of the document. 291#' @param encoding The character encoding to use in the document. The default 292#' encoding is \sQuote{UTF-8}. Available encodings are specified at 293#' <http://xmlsoft.org/html/libxml-encoding.html#xmlCharEncoding>. 294#' @return A `xml_document` object. 295#' @export 296# TODO: jimhester 2016-12-16 Deprecate this in the future? 297xml_new_document <- function(version = "1.0", encoding = "UTF-8") { 298 doc <- .Call(doc_new, version, encoding) 299 structure(list(doc = doc), class = "xml_document") 300} 301 302#' @param .version The version number of the document, passed to `xml_new_document(version)`. 303#' @param .encoding The encoding of the document, passed to `xml_new_document(encoding)`. 304#' @inheritParams xml_add_child 305#' @rdname xml_new_document 306#' @export 307xml_new_root <- function(.value, ..., .copy = inherits(.value, "xml_node"), .version = "1.0", .encoding = "UTF-8") { 308 xml_add_child(xml_new_document(version = .version, encoding = .encoding), .value = .value, ... = ..., .copy = .copy) 309} 310 311#' Strip the default namespaces from a document 312#' 313#' @inheritParams xml_name 314#' @examples 315#' x <- read_xml( 316#' "<foo xmlns = 'http://foo.com'> 317#' <baz/> 318#' <bar xmlns = 'http://bar.com'> 319#' <baz/> 320#' </bar> 321#' </foo>") 322#' # Need to specify the default namespaces to find the baz nodes 323#' xml_find_all(x, "//d1:baz") 324#' xml_find_all(x, "//d2:baz") 325#' 326#' # After stripping the default namespaces you can find both baz nodes directly 327#' xml_ns_strip(x) 328#' xml_find_all(x, "//baz") 329#' @export 330xml_ns_strip <- function(x) { 331 332 # //namespace::*[name()=''] finds all the namespace definition nodes with no 333 # prefix (default namespaces). 334 # What we actually want is the element node the definitions are contained in 335 # so return the parent (/parent::*) 336 namespace_element_nodes <- xml_find_all(x, "//namespace::*[name()='']/parent::*") 337 xml_attr(namespace_element_nodes, "xmlns") <- NULL 338 invisible(x) 339} 340