Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Tabelle.bi
| Uploader: |  XOR |
| Datum/Zeit: | 16.05.2011 23:43:11 |
Type _TABELLENITEM As TABELLENITEM
#Define TABELLE_CASE &H01
#Define TABELLE_NULL Cast(Any Ptr,0)
Type TABELLE
Declare Constructor ()
Declare Constructor ( ByVal As UInteger )
Declare Constructor ( ByVal As String )
Declare Constructor ( ByVal As UInteger, ByVal As String )
Declare Function AddItem ( ByVal As String ) As _TABELLENITEM Ptr
Declare Function GetItem ( ByVal As String ) As _TABELLENITEM Ptr
Declare Function GetItem ( ByVal As UInteger ) As _TABELLENITEM Ptr
Declare Sub DestroyItem ( ByVal As String )
Declare Sub DestroyItem ( ByVal As UInteger )
Declare Sub Destroy ()
Declare Property Item ( ByVal As String, ByVal As String )
Declare Property Item ( ByVal As String, ByVal As Integer )
Declare Property Item ( ByVal As String, ByVal As Double )
Declare Property Item ( ByVal As String, ByVal As Any Ptr )
Declare Property Item ( ByVal As String, ByVal As TABELLE )
Declare Property ItemS ( ByVal As String ) As String
Declare Property ItemI ( ByVal As String ) As Integer
Declare Property ItemD ( ByVal As String ) As Double
Declare Property ItemP ( ByVal As String ) As Any Ptr
Declare Function ItemU ( ByVal As String ) As Any Ptr
Declare Property ItemT ( ByVal As String ) As TABELLE
Declare Property ItemS ( ByVal As String, ByVal As String )
Declare Property ItemI ( ByVal As String, ByVal As Integer )
Declare Property ItemD ( ByVal As String, ByVal As Double )
Declare Property ItemP ( ByVal As String, ByVal As Any Ptr )
Declare Sub ItemU ( ByVal As String, ByVal As Any Ptr, ByVal As UInteger )
#Define SetUDT(__S__,__UDT__) ItemU ( __S__ , @__UDT__ , SizeOf(__UDT__))
Declare Property ItemT ( ByVal As String, ByVal As TABELLE )
Declare Function ItemType ( ByVal As String ) As UInteger
Declare Function ExistItem ( ByVal As String ) As Integer
Declare Sub Copy ( ByVal As TABELLE )
Private:
ChildZ As ZString Ptr
Caseintensiv:16 As Integer
NumItem As UInteger
PItem As _TABELLENITEM Ptr
End Type
#Define ITEM_STRING &H01
#Define ITEM_INTEGER &H02
#Define ITEM_DOUBLE &H03
#Define ITEM_POINTER &H04
#Define ITEM_UDT &H05
#Define ITEM_TABELLE &H06
Type TABELLENITEM
Declare Sub SetName ( ByVal As String )
Declare Sub SetVal0 ()
Declare Sub SetValS ( ByVal As String )
Declare Sub SetValI ( ByVal As Integer )
Declare Sub SetValD ( ByVal As Double )
Declare Sub SetValP ( ByVal As Any Ptr )
Declare Sub __SetValU ( ByVal As Any Ptr, ByVal As UInteger )
#Define SetValU ( __UDT__ ) __SetValU ( @__UDT__ , SizeOf(__UDT__) )
Declare Sub SetValT ( ByVal As TABELLE )
Declare Sub __SetValT ( ByVal As TABELLE )
Declare Function SetNext ( ByVal As TABELLENITEM Ptr ) As TABELLENITEM Ptr
Declare Function GetName () As String
Declare Function GetType () As UInteger
Declare Function GetValS () As String
Declare Function GetValI () As Integer
Declare Function GetValD () As Double
Declare Function GetValP () As Any Ptr
Declare Function GetValU () As Any Ptr
Declare Function GetValUDTSize () As UInteger
Declare Function GetValT () As TABELLE
Declare Function GetValSP () As ZString Ptr
Declare Function GetValIP () As Integer Ptr
Declare Function GetValDP () As Double Ptr
Declare Function GetValPP () As Any Ptr Ptr
Declare Function GetValUP () As Any Ptr
Declare Function GetValTP () As TABELLE Ptr
Declare Function GetNext () As TABELLENITEM Ptr
Declare Function Destroy () As TABELLENITEM Ptr
Declare Function GetTType () As UInteger
Private:
NName As ZString Ptr
TType As UInteger
Union
Stri As ZString Ptr
Inte As Integer Ptr
Doub As Double Ptr
Poin As Any Ptr Ptr
UDT As Any Ptr
Tabe As TABELLE Ptr
End Union
NNext As TABELLENITEM Ptr
End Type
Constructor TABELLE ()
This.ChildZ = Allocate(Len(".")+1)
*This.ChildZ = "."
This.Caseintensiv = 1
End Constructor
Constructor TABELLE ( ByVal ST As UInteger )
This.ChildZ = Allocate(Len(".")+1)
*This.ChildZ = "."
If (ST And TABELLE_CASE) Then
This.Caseintensiv = 0
Else
This.Caseintensiv = 1
EndIf
End Constructor
Constructor TABELLE ( ByVal S As String )
If S = "" Then S = "."
This.ChildZ = Allocate(Len(S)+1)
*This.ChildZ = S
This.Caseintensiv = 1
End Constructor
Constructor TABELLE ( ByVal ST As UInteger, ByVal S As String )
If S = "" Then S = "."
This.ChildZ = Allocate(Len(S)+1)
*This.ChildZ = S
If (ST And TABELLE_CASE) Then
This.Caseintensiv = 0
Else
This.Caseintensiv = 1
EndIf
End Constructor
Function TABELLE.AddItem ( ByVal S As String ) As _TABELLENITEM Ptr
Dim As String S1,F1,F2
Dim As Integer P
P = InStr(S,*This.ChildZ)
F1 = Mid(S,1,P-1)
F2 = Mid(S,P+1)
Dim L As TABELLENITEM Ptr
L = This.GetItem ( F1 )
If L = 0 Then
L = Allocate(SizeOf(TABELLENITEM))
For i As Integer = 0 To SizeOf(TABELLENITEM)-1
Cast(UByte Ptr,L)[i] = 0
Next
L->SetName(F1)
L->SetNext(This.PItem)
This.PItem = L
EndIf
If P <> 0 Then
If L->GetValTP = 0 Then
Dim T As TABELLE
T = TABELLE(IIf(This.Caseintensiv,0,TABELLE_CASE),*This.ChildZ)
Function = T.AddItem(F2)
L->SetValT(T)
Exit Function
Else
Dim T As TABELLE
T = L->GetValT()
Function = T.AddItem(F2)
L->__SetValT(T)
Exit Function
EndIf
EndIf
Return L
End Function
Function TABELLE.GetItem ( ByVal S As String ) As _TABELLENITEM Ptr
Dim As String S1,F1,F2
Dim As Integer P
P = InStr(S,*This.ChildZ)
F1 = Mid(S,1,P-1)
F2 = Mid(S,P+1)
If This.Caseintensiv Then
F1 = LCase(F1)
EndIf
Dim L As TABELLENITEM Ptr
L = This.PItem
Do Until L = 0
S1 = L->GetName
If This.Caseintensiv Then
S1 = LCase(S1)
EndIf
If F1 = S1 Then
If P = 0 Then
Return L
Else
Return L->GetValT.GetItem(F2)
EndIf
EndIf
L = L->GetNext
Loop
Return 0
End Function
Function TABELLE.GetItem ( ByVal I As UInteger ) As _TABELLENITEM Ptr
Dim L As TABELLENITEM Ptr
L = This.PItem
If I < 1 Then Return 0
If I = 1 Then Return This.PItem
For in As UInteger = 2 To I
If L = 0 Then Return 0
L = L->GetNext
Next
Return L
End Function
Sub TABELLE.DestroyItem ( ByVal S As String )
Dim As String S1,F1,F2
Dim As Integer P
P = InStr(S,*This.ChildZ)
F1 = Mid(S,1,P-1)
F2 = Mid(S,P+1)
If This.Caseintensiv Then
F1 = LCase(F1)
EndIf
Dim as TABELLENITEM Ptr L,LS
L = This.PItem
LS = 0
Do Until L = 0
S1 = L->GetName
If This.Caseintensiv Then
S1 = LCase(S1)
EndIf
If F1 = S1 Then
If P = 0 Then
If LS = 0 Then
This.PItem = L->Destroy
Else
LS->SetNext(L->Destroy)
EndIf
DeAllocate(L)
Else
L->GetValT.DestroyItem(F2)
EndIf
EndIf
LS = L
L = LS->GetNext
Loop
End Sub
Sub TABELLE.DestroyItem ( ByVal I As UInteger )
Dim as TABELLENITEM Ptr L,LS
L = This.PItem
If L = 0 Then Exit Sub
If I = 1 Then
This.PItem = L->Destroy()
DeAllocate(L)
Exit Sub
EndIf
For im As Integer = 2 To I
LS = L
L = L->GetNext()
If L = 0 Then Exit Sub
Next
LS->SetNext(L->Destroy)
DeAllocate(L)
End Sub
Sub TABELLE.Destroy ()
Do Until This.PItem = 0
This.DestroyItem(1)
Loop
This.PItem = 0
This.NumItem = 0
If This.ChildZ<>0 Then DeAllocate(This.ChildZ)
This.ChildZ = 0
End Sub
Property TABELLE.Item ( ByVal S As String, ByVal ST As String )
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then T = This.AddItem ( S )
T->SetValS ( ST )
End Property
Property TABELLE.Item ( ByVal S As String, ByVal I As Integer )
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then T = This.AddItem ( S )
T->SetValI ( I )
End Property
Property TABELLE.Item ( ByVal S As String, ByVal D As Double )
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then T = This.AddItem ( S )
T->SetValD ( D )
End Property
Property TABELLE.Item ( ByVal S As String, ByVal P As Any Ptr )
If P = 0 Then
This.DestroyItem ( S )
Exit Property
EndIf
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then T = This.AddItem ( S )
T->SetValP ( P )
End Property
Property TABELLE.Item ( ByVal S As String, ByVal Ta As TABELLE )
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then T = This.AddItem ( S )
T->SetValT ( Ta )
End Property
Property TABELLE.ItemS ( ByVal S As String ) As String
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return ""
Return T->GetValS ()
End Property
Property TABELLE.ItemI ( ByVal S As String ) As Integer
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return 0
Return T->GetValI ()
End Property
Property TABELLE.ItemD ( ByVal S As String ) As Double
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return 0
Return T->GetValD ()
End Property
Property TABELLE.ItemP ( ByVal S As String ) As Any Ptr
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return 0
Return T->GetValP ()
End Property
Function TABELLE.ItemU ( ByVal S As String ) As Any Ptr
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return 0
Return T->GetValU ()
End Function
Property TABELLE.ItemT ( ByVal S As String ) As TABELLE
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return TABELLE()
Return T->GetValT ()
End Property
Property TABELLE.ItemS ( ByVal S As String, ByVal St As String )
This.Item(S)=St
End Property
Property TABELLE.ItemI ( ByVal S As String, ByVal I As Integer )
This.Item(S)=I
End Property
Property TABELLE.ItemD ( ByVal S As String, ByVal D As Double )
This.Item(S)=D
End Property
Property TABELLE.ItemP ( ByVal S As String, ByVal P As Any Ptr )
This.Item(S)=P
End Property
Sub TABELLE.ItemU ( ByVal S As String, ByVal U As Any Ptr, ByVal L As UInteger )
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then T = This.AddItem ( S )
T->__SetValU ( U,L )
End Sub
Property TABELLE.ItemT ( ByVal S As String, ByVal T As TABELLE )
This.Item(S)=T
End Property
Function TABELLE.ItemType ( ByVal S As String ) As UInteger
Dim T As TABELLENITEM Ptr
T = This.GetItem ( S )
If T = 0 Then Return 0
Return T->GetTType
End Function
Function TABELLE.ExistItem ( ByVal S As String ) As Integer
If This.GetItem ( S ) = 0 Then Return 0
Return -1
End Function
Sub TABELLE.Copy ( ByVal T As TABELLE )
Type TK
ChildZ As ZString Ptr
SaveType:16 As Integer
Caseintensiv:16 As Integer
NumItem As UInteger
PItem As TABELLENITEM Ptr
End Type
Dim TTK As TK Ptr
TTK = Cast(TK Ptr,@T)
This.Destroy()
This.ChildZ = Allocate(Len(*TTK->ChildZ)+1)
*This.ChildZ = *TTK->ChildZ
This.Caseintensiv = TTK->Caseintensiv
Select Case TTK->SaveType
Case 0
Dim Ta As TABELLENITEM Ptr
Dim num As Integer = 1
This.NumItem = 0
This.PItem = 0
If TTK->PItem = 0 Then
Exit Sub
EndIf
Ta = T.GetItem(num)
Do
Select Case Ta->GetType
Case ITEM_STRING
This.Item(Ta->GetName)=Ta->GetValS
Case ITEM_INTEGER
This.Item(Ta->GetName)=Ta->GetValI
Case ITEM_DOUBLE
This.Item(Ta->GetName)=Ta->GetValD
Case ITEM_POINTER
This.Item(Ta->GetName)=Ta->GetValP
Case ITEM_UDT
This.ItemU(Ta->GetName,Ta->GetValU,Ta->GetValUDTSize)
Case ITEM_TABELLE
Dim Tabe As TABELLE
Tabe.Copy(Ta->GetValT)
This.Item(Ta->GetName)=Tabe
End Select
num += 1
Ta = T.GetItem(num)
Loop Until Ta = 0
Case 1
This.NumItem = TTK->NumItem
If This.NumItem = 0 Then
This.PItem = 0
Exit Sub
EndIf
This.PItem = Allocate(SizeOf(TABELLENITEM)*This.NumItem)
For i As UInteger = 0 To SizeOf(TABELLENITEM)*This.NumItem-1
Cast(UByte Ptr,This.PItem)[i] = 0
Next
For i As UInteger = 0 To This.NumItem-1
This.PItem[i].SetName(TTK->PItem[i].GetName)
Select Case TTK->PItem[i].GetType
Case ITEM_STRING
This.PItem[i].SetValS(TTK->PItem[i].GetValS)
Case ITEM_INTEGER
This.PItem[i].SetValI(TTK->PItem[i].GetValI)
Case ITEM_DOUBLE
This.PItem[i].SetValD(TTK->PItem[i].GetValD)
Case ITEM_POINTER
This.PItem[i].SetValP(TTK->PItem[i].GetValP)
Case ITEM_UDT
This.PItem[i].__SetValU(TTK->PItem[i].GetValU,TTK->PItem[i].GetValUDTSize)
Case ITEM_TABELLE
Dim Tabe As TABELLE
Tabe.Copy(TTK->PItem[i].GetValT)
This.PItem[i].SetValT(Tabe)
End Select
Next
End Select
End Sub
Sub TABELLENITEM.SetName ( ByVal Neu As String )
If This.NName <> 0 Then DeAllocate(This.NName)
This.NName = Allocate(Len(Neu)+1)
*This.NName = Neu
End Sub
Sub TABELLENITEM.SetVal0 ()
Select Case This.TType
Case ITEM_STRING
If This.Stri <> 0 Then DeAllocate(This.Stri)
This.Stri = 0
This.TType = 0
Case ITEM_INTEGER
If This.Inte <> 0 Then DeAllocate(This.Inte)
This.Inte = 0
This.TType = 0
Case ITEM_DOUBLE
If This.Doub <> 0 Then DeAllocate(This.Doub)
This.Doub = 0
This.TType = 0
Case ITEM_POINTER
If This.Poin <> 0 Then DeAllocate(This.Poin)
This.Poin = 0
This.TType = 0
Case ITEM_UDT
If This.UDT <> 0 Then DeAllocate(This.UDT)
This.UDT = 0
This.TType = 0
Case ITEM_TABELLE
If This.Tabe <> 0 Then
This.Tabe->Destroy ()
DeAllocate(This.Tabe)
EndIf
This.Tabe = 0
This.TType = 0
End Select
End Sub
Sub TABELLENITEM.SetValS ( ByVal Stri As String )
This.SetVal0 ()
This.TType = ITEM_STRING
This.Stri = Allocate(Len(Stri)+1)
*This.Stri = Stri
End Sub
Sub TABELLENITEM.SetValI ( ByVal Inte As Integer )
This.SetVal0 ()
This.TType = ITEM_INTEGER
This.Inte = Allocate(SizeOf(Integer))
*This.Inte = Inte
End Sub
Sub TABELLENITEM.SetValD ( ByVal Doub As Double )
This.SetVal0 ()
This.TType = ITEM_DOUBLE
This.Doub = Allocate(SizeOf(Double))
*This.Doub = Doub
End Sub
Sub TABELLENITEM.SetValP ( ByVal Poin As Any Ptr )
This.SetVal0 ()
This.TType = ITEM_POINTER
This.Poin = Allocate(SizeOf(Any Ptr))
*This.Poin = Poin
End Sub
Sub TABELLENITEM.__SetValU ( ByVal UDT As Any Ptr, ByVal Leng As UInteger )
This.SetVal0 ()
This.TType = ITEM_UDT
If Leng = 0 Then
This.UDT = 0
Exit Sub
EndIf
This.UDT = Allocate(Leng+4)
*Cast(UInteger Ptr,This.UDT) = Leng
For i As UInteger = 4 To Leng +3
Cast(UByte Ptr,This.UDT)[i] = Cast(UByte Ptr,UDT)[i-4]
Next
End Sub
Sub TABELLENITEM.SetValT ( ByVal Tabe As TABELLE )
This.SetVal0 ()
This.TType = ITEM_TABELLE
This.Tabe = Allocate(SizeOf(TABELLE))
*This.Tabe = Tabe
End Sub
Sub TABELLENITEM.__SetValT ( ByVal Tabe As TABELLE )
*This.Tabe = Tabe
End Sub
Function TABELLENITEM.SetNext ( ByVal Item As TABELLENITEM Ptr ) As TABELLENITEM Ptr
Function = This.NNext
This.NNext = Item
End Function
Function TABELLENITEM.GetName () As String
Return *This.NName
End Function
Function TABELLENITEM.GetType () As UInteger
Return This.TType
End Function
Function TABELLENITEM.GetValS () As String
Select Case This.TType
Case ITEM_STRING
Return *This.Stri
Case ITEM_INTEGER
Return Str(*This.Inte)
Case ITEM_DOUBLE
Return Str(*This.Doub)
Case ITEM_POINTER
Return Str(*This.Poin)
Case ITEM_UDT
Return Str(This.UDT)
Case ITEM_TABELLE
Return ""
End Select
End Function
Function TABELLENITEM.GetValI () As Integer
Select Case This.TType
Case ITEM_STRING
Return Val(*This.Stri)
Case ITEM_INTEGER
Return *This.Inte
Case ITEM_DOUBLE
Return *This.Doub
Case ITEM_POINTER
Return 0
Case ITEM_UDT
Return 0
Case ITEM_TABELLE
Return 0
End Select
End Function
Function TABELLENITEM.GetValD () As Double
Select Case This.TType
Case ITEM_STRING
Return Val(*This.Stri)
Case ITEM_INTEGER
Return *This.Inte
Case ITEM_DOUBLE
Return *This.Doub
Case ITEM_POINTER
Return 0
Case ITEM_UDT
Return 0
Case ITEM_TABELLE
Return 0
End Select
End Function
Function TABELLENITEM.GetValP () As Any Ptr
Select Case This.TType
Case ITEM_STRING
Return 0
Case ITEM_INTEGER
Return 0
Case ITEM_DOUBLE
Return 0
Case ITEM_POINTER
Return *This.Poin
Case ITEM_UDT
Return 0
Case ITEM_TABELLE
Return 0
End Select
End Function
Function TABELLENITEM.GetValU () As Any Ptr
Select Case This.TType
Case ITEM_STRING
Return 0
Case ITEM_INTEGER
Return 0
Case ITEM_DOUBLE
Return 0
Case ITEM_POINTER
Return 0
Case ITEM_UDT
Return This.UDT+4
Case ITEM_TABELLE
Return 0
End Select
End Function
Function TABELLENITEM.GetValUDTSize () As UInteger
Select Case This.TType
Case ITEM_STRING
Return 0
Case ITEM_INTEGER
Return 0
Case ITEM_DOUBLE
Return 0
Case ITEM_POINTER
Return 0
Case ITEM_UDT
Return *Cast(UInteger Ptr,This.UDT)
Case ITEM_TABELLE
Return 0
End Select
End Function
Function TABELLENITEM.GetValT () As TABELLE
Dim T_Null As TABELLE
Select Case This.TType
Case ITEM_STRING
Return T_Null
Case ITEM_INTEGER
Return T_Null
Case ITEM_DOUBLE
Return T_Null
Case ITEM_POINTER
Return T_Null
Case ITEM_UDT
Return T_Null
Case ITEM_TABELLE
Return *This.Tabe
End Select
End Function
Function TABELLENITEM.GetValSP () As ZString Ptr
If This.TType = ITEM_STRING Then Return This.Stri
Return 0
End Function
Function TABELLENITEM.GetValIP () As Integer Ptr
If This.TType = ITEM_INTEGER Then Return This.Inte
Return 0
End Function
Function TABELLENITEM.GetValDP () As Double Ptr
If This.TType = ITEM_DOUBLE Then Return This.Doub
Return 0
End Function
Function TABELLENITEM.GetValPP () As Any Ptr Ptr
If This.TType = ITEM_POINTER Then Return This.Poin
Return 0
End Function
Function TABELLENITEM.GetValUP () As Any Ptr
If This.TType = ITEM_UDT Then Return This.UDT+4
Return 0
End Function
Function TABELLENITEM.GetValTP () As TABELLE Ptr
If This.TType = ITEM_TABELLE Then Return This.Tabe
Return 0
End Function
Function TABELLENITEM.GetNext () As TABELLENITEM Ptr
Return This.NNext
End Function
Function TABELLENITEM.Destroy () As TABELLENITEM Ptr
This.SetVal0 ()
If This.NName <> 0 Then DeAllocate(This.NName)
This.NName = 0
Return This.NNext
End Function
Function TABELLENITEM.GetTType () As UInteger
Return This.TType
End Function