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

19990913-23:50 GMT+1

Browse Source
This commit is contained in:
Viktor Szakats
1999-09-13 21:03:04 +00:00
parent 01c7ba0a99
commit 95f06b74a4
11 changed files with 252 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
harbour/ChangeLog
View File

@@ -1,3 +1,40 @@
19990913-23:50 GMT+1 Victor Szel <info@szelvesz.hu>
* source/rtl/gtapi.c
! hb_gtRectSize() fixed to always return a valid value, even when
the coordinates are out of range, just like in Clipper.
This caused a GPF when running a program with the standard output
redirected. The screen size stored in the caching static variables
were invalid or uninitialized.
The Row()/Col() parameters are also cached in static variables, I'm not
sure if this is needed, it would be better IMO to add hb_gtRow() and
hb_gtCol() and call these when needed, it could be also cached locally
to optimalize where appropriate.
! s_uiMaxCol()/s_uiMaxRow() static variables replaced with hb_gtMax*()
calls.
% hb_gtWriteCon() now caches the screen size info locally.
* source/rtl/console.c
! SAVESCREEN() - Non GTAPI verison now returns an empty string.
* source/rtl/alert.prg
+ Will now return NIL and do nothing if the number of parameters was zero.
This better mimics the STRICT Clipper behaviour.
! One explicit value changed to manifest constant. ( 0 -> SC_NONE )
* source/rtl/memvars.c
! FO_SHARED flag uncommented for __MVRESTORE().
NOTE: Cygwin will now delete the .mem file after a restore.
This is a known problem and should be fixed elsewhere.
* tests/working/overload.prg
+ New tests added by Jose Lalin.
* source/rtl/natmsg/msggl.c
* Updated version by Jose Lalin.
* include/errorapi.h
source/rtl/errorapi.c
+ hb_errPutArgs() function to set :Args of an Error object.
* tests/working/rtl_test.prg
tests/working/memfile.prg
+ __MVSAVE()/__MVRESTORE() error cases moved here from MEMFILE.PRG
+ Operator overloading tests added.
19990913-15:35 GMT+2 Ryszard Glab <rglab@imid.med.pl>
*source/rdd/dbcmd.c

1
harbour/include/errorapi.h
View File

@@ -88,6 +88,7 @@ extern char * hb_errGetSubSystem ( PHB_ITEM pError );
extern USHORT hb_errGetTries ( PHB_ITEM pError );
extern WORD hb_errLaunch ( PHB_ITEM pError );
extern PHB_ITEM hb_errNew ( void );
extern PHB_ITEM hb_errPutArgs ( PHB_ITEM pError, USHORT uiArgCount, ... );
extern PHB_ITEM hb_errPutDescription ( PHB_ITEM pError, char * szDescription );
extern PHB_ITEM hb_errPutFileName ( PHB_ITEM pError, char * szFileName );
extern PHB_ITEM hb_errPutFlags ( PHB_ITEM pError, USHORT uiFlags );

9
harbour/source/rtl/alert.prg
View File

@@ -1,4 +1,4 @@
/*
/*
* $Id$
*/
@@ -15,6 +15,7 @@
#include "box.ch"
#include "inkey.ch"
#include "setcurs.ch"
// ; TOFIX: Clipper defines a clipped window for Alert()
// ; Clipper will return NIL if the first parameter is not a string, but
@@ -68,6 +69,10 @@ FUNCTION Alert( xMessage, aOptions, cColorNorm, nDelay )
#else
IF PCount() == 0
RETURN NIL
ENDIF
IF ValType( xMessage ) == "A"
FOR iEval := 1 TO Len( xMessage )
@@ -182,7 +187,7 @@ FUNCTION Alert( xMessage, aOptions, cColorNorm, nDelay )
/* save status */
nOldRow := Row()
nOldCol := Col()
nOldCursor := SetCursor( 0 )
nOldCursor := SetCursor( SC_NONE )
cOldScreen := SaveScreen( nInitRow, nInitCol, nInitRow + Len( aSay ) + 3, nInitCol + nWidth + 1 )
/* draw box */

6
harbour/source/rtl/console.c
View File

@@ -982,9 +982,7 @@ HARBOUR HB_NOSNOW( void )
{
#ifdef HARBOUR_USE_GTAPI
if( ISLOG( 1 ) )
{
hb_gtSetSnowFlag( hb_parl( 1 ) );
}
#endif
}
@@ -1023,7 +1021,7 @@ HARBOUR HB_SAVESCREEN( void )
uiCoords[ 2 ] = hb_gtMaxRow();
uiCoords[ 3 ] = hb_gtMaxCol();
for( uiX = 1; uiX < 5; uiX++ )
for( uiX = 1; uiX <= 4; uiX++ )
if( ISNUM( uiX ) )
uiCoords[ uiX - 1 ] = hb_parni( uiX );
@@ -1032,6 +1030,8 @@ HARBOUR HB_SAVESCREEN( void )
hb_gtSave( uiCoords[ 0 ], uiCoords[ 1 ], uiCoords[ 2 ], uiCoords[ 3 ], pBuffer );
hb_retclen( pBuffer, uiX );
hb_xfree( ( void * ) pBuffer );
#else
hb_retc( "" );
#endif
}

25
harbour/source/rtl/errorapi.c
View File

@@ -502,6 +502,31 @@ PHB_ITEM hb_errPutFlags( PHB_ITEM pError, USHORT uiFlags )
return pError;
}
PHB_ITEM hb_errPutArgs( PHB_ITEM pError, USHORT uiArgCount, ... )
{
PHB_ITEM pArray = hb_itemNew( NULL );
USHORT uiArgPos;
va_list va;
/* Build the array from the passed arguments. */
hb_arrayNew( pArray, uiArgCount );
va_start( va, uiArgCount );
for( uiArgPos = 1; uiArgPos <= uiArgCount; uiArgPos++ )
hb_arraySet( pArray, uiArgPos, va_arg( va, PHB_ITEM ) );
va_end( va );
/* Assign the new array to the object data item. */
hb_vmPushSymbol( hb_dynsymGet( "_ARGS" )->pSymbol );
hb_vmPush( pError );
hb_vmPush( pArray );
hb_vmDo( 1 );
return pError;
}
/* Wrappers for hb_errLaunch() */
PHB_ITEM hb_errRT_New(

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

@@ -74,8 +74,6 @@ static USHORT s_uiDispCount = 0;
static USHORT s_uiPreCount = 0;
static USHORT s_uiPreCNest = 0;
static USHORT s_uiColorIndex = 0;
static USHORT s_uiMaxCol;
static USHORT s_uiMaxRow;
static int * s_Color; /* masks: 0x0007 Foreground
0x0070 Background
@@ -96,8 +94,6 @@ void hb_gtInit( void )
s_ColorCount = 5;
hb_gt_Init();
hb_gtSetColorStr( hb_set.HB_SET_COLOR );
hb_gtMaxRow();
hb_gtMaxCol();
}
void hb_gtExit( void )
@@ -123,15 +119,15 @@ int hb_gtBox( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight, char
USHORT uiTopBak = uiTop;
USHORT uiLeftBak = uiLeft;
USHORT uiMRow = s_uiMaxRow;
USHORT uiMCol = s_uiMaxCol;
USHORT uiMaxRow = hb_gtMaxRow();
USHORT uiMaxCol = hb_gtMaxCol();
/* TODO: Would be better to support these cases, Clipper implementation */
/* was quite messy for these cases, which can be considered as */
/* a bug there. */
if( uiTop > uiMRow || uiBottom > uiMRow ||
uiLeft > uiMCol || uiRight > uiMCol )
if( uiTop > uiMaxRow || uiBottom > uiMaxRow ||
uiLeft > uiMaxCol || uiRight > uiMaxCol )
{
return 1;
}
@@ -404,7 +400,7 @@ int hb_gtSetColorStr( char * fpColorString )
s_Color[ 3 ] = 0;
s_Color[ 4 ] = 0x07;
}
do
{
c = *fpColorString++;
@@ -575,7 +571,7 @@ int hb_gtSetPos( USHORT uiRow, USHORT uiCol )
{
/* TODO: in this situation Clipper just turns off the cursor */
/* any further writes would be accounted for by clipping */
if( uiRow > s_uiMaxRow || uiCol > s_uiMaxCol )
if( uiRow > hb_gtMaxRow() || uiCol > hb_gtMaxCol() )
return 1;
s_uiCurrentRow = uiRow;
@@ -593,31 +589,16 @@ BOOL hb_gtIsColor( void )
USHORT hb_gtMaxCol( void )
{
return s_uiMaxCol = hb_gt_GetScreenWidth() - 1;
return hb_gt_GetScreenWidth() - 1;
}
USHORT hb_gtMaxRow( void )
{
return s_uiMaxRow = hb_gt_GetScreenHeight() - 1;
return hb_gt_GetScreenHeight() - 1;
}
int hb_gtRectSize( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight, USHORT * uipBuffSize )
{
USHORT uiMRow = s_uiMaxRow;
USHORT uiMCol = s_uiMaxCol;
if( uiBottom > uiMRow )
uiBottom = uiMRow;
if( uiRight > uiMCol )
uiRight = uiMCol;
if( uiTop > uiMRow || uiBottom > uiMRow ||
uiLeft > uiMCol || uiRight > uiMCol ||
uiTop > uiBottom || uiLeft > uiRight )
{
return 1;
}
*uipBuffSize = ( uiBottom - uiTop + 1 ) * ( uiRight - uiLeft + 1 ) * 2;
return 0;
@@ -654,8 +635,8 @@ int hb_gtSave( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight, cha
int hb_gtScrDim( USHORT * uipHeight, USHORT * uipWidth )
{
*uipHeight = s_uiMaxRow;
*uipWidth = s_uiMaxCol;
*uipHeight = hb_gtMaxRow();
*uipWidth = hb_gtMaxCol();
return 0;
}
@@ -678,8 +659,6 @@ int hb_gtSetMode( USHORT uiRows, USHORT uiCols )
{
/* ptucker */
hb_gt_SetMode( uiRows, uiCols );
s_uiMaxRow = hb_gtMaxRow();
s_uiMaxCol = hb_gtMaxCol();
return 0;
}
@@ -707,8 +686,8 @@ int hb_gtWrite( char * fpStr, ULONG length )
/* Determine where the cursor is going to end up */
iRow = s_uiCurrentRow;
iCol = s_uiCurrentCol;
iMaxRow = s_uiMaxRow;
iMaxCol = s_uiMaxCol;
iMaxRow = hb_gtMaxRow();
iMaxCol = hb_gtMaxCol();
length = ( length < iMaxCol-iCol+1 ) ? length : iMaxCol - iCol + 1;
@@ -780,6 +759,8 @@ int hb_gtWriteCon( char * fpStr, ULONG length )
BOOL ldisp = FALSE;
USHORT uiRow = s_uiCurrentRow, uiCol = s_uiCurrentCol;
USHORT tmpRow = s_uiCurrentRow, tmpCol = s_uiCurrentCol;
USHORT uiMaxRow = hb_gtMaxRow();
USHORT uiMaxCol = hb_gtMaxCol();
int ch;
char * fpPtr = fpStr;
#define STRNG_SIZE 500
@@ -799,12 +780,12 @@ int hb_gtWriteCon( char * fpStr, ULONG length )
else if( uiRow > 0 )
{
uiRow--;
uiCol = s_uiMaxCol;
uiCol = uiMaxCol;
}
else
{
hb_gtScroll( 0, 0, s_uiMaxRow, s_uiMaxCol, -1, 0 );
uiCol = s_uiMaxCol;
hb_gtScroll( 0, 0, uiMaxRow, uiMaxCol, -1, 0 );
uiCol = uiMaxCol;
}
*/
if( nLen > 0 )
@@ -815,9 +796,9 @@ int hb_gtWriteCon( char * fpStr, ULONG length )
break;
case 10:
/*
if( uiRow < s_uiMaxRow ) uiRow++;
if( uiRow < uiMaxRow ) uiRow++;
else
hb_gtScroll( 0, 0, s_uiMaxRow, s_uiMaxCol, 1, 0 );
hb_gtScroll( 0, 0, uiMaxRow, uiMaxCol, 1, 0 );
hb_gtSetPos( uiRow, uiCol );
*/
@@ -831,7 +812,7 @@ int hb_gtWriteCon( char * fpStr, ULONG length )
break;
default:
if( ++uiCol > s_uiMaxCol )
if( ++uiCol > uiMaxCol )
{
uiCol = 0;
++uiRow;
@@ -845,10 +826,10 @@ int hb_gtWriteCon( char * fpStr, ULONG length )
if( nLen )
rc = hb_gtWrite( strng, nLen );
nLen = 0;
if( uiRow > s_uiMaxRow )
if( uiRow > uiMaxRow )
{
hb_gtScroll( 0, 0, s_uiMaxRow, s_uiMaxCol, uiRow - s_uiMaxRow, 0 );
uiRow = s_uiMaxRow;
hb_gtScroll( 0, 0, uiMaxRow, uiMaxCol, uiRow - uiMaxRow, 0 );
uiRow = uiMaxRow;
uiCol = 0;
}
tmpRow = uiRow; tmpCol = uiCol;

2
harbour/source/rtl/memvars.c
View File

@@ -1743,7 +1743,7 @@ HARBOUR HB___MVRESTORE( void )
/* Open .MEM file */
while( ( fhnd = hb_fsOpen( ( BYTE * ) szFileName, FO_READ /* | FO_SHARED */ ) ) == FS_ERROR )
while( ( fhnd = hb_fsOpen( ( BYTE * ) szFileName, FO_READ | FO_SHARED ) ) == FS_ERROR )
{
WORD wResult = hb_errRT_BASE_Ext1( EG_OPEN, 2005, NULL, szFileName, hb_fsError(), EF_CANDEFAULT | EF_CANRETRY );

72
harbour/source/rtl/natmsg/msggl.c
View File

@@ -39,52 +39,52 @@ char *hb_daysname[ 7 ] =
char *hb_errorsGeneric[] =
{
"Unknown error",
"Argument error",
"Bound error",
"String overflow",
"Numeric overflow",
"Zero divisor",
"Numeric error",
"Syntax error",
"Operation too complex",
"Erro desco¤ecido",
"Erro de argumento",
"Erro de rango",
"Desbordamento de cadea caracteres",
"Desbordamento num‚rico",
"Divisi¢n por cero",
"Erro num‚rico",
"Erro de sintaxe",
"Operaci¢n demasiado complexa",
"",
"",
"Memory low",
"Undefined function",
"No exported method",
"Variable does not exist",
"Alias does not exist",
"No exported variable",
"Illegal characters in alias",
"Alias already in use",
"Pouca memoria",
"Funci¢n non definida",
"Non existe o m‚todo",
"Non existe a variable",
"Non existe o alias",
"Non existe a variable de instancia",
"Alias con caracteres non v lidos",
"Alias actualmente en uso",
"",
"Create error",
"Open error",
"Close error",
"Read error",
"Write error",
"Print error",
"Erro de creaci¢n",
"Erro de apertura",
"Erro de peche",
"Erro de lectura",
"Erro de escritura",
"Erro de impresi¢n",
"",
"",
"",
"",
"Operation not supported",
"Limit exceeded",
"Corruption detected",
"Data type error",
"Data width error",
"Workarea not in use",
"Workarea not indexed",
"Exclusive required",
"Lock required",
"Write not allowed",
"Append lock failed",
"Lock Failure",
"Operaci¢n non soportada",
"L¡mite excedido",
"Detectouse corrupci¢n",
"Erro de tipo de datos",
"Erro de anchura de datos",
"Area de traballo non usada",
"Area de traballo non indexada",
"Requ¡rese uso exclusivo",
"Requ¡rese bloqueo",
"Escritura non autorizada",
"Fallo no bloqueo ao engadir",
"Fallo no bloqueo",
"",
"",
"",
"Incorrect number of arguments",
"N£mero incorrecto de argumentos",
"array access",
"array assign",
"not an array",

8
harbour/tests/working/memfile.prg
View File

@@ -50,12 +50,6 @@ FUNCTION Main()
? __MRestore( "memfile", .F., "mndouble*", .T. )
? mnDouble
? mnDoubleH
? mnInt
// ; Error cases
? __MRestore( "mamfula", .F. )
? mxStayHere
// SAVE TO memempt* ALL
? __mvScope("mnInt")
RETURN NIL

46
harbour/tests/working/overload.prg
View File

@@ -21,15 +21,28 @@ function Main()
local oString := TString():New( "Hello" )
QOut( "Testing TString with Operator Overloading" )
QOut( oString:cValue )
if oString == "Hello"
QOut( "Ok" )
if oString != "Hello"
QOut( "Not ok" )
endif
endif
return nil
QOut()
QOut( "Equal........:", oString = "Hello" )
QOut( "Exactly Equal:", oString == "Hello" )
QOut( "Not Equal != :", oString != "Hello" )
QOut( "Not Equal <> :", oString <> "Hello" )
QOut( "Not Equal # :", oString # "Hello" )
QOut( "Substring $ :", oString $ "Hello" )
QOut( "Less than :", oString < "Hello" )
QOut( "Less than or Equal:", oString <= "Hello" )
QOut( "Greater than :", oString < "Hello" )
QOut( "Greater than or Equal:", oString <= "Hello" )
QOut( "Concatenation + :", oString + "Hello" )
QOut( "Concatenation - :", oString - "Hello" )
oString += " World"
QOut( "Compound += :", oString )
oString -= " World"
QOut( "Compound -= :", oString )
return nil
function TString()
@@ -41,15 +54,29 @@ function TString()
oClass:AddData( "cValue" ) // define this class objects datas
oClass:AddMethod( "New", @New() )
oClass:AddInline( "=", {| self, cTest | ::cValue = cTest } )
oClass:AddInline( "==", {| self, cTest | ::cValue == cTest } )
oClass:AddInline( "!=", {| self, cTest | ::cValue != cTest } )
oClass:AddInline( "<>", {| self, cTest | ::cValue <> cTest } )
oClass:AddInline( "#", {| self, cTest | ::cValue # cTest } )
oClass:AddInline( "+=", {| self, cTest | ::cValue += cTest } )
oClass:AddInline( "-=", {| self, cTest | ::cValue -= cTest } )
oClass:AddInline( "+", {| self, cTest | ::cValue := ::cValue + cTest } )
oClass:AddInline( "-", {| self, cTest | ::cValue := ::cValue - cTest } )
oClass:AddInline( "$", {| self, cTest | ::cValue $ cTest } )
oClass:AddInline( "<", {| self, cTest | ::cValue < cTest } )
oClass:AddInline( "<=", {| self, cTest | ::cValue <= cTest } )
oClass:AddInline( ">", {| self, cTest | ::cValue > cTest } )
oClass:AddInline( ">=", {| self, cTest | ::cValue >= cTest } )
oClass:AddInline( "HasMsg", {| self, cMsg | __ObjHasMsg( QSelf(), cMsg ) } )
oClass:Create() // builds this class
endif
return oClass:Instance() // builds an object of this class
static function New( cText )
local Self := QSelf()
@@ -57,6 +84,3 @@ static function New( cText )
::cValue := cText
return Self

85
harbour/tests/working/rtl_test.prg
View File

@@ -56,7 +56,7 @@
#define TEST_RESULT_COL2_WIDTH 20
#define TEST_RESULT_COL3_WIDTH 40
#define TEST_RESULT_COL4_WIDTH 55
#define TEST_RESULT_COL5_WIDTH 40
#define TEST_RESULT_COL5_WIDTH 55
STATIC s_nPass
STATIC s_nFail
@@ -94,7 +94,7 @@ STATIC sbBlockC
STATIC saArray
STATIC saAllTypes
MEMVAR mxNotHere
MEMVAR mxNotHere /* Please don't declare this variable, since it's used to test undeclared MEMVAR situations. */
MEMVAR mcString
MEMVAR mcStringE
MEMVAR mcStringZ
@@ -134,6 +134,10 @@ FUNCTION Main( cPar1, cPar2 )
Main_MATH()
Main_STRINGS()
Main_MISC()
#ifdef __HARBOUR__
Main_OPOVERL()
#endif
Main_LAST()
/* Show results, return ERRORLEVEL and exit */
@@ -1944,6 +1948,83 @@ STATIC FUNCTION Main_MISC()
RETURN NIL
#ifdef __HARBOUR__
STATIC FUNCTION Main_OPOVERL()
LOCAL oString := TString()
oString:cValue := "Hello"
TEST_LINE( oString = "Hello" , .T. )
TEST_LINE( oString == "Hello" , .T. )
TEST_LINE( oString != "Hello" , .F. )
TEST_LINE( oString <> "Hello" , .F. )
TEST_LINE( oString # "Hello" , .F. )
TEST_LINE( oString $ "Hello" , .T. )
TEST_LINE( oString < "Hello" , .F. )
TEST_LINE( oString <= "Hello" , .T. )
TEST_LINE( oString < "Hello" , .F. )
TEST_LINE( oString <= "Hello" , .T. )
TEST_LINE( oString + "Hello" , "HelloHello" )
TEST_LINE( oString - "Hello" , "HelloHello" )
oString:cValue := "Hello"
TEST_LINE( oString += " World" , "Hello World" )
oString:cValue := "Hello"
TEST_LINE( oString -= " World" , "Hello World" )
RETURN NIL
STATIC FUNCTION TString()
STATIC oClass
IF oClass == NIL
oClass = TClass():New( "TSTRING" )
oClass:AddData( "cValue" )
oClass:AddInline( "=" , {| self, cTest | ::cValue = cTest } )
oClass:AddInline( "==", {| self, cTest | ::cValue == cTest } )
oClass:AddInline( "!=", {| self, cTest | ::cValue != cTest } )
oClass:AddInline( "<>", {| self, cTest | ::cValue <> cTest } )
oClass:AddInline( "#" , {| self, cTest | ::cValue # cTest } )
oClass:AddInline( "+=", {| self, cTest | ::cValue += cTest } )
oClass:AddInline( "-=", {| self, cTest | ::cValue -= cTest } )
oClass:AddInline( "+" , {| self, cTest | ::cValue := ::cValue + cTest } )
oClass:AddInline( "-" , {| self, cTest | ::cValue := ::cValue - cTest } )
oClass:AddInline( "$" , {| self, cTest | ::cValue $ cTest } )
oClass:AddInline( "<" , {| self, cTest | ::cValue < cTest } )
oClass:AddInline( "<=", {| self, cTest | ::cValue <= cTest } )
oClass:AddInline( ">" , {| self, cTest | ::cValue > cTest } )
oClass:AddInline( ">=", {| self, cTest | ::cValue >= cTest } )
oClass:AddInline( "HasMsg", {| self, cMsg | __ObjHasMsg( QSelf(), cMsg ) } )
oClass:Create()
ENDIF
RETURN oClass:Instance()
#endif
/* NOTE: These should always be called last, since they can mess up the test
environment.
Right now the failing __MRestore() will clear all memory variables,
which is absolutely normal otherwise. */
STATIC FUNCTION Main_LAST()
TEST_LINE( MEMVARBLOCK( "mcString" ) , "{||...}" )
TEST_LINE( __MRestore() , "E BASE 2007 Argument error __MRESTORE " )
TEST_LINE( MEMVARBLOCK( "mcString" ) , "{||...}" )
TEST_LINE( __MSave() , "E BASE 2008 Argument error __MSAVE " )
TEST_LINE( __MRestore( "$NOTHERE.MEM", .F. ) , "E BASE 2005 Open error $NOTHERE.MEM F:DR" )
TEST_LINE( MEMVARBLOCK( "mcString" ) , NIL )
TEST_LINE( __MSave( "*BADNAM*.MEM", "*", .T. ) , "E BASE 2006 Create error *BADNAM*.MEM F:DR" )
RETURN NIL
STATIC FUNCTION TEST_BEGIN( cParam )
LOCAL cOs