R/AtomAbstractObject.R

In atom4R: Tools to Handle and Publish Metadata as 'Atom' XML Format

#' AtomAbstractObject
#'
#' @docType class
#' @importFrom R6 R6Class
#' @export
#'
#' @name AtomAbstractObject
#' @title Atom feed class
#' @description This class models an atom abstract object
#' @keywords atom
#' @return Object of \code{\link{R6Class}} for modelling an Atom abstract Object
#' @format \code{\link{R6Class}} object.
#'
#' @note abstract class used internally by \pkg{atom4R}
#'
#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
#'
AtomAbstractObject <- R6Class("AtomAbstractObject",
  inherit = atom4RLogger,
  private = list(
    xmlElement = "_abstract_",
    allowedTypes = c("text", "html", "xhtml"),
    xmlNamespacePrefix = "ATOM",
    encoding = options("encoding"),
    document = FALSE,
    system_fields = c(
      "verbose.info", "verbose.debug", "loggerType",
      "wrap", "element", "namespace", "defaults",
      "attrs", "printAttrs", "parentAttrs"
    ),
    xmlComments = function(compliant = NA){
      comments <- list()
      atom4R <- packageDescription("atom4R")
      title <- paste0("Atom XML generated by atom4R R package - Version ", atom4R$Version)

      isCompliant <- ifelse(is.na(compliant),"NOT TESTED", ifelse(compliant, "YES", "NO"))
      compliance <- paste0("Atom XML compliance: ", isCompliant)

      createdOn <- paste0("Creation date/time: ", format(Sys.time(), "%Y-%m-%dT%H:%M:%S"))
      author <- gsub(">","",gsub("<","",unlist(strsplit(as.character(eval(parse(text=atom4R$Authors)))," \\["))[1]))
      author <- paste0("\tContact: ", author)
      infoPage <- paste0("\tURL: ", atom4R$URL)
      bugReport <- paste0("\tBugReports: ", atom4R$BugReports)
      idx <- 1
      comments[[idx]] <- createdOn; idx <- idx+1
      comments[[idx]] <- title; idx <- idx+1
      comments[[idx]] <- compliance; idx <- idx+1
      comments[[idx]] <- paste("atom4R R package information:", author, infoPage, bugReport, sep="\n")
      return(comments)
    },
    toComplexTypes = function(value){
      newvalue <- value
      #datetime types
      if(regexpr(pattern = "^(\\d{4})-(\\d{2})-(\\d{2})T(\\d{2}):(\\d{2}):(\\d{2})", value)>0){
        if(endsWith(value, "Z")){
          newvalue <- as.POSIXct(strptime(value, "%Y-%m-%dT%H:%M:%S"), tz = "UTC")
        }else{
          if(nchar(value)==25){
            utc_offset <- substr(value, 20, 25)
            value <- unlist(strsplit(value, utc_offset))[1]
            utc_offset <- gsub(":", "", utc_offset)
            value <- paste0(value, utc_offset)
            #TODO find a way to fetch "tzone" attribute -not solved for now
            newvalue <- as.POSIXct(strptime(value, "%Y-%m-%dT%H:%M:%S"), tz = "")
          }
        }

      }else if(regexpr(pattern = "^(\\d{4})-(\\d{2})-(\\d{2})$", value)>0){
        newvalue <- as.Date(as.POSIXct(strptime(value, "%Y-%m-%d"), tz = "UTC"))
      }

      return(newvalue)
    },
    fromComplexTypes = function(value){
      #datetime types
      if(suppressWarnings(all(class(value)==c("POSIXct","POSIXt")))){
        tz <- attr(value, "tzone")
        if(length(tz)>0){
          if(tz %in% c("UTC","GMT")){
            value <- format(value,"%Y-%m-%dT%H:%M:%S")
            value <- paste0(value,"Z")
          }else{
            utc_offset <- format(value, "%z")
            utc_offset <- paste0(substr(utc_offset,1,3),":",substr(utc_offset,4,5))
            value <- paste0(format(value,"%Y-%m-%dT%H:%M:%S"), utc_offset)
          }
        }else{
          value <- format(value,"%Y-%m-%dT%H:%M:%S")
        }
      }else if(class(value)[1] == "Date"){
        value <- format(value,"%Y-%m-%d")
      }

      return(value)
    },
    xmlNodeToCharacter = function (x, ..., indent = "", tagSeparator = "\n")
    {
      out <- ""
      if (length(xmlAttrs(x))) {
        tmp <- paste(names(xmlAttrs(x)), paste("\"", XML:::insertEntities(xmlAttrs(x)),
                                               "\"", sep = ""), sep = "=", collapse = " ")
      } else{
        tmp <- ""
      }
      if (length(x$namespaceDefinitions) > 0) {
        k = as(x$namespaceDefinitions, "character")
        ns = paste("xmlns", ifelse(nchar(names(k)), ":", ""),
                   names(k), "=", ddQuote(k), sep = "", collapse = " ")
      } else{
        ns <- ""
      }
      subIndent <- paste(indent, " ", sep = "")
      if (is.logical(indent) && !indent) {
        indent <- ""
        subIndent <- FALSE
      }
      if (length(xmlChildren(x)) == 0) {
        out <- paste(out,indent, paste("<", xmlName(x, TRUE), ifelse(tmp !=
                                                                       "", " ", ""), tmp, ifelse(ns != "", " ", ""), ns,
                                       "/>", tagSeparator, sep = ""), sep = "")
      } else if (length(xmlChildren(x)) == 1 && inherits(xmlChildren(x)[[1]], "XMLTextNode")) {
        out <- paste(out,indent, paste("<", xmlName(x, TRUE), ifelse(tmp !=
                                                                       "", " ", ""), tmp, ifelse(ns != "", " ", ""), ns,
                                       ">", sep = ""), sep = "")
        kid = xmlChildren(x)[[1]]
        if (inherits(kid, "EntitiesEscaped"))
          txt = xmlValue(kid)
        else txt = XML:::insertEntities(xmlValue(kid))
        out <- paste(out,txt, sep = "")
        out <- paste(out,paste("</", xmlName(x, TRUE), ">", tagSeparator,
                               sep = ""), sep = "")
      } else {
        out <- paste(out,indent, paste("<", xmlName(x, TRUE), ifelse(tmp !=
                                                                       "", " ", ""), tmp, ifelse(ns != "", " ", ""), ns,
                                       ">", tagSeparator, sep = ""), sep = "")
        for (i in xmlChildren(x)){
          out_child <- NULL
          if(is(i,"XMLNode")){
            if(is(i,"XMLCommentNode")){
              out_child <- paste0(capture.output(i),collapse="")
            }else{
              out_child <- private$xmlNodeToCharacter(i)
            }
          }else{
            out_child <- paste(as(i,"character"),tagSeparator,sep="")
          }
          if(!is.null(out_child)) out <- paste(out, out_child, sep="")
        }
        out<-paste(out,indent, paste("</", xmlName(x, TRUE), ">", tagSeparator,
                                     sep = ""), sep = "")
      }
      return(out)
    }
  ),
  public = list(
    #'@field wrap wrapping XML element
    wrap = TRUE,
    #'@field element element
    element = NA,
    #'@field namespace namespace
    namespace = NA,
    #'@field defaults defaults
    defaults = list(),
    #'@field attrs attrs
    attrs = list(),
    #'@field printAttrs attrs to print
    printAttrs = list(),
    #'@field parentAttrs parent attrs
    parentAttrs = NULL,

    #'@description Initializes an object of class \link{AtomAbstractObject}
    #'@param xml object of class \link{XMLInternalNode-class}
    #'@param element element
    #'@param namespace namespace
    #'@param attrs attrs
    #'@param defaults defaults
    #'@param wrap wrap
    #'@param logger logger type
    initialize = function(xml = NULL, element = NULL, namespace = NULL,
                          attrs = list(), defaults = list(),
                          wrap = TRUE, logger = "INFO"){
      super$initialize(logger = logger)
      if(!is.null(element)){ private$xmlElement <- element }
      if(!is.null(namespace)){ private$xmlNamespacePrefix <- toupper(namespace)}
      self$element = private$xmlElement
      self$namespace = getAtomNamespace(private$xmlNamespacePrefix)
      self$attrs = attrs
      self$defaults = defaults
      self$wrap = wrap
      if(!is.null(xml)){
        self$decode(xml)
      }
    },

    #'@description Set if object is a document or not
    #'@param isDocument object of class \code{logical}
    setIsDocument = function(isDocument){
      private$document <- isDocument
    },

    #'@description Informs if the object is a document
    #'@return object of class \code{logical}
    isDocument = function(){
      return(private$document)
    },

    #'@description Get root XML element
    #'@return object of class \code{character}
    getRootElement = function(){
      return(private$xmlElement)
    },

    #'@description Get XML namespace
    #'@return object of class \code{character}
    getNamespace = function(){
      return(private$namespace)
    },

    #'@description Creates an element
    #'@param element element
    #'@param type type. Default is "text"
    #'@return the typed element
    createElement = function(element, type = "text"){
      if(!type %in% private$allowedTypes){
        stop(sprintf("Type should be among allowed types [%s]",
                     paste0(private$allowedTypes, collapse=",")))
      }
      obj <- element
      attr(obj, "type") <- type
      return(obj)
    },

    #'@description Add a metadata element to an element list
    #'@param field field
    #'@param metadataElement metadata element to add
    #'@return \code{TRUE} if added, \code{FALSE} otherwise
    addListElement = function(field, metadataElement){
      startNb <- length(self[[field]])
      if(!self$contains(field, metadataElement)){
        self[[field]] = c(self[[field]], metadataElement)
      }
      endNb = length(self[[field]])
      return(endNb == startNb+1)
    },

    #'@description Deletes a metadata element from an element list
    #'@param field field
    #'@param metadataElement metadata element to add
    #'@return \code{TRUE} if deleted, \code{FALSE} otherwise
    delListElement = function(field, metadataElement){
      startNb <- length(self[[field]])
      if(self$contains(field, metadataElement)){
        self[[field]] = self[[field]][!sapply(self[[field]], AtomAbstractObject$compare, metadataElement)]
      }
      endNb = length(self[[field]])
      return(endNb == startNb-1)
    },

    #'@description Indicates if an element list contains or not an element
    #'@param field field
    #'@param metadataElement metadata element to add
    #'@return \code{TRUE} if contained, \code{FALSE} otherwise
    contains = function(field, metadataElement){
      out = FALSE
      if(length(self[[field]]) == 0){
        out = FALSE
      }else{
        out = any(sapply(self[[field]], function(x){
          AtomAbstractObject$compare(x, metadataElement)
        }))
      }
      return(out)
    },

    #'@description Prints the element
    #'@param ... any parameter to pass to print method
    #'@param depth printing depth
    print = function(..., depth = 1){
      #list of fields to encode as XML
      fields <- rev(names(self))

      #fields
      fields <- fields[!sapply(fields, function(x){
        (class(self[[x]])[1] %in% c("environment", "function")) ||
          (x %in% private$system_fields)
      })]

      cat(sprintf("<%s>", self$getClassName()))

      for(field in fields){
        fieldObj <- self[[field]]

        #default values management
        if(is.null(fieldObj) || (is.list(fieldObj) & length(fieldObj)==0)){
          if(field %in% names(self$defaults)){
            fieldObj <- self$defaults[[field]]
          }
        }

        #user values management
        shift <- "...."
        if(!is.null(fieldObj)){
          if(is(fieldObj, "AtomAbstractObject")){
            cat(paste0("\n", paste(rep(shift, depth), collapse=""),"|-- ", field, " "))
            fieldObj$print(depth = depth+1)
          }else if(is(fieldObj, "list")){
            for(item in fieldObj){
              if(is(item, "AtomAbstractObject")){
                cat(paste0("\n", paste(rep(shift, depth), collapse=""),"|-- ", field, " "))
                item$print(depth = depth+1)
              }else{
                cat(paste0("\n", paste(rep(shift, depth), collapse=""),"|-- ", field, ": ", item))
              }
            }
          }else{
            cat(paste0("\n",paste(rep(shift, depth), collapse=""),"|-- ", field, ": ", fieldObj))
          }
        }
      }
      invisible(self)
    },

    #'@description Decodes the object from an \pkg{XML} representation
    #'@param xml object of class \link{XMLInternalNode-class} from \pkg{XML}
    decode = function(xml){
      #remove comments if any (in case of document)
      if(is(xml, "XMLInternalDocument")){
        children <- xmlChildren(xml, encoding = private$encoding, addFinalizer = FALSE)
        xml <- children[names(children) != "comment"][[1]]
      }
      xml_children <- xmlChildren(xml, encoding = private$encoding, addFinalizer = FALSE)
      xml_children <- xml_children[names(xml_children) != "comment"]
      for(child in xml_children){
        fieldName <- xmlName(child)
        childElement <- child
        nsPrefix <- ""
        fNames <- unlist(strsplit(fieldName, ":"))
        if(length(fNames)>1){
          fieldName <- fNames[2]
        }

        wrap_fields <- FALSE
        fieldClass <- NULL
        parentAttrs <- NULL
        if(!is(child, "XMLInternalTextNode")){
          fieldClass <- AtomAbstractObject$getClassByNode(child)
          nsPrefix <- names(xmlNamespace(child))
          if(is.null(nsPrefix)){
            #try to grab from ns prefix
            childName <- xmlName(child, full = TRUE)
            preftag <- unlist(strsplit(as(childName, "character"),":"))[1]
            if(preftag!=childName) nsPrefix <- substring(preftag, 2, nchar(preftag))
          }
          if(is.null(fieldClass)){
            parentAttrs <- as.list(xmlAttrs(child, TRUE, FALSE))
            if(length(parentAttrs)>0) parentAttrs <- parentAttrs[names(parentAttrs) != "xsi:type"]
            if(length(parentAttrs)==0) parentAttrs <- NULL
            children <- xmlChildren(child, encoding = private$encoding, addFinalizer = FALSE)
            if(length(children)>0){
              if(length(children)==1){
                childroot <- children[[1]]
                if(!is(childroot, "XMLInternalTextNode")){
                  child <- childroot
                  fieldClass <- AtomAbstractObject$getClassByNode(childroot)
                }
              }
            }
            if(!is.null(fieldClass)) wrap_fields <- TRUE
          }
        }

        #coercing
        fieldValue <- xmlValue(child, recursive = FALSE)
        if(length(fieldValue)>0){
          fieldValue <- private$toComplexTypes(fieldValue)
        }

        if(!is.null(fieldClass)){
          fieldValue <- fieldClass$new(xml = child)
          fieldValue$parentAttrs <- parentAttrs
          fieldValue$attrs <- as.list(xmlAttrs(child, TRUE, FALSE))
          self[[fieldName]] <- c(self[[fieldName]], fieldValue)
        }else{
          if(fieldName == "text") fieldName <- "value"
          if(is.null(nsPrefix)) nsPrefix <- ""
          value <- xmlValue(child)
          isList <- is.list(self$getClass()$public_fields[[fieldName]])
          attrs <- xmlAttrs(child)
          if(!is.null(attrs)){
            attrNs <- attr(attrs,"namespaces")
            if(!is.null(attrNs)){
              attr(attrs,"namespaces") <- NULL
              names(attrs) <- paste(attrNs, names(attrs), sep=":")
              #control mal-formed attributes (starting with :)
              names(attrs) <- lapply(names(attrs), function(x){
                out <- x
                if(startsWith(x,":")) out <- substr(x, 2, nchar(x))
                return(out)
              })
            }
          }
          for(fieldAttr in names(attrs)){
            attr(value, fieldAttr) <- attrs[[fieldAttr]]
          }
          if(is.list(self[[fieldName]])){
            self[[fieldName]][[length(self[[fieldName]])+1]] <- value
          }else{
            self[[fieldName]] <- value
          }
        }

      }

      #inherit attributes if any
      xmlattrs <- NULL
      if(!self$isDocument()) xmlattrs <- xmlAttrs(xml, TRUE, FALSE)
      self$attrs <- as.list(xmlattrs)
    },

    #'@description Encodes the object as XML
    #'@param addNS whether namespace has to be added. Default is \code{TRUE}
    #'@param validate whether validation has to be done vs. XML schemas. Default is \code{TRUE}
    #'@param strict whether strict validation has to be operated (raise an error if invalid). Default is \code{FALSE}
    #'@param encoding encoding. Default is "UTF-8"
    encode = function(addNS = TRUE, validate = TRUE, strict = FALSE, encoding = "UTF-8"){

      #list of fields to encode as XML
      fields <- rev(names(self))

      #root XML
      rootXML <- NULL
      rootXMLAttrs <- list()
      if("attrs" %in% fields){
        rootXMLAttrs <- self[["attrs"]]
        rootXMLAttrs <- rootXMLAttrs[!is.na(rootXMLAttrs)]
      }

      #fields
      fields <- fields[!sapply(fields, function(x){
        (class(self[[x]])[1] %in% c("environment", "function")) ||
          (x %in% private$system_fields)
      })]

      if(self$isDocument()){
        rootNamespaces <- sapply(getAtomNamespaces(), function(x){x$getDefinition()})
        rootXML <- xmlOutputDOM(
          tag = self$element,
          nameSpace = self$namespace$id,
          nsURI = rootNamespaces
        )
      }else{
        wrapperAttrs <- self$parentAttrs
        if(addNS){
          nsdefs <- self$getNamespaceDefinition(recursive = TRUE)
          if(!("xsi" %in% names(nsdefs))) nsdefs <- c(nsdefs, AtomNamespace$XSI$getDefinition())
          if(!("xlink" %in% names(nsdefs))) nsdefs <- c(nsdefs, AtomNamespace$XLINK$getDefinition())
          nsdefs <- nsdefs[order(names(nsdefs))]
          rootXML <- xmlOutputDOM(
            tag = self$element,
            nameSpace = self$namespace$id,
            nsURI = nsdefs,
            attrs = wrapperAttrs
          )
        }else{
          rootXML <- xmlOutputDOM(
            tag = self$element,
            nameSpace = self$namespace$id,
            attrs = wrapperAttrs
          )
        }
      }

      for(field in fields){
        fieldObj <- self[[field]]

        #default values management
        if(is.null(fieldObj) || (is.list(fieldObj) & length(fieldObj)==0)){
          if(field %in% names(self$defaults)){
            fieldObj <- self$defaults[[field]]
          }
        }

        #user values management
        ns <- self$namespace$getDefinition()
        if(field != "value"){
          klass <- self$isFieldInheritedFrom(field)
          if(!is.null(klass)){
            ns <-  AtomNamespace[[klass$private_fields$xmlNamespacePrefix]]$getDefinition()
          }
        }
        namespaceId <- names(ns)
        if(!is.null(fieldObj)){
          if(is(fieldObj, "AtomAbstractObject")){
            if(fieldObj$isDocument()) fieldObj$setIsDocument(FALSE)
            fieldObjXml <- fieldObj$encode(addNS = FALSE, validate = FALSE)
            if(fieldObj$wrap){
              wrapperAttrs <- fieldObj$parentAttrs
              wrapperNode <- xmlOutputDOM(
                tag = field,
                nameSpace = namespaceId,
                attrs = wrapperAttrs
              )
              rootXML$addNode(wrapperNode$value())
            }else{
              rootXML$addNode(fieldObjXml)
            }
          }else if(is(fieldObj, "list")){
            for(item in fieldObj){
              nodeValue <- NULL
              if(length(item)==0) item <- NA
              if(is(item, "AtomAbstractObject")){
                nodeValue <- item
                if(item$isDocument()) item$setIsDocument(FALSE)
                nodeValueXml <- nodeValue$encode(addNS = FALSE, validate = FALSE)
                if(nodeValue$wrap){
                  wrapperAttrs <- nodeValue$parentAttrs
                  wrapperNode <- xmlOutputDOM(
                    tag = field,
                    nameSpace = namespaceId,
                    attrs = wrapperAttrs
                  )
                  wrapperNode$addNode(nodeValueXml)
                  rootXML$addNode(wrapperNode$value())
                }else{
                  rootXML$addNode(nodeValueXml)
                }
              }else{
                itemAttrs <- attributes(item)
                itemAttrs <- itemAttrs[names(itemAttrs)!="class"]
                itemAttrs <- c(itemAttrs, href = item)
                if(length(item)==0) item <- NA
                if(is.logical(item)) item <- tolower(as.character(as.logical(item)))
                item <- private$fromComplexTypes(item)
                wrapperNode <- xmlOutputDOM(
                  tag = field,
                  nameSpace = namespaceId,
                  attrs = itemAttrs
                )
                wrapperNode$addNode(xmlTextNode(item))
                rootXML$addNode(wrapperNode$value())
              }
            }
          }else{
            fieldObjAttrs <- attributes(fieldObj)
            fieldObjAttrs <- fieldObjAttrs[names(fieldObjAttrs)!="class"]
            fieldObjattrs <- c(fieldObjAttrs, href = fieldObj)
            if(length(fieldObj)==0) fieldObj <- NA
            if(is.logical(fieldObj)) fieldObj <- tolower(as.character(as.logical(fieldObj)))
            fieldObj <- private$fromComplexTypes(fieldObj)
            if(field != "value"){
              wrapperNode <- xmlOutputDOM(
                tag = field,
                nameSpace = namespaceId,
                attrs = fieldObjAttrs
              )
              wrapperNode$addNode(xmlTextNode(fieldObj))
              rootXML$addNode(wrapperNode$value())
            }else{
              rootXML$addNode(xmlTextNode(fieldObj))
            }
          }
        }
      }

      #toXML (required for validation)
      out <- rootXML$value()
      out <- private$xmlNodeToCharacter(out)
      if(Encoding(out)!="UTF-8") out <- iconv(out, to = "UTF-8")
      out <- xmlParse(out, encoding = Encoding(out), error = function (msg, ...) {})
      out <- as(out, "XMLInternalNode") #to XMLInternalNode

      if(length(rootXMLAttrs)>0){
        suppressWarnings(xmlAttrs(out) <- rootXMLAttrs)
      }

      #validation vs. Atom XML schemas
      compliant <- NA
      if(validate){
        compliant <- self$validate(xml = out, strict = strict)
      }
      if(self$isDocument()){
        header_comments <- private$xmlComments(compliant)

        #process XML comments
        for(comment in header_comments){
          rootXML$addNode(xmlCommentNode(comment))
        }

        #toXML (regeneration with comments)
        out <- rootXML$value()
        out <- private$xmlNodeToCharacter(out)
        if(Encoding(out)!="UTF-8") out <- iconv(out, to = "UTF-8")
        out <- xmlParse(out, encoding = Encoding(out), error = function (msg, ...) {})
        out <- as(out, "XMLInternalNode") #to XMLInternalNode
        if(length(rootXMLAttrs)>0){
          suppressWarnings(xmlAttrs(out) <- rootXMLAttrs)
        }
      }

      return(out)
    },

    #'@description Validates the object / XML vs. XML schemas
    #'@param xml object of class \link{XMLInternalNode-class} from \pkg{XML}
    #'@param strict strict validation or not
    #'@return \code{TRUE} if valid, \code{FALSE} otherwise
    validate = function(xml = NULL, strict = FALSE){

      #xml
      schemaNamespaceId <- NULL
      if(is.null(xml)){
        schemaNamespaceId <- self$namespace$id
        xml <- self$encode(addNS = TRUE, validate = FALSE, strict = strict)
      }else{
        #remove comments if any
        content <- as(xml, "character")
        content <- gsub("<!--.*?-->", "", content)
        xml <- xmlParse(content, encoding = private$encoding)
        schemaNamespaceId <- names(xmlNamespace(xmlRoot(xml)))
      }

      #proceed with schema xml schema validation
      xsd <- getAtomSchemas()
      if(is(xml, "XMLInternalNode")) xml <- xmlDoc(xml)
      report <- xmlSchemaValidate(xsd, xml)

      #check validity on self
      isValid <- report$status == 0
      if(!isValid){
        loggerType <- ifelse(strict, "ERROR", "WARN")
        for(error in report$errors){
          errorMsg <- paste0(substr(error$msg, 1, nchar(error$msg)-2), " at line ", error$line, ".")
          self[[loggerType]](errorMsg)
        }
        msg <- sprintf("Object '%s' is INVALID according to Atom XML schemas!", self$getClassName())
        if(strict){
          self$ERROR(msg)
          stop(msg)
        }else{
          self$WARN(msg)
        }
      }else{
        self$INFO(sprintf("Object '%s' is VALID according to Atom XML schemas!", self$getClassName()))
      }

      return(isValid)
    },

    #'@description Saves the object as XML file
    #'@param file file name
    #'@param ... any parameter to pass to \code{encode()} method
    save = function(file, ...){
      #encode as xml
      xml <- self$encode(...)
      xml_str <- as(xml, "character")
      #write file with writeBin to overcome writeChar size limitation
      writeBin(xml_str, con = file, useBytes = TRUE)
      #read file to replace C-style zero-terminated string
      r = readBin(file, raw(), file.info(file)$size)
      r[r==as.raw(0)] = as.raw(0x20) ## replace with 0x20 = <space>
      writeBin(r, file)
    },

    #'@description Indicates the class from which field is inherited
    #'@param field field
    #'@return an object of class \link{R6Class}, or \code{NULL}
    isFieldInheritedFrom = function(field){
      parentClass <- NULL
      inherited <- !(field %in% names(self$getClass()$public_fields))
      if(inherited){
        classes <- class(self)
        classes <- classes[c(-1,-length(classes))]
        for(i in 1:length(classes)){
          cl <- eval(parse(text=classes[i]))
          if(field %in% names(cl$public_fields)){
            parentClass <- cl
            break
          }
        }
      }
      return(parentClass)
    },

    #'@description Get class name
    #'@return object of class \code{character}
    getClassName = function(){
      return(class(self)[1])
    },

    #'@description Get class
    #'@return object of class \link{R6Class}
    getClass = function(){
      class <- eval(parse(text=self$getClassName()))
      return(class)
    },

    #'@description Get namespace definition
    #'@param recursive recursive
    #'@return a named \code{list} of the XML namespaces
    getNamespaceDefinition = function(recursive = FALSE){
      nsdefs <- NULL

      if(recursive){
        #list of fields
        fields <- rev(names(self))
        fields <- fields[!sapply(fields, function(x){
          (class(self[[x]])[1] %in% c("environment", "function")) ||
            (x %in% private$system_fields)
        })]

        selfNsdef <- self$getNamespaceDefinition()
        nsdefs <- list()
        if(length(fields)>0){
          invisible(lapply(fields, function(x){
            xObj <- self[[x]]
            if(is.null(xObj) || (is.list(xObj) & length(xObj) == 0)){
              if(x %in% names(self$defaults)){
                xObj <- self$defaults[[x]]
              }
            }
            hasContent <- !is.null(xObj)
            if(is(xObj, "AtomAbstractObject")){
              hasContent <- any(hasContent, length(xObj$attrs)>0)
            }
            if(hasContent){

              #add parent namespaces if any parent field
              if(x != "value"){
                klass <- self$isFieldInheritedFrom(x)
                if(!is.null(klass)){
                  ns <- AtomNamespace[[klass$private_fields$xmlNamespacePrefix]]$getDefinition()
                  if(!(ns %in% nsdefs)){
                    nsdefs <<- c(nsdefs, ns)
                  }
                }
              }

              #add namespaces
              nsdef <- NULL
              if(is(xObj, "AtomAbstractObject")){
                nsdef <- xObj$getNamespaceDefinition(recursive = recursive)
              }else if(is(xObj, "list")){
                nsdef <- list()
                invisible(lapply(xObj, function(xObj.item){
                  nsdef.item <- NULL
                  if(is(xObj.item, "AtomAbstractObject")){
                    nsdef.item <- xObj.item$getNamespaceDefinition(recursive = recursive)
                  }
                  for(item in names(nsdef.item)){
                    nsd <- nsdef.item[[item]]
                    if(!(nsd %in% nsdef)){
                      nsdef.new <- c(nsdef, nsd)
                      names(nsdef.new) <- c(names(nsdef), item)
                      nsdef <<- nsdef.new
                    }
                  }
                }))
              }
              for(item in names(nsdef)){
                nsdef.item <- nsdef[[item]]
                if(!(nsdef.item %in% nsdefs)){
                  nsdefs.new <- c(nsdefs, nsdef.item)
                  names(nsdefs.new) <- c(names(nsdefs), item)
                  nsdefs <<- nsdefs.new
                }
              }
            }
          }))
        }
        if(!(selfNsdef[[1]] %in% nsdefs)) nsdefs <- c(selfNsdef, nsdefs)
        nsdefs <- nsdefs[!sapply(nsdefs, is.null)]
      }else{
        nsdefs <- self$namespace$getDefinition()
      }

      invisible(lapply(names(self$attrs), function(attr){
        str <- unlist(strsplit(attr,":", fixed=T))
        if(length(str)>1){
          nsprefix <- str[1]
          namespace <- AtomNamespace[[toupper(nsprefix)]]
          if(!is.null(namespace)){
            ns <- namespace$getDefinition()
            if(!(ns %in% nsdefs)) nsdefs <<- c(nsdefs, ns)
          }
        }
      }))
      nsdefs <- nsdefs[!duplicated(names(nsdefs))]
      return(nsdefs)
    },

    #'@description Get XML element name
    #'@return object of class \code{character}
    getXmlElement = function(){
      return(private$xmlElement)
    }

  )
)

AtomAbstractObject$compare = function(metadataElement1, metadataElement2){
  text1 <- NULL
  if(is(metadataElement1, "AtomAbstractObject")){
    xml1 <-metadataElement1$encode(validate = FALSE)
    content1 <- as(xml1, "character")
    content1 <- gsub("<!--.*?-->", "", content1)
    xml1 <- xmlParse(content1)
    text1 <- as(xml1, "character")
  }else{
    text1 <- as.character(metadataElement1)
  }
  text2 <- NULL
  if(is(metadataElement2, "AtomAbstractObject")){
    xml2 <- metadataElement2$encode(validate = FALSE)
    content2 <- as(xml2, "character")
    content2 <- gsub("<!--.*?-->", "", content2)
    xml2 <- xmlParse(content2)
    text2 <- as(xml2, "character")
  }else{
    text2 <- as.character(metadataElement2)
  }
  return(text1 == text2)
}

AtomAbstractObject$getClasses = function(extended = FALSE, pretty = FALSE){
  getClassesInheriting(classname = "AtomAbstractObject", extended = extended, pretty = pretty)
}

AtomAbstractObject$getClassByNode = function(node){
  outClass <- NULL
  if(!is(node, "XMLInternalDocument")) node <- xmlDoc(node)
  nodeElement <- xmlRoot(node)
  nodeElementName <- xmlName(nodeElement)
  nodeElementNames <- unlist(strsplit(nodeElementName, ":"))
  if(length(nodeElementNames)>1){
    nodeElementName <- nodeElementNames[2]
  }
  nodeElementNs <- xmlNamespaces(node)

  list_of_classes <- getAtomClasses()

  for(classname in list_of_classes){
    clazz <- try(eval(parse(text=classname)))
    if(is(clazz, "try-error")) clazz <- try(eval(parse(text=paste0("atom4R::",classname))))
    targetXmlNamespacePrefix <- clazz$private_fields$xmlNamespacePrefix
    if(nodeElementNs[[1]]$id == "dc"){
      targetXmlNamespacePrefix <- "DC"
      if(startsWith(classname, "Atom")) next; #use DC class in priority over Atom class
    }
    if(nodeElementName %in% clazz$private_fields$xmlElement &&
       nodeElementNs[[1]]$uri == getAtomNamespace(targetXmlNamespacePrefix)$uri){
      atom4R_inherits <- FALSE
      superclazz <- clazz
      while(!atom4R_inherits){
        clazz_fields <- names(superclazz)
        if(!is.null(clazz_fields)) if(length(clazz_fields)>0) if("parent_env" %in% clazz_fields){
          if(environmentName(superclazz$parent_env)=="atom4R"){
            atom4R_inherits <- TRUE
            break
          }else{
            if("get_inherit" %in% clazz_fields){
              superclazz <- superclazz$get_inherit()
            }
          }
        }
      }
      if(!atom4R_inherits) next
      if(length(clazz$private_fields)>0
         && !is.null(clazz$private_fields$xmlElement)
         && !is.null(clazz$private_fields$xmlNamespacePrefix)){
        outClass <- clazz
        break
      }
    }
  }
  return(outClass)
}

#' @name getClassesInheriting
#' @aliases getClassesInheriting
#' @title getClassesInheriting
#'
#' @param classname the name of the superclass for which inheriting sub-classes have to be listed
#' @param extended whether we want to look at user namespace for third-party sub-classes
#' @param pretty prettify the output as \code{data.frame}

#' @export
#' @description get the list of classes inheriting a given super class provided by its name
#'
#' @usage getClassesInheriting(classname, extended, pretty)
#'
#' @examples
#'   getClassesInheriting("DCElement")
getClassesInheriting <- function(classname, extended = FALSE, pretty = FALSE){
  list_of_classes <- ls(getNamespaceInfo("atom4R", "exports"))
  if(extended) {
    search_envs <- search()
    search_envs <- search_envs[search_envs!="package:atom4R"]
    list_of_other_classes <- unlist(sapply(search_envs, ls))
    list_of_classes <- c(list_of_classes, list_of_other_classes)
  }

  list_of_classes <- list_of_classes[sapply(list_of_classes, function(x){
    clazz <- try(eval(parse(text=x)),silent=TRUE)
    if(is(clazz, "try-error")) clazz <- try(eval(parse(text=paste0("atomR::",x))),silent=TRUE)
    r6Predicate <- class(clazz)[1]=="R6ClassGenerator"
    if(!r6Predicate) return(FALSE)

    atomObjPredicate <- FALSE
    superclazz <- clazz
    while(!atomObjPredicate && !is.null(superclazz)){
      clazz_fields <- names(superclazz)
      if(!is.null(clazz_fields)) if(length(clazz_fields)>0){
        if("get_inherit" %in% clazz_fields){
          superclazz <- superclazz$get_inherit()
          atom4RPredicate <- FALSE
          if("parent_env" %in% clazz_fields) atom4RPredicate <- environmentName(superclazz$parent_env)=="atom4R"
          atomObjPredicate <- superclazz$classname == classname && atom4RPredicate
        }else{
          break
        }
      }
    }
    return(atomObjPredicate)
  })]

  list_of_classes <- as.vector(list_of_classes)
  if(pretty){
    std_info <- do.call("rbind",lapply(list_of_classes, function(x){
      clazz <- try(eval(parse(text=x)),silent=TRUE)
      if(is(clazz,"try-error")) clazz <- try(eval(parse(text=paste0("atom4R::",x))),silent=TRUE)
      std_info <- data.frame(
        environment = environmentName(clazz$parent_env),
        ns_prefix = clazz$private_fields$xmlNamespacePrefix,
        ns_uri = AtomNamespace[[clazz$private_fields$xmlNamespacePrefix]]$uri,
        element = clazz$private_fields$xmlElement,
        stringsAsFactors = FALSE
      )
      return(std_info)
    }))

    list_of_classes <- cbind(
      class = list_of_classes,
      std_info,
      stringsAsFactors = FALSE
    )
  }
  return(list_of_classes)
}

#' @name getAtomClasses
#' @aliases getAtomClasses
#' @title getAtomClasses
#' @export
#' @description get the list of Atom classes, ie classes extending \link{AtomAbstractObject} super class,
#' including classes eventually defined outside \pkg{atom4R}. In case the latter is on the search path,
#' the list of Atom classes will be cached for optimized used by \pkg{atom4R} encoder/decoder.
#'
#' @usage getAtomClasses()
#'
#' @examples
#'   getAtomClasses()
#'
#' @author Emmanuel Blondel, \email{emmanuel.blondel1@@gmail.com}
#
getAtomClasses <- function(){
  if("package:atom4R" %in% search()){
    if(is.null(.atom4R$classes)){
      .atom4R$classes <- getClassesInheriting(classname = "AtomAbstractObject", extended = TRUE, pretty = FALSE)
    }
    return(.atom4R$classes)
  }else{
    getClassesInheriting(classname = "AtomAbstractObject", extended = TRUE, pretty = FALSE)
  }
}