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

19991208-01:59 GMT+1 Victor Szel <info@szelvesz.hu>

Browse Source
This commit is contained in:
Viktor Szakats
1999-12-08 02:15:56 +00:00
parent 6e4d8826ef
commit c4a9634b18
5 changed files with 222 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
harbour/ChangeLog
View File

@@ -1,3 +1,19 @@
19991208-01:59 GMT+1 Victor Szel <info@szelvesz.hu>
* source/rtl/arrays.c
+ Added C53 compatible error message to ASIZE()
! Fixed a bug in ACOPY() which was also fixed in CA-Cl*pper 5.3a,
this was previously implemented then removed as STRICT mode. Note that
there's still a small anomaly left in ACOPY().
* tests/regress/rt_array.prg
! Fixed the expected result for ASIZE() (w/o param)
* Changed expected results for some ACOPY() tests.
* source/rtl/errorsys.prg
+ EG_OPEN and EG_APPENDLOCK errors are handled in the Clipper way.
* source/rtl/errorsys.prg
+ ERRORSYS() documentation by Chen Kedem added
* source/rtl/fieldbl.prg
+ FIELD*BLOCK() documentation by Chen Kedem added
19991207-20:25 GMT+3 Alexander Kresin
* source/pp/hbpp.c
* some changes, related to '@ ... clear to ...' problem

23
harbour/source/rtl/arrays.c
View File

@@ -655,6 +655,9 @@ BOOL hb_arrayRelease( PHB_ITEM pArray )
return FALSE;
}
/* NOTE: CA-Cl*pper 5.3a has a fix for the case when the starting position
is greater than the length of the array. */
BOOL hb_arrayCopy( PHB_ITEM pSrcArray, PHB_ITEM pDstArray, ULONG * pulStart,
ULONG * pulCount, ULONG * pulTarget )
{
@@ -680,20 +683,31 @@ BOOL hb_arrayCopy( PHB_ITEM pSrcArray, PHB_ITEM pDstArray, ULONG * pulStart,
else
ulTarget = 1;
#ifdef HB_COMPAT_C53 /* From CA-Cl*pper 5.3a */
if( ulStart <= ulSrcLen )
#else
if( ulSrcLen > 0 )
#endif
{
#ifndef HB_COMPAT_C53 /* From CA-Cl*pper 5.3a */
if( ulStart > ulSrcLen )
ulStart = ulSrcLen;
#endif
if( pulCount && ( *pulCount <= ulSrcLen - ulStart ) )
ulCount = *pulCount;
else
ulCount = ulSrcLen - ulStart + 1;
/* This is probably a bug, present in all versions of CA-Cl*pper. */
#ifdef HB_FIX_ACOPY_BUG
if( ulTarget <= ulDstLen )
{
#else
if( ulDstLen > 0 )
{
if( ulTarget > ulDstLen )
ulTarget = ulDstLen;
#endif
if( ulCount > ulDstLen - ulTarget )
ulCount = ulDstLen - ulTarget + 1;
@@ -828,6 +842,9 @@ HARBOUR HB_AADD( void )
}
}
/* NOTE: CA-Cl*pper 5.3 and older will return NIL on bad parameter, 5.3a,b
will throw a runtime error. */
HARBOUR HB_ASIZE( void )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
@@ -840,6 +857,10 @@ HARBOUR HB_ASIZE( void )
hb_itemReturn( pArray ); /* ASize() returns the array itself */
}
#ifdef HB_COMPAT_C53 /* From CA-Cl*pper 5.3a */
else
hb_errRT_BASE( EG_ARG, 2023, NULL, "ASIZE" );
#endif
}
HARBOUR HB_ATAIL( void )

64
harbour/source/rtl/errorsys.prg
View File

@@ -33,11 +33,48 @@
*
*/
// Standard Harbour ErrorSys system
/*
* The following parts are Copyright of the individual authors.
* www - http://www.harbour-project.org
*
* Copyright 1999 Chen Kedem <niki@actcom.co.il>
* ERRORSYS() documentation
*
* See doc/license.txt for licensing terms.
*
*/
#include "common.ch"
#include "error.ch"
/* $DOC$
* $FUNCNAME$
* ERRORSYS()
* $CATEGORY$
* Error recovery
* $ONELINER$
* Install default error handler
* $SYNTAX$
* ERRORSYS() --> NIL
* $ARGUMENTS$
* none.
* $RETURNS$
* ERRORSYS() always return NIL.
* $DESCRIPTION$
* ERRORSYS() is called upon startup by Harbour and install the default
* error handler. Normally you should not call this function directly,
* instead use ERRORBLOCK() to install your own error handler.
* $EXAMPLES$
* $TESTS$
* $STATUS$
* R
* $COMPLIANCE$
* ERRORSYS() works exactly like CA-Clipper's ERRORSYS().
* $SEEALSO$
* ERRORBLOCK(), Error class
* $END$
*/
PROCEDURE ErrorSys
ErrorBlock( { | oError | DefError( oError ) } )
@@ -57,21 +94,36 @@ STATIC FUNCTION DefError( oError )
RETURN 0
ENDIF
// Set NetErr() of there was a database open error
IF oError:genCode == EG_OPEN .AND. ;
oError:osCode == 32 .AND. ;
oError:canDefault
NetErr( .T. )
RETURN .F.
ENDIF
// Set NetErr() if there was a lock error on dbAppend()
IF oError:genCode == EG_APPENDLOCK .AND. ;
oError:canDefault
NetErr( .T. )
RETURN .F.
ENDIF
cMessage := ErrorMessage( oError )
// Build buttons
aOptions := {}
// aAdd( aOptions, "Break" )
aAdd( aOptions, "Quit" )
// AAdd( aOptions, "Break" )
AAdd( aOptions, "Quit" )
IF oError:canRetry
aAdd( aOptions, "Retry" )
AAdd( aOptions, "Retry" )
ENDIF
IF oError:canDefault
aAdd( aOptions, "Default" )
AAdd( aOptions, "Default" )
ENDIF
// Show alert box
@@ -118,7 +170,7 @@ STATIC FUNCTION DefError( oError )
// [vszel]
STATIC FUNCTION ErrorMessage(oError)
STATIC FUNCTION ErrorMessage( oError )
LOCAL cMessage
// start error message

116
harbour/source/rtl/fieldbl.prg
View File

@@ -33,8 +33,67 @@
*
*/
/*
* The following parts are Copyright of the individual authors.
* www - http://www.harbour-project.org
*
* Copyright 1999 Chen Kedem <niki@actcom.co.il>
* FIELDBLOCK() documentation
* FIELDWBLOCK() documentation
*
* See doc/license.txt for licensing terms.
*
*/
#include "common.ch"
/* $DOC$
* $FUNCNAME$
* FIELDBLOCK()
* $CATEGORY$
* Code block manipulation / Databases
* $ONELINER$
* Return a code block that sets/gets a value for a given field
* $SYNTAX$
* FIELDBLOCK( <cFieldName> ) --> bFieldBlock
* $ARGUMENTS$
* <cFieldName> is a string that contain the field name.
* $RETURNS$
* FIELDBLOCK() return a code block that when evaluate could retrieve
* field value or assigning a new value to the field. If <cFieldName>
* is not specified or from type other than character, FIELDBLOCK()
* return NIL.
* $DESCRIPTION$
* FIELDBLOCK() return a code block that sets/gets the value of field.
* When this code block is evaluated without any parameters passed then
* it returns the current value of the given field. If the code block
* is evaluated with a parameter, than its value is used to set a new
* value to the field, this value is also return by the block. If the
* block is evaluate and there is no field with the name <cFieldName>
* in the current work area, the code block return NIL.
*
* Note that FIELDBLOCK() works on the current work area, if you need
* a specific work area code block use FIELDWBLOCK() instead.
* $EXAMPLES$
* // open a file named Test that have a field named "name"
* LOCAL bField
* bFiled := FIELDBLOCK( "name" )
* USE Test
* ? 'Original value of field "name" :', EVAL( bField )
* EVAL( bField, "Mr X new name" )
* ? 'New value for the field "name" :', EVAL( bField )
* $TESTS$
* $STATUS$
* $COMPLIANCE$
* If the block is evaluate and there is no field with the name
* <cFieldName> in the current work area, the code block return NIL.
*
* CA-Clipper would raise BASE/1003 error if the field does not exist.
* $SEEALSO$
* EVAL(), FIELDWBLOCK(), MEMVARBLOCK()
* $END$
*/
FUNCTION FIELDBLOCK( cFieldName )
IF ISCHARACTER( cFieldName )
@@ -44,6 +103,63 @@ FUNCTION FIELDBLOCK( cFieldName )
RETURN NIL
/* $DOC$
* $FUNCNAME$
* FIELDWBLOCK()
* $CATEGORY$
* Code block manipulation / Databases
* $ONELINER$
* Return a sets/gets code block for field in a given work area
* $SYNTAX$
* FIELDWBLOCK( <cFieldName>, <nWorkArea> ) --> bFieldBlock
* $ARGUMENTS$
* <cFieldName> is a string that contain the field name.
*
* <nWorkArea> is the work area number in which <cFieldName> exist.
* $RETURNS$
* FIELDWBLOCK() return a code block that when evaluate could retrieve
* field value or assigning a new value for a field in a given work
* area. If <cFieldName> is not specified or from type other than
* character, or if <nWorkArea> is not specified or is not numeric
* FIELDWBLOCK() return NIL.
* $DESCRIPTION$
* FIELDWBLOCK() return a code block that sets/gets the value of field
* from a given work area. When this code block is evaluated without
* any parameters passed then it returns the current value of the given
* field. If the code block is evaluated with a parameter, than its
* value is used to set a new value to the field, this value is also
* return by the block. If the block is evaluate and there is no field
* with the name <cFieldName> in work area number <nWorkArea>, the code
* block return NIL.
* $EXAMPLES$
* LOCAL bField
* // this block work on the field "name" that exist on work area 2
* bFiled := FIELDBLOCK( "name", 2 )
* // open a file named One in work area 1
* // that have a field named "name"
* SELECT 1
* USE One
* // open a file named Two in work area 2
* // it also have a field named "name"
* SELECT 2
* USE Two
* SELECT 1
* ? "Original names: ", One->name, Two->name
* ? "Name value for file Two :", EVAL( bField )
* EVAL( bField, "Two has new name" )
* ? "and now: ", One->name, Two->name
* $TESTS$
* $STATUS$
* $COMPLIANCE$
* If the block is evaluate and there is no field with the name
* <cFieldName> in the given work area, the code block return NIL.
*
* CA-Clipper would raise BASE/1003 error if the field does not exist.
* $SEEALSO$
* EVAL(), FIELDBLOCK(), MEMVARBLOCK()
* $END$
*/
FUNCTION FIELDWBLOCK( cFieldName, nWorkArea )
IF ISCHARACTER( cFieldName ) .AND. ISNUMBER( nWorkArea )

20
harbour/tests/regress/rt_array.prg
View File

@@ -214,7 +214,7 @@ FUNCTION Main_ARRAY()
TEST_LINE( aTail( {} ) , NIL )
TEST_LINE( aTail( { 1, 2 } ) , 2 )
TEST_LINE( aTail( ErrorNew() ) , NIL )
TEST_LINE( aSize() , NIL )
TEST_LINE( aSize() , "E BASE 2023 Argument error ASIZE " )
TEST_LINE( aSize( NIL ) , "E BASE 2023 Argument error ASIZE " )
TEST_LINE( aSize( {} ) , "E BASE 2023 Argument error ASIZE " )
TEST_LINE( aSize( ErrorNew() ) , "E BASE 2023 Argument error ASIZE " )
@@ -300,10 +300,10 @@ FUNCTION Main_ARRAY()
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 3, 0 )) , ".........." )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 3, 3 )) , "CDE......." )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 3, 20 )) , "CDEFGHIJ.." )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21 )) , "J........." ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21 )) , ".........." ) /* Bug in CA-Cl*pper, it will return: "J.........", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 0 )) , ".........." )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3 )) , "J........." ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 20 )) , "J........." ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3 )) , ".........." ) /* Bug in CA-Cl*pper, it will return: "J.........", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 20 )) , ".........." ) /* Bug in CA-Cl*pper, it will return: "J.........", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 1,NIL, 1)) , "ABCDEFGHIJ" )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 1, 0, 1)) , ".........." )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 1, 3, 0)) , "ABC......." )
@@ -318,13 +318,13 @@ FUNCTION Main_ARRAY()
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 3, 3, 8)) , ".......CDE" )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 3, 3, 20)) , ".........C" ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 3, 20, 3)) , "..CDEFGHIJ" )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21,NIL, 21)) , ".........J" ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21,NIL, 21)) , ".........." ) /* Bug in CA-Cl*pper, it will return: ".........J", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 0, 21)) , ".........." )
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 0)) , "J........." ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 2)) , ".J........" ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 8)) , ".......J.." ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 20)) , ".........J" ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 20, 21)) , ".........J" ) /* Strange in CA-Cl*pper, it should return: ".........." */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 0)) , ".........." ) /* Bug in CA-Cl*pper, it will return: "J.........", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 2)) , ".........." ) /* Bug in CA-Cl*pper, it will return: ".J........", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 8)) , ".........." ) /* Bug in CA-Cl*pper, it will return: ".......J..", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 3, 20)) , ".........." ) /* Bug in CA-Cl*pper, it will return: ".........J", fixed in 5.3a */
TEST_LINE( TAStr(aCopy(TARng(),TANew(), 21, 20, 21)) , ".........." ) /* Bug in CA-Cl*pper, it will return: ".........J", fixed in 5.3a */
/* ASORT() */