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

2012-10-05 18:08 UTC+0200 Viktor Szakats (vszakats syenar.net)

Browse Source 
* contrib/xhb/arrayblk.prg
  * contrib/xhb/dbgfx.prg
  * contrib/xhb/dumpvar.prg
  * contrib/xhb/hblognet.prg
  * contrib/xhb/hjwindow.prg
  * contrib/xhb/hterrsys.prg
  * contrib/xhb/htjlist.prg
  * contrib/xhb/htmutil.prg
  * contrib/xhb/tcgi.prg
  * contrib/xhb/tfile.prg
  * contrib/xhb/trpc.prg
  * contrib/xhb/trpccli.prg
  * contrib/xhb/ttable.prg
  * contrib/xhb/txml.prg
  * contrib/xhb/xcstr.prg
  * contrib/xhb/xdbmodst.prg
  * contrib/xhb/xhberr.prg
  * contrib/xhb/xhbtedit.prg
    * hbformatted, manually corrected
    * few corrections to use constants, hb_BChar()
This commit is contained in:
Viktor Szakats
2012-10-05 16:10:52 +00:00
parent 69e0fe3045
commit f393a30b6b
19 changed files with 862 additions and 732 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
harbour/ChangeLog
View File

@@ -16,6 +16,28 @@
The license applies to all entries newer than 2009-04-28.
*/
2012-10-05 18:08 UTC+0200 Viktor Szakats (vszakats syenar.net)
* contrib/xhb/arrayblk.prg
* contrib/xhb/dbgfx.prg
* contrib/xhb/dumpvar.prg
* contrib/xhb/hblognet.prg
* contrib/xhb/hjwindow.prg
* contrib/xhb/hterrsys.prg
* contrib/xhb/htjlist.prg
* contrib/xhb/htmutil.prg
* contrib/xhb/tcgi.prg
* contrib/xhb/tfile.prg
* contrib/xhb/trpc.prg
* contrib/xhb/trpccli.prg
* contrib/xhb/ttable.prg
* contrib/xhb/txml.prg
* contrib/xhb/xcstr.prg
* contrib/xhb/xdbmodst.prg
* contrib/xhb/xhberr.prg
* contrib/xhb/xhbtedit.prg
* hbformatted, manually corrected
* few corrections to use constants, hb_BChar()
2012-10-05 12:55 UTC+0200 Viktor Szakats (vszakats syenar.net)
* contrib/hbct/tests/ctwtest.prg
* contrib/hbwin/tests/testole.prg

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

@@ -53,4 +53,4 @@
FUNCTION HB_ARRAYBLOCK( aArray, nIndex )
RETURN {| x | iif( PCount() == 0, aArray[ nIndex ], aArray[ nIndex ] := x )}
RETURN {| x | iif( PCount() == 0, aArray[ nIndex ], aArray[ nIndex ] := x ) }

23
harbour/contrib/xhb/dbgfx.prg
View File

@@ -58,33 +58,45 @@ STATIC s_lToLogFile := .T.
STATIC s_lEmptyLogFile := .T.
FUNCTION HB_ToOutDebugOnOff( lOnOff )
LOCAL lOld := s_lToOutDebug
IF HB_ISLOGICAL( lOnOff )
s_lToOutDebug := lOnOff
ENDIF
RETURN lOld
RETURN lOld
PROCEDURE HB_ToOutDebug( ... )
IF s_lToOutDebug
hb_OutDebug( sprintf( ... ) )
ENDIF
RETURN
RETURN
FUNCTION HB_ToLogFileOnOff( lOnOff )
LOCAL lOld := s_lToLogFile
IF HB_ISLOGICAL( lOnOff )
s_lToLogFile := lOnOff
ENDIF
RETURN lOld
RETURN lOld
FUNCTION HB_EmptyLogFileOnOff( lOnOff )
LOCAL lOld := s_lEmptyLogFile
IF HB_ISLOGICAL( lOnOff )
s_lEmptyLogFile := lOnOff
ENDIF
RETURN lOld
RETURN lOld
PROCEDURE HB_ToLogFile( cLogFile, ... )
LOCAL nHandle
IF !s_lToLogFile
@@ -115,4 +127,5 @@ PROCEDURE HB_ToLogFile( cLogFile, ... )
FClose( nHandle )
ENDIF
ENDIF
RETURN
RETURN

237
harbour/contrib/xhb/dumpvar.prg
View File

@@ -61,10 +61,13 @@
*/
PROCEDURE __OutDebug( ... )
LOCAL xVal
FOR EACH xVal IN hb_aParams()
hb_OutDebug( hb_DumpVar( xVal ) )
FOR EACH xVal IN hb_AParams()
hb_OutDebug( hb_DumpVar( xVal ) )
NEXT
RETURN
/*
@@ -79,16 +82,18 @@ PROCEDURE __OutDebug( ... )
*/
FUNCTION HB_DumpVar( xVar, lRecursive, nMaxRecursionLevel )
LOCAL nRecursionLevel := 1
LOCAL nIndent := 0
//TraceLog( "HB_DumpVariable: xVar, lAssocAsObj, lRecursive", xVar, lAssocAsObj, lRecursive )
// TraceLog( "HB_DumpVariable: xVar, lAssocAsObj, lRecursive", xVar, lAssocAsObj, lRecursive )
DEFAULT nMaxRecursionLevel TO 0
RETURN __HB_DumpVar( xVar,, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
RETURN __HB_DumpVar( xVar, , lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
STATIC FUNCTION __HB_DumpVar( xVar, lAssocAsObj, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL cType := ValType( xVar )
LOCAL cString := "", cKey
LOCAL nEolLen
@@ -96,77 +101,78 @@ STATIC FUNCTION __HB_DumpVar( xVar, lAssocAsObj, lRecursive, nIndent, nRecursion
DEFAULT lAssocAsObj TO .F.
DEFAULT lRecursive TO .F.
//TraceLog( "Recursion: xVar, nRecursionLevel, nMaxRecursionLevel", xVar, nRecursionLevel, nMaxRecursionLevel )
// TraceLog( "Recursion: xVar, nRecursionLevel, nMaxRecursionLevel", xVar, nRecursionLevel, nMaxRecursionLevel )
// return if there is limit in recursion
IF nMaxRecursionLevel > 0 .AND. ;
nRecursionLevel > nMaxRecursionLevel
nRecursionLevel > nMaxRecursionLevel
RETURN AsString( xVar )
ENDIF
DO CASE
CASE cType == "O"
IF !lAssocAsObj .AND. xVar:ClassName == "TASSOCIATIVEARRAY"
cString += Space( nIndent ) + "Type='Associative' -> " + hb_eol()
// Keys extraction.
IF Len( xVar:Keys ) > 0
nEolLen := Len( hb_eol() )
cString += Space( nIndent ) + "{" + hb_eol()
FOR EACH cKey IN xVar:Keys
cString += Space( nIndent ) + " '" + cKey + "' => " + asString( xVar:SendKey( cKey ) ) + ", " + hb_eol()
IF lRecursive .AND. ValType( xVar:SendKey( cKey ) ) $ "AOH"
cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + hb_eol()
cString += __HB_DumpVar( xVar:SendKey( cKey ),, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString )-nEolLen ) + ", " + hb_eol()
ENDIF
NEXT
cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + hb_eol()
cString += Space( nIndent ) + "}" + hb_eol()
ENDIF
ELSE
cString += Space( nIndent ) + "<" + xVar:ClassName + " Object>" + hb_eol()
cString += Space( nIndent ) + " | " + hb_eol()
cString += Space( nIndent ) + " +- PRIVATE/HIDDEN:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_HIDDEN, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- PROTECTED:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_PROTECTED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- EXPORTED/VISIBLE/PUBLIC:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_EXPORTED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
IF !lAssocAsObj .AND. xVar:ClassName == "TASSOCIATIVEARRAY"
cString += Space( nIndent ) + "Type='Associative' -> " + hb_eol()
// Keys extraction.
IF Len( xVar:Keys ) > 0
nEolLen := Len( hb_eol() )
cString += Space( nIndent ) + "{" + hb_eol()
FOR EACH cKey IN xVar:Keys
cString += Space( nIndent ) + " '" + cKey + "' => " + asString( xVar:SendKey( cKey ) ) + ", " + hb_eol()
IF lRecursive .AND. ValType( xVar:SendKey( cKey ) ) $ "AOH"
cString := SubStr( cString, 1, Len( cString ) - 2 - nEolLen ) + hb_eol()
cString += __HB_DumpVar( xVar:SendKey( cKey ), , lRecursive, nIndent + 3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString ) - nEolLen ) + ", " + hb_eol()
ENDIF
NEXT
cString := SubStr( cString, 1, Len( cString ) - 2 - nEolLen ) + hb_eol()
cString += Space( nIndent ) + "}" + hb_eol()
ENDIF
ELSE
cString += Space( nIndent ) + "<" + xVar:ClassName + " Object>" + hb_eol()
cString += Space( nIndent ) + " | " + hb_eol()
cString += Space( nIndent ) + " +- PRIVATE/HIDDEN:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_HIDDEN, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- PROTECTED:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_PROTECTED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- EXPORTED/VISIBLE/PUBLIC:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_EXPORTED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
#ifdef __XHARBOUR__
cString += Space( nIndent ) + " +- PUBLISHED:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_PUBLISHED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- PUBLISHED:" + hb_eol()
cString += DShowProperties( xVar, HB_OO_CLSTP_PUBLISHED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
#endif
cString += Space( nIndent ) + " +----------->" + hb_eol()
ENDIF
cString += Space( nIndent ) + " +----------->" + hb_eol()
ENDIF
CASE cType == "A"
IF nRecursionLevel == 1
cString += Space( nIndent ) + "Type='A' -> { Array of " + hb_ntos( Len( xVar ) ) + " Items }" + hb_eol()
ENDIF
IF nMaxRecursionLevel > 0 .AND. nRecursionLevel > nMaxRecursionLevel
cString += AsString( xVar )
ELSE
cString += DShowArray( xVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
ENDIF
IF nRecursionLevel == 1
cString += Space( nIndent ) + "Type='A' -> { Array of " + hb_ntos( Len( xVar ) ) + " Items }" + hb_eol()
ENDIF
IF nMaxRecursionLevel > 0 .AND. nRecursionLevel > nMaxRecursionLevel
cString += AsString( xVar )
ELSE
cString += DShowArray( xVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
ENDIF
CASE cType == "H"
IF nRecursionLevel == 1
cString += Space( nIndent ) + "Type='H' -> { Hash of " + hb_ntos( Len( xVar ) ) + " Items }" + hb_eol()
ENDIF
IF nMaxRecursionLevel > 0 .AND. nRecursionLevel > nMaxRecursionLevel
cString += AsString( xVar )
ELSE
cString += DShowHash( xVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
ENDIF
IF nRecursionLevel == 1
cString += Space( nIndent ) + "Type='H' -> { Hash of " + hb_ntos( Len( xVar ) ) + " Items }" + hb_eol()
ENDIF
IF nMaxRecursionLevel > 0 .AND. nRecursionLevel > nMaxRecursionLevel
cString += AsString( xVar )
ELSE
cString += DShowHash( xVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
ENDIF
OTHERWISE
cString += Space( nIndent ) + AsString( xVar ) + hb_eol()
cString += Space( nIndent ) + AsString( xVar ) + hb_eol()
ENDCASE
RETURN cString
STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL xProp, aProps
LOCAL aMethods, aMth
LOCAL cString := ""
@@ -174,18 +180,18 @@ STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLe
DEFAULT nIndent TO 0
IF HB_ISOBJECT( oVar )
// lOldScope := __SetClassScope( .F. )
aMethods := __objGetMsgFullList( oVar, .F., HB_MSGLISTALL, nScope )
// 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 ------" + hb_eol()
FOR EACH xProp IN aProps
cString += Space( nIndent ) + " | +- " + PadR( xProp[ HB_OO_DATA_SYMBOL ], 20 ) + " [" + DecodeType( xProp[ HB_OO_DATA_TYPE ] ) + "] [" + DecodeScope( xProp[ HB_OO_DATA_SCOPE ] ) + "] " + ValType( xProp[ HB_OO_DATA_VALUE ] ) + " => " + AsString( xProp[ HB_OO_DATA_VALUE ] ) + hb_eol()
IF lRecursive .AND. ValType( xProp[ HB_OO_DATA_VALUE ] ) $ "AO"
cString += __HB_DumpVar( xProp[ HB_OO_DATA_VALUE ],, lRecursive, nIndent + 3, nRecursionLevel + 1, nMaxRecursionLevel ) + hb_eol()
ENDIF
cString += Space( nIndent ) + " | +- " + PadR( xProp[ HB_OO_DATA_SYMBOL ], 20 ) + " [" + DecodeType( xProp[ HB_OO_DATA_TYPE ] ) + "] [" + DecodeScope( xProp[ HB_OO_DATA_SCOPE ] ) + "] " + ValType( xProp[ HB_OO_DATA_VALUE ] ) + " => " + AsString( xProp[ HB_OO_DATA_VALUE ] ) + hb_eol()
IF lRecursive .AND. ValType( xProp[ HB_OO_DATA_VALUE ] ) $ "AO"
cString += __HB_DumpVar( xProp[ HB_OO_DATA_VALUE ], , lRecursive, nIndent + 3, nRecursionLevel + 1, nMaxRecursionLevel ) + hb_eol()
ENDIF
NEXT
cString += Space( nIndent ) + " | +- >> End Data ------" + hb_eol()
cString += Space( nIndent ) + " | " + hb_eol()
@@ -193,7 +199,7 @@ STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLe
IF Len( aMethods ) > 0
cString += Space( nIndent ) + " | +- >> Begin Methods ------" + hb_eol()
FOR EACH aMth IN aMethods
cString += Space( nIndent ) + " | +- " + PadR( aMth[HB_OO_DATA_SYMBOL], 20 ) + " [" + DecodeType( aMth[HB_OO_DATA_TYPE] ) + "]" + " [" + DecodeScope( aMth[HB_OO_DATA_SCOPE] ) + "] " + hb_eol()
cString += Space( nIndent ) + " | +- " + PadR( aMth[HB_OO_DATA_SYMBOL], 20 ) + " [" + DecodeType( aMth[HB_OO_DATA_TYPE] ) + "]" + " [" + DecodeScope( aMth[HB_OO_DATA_SCOPE] ) + "] " + hb_eol()
NEXT
cString += Space( nIndent ) + " | +- >> End Methods ------" + hb_eol()
cString += Space( nIndent ) + " | " + hb_eol()
@@ -202,9 +208,11 @@ STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLe
IF Empty( cString )
cString := Space( nIndent ) + " | " + hb_eol()
ENDIF
RETURN cString
STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL xVal, nChar, nEolLen
LOCAL cString := ""
@@ -215,18 +223,18 @@ STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecu
IF HB_ISARRAY( aVar )
nEolLen := Len( hb_eol() )
nChar := Len( hb_ntos( Len( aVar ) ) ) // return number of chars to display that value
// i.e. if Len( aVar ) == 99, then nChar := 2
// i.e. if Len( aVar ) == 99, then nChar := 2
cString += Space( nIndent ) + "{" + hb_eol()
FOR EACH xVal IN aVar
cString += Space( nIndent ) + " ["+ LTrim( StrZero( xVal:__EnumIndex(), nChar ) ) + "] => " + AsString( xVal ) + ", " + hb_eol()
IF lRecursive .AND. ValType( xVal ) $ "AOH"
cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + hb_eol()
cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString )-nEolLen ) + ", " + hb_eol()
ENDIF
cString += Space( nIndent ) + " [" + LTrim( StrZero( xVal:__EnumIndex(), nChar ) ) + "] => " + AsString( xVal ) + ", " + hb_eol()
IF lRecursive .AND. ValType( xVal ) $ "AOH"
cString := SubStr( cString, 1, Len( cString ) - 2 - nEolLen ) + hb_eol()
cString += __HB_DumpVar( xVal, , lRecursive, nIndent + 3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString ) - nEolLen ) + ", " + hb_eol()
ENDIF
NEXT
IF Len( aVar ) > 0
cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + hb_eol()
cString := SubStr( cString, 1, Len( cString ) - 2 - nEolLen ) + hb_eol()
ENDIF
cString += Space( nIndent ) + "}" + hb_eol()
ENDIF
@@ -234,6 +242,7 @@ STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecu
RETURN cString
STATIC FUNCTION DShowHash( hVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL xVal
LOCAL nEolLen
LOCAL cString := ""
@@ -246,15 +255,15 @@ STATIC FUNCTION DShowHash( hVar, lRecursive, nIndent, nRecursionLevel, nMaxRecur
nEolLen := Len( hb_eol() )
cString += Space( nIndent ) + "{" + hb_eol()
FOR EACH xVal IN hVar
cString += Space( nIndent ) + " ["+ LTrim( AsString( xVal:__enumKey() ) ) + "] => " + AsString( xVal ) + ", " + hb_eol()
cString += Space( nIndent ) + " [" + LTrim( AsString( xVal:__enumKey() ) ) + "] => " + AsString( xVal ) + ", " + hb_eol()
IF lRecursive .AND. ValType( xVal ) $ "AOH"
cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + hb_eol()
cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString )-nEolLen ) + ", " + hb_eol()
cString := SubStr( cString, 1, Len( cString ) - 2 - nEolLen ) + hb_eol()
cString += __HB_DumpVar( xVal, , lRecursive, nIndent + 3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString ) - nEolLen ) + ", " + hb_eol()
ENDIF
NEXT
IF Len( hVar ) > 0
cString := SubStr( cString, 1, Len( cString )-2-nEolLen ) + hb_eol()
cString := SubStr( cString, 1, Len( cString ) - 2 - nEolLen ) + hb_eol()
ENDIF
cString += Space( nIndent ) + "}" + hb_eol()
ENDIF
@@ -262,93 +271,95 @@ STATIC FUNCTION DShowHash( hVar, lRecursive, nIndent, nRecursionLevel, nMaxRecur
RETURN cString
STATIC FUNCTION DecodeScope( nScope AS NUMERIC )
LOCAL cString := ""
IF hb_BitAnd( nScope, HB_OO_CLSTP_EXPORTED ) # 0 // 1
IF hb_bitAnd( nScope, HB_OO_CLSTP_EXPORTED ) # 0 // 1
cString += "Ex,"
ENDIF
#ifdef __XHARBOUR__
IF hb_BitAnd( nScope, HB_OO_CLSTP_PUBLISHED ) # 0 // 2
IF hb_bitAnd( nScope, HB_OO_CLSTP_PUBLISHED ) # 0 // 2
cString += "Pu,"
ENDIF
#endif
IF hb_BitAnd( nScope, HB_OO_CLSTP_PROTECTED ) # 0 // 4
IF hb_bitAnd( nScope, HB_OO_CLSTP_PROTECTED ) # 0 // 4
cString += "Pr,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_HIDDEN ) # 0 // 8
IF hb_bitAnd( nScope, HB_OO_CLSTP_HIDDEN ) # 0 // 8
cString += "Hi,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_CTOR ) # 0 // 16
IF hb_bitAnd( nScope, HB_OO_CLSTP_CTOR ) # 0 // 16
cString += "Ct,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_READONLY ) # 0 // 32
IF hb_bitAnd( nScope, HB_OO_CLSTP_READONLY ) # 0 // 32
cString += "Ro,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_SHARED ) # 0 // 64
IF hb_bitAnd( nScope, HB_OO_CLSTP_SHARED ) # 0 // 64
cString += "Sh,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_CLASS ) # 0 // 128
IF hb_bitAnd( nScope, HB_OO_CLSTP_CLASS ) # 0 // 128
cString += "Cl,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_SUPER ) # 0 // 256
IF hb_bitAnd( nScope, HB_OO_CLSTP_SUPER ) # 0 // 256
cString += "Su,"
ENDIF
IF Right( cString, 1 ) == ","
cString := SubStr( cString, 1, Len(cString)-1 )
cString := SubStr( cString, 1, Len( cString ) - 1 )
ENDIF
RETURN PadR( cString, 18 )
STATIC FUNCTION DecodeType( nType AS NUMERIC )
LOCAL cString := ""
DO CASE
CASE nType == HB_OO_MSG_METHOD // 0
cString += "Method"
cString += "Method"
CASE nType == HB_OO_MSG_DATA // 1
cString += "Data"
cString += "Data"
CASE nType == HB_OO_MSG_CLASSDATA // 2
cString += "Clsdata"
cString += "Clsdata"
CASE nType == HB_OO_MSG_INLINE // 3
cString += "Inline"
cString += "Inline"
CASE nType == HB_OO_MSG_VIRTUAL // 4
cString += "Virtual"
cString += "Virtual"
CASE nType == HB_OO_MSG_SUPER // 5
cString += "Super"
cString += "Super"
CASE nType == HB_OO_MSG_ONERROR // 6
cString += "OnError"
cString += "OnError"
CASE nType == HB_OO_MSG_DESTRUCTOR // 7
cString += "Destructor"
cString += "Destructor"
CASE nType == HB_OO_PROPERTY // 8
cString += "Property"
cString += "Property"
CASE nType == HB_OO_MSG_PROPERTY // 9
cString += "MsgPrp"
cString += "MsgPrp"
CASE nType == HB_OO_MSG_CLASSPROPERTY // 10
cString += "ClsPrp"
cString += "ClsPrp"
CASE nType == HB_OO_MSG_REALCLASS
cString += "RealCls"
cString += "RealCls"
CASE nType == HB_OO_MSG_DELEGATE
cString += "Delegate"
cString += "Delegate"
CASE nType == HB_OO_MSG_PERFORM
cString += "Perform"
cString += "Perform"
ENDCASE
RETURN PadR( cString, 7 )
STATIC FUNCTION asString( x )
LOCAL v := ValType( x )
DO CASE
CASE v == "C"
RETURN '"' + x + '"'
OTHERWISE
RETURN hb_cStr( x )
RETURN hb_CStr( x )
ENDCASE
RETURN x
#include "error.ch"
/*
@@ -356,7 +367,9 @@ STATIC FUNCTION asString( x )
*
* return all informations about classes, included type and scope
*/
STATIC FUNCTION __objGetMsgFullList( oObject, lData, nRange, nScope, nNoScope )
LOCAL aMessages
LOCAL aReturn
LOCAL nFirstProperty, aMsg
@@ -375,32 +388,34 @@ STATIC FUNCTION __objGetMsgFullList( oObject, lData, nRange, nScope, nNoScope )
// 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] } )
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 ) == '_' } )
nFirstProperty := AScan( aMessages, {| aElement | Left( aElement[ HB_OO_DATA_SYMBOL ], 1 ) == "_" } )
FOR EACH aMsg IN aMessages
IF Left( aMsg[HB_OO_DATA_SYMBOL], 1 ) == '_'
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
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
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
@@ -413,13 +428,13 @@ STATIC FUNCTION __objGetValueFullList( oObject, aExcept, nScope, nNoScope )
aExcept := {}
ENDIF
aVars := __objGetMsgFullList( oObject, .T., HB_MSGLISTALL, nScope, nNoScope )
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] } )
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
RETURN aReturn

107
harbour/contrib/xhb/hblognet.prg
View File

@@ -57,6 +57,7 @@
#define HB_THREAD_SUPPORT
CLASS HB_LogEmail FROM HB_LogChannel
DATA cServer
DATA cAddress INIT "log@xharbour.org"
DATA cSubject INIT "Log message from xharbour application"
@@ -71,24 +72,25 @@ CLASS HB_LogEmail FROM HB_LogChannel
METHOD Open( cName )
METHOD Close( cName )
PROTECTED:
PROTECTED:
METHOD Send( nStyle, cMessage, cName, nPriority )
HIDDEN:
HIDDEN:
METHOD GetOk( skCon )
METHOD Prepare( nStyle, cMessage, cName, nPriority )
ENDCLASS
METHOD New( nLevel, cHelo, cServer, cSendTo, cSubject, cFrom ) CLASS HB_LogEmail
LOCAL nPos
::Super:New( nLevel )
nPos := At( ":", cServer )
IF nPos > 0
::nPort := Val(Substr( cServer, nPos + 1 ) )
cServer := Substr( cServer , 1, nPos -1 )
::nPort := Val( SubStr( cServer, nPos + 1 ) )
cServer := SubStr( cServer, 1, nPos - 1 )
ENDIF
::cServer := cServer
@@ -106,23 +108,29 @@ METHOD New( nLevel, cHelo, cServer, cSendTo, cSubject, cFrom ) CLASS HB_LogEmai
::cAddress := cFrom
ENDIF
RETURN SELF
RETURN SELF
/**
* Inet init must be called here
*/
METHOD Open( cName ) CLASS HB_LogEmail
HB_SYMBOL_UNUSED( cName )
hb_inetInit()
RETURN .T.
RETURN .T.
/**
* InetCleanup to be called here
*/
METHOD Close( cName ) CLASS HB_LogEmail
HB_SYMBOL_UNUSED( cName )
hb_inetCleanup()
RETURN .T.
RETURN .T.
/**
@@ -130,14 +138,14 @@ RETURN .T.
*/
METHOD Send( nStyle, cMessage, cName, nPriority ) CLASS HB_LogEmail
LOCAL skCon := hb_inetCreate()
LOCAL skCon := hb_inetCreate()
hb_inetTimeout( skCon, 10000 )
hb_inetConnect( ::cServer, ::nPort, skCon )
IF hb_inetErrorCode( skCon ) != 0 .or. ! ::GetOk( skCon )
IF hb_inetErrorCode( skCon ) != 0 .OR. ! ::GetOk( skCon )
RETURN .F.
ENDIF
@@ -146,12 +154,12 @@ METHOD Send( nStyle, cMessage, cName, nPriority ) CLASS HB_LogEmail
RETURN .F.
ENDIF
hb_inetSendAll( skCon, "MAIL FROM: <" + ::cAddress +">" + CRLF )
hb_inetSendAll( skCon, "MAIL FROM: <" + ::cAddress + ">" + CRLF )
IF ! ::GetOk( skCon )
RETURN .F.
ENDIF
hb_inetSendAll( skCon, "RCPT TO: <" + ::cSendTo +">" + CRLF )
hb_inetSendAll( skCon, "RCPT TO: <" + ::cSendTo + ">" + CRLF )
IF ! ::GetOk( skCon )
RETURN .F.
ENDIF
@@ -170,26 +178,30 @@ METHOD Send( nStyle, cMessage, cName, nPriority ) CLASS HB_LogEmail
hb_inetSendAll( skCon, "QUIT" + CRLF )
RETURN ::GetOk( skCon ) // if quit fails, the mail does not go!
RETURN ::GetOk( skCon ) // if quit fails, the mail does not go!
/**
* Get the reply and returns true if it is allright
*/
METHOD GetOk( skCon ) CLASS HB_LogEmail
LOCAL nLen, cReply
cReply := hb_inetRecvLine( skCon, @nLen, 128 )
IF hb_inetErrorCode( skcon ) != 0 .or. Substr( cReply, 1, 1 ) == '5'
IF hb_inetErrorCode( skcon ) != 0 .OR. SubStr( cReply, 1, 1 ) == "5"
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
METHOD Prepare( nStyle, cMessage, cName, nPriority ) CLASS HB_LogEmail
LOCAL cPre
cPre := "FROM: " + ::cAddress + CRLF + ;
"TO: " + ::cSendTo + CRLF +;
"Subject:" + ::cSubject + CRLF + CRLF
"TO: " + ::cSendTo + CRLF + ;
"Subject:" + ::cSubject + CRLF + CRLF
IF ! Empty( ::cPrefix )
cPre += ::cPrefix + CRLF + CRLF
@@ -198,10 +210,10 @@ METHOD Prepare( nStyle, cMessage, cName, nPriority ) CLASS HB_LogEmail
cPre += ::Format( nStyle, cMessage, cName, nPriority )
IF ! Empty( ::cPostfix )
cPre += CRLF +CRLF + ::cPostfix + CRLF
cPre += CRLF + CRLF + ::cPostfix + CRLF
ENDIF
RETURN cPre
RETURN cPre
@@ -210,6 +222,7 @@ RETURN cPre
*************************************************/
CLASS HB_LogInetPort FROM HB_LogChannel
DATA nPort INIT 7761
DATA aListeners INIT {}
DATA skIn
@@ -224,17 +237,16 @@ CLASS HB_LogInetPort FROM HB_LogChannel
METHOD Open( cName )
METHOD Close( cName )
PROTECTED:
PROTECTED:
METHOD Send( nStyle, cMessage, cName, nPriority )
#ifdef HB_THREAD_SUPPORT
HIDDEN:
HIDDEN:
METHOD AcceptCon()
#endif
ENDCLASS
METHOD New( nLevel, nPort ) CLASS HB_LogInetPort
::Super:New( nLevel )
@@ -243,8 +255,7 @@ METHOD New( nLevel, nPort ) CLASS HB_LogInetPort
::nPort := nPort
ENDIF
RETURN Self
RETURN Self
METHOD Open( cName ) CLASS HB_LogInetPort
@@ -259,18 +270,18 @@ METHOD Open( cName ) CLASS HB_LogInetPort
ENDIF
#ifdef HB_THREAD_SUPPORT
::mtxBusy := HB_MutexCreate()
::nThread := HB_ThreadStart( Self, "AcceptCon" )
::mtxBusy := hb_mutexCreate()
::nThread := hb_threadStart( Self, "AcceptCon" )
#else
// If we have not threads, we have to sync accept incoming connection
// when we log a message
// If we have not threads, we have to sync accept incoming connection
// when we log a message
hb_inetTimeout( ::skIn, 50 )
#endif
RETURN .T.
RETURN .T.
METHOD Close( cName ) CLASS HB_LogInetPort
LOCAL sk
HB_SYMBOL_UNUSED( cName )
@@ -280,14 +291,14 @@ METHOD Close( cName ) CLASS HB_LogInetPort
ENDIF
#ifdef HB_THREAD_SUPPORT
// kind termination request
// kind termination request
::bTerminate := .T.
hb_ThreadJoin( ::nThread )
hb_threadJoin( ::nThread )
#endif
hb_inetClose( ::skIn )
// we now are sure that incoming thread index is not used.
// we now are sure that incoming thread index is not used.
DO WHILE Len( ::aListeners ) > 0
sk := ATail( ::aListeners )
@@ -296,25 +307,27 @@ METHOD Close( cName ) CLASS HB_LogInetPort
ENDDO
hb_inetCleanup()
RETURN .T.
RETURN .T.
METHOD Send( nStyle, cMessage, cName, nPriority ) CLASS HB_LogInetPort
LOCAL sk, nCount
#ifdef HB_THREAD_SUPPORT
// be sure thread is not busy now
HB_MutexLock( ::mtxBusy )
// be sure thread is not busy now
hb_mutexLock( ::mtxBusy )
#else
// IF we have not a thread, we must see if there is a new connection
// IF we have not a thread, we must see if there is a new connection
sk := hb_inetAccept( ::skIn ) //timeout should be short
IF sk != NIL
Aadd( ::aListeners, sk )
AAdd( ::aListeners, sk )
ENDIF
#endif
// now we transmit the message to all the available channels
// now we transmit the message to all the available channels
cMessage := ::Format( nStyle, cMessage, cName, nPriority )
nCount := 1
@@ -324,21 +337,22 @@ METHOD Send( nStyle, cMessage, cName, nPriority ) CLASS HB_LogInetPort
// if there is an error, we remove the listener
IF hb_inetErrorCode( sk ) != 0
ADel( ::aListeners, nCount )
ASize( ::aListeners , Len( ::aListeners ) - 1)
ASize( ::aListeners , Len( ::aListeners ) - 1 )
ELSE
nCount ++
nCount++
ENDIF
ENDDO
#ifdef HB_THREAD_SUPPORT
HB_MutexUnlock( ::mtxBusy )
hb_mutexUnlock( ::mtxBusy )
#endif
RETURN .T.
RETURN .T.
#ifdef HB_THREAD_SUPPORT
METHOD AcceptCon() CLASS HB_LogInetPort
LOCAL sk
hb_inetTimeout( ::skIn, 250 )
@@ -346,11 +360,12 @@ METHOD AcceptCon() CLASS HB_LogInetPort
sk := hb_inetAccept( ::skIn )
// A gentle termination request, or an error
IF sk != NIL
HB_MutexLock( ::mtxBusy )
hb_mutexLock( ::mtxBusy )
AAdd( ::aListeners, sk )
HB_MutexUnlock( ::mtxBusy )
hb_mutexUnlock( ::mtxBusy )
ENDIF
ENDDO
RETURN .T.
RETURN .T.
#endif

74
harbour/contrib/xhb/hjwindow.prg
View File

@@ -94,7 +94,7 @@ CLASS TJsWindow
METHOD Paragraph() INLINE ::QOut( "<P></P>" )
METHOD CENTER( l ) INLINE ::QOut( iif( l, "<CENTER>", "</CENTER>" ) )
METHOD Center( l ) INLINE ::QOut( iif( l, "<CENTER>", "</CENTER>" ) )
METHOD bold( l ) INLINE ::QOut( iif( l, "<B>", "</B>" ) )
@@ -106,20 +106,20 @@ CLASS TJsWindow
METHOD Begin()
METHOD END ()
METHOD End()
METHOD Qout( c )
METHOD QOut( c )
METHOD WriteLN( c ) INLINE ::qOut( c )
METHOD WriteLN( c ) INLINE ::QOut( c )
METHOD SetFeatures( alwaysRaised, alwaysLowered, ;
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory )
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory )
METHOD ImageURL( cImage, cUrl, nHeight, nBorder, ;
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt )
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt )
ENDCLASS
@@ -150,7 +150,7 @@ METHOD New( cVarName, cUrl, cName, x, y, w, h ) CLASS TJsWindow
::height := h
::width := w
RETURN Self
RETURN Self
/****
*
@@ -159,9 +159,9 @@ RETURN Self
*/
METHOD SetFeatures( alwaysRaised, alwaysLowered, ;
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory ) CLASS TJsWindow
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory ) CLASS TJsWindow
LOCAL cStr := ""
@@ -247,7 +247,7 @@ METHOD SetFeatures( alwaysRaised, alwaysLowered, ;
::features += iif( Empty( ::Features ), cStr + ",", cStr )
RETURN Self
RETURN Self
/****
*
@@ -258,6 +258,7 @@ RETURN Self
METHOD SetSize( x, y, h, w ) CLASS TJsWindow
LOCAL cStr := ""
DEFAULT x TO ::ScreenX, ;
y TO ::ScreenY, ;
h TO ::height, ;
@@ -276,7 +277,7 @@ METHOD SetSize( x, y, h, w ) CLASS TJsWindow
::features += iif( Empty( ::Features ), cStr + ",", cStr )
RETURN Self
RETURN Self
/****
*
@@ -311,7 +312,7 @@ METHOD Put() CLASS TJsWindow
HtmlJsCmd( ::nH, cStr )
RETURN Self
RETURN Self
/****
*
@@ -322,7 +323,8 @@ RETURN Self
METHOD Write( c ) CLASS TJsWindow
HtmlJsCmd( ::nH, ::varName + ".document.write('" + c + "')" + CRLF() )
RETURN Self
RETURN Self
/****
*
@@ -331,10 +333,11 @@ RETURN Self
*
*/
METHOD Qout( c ) CLASS TJsWindow
METHOD QOut( c ) CLASS TJsWindow
Fwrite( ::nH, ::varName + ".document.write('" + c + "')" + CRLF() )
RETURN Self
FWrite( ::nH, ::varName + ".document.write('" + c + "')" + CRLF() )
RETURN Self
/****
*
@@ -348,8 +351,8 @@ METHOD Begin() CLASS TJsWindow
LOCAL i
Fwrite( ::nH, "<SCRIPT LANGUAGE=JavaScript 1.2>" + CRLF() )
Fwrite( ::nH, "<!--" + CRLF() )
FWrite( ::nH, "<SCRIPT LANGUAGE=JavaScript 1.2>" + CRLF() )
FWrite( ::nH, "<!--" + CRLF() )
::QOut( "<HTML><HEAD>" )
IF ::Title != NIL
@@ -359,14 +362,14 @@ METHOD Begin() CLASS TJsWindow
IF ::aScriptSrc != NIL
FOR i := 1 TO Len( ::aScriptSrc )
::QOut( ;
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aScriptSrc[ i ] + '"></SCRIPT>' )
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aScriptSrc[ i ] + '"></SCRIPT>' )
NEXT
ENDIF
IF ::aServerSrc != NIL
FOR i := 1 TO Len( ::aServerSrc )
::QOut( ;
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aServerSrc[ i ] + '" RUNAT=SERVER></SCRIPT>' )
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aServerSrc[ i ] + '" RUNAT=SERVER></SCRIPT>' )
NEXT
ENDIF
@@ -377,7 +380,7 @@ METHOD Begin() CLASS TJsWindow
::QOut( "</HEAD>" + "<BODY" )
IF ::onLoad != NIL
::Qout( ' onLoad="' + ::onLoad + '"' )
::QOut( ' onLoad="' + ::onLoad + '"' )
ENDIF
IF ::onUnLoad != NIL
@@ -398,10 +401,10 @@ METHOD Begin() CLASS TJsWindow
::QOut( '<BODY BACKGROUND="' + ::bgImage + '">' )
ENDIF
Fwrite( ::nH, "//-->" )
Fwrite( ::nH, "</SCRIPT>" + CRLF() )
FWrite( ::nH, "//-->" )
FWrite( ::nH, "</SCRIPT>" + CRLF() )
RETURN Self
RETURN Self
/****
*
@@ -409,11 +412,11 @@ RETURN Self
*
*/
METHOD END () CLASS TJsWindow
METHOD End() CLASS TJsWindow
HtmlJsCmd( ::nH, ::varName + ".document.write('</BODY></HTML>')" + CRLF() )
RETURN Self
RETURN Self
/****
*
@@ -422,8 +425,8 @@ RETURN Self
*/
METHOD ImageURL( cImage, cUrl, nHeight, nBorder, ;
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt ) CLASS TJsWindow
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt ) CLASS TJsWindow
LOCAL cStr := ""
@@ -456,9 +459,10 @@ METHOD ImageURL( cImage, cUrl, nHeight, nBorder, ;
IF cURL != NIL
::QOut( '<A HREF=' + cUrl + '><IMG SRC="' + cImage + '"' + ;
cStr + '></A>' )
cStr + '></A>' )
ELSE
::QOut( '<IMG SRC="' + cImage + '"' + ;
cStr + '></A>' )
cStr + '></A>' )
ENDIF
RETURN Self
RETURN Self

62
harbour/contrib/xhb/hterrsys.prg
View File

@@ -47,11 +47,11 @@
#include "error.ch"
#include "cgi.ch"
#define DEF_ERR_HEADER "Date : "+DTOC(Date())+"<BR>"+"Time : " + Time() + "<BR>"
#define DEF_ERR_HEADER "Date : " + DToC( Date() ) + "<BR>" + "Time : " + Time() + "<BR>"
// put messages to STDERR
#command ? <list,...> => ?? Chr(13) + Chr(10) ; ?? <list>
#command ?? <list,...> => OutErr(<list>)
#command ?? <list,...> => OutErr( <list> )
REQUEST HARDCR
REQUEST MEMOWRIT
@@ -64,9 +64,9 @@ STATIC s_cErrFooter := " "
* DefError()
*/
/*
STATIC FUNC xhb_cgi_DefError( e )
#if 0
STATIC FUNC xhb_cgi_DefError( e )
LOCAL i
LOCAL cMessage := ""
@@ -88,18 +88,18 @@ STATIC FUNC xhb_cgi_DefError( e )
ENDIF
// for network open error, set NETERR() and subsystem default
IF e:genCode == EG_OPEN .and. ( e:osCode == 32 .or. e:osCode == 5 ) ;
.and. e:canDefault
IF e:genCode == EG_OPEN .AND. ( e:osCode == 32 .OR. e:osCode == 5 ) ;
.AND. e:canDefault
Neterr( .T. )
NetErr( .T. )
RETURN .F. // NOTE
ENDIF
// for lock error during APPEND BLANK, set NETERR() and subsystem default
IF e:genCode == EG_APPENDLOCK .and. e:canDefault
IF e:genCode == EG_APPENDLOCK .AND. e:canDefault
Neterr( .T. )
NetErr( .T. )
RETURN .F. // NOTE
ENDIF
@@ -108,7 +108,7 @@ STATIC FUNC xhb_cgi_DefError( e )
cMessage += ErrorMessage( e )
// display message and traceback
IF ( !Empty( e:osCode ) )
IF ! Empty( e:osCode )
cMessage += " (DOS Error : " + hb_ntos( e:osCode ) + ")"
ENDIF
@@ -147,12 +147,12 @@ STATIC FUNC xhb_cgi_DefError( e )
i := 2
DO WHILE ( !Empty( Procname( i ) ) )
DO WHILE !Empty( ProcName( i ) )
cErrString += "Called from " + RTrim( Procname( i ) ) + ;
"(" + hb_ntos( Procline( i ) ) + ") <BR>" + CRLF()
cErrString += "Called from " + RTrim( ProcName( i ) ) + ;
"(" + hb_ntos( ProcLine( i ) ) + ") <BR>" + CRLF()
i ++
i++
ENDDO
cErrstring += '</EM>'
@@ -162,24 +162,25 @@ STATIC FUNC xhb_cgi_DefError( e )
cErrstring += "Extra Notes..."
cErrString += "</TD>" + CRLF() + "</TR>" + CRLF() + "</TABLE>" + CRLF()
Fwrite( nH, "<BR>" + cErrString + CRLF() )
Memowrit( "Error.Log", Hardcr( cErrString ) + CRLF() + ;
Hardcr( Memoread( "Error.Log" ) ) )
FWrite( nH, "<BR>" + cErrString + CRLF() )
MemoWrit( "Error.Log", HardCR( cErrString ) + CRLF() + ;
HardCR( MemoRead( "Error.Log" ) ) )
Fwrite( nH, "</TD>" + CRLF() + "</TR>" + CRLF() + "</TABLE>" + CRLF() )
FWrite( nH, "</TD>" + CRLF() + "</TR>" + CRLF() + "</TABLE>" + CRLF() )
HtmlJsCmd( nH, 'alert("There was an error processing your request:\n' + ;
'Look at the bottom of this page for\n' + ;
'error description and parameters...");' )
Fwrite( nH, "</FONT>" + CRLF() + "</BODY></HTML>" + CRLF() )
'Look at the bottom of this page for\n' + ;
'error description and parameters...");' )
FWrite( nH, "</FONT>" + CRLF() + "</BODY></HTML>" + CRLF() )
CLOSE ALL
Errorlevel( 1 )
ErrorLevel( 1 )
QUIT
RETURN .F.
*/
RETURN .F.
#endif
FUNCTION SetCorruptFunc( bFunc )
@@ -187,19 +188,19 @@ FUNCTION SetCorruptFunc( bFunc )
s_bFixCorrupt := bFunc
ENDIF
RETURN s_bFixCorrupt
RETURN s_bFixCorrupt
FUNCTION SetErrorFooter()
RETURN s_cErrFooter
RETURN s_cErrFooter
/***
* ErrorMessage()
*/
/*
STATIC FUNC ErrorMessage( e )
#if 0
STATIC FUNCTION ErrorMessage( e )
LOCAL cMessage := ""
@@ -235,5 +236,6 @@ STATIC FUNC ErrorMessage( e )
ENDIF
cMessage += CRLF()
RETURN cMessage
*/
RETURN cMessage
#endif

88
harbour/contrib/xhb/htjlist.prg
View File

@@ -53,6 +53,7 @@
#include "cgi.ch"
CLASS TJsList
DATA nH INIT STD_OUT
DATA aScript INIT {}
DATA aItems INIT {}
@@ -68,7 +69,7 @@ CLASS TJsList
DATA FontColor INIT "black"
METHOD New( name, lOpen, width, height, bgColor, ;
FONT, fntColor, fntSize, cMinusImg, cPlusImg )
FONT, fntColor, fntSize, cMinusImg, cPlusImg )
METHOD NewNode( name, lOpen, width, height, bgColor )
@@ -93,7 +94,7 @@ ENDCLASS
*/
METHOD New( name, lOpen, width, height, bgColor, ;
FONT, fntColor, fntSize, cMinusImg, cPlusImg ) CLASS TJsList
FONT, fntColor, fntSize, cMinusImg, cPlusImg ) CLASS TJsList
LOCAL cStr
@@ -117,18 +118,18 @@ METHOD New( name, lOpen, width, height, bgColor, ;
::aSCript := {}
cStr := "<HTML>" + CRLF() + "<HEAD>" + CRLF() + ;
"<STYLE>" + ::Style + "</STYLE>" + CRLF() + ;
'<SCRIPT LANGUAGE="JavaScript1.2" SRC="resize.js"></SCRIPT>' + CRLF() + ;
CRLF() + ;
'<SCRIPT LANGUAGE="JavaScript1.2" SRC="list.js"></SCRIPT>' + CRLF() + ;
CRLF() + ;
'<SCRIPT LANGUAGE="JavaScript">' + CRLF() + ;
"<!--" + crlf() + ;
"var " + name + ";" + CRLF() + CRLF() + ;
"function listInit() {" + CRLF() + ;
"var width =" + hb_ntos( width ) + ";" + ;
"var height=" + hb_ntos( height ) + ";" + CRLF() + ;
'listSetImages( "' + cMinusImg + '", "' + cPlusImg + '" );' + CRLF() + CRLF()
"<STYLE>" + ::Style + "</STYLE>" + CRLF() + ;
'<SCRIPT LANGUAGE="JavaScript1.2" SRC="resize.js"></SCRIPT>' + CRLF() + ;
CRLF() + ;
'<SCRIPT LANGUAGE="JavaScript1.2" SRC="list.js"></SCRIPT>' + CRLF() + ;
CRLF() + ;
'<SCRIPT LANGUAGE="JavaScript">' + CRLF() + ;
"<!--" + crlf() + ;
"var " + name + ";" + CRLF() + CRLF() + ;
"function listInit() {" + CRLF() + ;
"var width =" + hb_ntos( width ) + ";" + ;
"var height=" + hb_ntos( height ) + ";" + CRLF() + ;
'listSetImages( "' + cMinusImg + '", "' + cPlusImg + '" );' + CRLF() + CRLF()
::cMainNode := name
@@ -141,10 +142,10 @@ METHOD New( name, lOpen, width, height, bgColor, ;
cStr += "" //SPACE(10)
cStr += name + [.setFont("<FONT FACE='] + FONT + [' SIZE=] + hb_ntos( fntSize ) + [' COLOR='] + fntColor + ['>","</FONT>");] + CRLF()
::nItems ++
Aadd( ::aScript, cStr )
::nItems++
AAdd( ::aScript, cStr )
RETURN Self
RETURN Self
/****
*
@@ -155,6 +156,7 @@ RETURN Self
METHOD NewNode( name, lOpen, width, height, bgColor ) CLASS TJsList
LOCAL cStr := ""
DEFAULT lOpen TO .F.
DEFAULT WIDTH TO 200
DEFAULT HEIGHT TO 22
@@ -167,12 +169,12 @@ METHOD NewNode( name, lOpen, width, height, bgColor ) CLASS TJsList
cStr += '"' + BGCOLOR + '"' + ");" + CRLF()
::cCurrentNode := name
::nItems ++
Aadd( ::aScript, cStr )
::nItems++
AAdd( ::aScript, cStr )
::setFont()
RETURN Self
RETURN Self
/****
*
@@ -193,10 +195,11 @@ METHOD SetFont( name, font, fntColor, fntSize ) CLASS TJsList
[ FACE = '] + font + [' ] + ;
[ SIZE = ] + hb_ntos( fntSize ) + ['] + ;
[ COLOR = '] + fntColor + [' ] + ;
[ > ","</FONT>");]+CRLF()
[ > ","</FONT>");] + CRLF()
Aadd( ::aScript, cStr )
RETURN self
AAdd( ::aScript, cStr )
RETURN self
/****
*
@@ -208,13 +211,15 @@ METHOD AddItem( name, url, bgColor ) CLASS TJsList
LOCAL cStr := ""
LOCAL cUrl
DEFAULT name TO "o"
DEFAULT url TO ""
cUrl := [<A HREF='] + url + ['>] + htmlSpace( 2 ) + name + htmlSpace( 2 )
cStr += ::cCurrentNode + '.addItem( "' + cUrl + '"' + iif( bgColor != NIL, ',"' + bgColor + '"', "" ) + ');' + CRLF()
::nItems ++
Aadd( ::aScript, cStr )
RETURN self
::nItems++
AAdd( ::aScript, cStr )
RETURN self
/****
*
@@ -226,14 +231,16 @@ METHOD AddLink( name, url, img, bgColor ) CLASS TJsList
LOCAL cStr := ""
LOCAL cUrl
DEFAULT name TO "o"
DEFAULT url TO ""
DEFAULT img TO "webpage.jpg"
cUrl := "<A HREF='" + url + "'><IMG SRC='" + img + "' border=0 align=absmiddle>" + htmlSpace( 2 ) + name + htmlSpace( 2 )
cStr += ::cCurrentNode + '.addItem( "' + curl + '"' + iif( bgColor != NIL, ',"' + bgColor + '"', "" ) + ');' + CRLF()
::nItems ++
Aadd( ::aScript, cStr )
RETURN self
::nItems++
AAdd( ::aScript, cStr )
RETURN self
METHOD EndNode( name, caption ) CLASS TJsList
@@ -242,9 +249,10 @@ METHOD EndNode( name, caption ) CLASS TJsList
::cCurrentNode := ::cMainNode
cStr += ::cMainNode + ".addList( " + name + ", '<B>" + caption + "</B>' );" + CRLF()
::nItems ++
Aadd( ::aScript, cStr )
RETURN self
::nItems++
AAdd( ::aScript, cStr )
RETURN self
METHOD Build( xPos, yPos ) CLASS TJsList
@@ -267,34 +275,34 @@ METHOD Build( xPos, yPos ) CLASS TJsList
NEXT
cStr += "</STYLE>" + CRLF()
Aadd( ::aScript, cStr )
AAdd( ::aScript, cStr )
cStr := ""
cStr += "<TITLE>Collapsable Lists: Basic Example</TITLE>" + CRLF()
cStr += "</HEAD>" + CRLF()
cStr += '<BODY ONLOAD="listInit();" BGCOLOR="#FFFFFF">' + CRLF()
cStr += '<DIV ID="spacer"></DIV>' + CRLF()
//cStr += '<DIV ID="'+::cMainNode+'Item0" NAME="'+::cMainNode+"Item0"></DIV>'+CRLF()
// cStr += '<DIV ID="' + ::cMainNode + 'Item0" NAME="' + ::cMainNode + "Item0"></DIV>' + CRLF()
FOR i := 0 TO ::nItems
cStr += '<DIV ID="' + ::cMainNode + 'Item' + hb_ntos( i ) + '" NAME="' + ::cMainNode + 'Item' + hb_ntos( i ) + '"></DIV>' + CRLF()
NEXT
cStr += "</BODY></HTML>" + CRLF()
Aadd( ::aScript, cStr )
AAdd( ::aScript, cStr )
RETURN Self
RETURN Self
METHOD Put( cFile ) CLASS TJsList
IF cFile == NIL
::nH := STD_OUT
ELSE
::nH := Fcreate( cFile )
::nH := FCreate( cFile )
ENDIF
Aeval( ::aScript, {| e | Fwrite( ::nH, e ) } )
AEval( ::aScript, {| e | FWrite( ::nH, e ) } )
Fclose( ::nH )
FClose( ::nH )
RETURN Self
RETURN Self

300
harbour/contrib/xhb/htmutil.prg
View File

@@ -62,9 +62,9 @@ PROCEDURE BackButton( cImage, oHtm )
DEFAULT oHtm TO HtmlPageObject()
IMAGE( cImage ) ;
URL "" ;
ONCLICK "history.back()" ;
OF oHtm
URL "" ;
ONCLICK "history.back()" ;
OF oHtm
RETURN
@@ -116,7 +116,7 @@ FUNCTION PutCounter( oHtm, nNumber, cDir, nDigits, nWidth, bgColor, nBorder )
DEFAULT BGCOLOR TO "black"
IF HB_ISNUMERIC( nNumber )
cStr := Strzero( nNumber, nDigits )
cStr := StrZero( nNumber, nDigits )
ENDIF
oHtm:Write( "<center>" )
@@ -130,7 +130,7 @@ FUNCTION PutCounter( oHtm, nNumber, cDir, nDigits, nWidth, bgColor, nBorder )
oHtm:newTableCell( "center" )
FOR i := 1 TO Len( cStr )
IMAGE cDir + Substr( cStr, i, 1 ) + ".gif" ;
IMAGE cDir + SubStr( cStr, i, 1 ) + ".gif" ;
BORDER 0 ;
OF oHtm
NEXT
@@ -141,18 +141,17 @@ FUNCTION PutCounter( oHtm, nNumber, cDir, nDigits, nWidth, bgColor, nBorder )
oHtm:Write( "</center>" )
RETURN Nil
RETURN Nil
PROC htmlBrowse( oHtm, cAction, lUseLinks )
LOCAL i
LOCAL n := 0
LOCAL aFlds := Dbstruct()
LOCAL aFlds := dbStruct()
LOCAL cAlign
DEFAULT cAction to "confirm('RECORD: '+this.name+'\nPlace your action here !!!')"
DEFAULT lUseLinks to .F.
DEFAULT cAction TO "confirm('RECORD: '+this.name+'\nPlace your action here !!!')"
DEFAULT lUseLinks TO .F.
/*
// browse caption...
@@ -165,14 +164,14 @@ oHtm:endTableRow("black")
oHtm:endTable()
*/
oHtm:defineTable( Fcount(), 1, 98 )
oHtm:defineTable( FCount(), 1, 98 )
oHtm:TableHead( " ? " )
FOR i := 1 TO Fcount()
FOR i := 1 TO FCount()
oHtm:TableHead( aFlds[ i, 1 ] )
NEXT
WHILE !( Eof() )
WHILE !( EOF() )
// each row has a different color...
IF n == 0
@@ -187,11 +186,11 @@ oHtm:endTable()
oHtm:newTableCell( "center" )
IF lUseLinks
LINK ( cAction ) ;
TEXT( hb_ntos( Recno() ) ) ;
OF oHtm
TEXT( hb_ntos( RecNo() ) ) ;
OF oHtm
ELSE
PUSH BUTTON ;
NAME "'B" + hb_ntos( Recno() ) + "'" ;
NAME "'B" + hb_ntos( RecNo() ) + "'" ;
CAPTION "' ? '" ;
ONCLICK ( cAction ) ;
OF oHtm
@@ -201,8 +200,8 @@ oHtm:endTable()
// --> put the formatted fields data...
FOR i := 1 TO Len( aFlds )
cAlign := iif( aFlds[ i, 2 ] == "N", "RIGHT", "CENTER" )
oHtm:newTableCell( cAlign,,,, "black" )
oHtm:Write( greek2Html( htmlany2Str( Fieldget( i ) ) ) )
oHtm:newTableCell( cAlign, , , , "black" )
oHtm:Write( greek2Html( htmlany2Str( FieldGet( i ) ) ) )
oHtm:EndTableCell()
NEXT
oHtm:endTableRow()
@@ -212,7 +211,9 @@ oHtm:endTable()
oHtm:endTable()
RETURN
#ifdef MYSQL
PROC htmlBrowseSql( oHtm, cAction, lUseLinks, cTarget, oServer, oQuery )
LOCAL i
@@ -222,8 +223,8 @@ PROC htmlBrowseSql( oHtm, cAction, lUseLinks, cTarget, oServer, oQuery )
LOCAL cAlign
DEFAULT cAction to "confirm('RECORD: '+this.name+'\nPlace your action here !!!')"
DEFAULT lUseLinks to .F.
DEFAULT cAction TO "confirm('RECORD: '+this.name+'\nPlace your action here !!!')"
DEFAULT lUseLinks TO .F.
/*
// browse caption...
@@ -259,11 +260,11 @@ oHtm:endTable()
oHtm:newTableCell( "center" )
IF lUseLinks
LINK( cAction ) ;
TEXT( hb_ntos( oQuery:RECNO() ) ) ;
OF oHtm
TEXT( hb_ntos( oQuery:RecNo() ) ) ;
OF oHtm
ELSE
PUSH BUTTON ;
NAME "'B" + hb_ntos( oQuery:RECNO() ) + "'" ;
NAME "'B" + hb_ntos( oQuery:RecNo() ) + "'" ;
CAPTION "' ? '" ;
ONCLICK( cAction ) ;
OF oHtm
@@ -272,15 +273,15 @@ oHtm:endTable()
// --> put the formatted fields data...
FOR i := 1 TO oquery:fcount()
FOR i := 1 TO oquery:FCount()
cAlign := iif( oCurRow:FieldType( i ) == "N", "RIGHT", "CENTER" )
oHtm:newTableCell( cAlign,,,, "black" )
oHtm:newTableCell( cAlign, , , , "black" )
oHtm:Write( greek2Html( htmlany2Str( oCurRow:FieldGet( i ) ) ) )
oHtm:EndTableCell()
END
oHtm:endTableRow()
IF !oquery:eof()
IF !oquery:EOF()
oquery:skip()
ENDIF
@@ -288,11 +289,12 @@ oHtm:endTable()
oHtm:endTable()
RETURN
#endif
//*** EOF ***//
//*** EOF ***//
Class JWindow
CLASS JWindow
DATA nH
DATA Name INIT ""
@@ -348,22 +350,22 @@ Class JWindow
METHOD Put()
METHOD Begin()
METHOD BEGIN()
METHOD END ()
METHOD Qout( c )
METHOD QOut( c )
METHOD WriteLN( c ) INLINE ::qOut( c )
METHOD WriteLN( c ) INLINE ::QOut( c )
METHOD SetFeatures( alwaysRaised, alwaysLowered, ;
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory )
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory )
METHOD ImageURL( cImage, cUrl, nHeight, nBorder, ;
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt )
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt )
ENDCLASS
@@ -375,15 +377,15 @@ ENDCLASS
*
*/
METHOD New( cVarName, cUrl, cName, x, y, w, h ) Class JWindow
METHOD New( cVarName, cUrl, cName, x, y, w, h ) CLASS JWindow
DEFAULT cVarName to "newWin"
DEFAULT cURL to " "
DEFAULT cName to cVarName //"newWin"
DEFAULT x to 100
DEFAULT y to 100
DEFAULT h to 300
DEFAULT w to 300
DEFAULT cVarName TO "newWin"
DEFAULT cURL TO " "
DEFAULT cName TO cVarName //"newWin"
DEFAULT x TO 100
DEFAULT y TO 100
DEFAULT h TO 300
DEFAULT w TO 300
::nH := HtmlPageHandle()
::oHtm := HtmlPageObject()
@@ -396,9 +398,9 @@ METHOD New( cVarName, cUrl, cName, x, y, w, h ) Class JWindow
::height := h
::width := w
// objectViewer( self )
// objectViewer( self )
RETURN Self
RETURN Self
/****
*
@@ -409,9 +411,9 @@ RETURN Self
*/
METHOD SetFeatures( alwaysRaised, alwaysLowered, ;
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory ) Class JWindow
Resizable, Menubar, personalBar, ;
dependent, location, directories, ;
Scrollbars, Status, TitleBar, Toolbar, copyHistory ) CLASS JWindow
LOCAL cStr := ""
@@ -497,7 +499,7 @@ METHOD SetFeatures( alwaysRaised, alwaysLowered, ;
::features += iif( Empty( ::Features ), cStr + ",", cStr )
RETURN Self
RETURN Self
/****
*
@@ -507,9 +509,10 @@ RETURN Self
*
*/
METHOD SetSize( x, y, h, w ) Class JWindow
METHOD SetSize( x, y, h, w ) CLASS JWindow
LOCAL cStr := ""
DEFAULT x to ::ScreenX, ;
y to ::ScreenY, ;
h to ::height, ;
@@ -528,7 +531,7 @@ METHOD SetSize( x, y, h, w ) Class JWindow
::features += iif( Empty( ::Features ), cStr + ",", cStr )
RETURN Self
RETURN Self
/****
*
@@ -538,7 +541,7 @@ RETURN Self
*
*/
METHOD Put() Class JWindow
METHOD Put() CLASS JWindow
LOCAL cStr := ""
@@ -565,7 +568,7 @@ METHOD Put() Class JWindow
htmljscmd( ::nH, cStr )
RETURN Self
RETURN Self
/****
*
@@ -573,10 +576,11 @@ RETURN Self
*
*/
METHOD Write( c ) Class JWindow
METHOD Write( c ) CLASS JWindow
htmljscmd( ::nH, ::varName + ".document.write('" + c + "')" + CRLF() )
RETURN Self
RETURN Self
/****
*
@@ -585,10 +589,11 @@ RETURN Self
*
*/
METHOD Qout( c ) Class JWindow
METHOD QOut( c ) CLASS JWindow
Fwrite( ::nH, ::varName + ".document.write('" + c + "')" + CRLF() )
RETURN Self
FWrite( ::nH, ::varName + ".document.write('" + c + "')" + CRLF() )
RETURN Self
/****
*
@@ -598,12 +603,12 @@ RETURN Self
*
*/
METHOD Begin() Class JWindow
METHOD BEGIN() CLASS JWindow
LOCAL i
Fwrite( ::nH, "<SCRIPT LANGUAGE=JavaScript 1.2>" + CRLF() )
Fwrite( ::nH, "<!--" + CRLF() )
FWrite( ::nH, "<SCRIPT LANGUAGE=JavaScript 1.2>" + CRLF() )
FWrite( ::nH, "<!--" + CRLF() )
::QOut( "<HTML><HEAD>" )
IF ::Title != NIL
@@ -613,14 +618,14 @@ METHOD Begin() Class JWindow
IF ::aScriptSrc != NIL
FOR i := 1 TO Len( ::aScriptSrc )
::QOut( ;
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aScriptSrc[ i ] + '"></SCRIPT>' )
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aScriptSrc[ i ] + '"></SCRIPT>' )
NEXT
ENDIF
IF ::aServerSrc != NIL
FOR i := 1 TO Len( ::aServerSrc )
::QOut( ;
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aServerSrc[ i ] + '" RUNAT=SERVER></SCRIPT>' )
'<SCRIPT LANGUAGE=JavaScript SRC="' + ::aServerSrc[ i ] + '" RUNAT=SERVER></SCRIPT>' )
NEXT
ENDIF
@@ -631,7 +636,7 @@ METHOD Begin() Class JWindow
::QOut( "</HEAD>" + "<BODY" )
IF ::onLoad != NIL
::Qout( ' onLoad="' + ::onLoad + '"' )
::QOut( ' onLoad="' + ::onLoad + '"' )
ENDIF
IF ::onUnLoad != NIL
@@ -652,10 +657,10 @@ METHOD Begin() Class JWindow
::QOut( '<BODY BACKGROUND="' + ::bgImage + '">' )
ENDIF
Fwrite( ::nH, "//-->" )
Fwrite( ::nH, "</SCRIPT>" + CRLF() )
FWrite( ::nH, "//-->" )
FWrite( ::nH, "</SCRIPT>" + CRLF() )
RETURN Self
RETURN Self
/****
*
@@ -665,11 +670,11 @@ RETURN Self
*
*/
METHOD END () Class JWindow
METHOD END () CLASS JWindow
htmljscmd( ::nH, ::varName + ".document.write('</BODY></HTML>')" + CRLF() )
RETURN Self
RETURN Self
/****
*
@@ -680,12 +685,12 @@ RETURN Self
*/
METHOD ImageURL( cImage, cUrl, nHeight, nBorder, ;
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt ) Class JWindow
cOnClick, cOnMsover, cOnMsout, ;
cName, cAlt ) CLASS JWindow
LOCAL cStr := ""
DEFAULT cUrl to ""
DEFAULT cUrl TO ""
IF cName != NIL
cStr += ' NAME= "' + cName + '"' + CRLF()
@@ -714,85 +719,86 @@ METHOD ImageURL( cImage, cUrl, nHeight, nBorder, ;
IF cURL != NIL
::QOut( '<A HREF=' + cUrl + '><IMG SRC="' + cImage + '"' + ;
cStr + '></A>' )
cStr + '></A>' )
ELSE
::QOut( '<IMG SRC="' + cImage + '"' + ;
cStr + '></A>' )
cStr + '></A>' )
ENDIF
RETURN Self
RETURN Self
//*** EOF ***//
#define GREEK_ALPHABET {;
Chr( 193 ), ;
Chr( 194 ), ;
Chr( 195 ), ;
Chr( 196 ), ;
Chr( 197 ), ;
Chr( 198 ), ;
Chr( 199 ), ;
Chr( 200 ), ;
Chr( 201 ), ;
Chr( 202 ), ;
Chr( 203 ), ;
Chr( 204 ), ;
Chr( 205 ), ;
Chr( 206 ), ;
Chr( 207 ), ;
Chr( 208 ), ;
Chr( 209 ), ;
Chr( 211 ), ;
Chr( 212 ), ;
Chr( 213 ), ;
Chr( 214 ), ;
Chr( 215 ), ;
Chr( 216 ), ;
Chr( 217 ), ;
Chr( 225 ), ;
Chr( 226 ), ;
Chr( 227 ), ;
Chr( 228 ), ;
Chr( 229 ), ;
Chr( 230 ), ;
Chr( 231 ), ;
Chr( 232 ), ;
Chr( 233 ), ;
Chr( 234 ), ;
Chr( 235 ), ;
Chr( 236 ), ;
Chr( 237 ), ;
Chr( 238 ), ;
Chr( 239 ), ;
Chr( 240 ), ;
Chr( 241 ), ;
Chr( 243 ), ;
Chr( 242 ), ;
Chr( 244 ), ;
Chr( 245 ), ;
Chr( 246 ), ;
Chr( 247 ), ;
Chr( 248 ), ;
Chr( 249 ), ;
Chr( 220 ), ;
Chr( 221 ), ;
Chr( 222 ), ;
Chr( 250 ), ;
Chr( 223 ), ;
Chr( 252 ), ;
Chr( 253 ), ;
Chr( 251 ), ;
Chr( 254 ), ;
Chr( 162 ), ;
Chr( 184 ), ;
Chr( 185 ), ;
Chr( 186 ), ;
Chr( 188 ), ;
Chr( 190 ), ;
Chr( 191 ), ;
Chr( 218 ), ;
Chr( 219 ) ;
}
hb_BChar( 193 ), ;
hb_BChar( 194 ), ;
hb_BChar( 195 ), ;
hb_BChar( 196 ), ;
hb_BChar( 197 ), ;
hb_BChar( 198 ), ;
hb_BChar( 199 ), ;
hb_BChar( 200 ), ;
hb_BChar( 201 ), ;
hb_BChar( 202 ), ;
hb_BChar( 203 ), ;
hb_BChar( 204 ), ;
hb_BChar( 205 ), ;
hb_BChar( 206 ), ;
hb_BChar( 207 ), ;
hb_BChar( 208 ), ;
hb_BChar( 209 ), ;
hb_BChar( 211 ), ;
hb_BChar( 212 ), ;
hb_BChar( 213 ), ;
hb_BChar( 214 ), ;
hb_BChar( 215 ), ;
hb_BChar( 216 ), ;
hb_BChar( 217 ), ;
hb_BChar( 225 ), ;
hb_BChar( 226 ), ;
hb_BChar( 227 ), ;
hb_BChar( 228 ), ;
hb_BChar( 229 ), ;
hb_BChar( 230 ), ;
hb_BChar( 231 ), ;
hb_BChar( 232 ), ;
hb_BChar( 233 ), ;
hb_BChar( 234 ), ;
hb_BChar( 235 ), ;
hb_BChar( 236 ), ;
hb_BChar( 237 ), ;
hb_BChar( 238 ), ;
hb_BChar( 239 ), ;
hb_BChar( 240 ), ;
hb_BChar( 241 ), ;
hb_BChar( 243 ), ;
hb_BChar( 242 ), ;
hb_BChar( 244 ), ;
hb_BChar( 245 ), ;
hb_BChar( 246 ), ;
hb_BChar( 247 ), ;
hb_BChar( 248 ), ;
hb_BChar( 249 ), ;
hb_BChar( 220 ), ;
hb_BChar( 221 ), ;
hb_BChar( 222 ), ;
hb_BChar( 250 ), ;
hb_BChar( 223 ), ;
hb_BChar( 252 ), ;
hb_BChar( 253 ), ;
hb_BChar( 251 ), ;
hb_BChar( 254 ), ;
hb_BChar( 162 ), ;
hb_BChar( 184 ), ;
hb_BChar( 185 ), ;
hb_BChar( 186 ), ;
hb_BChar( 188 ), ;
hb_BChar( 190 ), ;
hb_BChar( 191 ), ;
hb_BChar( 218 ), ;
hb_BChar( 219 ) ;
}
/****
*
@@ -812,7 +818,7 @@ FUNCTION initGreek()
LOCAL aArr := Array( 255 )
FOR i := 1 TO 255
aArr[ i ] := Chr( i )
aArr[ i ] := hb_BChar( i )
NEXT
n := 1
@@ -829,7 +835,7 @@ FUNCTION initGreek()
n++
aArr[ 245 ] := aGreek[ n ]
RETURN aArr
RETURN aArr
/****
*
@@ -850,4 +856,4 @@ FUNCTION Greek2Html( cText )
cStr += s_aGreek[ Asc( Substr( cText, i, 1 ) ) ]
NEXT
RETURN cStr
RETURN cStr

80
harbour/contrib/xhb/tcgi.prg
View File

@@ -93,35 +93,35 @@ METHOD New( cInBuffer ) CLASS TCgi
::nH := HtmlPageHandle()
::Server_Software := Getenv( "SERVER_SOFTWARE" )
::Server_Name := Getenv( "SERVER_NAME" )
::Gateway_Interface := Getenv( "GATEWAY_INTERFACE" )
::Server_Protocol := Getenv( "SERVER_PROTOCOL" )
::Server_Port := Getenv( "SERVER_PORT" )
::Request_Method := Getenv( "REQUEST_METHOD" )
::Http_Accept := Getenv( "HTTP_ACCEPT" )
::Http_User_agent := Getenv( "HTTP_USER_AGENT" )
::Http_Referer := Getenv( "HTTP_REFERER" )
::Path_Info := Getenv( "PATH_INFO" )
::Path_Translated := Getenv( "PATH_TRANSLATED" )
::Script_Name := Getenv( "SCRIPT_NAME" )
::Query_String := Getenv( "QUERY_STRING" )
::Remote_Host := Getenv( "REMOTE_HOST" )
::Remote_Addr := Getenv( "REMOTE_ADDR" )
::ipAddress := Getenv( "REMOTE_ADDR" )
::Remote_User := Getenv( "REMOTE_USER" )
::Auth_Type := Getenv( "AUTH_TYPE" )
::Auth_User := Getenv( "AUTH_USER" )
::Auth_Pass := Getenv( "AUTH_PASS" )
::Content_Type := Getenv( "CONTENT_TYPE" )
::Content_Length := Getenv( "CONTENT_LENGTH" )
::Annotation_Server := Getenv( "ANNOTATION_SERVER" )
::Server_Software := GetEnv( "SERVER_SOFTWARE" )
::Server_Name := GetEnv( "SERVER_NAME" )
::Gateway_Interface := GetEnv( "GATEWAY_INTERFACE" )
::Server_Protocol := GetEnv( "SERVER_PROTOCOL" )
::Server_Port := GetEnv( "SERVER_PORT" )
::Request_Method := GetEnv( "REQUEST_METHOD" )
::Http_Accept := GetEnv( "HTTP_ACCEPT" )
::Http_User_agent := GetEnv( "HTTP_USER_AGENT" )
::Http_Referer := GetEnv( "HTTP_REFERER" )
::Path_Info := GetEnv( "PATH_INFO" )
::Path_Translated := GetEnv( "PATH_TRANSLATED" )
::Script_Name := GetEnv( "SCRIPT_NAME" )
::Query_String := GetEnv( "QUERY_STRING" )
::Remote_Host := GetEnv( "REMOTE_HOST" )
::Remote_Addr := GetEnv( "REMOTE_ADDR" )
::ipAddress := GetEnv( "REMOTE_ADDR" )
::Remote_User := GetEnv( "REMOTE_USER" )
::Auth_Type := GetEnv( "AUTH_TYPE" )
::Auth_User := GetEnv( "AUTH_USER" )
::Auth_Pass := GetEnv( "AUTH_PASS" )
::Content_Type := GetEnv( "CONTENT_TYPE" )
::Content_Length := GetEnv( "CONTENT_LENGTH" )
::Annotation_Server := GetEnv( "ANNOTATION_SERVER" )
IF cInBuffer != NIL
::Query_String := Rtrim( cInBuffer )
::Query_String := RTrim( cInBuffer )
ELSE
IF "POST" $ Upper( ::Request_Method )
::Query_String := Rtrim( Freadstr( STD_IN, Val( ::CONTENT_LENGTH ) ) )
::Query_String := RTrim( FReadStr( STD_IN, Val( ::CONTENT_LENGTH ) ) )
ENDIF
ENDIF
@@ -129,12 +129,12 @@ METHOD New( cInBuffer ) CLASS TCgi
::aQueryFields := {}
aTemp := hb_atokens( ::Query_String, "&" ) // separate fields
aTemp := hb_ATokens( ::Query_String, "&" ) // separate fields
FOR i := 1 TO Len( aTemp )
aVar := hb_atokens( aTemp[ i ], "=" )
aVar := hb_ATokens( aTemp[ i ], "=" )
IF Len( aVar ) == 2
Aadd( ::aQueryFields, { aVar[ 1 ], HtmlDecodeUrl( aVar[ 2 ] ) } )
AAdd( ::aQueryFields, { aVar[ 1 ], HtmlDecodeUrl( aVar[ 2 ] ) } )
ENDIF
NEXT
@@ -161,16 +161,16 @@ METHOD ToObject() CLASS TCgi
STATIC sn := 0
// --> create new oObject class from this one...
sn ++
aDb := hbClass():New( "NewCgi" + Strzero( sn, 3 ), { "TCgi" } )
sn++
aDb := HBClass():New( "NewCgi" + StrZero( sn, 3 ), { "TCgi" } )
FOR i := 1 TO Len( ::aQueryFields )
IF ::aQueryFields[ i, 2 ] == NIL .or. Empty( ::aQueryFields[ i, 2 ] )
IF ::aQueryFields[ i, 2 ] == NIL .OR. Empty( ::aQueryFields[ i, 2 ] )
::aQueryFields[ i, 2 ] := ""
ENDIF
adb:AddData( ::aQueryFields[ i, 1 ], ::aQueryFields[ i, 2 ],, nScope )
adb:AddData( ::aQueryFields[ i, 1 ], ::aQueryFields[ i, 2 ], , nScope )
NEXT
adb:Create()
@@ -208,8 +208,8 @@ METHOD Field( cQueryName ) CLASS TCgi
DEFAULT cQueryName TO ""
nRet := Ascan( ::aQueryFields, ;
{| x | Upper( x[ 1 ] ) == Upper( cQueryName ) } )
nRet := AScan( ::aQueryFields, ;
{| x | Upper( x[ 1 ] ) == Upper( cQueryName ) } )
IF nRet > 0
cRet := ::aQueryFields[ nRet, 2 ]
@@ -225,7 +225,7 @@ FUNCTION ParseString( cString, cDelim, nRet )
LOCAL nSize
LOCAL i
nSize := Len( cString ) - Len( Strtran( cString, cDelim, '' ) ) + 1
nSize := Len( cString ) - Len( StrTran( cString, cDelim, "" ) ) + 1
aElem := Array( nSize )
cBuf := cString
@@ -233,12 +233,12 @@ FUNCTION ParseString( cString, cDelim, nRet )
nPosFim := At( cDelim, cBuf )
IF nPosFim > 0
aElem[ i ] := Substr( cBuf, 1, nPosFim - 1 )
aElem[ i ] := SubStr( cBuf, 1, nPosFim - 1 )
ELSE
aElem[ i ] := cBuf
ENDIF
cBuf := Substr( cBuf, nPosFim + 1, Len( cBuf ) )
cBuf := SubStr( cBuf, nPosFim + 1, Len( cBuf ) )
NEXT
@@ -256,10 +256,10 @@ FUNCTION CgiParseVar( cEnvVar )
cEnvVar := HtmlDecodeURL( cEnvVar )
IF "=" $ cEnvVar .and. Len( cEnvVar ) > At( "=", cEnvVar )
cEnvVar := Alltrim( Substr( cEnvVar, At( "=", cEnvVar ) + 1 ) )
IF "=" $ cEnvVar .AND. Len( cEnvVar ) > At( "=", cEnvVar )
cEnvVar := AllTrim( SubStr( cEnvVar, At( "=", cEnvVar ) + 1 ) )
ELSE
cEnvVar := ""
ENDIF
RETURN cEnvVar
RETURN cEnvVar

22
harbour/contrib/xhb/tfile.prg
View File

@@ -68,7 +68,7 @@ CLASS TCgiFile
METHOD Open( nMode )
METHOD CLOSE() INLINE FClose( ::Handle ), ;
::Handle := - 999
::Handle := -999
METHOD RENAME( c ) INLINE FRename( ::File, c ) == 0
@@ -222,13 +222,13 @@ METHOD ReadAhead( nSize, cBuff ) CLASS TCgiFile
DEFAULT nSize TO 1024
DEFAULT cBuff TO Space( nSize )
// --> save position in file
// --> save position in file
nCurrent := FPOS( ::Handle )
// --> read ahead
// --> read ahead
::BytesRead := FRead( ::Handle, @cBuff, nSize )
// --> RETURN to saved position
// --> RETURN to saved position
FSeek( ::Handle, nCurrent )
RETURN cBuff
@@ -257,7 +257,7 @@ METHOD Readline( nSize ) CLASS TCgiFile
FSeek( ::Handle, nCr + 1, 1 )
::Buffer := SubStr( cString, 1, nCr - 1 )
::nRecord ++
::nRecord++
RETURN ::Buffer
@@ -361,7 +361,7 @@ METHOD GOTO( nLine ) CLASS TCgiFile
EXIT
ENDIF
nCount ++
nCount++
ENDDO
RETURN nPos
@@ -393,7 +393,7 @@ METHOD SKIP( nLines ) CLASS TCgiFile
ENDIF
::ReadLine()
nCount ++
nCount++
ENDDO
RETURN nPos
@@ -443,7 +443,7 @@ METHOD NextPage( nBytes ) CLASS TCgiFile
IF !::EOF()
::cPage := FReadStr( ::Handle, nBytes )
::nPage ++
::nPage++
ENDIF
RETURN ::cPage
@@ -475,18 +475,18 @@ METHOD PrevLine( nBytes ) CLASS TCgiFile
lMoved := .T.
// Check preceeding 2 chars for CR+LF
FSeek( fHandle, - 2, FS_RELATIVE )
FSeek( fHandle, -2, FS_RELATIVE )
cTemp := Space( 2 )
FRead( fHandle, @cTemp, hb_BLen( cTemp ) )
IF cTemp == CRLF()
FSeek( fHandle, - 2, FS_RELATIVE )
FSeek( fHandle, -2, FS_RELATIVE )
ENDIF
nMaxRead := Min( nBytes, FPOS( fHandle ) )
cBuff := Space( nMaxRead )
nNewPos := FSeek( fHandle, - nMaxRead, FS_RELATIVE )
nNewPos := FSeek( fHandle, -nMaxRead, FS_RELATIVE )
FRead( fHandle, @cBuff, nMaxRead )
nWhereCrLf := RAt( CRLF(), cBuff )
IF nWhereCrLf == 0

82
harbour/contrib/xhb/trpc.prg
View File

@@ -232,7 +232,7 @@ METHOD New( cFname, cSerial, nAuthLevel, oExec, oMeth ) CLASS tRPCFunction
LOCAL cParam
LOCAL aParams, aFuncDef
// Analyze the function definition
// Analyze the function definition
aFuncDef := hb_regex( "^([a-zA-Z0-9_-]+)\(([^)]*)\) *(-->)? *(.*)$", cFname )
IF Empty( aFuncDef )
Alert( "Invalid function defintion" )
@@ -244,7 +244,7 @@ METHOD New( cFname, cSerial, nAuthLevel, oExec, oMeth ) CLASS tRPCFunction
cParam := aFuncDef[3]
::cReturn := iif( Len( aFuncDef ) == 4, aFuncDef[4], aFuncDef[5] )
// analyze parameter list
// analyze parameter list
IF Len( Trim( cParam ) ) > 0
aParams := hb_ATokens( cParam, "," )
::aParameters := {}
@@ -257,17 +257,17 @@ METHOD New( cFname, cSerial, nAuthLevel, oExec, oMeth ) CLASS tRPCFunction
::aParameters := {}
ENDIF
// Analyze function definition return
// Analyze function definition return
::CheckParam( ::cReturn )
// Analyze function serial number
// Analyze function serial number
IF ! hb_regexMatch( "[0-9]{8}\..", cSerial )
Alert( "Serial value not valid" )
ErrorLevel( 1 )
QUIT
ENDIF
// analyze function authorization level
// analyze function authorization level
IF nAuthLevel < 1
Alert( "Authorization level must be at least 1" )
ErrorLevel( 1 )
@@ -277,7 +277,7 @@ METHOD New( cFname, cSerial, nAuthLevel, oExec, oMeth ) CLASS tRPCFunction
::cSerial := cSerial
::nAuthLevel := nAuthLevel
// Set now Executable object if given
// Set now Executable object if given
IF oExec != NIL
::SetCallable( oExec, oMeth )
ENDIF
@@ -286,15 +286,15 @@ METHOD New( cFname, cSerial, nAuthLevel, oExec, oMeth ) CLASS tRPCFunction
METHOD SetCallable( oExec, oMeth ) CLASS tRPCFunction
// If the callable is an object, we need to store the method
// If the callable is an object, we need to store the method
IF HB_ISOBJECT( oExec )
::aCall := Array( Len( ::aParameters ) + 3 )
::aCall[2] := oMeth
::aCall[ 2 ] := oMeth
ELSE
::aCall := Array( Len( ::aParameters ) + 2 )
ENDIF
::aCall[1] := oExec
::aCall[ 1 ] := oExec
RETURN .T.
@@ -306,11 +306,11 @@ METHOD RUN( aParams, oClient ) CLASS tRPCFunction
RETURN NIL
ENDIF
nStart := iif( HB_ISOBJECT( ::aCall[1] ), 3, 2 )
nStart := iif( HB_ISOBJECT( ::aCall[ 1 ] ), 3, 2 )
FOR nCount := 1 TO Len( aParams )
::aCall[ nStart ] := aParams[ nCount ]
nStart ++
nStart++
NEXT
::aCall[ nStart ] := oClient
@@ -440,14 +440,14 @@ METHOD New( oParent, skIn ) CLASS tRPCServeCon
::mtxBusy := hb_mutexCreate()
::bEncrypted := .F.
::nAuthLevel := 0
::nChallengeCRC := - 1
::nChallengeCRC := -1
RETURN Self
METHOD Destroy() CLASS tRPCServeCon
hb_mutexLock( ::mtxBusy )
// Eventually wait for the function to terminate
// Eventually wait for the function to terminate
IF ::thFunction != NIL
::lCanceled := .T.
hb_mutexUnlock( ::mtxBusy )
@@ -590,7 +590,7 @@ METHOD RUN() CLASS tRPCServeCon
IF nSafeStatus == RPCS_STATUS_LOGGED
aData := ::RecvFunction( .F. , .T. )
IF aData != NIL
lBreak := ! ::FuncLoopCall( aData[1], aData[2] )
lBreak := ! ::FuncLoopCall( aData[ 1 ], aData[ 2 ] )
ELSE
lBreak := .T.
ENDIF
@@ -605,7 +605,7 @@ METHOD RUN() CLASS tRPCServeCon
IF nSafeStatus == RPCS_STATUS_LOGGED
aData := ::RecvFunction( .T. , .T. )
IF aData != NIL
lBreak := ! ::FuncLoopCall( aData[1], aData[2] )
lBreak := ! ::FuncLoopCall( aData[ 1 ], aData[ 2 ] )
ELSE
lBreak := .T.
ENDIF
@@ -620,7 +620,7 @@ METHOD RUN() CLASS tRPCServeCon
IF nSafeStatus == RPCS_STATUS_LOGGED
aData := ::RecvFunction( .F. , .T. )
IF aData != NIL
lBreak := ! ::FuncForeachCall( aData[1], aData[2] )
lBreak := ! ::FuncForeachCall( aData[ 1 ], aData[ 2 ] )
ELSE
lBreak := .T.
ENDIF
@@ -635,7 +635,7 @@ METHOD RUN() CLASS tRPCServeCon
IF nSafeStatus == RPCS_STATUS_LOGGED
aData := ::RecvFunction( .T. , .T. )
IF aData != NIL
lBreak := ! ::FuncForeachCall( aData[1], aData[2] )
lBreak := ! ::FuncForeachCall( aData[ 1 ], aData[ 2 ] )
ELSE
lBreak := .T.
ENDIF
@@ -686,9 +686,9 @@ METHOD RUN() CLASS tRPCServeCon
ENDDO
// signaling termination of this thread
// signaling termination of this thread
::oServer:Terminating( Self )
// Destroy resources just before termination
// Destroy resources just before termination
::Destroy()
RETURN .T.
@@ -922,7 +922,7 @@ METHOD LaunchFunction( cFuncName, aParams, nMode, aDesc ) CLASS tRPCServeCon
LOCAL oFunc
//Check for function existance
//Check for function existance
oFunc := ::oServer:Find( cFuncName )
IF Empty( oFunc )
// signal error
@@ -931,7 +931,7 @@ METHOD LaunchFunction( cFuncName, aParams, nMode, aDesc ) CLASS tRPCServeCon
RETURN .T.
ENDIF
// check for level
// check for level
IF oFunc:nAuthLevel > ::nAuthLevel
// signal error
::oServer:OnFunctionError( Self, cFuncName, 01 )
@@ -939,7 +939,7 @@ METHOD LaunchFunction( cFuncName, aParams, nMode, aDesc ) CLASS tRPCServeCon
RETURN .T.
ENDIF
//check for parameters
//check for parameters
IF aParams == NIL .OR. ! oFunc:CheckTypes( aParams )
// signal error
::oServer:OnFunctionError( Self, cFuncName, 02 )
@@ -948,11 +948,11 @@ METHOD LaunchFunction( cFuncName, aParams, nMode, aDesc ) CLASS tRPCServeCon
ENDIF
hb_mutexLock( ::mtxBusy )
// allow progress indicator by default
// allow progress indicator by default
::lAllowProgress := .T.
// setting the cancel indicator as false
// setting the cancel indicator as false
::lCanceled := .F.
// Set the running status
// Set the running status
::nStatus := RPCS_STATUS_RUNNING
::thFunction := StartThread( Self, "FunctionRunner", ;
cFuncName, oFunc, nMode, aParams, aDesc )
@@ -978,7 +978,7 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
nSubstPos := AScan( aParams, {| x | HB_ISSTRING( x ) .AND. x == "$." } )
SWITCH aDesc[ 1 ]
CASE 'A' // all results
CASE "A" // all results
FOR nCount := aDesc[ 2 ] TO aDesc[ 3 ] STEP aDesc[ 4 ]
IF nSubstPos > 0
aSubst[ nSubstPos ] := nCount
@@ -989,7 +989,7 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
oRet := "Done"
EXIT
CASE 'C' // Vector of all results
CASE "C" // Vector of all results
aRet := {}
::lAllowProgress := .F.
FOR nCount := aDesc[ 2 ] TO aDesc[ 3 ] STEP aDesc[ 4 ]
@@ -1008,7 +1008,7 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
ENDIF
EXIT
CASE 'E' // Just send confirmation at end
CASE "E" // Just send confirmation at end
::lAllowProgress := .F.
FOR nCount := aDesc[ 2 ] TO aDesc[ 3 ] STEP aDesc[ 4 ]
IF nSubstPos > 0
@@ -1031,7 +1031,7 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
nSubstPos := AScan( aParams, {| x | HB_ISSTRING( x ) .AND. x == "$." } )
SWITCH aDesc[ 1 ]
CASE 'A' // all results
CASE "A" // all results
FOR EACH oElem IN aDesc[ 2 ]
IF nSubstPos > 0
aSubst[ nSubstPos ] := oElem
@@ -1042,7 +1042,7 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
oRet := "Done"
EXIT
CASE 'C' // Vector of all results
CASE "C" // Vector of all results
aRet := {}
::lAllowProgress := .F.
FOR EACH oElem IN aDesc[ 2 ]
@@ -1061,7 +1061,7 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
ENDIF
EXIT
CASE 'E' // Just send confirmation at end
CASE "E" // Just send confirmation at end
::lAllowProgress := .F.
FOR EACH oElem IN aDesc[ 2 ]
IF nSubstPos > 0
@@ -1076,17 +1076,17 @@ METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServe
ENDSWITCH
ENDCASE
// Now we can signal that execution terminated
// Now we can signal that execution terminated
hb_mutexLock( ::mtxBusy )
::nStatus := RPCS_STATUS_LOGGED
hb_mutexUnlock( ::mtxBusy )
// The execution of the function terminates BEFORE the sending of
// the last data or the confirmation data, even if the thread
// has still something to do.
// The execution of the function terminates BEFORE the sending of
// the last data or the confirmation data, even if the thread
// has still something to do.
::SendResult( oRet, cFuncName )
//Signal that the thread is no longer alive
// Should not be needed!
//Signal that the thread is no longer alive
// Should not be needed!
/*HB_MutexLock( ::mtxBusy )
::thFunction := -1
HB_MutexUnlock( ::mtxBusy )*/
@@ -1097,7 +1097,7 @@ METHOD SendResult( oRet, cFuncName )
LOCAL cData, cOrigLen, cCompLen
// Ignore requests to send result if function is canceled
// Ignore requests to send result if function is canceled
hb_mutexLock( ::mtxBusy )
IF ::lCanceled
hb_mutexUnlock( ::mtxBusy )
@@ -1135,7 +1135,7 @@ METHOD SendProgress( nProgress, oData ) CLASS tRPCServeCon
LOCAL cOrigLen, cCompLen, lRet := .T.
LOCAL cData
//Ignore if told so
// Ignore if told so
hb_mutexLock( ::mtxBusy )
IF ! ::lAllowProgress .OR. ::lCanceled
hb_mutexUnlock( ::mtxBusy )
@@ -1380,7 +1380,7 @@ METHOD Stop() CLASS tRPCService
ENDIF
hb_inetClose( ::skServer )
// closing the socket will make their infinite loops to terminate.
// closing the socket will make their infinite loops to terminate.
hb_threadQuitRequest( ::thAccept )
hb_threadJoin( ::thAccept )
IF hb_threadID( ::thUDP ) != 0
@@ -1397,7 +1397,7 @@ METHOD Stop() CLASS tRPCService
NEXT
ASize( ::aServing, 0 )
// now destroy all the allocated resources
// now destroy all the allocated resources
::skServer := NIL
::skUdp := NIL

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

@@ -665,7 +665,7 @@ METHOD SetPeriodCallback( ... ) CLASS tRPCClient
IF ! HB_ISARRAY( caCalling )
caCalling := Array( PCount() - 2 )
FOR nCount := 3 TO PCount()
caCalling[nCount - 2] := hb_PValue( nCount )
caCalling[ nCount - 2 ] := hb_PValue( nCount )
NEXT
ENDIF
::caPerCall := caCalling

48
harbour/contrib/xhb/ttable.prg
View File

@@ -183,37 +183,37 @@ FUNCTION NetLock( nType, lReleaseLocks, nSeconds )
WHILE lContinue == .T.
/*
IF (nKey := INKEY()) == K_ESC
RestScreen( maxrow(),0,maxrow(),maxcol()+1, cSave)
EXIT
ENDIF
*/
#if 0
IF ( nKey := Inkey() ) == K_ESC
RestScreen( MaxRow(), 0, MaxRow(), MaxCol() + 1, cSave )
EXIT
ENDIF
#endif
WHILE nSeconds > 0 .AND. lContinue == .T.
IF Eval( bOperation, xIdentifier )
nSeconds := 0
lSuccess := .T.
lContinue := .F.
s_lNetOk := .T.
s_lNetOk := .T.
EXIT
ELSE
IF nType == 1
cWord := "( " + dbInfo( 33 ) + " - Record Lock )"
cWord := "( " + dbInfo( DBI_ALIAS ) + " - Record Lock )"
ELSEIF nType == 2
cWord := "( " + dbInfo( 33 ) + " - File Lock )"
cWord := "( " + dbInfo( DBI_ALIAS ) + " - File Lock )"
ELSEIF nType == 3
cWord := "( " + dbInfo( 33 ) + " - File Append )"
cWord := "( " + dbInfo( DBI_ALIAS ) + " - File Append )"
ELSE
cWord := "( " + dbInfo( 33 ) + " - ??? "
cWord := "( " + dbInfo( DBI_ALIAS ) + " - ??? "
ENDIF
DispOutAt( MaxRow(), 0, ;
PadC( "Network Retry " + cWord + " | " + Str( nSeconds, 3 ) + " | ESC Exit", MaxCol() + 1 ), ;
s_cNetMsgColor )
nKey := Inkey( 1 ) //TONE( 1,1 )
nSeconds -- //.5
nKey := Inkey( 1 ) // Tone( 1, 1 )
nSeconds-- // .5
IF nKey == K_ESC
RestScreen( MaxRow(), 0, MaxRow(), MaxCol() + 1, cSave )
EXIT
@@ -283,7 +283,7 @@ FUNCTION NetOpenFiles( aFiles )
FOR EACH xFile IN aFiles
IF !hb_FileExists( xFile[ 1 ] )
nRet := - 1
nRet := -1
EXIT
ENDIF
@@ -293,13 +293,13 @@ FUNCTION NetOpenFiles( aFiles )
IF hb_FileExists( cIndex )
ordListAdd( cIndex )
ELSE
nRet := - 3
nRet := -3
EXIT
ENDIF
NEXT
ENDIF
ELSE
nRet := - 2
nRet := -2
EXIT
ENDIF
NEXT
@@ -458,7 +458,7 @@ FUNCTION TableNew( cDBF, cALIAS, cOrderBag, cDRIVER, ;
DEFAULT lNEW TO .T.
DEFAULT lREADONLY TO .F.
DEFAULT cDRIVER TO "DBFCDX"
DEFAULT cPATH TO SET( _SET_DEFAULT )
DEFAULT cPATH TO Set( _SET_DEFAULT )
DEFAULT cAlias TO FixExt( cDbf )
DEFAULT cOrderBag TO FixExt( cDbf ) //+".CDX"
@@ -479,7 +479,7 @@ FUNCTION TableNew( cDBF, cALIAS, cOrderBag, cDRIVER, ;
ENDIF
SET( _SET_AUTOPEN, lAuto )
Set( _SET_AUTOPEN, lAuto )
RETURN oDB
@@ -792,7 +792,7 @@ METHOD New( cDBF, cALIAS, cOrderBag, cDRIVER, ;
DEFAULT lNEW TO .T.
DEFAULT lREADONLY TO .F.
DEFAULT cDRIVER TO "DBFCDX"
DEFAULT cPATH TO SET( _SET_DEFAULT )
DEFAULT cPATH TO Set( _SET_DEFAULT )
DEFAULT cAlias TO FixExt( cDbf )
DEFAULT cOrderBag TO FixExt( cDbf ) //+".CDX"
@@ -858,7 +858,7 @@ METHOD PROCEDURE DBMove( nDirection ) CLASS HBTable
( ::Alias )->( dbGoBottom() )
CASE nDirection == _DB_BOF
( ::Alias )->( dbGoTop() )
( ::Alias )->( dbSkip( - 1 ) )
( ::Alias )->( dbSkip( -1 ) )
CASE nDirection == _DB_EOF
( ::Alias )->( dbGoBottom() )
( ::Alias )->( dbSkip( 1 ) )
@@ -1098,7 +1098,7 @@ METHOD __oTDelete( lKeepBuffer ) // ::Delete()
( ::Alias )->( dbUnlock() )
ENDIF
SET( _SET_DELETED, lDeleted )
Set( _SET_DELETED, lDeleted )
RETURN lRet
@@ -1134,7 +1134,7 @@ METHOD Undo( nBuffer, nLevel ) CLASS HBTable
IF !Empty( ::DeleteBuffers )
SET( _SET_DELETED, .F. ) // make deleted records visible temporarily...
Set( _SET_DELETED, .F. ) // make deleted records visible temporarily...
nLen := Len( ::deleteBuffers )
@@ -1178,7 +1178,7 @@ METHOD Undo( nBuffer, nLevel ) CLASS HBTable
ENDIF
SET( _SET_DELETED, lDelState )
Set( _SET_DELETED, lDelState )
ENDIF
EXIT
@@ -1474,7 +1474,7 @@ METHOD OnError( uParam ) CLASS HBTable
oErr:GenCode := EG_NOVARMETHOD
oErr:Operation := "HBTable:" + cMsg
oErr:Severity := ES_ERROR
oErr:SubCode := - 1
oErr:SubCode := -1
oErr:SubSystem := "HBTable"
uRet := Eval( ErrorBlock(), oErr )

127
harbour/contrib/xhb/txml.prg
View File

@@ -53,10 +53,12 @@
*/
#include "common.ch"
#include "fileio.ch"
#include "hbxml.ch"
#include "hbclass.ch"
CLASS TXMLNode
DATA nType
DATA cName
DATA aAttributes
@@ -89,12 +91,14 @@ CLASS TXMLNode
METHOD ToString( nStyle ) INLINE HBXml_node_to_string( Self, nStyle )
METHOD Write( fHandle, nStyle ) INLINE HBXml_node_write( Self, fHandle, nStyle )
//Useful for debugging purposes
// Useful for debugging purposes
METHOD ToArray() INLINE;
{ ::nType, ::cName, ::aAttributes, ::cData }
{ ::nType, ::cName, ::aAttributes, ::cData }
ENDCLASS
METHOD New( nType, cName, aAttributes, cData ) class TXmlNode
METHOD New( nType, cName, aAttributes, cData ) CLASS TXmlNode
IF nType == NIL
::nType := HBXML_TYPE_TAG
ELSE
@@ -102,17 +106,18 @@ METHOD New( nType, cName, aAttributes, cData ) class TXmlNode
ENDIF
IF aAttributes == NIL
::aAttributes := {=>}
::aAttributes := { => }
ELSE
::aAttributes := aAttributes
ENDIF
::cName := cName
::cData := cData
RETURN Self
RETURN Self
METHOD NextInTree() CLASS TXmlNode
LOCAL oNext := NIL, oTemp
IF ::oChild != NIL
@@ -130,17 +135,18 @@ METHOD NextInTree() CLASS TXmlNode
ENDDO
ENDIF
RETURN oNext
RETURN oNext
METHOD Depth() CLASS TXmlNode
IF ::oParent != NIL
RETURN ::oParent:Depth() + 1
ENDIF
RETURN 0
RETURN 0
METHOD Path() CLASS TXmlNode
IF ::nType == HBXML_TYPE_DOCUMENT
RETURN ""
ENDIF
@@ -154,12 +160,15 @@ METHOD Path() CLASS TXmlNode
RETURN "/" + ::cName
ENDIF
ENDIF
RETURN NIL
RETURN NIL
/********************************************
Iterator class
*********************************************/
CLASS TXmlIterator
METHOD New( oNodeTop ) CONSTRUCTOR
METHOD Next()
METHOD Rewind() INLINE ::oNode := ::oTop
@@ -169,7 +178,7 @@ CLASS TXmlIterator
METHOD SetContext()
METHOD Clone()
PROTECTED:
PROTECTED:
METHOD MatchCriteria( oNode )
DATA cName
@@ -177,7 +186,7 @@ PROTECTED:
DATA cValue
DATA cData
HIDDEN:
HIDDEN:
DATA nTopLevel
DATA oNode
@@ -185,15 +194,16 @@ HIDDEN:
ENDCLASS
METHOD New( oNodeTop ) CLASS TXmlIterator
::oTop := oNodeTop
::oNode := oNodeTop
::nTopLevel := oNodeTop:Depth()
RETURN Self
RETURN Self
METHOD Clone() CLASS TXmlIterator
LOCAL oRet
oRet := TXmlIterator():New( ::oNodeTop )
@@ -201,13 +211,17 @@ METHOD Clone() CLASS TXmlIterator
oRet:cAttribute := ::cAttribute
oRet:cValue := ::cValue
oRet:cData := ::cData
RETURN oRet
RETURN oRet
METHOD SetContext() CLASS TXmlIterator
::oTop := ::oNode
RETURN Self
RETURN Self
METHOD Find( cName, cAttribute, cValue, cData ) CLASS TXmlIterator
::cName := cName
::cAttribute := cAttribute
::cValue := cValue
@@ -224,10 +238,10 @@ METHOD Find( cName, cAttribute, cValue, cData ) CLASS TXmlIterator
RETURN ::oNode
ENDIF
RETURN ::Next()
RETURN ::Next()
METHOD Next() CLASS TXmlIterator
LOCAL oFound := ::oNode:NextInTree()
DO WHILE oFound != NIL
@@ -243,11 +257,13 @@ METHOD Next() CLASS TXmlIterator
oFound := oFound:NextInTree()
ENDDO
RETURN NIL
RETURN NIL
METHOD MatchCriteria( oNode ) CLASS TXmlIterator
HB_SYMBOL_UNUSED( oNode )
RETURN .T.
RETURN .T.
/********************************************
@@ -255,74 +271,81 @@ RETURN .T.
*********************************************/
CLASS TXmlIteratorScan FROM TXmlIterator
METHOD New( oNodeTop ) CONSTRUCTOR
PROTECTED:
PROTECTED:
METHOD MatchCriteria( oFound )
ENDCLASS
METHOD New( oNodeTop ) CLASS TXmlIteratorScan
::Super:New( oNodeTop )
RETURN Self
RETURN Self
METHOD MatchCriteria( oFound ) CLASS TXmlIteratorScan
IF ::cName != NIL .and. ( oFound:cName == NIL .or. !( ::cName == oFound:cName ) )
IF ::cName != NIL .AND. ( oFound:cName == NIL .OR. !( ::cName == oFound:cName ) )
RETURN .F.
ENDIF
IF ::cAttribute != NIL .and. ! ::cAttribute $ oFound:aAttributes
IF ::cAttribute != NIL .AND. ! ::cAttribute $ oFound:aAttributes
RETURN .F.
ENDIF
IF ::cValue != NIL .and. ;
hb_HScan( oFound:aAttributes, {| xKey, cValue | HB_SYMBOL_UNUSED( xKey ), ::cValue == cValue } ) == 0
IF ::cValue != NIL .AND. ;
hb_HScan( oFound:aAttributes, {| xKey, cValue | HB_SYMBOL_UNUSED( xKey ), ::cValue == cValue } ) == 0
RETURN .F.
ENDIF
IF ::cData != NIL .and. ( oFound:cData == NIL .or. !( ::cData == oFound:cData ) )
IF ::cData != NIL .AND. ( oFound:cData == NIL .OR. !( ::cData == oFound:cData ) )
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
/********************************************
Iterator regex class
*********************************************/
CLASS TXmlIteratorRegex FROM TXmlIterator
METHOD New( oNodeTop ) CONSTRUCTOR
PROTECTED:
PROTECTED:
METHOD MatchCriteria( oFound )
ENDCLASS
METHOD New( oNodeTop ) CLASS TXmlIteratorRegex
::Super:New( oNodeTop )
RETURN Self
RETURN Self
METHOD MatchCriteria( oFound ) CLASS TXmlIteratorRegex
IF ::cName != NIL .and. ;
( oFound:cName == NIL .or. ! HB_REGEXLIKE( ::cName, oFound:cName, .T. ) )
IF ::cName != NIL .AND. ;
( oFound:cName == NIL .OR. ! hb_regexLike( ::cName, oFound:cName, .T. ) )
RETURN .F.
ENDIF
IF ::cAttribute != NIL .and. ;
hb_hScan( oFound:aAttributes, {| cKey | HB_REGEXLIKE( ::cAttribute, cKey, .T. ) } ) == 0
IF ::cAttribute != NIL .AND. ;
hb_HScan( oFound:aAttributes, {| cKey | hb_regexLike( ::cAttribute, cKey, .T. ) } ) == 0
RETURN .F.
ENDIF
IF ::cValue != NIL .and. ;
hb_hScan( oFound:aAttributes, {| xKey, cValue | HB_SYMBOL_UNUSED( xKey ), HB_REGEXLIKE( ::cValue, cValue, .T. ) } ) == 0
IF ::cValue != NIL .AND. ;
hb_HScan( oFound:aAttributes, {| xKey, cValue | HB_SYMBOL_UNUSED( xKey ), hb_regexLike( ::cValue, cValue, .T. ) } ) == 0
RETURN .F.
ENDIF
IF ::cData != NIL .and. ;
( oFound:cData == NIL .or. ! HB_REGEXHAS( ::cData, oFound:cData, .F. ) )
IF ::cData != NIL .AND. ;
( oFound:cData == NIL .OR. ! hb_regexHas( ::cData, oFound:cData, .F. ) )
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
/********************************************
@@ -330,6 +353,7 @@ RETURN .T.
*********************************************/
CLASS TXmlDocument
DATA oRoot
DATA nStatus
DATA nError
@@ -347,13 +371,16 @@ CLASS TXmlDocument
METHOD FindNext() INLINE ::oIterator:Next()
METHOD GetContext()
HIDDEN:
HIDDEN:
DATA oIterator
DATA cHeader
ENDCLASS
METHOD New( xElem, nStyle ) CLASS TXmlDocument
::nStatus := HBXML_STATUS_OK
::nError := HBXML_ERROR_NONE
::nLine := 1
@@ -370,7 +397,7 @@ METHOD New( xElem, nStyle ) CLASS TXmlDocument
CASE "N"
CASE "C"
::oRoot := TXmlNode():New( HBXML_TYPE_DOCUMENT )
IF hb_fileExists( xElem )
IF hb_FileExists( xElem )
::Read( hb_MemoRead( xElem ), nStyle )
ELSE
::Read( xElem, nStyle )
@@ -383,7 +410,7 @@ METHOD New( xElem, nStyle ) CLASS TXmlDocument
ENDSWITCH
ENDIF
RETURN Self
RETURN Self
METHOD Write( fHandle, nStyle ) CLASS TXmlDocument
@@ -391,7 +418,7 @@ METHOD Write( fHandle, nStyle ) CLASS TXmlDocument
IF ValType( fHandle ) == "C" // It's a filename!
fHandle := FCreate( fHandle )
IF fHandle != -1
IF fHandle != F_ERROR
IF Empty( ::oRoot:oChild ) .OR. !( ::oRoot:oChild:cName == "xml" )
IF Empty( ::cHeader )
FWrite( fHandle, '<?xml version="1.0"?>' + hb_eol() )
@@ -405,21 +432,25 @@ METHOD Write( fHandle, nStyle ) CLASS TXmlDocument
RETURN nResult
ENDIF
RETURN ::oRoot:Write( fHandle, nStyle )
RETURN ::oRoot:Write( fHandle, nStyle )
METHOD FindFirst( cName, cAttrib, cValue, cData ) CLASS TXmlDocument
::oIterator := TXmlIteratorScan():New( ::oRoot )
RETURN ::oIterator:Find( cName, cAttrib, cValue, cData )
RETURN ::oIterator:Find( cName, cAttrib, cValue, cData )
METHOD FindFirstRegex( cName, cAttrib, cValue, cData ) CLASS TXmlDocument
::oIterator := TXmlIteratorRegex():New( ::oRoot )
RETURN ::oIterator:Find( cName, cAttrib, cValue, cData )
::oIterator := TXmlIteratorRegex():New( ::oRoot )
RETURN ::oIterator:Find( cName, cAttrib, cValue, cData )
METHOD GetContext() CLASS TXmlDocument
LOCAL oDoc
oDoc := TXmlDocument():New()
oDoc:oRoot := ::oIterator:GetNode()
RETURN oDoc
RETURN oDoc

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

@@ -63,6 +63,7 @@
#xtranslate THROW( <oErr> ) => ( Eval( ErrorBlock(), <oErr> ), Break( <oErr> ) )
//
FUNCTION CStrToVal( cExp, cType )
IF ! HB_ISSTRING( cExp )
@@ -70,36 +71,36 @@ FUNCTION CStrToVal( cExp, cType )
ENDIF
SWITCH cType
CASE 'C'
CASE "C"
RETURN cExp
CASE 'P'
CASE "P"
RETURN hb_HexToNum( cExp )
CASE 'D'
IF cExp[3] >= '0' .AND. cExp[3] <= '9' .AND. cExp[5] >= '0' .AND. cExp[5] <= '9'
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 )
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'
CASE "N"
RETURN Val( cExp )
CASE 'U'
CASE "U"
RETURN NIL
/*
CASE 'A'
CASE "A"
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'B'
CASE "B"
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'O'
CASE "O"
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
*/
@@ -110,16 +111,17 @@ FUNCTION CStrToVal( cExp, cType )
RETURN NIL
//
FUNCTION StringToLiteral( cString )
LOCAL lDouble := .F., lSingle := .F.
LOCAL lDouble := .F. , lSingle := .F.
IF hb_regexHas( "\n|\r", cString ) .OR. ;
( ( lDouble := '"' $ cString ) .AND. ( lSingle := "'" $ cString ) .AND. hb_regexHas( "\[|\]", cString ) )
( ( lDouble := '"' $ cString ) .AND. ( lSingle := "'" $ cString ) .AND. hb_regexHas( "\[|\]", cString ) )
cString := StrTran( cString, '"', '\"' )
cString := StrTran( cString, Chr(10), '\n' )
cString := StrTran( cString, Chr(13), '\r' )
cString := StrTran( cString, Chr( 10 ), "\n" )
cString := StrTran( cString, Chr( 13 ), "\r" )
//TraceLog( cString )
@@ -133,40 +135,41 @@ FUNCTION StringToLiteral( cString )
RETURN "[" + cString + "]"
//
FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
LOCAL aVar, cRet, cPad, nObj
//TraceLog( xVal, cName, nPad, aObjs )
// TraceLog( xVal, cName, nPad, aObjs )
SWITCH ValType( xVal )
CASE 'C'
CASE "C"
RETURN StringToLiteral( xVal )
CASE 'D'
RETURN "hb_SToD( '" + dToS( xVal ) + "' )"
CASE "D"
RETURN "hb_SToD( '" + DToS( xVal ) + "' )"
CASE 'L'
CASE "L"
RETURN iif( xVal, ".T.", ".F." )
CASE 'N'
RETURN hb_nToS( xVal )
CASE "N"
RETURN hb_ntos( xVal )
CASE 'A'
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 */"
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 } )
AAdd( aObjs, { xVal, cName } )
cRet += "Array(" + hb_ntos( Len( xVal ) ) + ")" + CRLF
@@ -177,11 +180,11 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
cRet += cPad + cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "] := " + ValToPrg( aVar, cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "]", nPad, aObjs ) + CRLF
NEXT
nPad -=3
nPad -= 3
RETURN cRet
CASE 'H'
CASE "H"
IF Empty( xVal )
cRet := "hb_Hash()"
ELSE
@@ -199,16 +202,16 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
RETURN cRet
/* There is no support for codeblock serialization */
/* There is no support for codeblock serialization */
#if 0
CASE 'B'
CASE "B"
RETURN ValToPrgExp( xVal )
#endif
CASE 'P'
CASE "P"
RETURN "0x" + hb_NumToHex( xVal )
CASE 'O'
CASE "O"
/* TODO: Use HBPersistent() when avialable! */
IF cName == NIL
cName := "M->__ValToPrg_Object"
@@ -216,14 +219,14 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {| a | HB_ArrayID( a[ 1 ] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][ 2 ] + " /* Cyclic */"
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 } )
AAdd( aObjs, { xVal, cName } )
cRet += xVal:ClassName + "():New()" + CRLF
@@ -231,10 +234,10 @@ 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
cRet += cPad + cName + ":" + aVar[ 1 ] + " := " + ValToPrg( aVar[ 2 ], cName + ":" + aVar[ 1 ], nPad, aObjs ) + CRLF
NEXT
nPad -=3
nPad -= 3
RETURN cRet
OTHERWISE
@@ -246,15 +249,18 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
ENDIF
ENDSWITCH
//TraceLog( cRet )
// TraceLog( cRet )
RETURN cRet
//
FUNCTION PrgExpToVal( cExp )
RETURN &( cExp )
RETURN &( cExp )
//
FUNCTION ValToArray( xVal )
IF HB_ISARRAY( xVal )
@@ -264,6 +270,7 @@ FUNCTION ValToArray( xVal )
RETURN { xVal }
//
FUNCTION ValToBlock( xVal )
IF HB_ISBLOCK( xVal )
@@ -273,6 +280,7 @@ FUNCTION ValToBlock( xVal )
RETURN {|| xVal }
//
FUNCTION ValToCharacter( xVal )
IF HB_ISSTRING( xVal )
@@ -281,36 +289,36 @@ FUNCTION ValToCharacter( xVal )
RETURN LTrim( CStr( xVal ) )
//
FUNCTION ValToDate( xVal )
SWITCH ValType( xVal )
CASE 'A'
CASE 'H'
CASE 'L'
CASE 'O'
CASE 'U'
CASE "A"
CASE "H"
CASE "L"
CASE "O"
CASE "U"
EXIT
CASE 'B'
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'
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 )
RETURN CToD( xVal )
ENDIF
CASE 'D'
CASE "D"
RETURN xVal
CASE 'N'
CASE 'P'
CASE "N"
CASE "P"
RETURN 0d19000101 + xVal
OTHERWISE
@@ -320,6 +328,7 @@ FUNCTION ValToDate( xVal )
RETURN hb_SToD()
//
FUNCTION ValToHash( xVal )
IF HB_ISHASH( xVal )
@@ -329,22 +338,23 @@ FUNCTION ValToHash( 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'
CASE "B"
RETURN ValToLogical( Eval( xVal ) )
CASE 'C'
IF Left( xVal, 1 ) == '.' .AND. SubStr( xVal, 3, 1 ) == '.' .AND. Upper( SubStr( xVal, 2, 1 ) ) $ "TFYN"
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"
@@ -353,10 +363,10 @@ FUNCTION ValToLogical( xVal )
ENDIF
EXIT
CASE 'L'
CASE "L"
RETURN xVal
CASE 'U'
CASE "U"
RETURN .F.
OTHERWISE
@@ -366,35 +376,36 @@ FUNCTION ValToLogical( xVal )
RETURN .F.
//
FUNCTION ValToNumber( xVal )
SWITCH ValType( xVal )
CASE 'A'
CASE 'H'
CASE "A"
CASE "H"
RETURN Len( xVal )
CASE 'B'
CASE "B"
RETURN ValToNumber( Eval( xVal ) )
CASE 'C'
CASE "C"
RETURN Val( xVal )
CASE 'D'
CASE "D"
RETURN xVal - 0d19000101
CASE 'L'
CASE "L"
RETURN iif( xVal, 1, 0 )
CASE 'O'
CASE "O"
RETURN xVal:hClass
CASE 'N'
CASE "N"
RETURN xVal
CASE 'P'
CASE "P"
RETURN xVal - 0
CASE 'U'
CASE "U"
RETURN 0
OTHERWISE
@@ -404,45 +415,46 @@ FUNCTION ValToNumber( xVal )
RETURN 0
//
FUNCTION ValToObject( xVal )
SWITCH ValType( xVal )
CASE 'A'
CASE "A"
ENABLE TYPE CLASS ARRAY
EXIT
CASE 'B'
CASE "B"
ENABLE TYPE CLASS BLOCK
EXIT
CASE 'C'
CASE "C"
ENABLE TYPE CLASS CHARACTER
EXIT
CASE 'D'
CASE "D"
ENABLE TYPE CLASS DATE
EXIT
CASE 'H'
CASE "H"
ENABLE TYPE CLASS HASH
EXIT
CASE 'L'
CASE "L"
ENABLE TYPE CLASS LOGICAL
EXIT
CASE 'N'
CASE "N"
ENABLE TYPE CLASS NUMERIC
EXIT
CASE 'O'
CASE "O"
RETURN xVal
CASE 'P'
CASE "P"
ENABLE TYPE CLASS POINTER
EXIT
CASE 'U'
CASE "U"
ENABLE TYPE CLASS NIL
EXIT
@@ -453,37 +465,38 @@ FUNCTION ValToObject( xVal )
RETURN 0
//
FUNCTION ValToType( xVal, cType )
SWITCH cType
CASE 'A'
CASE "A"
RETURN ValToArray( xVal )
CASE 'B'
CASE "B"
RETURN ValToBlock( xVal )
CASE 'C'
CASE "C"
RETURN ValToCharacter( xVal )
CASE 'D'
CASE "D"
RETURN ValToDate( xVal )
CASE 'H'
CASE "H"
RETURN ValToHash( xVal )
CASE 'L'
CASE "L"
RETURN ValToLogical( xVal )
CASE 'N'
CASE "N"
RETURN ValToNumber( xVal )
CASE 'O'
CASE "O"
RETURN ValToObject( xVal )
CASE 'P'
CASE "P"
RETURN ValToNumber( xVal )
CASE 'U'
CASE "U"
RETURN NIL
OTHERWISE

6
harbour/contrib/xhb/xdbmodst.prg
View File

@@ -123,13 +123,13 @@ FUNCTION dbModifyStructure( cFile )
// Rename original as backup, and new file as the new original.
// -----------------------
IF lRet
IF FRename( cFile, cBakFile ) == - 1
IF FRename( cFile, cBakFile ) == -1
BREAK
ENDIF
IF FRename( cNewFile, cFile ) == - 1
IF FRename( cNewFile, cFile ) == -1
// If we can't then try to restore backup as original
IF FRename( cBakFile, cFile ) == - 1
IF FRename( cBakFile, cFile ) == -1
// Oops - must advise the user!
oErr := ErrorNew()
oErr:severity := ES_ERROR

6
harbour/contrib/xhb/xhberr.prg
View File

@@ -306,7 +306,7 @@ STATIC FUNCTION LogError( oerr )
LOCAL nHandle
LOCAL nBytes
LOCAL nHandle2 := - 1
LOCAL nHandle2 := F_ERROR
LOCAL cLogFile2 := "_error.log"
LOCAL cBuff := ""
LOCAL nRead
@@ -537,7 +537,7 @@ STATIC FUNCTION LogError( oerr )
FWriteLine( nHandle, PadR( ProcName(), 21 ) + " : " + Transform( ProcLine(), "999,999" ) + " in Module: " + ProcFile() )
nCount := 3
WHILE !Empty( ProcName( ++ nCount ) )
WHILE ! Empty( ProcName( ++nCount ) )
FWriteLine( nHandle, PadR( ProcName( nCount ), 21 ) + " : " + Transform( ProcLine( nCount ), "999,999" ) + " in Module: " + ProcFile( nCount ) )
ENDDO
@@ -609,7 +609,7 @@ STATIC FUNCTION LogError( oerr )
FErase( "errormem.mem" )
#endif
IF lAppendLog .AND. nHandle2 != - 1
IF lAppendLog .AND. nHandle2 != F_ERROR
nBytes := FSeek( nHandle2, 0, FS_END )

99
harbour/contrib/xhb/xhbtedit.prg
View File

@@ -578,9 +578,9 @@ METHOD RefreshColumn() CLASS XHBEditor
// 2006/AUG/02 - E.F.
// Don't replace ::GetLine(nRow) by ::aText[nRow]:cText here
// because getline return line number in tbrwtext.prg (debug).
for i := 0 TO Min( ::nNumRows - 1, ::LastRow() - 1 )
FOR i := 0 TO Min( ::nNumRows - 1, ::LastRow() - 1 )
DispOutAt( ::nTop + i, nOCol, SubStr( ::GetLine(::nFirstRow + i ), ::nCol, 1 ), ::LineColor( ::nFirstRow + i ) )
next
NEXT
DispEnd()
@@ -1024,10 +1024,10 @@ METHOD Down() CLASS XHBEditor
ENDIF
ELSE
IF ::nFirstRow < ::LastRow() .AND. ::LastRow() > ::nNumRows
::nFirstRow ++
::nRow ++
::nFirstRow++
::nRow++
IF ::nRow > ::LastRow()
::nRow --
::nRow--
ENDIF
::RefreshWindow()
ELSEIF ::nRow < ::LastRow()
@@ -1101,8 +1101,8 @@ METHOD Up() CLASS XHBEditor
ENDIF
ELSE
IF ::nFirstRow > 1
::nFirstRow --
::nRow --
::nFirstRow--
::nRow--
IF ::nRow < 1
::nRow := 1
ENDIF
@@ -1297,7 +1297,7 @@ METHOD Left() CLASS XHBEditor
IF ::nRow > 1
// 2006/07/19 E.F. left should be at max in the leftmost column.
//
::GotoPos( ::nRow - 1, Max( ::nNumCols,::nWordWrapCol + 1 ) , .T. )
::GotoPos( ::nRow - 1, Max( ::nNumCols, ::nWordWrapCol + 1 ) , .T. )
ENDIF
//else do nothing
ENDIF
@@ -1483,7 +1483,7 @@ METHOD K_Bs() CLASS XHBEditor
//
::nCol := Min( ::LineLen( ::nRow - 1 ) + 1, ::nWordWrapCol )
::nRow --
::nRow--
// inherit sibling line's soft CR setting.
::aText[ ::nRow ]:lSoftCR := ::aText[ ::nRow + 1 ]:lSoftCR
@@ -1557,7 +1557,7 @@ METHOD K_Del() CLASS XHBEditor
// eventually pad.
//
//IF ::nCol > ::LineLen( ::nRow ) + 1
// ::aText[ ::nRow ]:cText := Padr( ::aText[ ::nRow ]:cText, ::nCol - 1)
// ::aText[ ::nRow ]:cText := Padr( ::aText[ ::nRow ]:cText, ::nCol - 1 )
//ENDIF
lMerge := .T.
@@ -1632,14 +1632,14 @@ METHOD K_Tab() CLASS XHBEditor
::lChanged := .T.
::lRightScroll := .F. //prevent auto linewrap
for i := 1 to ::nTabWidth
FOR i := 1 to ::nTabWidth
IF ::nCol < ::nWordWrapCol - ::nTabWidth - ::nTabWidth
::Right()
::RefreshLine()
ELSE
i := ::nTabWidth // end of line, stop it!
ENDIF
next
NEXT
::lRightScroll := .T.
// wrap lines
IF ::LineLen( ::nRow ) > ::nWordWrapCol
@@ -1677,26 +1677,27 @@ METHOD K_Return() CLASS XHBEditor
IF ::lEditAllow
// 2006/JUL/24 - E.F. - Fixed <Enter> at insert mode.
/*
* IF ::lInsert
* IF ::nRow == ::LastRow()
* IF ::nCol > ::LineLen( ::nRow )
* ::AddLine( "", .F. )
* else
* ::InsertLine( Substr( ::aText[ ::nRow ]:cText, ::nCol ), .F., ::nRow + 1 )
* ENDIF
* ELSEIF ::aText[ ::nRow ]:lSoftCR
* ::aText[ ::nRow + 1 ]:cText := Substr( ::aText[ ::nRow ]:cText, ::nCol ) +" "+ ::aText[ ::nRow + 1 ]:cText
* ::SplitLine( ::nRow + 1 )
* ELSE
* ::InsertLine( Substr( ::aText[ ::nRow ]:cText, ::nCol ), .F., ::nRow + 1 )
* ENDIF
* ::aText[ ::nRow ]:cText := Left( ::aText[ ::nRow ]:cText, ::nCol - 1 )
*
* ELSEIF ::nRow == ::LastRow()
* ::AddLine( "", .F. )
* ENDIF
*/
#if 0
IF ::lInsert
IF ::nRow == ::LastRow()
IF ::nCol > ::LineLen( ::nRow )
::AddLine( "", .F. )
else
::InsertLine( Substr( ::aText[ ::nRow ]:cText, ::nCol ), .F., ::nRow + 1 )
ENDIF
ELSEIF ::aText[ ::nRow ]:lSoftCR
::aText[ ::nRow + 1 ]:cText := Substr( ::aText[ ::nRow ]:cText, ::nCol ) + " " + ::aText[ ::nRow + 1 ]:cText
::SplitLine( ::nRow + 1 )
ELSE
::InsertLine( Substr( ::aText[ ::nRow ]:cText, ::nCol ), .F., ::nRow + 1 )
ENDIF
::aText[ ::nRow ]:cText := Left( ::aText[ ::nRow ]:cText, ::nCol - 1 )
ELSEIF ::nRow == ::LastRow()
::AddLine( "", .F. )
ENDIF
#endif
IF ::lInsert
IF ::LastRow() == 0
@@ -1885,7 +1886,7 @@ METHOD DelWordRight() CLASS XHBEditor
DO WHILE nCutCol <= 1 .AND. nCol < ::LineLen( ::nRow ) - 1
nCutCol := At( " ", SubStr( ::aText[ ::nRow ]:cText, nCol ) )
IF nCutCol <= 1 .AND. nCol < ::LineLen( ::nRow ) - 1
nCol ++
nCol++
ELSEIF nCutCol <= 1 .AND. nCol >= ::LineLen( ::nRow )
nCutCol := Len( SubStr( ::aText[::nRow]:cText, ::nCol, nCol - ::nCol ) )
EXIT
@@ -2162,7 +2163,7 @@ METHOD SplitLine( nRow ) CLASS XHBEditor
// Split line at fist space before current position
//
DO WHILE nFirstSpace > 1 .AND. !( cLine[nFirstSpace] == " " )
nFirstSpace --
nFirstSpace--
ENDDO
// If there is a space before beginning of line split there
@@ -2198,7 +2199,7 @@ METHOD SplitLine( nRow ) CLASS XHBEditor
ENDIF
// We must not trim the line as split occurs next to a space
//
::InsertLine( cSplittedLine, .T. , nStartRow ++ )
::InsertLine( cSplittedLine, .T. , nStartRow++ )
cLine := SubStr( cLine, Len( cSplittedLine ) + 1 )
ENDDO
@@ -2228,12 +2229,12 @@ METHOD SplitLine( nRow ) CLASS XHBEditor
// next line?
IF nCurSpace == 0
nRow ++
nRow++
//fake border new.
::nFirstCol := 1
::GotoPos( nRow, nPosInWord, .T. )
ELSEIF nCurSpace == ::nCol
nRow ++
nRow++
::GotoPos( nRow, 1, .T. )
ELSE
::RefreshWindow()
@@ -2332,7 +2333,7 @@ METHOD InsertState( lInsState ) CLASS XHBEditor
::lInsert := lInsState
// Redundant, but useful if ::lInsert is used as class DATA
SET( _SET_INSERT, lInsState )
Set( _SET_INSERT, lInsState )
IF lInsState
SetCursor( SC_INSERT )
@@ -2354,7 +2355,7 @@ METHOD DisplayInsert( lInsert ) CLASS XHBEditor
LOCAL nCurRow, nCurCol, nCursor
IF SET( _SET_SCOREBOARD )
IF Set( _SET_SCOREBOARD )
nCurCol := Col()
nCurRow := Row()
@@ -2765,9 +2766,9 @@ METHOD DelTextSelection() CLASS XHBEditor
::lChanged := .T.
for nI := nRowSelStart TO nRowSelEnd
FOR nI := nRowSelStart TO nRowSelEnd
::RemoveLine( nRowSelStart )
next
NEXT
::nRow := nRowSelStart
@@ -2833,21 +2834,21 @@ METHOD AddText( cString, lAtPos ) CLASS XHBEditor
DEFAULT lAtPos TO .F.
IF !lAtPos .OR. ( nAtRow > ::LastRow() )
for i := 1 TO nLines
IF ! lAtPos .OR. nAtRow > ::LastRow()
FOR i := 1 TO nLines
AAdd( ::aText, aTmpText[ i ] )
next
NEXT
ELSE
nAtRow --
for i := 1 TO nLines
nAtRow--
FOR i := 1 TO nLines
hb_AIns( ::aText, nAtRow + i, aTmpText[ i ], .T. )
next
NEXT
IF nLines > 0
// ::RemoveLine(nAtRow+nLines)
// ::RemoveLine( nAtRow + nLines )
ENDIF
ENDIF
IF !lSaveIns
IF ! lSaveIns
::InsertState( .F. )
ENDIF