PBWin/PBCC FStr16.inc, File Based: Dynamic String Storage

[Stanley Durham]

comments
Uses: FileMap2.inc and FileMemMang2.inc

Allows dynamic string storage in a file.
Stored strings accessed with a handle.

Strings can be any length, nulls OK.

FileMemMang takes care of storage, getting and recovering file space is string deleted.

'  PB 5/9
' FStr16.inc
    '
    '   File Based: Dynamic String Storage Manager
    '
    '   - uses File Mapping for fast file In/Out
    '
    '   - unlimited strings
    '   - unlimited string length
    '   - any kind of data - nulls OK
    '
    '   handle returned when string stored
    '   use handle to retrieve OR remove string
    '
    '   requires UDT File Memory Manager
    '       used to manage file storage
    '
#Include Once "C:\PB9\FileMapping\FileMemMang2.inc"
'
$FStr16_Err_ModuleNotInitiated = "FStr16: module not initiated"
$FStr16_Err_FileNotOpen = "FStr16: file not open"
$FStr16_Err_NullString = "FStr16: null strings not stored"
$FStr16_Err_NullHandle = "FStr16: null string handle"
$FStr16_Err_NullPointer = "FStr16: null pointer"
$FStr16_Err_MemAllocFailed = "FStr16: file memory allocation failed"
'
Macro FStr16_ExitFalse(test, procedure, msg)
    If test Then
    Else
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        Exit procedure
    End If
End Macro
Macro FStr16_ExitTrue(test, procedure, msg)
    If test Then
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        Exit procedure
    End If
End Macro
Macro FStr16_GoFalse(test, MARKER, msg)
    If test Then
    Else
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        GoTo MARKER
    End If
End Macro
Macro FStr16_GoTrue(test, MARKER, msg)
    If test Then
        #Debug Print FuncName$ +": "+ msg
        t.isErr = %TRUE
        t.errMsg = msg
        GoTo MARKER
    End If
End Macro
'
'
%FStr16StrSize = 16
%FStr16FirstSize = 24
%FStr16NextSize = 20
'
Type FStr16FirstT 'first string segment
    Next As Long
    str As String * %FStr16StrSize
    Count As Long 'string len
End Type
Type FStr16NextT 'subsequent string segments
    Next As Long
    str As String * %FStr16StrSize
End Type
Type FStr16T
    pMem As FMemT Ptr
    isErr As Long
    errMsg As Asciiz * 256
End Type
'
'
Sub FStr16_Initiate(t As FStr16T, FileMemManager As FMemT)
    'File Memory Manager must be set before use
    '   File Memory Manager must have an open file before use
    '       all file In/Out handled by File Memory Manager
    t.isErr = %FALSE
    t.pMem = VarPtr(FileMemManager)
End Sub
'
Function FStr16_Put(t As FStr16T, ByRef s As String) As Long
    'store string - return handle
    '   handle must be saved to access string
    'Note: if s = "" then Method = False : null strings not stored
    '
    Local strLen, strPos, hStr, hStr2, returnValue As Long
    '
    t.isErr = %FALSE
    FStr16_ExitFalse(t.pMem, Function, $FStr16_Err_ModuleNotInitiated)
    FStr16_ExitFalse([EMAIL="[email protected]"][email protected][/EMAIL], Function, $FStr16_Err_FileNotOpen)
    FStr16_ExitTrue(s = "", Function, $FStr16_Err_NullString)
    '
    strLen = Len(s)
    strPos = 1
    hStr = FMem_Alloc([email protected], %FStr16FirstSize) : FStr16_ExitFalse(hStr, Function, $FStr16_Err_MemAllocFailed)
    returnValue = hStr 'return string's first block
    FStr16_First_SetCount t, hStr, strLen
    FStr16_First_SetStr t, hStr, Mid$(s, strPos, Min&(%FStr16StrSize, strLen))
    FStr16_First_SetNext t, hStr, %NULL
    strLen -= %FStr16StrSize
    strPos += %FStr16StrSize
    If strLen > 0 Then
        hStr2 = FMem_Alloc([email protected], %FStr16NextSize) : FStr16_ExitFalse(hStr, Function, $FStr16_Err_MemAllocFailed)
        FStr16_Next_SetNext t, hStr2, %NULL
        FStr16_First_SetNext t, hStr, hStr2
        hStr = hStr2
    End If
    While strLen > 0
        FStr16_Next_SetStr t, hStr, Mid$(s, strPos, Min&(%FStr16StrSize, strLen))
        strLen -= %FStr16StrSize
        strPos += %FStr16StrSize
        If strLen > 0 Then
            hStr2 = FMem_Alloc([email protected], %FStr16NextSize) : FStr16_ExitFalse(hStr, Function, $FStr16_Err_MemAllocFailed)
            FStr16_Next_SetNext t, hStr2, %NULL
            FStr16_Next_SetNext t, hStr, hStr2
            hStr = hStr2
        End If
    Wend
    Function = returnValue
End Function
'
Function FStr16_Get(t As FStr16T, ByVal hStr As Long) As String
    'get stored string
    Local strLen, totalStrLen As Long
    Local s As String
    '
    t.isErr = %FALSE
    FStr16_ExitFalse(t.pMem, Function, $FStr16_Err_ModuleNotInitiated)
    FStr16_ExitFalse([EMAIL="[email protected]"][email protected][/EMAIL], Function, $FStr16_Err_FileNotOpen)
    FStr16_ExitFalse(hStr, Function, $FStr16_Err_NullHandle)
    '
    strLen = FStr16_First_GetCount(t, hStr) : FStr16_ExitTrue(strLen < 1, Function, $FStr16_Err_NullString)
    totalStrLen = strLen
    s = FStr16_First_GetStr(t, hStr)
    hStr = FStr16_First_GetNext(t, hStr)
    strLen -= %FStr16StrSize
    While strLen > 0
        FStr16_ExitFalse(hStr, Function, $FStr16_Err_NullHandle)
        s += FStr16_Next_GetStr(t, hStr)
        hStr = FStr16_Next_GetNext(t, hStr)
        strLen -= %FStr16StrSize
    Wend
    Function = Left$(s, totalStrLen)
End Function
'
Function FStr16_Remove(t As FStr16T, ByVal hStr As Long) As Long
    'remove string from file
    '   hStr = FStr16_Remove(t, hStr)
    '       (should always null handles to deleted strings)
    Local hDel As Long
    '
    t.isErr = %FALSE
    FStr16_ExitFalse(t.pMem, Function, $FStr16_Err_ModuleNotInitiated)
    FStr16_ExitFalse([EMAIL="[email protected]"][email protected][/EMAIL], Function, $FStr16_Err_FileNotOpen)
    FStr16_ExitFalse(hStr, Function, $FStr16_Err_NullHandle)
    '
    hDel = hStr
    hStr = FStr16_First_GetNext(t, hDel)
    FMem_Free [email protected], hDel, %FStr16FirstSize
    While hStr
        hDel = hStr
        hStr = FStr16_Next_GetNext(t, hDel)
        FMem_Free [email protected], hDel, %FStr16NextSize
    Wend
    Function = %NULL
End Function
'
Function FStr16_IsErr(t As FStr16T) As Long
    'True/False if last operation caused an error
    Function = t.isErr
End Function
'
Function FStr16_ErrMsg(t As FStr16T) As String
    'get error message
    If t.isErr Then Function = t.errMsg
End Function
'
'   -----------------------------------
'               internal
'   -----------------------------------
'
Sub FStr16_First_SetCount(t As FStr16T, ByVal hFirst As Long, ByVal Count As Long)
    Local pFirst As FStr16FirstT Ptr
    FStr16_ExitFalse(hFirst, Sub, $FStr16_Err_NullHandle)
    pFirst = FMem_Get([email protected], hFirst) : FStr16_ExitFalse(pFirst, Sub, $FStr16_Err_NullPointer)
    @pFirst.count = Count
End Sub
'
Function FStr16_First_GetCount(t As FStr16T, ByVal hFirst As Long) As Long
    Local pFirst As FStr16FirstT Ptr
    FStr16_ExitFalse(hFirst, Function, $FStr16_Err_NullHandle)
    pFirst = FMem_Get([email protected], hFirst) : FStr16_ExitFalse(pFirst, Function, $FStr16_Err_NullPointer)
    Function = @pFirst.count
End Function
'
Sub FStr16_First_SetNext(t As FStr16T, ByVal hFirst As Long, ByVal x As Long)
    Local pFirst As FStr16FirstT Ptr
    FStr16_ExitFalse(hFirst, Sub, $FStr16_Err_NullHandle)
    pFirst = FMem_Get([email protected], hFirst) : FStr16_ExitFalse(pFirst, Sub, $FStr16_Err_NullPointer)
    @pFirst.next = x
End Sub
'
Function FStr16_First_GetNext(t As FStr16T, ByVal hFirst As Long) As Long
    Local pFirst As FStr16FirstT Ptr
    FStr16_ExitFalse(hFirst, Function, $FStr16_Err_NullHandle)
    pFirst = FMem_Get([email protected], hFirst) : FStr16_ExitFalse(pFirst, Function, $FStr16_Err_NullPointer)
    Function = @pFirst.next
End Function
'
Sub FStr16_First_SetStr(t As FStr16T, ByVal hFirst As Long, ByRef s As String)
    Local pFirst As FStr16FirstT Ptr
    FStr16_ExitFalse(hFirst, Sub, $FStr16_Err_NullHandle)
    pFirst = FMem_Get([email protected], hFirst) : FStr16_ExitFalse(pFirst, Sub, $FStr16_Err_NullPointer)
    @pFirst.str = s
End Sub
'
Function FStr16_First_GetStr(t As FStr16T, ByVal hFirst As Long) As String
    Local pFirst As FStr16FirstT Ptr
    FStr16_ExitFalse(hFirst, Function, $FStr16_Err_NullHandle)
    pFirst = FMem_Get([email protected], hFirst) : FStr16_ExitFalse(pFirst, Function, $FStr16_Err_NullPointer)
    Function = @pFirst.str
End Function
'
Sub FStr16_Next_SetNext(t As FStr16T, ByVal hNext As Long, ByVal x As Long)
    Local pNext As FStr16NextT Ptr
    FStr16_ExitFalse(hNext, Sub, $FStr16_Err_NullHandle)
    pNext = FMem_Get([email protected], hNext) : FStr16_ExitFalse(pNext, Sub, $FStr16_Err_NullPointer)
    @pNext.next = x
End Sub
'
Function FStr16_Next_GetNext(t As FStr16T, ByVal hNext As Long) As Long
    Local pNext As FStr16NextT Ptr
    FStr16_ExitFalse(hNext, Function, $FStr16_Err_NullHandle)
    pNext = FMem_Get([email protected], hNext) : FStr16_ExitFalse(pNext, Function, $FStr16_Err_NullPointer)
    Function = @pNext.next
End Function
'
Sub FStr16_Next_SetStr(t As FStr16T, ByVal hNext As Long, ByRef s As String)
    Local pNext As FStr16NextT Ptr
    FStr16_ExitFalse(hNext, Sub, $FStr16_Err_NullHandle)
    pNext = FMem_Get([email protected], hNext) : FStr16_ExitFalse(pNext, Sub, $FStr16_Err_NullPointer)
    @pNext.str = s
End Sub
'
Function FStr16_Next_GetStr(t As FStr16T, ByVal hNext As Long) As String
    Local pNext As FStr16NextT Ptr
    FStr16_ExitFalse(hNext, Function, $FStr16_Err_NullHandle)
    pNext = FMem_Get([email protected], hNext) : FStr16_ExitFalse(pNext, Function, $FStr16_Err_NullPointer)
    Function = @pNext.str
End Function
'

[Stanley Durham]

test/sample app

#PBForms CREATED V1.51
'pbwin 9
$TestSource = "FStrTest.bas"
$TestTitle = "File String Test"
#Compile Exe "FStrTest.exe"
#Dim All
#Optimize Speed
#Include Once "..\FStr16.inc"
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
Sub BtnTest(ByVal hDlg As Long)
    Local file As String : file = "Test.dat"
    Local h1, h2, h3, compare As Long
    Local s As String
    Local tMem As FMemT
    Local tStr As FStr16T
    '
    lbx.Clear(2)
    '
    If IsFile(file) Then Kill file
    '
    If IsFalse FMem_Create(tMem, file) Then Exit Sub
    '
    ' - have to initiate string manager before use
    FStr16_Initiate tStr, tMem
    '
    ' - store some strings
    h1 = FStr16_Put(tStr, "testing 123")
    h2 = FStr16_Put(tStr, "testing 456 testing testing 456 testing testing 456 testing testing 456 testing testing 456")
    h3 = FStr16_Put(tStr, "testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789 testing testing 789")
    '
    ' - retrieve string from file using handle
    lbx.Add( FStr16_Get(tStr, h1) )
    lbx.Add( FStr16_Get(tStr, h2) )
    lbx.Add( FStr16_Get(tStr, h3) )
    '
    lbx.Add("")
    lbx.Add("close file")
    FMem_Close tMem
    '
    lbx.Add("")
    lbx.Add("reopen file")
    lbx.Add("    make sure strings still in file")
    FMem_Open(tMem, file)
    '
    ' - retrieve string from file using handle
    lbx.Add("")
    lbx.Add( FStr16_Get(tStr, h1) )
    lbx.Add( FStr16_Get(tStr, h2) )
    lbx.Add( FStr16_Get(tStr, h3) )
    '
    FMem_Close tMem 'thanks to A du Toit
    '
    lbx.Add("")
    lbx.Add("done...")
End Sub
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(2000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance meTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            meTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(Timer - meTime, "###.###############")
        End Method
    End Interface
End Class

[A du Toit]

Exceptionally GREAT code! :goldcup:

Forgot one line, only visible when running a 2nd time:

SUB BtnTest(BYVAL hDlg AS LONG)
    LOCAL file AS STRING : file = "Test.dat"
...
    lbx.Add("")
    lbx.Add("done...")
    FMem_Close tMem ' <<-- Mapped file should be closed...
END SUB

Kind regards

[Stanley Durham]

thanks, fixed it