PBWin/PBCC FileMemMang2.inc, UDT File Memory Manager

[Stanley Durham]

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.

'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
'

[Stanley Durham]

test/sample app

#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