paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 20:28:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r42594 into '.':

Browse Source 
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 -
This commit is contained in:
marco 2019-09-05 12:17:22 +00:00
parent 415c951a87
commit c07b8a1954
10 changed files with 395 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
packages/chm/src/chmreader.pas
View File

@ -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;
fURLSTRStream.ReadDWord; // URL
fURLSTRStream.ReadDWord; // FrameName
if fURLSTRStream.Position < fURLSTRStream.Size-1 then
Result := PChar(fURLSTRStream.Memory+fURLSTRStream.Position);
end;

14
packages/fcl-stl/doc/hashmapexample.pp
View File

@ -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;
repeat
writeln(iterator.Key, ' ', iterator.Value);
until not iterator.Next;
{Don't forget to destroy iterator}
iterator.Destroy;
// destroying class iterators is afaik a FPC extension.
for pair in data do
writeln(pair.Key, ' ', pair.Value);
data.Destroy;
end.

8
packages/fcl-stl/doc/mapexample.pp
View File

@ -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;

85
packages/fcl-stl/src/ghashmap.pp
View File

@ -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;
destructor destroy;override;
constructor Create;
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.

51
packages/fcl-stl/src/ghashset.pp
View File

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

38
packages/fcl-stl/src/gmap.pp
View File

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

22
packages/fcl-stl/src/gset.pp
View File

@ -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;

6
packages/fcl-stl/src/gvector.pp
View File

@ -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];

52
packages/winunits-base/src/comobj.pp
View File

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

177
packages/winunits-base/src/comserv.pp
View File

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