Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

FStr16.inc, File Based: Dynamic String Storage

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

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

    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.

    Code:
    '  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 protected], 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 protected], 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 protected], 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
    '
    Last edited by Stanley Durham; 16 Aug 2009, 10:24 AM.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

  • #2
    test/sample app

    Code:
    #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
    Last edited by Stanley Durham; 18 Aug 2009, 10:07 AM.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

    Comment


    • #3
      Exceptionally GREAT code! :goldcup:

      Forgot one line, only visible when running a 2nd time:
      Code:
      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
      JADT

      Comment


      • #4
        thanks, fixed it
        stanthemanstan~gmail
        Dead Theory Walking
        Range Trie Tree
        HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

        Comment

        Working...
        X