fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2023-01-31 14:59 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)

Browse Source 
* include/hbapierr.h
  * src/harbour.def
  * src/rtl/errapi.c
    + added new C function:
         void hb_errReinit( PHB_ITEM pError );
      it allows to replace default error object with user custom one which
      support :Init() method

  * contrib/xhb/xhb.hbp
  + contrib/xhb/xhb.h
  + contrib/xhb/xhberror.prg
    + added code which extends Harbour error objects adding functionality
      known from xHarbour:
         oError:ProcName
         oError:ProcLine
         oError:ProcModule
      Above instance variables are initialized automatically when error
      object is created.
      To enable this functionality it's enough to add to PRG code:
         REQUEST xhb_ErrorNew

  * contrib/xhb/xhberr.prg
    * use error object :Proc*() methods if they are available
    - removed PRG version of xhb_ErrorNew()

  * contrib/xhb/xhbmemo.prg
  * contrib/xhb/xhbtedit.prg
    ! use xhb_ErrorNew() instead of ErrorNew() which does not support
      any parameters

  * include/hbapicls.h
    ; typo in comment
This commit is contained in:
Przemysław Czerpak
2023-01-31 14:59:17 +01:00
parent c95f2a7ad5
commit 807c7d8e8b
10 changed files with 102 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
ChangeLog.txt
View File

@@ -7,6 +7,40 @@
Entries may not always be in chronological/commit order.
See license at the end of file. */
2023-01-31 14:59 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* include/hbapierr.h
* src/harbour.def
* src/rtl/errapi.c
+ added new C function:
void hb_errReinit( PHB_ITEM pError );
it allows to replace default error object with user custom one which
support :Init() method
* contrib/xhb/xhb.hbp
+ contrib/xhb/xhb.h
+ contrib/xhb/xhberror.prg
+ added code which extends Harbour error objects adding functionality
known from xHarbour:
oError:ProcName
oError:ProcLine
oError:ProcModule
Above instance variables are initialized automatically when error
object is created.
To enable this functionality it's enough to add to PRG code:
REQUEST xhb_ErrorNew
* contrib/xhb/xhberr.prg
* use error object :Proc*() methods if they are available
- removed PRG version of xhb_ErrorNew()
* contrib/xhb/xhbmemo.prg
* contrib/xhb/xhbtedit.prg
! use xhb_ErrorNew() instead of ErrorNew() which does not support
any parameters
* include/hbapicls.h
; typo in comment
2023-01-31 07:17 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* src/vm/fm.c
* src/vm/garbage.c

10
contrib/xhb/xhb.h
View File

@@ -52,6 +52,16 @@
HB_EXTERN_BEGIN
/* functions in xhberror.c */
extern HB_EXPORT const char * hb_errGetProcName( PHB_ITEM pError );
extern HB_EXPORT PHB_ITEM hb_errPutProcName( PHB_ITEM pError, const char * szProcName );
extern HB_EXPORT HB_UINT hb_errGetProcLine( PHB_ITEM pError );
extern HB_EXPORT PHB_ITEM hb_errPutProcLine( PHB_ITEM pError, HB_UINT uiProcLine );
extern HB_EXPORT const char * hb_errGetModuleName( PHB_ITEM pError );
extern HB_EXPORT PHB_ITEM hb_errPutModuleName( PHB_ITEM pError, const char * szModuleName );
extern HB_EXPORT PHB_ITEM hb_errGetCallStack( PHB_ITEM pError );
extern HB_EXPORT PHB_ITEM hb_errPutCallStack( PHB_ITEM pError, PHB_ITEM pCallStack );
/* functions in hboutdbg.c */
extern HB_EXPORT HB_BOOL hb_OutDebugName( PHB_ITEM pName );
extern HB_EXPORT void hb_OutDebug( const char * szMsg, HB_SIZE nMsgLen );

1
contrib/xhb/xhb.hbp
View File

@@ -45,6 +45,7 @@ xhbctbit.c
xhbdate.c
xhbenum.c
xhberrc.c
xhberror.c
xhbfs.c
xhbfunc.c
xhbgt.c

69
contrib/xhb/xhberr.prg
View File

@@ -212,7 +212,7 @@ STATIC FUNCTION xhb_DefError( oError )
? cMessage
?
? "Error at ...:", ProcName() + "(" + hb_ntos( ProcLine() ) + ") in Module:", ProcFile()
? "Error at ...:", err_ProcName( oError, 3 ) + "(" + hb_ntos( err_ProcLine( oError, 3 ) ) + ") in Module:", err_ModuleName( oError, 3 )
n := 2
WHILE ! Empty( ProcName( ++n ) )
? "Called from :", ProcName( n ) + ;
@@ -268,7 +268,7 @@ STATIC FUNCTION ErrorMessage( oError )
RETURN cMessage
STATIC FUNCTION LogError( oerr )
STATIC FUNCTION LogError( oErr )
LOCAL cScreen
LOCAL cLogFile := s_cErrorLog // error log file name
@@ -493,7 +493,7 @@ STATIC FUNCTION LogError( oerr )
FWriteLine( nHandle, "" )
FWriteLine( nHandle, "Subsystem Call ....: " + oErr:subsystem() )
FWriteLine( nHandle, "System Code .......: " + strvalue( oErr:suBcode() ) )
FWriteLine( nHandle, "Default Status ....: " + strvalue( oerr:candefault() ) )
FWriteLine( nHandle, "Default Status ....: " + strvalue( oErr:candefault() ) )
FWriteLine( nHandle, "Description .......: " + oErr:description() )
FWriteLine( nHandle, "Operation .........: " + oErr:operation() )
FWriteLine( nHandle, "Arguments .........: " + Arguments( oErr ) )
@@ -512,7 +512,7 @@ STATIC FUNCTION LogError( oerr )
FWriteLine( nHandle, " Trace Through:" )
FWriteLine( nHandle, "----------------" )
FWriteLine( nHandle, PadR( ProcName(), 21 ) + " : " + Transform( ProcLine(), "999,999" ) + " in Module: " + ProcFile() )
FWriteLine( nHandle, PadR( err_ProcName( oErr, 3 ), 21 ) + " : " + Transform( err_ProcLine( oErr, 3 ), "999,999" ) + " in Module: " + err_ModuleName( oErr, 3 ) )
nCount := 3
WHILE ! Empty( ProcName( ++nCount ) )
@@ -670,64 +670,3 @@ PROCEDURE __MinimalErrorHandler( oError )
QUIT
RETURN
FUNCTION xhb_ErrorNew( cSubSystem, nGenCode, nSubCode, ;
cOperation, cDescription, aArgs, ;
cModuleName, cProcName, nProcLine )
LOCAL oError := ErrorNew()
LOCAL aStack, n
IF HB_ISSTRING( cSubSystem )
oError:SubSystem := cSubSystem
ENDIF
IF HB_ISNUMERIC( nGenCode )
oError:GenCode := nGenCode
ENDIF
IF HB_ISNUMERIC( nSubCode )
oError:SubCode := nSubCode
ENDIF
IF HB_ISSTRING( cOperation )
oError:Operation := cOperation
ENDIF
IF HB_ISSTRING( cDescription )
oError:Description := cDescription
ENDIF
IF HB_ISARRAY( aArgs )
oError:Args := aArgs
ENDIF
IF __objHasMsg( oError, "MODULENAME" )
IF HB_ISSTRING( cModuleName )
oError:ModuleName := cModuleName
ELSE
oError:ModuleName := ProcFile( 1 )
ENDIF
ENDIF
IF __objHasMsg( oError, "PROCNAME" )
IF HB_ISSTRING( cProcName )
oError:ProcName := cProcName
ELSE
oError:ProcName := ProcName( 1 )
ENDIF
ENDIF
IF __objHasMsg( oError, "PROCLINE" )
IF HB_ISNUMERIC( nProcLine )
oError:ProcLine := nProcLine
ELSE
oError:ProcLine := ProcLine( 1 )
ENDIF
ENDIF
IF __objHasMsg( oError, "AASTACK" )
aStack := {}
n := 0
WHILE ! Empty( ProcName( ++n ) )
AAdd( aStack, { ProcFile( n ), ProcName( n ), ProcLine( n ) } )
ENDDO
oError:aAStack := aStack
ENDIF
RETURN oError

28
contrib/xhb/xhbmemo.prg
View File

@@ -430,49 +430,49 @@ FUNCTION xhb_MemoEdit( ;
// 2006-07-22 - E.F. Check argument types.
//
IF ! HB_ISNIL( cString ) .AND. ! HB_ISSTRING( cString ) .AND. ! HB_ISMEMO( cString )
Throw( ErrorNew( "BASE", 0, 1127, "<cString> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<cString> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nTop ) .AND. ! HB_ISNUMERIC( nTop )
Throw( ErrorNew( "BASE", 0, 1127, "<nTop> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nTop> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nLeft ) .AND. ! HB_ISNUMERIC( nLeft )
Throw( ErrorNew( "BASE", 0, 1127, "<nLeft> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nLeft> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nRight ) .AND. ! HB_ISNUMERIC( nRight )
Throw( ErrorNew( "BASE", 0, 1127, "<nRight> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nRight> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nBottom ) .AND. ! HB_ISNUMERIC( nBottom )
Throw( ErrorNew( "BASE", 0, 1127, "<nBottom> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nBottom> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( lEditMode ) .AND. ! HB_ISLOGICAL( lEditMode )
Throw( ErrorNew( "BASE", 0, 1127, "<lEditMode> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<lEditMode> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( xUDF ) .AND. ! HB_ISSTRING( xUDF ) .AND. ! HB_ISLOGICAL( xUDF )
Throw( ErrorNew( "BASE", 0, 1127, "<cUserFunction> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<cUserFunction> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nLineLength ) .AND. ! HB_ISNUMERIC( nLineLength )
Throw( ErrorNew( "BASE", 0, 1127, "<nLineLength> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nLineLength> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nTabSize ) .AND. ! HB_ISNUMERIC( nTabSize )
Throw( ErrorNew( "BASE", 0, 1127, "<nTabSize> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nTabSize> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nTextBuffRow ) .AND. ! HB_ISNUMERIC( nTextBuffRow )
Throw( ErrorNew( "BASE", 0, 1127, "<nTextBuffRow> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nTextBuffRow> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nTextBuffColumn ) .AND. ! HB_ISNUMERIC( nTextBuffColumn )
Throw( ErrorNew( "BASE", 0, 1127, "<nTextBuffColumn> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nTextBuffColumn> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nWindowRow ) .AND. ! HB_ISNUMERIC( nWindowRow )
Throw( ErrorNew( "BASE", 0, 1127, "<nWindowRow> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nWindowRow> Argument type error", ProcName() ) )
ENDIF
IF ! HB_ISNIL( nWindowColumn ) .AND. ! HB_ISNUMERIC( nWindowColumn )
Throw( ErrorNew( "BASE", 0, 1127, "<nWindowColumn> Argument type error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nWindowColumn> Argument type error", ProcName() ) )
ENDIF
// 2006-07-22 - E.F. To avoid run time error.
IF nTop > nBottom .OR. nLeft > nRight
Throw( ErrorNew( "BASE", 0, 1127, "<nTop,nLeft,nRight,nBottom> Argument error", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "<nTop,nLeft,nRight,nBottom> Argument error", ProcName() ) )
ENDIF
IF HB_ISSTRING( xUDF ) .AND. Empty( xUDF )

2
contrib/xhb/xhbtedit.prg
View File

@@ -262,7 +262,7 @@ METHOD New( cString, nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabS
// 2006-07-22 - E.F. To avoid run time error.
IF nTop > nBottom .OR. nLeft > nRight
Throw( ErrorNew( "BASE", 0, 1127, "Argument error: <nTop,nRight,nLeft,nBottom>", ProcName() ) )
Throw( xhb_ErrorNew( "BASE", 0, 1127, "Argument error: <nTop,nRight,nLeft,nBottom>", ProcName() ) )
ENDIF

2
include/hbapicls.h
View File

@@ -119,7 +119,7 @@ extern HB_EXPORT HB_USHORT hb_clsFindClass( const char * szClass, const char *
/* object management */
extern HB_EXPORT HB_USHORT hb_objGetClass( PHB_ITEM pItem ); /* get object class handle */
extern HB_EXPORT HB_USHORT hb_objSetClass( PHB_ITEM pItem, const char * szClass, const char * szFunc ); /* get object class handle using class name and class function name */
extern HB_EXPORT HB_USHORT hb_objSetClass( PHB_ITEM pItem, const char * szClass, const char * szFunc ); /* set object class handle using class name and class function name */
extern HB_EXPORT const char * hb_objGetClsName( PHB_ITEM pObject ); /* retrieves an object class name */
extern HB_EXPORT const char * hb_objGetRealClsName( PHB_ITEM pObject, const char * szString ); /* retrieves an object class name for a specific message */

2
include/hbapierr.h
View File

@@ -127,6 +127,8 @@ extern HB_EXPORT void hb_errRelease ( PHB_ITEM pError );
extern void hb_errInit ( void );
extern void hb_errExit ( void );
extern HB_EXPORT void hb_errReinit( PHB_ITEM pError );
extern HB_EXPORT PHB_ITEM hb_errLaunchSubst( PHB_ITEM pError );
extern HB_EXPORT PHB_ITEM hb_errRT_New( HB_USHORT uiSeverity,

1
src/harbour.def
View File

@@ -2444,6 +2444,7 @@ hb_errRT_New
hb_errRT_New_Subst
hb_errRT_SubstParams
hb_errRT_TERM
hb_errReinit
hb_errRelease
hb_errorBlock
hb_errorHandler

35
src/rtl/errapi.c
View File

@@ -82,8 +82,10 @@ HB_FUNC_EXTERN( ERRORNEW );
static PHB_ITEM s_pError = NULL;
static HB_BOOL s_fErrInit = HB_FALSE;
static HB_SYMB s_symErrorNew = { "ERRORNEW", { HB_FS_PUBLIC | HB_FS_LOCAL }, { HB_FUNCNAME( ERRORNEW ) }, NULL };
static HB_SYMB s_symmsgInit = { "INIT", { HB_FS_MESSAGE }, { NULL }, NULL };
typedef struct
{
@@ -478,11 +480,14 @@ void hb_errInit( void )
/* error function */
hb_dynsymNew( &s_symErrorNew );
/* init message */
hb_dynsymNew( &s_symmsgInit );
/* Create error class and base object */
s_pError = hb_itemNew( NULL );
hb_clsAssociate( hb_errClassCreate() );
hb_itemMove( s_pError, hb_stackReturnItem() );
s_fErrInit = hb_objHasMessage( s_pError, s_symmsgInit.pDynSym );
}
void hb_errExit( void )
@@ -493,14 +498,42 @@ void hb_errExit( void )
s_pError = NULL;
}
void hb_errReinit( PHB_ITEM pError )
{
if( pError && HB_IS_OBJECT( pError ) )
{
hb_itemRelease( s_pError );
s_pError = hb_itemNew( pError );
}
/* intentionaly outside above if() block so it can be called
* with NULL parameter just to refresh :Init() method status
* after class modification [druzus]
*/
s_fErrInit = hb_objHasMessage( s_pError, s_symmsgInit.pDynSym );
}
PHB_ITEM hb_errNew( void )
{
PHB_ITEM pError;
HB_TRACE( HB_TR_DEBUG, ( "hb_errNew()" ) );
if( ! s_pError || ! HB_IS_OBJECT( s_pError ) )
hb_errInternal( HB_EI_ERRRECFAILURE, NULL, NULL, NULL );
return hb_arrayClone( s_pError );
pError = hb_arrayClone( s_pError );
if( s_fErrInit )
{
if( hb_vmRequestReenter() )
{
hb_vmPushSymbol( &s_symmsgInit );
hb_vmPush( pError );
hb_vmSend( 0 );
hb_vmRequestRestore();
}
}
return pError;
}
HB_USHORT hb_errLaunch( PHB_ITEM pError )