<% Class XmlForm Private m_Doc Private m_IsValid Private m_FileName Private m_Log Public Sub Class_Initialize() Set m_Doc = CreateObject("MSXML2.DOMDocument.4.0") Set m_Log = New Logger : m_Log.Level = "ERROR" : m_Log.BufferOutput = True : m_Log.Name = "XmlForm" m_IsValid = True End Sub ' Loads the definition from an XML file. Public Function Load(FileName) m_FileName = Server.MapPath(FileName) Load = m_Doc.Load(m_FileName) If Not Load Then Dim Error : Set Error = m_Doc.parseError m_Log.Error "Xml parsing error at line " & Error.Line _ & ", char " & Error.LinePos & ": " & Error.Reason _ & "
" & Error.SrcText End If End Function ' Loads the definition from a string. Public Function LoadXml(XmlString) LoadXml = m_Doc.LoadXml(XmlString) If Not LoadXml Then Dim Error : Set Error = m_Doc.parseError m_Log.Error "Xml parsing error at line " & Error.Line _ & ", char " & Error.LinePos & ": " & Error.Reason _ & "
" & Error.SrcText End If End Function ' Returns whether the form is valid or not. Public Property Get IsValid IsValid = m_IsValid End Property ' Returns text that you can insert into a web page to display the form. Public Function ToString() Dim NewDoc, Hidden, Node, FormNode, Action ' If the form hasn't got an action, set the action to the current page. Set FormNode = m_Doc.selectSingleNode("/form") If FormNode.getAttribute("action") = "" Or IsNull(FormNode.getAttribute("action")) Then Action = Request.ServerVariables("URL") If FormNode.getAttribute("method") = "POST" Then Action = Action & "?" & Request.QueryString End If FormNode.setAttribute "action", Action End If ' Clone the document so we can remove elements that should be hidden, ' without modifying the original document Set NewDoc = m_Doc.cloneNode(True) Set Hidden = NewDoc.selectNodes("//node()[@hidden='1']") For Each Node In Hidden Node.parentNode.removeChild Node Next ToString = NewDoc.Xml End Function ' Populates the form with data submitted by the browser. Public Sub Grab() Dim Config, Form, Method ' Get the element that describes the form, and the form itself. Set Config = m_Doc.selectSingleNode("/form/config") Set Form = m_Doc.selectSingleNode("/form") If Form Is Nothing Or Config Is Nothing Then m_IsValid = False Else Method = Form.getAttribute("method") ' See if the browser posted any form data. If not, then there is no ' point trying to set element values. If GetBrowserData(Method, "formSanityCheck") = "" Then m_IsValid = False Else ' For each element described in the config element, get the element or ' list of elements in the form, and populate them with the browser's ' data. Dim Node For Each Node In m_Doc.DocumentElement.selectNodes("/form/config/element") SetValue Node.getAttribute("name"), GetBrowserData(Method, Node.getAttribute("name")) Next End If End If End Sub ' Gets a value from the form, by name Public Function GetValue(Name) Dim Config, Node, Val, Options, Child, Result(), i Set Config = m_Doc.selectSingleNode("/form/config/element[@name='" & Name & "']") If Config Is Nothing Then m_Log.Error "The form element '" & Name & "' is not defined in the config." Exit Function End If ' Get the element's value If Config.getAttribute("type") = "array" Then If Config.getAttribute("tag-name") = "input" Then ' It's a CheckBox Set Options = m_Doc.selectNodes("//input[@type='checkbox' and @checked='1' and @name='" & Name & "']") ReDim Result(Options.Length - 1) For i = 0 To Options.Length - 1 Result(i) = Options(i).Attributes.getNamedItem("value").Text Next GetValue = Result ElseIf Config.getAttribute("tag-name") = "select" Then Set Node = m_Doc.selectSingleNode("//select[@id='" & Config.getAttribute("element-id") & "']") Set Options = Node.selectNodes("option[@selected='1']") ReDim Result(Options.Length - 1) For i = 0 To Options.Length - 1 Result(i) = Options(i).Attributes.getNamedItem("value").Text Next GetValue = Result End If ElseIf Config.getAttribute("element-id") <> "" Then ' It's a scalar that's not a radio button or checkbox array Set Node = m_Doc.selectSingleNode("//node()[@id='" & Config.getAttribute("element-id") & "']") If Not Node Is Nothing Then If Node.nodeName = "select" Then ' Find the correct child node of the element and get its value For Each Child In Node.selectNodes("option") If Child.getAttribute("selected") <> "" Then GetValue = Child.getAttribute("value") End If Next ElseIf Node.nodeName = "input" Then ' It's a TextBox, Password, Hidden, Button, Submit, or Reset Select Case Node.getAttribute("type") Case "checkbox" If Not IsNull(Node.getAttribute("checked")) And Not IsNull(Node.getAttribute("value")) Then If Node.getAttribute("checked") = "1" Then GetValue = Node.getAttribute("value") Else GetValue = "" End If End If Case Else If Not IsNull(Node.getAttribute("value")) Then GetValue = Node.getAttribute("value") Else GetValue = "" End If End Select Else ' Textarea GetValue = Node.Text End If End If Else ' It's a scalar that's a radio button, or *scalar* checkbox array Set Options = m_Doc.selectNodes("//input[@name='" & Name & "' and @checked='1']") If Options.Length > 0 Then GetValue = Options(0).Attributes.getNamedItem("value").Text End If End If If IsArray(GetValue) Then m_Log.Debug "Got value for " & Name & ". Result: ('" & Join(GetValue, "', '") & "')" Else m_Log.Debug "Got value for " & Name & ". Result: " & GetValue End If End Function ' Sets the value of a form element Public Sub SetValue(Name, Value) Dim Config, Node, Checkboxes, Child, OneVal, Radios, Options ' If the value isn't a string, stringify it If Not IsArray(Value) Then Value = CStr(Value) End If ' If the element isn't defined in the config, quit Set Config = m_Doc.selectSingleNode("/form/config/element[@name='" & Name & "']") If Not Config Is Nothing Then ' There are two types of form elements: arrays and scalars. If Config.getAttribute("type") = "array" Then ' An array means that there could be multiple values submitted ' for this element. Form elements that are arrays by nature ' are ' * CheckBox ' * SelectMultiple ' First array-ize the value If Not IsArray(Value) Then Value = Array(Value) End If ' Find out what kind of form element it is If Config.getAttribute("tag-name") = "input" Then ' It's a CheckBox array. Uncheck everything there's no data for, and ' check everything there is Set Checkboxes = m_Doc.selectNodes("//input[@name='" & Name & "' and @type='checkbox']") For Each Child In Checkboxes If InArray(Value, Child.getAttribute("value")) Then Child.SetAttribute ("checked"), 1 Else Child.RemoveAttribute ("checked") End If Next Else ' It's a element. For this ' element, we need to get all child elements of type ' and set the "selected" option on those that there's ' data for. XPath = "//select[@id='" & Config.getAttribute("element-id") & "']" Set Node = m_Doc.selectSingleNode(XPath) If Not Node Is Nothing Then ' Unselect them all first For Each Child In Node.selectNodes("option") Child.RemoveAttribute ("selected") Next ' Then set the ones we want to be set. For Each OneVal In Value Set Child = Node.selectSingleNode("option[@value='" & OneVal & "']") If Not Child Is Nothing Then Child.SetAttribute "selected", 1 m_Log.Debug "Set child option with value " & OneVal Else m_Log.Debug "Couldn't find child option with value " & OneVal End If Next Else m_Log.Error "Could not find node with XPath " & XPath End If End If Else ' Element is not an array, it's a scalar ' A scalar means that the browser submits a single value for ' the element. Form elements that are scalar by nature are ' * Radio ' * TextBox ' * Password ' * Hidden ' * Button ' * Submit ' * Reset ' * SelectOne ' * TextArea ' * A CheckBox can also be defined as scalar. ' If there's a tag-name attribute, the element needs to be ' identified by tag name (there might be multiples, as in a radio ' array). Otherwise, it needs to be identified by element-id. If Config.getAttribute("tag-name") <> "" Then ' Assume it's a radio button array. If Config.getAttribute("tag-name") = "input" Then ' Unselect everything there's no data for, select everything there is. Set Radios = m_Doc.selectNodes("//input[@name='" & Name & "' and @type='radio']") For Each Node In Radios If Node.getAttribute("value") = Value Then Node.SetAttribute "checked", "1" Else Node.RemoveAttribute ("checked") End If Next End If Else ' Need to identify the element by the element-id Set Node = m_Doc.selectSingleNode("//node()[@id='" & Config.getAttribute("element-id") & "']") If Not Node Is Nothing Then ' There are several kinds of elements in the scalar category: ' those whose value is contained in the "value" attribute, ' those whose value is in a Text node, and those who are one of ' several elements that must have their "selected" or "checked" ' attribute set to true to indicate which of them is actually ' the active element. If Node.nodeName = "input" Then Select Case Node.getAttribute("type") Case "text", "password", "hidden", "button", "submit", "reset" Node.SetAttribute "value", Value Case "checkbox" ' This is a checkbox that's NOT an array If Value <> "" Then Node.SetAttribute "checked", "1" Else Node.RemoveAttribute "checked" End If Case Else m_Log.Error "Node " & Name & " is an 'input' element but its 'type' " _ & "attribute is '" & Node.getAttribute("type") & "'" End Select ElseIf Node.nodeName = "select" Then ' It's a that's not multiple ' Find the correct child node of the element with a value ' of whatever value it is, and set its "selected" attribute ' to "1". All others get their "selected" attribute removed. Set Options = Node.GetElementsByTagName("option") For Each Child In Options If Child.getAttribute("value") = Value Then Child.SetAttribute "selected", "1" Else Child.RemoveAttribute "selected" End If Next ElseIf Node.nodeName = "textarea" Then Node.Text = Value Else m_Log.Error "Node " & Name & " has nodeName of '" & Node.nodeName & "'" End If End If End If ' Not Node Is Nothing End If ' Element is a scalar End If End Sub ' Returns true if a value exists in an array Private Function InArray(Coll, Value) InArray = False Dim Item For Each Item In Coll If CStr(Item) = Value Then InArray = True Exit Function End If Next End Function ' Gets the data that the browser sent Private Function GetBrowserData(Method, Name) Dim Result(), i If LCase(Method) = "get" Then If Request.QueryString(Name).Count > 1 Then ReDim Result(Request.QueryString(Name).Count) For i = 1 To Request.QueryString(Name).Count Result(i) = Request.QueryString(Name)(i) Next GetBrowserData = Result Else GetBrowserData = Request.QueryString(Name) End If Else If Request.Form(Name).Count > 1 Then ReDim Result(Request.Form(Name).Count) For i = 1 To Request.Form(Name).Count Result(i) = Request.Form(Name)(i) Next GetBrowserData = Result Else GetBrowserData = Request.Form(Name) End If End If End Function ' Validates a required element Private Function ValidateRequired(ConfigNode) Dim Node, Child, Options, XPath ValidateRequired = False m_Log.Debug "Validating for " & ConfigNode.getAttribute("name") ' First, discover whether it's an array or a scalar. If a value is ' required, a scalar must have a value; an array must have a value for ' at least one of its elements. If ConfigNode.getAttribute("type") = "array" Then m_Log.Debug ConfigNode.getAttribute("name") & " is an array" If ConfigNode.getAttribute("element-id") <> "" Then ' It's a SelectMultiple. Requires that the element be identified by ID. XPath = "//select[@id='" & ConfigNode.getAttribute("element-id") & "']" Set Node = m_Doc.selectSingleNode(XPath) If Not Node Is Nothing Then If Node.selectNodes("option[@selected and @value != '']").length > 0 Then ValidateRequired = True End If Else m_Log.Error "Could not find node with XPath " & XPath End If Exit Function Else ' It's a CheckBox array. Get an array of elements and check ' that at least one has the "checked" attribute. Find elements ' by getting all elements ' where {name} comes from the "name" attr of the ' element. For Each Node In m_Doc.selectNodes("//input[@name='" & ConfigNode.getAttribute("name") & "' and @type='checkbox']") If Node.getAttribute("checked") <> "" Then ValidateRequired = True Exit Function End If Next Exit Function End If Else ' type = "array" m_Log.Debug ConfigNode.getAttribute("name") & " is a scalar" ' The type is scalar (this is the default). There are 3 kinds of ' scalar elements: , and <select> If Not IsNull(ConfigNode.getAttribute("element-id")) And ConfigNode.getAttribute("element-id") <> "" Then XPath = "//node()[@id='" & ConfigNode.getAttribute("element-id") & "']" m_Log.Debug "XPath is " & XPath Set Node = m_Doc.selectSingleNode(XPath) If Not Node Is Nothing Then If Node.nodeName = "input" Then ' There are two kinds of <input> elements: checkbox and ' everything else. There may be multiple HTML elements ' that we need to go through for a radio, but checkbox and ' others are going to be single and are identified by ID. ' Radio buttons are special: they are in an array of ' elements not identified by element-id (see below) If Node.getAttribute("type") = "checkbox" Then If Node.getAttribute("checked") = "1" Then ValidateRequired = True Exit Function End If Exit Function Else ' text, password, hidden, button, submit, reset ' Only validate text, password; the user has no control ' over the others. m_Log.Debug "Validating for " & Node.getAttribute("name") If Node.getAttribute("type") = "text" Or Node.getAttribute("type") = "password" Then If Trim(Node.getAttribute("value")) <> "" Then ValidateRequired = True Exit Function End If Exit Function End If End If ElseIf Node.nodeName = "select" Then ' At least one of the element's childNodes needs to be ' selected. Elements with an empty value count as not ' selected. If Node.selectNodes("option[@selected = '1' and @value != '']").Length > 0 Then ValidateRequired = True End If Exit Function Else ' <textarea> If Trim(Node.firstChild.Data) <> "" Then ValidateRequired = True End If Exit Function End If Else m_Log.Error "Cannot find the element for " & ConfigNode.getAttribute("name") End If Else ' It's an <input type="radio"> and we look up its elements by ' name and type, not by ID m_Log.Debug ConfigNode.getAttribute("name") & " is a radio collection" If m_Doc.selectNodes("//input[@name='" & ConfigNode.getAttribute("name") & "' and @type='radio' and @checked='1']").Length > 0 Then ValidateRequired = True End If Exit Function End If End If End Function ' Validates an element by examining if its contents match its data type Private Function ValidateDataType(ConfigNode) Dim Node, Val Dim Regex Val = "" Set Regex = New RegExp ValidateDataType = False Set Node = m_Doc.selectSingleNode("//node()[@id='" & ConfigNode.getAttribute("element-id") & "']") If Node Is Nothing Then Exit Function End If If Node.nodeName = "input" Then Val = Node.getAttribute("value") ElseIf Node.nodeName = "textarea" Then Val = Node.firstChild.Data End If If Val = "" Then ValidateDataType = True Exit Function End If Select Case ConfigNode.getAttribute("data-type") Case "number" ValidateDataType = IsNumeric(Val) Case "regexp" If Not IsNull(ConfigNode.getAttribute("expression")) And ConfigNode.getAttribute("expression") <> "" Then Regex.Pattern = ConfigNode.getAttribute("expression") ValidateDataType = Regex.Test(Val) Else m_Log.Error "You did not specify an 'expression' attribute for " & ConfigNode.Xml End If Case "date", "datetime", "timestamp" ValidateDataType = IsDate(Val) Case "email" Regex.Pattern = "^[\w-]+(?:\.[\w-]+)*@(?:[\w-]+\.)+[a-zA-Z]{2,7}$" ValidateDataType = Regex.Test(Val) Case "integer" Regex.Pattern = "^\d+$" ValidateDataType = Regex.Test(Val) Case "words" Regex.Pattern = "^[\w\d\t ]+$" ValidateDataType = Regex.Test(Val) End Select End Function ' Validates an element by comparing it as defined. Private Function ValidateComparison(ConfigNode) ValidateComparison = False Dim ThisNode, OtherNode, ThisValue, OtherValue ' As usual, advanced validation can only be done on textbox, password, ' and textarea Set ThisNode = m_Doc.selectSingleNode("//node()[@id='" & ConfigNode.getAttribute("element-id") & "']") Set OtherNode = m_Doc.selectSingleNode("//node()[@id='" & ConfigNode.getAttribute("compare-to-id") & "']") If ThisNode Is Nothing Or OtherNode Is Nothing Then ValidateComparison = False Exit Function End If ' Fetch the data from both elements ThisValue = "" OtherValue = "" If ThisNode.nodeName = "input" Then ThisValue = ThisNode.getAttribute("value") Else ' textarea ThisValue = ThisNode.firstChild.Text End If If OtherNode.nodeName = "input" Then OtherValue = OtherNode.getAttribute("value") Else ' textarea OtherValue = OtherNode.firstChild.Text End If ' There might be different types of data, such as numbers, strings, and ' dates, that have to be compared. These need to be converted into ' something that can compare. Select Case ConfigNode.getAttribute("data-type") Case "date", "datetime", "timestamp" ThisValue = CDate(ThisValue) OtherValue = CDate(OtherValue) End Select ' Do the comparison Select Case ConfigNode.getAttribute("compare-type") Case "less" ValidateComparison = ThisValue < OtherValue Case "equal" ValidateComparison = ThisValue = OtherValue Case "greater" ValidateComparison = ThisValue > OtherValue Case "lessequal" ValidateComparison = ThisValue <= OtherValue Case "greaterequal" ValidateComparison = ThisValue >= OtherValue End Select End Function ' Validates the form against its definition in the <config> element Public Sub Validate() Dim Config, FormNode, Node, Continue ' Get the configuration information for the form Set Config = m_Doc.selectSingleNode("/form/config") Set FormNode = m_Doc.selectSingleNode("/form") ' The form is not valid unless it has been submitted. If GetBrowserData(FormNode.getAttribute("method"), "formSanityCheck") = "" Then m_IsValid = False Exit Sub End If ' Check each element referenced by the config element For Each Node In Config.selectNodes("element") Continue = True If Node.getAttribute("required") <> "" Then If Not ValidateRequired(Node) Then m_IsValid = False Node.SetAttribute "failed-required", "1" Continue = False End If End If If Continue Then If Node.getAttribute("required-unless") <> "" Then If GetBrowserData(FormNode.getAttribute("method"), Node.getAttribute("required-unless")) = "" Then If Not ValidateRequired(Node) Then m_IsValid = False Node.SetAttribute "failed-required", "1" Continue = False End If End If End If End If If Continue Then If Node.getAttribute("required-if") <> "" Then If GetBrowserData(FormNode.getAttribute("method"), Node.getAttribute("required-if")) <> "" Then If Not ValidateRequired(Node) Then m_IsValid = False Node.SetAttribute "failed-required", "1" Continue = False End If End If End If End If If Continue Then If Node.getAttribute("data-type") <> "" Then If Not ValidateDataType(Node) Then m_IsValid = False Node.SetAttribute "failed-data-type", "1" Continue = False End If End If End If If Continue Then If Node.getAttribute("compare-to-id") <> "" Then If Not ValidateComparison(Node) Then m_IsValid = False Node.SetAttribute "failed-comparison", "1" End If End If End If Next If Not m_IsValid Then EnableErrorMessages End If End Sub ' Unhides error elements Private Sub EnableErrorMessages() Dim Config, Node Dim Default, ErrorElement, Failed, Overall For Each Node In m_Doc.selectNodes("/form/config/element") ErrorElement = "" If Node.getAttribute("error-element") <> "" Then Default = Node.getAttribute("error-element") Else Default = False End If ' Then check if the element failed any validation checks; if so, ' get the name of the element to unhide Failed = False If Node.getAttribute("failed-required") <> "" Then ErrorElement = Node.getAttribute("name") & "-error" Failed = True ElseIf Node.getAttribute("failed-data-type") <> "" Then ErrorElement = Node.getAttribute("name") & "-data-error" Failed = True ElseIf Node.getAttribute("failed-comparison") <> "" Then ErrorElement = Node.getAttribute("name") & "-comparison-error" Failed = True End If If Failed Then Dim ErrorNode ' Try to find the error element to unhide If ErrorElement <> "" Then Set ErrorNode = m_Doc.selectSingleNode("//node()[@id='" & ErrorElement & "']") End If If ErrorNode Is Nothing Then ' Try to find the explicitly specified default error element If Default <> "" Then Set ErrorNode = m_Doc.selectSingleNode("//node()[@id='" & Default & "']") End If End If If ErrorNode Is Nothing Then ' Try to find an element that's named with the magical name Set ErrorNode = m_Doc.selectSingleNode("//node()[@id='" & Node.getAttribute("name") & "-error']") End If If Not ErrorNode Is Nothing Then ErrorNode.Attributes.removeNamedItem "hidden" End If End If Next ' Look for an error element for the *whole form* and unhide that if it ' exists. Set Config = m_Doc.selectSingleNode("/form/config") If Not Config.Attributes.getNamedItem("error-element") Is Nothing Then Set Overall = m_Doc.selectSingleNode("//node()[@id='" & Config.Attributes.getNamedItem("error-element").Text & "']") If Not Overall Is Nothing Then Overall.Attributes.removeNamedItem "hidden" End If End If End Sub ' Adds children from a query result to a <select> menu. You must name the element, and ' specify which column in the recordset should go into the value and which the text of ' the resulting <option> elements. Public Sub PopulateSelectMenu(Name, RecordSet, ValueCol, TextCol) Dim ConfiNode, SelectNode, OptionNode, TextNode, XPath Set ConfigNode = m_Doc.selectSingleNode("/form/config/element[@name='" & Name & "']") If Not ConfigNode Is Nothing Then ' Find the <select> element XPath = "//select[@id='" & ConfigNode.getAttribute("element-id") & "']" m_Log.Debug XPath Set SelectNode = m_Doc.selectSingleNode(XPath) If Not SelectNode Is Nothing Then Do While Not RecordSet.EOF Set OptionNode = m_Doc.createElement("option") Set TextNode = m_Doc.createTextNode(RecordSet(TextCol)) OptionNode.setAttribute "value", RecordSet(ValueCol) OptionNode.appendChild TextNode SelectNode.appendChild OptionNode RecordSet.MoveNext Loop End If Else m_Log.Error Name & " is not defined in the form's <config> section." End If End Sub End Class %>