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

see changelog

Browse Source
This commit is contained in:
Eddie Runia
1999-06-01 20:38:55 +00:00
parent 700a198a27
commit 818a783060
5 changed files with 413 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
harbour/ChangeLog
View File

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

28
harbour/source/rtl/classes.c
View File

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

30
harbour/source/rtl/tclass.prg
View File

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

77
harbour/tests/working/inifiles.prg
View File

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

307
harbour/tests/working/multinh.prg Normal file
View File

@@ -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
//
// <cFile> file name. No wild characters
// <cMode> mode for opening. Default "R"
// <nBlockSize> 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
//
// <xTxt> Text to write. May be any type. May also be an array containing
// one or more strings
// <lCRLF> 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