From 05dd30df9b1ccd56374e9640cd24f6bd77f88407 Mon Sep 17 00:00:00 2001 From: Przemyslaw Czerpak Date: Tue, 22 Apr 2008 02:51:18 +0000 Subject: [PATCH] 2008-04-22 04:50 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * harbour/include/hbapicls.h * harbour/source/vm/classes.c + added new function hb_dbgObjSendMessage() which allows to call messages with given given execution context for proper scope checking * harbour/source/debug/dbgentry.c + added HB_DBG_SENDMSG() for calling messages with given execution context * harbour/source/debug/dbgtobj.prg * removed all __obj*() function calls * use HB_DBG_SENDMSG() to access/assign object variables ! fixed default value in GET operation called from object inspector to always show current object variable value ! fixed set for object variables which hold value: "Method" they were recognized as method Now object variables can be inspected by debugger. If object has multiple private messages with the same name inherited from parent classes then their context will be dynamically changed depending on position in currently debugged code. --- harbour/ChangeLog | 24 ++++++++ harbour/include/hbapicls.h | 2 + harbour/source/debug/dbgentry.c | 7 +++ harbour/source/debug/dbgtobj.prg | 92 ++++++++++++++++++++++------ harbour/source/vm/classes.c | 100 +++++++++++++++++++++++++++---- 5 files changed, 193 insertions(+), 32 deletions(-) diff --git a/harbour/ChangeLog b/harbour/ChangeLog index f6cb5e0553..6683b7532e 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,30 @@ 2008-12-31 13:59 UTC+0100 Foo Bar */ +2008-04-22 04:50 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + * harbour/include/hbapicls.h + * harbour/source/vm/classes.c + + added new function hb_dbgObjSendMessage() which allows to + call messages with given given execution context for proper + scope checking + + * harbour/source/debug/dbgentry.c + + added HB_DBG_SENDMSG() for calling messages with given execution + context + + * harbour/source/debug/dbgtobj.prg + * removed all __obj*() function calls + * use HB_DBG_SENDMSG() to access/assign object variables + ! fixed default value in GET operation called from object + inspector to always show current object variable value + ! fixed set for object variables which hold value: "Method" + they were recognized as method + Now object variables can be inspected by debugger. + If object has multiple private messages with the same name + inherited from parent classes then their context will be + dynamically changed depending on position in currently + debugged code. + 2008-04-21 15:54 UTC+0100 Viktor Szakats (harbour.01 syenar hu) * source/rtl/tbrowse.prg ! Added some new lines to XPP methods. diff --git a/harbour/include/hbapicls.h b/harbour/include/hbapicls.h index b35a6efde6..0e5eb13f53 100644 --- a/harbour/include/hbapicls.h +++ b/harbour/include/hbapicls.h @@ -126,6 +126,8 @@ HB_EXPORT extern BOOL hb_objHasMessage( PHB_ITEM pObject, PHB_DYNS pMessag HB_EXPORT extern PHB_ITEM hb_objSendMsg( PHB_ITEM pObj, const char *sMsg, ULONG ulArg, ... ); HB_EXPORT extern PHB_ITEM hb_objSendMessage( PHB_ITEM pObj, PHB_DYNS pMessage, ULONG ulArg, ... ); +/* send message which allows to set execution context for debugger */ +HB_EXPORT extern void hb_dbgObjSendMessage( int iProcLevel, PHB_ITEM pObject, PHB_ITEM pMessage, int iParamOffset ); /* Harbour equivalent for Clipper internal __mdCreate() */ USHORT hb_clsCreate( USHORT usSize, const char * szClassName ); diff --git a/harbour/source/debug/dbgentry.c b/harbour/source/debug/dbgentry.c index f0b0f4d95d..1bced51f90 100644 --- a/harbour/source/debug/dbgentry.c +++ b/harbour/source/debug/dbgentry.c @@ -54,6 +54,7 @@ #include "hbvmopt.h" #include "hbapidbg.h" #include "hbapiitm.h" +#include "hbapicls.h" #include "hbapirdd.h" #include "hbstack.h" #include "hbvm.h" @@ -1749,3 +1750,9 @@ HB_FUNC( HB_DBG_SETWATCH ) if( ptr ) hb_dbgSetWatch( ptr, hb_parni( 2 ), hb_parc( 3 ), hb_parl( 4 ) ); } + +HB_FUNC( HB_DBG_SENDMSG ) +{ + hb_dbgObjSendMessage( hb_parnl( 1 ), hb_param( 2, HB_IT_ANY ), + hb_param( 3, HB_IT_ANY ), 4 ); +} diff --git a/harbour/source/debug/dbgtobj.prg b/harbour/source/debug/dbgtobj.prg index 53b505184c..fd43495a69 100644 --- a/harbour/source/debug/dbgtobj.prg +++ b/harbour/source/debug/dbgtobj.prg @@ -77,21 +77,29 @@ ENDCLASS METHOD New( oObject, cVarName, lEditable ) CLASS HBDbObject - LOCAL aTemp + LOCAL cMsg, cMsgAcc + LOCAL aMessages, aMethods + LOCAL xValue DEFAULT lEditable TO .T. - FOR EACH aTemp IN __objGetValueList( oObject ) - AAdd( ::pItems, { aTemp[ 1 ], aTemp[ 2 ] } ) - AAdd( ::AllNames, aTemp[ 1 ] ) - NEXT - - FOR EACH aTemp IN __objGetMethodList( oObject ) - IF !Empty( aTemp ) - AAdd( ::pItems, { aTemp, "Method" } ) - AAdd( ::AllNames, aTemp ) + /* create list of object messages */ + aMessages := oObject:classSel() + aMethods := {} + FOR EACH cMsg IN aMessages + IF Left( cMsg, 1 ) == "_" .AND. ; + HB_AScan( aMessages, cMsgAcc := Substr( cMsg, 2 ),,, .T. ) != 0 + xValue := __dbgObjGetValue( oObject, cMsgAcc ) + AAdd( ::pItems, { cMsgAcc, xValue, .T. } ) + AAdd( ::AllNames, cMsgAcc ) + ELSEIF HB_AScan( aMessages, "_" + cMsg,,, .T. ) == 0 + AAdd( aMethods, cMsg ) ENDIF NEXT + FOR EACH cMsg IN aMethods + AAdd( ::pItems, { cMsg, "Method", .F. } ) + AAdd( ::AllNames, cMsg ) + NEXT ::objname := cVarName ::TheObj := oObject @@ -133,7 +141,7 @@ METHOD addWindows( aArray, nRow ) CLASS HBDbObject oBrwSets:GoTopBlock := { || ::Arrayindex := 1 } oBrwSets:GoBottomBlock := { || ::arrayindex := Len( ::ArrayReference ) } oBrwSets:SkipBlock := { | nSkip, nPos | nPos := ::arrayindex,; - ::arrayindex := iif( nSkip > 0, Min( ::arrayindex + nSkip, Len( ::arrayreference ) ),; + ::arrayindex := iif( nSkip > 0, Min( ::arrayindex + nSkip, Len( ::arrayReference ) ),; Max( 1, ::arrayindex + nSkip ) ), ::arrayindex - nPos } nMaxLen := ArrayMaxLen( ::AllNames ) @@ -143,16 +151,16 @@ METHOD addWindows( aArray, nRow ) CLASS HBDbObject oCol:ColorBlock := { || { iif( ::Arrayindex == oBrwSets:Cargo, 2, 1 ), 2 } } oBrwSets:Freeze := 1 - oBrwSets:AddColumn( oCol := TBColumnNew( "", { || iif( ISCHARACTER( ::ArrayReference[ ::ArrayIndex, 2 ] ) .AND. ::ArrayReference[ ::ArrayIndex, 2 ] == "Method",; - "Method",; - PadR( __dbgValToStr( __objSendMsg( ::TheObj, ::ArrayReference[ ::arrayindex, 1 ] ) ), nWidth - 12 ) ) } ) ) + oBrwSets:AddColumn( oCol := TBColumnNew( "", { || iif( ISCHARACTER( ::ArrayReference[ ::ArrayIndex, 2 ] ) .AND. !::ArrayReference[ ::ArrayIndex, 3 ],; + ::ArrayReference[ ::ArrayIndex, 2 ],; + PadR( __dbgValToStr( __dbgObjGetValue( ::TheObj, ::ArrayReference[ ::arrayindex, 1 ] ) ), nWidth - 12 ) ) } ) ) oBrwSets:Cargo := 1 // Actual highlighted row oCol:ColorBlock := { || { iif( ::Arrayindex == oBrwSets:Cargo, 3, 1 ), 3 } } oCol:width := MaxCol() - 14 - nMaxLen oBrwSets:colPos := 2 ::aWindows[ ::nCurWindow ]:bPainted := { || oBrwSets:ForceStable() } - ::aWindows[ ::nCurWindow ]:bKeyPressed := { | nKey | ::SetsKeyPressed( nKey, oBrwSets, Len( aArray ), ::Arrayreference ) } + ::aWindows[ ::nCurWindow ]:bKeyPressed := { | nKey | ::SetsKeyPressed( nKey, oBrwSets, Len( aArray ), ::ArrayReference ) } ::aWindows[ ::nCurwindow ]:cCaption := ::objname + " is of class: " +::TheObj:ClassName() SetCursor( SC_NONE ) @@ -172,6 +180,7 @@ METHOD doGet( oBrowse, pItem, nSet ) CLASS HBDbObject LOCAL lExitSave := Set( _SET_EXIT, .T. ) LOCAL bInsSave := SetKey( K_INS ) LOCAL cValue + LOCAL lCanAcc // make sure browse is stable oBrowse:forceStable() @@ -190,7 +199,12 @@ METHOD doGet( oBrowse, pItem, nSet ) CLASS HBDbObject column := oBrowse:getColumn( oBrowse:colPos ) // create a corresponding GET - cValue := PadR( __dbgValToStr( pitem[ nSet, 2 ] ), column:Width ) + cValue := __dbgObjGetValue( ::TheObj, pitem[ nSet, 1 ], @lCanAcc ) + IF !lCanAcc + Alert( cValue ) + RETURN NIL + ENDIF + cValue := PadR( __dbgValToStr( cValue ), column:Width ) @ Row(), Col() GET cValue ; VALID iif( Type( cValue ) == "UE", ( Alert( "Expression error" ), .F. ), .T. ) @@ -202,7 +216,7 @@ METHOD doGet( oBrowse, pItem, nSet ) CLASS HBDbObject SetKey( K_INS, bInsSave ) IF LastKey() == K_ENTER - __objSendMsg( ::TheObj, "_" + pitem[ nSet, 1 ], &cValue ) + __dbgObjSetValue( ::TheObj, pitem[ nSet, 1 ], &cValue ) ENDIF // check exit key from get @@ -289,14 +303,14 @@ METHOD SetsKeyPressed( nKey, oBrwSets, nSets, aArray ) CLASS HBDbObject ELSEIF ISOBJECT( aArray[ nSet, 2 ] ) HBDbObject():New( aArray[ nSet, 2 ], ::pitems[ nSet, 1 ] ) ELSEIF ( ISCHARACTER( aArray[ nSet, 2 ] ) .AND. ; - aArray[ nSet, 2 ] == "Method" ) .OR. ; + !aArray[ nSet, 3 ] ) .OR. ; ISBLOCK( aArray[ nSet, 2 ] ) .OR. ; ValType( aArray[ nSet, 2 ] ) == "P" Alert( "Value cannot be edited" ) ELSE IF ::lEditable oBrwSets:RefreshCurrent() - ::doGet( oBrwSets, ::arrayreference, nSet ) + ::doGet( oBrwSets, ::arrayReference, nSet ) oBrwSets:RefreshCurrent() oBrwSets:ForceStable() else @@ -326,3 +340,43 @@ STATIC FUNCTION ArrayMaxLen( aArray ) NEXT RETURN nMaxLen + +STATIC FUNCTION __dbgObjGetValue( oObject, cVar, lCanAcc ) + + LOCAL nProcLevel := __Dbg():nProcLevel + LOCAL xResult + LOCAL oErr + + BEGIN SEQUENCE WITH {|| break() } + xResult := HB_DBG_SENDMSG( nProcLevel, oObject, cVar ) + lCanAcc := .T. + RECOVER + BEGIN SEQUENCE WITH {|oErr| break( oErr ) } + /* Try to access variables using class code level */ + xResult := HB_DBG_SENDMSG( 0, oObject, cVar ) + lCanAcc := .T. + RECOVER USING oErr + xResult := oErr:description + lCanAcc := .F. + END SEQUENCE + END SEQUENCE + + RETURN xResult + +STATIC FUNCTION __dbgObjSetValue( oObject, cVar, xValue ) + + LOCAL nProcLevel := __Dbg():nProcLevel + LOCAL oErr + + BEGIN SEQUENCE WITH {|| break() } + HB_DBG_SENDMSG( nProcLevel, oObject, "_" + cVar, xValue ) + RECOVER + BEGIN SEQUENCE WITH {|oErr| break( oErr ) } + /* Try to access variables using class code level */ + HB_DBG_SENDMSG( 0, oObject, "_" + cVar, xValue ) + RECOVER USING oErr + Alert( oErr:description ) + END SEQUENCE + END SEQUENCE + + RETURN xValue diff --git a/harbour/source/vm/classes.c b/harbour/source/vm/classes.c index 391f517410..01fd48bb9b 100644 --- a/harbour/source/vm/classes.c +++ b/harbour/source/vm/classes.c @@ -1520,7 +1520,7 @@ static PHB_SYMB hb_clsScalarMethod( PCLASS pClass, PHB_DYNS pMsg, if( pStack ) { - pStack->uiClass = pClass - s_pClasses; + pStack->uiClass = ( USHORT ) ( pClass - s_pClasses ); if( pMethod ) { pStack->uiMethod = ( USHORT ) ( pMethod - pClass->pMethods ); @@ -2264,6 +2264,74 @@ static PHB_SYMB hb_objGetFuncSym( PHB_ITEM pItem ) return NULL; } +/* send message which allows to set execution context for debugger */ +HB_EXPORT void hb_dbgObjSendMessage( int iProcLevel, PHB_ITEM pObject, PHB_ITEM pMessage, int iParamOffset ) +{ + PHB_DYNS pMsgSym; + + pMsgSym = hb_objGetMsgSym( pMessage ); + if( pObject && pMsgSym ) + { + USHORT uiParams = 0; + + /* set requested sender class and method id for scope verification */ + if( iProcLevel > 0 ) + { + int iLevel = hb_stackCallDepth(); + if( iProcLevel < iLevel ) + { + LONG lOffset = hb_stackBaseProcOffset( iLevel - iProcLevel ); + if( lOffset > 0 ) + { + PHB_ITEM pItem = hb_stackItem( lOffset ); + PHB_ITEM pBase = hb_stackBaseItem(); + pBase->item.asSymbol.stackstate->uiClass = + pItem->item.asSymbol.stackstate->uiClass; + pBase->item.asSymbol.stackstate->uiMethod = + pItem->item.asSymbol.stackstate->uiMethod; + } + } + } + else if( iProcLevel == 0 ) + { + /* set scope like for internal object messages to any visible + method without respecting overloaded methods */ + USHORT uiClass = hb_objGetClassH( pObject ); + + if( uiClass && uiClass <= s_uiClasses ) + { + PMETHOD pMethod = hb_clsFindMsg( &s_pClasses[ uiClass ], pMsgSym ); + if( pMethod ) + { + PHB_ITEM pBase = hb_stackBaseItem(); + + pBase->item.asSymbol.stackstate->uiClass = uiClass; + pBase->item.asSymbol.stackstate->uiMethod = + ( USHORT ) ( pMethod - s_pClasses[ uiClass ].pMethods ); + } + } + } + + hb_vmPushSymbol( pMsgSym->pSymbol ); + hb_vmPush( pObject ); + + if( iParamOffset > 0 ) + { + int iPCount = hb_pcount(); + + while( iParamOffset <= iPCount ) + { + hb_vmPush( hb_stackItemFromBase( iParamOffset ) ); + ++uiParams; + ++iParamOffset; + } + } + hb_vmSend( uiParams ); + } + else + hb_errRT_BASE( EG_ARG, 3000, NULL, "hb_dbgObjSendMessage()", 2, pObject, pMsgSym ); +} + static USHORT hb_clsUpdateScope( USHORT uiScope, BOOL fAssign ) { if( !fAssign ) @@ -4332,25 +4400,32 @@ HB_FUNC( __CLSGETPROPERTIES ) if( uiClass && uiClass <= s_uiClasses ) { PCLASS pClass = &s_pClasses[ uiClass ]; - PMETHOD pMethod = pClass->pMethods; - ULONG ulLimit = hb_clsMthNum( pClass ); - PHB_ITEM pItem = NULL; - - hb_arrayNew( pReturn, 0 ); + PMETHOD pMethod; + ULONG ulLimit, ulCount; + ulCount = 0; + ulLimit = hb_clsMthNum( pClass ); + pMethod = pClass->pMethods; do { if( pMethod->pMessage && ( pMethod->uiScope & HB_OO_CLSTP_PERSIST ) ) - { - pItem = hb_itemPutC( pItem, pMethod->pMessage->pSymbol->szName ); - hb_arrayAdd( pReturn, pItem ); - } + ++ulCount; ++pMethod; } while( --ulLimit ); - if( pItem ) - hb_itemRelease( pItem ); + hb_arrayNew( pReturn, ulCount ); + + ulCount = 0; + ulLimit = hb_clsMthNum( pClass ); + pMethod = pClass->pMethods; + do + { + if( pMethod->pMessage && ( pMethod->uiScope & HB_OO_CLSTP_PERSIST ) ) + hb_arraySetC( pReturn, ++ulCount, pMethod->pMessage->pSymbol->szName ); + ++pMethod; + } + while( --ulLimit ); } hb_itemReturnRelease( pReturn ); @@ -4413,7 +4488,6 @@ void hb_clsAssociate( USHORT usClassH ) hb_itemReturnRelease( pSelf ); } - #if 1 /* * __CLS_PARAM() and __CLS_PAR00() functions are only for backward binary