Copyright 2009 TietoEnator Alise (developed by Arturs Mekss)

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and limitations under the License.
%END REM

Type NodeQuery
nodeName As String
subNodeName As String
subNodeValue As String
nth As Integer
End Type

%REM
Version: 0.8.0
Author: AMe
Purpose: This class provides methods for XML structured data processing in LotusScript.
XML structure could be read from files or String variables and/or could be written to files or printed out as Text.
There are methodes which can be used in order to modify existing XML structure or XML structure
could be built from scarch
Methods:
- isReady() As Boolean

- parseString(sourceStr As String) As Boolean
- parseFile(sourceFilePath As String) As Boolean

- toStream() As NotesStream
- toText() As Boolean
- toFile(targetFilePath As String)

- appendElementNode(pNode As NotesDOMElementNode, nodeName As String, nodeValue As String, altNodeValue As String) As NotesDOMElementNode
- selectNode(elementNode As NotesDOMElementNode, query As String) As NotesDOMElementNode
- getNodeValue(elementNode As NotesDOMElementNode, altVal As String) As String
Examples:
'1. Build XML from scrach and store to file
Dim xml As XMLProcessor
Dim personNode As NotesDOMElementNode
Set xml = New XMLProcessor("persons")
Set personNode = xml.appendElementNode(Nothing, "person", "", "") 'if parent node is Nothing then root node will be used as parent node
Call xml.appendElementNode(personNode, "name", "Bart", "")
Call xml.appendElementNode(personNode, "sureName", "Simpson", "")
Set personNode = xml.appendElementNode(Nothing, "person", "", "")
Call xml.appendElementNode(personNode, "name", "Jonny", "")
Call xml.appendElementNode(personNode, "sureName", "Bravo", "")
Call xml.toFile("D:\WORK_TMP\xml\persons.xml")


'2. Read XML from file and print it as a plain text
Dim xml As XMLProcessor
Set xml = New XMLProcessor("")
Call xml.parseFile("D:\WORK_TMP\xml\persons.xml")
Call xml.toText()

'3. Read XML from file and get values via selector
Dim xml As XMLProcessor
Dim node As NotesDOMElementNode
Set xml = New XMLProcessor("")
Call xml.parseFile("D:\WORK_TMP\xml\persons.xml")
Set node = xml.selectNode(Nothing, "person:2>name")
MessageBox xml.getNodeValue(node, "-")
Set node = xml.selectNode(Nothing, "person(name=Bart)>sureName")
MessageBox xml.getNodeValue(node, "-")

%END REM
Class XMLProcessor

'General variables
Private session As NotesSession
Private objIsReady As Boolean 'Object is properly initialized

'XSLT variables
Private isXSLTDefined As Boolean
Private XSLT As NotesStream

'InputStream variables
Private InputStream As NotesStream

'OutputStream variables
Private outputStream As NotesStream

'DOM variables
Private domparser As NotesDOMParser
Private domdoc As NotesDOMDocumentNode
Private rootNode As NotesDOMElementNode

'PUBLIC Scope:

Public Sub new(rootNodeName As String)
On Error Goto errh
Dim piNode As NotesDOMProcessingInstructionNode
Set Me.session = New NotesSession

If rootNodeName <> "" Then
Set domParser=session.CreateDOMParser
Set domdoc = domparser.Document
Set piNode = domdoc.CreateProcessingInstructionNode(|xml|, |version="1.0" encoding="UTF-8"|)
Call domdoc.appendChild(piNode)
Set rootNode = domdoc.CreateElementNode(rootNodeName)
Call domdoc.appendChild(rootNode)
Me.objIsReady = True
End If

Exit Sub
errh: Call Me.onError()
Exit Sub
End Sub

Public Sub Delete
On Error Goto errh

' -- Closing opened resources
' closing xslt stream
If Me.isXSLTDefined Then Call Me.XSLT.Close()
'closing output stream
If Not Me.outputStream Is Nothing Then Call Me.outputStream.Close
'closing input stream
If Not Me.inputStream Is Nothing Then Call Me.inputStream.Close

Exit Sub
errh: Call Me.onError()
Exit Sub
End Sub

Public Function isReady() As Boolean
isReady = Me.objIsReady
End Function

Public Function parseString(sourceStr As String) As Boolean
On Error Goto errh

If Me.createDOMParserFromSource(sourceStr) Then
parseString = True
Me.objIsReady = True
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Public Function parseFile(sourceFilePath As String) As Boolean
On Error Goto errh

Set Me.InputStream = session.CreateStream()
If Me.InputStream.Open(sourceFilePath, "UTF-8") Then
If Me.InputStream.Bytes = 0 Then Error 3000, "File does not exist or is empty: " + sourceFilePath
If Me.createDOMParserFromSource(Me.InputStream) Then
parseFile = True
Me.objIsReady = True
End If
Else
Error 3000, "Can't open " & sourceFilePath
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Function toStream() As NotesStream
On Error Goto errh

If Me.processOutput("") Then
Set Me.toStream = Me.outputStream
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Public Function toText() As Boolean
On Error Goto errh

If Me.processOutput("") Then
Print Me.outputStream.Readtext()
Call Me.outputStream.Close
toText = True
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Public Function toFile(targetFilePath As String) As Boolean
On Error Goto errh

If Me.processOutput(targetFilePath) Then
Call Me.outputStream.Close
toFile = True
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Public Function setXSLT(sourceXSLT As XMLProcessor) As Boolean
On Error Goto errh

Exit Function 'not implemented yet

If Not sourceXSLT Is Nothing Then
If sourceXSLT.isReady()Then
Set Me.XSLT = sourceXSLT.toStream()
Me.isXSLTDefined = True
End If
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Public Function appendElementNode(pNode As NotesDOMElementNode, nodeName As String, nodeValue As String, altNodeValue As String) As NotesDOMElementNode
On Error Goto errh
Dim parentNode As NotesDOMElementNode
Dim childNode As NotesDOMElementNode
Dim value As String

If Not Me.objIsReady Then Error 3000, "Error: Object is not fully inicialized"

value = nodeValue
If value = "" Then value = altNodeValue

If pNode Is Nothing Then
Set parentNode = rootNode
Else
Set parentNode = pNode
End If

Set childNode = domdoc.CreateElementNode(nodeName)
If value <> "" Then
Call childNode.AppendChild(domdoc.CreateTextNode(nodeValue))
End If
Call parentNode.appendChild(childNode)
Set appendElementNode = childNode

Exit Function
errh: Call Me.onError()
Exit Function
End Function

%REM
'#AMe (17.09.2009) Get & return node from XML document by selector query
'Supported query syntax:
'E>F (F is a child of E)
'E:n (nth E element in result set, default is the first element)
'E(F=abc) (E which has child node F with value 'abc')
'For example:
'Product>Part:3 this query will return 3rd child Part tag of a Product
%END REM
Public Function selectNode(scope As NotesDOMElementNode, query As String) As NotesDOMElementNode
On Error Goto errh
Dim nQueryList List As NodeQuery
Dim rvNode As NotesDOMElementNode, scopeNode As NotesDOMElementNode

If Not Me.objIsReady Then Error 3000, "Error: Object is not fully inicialized"

If Me.parseQuery(query, nQueryList) Then
If scope Is Nothing Then
Set scopeNode = rootNode
Else
Set scopeNode = scope
End If

Forall nq In nQueryList
If nq.subNodeValue <> "" Then
Set rvNode = Me.getNodeByTagNameWithSpecContent(scopeNode, nq.nodeName, nq.subNodeName, nq.subNodeValue)
Else
Set rvNode = Me.getNodeByTagName(scopeNode, nq.nodeName, nq.nth)
End If

If rvNode Is Nothing Then
Exit Forall
Else
Set scopeNode = rvNode
End If
End Forall
End If

Set Me.SelectNode = rvNode

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Public Function getNodeValue(elementNode As NotesDOMElementNode, altVal As String) As String
On Error Goto errh
Dim rv As String

rv = altVal
If Not elementNode Is Nothing Then
If Not elementNode.FirstChild.IsNull Then
rv = elementNode.FirstChild.NodeValue
End If
End If

getNodeValue = rv

Exit Function
errh: Call Me.onError()
Exit Function
End Function

'PRIVATE Scope
Private Sub onError()
Error 3000, " [" & Getthreadinfo( 10 ) & ": " & Cstr( Erl ) & "] " & Error
End Sub

Private Function createDOMParserFromSource(source As Variant) As Boolean
On Error Goto errh

Set Me.domParser = Me.session.CreateDOMParser(source)
Call Me.domParser.Process
Set Me.rootNode = Me.domParser.Document.DocumentElement
Me.createDOMParserFromSource = True

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Private Function processOutput(targetFilePath As String) As Boolean
On Error Goto errh
If Not Me.objIsReady Then Error 3000, "Error: Object is not fully inicialized"

Set Me.outputStream = session.CreateStream
If targetFilePath <> "" Then
If Me.outputStream.Open(targetFilePath, "utf-8") Then
Call Me.outputStream.Truncate
Else
Error 3000, "Can't open " & targetFilePath
End If
End If
Call Me.domparser.SetOutput(Me.outputStream)
Call Me.domparser.serialize()

If Me.isXSLTDefined Then
Set Me.outputStream = Me.transform()
End If

Me.processOutput = True

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Private Function transform() As NotesStream
On Error Goto errh
Dim transformedOutputStream As NotesStream
Dim transformer As NotesXSLTransformer

'checking
If Not Me.objIsReady Then Error 3000, "Error: Object is not fully inicialized"
If Not Me.isXSLTDefined Then Error 3000, "Error: XSLT is not defined for transformation"

'transformation
Set transformedOutputStream = Me.session.Createstream()
Set transformer = Me.session.CreateXSLTransformer(Me.outputStream , Me.XSLT , transformedOutputStream)
Call transformer.Process()
Set Me.transform = transformedOutputStream

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Private Function getNodeByTagName(elementNode As notesDOMElementNode, tagName As String, nth As Integer) As notesDOMElementNode
On Error Goto errh
Dim nodeList As NotesDOMNodeList
Dim max As Integer

Set nodeList = elementNode.GetElementsByTagName(tagName)
max = nodeList.NumberOfEntries
If nth <= max Then
Set getNodeByTagName = nodeList.GetItem(nth)
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Private Function getValueByTagName(elementNode As notesDOMElementNode, tagName As String) As Variant
'#AMe (11.03.2008) Get & return value from XML document by Tag name
On Error Goto errh
Dim result As Variant

Dim nodeList As NotesDOMNodeList
Dim currNode As NotesDOMElementNode
Dim i As Integer, max As Integer

Set nodeList = elementNode.GetElementsByTagName(tagName)
max = nodeList.NumberOfEntries

If (max > 0) Then
Redim result(max-1)
For i=1 To max
Set currNode = nodeList.GetItem(i)
If Not currNode.FirstChild.IsNull Then
result(i-1) = currNode.FirstChild.NodeValue
Else
result(i-1) = " "
End If
Next i
Else
Redim result(0)
End If

Me.getValueByTagName = result

Exit Function
errh: Call Me.onError()
Exit Function
End Function

Private Function parseQuery(query As String, nQueryList List As NodeQuery) As Boolean
On Error Goto errh
Dim idx As Integer
Dim qLevels As Variant
Dim nth As Integer
Dim tmpStr As String
Dim subNodeName As String, subNodeValue As String


qLevels = Split(query, ">")

Forall level In qLevels
nth = 1
subNodeName = ""
subNodeValue = ""

If Instr(level, ":") > 0 Then
nth = Cint(Strrightback(level, ":"))
level = Strleftback(level, ":")
End If

If Instr(level, "(") > 0 Then
tmpStr = Strrightback(level, "(")
tmpStr = Left(tmpStr, Len(tmpStr) - 1)
level = Strleftback(level, "(")
nth = 1
If Instr(tmpStr, "=") > 0 Then
subNodeName = Strleftback(tmpStr, "=")
subNodeValue = Strrightback(tmpStr, "=")
Else
subNodeName = tmpStr
End If
End If

nQueryList(Cstr(idx)).nodeName = level
nQueryList(Cstr(idx)).subNodeName = subNodeName
nQueryList(Cstr(idx)).subNodeValue = subNodeValue
nQueryList(Cstr(idx)).nth = nth

idx = idx + 1
End Forall

parseQuery = True
Exit Function
errh: Call Me.onError()
Exit Function
End Function

Private Function getNodeByTagNameWithSpecContent(elementNode As notesDOMElementNode, tagName As String, containsTag As String, containsValue As String) As notesDOMElementNode
On Error Goto errh
Dim nodeList As NotesDOMNodeList
Dim currNode As NotesDOMElementNode
Dim i As Integer, max As Integer

Set Me.getNodeByTagNameWithSpecContent = currNode ' initial value
Set nodeList = elementNode.GetElementsByTagName(tagName)
max = nodeList.NumberOfEntries

If (max > 0) Then
For i=1 To max
Set currNode = nodeList.GetItem(i)
If Me.getValueByTagName(currNode, containsTag)(0) = containsValue Then
Set Me.getNodeByTagNameWithSpecContent = currNode
Exit Function
End If
Next i
End If

Exit Function
errh: Call Me.onError()
Exit Function
End Function

End Class