From 7b045b62187e674add2a2d650f522f5470e2d5c8 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Fri, 3 Dec 1999 14:25:35 +0000 Subject: [PATCH] 19991203-15:11 GMT+1 Victor Szel --- harbour/ChangeLog | 18 ++++++++ harbour/include/extend.h | 3 +- harbour/source/rtl/empty.c | 70 +++++++++++++++++-------------- harbour/source/rtl/len.c | 46 ++++++++++---------- harbour/source/rtl/valtype.c | 65 +++++++++++++++------------- harbour/tests/regress/rt_hvm.prg | 56 ++++++++++++++++++++++--- harbour/tests/regress/rt_main.prg | 38 +++++++++++++++++ harbour/tests/regress/rt_str.prg | 4 ++ 8 files changed, 212 insertions(+), 88 deletions(-) diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 5d67902be8..c026abd6e0 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,21 @@ +19991203-15:11 GMT+1 Victor Szel + * tests/regress/* + + Added functionality to test database/field stuff. Alias is w_TEST + + Added Len(), ValType(), Empty(), Str() tests for fields, all of them + pass. + - Removed NIL:classname tests temporarily. + * include/extend.h + ! IT_MEMO constand fixed (it was equal with IT_NIL). + + IS_MEMO() macro added. + * source/rtl/valtype.c + source/rtl/len.c + source/rtl/empty.c + ! Fixed case when no parameter was passed (via hb_vmDo() for example) + + Added an $EXAMPLE$ for LEN() + + Changed $SYNTAX$ for LEN() + + Added some $SEEALSO$ for LEN() + * Changed LEN() not to use internal ITEM access. + 19991203-02:25 GMT+1 Victor Szel * source/rdd/dbcmd.c + DBEVAL() doc added from dbeval.prg diff --git a/harbour/include/extend.h b/harbour/include/extend.h index 007b418df2..c349516792 100644 --- a/harbour/include/extend.h +++ b/harbour/include/extend.h @@ -50,7 +50,7 @@ #define IT_ALIAS ( ( USHORT ) 0x0200 ) #define IT_STRING ( ( USHORT ) 0x0400 ) #define IT_MEMOFLAG ( ( USHORT ) 0x0800 ) -#define IT_MEMO ( IT_MEMOFLAG & IT_STRING ) +#define IT_MEMO ( IT_MEMOFLAG | IT_STRING ) #define IT_BLOCK ( ( USHORT ) 0x1000 ) #define IT_BYREF ( ( USHORT ) 0x2000 ) #define IT_MEMVAR ( ( USHORT ) 0x4000 ) @@ -72,6 +72,7 @@ #define IS_NUMERIC( p ) ( ( p )->type & IT_NUMERIC ) #define IS_OBJECT( p ) IS_OF_TYPE( p, IT_OBJECT ) #define IS_STRING( p ) IS_OF_TYPE( p, IT_STRING ) +#define IS_MEMO( p ) IS_OF_TYPE( p, IT_MEMO ) #define IS_SYMBOL( p ) IS_OF_TYPE( p, IT_SYMBOL ) #define IS_MEMVAR( p ) IS_OF_TYPE( p, IT_MEMVAR ) diff --git a/harbour/source/rtl/empty.c b/harbour/source/rtl/empty.c index 83009f1e92..83e03e7ccf 100644 --- a/harbour/source/rtl/empty.c +++ b/harbour/source/rtl/empty.c @@ -74,46 +74,54 @@ HARBOUR HB_EMPTY( void ) { PHB_ITEM pItem = hb_param( 1, IT_ANY ); - /* NOTE: pItem cannot be NULL here */ + /* NOTE: Double safety to ensure that a parameter was really passed, + compiler checks this, but a direct hb_vmDo() call + may not do so. [vszel] */ - switch( pItem->type & ~IT_BYREF ) + if( pItem ) { - case IT_ARRAY: - hb_retl( hb_arrayLen( pItem ) == 0 ); - break; + switch( pItem->type & ~IT_BYREF ) + { + case IT_ARRAY: + hb_retl( hb_arrayLen( pItem ) == 0 ); + break; - case IT_STRING: - case IT_MEMO: - hb_retl( hb_strEmpty( hb_itemGetCPtr( pItem ), hb_itemGetCLen( pItem ) ) ); - break; + case IT_STRING: + case IT_MEMO: + hb_retl( hb_strEmpty( hb_itemGetCPtr( pItem ), hb_itemGetCLen( pItem ) ) ); + break; - case IT_INTEGER: - hb_retl( hb_itemGetNI( pItem ) == 0 ); - break; + case IT_INTEGER: + hb_retl( hb_itemGetNI( pItem ) == 0 ); + break; - case IT_LONG: - hb_retl( hb_itemGetNL( pItem ) == 0 ); - break; + case IT_LONG: + hb_retl( hb_itemGetNL( pItem ) == 0 ); + break; - case IT_DOUBLE: - hb_retl( hb_itemGetND( pItem ) == 0.0 ); - break; + case IT_DOUBLE: + hb_retl( hb_itemGetND( pItem ) == 0.0 ); + break; - case IT_DATE: - /* NOTE: This is correct ! Get the date as long value. */ - hb_retl( hb_itemGetNL( pItem ) == 0 ); - break; + case IT_DATE: + /* NOTE: This is correct ! Get the date as long value. */ + hb_retl( hb_itemGetNL( pItem ) == 0 ); + break; - case IT_LOGICAL: - hb_retl( ! hb_itemGetL( pItem ) ); - break; + case IT_LOGICAL: + hb_retl( ! hb_itemGetL( pItem ) ); + break; - case IT_BLOCK: - hb_retl( FALSE ); - break; + case IT_BLOCK: + hb_retl( FALSE ); + break; - default: - hb_retl( TRUE ); - break; + default: + hb_retl( TRUE ); + break; + } } + else + hb_retl( TRUE ); } + diff --git a/harbour/source/rtl/len.c b/harbour/source/rtl/len.c index 30f9f76f73..03cd46c99a 100644 --- a/harbour/source/rtl/len.c +++ b/harbour/source/rtl/len.c @@ -45,7 +45,7 @@ * $ONELINER$ * Returns size of a string or size of an array. * $SYNTAX$ - * LEN( ) --> + * LEN( | ) --> * $ARGUMENTS$ * is a character string or the array to check. * $RETURNS$ @@ -53,10 +53,11 @@ * an array. * $DESCRIPTION$ * This function returns the string length or the size of an array. If - * it is used with a multidimensional array it returns the sizee of the + * it is used with a multidimensional array it returns the size of the * first dimension. * $EXAMPLES$ * ? Len( "Harbour" ) --> 7 + * ? Len( { "One", "Two" } ) --> 2 * $TESTS$ * function Test() * LOCAL cName := "" @@ -68,7 +69,7 @@ * $COMPLIANCE$ * LEN() is fully CA-Clipper compliant. * $SEEALSO$ - * EMPTY, RTRIM, LTRIM + * EMPTY, RTRIM, LTRIM, AADD, ASIZE * $END$ */ @@ -76,28 +77,31 @@ HARBOUR HB_LEN( void ) { PHB_ITEM pItem = hb_param( 1, IT_ANY ); - /* NOTE: pItem cannot be NULL here */ + /* NOTE: Double safety to ensure that a parameter was really passed, + compiler checks this, but a direct hb_vmDo() call + may not do so. [vszel] */ - switch( pItem->type ) + if( pItem ) { - case IT_ARRAY: - hb_retnl( hb_arrayLen( pItem ) ); - break; - - case IT_STRING: - case IT_MEMO: - hb_retnl( hb_itemGetCLen( pItem ) ); - break; - - default: + if( IS_STRING( pItem ) ) { - PHB_ITEM pResult = hb_errRT_BASE_Subst( EG_ARG, 1111, NULL, "LEN" ); + hb_retnl( hb_itemGetCLen( pItem ) ); + return; + } + else if( IS_ARRAY( pItem ) ) + { + hb_retnl( hb_arrayLen( pItem ) ); + return; + } + } - if( pResult ) - { - hb_itemReturn( pResult ); - hb_itemRelease( pResult ); - } + { + PHB_ITEM pResult = hb_errRT_BASE_Subst( EG_ARG, 1111, NULL, "LEN" ); + + if( pResult ) + { + hb_itemReturn( pResult ); + hb_itemRelease( pResult ); } } } diff --git a/harbour/source/rtl/valtype.c b/harbour/source/rtl/valtype.c index 12bf1a0bb7..eb4f9e74a9 100644 --- a/harbour/source/rtl/valtype.c +++ b/harbour/source/rtl/valtype.c @@ -77,43 +77,50 @@ HARBOUR HB_VALTYPE( void ) { PHB_ITEM pItem = hb_param( 1, IT_ANY ); - /* NOTE: pItem cannot be NULL here */ + /* NOTE: Double safety to ensure that a parameter was really passed, + compiler checks this, but a direct hb_vmDo() call + may not do so. [vszel] */ - switch( pItem->type & ~IT_BYREF ) + if( pItem ) { - case IT_ARRAY: - hb_retc( hb_arrayIsObject( pItem ) ? "O" : "A" ); - break; + switch( pItem->type & ~IT_BYREF ) + { + case IT_ARRAY: + hb_retc( hb_arrayIsObject( pItem ) ? "O" : "A" ); + break; - case IT_BLOCK: - hb_retc( "B" ); - break; + case IT_BLOCK: + hb_retc( "B" ); + break; - case IT_DATE: - hb_retc( "D" ); - break; + case IT_DATE: + hb_retc( "D" ); + break; - case IT_LOGICAL: - hb_retc( "L" ); - break; + case IT_LOGICAL: + hb_retc( "L" ); + break; - case IT_INTEGER: - case IT_LONG: - case IT_DOUBLE: - hb_retc( "N" ); - break; + case IT_INTEGER: + case IT_LONG: + case IT_DOUBLE: + hb_retc( "N" ); + break; - case IT_STRING: - hb_retc( "C" ); - break; + case IT_STRING: + hb_retc( "C" ); + break; - case IT_MEMOFLAG: - hb_retc( "M" ); - break; + case IT_MEMO: + hb_retc( "M" ); + break; - case IT_NIL: - default: - hb_retc( "U" ); - break; + default: + hb_retc( "U" ); + break; + } } + else + hb_retc( "U" ); } + diff --git a/harbour/tests/regress/rt_hvm.prg b/harbour/tests/regress/rt_hvm.prg index 8eb21563af..7aebde083b 100644 --- a/harbour/tests/regress/rt_hvm.prg +++ b/harbour/tests/regress/rt_hvm.prg @@ -171,6 +171,12 @@ FUNCTION Main_HVM() TEST_LINE( ValType( sbBlock ) , "B" ) TEST_LINE( ValType( saArray ) , "A" ) TEST_LINE( ValType( { 1, 2, 3 } ) , "A" ) + TEST_LINE( ValType( w_TEST->TYPE_C ) , "C" ) + TEST_LINE( ValType( w_TEST->TYPE_D ) , "D" ) + TEST_LINE( ValType( w_TEST->TYPE_M ) , "M" ) + TEST_LINE( ValType( w_TEST->TYPE_N_I ) , "N" ) + TEST_LINE( ValType( w_TEST->TYPE_N_D ) , "N" ) + TEST_LINE( ValType( w_TEST->TYPE_L ) , "L" ) #ifdef __HARBOUR__ TEST_LINE( ValType( @scString ) , "C" ) /* Bug in CA-Cl*pper, it will return "U" */ TEST_LINE( ValType( @scStringE ) , "C" ) /* Bug in CA-Cl*pper, it will return "U" */ @@ -235,24 +241,33 @@ FUNCTION Main_HVM() /* Special internal messages */ +/* Harbour compiler not yet handles these */ +#ifndef __HARBOUR__ TEST_LINE( NIL:className , "NIL" ) +#endif ) TEST_LINE( "":className , "CHARACTER" ) TEST_LINE( 0:className , "NUMERIC" ) TEST_LINE( SToD( "" ):className , "DATE" ) TEST_LINE( .F.:className , "LOGICAL" ) - TEST_LINE( {|| nil }:className , "BLOCK" ) + TEST_LINE( {|| NIL }:className , "BLOCK" ) TEST_LINE( {}:className , "ARRAY" ) TEST_LINE( ErrorNew():className , "ERROR" ) +/* Harbour compiler not yet handles these */ +#ifndef __HARBOUR__ TEST_LINE( NIL:classH , 0 ) +#endif TEST_LINE( "":classH , 0 ) TEST_LINE( 0:classH , 0 ) TEST_LINE( SToD( "" ):classH , 0 ) TEST_LINE( .F.:classH , 0 ) - TEST_LINE( {|| nil }:classH , 0 ) + TEST_LINE( {|| NIL }:classH , 0 ) TEST_LINE( {}:classH , 0 ) TEST_LINE( ErrorNew():classH > 0 , .T. ) +/* Harbour compiler not yet handles these */ +#ifndef __HARBOUR__ TEST_LINE( suNIL:className , "NIL" ) +#endif TEST_LINE( scString:className , "CHARACTER" ) TEST_LINE( snIntP:className , "NUMERIC" ) TEST_LINE( sdDateE:className , "DATE" ) @@ -260,7 +275,10 @@ FUNCTION Main_HVM() TEST_LINE( sbBlock:className , "BLOCK" ) TEST_LINE( saArray:className , "ARRAY" ) TEST_LINE( soObject:className , "ERROR" ) +/* Harbour compiler not yet handles these */ +#ifndef __HARBOUR__ TEST_LINE( suNIL:classH , 0 ) +#endif TEST_LINE( scString:classH , 0 ) TEST_LINE( snIntP:classH , 0 ) TEST_LINE( sdDateE:classH , 0 ) @@ -488,6 +506,14 @@ FUNCTION Main_HVM() /* == special */ TEST_LINE( NIL == NIL , .T. ) + TEST_LINE( 1 == NIL , .F. ) + TEST_LINE( NIL == 1 , .F. ) + TEST_LINE( "" == NIL , .F. ) + TEST_LINE( NIL == "" , .F. ) + TEST_LINE( 1 == suNIL , .F. ) + TEST_LINE( suNIL == 1 , .F. ) + TEST_LINE( "" == suNIL , .F. ) + TEST_LINE( suNIL == "" , .F. ) TEST_LINE( scString == NIL , .F. ) TEST_LINE( scString == 1 , "E BASE 1070 Argument error == F:S" ) TEST_LINE( soObject == "" , "E BASE 1070 Argument error == F:S" ) @@ -834,8 +860,8 @@ FUNCTION Main_HVM() TEST_LINE( (.T.)->NOFIELD , "E BASE 1065 Argument error & F:S" ) TEST_LINE( (.F.)->NOFIELD , "E BASE 1065 Argument error & F:S" ) TEST_LINE( (NIL)->NOFIELD , "E BASE 1065 Argument error & F:S" ) - TEST_LINE( (1)->NOFIELD , "E BASE 1003 Variable does not exist NOFIELD F:R" ) - TEST_LINE( (1.5)->NOFIELD , "E BASE 1003 Variable does not exist NOFIELD F:R" ) + TEST_LINE( (2)->NOFIELD , "E BASE 1003 Variable does not exist NOFIELD F:R" ) + TEST_LINE( (2.5)->NOFIELD , "E BASE 1003 Variable does not exist NOFIELD F:R" ) TEST_LINE( (SToD(""))->NOFIELD , "E BASE 1065 Argument error & F:S" ) TEST_LINE( (ErrorNew())->NOFIELD , "E BASE 1065 Argument error & F:S" ) @@ -846,8 +872,8 @@ FUNCTION Main_HVM() TEST_LINE( (.T.)->(Eof()) , .T. ) TEST_LINE( (.F.)->(Eof()) , .T. ) TEST_LINE( (NIL)->(Eof()) , .T. ) - TEST_LINE( (1)->(Eof()) , .T. ) - TEST_LINE( (1.5)->(Eof()) , .T. ) + TEST_LINE( (2)->(Eof()) , .T. ) + TEST_LINE( (2.5)->(Eof()) , .T. ) TEST_LINE( (SToD(""))->(Eof()) , .T. ) TEST_LINE( (ErrorNew())->(Eof()) , .T. ) @@ -887,10 +913,16 @@ FUNCTION Main_HVM() TEST_LINE( Len( "" ) , 0 ) TEST_LINE( Len( "123" ) , 3 ) TEST_LINE( Len( "123"+Chr(0)+"456 " ) , 8 ) + TEST_LINE( Len( w_TEST->TYPE_C ) , 15 ) + TEST_LINE( Len( w_TEST->TYPE_C_E ) , 15 ) + TEST_LINE( Len( w_TEST->TYPE_M ) , 11 ) + TEST_LINE( Len( w_TEST->TYPE_M_E ) , 0 ) TEST_LINE( Len( saArray ) , 1 ) #ifdef __HARBOUR__ + TEST_LINE( Len( ErrorNew() ) , 14 ) TEST_LINE( Len( Space( 1000000 ) ) , 1000000 ) #else + TEST_LINE( Len( ErrorNew() ) , 7 ) TEST_LINE( Len( Space( 40000 ) ) , 40000 ) #endif @@ -911,6 +943,18 @@ FUNCTION Main_HVM() TEST_LINE( Empty( " x " ) , .F. ) TEST_LINE( Empty( " x"+Chr(0) ) , .F. ) TEST_LINE( Empty( " "+Chr(13)+"x"+Chr(9) ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_C ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_C_E ) , .T. ) + TEST_LINE( Empty( w_TEST->TYPE_D ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_D_E ) , .T. ) + TEST_LINE( Empty( w_TEST->TYPE_M ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_M_E ) , .T. ) + TEST_LINE( Empty( w_TEST->TYPE_N_I ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_N_IE ) , .T. ) + TEST_LINE( Empty( w_TEST->TYPE_N_D ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_N_DE ) , .T. ) + TEST_LINE( Empty( w_TEST->TYPE_L ) , .F. ) + TEST_LINE( Empty( w_TEST->TYPE_L_E ) , .T. ) TEST_LINE( Empty( 0 ) , .T. ) TEST_LINE( Empty( -0 ) , .T. ) TEST_LINE( Empty( 0.0 ) , .T. ) diff --git a/harbour/tests/regress/rt_main.prg b/harbour/tests/regress/rt_main.prg index eb97e938b5..7faafe4e03 100644 --- a/harbour/tests/regress/rt_main.prg +++ b/harbour/tests/regress/rt_main.prg @@ -265,6 +265,39 @@ STATIC FUNCTION TEST_BEGIN( cParam ) PUBLIC mbBlockC := {|| "(string)" } PUBLIC maArray := { 9898 } + rddSetDefault( "DBFNTX" ) + + dbCreate( "!TEMP!.DBF",; + { { "TYPE_C" , "C", 15, 0 } ,; + { "TYPE_C_E" , "C", 15, 0 } ,; + { "TYPE_D" , "D", 8, 0 } ,; + { "TYPE_D_E" , "D", 8, 0 } ,; + { "TYPE_M" , "M", 10, 0 } ,; + { "TYPE_M_E" , "M", 10, 0 } ,; + { "TYPE_N_I" , "N", 11, 0 } ,; + { "TYPE_N_IE", "N", 11, 0 } ,; + { "TYPE_N_D" , "N", 11, 3 } ,; + { "TYPE_N_DE", "N", 11, 3 } ,; + { "TYPE_L" , "L", 1, 0 } ,; + { "TYPE_L_E" , "L", 1, 0 } } ) + + USE ( "!TEMP!.DBF" ) NEW ALIAS w_TEST EXCLUSIVE + + dbAppend() + + w_TEST->TYPE_C := "" + w_TEST->TYPE_C_E := "" + w_TEST->TYPE_D := STOD( "19800101" ) + w_TEST->TYPE_D_E := STOD( "" ) + w_TEST->TYPE_M := "" + w_TEST->TYPE_M_E := "" + w_TEST->TYPE_N_I := 100 + w_TEST->TYPE_N_IE := 0 + w_TEST->TYPE_N_D := 101.127 + w_TEST->TYPE_N_DE := 0 + w_TEST->TYPE_L := .T. + w_TEST->TYPE_L_E := .F. + RETURN NIL FUNCTION TEST_CALL( cBlock, bBlock, xResultExpected ) @@ -339,6 +372,11 @@ FUNCTION TEST_OPT_Z() STATIC FUNCTION TEST_END() + dbSelectArea( "w_TEST" ) + dbCloseArea() + fErase( "!TEMP!.DBF" ) + fErase( "!TEMP!.DBT" ) + s_nEndTime := Seconds() FWrite( s_nFhnd, "===========================================================================" + s_cNewLine +; diff --git a/harbour/tests/regress/rt_str.prg b/harbour/tests/regress/rt_str.prg index 03beb0606c..c93ee738ea 100644 --- a/harbour/tests/regress/rt_str.prg +++ b/harbour/tests/regress/rt_str.prg @@ -752,6 +752,10 @@ FUNCTION Main_STR() TEST_LINE( Str(100, 10, "A") , "E BASE 1099 Argument error STR F:S" ) TEST_LINE( Str(100, 10, NIL) , "E BASE 1099 Argument error STR F:S" ) TEST_LINE( Str(100, NIL, NIL) , "E BASE 1099 Argument error STR F:S" ) + TEST_LINE( Str( w_TEST->TYPE_N_I ) , " 100" ) + TEST_LINE( Str( w_TEST->TYPE_N_IE ) , " 0" ) + TEST_LINE( Str( w_TEST->TYPE_N_D ) , " 101.127" ) + TEST_LINE( Str( w_TEST->TYPE_N_DE ) , " 0.000" ) TEST_LINE( Str(5000000000.0) , "5000000000.0" ) TEST_LINE( Str(5000000000) , " 5000000000" ) TEST_LINE( Str(-5000000000.0) , " -5000000000.0" )