source: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Xml/Parser.ab

Namespace ActiveBasic   
Namespace Xml


Class ParserException
    Inherits System.Exception
Public
    Sub ParserException( message As String )
        Exception( message )
    End Sub
End Class

Class Parser
    xmlString As String
    currentIndex As Long

    doc As System.Xml.XmlDocument

    Static Const tokenLPar = &H3C       ' <
    Static Const tokenRPar = &H3E       ' >
    Static Const tokenSlash = &H2F  ' /
    Static Const xmlHeaderStr = "<?xml"
    Static Const commentHeader = "<!--"
    Static Const cdataHeader = "<![CDATA["
    Static Const dtdHeader = "<!"
    Static Const versionAttributeName = "version"
    Static Const encodingAttributeName = "encoding"

    Static Function IsAlpha( c As Char ) As Boolean
        Return ( &H41 <= c and c <= &H5A or &H61 <= c and c <= &H7A )
    End Function

    Static Function IsUnderscore( c As Char ) As Boolean
        Return ( c = &H5F )
    End Function

    Static Function IsNumber( c As Char ) As Boolean
        Return ( &H30 <= c and c <= &H39 )
    End Function

    Static Function IsWhiteSpace( c As Char ) As Boolean
        If c = &H20 Then
            ' 空白
            Return True
        ElseIf c = &H09 Then
            ' タブ文字
            Return True
        ElseIf c = &H0A or c = &H0D Then
            ' 改行
            Return True
        End If
        ' その他
        Return False
    End Function

    Sub ts()
        MessageBox(0,xmlString.Substring(currentIndex),"test",0)
    End Sub

    Function StringWordEquals( src As String ) As Boolean
        Dim nextChar = xmlString[currentIndex + src.Length] As Char
        Return ( xmlString.Substring( currentIndex, src.Length ) = src and Not (IsAlpha( nextChar ) or IsUnderscore( nextChar ) or IsNumber( nextChar ) ) )
    End Function

    Function ReadName() As String
        Dim startIndex = currentIndex

        Dim c = xmlString[currentIndex] As Char

        If Not( IsAlpha( c ) or IsUnderscore( c ) ) Then
            Throw New ParserException( Ex"タグ名がアルファベットまたはアンダースコアから始まっていない" )
        End If

        While IsAlpha( c ) or IsUnderscore( c ) or IsNumber( c )
            currentIndex++
            c = xmlString[currentIndex] As Char
        Wend

        Return xmlString.Substring( startIndex, currentIndex - startIndex )
    End Function

    Function ReadStringInDoubleQuotes() As String
        ' '\"'分を進める
        currentIndex++

        Dim startIndex = currentIndex
        Dim endIndex = 0 As Long

        Do
            If xmlString[currentIndex] = 0 Then
                Throw New ParserException( Ex"属性の値の閉じ側のダブルクォートが存在しない" )
            End If

            If xmlString[currentIndex] = &H and xmlString[currentIndex+1] = &H22 Then
                ' エスケープシーケンス付きのダブルクォートは無視
                currentIndex += 2
                Continue
            End If

            If xmlString[currentIndex] = &H22 Then  ' '\"'
                ' 閉じ側のダブルクォート
                endIndex = currentIndex
                currentIndex++
                Exit Do
            End If

            currentIndex++
        Loop

        Return xmlString.Substring( startIndex, endIndex - startIndex )
    End Function

    Function ReadAttribute() As System.Xml.XmlAttribute
        Dim attributeName = ReadName()
        SkipWhiteSpace()

        Dim atr = doc.CreateAttribute( attributeName )

        If Not xmlString[currentIndex] = &H3D Then  ' '='
            Return atr
        End If

        currentIndex++ ' '='分を進める
        SkipWhiteSpace()

        If Not xmlString[currentIndex] = &H22 Then  '\"'
            Throw New ParserException( Ex"属性の値がダブルクォートで囲まれていない" )
        End If

        atr.Value = ReadStringInDoubleQuotes()

        Return atr
    End Function

    Function ReadTextArea() As String
        Dim startIndex = currentIndex

        While Not ( xmlString[currentIndex] = tokenLPar or xmlString[currentIndex] = 0 )
            currentIndex++
        Wend

        Return xmlString.Substring( startIndex, currentIndex - startIndex )
    End Function

    Sub SkipWhiteSpace()
        While IsWhiteSpace( xmlString[currentIndex] )
            currentIndex++
        Wend
    End Sub

    Function ParseDeclaration() As System.Xml.XmlDeclaration
        Dim versionStr = Nothing As String
        Dim encodingStr = Nothing As String
        currentIndex += xmlHeaderStr.Length

        SkipWhiteSpace()

        Do
            If xmlString[currentIndex] = 0 Then
                Throw New ParserException( Ex"タグの閉じ括弧が見つからない" )
            End If
            If xmlString[currentIndex] = tokenRPar Then
                currentIndex ++
                Exit Do
            End If

            currentIndex ++
        Loop

        Return doc.CreateXmlDeclaration( "1.0", "shift-jis", Nothing )
    End Function
    Function ParseComment() As System.Xml.XmlNode
    End Function
    Function ParseCData() As System.Xml.XmlNode
    End Function
    Function ParseDtd() As System.Xml.XmlNode
    End Function
    Function ParseElement() As System.Xml.XmlElement
        ' '<'分を進める
        currentIndex++

        ' タグ名を取得し、要素を作成
        Dim name = ReadName()
        Dim xmlElement = doc.CreateElement( name )

        SkipWhiteSpace()

        Do
            If xmlString[currentIndex] = 0 Then
                Throw New ParserException( Ex"タグの閉じ括弧が見つからない" )
            End If
            If xmlString[currentIndex] = tokenRPar or ( xmlString[currentIndex] = tokenSlash and xmlString[currentIndex+1] = tokenRPar ) Then
                Exit Do
            End If

            ' 属性を取得し、要素に追加
            xmlElement.Attributes.Add( ReadAttribute() )

            SkipWhiteSpace()
        Loop

        Dim closeTagStr = "</" + xmlElement.LocalName + ">"

        If xmlString[currentIndex] = tokenRPar Then ' '>'
            ' ">" で閉じられている
            currentIndex ++

            Do
                SkipWhiteSpace()

                If xmlString[currentIndex] = 0 Then
                    Throw New ParserException( xmlElement.LocalName + Ex"の閉じタグが見つからない" )
                End If

                If xmlString[currentIndex] = tokenLPar Then ' '<'
                    ' タグ
                    If StringWordEquals( closeTagStr ) Then
                        ' タグが閉じられた
                        currentIndex += closeTagStr.Length
                        Exit Do
                    End If

                    xmlElement.AppendChild( ParseNode() )
                Else
                    ' タグ以外
                    xmlElement.AppendChild( doc.CreateTextNode( ReadTextArea() ) )
                End If
            Loop
        Else
            ' "/>" で閉じられている
            currentIndex += 2
        End If

        Return xmlElement
    End Function

    Function ParseNode() As System.Xml.XmlNode
        If Not xmlString[currentIndex] = tokenLPar Then
            ' "<" で開始できないとき
            Throw New ParserException( Ex"\q<\q で開始できない" )
        End If

        If StringWordEquals( xmlHeaderStr ) Then
            ' XMLヘッダ
            Return ParseDeclaration()
        ElseIf StringWordEquals( commentHeader ) Then
            ' コメントヘッダ
            Return ParseComment()
        ElseIf StringWordEquals( cdataHeader ) Then
            ' CDATAヘッダ
            Return ParseCData()
        ElseIf StringWordEquals( dtdHeader ) Then
            ' DTDヘッダ
            Return ParseDtd()
        Else
            ' その他のタグ
            Return ParseElement()
        End If
    End Function

Public

    Sub Parser( xmlString As String, doc As System.Xml.XmlDocument )
        This.xmlString = xmlString
        This.doc = doc
    End Sub

    Sub Parse()
        This.currentIndex = 0
        This.doc.RemoveAll()

        SkipWhiteSpace()

        While currentIndex < xmlString.Length

            This.doc.AppendChild( ParseNode() )

            SkipWhiteSpace()
        Wend
    End Sub

    Static Sub Parse( xmlString As String, doc As System.Xml.XmlDocument )
        Dim parser = New Parser( xmlString, doc )
        parser.Parse()
    End Sub
End Class


End Namespace
End Namespace