diff --git a/harbour/ChangeLog b/harbour/ChangeLog index d1c85b19e7..dd002b4e6a 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,10 @@ +19990603-18:30 CET Eddie Runia + * source/rtl/classes.c; source/rtl/tclass.prg; source/rtl/arrays.c + * include/ctoharb.h; include/extend.h + New class module added with lots of commands and alphabetic order. + aClone() no longer necessary for super casting + ctoharb.h updated so the forward declarations could be removed. + 19990603-16:00 CET Eddie Runia * source/rtl/classes.c wLimit bug resolved diff --git a/harbour/include/ctoharb.h b/harbour/include/ctoharb.h index ef18775b2f..af9060a982 100644 --- a/harbour/include/ctoharb.h +++ b/harbour/include/ctoharb.h @@ -5,6 +5,7 @@ /* Calling Harbour from C code */ /* executing Harbour code from C */ +void Message( PSYMBOL ); void PushSymbol( PSYMBOL pSym ); /* pushes a function pointer onto the stack */ void Push( PITEM pItem ); /* pushes any item to the stack */ void PushNil( void ); /* in this case it places nil at self */ @@ -13,6 +14,7 @@ void PushInteger( int iNumber ); void PushLong( long lNumber ); void PushDouble( double dNumber, WORD wDec ); void PushString( char * szText, WORD wLength ); /* pushes a string on to the stack */ +void PushSymbol( PSYMBOL ); void Do( WORD wParams ); /* invokes the virtual machine */ void Function( WORD wParams ); /* invokes the virtual machine */ void StackShow( void ); diff --git a/harbour/include/extend.h b/harbour/include/extend.h index f24f1f729f..be684ed44c 100644 --- a/harbour/include/extend.h +++ b/harbour/include/extend.h @@ -80,6 +80,7 @@ typedef struct ULONG ulLen; /* number of items in the array */ WORD wHolders; /* number of holders of this array */ WORD wClass; /* offset to the classes base if it is an object */ + WORD wSuperCast; /* is it a super cast ? */ } BASEARRAY, * PBASEARRAY; typedef struct /* stack managed by the virtual machine */ diff --git a/harbour/source/rtl/arrays.c b/harbour/source/rtl/arrays.c index f99d91e1db..9fe5243675 100644 --- a/harbour/source/rtl/arrays.c +++ b/harbour/source/rtl/arrays.c @@ -36,6 +36,7 @@ void hb_arrayNew( PITEM pItem, ULONG ulLen ) /* creates a new array */ pBaseArray->ulLen = ulLen; pBaseArray->wHolders = 1; pBaseArray->wClass = 0; + pBaseArray->wSuperCast = FALSE; for( ul = 0; ul < ulLen; ul++ ) ( pBaseArray->pItems + ul )->wType = IT_NIL; @@ -465,11 +466,14 @@ void hb_arrayRelease( PITEM pArray ) ULONG ul, ulLen = hb_arrayLen( pArray ); PBASEARRAY pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; - for ( ul = 0; ul < ulLen; ul ++ ) - ItemRelease( pBaseArray->pItems + ul ); + if( !pBaseArray->wSuperCast ) + { + for ( ul = 0; ul < ulLen; ul ++ ) + ItemRelease( pBaseArray->pItems + ul ); - if( pBaseArray->pItems ) - _xfree( pBaseArray->pItems ); + if( pBaseArray->pItems ) + _xfree( pBaseArray->pItems ); + } _xfree( pBaseArray ); pArray->wType = IT_NIL; diff --git a/harbour/source/rtl/classes.c b/harbour/source/rtl/classes.c index ead63f53ba..e5cf14c901 100644 --- a/harbour/source/rtl/classes.c +++ b/harbour/source/rtl/classes.c @@ -4,13 +4,7 @@ #include #include - -void Push( PITEM ); -void PushNil( void ); -void PushSymbol( PSYMBOL ); -void Message( PSYMBOL ); -void Do( WORD wParams ); -void Function( WORD wParams ); +#include #define MET_METHOD 0 #define MET_DATA 1 @@ -50,308 +44,51 @@ WORD wClasses = 0; PMETHOD pMethod = 0; PDYNSYM msgClassName = 0, msgClassH = 0, msgEval = 0, msgClassSel = 0; -HARBOUR CLASSCREATE() /* cClassName, nDatas, xSuper --> hClass */ -{ - WORD hSuper = 0; - PITEM pSuper = _param( 3, IT_ANY ); /* Super class present */ - PITEM pItem; - PCLASS pNewCls; - PCLASS pSprCls; + HARBOUR CLASSADD(); + HARBOUR CLASSCREATE(); + HARBOUR CLASSDEL(); +static HARBOUR ClassH(); + HARBOUR CLASSINSTANCE(); + HARBOUR CLASSMOD(); +static HARBOUR ClassName(); + HARBOUR CLASSNAME(); +static HARBOUR ClassSel(); +static void DictRealloc( PCLASS ); +static HARBOUR EvalInline(); +static HARBOUR GetClassData(); +static HARBOUR GetData(); + HARBOURFUNC GetMethod( PITEM, PSYMBOL ); + ULONG hb_isMessage( PITEM, char *); + HARBOUR ISMESSAGE(); + HARBOUR OCLONE(); + HARBOUR OSEND(); + void ReleaseClass( PCLASS ); + void ReleaseClasses(); +static HARBOUR SelectSuper(); +static HARBOUR SetClassData(); +static HARBOUR SetData(); +static HARBOUR Virtual(); + HARBOUR __INSTSUPER(); + HARBOUR __WDATAS(); + HARBOUR __WDATADEC(); + HARBOUR __WDATAINC(); - if( pClasses ) - pClasses = ( PCLASS ) _xrealloc( pClasses, sizeof( CLASS ) * ( wClasses + 1 ) ); - else - pClasses = ( PCLASS ) _xgrab( sizeof( CLASS ) ); - - pNewCls = pClasses + wClasses; - pNewCls->szName = ( char * ) _xgrab( _parclen( 1 ) + 1 ); - strcpy( pNewCls->szName, _parc( 1 ) ); - - if( pSuper ) - { - if( IS_NUMERIC( pSuper ) ) - hSuper = _parni( 3 ) - 1; - else if( IS_ARRAY( pSuper ) ) - { - if( hb_arrayLen( pSuper ) != 1 ) - printf( "\nMultiple inheritance not supported yet" ); - else - { - pItem = hb_itemArrayGet( pSuper, 1 ); - hSuper = (WORD) pItem->value.iNumber - 1; - hb_itemRelease( pItem ); - } - } - pSprCls = pClasses + hSuper; - - pNewCls->wDataFirst = pSprCls->wDatas; - pNewCls->wDatas = pSprCls->wDatas + _parni(2); - pNewCls->wMethods = pSprCls->wMethods; - - pNewCls->pClassDatas = hb_arrayClone( pSprCls->pClassDatas ); - pNewCls->pInlines = hb_arrayClone( pSprCls->pInlines ); - - pNewCls->wHashKey = pClasses[ hSuper ].wHashKey; - pNewCls->pMethods = ( PMETHOD ) _xgrab( - pSprCls->wHashKey * BUCKET * sizeof( METHOD ) ); - memcpy( pNewCls->pMethods, pSprCls->pMethods, - pSprCls->wHashKey * BUCKET * sizeof( METHOD ) ); - } - else - { - pNewCls->wDatas = _parni( 2 ); - pNewCls->wDataFirst = 0; - pNewCls->pMethods = ( PMETHOD ) _xgrab( 100 * sizeof( METHOD ) ); - pNewCls->wMethods = 0; - pNewCls->wHashKey = 25; /* BUCKET = 4 repetitions */ - - pNewCls->pClassDatas = hb_itemArrayNew( 0 ); - pNewCls->pInlines = hb_itemArrayNew( 0 ); - - memset( pNewCls->pMethods, 0, 100 * sizeof( METHOD ) ); - } - _retni( ++wClasses ); -} - -static HARBOUR ClassH( void ) -{ - _retni( ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass ); -} - -char * _GetClassName( PITEM pObject ) -{ - char * szClassName; - - if( IS_ARRAY( pObject ) ) - { - if( ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass ) - szClassName = ( pClasses + ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass - 1 )->szName; - else - szClassName = "ARRAY"; - } - else /* built in types */ - { - switch( pObject->wType ) - { - case IT_NIL: - szClassName = "NIL"; - break; - - case IT_STRING: - szClassName = "CHARACTER"; - break; - - case IT_BLOCK: - szClassName = "BLOCK"; - break; - - case IT_SYMBOL: - szClassName = "SYMBOL"; - break; - - case IT_DATE: - szClassName = "DATE"; - break; - - case IT_INTEGER: - case IT_LONG: - case IT_DOUBLE: - szClassName = "NUMERIC"; - break; - - case IT_LOGICAL: - szClassName = "LOGICAL"; - break; - - default: - szClassName = "UNKNOWN"; - break; - } - } - return szClassName; -} - -static HARBOUR GetData( void ) -{ - PITEM pObject = stack.pBase + 1; - WORD wIndex = pMethod->wData; - - if( wIndex > ( WORD ) hb_arrayLen ( pObject ) ) - /* Resize needed */ - hb_arraySize( pObject, wIndex ); /* Make large enough */ - hb_arrayGet( pObject, wIndex, &stack.Return ); -} - -static HARBOUR SetData( void ) -{ - PITEM pObject = stack.pBase + 1; - WORD wIndex = pMethod->wData; - - if( wIndex > ( WORD ) hb_arrayLen( pObject ) ) - /* Resize needed */ - hb_arraySize( pObject, wIndex ); /* Make large enough */ - hb_arraySet( pObject, wIndex, stack.pBase + 2 ); -} - -static HARBOUR GetClassData( void ) -{ - WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; - - if( wClass && wClass <= wClasses ) - hb_arrayGet( pClasses[ wClass - 1 ].pClassDatas, pMethod->wData, &stack.Return ); -} - -static HARBOUR SetClassData( void ) -{ - WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; - - if( wClass && wClass <= wClasses ) - hb_arraySet( pClasses[ wClass - 1 ].pClassDatas, pMethod->wData, stack.pBase + 2 ); -} - -static HARBOUR EvalInline( void ) -{ - ITEM block; - WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; - WORD w; - - hb_arrayGet( pClasses[ wClass - 1 ].pInlines, pMethod->wData, &block ); - - PushSymbol( &symEval ); - Push( &block ); - Push( stack.pBase + 1 ); /* Push self */ - for( w = 1; w <= _pcount(); w++ ) - Push( _param( w, IT_ANY ) ); - Do( _pcount() + 1 ); /* Self is also an argument */ - - ItemRelease( &block ); /* Release block */ -} - -static HARBOUR Virtual( void ) -{ - _ret(); -} - -static HARBOUR SelectSuper( void ) -{ - PITEM pObject = stack.pBase + 1; - PITEM pSuper = hb_arrayClone( pObject ); - WORD wSuperCls = pMethod->wData; - - ItemCopy( &stack.Return, pSuper ); - ( (PBASEARRAY) (stack.Return.value.pBaseArray) )->wClass = wSuperCls; - hb_itemRelease( pSuper ); -} - -static HARBOUR ClassName( void ) -{ - WORD wClass = IS_ARRAY( stack.pBase + 1 ) ? - ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass: 0; - PITEM pItemRef; - - /* Variables by reference */ - if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) ) - { - pItemRef = stack.pItems + ( stack.pBase + 1 )->value.wItem; - if( IS_ARRAY( pItemRef ) ) - wClass = ( ( PBASEARRAY ) pItemRef->value.pBaseArray )->wClass; - } - - if( wClass && ( wClass <= wClasses ) ) - _retc( pClasses[ wClass - 1 ].szName ); - else - { - switch( ( stack.pBase )->wType ) - { - case IT_ARRAY: - _retc( "ARRAY" ); - break; - - case IT_BLOCK: - _retc( "BLOCK" ); - break; - - case IT_STRING: - _retc( "CHARACTER" ); - break; - - case IT_DATE: - _retc( "DATE" ); - break; - - case IT_LOGICAL: - _retc( "LOGICAL" ); - break; - - case IT_INTEGER: - case IT_LONG: - case IT_DOUBLE: - _retc( "NUMERIC" ); - break; - - default: - _retc( "NIL" ); - break; - } - } -} - -static void DictRealloc( PCLASS pClass ) -{ - /* TODO: Implement it for very large classes */ - if( pClass ) - { - printf( "classes.c DictRealloc not implemented yet\n" ); - exit( 1 ); - } -} - -static HARBOUR ClassSel() -{ - WORD wClass = IS_ARRAY( stack.pBase + 1 ) ? - ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass: 0; - /* Get class word */ - WORD wLimit; /* Number of Hash keys */ - WORD wAt; - WORD wPos = 0; - PCLASS pClass; - PDYNSYM pMessage; - PITEM pReturn = hb_itemNew( NULL ); - PITEM pItem; - PITEM pItemRef; - - /* Variables by reference */ - if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) ) - { - pItemRef = stack.pItems + ( stack.pBase + 1 )->value.wItem; - if( IS_ARRAY( pItemRef ) ) - wClass = ( ( PBASEARRAY ) pItemRef->value.pBaseArray )->wClass; - } - - if( wClass && wClass <= wClasses ) - { - pClass = &pClasses[ wClass - 1 ]; - wLimit = pClass->wHashKey * BUCKET; - hb_itemRelease( pReturn ); - pReturn = hb_itemArrayNew( pClass->wMethods ); - /* Create a transfer array */ - for( wAt = 0; wAt < wLimit ; wAt++ ) - { - pMessage = (PDYNSYM) pClass->pMethods[ wAt ].pMessage; - if( pMessage ) /* Hash Entry used ? */ - { - pItem = hb_itemPutC( NULL, pMessage->pSymbol->szName ); - /* Add to array */ - hb_itemArrayPut( pReturn, ++wPos, pItem ); - hb_itemRelease( pItem ); - } - } - } - hb_itemReturn( pReturn ); - hb_itemRelease( pReturn ); -} - -HARBOUR CLASSADD() /* hClass, cMessage, pFunction, nType, xInit */ +/* + * ClassAdd( , , , , [xInit] ) + * + * Add a message to the class. + * + * Class handle + * Message + * MET_METHOD : Pointer to function + * MET_DATA : Index number in array + * MET_CLASSDATA : Index number in array + * MET_INLINE : Code block + * MET_SUPER : Handle of super class + * see MET_* + * Optional initializer for DATA + */ +HARBOUR CLASSADD() { WORD wClass = _parnl( 1 ); WORD wType = _parni( 4 ); @@ -441,27 +178,140 @@ HARBOUR CLASSADD() /* hClass, cMessage, pFunction, nType, xInit */ } } -HARBOUR CLASSNAME() /* hClass --> cClassName */ -{ - PITEM pObject = _param( 0, IT_OBJECT ); - WORD wClass; - if( pObject && ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass ) +/* + * := ClassCreate( , , [hSuper] ) + * + * Create a new class + * + * Name of the class + * Number of DATAs in the class + * Optional handle of superclass + */ +HARBOUR CLASSCREATE() +{ + WORD wSuper = _parni( 3 ); /* Super class present */ + WORD wSize; + PITEM pItem; + PCLASS pNewCls; + PCLASS pSprCls; + + if( pClasses ) + pClasses = ( PCLASS ) _xrealloc( pClasses, sizeof( CLASS ) * ( wClasses + 1 ) ); + else + pClasses = ( PCLASS ) _xgrab( sizeof( CLASS ) ); + + pNewCls = pClasses + wClasses; + pNewCls->szName = ( char * ) _xgrab( _parclen( 1 ) + 1 ); + strcpy( pNewCls->szName, _parc( 1 ) ); + + if( wSuper ) { - wClass = ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass; - _retc( pClasses[ wClass - 1 ].szName ); + pSprCls = pClasses + wSuper - 1; + + pNewCls->wDataFirst = pSprCls->wDatas; + pNewCls->wDatas = pSprCls->wDatas + _parni(2); + pNewCls->wMethods = pSprCls->wMethods; + + pNewCls->pClassDatas = hb_arrayClone( pSprCls->pClassDatas ); + pNewCls->pInlines = hb_arrayClone( pSprCls->pInlines ); + + pNewCls->wHashKey = pSprCls->wHashKey; + + wSize = pSprCls->wHashKey * BUCKET * sizeof( METHOD ); + pNewCls->pMethods = ( PMETHOD ) _xgrab( wSize ); + memcpy( pNewCls->pMethods, pSprCls->pMethods, wSize ); } else { - wClass = _parni( 1 ); - if( wClass <= wClasses ) - _retc( pClasses[ wClass - 1 ].szName ); - else - _retc( "" ); + pNewCls->wDatas = _parni( 2 ); + pNewCls->wDataFirst = 0; + pNewCls->pMethods = ( PMETHOD ) _xgrab( 100 * sizeof( METHOD ) ); + pNewCls->wMethods = 0; + pNewCls->wHashKey = 25; /* BUCKET = 4 repetitions */ + + pNewCls->pClassDatas = hb_itemArrayNew( 0 ); + pNewCls->pInlines = hb_itemArrayNew( 0 ); + + memset( pNewCls->pMethods, 0, 100 * sizeof( METHOD ) ); + } + _retni( ++wClasses ); +} + +/* + * ClassDel( , ) + * + * Delete message (only for INLINE and METHOD) + * + * Object + * Message + */ +HARBOUR CLASSDEL() +{ + PITEM pString = _param( 2, IT_STRING ); + PSYMBOL pMessage = GetDynSym( pString->value.szText )->pSymbol; + PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; + PCLASS pClass; + + WORD wClass = _parni( 1 ); + WORD wAt; + WORD wLimit; + WORD wMask; + + HARBOURFUNC pFunc; + + if( wClass && wClass <= wClasses ) + { + pClass = pClasses + wClass - 1; + wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; + wMask = pClass->wHashKey * BUCKET; + wLimit = ( wAt - 1 ) % wMask; + + while( ( wAt != wLimit ) && + ( pClass->pMethods[ wAt ].pMessage && + ( pClass->pMethods[ wAt ].pMessage != pMsg ) ) ) + wAt = ( wAt == wMask ) ? 0 : wAt + 1; + + if( wAt != wLimit ) + { /* Requested method found */ + pFunc = pClass->pMethods[ wAt ].pFunction; + if( pFunc == EvalInline ) /* INLINE method deleted */ + { + hb_arrayDel( pClass->pInlines, pClass->pMethods[ wAt ].wData ); + /* Delete INLINE block */ + } /* Move messages */ + for( ; pClass->pMethods[ wAt ].pMessage && wAt < wLimit; wAt ++ ) + memcpy( &( pClass->pMethods[ wAt ] ), + &( pClass->pMethods[ wAt + 1 ] ), sizeof( METHOD ) ); + + pClass->pMethods[ wAt ].pFunction = NULL; + pClass->pMethods[ wAt ].pMessage = NULL; + pClass->pMethods[ wAt ].wData = NULL; + pClass->pMethods[ wAt ].wScope = NULL; + pClass->pMethods[ wAt ].pInitValue = NULL; + + pClass->wMethods--; /* Decrease number messages */ + } } } -HARBOUR CLASSINSTANCE() /* hClass --> oNewObject */ + +/* + * := :ClassH() + * + * Returns class handle of + */ +static HARBOUR ClassH( void ) +{ + _retni( ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass ); +} + +/* + * := ClassInstance( ) + * + * Create a new object from class definition + */ +HARBOUR CLASSINSTANCE() { WORD wClass = _parni( 1 ); WORD wAt, wLimit; @@ -488,6 +338,271 @@ HARBOUR CLASSINSTANCE() /* hClass --> oNewObject */ _ret(); } +/* + * ClassMod( , , ) + * + * Modify message (only for INLINE and METHOD) + */ +HARBOUR CLASSMOD() +{ + PITEM pString = _param( 2, IT_STRING ); + PSYMBOL pMessage = GetDynSym( pString->value.szText )->pSymbol; + PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; + PCLASS pClass; + + WORD wClass = _parni( 1 ); + WORD wAt; + WORD wLimit; + WORD wMask; + + HARBOURFUNC pFunc; + + if( wClass && wClass <= wClasses ) + { + pClass = pClasses + wClass - 1; + wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; + wMask = pClass->wHashKey * BUCKET; + wLimit = wAt ? ( wAt - 1 ) : ( wMask - 1 ); + + while( ( wAt != wLimit ) && + ( pClass->pMethods[ wAt ].pMessage && + ( pClass->pMethods[ wAt ].pMessage != pMsg ) ) ) + wAt = ( wAt == wMask ) ? 0 : wAt + 1; + + if( wAt != wLimit ) + { /* Requested method found */ + pFunc = pClass->pMethods[ wAt ].pFunction; + if( pFunc == EvalInline ) /* INLINE method changed */ + { + hb_arraySet( pClass->pInlines, pClass->pMethods[ wAt ].wData, + _param( 3, IT_BLOCK ) ); + } + else if( ( pFunc == SetData ) || ( pFunc == GetData ) ) + { /* Not allowed for DATA */ + printf( "\nCannot modify a DATA item" ); + exit(1); + } /* TODO : Real error */ + else /* Modify METHOD */ + { + pClass->pMethods[ wAt ].pFunction = ( HARBOURFUNC ) _parnl( 3 ); + } + } + } +} + + +/* + * := :ClassName() + * + * Return class name of . Can also be used for all types. + */ +static HARBOUR ClassName( void ) +{ + WORD wClass = IS_ARRAY( stack.pBase + 1 ) ? + ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass: 0; + PITEM pItemRef; + + /* Variables by reference */ + if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) ) + { + pItemRef = stack.pItems + ( stack.pBase + 1 )->value.wItem; + if( IS_ARRAY( pItemRef ) ) + wClass = ( ( PBASEARRAY ) pItemRef->value.pBaseArray )->wClass; + } + + if( wClass && ( wClass <= wClasses ) ) + _retc( pClasses[ wClass - 1 ].szName ); + else + { + switch( ( stack.pBase )->wType & ~IT_BYREF ) + { + case IT_ARRAY: + _retc( "ARRAY" ); + break; + + case IT_BLOCK: + _retc( "BLOCK" ); + break; + + case IT_STRING: + _retc( "CHARACTER" ); + break; + + case IT_DATE: + _retc( "DATE" ); + break; + + case IT_LOGICAL: + _retc( "LOGICAL" ); + break; + + case IT_INTEGER: + case IT_LONG: + case IT_DOUBLE: + _retc( "NUMERIC" ); + break; + + default: + _retc( "NIL" ); + break; + } + } +} + + +/* + * := ClassName( ) + * + * Returns class name of + */ +HARBOUR CLASSNAME() +{ + PITEM pObject = _param( 0, IT_OBJECT ); + WORD wClass; + + if( pObject && ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass ) + { + wClass = ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass; + _retc( pClasses[ wClass - 1 ].szName ); + } + else + { + wClass = _parni( 1 ); + if( wClass <= wClasses ) + _retc( pClasses[ wClass - 1 ].szName ); + else + _retc( "" ); + } +} + + +/* + * := :ClassSel() + * + * Returns all the messages in + */ +static HARBOUR ClassSel() +{ + WORD wClass = IS_ARRAY( stack.pBase + 1 ) ? + ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass: 0; + /* Get class word */ + WORD wLimit; /* Number of Hash keys */ + WORD wAt; + WORD wPos = 0; + PCLASS pClass; + PDYNSYM pMessage; + PITEM pReturn = hb_itemNew( NULL ); + PITEM pItem; + PITEM pItemRef; + + /* Variables by reference */ + if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) ) + { + pItemRef = stack.pItems + ( stack.pBase + 1 )->value.wItem; + if( IS_ARRAY( pItemRef ) ) + wClass = ( ( PBASEARRAY ) pItemRef->value.pBaseArray )->wClass; + } + + if( wClass && wClass <= wClasses ) + { + pClass = &pClasses[ wClass - 1 ]; + wLimit = pClass->wHashKey * BUCKET; + hb_itemRelease( pReturn ); + pReturn = hb_itemArrayNew( pClass->wMethods ); + /* Create a transfer array */ + for( wAt = 0; wAt < wLimit ; wAt++ ) + { + pMessage = (PDYNSYM) pClass->pMethods[ wAt ].pMessage; + if( pMessage ) /* Hash Entry used ? */ + { + pItem = hb_itemPutC( NULL, pMessage->pSymbol->szName ); + /* Add to array */ + hb_itemArrayPut( pReturn, ++wPos, pItem ); + hb_itemRelease( pItem ); + } + } + } + hb_itemReturn( pReturn ); + hb_itemRelease( pReturn ); +} + + +/* + * DictRealloc( PCLASS ) + * + * Realloc (widen) class + */ +static void DictRealloc( PCLASS pClass ) +{ + /* TODO: Implement it for very large classes */ + if( pClass ) + { + printf( "classes.c DictRealloc not implemented yet\n" ); + exit( 1 ); + } +} + + +/* + * EvalInline() + * + * Internal function executed for inline methods + */ +static HARBOUR EvalInline( void ) +{ + ITEM block; + WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; + WORD w; + + hb_arrayGet( pClasses[ wClass - 1 ].pInlines, pMethod->wData, &block ); + + PushSymbol( &symEval ); + Push( &block ); + Push( stack.pBase + 1 ); /* Push self */ + for( w = 1; w <= _pcount(); w++ ) + Push( _param( w, IT_ANY ) ); + Do( _pcount() + 1 ); /* Self is also an argument */ + + ItemRelease( &block ); /* Release block */ +} + + +/* + * GetClassData() + * + * Internal function to return a CLASSDATA + */ +static HARBOUR GetClassData( void ) +{ + WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; + + if( wClass && wClass <= wClasses ) + hb_arrayGet( pClasses[ wClass - 1 ].pClassDatas, pMethod->wData, &stack.Return ); +} + + +/* + * GetData() + * + * Internal function to return a DATA + */ +static HARBOUR GetData( void ) +{ + PITEM pObject = stack.pBase + 1; + WORD wIndex = pMethod->wData; + + if( wIndex > ( WORD ) hb_arrayLen ( pObject ) ) + /* Resize needed */ + hb_arraySize( pObject, wIndex ); /* Make large enough */ + hb_arrayGet( pObject, wIndex, &stack.Return ); +} + + +/* + * = GetMethod( , ) + * + * Internal function to the function pointer of a message of an object + */ HARBOURFUNC GetMethod( PITEM pObject, PSYMBOL pMessage ) { PCLASS pClass; @@ -538,6 +653,14 @@ HARBOURFUNC GetMethod( PITEM pObject, PSYMBOL pMessage ) return 0; } + +/* + * = hb_isMessage( , ) + * + * Check whether is an existing message for object. + * + * should be read as a boolean + */ ULONG hb_isMessage( PITEM pObject, char *szString ) { PSYMBOL pMessage = GetDynSym( szString )->pSymbol; @@ -546,8 +669,13 @@ ULONG hb_isMessage( PITEM pObject, char *szString ) /* message */ } -HARBOUR ISMESSAGE() /* Is the message valid for the class */ - /* := IsMessage( , ) */ + +/* + * := IsMessage( , ) + * + * Is a valid message for the + */ +HARBOUR ISMESSAGE() { PITEM pObject = _param( 1, IT_OBJECT ); PITEM pString = _param( 2, IT_STRING ); @@ -563,42 +691,34 @@ HARBOUR ISMESSAGE() /* Is the message valid for the class */ } } -void ReleaseClass( PCLASS pClass ) + +/* + * := oClone( ) + * + * Clone an object. Note the similarity with aClone ;-) + */ +HARBOUR OCLONE( void ) { - WORD wAt; - WORD wLimit; + PITEM pSrcObject = _param( 1, IT_OBJECT ); - wLimit = pClass->wHashKey * BUCKET; - for( wAt = 0; wAt < wLimit; wAt++ ) /* Release initializers */ - if( pClass->pMethods[ wAt ].pInitValue && - pClass->pMethods[ wAt ].wData > pClass->wDataFirst ) - { - hb_itemRelease( pClass->pMethods[ wAt ].pInitValue ); - } - _xfree( pClass->szName ); - _xfree( pClass->pMethods ); - - hb_itemRelease( pClass->pClassDatas ); - hb_itemRelease( pClass->pInlines ); -} - -void ReleaseClasses( void ) -{ - WORD w; - - for( w = 0; w < wClasses; w++ ) - { - ReleaseClass( pClasses + w ); - } - - if( pClasses ) - _xfree( pClasses ); + if ( pSrcObject ) + { + PITEM pDstObject = hb_arrayClone( pSrcObject ); + ItemCopy( &stack.Return, pDstObject ); /* OClone() returns the new object */ + hb_itemRelease( pDstObject ); + } + else + _ret(); } - -HARBOUR OSEND() /* = oSend( , , */ -{ /* Send a message to an object */ +/* + * = oSend( , , + * + * Send a message to an object + */ +HARBOUR OSEND() +{ PITEM pObject = _param( 1, IT_OBJECT ); PITEM pMessage = _param( 2, IT_STRING ); WORD w; @@ -622,150 +742,122 @@ HARBOUR OSEND() /* = oSend( , , */ } -HARBOUR __WDATAS() /* = __wDatas( ) */ +/* + * ReleaseClass( ) + * + * Release a class from memory + */ +void ReleaseClass( PCLASS pClass ) { - WORD wClass = _parnl( 1 ); - - if( wClass ) - _retni( pClasses[ wClass - 1 ].wDatas ); /* Return number of DATAs */ -} - - -HARBOUR __WDATAINC() /* = __wDataInc( )*/ -{ - WORD wClass = _parnl( 1 ); - - if( wClass ) - _retni( ++pClasses[ wClass - 1 ].wDatas ); /* Return and increase */ -} /* number of DATAs */ - - -HARBOUR __WDATADEC() /* = __wDataDec( )*/ -{ - WORD wClass = _parnl( 1 ); - - if( wClass ) - _retni( pClasses[ wClass - 1 ].wDatas-- ); /* Return and decrease */ -} /* number of DATAs */ - - -HARBOUR CLASSMOD() /* Modify message (only for INLINE and METHOD) */ - /* := ClassMod( , , ) */ -{ - PITEM pString = _param( 2, IT_STRING ); - PSYMBOL pMessage = GetDynSym( pString->value.szText )->pSymbol; - PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; - PCLASS pClass; - - WORD wClass = _parni( 1 ); WORD wAt; WORD wLimit; - WORD wMask; - HARBOURFUNC pFunc; + wLimit = pClass->wHashKey * BUCKET; + for( wAt = 0; wAt < wLimit; wAt++ ) /* Release initializers */ + if( pClass->pMethods[ wAt ].pInitValue && + pClass->pMethods[ wAt ].wData > pClass->wDataFirst ) + { + hb_itemRelease( pClass->pMethods[ wAt ].pInitValue ); + } + _xfree( pClass->szName ); + _xfree( pClass->pMethods ); + + hb_itemRelease( pClass->pClassDatas ); + hb_itemRelease( pClass->pInlines ); +} + + +/* + * ReleaseClasses() + * + * Release all classes + */ +void ReleaseClasses( void ) +{ + WORD w; + + for( w = 0; w < wClasses; w++ ) + { + ReleaseClass( pClasses + w ); + } + + if( pClasses ) + _xfree( pClasses ); +} + + +/* + * SelectSuper() + * + * Internal function to cast to a super method + */ +static HARBOUR SelectSuper( void ) /* Without aClone !!! */ +{ + PITEM pObject = stack.pBase + 1; + PITEM pSuper = (PITEM) _xgrab( sizeof( ITEM ) ); + PBASEARRAY pNewBase = (PBASEARRAY) _xgrab( sizeof( BASEARRAY ) ); + + WORD wSuperCls = pMethod->wData; /* Get handle of superclass */ + + memcpy( pSuper, pObject, sizeof( ITEM ) ); /* Allocate new structures */ + memcpy( pNewBase, pObject->value.pBaseArray, sizeof( BASEARRAY ) ); + + pSuper->value.pBaseArray = pNewBase; + + pNewBase->wClass = wSuperCls; + pNewBase->wHolders = 1; /* New item is returned */ + pNewBase->wSuperCast = TRUE; /* Do not dispose pItems !! */ + /* A bit dirty, but KISS. */ + ItemCopy( &stack.Return, pSuper ); + hb_itemRelease( pSuper ); +} + + +/* + * SetClassData() + * + * Internal function to set a CLASSDATA + */ +static HARBOUR SetClassData( void ) +{ + WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; if( wClass && wClass <= wClasses ) - { - pClass = pClasses + wClass - 1; - wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; - wMask = pClass->wHashKey * BUCKET; - wLimit = wAt ? ( wAt - 1 ) : ( wMask - 1 ); - - while( ( wAt != wLimit ) && - ( pClass->pMethods[ wAt ].pMessage && - ( pClass->pMethods[ wAt ].pMessage != pMsg ) ) ) - wAt = ( wAt == wMask ) ? 0 : wAt + 1; - - if( wAt != wLimit ) - { /* Requested method found */ - pFunc = pClass->pMethods[ wAt ].pFunction; - if( pFunc == EvalInline ) /* INLINE method changed */ - { - hb_arraySet( pClass->pInlines, pClass->pMethods[ wAt ].wData, - _param( 3, IT_BLOCK ) ); - } - else if( ( pFunc == SetData ) || ( pFunc == GetData ) ) - { /* Not allowed for DATA */ - printf( "\nCannot modify a DATA item" ); - exit(1); - } /* TODO : Real error */ - else /* Modify METHOD */ - { - pClass->pMethods[ wAt ].pFunction = ( HARBOURFUNC ) _parnl( 3 ); - } - } - } + hb_arraySet( pClasses[ wClass - 1 ].pClassDatas, pMethod->wData, stack.pBase + 2 ); } -HARBOUR CLASSDEL() /* Delete message (only for INLINE and METHOD) */ - /* := ClassDel( , ) */ + +/* + * SetData() + * + * Internal function to set a DATA + */ +static HARBOUR SetData( void ) { - PITEM pString = _param( 2, IT_STRING ); - PSYMBOL pMessage = GetDynSym( pString->value.szText )->pSymbol; - PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; - PCLASS pClass; + PITEM pObject = stack.pBase + 1; + WORD wIndex = pMethod->wData; - WORD wClass = _parni( 1 ); - WORD wAt; - WORD wLimit; - WORD wMask; - - HARBOURFUNC pFunc; - - if( wClass && wClass <= wClasses ) - { - pClass = pClasses + wClass - 1; - wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; - wMask = pClass->wHashKey * BUCKET; - wLimit = ( wAt - 1 ) % wMask; - - while( ( wAt != wLimit ) && - ( pClass->pMethods[ wAt ].pMessage && - ( pClass->pMethods[ wAt ].pMessage != pMsg ) ) ) - wAt = ( wAt == wMask ) ? 0 : wAt + 1; - - if( wAt != wLimit ) - { /* Requested method found */ - pFunc = pClass->pMethods[ wAt ].pFunction; - if( pFunc == EvalInline ) /* INLINE method deleted */ - { - hb_arrayDel( pClass->pInlines, pClass->pMethods[ wAt ].wData ); - /* Delete INLINE block */ - } /* Move messages */ - for( ; pClass->pMethods[ wAt ].pMessage && wAt < wLimit; wAt ++ ) - memcpy( &( pClass->pMethods[ wAt ] ), - &( pClass->pMethods[ wAt + 1 ] ), sizeof( METHOD ) ); - - pClass->pMethods[ wAt ].pFunction = NULL; - pClass->pMethods[ wAt ].pMessage = NULL; - pClass->pMethods[ wAt ].wData = NULL; - pClass->pMethods[ wAt ].wScope = NULL; - pClass->pMethods[ wAt ].pInitValue = NULL; - - pClass->wMethods--; /* Decrease number messages */ - } - } + if( wIndex > ( WORD ) hb_arrayLen( pObject ) ) + /* Resize needed */ + hb_arraySize( pObject, wIndex ); /* Make large enough */ + hb_arraySet( pObject, wIndex, stack.pBase + 2 ); } -HARBOUR OCLONE( void ) +/* No comment :-) */ +static HARBOUR Virtual( void ) { - PITEM pSrcObject = _param( 1, IT_OBJECT ); - - if ( pSrcObject ) - { - PITEM pDstObject = hb_arrayClone( pSrcObject ); - ItemCopy( &stack.Return, pDstObject ); /* OClone() returns the new object */ - hb_itemRelease( pDstObject ); - } - else - _ret(); + _ret(); } -HARBOUR __INSTSUPER( void ) /* ClassH := __InstSuper( ) */ -{ /* Instance super class and return */ - /* class handle */ +/* + * := __InstSuper( ) + * + * Instance super class and return class handle + */ +HARBOUR __INSTSUPER( void ) +{ PITEM pString = _param( 1, IT_STRING ); PDYNSYM pDynSym; PITEM pSuperCls; @@ -811,4 +903,45 @@ HARBOUR __INSTSUPER( void ) /* ClassH := __InstSuper( ) */ } +/* + * = __wDataDec( ) + * + * Return number of datas and decrease + */ +HARBOUR __WDATADEC() +{ + WORD wClass = _parnl( 1 ); + + if( wClass ) + _retni( pClasses[ wClass - 1 ].wDatas-- ); +} + + +/* + * = __wDataInc( ) + * + * Return number of datas and decrease + */ +HARBOUR __WDATAINC() +{ + WORD wClass = _parnl( 1 ); + + if( wClass ) + _retni( ++pClasses[ wClass - 1 ].wDatas ); +} + + +/* + * = __wDatas( ) + * + * Return number of datas + */ +HARBOUR __WDATAS() +{ + WORD wClass = _parnl( 1 ); + + if( wClass ) + _retni( pClasses[ wClass - 1 ].wDatas ); +} + diff --git a/harbour/source/rtl/tclass.prg b/harbour/source/rtl/tclass.prg index ddb938184e..05a1a77f12 100644 --- a/harbour/source/rtl/tclass.prg +++ b/harbour/source/rtl/tclass.prg @@ -42,15 +42,15 @@ function TClass() ClassAdd( hClass, "_aInlines", 6, MET_DATA ) ClassAdd( hClass, "aVirtuals", 7, MET_DATA ) ClassAdd( hClass, "_aVirtuals", 7, MET_DATA ) - ClassAdd( hClass, "xSuper", 8, MET_DATA ) - ClassAdd( hClass, "_xSuper", 8, MET_DATA ) + ClassAdd( hClass, "cSuper", 8, MET_DATA ) + ClassAdd( hClass, "_cSuper", 8, MET_DATA ) endif return ClassInstance( hClass ) //----------------------------------------------------------------------------// -static function New( cClassName, xSuper ) +static function New( cClassName, cSuper ) local Self := QSelf() @@ -60,8 +60,8 @@ static function New( cClassName, xSuper ) ::aClsDatas = {} ::aInlines = {} ::aVirtuals = {} - if ValType( xSuper ) $ "CA" - ::xSuper = xSuper + if ValType( cSuper ) == "C" + ::cSuper = cSuper endif return Self @@ -79,30 +79,14 @@ static function Create() local hSuper local ahSuper := {} - if ::xSuper == NIL + if ::cSuper == NIL hClass := ClassCreate( ::cName, nLenDatas ) - elseif ValType(::xSuper) == "A" // Multiple inheritance - ahSuper := {} - nLen := Len( ::xSuper ) - for n := 1 to nLen - aAdd( ahSuper, __InstSuper( Upper( ::xSuper[ n ] ) ) ) - next n - - hClass := ClassCreate( ::cName, nLenDatas, ahSuper ) - - for n := 1 to nLen - ClassAdd( hClass, Upper( ::xSuper[ n ] ), ahSuper[ n ], MET_SUPER ) - nDataBegin += __WDatas( ahSuper[ n ] ) // Calc offset for new DATAs - next n - ClassAdd( hClass, "SUPER", aTail( ahSuper ), MET_SUPER ) - // Last super is the SUPER - - elseif ValType(::xSuper) == "C" // Single inheritance - hSuper := __InstSuper( Upper( ::xSuper ) ) + else // Single inheritance + hSuper := __InstSuper( Upper( ::cSuper ) ) hClass := ClassCreate( ::cName, nLenDatas, hSuper ) // Add class casts - ClassAdd( hClass, Upper( ::xSuper ), hSuper, MET_SUPER ) + ClassAdd( hClass, Upper( ::cSuper ), hSuper, MET_SUPER ) ClassAdd( hClass, "SUPER", hSuper, MET_SUPER ) nDataBegin := __WDatas( hSuper ) // Get offset for new DATAs diff --git a/harbour/tests/working/multinh.prg b/harbour/tests/working/multinh.prg deleted file mode 100644 index 6d23c01fa7..0000000000 --- a/harbour/tests/working/multinh.prg +++ /dev/null @@ -1,307 +0,0 @@ -#include "set.ch" - -// -// MultInh -// -// First step to multiple inheritage -// -// Date : 01/06/1999 -// - -function Main() - - local oFrom - local oTo - local cOut - - set( _SET_EXACT, .T.) - - oFrom := TOnTop() :New( "hello.prg", "R" ) - oTo := TTextFile():New( "hello.out", "W" ) - - QOut( "What's in oFrom" ) - HBDebug( { oFrom, aoMethod( oFrom ) } ) - - QOut() - QOut( "What's in oFrom:TEmpty" ) - HBDebug( { oFrom:TEmpty, aoMethod( oFrom:TEmpty ) } ) - - QOut() - QOut( "Let's call Run() from TEmpty : " ) - oFrom:TEmpty:Run() - - QOut() - QOut( "Let's call a method from TEmpty and one from TOnTop" ) - oFrom:Set( "Done !" ) - oFrom:Say( "Out" ) - - QOut() - QOut( "Basic copy loop using the default Run() from TTextFile" ) - do while !oFrom:lEoF - cOut := oFrom:Run() - QOut( cOut ) - oTo:Run( cOut ) - enddo - oFrom:Dispose() - oTo:Dispose() - -return nil - -// -// Generic Empty Class -// -function TEmpty() - - static oEmpty - - if oEmpty == NIL - oEmpty := TClass():New( "TEmpty" ) // Create a new class def - - oEmpty:AddInline( "New", {|self|self} ) - - oEmpty:AddInline( "Run", {||QOut( "Run !" )}) // Test command -// oEmpty:AddInline( "Set", {|self,xParam|::Out := xParam } ) - oEmpty:AddInline( "Set", {|self,xParam| oSend(self,"_Out",xParam) } ) - oEmpty:AddData( "Out", "Hi there" ) // Test command - oEmpty:AddVirtual( "Dispose" ) // Clean up code - - oEmpty:Create() - endif -return oEmpty:Instance() - - -// -// Let's add another one on top -// -function TOnTop() - - static oOnTop - - if oOnTop == NIL - oOnTop := TClass():New( "TOnTop", { "TTextFile" } ) - oOnTop:AddInline( "Say", {|self, cArg| QOut( oSend(self, cArg) ) } ) - oOnTop:Create() - endif -return oOnTop:Instance() - - -// -// Generic Text file handler -// -function TTextFile() - - static oFile - - if oFile == NIL - oFile := TClass():New( "TTextFile", "TEmpty" ) - // Create a new class def - // from TEmpty class - - oFile:AddData( "cFileName" ) // Filename spec. by user - oFile:AddData( "hFile" ) // File handle - oFile:AddData( "nLine" ) // Current linenumber - oFile:AddData( "nError" ) // Last error - oFile:AddData( "lEoF" ) // End of file - oFile:AddData( "cBlock" ) // Storage block - oFile:AddData( "nBlockSize" ) // Size of read-ahead buffer - oFile:AddData( "cMode" ) // Mode of file use - // R = read, W = write - - oFile:AddMethod( "New" , @New() ) // Constructor - oFile:AddMethod( "Run" , @Run() ) // Get/set data - oFile:AddMethod( "Dispose", @Dispose() ) // Clean up code - oFile:AddMethod( "Read" , @Read() ) // Read line - oFile:AddMethod( "WriteLn", @WriteLn() ) // Write line - oFile:AddMethod( "Write" , @Write() ) // Write without CR - oFile:AddMethod( "Goto" , @Goto() ) // Go to line - - oFile:Create() - endif -return oFile:Instance() - - -// -// Method TextFile:New -> Create a new text file -// -// file name. No wild characters -// mode for opening. Default "R" -// Optional maximum blocksize -// -function New( cFileName, cMode, nBlock ) - - local self := QSelf() // Get self - - ::nLine := 0 - ::lEoF := .F. - ::cBlock := "" - ::cFileName := cFileName - ::cMode := Default( cMode, "R" ) - - if ::cMode == "R" - ::hFile := fOpen( cFileName ) - elseif ::cMode == "W" - ::hFile := fCreate( cFileName ) - else - QOut( "DosFile Init: Unknown file mode:", ::cMode ) - endif - - ::nError := fError() - if ::nError != 0 - ::lEoF := .T. - QOut( "Error ", ::nError) - endif - ::nBlockSize := Default( nBlock, 4096 ) - -return self - - -function Run( xTxt, lCRLF ) - - local self := QSelf() - local xRet - - if ::cMode == "R" - xRet := ::Read() - else - xRet := ::WriteLn( xTxt, lCRLF ) - endif -return xRet - - -// -// Dispose -> Close the file handle -// -function Dispose() - - local self := QSelf() - - ::cBlock := NIL - if ::hFile != -1 - if ::cMode == "W" .and. ::nError != 0 - ::Write( Chr(26) ) // Do not forget EOF marker - endif - if !fClose(::hFile) - ::nError := fError() - QOut( "Dos Error closing ", ::cFileName, " Code ", ::nError) - endif - endif -return self - - -// -// Read a single line -// -function Read() - - local self := QSelf() - local cRet := "" - local cBlock - local nCrPos - local nEoFPos - local nRead - - if ::hFile == -1 - QOut( "DosFile:Read : No file open" ) - elseif ::cMode != "R" - QOut( "File ", cFileName, " not open for reading" ) - elseif !::lEoF - - if Len(::cBlock) == 0 // Read new block - cBlock := fReadStr( ::hFile, ::nBlockSize ) - if len(cBlock) == 0 - ::nError := fError() // Error or EOF - ::lEoF := .T. - else - ::cBlock := cBlock - endif - endif - - if !::lEoF - ::nLine++ - nCRPos := At(Chr(10), ::cBlock) - if nCRPos != 0 // More than one line read - cRet := Substr( ::cBlock, 1, nCRPos - 1) - ::cBlock := Substr( ::cBlock, nCRPos + 1) - else // No complete line - cRet := ::cBlock - ::cBlock := "" - cRet += ::Read() // Read the rest - if !::lEoF - ::nLine-- // Adjust erroneous line count - endif - endif - nEoFPos := At( Chr(26), cRet ) - if nEoFPos != 0 // End of file read - cRet := Substr( cRet, 1, nEoFPos-1 ) - ::lEoF := .T. - endif - cRet := Strtran( cRet, Chr(13), "" ) // Remove CR - endif - endif -return cRet - - -// -// WriteLn -> Write a line to a file -// -// Text to write. May be any type. May also be an array containing -// one or more strings -// End with Carriage Return/Line Feed (Default == TRUE) -// -function WriteLn( xTxt, lCRLF ) - - local self := QSelf() - local cBlock - - if ::hFile == -1 - QOut( "DosFile:Write : No file open" ) - elseif ::cMode != 'W' - QOut( "File ",cFileName," not opened for writing" ) - else - cBlock := ToChar( xTxt ) // Convert to string - if Default( lCRLF, .T. ) - cBlock += Chr(10) // +chr(13) ?? - endif - fWrite( ::hFile, cBlock, len(cBlock) ) - if fError() != 0 - ::nError := fError() // Not completely written ! - endif - ::nLine := ::nLine + 1 - endif -return self - - -function Write( xTxt ) - - local self := QSelf() - -return ::WriteLn( xTxt, .F. ) - - -// -// Go to a specified line number -// -static function Goto( nLine ) - - local self := QSelf() - local nWhere := 1 - - if Empty(::hFile) - QOut( "DosFile:Goto : No file open" ) - elseif ::cMode != "R" - QOut( "File ", cName, " not open for reading" ) - else - ::lEoF := .F. // Clear (old) End of file - ::nLine := 0 // Start at beginning - ::cBlock := "" - fSeek(::hFile, 0) // Go top - do while !::lEoF .and. nWhere < nLine - nWhere++ - ::Read() - enddo - endif -return !lEoF - - - -