mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-07 20:08:12 +02:00
* mantis #35013 library parts. Allow embedded objects.
git-svn-id: trunk@42594 -
This commit is contained in:
marco
parent
481126fc80
commit
cffc8317fa
@ -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.
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user