From 3e9c09053bc99f2ccf7f068048e7a62052202500 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Przemys=C5=82aw=20Czerpak?= Date: Thu, 20 Apr 2023 23:35:56 +0200 Subject: [PATCH] 2023-04-20 23:35 UTC+0200 Przemyslaw Czerpak (druzus/at/poczta.onet.pl) * contrib/xhb/hbcompat.ch ! fixed translations of xHarbour operators inside brackets, thanks to Ron. * contrib/xhb/xhb.hbx * contrib/xhb/xcstr.prg + added support for timestamp translations ! fixed few wrong translations ! fixed serialization of hash items with cyclic references in ValToPrg() % optimized cyclic references detection in ValToPrg() ! generate dummy code which cannot be compiled for codeblocks serialized by ValToPrg() * contrib/xhb/xhb.ch + added SET TRACE ... command, thanks to Ron. * contrib/xhb/xhberror.c * do not show __ERRRT_BASE() and __ERRRT_SBASE() in error call stack. * src/vm/classes.c ! added protection against possible GPF when manually created serialized object data with super class symbols longer then HB_SYMBOL_NAME_LEN is deserialized --- ChangeLog.txt | 25 ++++++ contrib/xhb/hbcompat.ch | 14 ++-- contrib/xhb/xcstr.prg | 168 +++++++++++++++++++++++++++++----------- contrib/xhb/xhb.ch | 2 + contrib/xhb/xhb.hbx | 1 + contrib/xhb/xhberror.c | 4 +- src/vm/classes.c | 2 + 7 files changed, 162 insertions(+), 54 deletions(-) diff --git a/ChangeLog.txt b/ChangeLog.txt index 8efb538b71..01d86e75ab 100644 --- a/ChangeLog.txt +++ b/ChangeLog.txt @@ -7,6 +7,31 @@ Entries may not always be in chronological/commit order. See license at the end of file. */ +2023-04-20 23:35 UTC+0200 Przemyslaw Czerpak (druzus/at/poczta.onet.pl) + * contrib/xhb/hbcompat.ch + ! fixed translations of xHarbour operators inside brackets, + thanks to Ron. + + * contrib/xhb/xhb.hbx + * contrib/xhb/xcstr.prg + + added support for timestamp translations + ! fixed few wrong translations + ! fixed serialization of hash items with cyclic references + in ValToPrg() + % optimized cyclic references detection in ValToPrg() + ! generate dummy code which cannot be compiled for codeblocks serialized + by ValToPrg() + + * contrib/xhb/xhb.ch + + added SET TRACE ... command, thanks to Ron. + + * contrib/xhb/xhberror.c + * do not show __ERRRT_BASE() and __ERRRT_SBASE() in error call stack. + + * src/vm/classes.c + ! added protection against possible GPF when manually created serialized object + data with super class symbols longer then HB_SYMBOL_NAME_LEN is deserialized + 2023-04-20 15:12 UTC+0200 Przemyslaw Czerpak (druzus/at/poczta.onet.pl) * contrib/gtqtc/gtqtc1.cpp % minor optimization in HB_GTI_PALETTE diff --git a/contrib/xhb/hbcompat.ch b/contrib/xhb/hbcompat.ch index bca08ba9c4..32beaec952 100644 --- a/contrib/xhb/hbcompat.ch +++ b/contrib/xhb/hbcompat.ch @@ -314,19 +314,19 @@ /* xHarbour operators: IN, HAS, LIKE, >>, <<, |, &, ^^ */ #translate ( IN ) => ( ( ) $ ( ) ) - #translate ( HAS ) => hb_regexHas( , ) - #translate ( LIKE ) => hb_regexLike( , ) - #translate ( \<\< ) => hb_bitShift( , ) - #translate ( >> ) => hb_bitShift( , -( ) ) + #translate ( HAS ) => ( hb_regexHas( , ) ) + #translate ( LIKE ) => ( hb_regexLike( , ) ) + #translate ( \<\< ) => ( hb_bitShift( , ) ) + #translate ( >> ) => ( hb_bitShift( , -( ) ) ) /* NOTE: These macros can break some valid Harbour/Clipper constructs, so they are disabled by default. Enable them with care, or even better to switch to use HB_BIT*() functions directly. They are optimized by Harbour compiler the same way (and even more) as these C-like operators, without any bad side-effects. */ #if defined( XHB_BITOP ) - #translate ( | ) => xhb_bitOr( , ) - #translate ( & ) => xhb_bitAnd( , ) - #translate ( ^^ ) => xhb_bitXor( , ) + #translate ( | ) => ( xhb_bitOr( , ) ) + #translate ( & ) => ( xhb_bitAnd( , ) ) + #translate ( ^^ ) => ( xhb_bitXor( , ) ) #endif #command @ , PROMPT [ MESSAGE ] [ COLOR ] => ; diff --git a/contrib/xhb/xcstr.prg b/contrib/xhb/xcstr.prg index 68f5851b8b..de8f554dbe 100644 --- a/contrib/xhb/xcstr.prg +++ b/contrib/xhb/xcstr.prg @@ -73,14 +73,23 @@ FUNCTION CStrToVal( cExp, cType ) RETURN hb_HexToNum( cExp ) CASE "D" - IF cExp[ 3 ] >= "0" .AND. cExp[ 3 ] <= "9" .AND. cExp[ 5 ] >= "0" .AND. cExp[ 5 ] <= "9" + IF IsDigit( SubStr( cExp, 3, 1 ) ) .AND. IsDigit( SubStr( cExp, 5, 1 ) ) RETURN hb_SToD( cExp ) ELSE RETURN CToD( cExp ) ENDIF + CASE "T" + IF IsDigit( SubStr( cExp, 3, 1 ) ) .AND. ; + IsDigit( SubStr( cExp, 5, 1 ) ) .AND. ; + IsDigit( SubStr( cExp, 7, 1 ) ) + RETURN hb_SToT( cExp ) + ELSE + RETURN hb_StrToTS( cExp ) + ENDIF + CASE "L" - RETURN iif( cExp[ 1 ] == "T" .OR. cExp[ 1 ] == "Y" .OR. cExp[ 2 ] == "T" .OR. cExp[ 2 ] == "Y", .T., .F. ) + RETURN SubStr( cExp, 1, 1 ) $ "TY" .OR. SubStr( cExp, 2, 1 ) $ "TY" CASE "N" RETURN Val( cExp ) @@ -134,11 +143,11 @@ FUNCTION StringToLiteral( cString ) // -FUNCTION ValToPrg( xVal, cName, nPad, aObjs ) +FUNCTION ValToPrg( xVal, cName, nPad, hRefs ) - LOCAL aVar, cRet, cPad, nObj + LOCAL aVar, cRet, cPad, cRef, pRef - // TraceLog( xVal, cName, nPad, aObjs ) + // TraceLog( xVal, cName, nPad, hRefs ) SWITCH ValType( xVal ) CASE "C" @@ -147,6 +156,9 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs ) CASE "D" RETURN "hb_SToD( '" + DToS( xVal ) + "' )" + CASE "T" + RETURN 't"' + hb_TSToStr( xVal, .T. ) + '"' + CASE "L" RETURN iif( xVal, ".T.", ".F." ) @@ -154,20 +166,19 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs ) RETURN hb_ntos( xVal ) CASE "A" + pRef := __vmItemId( xVal ) IF cName == NIL nPad := 0 cName := "M->__ValToPrg_Array" - aObjs := {} + hRefs := { => } cRet := cName + " := " + ELSEIF ! ( cRef := hb_HGetDef( hRefs, pRef ) ) == NIL + RETURN cRef + " /* Cyclic */" ELSE - IF ( nObj := AScan( aObjs, {| a | hb_ArrayId( a[ 1 ] ) == hb_ArrayId( xVal ) } ) ) > 0 - RETURN aObjs[ nObj ][ 2 ] + " /* Cyclic */" - ENDIF - cRet := "" ENDIF - AAdd( aObjs, { xVal, cName } ) + hRefs[ pRef ] := cName cRet += "Array(" + hb_ntos( Len( xVal ) ) + ")" + CRLF @@ -175,56 +186,69 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs ) cPad := Space( nPad ) FOR EACH aVar IN xVal - cRet += cPad + cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "] := " + ValToPrg( aVar, cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "]", nPad, aObjs ) + CRLF + cRef := cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "]" + cRet += cPad + cRef + " := " + ValToPrg( aVar, cRef, nPad, hRefs ) + IF ! Right( cRet, Len( CRLF ) ) == CRLF + cRet += CRLF + ENDIF NEXT nPad -= 3 - RETURN cRet CASE "H" - IF Empty( xVal ) - cRet := "hb_Hash()" + pRef := __vmItemId( xVal ) + IF cName == NIL + nPad := 0 + cName := "M->__ValToPrg_Hash" + hRefs := { => } + cRet := cName + " := " + ELSEIF ! ( cRef := hb_HGetDef( hRefs, pRef ) ) == NIL + RETURN cRef + " /* Cyclic */" ELSE - cRet := "{ " - FOR EACH aVar IN xVal - IF aVar:__enumIndex() != 1 - cRet += ", " - ENDIF - cRet += ValToPrg( aVar:__enumKey() ) - cRet += " => " - cRet += ValToPrg( aVar ) - NEXT - cRet += " }" + cRet := "" ENDIF + hRefs[ pRef ] := cName + + cRet += "{ => }" + CRLF + + nPad += 3 + cPad := Space( nPad ) + + FOR EACH aVar IN xVal + cRef := cName + "[" + ValToPrg( aVar:__EnumKey() ) + "]" + cRet += cPad + cRef + " := " + ValToPrg( aVar, cRef, nPad, hRefs ) + IF ! Right( cRet, Len( CRLF ) ) == CRLF + cRet += CRLF + ENDIF + NEXT + + nPad -= 3 RETURN cRet - /* There is no support for codeblock serialization */ -#if 0 CASE "B" - RETURN ValToPrgExp( xVal ) -#endif + /* There is no support for codeblock serialization */ + RETURN "{|| /* block */ }" CASE "P" RETURN "0x" + hb_NumToHex( xVal ) CASE "O" /* TODO: Use HBPersistent() when avialable! */ + pRef := __vmItemId( xVal ) IF cName == NIL cName := "M->__ValToPrg_Object" nPad := 0 - aObjs := {} + hRefs := { => } cRet := cName + " := " + ELSEIF ! ( cRef := hb_HGetDef( hRefs, pRef ) ) == NIL + RETURN cRef + " /* Cyclic */" ELSE - IF ( nObj := AScan( aObjs, {| a | hb_ArrayId( a[ 1 ] ) == hb_ArrayId( xVal ) } ) ) > 0 - RETURN aObjs[ nObj ][ 2 ] + " /* Cyclic */" - ENDIF - cRet := "" ENDIF - AAdd( aObjs, { xVal, cName } ) + hRefs[ pRef ] := cName cRet += xVal:ClassName + "():New()" + CRLF @@ -232,7 +256,11 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs ) cPad := Space( nPad ) FOR EACH aVar IN __objGetValueList( xVal ) - cRet += cPad + cName + ":" + aVar[ 1 ] + " := " + ValToPrg( aVar[ 2 ], cName + ":" + aVar[ 1 ], nPad, aObjs ) + CRLF + cRef := cName + ":" + aVar[ 1 ] + cRet += cPad + cRef + " := " + ValToPrg( aVar[ 2 ], cRef, nPad, hRefs ) + IF ! Right( cRet, Len( CRLF ) ) == CRLF + cRet += CRLF + ENDIF NEXT nPad -= 3 @@ -243,7 +271,7 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs ) IF xVal == NIL cRet := "NIL" ELSE - Throw( xhb_ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) ) + Throw( xhb_ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type: " + ValType( xVal ), { xVal } ) ) ENDIF ENDSWITCH @@ -303,21 +331,60 @@ FUNCTION ValToDate( xVal ) RETURN ValToDate( Eval( xVal ) ) CASE "C" - IF SubStr( DToS( xVal ), 3, 1 ) >= "0" .AND. ; - SubStr( DToS( xVal ), 3, 1 ) <= "9" .AND. ; - SubStr( DToS( xVal ), 5, 1 ) >= "0" .AND. ; - SubStr( DToS( xVal ), 5, 1 ) <= "9" - RETURN hb_SToD( xVal ) - ELSE - RETURN CToD( xVal ) - ENDIF + RETURN iif( IsDigit( SubStr( xVal, 3, 1 ) ) .AND. ; + IsDigit( SubStr( xVal, 5, 1 ) ), hb_SToD( xVal ), ; + CToD( xVal ) ) CASE "D" RETURN xVal + CASE "T" + RETURN hb_TToD( xVal ) + CASE "N" + RETURN d"1900-01-01" + xVal + CASE "P" - RETURN 0d19000101 + xVal + RETURN d"1900-01-01" + hb_HexToNum( hb_NumToHex( xVal ) ) + + OTHERWISE + Throw( xhb_ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) ) + ENDSWITCH + + RETURN hb_SToD() + +// + +FUNCTION ValToTimeStamp( xVal ) + + SWITCH ValType( xVal ) + CASE "A" + CASE "H" + CASE "L" + CASE "O" + CASE "U" + EXIT + + CASE "B" + RETURN ValToTimeStamp( Eval( xVal ) ) + + CASE "C" + RETURN iif( IsDigit( SubStr( xVal, 3, 1 ) ) .AND. ; + IsDigit( SubStr( xVal, 5, 1 ) ) .AND. ; + IsDigit( SubStr( xVal, 7, 1 ) ), hb_SToT( xVal ), ; + hb_StrToTS( xVal ) ) + + CASE "D" + RETURN hb_DToT( xVal ) + + CASE "T" + RETURN xVal + + CASE "N" + RETURN t"1900-01-01" + xVal + + CASE "P" + RETURN t"1900-01-01" + hb_HexToNum( hb_NumToHex( xVal ) ) OTHERWISE Throw( xhb_ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) ) @@ -342,6 +409,7 @@ FUNCTION ValToLogical( xVal ) SWITCH ValType( xVal ) CASE "A" CASE "D" + CASE "T" CASE "H" CASE "N" CASE "O" @@ -389,6 +457,7 @@ FUNCTION ValToNumber( xVal ) RETURN Val( xVal ) CASE "D" + CASE "T" RETURN xVal - 0d19000101 CASE "L" @@ -433,6 +502,10 @@ FUNCTION ValToObject( xVal ) ENABLE TYPE CLASS DATE EXIT + CASE "T" + ENABLE TYPE CLASS TIMESTAMP + EXIT + CASE "H" ENABLE TYPE CLASS HASH EXIT @@ -479,6 +552,9 @@ FUNCTION ValToType( xVal, cType ) CASE "D" RETURN ValToDate( xVal ) + CASE "T" + RETURN ValToTimeStamp( xVal ) + CASE "H" RETURN ValToHash( xVal ) diff --git a/contrib/xhb/xhb.ch b/contrib/xhb/xhb.ch index e48eb26e68..e015c8302e 100644 --- a/contrib/xhb/xhb.ch +++ b/contrib/xhb/xhb.ch @@ -78,6 +78,8 @@ #xtranslate AllTrim( [] ) => xhb_AllTrim( ) /* _SET_TRACE* / TraceLog() */ + #command SET TRACE => xhb_SetTrace( <(x)> ) + #command SET TRACE () => xhb_SetTrace( ) #xtranslate Set( _SET_TRACE [,] ) => xhb_SetTrace( ) #xtranslate Set( _SET_TRACEFILE [,] ) => xhb_SetTraceFile( ) #xtranslate Set( _SET_TRACESTACK [,] ) => xhb_SetTraceStack( ) diff --git a/contrib/xhb/xhb.hbx b/contrib/xhb/xhb.hbx index adb940c47c..0ccd457e6f 100644 --- a/contrib/xhb/xhb.hbx +++ b/contrib/xhb/xhb.hbx @@ -425,6 +425,7 @@ DYNAMIC ValToNumber DYNAMIC ValToObject DYNAMIC ValToPrg DYNAMIC ValToPrgExp +DYNAMIC ValToTimeStamp DYNAMIC ValToType DYNAMIC WaitForThreads DYNAMIC WideToANSI diff --git a/contrib/xhb/xhberror.c b/contrib/xhb/xhberror.c index 3df6ffa4e8..0883f20877 100644 --- a/contrib/xhb/xhberror.c +++ b/contrib/xhb/xhberror.c @@ -242,7 +242,9 @@ HB_FUNC_STATIC( ERRORINIT ) if( ! pItem ) { if( strcmp( szProcName, "ERRORNEW" ) == 0 || - strcmp( szProcName, "XHB_ERRORNEW" ) == 0 ) + strcmp( szProcName, "XHB_ERRORNEW" ) == 0 || + strcmp( szProcName, "__ERRRT_BASE" ) == 0 || + strcmp( szProcName, "__ERRRT_SBASE" ) == 0 ) continue; hb_errPutProcName( pError, szProcName ); hb_errPutProcLine( pError, uiProcLine ); diff --git a/src/vm/classes.c b/src/vm/classes.c index 653bc8b12c..1fd9f2c92b 100644 --- a/src/vm/classes.c +++ b/src/vm/classes.c @@ -5213,6 +5213,8 @@ static void hb_objSetIVars( PHB_ITEM pObject, PHB_ITEM pArray ) PHB_DYNS pParentSym; char szClassName[ HB_SYMBOL_NAME_LEN + 1 ]; + if( nLen > HB_SYMBOL_NAME_LEN ) + nLen = HB_SYMBOL_NAME_LEN; memcpy( szClassName, pszMethod, nLen ); szClassName[ nLen ] = '\0'; pParentSym = hb_dynsymFindName( szClassName );