<% ' wxml.inc (C) 2010 Walter Bislin ' http://walter.bislins.ch/doku/wxml ' ' Dependencies: ' - perf.inc (CStream) ' - pattern.inc ' class CXmlTag public Name ' as string public TagList ' as array of CXmlTag public Value ' as string private mLastName private mLastIx private sub Class_Initialize() Name = "" TagList = Array() Value = "" mLastName = "" mLastIx = -1 end sub function TagsCount() TagsCount = UBound(TagList) + 1 end function function FindTag( aName ) dim i ' check cache first if aName = mLastName then FindTag = mLastIx exit function end if ' try next entry second if mLastIx < UBound(TagList) then if TagList(mLastIx+1).Name = aName then FindTag = mLastIx + 1 mLastIx = FindTag mLastName = aName exit function end if end if ' finally we must search the list from start for i = 0 to UBound(TagList) if TagList(i).Name = aName then FindTag = i mLastIx = i mLastName = aName exit function end if next FindTag = -1 end function function GetTagByName( aName ) dim i i = FindTag( aName ) if i >= 0 then set GetTagByName = TagList(i) else set GetTagByName = Nothing end if end function function NewTag( aName ) ' creates and adds a new tag with name aName and returns it ' return as CXmlTag set NewTag = NewXmlTag( aName ) AddTag NewTag end function sub AddValueTag( aName, aValue ) dim tag set tag = NewTag( aName ) tag.Value = aValue end sub sub Parse( aString ) dim p, s p = 1 ' remove comments s = ReplacePattern( aString, "<!--[^\x00]*-->", "", false ) ParseTagValue s, Len(s), p end sub sub ParseTagValue( aString, aLen, byRef aPos ) ' aPos points behind ">" of tag start or is 1 ' at aPos starts eather a list of tags or a string value (if next "<" is a tag end) dim pts, tag, p if aPos > aLen then exit sub pts = InStr( aPos, aString, "<" ) if pts = 0 or pts = aLen then ' unexpected end of data Value = UnmaskValue( Mid( aString, aPos, aLen-aPos+1 ) ) aPos = aLen + 1 exit sub end if ' pts points to "<" or "</" if Mid(aString,pts+1,1) = "/" then ' end of tag value Value = UnmaskValue( Mid( aString, aPos, pts-aPos ) ) aPos = pts exit sub end if ' loop over tag list p = pts do while p <= aLen set tag = new CXmlTag tag.ParseTag aString, aLen, p AddTag tag pts = InStr( p, aString, "<" ) if pts = 0 or pts = aLen then ' end of data aPos = aLen + 1 exit sub end if if Mid(aString,pts+1,1) = "/" then ' end of tag list aPos = pts exit sub end if ' one more tag p = pts loop aPos = p end sub sub ParseTag( aString, aLen, byRef aPos ) ' aPos must point to start of tag "<" ' sets aPos behind end of corr. tag ">" + 1 dim p, pte ' parse tag name p = aPos + 1 aPos = aLen+1 if p >= aLen then exit sub pte = InStr( p, aString, ">" ) if pte = 0 then exit sub Name = Mid( aString, p, pte-p ) aPos = pte + 1 ' parse tag value; aPos points behind ">" ParseTagValue aString, aLen, aPos ' skip tag end "</Name>"; aPos points to "<" of tag end if aPos > aLen then exit sub if InStr( aPos, aString, "</" ) <> aPos then exit sub p = InStr( aPos, aString, ">" ) if p = 0 then exit sub aPos = p + 1 end sub function Serialize() dim s set s = NewStream(0) SerializeToStream s, "" Serialize = s.GetString(false) end function sub SerializeToStream( aStream, aIndentStr ) ' aStream as CStrStream dim i if UBound(TagList) >= 0 then for i = 0 to UBound(TagList) aStream.Add vbCRLF TagList(i).SerializeTag aStream, aIndentStr next aStream.Add vbCRLF else aStream.Add MaskValue( Value ) end if end sub sub SerializeTag( aStream, aIndentStr ) ' aStream as CStrStream aStream.Add4 aIndentStr, "<", Name, ">" SerializeToStream aStream, aIndentStr & " " if UBound(TagList) >= 0 then aStream.Add4 aIndentStr, "</", Name, ">" else aStream.Add "</>" end if end sub sub AddTag( aTag ) ' aTag as CXmlTag dim sz sz = UBound(TagList) + 1 redim preserve TagList(sz) set TagList(sz) = aTag end sub private function MaskValue( aValue ) MaskValue = Replace( aValue, "&", "&" ) MaskValue = Replace( MaskValue, "<", "<" ) MaskValue = Replace( MaskValue, ">", ">" ) end function private function UnmaskValue( aString ) UnmaskValue = Replace( aString, ">", ">" ) UnmaskValue = Replace( UnmaskValue, "<", "<" ) UnmaskValue = Replace( UnmaskValue, "&", "&" ) end function ' some useful functions sub AddBool( aName, aBool ) dim name, val name = aName if name = "" then name = "bool" if aBool then val = "true" else val = "false" end if AddValueTag name, val end sub sub AddInt( aName, aInt ) dim name name = aName if name = "" then name = "int" AddValueTag name, CStr(aInt) end sub sub AddDate( aName, aDate ) dim name name = aName if name = "" then name = "date" AddValueTag name, CStr(aDate) end sub sub AddStr( aName, aStr ) dim name name = aName if name = "" then name = "str" AddValueTag name, aStr end sub function AddArray( aName, aSize ) ' returns CXmlTag dim name name = aName if name = "" then name = "array" set AddArray = NewXmlArrayTag( name, aSize ) AddTag AddArray end function sub AddStrArray( aName, aStrArray ) dim sz, arrayTag, i sz = UBound(aStrArray) set arrayTag = AddArray( aName, sz+1 ) for i = 0 to sz set arrayTag.TagList(i) = NewXmlValueTag( "str", aStrArray(i) ) next end sub function GetBool() GetBool = (Value = "true") end function function GetBoolByIx( aIx ) GetBoolByIx = TagList(aIx).GetBool() end function function GetBoolByName( aName, aDefVal ) dim tag GetBoolByName = aDefVal set tag = GetTagByName(aName) if not tag is Nothing then GetBoolByName = tag.GetBool() end function function GetInt() if IsNumeric(Value) then GetInt = CLng(Value) else GetInt = 0 end if end function function GetIntByIx( aIx ) GetIntByIx = TagList(aIx).GetInt() end function function GetIntByName( aName, aDefVal ) dim tag GetIntByName = aDefVal set tag = GetTagByName(aName) if not tag is Nothing then GetIntByName = tag.GetInt() end function function GetDate() if IsDate(Value) then GetDate = CDate(Value) else GetDate = CDate(0) end if end function function GetDateByIx( aIx ) GetDateByIx = TagList(aIx).GetDate() end function function GetDateByName( aName, aDefVal ) dim tag GetDateByName = aDefVal set tag = GetTagByName(aName) if not tag is Nothing then GetDateByName = tag.GetDate() end function function GetStr() GetStr = Value end function function GetStrByIx( aIx ) GetStrByIx = TagList(aIx).GetStr() end function function GetStrByName( aName, aDefVal ) dim tag GetStrByName = aDefVal set tag = GetTagByName(aName) if not tag is Nothing then GetStrByName = tag.GetStr() end function function GetArray() dim arrRet arrRet = Array() if UBound(TagList) >= 0 then redim arrRet( UBound(TagList) ) end if GetArray = arrRet end function function GetArrayByIx( aIx ) GetArrayByIx = TagList(aIx).GetArray() end function function GetArrayByName( aName ) dim tag set tag = GetTagByName(aName) if not tag is Nothing then GetArrayByName = tag.GetArray() else GetArrayByName = Array() end if end function function GetStrArray() dim arrRet, i arrRet = GetArray() for i = 0 to UBound(arrRet) arrRet(i) = GetStrByIx(i) next GetStrArray = arrRet end function function GetStrArrayByIx( aIx ) GetStrArrayByIx = TagList(aIx).GetStrArray() end function function GetStrArrayByName( aName ) dim tag set tag = GetTagByName(aName) if not tag is Nothing then GetStrArrayByName = tag.GetStrArray() else GetStrArrayByName = Array() end if end function end class function NewXmlTag( aName ) set NewXmlTag = new CXmlTag NewXmlTag.Name = aName end function function NewXmlValueTag( aName, aValue ) set NewXmlValueTag = new CXmlTag NewXmlValueTag.Name = aName NewXmlValueTag.Value = aValue end function function NewXmlArrayTag( aName, aSize ) dim tl set NewXmlArrayTag = new CXmlTag NewXmlArrayTag.Name = aName if aSize > 0 then redim tl( aSize-1 ) NewXmlArrayTag.TagList = tl end if end function %>