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

2012-06-04 19:15 UTC+0200 Viktor Szakats (harbour syenar.net)

Browse Source 
* contrib\hbblink\blinker.prg
  * contrib\xhb\thtm.prg
  * contrib\xhb\xcstr.prg
  * examples\hbvpdf\hbvpdf.prg
  * examples\hbvpdf\hbvpdft.prg
    * some exceptions missed in previous commit
This commit is contained in:
Viktor Szakats
2012-06-04 17:16:55 +00:00
parent 2a2d1764dc
commit 25c792a829
6 changed files with 254 additions and 246 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
harbour/ChangeLog
View File

@@ -16,6 +16,14 @@
The license applies to all entries newer than 2009-04-28.
*/
2012-06-04 19:15 UTC+0200 Viktor Szakats (harbour syenar.net)
* contrib\hbblink\blinker.prg
* contrib\xhb\thtm.prg
* contrib\xhb\xcstr.prg
* examples\hbvpdf\hbvpdf.prg
* examples\hbvpdf\hbvpdft.prg
* some exceptions missed in previous commit
2012-06-04 19:02 UTC+0200 Viktor Szakats (harbour syenar.net)
* contrib\gtwvg\wvg3stat.prg
* contrib\gtwvg\wvgax.prg

2
harbour/contrib/hbblink/blinker.prg
View File

@@ -73,7 +73,7 @@ PROCEDURE HB_BLIVERNUM( cString )
RETURN
PROCEDURE HB_BLIDEMDTE( dDate )
IF ISDATE( dDate )
IF HB_ISDATE( dDate )
s_cDemoDate := DToS( dDate )
ENDIF
RETURN

2
harbour/contrib/xhb/thtm.prg
View File

@@ -2276,7 +2276,7 @@ FUNCTION HTMLANY2STR( xVal )
ELSEIF HB_ISOBJECT( xVal )
xRet := "<" + xVal:CLASSNAME() + ">"
ELSEIF ISDATE( xVal )
ELSEIF HB_ISDATE( xVal )
xRet := Dtoc( xVal )
ELSEIF HB_ISLOGICAL( xVal )

484
harbour/contrib/xhb/xcstr.prg
View File

@@ -65,49 +65,49 @@
//--------------------------------------------------------------//
FUNCTION CStrToVal( cExp, cType )
IF ! ISCHAR( cExp )
IF ! HB_ISSTRING( cExp )
Throw( xhb_ErrorNew( "CSTR", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
ENDIF
SWITCH cType
CASE 'C'
RETURN cExp
CASE 'C'
RETURN cExp
CASE 'P'
RETURN hb_HexToNum( cExp )
CASE 'P'
RETURN hb_HexToNum( cExp )
CASE 'D'
IF cExp[3] >= '0' .AND. cExp[3] <= '9' .AND. cExp[5] >= '0' .AND. cExp[5] <= '9'
RETURN hb_SToD( cExp )
ELSE
RETURN cToD( cExp )
ENDIF
CASE 'D'
IF cExp[3] >= '0' .AND. cExp[3] <= '9' .AND. cExp[5] >= '0' .AND. cExp[5] <= '9'
RETURN hb_SToD( cExp )
ELSE
RETURN cToD( cExp )
ENDIF
CASE 'L'
RETURN IIF( cExp[1] == 'T' .OR. cExp[1] == 'Y' .OR. cExp[2] == 'T' .OR. cExp[2] == 'Y', .T., .F. )
CASE 'L'
RETURN IIF( cExp[1] == 'T' .OR. cExp[1] == 'Y' .OR. cExp[2] == 'T' .OR. cExp[2] == 'Y', .T., .F. )
CASE 'N'
RETURN Val( cExp )
CASE 'N'
RETURN Val( cExp )
CASE 'U'
RETURN NIL
CASE 'U'
RETURN NIL
/*
CASE 'A'
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
/*
CASE 'A'
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'B'
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'B'
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'O'
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
*/
CASE 'O'
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
*/
OTHERWISE
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
OTHERWISE
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
ENDSWITCH
RETURN NIL
RETURN NIL
//--------------------------------------------------------------//
FUNCTION StringToLiteral( cString )
@@ -130,7 +130,7 @@ FUNCTION StringToLiteral( cString )
RETURN "'" + cString + "'"
ENDIF
RETURN "[" + cString + "]"
RETURN "[" + cString + "]"
//--------------------------------------------------------------//
FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
@@ -140,115 +140,115 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
//TraceLog( xVal, cName, nPad, aObjs )
SWITCH ValType( xVal )
CASE 'C'
RETURN StringToLiteral( xVal )
CASE 'C'
RETURN StringToLiteral( xVal )
CASE 'D'
RETURN "hb_SToD( '" + dToS( xVal ) + "' )"
CASE 'D'
RETURN "hb_SToD( '" + dToS( xVal ) + "' )"
CASE 'L'
RETURN IIF( xVal, ".T.", ".F." )
CASE 'L'
RETURN IIF( xVal, ".T.", ".F." )
CASE 'N'
RETURN hb_nToS( xVal )
CASE 'N'
RETURN hb_nToS( xVal )
CASE 'A'
IF cName == NIL
nPad := 0
cName := "M->__ValToPrg_Array"
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {|a| HB_ArrayID( a[1] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][2] + " /* Cyclic */"
ENDIF
cRet := ""
CASE 'A'
IF cName == NIL
nPad := 0
cName := "M->__ValToPrg_Array"
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {|a| HB_ArrayID( a[1] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][2] + " /* Cyclic */"
ENDIF
aAdd( aObjs, { xVal, cName } )
cRet := ""
ENDIF
cRet += "Array(" + hb_ntos( Len( xVal ) ) + ")" + CRLF
aAdd( aObjs, { xVal, cName } )
nPad += 3
cPad := Space( nPad )
cRet += "Array(" + hb_ntos( Len( xVal ) ) + ")" + CRLF
nPad += 3
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
NEXT
nPad -=3
RETURN cRet
CASE 'H'
IF Empty( xVal )
cRet := "hb_Hash()"
ELSE
cRet := "{ "
FOR EACH aVar IN xVal
cRet += cPad + cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "] := " + ValToPrg( aVar, cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "]", nPad, aObjs ) + CRLF
IF aVar:__enumIndex() != 1
cRet += ", "
ENDIF
cRet += ValToPrg( aVar:__enumKey() )
cRet += " => "
cRet += ValToPrg( aVar )
NEXT
cRet += " }"
ENDIF
nPad -=3
RETURN cRet
CASE 'H'
IF Empty( xVal )
cRet := "hb_Hash()"
ELSE
cRet := "{ "
FOR EACH aVar IN xVal
IF aVar:__enumIndex() != 1
cRet += ", "
ENDIF
cRet += ValToPrg( aVar:__enumKey() )
cRet += " => "
cRet += ValToPrg( aVar )
NEXT
cRet += " }"
ENDIF
RETURN cRet
RETURN cRet
/* There is no support for codeblock serialization */
#if 0
CASE 'B'
RETURN ValToPrgExp( xVal )
CASE 'B'
RETURN ValToPrgExp( xVal )
#endif
CASE 'P'
RETURN "0x" + hb_NumToHex( xVal )
CASE 'P'
RETURN "0x" + hb_NumToHex( xVal )
CASE 'O'
/* TODO: Use HBPersistent() when avialable! */
IF cName == NIL
cName := "M->__ValToPrg_Object"
nPad := 0
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {|a| HB_ArrayID( a[1] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][2] + " /* Cyclic */"
ENDIF
cRet := ""
CASE 'O'
/* TODO: Use HBPersistent() when avialable! */
IF cName == NIL
cName := "M->__ValToPrg_Object"
nPad := 0
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {|a| HB_ArrayID( a[1] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][2] + " /* Cyclic */"
ENDIF
aAdd( aObjs, { xVal, cName } )
cRet := ""
ENDIF
cRet += xVal:ClassName + "():New()" + CRLF
aAdd( aObjs, { xVal, cName } )
nPad += 3
cPad := Space( nPad )
cRet += xVal:ClassName + "():New()" + CRLF
FOR EACH aVar IN __objGetValueList( xVal )
cRet += cPad + cName + ":" + aVar[1] + " := " + ValToPrg( aVar[2], cName + ":" + aVar[1], nPad, aObjs ) + CRLF
NEXT
nPad += 3
cPad := Space( nPad )
nPad -=3
RETURN cRet
FOR EACH aVar IN __objGetValueList( xVal )
cRet += cPad + cName + ":" + aVar[1] + " := " + ValToPrg( aVar[2], cName + ":" + aVar[1], nPad, aObjs ) + CRLF
NEXT
OTHERWISE
//TraceLog( xVal, cName, nPad )
IF xVal == NIL
cRet := "NIL"
ELSE
Throw( xhb_ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDIF
nPad -=3
RETURN cRet
OTHERWISE
//TraceLog( xVal, cName, nPad )
IF xVal == NIL
cRet := "NIL"
ELSE
Throw( xhb_ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDIF
ENDSWITCH
//TraceLog( cRet )
RETURN cRet
RETURN cRet
//--------------------------------------------------------------//
FUNCTION PrgExpToVal( cExp )
@@ -261,7 +261,7 @@ FUNCTION ValToArray( xVal )
RETURN xVal
ENDIF
RETURN { xVal }
RETURN { xVal }
//--------------------------------------------------------------//
FUNCTION ValToBlock( xVal )
@@ -270,54 +270,54 @@ FUNCTION ValToBlock( xVal )
RETURN xVal
ENDIF
RETURN { || xVal }
RETURN { || xVal }
//--------------------------------------------------------------//
FUNCTION ValToCharacter( xVal )
IF ISCHAR( xVal )
IF HB_ISSTRING( xVal )
RETURN xVal
ENDIF
RETURN LTrim( CStr( xVal ) )
RETURN LTrim( CStr( xVal ) )
//--------------------------------------------------------------//
FUNCTION ValToDate( xVal )
SWITCH ValType( xVal )
CASE 'A'
CASE 'H'
CASE 'L'
CASE 'O'
CASE 'U'
EXIT
CASE 'A'
CASE 'H'
CASE 'L'
CASE 'O'
CASE 'U'
EXIT
CASE 'B'
RETURN ValToDate( Eval( xVal ) )
CASE 'B'
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
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
CASE 'D'
RETURN xVal
CASE 'D'
RETURN xVal
CASE 'N'
CASE 'P'
RETURN 0d19000101 + xVal
CASE 'N'
CASE 'P'
RETURN 0d19000101 + xVal
OTHERWISE
Throw( xhb_ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
OTHERWISE
Throw( xhb_ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN hb_SToD()
RETURN hb_SToD()
//--------------------------------------------------------------//
FUNCTION ValToHash( xVal )
@@ -326,169 +326,169 @@ FUNCTION ValToHash( xVal )
RETURN xVal
ENDIF
RETURN { ValToCharacter( xVal ) => xVal }
RETURN { ValToCharacter( xVal ) => xVal }
//--------------------------------------------------------------//
FUNCTION ValToLogical( xVal )
SWITCH ValType( xVal )
CASE 'A'
CASE 'D'
CASE 'H'
CASE 'N'
CASE 'O'
CASE 'P'
CASE 'A'
CASE 'D'
CASE 'H'
CASE 'N'
CASE 'O'
CASE 'P'
RETURN ! Empty( xVal )
CASE 'B'
RETURN ValToLogical( Eval( xVal ) )
CASE 'C'
IF Left( xVal, 1 ) == '.' .AND. SubStr( xVal, 3, 1 ) == '.' .AND. Upper( SubStr( xVal, 2, 1 ) ) $ "TFYN"
RETURN Upper( SubStr( xVal, 2, 1 ) ) $ "TY"
ELSEIF Len( xVal ) == 1 .AND. Upper( xVal ) $ "TFYN"
RETURN Upper( xVal ) $ "TY"
ELSE
RETURN ! Empty( xVal )
ENDIF
EXIT
CASE 'B'
RETURN ValToLogical( Eval( xVal ) )
CASE 'L'
RETURN xVal
CASE 'C'
IF Left( xVal, 1 ) == '.' .AND. SubStr( xVal, 3, 1 ) == '.' .AND. Upper( SubStr( xVal, 2, 1 ) ) $ "TFYN"
RETURN Upper( SubStr( xVal, 2, 1 ) ) $ "TY"
ELSEIF Len( xVal ) == 1 .AND. Upper( xVal ) $ "TFYN"
RETURN Upper( xVal ) $ "TY"
ELSE
RETURN ! Empty( xVal )
ENDIF
EXIT
CASE 'U'
RETURN .F.
CASE 'L'
RETURN xVal
CASE 'U'
RETURN .F.
OTHERWISE
Throw( xhb_ErrorNew( "VALTOLOGICAL", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
OTHERWISE
Throw( xhb_ErrorNew( "VALTOLOGICAL", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN .F.
RETURN .F.
//--------------------------------------------------------------//
FUNCTION ValToNumber( xVal )
SWITCH ValType( xVal )
CASE 'A'
CASE 'H'
RETURN Len( xVal )
CASE 'A'
CASE 'H'
RETURN Len( xVal )
CASE 'B'
RETURN ValToNumber( Eval( xVal ) )
CASE 'B'
RETURN ValToNumber( Eval( xVal ) )
CASE 'C'
RETURN Val( xVal )
CASE 'C'
RETURN Val( xVal )
CASE 'D'
RETURN xVal - 0d19000101
CASE 'D'
RETURN xVal - 0d19000101
CASE 'L'
RETURN IIF( xVal, 1, 0 )
CASE 'L'
RETURN IIF( xVal, 1, 0 )
CASE 'O'
RETURN xVal:hClass
CASE 'O'
RETURN xVal:hClass
CASE 'N'
RETURN xVal
CASE 'N'
RETURN xVal
CASE 'P'
RETURN xVal - 0
CASE 'P'
RETURN xVal - 0
CASE 'U'
RETURN 0
CASE 'U'
RETURN 0
OTHERWISE
Throw( xhb_ErrorNew( "VALTONUMBER", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
OTHERWISE
Throw( xhb_ErrorNew( "VALTONUMBER", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN 0
RETURN 0
//--------------------------------------------------------------//
FUNCTION ValToObject( xVal )
SWITCH ValType( xVal )
CASE 'A'
ENABLE TYPE CLASS ARRAY
EXIT
CASE 'A'
ENABLE TYPE CLASS ARRAY
EXIT
CASE 'B'
ENABLE TYPE CLASS BLOCK
EXIT
CASE 'B'
ENABLE TYPE CLASS BLOCK
EXIT
CASE 'C'
ENABLE TYPE CLASS CHARACTER
EXIT
CASE 'C'
ENABLE TYPE CLASS CHARACTER
EXIT
CASE 'D'
ENABLE TYPE CLASS DATE
EXIT
CASE 'D'
ENABLE TYPE CLASS DATE
EXIT
CASE 'H'
ENABLE TYPE CLASS HASH
EXIT
CASE 'H'
ENABLE TYPE CLASS HASH
EXIT
CASE 'L'
ENABLE TYPE CLASS LOGICAL
EXIT
CASE 'L'
ENABLE TYPE CLASS LOGICAL
EXIT
CASE 'N'
ENABLE TYPE CLASS NUMERIC
EXIT
CASE 'N'
ENABLE TYPE CLASS NUMERIC
EXIT
CASE 'O'
RETURN xVal
CASE 'O'
RETURN xVal
CASE 'P'
ENABLE TYPE CLASS POINTER
EXIT
CASE 'P'
ENABLE TYPE CLASS POINTER
EXIT
CASE 'U'
ENABLE TYPE CLASS NIL
EXIT
CASE 'U'
ENABLE TYPE CLASS NIL
EXIT
OTHERWISE
Throw( xhb_ErrorNew( "VALTOOBJECT", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
OTHERWISE
Throw( xhb_ErrorNew( "VALTOOBJECT", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN 0
RETURN 0
//--------------------------------------------------------------//
FUNCTION ValToType( xVal, cType )
SWITCH cType
CASE 'A'
RETURN ValToArray( xVal )
CASE 'A'
RETURN ValToArray( xVal )
CASE 'B'
RETURN ValToBlock( xVal )
CASE 'B'
RETURN ValToBlock( xVal )
CASE 'C'
RETURN ValToCharacter( xVal )
CASE 'C'
RETURN ValToCharacter( xVal )
CASE 'D'
RETURN ValToDate( xVal )
CASE 'D'
RETURN ValToDate( xVal )
CASE 'H'
RETURN ValToHash( xVal )
CASE 'H'
RETURN ValToHash( xVal )
CASE 'L'
RETURN ValToLogical( xVal )
CASE 'L'
RETURN ValToLogical( xVal )
CASE 'N'
RETURN ValToNumber( xVal )
CASE 'N'
RETURN ValToNumber( xVal )
CASE 'O'
RETURN ValToObject( xVal )
CASE 'O'
RETURN ValToObject( xVal )
CASE 'P'
RETURN ValToNumber( xVal )
CASE 'P'
RETURN ValToNumber( xVal )
CASE 'U'
RETURN NIL
CASE 'U'
RETURN NIL
OTHERWISE
Throw( xhb_ErrorNew( "VALTOTYPE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
OTHERWISE
Throw( xhb_ErrorNew( "VALTOTYPE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN NIL
RETURN NIL
//--------------------------------------------------------------//

2
harbour/examples/hbvpdf/hbvpdf.prg
View File

@@ -2449,7 +2449,7 @@ local cData := valtype(xData)
cData += i2bin(len(xData))+xData
elseif HB_ISNUMERIC(xData)
cData += i2bin(len(alltrim(str(xData))) )+alltrim(str(xData))
elseif ISDATE(xData)
elseif HB_ISDATE(xData)
cData += i2bin(8)+dtos(xData)
elseif HB_ISLOGICAL(xData)
cData += i2bin(1)+iif(xData,'T','F')

2
harbour/examples/hbvpdf/hbvpdft.prg
View File

@@ -2536,7 +2536,7 @@ local cData := valtype(xData)
cData += i2bin( len( xData ) ) + xData
elseif HB_ISNUMERIC(xData)
cData += i2bin( len( alltrim( str( xData ) ) ) ) + alltrim( str( xData ) )
elseif ISDATE( xData )
elseif HB_ISDATE( xData )
cData += i2bin( 8 )+dtos(xData)
elseif HB_ISLOGICAL(xData)
cData += i2bin( 1 )+iif( xData,"T","F" )