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