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

19991203-15:11 GMT+1 Victor Szel <info@szelvesz.hu>

Browse Source
This commit is contained in:
Viktor Szakats
1999-12-03 14:25:35 +00:00
parent a9d06a6717
commit 7b045b6218
8 changed files with 212 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
harbour/ChangeLog
View File

@@ -1,3 +1,21 @@
19991203-15:11 GMT+1 Victor Szel <info@szelvesz.hu>
* 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 <info@szelvesz.hu>
* source/rdd/dbcmd.c
+ DBEVAL() doc added from dbeval.prg

3
harbour/include/extend.h
View File

@@ -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 )

70
harbour/source/rtl/empty.c
View File

@@ -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 );
}

46
harbour/source/rtl/len.c
View File

@@ -45,7 +45,7 @@
* $ONELINER$
* Returns size of a string or size of an array.
* $SYNTAX$
* LEN( <acString> ) --> <nLength>
* LEN( <cString> | <aArray> ) --> <nLength>
* $ARGUMENTS$
* <acString> 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 );
}
}
}

65
harbour/source/rtl/valtype.c
View File

@@ -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" );
}

56
harbour/tests/regress/rt_hvm.prg
View File

@@ -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. )

38
harbour/tests/regress/rt_main.prg
View File

@@ -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 := "<FieldValue>"
w_TEST->TYPE_C_E := ""
w_TEST->TYPE_D := STOD( "19800101" )
w_TEST->TYPE_D_E := STOD( "" )
w_TEST->TYPE_M := "<MemoValue>"
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 +;

4
harbour/tests/regress/rt_str.prg
View File

@@ -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" )