diff --git a/harbour/ChangeLog b/harbour/ChangeLog index d9b87e070a..8362d16c20 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,9 @@ +19990530-14:00 CET Eddie Runia + * source/rtl/classes.c; source/rtl/tclass.prg + first step to inheritage + * tests/working/inherit.prg + test program + 19990530-13:15 CET Eddie Runia * source/rtl/classes.c message <> not found bug finally removed diff --git a/harbour/source/rtl/classes.c b/harbour/source/rtl/classes.c index 73c9f0a69d..8854ad995c 100644 --- a/harbour/source/rtl/classes.c +++ b/harbour/source/rtl/classes.c @@ -63,8 +63,9 @@ HARBOUR CLASSCREATE() /* cClassName, nDatas, hSuper --> hClass */ if( hSuper ) { - pClasses[ wClasses ].wDatas += pClasses[ hSuper ].wDatas; - pClasses[ wClasses ].wMethods = pClasses[ hSuper ].wMethods; + hSuper--; + pClasses[ wClasses ].wDatas = pClasses[ hSuper ].wDatas; + pClasses[ wClasses ].wMethods = pClasses[ hSuper ].wMethods; pClasses[ wClasses ].pClassDatas = hb_arrayClone( pClasses[ hSuper ].pClassDatas ); pClasses[ wClasses ].pInlines = @@ -351,6 +352,8 @@ HARBOUR CLASSADD() /* hClass, cMessage, pFunction, nType, xInit */ if( wAt < wLimit ) { + if( !pClass->pMethods[ wAt ].pMessage ) + pClass->wMethods++; pClass->pMethods[ wAt ].pMessage = pMessage; switch( wType ) { @@ -401,7 +404,6 @@ HARBOUR CLASSADD() /* hClass, cMessage, pFunction, nType, xInit */ exit( 1 ); break; } - pClass->wMethods++; return; } } diff --git a/harbour/source/rtl/tclass.prg b/harbour/source/rtl/tclass.prg index e31572e6c0..68e6e185c5 100644 --- a/harbour/source/rtl/tclass.prg +++ b/harbour/source/rtl/tclass.prg @@ -16,7 +16,7 @@ function TClass() static hClass := 0 if hClass == 0 - hClass = ClassCreate( "TCLASS", 7 ) + hClass = ClassCreate( "TCLASS", 8 ) ClassAdd( hClass, "New", @New(), MET_METHOD ) ClassAdd( hClass, "Create", @Create(), MET_METHOD ) @@ -41,13 +41,15 @@ function TClass() ClassAdd( hClass, "_aInlines", 6, MET_DATA ) ClassAdd( hClass, "aVirtuals", 7, MET_DATA ) ClassAdd( hClass, "_aVirtuals", 7, MET_DATA ) + ClassAdd( hClass, "hSuper", 8, MET_DATA ) + ClassAdd( hClass, "_hSuper", 8, MET_DATA ) endif return ClassInstance( hClass ) //----------------------------------------------------------------------------// -static function New( cClassName ) +static function New( cClassName, hSuper ) local Self := QSelf() @@ -57,6 +59,7 @@ static function New( cClassName ) ::aClsDatas = {} ::aInlines = {} ::aVirtuals = {} + ::hSuper = Default( hSuper, 0 ) return Self @@ -66,7 +69,7 @@ static function Create() local Self := QSelf() local n, nLen := Len( ::aDatas ) - local hClass := ClassCreate( ::cName, nLen ) + local hClass := ClassCreate( ::cName, nLen, ::hSuper ) ::hClass = hClass diff --git a/harbour/tests/working/inherit.prg b/harbour/tests/working/inherit.prg new file mode 100644 index 0000000000..6c476f64b1 --- /dev/null +++ b/harbour/tests/working/inherit.prg @@ -0,0 +1,287 @@ +#include "set.ch" + +// +// Inherit +// +// First step to inheritage +// +// Date : 30/05/1999 +// +// Antonio : Please Help ! Super / Multiple inheritage etc. +// + +function Main( cFrom, cTo ) + + local oFrom + local oTo + local cOut + + set( _SET_EXACT, .T.) + cFrom := Default( cFrom, "strip.prg" ) + cTo := Default( cTo, "strip.out" ) + + oFrom := TTextFile() + HBDebug( { aoMethod( oFrom ), aoData( oFrom ) } ) +// oFrom:Super:Run() + oFrom:New( cFrom, "R" ) + oTo := TTextFile() +// HBDebug( aoMethod( oTo ) ) + oTo:New( cTo , "W" ) + + do while !oFrom:lEoF + cOut := oFrom:Run() + if alltrim(cOut) != "" + oTo:Run( cOut ) + endif + enddo + QOut( "Number of lines", oTo:nLine ) + 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} ) // Constructor + oEmpty:AddInline( "Run", {||QOut( "Run!" ) } ) // Test command + oEmpty:AddVirtual( "Dispose" ) // Clean up code + + oEmpty:Create() + endif +return oEmpty:Instance() + + + +// +// Generic DOS file handler +// +function TTextFile() + + static oFile + + if oFile == NIL + oFile := TClass():New( "TTEXTFILE", TEmpty():ClassH() ) + // Create a new class def + + 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( "EoF" , @EoF() ) // End of file as function + 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 := ::nLine + 1 // ++ not available + 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 := ::nLine - 1 // 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. ) + + +//function EoF() +// +// local self := QSelf() +//return ::lEoF + + +// +// Go to a specified line number +// +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++ + ::Run() + enddo + endif +return !lEoF + + + +