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