From 818a7830608569533ddbb5cd093c22582d6944ab Mon Sep 17 00:00:00 2001 From: Eddie Runia Date: Tue, 1 Jun 1999 20:38:55 +0000 Subject: [PATCH] see changelog --- harbour/ChangeLog | 4 + harbour/source/rtl/classes.c | 28 ++- harbour/source/rtl/tclass.prg | 30 ++- harbour/tests/working/inifiles.prg | 77 ++++++-- harbour/tests/working/multinh.prg | 307 +++++++++++++++++++++++++++++ 5 files changed, 413 insertions(+), 33 deletions(-) create mode 100644 harbour/tests/working/multinh.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 5f01a8037d..35f4365b7f 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,7 @@ +19990601-21:35 CET Eddie Runia + * tests/working/multinh.prg, source/rtl/classes.c, source/rtl/tclass.prg + first step to multiple inheritance + 19990601-18:15 CET Eddie Runia * tests/working/inherit.prg, source/rtl/classes.c, source/rtl/tclass.prg version correct release (+ super ) diff --git a/harbour/source/rtl/classes.c b/harbour/source/rtl/classes.c index e572311d95..56b58f2c55 100644 --- a/harbour/source/rtl/classes.c +++ b/harbour/source/rtl/classes.c @@ -38,7 +38,6 @@ typedef struct WORD wHashKey; PITEM pClassDatas; /* Array for ClassDatas */ PITEM pInlines; /* Array for inline codeblocks */ -/* PITEM pInitValues; */ /* Array for Datas init values */ } CLASS, * PCLASS; #define BUCKET 4 @@ -48,12 +47,14 @@ extern SYMBOL symEval; PCLASS pClasses = 0; WORD wClasses = 0; -PMETHOD pMethod = 0; +PMETHOD pMethod = 0; PDYNSYM msgClassName = 0, msgClassH = 0, msgEval = 0, msgClassSel = 0; -HARBOUR CLASSCREATE() /* cClassName, nDatas, hSuper --> hClass */ +HARBOUR CLASSCREATE() /* cClassName, nDatas, xSuper --> hClass */ { - WORD hSuper = _parni( 3 ); /* Super class present */ + WORD hSuper = 0; + PITEM pSuper = _param( 3, IT_ANY ); /* Super class present */ + PITEM pItem; if( ! pClasses ) pClasses = ( PCLASS ) _xgrab( sizeof( CLASS ) ); @@ -63,9 +64,22 @@ HARBOUR CLASSCREATE() /* cClassName, nDatas, hSuper --> hClass */ pClasses[ wClasses ].szName = ( char * ) _xgrab( _parclen( 1 ) + 1 ); strcpy( pClasses[ wClasses ].szName, _parc( 1 ) ); - if( hSuper ) + + if( pSuper ) { - hSuper--; + 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 ); + } + } pClasses[ wClasses ].wDataFirst = pClasses[ hSuper ].wDatas; pClasses[ wClasses ].wDatas = pClasses[ hSuper ].wDatas + _parni(2); pClasses[ wClasses ].wMethods = pClasses[ hSuper ].wMethods; @@ -92,7 +106,6 @@ HARBOUR CLASSCREATE() /* cClassName, nDatas, hSuper --> hClass */ pClasses[ wClasses ].pClassDatas = hb_itemArrayNew( 0 ); pClasses[ wClasses ].pInlines = hb_itemArrayNew( 0 ); - /* pClasses[ wClasses ].pInitValues = hb_itemArrayNew( 0 ); */ memset( pClasses[ wClasses ].pMethods, 0, 100 * sizeof( METHOD ) ); } @@ -563,7 +576,6 @@ void ReleaseClass( PCLASS pClass ) hb_itemRelease( pClass->pClassDatas ); hb_itemRelease( pClass->pInlines ); - /* hb_itemRelease( pClass->pInitValues ); */ } void ReleaseClasses( void ) diff --git a/harbour/source/rtl/tclass.prg b/harbour/source/rtl/tclass.prg index d08539099c..ddb938184e 100644 --- a/harbour/source/rtl/tclass.prg +++ b/harbour/source/rtl/tclass.prg @@ -70,21 +70,37 @@ return Self static function Create() - local Self := QSelf() - local n, nLen := Len( ::aDatas ) - local hClass + local Self := QSelf() + local n + local nLen + local nLenDatas := Len( ::aDatas ) local nDataBegin := 0 + local hClass local hSuper + local ahSuper := {} if ::xSuper == NIL - hClass := ClassCreate( ::cName, nLen ) + hClass := ClassCreate( ::cName, nLenDatas ) elseif ValType(::xSuper) == "A" // Multiple inheritance - QOut( "Sorry, not supported yet :-)" ) + 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 ) ) - hClass := ClassCreate( ::cName, nLen, hSuper ) + hClass := ClassCreate( ::cName, nLenDatas, hSuper ) // Add class casts ClassAdd( hClass, Upper( ::xSuper ), hSuper, MET_SUPER ) ClassAdd( hClass, "SUPER", hSuper, MET_SUPER ) @@ -94,7 +110,7 @@ static function Create() ::hClass = hClass - for n = 1 to nLen + for n = 1 to nLenDatas ClassAdd( hClass, ::aDatas[ n ][ DAT_SYMBOL ], n + nDataBegin, MET_DATA, ; ::aDatas[ n ][ DAT_INITVAL ] ) ClassAdd( hClass, "_" + ::aDatas[ n ][ DAT_SYMBOL ], n + nDataBegin, MET_DATA ) diff --git a/harbour/tests/working/inifiles.prg b/harbour/tests/working/inifiles.prg index 433bcbf615..5b8b2ea229 100644 --- a/harbour/tests/working/inifiles.prg +++ b/harbour/tests/working/inifiles.prg @@ -1,4 +1,20 @@ -function Main() +#define IF_BUFFER 65535 + +function Main(cFilename, cSection) + local oIni := TIniFile():New( Default( cFilename, "harbour.ini" ) ) + local s, n := Val(Default( cSection, "1" )) + + qout('') + qout('Sections:') + s := oIni:ReadSections() + aeval(s, {|x| qout('[' + x + ']')}) + + qout('') + qout('[' + s[n] + ']') + s := oIni:ReadSection(s[n]) + aeval(s, {|x| qout(x)}) + + /* local i := TIniFile():New('harbour.ini') local s @@ -20,8 +36,11 @@ function Main() s := i:ReadSection(s[1]) aeval(s, {|x| qout(x)}) + i:DeleteKey('test', 'hello') + i:Filename := 'harbour.new' i:Commit() // saves file + */ return nil function TIniFile() @@ -38,6 +57,8 @@ function TIniFile() oClass:AddMethod( "WriteString", @WriteString() ) oClass:AddMethod( "ReadSection", @ReadSection() ) oClass:AddMethod( "ReadSections", @ReadSections() ) + oClass:AddMethod( "DeleteKey", @DeleteKey() ) + oClass:AddMethod( "EraseSection", @EraseSection() ) oClass:AddMethod( "Commit", @Commit() ) oClass:Create() // builds this class @@ -66,8 +87,8 @@ static function New(cFileName) hFile := fcreate(cFilename) endif - cFile := space(255) - do while (nPos := fread(hFile, @cFile, 255)) > 0 + cFile := space(IF_BUFFER) + do while (nPos := fread(hFile, @cFile, IF_BUFFER)) > 0 do while !Empty(cFile) if (nPos := At(Chr(13), cFile)) > 1 @@ -83,7 +104,7 @@ static function New(cFileName) if Left(cLine, 1) == '[' // new section if (nPos := At(']', cLine)) > 1 cLine := substr(cLine, 2, nPos - 2); - + else cLine := substr(cLine, 2) endif @@ -98,9 +119,9 @@ static function New(cFileName) if (nPos := At('=', cLine)) > 0 cIdent := Left(cLine, nPos - 1) cLine := SubStr(cLine, nPos + 1) - + AAdd( CurrArray, { cIdent, cLine } ) - + else AAdd( CurrArray, { cLine, '' } ) endif @@ -108,8 +129,8 @@ static function New(cFileName) endif end - cFile := space(255) - fread(hFile, cFile, 255) + cFile := space(IF_BUFFER) + fread(hFile, cFile, IF_BUFFER) end fclose(hFile) endif @@ -119,7 +140,7 @@ static function ReadString(cSection, cIdent, cDefault) local Self := QSelf() local cResult := cDefault local j, i := AScan( ::Contents, {|x| x[1] == cSection} ) - + if i > 0 j := AScan( ::Contents[i][2], {|x| x[1] == cIdent} ) @@ -155,8 +176,7 @@ static procedure WriteString(cSection, cIdent, cString) ::Contents := a endif - elseif (i := AScan( ::Contents, {|x| x[1] == cSection .and. ; - ValType(x[2]) == 'A'})) > 0 + elseif (i := AScan( ::Contents, {|x| x[1] == cSection .and. ValType(x[2]) == 'A'})) > 0 j := AScan( ::Contents[i][2], {|x| x[1] == cIdent} ) if j > 0 @@ -169,6 +189,31 @@ static procedure WriteString(cSection, cIdent, cString) else AAdd( ::Contents, {cSection, {{cIdent, cString}}} ) endif +return + +static procedure DeleteKey(cSection, cIdent) + local Self := QSelf() + local j, i := AScan( ::Contents, {|x| x[1] == cSection} ) + + if i > 0 + j := AScan( ::Contents[i][2], {|x| x[1] == cIdent} ) + + ADel( ::Contents[i][2], j ) + ASize( ::Contents[i][2], Len(::Contents[i][2]) - 1 ) + endif +return + +static procedure EraseSection(cSection) + local Self := QSelf() + local i + + if Empty(cSection) + outerr('Must specify a section') + + elseif (i := AScan( ::Contents, {|x| x[1] == cSection .and. ValType(x[2]) == 'A'})) > 0 + ADel( ::Contents, i ) + ASize( ::Contents, Len(::Contents) - 1 ) + endif return static function ReadSection(cSection) @@ -178,8 +223,7 @@ static function ReadSection(cSection) if Empty(cSection) outerr('Must specify a section') - elseif (i := AScan( ::Contents, {|x| x[1] == cSection .and. ; - ValType(x[2]) == 'A'})) > 0 + elseif (i := AScan( ::Contents, {|x| x[1] == cSection .and. ValType(x[2]) == 'A'})) > 0 for j := 1 to Len(::Contents[i][2]) @@ -206,7 +250,6 @@ static procedure Commit() local Self := QSelf() local i, j, hFile - qout('Writing to file ' + ::Filename) hFile := fcreate(::Filename) for i := 1 to Len(::Contents) @@ -221,15 +264,13 @@ static procedure Commit() fwrite(hFile, ::Contents[i][2][j][2] + Chr(13) + Chr(10)) else - fwrite(hFile, ::Contents[i][2][j][1] + '=' + ; - ::Contents[i][2][j][2] + Chr(13) + Chr(10)) + fwrite(hFile, ::Contents[i][2][j][1] + '=' + ::Contents[i][2][j][2] + Chr(13) + Chr(10)) endif next j fwrite(hFile, Chr(13) + Chr(10)) elseif ValType(::Contents[i][2]) == 'C' - fwrite(hFile, ::Contents[i][1] + '=' + ::Contents[i][2] +; - Chr(13) + Chr(10)) + fwrite(hFile, ::Contents[i][1] + '=' + ::Contents[i][2] + Chr(13) + Chr(10)) endif next i diff --git a/harbour/tests/working/multinh.prg b/harbour/tests/working/multinh.prg new file mode 100644 index 0000000000..6d23c01fa7 --- /dev/null +++ b/harbour/tests/working/multinh.prg @@ -0,0 +1,307 @@ +#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 + + + +