fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2023-04-20 23:35 UTC+0200 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)

Browse Source 
* 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
This commit is contained in:
Przemysław Czerpak
2023-04-20 23:35:56 +02:00
parent e11ee84e6a
commit 3e9c09053b
7 changed files with 162 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
ChangeLog.txt
View File

@@ -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

14
contrib/xhb/hbcompat.ch
View File

@@ -314,19 +314,19 @@
/* xHarbour operators: IN, HAS, LIKE, >>, <<, |, &, ^^ */
#translate ( <exp1> IN <exp2> ) => ( ( <exp1> ) $ ( <exp2> ) )
#translate ( <exp1> HAS <exp2> ) => hb_regexHas( <exp2>, <exp1> )
#translate ( <exp1> LIKE <exp2> ) => hb_regexLike( <exp2>, <exp1> )
#translate ( <exp1> \<\< <exp2> ) => hb_bitShift( <exp1>, <exp2> )
#translate ( <exp1> >> <exp2> ) => hb_bitShift( <exp1>, -( <exp2> ) )
#translate ( <exp1> HAS <exp2> ) => ( hb_regexHas( <exp2>, <exp1> ) )
#translate ( <exp1> LIKE <exp2> ) => ( hb_regexLike( <exp2>, <exp1> ) )
#translate ( <exp1> \<\< <exp2> ) => ( hb_bitShift( <exp1>, <exp2> ) )
#translate ( <exp1> >> <exp2> ) => ( hb_bitShift( <exp1>, -( <exp2> ) ) )
/* 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 ( <exp1> | <exp2> ) => xhb_bitOr( <exp1>, <exp2> )
#translate ( <exp1> & <exp2> ) => xhb_bitAnd( <exp1>, <exp2> )
#translate ( <exp1> ^^ <exp2> ) => xhb_bitXor( <exp1>, <exp2> )
#translate ( <exp1> | <exp2> ) => ( xhb_bitOr( <exp1>, <exp2> ) )
#translate ( <exp1> & <exp2> ) => ( xhb_bitAnd( <exp1>, <exp2> ) )
#translate ( <exp1> ^^ <exp2> ) => ( xhb_bitXor( <exp1>, <exp2> ) )
#endif
#command @ <row>, <col> PROMPT <prompt> [ MESSAGE <msg> ] [ COLOR <color> ] => ;

168
contrib/xhb/xcstr.prg
View File

@@ -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 )

2
contrib/xhb/xhb.ch
View File

@@ -78,6 +78,8 @@
#xtranslate AllTrim( [<x,...>] ) => xhb_AllTrim( <x> )
/* _SET_TRACE* / TraceLog() */
#command SET TRACE <x:ON,OFF,&> => xhb_SetTrace( <(x)> )
#command SET TRACE (<x>) => xhb_SetTrace( <x> )
#xtranslate Set( _SET_TRACE [,<x,...>] ) => xhb_SetTrace( <x> )
#xtranslate Set( _SET_TRACEFILE [,<x,...>] ) => xhb_SetTraceFile( <x> )
#xtranslate Set( _SET_TRACESTACK [,<x,...>] ) => xhb_SetTraceStack( <x> )

1
contrib/xhb/xhb.hbx
View File

@@ -425,6 +425,7 @@ DYNAMIC ValToNumber
DYNAMIC ValToObject
DYNAMIC ValToPrg
DYNAMIC ValToPrgExp
DYNAMIC ValToTimeStamp
DYNAMIC ValToType
DYNAMIC WaitForThreads
DYNAMIC WideToANSI

4
contrib/xhb/xhberror.c
View File

@@ -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 );

2
src/vm/classes.c
View File

@@ -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 );