XiMpLe: A Simple XML Tree Parser and Generator

Documented in pasteXMLNode pasteXMLTree

# Copyright 2011-2022 Meik Michalke <meik.michalke@hhu.de>
#
# This file is part of the R package XiMpLe.
#
# XiMpLe is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# XiMpLe is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with XiMpLe.  If not, see <http://www.gnu.org/licenses/>.


#' Paste methods for XiMpLe XML objects
#' 
#' These methods can be used to paste objects if class \code{\link[XiMpLe:XiMpLe_node-class]{XiMpLe_node}}
#' or \code{\link[XiMpLe:XiMpLe_doc-class]{XiMpLe_doc}}.
#'
#' @note The functions pasteXMLNode() and pasteXMLTree() have been replaced by the pasteXML methods.
#'    They should no longer be used.
#'
#' @param obj An object of class \code{XiMpLe_node} or \code{XiMpLe_doc}.
#' @param ... Additional options for the generic method, see options for a specific method, respectively.
#' @aliases
#'    pasteXML,-methods
#'    pasteXMLNode
#'    pasteXMLTree
#' @seealso \code{\link[XiMpLe:XiMpLe_node-class]{XiMpLe_node}}, 
#'    \code{\link[XiMpLe:XiMpLe_doc-class]{XiMpLe_doc}}
#' @keywords methods
#' @import methods
#' @rdname pasteXML-methods
#' @include 00_class_01_XiMpLe.node.R
#' @include 00_class_02_XiMpLe.doc.R
#' @docType methods
#' @export
setGeneric("pasteXML", function(obj, ...){
  standardGeneric("pasteXML")
})

#' @param level Indentation level.
#' @param shine Integer, controlling if the output should be formatted for better readability. Possible values:
#'    \describe{
#'      \item{0}{No formatting.}
#'      \item{1}{Nodes will be indented.}
#'      \item{2}{Nodes will be indented and each attribute gets a new line.}
#'    }
#' @param indent.by A charachter string defining how indentation should be done. Defaults to tab.
#' @param tidy Logical, if \code{TRUE} the special characters "<" and ">" will be replaced with the entities
#'    "&lt;" and "gt;" in attributes and text values.
#' @param tidy.omit A character vector with node names that should be excluded from \code{tidy}.
#' @param as_script Logical, if \code{TRUE}, tags will be pasted as a sketch for a script to be run in conjunction with
#'    functions generated by \code{\link[XiMpLe:gen_tag_functions]{gen_tag_functions}}. This script code will most
#'    likely not run without adjustments, but is perhaps a good start anyway.
#' @param func_rename Named character vector defining which tags' functions should get a different name.
#'    This makes it easier to get functions with valid names that generate special tag nodes.
#'    Only used when \code{as_script=TRUE}. Use the same names and values as you used in
#'    \code{\link[XiMpLe:gen_tag_functions]{gen_tag_functions}}.
#' @rdname pasteXML-methods
#' @aliases
#'    pasteXML,XiMpLe_node-method
setMethod("pasteXML",
  signature=signature(obj="XiMpLe_node"),
  function(
    obj,
    level=1,
    shine=1,
    indent.by=getOption("XiMpLe_indent", "\t"),
    tidy=TRUE,
    tidy.omit=c("![CDATA[", "*![CDATA["),
    as_script=FALSE,
    func_rename=c(
      "?xml_"="xml_",
      "!--_"="comment_",
      "![CDATA[_"="CDATA_",
      "!DOCTYPE_"="DOCTYPE_"
    )
  ){
    if(isTRUE(as_script)){
      next_sep <- ","
    } else {
      next_sep <- ""
    }
    new_indent <- ifelse(shine > 0, indent(level+1, by=indent.by), "")
    new_node   <- ifelse(shine > 0, paste0(next_sep, "\n"), paste0(next_sep, " "))

    # get the slot contents
    node_name <- slot(obj, "name")
    node_attr <- slot(obj, "attributes")
    node_chld <- slot(obj, "children")
    node_val  <- slot(obj, "value")

    if(!length(node_attr) > 0){
      node_attr <- NULL
    } else {}

    if(length(node_chld) > 0){
      # check for shine overwrites, pass it down to children
      shine_override <- slot(obj, "extra")[["shine"]]
      node_chld <- paste0(unlist(sapply(
        node_chld,
        function(this_node){
          if(slot(this_node, "name") %in% tidy.omit){
            tidy <- FALSE
          } else {}
          if(slot(this_node, "name") == ""){
            this_node_pasted <- trim(pasteXML(
              this_node,
              level=level,
              shine=ifelse(length(shine_override) > 0, shine_override, shine),
              indent.by=indent.by,
              tidy=tidy,
              tidy.omit=tidy.omit,
              as_script=as_script,
              func_rename=func_rename
            ))
          } else {
            this_node_pasted <- trim(pasteXML(
              this_node,
              level=(level + 1),
              shine=ifelse(length(shine_override) > 0, shine_override, shine),
              indent.by=indent.by,
              tidy=tidy,
              tidy.omit=tidy.omit,
              as_script=as_script,
              func_rename=func_rename
            ))
          }
          return(this_node_pasted)
        },
        USE.NAMES=FALSE
      )), collapse=paste0(new_node, new_indent))
      node_empty <- FALSE
    } else {
      node_chld <- NULL
      node_empty <- TRUE
    }

    # take care of text value
    if(length(node_val) > 0){
      node_empty <- FALSE
      if(nchar(node_val) > 0){
        if(all(isTRUE(tidy), !node_name %in% tidy.omit)){
          node_val <- sapply(node_val, xml.tidy, USE.NAMES=FALSE)
        } else {}
        node_chld <- paste0(
          node_chld,
          trim(
            paste0(
              node_val,
              collapse=new_node
            )
          )
        )
      } else {}
    } else {}

    result <- pasteXMLTag(
      node_name,
      attr=node_attr,
      child=node_chld,
      empty=node_empty,
      level=level,
      allow.empty=TRUE,
      rename=NULL,
      shine=shine,
      indent.by=indent.by,
      tidy=tidy,
      as_script=as_script,
      func_rename=func_rename
    )

    return(result)
  }
)

#' @rdname pasteXML-methods
#' @aliases
#'    pasteXML,XiMpLe_doc-method
setMethod("pasteXML",
  signature=signature(obj="XiMpLe_doc"),
  function(
    obj,
    shine=1,
    indent.by=getOption("XiMpLe_indent", "\t"),
    tidy=TRUE,
    tidy.omit=c("![CDATA[", "*![CDATA["),
    as_script=FALSE,
    func_rename=c(
      "?xml_"="xml_",
      "!--_"="comment_",
      "![CDATA[_"="CDATA_",
      "!DOCTYPE_"="DOCTYPE_"
    )
  ){
    filename <- slot(obj, "file")
    tree_xml <- slot(obj, "xml")
    tree_doctype <- slot(obj, "dtd")
    tree_nodes <- slot(obj, "children")

    doc_xml <- ""
    new_node <- ifelse(shine > 0, "\n", "")
    if(all(sapply(tree_xml, is.character, USE.NAMES=FALSE))){
      if(any(nchar(unlist(tree_xml)) > 0)) {
        doc_xml <- pasteXMLTag(
          "?xml",
          attr=tree_xml,
          empty=TRUE,
          level=1,
          allow.empty=FALSE,
          shine=min(1, shine),
          indent.by=indent.by,
          tidy=tidy,
          as_script=as_script,
          func_rename=func_rename
        )
      } else {}
    } else if(all(sapply(tree_xml, is.XiMpLe.node, USE.NAMES=FALSE))){
      doc_xml <- paste0(unlist(sapply(
        tree_xml,
        function(this.decl){
          pasteXML(
            this.decl,
            level=1,
            shine=shine,
            indent.by=indent.by,
            tidy=tidy,
            tidy.omit=tidy.omit,
            as_script=as_script,
            func_rename=func_rename
          )
        }
      )), collapse="")
    } else {}

    if(length(tree_doctype) > 0) {
      if(any(c("doctype", "decl", "id", "refer") %in% names(tree_doctype))){
        # convert old syntax
        doc_doctype_attrs <- list()
        if(isTRUE("doctype" %in% names(tree_doctype))){
          doc_doctype_attrs[[tree_doctype[["doctype"]]]] <- character()
        } else {}
        if(isTRUE("decl" %in% names(tree_doctype))){
          doc_doctype_attrs[[tree_doctype[["decl"]]]] <- character()
        } else {}
        if(isTRUE("id" %in% names(tree_doctype))){
          doc_doctype_attrs[[paste0("\"", tree_doctype[["id"]], "\"")]] <- character()
        } else {}
        if(isTRUE("refer" %in% names(tree_doctype))){
          doc_doctype_attrs[[paste0("\"", tree_doctype[["refer"]], "\"")]] <- character()
        } else {}
        tree_doctype <- doc_doctype_attrs
      } else {}
      doc_doctype <- pasteXML(
        XMLNode(
          "!DOCTYPE",
          attrs=tree_doctype
        ),
        level=1,
        shine=shine,
        indent.by=indent.by,
        tidy=tidy,
        tidy.omit=tidy.omit,
        as_script=as_script,
        func_rename=func_rename
      )
    } else {
      doc_doctype <- ""
    }

    if(length(tree_nodes) > 0) {
      doc_nodes <- paste0(unlist(sapply(
        tree_nodes,
        function(this_node){
          return(
            pasteXML(
              this_node,
              level=1,
              shine=shine,
              indent.by=indent.by,
              tidy=tidy,
              tidy.omit=tidy.omit,
              as_script=as_script,
              func_rename=func_rename
            )
          )
        },
        USE.NAMES=FALSE
      )), collapse="")
    } else {
      doc_nodes <- ""
    }

    doc.all <- paste0(doc_xml, doc_doctype, doc_nodes, collapse="")

    return(doc.all)
  }
)

# for compatibility reasons, deploy wrapper functions
#' @export
pasteXMLNode <- function(node, level=1, shine=1, indent.by=getOption("XiMpLe_indent", "\t"), tidy=TRUE){
  .Deprecated("pasteXML")
  pasteXML(node, level=level, shine=shine, indent.by=indent.by, tidy=tidy)
}

#' @export
pasteXMLTree <- function(obj, shine=1, indent.by=getOption("XiMpLe_indent", "\t"), tidy=TRUE){
  .Deprecated("pasteXML")
  pasteXML(obj, shine=shine, indent.by=indent.by, tidy=tidy)
}