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

made validation work

  - seems to work now
  - attributes are now checked as well
  - a battery of unit tests will follow, and probably show remaining bugs
parent 7e671055
......@@ -56,7 +56,7 @@ setGeneric("validXML", function(obj, validity, parent=NULL, children=TRUE, attri
#' @rdname validXML
#' @export
setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, parent=NULL, children=TRUE, attributes=TRUE, warn=FALSE, section=parent){
childValidity <- NULL
childValidity <- attributeValidity <- NULL
if(!is.XiMpLe.validity(validity)){
stop(simpleError(paste0(
"Invalid value for \"validity\": Got class ",
......@@ -64,22 +64,21 @@ setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, paren
", should be XiMpLe.validity!"))
)
}
# see if we're checking the parent node or child node for a given parent
# two possibilities:
# a) there's no "parent" value
# we're checking "obj" as the parent node itself
# - check attributes of "obj" directly
# - check child nodes of "obj" for valid node names
# - recursion: check attributes of child nodes etc.
# b) "parent" is given
# we're checking "obj" as child node for a given parent
# - check if "obj" node name is valid for parent node
# - check attributes of "obj"
# - no recursion
recursion <- FALSE
if(is.null(parent)){
parentName <- XMLName(obj)
# are there any children to check in the first place?
nodeChildren <- XMLChildren(obj)
if(length(nodeChildren) == 0){
children <- FALSE
} else {
childValidity <- all(sapply(
nodeChildren,
function(thisChild){
validXML(thisChild, validity=validity, parent=parentName, children=children, attributes=attributes, warn=warn, section=parentName)
}
))
children <- FALSE
}
recursion <- TRUE
} else if(is.XiMpLe.node(parent)){
parentName <- XMLName(parent)
} else if(is.character(parent) & length(parent) == 1){
......@@ -103,13 +102,33 @@ setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, paren
"\", should be XiMpLe.node or single character string!"))
)
} else {}
## more checks
if(isTRUE(children)){
childValidity <- valid.child(parent=parentName, children=obj, validity=validity, warn=warn, section=section)
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)
# check grandchildren
grandChildValidity <- validXML(thisChild, validity=validity, children=children, attributes=attributes, warn=warn, section=thisChild)
return(all(thisChildValidity, grandChildValidity))
}
))
} else {
childValidity <- NULL
}
} else {
childValidity <- valid.child(parent=parentName, children=obj, validity=validity, warn=warn, section=section)
}
} else {}
if(isTRUE(attributes)){
# we only check attributes of "obj"
attributeValidity <- valid.attribute(node=XMLName(obj), attrs=XMLAttrs(obj), validity=validity, warn=warn)
} else {}
return(childValidity)
return(all(childValidity, attributeValidity))
})
......@@ -581,14 +581,14 @@ valid.child <- function(parent, children, validity, warn=FALSE, section=parent,
return(this.child.name)
}
} else {
stop(simpleError(paste0("Invalid object for ", section, " section, must be of class XiMpLe.node, but got class ", class(this.child), "!")))
stop(simpleError(paste0("Invalid object for <", section, "> node, must be of class XiMpLe.node, but got class ", class(this.child), "!")))
}
}))
} else {}
invalid.sets <- !node.names %in% c(slot(validity, "allChildren"), slot(validity, "children")[[parent]])
if(any(invalid.sets)){
return.message <- paste0("Invalid XML nodes for ", section, " section: ", paste(node.names[invalid.sets], collapse=", "))
return.message <- paste0("Invalid XML nodes for <", section, "> section: ", paste(node.names[invalid.sets], collapse=", "))
if(isTRUE(warn)){
warning(return.message, call.=FALSE)
return(FALSE)
......@@ -599,3 +599,30 @@ valid.child <- function(parent, children, validity, warn=FALSE, section=parent,
return(TRUE)
}
} ## end function valid.child()
## function valid.attribute()
# similar to valid.child(), but checks the validity of attributes of a given node
# it's a bit simpler
# - 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){
if(length(attrs) > 0){
attrsNames <- names(attrs)
invalid.sets <- !attrsNames %in% c(slot(validity, "allAttrs"), slot(validity, "attrs")[[node]])
if(any(invalid.sets)){
return.message <- paste0("Invalid XML attributes for <", node, "> node: ", paste(attrsNames[invalid.sets], collapse=", "))
if(isTRUE(warn)){
warning(return.message, call.=FALSE)
return(FALSE)
} else {
stop(simpleError(return.message))
}
} else {
return(TRUE)
}
} else {
return(NULL)
}
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment