<%
'Const fhForReading = 1, fhForWriting = 2, fhForAppending = 8, fhAdChar = 129, _
' fhAdOpenKeyset =1, fhAdLockOptimistic =3
' @returns OnSuccess: An XML Document object
' @returns OnFailure: An empty object
'
' @throws 620 XML file not found
' @throws 650 XML server object could be created
' @throws 601 XML file could not be opened
Function fhOpenXMLFile(ByVal file)
On Error Resume Next
Dim FSO
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
If not FSO.FileExists(file) Then
Call Err.Raise(620, "fhOpenXMLFile", "File '" & file & "' not found")
Exit Function
End If
Dim Prefixes
Prefixes = Array("Microsoft.XMLDOM","MSXML2.DOMDocument.3.0","MSXML2.DOMDocument.4.0")
Dim xmlDoc
Dim i
for i = 0 to UBound(Prefixes)
Set xmlDoc = Nothing
Set xmlDoc = Server.CreateObject(Prefixes(i))
If (xmlDoc Is Nothing And i > 0) Then
Err.Clear()
Set xmlDoc = Server.CreateObject(Prefixes(i-1))
End If
next
if (xmlDoc is nothing) then
Call Err.Raise(650, "fhOpenXMLFile", "")
Exit Function
else
Dim f
set f = fso.OpenTextFile(file, 1)
dim str
str = f.ReadAll
if (cstr(str) = "") then
Call Err.Raise(601, "fhOpenXMLFile", "[" & err.number & "]" & err.Description)
Exit Function
end if
xmlDoc.loadXML(str)
set f = nothing
end if
set fhOpenXMLFile = xmlDoc
End Function
' @param (string) compName The name of the XML tag e.g. "FormsHandler"
' @param (string) dbPath The value of the dbpath attribute
' @returns OnSuccess: [compName]
' @returns OnFailure: nothing
Function fhGetByDBpath(ByVal XMLDoc, ByVal compName, ByVal dbpath)
On Error Resume Next
Dim NodeList, compNode
Set NodeList = XMLDoc.GetElementsByTagName("Component")
set compNode = nothing
Dim i
For i = 0 To NodeList.length - 1
if NodeList.Item(i).Attributes.length > 0 then
Dim j
For j = 0 to NodeList.Item(i).Attributes.length - 1
if LCase(NodeList.Item(i).Attributes.Item(j).nodeName) = "name" then
if NodeList.Item(i).Attributes.Item(j).nodeTypedValue = compName then
Dim ComponentNode
set ComponentNode = NodeList.Item(i)
if fhGetProperty(ComponentNode, "dbpath") = dbpath then
set compNode = ComponentNode
end if
set ComponentNode = nothing
end if
end if
next
end if
next
set fhGetByDBpath = compNode
end function
' @returns OnSuccess: An XML node
' @returns OnFailure: Nothing object
Public function fhGetNode(ByVal XML, ByVal StartNode, ByVal Nodename, ByVal attrName, ByVal attrVal, ByVal tagNr)
On Error Resume Next
Set fhGetNode = nothing
Dim NodeList
If IsObject(StartNode) then
Set NodeList = XML.documentElement.selectNodes(Nodename)
else
Set NodeList = XML.GetElementsByTagName(NodeName)
end if
Dim CompNode
set CompNode = nothing
Dim i
For i = 0 To NodeList.length - 1
Dim continue
continue = true
if NodeList.Item(i).Attributes.length > 0 then
Dim sw
sw = true
if isArray(attrName) then
Dim k
for k = 0 to UBound(attrName)
Dim j
For j = 0 to NodeList.Item(i).Attributes.length - 1
if LCase(NodeList.Item(i).Attributes.Item(j).nodeName) = LCase(attrName(k)) then
if Lcase(NodeList.Item(i).Attributes.Item(j).nodeTypedValue) = Lcase(attrVal(k)) then
if not sw then
continue = false
else
sw = false
end if
end if
end if
next
next
elseif attrName <> "" then
if LCase(NodeList.Item(i).Attributes.Item(j).nodeName) = LCase(attrName) then
if NodeList.Item(i).Attributes.Item(j).nodeTypedValue = attrVal then continue = false
end if
end if
elseif tagNr >= 0 then
if i = tagNr then
continue = false
end if
end if
if not continue then
set CompNode = NodeList.Item(i)
Exit For
end if
next
if err.number = 0 then
set fhGetNode = CompNode
end if
end function
' @returns OnSuccess: Node text
' @returns OnFailure: Empty string
Public Function fhGetProperty(ByVal XmlElement, ByVal PropName)
On Error Resume Next
Set fhGetProperty = nothing
Dim PropNode
Set PropNode = fhGetXMLElementByName(XmlElement, PropName)
fhGetProperty = PropNode.nodeTypedValue
End Function
Public Function fhGetXMLElementByName(ByVal XmlElement, ByVal TagName)
Dim i, j
Set fhGetXMLElementByName = Nothing
For i = 0 To XmlElement.childNodes.length - 1
If Trim(XmlElement.childNodes.Item(i).nodeName) = Trim(TagName) Then
Set fhGetXMLElementByName = XmlElement.childNodes.Item(i)
Exit For
End If
Next
End Function
Public Function fhGetXMLElementByPosition(ByVal XmlElement, ByVal pos)
Dim i
Set fhGetXMLElementByPosition = Nothing
For i = 0 To XmlElement.childNodes.length - 1
If i = pos Then
Set fhGetXMLElementByPosition = XmlElement.childNodes.Item(i)
Exit For
End If
Next
End Function
Public Function fhGetXMLElementByProperty(ByVal XmlElement, ByVal Property, ByVal PropValue)
Dim nodeElem
set fhGetXMLElementByProperty = nothing
if not XmlElement is nothing then
for j=0 to XmlElement.childNodes.length - 1
set nodeElem = fhGetXMLElementByPosition(XmlElement, j)
if LCase(Trim(fhGetProperty(nodeElem, Property))) = LCase(PropValue) then
set fhGetXMLElementByProperty = nodeElem
exit for
end if
next
else
response.write "the node provided is not a node in this XML"
response.end
end if
End Function
'### fhGetNextCurrentPage function - return value for requested property ###'
function fhGetNextCurrentPage(ByVal property)
Dim regEx1, Match, Matches
Set regEx1 = New RegExp
regEx1.Pattern = "((\.\./|\./)*)(.*)"
regEx1.IgnoreCase = True
regEx1.Global = False
Set Matches = regEx1.Execute(property)
For Each Match in Matches
fhGetNextCurrentPage = Match.SubMatches(2)
Next
end function
'### fhCheckEmail function - return true if email is a valid email address ###'
Function fhCheckEmail(ByVal strng)
Dim regEx, retVal
Set regEx = New RegExp
regEx.Pattern = "^(\w[-\w\.]*)?\w(@|%40)(\w[-\w]*)?\w(\.\w[-\w]*)?\w*\.[a-z]{2,4}$"
regEx.IgnoreCase = True
retVal = regEx.Test(strng)
If retVal Then
fhCheckEmail = true
Else
fhCheckEmail = false
End If
End Function
'### fhEncodeValue function - return value for requested property ###'
function fhEncodeValue(ByVal str)
Dim regEx, Match, Matches
Set regEx = New RegExp
regEx.Pattern = """"
regEx.IgnoreCase = True
regEx.Global = True
fhEncodeValue = regEx.Replace(str,"'")
regEx.Pattern = "\r\n"
regEx.IgnoreCase = True
regEx.Global = True
fhEncodeValue = regEx.Replace(fhEncodeValue, " ")
set regEx = nothing
end function
Sub fhLog(file, msg)
Dim fso, f
set fso = Server.CreateObject("Scripting.FileSystemObject")
set f = fso.OpenTextFile(file, 8, true)
f.writeLine msg
f.close
set f = nothing
set fso = nothing
end sub
Public Function fhCheckProperty(ByVal XMLElement, ByVal PropName, ByVal PropValue)
Dim errEvent
set fhCheckProperty = nothing
set errEvent = fhGetXMLElementByProperty(XMLElement, PropName, PropValue)
if not errEvent is nothing then
if fhGetProperty(errEvent, "active") then set fhCheckProperty = errEvent
end if
end function
'### fhFileExist function - check if a file exist ###'
function fhFileExist(ByVal path)
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(path) then
fhFileExist = true
else
fhFileExist = false
end if
set fso = nothing
end function
'### fhCreateDB sub - create database, if exist overwrite it ###'
sub fhCreateDB(ByVal path, ByVal head)
On Error Resume Next
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateTextFile(path, True)
if f is nothing then
Err.Raise 500
else
f.WriteLine head
f.Close
end if
set fso = nothing
end sub
'
' @return The first line from a file
'
function fhGetLine(ByVal path)
On error resume next
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(path, 1)
if f is nothing then
Err.Raise 501
Exit Function
end if
fhGetLine = f.ReadLine
f.Close()
set f = nothing
set fso = nothing
end function
' Attempts to open the @path file and returns a TextStream object
' @throws 520 Failed to open file
' @throws 502 Failed to open file
function fhOpenFile(ByVal path, ByVal oType)
On Error Resume Next
Dim FSO, f
set fhOpenFile = nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(path) then
Set f = FSO.OpenTextFile(path, oType)
else
set fso = nothing
Err.Raise 520
Exit Function
end if
if f is nothing then
set fso = nothing
Err.Raise 502
Exit Function
end if
set fhOpenFile = f
set fso = nothing
end function
' @return OnSuccess: Matching xml sub-node
' @return OnFailure: Nothing object
function fhGetErrorEvent(ByVal ComponentNode, ByVal fieldname, ByVal errorname)
On Error Resume Next
set fhGetErrorEvent = nothing
Dim j, k, field
For j = 0 To ComponentNode.childNodes.length - 1
If ComponentNode.childNodes.Item(j).nodeName = "field" Then
Set field = ComponentNode.childNodes.Item(j)
if Lcase(fhGetProperty(field, "name")) = Lcase(fieldname) then
for k = 0 to field.childNodes.length - 1
if field.childNodes.Item(k).nodeName = "errorevent" then
if Lcase(fhGetProperty(field.childNodes.Item(k), "errorname")) = Lcase(errorname) and _
fhGetProperty(field.childNodes.Item(k), "active") = "true" then
set fhGetErrorEvent = field.childNodes.Item(k)
exit function
end if
end if
next
end if
End If
Next
end function
function fhGetDBFields(ByVal comp)
Dim j, fields, found, nodeList, compNode
found = false
fhGetDBFields = ""
set fields = fhGetXMLElementByName(comp, "dbcolumns")
for i = 0 to fields.childNodes.length - 1
if len(fhGetDBFields) = 0 then
fhGetDBFields = fields.childNodes.Item(i).nodeTypedValue
else
fhGetDBFields = fhGetDBFields & "," & fields.childNodes.Item(i).nodeTypedValue
end if
next
end function
'### fhInsert function ###'
function fhInsert(ByVal path, ByVal rec)
On Error Resume Next
Dim f
set f = fhOpenFile(path, 8)
if (Err.number <> 0) then
if Err.Number <> 520 then Err.Raise 502
Exit Function
end if
f.WriteLine rec
f.Close
fhInsert = true
end function
'### fhGetTemplateValue function - return value for a template file ###'
function fhGetTemplateValue(ByVal path, ByVal property)
Dim fso, f, pos, prop, line
set f = fhOpenFile(path, 1)
prop = ""
Do While f.AtEndOfStream <> True
line = f.ReadLine
if Len(prop) = 0 then
pos = inStr(1, line, property & "=", 1)
if pos > 0 then
if Right(line,1) <> "\" then
prop = Mid(line, pos + Len(property)+1, Len(Line)-(pos + Len(property)))
exit do
end if
prop = Mid(line, pos + Len(property)+1, Len(Line)-(pos + Len(property))-1)
end if
else
if Right(line,1) <> "\" then
prop = prop & line
exit do
end if
prop = prop & Left(line, Len(line)-1)
end if
loop
f.Close
fhGetTemplateValue = prop
end function
'### get file content and return a RecordSet ###'
function fhRSFileContent(ByVal path, ByVal usrStat)
On Error Resume Next
Dim fso, f, fileLine, i, rs, allFields, statPos
statPos = fhGetRecPos("ValidationFlag", path)
set f = fhOpenFile(path, 1)
fileLine = f.ReadLine
set rs = Server.CreateObject("ADODB.RecordSet")
if rs is nothing then
call Err.Raise(910, "xmlLib fhRSFileContent", Err.Description)
end if
allFields = Split(fileLine, ",", -1, 1)
For i = 0 To UBound(allFields)
rs.Fields.Append CStr(allFields(i)), 129, 250
Next
rs.CursorType = 1
rs.LockType = 3
rs.Open
Do While f.AtEndOfStream <> True
fileLine = f.ReadLine
fileLine = Mid(fileLine, 2, Len(fileLine)-2)
allFields = Split(fileLine, """,""", -1, 1)
select case usrStat
case "valid"
if allFields(CLng(statPos)) then
With rs
.AddNew
For i = 0 To UBound(allFields)
.Fields(i).Value = Trim(allFields(i))
Next
.Update
.MoveFirst
End With
end if
case "invalid"
if not allFields(CLng(statPos)) then
With rs
.AddNew
For i = 0 To UBound(allFields)
.Fields(i).Value = Trim(allFields(i))
Next
.Update
.MoveFirst
End With
end if
case else
With rs
.AddNew
For i = 0 To UBound(allFields)
.Fields(i).Value = Trim(allFields(i))
Next
.Update
.MoveFirst
End With
end select
Loop
set fhRSFileContent = rs
f.Close
end function
'@returns OnSuccess: The line # of the of the field named [fieldName]
'@returns OnFailure: -1
Function fhGetRecPos(ByVal fieldName, ByVal dbPath)
On Error Resume Next
Dim out
out = -1
Dim f
set f = fhOpenFile(dbPath, 1)
Dim allTHeads
allTHeads = split(f.ReadLine, ",")
Dim i
For i = 0 to UBound(allTHeads)
if LCase(fieldName) = LCase(allTHeads(i)) then
out = i
exit for
end if
next
f.Close()
fhGetRecPos = out
End Function
' Inserts the contents of [rs] in the [path] CSV file
'
' @returns OnSuccess: true
' @returns OnFailure: false
Function fhUpdateDB(ByVal path, ByVal rs)
On Error Resume Next
fhUpdateDB = False
Dim fileLine
fileLine = ""
Dim tableHead
tableHead = fhGetLine(path)
Dim f
Set f = fhOpenFile(path, 2)
if f is nothing then
exit function
end if
f.WriteLine(tableHead)
With rs
.MoveFirst
Do While Not .EOF
For Each fld In .Fields
fldValue = """" & fhEncodeValue(Trim(fld.Value)) & """"
if Len(fileLine) > 0 then fileLine = fileLine & ","
fileLine = fileLine & fldValue
Next
f.WriteLine fileLine
fileLine = ""
.MoveNext
Loop
End With
f.Close
if Err.Number = 0 then
fhUpdateDB = true
else
fhUpdateDB = false
end if
End Function
' @returns File line associated with record number recNr, or empty string if not found
function fhGetRecord(ByVal recNr, ByVal dbPath)
On Error Resume Next
fhGetRecord = ""
Dim f
Set f = fhOpenFile(dbPath, 1)
f.ReadLine
Dim i
i = 0
Dim line
Do While f.AtEndOfStream <> True
line = f.ReadLine
i = i + 1
if i = CLng(recNr) then
fhGetRecord = Mid(line,2,Len(line)-2)
exit do
end if
loop
f.Close
end function
'@returns true if recNr exists, false otherwise
Function fhRecordExist(ByVal recNr)
on error resume next
fhRecordExist = false
Dim f
set f = fhOpenFile(dbPath, 1)
f.ReadLine()
Dim line
line = 0
Do While f.AtEndOfStream <> True
line = line + 1
if line = CLng(recNr) then
fhRecordExist = true
exit do
end if
f.ReadLine
loop
f.Close()
End Function
Function fhReFind(ByVal str, ByVal patrn)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
Set fhReFind = regEx.Execute(str)
set regEx = nothing
End Function
'Stops execution on fatal error
'@param Code (int) Error code
Function fhRaiseFatalError(ByVal Code)
Response.Write ""
'
' Response.Write "
"
' Response.Write "
"
' Response.Write "
An error occured. Please contact the site administrator.
Error code: " & Code & "
"
' Response.Write "
"
' Response.Write "
"
End Function
'functions for generating html code
Sub fhBuildHiddenField(ByVal name, ByVal value)
Response.Write "" & vbCRLF
End Sub
%>