R/pasteXMLTag.R

In XiMpLe: A Simple XML Tree Parser and Generator

# 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/>.


#' Write an XML tag
#'
#' Creates a whole XML tag with attributes and, if it is a pair of start and end tags,
#' also one object as child. This can be used recursively to create whole XML tree structures
#' with this one function.
#' 
#' @note However, you will probably not want to use this function at all, as it is much more
#'   comfortable to create XML nodes or even nested trees with \code{\link[XiMpLe:XMLNode]{XMLNode}} and
#'   \code{\link[XiMpLe:XMLTree]{XMLTree}}, and then feed the result to \code{\link[XiMpLe:pasteXML]{pasteXML}}.
#'
#' @param tag Character string, name of the XML tag.
#' @param attr A list of attributes for the tag.
#' @param child If \code{empty=FALSE}, a character string to be pasted as a child node between start and end tag.
#' @param empty Logical, <true /> or <false></false>
#' @param level Indentation level.
#' @param allow.empty Logical, if \code{FALSE}, tags without attributes will not be returned.
#' @param rename An optional named list if the attributes in XML need to be renamed from their list names in \code{attr}.
#'    This list must in turn have a list element named after \code{tag}, containing named character elements, where the
#'    names represent the element names in \code{attr} and their values the names the XML attribute should get.
#' @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;", "&gt;" and "&amp;" in attribute values. For comment or CDATA tags, if the text includes newline characters
#'    they will also be indented.
#' @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_name A character string, defining a function name for \code{tag}. Only used when \code{as_script=TRUE}.
#' @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}}.
#' @return A character string.
#' @seealso \code{\link[XiMpLe:XMLNode]{XMLNode}},
#'    \code{\link[XiMpLe:XMLTree]{XMLTree}},
#'    \code{\link[XiMpLe:pasteXML]{pasteXML}}
#' @export
#' @examples
#' sample.XML.tag <- pasteXMLTag("a",
#'   attr=list(href="http://example.com", target="_blank"),
#'   child="klick here!",
#'   empty=FALSE)

pasteXMLTag <- function(
  tag,
  attr=NULL,
  child=NULL,
  empty=TRUE,
  level=1,
  allow.empty=FALSE,
  rename=NULL,
  shine=2,
  indent.by=getOption("XiMpLe_indent", "\t"),
  tidy=TRUE,
  as_script=FALSE,
  func_name=paste0(tag, "_"),
  func_rename=c(
    "?xml_"="xml_",
    "!--_"="comment_",
    "![CDATA[_"="CDATA_",
    "!DOCTYPE_"="DOCTYPE_"
  )
){
  # what attributes do we have?
  all.attributes <- pasteXMLAttr(
    attr,
    tag=tag,
    level=level,
    rename=rename,
    shine=shine,
    indent.by=indent.by,
    tidy=tidy,
    as_script=as_script
  )
  # probaly don't produce empty tags
  if(!isTRUE(allow.empty) & is.null(all.attributes)){
    return("")
  } else {}

  new.cmmt   <- ifelse(shine > 0, "\n", " ")

  if(isTRUE(as_script)){
    if(func_name %in% names(func_rename)){
        func_name <- func_rename[func_name]
    } else {}
  } else {}

  # test variuos special cases: value pseudotags, XML declarations, comments and CDATA
  if(isTRUE(nchar(tag) == 0) | length(tag) == 0){
    if(isTRUE(tidy)){
      child <- trim(child)
      child <- gsub("\n", new.cmmt, trim(setMinIndent(child, level=2, indent.by=indent.by)))
    } else {}
    if(isTRUE(as_script)){
      full.tag <- paste0("\"", child, "\"")
    } else {
      full.tag <- child
    }
  } else if(grepl("^\\?", tag)){
    if(is.null(child)){
      if(isTRUE(as_script)){
        full.tag <- paste_shine(
          start=paste0(func_name, "("),
          end="",
          attrs=all.attributes,
          close=")",
          level=level,
          indent.by=indent.by,
          shine=shine,
          as_script=TRUE
        )
      } else {
        full.tag <- paste_shine(
          start=paste0("<", tag),
          end="?>",
          attrs=all.attributes,
          level=level,
          indent.by=indent.by,
          shine=shine,
          space_attrs=TRUE
        )
      }
    } else {
      stop(simpleError("child nodes for XML declaraions are not supported!"))
    }
  } else if(identical(tag, "!--")){
    # clean up value if needed
    if(!is.null(child)){
      if(isTRUE(tidy)){
        child <- trim(child)
        child <- gsub("\n", new.cmmt, trim(setMinIndent(child, level=max(1, level - 1), indent.by=indent.by)))
      }
    } else {}
    if(isTRUE(as_script)){
      full.tag <- paste_shine(
        start=paste0(func_name, "("),
        end="",
        child=trim(child),
        close=")",
        level=level,
        indent.by=indent.by,
        shine=shine,
        as_script=TRUE
      )
    } else {
      full.tag <- paste_shine(
        start="<!--",
        end="",
        child=trim(child),
        close="-->",
        level=level,
        indent.by=indent.by,
        shine=shine,
        space_child=TRUE
      )
    }
  } else if(identical(tag, "!DOCTYPE")){
    # clean up value if needed
    if(!is.null(child)){
      stop(simpleError("A DOCTYPE definition must not have child nodes!"))
    } else {}
    if(isTRUE(as_script)){
      full.tag <- paste_shine(
        start=paste0(func_name, "("),
        end="",
        attrs=all.attributes,
        close=")",
        level=level,
        indent.by=indent.by,
        shine=shine,
        as_script=TRUE
      )
    } else {
      full.tag <- paste_shine(
        start="<!DOCTYPE",
        end=">",
        attrs=all.attributes,
        level=level,
        indent.by=indent.by,
        shine=shine,
        space_attrs=TRUE
      )
    }
  } else if(identical(tag, "![CDATA[")){
    # clean up value if needed
    if(!is.null(child)){
      child <- trim(child)
      if(isTRUE(tidy)){
        child <- gsub("\n", new.cmmt, trim(setMinIndent(child, level=max(1, level - 1), indent.by=indent.by)))
      }
    } else {}
    if(isTRUE(as_script)){
        full.tag <- paste_shine(
          start=paste0(func_name, "("),
          end="",
          child=trim(child),
          close=")",
          level=level,
          indent.by=indent.by,
          shine=shine,
          as_script=TRUE
        )
    } else {
      full.tag <- paste_shine(
        start="<![CDATA[",
        end="",
        child=trim(child),
        close="]]>",
        level=level,
        indent.by=indent.by,
        shine=shine,
        space_child=TRUE
      )
    }
  } else if(identical(tag, "*![CDATA[")){
    # clean up value if needed
    if(!is.null(child)){
      child <- trim(child)
      if(isTRUE(tidy)){
        child <- gsub("\n", new.cmmt, trim(setMinIndent(child, level=max(1, level - 1), indent.by=indent.by)))
      }
    } else {}
    if(isTRUE(as_script)){
        full.tag <- paste_shine(
          start=paste0(func_name, "("),
          end="",
          child=trim(child),
          close=")",
          level=level,
          indent.by=indent.by,
          shine=shine,
          as_script=TRUE
        )
    } else {
      full.tag <- paste_shine(
        start="/* <![CDATA[ */",
        end="",
        child=trim(child),
        close="/* ]]> */",
        level=level,
        indent.by=indent.by,
        shine=shine,
        space_child=TRUE
      )
    }
  } else if(grepl("^!", tag)){
    if(!is.null(child)){
      child <- trim(child)
      if(isTRUE(tidy)){
        child <- gsub("\n", new.cmmt, trim(setMinIndent(child, level=max(1, level - 1), indent.by=indent.by)))
      }
    } else {}
    if(isTRUE(as_script)){
        full.tag <- paste_shine(
          start=paste0(func_name, "("),
          end="",
          attrs=all.attributes,
          child=trim(child),
          close=")",
          level=level,
          indent.by=indent.by,
          shine=shine,
          as_script=TRUE
        )
    } else {
      full.tag <- paste_shine(
        start=paste0("<", tag),
        end="",
        attrs=all.attributes,
        child=trim(child),
        close=">",
        level=level,
        indent.by=indent.by,
        shine=shine,
        space_child=TRUE
      )
    }
  } else {
    # last but not least, the default value
    # only put attributes in new lines if there's more than one

    # empty decides whether this is a empty tag or a pair of start and end tags
    if(isTRUE(empty)){
      if(isTRUE(as_script)){
        full.tag <- paste_shine(
          start=paste0(func_name, "("),
          end="",
          attrs=all.attributes,
          close=")",
          level=level,
          indent.by=indent.by,
          shine=shine,
          as_script=TRUE
        )
      } else {
        full.tag <- paste_shine(
          start=paste0("<", tag),
          end="/>",
          attrs=all.attributes,
          level=level,
          indent.by=indent.by,
          shine=shine,
          space_attrs=TRUE
        )
      }
    } else {
      if(isTRUE(as_script)){
        if(is.null(attr)){
          attr_section <- ""
        } else {
          attr_section <- ifelse(is.null(child) & !is.null(attr), all.attributes, paste0(all.attributes, ","))
        }
        full.tag <- paste_shine(
          start=paste0(func_name, "("),
          end="",
          attrs=all.attributes,
          child=trim(child),
          close=")",
          level=level,
          indent.by=indent.by,
          shine=shine,
          as_script=TRUE
        )
      } else {
        full.tag <- paste_shine(
          start=paste0("<", tag),
          end=">",
          attrs=all.attributes,
          child=trim(child),
          close=paste0("</", tag, ">"),
          level=level,
          indent.by=indent.by,
          shine=shine
        )
      }
    }
  }
  return(full.tag)
}