Index: trunk/Include/Classes/ActiveBasic/Xml/Parser.ab
===================================================================
--- trunk/Include/Classes/ActiveBasic/Xml/Parser.ab	(revision 463)
+++ trunk/Include/Classes/ActiveBasic/Xml/Parser.ab	(revision 465)
@@ -3,8 +3,285 @@
 
 
+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
-	Static Function Parse( xmlString As String, doc As System.Xml.XmlDocument ) As Boolean
-	End Function
+
+	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