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
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
  • 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:

  • Stanley Durham
    started a topic Assert() like; error trapping and message handling functions

    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.
    Tags: None
Previous template Next
Working...
X

We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

I Agree