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

FileMemMang2.inc, UDT File Memory Manager

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

  • PBWin/PBCC FileMemMang2.inc, UDT File Memory Manager

    comments
    Uses FileMap2.inc.

    This is an UDT file memory manager.
    Takes care of allocating file space and storing UDTs in a file.
    Storage is allocated form 4 to 1024 bytes; in 4 byte increments.
    Allocating a 7 byte UDT will take 8 bytes in file.

    An allocation request returns a handle.
    Thereafter, you use the handle to access the UDT.
    You access the UDT, in the file, with a pointer.
    FMem_Get(tMem, handle) returns a memory address for the stored UDT.
    You use the pointer to Get/Set the UDT’s members.
    Modifications to the pointer reflect through to the file.

    File Mapping is used, so you’re reading/writing at full memory speed.

    You don’t have to worry about where UDTs are stored in the file, all taken care of.

    If UDT is freed, the freed file memory block added to a freed stack for reuse.

    Code:
    'PB 5/9
    'FileMemMang2.inc
        '   UDT File Memory Manager Module
        '
        '   - automatic storage of UDTs in file
        '   - access in-file UDT at full memory speed
        '
        '   works like system memory allocation
        '   hMem = FMem_Alloc(tMem, 16) 'allocate 16 bytes to hold UDT
        '
        '   pMyUDT = FMem_Get(tMem, hMem) 'set UDT pointer
        '   @pMyUDT.price = 99.99
        '
        '   changing a pointer to a UDT reflects through to file
        '
        '   Important!
        '       it's best to use wrapper procedures to Set/Get UDT values
        '           reestablish pointer memory address in each procedure
        '       this will slow things down, but;
        '           any allocation request might cause the file to have to grow
        '               file mapping has to be closed to change the size of the file
        '               a pointer address may be invalid after a file resize
        '                   depends on where Window's establishes new file mapping view address
    '
    #If Not %Def(%WINAPI)
        #Include Once "WIN32API.INC"
    #EndIf
    '''#Include Once "C:\PB9\FileMapping\GlobalMem.inc"
    #Include Once "C:\PB9\FileMapping\FileMap2.inc"
    '
    $FMem_Validation = Guid$("{65B4C69F-FFE9-484B-AAFD-1396C9D4FFBA}")
    '
    %FMem_PageSize = 2048
    %FMem_UserMax = 200
    %FMem_BlockMax = 1024
    %FMem_BlockIncr = 4
    %FMem_BlockVariations = 256
    '
    $FMem_Err_NullPtr = "File Memory Manager: null pointer"
    $FMem_Err_NullHandle = "File Memory Manager: null memory block handle"
    $FMem_Err_InvalidFile = "File Memory Manager: invalid file"
    $FMem_Err_FileNotOpen = "File Memory Manager: file not open"
    $FMem_Err_IndexOutOfBounds = "File Memory Manager: index out of bounds"
    $FMem_Err_InvalidBlockSize = "File Memory Manager: invalid block size"
    $FMem_Err_InvalidPageNo = "File Memory Manager: invalid page number"
    $FMem_Err_BlockOutOfFileBounds = "File Memory Manager: block out of file bounds"
    $FMem_Err_BlockOutOfPageBounds = "File Memory Manager: block out of page bounds"
    $FMem_Err_InvalidBlockPos = "File Memory Manager: invalid block position"
    $FMem_Err_BadBlockHandle = "File Memory Manager: bad block handle"
    '
    Macro FMem_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 FMem_ExitTrue(test, procedure, msg)
        If test Then
            #Debug Print FuncName$ +": "+ msg
            t.isErr = %TRUE
            t.errMsg = msg
            Exit procedure
        End If
    End Macro
    Macro FMem_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 FMem_GoTrue(test, MARKER, msg)
        If test Then
            #Debug Print FuncName$ +": "+ msg
            t.isErr = %TRUE
            t.errMsg = msg
            GoTo MARKER
        End If
    End Macro
    '
    Macro McFMem_BlockSize(blockSize) = ((Int(blockSize / %FMem_BlockIncr)) * %FMem_BlockIncr) + IIf&(blockSize Mod %FMem_BlockIncr, %FMem_BlockIncr, 0)
    '12345|12345|12345
    Macro McFMem_PageFilePosition(pageNo) = (pageNo * %FMem_PageSize) - %FMem_PageSize + 1
    Macro McFMem_BlockIndex(blockSize) = blockSize / %FMem_BlockIncr
    Macro McFMem_PageCount = (FMap_LOF(t.map) / %FMem_PageSize)
    Macro McFMem_BlocksPerPage(blockSize) = Int(%FMem_PageSize / blockSize)
    Macro McFMem_MemAddr(hBlock) = t.map.hView + hBlock - 1
    '
    '
    '
    Type FMem_FreeT
        nextFree As Long
    End Type
    Type FMem_HdrT
        validate As Guid
        freeBlock(1 To %FMem_BlockVariations) As Long
        userArr(1 To %FMem_UserMax) As Long
    End Type
    Type FMemT
        hdr As FMem_HdrT
        map As FMapT
        isOpen As Long
        isErr As Long
        errMsg As Asciiz * 256
    End Type
    '
    '
    '
    Function FMem_Create(t As FMemT, ByVal file As String) As Long
        'create new file - open for use - True/False success
        Local i As Long
        Local pHdr As FMem_HdrT Ptr
        '
        t.isErr = %FALSE
        t.isOpen = %FALSE
        FMem_ExitFalse(FMap_Create(t.map, file, %FMem_PageSize), Function, t.map.errMsg)
        t.hdr.validate = $FMem_Validation
        For i = 1 To %FMem_BlockVariations
            t.hdr.freeBlock(i) = %NULL
        Next i
        For i = 1 To %FMem_UserMax
            t.hdr.userArr(i) = %NULL
        Next i
        pHdr = FMap_MemStart(t.map) : FMem_GoFalse(pHdr, CLOSE_FILE_MAP, $FMem_Err_NullPtr)
        @pHdr = t.hdr 'store header in file
        t.isOpen = %TRUE
        Function = %TRUE
        '
        Exit Function
        '
        CLOSE_FILE_MAP:
        FMap_Close t.map
    End Function
    '
    Function FMem_Open(t As FMemT, ByVal file As String) As Long
        'open existing file - True/False success
        '   file must have been created by FMem_Create()
        Local pHdr As FMem_HdrT Ptr
        '
        t.isErr = %FALSE
        t.isOpen = %FALSE
        FMem_ExitFalse(FMap_Open(t.map, file), Function, t.map.errMsg)
        FMem_GoTrue(FMap_LOF(t.map) < %FMem_PageSize, CLOSE_FILE_MAP, $FMem_Err_InvalidFile)
        pHdr = FMap_MemStart(t.map) : FMem_GoFalse(pHdr, CLOSE_FILE_MAP, $FMem_Err_NullPtr)
        t.hdr = @pHdr 'get header from file
        FMem_GoFalse(t.hdr.validate = $FMem_Validation, CLOSE_FILE_MAP, $FMem_Err_InvalidFile)
        t.isOpen = %TRUE
        Function = %TRUE
        '
        Exit Function
        '
        CLOSE_FILE_MAP:
        FMap_Close t.map
    End Function
    '
    Sub FMem_Close(t As FMemT)
        'close file
        Local pHdr As FMem_HdrT Ptr
        '
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Sub, $FMem_Err_FileNotOpen)
        pHdr = FMap_MemStart(t.map) : FMem_GoFalse(pHdr, CLOSE_FILE_MAP, $FMem_Err_NullPtr)
        @pHdr = t.hdr 'save header in file
        '
        CLOSE_FILE_MAP:
        FMap_Close t.map
        t.isOpen = %FALSE
    End Sub
    '
    Sub FMem_Clear(t As FMemT)
        'delete all data
        '   file header cleared
        '   200 user slots cleared
        '   file reduced to one page - holds header
        Local i As Long
        Local pHdr As FMem_HdrT Ptr
        '
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Sub, $FMem_Err_FileNotOpen)
        FMap_Resize t.map, %FMem_PageSize
        FMem_ExitTrue(t.map.isErr, Sub, t.map.errMsg)
        For i = 1 To %FMem_BlockVariations
            t.hdr.freeBlock(i) = %NULL
        Next i
        For i = 1 To %FMem_UserMax
            t.hdr.userArr(i) = %NULL
        Next i
        pHdr = FMap_MemStart(t.map) : FMem_ExitFalse(pHdr, Sub, $FMem_Err_NullPtr)
        @pHdr = t.hdr
    End Sub
    '
    Function FMem_Alloc(t As FMemT, ByVal blockSize As Long) As Long
        'allocate block of memory in file - return handle
        '   this returns a handle to an allocated memory block in the file
        '   use FMem_Get() to get a memory address to work with allocated block
        '       p = FMem_Get(tFMem, h) : @p.count = 99 'changes reflected in file
        Local i, hBlock, pageNo, blockCount As Long
        '
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Function, $FMem_Err_FileNotOpen)
        FMem_ExitTrue(blockSize < 1 Or blockSize > %FMem_BlockMax, Function, $FMem_Err_InvalidBlockSize)
        '
        blockSize = McFMem_BlockSize(blockSize)
        hBlock = FMem_GetFreeBlock(t, blockSize)
        If hBlock Then
            Function = hBlock
        Else
            FMap_Resize t.map, FMap_LOF(t.map) + %FMem_PageSize
            pageNo = McFMem_PageCount : FMem_ExitFalse(pageNo, Function, $FMem_Err_InvalidPageNo)
            hBlock = McFMem_PageFilePosition(pageNo)
            blockCount = McFMem_BlocksPerPage(blockSize)
            'push all blocks on free stack
            For i = 1 To blockCount
                FMem_Free t, hBlock, blockSize
                hBlock += blockSize
            Next i
            hBlock = FMem_GetFreeBlock(t, blockSize)
            FMem_ExitFalse(hBlock, Function, $FMem_Err_NullHandle)
            Function = hBlock
        End If
    End Function
    Function FMem_Get(t As FMemT, ByVal hBlock As Long) As Long
        'get pointer memory address for hBlock
        '   this returns the memory address within the File Mapping, File View; for hBlock
        '   use this memory address to set a pointer to the structure that hBlock was allocated for
        '       p = FMem_Get(tFMem, hBlock)
        '       you can now use the pointer to Get/Set values
        '           INCR @p.count : x = @p.count
        '       modifications automatically reflect threw to file
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Function, $FMem_Err_FileNotOpen)
        FMem_ExitFalse(hBlock, Function, $FMem_Err_NullHandle)
        Function = McFMem_MemAddr(hBlock)
    End Function
    '
    Sub FMem_Free(t As FMemT, ByVal hBlock As Long, ByVal blockSize As Long)
        'free an allocated file memory block - block pushed on stack for reuse
        Local index As Long
        Local pFree As FMem_FreeT Ptr
        '
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Sub, $FMem_Err_FileNotOpen)
        FMem_ExitFalse(hBlock, Sub, $FMem_Err_NullHandle)
        FMem_ExitTrue(blockSize < 1 Or blockSize > %FMem_BlockMax, Sub, $FMem_Err_InvalidBlockSize)
        '
        blockSize = McFMem_BlockSize(blockSize)
        '
        index = McFMem_BlockIndex(blockSize) : FMem_ExitTrue(index < 1 Or index > %FMem_BlockVariations, Sub, $FMem_Err_IndexOutOfBounds)
        pFree = FMem_Get(t, hBlock) : FMem_ExitFalse(pFree, Sub, $FMem_Err_NullHandle)
        'null memory
        Poke$ pFree, Nul$(blockSize)
        @pFree.nextFree = t.hdr.freeBlock(index)
        t.hdr.freeBlock(index) = hBlock
    End Sub
    '
    Function FMem_IsErr(t As FMemT) As Long
        'True/False if last operation caused an error
        Function = t.isErr
    End Function
    '
    Function FMem_ErrMsg(t As FMemT) As String
        'get error message
        If t.isErr Then Function = t.errMsg
    End Function
    '
    Sub FMem_SetUser(t As FMemT, ByVal index As Long, ByVal value As Long)
        'set one of the 200 LONG user slots available
        '   value will be permanently stored in file header
        '       erased by FMem_Clear()
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Sub, $FMem_Err_FileNotOpen)
        FMem_ExitTrue(index < 1 Or index > %FMem_UserMax, Sub, $FMem_Err_IndexOutOfBounds)
        t.hdr.userArr(index) = value
    End Sub
    '
    Function FMem_GetUser(t As FMemT, ByVal index As Long) As Long
        'get one of the 200 LONG user slots available
        '   user values are permanently stored in file header
        '       erased by FMem_Clear()
        t.isErr = %FALSE
        FMem_ExitFalse(t.isOpen, Function, $FMem_Err_FileNotOpen)
        FMem_ExitTrue(index < 1 Or index > %FMem_UserMax, Function, $FMem_Err_IndexOutOfBounds)
        Function = t.hdr.userArr(index)
    End Function
    '
    '   -----------------------------------
    '               internal
    '   -----------------------------------
    '
    Function FMem_GetFreeBlock(t As FMemT, ByVal blockSize As Long) As Long
        'get freed block from stack
        Local index, hBlock As Long
        Local pFree As FMem_FreeT Ptr
        '
        t.isErr = %FALSE
        index = McFMem_BlockIndex(blockSize) : FMem_ExitTrue(index < 1 Or index > %FMem_BlockVariations, Function, $FMem_Err_IndexOutOfBounds)
        hBlock = t.hdr.freeBlock(index)
        If hBlock Then
            pFree = McFMem_MemAddr(hBlock) : FMem_ExitFalse(pFree, Function, $FMem_Err_NullPtr)
            t.hdr.freeBlock(index) = @pFree.nextFree
            Function = hBlock
        End If
    End Function
    '
    Last edited by Stanley Durham; 16 Aug 2009, 09:25 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 = "UDTMemMangTest.bas"
    $TestTitle = "UDT Memory Manager Class Test"
    #Compile Exe "UDTMemMangTest.exe"
    #Dim All
    #Optimize Speed
    #Include Once "..\FileMemMang2.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
    Type TestT
        str As String * 32
    End Type
    Sub BtnTest(ByVal hDlg As Long)
        Local ok, h1, h2, h3, h4, h5 As Long
        Local file As String : file = "test.dat"
        Local t As FMemT
        Local p As TestT Ptr
        '
        lbx.Clear(2)
        '
        If IsFile(file) Then Kill file
        If IsFalse FMem_Create(t, file) Then
            ? FMem_ErrMsg(t)
        End If
        '
        h1 = FMem_Alloc(t, 32)
        p = FMem_Get(t, h1)
        @p.str = "1=345678901234567890123456789012"
        '
        h2 = FMem_Alloc(t, 32)
        p = FMem_Get(t, h2)
        @p.str = "2=345678901234567890123456789012"
        '
        h3 = FMem_Alloc(t, 32)
        p = FMem_Get(t, h3)
        @p.str = "3=345678901234567890123456789012"
        '
        h4 = FMem_Alloc(t, 32)
        p = FMem_Get(t, h4)
        @p.str = "4=345678901234567890123456789012"
        '
        h5 = FMem_Alloc(t, 32)
        p = FMem_Get(t, h5)
        @p.str = "5=345678901234567890123456789012"
        '
        p = FMem_Get(t, h1)
        lbx.Add(@p.str)
        '
        lbx.Add("")
        lbx.Add("Close/Reopen file")
        FMem_Close(t)
        FMem_Open(t, file)
        '
        p = FMem_Get(t, h1)
        lbx.Add(@p.str)
        p = FMem_Get(t, h2)
        lbx.Add(@p.str)
        p = FMem_Get(t, h3)
        lbx.Add(@p.str)
        p = FMem_Get(t, h4)
        lbx.Add(@p.str)
        p = FMem_Get(t, h5)
        lbx.Add(@p.str)
        '
        FMem_Close(t)
        '
        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(1000)
                 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
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

    Comment

    Working...
    X