diff --git a/ChangeLog.txt b/ChangeLog.txt index 13bae10512..10bf74756a 100644 --- a/ChangeLog.txt +++ b/ChangeLog.txt @@ -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 diff --git a/contrib/xhb/xhb.h b/contrib/xhb/xhb.h index 58c9f9e780..a73bbd17c5 100644 --- a/contrib/xhb/xhb.h +++ b/contrib/xhb/xhb.h @@ -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 ); diff --git a/contrib/xhb/xhb.hbp b/contrib/xhb/xhb.hbp index 4fd16cb35d..e8f564ce7c 100644 --- a/contrib/xhb/xhb.hbp +++ b/contrib/xhb/xhb.hbp @@ -45,6 +45,7 @@ xhbctbit.c xhbdate.c xhbenum.c xhberrc.c +xhberror.c xhbfs.c xhbfunc.c xhbgt.c diff --git a/contrib/xhb/xhberr.prg b/contrib/xhb/xhberr.prg index 67885b256d..7de3e430a5 100644 --- a/contrib/xhb/xhberr.prg +++ b/contrib/xhb/xhberr.prg @@ -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 diff --git a/contrib/xhb/xhbmemo.prg b/contrib/xhb/xhbmemo.prg index cc42f12a73..76916b83eb 100644 --- a/contrib/xhb/xhbmemo.prg +++ b/contrib/xhb/xhbmemo.prg @@ -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, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nTop ) .AND. ! HB_ISNUMERIC( nTop ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nLeft ) .AND. ! HB_ISNUMERIC( nLeft ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nRight ) .AND. ! HB_ISNUMERIC( nRight ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nBottom ) .AND. ! HB_ISNUMERIC( nBottom ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( lEditMode ) .AND. ! HB_ISLOGICAL( lEditMode ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( xUDF ) .AND. ! HB_ISSTRING( xUDF ) .AND. ! HB_ISLOGICAL( xUDF ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nLineLength ) .AND. ! HB_ISNUMERIC( nLineLength ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nTabSize ) .AND. ! HB_ISNUMERIC( nTabSize ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nTextBuffRow ) .AND. ! HB_ISNUMERIC( nTextBuffRow ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nTextBuffColumn ) .AND. ! HB_ISNUMERIC( nTextBuffColumn ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nWindowRow ) .AND. ! HB_ISNUMERIC( nWindowRow ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) ENDIF IF ! HB_ISNIL( nWindowColumn ) .AND. ! HB_ISNUMERIC( nWindowColumn ) - Throw( ErrorNew( "BASE", 0, 1127, " Argument type error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " 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, " Argument error", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, " Argument error", ProcName() ) ) ENDIF IF HB_ISSTRING( xUDF ) .AND. Empty( xUDF ) diff --git a/contrib/xhb/xhbtedit.prg b/contrib/xhb/xhbtedit.prg index 373dc633ea..09ec3b7c69 100644 --- a/contrib/xhb/xhbtedit.prg +++ b/contrib/xhb/xhbtedit.prg @@ -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: ", ProcName() ) ) + Throw( xhb_ErrorNew( "BASE", 0, 1127, "Argument error: ", ProcName() ) ) ENDIF diff --git a/include/hbapicls.h b/include/hbapicls.h index f1c2ca7f9c..3ecc904aba 100644 --- a/include/hbapicls.h +++ b/include/hbapicls.h @@ -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 */ diff --git a/include/hbapierr.h b/include/hbapierr.h index 68299a0182..3171807b2c 100644 --- a/include/hbapierr.h +++ b/include/hbapierr.h @@ -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, diff --git a/src/harbour.def b/src/harbour.def index a94126ee84..169e0c6cee 100644 --- a/src/harbour.def +++ b/src/harbour.def @@ -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 diff --git a/src/rtl/errapi.c b/src/rtl/errapi.c index 8da99f95be..1e366bc6ab 100644 --- a/src/rtl/errapi.c +++ b/src/rtl/errapi.c @@ -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 )