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