From cffc8317fad044372b91eb31ef7b1a5c7281bd6c Mon Sep 17 00:00:00 2001 From: marco Date: Tue, 6 Aug 2019 12:00:25 +0000 Subject: [PATCH] * mantis #35013 library parts. Allow embedded objects. git-svn-id: trunk@42594 - --- packages/winunits-base/src/comobj.pp | 52 ++++++-- packages/winunits-base/src/comserv.pp | 177 +++++++++++++++++++++++++- 2 files changed, 209 insertions(+), 20 deletions(-) diff --git a/packages/winunits-base/src/comobj.pp b/packages/winunits-base/src/comobj.pp index f48d42d5de..3f70d1e1c7 100644 --- a/packages/winunits-base/src/comobj.pp +++ b/packages/winunits-base/src/comobj.pp @@ -92,7 +92,7 @@ unit ComObj; destructor Destroy; override; procedure AddObjectFactory(factory: TComObjectFactory); procedure RemoveObjectFactory(factory: TComObjectFactory); - procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc); + procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc;const bBackward:boolean=false); function GetFactoryFromClass(ComClass: TClass): TComObjectFactory; function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory; end; @@ -159,11 +159,12 @@ unit ComObj; FErrorIID: TGUID; FInstancing: TClassInstancing; FLicString: WideString; - //FRegister: Longint; + FIsRegistered: dword; FShowErrors: Boolean; FSupportsLicensing: Boolean; FThreadingModel: TThreadingModel; function GetProgID: string; + function reg_flags(): integer; protected { IUnknown } function QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall; @@ -694,7 +695,7 @@ implementation end; procedure TComClassManager.ForEachFactory(ComServer: TComServerObject; - FactoryProc: TFactoryProc); + FactoryProc: TFactoryProc;const bBackward:boolean=false); var i: Integer; obj: TComObjectFactory; @@ -703,12 +704,20 @@ implementation if printcom then WriteLn('ForEachFactory'); {$endif} + if not bBackward then for i := 0 to fClassFactoryList.Count - 1 do begin obj := TComObjectFactory(fClassFactoryList[i]); if obj.ComServer = ComServer then FactoryProc(obj); - end; + end + else + for i := fClassFactoryList.Count - 1 downto 0 do + begin + obj := TComObjectFactory(fClassFactoryList[i]); + if obj.ComServer = ComServer then + FactoryProc(obj); + end end; @@ -937,8 +946,8 @@ implementation if printcom then WriteLn('LockServer: ', fLock); {$endif} - RunError(217); - Result:=0; + Result := CoLockObjectExternal(Self, fLock, True); + ComServer.CountObject(fLock); end; @@ -1003,13 +1012,14 @@ implementation FComClass := ComClass; FInstancing := Instancing;; ComClassManager.AddObjectFactory(Self); + fIsRegistered := dword(-1); end; destructor TComObjectFactory.Destroy; begin + if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered); ComClassManager.RemoveObjectFactory(Self); - //RunError(217); end; @@ -1023,15 +1033,27 @@ implementation Result := TComClass(FComClass).Create(); end; + function TComObjectFactory.reg_flags():integer;inline; + begin + Result:=0; + case Self.FInstancing of + ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE; + ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE; + end; + if FComServer.StartSuspended then + Result:=Result or REGCLS_SUSPENDED; + end; procedure TComObjectFactory.RegisterClassObject; - begin + begin {$ifdef DEBUG_COM} if printcom then WriteLn('TComObjectFactory.RegisterClassObject'); {$endif} - RunError(217); - end; + if FInstancing <> ciInternal then + OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER, + reg_flags(), @FIsRegistered)); + end; (* Copy from Sample.RGS (http://www.codeproject.com/KB/atl/RegistryMap.aspx) @@ -1066,6 +1088,7 @@ HKCR procedure TComObjectFactory.UpdateRegistry(Register: Boolean); var classidguid: String; + srv_type: string; function ThreadModelToString(model: TThreadingModel): String; begin @@ -1086,12 +1109,14 @@ HKCR {$endif} if Instancing = ciInternal then Exit; + if System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32'; + if Register then begin classidguid := GUIDToString(ClassID); - CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName); + CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName); //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral - CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel)); + CreateRegKey('CLSID\' + classidguid + '\'+srv_type, 'ThreadingModel', ThreadModelToString(ThreadingModel)); CreateRegKey('CLSID\' + classidguid, '', Description); if ClassName <> '' then begin @@ -1115,7 +1140,7 @@ HKCR end else begin classidguid := GUIDToString(ClassID); - DeleteRegKey('CLSID\' + classidguid + '\InprocServer32'); + DeleteRegKey('CLSID\' + classidguid + '\'+srv_type); DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID'); if ClassName <> '' then begin @@ -1875,4 +1900,3 @@ finalization if Initialized then CoUninitialize; end. - diff --git a/packages/winunits-base/src/comserv.pp b/packages/winunits-base/src/comserv.pp index 164f713f3d..d81adc8768 100644 --- a/packages/winunits-base/src/comserv.pp +++ b/packages/winunits-base/src/comserv.pp @@ -37,10 +37,13 @@ const SELFREG_E_CLASS = -2; type + TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver); + TLastReleaseEvent = procedure(var shutdown: Boolean) of object; { TComServer } TComServer = class(TComServerObject) + class var orgInitProc: codepointer; private fCountObject: Integer; fCountFactory: Integer; @@ -48,7 +51,23 @@ type fServerName, fServerFileName: String; fHelpFileName : String; + fRegister: Boolean; fStartSuspended : Boolean; + FIsInproc: Boolean; + FIsInteractive: Boolean; + FStartMode: TStartMode; + FOnLastRelease: TLastReleaseEvent; + + class function AutomationDone: Boolean; + class procedure AutomationStart; + procedure CheckCmdLine; + procedure FactoryFree(Factory: TComObjectFactory); + procedure FactoryRegisterClassObject(Factory: TComObjectFactory); + procedure FactoryUpdateRegistry(Factory: TComObjectFactory); + procedure CheckReleased; + function GetTypeLibName: widestring; + procedure RegisterObjectWith(Factory: TComObjectFactory); + procedure Start; protected function CountObject(Created: Boolean): Integer; override; function CountFactory(Created: Boolean): Integer; override; @@ -69,10 +88,16 @@ type function CanUnloadNow: Boolean; procedure RegisterServer; procedure UnRegisterServer; + property IsInprocServer: Boolean read FIsInproc write FIsInproc; + property IsInteractive: Boolean read fIsInteractive; + property StartMode: TStartMode read FStartMode; + property ServerObjects:integer read fCountObject; end; var ComServer: TComServer = nil; + haut :TLibHandle; + //http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx //If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE. @@ -219,9 +244,24 @@ end; function TComServer.CountObject(Created: Boolean): Integer; begin if Created then - Result:=InterLockedIncrement(fCountObject) + begin + Result := InterlockedIncrement(FCountObject); + if (not IsInProcServer) and (StartMode = smAutomation) + and Assigned(ComObj.CoAddRefServerProcess) then + ComObj.CoAddRefServerProcess; + end else - Result:=InterLockedDecrement(fCountObject); + begin + Result := InterlockedDecrement(FCountObject); + if (not IsInProcServer) and (StartMode = smAutomation) + and Assigned(ComObj.CoReleaseServerProcess) then + begin + if ComObj.CoReleaseServerProcess() = 0 then + CheckReleased; + end + else if Result = 0 then + CheckReleased; + end; end; function TComServer.CountFactory(Created: Boolean): Integer; @@ -232,6 +272,22 @@ begin Result:=InterLockedDecrement(fCountFactory); end; +procedure TComServer.FactoryFree(Factory: TComObjectFactory); +begin + Factory.Free; +end; + +procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory); +begin + Factory.RegisterClassObject; +end; + +procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory); +begin + if Factory.Instancing <> ciInternal then + Factory.UpdateRegistry(FRegister); +end; + function TComServer.GetHelpFileName: string; begin result:=fhelpfilename; @@ -244,14 +300,29 @@ end; function TComServer.GetServerKey: string; begin - result:='LocalServer32'; + if FIsInproc then + Result := 'InprocServer32' + else + Result := 'LocalServer32'; end; function TComServer.GetServerName: string; begin - Result := fServerName; + if FServerName <> '' then + Result := FServerName + else + if FTypeLib <> nil then + Result := GetTypeLibName + else + Result := GetModuleName; end; +function TComServer.GetTypeLibName: widestring; +begin + OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil)); +end; + + function TComServer.GetStartSuspended: Boolean; begin result:=fStartSuspended; @@ -262,6 +333,30 @@ begin Result := fTypeLib; end; +procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory); +begin + Factory.RegisterClassObject; +end; + + +procedure TComServer.Start; +begin + case fStartMode of + smRegServer: + begin + Self.RegisterServer; + Halt; + end; + smUnregServer: + begin + Self.UnRegisterServer; + Halt; + end; + end; + ComClassManager.ForEachFactory(Self, @RegisterObjectWith); +end; + + procedure TComServer.SetHelpFileName(const Value: string); begin FHelpFileName:=value; @@ -277,10 +372,25 @@ begin Factory.UpdateRegistry(False); end; +procedure TComServer.CheckCmdLine; +const + sw_set:TSysCharSet = ['/','-']; +begin + if FindCmdLineSwitch('automation',sw_set,true) or + FindCmdLineSwitch('embedding',sw_set,true) then + fStartMode := smAutomation + else if FindCmdlIneSwitch('regserver',sw_set,true) then + fStartMode := smRegServer + else if FindCmdLineSwitch('unregserver',sw_set,true) then + fStartMode := smUnregServer; +end; + constructor TComServer.Create; var name: WideString; begin + haut := SafeLoadLibrary('oleaut32.DLL'); + CheckCmdLine; inherited Create; {$ifdef DEBUG_COM} WriteLn('TComServer.Create'); @@ -288,6 +398,9 @@ begin fCountFactory := 0; fCountObject := 0; + FTypeLib := nil; + FIsInproc := ModuleIsLib; + fServerFileName := GetModuleFileName(); name := fServerFileName; @@ -301,11 +414,61 @@ begin end else fServerName := GetModuleName; + + if not ModuleIsLib then + begin + orgInitProc := InitProc; + InitProc := @TComServer.AutomationStart; + // AddTerminateProc(TTerminateProc(@TComServer.AutomationDone)); + end; + + Self.FIsInteractive := True; end; +class procedure TComServer.AutomationStart; +begin + if orgInitProc <> nil then TProcedure(orgInitProc)(); + ComServer.FStartSuspended := (CoInitFlags <> -1) and + Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects); + ComServer.Start; + if ComServer.FStartSuspended then + ComObj.CoResumeClassObjects; +end; + +class function TComServer.AutomationDone: Boolean; +begin + Result := True; + if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then + begin + Result := MessageBox(0, PChar('COM server is in use'), + PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or + MB_ICONWARNING or MB_DEFBUTTON2) = IDYES; + end; +end; + + +procedure TComServer.CheckReleased; +var + Shutdown: Boolean; +begin + if not FIsInproc then + begin + Shutdown := FStartMode = smAutomation; + try + if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown); + finally + if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0); + end; + end; +end; + + destructor TComServer.Destroy; begin + ComClassManager.ForEachFactory(Self, @FactoryFree,true); + Self.fTypeLib:=nil; inherited Destroy; + FreeLibrary(haut); {$ifdef DEBUG_COM} WriteLn('TComServer.Destroy'); {$endif} @@ -332,15 +495,17 @@ begin ComClassManager.ForEachFactory(self, @UnregisterServerFactory); end; + initialization {$ifdef DEBUG_COM} WriteLn('comserv initialization begin'); {$endif} ComServer := TComServer.Create; + {$ifdef DEBUG_COM} WriteLn('comserv initialization end'); {$endif} finalization - ComServer.Free; + ComServer.AutomationDone; + FreeAndNil(ComServer); end. -