1#xmlRoot.HTMLInternalDocument = 2 xmlRoot.XMLInternalDocument = 3function(x, skip = TRUE, addFinalizer = NA, ...) 4{ 5 .Call("R_xmlRootNode", x, as.logical(skip), addFinalizer, PACKAGE = "XML") 6} 7 8setAs("XMLNode", "XMLInternalNode", 9 function(from) { 10 con = textConnection("tmp", "w", local = TRUE) 11 sink(con) 12 on.exit({sink(file = NULL); close(con)}) 13 print(from) 14 15 doc = xmlParse(tmp, asText = TRUE) 16 node = xmlRoot(doc) 17 removeChildren(node) 18 node 19 } 20 ) 21 22 23setAs("XMLInternalDocument", "character", function(from) saveXML(from)) 24setAs("XMLInternalDOM", "character", function(from) saveXML(from)) 25 26 27setAs("XMLInternalDocument", "XMLInternalNode", 28 function(from) xmlRoot(from)) 29 30 31setAs("XMLInternalNode", "XMLInternalDocument", 32 function(from) { 33 doc = .Call("R_getXMLNodeDocument", from, PACKAGE = "XML") 34 addDocFinalizer(doc, TRUE) 35 if(is(doc, "HTMLInternalDocument")) 36 class(doc) = c(class(doc), "XMLInternalDocument", "XMLAbstractDocument") 37 doc 38 }) 39 40 41 42setGeneric("free", function(obj) standardGeneric("free")) 43 44setMethod("free", "XMLInternalDocument", 45 function(obj) { 46 invisible(.Call("R_XMLInternalDocument_free", obj, PACKAGE = "XML")) 47 }) 48 49 50addFinalizer = 51function(obj, fun, ...) 52{ 53 UseMethod("addFinalizer") 54} 55 56addCFinalizer.XMLInternalDocument = 57function(obj, fun, ...) 58{ 59 if(missing(fun) || fun == NULL) 60 fun = getNativeSymbolInfo("RSXML_free_internal_document")$address 61 else if(!is.function(obj)) { 62 63 } 64 65 .Call("R_addXMLInternalDocument_finalizer", obj, fun, PACKAGE = "XML") 66} 67 68 69asRXMLNode = 70function(node, converters = NULL, trim = TRUE, ignoreBlanks = TRUE) 71{ 72 .Call("R_createXMLNode", node, converters, as.logical(trim), as.logical(ignoreBlanks), PACKAGE = "XML")[[1]] 73} 74 75"[.XMLInternalDocument" = 76function(x, i, j, ..., namespaces = xmlNamespaceDefinitions(x, simplify = TRUE), addFinalizer = NA) 77{ 78 if(is.character(i)) { 79 getNodeSet(x, i, ..., addFinalizer = addFinalizer) 80 } else 81 stop("No method for subsetting an XMLInternalDocument with ", class(i)) 82} 83 84"[[.XMLInternalDocument" = 85function(x, i, j, ..., exact = NA, namespaces = xmlNamespaceDefinitions(x, simplify = TRUE), 86 addFinalizer = NA) 87{ 88 ans = x[i, addFinalizer = addFinalizer] 89 if(length(ans) > 1) 90 warning(length(ans), " elements in node set. Returning just the first one! (Use [])") 91 ans[[1]] 92} 93 94 95 96 97 98 99xmlName.XMLInternalNode = 100function(node, full = FALSE) 101{ 102 ans = .Call("RS_XML_xmlNodeName", node, PACKAGE = "XML") 103 if((is.logical(full) && full) || (!is.logical(full) && length(full))) { 104 tmp = xmlNamespace(node) 105 if(length(tmp) && length(names(tmp)) > 0 && names(tmp) != "") 106 ans = paste(names(tmp), ans, sep = ":") 107 else if(is.character(full) && full != "") 108 ans = paste(full, ans, sep = ":") 109 } 110 ans 111} 112 113if(useS4) 114 setMethod("xmlName", "XMLInternalNode", xmlName.XMLInternalNode) 115 116 117xmlNamespace.XMLInternalNode = 118function(x) 119{ 120 .Call("RS_XML_xmlNodeNamespace", x, PACKAGE = "XML") 121} 122 123 124 125xmlAttrs.XMLInternalNode = 126function(node, addNamespacePrefix = FALSE, addNamespaceURLs = TRUE, ...) 127{ 128 ans = .Call("RS_XML_xmlNodeAttributes", node, as.logical(addNamespacePrefix), as.logical(addNamespaceURLs), PACKAGE = "XML") 129 if(length(attr(ans, "namespaces"))) 130 ans = new("XMLAttributes", ans) # class(ans) = "XMLAttributes" 131 132 ans 133} 134 135#setOldClass(c("XMLAttributes", "character")) 136setClass("XMLAttributes", contains = "character") 137 138setMethod("show", "XMLAttributes", 139 function(object) 140 print(unclass(object))) 141 142setMethod('[', c('XMLAttributes', "ANY"), 143function(x, i, j, ...) 144{ 145 ans = callNextMethod() 146 i = match(i, names(x)) 147 structure(ans, namespaces = attr(x, "namespaces")[i], class = class(x)) 148}) 149 150 151 152xmlChildren.XMLInternalNode = 153function(x, addNames = TRUE, omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA, ...) 154{ 155 kids = .Call("RS_XML_xmlNodeChildrenReferences", x, as.logical(addNames), addFinalizer, PACKAGE = "XML") 156 157if(length(omitNodeTypes)) 158 kids = kids[! sapply(kids, function(x) any(inherits(x, omitNodeTypes)) )] 159 160 structure(kids, class = c("XMLInternalNodeList", "XMLNodeList")) 161} 162 163 164xmlChildren.XMLInternalDocument = 165function(x, addNames = TRUE, ...) 166{ 167# .Call("RS_XML_xmlDocumentChildren", x, as.logical(addNames), PACKAGE = "XML") 168 xmlChildren.XMLInternalNode(x, addNames, ...) 169} 170 171 172if(useS4) { 173setMethod("xmlAttrs", "XMLInternalNode", xmlAttrs.XMLInternalNode) 174setMethod("xmlChildren", "XMLInternalNode", xmlChildren.XMLInternalNode) 175setMethod("xmlChildren", "XMLInternalDocument", xmlChildren.XMLInternalDocument) 176} 177 178 179xmlSize.XMLInternalNode = 180function(obj) 181 .Call("RS_XML_xmlNodeNumChildren", obj, PACKAGE = "XML") 182 183"[[.XMLInternalNode" <- 184#setMethod("[[", "XMLInternalNode", 185function(x, i, j, ..., addFinalizer = NA) 186{ 187 if(inherits(i, "formula")) { 188 return(getNodeSet(x, i, if(missing(j)) character() else j, addFinalizer = addFinalizer, ...)[[1]]) 189 } 190 191 if(is.na(i)) 192 return(NULL) 193 # Get the individual elements rather than all the children and then subset those 194 return( 195 if(is(i, "numeric")) 196 .Call("R_getChildByIndex", x, as.integer(i), as.logical(addFinalizer), PACKAGE = "XML") 197 else 198 .Call("R_getChildByName", x, as.character(i), as.logical(addFinalizer), PACKAGE = "XML") 199 ) 200 201 kids = xmlChildren(x, addFinalizer = addFinalizer) 202 if(length(kids) == 0) 203 return(NULL) 204 205 if(is.numeric(i)) 206 kids[[i]] 207 else { 208 id = as.character(i) 209 which = match(id, sapply(kids, xmlName)) 210 kids[[which]] 211 } 212} 213 214 215 216"[.XMLInternalNode" <- 217function(x, i, j, ..., addFinalizer = NA) 218{ 219 kids = xmlChildren(x, addFinalizer = addFinalizer) 220 if(is.logical(i)) 221 i = which(i) 222 223 if(is(i, "numeric")) 224 structure(kids[i], class = c("XMLInternalNodeList", "XMLNodeList")) 225 else { 226 id = as.character(i) 227 which = match(sapply(kids, xmlName), id) 228 structure(kids[!is.na(which)], class = c("XMLInternalNodeList", "XMLNodeList")) 229 } 230} 231 232 233xmlValue.XMLInternalNode = 234function(x, ignoreComments = FALSE, recursive = TRUE, encoding = getEncoding(x), trim = FALSE) #CE_NATIVE) 235{ 236 237 encoding = if(is.integer(encoding)) 238 encoding 239 else 240 getEncodingREnum(encoding) 241 242 if(!recursive) { 243 if(xmlSize(x) == 0) 244 return(character()) 245 246 kids = xmlChildren(x, addFinaliizer = FALSE) 247 i = sapply(kids, inherits, "XMLInternalTextNode") 248 if(any(i)) 249 return(paste(unlist(lapply(kids[i], xmlValue, ignoreComments, recursive = TRUE, encoding = encoding, trim = trim)), collapse = "")) 250 else 251 return(character()) 252 } 253 254 ans = .Call("R_xmlNodeValue", x, NULL, encoding, PACKAGE = "XML") # 2nd argument ignored. 255 if(trim) 256 trim(ans) 257 else 258 ans 259} 260 261setS3Method("xmlValue", "XMLInternalNode") 262 263setGeneric("xmlValue<-", function(x, ..., value) standardGeneric("xmlValue<-")) 264 265setMethod("xmlValue<-", "XMLInternalTextNode", 266 function(x, ..., value) { 267 .Call("R_setXMLInternalTextNode_value", x, as.character(value), PACKAGE = "XML") 268 x 269 }) 270 271setMethod("xmlValue<-", "XMLTextNode", 272 function(x, ..., value) { 273 x$value = as.character(value) 274 x 275 }) 276 277setMethod("xmlValue<-", "XMLAbstractNode", 278 function(x, ..., value) { 279 if(xmlSize(x) == 0) { 280 x = addChildren(x, as.character(value)) 281 } else if(xmlSize(x) == 1 && any(inherits(x[[1]], c("XMLTextNode", "XMLInternalTextNode")))) { 282 #XXX Fix the assignment to children. 283 # should be xmlValue(x[[1]]) = value 284 tmp = x[[1]] 285 xmlValue(tmp) = as.character(value) 286 if(inherits(x[[1]], "XMLTextNode")) 287 x$children[[1]] = tmp 288 } else 289 stop("Cannot set the content of a node that is not an XMLInternalTextNode or a node containing a text node") 290 x 291 }) 292 293 294 295names.XMLInternalNode = 296function(x) 297 xmlSApply(x, xmlName, addFinalizer = FALSE) 298 299xmlApply.XMLInternalNode = 300function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA) 301{ 302 kids = xmlChildren(X, addFinalizer = addFinalizer) 303 if(length(omitNodeTypes)) 304 kids = kids[! sapply(kids, function(x) any(inherits(x, omitNodeTypes)) )] 305 lapply(kids, FUN, ...) 306} 307 308xmlSApply.XMLInternalNode = 309function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA) 310{ 311 kids = xmlChildren(X, addFinalizer = addFinalizer) 312 if(length(omitNodeTypes)) 313 kids = kids[! sapply(kids, function(x) any(inherits(x, omitNodeTypes)) )] 314 sapply(kids, FUN, ...) 315} 316 317 318xmlSApply.XMLNodeSet = 319function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA) 320{ 321 sapply(X, FUN, ...) 322} 323 324xmlApply.XMLNodeSet = 325function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA) 326{ 327 lapply(X, FUN, ...) 328} 329 330getChildrenStrings = 331function(node, encoding = getEncoding(node), asVector = TRUE, len = xmlSize(node), 332 addNames = TRUE) 333{ 334 encoding = getEncodingREnum(encoding) 335 .Call("R_childStringValues", node, as.integer(len), as.logical(asVector), as.integer(encoding), 336 as.logical(addNames), PACKAGE = "XML") 337} 338 339 340setMethod("xmlParent", "XMLInternalNode", 341function(x, addFinalizer = NA, ...) 342{ 343 .Call("RS_XML_xmlNodeParent", x, addFinalizer, PACKAGE = "XML") 344}) 345 346 347newXMLDTDNode <- 348function(nodeName, externalID = character(), systemID = character(), doc = NULL, addFinalizer = NA) 349{ 350 if(length(nodeName) > 1 && missing(externalID)) 351 externalID = nodeName[2] 352 if(length(nodeName) > 2 && missing(systemID)) 353 systemID = nodeName[3] 354 355 .Call("R_newXMLDtd", doc, as.character(nodeName), as.character(externalID), as.character(systemID), 356 addFinalizer, PACKAGE = "XML") 357} 358 359setInternalNamespace = 360function(node, ns) 361{ 362 .Call("R_xmlSetNs", node, ns, FALSE, PACKAGE = "XML") # as.logical(append)) 363} 364 365 366addDocFinalizer = 367function(doc, finalizer) 368{ 369 fun = NULL 370 if(is.logical(finalizer)) { 371 if(is.na(finalizer) || !finalizer) 372 return() 373 else 374 fun = NULL 375 } else { 376 fun = finalizer 377 if(inherits(fun, "NativeSymbolInfo")) 378 fun = fun$address 379 } 380 381 if(!is.null(fun) && !is.function(fun) && typeof(fun) != "externalptr") 382 stop("need an R function, address of a routine or NULL for finalizer") 383 384 .Call("R_addXMLInternalDocument_finalizer", doc, fun, PACKAGE = "XML") 385} 386 387HTML_DTDs = 388 c("http://www.w3.org/TR/html4/frameset.dtd", 389 "http://www.w3.org/TR/html4/loose.dtd", 390 "http://www.w3.org/TR/html4/strict.dtd", 391 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd", 392 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd", 393 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd", 394 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" 395 ) 396 397newHTMLDoc = 398function(dtd = "loose", addFinalizer = TRUE, name = character(), 399 node = newXMLNode("html", newXMLNode("head", addFinalizer = FALSE), newXMLNode("body", addFinalizer = FALSE), 400 addFinalizer = FALSE)) 401{ 402 if(is.na(dtd) || dtd == "") 403 dtd = "" 404 else if(tolower(dtd) %in% c("html5", "5")) 405 dtd = "5" 406 else { 407 i = grep(dtd, HTML_DTDs) 408 if(length(i)) { 409 if(length(i) > 1) 410 warning("matched multiple DTDs. Using the first") 411 dtd = HTML_DTDs[i[1]] 412 } else 413 dtd = "" 414 } 415 416 417 doc = newXMLDoc(dtd = dtd, isHTML = TRUE, addFinalizer = addFinalizer, node = node) 418 doc 419} 420 421newXMLDoc <- 422# 423# Creates internal C-level libxml object for representing 424# an XML document/tree of nodes. 425# 426function(dtd = "", namespaces = NULL, addFinalizer = TRUE, name = character(), node = NULL, 427 isHTML = FALSE) 428{ 429 if(is(dtd, "XMLInternalNode")) { 430 dtdNode = dtd 431 dtd = character() 432 } else 433 dtdNode = NULL 434 435 ans = .Call("R_newXMLDoc", dtd, namespaces, as.logical(isHTML), PACKAGE = "XML") 436 class(ans) = oldClass(class(ans)) 437 438 addDocFinalizer(ans, addFinalizer) 439 440 if(length(name)) 441 docName(ans) = as.character(name) 442 443 if(length(dtdNode)) 444 addChildren(ans, dtdNode) 445 446 if(length(node)) { 447 if(is.character(node)) 448 ## was parent = doc 449 newXMLTextNode(node, addFinalizer = FALSE, parent = ans) 450 else 451 addChildren(ans, node) 452 } 453 454 ans 455} 456 457XMLOptions = new.env() 458getOption = 459function(name, default = NULL, converter = NULL) 460{ 461 if(!exists(name, XMLOptions, inherits = FALSE)) 462 return(base::getOption(name, default)) 463 464 ans = get(name, XMLOptions) 465 466 if(is.function(converter)) 467 converter(ans) 468 else 469 ans 470} 471 472setOption = 473function(name, value) 474{ 475 prev = getOption(name) 476 assign(name, value, XMLOptions) 477 prev 478} 479 480 481newXMLNode <- 482 ###XXX Note that there is another definition of this in dups.R 483 # Which is now elided. 484 485 # Create an internal C-level libxml node 486 # 487 # 488 # It is possible to use a namespace prefix that is not defined. 489 # This is okay as it may be defined in another node which will become 490 # an ancestor of this newly created one. 491 492 # XXX Have to add something to force the namespace prefix into the node 493 # when there is no corresponding definition for that prefix. 494 495function(name, ..., attrs = NULL, 496 namespace = character(), namespaceDefinitions = character(), 497 doc = NULL, .children = list(...), parent = NULL, 498 at = NA, 499 cdata = FALSE, 500 suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), # i.e. warn. 501 sibling = NULL, addFinalizer = NA, 502 noNamespace = length(namespace) == 0 && !missing(namespace), 503 fixNamespaces = c(dummy = TRUE, default = TRUE) 504 ) 505{ 506 # determine whether we know now that there is definitely no namespace. 507 508 # make certain we have a character vector for the attributes. 509 if(length(attrs)) { 510 ids = names(attrs) 511 attrs = structure(as(attrs, "character"), names = ids) 512 513 # Find any attributes that are actually namespace definitions. 514 i = grep("^xmlns", names(attrs)) 515 if(length(i)) { 516 warning("Don't specify namespace definitions via 'attrs'; use namespaceDefinitions") 517 namespace = c(namespace, structure(attrs[i], names = gsub("^xmlns:", "", names(attrs)[i]))) 518 attrs = attrs[ -i] 519 } 520 } else 521 attrs = character() 522 523 # allow the caller to specify the node name as ns_prefix:name 524 # but we have to create it as name and the set the namespace. 525 ns = character() # the namespace prefix 526 name = strsplit(name, ":")[[1]] 527 if(length(name) == 2) { 528 ns = name[1] 529 name = name[2] 530 noNamespace = FALSE 531 } 532 533 if(is.list(parent)) { 534 if(length(parent) < 1 || 535 !(is(parent[[1]], "XMLInternalElementNode") || is(parent[[1]], "XMLInternalDocument"))) 536 stop("incorrect value for parent") 537 538 parent = parent[[1]] 539 } 540 541 # if there is no doc, but we have a parent which is an XMLInternalDocument, use that. 542 if(missing(doc) && !missing(parent) && 543 inherits(parent, "XMLInternalDocument")) { 544 doc = parent 545 parent = NULL 546 } 547 548 # Get the doc from the parent node/document. 549 if(is.null(doc) && !is.null(parent)) { 550 # doc = as(parent, "XMLInternalDocument") 551 doc = if(inherits(parent, "XMLInternalDocument")) 552 parent 553 else 554 .Call("R_getXMLNodeDocument", parent, PACKAGE = "XML") 555 } 556 557 558 # create the node. Let's leave the namespace definitions and prefix till later. 559 560 # xmlSetProp() routine in R_newXMLNode() handles namespaces on the attribute names, even checking them. 561 node <- .Call("R_newXMLNode", as.character(name), character(), character(), doc, namespaceDefinitions, 562 addFinalizer, PACKAGE = "XML") 563 564 if(!is.null(sibling)) 565 addSibling(sibling, node, after = as.logical(at)) 566 else if(!is.null(parent)) 567 addChildren(parent, node, at = at) 568 569 570 if(TRUE) { # Create the name space definitions here rather than in C code. 571 nsDefs = lapply(seq(along = namespaceDefinitions), 572 function(i) 573 newNamespace(node, namespaceDefinitions[[i]], names(namespaceDefinitions)[i], set = FALSE) 574 ) 575 if(length(namespaceDefinitions)) 576 names(nsDefs) = if(length(names(namespaceDefinitions))) names(namespaceDefinitions) else "" 577 } else 578 nsDefs = xmlNamespaceDefinitions(node) 579 580 # Now that the namespaces are defined, we can define the attributes which _may_ use them. 581 addAttributes(node, .attrs = attrs, suppressNamespaceWarning = suppressNamespaceWarning) 582 583 if(is(namespace, "XMLNamespaceRef")) { 584 setInternalNamespace(node, namespace) 585 } else if(is.na(noNamespace) || !noNamespace) { 586 ns = getNodeNamespace(ns, nsDefs, node, namespace, noNamespace, namespaceDefinitions, parent, suppressNamespaceWarning) 587 if(is.null(ns)) 588 !.Call("R_setNamespaceFromAncestors", node, PACKAGE = "XML") 589# .Call("R_getAncestorDefaultNSDef", node, TRUE, PACKAGE = "XML") 590 } 591 592 593 594 # Here is where we set the namespace for this node. 595 if(length(ns) && (inherits(ns, c("XMLNamespaceRef", "XMLNamespaceDeclaration")) || (is.character(ns) && ns != ""))) 596 setXMLNamespace( node, ns) # should this be append = FALSE ? 597 598 599 # Add any children to this node. 600 if(length(.children)) { 601 if(!is.list(.children)) 602 .children = list(.children) 603 addChildren(node, kids = .children, cdata = cdata, addFinalizer = addFinalizer) 604 } 605 606 if(any(fixNamespaces)) { # !is.null(parent)) { 607 xmlFixNamespaces(node, fixNamespaces) 608 # fixDummyNS(node, suppressNamespaceWarning) 609 } 610 611 node 612} 613 614xmlFixNamespaces = 615function(node, fix) 616{ 617 618 if(length(fix) == 1) 619 fix = structure(rep(fix, 2), names = c("dummy", "default")) 620 621 if(length(names(fix)) == 0) 622 names(fix) = c("dummy", "default") 623 624 625 if(fix["dummy"]) 626 xmlApply(node, function(x) .Call("R_fixDummyNS", x, TRUE, PACKAGE = "XML")) 627 if(fix["default"]) 628 .Call("R_getAncestorDefaultNSDef", node, TRUE, PACKAGE = "XML") 629} 630 631 632FixDummyNS = 2L 633FixDefaultNS = 4L 634 635 636xmlNamespaceRef = 637function(node) 638 .Call("R_getXMLNsRef", node, PACKAGE = "XML") 639 640 641 642if(FALSE) { 643 # Quick check to see if the speed problem in newXMLNode above is in the extra processing 644newXMLNode <- 645function(name, ..., attrs = NULL, 646 namespace = "", namespaceDefinitions = character(), 647 doc = NULL, .children = list(...), parent = NULL, 648 at = NA, 649 cdata = FALSE, 650 suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE) # i.e. warn. 651 ) 652{ 653 node = .Call("R_newXMLNode", name, as.character(attrs), character(), doc, character(), TRUE, PACKAGE = "XML") 654 if(!is.null(parent)) 655 addChildren(parent, node, at = at) 656 node 657} 658} 659 660 661findNamespaceDefinition = 662 # 663 # Search up the node hierarchy looking for a namespace 664 # matching that prefix. 665 # 666function(node, namespace, error = TRUE) 667{ 668 ptr = node 669 while(!is.null(ptr)) { 670 tmp = namespaceDeclarations(ptr, TRUE) 671 i = match(namespace, names(tmp)) 672 if(!is.na(i)) 673 return(tmp[[i]]) 674 ptr = xmlParent(ptr) 675 } 676 677 if(error) 678 stop("no matching namespace definition for prefix ", namespace) 679 680 NULL 681} 682 683setXMLNamespace = 684 # 685 # Set the specified namespace as the namespace for this 686 # node. 687 # namespace can be a prefix in which case we find it in the 688 # definition in this node or its ancestors. 689 # Otherwise, we expect a name = value character vector giving the 690 # prefix and URI and we create a new namespace definition. 691 # Alternatively, if you already have the namespace reference object 692 # from earlier, you can pass that in. 693 # Then we set the namespace on the node. 694function(node, namespace, append = FALSE) 695{ 696 if(is.character(namespace) && is.null(names(namespace))) 697 698 namespace = findNamespaceDefinition(node, namespace) 699 700 else if(is.character(namespace)) 701 702 namespace = newNamespace(node, namespace) 703 else if(!is.null(namespace) && !inherits(namespace, c("XMLNamespaceRef", "XMLNamespaceDeclaration"))) 704 stop("Must provide a namespace definition, a prefix of existing namespace or a reference to a namespace definition") 705 706 .Call("R_xmlSetNs", node, namespace, FALSE, PACKAGE = "XML") 707} 708 709 710setAs("XMLNamespace", "character", 711 function(from) 712 unclass(from)) 713 714setAs("XMLNamespaceDefinition", "character", 715 function(from) 716 structure(from$uri, names = from$id)) 717 718 719setGeneric("xmlNamespace<-", 720 function(x, ..., value) 721 standardGeneric("xmlNamespace<-")) 722 723setMethod("xmlNamespace<-", "XMLInternalNode", 724 function(x, ..., value) { 725 setXMLNamespace(x, value) 726 x 727 }) 728 729 730setGeneric("xmlNamespaces<-", 731 function(x, append = TRUE, set = FALSE, value) 732 standardGeneric("xmlNamespaces<-")) 733 734 735setMethod("xmlNamespaces<-", "XMLNode", 736 function(x, append = TRUE, set = FALSE, value) { 737 738 if(inherits(value, "XMLNamespace")) 739 value = as(value, "character") 740 else if(is.null(names(value))) 741 names(value) = "" 742 743 # check for duplicates? 744 i = duplicated(names(value)) 745 if(any(i)) { 746 warning("discarding duplicated namespace prefixes ", paste(names(value)[i], collapse = ", ")) 747 value = value[!i] 748 } 749 750 if(append) { 751 cur = as(x$namespaceDefinitions, "character") 752 cur[names(value)] = value 753 value = cur 754 } 755 756 x$namespaceDefinitions = as(value, "XMLNamespaceDefinitions") 757 758 if(set) 759 x$namespace = names(value) 760 761 x 762 }) 763 764 765 766 767setMethod("xmlNamespaces<-", "XMLInternalNode", 768 function(x, append = TRUE, set = FALSE, value) { 769 770 value = as(value, "character") 771 772 if(is.null(names(value))) 773 names(value) = "" 774 775 # check for duplicates? 776 i = duplicated(names(value)) 777 if(any(i)) { 778 warning("discarding duplicated namespace prefixes ", paste(names(value)[i], collapse = ", ")) 779 value = value[!i] 780 } 781 782 if(append) { 783 # Work with existing ones 784 curDefs = namespaceDeclarations(x) 785 i = names(value) %in% names(curDefs) 786 if(any(i)) { 787 warning("discarding duplicated namespace prefixes ", paste(names(value)[i], collapse = ", ")) 788 value = value[!i] 789 } 790 } 791 792 if(length(value) == 0) 793 # Should worry about the set. 794 return() 795 796 if(length(set) == 1 && set == TRUE && length(value) > 1) 797 set = c(set, rep(FALSE, length(value) - 1)) 798 else 799 set = rep(set, length.out = length(value)) 800 801 802 for(i in seq(along = value)) 803 newXMLNamespace(x, value[i], set = set[i]) 804 805 x 806 }) 807 808 809 810newXMLNamespace = newNamespace = 811 # Create a new namespace reference object. 812function(node, namespace, prefix = names(namespace), set = FALSE) 813{ 814 if(is.null(namespace)) 815 return(NULL) # XXX 816 817 ns <- .Call("R_xmlNewNs", node, namespace, as.character(prefix), PACKAGE = "XML") 818 if(set) 819 setXMLNamespace(node, ns) 820 ns 821} 822 823checkNodeNamespace = 824 # 825 # can only be checked after we know the parent node, 826 # i.e. after it has been inserted. 827 # 828function(node, prefix = xmlNamespace(node)) 829{ 830 if(length(prefix) == 0 || prefix == "") 831 return(TRUE) 832 833 # XXX should check that namespace is defined 834 # walk the parents. 835 836 okay = FALSE 837 p = xmlParent(node) 838 while(!is.null(p)) { 839 okay = prefix %in% names(xmlNamespaceDefinitions(p)) 840 if(okay) 841 break 842 } 843 844 if(!okay) 845 stop("using an XML namespace prefix '", prefix, "' for a node that is not defined for this node or its node's ancestors") 846 847 TRUE 848} 849 850# Still to do: 851# element, entity, entity_ref, notation 852# And more in libxml/tree.h, e.g. the declaration nodes 853# 854 855newXMLTextNode = 856 # 857 # cdata allows the caller to specify that the text be 858 # wrapped in a newXMLCDataNode 859function(text, parent = NULL, doc = NULL, cdata = FALSE, escapeEntities = is(text, "AsIs"), 860 addFinalizer = NA) 861{ 862 if(cdata) 863 return(newXMLCDataNode(text, parent, doc, addFinalizer = addFinalizer)) 864 865 a = .Call("R_newXMLTextNode", as.character(text), doc, addFinalizer, PACKAGE = "XML") 866 if(escapeEntities) 867 setNoEnc(a) 868 869 if(!is.null(parent)) 870 addChildren(parent, a) 871 872 a 873} 874 875newXMLPINode <- 876function(name, text, parent = NULL, doc = NULL, at = NA, addFinalizer = NA) 877{ 878 a = .Call("R_newXMLPINode", doc, as.character(name), as.character(text), addFinalizer, PACKAGE = "XML") 879 if(!is.null(parent)) 880 addChildren(parent, a, at = at) 881 a 882} 883 884newXMLCDataNode <- 885function(text, parent = NULL, doc = NULL, at = NA, sep = "\n", addFinalizer = NA) 886{ 887 text = paste(as.character(text), collapse = "\n") 888 a = .Call("R_newXMLCDataNode", doc, text, addFinalizer, PACKAGE = "XML") 889 if(!is.null(parent)) 890 addChildren(parent, a, at = at) 891 a 892} 893 894newXMLCommentNode <- 895function(text, parent = NULL, doc = NULL, at = NA, addFinalizer = NA) 896{ 897 a = .Call("R_xmlNewComment", as.character(text), doc, addFinalizer, PACKAGE = "XML") 898 if(!is.null(parent)) 899 addChildren(parent, a, at = at) 900 a 901} 902 903replaceNodes = 904function(oldNode, newNode, ...) 905{ 906 UseMethod("replaceNodes") 907} 908 909replaceNodes.list = 910function(oldNode, newNode, addFinalizer = NA, ...) 911{ 912 mapply(replaceNodes, oldNode, newNode, MoreArgs = list(addFinalizer = addFinalizer, ...)) 913} 914 915replaceNodes.XMLInternalNode = 916function(oldNode, newNode, addFinalizer = NA, ...) 917{ 918 oldNode = as(oldNode, "XMLInternalNode") 919 #XXX deal with a list of nodes. 920 newNode = as(newNode, "XMLInternalNode") 921 922 .Call("RS_XML_replaceXMLNode", oldNode, newNode, addFinalizer, PACKAGE = "XML") 923} 924 925# 926if(FALSE) # This is vectorized for no reason 927"[[<-.XMLInternalNode" = 928function(x, i, j, ..., value) 929{ 930 if(!is.list(value)) 931 value = list(value) 932 933 if(is.character(i)) { 934 if(length(names(x)) == 0) 935 k = rep(NA, length(i)) 936 else 937 k = match(i, names(x)) 938 939 if(any(is.na(k))) { 940 # create a node with that name and text 941 value[is.na(k)] = mapply(function(name, val) 942 if(is.character(val)) 943 newXMLNode(name, val) 944 else 945 val) 946 } 947 i = k 948 } 949 950 replace = (i <= xmlSize(x)) 951 952 if(any(replace)) { 953 replaceNodes(xmlChildren(x)[i[replace]], value[replace]) 954 value = value[!replace] 955 i = i[!replace] 956 } 957 958 if(length(i)) 959 addChildren(x, kids = value, at = i) 960 961 x 962} 963 964 965 966 967"[[<-.XMLInternalNode" = 968function(x, i, j, ..., value) 969{ 970 if(is.character(i)) { 971 if(length(names(x)) == 0) 972 k = NA 973 else 974 k = match(i, names(x)) 975 976 if(is.na(k) && is.character(value) && !inherits(value, "AsIs")) { 977 # create a node with that name and text 978 value = newXMLNode(i, value) 979 } 980 i = k 981 } 982 983 replace = !is.na(i) & (i <= xmlSize(x)) 984 985 if(replace) 986 replaceNodes(xmlChildren(x)[[i]], value) 987 else 988 addChildren(x, kids = list(value), at = i) 989 990 x 991} 992 993 994 995 996setNoEnc = 997function(node) 998{ 999 if(!is(node, "XMLInternalTextNode")) 1000 stop("setNoEnc can only be applied to an native/internal text node, not ", paste(class(node), collapse = ", ")) 1001 1002 .Call("R_setXMLInternalTextNode_noenc", node, PACKAGE = "XML") 1003} 1004 1005 1006 1007addChildren.XMLInternalNode = 1008addChildren.XMLInternalDocument = 1009 # 1010 # XXX need to expand/recycle the at if it is given as a scalar 1011 # taking into account if the subsequent elements are lists, etc. 1012 # 1013 # Basically, if the caller specifies at as a scalar 1014 # we expand this to be the sequence starting at that value 1015 # and having length which is the total number of nodes 1016 # in kids. This is not just the length of kids but 1017 # the number of nodes since some of the elements might be lists. 1018 # 1019function(node, ..., kids = list(...), at = NA, cdata = FALSE, addFinalizer = NA, 1020 fixNamespaces = c(dummy = TRUE, default = TRUE)) 1021{ 1022 kids = unlist(kids, recursive = FALSE) 1023 1024 removeNodes(kids[!vapply(kids, is.character, logical(1L))]) 1025 1026 if(length(kids) == 1 && inherits(kids[[1]], "XMLInternalNode") && is.na(at)) { 1027 .Call("R_insertXMLNode", kids[[1]], node, -1L, FALSE, PACKAGE = "XML") 1028# return(node) 1029 } else { 1030 1031# if(all(is.na(at))) { 1032# kids = lapply(kids, as, function(x) if(is.character(x)) newXMLTextNode(x) else as(x, "XMLInternalNode")) 1033# .Call("R_insertXMLNodeDirectly", node, kids, PACKAGE = "XML") 1034# return(node) 1035# } 1036 1037 1038 if(!is.na(at)) { 1039 1040 # if at is the name of a child node, find its index (first node with that name) 1041 if(is.character(at)) 1042 at = match(at, names(node)) 1043 1044 1045 if(length(at) == 1) 1046 at = seq(as.integer(at), length = sum(sapply(kids, function(x) if(is.list(x)) length(x) else 1))) 1047 else # pad with NAs 1048 length(at) = length(kids) 1049 1050 return(lapply(seq(along = kids), 1051 function(j) { 1052 i = kids[[j]] 1053 1054 if(is.character(i)) 1055 i = newXMLTextNode(i, cdata = cdata, addFinalizer = addFinalizer) 1056 1057 if(!inherits(i, "XMLInternalNode")) #XX is(i, "XMLInternalNode") 1058 i = as(i, "XMLInternalNode") 1059 1060 if(.Call("R_isNodeChildOfAt", i, node, as.integer(at[j]), PACKAGE = "XML")) 1061 return(i) 1062 1063 if(is.na(at[j])) 1064 .Call("R_insertXMLNode", i, node, -1L, FALSE, PACKAGE = "XML") 1065 else { 1066 after = at[j] > 0 1067 if(!after) 1068 at[j] = 1 1069 1070 if(xmlSize(node) < at[j]) 1071 .Call("R_insertXMLNode", i, node, as.integer(NA), FALSE, PACKAGE = "XML") 1072 else 1073 .Call("RS_XML_xmlAddSiblingAt", node[[ at[j] ]], i, after, addFinalizer, PACKAGE = "XML") # if at = 0, then shove it in before the sibling. 1074 } 1075 })) 1076 } 1077 1078 for(j in seq(along = kids)) { 1079 i = kids[[j]] 1080 1081 if(is.list(i)) { # can't happen now since we unlist() 1082 for(k in i) 1083 addChildren(node, k, addFinalizer = addFinalizer) 1084 } else { 1085 1086 if(is.null(i)) 1087 next 1088 1089 if(is.character(i)) 1090 i = newXMLTextNode(i, cdata = cdata, addFinalizer = FALSE) 1091 1092 1093 if(!inherits(i, "XMLInternalNode")) { 1094 i = as(i, "XMLInternalNode") 1095 } 1096 1097 .Call("R_insertXMLNode", i, node, at[j], FALSE, PACKAGE = "XML") 1098 1099 ns = attr(i, "xml:namespace") 1100 if(!is.null(ns)) { 1101 nsdef = findNamespaceDefinition(node, ns) 1102 if(!is.null(nsdef) && (inherits(nsdef, c("XMLNamespaceRef", "XMLNamespaceDeclaration")) || (is.character(nsdef) && nsdef != ""))) { 1103 setXMLNamespace( i, nsdef) 1104 attr(i, "xml:namespace") = NULL 1105 } 1106 } 1107 } 1108 } 1109 } 1110 1111 1112 if(!is(node, "XMLInternalDocument") && any(fixNamespaces)) 1113 xmlFixNamespaces(node, fixNamespaces) 1114 1115 node 1116} 1117 1118 1119 1120addSibling = 1121function(node, ..., kids = list(...), after = NA) 1122{ 1123 UseMethod("addSibling") 1124} 1125 1126addSibling.XMLInternalNode = 1127function(node, ..., kids = list(...), after = TRUE, addFinalizer = NA) 1128{ 1129 #XXX Why add as children? 1130 if(FALSE && is.na(after)) 1131 addChildren(node, kids = kids, at = NA) 1132 else { 1133 lapply(kids, 1134 function(x) { 1135 .Call("RS_XML_xmlAddSiblingAt", node, x, as.logical(after), addFinalizer, PACKAGE = "XML") 1136 }) 1137 } 1138 1139} 1140 1141 1142 1143removeNodes = 1144function(node, free = rep(FALSE, length(node))) 1145 UseMethod("removeNodes") 1146 1147removeNodes.default = 1148function(node, free = rep(FALSE, length(node))) 1149 NULL 1150 1151removeNodes.list = removeNodes.XMLNodeList = 1152function(node, free = rep(FALSE, length(node))) 1153{ 1154 if(!all(sapply(node, inherits, "XMLInternalNode"))) { 1155 warning("removeNode only works on internal nodes at present") 1156 return(NULL) 1157 } 1158 1159 free = as.logical(free) 1160 free = rep(free, length = length(node)) 1161 .Call("R_removeInternalNode", node, free, PACKAGE = "XML") 1162} 1163 1164removeNodes.XMLNodeSet = 1165function(node, free = rep(FALSE, length(node))) 1166{ 1167 removeNodes.list(node, free) 1168} 1169 1170 1171removeNodes.XMLInternalNode = 1172function(node, free = rep(FALSE, length(node))) 1173{ 1174 node = list(node) 1175 free = as.logical(free) 1176 .Call("R_removeInternalNode", node, free, PACKAGE = "XML") 1177} 1178 1179 1180 1181 1182removeChildren = 1183function(node, ..., kids = list(...), free = FALSE) 1184{ 1185 UseMethod("removeChildren") 1186} 1187 1188removeChildren.XMLNode = 1189 # 1190 # 1191function(node, ..., kids = list(...), free = FALSE) 1192{ 1193 1194 kidNames = names(node) 1195 w = sapply(kids, 1196 function(i) { 1197 orig = i 1198 if(length(i) > 1) 1199 warning("each node identifier should be a single value, i.e. a number or a name, not a vector. Ignoring ", 1200 paste(i[-1], collapse = ", ")) 1201 1202 if(!inherits(i, "numeric")) 1203 i = match(i, kidNames) 1204 1205 if(is.na(i)) { 1206 warning("can't find node identified by ", orig) 1207 i = 0 1208 } 1209 i 1210 }) 1211 1212 node$children = unclass(node)$children[ - w ] 1213 node 1214} 1215 1216removeChildren.XMLInternalNode = 1217function(node, ..., kids = list(...), free = FALSE) 1218{ 1219 # idea is to get the actual XMLInternalNode objects 1220 # corresponding the identifiers in the kids list. 1221 # These are numbers, node names or node objects themselves 1222 # This could be fooled by duplicates, e.g. kids = list(2, 2) 1223 # or kids = list(2, "d") where "d" identifies the second node. 1224 # We can put in stricter checks in the C code if needed. 1225 nodes = xmlChildren(node) 1226 nodeNames = xmlSApply(node, xmlName) 1227 v = lapply(kids, 1228 function(x) { 1229 if(inherits(x, "XMLInternalNode")) 1230 x 1231 else if(is.character(x)) { 1232 i = match(x, nodeNames) 1233 nodes[[i]] 1234 } else 1235 nodes[[as.integer(x)]] 1236 }) 1237 1238 free = rep(free, length = length(v)) 1239 .Call("RS_XML_removeChildren", node, v, as.logical(free), PACKAGE = "XML") 1240 node 1241} 1242 1243replaceNodeWithChildren = 1244function(node) 1245{ 1246 if(!inherits(node, "XMLInternalNode")) 1247 stop("replaceNodeWithChildren only work on internal XML/HTML nodes") 1248 1249 .Call("R_replaceNodeWithChildren", node, PACKAGE = "XML") 1250} 1251 1252 1253 1254setGeneric("toHTML", 1255 function(x, context = NULL) standardGeneric("toHTML")) 1256 1257 1258setMethod('toHTML', 'vector', 1259 function(x, context = NULL) { 1260 tb = newXMLNode("table") 1261 if(length(names(x)) > 0) 1262 addChildren(tb, newXMLNode("tr", .children = sapply(names(x), function(x) newXMLNode("th", x)))) 1263 1264 1265 addChildren(tb, newXMLNode("tr", .children = sapply(x, function(x) newXMLNode("th", format(x))))) 1266 tb 1267 }) 1268 1269setMethod('toHTML', 'matrix', 1270 function(x, context = NULL) { 1271 tb = newXMLNode("table") 1272 if(length(colnames(x)) > 0) 1273 addChildren(tb, newXMLNode("tr", .children = sapply(names(x), function(x) newXMLNode("th", x)))) 1274 1275 rows = sapply(seq(length = nrow(x)), 1276 function(i) { 1277 row = newXMLNode("tr") 1278 if(length(rownames(x)) > 0) 1279 addChildren(row, newXMLNode("th", rownames(x)[i])) 1280 addChildren(row, .children = sapply(x[i,], function(x) newXMLNode("th", format(x)))) 1281 row 1282 }) 1283 addChildren(tb, rows) 1284 1285 tb 1286 }) 1287 1288 1289 1290SpecialCallOperators = 1291 c("+", "-", "*", "/", "%*%", "%in%", ":") 1292 1293#XXX Not necessarily working yet! See RXMLDoc 1294setMethod('toHTML', 'call', 1295 function(x, context) { 1296 # handle special operators like +, -, :, ... 1297 if(as.character(v[[1]]) %in% SpecialCallOperators) { 1298 1299 } 1300 1301 v = newXMLNode(x[[1]], "(") 1302 for(i in v[-1]) 1303 addChildren(v, toHTML( i , context)) 1304 1305 v 1306 }) 1307 1308setAs("vector", "XMLInternalNode", 1309 function(from) { 1310 newXMLTextNode(as(from, "character")) 1311 }) 1312 1313 1314 1315print.XMLInternalDocument = 1316function(x, ...) 1317{ 1318 cat(as(x, "character"), "\n") 1319} 1320 1321print.XMLInternalNode = 1322function(x, ...) 1323{ 1324 cat(as(x, "character"), "\n") 1325} 1326 1327 1328setAs("XMLInternalNode", "character", 1329 function(from) saveXML.XMLInternalNode(from)) 1330 1331setAs("XMLInternalTextNode", "character", 1332 function(from) xmlValue(from)) 1333 1334 1335checkAttrNamespaces = 1336function(nsDefs, .attrs, suppressNamespaceWarning) 1337{ 1338 ns = sapply(strsplit(names(.attrs), ":"), 1339 function(x) if(length(x) > 1) x[1] else NA) 1340 i = which(!is.na(ns)) 1341 m = match(ns[i], names(nsDefs)) 1342 if(any(is.na(m))) { 1343 f = if(is.character(suppressNamespaceWarning)) 1344 get(suppressNamespaceWarning, mode = "function") 1345 else 1346 warning 1347 1348 f(paste("missing namespace definitions for prefix(es)", paste(ns[i][is.na(m)]))) 1349 } 1350} 1351 1352setGeneric("addAttributes", 1353 function(node, ..., .attrs = NULL, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), append = TRUE) 1354 standardGeneric("addAttributes")) 1355 1356setMethod("addAttributes", "XMLInternalElementNode", 1357function(node, ..., .attrs = NULL, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), append = TRUE) 1358{ 1359 if(missing(.attrs)) 1360 .attrs = list(...) 1361 1362 .attrs = structure(as.character(.attrs), names = names(.attrs)) 1363 1364 if(length(.attrs) == 0) 1365 return(node) 1366 1367 if(is.null(names(.attrs)) || any(names(.attrs) == "")) 1368 stop("all node attributes must have a name") 1369 1370 1371 if(is.character(suppressNamespaceWarning) || !suppressNamespaceWarning) 1372 checkAttrNamespaces(getEffectiveNamespaces(node), .attrs, suppressNamespaceWarning) 1373 1374 if(!append) 1375 removeAttributes(node, .all = TRUE) 1376 1377 .Call("RS_XML_addNodeAttributes", node, .attrs, PACKAGE = "XML") 1378 node 1379}) 1380 1381#if(!isGeneric("xmlAttrs<-")) 1382 setGeneric("xmlAttrs<-", function(node, append = TRUE, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), value) 1383 standardGeneric("xmlAttrs<-")) 1384 1385tmp = 1386function(node, append = TRUE, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), value) 1387{ 1388 addAttributes(node, .attrs = value, suppressNamespaceWarning = suppressNamespaceWarning, append = append) 1389} 1390 1391setMethod("xmlAttrs<-", "XMLInternalElementNode", tmp) 1392setMethod("xmlAttrs<-", "XMLNode", tmp) 1393 1394 1395setMethod("addAttributes", "XMLNode", 1396 function(node, ..., .attrs = NULL, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), append = TRUE) { 1397 if(missing(.attrs)) 1398 .attrs = list(...) 1399 1400 .attrs = structure(as.character(.attrs), names = names(.attrs)) 1401 1402 if(is.null(names(.attrs)) || any(names(.attrs) == "")) 1403 stop("all node attributes must have a name") 1404 1405 if(is.character(suppressNamespaceWarning) || !suppressNamespaceWarning) 1406 checkAttrNamespaces(getEffectiveNamespaces(node), .attrs, suppressNamespaceWarning) 1407 1408 if(append) { 1409 i = match(names(.attrs), names(node$attributes)) 1410 if(any(!is.na(i))) { 1411 node$attributes[i[!is.na(i)]] = .attrs[!is.na(i)] 1412 .attrs = .attrs[is.na(i)] 1413 } 1414 node$attributes = c(node$attributes, .attrs) 1415 } else 1416 node$attributes = .attrs 1417 node 1418 }) 1419 1420setGeneric("removeAttributes", function(node, ..., .attrs = NULL, .namespace = FALSE, 1421 .all = (length(list(...)) + length(.attrs)) == 0) 1422 standardGeneric("removeAttributes")) 1423 1424 1425setGeneric("removeXMLNamespaces", 1426 function(node, ..., all = FALSE, .els = unlist(list(...))) 1427 standardGeneric("removeXMLNamespaces")) 1428 1429 1430setMethod("removeXMLNamespaces", "XMLInternalElementNode", 1431 function(node, ..., all = FALSE, .els = unlist(list(...))) { 1432 1433 if(all) 1434 .Call("RS_XML_removeAllNodeNamespaces", node, PACKAGE = "XML") 1435 else { 1436 if(is.character(.els)) 1437 .els = lapply(.els, function(x) x) 1438 .Call("RS_XML_removeNodeNamespaces", node, .els, PACKAGE = "XML") 1439 } 1440 }) 1441 1442setMethod("removeAttributes", "XMLInternalElementNode", 1443# 1444# The idea here is to remove attributes by name 1445# We handle the case where these are a simple collection 1446# of character string identifiers given via the ... or as a character 1447# vector using, e.g., .attrs = c("a", "b") 1448# 1449# Each identifier can be of the form "name" or "ns:name" giving 1450# the namespace prefix. We resolve the namespace and 1451# 1452 1453# If we are dealing with regular attributes (no namespace attributes) 1454# then we expect these as a character vector. 1455# 1456# The intent of the .namespace argument was originally to indicate that 1457# we wanted to remove the namespace definition. It appears that libxml2 does 1458# not support that. (And it would seem that this is a real pain as the xmlNsPtr 1459# objects can be shared across numerous places in a linked list, so it would 1460# be very difficult to remove it from one node.) 1461# 1462# 1463# 1464function(node, ..., .attrs = NULL, .namespace = FALSE, 1465 .all = (length(list(...)) + length(.attrs)) == 0) 1466{ 1467 if(missing(.attrs)) 1468 .attrs = list(...) 1469 1470 .attrs = as.character(.attrs) 1471 1472 if(.all) { 1473 if(length(list(...)) || length(.attrs)) 1474 stop(".all specified as TRUE and individual values specified via .../.attrs") 1475 1476 # Use the integer indices to identify the elements. 1477 .Call("RS_XML_removeNodeAttributes", node, seq(along = xmlAttrs(node)), FALSE, PACKAGE = "XML") 1478 return(node) 1479 } 1480 1481 1482 if(is(.namespace, "XMLNamespaceDeclaration")) 1483 .namespace = list(.namespace) 1484#XXX 1485 1486 tmp = strsplit(.attrs, ":") 1487 prefix = sapply(tmp, function(x) if(length(x) > 1) x[1] else "") 1488 ids = sapply(tmp, function(x) if(length(x) == 1) x[1] else x[2]) 1489 1490 if(any(prefix != "") && is.logical(.namespace)) 1491 .namespace = TRUE 1492 1493 if(is.logical(.namespace) && .namespace) { 1494 ns = namespaceDeclarations(node, TRUE) 1495 # need to create a list with the elements corresponding to the 1496 # (potentially repeated) ns elements 1497 1498 i = match(prefix, names(ns)) 1499 ns = ns[i] 1500 names(ns) = gsub("^.*:", "", .attrs) # or ids from above 1501 1502 .attrs = ns 1503 } 1504 1505 .Call("RS_XML_removeNodeAttributes", node, .attrs, .namespace, PACKAGE = "XML") 1506 node 1507}) 1508 1509 1510setMethod("removeAttributes", "XMLNode", 1511function(node, ..., .attrs = NULL, .namespace = FALSE, 1512 .all = (length(list(...)) + length(.attrs)) == 0) 1513{ 1514 a = node$attributes 1515 1516 if(missing(.attrs)) 1517 .attrs = list(...) 1518 1519 .attrs = as.character(.attrs) 1520 1521 if(.all) { 1522 if(length(.attrs)) 1523 stop("Both individual attribute names and .all specified") 1524 node$attributes = character() 1525 return(node) 1526 } 1527 1528 i = match(.attrs, names(a)) 1529 if(any(is.na(i)) ) 1530 warning("Can't locate attributes ", paste(.attrs[is.na(i)], collapse = ", "), "in XML node ", node$name) 1531 1532 a = a[is.na(i)] 1533 1534 node$attributes <- a 1535 node 1536}) 1537 1538#xmlNamespaceDefinitions = # ??? added this but overrides other S3 generic. 1539namespaceDeclarations = 1540function(node, ref = FALSE, ...) 1541{ 1542 .Call("RS_XML_getNsList", node, as.logical(ref), PACKAGE = "XML") 1543} 1544 1545 1546"xmlName<-" = 1547function(x, value) 1548{ 1549 UseMethod("xmlName<-") 1550} 1551 1552"xmlName<-.XMLNode" <- 1553function(x, value) 1554{ 1555 x$name <- value 1556 x 1557} 1558 1559"xmlName<-.XMLInternalElementNode" <- 1560function(x, value) 1561{ 1562 # we could handle a new namespace by accepting value as 1563 # a character vector with a name 1564 # e.g. c(r:array = 'http://www.r-project.org') 1565 # Alternatively, just define the namespace on the node _before_ 1566 # changing the name. 1567 id = names(value) 1568 if(!is.null(id) && length( (tmp <- strsplit(id, ":")[[1]])) > 1) { 1569 names(value) = tmp[1] 1570 newXMLNamespaces(x, .values = as(value, "character")) 1571 value = id 1572 } 1573 1574 .Call("RS_XML_setNodeName", x, value, PACKAGE = "XML") 1575 1576 x 1577} 1578 1579 1580 1581newXMLNamespaces = 1582 # allow for multiple namespaces 1583 # and also allow for "r:value" 1584 # 1585 # newXMLNamespaces(node, r = "http://www.r-project.org", ...) 1586 # 1587function(node, ..., .values = list(...)) 1588{ 1589 ids = names(.values) 1590 ans = lapply(ids, function(id) 1591 newNamespace(node, id, as.character(.values[[id]]))) 1592 1593 names(ans) = ids 1594 ans 1595} 1596 1597 1598 1599 1600xmlNodeMatch = 1601function(x, table, nomatch = NA_integer_) 1602{ 1603 .Call("R_matchNodesInList", x, table, as.integer(nomatch), PACKAGE = "XML") 1604} 1605 1606 1607setGeneric("xmlClone", 1608function(node, recursive = TRUE, addFinalizer = FALSE, ...) 1609 { 1610 oclass = class(node) 1611 ans = standardGeneric("xmlClone") 1612 if(!isS4(node)) 1613 class(ans) = oclass 1614 ans 1615 }) 1616 1617setMethod("xmlClone", "XMLInternalDocument", 1618function(node, recursive = TRUE, addFinalizer = NA, ...) 1619{ 1620 ans = .Call("RS_XML_clone", node, as.logical(recursive), addFinalizer, PACKAGE = "XML") 1621 1622 addDocFinalizer(ans, addFinalizer) 1623 ans 1624}) 1625 1626setMethod("xmlClone", "XMLInternalNode", 1627function(node, recursive = TRUE, addFinalizer = FALSE, ...) 1628{ 1629 ans = .Call("RS_XML_clone", node, as.logical(recursive), addFinalizer, PACKAGE = "XML") 1630}) 1631 1632 1633 1634 1635 1636 1637 1638 1639ensureNamespace = 1640 # 1641 # Idea is to make certain that the root node has definitions for the specified 1642 # namespaces. The caller specifies the named vector of interest. 1643 # If the URL already exists, we return the corresponding prefix. 1644 # 1645 # 1646 # Returns the prefixes in the documents that correspond to the 1647 # namespace definitions 1648 # 1649function(doc, what) 1650{ 1651 if(is(doc, "XMLInternalDocument")) 1652 node = xmlRoot(doc) 1653 else 1654 node = doc 1655 1656 defs = xmlNamespaceDefinitions(xmlRoot(doc), simplify = TRUE) 1657 i = match(what, defs) 1658 w = is.na(i) 1659 1660 if(any(w)) { 1661 sapply(names(what)[w], function(id) newXMLNamespace(node, what[id], id)) 1662 names(what)[w] 1663 } else 1664 names(defs)[i] 1665} 1666 1667 1668"xmlParent<-" = 1669 function(x, ..., value) { 1670 addChildren(value, ..., kids = list(x)) 1671} 1672 1673 1674setOldClass("XMLNamespaceRef") 1675setAs("XMLNamespaceRef", "character", 1676 function(from) { 1677 .Call("R_convertXMLNsRef", from, PACKAGE = "XML") 1678 }) 1679 1680 1681 1682 1683xmlSearchNs = 1684function(node, ns, asPrefix = TRUE, doc = as(node, "XMLInternalDocument")) 1685{ 1686 1687 .Call("R_xmlSearchNs", doc, node, as.character(ns), as.logical(asPrefix), PACKAGE = "XML") 1688} 1689