* mantis #35013 library parts. Allow embedded objects.

git-svn-id: trunk@42594 -

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.
-

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.
-