[rkward/releases/0.6.4] packages/XiMpLe/R: made validation work

[m.eik michalke]

Git commit 5c03eb3a73adffb9dca866da2ff52d87ff98d4eb by m.eik michalke.
Committed on 08/12/2015 at 15:13.
Pushed by meikm into branch 'releases/0.6.4'.

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

M  +39   -20   packages/XiMpLe/R/01_method_04_validXML.R
M  +29   -2    packages/XiMpLe/R/XiMpLe-internal.R

http://commits.kde.org/rkward/5c03eb3a73adffb9dca866da2ff52d87ff98d4eb

diff --git a/packages/XiMpLe/R/01_method_04_validXML.R b/packages/XiMpLe/R/01_method_04_validXML.R
index db98be8..fd67a79 100644
--- a/packages/XiMpLe/R/01_method_04_validXML.R
+++ b/packages/XiMpLe/R/01_method_04_validXML.R
@@ -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))
 })
diff --git a/packages/XiMpLe/R/XiMpLe-internal.R b/packages/XiMpLe/R/XiMpLe-internal.R
index 6fd79e0..77ba1dd 100644
--- a/packages/XiMpLe/R/XiMpLe-internal.R
+++ b/packages/XiMpLe/R/XiMpLe-internal.R
@@ -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)
+  }
+}