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

2007-08-20 15:50 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

Browse Source 
* harbour/include/hbexprb.c
    * do not generate error for QSELF()[...] - Clipper allows such
      operation and because some valid Clipper code needs it then
      I disabled error message.

  * harbour/common.mak
  * harbour/source/rtl/Makefile
  + harbour/source/rtl/einstvar.prg
    + added undocumented CA-Cl*pper function _eInstVar() used to validate
      variable type in assign messages.

  * harbour/include/hbapi.h
  * harbour/source/vm/arrays.c
    * changed 'char *' to 'const char *' in hb_arraySetC() and hb_arraySetCL()

  * harbour/source/rdd/dbcmd.c
    * cleaned DBSKIPPER() code

  * harbour/source/rtl/browdb.prg
    * use written in C DBSKIPPER() function instead of static .prg Skipped()
      when HB_COMPAT_XPP macro is enabled

  * harbour/source/rtl/browse.prg
    ! fixes in BROWSE() function:
      ! displaying box characters
      + added CL53 compatible mouse actions
      + added mouse wheel actions
      + added support for deleting records (K_DEL)
      + added support for edit mode
      + added support for append mode
This commit is contained in:
Przemyslaw Czerpak
2007-08-20 13:50:18 +00:00
parent 3992714e33
commit c775f56f50
10 changed files with 503 additions and 138 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
harbour/ChangeLog
View File

@@ -8,6 +8,38 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2007-08-20 15:50 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/include/hbexprb.c
* do not generate error for QSELF()[...] - Clipper allows such
operation and because some valid Clipper code needs it then
I disabled error message.
* harbour/common.mak
* harbour/source/rtl/Makefile
+ harbour/source/rtl/einstvar.prg
+ added undocumented CA-Cl*pper function _eInstVar() used to validate
variable type in assign messages.
* harbour/include/hbapi.h
* harbour/source/vm/arrays.c
* changed 'char *' to 'const char *' in hb_arraySetC() and hb_arraySetCL()
* harbour/source/rdd/dbcmd.c
* cleaned DBSKIPPER() code
* harbour/source/rtl/browdb.prg
* use written in C DBSKIPPER() function instead of static .prg Skipped()
when HB_COMPAT_XPP macro is enabled
* harbour/source/rtl/browse.prg
! fixes in BROWSE() function:
! displaying box characters
+ added CL53 compatible mouse actions
+ added mouse wheel actions
+ added support for deleting records (K_DEL)
+ added support for edit mode
+ added support for append mode
2007-08-20 15:25 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/source/rtl/fserror.c
+ added translation (errno=>dosError) for ENOSPC

1
harbour/common.mak
View File

@@ -544,6 +544,7 @@ RTL_LIB_OBJS = \
$(OBJ_DIR)\dbedit$(OBJEXT) \
$(OBJ_DIR)\devoutp$(OBJEXT) \
$(OBJ_DIR)\dircmd$(OBJEXT) \
$(OBJ_DIR)\einstvar$(OBJEXT) \
$(OBJ_DIR)\errorsys$(OBJEXT) \
$(OBJ_DIR)\fieldbl$(OBJEXT) \
$(OBJ_DIR)\getlist$(OBJEXT) \

4
harbour/include/hbapi.h
View File

@@ -683,8 +683,8 @@ extern HB_EXPORT BOOL hb_arraySetNL( PHB_ITEM pArray, ULONG ulIndex, LONG l
extern HB_EXPORT BOOL hb_arraySetNLL( PHB_ITEM pArray, ULONG ulIndex, LONGLONG llNumber );
extern HB_EXPORT BOOL hb_arraySetNInt( PHB_ITEM pArray, ULONG ulIndex, HB_LONG lNumber );
extern HB_EXPORT BOOL hb_arraySetND( PHB_ITEM pArray, ULONG ulIndex, double dNumber );
extern HB_EXPORT BOOL hb_arraySetC( PHB_ITEM pArray, ULONG ulIndex, char * szText );
extern HB_EXPORT BOOL hb_arraySetCL( PHB_ITEM pArray, ULONG ulIndex, char * szText, ULONG ulLen );
extern HB_EXPORT BOOL hb_arraySetC( PHB_ITEM pArray, ULONG ulIndex, const char * szText );
extern HB_EXPORT BOOL hb_arraySetCL( PHB_ITEM pArray, ULONG ulIndex, const char * szText, ULONG ulLen );
extern HB_EXPORT BOOL hb_arraySetCPtr( PHB_ITEM pArray, ULONG ulIndex, char * szText, ULONG ulLen );
extern HB_EXPORT BOOL hb_arraySetPtr( PHB_ITEM pArray, ULONG ulIndex, void * pValue );
extern HB_EXPORT BOOL hb_arrayFill( PHB_ITEM pArray, PHB_ITEM pValue, ULONG * pulStart, ULONG * pulCount ); /* fill an array with a given item */

5
harbour/include/hbexprb.c
View File

@@ -492,7 +492,10 @@ static HB_EXPR_FUNC( hb_compExprUseSelf )
case HB_EA_REDUCE:
break;
case HB_EA_ARRAY_AT:
HB_COMP_ERROR_TYPE( pSelf ); /* QUESTION: Is this OK ? */
/* Clipper allows such operation and because some valid Clipper
* code needs it then I disabled error message, [druzus]
*/
/* HB_COMP_ERROR_TYPE( pSelf ); */
break;
case HB_EA_ARRAY_INDEX:
hb_compErrorIndex( HB_COMP_PARAM, pSelf ); /* SELF cannot be used as array index element */

85
harbour/source/rdd/dbcmd.c
View File

@@ -2668,61 +2668,52 @@ HB_FUNC( DBSKIPPER )
if( pArea )
{
LONG nSkipped = 0;
LONG nRecs = 1;
BOOL bBEof = TRUE;
if( hb_pcount() > 0 )
{
nRecs = hb_parnl( 1 ) ;
}
LONG lSkipped = 0;
LONG lRecs = 1;
BOOL fBEof;
ULONG ulRecords = 0;
if( SELF_EOF( pArea, &bBEof ) != SUCCESS )
return;
if( SELF_RECCOUNT( pArea, &ulRecords ) == SUCCESS && ulRecords > 0 )
{
if( ISNUM( 1 ) )
lRecs = hb_parnl( 1 ) ;
if( nRecs == 0 )
{
if( SELF_SKIP( pArea, 0 ) != SUCCESS )
return;
}
else if( nRecs > 0 && !bBEof )
{
while( nSkipped < nRecs )
if( lRecs == 0 )
SELF_SKIP( pArea, 0 );
else if( lRecs > 0 )
{
if( SELF_SKIP( pArea, 1 ) != SUCCESS )
return;
if( SELF_EOF( pArea, &bBEof ) != SUCCESS )
return;
if( bBEof )
if( SELF_EOF( pArea, &fBEof ) == SUCCESS )
{
while( lSkipped < lRecs )
{
if( SELF_SKIP( pArea, 1 ) != SUCCESS )
break;
if( SELF_EOF( pArea, &fBEof ) != SUCCESS )
break;
if( fBEof )
{
SELF_SKIP( pArea, -1 );
break;
}
lSkipped++;
}
}
}
else /* if( lRecs < 0 ) */
{
while( lSkipped > lRecs )
{
if( SELF_SKIP( pArea, -1 ) != SUCCESS )
return;
nRecs = nSkipped ;
}
else
{
nSkipped++ ;
break;
if( SELF_BOF( pArea, &fBEof ) != SUCCESS )
break;
if( fBEof )
break;
lSkipped--;
}
}
hb_retnl( lSkipped );
}
else if( nRecs < 0 )
{
while( nSkipped > nRecs )
{
if( SELF_SKIP( pArea, -1 ) != SUCCESS )
return;
if( SELF_BOF( pArea, &bBEof ) != SUCCESS )
return;
if( bBEof )
{
nRecs = nSkipped ;
}
else
{
nSkipped-- ;
}
}
}
hb_retnl( nSkipped );
}
else
hb_errRT_DBCMD( EG_NOTABLE, EDBCMD_NOTABLE, NULL, "DBSKIPPER" );

1
harbour/source/rtl/Makefile
View File

@@ -151,6 +151,7 @@ PRG_SOURCES=\
dbedit.prg \
devoutp.prg \
dircmd.prg \
einstvar.prg \
errorsys.prg \
fieldbl.prg \
getlist.prg \

7
harbour/source/rtl/browdb.prg
View File

@@ -54,12 +54,17 @@ FUNCTION TBrowseDB( nTop, nLeft, nBottom, nRight )
LOCAL oBrowse := TBrowseNew( nTop, nLeft, nBottom, nRight )
#ifdef HB_COMPAT_XPP
oBrowse:SkipBlock := { | nRecs | DbSkipper( nRecs ) }
#else
oBrowse:SkipBlock := { | nRecs | Skipped( nRecs ) }
#endif
oBrowse:GoTopBlock := { || dbGoTop() }
oBrowse:GoBottomBlock := { || dbGoBottom() }
RETURN oBrowse
#ifndef HB_COMPAT_XPP
STATIC FUNCTION Skipped( nRecs )
LOCAL nSkipped := 0
@@ -88,4 +93,4 @@ STATIC FUNCTION Skipped( nRecs )
ENDIF
RETURN nSkipped
#endif

425
harbour/source/rtl/browse.prg
View File

@@ -51,139 +51,394 @@
*/
#include "inkey.ch"
#include "setcurs.ch"
#include "box.ch"
function Browse( nTop, nLeft, nBottom, nRight )
FUNCTION Browse( nTop, nLeft, nBottom, nRight )
local oBrw
local cOldScreen
local n, nOldCursor
local nKey := 0
local lExit := .f.
local lGotKey := .f.
local bAction
LOCAL oBrw
LOCAL lExit, lGotKey, lAppend, lKeyPressed, lRefresh
LOCAL n, nOldCursor, nKey
LOCAL cOldScreen
LOCAL bAction
if ! Used()
return .f.
end
IF ! Used()
RETURN .F.
ENDIF
if PCount() < 4
lExit := lGotKey := lAppend := lKeyPressed := lRefresh := .F.
IF PCount() < 4
nTop := 1
nLeft := 0
nBottom := MaxRow()
nRight := MaxCol()
endif
ENDIF
nOldCursor := SetCursor( 0 )
DispBegin()
nOldCursor := SetCursor( SC_NONE )
cOldScreen := SaveScreen( nTop, nLeft, nBottom, nRight )
@ nTop, nLeft TO nBottom, nRight
@ nTop + 3, nLeft SAY Chr( 198 )
@ nTop + 3, nRight SAY Chr( 181 )
@ nTop + 1, nLeft + 1 SAY Space( nRight - nLeft - 1 )
DispBox( nTop, nLeft, nBottom, nRight, B_DOUBLE_SINGLE )
DispBox( nTop + 3, nLeft, nTop + 3, nLeft, chr( 198 ) )
DispBox( nTop + 3, nRight, nTop + 3, nRight, chr( 181 ) )
DispOutAt( nTop + 1, nLeft + 1, Space( nRight - nLeft - 1 ) )
oBrw := TBrowseDB( nTop + 2, nLeft + 1, nBottom - 1, nRight - 1 )
oBrw:HeadSep := " " + Chr( 205 )
oBrw:HeadSep := " " + Chr( 205 )
oBrw:SkipBlock := { | nRecs | Skipped( nRecs, lAppend ) }
for n := 1 to FCount()
FOR n := 1 to FCount()
oBrw:AddColumn( TBColumnNew( FieldName( n ), FieldBlock( FieldName( n ) ) ) )
next
NEXT
IF Eof()
DbGoTop()
ENDIF
oBrw:ForceStable()
while ! lExit
DispEnd()
if nKey == 0
while !oBrw:stabilize() .and. NextKey() == 0
enddo
endif
IF LastRec() == 0
nKey := K_DOWN
lKeyPressed := .T.
ENDIF
if NextKey() == 0
WHILE ! lExit
oBrw:forceStable()
Statline( oBrw )
WHILE ! lKeyPressed .AND. ! oBrw:Stabilize()
lKeyPressed := ( nKey := Inkey() ) != 0
ENDDO
nKey := Inkey( 0 )
IF ! lKeyPressed
if ( bAction := SetKey( nKey ) ) != nil
Eval( bAction, ProcName( 1 ), ProcLine( 1 ), "" )
loop
endif
else
nKey := Inkey()
endif
do case
case nKey == K_ESC
lExit := .t.
case nKey == K_UP
oBrw:Up()
case nKey == K_DOWN
IF oBrw:HitBottom() .AND. ( ! lAppend .OR. RecNo() != LastRec() + 1 )
IF lAppend
oBrw:RefreshCurrent()
oBrw:ForceStable()
dbGoBottom()
ELSE
lAppend := .T.
SetCursor( IIF( ReadInsert(), SC_INSERT, SC_NORMAL ) )
ENDIF
oBrw:Down()
oBrw:ForceStable()
oBrw:ColorRect( { oBrw:RowPos, 1, oBrw:RowPos, oBrw:ColCount() }, ;
{ 2, 2 } )
ENDIF
case nKey == K_END
oBrw:End()
StatLine( oBrw, lAppend )
case nKey == K_HOME
oBrw:Home()
oBrw:ForceStable()
case nKey == K_LEFT
nKey := InKey( 0 )
IF ( bAction := SetKey( nKey ) ) != NIL
Eval( bAction, ProcName( 1 ), ProcLine( 1 ), "")
LOOP
ENDIF
ELSE
lKeyPressed := .F.
ENDIF
SWITCH nKey
#ifdef HB_COMPAT_C53
CASE K_LBUTTONDOWN
CASE K_LDBLCLK
TBMOUSE( oBrw, MRow(), MCol() )
EXIT
#endif
#ifdef HB_EXTENSION
CASE K_MWFORWARD
#endif
CASE K_UP
IF lAppend
lRefresh := .T.
ELSE
oBrw:Up()
ENDIF
EXIT
#ifdef HB_EXTENSION
CASE K_MWBACKWARD
#endif
CASE K_DOWN
IF lAppend
oBrw:HitBottom( .T. )
ELSE
oBrw:Down()
ENDIF
EXIT
CASE K_PGUP
IF lAppend
lRefresh := .T.
ELSE
oBrw:PageUp()
ENDIF
EXIT
CASE K_PGDN
IF lAppend
oBrw:HitBottom( .T. )
ELSE
oBrw:PageDown()
ENDIF
EXIT
CASE K_CTRL_PGUP
IF lAppend
lRefresh := .T.
ELSE
oBrw:GoTop()
ENDIF
EXIT
CASE K_CTRL_PGDN
IF lAppend
lRefresh := .T.
ELSE
oBrw:GoBottom()
ENDIF
EXIT
CASE K_LEFT
oBrw:Left()
EXIT
case nKey == K_RIGHT
CASE K_RIGHT
oBrw:Right()
EXIT
case nKey == K_PGUP
oBrw:PageUp()
CASE K_HOME
oBrw:Home()
EXIT
case nKey == K_PGDN
oBrw:PageDown()
CASE K_END
oBrw:End()
EXIT
case nKey == K_CTRL_PGUP
oBrw:GoTop()
case nKey == K_CTRL_PGDN
oBrw:GoBottom()
case nKey == K_CTRL_LEFT
CASE K_CTRL_LEFT
oBrw:panLeft()
EXIT
case nKey == K_CTRL_RIGHT
CASE K_CTRL_RIGHT
oBrw:panRight()
EXIT
case nKey == K_CTRL_HOME
CASE K_CTRL_HOME
oBrw:panHome()
EXIT
case nKey == K_CTRL_END
CASE K_CTRL_END
oBrw:panEnd()
EXIT
endcase
end
CASE K_INS
IF lAppend
SetCursor( IIF( ReadInsert( ! ReadInsert() ), ;
SC_NORMAL, SC_INSERT ) )
ENDIF
EXIT
CASE K_DEL
IF RecNo() != LastRec() + 1
IF Deleted()
DbRecall()
ELSE
DbDelete()
ENDIF
ENDIF
EXIT
CASE K_ENTER
IF lAppend .OR. RecNo() != LastRec() + 1
lKeyPressed := ( nKey := DoGet( oBrw, lAppend ) ) != 0
ELSE
nKey := K_DOWN
lKeyPressed := .T.
ENDIF
EXIT
CASE K_ESC
lExit := .t.
EXIT
OTHERWISE
IF nKey >= 32 .AND. nKey <= 255
KEYBOARD Chr( nKey )
nKey := K_ENTER
lKeyPressed := .T.
ENDIF
EXIT
END
IF lRefresh
lRefresh := lAppend := .F.
FreshOrder( oBrw )
SetCursor( SC_NONE )
ENDIF
ENDDO
RestScreen( nTop, nLeft, nBottom, nRight, cOldScreen )
SetCursor( nOldCursor )
return .t.
RETURN .T.
static procedure Statline( oBrw )
STATIC FUNCTION StatLine( oBrw, lAppend )
local nTop := oBrw:nTop - 1
local nRight := oBrw:nRight
LOCAL nTop := oBrw:nTop - 1
LOCAL nRight := oBrw:nRight
@ nTop, nRight - 27 SAY "Record "
DispOutAt( nTop, nRight - 27, "Record " )
if LastRec() == 0
@ nTop, nRight - 20 SAY "<none> "
elseif RecNo() == LastRec() + 1
@ nTop, nRight - 40 SAY " "
@ nTop, nRight - 20 SAY " <new>"
else
@ nTop, nRight - 40 SAY iif( Deleted(), "<Deleted>", " " )
@ nTop, nRight - 20 SAY PadR( LTrim( Str( RecNo() ) ) + "/" +;
Ltrim( Str( LastRec() ) ), 16 ) +;
iif( oBrw:hitTop, "<bof>", " " )
endif
IF LastRec() == 0 .and. ! lAppend
DispOutAt( nTop, nRight - 20, "<none> " )
ELSEIF RecNo() == LastRec() + 1
DispOutAt( nTop, nRight - 40, " " )
DispOutAt( nTop, nRight - 20, " <new>" )
ELSE
DispOutAt( nTop, nRight - 40, IIF( Deleted(), "<Deleted>", " " ) )
DispOutAt( nTop, nRight - 20, PadR( LTrim( Str( RecNo() ) ) + "/" + ;
LTrim( Str( LastRec() ) ), 16 ) + ;
IIF( oBrw:HitTop(), "<bof>", " " ) )
ENDIF
return
RETURN NIL
STATIC FUNCTION DoGet( oBrw, lAppend )
LOCAL lScore, lExit, bIns, nCursor
LOCAL oCol, oGet
LOCAL cIndexKey, cForExp, xKeyValue
LOCAL lSuccess, nKey, xValue
oBrw:HitTop( .F. )
StatLine( oBrw, lAppend )
oBrw:ForceStable()
lScore := Set( _SET_SCOREBOARD, .F. )
lExit := Set( _SET_EXIT, .T. )
bIns := SetKey( K_INS, {|| SetCursor( IIF( ReadInsert( ! ReadInsert() ), ;
SC_NORMAL, SC_INSERT ) ) } )
nCursor := SetCursor( IIF( ReadInsert(), SC_INSERT, SC_NORMAL ) )
IF !Empty( cIndexKey := IndexKey( 0 ) )
xKeyValue := &cIndexKey
ENDIF
oCol := oBrw:GetColumn( oBrw:ColPos )
xValue := Eval( oCol:Block )
oGet := GetNew( Row(), Col(), ;
{ |xNewVal| IIF( PCount() == 0, xValue, xValue := xNewVal ) }, ;
"mGetVar", NIL, oBrw:ColorSpec )
lSuccess := .F.
IF ReadModal( { oGet } )
IF lAppend .AND. RecNo() == LastRec() + 1
dbAppend()
ENDIF
Eval( oCol:Block, xValue )
IF !lAppend .AND. !Empty( cForExp := OrdFor( IndexOrd() ) ) .AND. ;
! &cForExp
dbGoTop()
ENDIF
IF !lAppend .AND. !Empty( cIndexKey ) .AND. ! xKeyValue == &cIndexKey
lSuccess := .T.
ENDIF
ENDIF
IF lSuccess
FreshOrder( oBrw )
nKey := 0
ELSE
oBrw:RefreshCurrent()
nKey := ExitKey( lAppend )
ENDIF
IF lAppend
oBrw:ColorRect( { oBrw:rowpos, 1, oBrw:rowpos, oBrw:colcount }, ;
{ 2, 2 } )
ENDIF
SetCursor( nCursor )
SetKey( K_INS, bIns )
Set( _SET_EXIT, lExit )
Set( _SET_SCOREBOARD, lScore )
RETURN nKey
STATIC FUNCTION ExitKey( lAppend )
LOCAL nKey := LastKey()
SWITCH nKey
CASE K_PGDN
nKey := IIF( lAppend, 0, K_DOWN )
EXIT
CASE K_PGUP
nKey := IIF( lAppend, 0, K_UP )
CASE K_DOWN
CASE K_UP
EXIT
OTHERWISE
nKey := IIF( nKey == 13 .OR. ;
( nKey >= 32 .AND. nKey <= 255 ), K_RIGHT, 0 )
EXIT
END
RETURN nKey
STATIC FUNCTION FreshOrder( oBrw )
LOCAL nRec := RecNo()
oBrw:RefreshAll()
oBrw:ForceStable()
IF nRec != LastRec() + 1
WHILE RecNo() != nRec .AND. !BOF()
oBrw:Up()
oBrw:ForceStable()
ENDDO
ENDIF
RETURN NIL
STATIC FUNCTION Skipped( nRecs, lAppend )
LOCAL nSkipped := 0
IF LastRec() != 0
IF nRecs == 0
dbSkip( 0 )
ELSEIF nRecs > 0 .AND. RecNo() != LastRec() + 1
DO WHILE nSkipped < nRecs
dbSkip()
IF Eof()
IF lAppend
nSkipped++
ELSE
dbSkip( -1 )
ENDIF
EXIT
ENDIF
nSkipped++
ENDDO
ELSEIF nRecs < 0
DO WHILE nSkipped > nRecs
dbSkip( -1 )
IF Bof()
EXIT
ENDIF
nSkipped--
ENDDO
ENDIF
ENDIF
RETURN nSkipped

77
harbour/source/rtl/einstvar.prg Normal file
View File

@@ -0,0 +1,77 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Undocumented CA-Cl*pper function used to validate
* instance variable type in assign messages.
*
* Copyright 2007 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* 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"
FUNCTION _eInstVar( oVar, cMethod, xValue, cType, nSubCode, bValid )
LOCAL oError
IF VALTYPE( xValue ) != cType .OR. ;
( bValid != NIL .AND. !EVAL( bValid, oVar, xValue ) )
oError := errornew()
oError:description := HB_LANGERRMSG( 1 )
oError:gencode := 1
oError:severity := 2
oError:cansubstitute := .T.
oError:subsystem := oVar:classname
oError:operation := cMethod
oError:subcode := nSubCode
oError:args := { xValue }
xValue := EVAL( ERRORBLOCK(), oError )
IF VALTYPE( xValue ) != cType
__errInHandler()
ENDIF
ENDIF
RETURN xValue

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

@@ -715,7 +715,7 @@ HB_EXPORT BOOL hb_arraySetND( PHB_ITEM pArray, ULONG ulIndex, double dNumber )
return FALSE;
}
HB_EXPORT BOOL hb_arraySetC( PHB_ITEM pArray, ULONG ulIndex, char * szText )
HB_EXPORT BOOL hb_arraySetC( PHB_ITEM pArray, ULONG ulIndex, const char * szText )
{
HB_TRACE(HB_TR_DEBUG, ("hb_arraySetC(%p, %lu, %p)", pArray, ulIndex, szText));
@@ -728,7 +728,7 @@ HB_EXPORT BOOL hb_arraySetC( PHB_ITEM pArray, ULONG ulIndex, char * szText )
return FALSE;
}
HB_EXPORT BOOL hb_arraySetCL( PHB_ITEM pArray, ULONG ulIndex, char * szText, ULONG ulLen )
HB_EXPORT BOOL hb_arraySetCL( PHB_ITEM pArray, ULONG ulIndex, const char * szText, ULONG ulLen )
{
HB_TRACE(HB_TR_DEBUG, ("hb_arraySetC(%p, %lu, %p, %lu)", pArray, ulIndex, szText, ulLen));