From 4fe32a0a7970e5c5f5077dd7587cfb2a5199e844 Mon Sep 17 00:00:00 2001 From: Przemyslaw Czerpak Date: Fri, 8 May 2009 12:27:40 +0000 Subject: [PATCH] 2009-05-08 14:35 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * harbour/source/vm/Makefile * respect HB_HVM_ALL user settings ! export HB_HVM_ALL value set automatically - otherwise it's not seen when HBVMMT is compiled * harbour/source/vm/classes.c * exteneded :classsel() build in method to repsect scope given as 2-nd parameter and return extended information compatible with :ClassFullSel() implemented in xHarbour by Francesco Saverio Giudice. This extended info is returned when 3-rd parameter is .T. * harbour/source/rtl/dateshb.c * do not generate RTE on wrong params in HB_STOT() function * harbour/contrib/xhb/xhbfunc.c + added hacked function which allows to send messages without respecting scope. It works only for the most visible data and does not support any automatic casting. * harbour/contrib/xhb/dumpvar.prg ! fixed HB_DumpVar() results on platforms where CRLF has different length then 2 % small improve in hash item presentation + added __objGetMsgFullList() and __objGetValueFullList() as static functions. Code borrowed form xHarbour by Francesco Saverio Giudice. * make HB_DumpVar() working with object values. --- harbour/ChangeLog | 28 +++++++ harbour/contrib/xhb/dumpvar.prg | 130 ++++++++++++++++++++++++++------ harbour/contrib/xhb/xhbfunc.c | 7 ++ harbour/source/rtl/dateshb.c | 2 +- harbour/source/vm/Makefile | 4 + harbour/source/vm/classes.c | 68 +++++++++++++++-- 6 files changed, 209 insertions(+), 30 deletions(-) diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 8f1d096080..3e569aa535 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -17,6 +17,34 @@ past entries belonging to these authors: Viktor Szakats. */ +2009-05-08 14:35 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + * harbour/source/vm/Makefile + * respect HB_HVM_ALL user settings + ! export HB_HVM_ALL value set automatically - otherwise it's not seen + when HBVMMT is compiled + + * harbour/source/vm/classes.c + * exteneded :classsel() build in method to repsect scope given as + 2-nd parameter and return extended information compatible with + :ClassFullSel() implemented in xHarbour by Francesco Saverio Giudice. + This extended info is returned when 3-rd parameter is .T. + + * harbour/source/rtl/dateshb.c + * do not generate RTE on wrong params in HB_STOT() function + + * harbour/contrib/xhb/xhbfunc.c + + added hacked function which allows to send messages without respecting + scope. It works only for the most visible data and does not support + any automatic casting. + + * harbour/contrib/xhb/dumpvar.prg + ! fixed HB_DumpVar() results on platforms where CRLF has different + length then 2 + % small improve in hash item presentation + + added __objGetMsgFullList() and __objGetValueFullList() as static + functions. Code borrowed form xHarbour by Francesco Saverio Giudice. + * make HB_DumpVar() working with object values. + 2009-05-08 10:14 UTC+0200 Viktor Szakats (harbour.01 syenar hu) * source/rtl/tclass.prg ! Fix to prev commit. diff --git a/harbour/contrib/xhb/dumpvar.prg b/harbour/contrib/xhb/dumpvar.prg index b65b2d9265..dae4f67635 100644 --- a/harbour/contrib/xhb/dumpvar.prg +++ b/harbour/contrib/xhb/dumpvar.prg @@ -94,6 +94,7 @@ FUNCTION HB_DumpVar( xVar, lRecursive, nMaxRecursionLevel ) STATIC FUNCTION __HB_DumpVar( xVar, lAssocAsObj, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel ) LOCAL cType := ValType( xVar ) LOCAL cString := "", cKey + LOCAL nEolLen DEFAULT lAssocAsObj TO FALSE DEFAULT lRecursive TO FALSE @@ -113,16 +114,17 @@ STATIC FUNCTION __HB_DumpVar( xVar, lAssocAsObj, lRecursive, nIndent, nRecursion cString += Space( nIndent ) + "Type='Associative' -> " + CRLF // Keys extraction. IF Len( xVar:Keys ) > 0 + nEolLen := Len( CRLF ) cString += Space( nIndent ) + "{" + CRLF FOR EACH cKey IN xVar:Keys cString += Space( nIndent ) + " '" + cKey + "' => " + asString( xVar:SendKey( cKey ) ) + ", " + CRLF IF lRecursive .AND. ValType( xVar:SendKey( cKey ) ) $ "AOH" - cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF + cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + CRLF cString += __HB_DumpVar( xVar:SendKey( cKey ),, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel ) - cString := SubStr( cString, 1, Len( cString )-2 ) + ", " + CRLF + cString := SubStr( cString, 1, Len( cString )-nEolLen ) + ", " + CRLF ENDIF NEXT - cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF + cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + CRLF cString += Space( nIndent ) + "}" + CRLF ENDIF ELSE @@ -170,16 +172,15 @@ STATIC FUNCTION __HB_DumpVar( xVar, lAssocAsObj, lRecursive, nIndent, nRecursion STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel ) LOCAL xProp, aProps LOCAL aMethods, aMth - LOCAL lOldScope LOCAL cString := "" DEFAULT nIndent TO 0 IF ValType( oVar ) == "O" - lOldScope := __SetClassScope( .F. ) +// lOldScope := __SetClassScope( .F. ) aMethods := __objGetMsgFullList( oVar, .F., HB_MSGLISTALL, nScope ) aProps := __objGetValueFullList( oVar, NIL, nScope ) - __SetClassScope( lOldScope ) +// __SetClassScope( lOldScope ) IF Len( aProps ) > 0 cString += Space( nIndent ) + " | +- >> Begin Data ------" + CRLF @@ -207,7 +208,7 @@ STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLe RETURN cString STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel ) - LOCAL xVal, nChar + LOCAL xVal, nChar, nEolLen LOCAL cString := "" DEFAULT nIndent TO 0 @@ -215,19 +216,20 @@ STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecu //TraceLog( "DShowArray: aVar, lRecursive", aVar, lRecursive ) IF ValType( aVar ) == "A" + nEolLen := Len( CRLF ) nChar := Len( LTrim( Str( Len( aVar ) ) ) ) // return number of chars to display that value // i.e. if Len( aVar ) == 99, then nChar := 2 cString += Space( nIndent ) + "{" + CRLF FOR EACH xVal IN aVar cString += Space( nIndent ) + " ["+ LTrim( StrZero( xVal:__EnumIndex(), nChar ) ) + "] => " + AsString( xVal ) + ", " + CRLF IF lRecursive .AND. ValType( xVal ) $ "AOH" - cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF + cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + CRLF cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel ) - cString := SubStr( cString, 1, Len( cString )-2 ) + ", " + CRLF + cString := SubStr( cString, 1, Len( cString )-nEolLen ) + ", " + CRLF ENDIF NEXT IF Len( aVar ) > 0 - cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF + cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + CRLF ENDIF cString += Space( nIndent ) + "}" + CRLF ENDIF @@ -235,7 +237,8 @@ STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecu RETURN cString STATIC FUNCTION DShowHash( hVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel ) - LOCAL xVal, xKey, aKeys + LOCAL xVal + LOCAL nEolLen LOCAL cString := "" DEFAULT nIndent TO 0 @@ -243,19 +246,18 @@ STATIC FUNCTION DShowHash( hVar, lRecursive, nIndent, nRecursionLevel, nMaxRecur //TraceLog( "DShowHash: hVar, ValType( hVar ), lRecursive", hVar, ValType( hVar ), ValToPrg( hVar ), lRecursive ) IF ValType( hVar ) == "H" - aKeys := hb_HKeys( hVar ) + nEolLen := Len( CRLF ) cString += Space( nIndent ) + "{" + CRLF - FOR EACH xKey IN aKeys - xVal := hVar[ xKey ] - cString += Space( nIndent ) + " ["+ LTrim( AsString( xKey ) ) + "] => " + AsString( xVal ) + ", " + CRLF - IF lRecursive .AND. ValType( xVal ) $ "AOH" - cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF - cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel ) - cString := SubStr( cString, 1, Len( cString )-2 ) + ", " + CRLF - ENDIF + FOR EACH xVal IN hVar + cString += Space( nIndent ) + " ["+ LTrim( AsString( xVal:__enumKey() ) ) + "] => " + AsString( xVal ) + ", " + CRLF + IF lRecursive .AND. ValType( xVal ) $ "AOH" + cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + CRLF + cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel ) + cString := SubStr( cString, 1, Len( cString )-nEolLen ) + ", " + CRLF + ENDIF NEXT - IF Len( aKeys ) > 0 - cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF + IF Len( hVar ) > 0 + cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + CRLF ENDIF cString += Space( nIndent ) + "}" + CRLF ENDIF @@ -327,6 +329,12 @@ STATIC FUNCTION DecodeType( nType AS NUMERIC ) cString += "MsgPrp" CASE nType == HB_OO_MSG_CLASSPROPERTY // 10 cString += "ClsPrp" + CASE nType == HB_OO_MSG_REALCLASS + cString += "RealCls" + CASE nType == HB_OO_MSG_DELEGATE + cString += "Delegate" + CASE nType == HB_OO_MSG_PERFORM + cString += "Perform" ENDCASE RETURN PadR( cString, 7 ) @@ -338,7 +346,83 @@ STATIC FUNCTION asString( x ) CASE v == "C" RETURN '"' + x + '"' OTHERWISE - RETURN cStr( x ) + RETURN hb_cStr( x ) ENDCASE RETURN x + + +#include "error.ch" + +/* + * (C) 2003 - Francesco Saverio Giudice + * + * return all informations about classes, included type and scope +*/ +STATIC FUNCTION __objGetMsgFullList( oObject, lData, nRange, nScope, nNoScope ) + LOCAL aMessages + LOCAL aReturn + LOCAL nFirstProperty, aMsg + + IF ValType( oObject ) != 'O' + __errRT_BASE( EG_ARG, 3101, NIL, ProcName() ) + ENDIF + + IF ValType( lData ) != 'L' + lData := .T. + ENDIF + + IF ValType( nNoScope ) != 'N' + nNoScope := 0 + ENDIF + + // nRange is already defaulted in ClassFullSel in classes.c + + aMessages := ASort( oObject:ClassSel( nRange, nScope, .T. ),,, {|x,y| x[HB_OO_DATA_SYMBOL] < y[HB_OO_DATA_SYMBOL] } ) + aReturn := {} + + nFirstProperty := aScan( aMessages, { | aElement | Left( aElement[HB_OO_DATA_SYMBOL], 1 ) == '_' } ) + + FOR EACH aMsg IN aMessages + + IF Left( aMsg[HB_OO_DATA_SYMBOL], 1 ) == '_' + LOOP + ENDIF + + IF ( AScan( aMessages, { | aElement | aElement[HB_OO_DATA_SYMBOL] == "_" + aMsg[HB_OO_DATA_SYMBOL] }, nFirstProperty ) != 0 ) == lData + IF nNoScope == 0 .OR. HB_BITAND( aMsg[HB_OO_DATA_SCOPE], nNoScope ) == 0 + AAdd( aReturn, aMsg ) + ENDIF + ENDIF + NEXT + +RETURN aReturn + +/* + * (C) 2003 - Francesco Saverio Giudice + * + * return all values from classes, included type and scope +*/ +STATIC FUNCTION __objGetValueFullList( oObject, aExcept, nScope, nNoScope ) + LOCAL aVars + LOCAL aReturn + LOCAL aVar + + IF ValType( oObject ) != 'O' + __errRT_BASE( EG_ARG, 3101, NIL, ProcName( 0 ) ) + ENDIF + + IF ValType( aExcept ) != 'A' + aExcept := {} + ENDIF + + aVars := __objGetMsgFullList( oObject, .T., HB_MSGLISTALL, nScope, nNoScope ) + aReturn := {} + FOR EACH aVar IN aVars + IF hb_aScan( aExcept, aVar[HB_OO_DATA_SYMBOL],,, .T. ) == 0 + //TraceLog( "__objGetValueFullList(): aVar[HB_OO_DATA_SYMBOL]", aVar[HB_OO_DATA_SYMBOL] ) + AAdd( aReturn, { aVar[HB_OO_DATA_SYMBOL], __SendRawMsg( oObject, aVar[HB_OO_DATA_SYMBOL] ), aVar[HB_OO_DATA_TYPE], aVar[HB_OO_DATA_SCOPE] } ) + ENDIF + NEXT + +RETURN aReturn diff --git a/harbour/contrib/xhb/xhbfunc.c b/harbour/contrib/xhb/xhbfunc.c index a37dcdc523..f0a221e6f7 100644 --- a/harbour/contrib/xhb/xhbfunc.c +++ b/harbour/contrib/xhb/xhbfunc.c @@ -54,6 +54,7 @@ #include "hbapigt.h" #include "hbapiitm.h" #include "hbapigt.h" +#include "hbapicls.h" #if 0 @@ -212,6 +213,12 @@ HB_FUNC( HB_ARRAYID ) /* for debugging: returns the array's "address" so dual r hb_retptr( pArray ? hb_arrayId( pArray ) : NULL ); } +HB_FUNC( __SENDRAWMSG ) +{ + hb_dbg_objSendMessage( 0, hb_param( 1, HB_IT_ANY ), + hb_param( 2, HB_IT_ANY ), 3 ); +} + /* Hash utem functions */ HB_FUNC_EXTERN( HB_HASH ); HB_FUNC_EXTERN( HB_HHASKEY ); diff --git a/harbour/source/rtl/dateshb.c b/harbour/source/rtl/dateshb.c index 75081b74e1..7c434e36ef 100644 --- a/harbour/source/rtl/dateshb.c +++ b/harbour/source/rtl/dateshb.c @@ -319,7 +319,7 @@ HB_FUNC( HB_STOT ) hb_rettdt( lDate, lTime ); } else - hb_errRT_BASE_SubstR( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS ); + hb_rettdt( 0, 0 ); } HB_FUNC( HB_HOUR ) diff --git a/harbour/source/vm/Makefile b/harbour/source/vm/Makefile index deeb5aa713..64c7355fee 100644 --- a/harbour/source/vm/Makefile +++ b/harbour/source/vm/Makefile @@ -4,6 +4,8 @@ ROOT = ../../ +ifeq ($(HB_HVM_ALL),) + HB_HVM_ALL = yes ifeq ($(HB_COMPILER),owatcom) ifeq ($(HB_ARCHITECTURE),win) @@ -28,6 +30,8 @@ endif ifeq ($(HB_COMPILER),dmc) HB_HVM_ALL = no endif +export HB_HVM_ALL +endif ifeq ($(HB_ARCHITECTURE),win) ifeq ($(HB_COMPILER),mingw) diff --git a/harbour/source/vm/classes.c b/harbour/source/vm/classes.c index b8889cbf76..daa5f04e9e 100644 --- a/harbour/source/vm/classes.c +++ b/harbour/source/vm/classes.c @@ -4133,6 +4133,46 @@ static HARBOUR hb___msgClassName( void ) } +static int hb_methodType( PMETHOD pMethod ) +{ + if ( pMethod->pFuncSym == &s___msgSetClsData || + pMethod->pFuncSym == &s___msgGetClsData || + pMethod->pFuncSym == &s___msgSetShrData || + pMethod->pFuncSym == &s___msgGetShrData ) + return HB_OO_MSG_CLASSDATA; + + else if( pMethod->pFuncSym == &s___msgSetData || + pMethod->pFuncSym == &s___msgGetData ) + return HB_OO_MSG_DATA; + + else if( pMethod->pFuncSym == &s___msgEvalInline ) + return HB_OO_MSG_INLINE; + + else if( pMethod->pFuncSym == &s___msgVirtual ) + return HB_OO_MSG_VIRTUAL; + + else if( pMethod->pFuncSym == &s___msgSuper ) + return HB_OO_MSG_SUPER; + + else if( pMethod->pFuncSym == &s___msgRealClass ) + return HB_OO_MSG_REALCLASS; + + else if( pMethod->pFuncSym == &s___msgDelegate ) + return HB_OO_MSG_DELEGATE; + + else if( pMethod->pFuncSym == &s___msgPerform ) + return HB_OO_MSG_PERFORM; + + else if( pMethod->pMessage == s___msgOnError.pDynSym ) + return HB_OO_MSG_ONERROR; + + else if( pMethod->pMessage == s___msgDestructor.pDynSym ) + return HB_OO_MSG_DESTRUCTOR; + + else + return HB_OO_MSG_METHOD; +} + /* * := :ClassSel() * @@ -4145,20 +4185,23 @@ static HARBOUR hb___msgClassSel( void ) if( uiClass && uiClass <= s_uiClasses ) { - PHB_ITEM pReturn = hb_itemNew( NULL ); + PHB_ITEM pReturn, pItem; PCLASS pClass = s_pClasses[ uiClass ]; PMETHOD pMethod = pClass->pMethods; ULONG ulLimit = hb_clsMthNum( pClass ), ulPos = 0; - USHORT nParam; + USHORT nParam, nScope; + BOOL lFull; nParam = hb_pcount() > 0 ? ( USHORT ) hb_parni( 1 ) : HB_MSGLISTALL; - hb_arrayNew( pReturn, pClass->uiMethods ); + nScope = hb_pcount() > 1 ? ( USHORT ) hb_parni( 2 ) : 0; + lFull = hb_pcount() > 2 && ISLOG( 3 ) && hb_parl( 3 ); + pReturn = hb_itemArrayNew( pClass->uiMethods ); do { if( pMethod->pMessage ) /* Hash Entry used ? */ { - if( ( nParam == HB_MSGLISTALL ) || + if( ( nParam == HB_MSGLISTALL ) || ( nParam == HB_MSGLISTCLASS && ( ( pMethod->pFuncSym == &s___msgSetClsData ) || @@ -4177,8 +4220,21 @@ static HARBOUR hb___msgClassSel( void ) ) ) { - hb_arraySetC( pReturn, ++ulPos, - pMethod->pMessage->pSymbol->szName ); + if( nScope == 0 || ( pMethod->uiScope & nScope ) != 0 ) + { + if( lFull ) + { + pItem = hb_arrayGetItemPtr( pReturn, ++ulPos ); + hb_arrayNew( pItem, 4 ); + hb_arraySetC( pItem, HB_OO_DATA_SYMBOL, + pMethod->pMessage->pSymbol->szName ); + hb_arraySetNI( pItem, HB_OO_DATA_TYPE, hb_methodType( pMethod) ); + hb_arraySetNI( pItem, HB_OO_DATA_SCOPE, pMethod->uiScope ); + } + else + hb_arraySetC( pReturn, ++ulPos, + pMethod->pMessage->pSymbol->szName ); + } } } ++pMethod;