/* * $Id$ */ /* * Harbour Project source code: * Base Class for internal handling of class creation * * Copyright 1999 Antonio Linares * www - http://www.harbour-project.org * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). * * As a special exception, the Harbour Project gives permission for * additional uses of the text contained in its release of Harbour. * * The exception is that, if you link the Harbour libraries with other * files to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the Harbour library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the Harbour * Project under the name Harbour. If you copy code from other * Harbour Project or Free Software Foundation releases into a copy of * Harbour, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for Harbour, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. * */ /* * The following parts are Copyright of the individual authors. * www - http://www.harbour-project.org * * Copyright 2000 J. Lefebvre & RA. Cuylen * Multiple inheritance * Support shared class DATA * scoping (hidden, protected, readOnly) * Use of __cls_param function to allow multiple superclass declaration * Suppress of SetType and SetInit not more nedded * Delegation and forwarding * Preparing the InitClass class method (not working !! ) * * Copyright 1999 Eddie Runia * Support for inheritance * Support for default DATA values * * See doc/license.txt for licensing terms. * */ // Harbour Class HBClass to build classes #include "common.ch" #include "hboo.ch" REQUEST HBObject FUNCTION HBClass() STATIC s_hClass /* NOTE: Automatically default to NIL */ IF s_hClass == NIL s_hClass := __clsNew( "HBCLASS", 16,, @HBClass() ) /* s_hClass := __clsNew( "HBCLASS", 17,, @HBClass()) */ __clsAddMsg( s_hClass, "New" , @New() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "Create" , @Create() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddData" , @AddData() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddMultiData" , @AddMultiData() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddClassData" , @AddClassData() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddMultiClsData", @AddMultiClsData(), HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddInline" , @AddInline() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddMethod" , @AddMethod() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddClsMethod" , @AddClsMethod() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddVirtual" , @AddVirtual() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddDelegate" , @AddDelegate() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddFriendFunc" , @AddFriendFunc() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "AddFriendClass" , @AddFriendClass() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "Instance" , @Instance() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "SetOnError" , @SetOnError() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "SetDestructor" , @SetDestructor() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "InitClass" , @InitClass() , HB_OO_MSG_METHOD ) __clsAddMsg( s_hClass, "cSuper" , {| Self | iif( Empty( ::asSuper ), NIL, ::asSuper[ 1 ]:name ) }, HB_OO_MSG_INLINE ) __clsAddMsg( s_hClass, "hClass" , 1, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_hClass" , 1, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "cName" , 2, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_cName" , 2, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aDatas" , 3, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aDatas" , 3, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aMethods" , 4, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aMethods" , 4, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aClsDatas" , 5, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aClsDatas" , 5, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aClsMethods" , 6, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aClsMethods" , 6, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aInlines" , 7, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aInlines" , 7, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aVirtuals" , 8, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aVirtuals" , 8, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "aDelegates" , 9, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_aDelegates" , 9, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "asSuper" , 10, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_asSuper" , 10, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "nOnError" , 11, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_nOnError" , 11, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "nDestructor" , 12, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_nDestructor" , 12, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "lModFriendly" , 13, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_lModFriendly" , 13, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "asFriendClass" , 14, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_asFriendClass" , 14, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "asFriendFunc" , 15, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_asFriendFunc" , 15, HB_OO_MSG_ASSIGN ) __clsAddMsg( s_hClass, "sClassFunc" , 16, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_sClassFunc" , 16, HB_OO_MSG_ASSIGN ) /* __clsAddMsg( s_hClass, "class" , 17, HB_OO_MSG_ACCESS ) __clsAddMsg( s_hClass, "_class" , 17, HB_OO_MSG_ASSIGN ) */ ENDIF RETURN __clsInst( s_hClass ) //----------------------------------------------------------------------------// // xSuper is used here as the new preprocessor file (HBCLASS.CH) send here // always an array (if no superclass, this will be an empty one) // In case of direct class creation (without the help of preprocessor) xSuper can be // either NIL or contain the name of the superclass. STATIC FUNCTION New( cClassName, xSuper, sClassFunc, lModuleFriendly ) LOCAL Self := QSelf() LOCAL nSuper, i DEFAULT lModuleFriendly TO .F. IF Empty( xSuper ) ::asSuper := {} ELSEIF VALTYPE( xSuper ) == "C" ::asSuper := { __DynsN2Sym( xSuper ) } ELSEIF VALTYPE( xSuper ) == "S" ::asSuper := { xSuper } ELSEIF VALTYPE( xSuper ) == "A" ::asSuper := {} nSuper := Len( xSuper ) FOR i := 1 TO nSuper IF !Empty( xSuper[ i ] ) IF VALTYPE( xSuper[ i ] ) == "C" AADD( ::asSuper, __DynsN2Sym( xSuper[ i ] ) ) ELSEIF VALTYPE( xSuper[ i ] ) == "S" AADD( ::asSuper, xSuper[ i ] ) ENDIF ENDIF NEXT ENDIF ::cName := Upper( cClassName ) ::sClassFunc := sClassFunc ::lModFriendly := lModuleFriendly ::aDatas := {} ::aMethods := {} ::aClsDatas := {} ::aClsMethods := {} ::aInlines := {} ::aVirtuals := {} ::aDelegates := {} ::asFriendClass := {} ::asFriendFunc := {} RETURN QSelf() //----------------------------------------------------------------------------// /* STATIC PROCEDURE Create(MetaClass) */ STATIC PROCEDURE Create() LOCAL Self := QSelf() LOCAL n LOCAL nLen LOCAL nLenDatas := Len( ::aDatas ) //Datas local to the class !! LOCAL nClassBegin LOCAL hClass LOCAL ahSuper := {} /* Self:Class := MetaClass */ nLen := Len( ::asSuper ) FOR n := 1 TO nLen hClass := __clsInstSuper( ::asSuper[ n ] ) // Super handle available IF hClass != 0 AAdd( ahSuper, hClass ) ENDIF NEXT hClass := __clsNew( ::cName, nLenDatas, ahSuper, ::sClassFunc, ::lModFriendly ) ::hClass := hClass IF !EMPTY( ahSuper ) IF ahSuper[ 1 ] != 0 __clsAddMsg( hClass, "SUPER" , 0, HB_OO_MSG_SUPER, ahSuper[ 1 ], HB_OO_CLSTP_EXPORTED ) __clsAddMsg( hClass, "__SUPER", 0, HB_OO_MSG_SUPER, ahSuper[ 1 ], HB_OO_CLSTP_EXPORTED ) ENDIF ENDIF __clsAddMsg( hClass, "REALCLASS" , 0, HB_OO_MSG_REALCLASS, 0 , HB_OO_CLSTP_EXPORTED ) // We will work here on the MetaClass object to add the Class Method // as needed //nLen := Len( ::aClsMethods ) //FOR n := 1 TO nLen // // do it //NEXT //// //Local message... FOR n := 1 TO nLenDatas __clsAddMsg( hClass, ::aDatas[ n ][ HB_OO_DATA_SYMBOL ] , n, ; HB_OO_MSG_ACCESS, ::aDatas[ n ][ HB_OO_DATA_VALUE ], ::aDatas[ n ][ HB_OO_DATA_SCOPE ] ) __clsAddMsg( hClass, "_" + ::aDatas[ n ][ HB_OO_DATA_SYMBOL ] , n, ; HB_OO_MSG_ASSIGN, ::aDatas[ n ][ HB_OO_DATA_TYPE ] , ::aDatas[ n ][ HB_OO_DATA_SCOPE ] ) NEXT nLen := Len( ::aMethods ) FOR n := 1 TO nLen __clsAddMsg( hClass, ::aMethods[ n ][ HB_OO_MTHD_SYMBOL ], ::aMethods[ n ][ HB_OO_MTHD_PFUNCTION ],; HB_OO_MSG_METHOD, NIL, ::aMethods[ n ][ HB_OO_MTHD_SCOPE ] ) NEXT nLen := Len( ::aClsDatas ) nClassBegin := __CLS_CNTCLSDATA( hClass ) FOR n := 1 TO nLen __clsAddMsg( hClass, ::aClsDatas[ n ][ HB_OO_CLSD_SYMBOL ] , n + nClassBegin,; HB_OO_MSG_CLSACCESS, ::aClsDatas[ n ][ HB_OO_CLSD_VALUE ], ::aClsDatas[ n ][ HB_OO_CLSD_SCOPE ] ) __clsAddMsg( hClass, "_" + ::aClsDatas[ n ][ HB_OO_CLSD_SYMBOL ], n + nClassBegin,; HB_OO_MSG_CLSASSIGN, , ::aClsDatas[ n ][ HB_OO_CLSD_SCOPE ] ) NEXT nLen := Len( ::aInlines ) FOR n := 1 TO nLen __clsAddMsg( hClass, ::aInlines[ n ][ HB_OO_MTHD_SYMBOL ], ::aInlines[ n ][ HB_OO_MTHD_PFUNCTION ],; HB_OO_MSG_INLINE, NIL, ::aInlines[ n ][ HB_OO_MTHD_SCOPE ] ) NEXT nLen := Len( ::aVirtuals ) FOR n := 1 TO nLen __clsAddMsg( hClass, ::aVirtuals[ n ], n, HB_OO_MSG_VIRTUAL ) NEXT IF ::nOnError != NIL __clsAddMsg( hClass, "__OnError", ::nOnError, HB_OO_MSG_ONERROR ) ENDIF IF ::nDestructor != NIL __clsAddMsg( hClass, "__Destructor", ::nDestructor, HB_OO_MSG_DESTRUCTOR ) ENDIF //Friend Classes nLen := Len( ::asFriendClass ) FOR n := 1 TO nLen __clsAddFriend( ::hClass, ::asFriendClass[ n ] ) NEXT //Friend Functions nLen := Len( ::asFriendFunc ) FOR n := 1 TO nLen __clsAddFriend( ::hClass, ::asFriendFunc[ n ] ) NEXT RETURN //----------------------------------------------------------------------------// STATIC FUNCTION Instance() LOCAL Self := QSelf() LOCAL oInstance := __clsInst( ::hClass ) /*oInstance:Class := Self:Class*/ RETURN oInstance //----------------------------------------------------------------------------// STATIC PROCEDURE AddData( cData, xInit, cType, nScope, lNoinit ) LOCAL c DEFAULT lNoInit TO .F. DEFAULT nScope TO HB_OO_CLSTP_EXPORTED // Default Init for Logical and numeric IF ! lNoInit .AND. cType != NIL .AND. xInit == NIL c := Upper( Left( cType, 1 ) ) IF c == "L" /* Logical */ xInit := .F. ELSEIF c $ "NI" /* Numeric or Integer */ xInit := 0 ELSEIF c == "D" /* Date */ xInit := Ctod("") ENDIF ENDIF AAdd( QSelf():aDatas, { cData, xInit, cType, nScope } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddMultiData( cType, xInit, nScope, aData, lNoInit ) LOCAL i LOCAL nParam := Len( aData ) FOR i := 1 TO nParam IF VALTYPE( aData[ i ] ) == "C" QSelf():AddData( aData[ i ], xInit, cType, nScope, lNoInit ) ENDIF NEXT RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddClassData( cData, xInit, cType, nScope, lNoInit ) LOCAL c DEFAULT lNoInit TO .F. // Default Init for Logical and numeric IF ! lNoInit .AND. cType != NIL .AND. xInit == NIL c := Upper( Left( cType, 1 ) ) IF c == "L" /* Logical */ xInit := .F. ELSEIF c $ "NI" /* Numeric or Integer */ xInit := 0 ELSEIF c == "D" /* Date */ xInit := Ctod("") ENDIF ENDIF AAdd( QSelf():aClsDatas, { cData, xInit, cType, nScope } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddMultiClsData( cType, xInit, nScope, aData, lNoInit ) LOCAL i LOCAL nParam := Len( aData ) FOR i := 1 TO nParam IF VALTYPE( aData[ i ] ) == "C" QSelf():AddClassData( aData[ i ], xInit, cType, nScope, lNoInit ) ENDIF NEXT RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddInline( cMethod, bCode, nScope ) DEFAULT nScope TO HB_OO_CLSTP_EXPORTED AAdd( QSelf():aInlines, { cMethod, bCode, nScope } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddMethod( cMethod, nFuncPtr, nScope ) DEFAULT nScope TO HB_OO_CLSTP_EXPORTED AAdd( QSelf():aMethods, { cMethod, nFuncPtr, nScope } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddClsMethod( cMethod, nFuncPtr, nScope ) AAdd( QSelf():aClsMethods, { cMethod, nFuncPtr, nScope } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddVirtual( cMethod ) AAdd( QSelf():aVirtuals, cMethod ) RETURN STATIC PROCEDURE AddDelegate( xMethod, nAccScope, nAsgScope, cType, cDelegMsg, cDelegClass ) LOCAL i IF VALTYPE( xMethod ) == "C" AAdd( QSelf():aDelegates, { xMethod, nAccScope, nAsgScope, cType, cDelegMsg, cDelegClass } ) ELSEIF VALTYPE( xMethod ) == "A" FOR i := 1 TO LEN( xMethod ) AAdd( QSelf():aDelegates, { xMethod[ i ], nAccScope, nAsgScope, cType, cDelegMsg, cDelegClass } ) NEXT ENDIF RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddFriendClass( ... ) LOCAL Self := QSelf() AEval( HB_AParams(), { | sClass | AAdd( ::asFriendClass, sClass ) } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE AddFriendFunc( ... ) LOCAL Self := QSelf() AEval( HB_AParams(), { | sFunc | AAdd( ::asFriendFunc, sFunc ) } ) RETURN //----------------------------------------------------------------------------// STATIC PROCEDURE SetOnError( nFuncPtr ) QSelf():nOnError := nFuncPtr RETURN STATIC PROCEDURE SetDestructor( nFuncPtr ) QSelf():nDestructor := nFuncPtr RETURN //----------------------------------------------------------------------------// STATIC FUNCTION InitClass() RETURN QSelf() //----------------------------------------------------------------------------//