Commit d5a16f3b authored by m.eik michalke's avatar m.eik michalke
Browse files

added tests to validation functionality

  - also added support for validation of empty nodes
  - fixed some recursion issues
  - added some examples
  - updated docs
parent 5c03eb3a
......@@ -19,7 +19,7 @@ LazyLoad: yes
URL: http://reaktanz.de/?c=hacking&s=XiMpLe
Authors@R: c(person(given="Meik", family="Michalke", email="meik.michalke@hhu.de", role=c("aut", "cre")))
Version: 0.03-24
Date: 2015-12-07
Date: 2015-12-08
RoxygenNote: 5.0.1
Collate:
'00_class_01_XiMpLe.node.R'
......
......@@ -19,6 +19,8 @@
#' Class XiMpLe.validity
#'
#' Used for objects that describe valid child nodes and attributes of XiMpLe.nodes.
#'
#' You should use \code{\link[XiMpLe:XMLValidity]{XMLValidity}} to create objects of this class.
#'
#' @slot children Named list of character vectors, where the element name defines the parent node
#' name and each character string a valid child node name.
......@@ -26,10 +28,14 @@
#' name and each character string a valid attribute name.
#' @slot allChildren Character vector, names of globally valid child nodes for all nodes, if any.
#' @slot allAttrs Character vector, names of globally valid attributes for all nodes, if any.
#' @slot empty Character vector, names of nodes that must be empty nodes (i.e., no closing tag), if any.
#' @name XiMpLe.validity,-class
#' @aliases XiMpLe.validity-class XiMpLe.validity,-class
#' @import methods
#' @keywords classes
#' @seealso
#' \code{\link[XiMpLe:XMLValidity]{XMLValidity}},
#' \code{\link[XiMpLe:validXML]{validXML}}
#' @rdname XiMpLe.validity-class
#' @export
......@@ -38,13 +44,15 @@ setClass("XiMpLe.validity",
children="list",
attrs="list",
allChildren="character",
allAttrs="character"
allAttrs="character",
empty="character"
),
prototype(
children=list(),
attrs=list(),
allChildren=character(),
allAttrs=character()
allAttrs=character(),
empty=character()
)
)
......
......@@ -23,18 +23,23 @@
#'
#' XiMpLe can't handle DOM specifications yet, but this method can be used to construct
#' validation schemes.
#'
#' @note: If no \code{parent} is specified, \code{obj} will be checked recursively. If
#'
#' @param obj An object of class \code{XiMpLe.doc} or \code{XiMpLe.node}. If \code{parent=NULL}, this object
#' will be checked for validity, including its child nodes. If \code{parent} is either a character string
#' or another XiMpLe node, it will be checked whether \code{obj} is a valid child node of \code{parent}.
## TODO: validity class objects
#' @param validity A list with validity information.
#' @param validity An object of class \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}},
#' see \code{\link[XiMpLe:XMLValidity]{XMLValidity}}.
#' @param parent Either a character string (name of the parent node) or a XiMpLe node, whose name will be used
#' as name of the parent node.
#' @param children Logical, whether child node names should be checked for validity.
#' @param attributes Logical, whether attributes should be checked for validity.
#' @param warn Logical, whether invalid objects should cause a warning or stop with an error.
#' @param section Either a character string (name of the section) or a XiMpLe node, whose name will be used
#' as name of the XML section this check refers to. This is only relevant for warnings and error messages,
#' in case you want to use something different than the actual parent node name.
#' @param caseSens Logical, whether checks should be case sensitive or not.
#' @return Returns \code{TRUE} if tests pass, and depending on the setting of \code{warn} either \code{FALSE} or
#' an error if a test fails.
#' @aliases
......@@ -42,8 +47,10 @@
#' validXML,XiMpLe.doc-method
#' validXML,XiMpLe.node-method
#' validXML,XiMpLe.XML-method
#' @seealso
#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
#' @seealso
#' \code{\link[XiMpLe:validXML]{validXML}},
#' \code{\link[XiMpLe:XMLValidity]{XMLValidity}},
#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}, and
#' \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}
#' @keywords methods
#' @docType methods
......@@ -51,16 +58,71 @@
#' @rdname validXML
#' @include 00_class_01_XiMpLe.node.R
#' @include 00_class_02_XiMpLe.doc.R
setGeneric("validXML", function(obj, validity, parent=NULL, children=TRUE, attributes=TRUE, warn=FALSE, section=parent){standardGeneric("validXML")})
setGeneric("validXML", function(obj, validity=XMLValidity(), parent=NULL, children=TRUE, attributes=TRUE, warn=FALSE, section=parent, caseSens=TRUE){standardGeneric("validXML")})
#' @rdname validXML
#' @export
setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, parent=NULL, children=TRUE, attributes=TRUE, warn=FALSE, section=parent){
childValidity <- attributeValidity <- NULL
#' @examples
#' HTMLish <- XMLValidity(
#' children=list(
#' body=c("a", "p", "ol", "ul", "strong"),
#' head=c("title"),
#' html=c("head", "body"),
#' li=c("a", "br", "strong"),
#' ol=c("li"),
#' p=c("a", "br", "ol", "ul", "strong"),
#' ul=c("li")
#' ),
#' attrs=list(
#' a=c("href", "name"),
#' p=c("align")
#' ),
#' allChildren=c("!--"),
#' allAttrs=c("id", "class"),
#' empty=c("br")
#' )
#' # make XML object
#' validChildNodes <- XMLNode("html",
#' XMLNode("head",
#' XMLNode("!--", "comment always passes"),
#' XMLNode("title", "test")
#' ),
#' XMLNode("body",
#' XMLNode("p",
#' XMLNode("a", "my link"),
#' XMLNode("br"),
#' "text goes on"
#' )
#' )
#' )
#' invalidChildNodes <- XMLNode("html",
#' XMLNode("head",
#' XMLNode("title",
#' XMLNode("body", "test")
#' )
#' )
#' )
#'
#' # do validity checks
#' # the first should pass
#' validXML(
#' validChildNodes,
#' validity=HTMLish
#' )
#'
#' # now this one should cause a warning and return FALSE
#' validXML(
#' invalidChildNodes,
#' validity=HTMLish,
#' warn=TRUE
#' )
setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity=XMLValidity(), parent=NULL, children=TRUE, attributes=TRUE,
warn=FALSE, section=parent, caseSens=TRUE){
childValidity <- attributeValidity <- emptyValidity <- NULL
if(!is.XiMpLe.validity(validity)){
stop(simpleError(paste0(
"Invalid value for \"validity\": Got class ",
class(valid),
class(validity),
", should be XiMpLe.validity!"))
)
}
......@@ -69,6 +131,7 @@ setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, paren
# we're checking "obj" as the parent node itself
# - check attributes of "obj" directly
# - check child nodes of "obj" for valid node names
# - check if "obj" should be empty but is not
# - recursion: check attributes of child nodes etc.
# b) "parent" is given
# we're checking "obj" as child node for a given parent
......@@ -78,6 +141,23 @@ setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, paren
recursion <- FALSE
if(is.null(parent)){
parentName <- XMLName(obj)
nodeChildren <- XMLChildren(obj)
# check for violations of mandatory empty nodes
emptyNodes <- slot(validity, "empty")
if(!isTRUE(caseSens)){
emptyNodes <- tolower(emptyNodes)
} else {}
if(parentName %in% emptyNodes){
if(length(nodeChildren) > 0 | !identical(XMLValue(obj), character())){
return.message <- paste0("Invalid XML node <", parentName, " />: Should be empty, but it isn't!")
if(isTRUE(warn)){
warning(return.message, call.=FALSE)
emptyValidity <- FALSE
} else {
stop(simpleError(return.message))
}
} else {}
} else {}
recursion <- TRUE
} else if(is.XiMpLe.node(parent)){
parentName <- XMLName(parent)
......@@ -106,15 +186,29 @@ setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, paren
if(isTRUE(children)){
if(isTRUE(recursion)){
# are there any children to check in the first place?
nodeChildren <- XMLChildren(obj)
if(length(nodeChildren) > 0){
childValidity <- all(sapply(
nodeChildren,
function(thisChild){
# check child itself
thisChildValidity <- valid.child(parent=parentName, children=thisChild, validity=validity, warn=warn, section=section)
thisChildValidity <- valid.child(
parent=parentName,
children=thisChild,
validity=validity,
warn=warn,
section=section,
caseSens=caseSens
)
# check grandchildren
grandChildValidity <- validXML(thisChild, validity=validity, children=children, attributes=attributes, warn=warn, section=thisChild)
grandChildValidity <- validXML(
thisChild,
validity=validity,
children=children,
attributes=attributes,
warn=warn,
section=thisChild,
caseSens=caseSens
)
return(all(thisChildValidity, grandChildValidity))
}
))
......@@ -122,13 +216,54 @@ setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, paren
childValidity <- NULL
}
} else {
childValidity <- valid.child(parent=parentName, children=obj, validity=validity, warn=warn, section=section)
childValidity <- valid.child(
parent=parentName,
children=obj,
validity=validity,
warn=warn,
section=section,
caseSens=caseSens
)
}
} else {}
if(isTRUE(attributes)){
# we only check attributes of "obj"
attributeValidity <- valid.attribute(node=XMLName(obj), attrs=XMLAttrs(obj), validity=validity, warn=warn)
attributeValidityObj <- valid.attribute(
node=XMLName(obj),
attrs=XMLAttrs(obj),
validity=validity,
warn=warn,
caseSens=caseSens
)
if(isTRUE(recursion) & !isTRUE(children)){
# we can skip this if children was TRUE, because attributes were
# already checked recursively, then. but if not:
# are there any children to check in the first place?
if(length(nodeChildren) > 0){
attributeValidityRecursive <- all(sapply(
nodeChildren,
function(thisChild){
# because of the recursion this checks the attributes of "thisChild"
thisChildValidity <- validXML(
thisChild,
validity=validity,
children=FALSE,
attributes=TRUE,
warn=warn,
section=thisChild,
caseSens=caseSens
)
return(thisChildValidity)
}
))
} else {
attributeValidityRecursive <- NULL
}
} else {
attributeValidityRecursive <- NULL
}
attributeValidity <- all(attributeValidityObj, attributeValidityRecursive)
} else {}
return(all(childValidity, attributeValidity))
return(all(childValidity, attributeValidity, emptyValidity))
})
......@@ -27,13 +27,32 @@
#' name and each character string a valid attribute name.
#' @param allChildren Character vector, names of globally valid child nodes for all nodes, if any.
#' @param allAttrs Character vector, names of globally valid attributes for all nodes, if any.
#' @param empty Character vector, names of nodes that must be empty nodes (i.e., no closing tag), if any.
#' @return An object of class \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}}
#' @seealso
#' \code{\link[XiMpLe:validXML]{validXML}}
#' @export
#' @rdname XiMpLe.validity-class
XMLValidity <- function(children=NULL, attrs=NULL, allChildren=NULL, allAttrs=NULL){
#' @rdname XMLValidity
#' @examples
#' HTMLish <- XMLValidity(
#' children=list(
#' body=c("a", "p", "ol", "ul", "strong"),
#' head=c("title"),
#' html=c("head", "body"),
#' li=c("a", "br", "strong"),
#' ol=c("li"),
#' p=c("a", "br", "ol", "ul", "strong"),
#' ul=c("li")
#' ),
#' attrs=list(
#' a=c("href", "name"),
#' p=c("align")
#' ),
#' allChildren=c("!--"),
#' allAttrs=c("id", "class"),
#' empty=c("br")
#' )
XMLValidity <- function(children=NULL, attrs=NULL, allChildren=NULL, allAttrs=NULL, empty=NULL){
if(is.null(children)){
children <- list()
......@@ -47,12 +66,16 @@ XMLValidity <- function(children=NULL, attrs=NULL, allChildren=NULL, allAttrs=NU
if(is.null(allAttrs)){
allAttrs <- character()
} else {}
if(is.null(empty)){
empty <- character()
} else {}
newValidity <- new("XiMpLe.validity",
children=children,
attrs=attrs,
allChildren=allChildren,
allAttrs=allAttrs
allAttrs=allAttrs,
empty=empty
)
return(newValidity)
......
......@@ -566,7 +566,13 @@ XML.nodes <- function(single.tags, end.here=NA, start=1){
# - section: an optional name for the section for the warning/error
# (if it shouldn't be the parent name)
# - node names: can alternatively be given instead of 'children', as character vector
valid.child <- function(parent, children, validity, warn=FALSE, section=parent, node.names=NULL){
# - graceful: allow everything inside "!--" comments?
valid.child <- function(parent, children, validity, warn=FALSE, section=parent, node.names=NULL,
caseSens=TRUE, graceful=TRUE){
if(isTRUE(graceful) && identical(parent, "!--")){
# skip all checks and return TRUE
return(TRUE)
} else {}
if(is.null(node.names)){
# check the node names and allow only valid ones
node.names <- unlist(sapply(child.list(children), function(this.child){
......@@ -585,8 +591,16 @@ valid.child <- function(parent, children, validity, warn=FALSE, section=parent,
}
}))
} else {}
validAllChildren <- slot(validity, "allChildren")
validChildren <- slot(validity, "children")[[parent]]
if(!isTRUE(caseSens)){
node.names <- tolower(node.names)
validAllChildren <- tolower(validAllChildren)
validChildren <- tolower(validChildren)
} else {}
invalid.sets <- !node.names %in% c(slot(validity, "allChildren"), slot(validity, "children")[[parent]])
invalid.sets <- !node.names %in% c(validAllChildren, validChildren)
if(any(invalid.sets)){
return.message <- paste0("Invalid XML nodes for <", section, "> section: ", paste(node.names[invalid.sets], collapse=", "))
if(isTRUE(warn)){
......@@ -607,10 +621,17 @@ valid.child <- function(parent, children, validity, warn=FALSE, section=parent,
# - node: a character string, node name
# - attrs: a named list of attributes to check
# - validity: definitions of valid child nodes, class XiMpLe.validity
valid.attribute <- function(node, attrs, validity, warn=FALSE){
valid.attribute <- function(node, attrs, validity, warn=FALSE, caseSens=TRUE){
if(length(attrs) > 0){
attrsNames <- names(attrs)
invalid.sets <- !attrsNames %in% c(slot(validity, "allAttrs"), slot(validity, "attrs")[[node]])
validAllAttrs <- slot(validity, "allAttrs")
validAttrs <- slot(validity, "attrs")[[node]]
if(!isTRUE(caseSens)){
attrsNames <- tolower(attrsNames)
validAllAttrs <- tolower(validAllAttrs)
validAttrs <- tolower(validAttrs)
} else {}
invalid.sets <- !attrsNames %in% c(validAllAttrs, validAttrs)
if(any(invalid.sets)){
return.message <- paste0("Invalid XML attributes for <", node, "> node: ", paste(attrsNames[invalid.sets], collapse=", "))
if(isTRUE(warn)){
......
......@@ -4,7 +4,7 @@
#' Package: \tab XiMpLe\cr
#' Type: \tab Package\cr
#' Version: \tab 0.03-24\cr
#' Date: \tab 2015-12-07\cr
#' Date: \tab 2015-12-08\cr
#' Depends: \tab R (>= 2.9.0),methods\cr
#' Encoding: \tab UTF-8\cr
#' License: \tab GPL (>= 3)\cr
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/XMLValidity.R
\name{XMLValidity}
\alias{XMLValidity}
\title{Constructor function for XiMpLe.validity objects}
\usage{
XMLValidity(children = NULL, attrs = NULL, allChildren = NULL,
allAttrs = NULL, empty = NULL)
}
\arguments{
\item{children}{Named list of character vectors, where the element name defines the parent node
name and each character string a valid child node name.}
\item{attrs}{Named list of character vectors, where the element name defines the parent node
name and each character string a valid attribute name.}
\item{allChildren}{Character vector, names of globally valid child nodes for all nodes, if any.}
\item{allAttrs}{Character vector, names of globally valid attributes for all nodes, if any.}
\item{empty}{Character vector, names of nodes that must be empty nodes (i.e., no closing tag), if any.}
}
\value{
An object of class \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}}
}
\description{
Create validity definitions for XiMpLe nodes, to be used by
\code{\link[XiMpLe:validXML]{validXML}}.
}
\examples{
HTMLish <- XMLValidity(
children=list(
body=c("a", "p", "ol", "ul", "strong"),
head=c("title"),
html=c("head", "body"),
li=c("a", "br", "strong"),
ol=c("li"),
p=c("a", "br", "ol", "ul", "strong"),
ul=c("li")
),
attrs=list(
a=c("href", "name"),
p=c("align")
),
allChildren=c("!--"),
allAttrs=c("id", "class"),
empty=c("br")
)
}
\seealso{
\code{\link[XiMpLe:validXML]{validXML}}
}
......@@ -12,7 +12,7 @@ A Simple XML Tree Parser and Generator.
Package: \tab XiMpLe\cr
Type: \tab Package\cr
Version: \tab 0.03-24\cr
Date: \tab 2015-12-07\cr
Date: \tab 2015-12-08\cr
Depends: \tab R (>= 2.9.0),methods\cr
Encoding: \tab UTF-8\cr
License: \tab GPL (>= 3)\cr
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/00_class_03_XiMpLe.validity.R, R/XMLValidity.R, R/zzz_is_get_utils.R
% Please edit documentation in R/00_class_03_XiMpLe.validity.R, R/zzz_is_get_utils.R
\docType{class}
\name{XiMpLe.validity,-class}
\alias{XMLValidity}
\alias{XiMpLe.validity,-class}
\alias{XiMpLe.validity-class}
\alias{is.XiMpLe.validity}
\title{Class XiMpLe.validity}
\usage{
XMLValidity(children = NULL, attrs = NULL, allChildren = NULL,
allAttrs = NULL)
is.XiMpLe.validity(x)
}
\arguments{
\item{children}{Named list of character vectors, where the element name defines the parent node
name and each character string a valid child node name.}
\item{attrs}{Named list of character vectors, where the element name defines the parent node
name and each character string a valid attribute name.}
\item{allChildren}{Character vector, names of globally valid child nodes for all nodes, if any.}
\item{allAttrs}{Character vector, names of globally valid attributes for all nodes, if any.}
\item{x}{An arbitrary \code{R} object.}
}
\value{
An object of class \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}}
}
\description{
Used for objects that describe valid child nodes and attributes of XiMpLe.nodes.
Create validity definitions for XiMpLe nodes, to be used by
\code{\link[XiMpLe:validXML]{validXML}}.
}
\details{
You should use \code{\link[XiMpLe:XMLValidity]{XMLValidity}} to create objects of this class.
}
\section{Slots}{
......@@ -47,9 +30,12 @@ name and each character string a valid attribute name.}
\item{\code{allChildren}}{Character vector, names of globally valid child nodes for all nodes, if any.}
\item{\code{allAttrs}}{Character vector, names of globally valid attributes for all nodes, if any.}
\item{\code{empty}}{Character vector, names of nodes that must be empty nodes (i.e., no closing tag), if any.}
}}
\seealso{
\code{\link[XiMpLe:validXML]{validXML}}
\code{\link[XiMpLe:XMLValidity]{XMLValidity}},
\code{\link[XiMpLe:validXML]{validXML}}
}
\keyword{classes}
......@@ -9,27 +9,35 @@
\alias{validXML,XiMpLe.node-method}
\title{Validate S4 objects of XiMpLe XML classes}
\usage{
validXML(obj, validity, parent = NULL, children = TRUE, attributes = TRUE,
warn = FALSE, section = parent)
validXML(obj, validity = XMLValidity(), parent = NULL, children = TRUE,
attributes = TRUE, warn = FALSE, section = parent, caseSens = TRUE)
\S4method{validXML}{XiMpLe.XML}(obj, validity, parent = NULL,
children = TRUE, attributes = TRUE, warn = FALSE, section = parent)
\S4method{validXML}{XiMpLe.XML}(obj, validity = XMLValidity(),
parent = NULL, children = TRUE, attributes = TRUE, warn = FALSE,
section = parent, caseSens = TRUE)
}
\arguments{
\item{obj}{An object of class \code{XiMpLe.doc} or \code{XiMpLe.node}. If \code{parent=NULL}, this object
will be checked for validity, including its child nodes. If \code{parent} is either a character string
or another XiMpLe node, it will be checked whether \code{obj} is a valid child node of \code{parent}.}
\item{validity}{A list with validity information.}
\item{validity}{An object of class \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}},
see \code{\link[XiMpLe:XMLValidity]{XMLValidity}}.}
\item{parent}{Either a character string (name of the parent node) or a XiMpLe node, whose name will be used
as name of the parent node.}
\item{children}{Logical, whether child node names should be checked for validity.}
\item{attributes}{Logical, whether attributes should be checked for validity.}
\item{warn}{Logical, whether invalid objects should cause a warning or stop with an error.}
\item{section}{Either a character string (name of the section) or a XiMpLe node, whose name will be used
as name of the XML section this check refers to. This is only relevant for warnings and error messages,
in case you want to use something different than the actual parent node name.}
\item{caseSens}{Logical, whether checks should be case sensitive or not.}
}
\value{
Returns \code{TRUE} if tests pass, and depending on the setting of \code{warn} either \code{FALSE} or
......@@ -43,8 +51,68 @@ or \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}} have valid child nodes.
XiMpLe can't handle DOM specifications yet, but this method can be used to construct
validation schemes.
}
\note{
: If no \code{parent} is specified, \code{obj} will be checked recursively. If
}
\examples{
HTMLish <- XMLValidity(
children=list(
body=c("a", "p", "ol", "ul", "strong"),
head=c("title"),
html=c("head", "body"),
li=c("a", "br", "strong"),
ol=c("li"),
p=c("a", "br", "ol", "ul", "strong"),
ul=c("li")
),
attrs=list(
a=c("href", "name"),
p=c("align")
),
allChildren=c("!--"),
allAttrs=c("id", "class"),
empty=c("br")
)
# make XML object
validChildNodes <- XMLNode("html",
XMLNode("head",
XMLNode("!--", "comment always passes"),
XMLNode("title", "test")
),
XMLNode("body",
XMLNode("p",
XMLNode("a", "my link"),
XMLNode("br"),
"text goes on"
)
)
)
invalidChildNodes <- XMLNode("html",
XMLNode("head",
XMLNode("title",
XMLNode("body", "test")
)
)
)
# do validity checks
# the first should pass