If nothing else, this might be interesting. The array exists entirely inside a host string. May be stored and passed as a string. Array remains intact for life of host string. Doesn't need to be freed, just a string. Must be passed ByRef to stay current. Elements in array may be other hosted in-string arrays. This has limitation due to string overhead, but fast for light use. Public domain, use at own risk. SDurham
Source: Powerbasic-Forum (https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/824221-pbwin-pbcc-in-string-string-array)
' In-String String & WString Array
' CSV on steroids.
' Not for heavy use.
' ((( The array exist entirely inside host string. )))
' May be passed or stored anywhere, remains intact for life of host string.
' store in file, database, another string container, ...
' No ReDim(), just set, get, add, insert and delete.
' To reset or erase array, container$ = "".
' Doesn't need to be freed, it's just a string.
' Needs to be passed ByRef to stay current.
' A copy of the host string is a new instance.
' The original can be updated from a copy, original = copy.
' Host string protected with hash tag.
' Should be limited to a few thousand strings.
' add 1,000 random strings to empty arra = 0.000 seconds
' set 1,000 values = 0.000 seconds
' get 1,000 from array of 1,000 value = 0.014 seconds
' add 2,000 random strings to empty array = 0.000 seconds
' set 2,000 values = 0.023 seconds
' get 2,000 from array of 2,000 values = 0.055 seconds
' add 5,000 random strings to empty array = 0.028 seconds
' set 5,000 values = 0.297 seconds
' get 5,000 from array of 5,000 values = 0.453 seconds
' add 10,000 random strings to empty array = 0.054 seconds
' set 10,000 values = 0.846 seconds
' get 10,000 from array of 10,000 values = 1.447 seconds
' add 20,000 random strings to empty array = 0.158 seconds
' set 20,000 values = 3.431 seconds
' get 20,000 from array of 20,000 values = 5.842 seconds
' add 30,000 random strings to empty array = 0.270 seconds
' set 30,000 values = 7.165 seconds
' get 30,000 from array of 30,000 values = 12.556 seconds
' about 5,000 to 10,000 limit for small strings
' less for large strings
#If Not %Def(%HostedStringArray230304)
%HostedStringArray230304 = 1
%HostedStringArrayTag = -1622479746
' String Array Stored in String
' Memory allocation is just a string.
' public domain, use at own risk
' SDurham
Function SarrCount(container$) ThreadSafe As Long
' get item count
If Len(container$) And Peek(Long, StrPtr(container$)) = %HostedStringArrayTag Then Function = Peek(Long, StrPtr(container$) + 4)
End Function
Sub SarrAdd(container$, ByVal value As String) ThreadSafe
' append value to end of array
Local itemCount&
itemCount& = SarrCount(container$)
If itemCount& = 0 Then
container$ = Mkl$(%HostedStringArrayTag) + Mkl$(1) + Mkl$(Len(value)) + value
Else
container$ += Mkl$(Len(value)) + value
Poke Long, StrPtr(container$) + 4, itemCount& + 1
End If
End Sub
Function SarrGet(container$, ByVal index As Long) ThreadSafe As String
' get value at one-based index
Local itemCount&, itemCounter&
Local p As Long Ptr
itemCount& = SarrCount(container$)
If index > 0 And index <= itemCount& Then
itemCounter& = 0
p = StrPtr(container$) + 8
While itemCounter& < index - 1
Incr itemCounter&
p += 4 + @p
Wend
Function = Peek$(p + 4, @p)
End If
End Function
Sub SarrSet(container$, ByVal index As Long, ByVal value As String) ThreadSafe
' set value at one-based index
Local itemCount&, bytes&, itemCounter&
Local p As Long Ptr
itemCount& = SarrCount(container$)
If index > 0 And index <= itemCount& Then
itemCounter& = 0
bytes& = 8
p = StrPtr(container$) + 8
While itemCounter& < index - 1
Incr itemCounter&
bytes& += 4 + @p
p += 4 + @p
Wend
container$ = Left$(container$, bytes&) + Mkl$(Len(value)) + value + Mid$(container$, bytes& + 1 + 4 + @p)
End If
End Sub
Sub SarrInsert(container$, ByVal index As Long, ByVal value As String) ThreadSafe
' insert value at one-based index
Local itemCount&, bytes&, itemCounter&
Local p As Long Ptr
itemCount& = SarrCount(container$)
If index > 0 And index <= itemCount& Then
itemCounter& = 0
bytes& = 8
p = StrPtr(container$) + 8
While itemCounter& < index - 1
Incr itemCounter&
bytes& += 4 + @p
p += 4 + @p
Wend
container$ = Left$(container$, bytes&) + Mkl$(Len(value)) + value + Mid$(container$, bytes& + 1)
Poke Long, StrPtr(container$) + 4, itemCount& + 1
End If
End Sub
Sub SarrDelete(container$, ByVal index As Long) ThreadSafe
' delete value at one-based index
Local itemCount&, bytes&, itemCounter&
Local p As Long Ptr
itemCount& = SarrCount(container$)
If Len(container$) And index > 0 And index <= itemCount& Then
itemCounter& = 0
bytes& = 8
p = StrPtr(container$) + 8
While itemCounter& < index - 1
Incr itemCounter&
bytes& += 4 + @p
p += 4 + @p
Wend
container$ = Left$(container$, bytes&) + Mid$(container$, bytes& + 1 + 4 + @p)
Poke Long, StrPtr(container$) + 4, itemCount& - 1
End If
End Sub
#EndIf '%HostedStringArray230304
#If Not %Def(%HostedWStringArray230304)
%HostedWStringArray230304 = 1
' String Array Stored in String
' Memory allocation is just a string.
' public domain, use at own risk
' SDurham
Function WarrCount(container$) ThreadSafe As Long
' get item count
Function = SarrCount(container$)
End Function
Sub WarrAdd(container$, ByVal value As WString) ThreadSafe
' append value to end of array
SarrAdd container$, ChrToUtf8$(value)
End Sub
Function WarrGet(container$, ByVal index As Long) ThreadSafe As WString
' get value at one-based index
Function = Utf8ToChr$(SarrGet(container$, index))
End Function
Sub WarrSet(container$, ByVal index As Long, ByVal value As WString) ThreadSafe
' set value at one-based index
SarrSet container$, index, ChrToUtf8$(value)
End Sub
Sub WarrInsert(container$, ByVal index As Long, ByVal value As WString) ThreadSafe
' insert value at one-based index
SarrInsert container$, index, ChrToUtf8$(value)
End Sub
Sub WarrDelete(container$, ByVal index As Long) ThreadSafe
' delete value at one-based index
SarrDelete container$, index
End Sub
#EndIf '%HostedWStringArray230304
�
[size=4]Test-Code:[/size]
[code]
#Option LargeMem32
#Compile Exe
#Dim All
#Include Once "..\Hosted String Array.inc"
%TestCount = 1000
Function PBMain() As Long
Register i As Long
Local h&, outFile$, hprocess&
h& = FreeFile
outFile$ = Exe.Path$ + Exe.Name$ + ".txt"
Kill outFile$
Open outFile$ For Append As h&
Local arr$
Local a() As String
Local d As Double
Randomize
ReDim a(1 To %TestCount)
For i = 1 To %TestCount
a(i) = Format$(Rnd(1, 99999999))
Next i
Print# h&, ""
Print# h&, "Sub SarrAdd(container$, ByVal value As String) ThreadSafe"
Print# h&, " append value to end of array"
Print# h&, " add 5 values "
SarrAdd arr$, "AA"
SarrAdd arr$, "BB"
SarrAdd arr$, "CC"
SarrAdd arr$, "DD"
SarrAdd arr$, "EE"
SarrAdd arr$, "FF"
Print# h&, "--- Display Array ---"
For i = 1 To SarrCount(arr$)
Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
Next i
Print# h&, ""
Print# h&, "Function SarrGet(container$, ByVal index As Long) ThreadSafe As String"
Print# h&, " get value at one-based index"
Print# h&, "Sub SarrSet(container$, ByVal index As Long, ByVal value As String) ThreadSafe"
Print# h&, " set value at one-based index"
Print# h&, " Get/Set values"
For i = 1 To SarrCount(arr$)
SarrSet arr$, i, Left$(SarrGet(arr$, i), 1)
Next i
Print# h&, "--- Display Array ---"
For i = 1 To SarrCount(arr$)
Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
Next i
Print# h&, ""
Print# h&, "Sub SarrInsert(container$, ByVal index As Long, ByVal value As String) ThreadSafe"
Print# h&, " insert value at one-based index"
Print# h&, " insert value at index 1"
SarrInsert arr$, 2, "String inserted at index 2"
Print# h&, "--- Display Array ---"
For i = 1 To SarrCount(arr$)
Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
Next i
Print# h&, ""
Print# h&, "Sub SarrDelete(container$, ByVal index As Long) ThreadSafe"
Print# h&, " delete value at one-based index"
Print# h&, " delete value at index 2"
SarrDelete arr$, 2
Print# h&, "--- Display Array ---"
For i = 1 To SarrCount(arr$)
Print# h&, "index "+Format$(i)+" = " + $Dq + SarrGet(arr$, i) + $Dq
Next i
Print# h&, ""
Print# h&, ""
Print# h&, ""
Print# h&, "clear array"
arr$ = ""
Print# h&, "add "+Format$(%TestCount, "#,")+" random strings to empty array"
d = Timer
For i = 1 To %TestCount
SarrAdd arr$, a(i)
Next i
Print# h&, "Time = " + Format$(Timer - d, "000.000")
Print# h&, ""
Print# h&, "set "+Format$(%TestCount, "#,")+" values"
For i = 1 To %TestCount
SarrSet arr$, i, a(i)
Next i
Print# h&, "Time = " + Format$(Timer - d, "000.000")
Print# h&, ""
Print# h&, "get "+Format$(%TestCount, "#,")+" from array of "+Format$(%TestCount, "#,")+" values"
For i = 1 To %TestCount
If SarrGet(arr$, i) <> a(i) Then
? "SarrGet() fail" : Exit For
End If
Next i
Print# h&, "Time = " + Format$(Timer - d, "000.000")
Print# h&, ""
Print# h&, ""
Close h&
Sleep 1
hprocess& = Shell("notepad.exe " + outFile$, 1)
End Function�
[/code]