diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 56336d66ad..82998b5f02 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,19 @@ +19991208-01:59 GMT+1 Victor Szel + * 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 diff --git a/harbour/source/rtl/arrays.c b/harbour/source/rtl/arrays.c index b2a4b0556d..4116413ea2 100644 --- a/harbour/source/rtl/arrays.c +++ b/harbour/source/rtl/arrays.c @@ -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 ) diff --git a/harbour/source/rtl/errorsys.prg b/harbour/source/rtl/errorsys.prg index 602658cf23..4929ea6ca4 100644 --- a/harbour/source/rtl/errorsys.prg +++ b/harbour/source/rtl/errorsys.prg @@ -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 + * 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 diff --git a/harbour/source/rtl/fieldbl.prg b/harbour/source/rtl/fieldbl.prg index 9134b39141..ba2de97b12 100644 --- a/harbour/source/rtl/fieldbl.prg +++ b/harbour/source/rtl/fieldbl.prg @@ -33,8 +33,67 @@ * */ +/* + * The following parts are Copyright of the individual authors. + * www - http://www.harbour-project.org + * + * Copyright 1999 Chen Kedem + * 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( ) --> bFieldBlock + * $ARGUMENTS$ + * 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 + * 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 + * 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 + * 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( , ) --> bFieldBlock + * $ARGUMENTS$ + * is a string that contain the field name. + * + * is the work area number in which 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 is not specified or from type other than + * character, or if 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 in work area number , 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 + * 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 ) diff --git a/harbour/tests/regress/rt_array.prg b/harbour/tests/regress/rt_array.prg index c84f3e1462..33731587b4 100644 --- a/harbour/tests/regress/rt_array.prg +++ b/harbour/tests/regress/rt_array.prg @@ -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() */