see changelog

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

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;
       }
    }

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
 

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
+//
+// <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 := ::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
+//
+// <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. )
+
+
+//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
+
+
+
+