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

Assert() like; error trapping and message handling functions

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

  • Stanley Durham
    replied
    class sample need this to compile

    Code:
    'PB 5/9 .02
    'GlobalMem.inc
    '
        'allocate global memory
    '
    #If Not %Def(%WINAPI)
        #Include Once "WIN32API.INC"
    #EndIf
    #Include Once "C:\PBINC\Error.inc"
    '
    Function GMem_Alloc(ByVal memSize As Long, e As ErrT) As Long
        'allocate memory
        If e.err = %false Then
            If memSize Then
                Local hMem As Long
                hMem = GlobalAlloc(ByVal %GPTR, ByVal memSize)
                If hMem Then
                    Function = hMem
                Else
                    Err_Set e, %ErrUndefined, "GlobalMem.inc", "", "", "GMem_Alloc", "memory allocation fail"
                End If
            End If
        End If
    End Function
    '
    Function GMem_Free(ByVal hMem As Long, e As ErrT) As Long
        'free allocated memory
        If hMem Then GlobalFree(ByVal hMem)
        Function = %NULL
    End Function
    '
    Function GMem_ReAlloc(ByVal hMem As Long, ByVal newSize As Long, e As ErrT) As Long
        'reallocate block of memory
        'USE: hMem = GMemReAlloc(hMem, newSize)
        Local h As Long
        If newSize = 0 Then
            If hMem Then GlobalFree(ByVal hMem)
            Function = %NULL
        Else
            If hMem Then
                h = GlobalReAlloc(ByVal hMem, ByVal newSize, ByVal %GMEM_MOVEABLE Or %GMEM_ZEROINIT)
            Else
                h = GlobalAlloc(ByVal %GPTR, ByVal newSize)
            End If
            If h Then
                Function = h
            Else
                Err_Set e, %ErrUndefined, "GlobalMem.inc", "", "", "GMem_ReAlloc", "memory allocation fail"
            End If
        End If
    End Function
    '
    Sub GMem_Copy(ByVal copyTo As Long, ByVal copyFrom As Long, ByVal byteCount As Long, e As ErrT)
        'copy/move block of memory
        If e.err = %false Then
            If copyTo = %null Or copyFrom = %null Then
                Err_Set e, %ErrUndefined, "GlobalMem.inc", "", "", "GMem_Copy", "null memory handle"
            End If
            MoveMemory(ByVal copyTo, ByVal copyFrom, ByVal byteCount)
        End If
    End Sub

    Leave a comment:


  • Stanley Durham
    replied
    test program for sample class

    Code:
    'PB 9
    '''''''''''''''''''''''''''''''
    %ErrHaltActive = 1
    '''''''''''''''''''''''''''''''
    $TestSource = "LongListNodeC.bas"
    $TestTitle = "Long List Node Class Test"
    #Compile Exe "LongListNodeC.exe"
    #Dim All
    #Optimize Speed
    #If Not %Def(%WINAPI)
        #Include Once "WIN32API.INC"
    #EndIf
    #Include Once "PBForms.INC"
    #Include "LongListNodeC.inc"
    '
    %Dlg1    =  101
    %BtnTest = 1002
    %Lbx     = 1001
    '
    Global lbx As ListBoxI
    Global tmr As TimerI
    '
    Sub BtnTest(ByVal hDlg As Long)
        Local e As ErrT
        Local node As LongListNodeI : node = Class "LongListNodeC" : node.Initialize(e)
        '
        lbx.Clear(2)
        '
        node.Alloc()
        '
        '
        lbx.Add("")
        lbx.Add("set next, 99") : node.Next = 99
        lbx.Add("next = " + Format$(node.Next))
        '
        lbx.Add("")
        lbx.Add("set previous, 14") : node.Prev = 14
        lbx.Add("previous = " + Format$(node.Prev))
        '
        ''''''''''''''''''''''''''''''''''''''''''''''
        ''''''''''''''''''''''''''''''''''''''''''''''
        'un-comment to test assert failure
        node.Ptr = 0 'test error message
        ''''''''''''''''''''''''''''''''''''''''''''''
        ''''''''''''''''''''''''''''''''''''''''''''''
        '
        lbx.Add("")
        lbx.Add("set value, 22") : node.Value = 22
        lbx.Add("value = " + Format$(node.Value))
        '
        lbx.Add("")
        lbx.Add("compare value with 3 = " + Format$(node.Compare(3)))
        lbx.Add("compare value with 22 = " + Format$(node.Compare(22)))
        lbx.Add("compare value with 63 = " + Format$(node.Compare(63)))
        '
        '
        '
        '
        node.Free()
        '
        lbx.Add("")
        lbx.Add("done...")
    End Sub
    '
    Function PBMain()
        ShowDlg1 %HWND_Desktop
    End Function
    CallBack Function ShowDlg1Proc()
        Select Case As Long CbMsg
            Case %WM_InitDialog
                 lbx = Class "ListBoxC"
                 lbx.INI(Cb.Hndl, %Lbx)
                 lbx.SetHorizontal(1000)
                 tmr = Class "TimerC"
            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
        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, %Lbx, , 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, %Lbx, %WM_SETFONT, hFont1, 0
        Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
        DeleteObject hFont1
        Function = lRslt
    End Function
    Class ListBoxC
        Instance meHDlg As Long
        Instance meID As Long
        Interface ListBoxI
            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; 2 Nov 2009, 10:38 AM.

    Leave a comment:


  • Stanley Durham
    replied
    test sample class

    Code:
    'PB 5/9 .02
    'LongListNodeC.inc
    '
    '   Node Class for Long Linked List, and derivatives
    '       Hybrid COM Object
    '
    #Include Once "Error.inc"
    #Include Once "GlobalMem.inc"
    '
    Macro LongListNodeC_ErrStatus(exitWhat) = If pe = %null Or @pe.err Then Exit exitWhat
    Macro LongListNodeC_ExitIf(test, message, exitWhat)
        If test Then
            Err_Set @pe, %ErrUndefined, "LongListNodeC.inc", "LongListNodeC", "LongListNodeI", FuncName$, message
            Exit exitWhat
        End If
    End Macro
    '
    %LongListNodeC_Hash = -1827108340
    '
    Type LongListNodeCT
        hash As Long
        Next As LongListNodeCT Ptr
        prev As LongListNodeCT Ptr
        value As Long
    End Type
    '
    '
    '
    Class LongListNodeC
        Instance p As LongListNodeCT Ptr
        Instance pe As ErrT Ptr
        '
        Interface LongListNodeI : Inherit IUnknown
            '
            Method Initialize(e As ErrT)
                'set error handler
                pe = VarPtr(e)
            End Method
            '
            Method Alloc()
                'allocate new instance
                LongListNodeC_ErrStatus(Method)
                p = GMem_Alloc(SizeOf(@p), @pe)
                If @pe.err Then Exit Method
                @p.hash = %LongListNodeC_Hash
            End Method
            '
            Method Free()
                'free instance
                LongListNodeC_ErrStatus(Method)
                If p Then p = GMem_Free(p, @pe)
            End Method
            '
            Property Get Ptr() As Long
                'get current instance
                LongListNodeC_ErrStatus(Property)
                Property = p
            End Property
            '
            Property Set Ptr(ByVal hMem As Long)
                'set current instance
                LongListNodeC_ErrStatus(Property)
                p = hMem
                If p Then
                    LongListNodeC_ExitIf(@p.hash <> %LongListNodeC_Hash, "invalid memory handle", Property)
                End If
            End Property
            '
            Property Get Next() As Long
                LongListNodeC_ErrStatus(Property)
                LongListNodeC_ExitIf(p = %null, "null instance", Property)
                Property = @p.next
            End Property
            '
            Property Set Next(ByVal v As Long)
                LongListNodeC_ErrStatus(Property)
                LongListNodeC_ExitIf(p = %null, "null instance", Property)
                @p.next = v
            End Property
            '
            Property Get Prev() As Long
                LongListNodeC_ErrStatus(Property)
                LongListNodeC_ExitIf(p = %null, "null instance", Property)
                Property = @p.prev
            End Property
            '
            Property Set Prev(ByVal v As Long)
                LongListNodeC_ErrStatus(Property)
                LongListNodeC_ExitIf(p = %null, "null instance", Property)
                @p.prev = v
            End Property
            '
            Property Get Value() As Long
                LongListNodeC_ErrStatus(Property)
                LongListNodeC_ExitIf(p = %null, "null instance", Property)
                Property = @p.value
            End Property
            '
            Property Set Value(ByVal v As Long)
                LongListNodeC_ErrStatus(Property)
                LongListNodeC_ExitIf(p = %null, "null instance", Property)
                @p.value = v
            End Property
            '
            Method Compare(ByVal v As Long) As Long
                LongListNodeC_ErrStatus(Method)
                LongListNodeC_ExitIf(p = %null, "null instance", Method)
                If @p.value < v Then
                    Method = -1
                ElseIf @p.value > v Then
                    Method = 1
                Else
                    Method = 0
                End If
            End Method
            '
        End Interface
        '
    End Class

    Leave a comment:


  • Stanley Durham
    replied
    test/sample

    Code:
    'PB 9
    'Error.bas
    ''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''
    %ErrHaltActive = 1
    ''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''
    $TestSource = "Error.bas"
    $TestTitle = ""
    #Compile Exe "Error.exe"
    #Dim All
    #Optimize Speed
    #If Not %Def(%WINAPI)
        #Include Once "WIN32API.INC"
    #EndIf
    #Include Once "PBForms.INC"
    #Include "Error.inc"
    '
    %Dlg1    =  101
    %BtnTest = 1002
    %Lbx     = 1001
    '
    Global lbx As ListBoxI
    Global tmr As TimerI
    '
    Sub BtnTest(ByVal hDlg As Long)
        Local e As ErrT
        Local p As Long Ptr
        '
        If p = %null Then Err_Set e,  0, "Error.bas", "", "", "BtnTest()", "null pointer"
        '
        @p = 99
        '
        lbx.Add("")
        lbx.Add("done...")
    End Sub
    '
    Function PBMain()
        ShowDlg1 %HWND_Desktop
    End Function
    CallBack Function ShowDlg1Proc()
        Select Case As Long CbMsg
            Case %WM_InitDialog
                 lbx = Class "ListBoxC"
                 lbx.INI(Cb.Hndl, %Lbx)
                 lbx.SetHorizontal(1000)
                 tmr = Class "TimerC"
            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
        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, %Lbx, , 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, %Lbx, %WM_SETFONT, hFont1, 0
        Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
        DeleteObject hFont1
        Function = lRslt
    End Function
    Class ListBoxC
        Instance meHDlg As Long
        Instance meID As Long
        Interface ListBoxI
            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; 2 Nov 2009, 10:24 AM.

    Leave a comment:


  • Assert() like; error trapping and message handling functions

    11/02/2009: changed to ExitProcess(); thanks to Mike Stefanik

    11/02/2009
    added sample class & and test code for the class
    with %ErrHaltActive defined
    - you'll get a message of where the error occurred;
    source file, class, interface, method/procedure, message

    this is really aimed at classes and low-level include files
    you write a little test program to call all the methods in the class
    define %ErrHaltActive in the test app
    any errors will be pinpointed
    may be used for contract style programming;
    if this <> that then Err_Set(....) 'displays message if %ErrHaltActive defined



    I got rid of the evil !HLT, thanks to Mike Stefanik for pointing me in the right direction

    this may be used like Assert(c, c++) by defining %ErrHaltActive during development phase.

    IF p = %NULL THEN Err_Set(...)

    application will stop at point of error with; source file, class, interface, procedure and message


    Code:
    'PB 5/9 .02
    'Error.inc
    '
    '   11/02/2009: changed to ExitProcess(); thanks to Mike Stefanik
    '
    '   error trapping and message handling functions
    '
    '    !!! %ErrHaltActive should only be defined: test/debug phase !!!
    '
    '    if, %ErrHaltActive is defined: %ErrHaltActive = 1
    '        FatalAppExit() will be called
    '            displays message box
    '            - display error number
    '            - display error source file
    '            - display Class, Interface, Procedure
    '            - display error message
    '
    'to use for error trapping, ErrT has to be global (bad ideal) or passed to every procedure.
    'SUB MySub(e as ErrT)
    '    IF e.err = %false then
    '        'code
    '    END IF
    'END SUB
    '
    'at any point, you may catch and clear the error; Err_Clear(e)
    '
    '   for full error protection - you have to retest ErrT after calling any procedure that might cause an error
    '
    #If Not %Def(%WINAPI)
        #Include Once "WIN32API.INC"
    #EndIf
    '
    '   you can use your own error codes
    '       "no error" has to equal zero
    '   you can also ignore the error codes and just use a string message
    '
    %ErrNone = 0
    %ErrUndefined = -1
    '
    Type ErrT
        Err As Long
        file As Asciiz * 256
        Class As Asciiz * 256
        Interface As Asciiz * 256
        procedure As Asciiz * 256
        message As Asciiz * 256
    End Type
    '
    Sub Err_Clear(e As ErrT, ByVal clearCritical As Long)
        'reset error status
        e.err = %ErrNone
    End Sub
    '
    Sub Err_Set( _
        e As ErrT, _
        ByVal errNo As Long, _ 'error number
        ByVal errFile As String, _ 'source file
        ByVal errClass As String, _ 'class error occurred in
        ByVal errInterface As String, _ 'interface error occurred in
        ByVal errProcedure As String, _ 'Function/Sub/Method/Property error occurred in
        ByVal errMessage As String _ 'error message
        )
        '
        'set error
        '   program will halt if %ErrHaltActive is defined [ %ErrHaltActive = 1 ]
        '
        e.err = IIf&(errNo, errNo, %ErrUndefined)
        e.file = errFile
        e.class = errClass
        e.interface = errInterface
        e.procedure = errProcedure
        e.message = errMessage
        Local t As String
        t = "Fatal Error!"
        Local s As String
        s = "Error: " + Format$(e.err) +": "+ e.file +": "+ e.class +": "+ e.interface +": "+ e.procedure +": "+ e.message
        #If %Def(%ErrHaltActive)
            MessageBox(0, ByVal StrPtr(s),  ByVal StrPtr(t), %MB_Ok Or %MB_IconWarning Or %MB_ApplModal)
            '''''''FatalAppExit(%null, ByVal StrPtr(s))
            '''''''''DebugBreak()
            ExitProcess(%null)
        #Else
            #Debug Print s
        #EndIf
    End Sub
    '
    Function Err_Get(e As ErrT) As Long
        'get error status - null if no error
        Function = e.err
    End Function
    '
    Function Err_Message(e As ErrT) As String
        'get error message
        If e.err Then Function = e.message
    End Function
    '
    Function Err_FullMessage(e As ErrT) As String
        'get full error message
        If e.err Then
            Local s As String
            s = "Error: " + Format$(e.err) +": "+ e.file +": "+ e.class +": "+ e.interface +": "+ e.procedure +": "+ e.message
            Function = s
        End If
    End Function
    '
    Last edited by Stanley Durham; 2 Nov 2009, 10:56 AM.
Working...
X