Announcement

**Stanley Durham** · 16 Aug 2009, 08:44 AM

test/sample app

Code:

#PBForms CREATED V1.51
'pbwin 9
$TestSource = "FLStackTest.bas"
$TestTitle = "File Based: Long Stack Test"
#Compile Exe "FLStackTest.exe"
#Dim All
#Optimize Speed
#Include "..\FLStack.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 i, x, Count As Long
    Local file As String : file = "StackTest.dat"
    Local s As String
    Local t As FLStackT
    '
    lbx.Clear(2)
    Count = 100000
    '
    If IsFile(file) Then Kill file
    '
    If IsFalse FLStack_Create(t, file) Then Exit Sub
    '
    lbx.Add("push "+Format$(Count, "#,")+" items on stack")
    tmr.Start()
    For i = 1 To Count
        FLStack_Push t, i
    Next i
    lbx.Add(tmr.Get())
    '
    lbx.Add("")
    lbx.Add("Count = " + Format$(FLStack_Count(t),"#,"))
    '
    lbx.Add("")
    lbx.Add("close and reopen stack - make sure data saved")
    FLStack_Close t
    FLStack_Open(t, file)
    '
    lbx.Add("")
    lbx.Add("pop all "+Format$(Count, "#,")+" items")
    i = Count + 1
    tmr.Start()
    While FLStack_Count(t)
        Decr i
        If FLStack_Pop(t) <> i Then
            ? "fail at: " + Format$(i) : Exit Loop
        End If
    Wend
    lbx.Add(tmr.Get())
    '
    lbx.Add("")
    lbx.Add("file size = 804,864 bytes")
    '
    lbx.Add("")
    lbx.Add("push "+Format$(Count, "#,")+" items on stack; again")
    lbx.Add("   test to see that freed file blocks are being reused")
    tmr.Start()
    For i = 1 To Count
        FLStack_Push t, i
    Next i
    lbx.Add(tmr.Get())
    '
    lbx.Add("")
    lbx.Add("file size = 804,864 bytes - 100% recovery of deleted blocks")
    '
    lbx.Add("")
    lbx.Add("Clear() file")
    FLStack_Clear t
    lbx.Add("push 5 items")
    For i = 1 To 5
        FLStack_Push t, i * 1000
    Next i
    '
    While FLStack_Count(t)
        s = "Peek = "
        s += Format$(FLStack_Peek(t))
        s += " | "
        s += "Pop = "
        s += Format$(FLStack_Pop(t))
        lbx.Add(s)
    Wend
    '
    '
    lbx.Add("")
    lbx.Add("file size now = 6,144 bytes")
    '
    '- close stack
    FLStack_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

Announcement

Forum Guidelines

FLStack.inc, File Based: Long Stack

PBWin/PBCC FLStack.inc, File Based: Long Stack

Comment