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

  • 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.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

  • #2
    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.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

    Comment


    • #3
      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
      stanthemanstan~gmail
      Dead Theory Walking
      Range Trie Tree
      HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

      Comment


      • #4
        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.
        stanthemanstan~gmail
        Dead Theory Walking
        Range Trie Tree
        HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

        Comment


        • #5
          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
          stanthemanstan~gmail
          Dead Theory Walking
          Range Trie Tree
          HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

          Comment

          Working...
          X