--- Merging r42594 into '.':

U    packages/winunits-base/src/comobj.pp
U    packages/winunits-base/src/comserv.pp
--- Recording mergeinfo for merge of r42594 into '.':
 U   .
--- Merging r42908 into '.':
U    packages/fcl-stl/doc/hashmapexample.pp
U    packages/fcl-stl/src/ghashmap.pp
--- Recording mergeinfo for merge of r42908 into '.':
 G   .
--- Merging r42909 into '.':
G    packages/fcl-stl/src/ghashmap.pp
U    packages/fcl-stl/src/gvector.pp
--- Recording mergeinfo for merge of r42909 into '.':
 G   .
--- Merging r42910 into '.':
U    packages/fcl-stl/doc/mapexample.pp
U    packages/fcl-stl/src/gmap.pp
--- Recording mergeinfo for merge of r42910 into '.':
 G   .
--- Merging r42914 into '.':
U    packages/chm/src/chmreader.pas
--- Recording mergeinfo for merge of r42914 into '.':
 G   .
--- Merging r42915 into '.':
U    packages/fcl-stl/src/ghashset.pp
U    packages/fcl-stl/src/gset.pp
--- Recording mergeinfo for merge of r42915 into '.':
 G   .

# revisions: 42594,42908,42909,42910,42914,42915

git-svn-id: branches/fixes_3_2@42922 -

packages/chm/src/chmreader.pas

@@ -115,6 +115,7 @@ type
     procedure ReadCommonData;
     function  ReadStringsEntry(APosition: DWord): String;
     function  ReadStringsEntryFromStream ( strm:TStream ) : String;
+    { Return LocalUrl string from #URLSTR }
     function  ReadURLSTR(APosition: DWord): String;
     function  CheckCommonStreams: Boolean;
     procedure ReadWindows(mem:TMemoryStream);
@@ -489,8 +490,8 @@ begin
   fURLTBLStream.ReadDWord; // unknown
   fURLTBLStream.ReadDWord; // TOPIC index #
   fURLSTRStream.Position := LEtoN(fURLTBLStream.ReadDWord);
-  fURLSTRStream.ReadDWord;
+  fURLSTRStream.ReadDWord; // URL
-  fURLSTRStream.ReadDWord;
+  fURLSTRStream.ReadDWord; // FrameName
   if fURLSTRStream.Position < fURLSTRStream.Size-1 then
     Result := PChar(fURLSTRStream.Memory+fURLSTRStream.Position);
 end;

packages/fcl-stl/doc/hashmapexample.pp

@@ -1,5 +1,7 @@
 {$mode objfpc}
 
+{define oldstyleiterator}
+
 uses ghashmap;
 
 type hashlli=class
@@ -13,7 +15,8 @@ begin
   hash:= a mod b;
 end;
 
-var data:maplli; i:longint; iterator:maplli.TIterator;
+var data:maplli; i:longint;
+    pair : maplli.TPair;
 
 begin
   data:=maplli.Create;
@@ -24,12 +27,9 @@ begin
   data.delete(5);
 
   {Iteration through elements}
-  iterator:=data.Iterator;
+  // destroying class iterators is afaik a FPC extension.
-  repeat
+  for pair in data do
-    writeln(iterator.Key, ' ', iterator.Value);
+    writeln(pair.Key, ' ', pair.Value);
-  until not iterator.Next;
-  {Don't forget to destroy iterator}
-  iterator.Destroy;
 
   data.Destroy;
 end.

packages/fcl-stl/doc/mapexample.pp

@@ -4,7 +4,7 @@ type lesslli=specialize TLess<longint>;
      maplli=specialize TMap<longint, longint, lesslli>;
 
 var data:maplli; i:longint; iterator:maplli.TIterator;
-
+    pair : maplli.TPair;
 begin
   data:=maplli.Create;
 
@@ -14,7 +14,7 @@ begin
   writeln(data[7]);
   data[7] := 42;
 
-  {Iteration through elements}
+  {Iteration through elements with write access}
   iterator:=data.Min;
   repeat
     writeln(iterator.Key, ' ', iterator.Value);
@@ -22,6 +22,10 @@ begin
   until not iterator.next;
   iterator.Destroy;
 
+  // using for..in to check everything changed to 47. For in is shorter and autoallocated, but can't write to cells via iterator.
+  for pair in data.min do
+    writeln('Min: ',pair.Key, ' ', pair.Value);         
+
   iterator := data.FindLess(7);
   writeln(iterator.Value);
   iterator.Destroy;

packages/fcl-stl/src/ghashmap.pp

@@ -38,25 +38,33 @@
   }
 
   type
-    generic THashmapIterator<TKey, TValue, T, TTable>=class
-      public
-      type PValue=^TValue;
-      var
-        Fh,Fp:SizeUInt;
-        FData:TTable;
-        function Next:boolean;inline;
-        function Prev:boolean;inline;
-        function GetData:T;inline;
-        function GetKey:TKey;inline;
-        function GetValue:TValue;inline;
-        function GetMutable:PValue;inline;
-        procedure SetValue(value:TValue);inline;
-        property Data:T read GetData;
-        property Key:TKey read GetKey;
-        property Value:TValue read GetValue write SetValue;
-        property MutableValue:PValue read GetMutable;
-    end;
 
+    { THashmapIterator }
+
+    generic THashmapIterator<TKey, TValue, T, TTable>=class
+         public
+         type PValue=^TValue;
+              TIntIterator = specialize THashmapIterator<TKey, TValue, T, TTable>;
+         var
+           Fh,Fp:SizeUInt;
+           FData:TTable;
+           function Next:boolean;inline;
+           function MoveNext:boolean;inline;
+           function Prev:boolean;inline;
+           function GetData:T;inline;
+           function GetKey:TKey;inline;
+           function GetValue:TValue;inline;
+           function GetMutable:PValue;inline;
+           procedure SetValue(value:TValue);inline;
+           function GetEnumerator : TIntIterator; inline;
+           property Data:T read GetData;
+           property Key:TKey read GetKey;
+           property Value:TValue read GetValue write SetValue;
+           property MutableValue:PValue read GetMutable;
+           property Current : T read GetData;
+       end;
+
+    { THashmap }
     generic THashmap<TKey, TValue, Thash>=class
       public
       type
@@ -76,20 +84,19 @@
       public 
       type
         TIterator = specialize THashmapIterator<TKey, TValue, TPair, TTable>;
-        constructor create;
+        constructor Create;
-        destructor destroy;override;
+        destructor Destroy;override;
         procedure insert(key:TKey;value:TValue);inline;
         function contains(key:TKey):boolean;inline;
-        function size:SizeUInt;inline;
+        function Size:SizeUInt;inline;
         procedure delete(key:TKey);inline;
         procedure erase(iter:TIterator);inline;
         function IsEmpty:boolean;inline;
         function GetData(key:TKey):TValue;inline;
         function GetValue(key:TKey;out value:TValue):boolean;inline;
-
-        property Items[i : TKey]: TValue read GetData write Insert; default;
-
         function Iterator:TIterator;
+        function getenumerator :TIterator;
+        property Items[i : TKey]: TValue read GetData write Insert; default;
   end;
 
 implementation
@@ -111,7 +118,7 @@ begin
   FData.Destroy;
 end;
 
-function THashmap.IsEmpty(): boolean;
+function THashmap.IsEmpty: boolean;
 begin
   IsEmpty := Size()=0;
 end;
@@ -145,7 +152,7 @@ begin
   end;
 end;
 
-constructor THashmap.create;
+constructor THashmap.Create;
 var i: SizeUInt;
 begin
   FDataSize:=0;
@@ -290,6 +297,22 @@ begin
   exit(false);
 end;
 
+function THashmapIterator.MoveNext: boolean;
+begin
+  Assert(Fh < FData.size);      // assumes FData.size>0 (i.e. buckets don't shrink) and cannot call Next again after reaching end
+  inc(Fp);
+  if (Fp < (FData[Fh]).size) then
+    exit(true);
+  Fp:=0; Inc(Fh);
+  while Fh < FData.size do begin
+    if ((FData[Fh]).size > 0) then
+      exit(true);
+    Inc(Fh);
+  end;
+  //Assert((Fp = 0) and (Fh = FData.size));
+  exit(false);
+end;
+
 function THashmapIterator.Prev: boolean;
 var bs:SizeUInt;
 begin
@@ -330,6 +353,11 @@ begin
   Iterator.FData := FData;
 end;
 
+function THashmap.getenumerator: TIterator;
+begin
+  result:=iterator;
+end;
+
 function THashmapIterator.GetKey: TKey;
 begin
   GetKey:=((FData[Fh])[Fp]).Key;
@@ -350,4 +378,9 @@ begin
   ((FData[Fh]).mutable[Fp])^.Value := value;
 end;
 
+function THashmapIterator.getenumerator: TIntIterator;
+begin
+  result:=self;
+end;
+
 end.

packages/fcl-stl/src/ghashset.pp

@@ -23,14 +23,22 @@ const baseFDataSize = 8;
 value in range <0,n-1> base only on arguments, n will be always power of 2}
 
 type
+
+    { THashSetIterator }
+
     generic THashSetIterator<T, TTable>=class
     public
+    Type
+      TLHashSetIterator = specialize THashSetIterator<T, TTable>;
     var
       Fh,Fp:SizeUInt;
       FData:TTable;
       function Next:boolean;
+      function MoveNext:boolean; inline;
       function GetData:T;
+      function GetEnumerator: TLHashSetIterator; inline;
       property Data:T read GetData;
+      property Current:T read GetData;
  end;
 
   generic THashSet<T, Thash>=class
@@ -52,18 +60,18 @@ type
       function size:SizeUInt;inline;
       procedure delete(value:T);inline;
       function IsEmpty:boolean;inline;
-
+      function GetEnumerator: TIterator; inline;
       function Iterator:TIterator;
   end;
 
 implementation
 
-function THashSet.Size:SizeUInt;inline;
+function THashSet.size: SizeUInt;
 begin
   Size:=FDataSize;
 end;
 
-destructor THashSet.Destroy;
+destructor THashSet.destroy;
 var i:SizeUInt;
 begin
   for i:=0 to FData.size-1 do
@@ -71,7 +79,7 @@ begin
   FData.Destroy;
 end;
 
-function THashSet.IsEmpty():boolean;inline;
+function THashSet.IsEmpty: boolean;
 begin
   if Size()=0 then 
     IsEmpty:=true
@@ -79,6 +87,22 @@ begin
     IsEmpty:=false;
 end;
 
+function THashSet.GetEnumerator: TIterator;
+  var h,p:SizeUInt;
+begin
+  h:=0;
+  p:=0;
+  while h < FData.size do begin
+    if ((FData[h]).size > 0) then break;
+    inc(h);
+  end;
+  if (h = FData.size) then exit(nil);
+  result := TIterator.create;
+  result.Fh := h;
+  result.Fp := p;
+  result.FData := FData;
+end;
+
 procedure THashSet.EnlargeTable;
 var i,j,h,oldDataSize:SizeUInt; 
     value:T;
@@ -163,11 +187,30 @@ begin
   Next := true;
 end;
 
+function THashSetIterator.MoveNext: boolean;
+begin
+  inc(Fp);
+  if (Fp = (FData[Fh]).size) then begin
+    Fp:=0; inc(Fh);
+    while Fh < FData.size do begin
+      if ((FData[Fh]).size > 0) then break;
+      inc(Fh);
+    end;
+    if (Fh = FData.size) then exit(false);
+  end;
+  MoveNext := true;
+end;
+
 function THashSetIterator.GetData:T;
 begin
   GetData:=(FData[Fh])[Fp];
 end;
 
+function THashSetIterator.GetEnumerator: TLHashSetIterator;
+begin
+  result:=self;
+end;
+
 function THashSet.Iterator:TIterator;
 var h,p:SizeUInt;
 begin

packages/fcl-stl/src/gmap.pp

@@ -23,9 +23,12 @@ type
     class function c(a,b :TPair):boolean;
   end;
 
+  { TMapIterator }
+
   generic TMapIterator<TKey, TValue, TPair, TNode>=class
     public
     type PNode=^TNode;
+         TLMapIterator = specialize TMapIterator<TKey, TValue, TPair, TNode>;
     var FNode:PNode;
     type PValue=^TValue;
     function GetData:TPair;inline;
@@ -33,12 +36,15 @@ type
     function GetValue:TValue;inline;
     function GetMutable:PValue;inline;
     procedure SetValue(value:TValue);inline;
+    function MoveNext:boolean;inline;
     function Next:boolean;inline;
     function Prev:boolean;inline;
+    function GetEnumerator: TLMapIterator; inline;
     property Data:TPair read GetData;
     property Key:TKey read GetKey;
     property Value:TValue read GetValue write SetValue;
     property MutableValue:PValue read GetMutable;
+    property Current : TPair read GetData;
   end;
 
   generic TMap<TKey, TValue, TCompare>=class
@@ -71,6 +77,7 @@ type
     procedure Delete(key:TKey);inline;
     function Size:SizeUInt;inline;
     function IsEmpty:boolean;inline;
+    function GetEnumerator: TIterator; inline;
     constructor Create;
     destructor Destroy;override;
     property Items[i : TKey]: TValue read GetValue write Insert; default;
@@ -227,6 +234,11 @@ begin
   IsEmpty:=FSet.IsEmpty;
 end;
 
+function TMap.GetEnumerator: TIterator;
+begin
+  result:=titerator.create;
+end;
+
 function TMapIterator.GetData:TPair;inline;
 begin
   GetData:=FNode^.Data;
@@ -252,6 +264,27 @@ begin
   FNode^.Data.Value := value;
 end;
 
+function TMapIterator.MoveNext: boolean;
+var temp:PNode;
+begin
+  if(FNode=nil) then exit(false);
+  if(FNode^.Right<>nil) then begin
+    temp:=FNode^.Right;
+    while(temp^.Left<>nil) do temp:=temp^.Left;
+  end
+  else begin
+    temp:=FNode;
+    while(true) do begin
+      if(temp^.Parent=nil) then begin temp:=temp^.Parent; break; end;
+      if(temp^.Parent^.Left=temp) then begin temp:=temp^.Parent; break; end;
+      temp:=temp^.Parent;
+    end;
+  end;
+  if (temp = nil) then exit(false);
+  FNode:=temp;
+  MoveNext:=true;
+end;
+
 function TMapIterator.Next:boolean;inline;
 var temp:PNode;
 begin
@@ -294,4 +327,9 @@ begin
   Prev:=true;
 end;
 
+function TMapIterator.GetEnumerator: TLMapIterator;
+begin
+  result:=Self;
+end;
+
 end.

packages/fcl-stl/src/gset.pp

@@ -20,14 +20,22 @@ const RED=true;
 const BLACK=false;
 
 type
+
+  { TSetIterator }
+
   generic TSetIterator<T, TNode>=class
     public
     type PNode=^TNode;
+         TLSetIterator = specialize TSetIterator<T, TNode>;
+
     var FNode:PNode;
-    function GetData:T;
+    function GetData:T; Inline;
     function Next:boolean;
+    function MoveNext:boolean; Inline;
+    function GetEnumerator : TLSetIterator; Inline;
     function Prev:boolean;
     property Data:T read GetData;
+    property Current:T read GetData;
   end;
 
   generic TSet<T, TCompare>=class
@@ -502,6 +510,11 @@ begin
 end;
 
 function TSetIterator.Next:boolean;
+begin
+  Result:=MoveNext;
+end;
+
+function TSetIterator.MoveNext: boolean;
 var temp:PNode;
 begin
   if(FNode=nil) then exit(false);
@@ -519,7 +532,12 @@ begin
   end;
   if (temp = nil) then exit(false);
   FNode:=temp;
-  Next:=true;
+  Result:=true;
+end;
+
+function TSetIterator.GetEnumerator: TLSetIterator;
+begin
+  result:=self;
 end;
 
 function TSetIterator.Prev:boolean;

packages/fcl-stl/src/gvector.pp

@@ -50,6 +50,7 @@ type
       function GetCurrent: T; inline;
     public
       constructor Create(AVector: TVector);
+      function GetEnumerator: TVectorEnumerator; inline;
       function MoveNext: Boolean; inline;
       property Current: T read GetCurrent;
     end;
@@ -83,6 +84,11 @@ begin
   FVector := AVector;
 end;
 
+function TVector.TVectorEnumerator.GetEnumerator: TVectorEnumerator;
+begin
+  result:=self;
+end;
+
 function TVector.TVectorEnumerator.GetCurrent: T;
 begin
   Result := FVector[FPosition];

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 := CoLockObjectExternal(Self, fLock, True);
-        Result:=0;
+          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);
+      if FInstancing <> ciInternal then
-      end;
+      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.
-