'
' XML
' version 0.4
' (c) 2009 Stefan Wurzinger
'

#Include Once "conv.bi"

#ifndef CRLF
	#define CRLF chr(13,10)
#endif

Type XML
	Tag as String
	Flags as UInteger = 0
	Daten as String
	SubTags as String = ""
	Parent as XML ptr
	Declare Function GetSubTag(ElemNr as Integer, Flag as UInteger = 0) as XML ptr
	Declare Function GetSubTag(Tag as String, ElemNr as Integer = 0, Flag as UInteger = 0) as XML ptr
	Declare Function SubTagCount(Flag as UInteger = 0) as Integer
	Declare Function SubTagAdd(Tag__ as String = "", Daten__ as String = "", Flags__ as UInteger = 0) as Integer
	Declare Function SubTagRemove(ElemNr as Integer, Flag as UInteger = 0) as Integer
	Declare Function SubTagRemove(Tag as String, ElemNr as Integer = 0, Flag as UInteger = 0) as Integer
	Declare Function SubTagClear(Flag as UInteger = 0) as Integer
	Declare Function SubTagChPos(SubXML as XML ptr, ElemPos as Integer, Flag as UInteger = 0) as Integer
	Declare Function SubTagCountElem(Tag as String, Flag as UInteger = 0) as Integer
	Declare Function GetIndexOf(SubXML as XML ptr, Flag as UInteger = 0) as Integer
	Declare Function ChPos(ElemPos as Integer, Flag as UInteger = 0) as Integer
	Declare Function Parse(XMLDaten as String) as Integer
	Declare Function ToString(Level as Integer = 0) as String
	Declare Destructor()
End Type


Function XML.Parse(XMLDaten as String) as Integer
	Dim q as Integer
	Dim SPos as UInteger
	Dim TPos as UInteger
	Dim EPos as UInteger
	Dim FPos as UInteger
	Dim tmpDaten as String
	Dim tmpStr as String
	Dim Trennzeichen as String
	Dim SubXML as XML ptr
	
	if Subtags <> "" then SubTagClear()
	
	this.Tag = ""
	this.Flags = 1
	this.Daten = ""
	this.SubTags = ""
	
	SPos = Instr(XMLDaten, "<")
	if SPos = 0 then return 0
	EPos = Instr(SPos+1, XMLDaten, " ")
	TPos = Instr(SPos+1, XMLDaten, chr(10))
	if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
	TPos = Instr(SPos+1, XMLDaten, chr(13))
	if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
	TPos = Instr(SPos+1, XMLDaten, "/>")
	if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
	TPos = Instr(SPos+1, XMLDaten, ">")
	if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
	this.Tag = mid(XMLDaten, SPos+1, EPos-SPos-1)
	if EPos <> TPos then
		SPos = Instr(EPos+1, XMLDaten, ">")
		if mid(XMLDaten, SPos-1, 2) = "/>" then tmpDaten = mid(XMLDaten, EPos+1, SPos-EPos-2) else tmpDaten = mid(XMLDaten, EPos+1, SPos-EPos-1)
		do
			EPos = Instr(tmpDaten, "=")
			if EPos = 0 then exit do
			FPos = Instr(EPos+1, tmpDaten, "'")
			TPos = Instr(EPos+1, tmpDaten, !"\"")
			if (TPos < FPos and TPos <> 0) or FPos = 0 then FPos = TPos
			Trennzeichen = mid(tmpDaten, FPos, 1)
			TPos = Instr(FPos+1, tmpDaten, Trennzeichen)
			this.SubTagAdd(trim(left(tmpDaten, EPos-1), Any chr(32, 13, 10, 9)), mid(tmpDaten, FPos+1, TPos-FPos-1), 2)
			tmpDaten = mid(tmpDaten, TPos+2)
		Loop
	else
		SPos = EPos
	EndIf
	if mid(XMLDaten, SPos-1, 2) = "/>" then return 0
	EPos = SPos
	Do
		SPos = Instr(SPos+1, XMLDaten, "<")
		if SPos = 0 or mid(XMLDaten, SPos+1, 1) = "/" then
			if len(this.SubTags) = this.SubTagCount(2)*4 then
				SPos = Instr(EPos+1, XMLDaten, "</"+this.Tag+">")
				this.Daten = mid(XMLDaten, EPos+1, SPos-EPos-1)
			EndIf
			exit do
		EndIf
		FPos = SPos
		EPos = Instr(SPos+1, XMLDaten, " ")
		TPos = Instr(SPos+1, XMLDaten, ">")
		if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
		TPos = Instr(SPos+1, XMLDaten, chr(10))
		if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
		TPos = Instr(SPos+1, XMLDaten, chr(13))
		if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
		TPos = Instr(SPos+1, XMLDaten, "/>")
		if (TPos < EPos and TPos <> 0) or EPos = 0 then EPos = TPos
		tmpDaten = mid(XMLDaten, SPos+1, EPos-SPos-1)
		SPos = Instr(EPos+1, XMLDaten, "</"+tmpDaten+">")
		TPos = Instr(EPos+1, XMLDaten, "/>")
		if SPos = 0 then SPos = TPos+1 else SPos += 2+Len(tmpDaten)
		tmpDaten = mid(XMLDaten, FPos, SPos-FPos+1)
		SubXML = New XML
		if SubXML = 0 then return 10
		SubXML->Parent = @this
		this.SubTags &= Int2StrLE(cast(UInteger, SubXML), 4)
		q = SubXML->Parse(tmpDaten)
		if q <> 0 then return q
	Loop
	
	return 0
End Function

Destructor XML()
	if Subtags <> "" then SubTagClear()
End Destructor

Function XML.ToString(Level as Integer = 0) as String
	dim tmpDaten as String = ""
	dim SubXML as XML ptr
	tmpDaten = String(Level, 9) & "<" & this.Tag
	for q as Integer = 0 to this.SubTagCount(2)-1
		tmpDaten &= " " & GetSubTag(q, 2)->Tag & !"=\"" & GetSubTag(q, 2)->Daten & !"\""
	Next
	if this.Daten <> "" then
		tmpDaten &= ">" & this.Daten
	else
		if this.SubTagCount(1) = 0 then return tmpDaten & "/>" & CRLF
		tmpDaten &= ">" & CRLF
		for q as Integer = 0 to this.SubTagCount(1)-1
			tmpDaten &= this.GetSubTag(q,1)->ToString(Level+1)
		Next
		tmpDaten &= String(Level, 9)
	EndIf
	tmpDaten &= "</" & this.Tag & ">" & CRLF
	return tmpDaten
End Function

Function XML.SubTagCount(Flag as UInteger = 0) as Integer
	if Flag = 0 then return len(this.SubTags)/4
	Dim Anz as Integer = 0
	For q as Integer = 0 to len(this.SubTags)/4-1
		if (Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))->Flags and Flag) <> 0 then Anz += 1
	Next
	return Anz
End Function

Function XML.GetSubTag(ElemNr as Integer, Flag as UInteger = 0) as XML ptr
	if ElemNr >= this.SubTagCount(Flag) or ElemNr < 0 then return 0
	if Flag = 0 then return Cast(XML ptr, Str2IntLE(mid(this.SubTags, ElemNr*4+1, 4)))
	Dim Anz as Integer = 0
	Dim SubXML as XML ptr
	For q as Integer = 0 to (len(this.SubTags)/4)-1
		SubXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if (SubXML->Flags and Flag) <> 0 then Anz += 1
		if ElemNr+1 = Anz then return SubXML
	Next
End Function

Function XML.GetSubTag(Tag as String, ElemNr as Integer = 0, Flag as UInteger = 0) as XML ptr
	dim Anz as Integer = 0
	dim SubXML as XML ptr
	for q as Integer = 0 to (len(this.SubTags)/4)-1
		SubXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if (SubXML->Tag = Tag) and ((Flag = 0) OrElse ((SubXML->Flags and Flag) <> 0)) then Anz += 1
		if ElemNr+1 = Anz then return SubXML
	Next
	return 0
End Function

Function XML.SubTagAdd(Tag__ as String = "", Daten__ as String = "", Flags__ as UInteger = 0) as Integer
	Dim SubXML as XML ptr
	if (Flags__ and 2) <> 2 then this.Daten = ""
	SubXML = New XML
	if SubXML = 0 then return 10
	this.SubTags &= Int2StrLE(cast(UInteger, SubXML), 4)
	SubXML->Parent = @this
	SubXML->Tag = Tag__
	SubXML->Daten = Daten__
	SubXML->Flags = IIf(Flags__ = 0, 1, Flags__)
	'FBedit Bug
	return 0
End Function

Function XML.SubTagRemove(ElemNr as Integer, Flag as UInteger = 0) as Integer
	if ElemNr >= this.SubTagCount(Flag) or ElemNr < 0 then return 0
	if Flag = 0 then
		Delete(Cast(XML ptr, Str2IntLE(mid(this.SubTags, ElemNr*4+1, 4))))
		this.SubTags = left(this.SubTags, ElemNr*4) & mid(this.SubTags, (ElemNr+1)*4+1)
		return 0
	EndIf
	Dim Anz as Integer = 0
	Dim SubXML as XML ptr
	For q as Integer = 0 to (len(this.SubTags)/4)-1
		SubXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if (SubXML->Flags and Flag) <> 0 then Anz += 1
		if ElemNr+1 = Anz then
			Delete(SubXML)
			this.SubTags = left(this.SubTags, q*4) & mid(this.SubTags, (q+1)*4+1)
			return 0
		EndIf
	Next
	return 0
End Function

Function XML.SubTagRemove(Tag as String, ElemNr as Integer = 0, Flag as UInteger = 0) as Integer
	if ElemNr >= this.SubTagCount(Flag) or ElemNr < 0 then return 0
	Dim Anz as Integer = 0
	Dim SubXML as XML ptr
	For q as Integer = 0 to (len(this.SubTags)/4)-1
		SubXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if (SubXML->Tag = Tag) and ((Flag = 0) OrElse ((SubXML->Flags and Flag) <> 0)) then Anz += 1
		if ElemNr+1 = Anz then
			Delete(SubXML)
			this.SubTags = left(this.SubTags, q*4) & mid(this.SubTags, (q+1)*4+1)
			return 0
		EndIf
	Next
	return 0
End Function

Function XML.SubTagClear(Flag as UInteger = 0) as Integer
	Dim SubXML as XML ptr
	for q as Integer = (len(this.SubTags)/4)-1 to 0 step -1
		SubXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if (Flag = 0) OrElse ((SubXML->Flags and Flag) <> 0) then
			Delete(SubXML)
			this.SubTags = left(this.SubTags, q*4) & mid(this.SubTags, (q+1)*4+1)
		EndIf
	Next
	return 0
End Function

Function XML.GetIndexOf(SubXML as XML ptr, Flag as UInteger = 0) as Integer
	Dim Anz as Integer = 0
	Dim TmpXML as XML ptr
	For q as Integer = 0 to (len(this.SubTags)/4)-1
		TmpXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if Flag = 0 OrElse (TmpXML->Flags and Flag) <> 0 then
			if TmpXML = SubXML then return Anz
			Anz += 1
		EndIf
	Next
	return -1
End Function

Function XML.SubTagChPos(SubXML as XML ptr, ElemPos as Integer, Flag as UInteger = 0) as Integer
	Dim Anz as Integer = 0
	Dim tmpPos as Integer = ElemPos
	if SubXML = 0 then return 1
	if tmpPos < 0 then tmpPos = 0
	if tmpPos > len(this.SubTags)/4 then tmpPos = len(this.SubTags)/4
	for q as Integer = 0 to len(this.SubTags)/4
		if q = len(this.SubTags)/4 then return 15
		if (Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4))) = SubXML) and (Flag = 0 OrElse ((Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))->Flags and Flag) <> 0)) then
			this.SubTags = left(this.SubTags, q*4) & mid(this.SubTags, (q+1)*4+1)
			exit for
		EndIf
	Next
	for q as Integer = 0 to len(this.SubTags)/4
		if ElemPos = Anz then
			this.SubTags = left(this.SubTags, q*4) & Int2StrLE(cast(UInteger,SubXML),4) & mid(this.SubTags, q*4+1)
			return 0
		EndIf
		if q = len(this.SubTags)/4 then return 1
		if Flag = 0 OrElse (Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))->Flags and Flag) <> 0 then Anz += 1
	Next
End Function

Function XML.ChPos(ElemPos as Integer, Flag as UInteger = 0) as Integer
	return this.Parent->SubTagChPos(@this, ElemPos, Flag)
End Function

Function XML.SubTagCountElem(Tag as String, Flag as UInteger = 0) as Integer
	Dim Anz as Integer = 0
	Dim SubXML as XML ptr
	For q as Integer = 0 to (len(this.SubTags)/4)-1
		SubXML = Cast(XML ptr, Str2IntLE(mid(this.SubTags, q*4+1, 4)))
		if SubXML->Tag = Tag and (Flag = 0 OrElse (SubXML->Flags and Flag) <> 0) then Anz += 1
	Next
	return Anz
End Function

