Modul BaseClass ClassDispatch inklusive ClassFactory

[mk-soft]

Update v1.18
- Bugfix InitObject

[GPI]

in der DllRegisterServer - Procedure

Code: Alles auswählen

r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_ProgramID + ".1", StringByteLength(CF_Description) + 2)

müsste das nicht

Code: Alles auswählen

r1 + RegSetValueEx_ (hKey, "", 0, #REG_SZ, CF_ProgramID + ".1", StringByteLength(CF_ProgramID + ".1") + 2)

heißen?

zu LockServer(*This.sClassFactory, fLock)
müsste *This\cntLock nicht besser eine Globale Variable sein, die man auch in DllCanUnloadNow() überprüft werden sollte?

[mk-soft]

Die ProgID ist ein nicht eindeutiger Verweis mit Versionsnummer. Zur Zeit nicht relevant.
Sollte es mehr als eine Version geben, muss die ProgramID mit Versionsnummer in der HKEY_CLASSES_ROOT zusätzlich eingetragen werden.

Zum Beispiel:
PureExample3.Application
PureExample3.Application.6
Die CLSID kann dabei auf die gleiche ClassID verweisen und somit auf die gleiche DLL.

LockServer zur Zeit nicht relevant.
Habe aber den ObjectCounter zu ClassCommon ausgelagert damit die ClassFactory mitgezählt werden.

Update v1.19
- Geändert ObjectCounter

[GPI]

Die ProgID ist ein nicht eindeutiger Verweis mit Versionsnummer. Zur Zeit nicht relevant.
Sollte es mehr als eine Version geben, muss die ProgramID mit Versionsnummer in der HKEY_CLASSES_ROOT zusätzlich eingetragen werden.

Mir gibts eigentlich um die Länge - links steht cf_programid+.1, rechts cf_description.

[mk-soft]

Ups...
Danke, habe ich korrigiert.

Update v1.20
- Bugfix

[mk-soft]

Update v1.22
- Entfernt: Macro AsNewMethod. Nicht erforderlich das Macro AsMethod dasselbe macht.
- Hinzugefügt: Macro AsMethodeDisp. Erstellt zusätzlich die erforderliche Funktion Disp[MethodeName](...)*

* Für das automatische erstellen der DispInvoke Methode benötigt das Macro die Type information des Rückgabewerte und der zu übergebenen Argumente. Es können bis zu 8 Standard Variablen übergeben werde.

Schlüsselnamen für den Type des Rückgabewertes (tResult)
- Void, Object, Bool, Integer, Long, Float, Double, String

Schlüsselnamen für die Typen der Argumente (tArgX)
- Bool, Integer, Long, Float, Double, String

Beispiel 4

Code: Alles auswählen

;-TOP

IncludeFile "Modul_BaseClassDispatch.pb"

; Create Logfile
ClassCommon::EnableClassDebug()

; *******************************************************************************

DeclareModule ClassTextObject
  
  UseModule ClassDispatch
  
  Structure sClassTextObject Extends sClassDispatch
    text.s
  EndStructure
  
  Interface iClassTextObject Extends iClassDispatch
    Upper.s()
    Lower.s()
    Reverse.s()
  EndInterface
  
  UnuseModule ClassDispatch
  
  Declare.i New(Text.s)
  
EndDeclareModule

Module ClassTextObject
  
  EnableExplicit
  
  UseModule ClassCommon
  UseModule ClassDispatch
  
  NewClass(iClassTextObject)
  
  ; ---------------------------------------------------------------------------
  
  ; Format: Text = Object.Upper
  
  Procedure.s Upper(*this.sClassTextObject) ; Result String
    ProcedureReturn UCase(*this\text)
  EndProcedure : AsMethodeDisp(Upper, String)
  
  ; ---------------------------------------------------------------------------
  
  ; Format: Text = Object.Lower
  
  Procedure.s Lower(*this.sClassTextObject) ; Result String
    ProcedureReturn LCase(*this\text)
  EndProcedure : AsMethodeDisp(Lower, String)
  
  ; ---------------------------------------------------------------------------
  
  ; Format : Text = Object.Reverse
  
  Procedure.s Reverse(*this.sClassTextObject) ; Result String
    ProcedureReturn ReverseString(*this\text)
  EndProcedure : AsMethodeDisp(Reverse, String)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Init(*this.sClassTextObject)
    ClassDebug("Init TextObject", *this)
  EndProcedure : AsInitalizeObject(Init)
  
  Procedure Dispose(*this.sClassTextObject)
    ClassDebug("Dispose TextObject", *this)
  EndProcedure : AsDisposeObject(Dispose)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New(text.s)
    Protected *obj.sClassTextObject
    AllocateObject(*obj, sClassTextObject)
    If *obj
      *obj\text = text
      InitalizeObject(*obj)
    EndIf
    ProcedureReturn *obj
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface(iClassTextObject)
  
EndModule

; ***************************************************************************************

DeclareModule ClassText
  
  UseModule ClassDispatch
  
  Structure sClassText Extends sClassDispatch
    
  EndStructure
  
  Interface iClassText Extends iClassDispatch
    Text(String.s)
  EndInterface
  
  UnuseModule ClassDispatch
  
  Declare.i New()
  
EndDeclareModule

Module ClassText
  
  EnableExplicit
  
  UseModule ClassCommon
  UseModule ClassDispatch
  
  NewClass(iClassText)
  
  ; ---------------------------------------------------------------------------
  
  ; Object = obj.Text("String")
  
  Procedure Text(*this.iClassText, String.s) ; Result: Object of iClassTextObject
    ProcedureReturn ClassTextObject::New(String)
  EndProcedure : AsMethodeDisp(Text, Object, String)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sClassText)
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface(iClassText)
  
EndModule

; ***************************************************************************************

;- Test as DLL

CompilerIf #PB_Compiler_Debugger
  
  Debug "Test with Purebasic code"
  
  ClassDispatch::ShowClasses()
  
  *obj.ClassText::iClassText = ClassText::New()
  *obj2.ClassTextObject::iClassTextObject = *obj\Text("Hello World")
  Debug *obj2\Upper()
  Debug *obj2\Lower()
  Debug *obj2\Reverse()
  *obj2\Release()
  *obj\Release()
  
CompilerElse
  
  ; Create DLL
  EnableExplicit
  
  Procedure InitDLL()
    Global ProgramId.s   = "PureExample4.Application"
    Global ClassId.s    = ClassCommon::GetGuidString(?CLSID_App); "{01AAD4B2-FFFF-4E08-FFFF-FFFF60FF3B24}"
    Global Description.s = "Purebasic Example 4 with simple object"
  EndProcedure : InitDLL()
  
  DataSection
    CLSID_App:
    Data.l $01AAD4B2
    Data.w $FFFF, $4E08
    Data.b $FF, $FF, $FF, $FF, $60, $FF, $3B, $24
  EndDataSection
  
  InitClassFactory(ProgramId, ClassId, Description, ClassText::@New(), ?CLSID_App)
  
CompilerEndIf

VBS:

dim obj, obj2
set obj = createobject("PureExample4.Application")
set obj2 = obj.text("Hello World")

msgbox obj2.Upper
msgbox obj2.Lower
msgbox obj2.Reverse

msgbox obj.text("purebasic ").Upper & obj.text("rewoP").Reverse
set obj = Nothing

[mk-soft]

Update v1.23
- Hinzugefügt: UseProperty(...) und DefineProperty(...). Definieren von Properties den für direkten Zugriff.

Es können jetzt auch neben den Methoden auch Properties definiert werden.

Neues Beispiel 1

Code: Alles auswählen

;-TOP

IncludeFile "Modul_BaseClassDispatch.pb"

; Create Logfile
ClassCommon::EnableClassDebug()

; *******************************************************************************

DeclareModule ClassUser
  
  UseModule ClassDispatch
  
  Structure sClassUser Extends sClassDispatch
    firstname.s
    lastname.s
    age.i
  EndStructure
  
  Interface iClassUser Extends iClassDispatch
    SetName(FirstName.s, LastName.s)
    GetName.s()
    GetFirstName.s()
    GetLastName.s()
  EndInterface
  
  UnuseModule ClassDispatch
  
  Declare.i New()
  
EndDeclareModule

Module ClassUser
  
  EnableExplicit
  
  UseModule ClassCommon
  UseModule ClassDispatch
  
  NewClass(iClassUser)
  
  ; ---------------------------------------------------------------------------
  
  UseProperty(sClassUser)
  DefineProperty(firstname)
  DefineProperty(lastname)
  DefineProperty(age)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Init(*this.sClassUser)
    *this\firstname = "no name"
    *this\lastname = "no name"
  EndProcedure : AsInitalizeObject(Init)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Dispose(*this.sClassUser)
    Debug "Dispose Object " + *this
  EndProcedure : AsDisposeObject(Dispose)
  
  ; ---------------------------------------------------------------------------
  
  Procedure SetName(*this.sClassUser, FirstName.s, LastName.s)
    ClassDebug("Parameter: " + FirstName + ", " + LastName)
    With *this
      \firstname = FirstName
      \lastname = LastName
    EndWith
  EndProcedure : AsMethodeDisp(SetName, Void, String, String)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetName(*this.sClassUser)
    Protected text.s
    With *this
      text = "Name: " + \firstname + " " + \lastname + "; Age: " + Str(\age)
      ProcedureReturn text
    EndWith
  EndProcedure : AsMethodeDisp(GetName, String)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetFirstName(*this.sClassUser)
    Protected text.s
    With *this
      text = \firstname
      ProcedureReturn text
    EndWith
  EndProcedure : AsMethodeDisp(GetFirstName, String)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetLastName(*this.sClassUser)
    Protected text.s
    With *this
      text = \lastname
      ProcedureReturn text
    EndWith
  EndProcedure : AsMethodeDisp(GetLastName, String)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sClassUser)
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface(iClassUser)
  
EndModule

; ***************************************************************************************

;- Test as DLL

EnableExplicit

Procedure InitDLL()
  Global ProgramId.s   = "PureExample.Application"
  Global ClassId.s     = "{01AAD4B2-FFFF-4E08-FFFF-FFFF60FF3B21}"
  Global Description.s = "Purebasic Example COM-DLL"
EndProcedure : InitDLL()

DataSection
  CLSID_App:
  Data.l $01AAD4B2
  Data.w $FFFF, $4E08
  Data.b $FF, $FF, $FF, $FF, $60, $FF, $3B, $21
EndDataSection

InitClassFactory(ProgramId, ClassId, Description, ClassUser::@New(), ?CLSID_App)

VBS

dim obj, text
set obj = createobject("PureExample.Application")

obj.SetName "Purebasic", "COM-Power"

msgbox obj.firstname
msgbox obj.lastname

obj.firstname = "Tom"
obj.lastname = "Smith"
obj.age = 51

msgbox obj.getname

set obj = Nothing

[GPI]

mir ist gerade was aufgefallen:

Code: Alles auswählen

  Procedure.s GetVariantString(*vArg.Variant)
    Protected r1.s, vArg.Variant
    If VariantCopy_(vArg, *vArg) = #S_OK
      VariantChangeType_(vArg, vArg, 0, #VT_BSTR)
      r1 = PeekS(vArg\bstrVal)
    Else
      r1 = ""
    EndIf
    VariantClear_(vArg)
    ProcedureReturn r1
  EndProcedure

Bei meinen Tests kam mal raus, das gerne anstatt eines Leerstrings "" ein #Null$ verwendet wird. Hier wäre vielleicht nicht schlecht, wenn du eine Überprüfung vor den PEEKS machst.

Mir ist aber was anderes bezüglich QueryInterface aufgefallen. Momentan nutzen die COM-Objekte quasi nur die Invoke-Schnittstelle. Sehr praktisch für Scriptsprachen wie VBS, man muss außerdem kein Interface definieren.
Aber rein Theoretisch, könnte man nicht auf so ein Ding ein QueryInterface mit der ID aufrufen und so dann direkt, ohne Invoke, auf das Objekt zugreifen? Bei dir ja kein Problem, weil das "eingebundene" Objekt ja eh ein iDispatch-Interface ist.
Bei mir wärs auch möglich, ich kann ja überprüfen, ob das Eingebundene eine iUnknown verwandschaft ist und könnte dann das Objekt direkt zurückgeben. Keine AHnung ob das erlaubt ist, aber das QueryInterface gibt es ja her, es ist ja nicht nur ein Test, sondern man schreibt ja auch das Rückgabeobjekt rein.
Wäre zumindest eine nette Methode, um das Handling bei "Nativen"-Sprachen deutlich zu beschleunigen. Nur keine Ahnung ob das erlaubt ist.

[mk-soft]

Ein Objekt beginnt immer mit einer IUnknown. Die IDispatch auch.
Es ist erlaubt für frühe Bindung die Methoden an die IDispatch anzuhängen. Es sind aber bein anlegen der Methoden für frühe Bindung noch einige Regeln zu beachten.

Code: Alles auswählen

Procedure.i MeineMetohde(*This, [in/out] Result, [in] Arg, ...)
  ...
  ProcedureReturn #S_OK
EndProcedure

[GPI]

Ich glaub du hast mich missverstanden. Ich mein hier die Anwender-Seite, nicht die Ersteller-Seite

Du hast ein COM mit der IDD1

du erstellst also ein Objekt OBJ1 über die COM-Routinen und rufst prinzipell immer

Code: Alles auswählen

OBJ1\Invoke "GetText"

auf. (klar, der Weg ist ein bischen anders, vereinfacht dargestellt)

Aber was hindert mich folgendes zu machen

Code: Alles auswählen

Interface Direct
  ...
  GetText()
EndInterface
obj2.direct
OBJ1\QueryInterface IID1,@OBJ2

OBJ2\GetText()

Aktuell geht das nicht bei dir und mir, weil dein/mein QueryInterface zurückmeldet: Geht nicht. Die Frage ist - warum eigentlich? Es kann ja genauso gut sagen, ja geht, ruf doch direkt auf. Man muss natürlich das passende Interface/Endinterface haben. Die Frage ist, ob sowas überhaupt erlaubt ist.

Bei mir kommt halt hinzu, das meine OBjekte nicht IUnknown sein müssen. Aber wer sagt, das bei QueryInterface hinten als Result das Objekt zurückgeben muss. Bei mir sind Objekt und IDispatch-Objekt komplett getrennt. Wenn aber das Eingebunde ein IUnknwon ableger ist, könnte ich das ja einfach über QueryInterface zurückgeben und direkt aufrufen lassen.