Code: Select all
;-TOP
; Comment : Module as Object Class Dispatch inclusive Class Factory
; Author : mk-soft
; Version : v1.29
; Created : 04.03.2017
; Updated : 05.06.2017
; Link GE : http://www.purebasic.fr/german/viewtopic.php?f=8&t=30103
; Link EN : http://www.purebasic.fr/english/viewtopic.php?f=12&t=68101
; ***************************************************************************************
;- Begin Declare Module ClassCommon
DeclareModule ClassCommon
#EnableClassDebug = #True ; Set to False for remove all class debug functions
; ---------------------------------------------------------------------------
Structure udtObjectCounter
Count.i
Mutex.i
EndStructure
Global __ObjectCounter.udtObjectCounter
Macro GlobalObjectCounter(fLock)
LockMutex(ClassCommon::__ObjectCounter\Mutex)
If fLock
ClassCommon::__ObjectCounter\Count + 1
Else
If ClassCommon::__ObjectCounter\Count > 0
ClassCommon::__ObjectCounter\Count - 1
EndIf
EndIf
UnlockMutex(ClassCommon::__ObjectCounter\Mutex)
EndMacro
; ---------------------------------------------------------------------------
Structure udtArrayVariant
Arg.Variant[0]
EndStructure
; ---------------------------------------------------------------------------
;-- Public Debug Functions
Global __IsClassDebug
Declare ClassDebugLogging(Modul.s, Function.s, Info.s, *Object)
Declare EnableClassDebug(Enable = #True)
Macro ClassDebug(Info, Object=0)
CompilerIf #EnableClassDebug
ClassDebugLogging(#PB_Compiler_Module, #PB_Compiler_Procedure, Info, Object)
CompilerEndIf
EndMacro
Macro ClassDebugEx(Modul, Function, Info, Object=0)
CompilerIf #EnableClassDebug
ClassDebugLogging(Modul, Function, Info, Object)
CompilerEndIf
EndMacro
; ---------------------------------------------------------------------------
;-- Public Help Functions
Declare.s GetGuidString(*Guid.GUID)
Declare.i GetVariantBool(*vArg.Variant)
Declare.i GetVariantInteger(*vArg.Variant)
Declare.i GetVariantLong(*vArg.Variant)
Declare.q GetVariantQuad(*vArg.Variant)
Declare.f GetVariantFloat(*vArg.Variant)
Declare.d GetVariantDouble(*vArg.Variant)
Declare.s GetVariantString(*vArg.Variant)
Declare.i GetVariantDate(*vArg.Variant)
Declare.i GetVariantVariant(*vArg.Variant)
Declare SetVariantBool(*vArg.Variant, Value.i)
Declare SetVariantInteger(*vArg.Variant, Value.i)
Declare SetVariantLong(*vArg.Variant, Value.i)
Declare SetVariantQuad(*vArg.Variant, Value.q)
Declare SetVariantFloat(*vArg.Variant, Value.f)
Declare SetVariantDouble(*vArg.Variant, Value.d)
Declare SetVariantString(*vArg.Variant, Value.s)
Declare SetVariantDate(*vArg.Variant, Date.i)
Declare SetVariantVariant(*vArg.Variant, *Value.Variant)
Declare SetVariantObject(*vArg.Variant, *Object)
; ---------------------------------------------------------------------------
DataSection
IID_INull: ; {00000000-0000-0000-0000-000000000000}
Data.l $00000000
Data.w $0000,$0000
Data.b $00,$00,$00,$00,$00,$00,$00,$00
IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
Data.l $00000000
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
Data.l $00020400
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IDispatchEx: ; {A6EF9860-C720-11D0-9337-00A0C90DCAA9}
Data.l $A6EF9860
Data.w $C720, $11D0
Data.b $93, $37, $00, $A0, $C9, $0D, $CA, $A9
IID_IClassFactory: ; {00000001-0000-0000-C000-000000000046}
Data.l $00000001
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IClassFactoryEx: ; {342D1EA0-AE25-11D1-89C5-006008C3FBFC}
Data.l $342D1EA0
Data.w $AE25,$11D1
Data.b $89,$C5,$00,$60,$08,$C3,$FB,$FC
EndDataSection
; ---------------------------------------------------------------------------
EndDeclareModule
; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;- Begin Module ClassCommon
Module ClassCommon
EnableExplicit
; ---------------------------------------------------------------------------
Procedure InitClassCommon()
__ObjectCounter\Mutex = CreateMutex()
EndProcedure : InitClassCommon()
; ---------------------------------------------------------------------------
Procedure ClassDebugLogging(Modul.s, Function.s, Info.s, *Object)
CompilerIf #EnableClassDebug
Static file.s, mutex.i
Protected id, Object.s
If __IsClassDebug
If Not Bool(file)
mutex = CreateMutex()
LockMutex(mutex)
file = ProgramFilename()
file = ReplaceString(file, ".dll", ".log", #PB_String_NoCase)
file = ReplaceString(file, ".exe", ".log", #PB_String_NoCase)
id = OpenFile(#PB_Any, file, #PB_File_Append)
If id
If *object
Object = " [" + Hex(*Object) + "]"
EndIf
WriteStringN(id, "Start Logging: " + FormatDate("%yyyy-%mm-%dd %hh:%ii:%ss", Date()), #PB_Ascii)
WriteStringN(id, "[" + Modul + "." + Function + "] " + Info + Object, #PB_Ascii)
CloseFile(id)
EndIf
UnlockMutex(mutex)
Else
LockMutex(mutex)
id = OpenFile(#PB_Any, file, #PB_File_Append)
If id
If *object
Object = " [" + Hex(*Object) + "]"
EndIf
WriteStringN(id, "[" + Modul + "." + Function + "] " + Info + Object, #PB_Ascii)
CloseFile(id)
EndIf
UnlockMutex(mutex)
EndIf
EndIf
CompilerEndIf
EndProcedure
Procedure EnableClassDebug(Enable = #True)
__IsClassDebug = Enable
EndProcedure
; ---------------------------------------------------------------------------
Procedure.s GetGuidString(*Guid.GUID)
Protected msg.s
msg = "{"
msg + RSet (Hex(*Guid\Data1 , #PB_Long), 8, "0") + "-"
msg + RSet (Hex(*Guid\Data2 , #PB_Word), 4, "0") + "-"
msg + RSet (Hex(*Guid\Data3 , #PB_Word), 4, "0") + "-"
msg + RSet (Hex(*Guid\Data4[0], #PB_Byte), 2, "0")
msg + RSet (Hex(*Guid\Data4[1], #PB_Byte), 2, "0") + "-"
msg + RSet (Hex(*Guid\Data4[2], #PB_Byte), 2, "0")
msg + RSet (Hex(*Guid\Data4[3], #PB_Byte), 2, "0")
msg + RSet (Hex(*Guid\Data4[4], #PB_Byte), 2, "0")
msg + RSet (Hex(*Guid\Data4[5], #PB_Byte), 2, "0")
msg + RSet (Hex(*Guid\Data4[6], #PB_Byte), 2, "0")
msg + RSet (Hex(*Guid\Data4[7], #PB_Byte), 2, "0")
msg + "}"
ProcedureReturn msg
EndProcedure
; ---------------------------------------------------------------------------
;-- Help functions get variant value
Procedure.i GetVariantBool(*vArg.Variant)
Protected r1, vArg.Variant
r1 = #False
If VariantChangeType_(vArg, *vArg, 0, #VT_BOOL) = #S_OK
If vArg\bool
r1 = #True
EndIf
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.i GetVariantInteger(*vArg.Variant)
Protected r1.i, vArg.Variant
CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
If *vArg\vt = #VT_I4
ProcedureReturn *vArg\lVal
EndIf
CompilerElse
If *vArg\vt = #VT_I8
ProcedureReturn *vArg\llVal
EndIf
CompilerEndIf
r1 = 0
CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
If VariantChangeType_(vArg, *vArg, 0, #VT_I4) = #S_OK
r1 = vArg\lVal
EndIf
CompilerElse
If VariantChangeType_(vArg, *vArg, 0, #VT_I8) = #S_OK
r1 = vArg\llVal
EndIf
CompilerEndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.i GetVariantLong(*vArg.Variant)
Protected r1.i, vArg.Variant
If *vArg\vt = #VT_I4
ProcedureReturn *vArg\lVal
EndIf
r1 = 0
If VariantChangeType_(vArg, *vArg, 0, #VT_I4) = #S_OK
r1 = vArg\lVal
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.q GetVariantQuad(*vArg.Variant)
Protected r1.q, vArg.Variant
If *vArg\vt = #VT_I8
ProcedureReturn *vArg\llVal
EndIf
r1 = 0
If VariantChangeType_(vArg, *vArg, 0, #VT_I8) = #S_OK
r1 = vArg\llVal
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.f GetVariantFloat(*vArg.Variant)
Protected r1.f, vArg.Variant
If *vArg\vt = #VT_R4
ProcedureReturn *vArg\fltVal
EndIf
r1 = 0.0
If VariantChangeType_(vArg, *vArg, 0, #VT_R4) = #S_OK
r1 = vArg\fltVal
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.d GetVariantDouble(*vArg.Variant)
Protected r1.d, vArg.Variant
If *vArg\vt = #VT_R8
ProcedureReturn *vArg\dblVal
EndIf
r1 = 0.0
If VariantChangeType_(vArg, *vArg, 0, #VT_R8) = #S_OK
r1 = vArg\dblVal
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.s GetVariantString(*vArg.Variant)
Protected r1.s, vArg.Variant
r1 = ""
If *vArg\vt = #VT_BSTR
r1 = PeekS(*vArg\bstrVal)
ProcedureReturn r1
EndIf
If VariantChangeType_(vArg, *vArg, 0, #VT_BSTR) = #S_OK
r1 = PeekS(vArg\bstrVal)
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.i GetVariantDate(*vArg.Variant) ; Result PB_Date
Protected r1.i, vArg.Variant
r1 = 0
If *vArg\vt = #VT_DATE
r1 = (*vArg\date - 25569.0) * 86400.0
ProcedureReturn r1
EndIf
If VariantChangeType_(vArg, *vArg, 0, #VT_DATE) = #S_OK
r1 = (vArg\date - 25569.0) * 86400.0
EndIf
VariantClear_(vArg)
ProcedureReturn r1
EndProcedure
Procedure.i GetVariantVariant(*vArg.Variant) ; Result pointer to varint (ByRef)
ProcedureReturn *vArg
EndProcedure
; ---------------------------------------------------------------------------
;-- Help functions set variant value
Procedure SetVariantBool(*vArg.Variant, Value.i)
VariantClear_(*vArg)
*vArg\vt = #VT_BOOL
If Value
*vArg\bool = #VARIANT_TRUE
Else
*vArg\bool = #VARIANT_FALSE
EndIf
EndProcedure
Procedure SetVariantInteger(*vArg.Variant, Value.i)
VariantClear_(*vArg)
CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
*vArg\vt = #VT_I4
*vArg\lVal = Value
CompilerElse
*vArg\vt = #VT_I8
*vArg\llVal = Value
CompilerEndIf
EndProcedure
Procedure SetVariantLong(*vArg.Variant, Value.i)
VariantClear_(*vArg)
*vArg\vt = #VT_I4
*vArg\lVal = Value
EndProcedure
Procedure SetVariantQuad(*vArg.Variant, Value.q)
VariantClear_(*vArg)
*vArg\vt = #VT_I8
*vArg\llVal = Value
EndProcedure
Procedure SetVariantFloat(*vArg.Variant, Value.f)
VariantClear_(*vArg)
*vArg\vt = #VT_R4
*vArg\fltVal = Value
EndProcedure
Procedure SetVariantDouble(*vArg.Variant, Value.d)
VariantClear_(*vArg)
*vArg\vt = #VT_R8
*vArg\dblVal = Value
EndProcedure
Procedure SetVariantString(*vArg.Variant, Value.s)
VariantClear_(*vArg)
*vArg\vt = #VT_BSTR
*vArg\bstrVal = SysAllocString_(Value)
EndProcedure
Procedure SetVariantDate(*vArg.Variant, Date.i)
VariantClear_(*vArg)
*vArg\vt = #VT_DATE
*vArg\date = Date / 86400.0 + 25569.0
EndProcedure
Procedure SetVariantVariant(*vArg.Variant, *vValue.Variant)
VariantClear_(*vArg)
VariantCopy_(*vArg, *vValue)
EndProcedure
Procedure SetVariantObject(*vArg.Variant, *Object)
VariantClear_(*vArg)
If *Object
*vArg\vt = #VT_DISPATCH
*vArg\pdispVal = *Object
Else
*vArg\vt = #VT_ERROR
*vArg\scode = #E_OUTOFMEMORY
EndIf
EndProcedure
; ---------------------------------------------------------------------------
EndModule
;- End Module ClassCommon
; ***************************************************************************************
;-Begin Declare Module ClassDispatch
DeclareModule ClassDispatch
; ---------------------------------------------------------------------------
; Internal Class Manager
Prototype ProtoInvoke(*This)
Prototype ProtoInvokeDispatch(*This, DispId.i, *iid.IID, lcid.i, Flags.i, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
Structure udtInvoke
*Invoke.ProtoInvoke
EndStructure
Structure udtMethode
Index.i
EndStructure
Structure udtProperty
Index.i
Type.i
Offset.i
EndStructure
Structure udtClass
Array *vTable(6)
Array *vDispInvoke(6)
Map vMethodeID.udtMethode()
Map vPropertyID.udtProperty()
List Initalize.udtInvoke()
List Dispose.udtInvoke()
cDispInvoke.i
Mutex.i
EndStructure
Structure udtClasses
Map Entry.udtClass()
EndStructure
Global Class.udtClasses
; ---------------------------------------------------------------------------
; BaseClass declaration
Structure sBaseSystem
*vTable
*Self.udtClass
RefCounter.i
Mutex.i
EndStructure
;-- Public Structure
Structure sClassDispatch
System.sBaseSystem
EndStructure
;-- Public Interface
Interface iClassDispatch
QueryInterface(*riid, *addr)
AddRef()
Release()
GetTypeInfoCount(*CntTypeInfo.Integer)
GetTypeInfo(TypeInfo.i, LocalId.i, *ppTypeInfo.Integer)
GetIDsOfNames(*iid.IID, *Names, cntNames.i, lcid.i, *DispId)
Invoke(DispId.i, *iid.IID, lcid.i, Flags.i, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
EndInterface
; ---------------------------------------------------------------------------
Macro dq
"
EndMacro
; ---------------------------------------------------------------------------
;-- Macros to defined object
; Added New Class
Declare AddClass(ClassName.s, ClassExtends.s, Size) ; Internal
Macro NewClass(ClassInterface, ClassExtends=ClassDispatch)
; Interface helper
Interface __Interface Extends ClassInterface
EndInterface
; Add Class
AddClass(#PB_Compiler_Module, dq#ClassExtends#dq, SizeOf(__Interface) / SizeOf(integer))
EndMacro
; ---------------------------------------------------------------------------
; Macro for init object (default)
Macro InitObject(sProperty)
Protected *Object.sProperty
*Object = AllocateStructure(sProperty)
If *Object
GlobalObjectCounter(#True)
*Object\System\vTable = Class\Entry(#PB_Compiler_Module)\vTable()
*Object\System\Self = @Class\Entry(#PB_Compiler_Module)
*Object\System\RefCounter = 0
*Object\System\Mutex = CreateMutex()
If Not *Object\System\Mutex
Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
FreeStructure(*Object)
*Object = 0
GlobalObjectCounter(#False)
Else
LockMutex(*Object\System\Self\Mutex)
ForEach *Object\System\Self\Initalize()
*Object\System\Self\Initalize()\Invoke(*Object)
Next
UnlockMutex(*Object\System\Self\Mutex)
EndIf
EndIf
ProcedureReturn *Object
EndMacro
; ---------------------------------------------------------------------------
; Macros for init object (advanced)
Macro AllocateObject(Object, sProperty)
Object = AllocateStructure(sProperty)
If Object
GlobalObjectCounter(#True)
Object\System\vTable = Class\Entry(#PB_Compiler_Module)\vTable()
Object\System\Self = @Class\Entry(#PB_Compiler_Module)
Object\System\RefCounter = 0
Object\System\Mutex = CreateMutex()
If Not Object\System\Mutex
Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
FreeStructure(Object)
Object = 0
GlobalObjectCounter(#False)
EndIf
EndIf
EndMacro
Macro InitalizeObject(Object, sProperty=)
If Object
LockMutex(Object\System\Self\Mutex)
ForEach Object\System\Self\Initalize()
Object\System\Self\Initalize()\Invoke(Object)
Next
UnlockMutex(Object\System\Self\Mutex)
EndIf
EndMacro
; ---------------------------------------------------------------------------
; Macros for clone object
Macro CloneObject(This, Clone, sProperty)
Clone = AllocateStructure(sProperty)
If Clone
GlobalObjectCounter(#True)
CopyStructure(This, Clone, sProperty)
Clone\System\RefCounter = 0
Clone\System\Mutex = CreateMutex()
If Not Clone\System\Mutex
Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
FreeStructure(Clone)
Clone = 0
GlobalObjectCounter(#False)
EndIf
EndIf
EndMacro
; ---------------------------------------------------------------------------
Macro LockObject(This)
LockMutex(This\System\Mutex)
EndMacro
Macro UnlockObject(This)
UnlockMutex(This\System\Mutex)
EndMacro
; ---------------------------------------------------------------------------
;-- Macros to defined Initalize, Dispose, Methode
; Add Procedure as Initalize Object
Macro AsInitalizeObject(Name)
Procedure __AddInitalizeObject#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
LastElement(Class\Entry()\Initalize())
AddElement(Class\Entry()\Initalize())
Class\Entry()\Initalize()\Invoke = @Name()
EndIf
EndProcedure : __AddInitalizeObject#Name()
EndMacro
; Add Procedure as Dispose Object
Macro AsDisposeObject(Name)
Procedure __AddDisposeObject#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
LastElement(Class\Entry()\Dispose())
AddElement(Class\Entry()\Dispose())
Class\Entry()\Dispose()\Invoke = @Name()
EndIf
EndProcedure : __AddDisposeObject#Name()
EndMacro
; ---------------------------------------------------------------------------
; Add Procedure as Methode Dispatch or Overwrite Inheritance Methode Dispatch
Macro AsMethode(Name)
Procedure __AddMethode#Name()
Protected MethodeID
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
MethodeID = OffsetOf(__Interface\Name()) / SizeOf(integer)
Class\Entry()\vTable(MethodeID) = @Name()
Class\Entry()\vMethodeID(LCase(dq#Name#dq))\Index = MethodeID
CompilerIf Defined(Disp#Name, #PB_Procedure)
Class\Entry()\vDispInvoke(MethodeID) = @Disp#Name()
CompilerElse
Class\Entry()\vDispInvoke(MethodeID) = @Name()
CompilerEndIf
EndIf
EndProcedure : __AddMethode#Name()
EndMacro
; ---------------------------------------------------------------------------
; Add Procedure as Methode or Overwrite Inheritance Methode with creating Disp[MethodeName]
; Added Purebasic unknown Datatype for DispInvoke and Properties
#PB_None = 1000
#PB_Void = 1001
#PB_Object = 1002
#PB_Bool = 1003
#PB_Date = 1004
#PB_Variant = 1005
#PB_VariantByRef = 1006
; Help stucture for DispInvoke
Structure udtDispResult
StructureUnion
Void.i
*Object
Bool.i
Integer.i
Long.l
Quad.q
Float.f
Double.d
Date.i
*Variant
EndStructureUnion
String.s
EndStructure
Macro AsMethodeDisp(Name, tResult=Void, tArg1=None, tArg2=None, tArg3=None, tArg4=None, tArg5=None, tArg6=None, tArg7=None, tArg8=None)
Procedure Disp#Name(*this.__Interface, DispId.l, *iid.IID, lcid.l, Flags.w, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
Protected r1.udtDispResult, cArgs, *vArgs.udtArrayVariant
CompilerIf #PB_#tArg8 <> #PB_None
#ParamCount#Name = 8
CompilerElseIf #PB_#tArg7 <> #PB_None
#ParamCount#Name = 7
CompilerElseIf #PB_#tArg6 <> #PB_None
#ParamCount#Name = 6
CompilerElseIf #PB_#tArg5 <> #PB_None
#ParamCount#Name = 5
CompilerElseIf #PB_#tArg4 <> #PB_None
#ParamCount#Name = 4
CompilerElseIf #PB_#tArg3 <> #PB_None
#ParamCount#Name = 3
CompilerElseIf #PB_#tArg2 <> #PB_None
#ParamCount#Name = 2
CompilerElseIf #PB_#tArg1 <> #PB_None
#ParamCount#Name = 1
CompilerElse
#ParamCount#Name = 0
CompilerEndIf
; Check parameter count
cArgs = *DispParams\cArgs
*vArgs = *DispParams\rgvarg
If cArgs <> #ParamCount#Name
ProcedureReturn #DISP_E_BADPARAMCOUNT
EndIf
; Invoke methode
CompilerSelect #ParamCount#Name
CompilerCase 0
r1\tResult = *this\Name()
CompilerCase 1
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[0]))
CompilerCase 2
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[1]),
GetVariant#tArg2(*vArgs\Arg[0]))
CompilerCase 3
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[2]),
GetVariant#tArg2(*vArgs\Arg[1]),
GetVariant#tArg3(*vArgs\Arg[0]))
CompilerCase 4
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[3]),
GetVariant#tArg2(*vArgs\Arg[2]),
GetVariant#tArg3(*vArgs\Arg[1]),
GetVariant#tArg4(*vArgs\Arg[0]))
CompilerCase 5
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[4]),
GetVariant#tArg2(*vArgs\Arg[3]),
GetVariant#tArg3(*vArgs\Arg[2]),
GetVariant#tArg4(*vArgs\Arg[1]),
GetVariant#tArg5(*vArgs\Arg[0]))
CompilerCase 6
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[5]),
GetVariant#tArg2(*vArgs\Arg[4]),
GetVariant#tArg3(*vArgs\Arg[3]),
GetVariant#tArg4(*vArgs\Arg[2]),
GetVariant#tArg5(*vArgs\Arg[1]),
GetVariant#tArg6(*vArgs\Arg[0]))
CompilerCase 7
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[6]),
GetVariant#tArg2(*vArgs\Arg[5]),
GetVariant#tArg3(*vArgs\Arg[4]),
GetVariant#tArg4(*vArgs\Arg[3]),
GetVariant#tArg5(*vArgs\Arg[2]),
GetVariant#tArg6(*vArgs\Arg[1]),
GetVariant#tArg7(*vArgs\Arg[0]))
CompilerCase 8
r1\tResult = *this\Name(GetVariant#tArg1(*vArgs\Arg[7]),
GetVariant#tArg2(*vArgs\Arg[6]),
GetVariant#tArg3(*vArgs\Arg[5]),
GetVariant#tArg4(*vArgs\Arg[4]),
GetVariant#tArg5(*vArgs\Arg[3]),
GetVariant#tArg6(*vArgs\Arg[2]),
GetVariant#tArg7(*vArgs\Arg[1]),
GetVariant#tArg8(*vArgs\Arg[0]))
CompilerEndSelect
; Write result
CompilerIf #PB_#tResult <> #PB_Void
If *vResult
SetVariant#tResult(*vResult, r1\tResult)
If *vResult\vt <> #VT_ERROR
ProcedureReturn #S_OK
Else
ProcedureReturn *vResult\scode
EndIf
Else
ProcedureReturn #S_OK
EndIf
CompilerElse
ProcedureReturn #S_OK
CompilerEndIf
EndProcedure : AsMethode(Name)
EndMacro
; ---------------------------------------------------------------------------
;-- Macros to defined Properties
Macro NextPropertyID
(1000 + MacroExpandedCount)
EndMacro
Macro UseProperty(sProperty)
Structure __Property Extends sProperty
EndStructure
EndMacro
Macro DefineProperty(Name)
Procedure __AddProperty#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = TypeOf(__Property\Name)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
EndIf
EndProcedure : __AddProperty#Name()
EndMacro
Macro DefinePropertyDate(Name)
Procedure __AddProperty#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Date
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
EndIf
EndProcedure : __AddProperty#Name()
EndMacro
Macro DefinePropertyVariant(Name)
Procedure __AddProperty#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Variant
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
EndIf
EndProcedure : __AddProperty#Name()
EndMacro
Macro DefinePropertyVariantByRef(Name)
Procedure __AddProperty#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_VariantByRef
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(__Property\Name)
EndIf
EndProcedure : __AddProperty#Name()
EndMacro
Macro DefinePropertyAs(Name, sProperty)
Procedure __AddPropertyAs#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = TypeOf(sProperty)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
EndIf
EndProcedure : __AddPropertyAs#Name()
EndMacro
Macro DefinePropertyDateAs(Name, sProperty)
Procedure __AddPropertyAs#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Date
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
EndIf
EndProcedure : __AddPropertyAs#Name()
EndMacro
Macro DefinePropertyVariantAs(Name, sProperty)
Procedure __AddPropertyAs#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_Variant
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
EndIf
EndProcedure : __AddPropertyAs#Name()
EndMacro
Macro DefinePropertyVariantByRefAs(Name, sProperty)
Procedure __AddPropertyAs#Name()
If FindMapElement(Class\Entry(), #PB_Compiler_Module)
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Index = NextPropertyID
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Type = #PB_VariantByRef
Class\Entry()\vPropertyID(LCase(dq#Name#dq))\Offset = OffsetOf(sProperty)
EndIf
EndProcedure : __AddPropertyAs#Name()
EndMacro
; ---------------------------------------------------------------------------
;-- Debugger Functions
Macro ShowInterface(ClassName=#PB_Compiler_Module)
CompilerIf #PB_Compiler_Debugger
Define __index
Debug "Interface " + ClassName
Debug "{"
If FindMapElement(ClassDispatch::Class\Entry(), ClassName)
For __index = 0 To ArraySize(ClassDispatch::Class\Entry()\vTable()) - 1
ForEach ClassDispatch::Class\Entry()\vMethodeID()
If ClassDispatch::Class\Entry()\vMethodeID()\Index = __index
Debug " - MethodeID " + ClassDispatch::Class\Entry()\vMethodeID()\Index + " - " + MapKey(ClassDispatch::Class\Entry()\vMethodeID()) + "()"
Break
EndIf
Next
Next
Else
Debug " - Interface not found."
EndIf
Debug "}"
CompilerEndIf
EndMacro
Macro ShowClasses()
CompilerIf #PB_Compiler_Debugger
ForEach ClassDispatch::Class\Entry()
Define __index
Debug "Interface " + MapKey(ClassDispatch::Class\Entry())
Debug "{"
For __index = 0 To ArraySize(ClassDispatch::Class\Entry()\vTable()) - 1
ForEach ClassDispatch::Class\Entry()\vMethodeID()
If ClassDispatch::Class\Entry()\vMethodeID()\Index = __index
Debug " - MethodeID " + ClassDispatch::Class\Entry()\vMethodeID()\Index + " - " + MapKey(ClassDispatch::Class\Entry()\vMethodeID()) + "()"
Break
EndIf
Next
Next
Debug "}"
Next
CompilerEndIf
EndMacro
Macro CheckInterface(InterfaceName)
CompilerIf #PB_Compiler_Debugger
CompilerIf Defined(InterfaceName, #PB_Interface)
Define __SizeOfInterface = SizeOf(InterfaceName) / SizeOf(Integer)
Define __IndexOfInterface
For __IndexOfInterface = 0 To __SizeOfInterface - 1
If Class\Entry(#PB_Compiler_Module)\vTable(__IndexOfInterface) = 0
Debug "Error: Invalid Interface " + dq#InterfaceName#dq + " by MethodeID " + __IndexOfInterface
ShowInterface()
CallDebugger
EndIf
Next
CompilerElse
Debug "Error: Interface not exists"
CallDebugger
CompilerEndIf
CompilerEndIf
EndMacro
; ---------------------------------------------------------------------------
EndDeclareModule
; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;- Begin Module ClassDispatch
Module ClassDispatch
EnableExplicit
UseModule ClassCommon
; ---------------------------------------------------------------------------
#DISPID_VALUE = 0
#DISPID_UNKNOWN = -1
#DISPID_PROPERTYPUT = -3
#DISPID_NEWENUM = -4
#DISPID_EVALUATE = -5
#DISPID_CONSTRUCTOR = -6
#DISPID_DESTRUCTOR = -7
#DISPID_COLLECT = -8
Structure udtArrayString
Name.string[0]
EndStructure
Structure udtArrayLong
lVal.l[0]
EndStructure
; ---------------------------------------------------------------------------
Procedure AddClass(ClassName.s, ClassExtends.s, Size)
Protected r1
If FindMapElement(Class\Entry(), ClassExtends)
r1 = AddMapElement(Class\Entry(), ClassName)
Else
Debug "Error: Extends Class '" + ClassExtends + "' not exists!"
CallDebugger
EndIf
If r1
CopyStructure(Class\Entry(ClassExtends), Class\Entry(ClassName), udtClass)
ReDim Class\Entry(ClassName)\vTable(Size)
ReDim Class\Entry(ClassName)\vDispInvoke(Size)
Class\Entry(ClassName)\cDispInvoke = Size
Class\Entry(ClassName)\Mutex = CreateMutex()
Else
Debug "Warning: Class '" + ClassName + "' not initalized!"
EndIf
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------
Procedure QueryInterface(*This.sClassDispatch, *riid, *Object.integer)
If CompareMemory(*riid, ?IID_IDispatch, 16)
ClassDebug("Interface IDispatch ok", *This)
LockMutex(*This\System\Mutex)
*Object\i = *This : *This\System\RefCounter + 1
UnlockMutex(*This\System\Mutex)
ProcedureReturn #S_OK
EndIf
If CompareMemory(*riid, ?IID_IUnknown, 16)
ClassDebug("Interface IUnknown ok", *This)
LockMutex(*This\System\Mutex)
*Object\i = *This : *This\System\RefCounter + 1
UnlockMutex(*This\System\Mutex)
ProcedureReturn #S_OK
EndIf
ClassDebug("Error: Interface not exists " + GetGuidString(*riid), *This)
*Object\i = 0
ProcedureReturn #E_NOINTERFACE
EndProcedure
; ---------------------------------------------------------------------------
Procedure AddRef(*This.sClassDispatch)
LockMutex(*This\System\Mutex)
*This\System\RefCounter + 1
ClassDebug("RefCounter: " + Str(*This\System\RefCounter), *This)
UnlockMutex(*This\System\Mutex)
ProcedureReturn *This\System\RefCounter
EndProcedure
; ---------------------------------------------------------------------------
Procedure Release(*This.sClassDispatch)
With *This\System
LockMutex(*This\System\Mutex)
If \RefCounter = 0
LockMutex(*This\System\Self\Mutex)
If LastElement(\Self\Dispose())
Repeat
\Self\Dispose()\Invoke(*This)
Until PreviousElement(\Self\Dispose()) = 0
EndIf
UnlockMutex(*This\System\Self\Mutex)
ClassDebug("Object Released", *This)
FreeMutex(*This\System\Mutex)
FreeStructure(*This)
GlobalObjectCounter(#False)
ProcedureReturn 0
Else
\RefCounter - 1
ClassDebug("RefCounter: " + Str(*This\System\RefCounter), *This)
EndIf
UnlockMutex(*This\System\Mutex)
ProcedureReturn \RefCounter
EndWith
EndProcedure
; ---------------------------------------------------------------------------
Procedure GetTypeInfoCount(*This.sClassDispatch, *CntTypeInfo.Integer)
ClassDebug("No typeinfo count")
*CntTypeInfo\i = 0
ProcedureReturn #S_OK
EndProcedure
; ---------------------------------------------------------------------------
Procedure GetTypeInfo(*This.sClassDispatch, TypeInfo.i, LocalId.i, *ppTypeInfo.Integer)
ClassDebug("No typeinfo")
ProcedureReturn #E_NOTIMPL
EndProcedure
; ---------------------------------------------------------------------------
Procedure GetIDsOfNames(*This.sClassDispatch, *iid.IID, *Names.udtArrayString, cntNames.i, lcid.i, *DispId.udtArrayLong)
Protected Name.s, index, cnt, r1
If Not *Names
ClassDebug("Error: Name invalid arg", *This)
ProcedureReturn #E_POINTER
EndIf
If Not *DispId
ClassDebug("Error: DispID invalid arg", *This)
ProcedureReturn #E_POINTER
EndIf
r1 = #S_OK
cnt = cntNames - 1
If cnt
ClassDebug("Count of Names: " + cntNames, *This)
EndIf
For index = 0 To cnt
Name.s = LCase(*Names\Name[index]\s)
If FindMapElement(*This\System\Self\vMethodeID(), Name)
*DispId\lVal[index] = *This\System\Self\vMethodeID()\Index
ClassDebug(*Names\Name[index]\s + ": DispID " + Str(*DispId\lVal[index]), *This)
ElseIf FindMapElement(*This\System\Self\vPropertyID(), Name)
*DispId\lVal[index] = *This\System\Self\vPropertyID()\Index
ClassDebug(*Names\Name[index]\s + ": DispID " + Str(*DispId\lVal[index]), *This)
Else
*DispId\lVal[index] = #DISPID_UNKNOWN
r1 = #DISP_E_UNKNOWNNAME
EndIf
Next
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------
Procedure Invoke(*This.sClassDispatch, DispId.i, *iid.IID, lcid.i, Flags.i, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
Protected result, cArgs, *vArgs.udtArrayVariant, cNamedArgs, *DispIdNamedArgs.udtArrayLong
Protected *pInteger.Integer, *pLong.Long, *pQuad.Quad, *pFloat.Float, *pDouble.Double, *pString.String, *pPointer.Integer, *Variant.Variant
Protected vDispInvoke.ProtoInvokeDispatch
With *This\System\Self
; Check Parameters
If Not CompareMemory(*iid, ?IID_INULL, SizeOf(IID))
ClassDebug("Error: IID unknown interface " + GetGuidString(*iid), *This)
ProcedureReturn #DISP_E_UNKNOWNINTERFACE
EndIf
If *DispParams = 0
ClassDebug("Error: Pointer DispParams invalid", *This)
ProcedureReturn #DISP_E_PARAMNOTOPTIONAL
EndIf
; Check DispId
If DispId <= 1000
; Methode
If *DispParams\cNamedArgs
ClassDebug("Error: DispInvoke not support named arguments", *This)
ProcedureReturn #DISP_E_NONAMEDARGS
EndIf
If DispId < 7 Or DispId >= \cDispInvoke
ClassDebug("Error: DispID invalid index", *This)
ProcedureReturn #DISP_E_BADINDEX
EndIf
If \vDispInvoke(DispId) = 0
ClassDebug("Error: DispID invalid index", *This)
ProcedureReturn #DISP_E_BADINDEX
EndIf
; Invoke function
ClassDebug("Method: DispID " + Str(DispId), *This)
vDispInvoke = \vDispInvoke(DispId)
result = vDispInvoke(*This, DispId.i, *iid, lcid.i, Flags.i, *DispParams, *vResult, *ExcepInfo, *ArgErr)
ProcedureReturn result
Else
; Properties
Repeat
ForEach \vPropertyID()
If \vPropertyID()\Index = DispID
Break 2
EndIf
Next
ProcedureReturn #DISP_E_BADINDEX
Until #True
If Flags & #DISPATCH_PROPERTYGET
If *vResult = 0
ClassDebug("Error: Pointer vResult invalid", *This)
ProcedureReturn #DISP_E_PARAMNOTOPTIONAL
EndIf
ClassDebug("PropertyGet: DispID " + Str(DispId), *This)
Select \vPropertyID()\Type
Case #PB_Integer
*pInteger = *this + \vPropertyID()\Offset
SetVariantInteger(*vResult, *pInteger\i)
ProcedureReturn #S_OK
Case #PB_Long
*pLong = *this + \vPropertyID()\Offset
SetVariantLong(*vResult, *pLong\l)
ProcedureReturn #S_OK
Case #PB_Quad
*pQuad = *this + \vPropertyID()\Offset
SetVariantQuad(*vResult, *pQuad\q)
ProcedureReturn #S_OK
Case #PB_Float
*pFloat = *this + \vPropertyID()\Offset
SetVariantFloat(*vResult, *pFloat\f)
ProcedureReturn #S_OK
Case #PB_Double
*pDouble = *this + \vPropertyID()\Offset
SetVariantDouble(*vResult, *pDouble\d)
ProcedureReturn #S_OK
Case #PB_String
*pString = *this + \vPropertyID()\Offset
SetVariantString(*vResult, *pString\s)
ProcedureReturn #S_OK
Case #PB_Date
*pInteger = *this + \vPropertyID()\Offset
SetVariantDate(*vResult, *pInteger\i)
ProcedureReturn #S_OK
Case #PB_Variant
*Variant = *this + \vPropertyID()\Offset
If *Variant
VariantCopy_(*vResult, *Variant)
EndIf
ProcedureReturn #S_OK
Case #PB_VariantByRef
*pPointer = *this + \vPropertyID()\Offset
*Variant = *pPointer\i
If *Variant
VariantCopy_(*vResult, *Variant)
Else
VariantClear_(*vResult)
EndIf
ProcedureReturn #S_OK
EndSelect
ElseIf Flags & #DISPATCH_PROPERTYPUT
cArgs = *DispParams\cArgs
If cArgs <> 1
ProcedureReturn #DISP_E_BADPARAMCOUNT
EndIf
ClassDebug("PropertyPut: DispID " + Str(DispId), *This)
*vArgs = *DispParams\rgvarg
Select \vPropertyID()\Type
Case #PB_Integer
*pInteger = *this + \vPropertyID()\Offset
*pInteger\i = GetVariantInteger(*vArgs\Arg[0])
ProcedureReturn #S_OK
Case #PB_Long
*pLong = *this + \vPropertyID()\Offset
*pLong\l = GetVariantLong(*vArgs\Arg[0])
ProcedureReturn #S_OK
Case #PB_Quad
*pQuad = *this + \vPropertyID()\Offset
*pQuad\q = GetVariantQuad(*vArgs\Arg[0])
ProcedureReturn #S_OK
Case #PB_Float
*pFloat = *this + \vPropertyID()\Offset
*pFloat\f = GetVariantFloat(*vArgs\Arg[0])
ProcedureReturn #S_OK
Case #PB_Double
*pDouble = *this + \vPropertyID()\Offset
*pDouble\d = GetVariantDouble(*vArgs\Arg[0])
ProcedureReturn #S_OK
Case #PB_String
*pString = *this + \vPropertyID()\Offset
*pString\s = GetVariantString(*vArgs\Arg[0])
ProcedureReturn #S_OK
Case #PB_Date
*pInteger = *this + \vPropertyID()\Offset
*pInteger\i = GetVariantDate(*vArgs\Arg[0])
Case #PB_Variant
*Variant = *this + \vPropertyID()\Offset
VariantClear_(*Variant)
VariantCopy_(*Variant, *vArgs\Arg[0])
Case #PB_VariantByRef
*pPointer = *this + \vPropertyID()\Offset
*Variant = *pPointer\i
If *Variant
VariantClear_(*Variant)
VariantCopy_(*Variant, *vArgs\Arg[0])
EndIf
EndSelect
Else
ProcedureReturn #DISP_E_BADVARTYPE
EndIf
EndIf
EndWith
EndProcedure
; ---------------------------------------------------------------------------
Procedure InitClassDispatch()
AddMapElement(Class\Entry(), "ClassDispatch")
With Class\Entry("ClassDispatch")
\vTable(0) = @QueryInterface()
\vTable(1) = @AddRef()
\vTable(2) = @Release()
\vTable(3) = @GetTypeInfoCount()
\vTable(4) = @GetTypeInfo()
\vTable(5) = @GetIDsOfNames()
\vTable(6) = @Invoke()
\vMethodeID("QueryInterface")\Index = 0
\vMethodeID("AddRef")\Index = 1
\vMethodeID("Release")\Index = 2
\vMethodeID("GetTypeInfoCount")\Index = 3
\vMethodeID("GetTypeInfo")\Index = 4
\vMethodeID("GetIDsOfNames")\Index = 5
\vMethodeID("Invoke")\Index = 6
EndWith
EndProcedure : InitClassDispatch()
; ---------------------------------------------------------------------------
EndModule
;- End Module ClassDispatch
; ***************************************************************************************
;- Begin Declare Module ClassFactory
DeclareModule ClassFactory
Prototype InvokeNewAppObject()
Structure sClassFactory
*VTable
cntRef.i
cntLockServer.i
NewAppObject.InvokeNewAppObject
EndStructure
; ---------------------------------------------------------------------------
Declare NewClassFactory(*NewAppObject)
; ---------------------------------------------------------------------------
EndDeclareModule
; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;- Begin Module Classfactory
Module ClassFactory
EnableExplicit
UseModule ClassCommon
; ---------------------------------------------------------------------------
Procedure QueryInterface(*This.sClassFactory, *iid.IID, *Object.Integer)
If CompareMemory(*iid, ?IID_IClassFactory, 16)
ClassDebug("Interface IClassFactory ok", *This)
*Object\i = *This : *This\cntRef + 1
ProcedureReturn #S_OK
EndIf
If CompareMemory(*iid, ?IID_IUnknown, 16)
ClassDebug("Interface IUnknown ok", *This)
*Object\i = *This : *This\cntRef + 1
ProcedureReturn #S_OK
EndIf
ClassDebug("Error: Interface not exists " + GetGuidString(*iid), *This)
*Object\i = 0
ProcedureReturn #E_NOINTERFACE
EndProcedure
; ---------------------------------------------------------------------------
Procedure AddRef(*This.sClassFactory)
*This\cntRef + 1
ClassDebug("RefCounterer: " + Str(*This\cntRef), *This)
ProcedureReturn *This\cntRef
EndProcedure
; ---------------------------------------------------------------------------
Procedure Release(*This.sClassFactory)
If *This\cntRef > 1
*This\cntRef - 1
ClassDebug("RefCounter: " + Str(*This\cntRef), *This)
ProcedureReturn *This\cntRef
EndIf
ClassDebug("Object released", *This)
FreeStructure(*This)
GlobalObjectCounter(#False)
ProcedureReturn 0
EndProcedure
; ---------------------------------------------------------------------------
Procedure CreateInstance(*This.sClassFactory, *pUnkOuter, *riid.IID, *ppvObject.Integer)
Protected *NewObject.IUnknown
; Aggregation is currently not supported
If *pUnkOuter
*ppvObject\i = 0
ClassDebug("New application no aggregation")
ProcedureReturn #CLASS_E_NOAGGREGATION
EndIf
If CompareMemory(*riid, ?IID_IUnknown, 16) Or CompareMemory(*riid, ?IID_IDispatch, 16)
; Create a new application object
If *This\NewAppObject
*NewObject = *This\NewAppObject()
If *NewObject
ClassDebug("New object ok [" + Hex(*NewObject) + "]")
*ppvObject\i = *NewObject
ProcedureReturn #S_OK
Else
ClassDebug("Error: New object out of memory")
ProcedureReturn #E_OUTOFMEMORY
EndIf
Else
ClassDebug("Error: New object no pointer")
ProcedureReturn #E_POINTER
EndIf
Else
; Not implemented class was requested
*ppvObject\i = 0
ClassDebug("Error: Interface not exists " + GetGuidString(*riid))
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
; ---------------------------------------------------------------------------
Procedure LockServer(*This.sClassFactory, fLock)
If fLock = #False
If *This\cntLockServer > 0
*This\cntLockServer - 1
ClassDebug("LockCounter: " + Str(*This\cntLockServer))
EndIf
Else
*This\cntLockServer + 1
ClassDebug("LockCounter: " + Str(*This\cntLockServer))
EndIf
ProcedureReturn #S_OK
EndProcedure
; ---------------------------------------------------------------------------
Procedure NewClassFactory(*NewAppObject)
Protected *object.sClassFactory
*object = AllocateStructure(sClassFactory)
If *object
GlobalObjectCounter(#True)
*object\VTable = ?VT_ClassFactory
*object\NewAppObject = *NewAppObject
ProcedureReturn *object
Else
ProcedureReturn 0
EndIf
EndProcedure
; ---------------------------------------------------------------------------
DataSection
VT_ClassFactory:
Data.i @QueryInterface()
Data.i @AddRef()
Data.i @Release()
Data.i @CreateInstance()
Data.i @LockServer()
EndDataSection
EndModule
;- End Module ClassFactory
; ***************************************************************************************
;- Begin Macro InitClassFactory
Macro InitClassFactory(CF_ProgramID, CF_ClassID, CF_Description, CF_NewAppObject, CF_IID_Application)
; -------------------------------------------------------------------------
UseModule ClassCommon
UseModule ClassFactory
; -------------------------------------------------------------------------
ProcedureDLL AttachProcess(Instanz)
ClassCommon::ClassDebugEx("COM","DLL","AttachProzess")
EndProcedure
ProcedureDLL DetachProcess(Instanz)
ClassCommon::ClassDebugEx("COM","DLL","DetachProzess")
EndProcedure
ProcedureDLL AttachThread(Instanz)
ClassCommon::ClassDebugEx("COM","DLL","AttachThread")
EndProcedure
ProcedureDLL DetachThread(Instanz)
ClassCommon::ClassDebugEx("COM","DLL","DetachThread")
EndProcedure
; -------------------------------------------------------------------------
ProcedureDLL DllCanUnloadNow()
If ClassCommon::__ObjectCounter\Count = 0
ClassCommon::ClassDebugEx("COM","DLL","CanUnloadNow Ok")
ProcedureReturn #S_OK
Else
ClassCommon::ClassDebugEx("COM","DLL","CanUnloadNow False")
ProcedureReturn #S_FALSE
EndIf
EndProcedure
; -------------------------------------------------------------------------
ProcedureDLL DllGetClassObject(*rclsid.IID, *riid.iid, *ppvObject.Integer)
Define *Object.IUnknown
If CompareMemory(*rclsid, CF_IID_Application, SizeOf(iid))
If CompareMemory(*riid, ?IID_IClassFactory, SizeOf(iid))
;Klassenobjekt erstellen
*Object = NewClassFactory(CF_NewAppObject)
If *Object
ClassCommon::ClassDebugEx("COM","DLL","GetClassObject: Object ClassFactory ok [" + Hex(*Object) + "]")
*Object\AddRef()
*ppvObject\i = *Object
ProcedureReturn #S_OK
Else
*ppvObject\i = 0
ClassCommon::ClassDebugEx("COM","DLL","GetClassObject Error: Out of memory")
ProcedureReturn #E_OUTOFMEMORY
EndIf
Else
*ppvObject\i = 0
ClassCommon::ClassDebugEx("COM","DLL", "GetClassObject Error: Interface not exists " + GetGuidString(*riid))
ProcedureReturn #CLASS_E_CLASSNOTAVAILABLE
EndIf
Else
*ppvObject\i = 0
ClassCommon::ClassDebugEx("COM","DLL","GetClassObject Error: ClassID not available")
ProcedureReturn #CLASS_E_CLASSNOTAVAILABLE
EndIf
EndProcedure
; -------------------------------------------------------------------------
ProcedureDLL DllRegisterServer()
Protected DLL_Name.s, hKey.i, r1.i
DLL_Name = ProgramFilename()
r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, CF_ProgramID, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_Description, StringByteLength(CF_Description) + 2)
r1 + RegCloseKey_ (hKey)
r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, CF_ProgramID + "\CLSID", 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_ClassID, StringByteLength(CF_ClassID) + 2)
r1 + RegCloseKey_ (hKey)
r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_Description, StringByteLength(CF_Description) + 2)
r1 + RegCloseKey_ (hKey)
r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\InprocServer32", 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, DLL_Name, StringByteLength(DLL_Name) + 2)
r1 + RegCloseKey_ (hKey)
r1 + RegCreateKeyEx_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\ProgId", 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)
r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_ProgramID + ".1", StringByteLength(CF_ProgramID + ".1") + 2)
r1 + RegCloseKey_ (hKey)
If r1
ProcedureReturn #SELFREG_E_CLASS
Else
ProcedureReturn #S_OK
EndIf
EndProcedure
; -------------------------------------------------------------------------
ProcedureDLL DllUnregisterServer()
Protected r1.i
r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\ProgId")
r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID + "\InprocServer32")
r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + CF_ClassID)
r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, CF_ProgramID + "\CLSID")
r1 + RegDeleteKey_(#HKEY_CLASSES_ROOT, CF_ProgramID)
If r1
ProcedureReturn #SELFREG_E_CLASS
Else
ProcedureReturn #S_OK
EndIf
EndProcedure
; -------------------------------------------------------------------------
UnuseModule ClassCommon
UnuseModule ClassFactory
; -------------------------------------------------------------------------
EndMacro
;- End Macro InitClassFactory
; ***************************************************************************************