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

2009-06-13 13:49 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)

Browse Source 
* source/rtl/achoice.prg
    ! Partially reverted this commit:
      https://sourceforge.net/apps/trac/harbour-project/changeset/10605
      After this change, activating DBU menus with all items disabled
      (f.e. F7/F8) caused app hang.
      This line:
         nUserFunc := iif( nMode != AC_NOITEM,;
            Do( xUserFunc, nMode, nPos, nPos - nAtTop ), NIL )
      Was now changed back to this:
         nUserFunc := Do( xUserFunc, nMode, nPos, nPos - nAtTop )
      ac_test2.prg still seem to function fine after this, but
      I'd kindly like to ask Vladislav Lavrecky to make tests
      again, maybe we need another fix here.

  * source/vm/evalhb.c
    * Minor formatting.

  * contrib/hbtip/client.prg
    * Minor formatting.
    ! :ReadToFile() nMode param check.

  * utils/hbmk2/hbmk2.prg
    * Cleanup to variable name prefixes.

  * contrib/xhb/Makefile
  + contrib/xhb/xthrow.prg
    + Added THROW() function for xhb compatibility.
      This is written in Harbour, based on hbcompat.ch
      and has Harbour license + exception.

  + contrib/xhb/xcstr.prg
  + contrib/xhb/xdbmodst.prg
  * contrib/xhb/Makefile
    + Ported following old functions from xhb:
      CSTRTOVAL(), STRINGTOLITERAL(), VALTOPRG(), PRGEXPTOVAL()
    + Ported following new functions from xhb:
      VALTOARRAY(), VALTODATE(), VALTOHASH(), VALTOLOGICAL()
      VALTONUMBER(), VALTOARRAY(), VALTOTYPE(),
      DBMODIFYSTRUCTURE(), DBIMPORT(), DBMERGE()
      (borrowed from xhb, work of Ron Pinkas)
This commit is contained in:
Viktor Szakats
2009-06-13 11:56:32 +00:00
parent b491ab27bb
commit 3219e88ed7
9 changed files with 1399 additions and 524 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
harbour/ChangeLog
View File

@@ -17,6 +17,48 @@
past entries belonging to author(s): Viktor Szakats.
*/
2009-06-13 13:49 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)
* source/rtl/achoice.prg
! Partially reverted this commit:
https://sourceforge.net/apps/trac/harbour-project/changeset/10605
After this change, activating DBU menus with all items disabled
(f.e. F7/F8) caused app hang.
This line:
nUserFunc := iif( nMode != AC_NOITEM,;
Do( xUserFunc, nMode, nPos, nPos - nAtTop ), NIL )
Was now changed back to this:
nUserFunc := Do( xUserFunc, nMode, nPos, nPos - nAtTop )
ac_test2.prg still seem to function fine after this, but
I'd kindly like to ask Vladislav Lavrecky to make tests
again, maybe we need another fix here.
* source/vm/evalhb.c
* Minor formatting.
* contrib/hbtip/client.prg
* Minor formatting.
! :ReadToFile() nMode param check.
* utils/hbmk2/hbmk2.prg
* Cleanup to variable name prefixes.
* contrib/xhb/Makefile
+ contrib/xhb/xthrow.prg
+ Added THROW() function for xhb compatibility.
This is written in Harbour, based on hbcompat.ch
and has Harbour license + exception.
+ contrib/xhb/xcstr.prg
+ contrib/xhb/xdbmodst.prg
* contrib/xhb/Makefile
+ Ported following old functions from xhb:
CSTRTOVAL(), STRINGTOLITERAL(), VALTOPRG(), PRGEXPTOVAL()
+ Ported following new functions from xhb:
VALTOARRAY(), VALTODATE(), VALTOHASH(), VALTOLOGICAL()
VALTONUMBER(), VALTOARRAY(), VALTOTYPE(),
DBMODIFYSTRUCTURE(), DBIMPORT(), DBMERGE()
(borrowed from xhb, work of Ron Pinkas)
2009-06-12 17:50 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)
* mpkg_deb.sh
! Applied patch to recent change to only accept

174
harbour/contrib/hbtip/client.prg
View File

@@ -71,11 +71,12 @@
Added data ::nWrite to work like ::nRead
*/
#include "hbclass.ch"
#include "common.ch"
#include "error.ch"
#include "fileio.ch"
#include "hbclass.ch"
#include "tip.ch"
#include "common.ch"
#DEFINE RCV_BUF_SIZE Int( ::InetRcvBufSize( ::SocketCon ) / 2 )
#DEFINE SND_BUF_SIZE Int( ::InetSndBufSize( ::SocketCon ) / 2 )
@@ -87,13 +88,13 @@ CLASS tIPClient
CLASSDATA bInitSocks INIT .F.
CLASSDATA cCRLF INIT HB_InetCRLF()
DATA oUrl // url to wich to connect
DATA oCredentials // credential needed to access the service
DATA nStatus // basic status
DATA oUrl /* url to wich to connect */
DATA oCredentials /* credential needed to access the service */
DATA nStatus /* basic status */
DATA SocketCon
Data lTrace
Data nHandle
DATA nDefaultRcvBuffSize
DATA nDefaultSndBuffSize
@@ -116,7 +117,7 @@ CLASS tIPClient
DATA bEof
DATA isOpen INIT .F.
/** Gauge control; it can be a codeblock or a function pointer. */
/* Gauge control; it can be a codeblock or a function pointer. */
DATA exGauge
DATA Cargo
@@ -136,8 +137,8 @@ CLASS tIPClient
METHOD lastErrorCode() INLINE ::nLastError
METHOD lastErrorMessage(SocketCon) INLINE ::INetErrorDesc(SocketCon)
METHOD InetRcvBufSize( SocketCon, nSizeBuff )
METHOD InetSndBufSize( SocketCon, nSizeBuff )
METHOD InetRcvBufSize( SocketCon, nSizeBuff )
METHOD InetSndBufSize( SocketCon, nSizeBuff )
PROTECTED:
DATA nLastError INIT 0
@@ -151,7 +152,7 @@ CLASS tIPClient
METHOD InetErrorCode(SocketCon)
METHOD InetErrorDesc(SocketCon)
METHOD InetConnect( cServer, nPort, SocketCon )
METHOD Log()
ENDCLASS
@@ -160,18 +161,18 @@ ENDCLASS
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClient
LOCAL oErr
Default lTrace to .F.
DEFAULT lTrace TO .F.
IF .not. ::bInitSocks
IF ! ::bInitSocks
HB_InetInit()
::bInitSocks := .T.
ENDIF
IF HB_IsString( oUrl )
IF ISCHARACTER( oUrl )
oUrl := tUrl():New( oUrl )
ENDIF
IF .NOT. oURL:cProto $ "ftp,http,pop,smtp"
IF ! oURL:cProto $ "ftp,http,pop,smtp"
oErr := ErrorNew()
oErr:Args := { Self, oURL:cProto }
oErr:CanDefault := .F.
@@ -206,7 +207,7 @@ METHOD Open( cUrl ) CLASS tIPClient
LOCAL nPort
IF HB_IsString( cUrl )
IF ISCHARACTER( cUrl )
::oUrl := tUrl():New( cUrl )
ENDIF
@@ -232,9 +233,9 @@ RETURN .T.
METHOD Close() CLASS tIPClient
local nRet:=-1
LOCAL nRet := -1
IF .not. Empty( ::SocketCon )
IF ! Empty( ::SocketCon )
nRet := HB_InetClose( ::SocketCon )
@@ -259,17 +260,18 @@ RETURN .T.
METHOD Read( nLen ) CLASS tIPClient
LOCAL cStr0, cStr1
LOCAL cStr0
LOCAL cStr1
IF ::nLength > 0 .and. ::nLength == ::nRead
IF ::nLength > 0 .AND. ::nLength == ::nRead
RETURN NIL
ENDIF
IF Empty( nLen ) .or. nLen < 0 .or.( ::nLength > 0 .and. nLen > ::nLength - ::nRead )
IF Empty( nLen ) .OR. nLen < 0 .OR.( ::nLength > 0 .AND. nLen > ::nLength - ::nRead )
nLen := ::nLength - ::nRead
ENDIF
IF Empty( nLen ) .or. nLen < 0
IF Empty( nLen ) .OR. nLen < 0
// read till end of stream
cStr1 := Space( RCV_BUF_SIZE )
cStr0 := ""
@@ -311,7 +313,7 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
LOCAL cData
LOCAL nSent
IF Empty ( nMode )
IF ! ISNUMBER( nMode )
nMode := FC_NORMAL
ENDIF
@@ -324,11 +326,11 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
::nRead := 0
::nStatus := 1
DO WHILE ::InetErrorCode( ::SocketCon ) == 0 .and. .not. ::bEof
DO WHILE ::InetErrorCode( ::SocketCon ) == 0 .AND. ! ::bEof
cData := ::Read( RCV_BUF_SIZE )
IF cData == NIL
IF nFout != NIL
Fclose( nFout )
FClose( nFout )
ENDIF
IF ::InetErrorCode( ::SocketCon ) > 0
RETURN .F.
@@ -337,15 +339,15 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
ENDIF
ENDIF
IF nFout == NIL
nFout := Fcreate( cFile, nMode )
nFout := FCreate( cFile, nMode )
IF nFout < 0
::nStatus := 0
RETURN .F.
ENDIF
ENDIF
IF Fwrite( nFout, cData ) < 0
Fclose( nFout )
IF FWrite( nFout, cData ) < 0
FClose( nFout )
RETURN .F.
ENDIF
@@ -358,10 +360,11 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
IF nSent > 0
::Commit()
Endif
ENDIF
::nStatus := 2
Fclose( nFout )
FClose( nFout )
RETURN .T.
@@ -374,7 +377,7 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
::nWrite := 0
::nStatus := 0
nFin := Fopen( cFile, FO_READ )
nFin := FOpen( cFile, FO_READ )
IF nFin < 0
RETURN .F.
ENDIF
@@ -391,17 +394,17 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
::nStatus := 1
cData := Space( nBufSize )
nLen := Fread( nFin, @cData, nBufSize )
nLen := FRead( nFin, @cData, nBufSize )
DO WHILE nLen > 0
IF ::Write( @cData, nLen ) != nLen
Fclose( nFin )
FClose( nFin )
RETURN .F.
ENDIF
nSent += nLen
IF ! Empty( ::exGauge )
HB_ExecFromArray( ::exGauge, {nSent, nSize, Self} )
ENDIF
nLen := Fread( nFin, @cData, nBufSize )
nLen := FRead( nFin, @cData, nBufSize )
ENDDO
// it may happen that the file has lenght 0
@@ -410,7 +413,7 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
ENDIF
::nStatus := 2
Fclose( nFin )
FClose( nFin )
RETURN .T.
@@ -419,7 +422,7 @@ HZ: METHOD :getOk() is not declared in TIpClient
METHOD Data( cData ) CLASS tIPClient
::InetSendall( ::SocketCon, "DATA" + ::cCRLF )
IF .not. ::GetOk()
IF ! ::GetOk()
RETURN .F.
ENDIF
::InetSendall(::SocketCon, cData + ::cCRLF + "." + ::cCRLF )
@@ -435,10 +438,8 @@ METHOD Write( cData, nLen, bCommit ) CLASS tIPClient
::nLastWrite := ::InetSendall( ::SocketCon, cData , nLen )
IF .not. Empty( bCommit ) .and. bCommit
IF ! Empty( bCommit ) .AND. bCommit
::Commit()
ENDIF
::nWrite += ::nLastWrite
@@ -448,8 +449,7 @@ RETURN ::nLastWrite
METHOD InetSendAll( SocketCon, cData, nLen ) CLASS tIPClient
Local nRet
LOCAL nRet
IF Empty( nLen )
nLen := Len( cData )
@@ -457,89 +457,76 @@ METHOD InetSendAll( SocketCon, cData, nLen ) CLASS tIPClient
nRet := HB_InetSendAll( SocketCon, cData, nLen )
if ::lTrace
IF ::lTrace
::Log( SocketCon, nlen, cData, nRet )
endif
ENDIF
Return nRet
RETURN nRet
METHOD InetCount( SocketCon ) CLASS tIPClient
Local nRet
LOCAL nRet
nRet := HB_InetCount( SocketCon )
if ::lTrace
IF ::lTrace
::Log( SocketCon, nRet )
endif
ENDIF
Return nRet
RETURN nRet
METHOD InetRecv( SocketCon, cStr1, len ) CLASS tIPClient
Local nRet
LOCAL nRet
nRet := HB_InetRecv( SocketCon, @cStr1, len )
if ::lTrace
IF ::lTrace
::Log( SocketCon, "", len, iif( nRet >= 0, cStr1, nRet ) )
ENDIF
endif
Return nRet
RETURN nRet
METHOD InetRecvLine( SocketCon, nLen, size ) CLASS tIPClient
Local cRet
LOCAL cRet
cRet := HB_InetRecvLine( SocketCon, @nLen, size )
if ::lTrace
IF ::lTrace
::Log( SocketCon, "", size, cRet )
ENDIF
endif
Return cRet
RETURN cRet
METHOD InetRecvAll( SocketCon, cStr1, len ) CLASS tIPClient
Local nRet
LOCAL nRet
nRet := HB_InetRecvAll( SocketCon, @cStr1, len )
if ::lTrace
IF ::lTrace
::Log( SocketCon, "", len, iif( nRet >= 0, cStr1, nRet ) )
ENDIF
endif
Return nRet
RETURN nRet
METHOD InetErrorCode( SocketCon ) CLASS tIPClient
Local nRet
LOCAL nRet
::nLastError := nRet := HB_InetErrorCode( SocketCon )
if ::lTrace
IF ::lTrace
::Log( SocketCon, nRet )
ENDIF
endif
Return nRet
RETURN nRet
METHOD InetErrorDesc( SocketCon ) CLASS tIPClient
@@ -547,11 +534,10 @@ METHOD InetErrorDesc( SocketCon ) CLASS tIPClient
DEFAULT SocketCon TO ::SocketCon
IF .not. Empty( SocketCon )
IF ! Empty( SocketCon )
cMsg := HB_InetErrorDesc( SocketCon )
ENDIF
RETURN cMsg
@@ -563,18 +549,16 @@ METHOD InetConnect( cServer, nPort, SocketCon ) CLASS tIPClient
IF ! Empty( ::nDefaultSndBuffSize )
::InetSndBufSize( SocketCon, ::nDefaultSndBuffSize )
ENDIF
IF ! Empty( ::nDefaultRcvBuffSize )
::InetRcvBufSize( SocketCon, ::nDefaultRcvBuffSize )
ENDIF
if ::lTrace
IF ::lTrace
::Log( cServer, nPort, SocketCon )
ENDIF
endif
Return Nil
RETURN NIL
/* Methods to manage buffers */
METHOD InetRcvBufSize( SocketCon, nSizeBuff ) CLASS tIPClient
@@ -598,30 +582,30 @@ METHOD Log( ... ) CLASS tIPClient
LOCAL xVar
LOCAL cMsg := DToS( Date() ) + "-" + Time() + Space( 2 ) + ;
SubStr( ProcName( 1 ), Rat( ":", ProcName( 1 ) ) ) +;
SubStr( ProcName( 1 ), RAt( ":", ProcName( 1 ) ) ) +;
"( "
for each xVar in hb_aParams()
FOR EACH xVar IN hb_AParams()
// Preserves CRLF on result
if xVar:__enumIndex() < PCount()
IF xVar:__enumIndex() < PCount()
cMsg += StrTran( StrTran( AllTrim( hb_CStr( xVar ) ), Chr( 13 ) ), Chr( 10 ) )
else
ELSE
cMsg += hb_CStr( xVar )
endif
ENDIF
cMsg += iif ( xVar:__enumIndex() < PCount() - 1, ", ", "" )
if xVar:__enumIndex() == PCount() - 1
IF xVar:__enumIndex() == PCount() - 1
cMsg += " )" + hb_OsNewLine() + ">> "
elseif xVar:__enumIndex() == PCount()
ELSEIF xVar:__enumIndex() == PCount()
cMsg += " <<" + hb_OsNewLine() + hb_OsNewLine()
endif
ENDIF
next
NEXT
fWrite( ::nHandle, cMsg )
FWrite( ::nHandle, cMsg )
RETURN Self

3
harbour/contrib/xhb/Makefile
View File

@@ -59,10 +59,13 @@ PRG_SOURCES=\
trpccli.prg \
ttable.prg \
txml.prg \
xcstr.prg \
xdbmodst.prg \
xhbcomp.prg \
xhberr.prg \
xhbmt.prg \
xhbver.prg \
xthrow.prg \
PRG_HEADERS=\
hbcompat.ch \

501
harbour/contrib/xhb/xcstr.prg Normal file
View File

@@ -0,0 +1,501 @@
/*
* $Id$
*/
/*
* xHarbour Project source code:
* CStr( xAnyType ) -> String
*
* Copyright 2001 Ron Pinkas <ron@@ronpinkas.com>
* www - http://www.xharbour.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, xHarbour license gives permission for
* additional uses of the text contained in its release of xHarbour.
*
* The exception is that, if you link the xHarbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the xHarbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released with this xHarbour
* explicit exception. If you add/copy code from other sources,
* as the General Public License permits, the above exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for xHarbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "common.ch"
#include "error.ch"
#include "hbclass.ch"
/*
For performance NOT using OS indpendant R/T function,
this define only used in ValTpPrg() which currently only used in win32.
*/
#undef CRLF
#define CRLF Chr(13) + Chr(10)
#xtranslate THROW(<oErr>) => (Eval(ErrorBlock(), <oErr>), Break(<oErr>))
//--------------------------------------------------------------//
FUNCTION CStrToVal( cExp, cType )
IF ! ISCHAR( cExp )
Throw( ErrorNew( "CSTR", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
ENDIF
SWITCH cType
CASE 'C'
RETURN cExp
CASE 'P'
RETURN hb_HexToNum( cExp )
CASE 'D'
IF cExp[3] >= '0' .AND. cExp[3] <= '9' .AND. cExp[5] >= '0' .AND. cExp[5] <= '9'
RETURN hb_SToD( cExp )
ELSE
RETURN cToD( cExp )
ENDIF
CASE 'L'
RETURN IIF( cExp[1] == 'T' .OR. cExp[1] == 'Y' .OR. cExp[2] == 'T' .OR. cExp[2] == 'Y', .T., .F. )
CASE 'N'
RETURN Val( cExp )
CASE 'U'
RETURN NIL
/*
CASE 'A'
Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'B'
Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
CASE 'O'
Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
*/
OTHERWISE
Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
ENDSWITCH
RETURN NIL
//--------------------------------------------------------------//
FUNCTION StringToLiteral( cString )
LOCAL lDouble := .F., lSingle := .F.
IF hb_RegExHas( "\n|\r", cString ) .OR. ;
( ( lDouble := '"' $ cString ) .AND. ( lSingle := "'" $ cString ) .AND. hb_RegExHas( "\[|\]", cString ) )
cString := StrTran( cString, '"', '\"' )
cString := StrTran( cString, Chr(10), '\n' )
cString := StrTran( cString, Chr(13), '\r' )
//TraceLog( cString )
RETURN 'E"' + cString + '"'
ELSEIF lDouble == .F.
RETURN '"' + cString + '"'
ELSEIF lSingle == .F.
RETURN "'" + cString + "'"
ENDIF
RETURN "[" + cString + "]"
//--------------------------------------------------------------//
FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
LOCAL cType := ValType( xVal )
LOCAL aVar, cRet, cPad, nObj
//TraceLog( xVal, cName, nPad, aObjs )
SWITCH cType
CASE 'C'
RETURN StringToLiteral( xVal )
CASE 'D'
RETURN "hb_SToD( '" + dToS( xVal ) + "' )"
CASE 'L'
RETURN IIF( xVal, ".T.", ".F." )
CASE 'N'
RETURN Str( xVal )
CASE 'A'
IF cName == NIL
nPad := 0
cName := "M->__ValToPrg_Array"
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {|a| HB_ArrayID( a[1] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][2] + " /* Cyclic */"
ENDIF
cRet := ""
ENDIF
aAdd( aObjs, { xVal, cName } )
cRet += "Array(" + hb_ntos( Len( xVal ) ) + ")" + CRLF
nPad += 3
cPad := Space( nPad )
FOR EACH aVar IN xVal
cRet += cPad + cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "] := " + ValToPrg( aVar, cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "]", nPad, aObjs ) + CRLF
NEXT
nPad -=3
RETURN cRet
CASE 'H'
IF Len( xVal ) == 0
RETURN "hb_Hash()"
ELSE
cRet := "{ "
FOR EACH aVar IN xVal:Keys
cRet += ValToPrg( aVar ) + " => "
cRet += ValToPrg( xVal:Values[ aVar:__EnumIndex() ] ) + ", "
NEXT
/* We know for sure xVal isn't empty, and a last ',' is here */
cRet[ -2 ] := ' '
cRet[ -1 ] := '}'
RETURN cRet
ENDIF
CASE 'B'
RETURN ValToPrgExp( xVal )
CASE 'P'
RETURN "0x" + hb_NumToHex( xVal )
CASE 'O'
/* TODO: Use HBPersistent() when avialable! */
IF cName == NIL
cName := "M->__ValToPrg_Object"
nPad := 0
aObjs := {}
cRet := cName + " := "
ELSE
IF ( nObj := aScan( aObjs, {|a| HB_ArrayID( a[1] ) == HB_ArrayID( xVal ) } ) ) > 0
RETURN aObjs[ nObj ][2] + " /* Cyclic */"
ENDIF
cRet := ""
ENDIF
aAdd( aObjs, { xVal, cName } )
cRet += xVal:ClassName + "():New()" + CRLF
nPad += 3
cPad := Space( nPad )
FOR EACH aVar IN __objGetValueDiff( xVal )
cRet += cPad + cName + ":" + aVar[1] + " := " + ValToPrg( aVar[2], cName + ":" + aVar[1], nPad, aObjs ) + CRLF
NEXT
nPad -=3
RETURN cRet
OTHERWISE
//TraceLog( xVal, cName, nPad )
IF xVal == NIL
cRet := "NIL"
ELSE
Throw( ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDIF
ENDSWITCH
//TraceLog( cRet )
RETURN cRet
//--------------------------------------------------------------//
FUNCTION PrgExpToVal( cExp )
RETURN &( cExp )
//--------------------------------------------------------------//
FUNCTION ValToArray( xVal )
IF ISARRAY( xVal )
RETURN xVal
ENDIF
RETURN { xVal }
//--------------------------------------------------------------//
FUNCTION ValToBlock( xVal )
IF ISBLOCK( xVal )
RETURN xVal
ENDIF
RETURN { || xVal }
//--------------------------------------------------------------//
FUNCTION ValToCharacter( xVal )
IF ISCHAR( xVal )
RETURN xVal
ENDIF
RETURN LTrim( CStr( xVal ) )
//--------------------------------------------------------------//
FUNCTION ValToDate( xVal )
LOCAL cType := ValType( xVal )
SWITCH cType
CASE 'A'
CASE 'H'
CASE 'L'
CASE 'O'
CASE 'U'
EXIT
CASE 'B'
RETURN ValToDate( Eval( xVal ) )
CASE 'C'
IF SubStr( DToS( xVal ), 3, 1 ) >= '0' .AND. ;
SubStr( DToS( xVal ), 3, 1 ) <= '9' .AND. ;
SubStr( DToS( xVal ), 5, 1 ) >= '0' .AND. ;
SubStr( DToS( xVal ), 5, 1 ) <= '9'
RETURN hb_SToD( xVal )
ELSE
RETURN cToD( xVal )
ENDIF
CASE 'D'
RETURN xVal
CASE 'N'
CASE 'P'
RETURN 0d19000101 + xVal
OTHERWISE
Throw( ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN hb_SToD()
//--------------------------------------------------------------//
FUNCTION ValToHash( xVal )
IF hb_IsHash( xVal )
RETURN xVal
ENDIF
RETURN { ValToCharacter( xVal ) => xVal }
//--------------------------------------------------------------//
FUNCTION ValToLogical( xVal )
LOCAL cType := ValType( xVal )
SWITCH cType
CASE 'A'
CASE 'D'
CASE 'H'
CASE 'N'
CASE 'O'
CASE 'P'
RETURN ! Empty( xVal )
CASE 'B'
RETURN ValToLogical( Eval( xVal ) )
CASE 'C'
IF Left( xVal, 1 ) == '.' .AND. SubStr( xVal, 3, 1 ) == '.' .AND. Upper( SubStr( xVal, 2, 1 ) ) $ "TFYN"
RETURN Upper( SubStr( xVal, 2, 1 ) ) $ "TY"
ELSEIF Len( xVal ) == 1 .AND. Upper( xVal ) $ "TFYN"
RETURN Upper( xVal ) $ "TY"
ELSE
RETURN ! Empty( xVal )
ENDIF
EXIT
CASE 'L'
RETURN xVal
CASE 'U'
RETURN .F.
OTHERWISE
Throw( ErrorNew( "VALTOLOGICAL", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN .F.
//--------------------------------------------------------------//
FUNCTION ValToNumber( xVal )
LOCAL cType := ValType( xVal )
SWITCH cType
CASE 'A'
CASE 'H'
RETURN Len( xVal )
CASE 'B'
RETURN ValToNumber( Eval( xVal ) )
CASE 'C'
RETURN Val( xVal )
CASE 'D'
RETURN xVal - 0d19000101
CASE 'L'
RETURN IIF( xVal, 1, 0 )
CASE 'O'
RETURN xVal:hClass
CASE 'N'
RETURN xVal
CASE 'P'
RETURN xVal - 0
CASE 'U'
RETURN 0
OTHERWISE
Throw( ErrorNew( "VALTONUMBER", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN 0
//--------------------------------------------------------------//
FUNCTION ValToObject( xVal )
LOCAL cType := ValType( xVal )
SWITCH cType
CASE 'A'
ENABLE TYPE CLASS ARRAY
EXIT
CASE 'B'
ENABLE TYPE CLASS BLOCK
EXIT
CASE 'C'
ENABLE TYPE CLASS CHARACTER
EXIT
CASE 'D'
ENABLE TYPE CLASS DATE
EXIT
CASE 'H'
ENABLE TYPE CLASS HASH
EXIT
CASE 'L'
ENABLE TYPE CLASS LOGICAL
EXIT
CASE 'N'
ENABLE TYPE CLASS NUMERIC
EXIT
CASE 'O'
RETURN xVal
CASE 'P'
ENABLE TYPE CLASS POINTER
EXIT
CASE 'U'
ENABLE TYPE CLASS NIL
EXIT
OTHERWISE
Throw( ErrorNew( "VALTOOBJECT", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN 0
//--------------------------------------------------------------//
FUNCTION ValToType( xVal, cType )
SWITCH cType
CASE 'A'
RETURN ValToArray( xVal )
CASE 'B'
RETURN ValToBlock( xVal )
CASE 'C'
RETURN ValToCharacter( xVal )
CASE 'D'
RETURN ValToDate( xVal )
CASE 'H'
RETURN ValToHash( xVal )
CASE 'L'
RETURN ValToLogical( xVal )
CASE 'N'
RETURN ValToNumber( xVal )
CASE 'O'
RETURN ValToObject( xVal )
CASE 'P'
RETURN ValToNumber( xVal )
CASE 'U'
RETURN NIL
OTHERWISE
Throw( ErrorNew( "VALTOTYPE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
ENDSWITCH
RETURN NIL
//--------------------------------------------------------------//

292
harbour/contrib/xhb/xdbmodst.prg Normal file
View File

@@ -0,0 +1,292 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* dbModifyStructure( <cFile> ) -> lSuccess
*
* Copyright 2009 Ron Pinkas <Ron.Pinkas at xHarbour.com>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "common.ch"
#include "dbstruct.ch"
#include "dbinfo.ch"
#include "error.ch"
#ifndef EG_RENAME
#define EG_RENAME 26
#endif
#xtranslate THROW(<oErr>) => (Eval(ErrorBlock(), <oErr>), Break(<oErr>))
/*
xHarbour extensions by Ron Pinkas
*/
//----------------------------------------------------------------------------//
FUNCTION dbModifyStructure( cFile )
LOCAL lRet
LOCAL cExt
LOCAL cTable
LOCAL cBakFile
LOCAL cStructureFile
LOCAL cNewFile
LOCAL oErr
LOCAL nPresetArea := Select()
LOCAL nSourceArea
LOCAL cDateTime := SubStr( dtos( Date() ), 3 ) + "." + StrTran( Left( Time(), 5 ), ":", "." )
BEGIN SEQUENCE WITH {|oErr| Break( oErr )}
// Open exclusively, get name info, and create the structure db.
//-------------------------------------------------------------//
USE ( cFile ) ALIAS ModifySource EXCLUSIVE NEW
nSourceArea := Select()
cFile := dbInfo( DBI_FULLPATH )
cExt := dbInfo( DBI_TABLEEXT )
hb_FNameSplit( cFile, , @cTable )
cBakFile := cTable + ".bak." + cDateTime + cExt
cStructureFile := cTable + ".str." + cDateTime + cExt
cNewFile := cTable + ".new." + cDateTime + cExt
COPY STRUCTURE EXTENDED TO ( cStructureFile )
//-------------------------------------------------------------//
// Let user modify the structure.
//-------------------------------------------------------------//
USE ( cStructureFile ) ALIAS NewStructure EXCLUSIVE NEW
Browse( 0, 0, Min( 20, MaxRow() - 1 ), Min( MaxCol() - 30, 50 ) )
CLOSE
CREATE ( cNewFile ) FROM ( cStructureFile ) ALIAS NEW_MODIFIED NEW
//-------------------------------------------------------------//
// Import data into the new file, and close it
//-------------------------------------------------------------//
lRet := dbImport( nSourceArea )
CLOSE
SELECT ( nSourceArea )
CLOSE
SELECT ( nPresetArea )
//-------------------------------------------------------------//
// Rename original as backup, and new file as the new original.
//-------------------------------------------------------------//
IF lRet
IF FRename( cFile, cBakFile ) == -1
BREAK
ENDIF
IF FRename( cNewFile, cFile ) == -1
// If we can't then try to restore backup as original
IF FRename( cBakFile, cFile ) == -1
// Oops - must advise the user!
oErr := ErrorNew()
oErr:severity := ES_ERROR
oErr:genCode := EG_RENAME
oErr:subSystem := "DBCMD"
oErr:canDefault := .F.
oErr:canRetry := .F.
oErr:canSubtitute := .F.
oErr:operation := cFile
oErr:subCode := 1101
oErr:args := { cNewFile, cBakFile }
BREAK oErr
ENDIF
ENDIF
ENDIF
//-------------------------------------------------------------//
RECOVER USING oErr
IF oErr:ClassName == "ERROR"
IF oErr:genCode == EG_RENAME
// This kind of error must be reported
lRet := Throw( oErr )
ELSE
lRet := .F.
ENDIF
ELSE
lRet := .F.
ENDIF
END SEQUENCE
SELECT ( nPresetArea )
RETURN lRet
//----------------------------------------------------------------------------//
FUNCTION dbImport( xSource )
RETURN dbMerge( xSource )
//----------------------------------------------------------------------------//
FUNCTION dbMerge( xSource, lAppend )
LOCAL nArea, nSource, nRecNo
LOCAL aFields
LOCAL cField, xField
LOCAL nSourcePos, aTranslate := {}, aTranslation
// LOCAL oErr
LOCAL cTargetType
// Safety
//-------------------------------------------------------------//
IF LastRec() > 0
IF ! lAppend
RETURN .F.
ENDIF
ENDIF
//-------------------------------------------------------------//
// Validate args
//-------------------------------------------------------------//
IF ValType( xSource ) == 'C'
nArea := Select()
USE ( xSource ) ALIAS MergeSource EXCLUSIVE NEW
nSource := Select()
SELECT ( nArea )
ELSEIF ValType( xSource ) == 'N'
nSource := xSource
ELSE
RETURN .F.
ENDIF
//-------------------------------------------------------------//
// Temp working record
IF LastRec() == 0
APPEND BLANK
ENDIF
// Create translation plan
//-------------------------------------------------------------//
aFields := Array( FCount() )
aFields( aFields )
FOR EACH cField IN aFields
nSourcePos := (nSource)->( FieldPos( cField ) )
IF nSourcePos > 0
BEGIN SEQUENCE WITH {|oErr| Break( oErr )}
// Save
xField := FieldGet( cField:__EnumIndex() )
// Test type compatability
FieldPut( cField:__EnumIndex(), (nSource)->( FieldGet( nSourcePos ) ) )
// Restore
FieldPut( cField:__EnumIndex(), xField )
// Ok to process
aAdd( aTranslate, { cField:__EnumIndex(), nSourcePos, {|xSource| xSource } } )
RECOVER // USING oErr
cTargetType := ValType( FieldGet( cField:__EnumIndex() ) )
BEGIN SEQUENCE WITH {|oErr| Break( oErr )}
// Test type compatability
FieldPut( cField:__EnumIndex(), ValToType( (nSource)->( FieldGet( nSourcePos ) ), cTargetType ) )
// Restore
FieldPut( cField:__EnumIndex(), xField )
// Ok to process
aAdd( aTranslate, { cField:__EnumIndex(), nSourcePos, {|xSource| ValToType( xSource, cTargetType ) } } )
RECOVER // USING oErr
//TraceLog( oErr:Description, oErr:Operation )
END SEQUENCE
END SEQUENCE
ENDIF
NEXT
//-------------------------------------------------------------//
// Reset
//-------------------------------------------------------------//
IF LastRec() == 1 .AND. ! lAppend
DELETE
ZAP
ENDIF
//-------------------------------------------------------------//
// Process
//-------------------------------------------------------------//
nRecNo := (nSource)->( RecNo() )
(nSource)->( dbGoTop(1) )
WHILE ! (nSource)->( Eof() )
APPEND BLANK
FOR EACH aTranslation IN aTranslate
FieldPut( aTranslation[1], Eval( aTranslation[3], (nSource)->( FieldGet( aTranslation[2] ) ) ) )
NEXT
(nSource)->( dbSkip() )
ENDDO
(nSource)->( dbGoTo( nRecNo ) )
//-------------------------------------------------------------//
// Reset
//-------------------------------------------------------------//
IF ! Empty( nArea )
SELECT ( nSource )
CLOSE
SELECT ( nArea )
ENDIF
//-------------------------------------------------------------//
RETURN .T.
//----------------------------------------------------------------------------//

58
harbour/contrib/xhb/xthrow.prg Normal file
View File

@@ -0,0 +1,58 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* THROW() compatibility function
*
* Copyright 2009 Viktor Szakats (harbour.01 syenar.hu)
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
PROCEDURE THROW( oError )
Eval( ErrorBlock(), oError )
Break( oError )
RETURN

3
harbour/source/rtl/achoice.prg
View File

@@ -486,8 +486,7 @@ FUNCTION AChoice( nTop, nLeft, nBottom, nRight, acItems, xSelect, xUserFunc, nPo
IF lUserFunc
nUserFunc := iif( nMode != AC_NOITEM,;
Do( xUserFunc, nMode, nPos, nPos - nAtTop ), NIL )
nUserFunc := Do( xUserFunc, nMode, nPos, nPos - nAtTop )
IF ISNUMBER( nUserFunc )

4
harbour/source/vm/evalhb.c
View File

@@ -73,14 +73,10 @@ HB_FUNC( EVAL )
* hb_param() is dereferencing the passed parameters
*/
for( uiParam = 2; uiParam <= uiPCount; uiParam++ )
{
hb_vmPush( hb_stackItemFromBase( uiParam ) );
}
hb_vmSend( ( USHORT ) ( uiPCount - 1 ) );
}
else
{
hb_errRT_BASE_SubstR( EG_NOMETHOD, 1004, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
}

846
harbour/utils/hbmk2/hbmk2.prg
View File

File diff suppressed because it is too large Load Diff