Cannot add objects to GlobalInterfaceTable during ADO async callback - delphi

i am using the follow test code to add an object to the GlobalInterfaceTable:
function TForm1.AddSomethingToGit(): DWORD;
var
unk: IUnknown;
cookie: DWORD;
git: IGlobalInterfaceTable;
begin
unk := TCounter.Create;
if FGit = nil then
begin
git := CoGlobalInterfaceTable.Create;
Fgit := git; //yes, i didn't use InterlockedCompareExchange. Can you imagine trying to explain that syntax to people?
end;
OleCheck(Fgit.RegisterInterfaceInGlobal(unk, IUnknown, {out}cookie));
Result := cookie;
end;
And i call the test code from a button handler:
procedure TForm1.Button1Click(Sender: TObject);
begin
AddSomethingToGit();
end;
And everything is good. The object it sitting in the global interface table, waiting to be extracted. i know it is still in there because the the destructor in TInterfacedObject has not been run e.g. breakpoint never hit:
Note: if i close the test app right now, then i will see the GlobalInterfaceTable call Release on my object, freeing it. But that's during shutdown, for now i'm still in memory.
But if i call the same test function from an ADO callback:
conn := CreateTrustedSqlServerConnection(serverName, defaultDatabaseName);
dataSet := TADODataSet.Create(nil);
dataSet.Connection := conn;
dataSet.OnFetchComplete := FetchComplete;
dataSet.CursorLocation := clUseClient;
dataSet.CommandText := 'WAITFOR DELAY ''00:00:03''; SELECT GETDATE() AS foo';
dataSet.CommandType := cmdText;
dataSet.ExecuteOptions := [eoAsyncFetch];
dataSet.Open();
with the callback:
procedure TForm1.FetchComplete(DataSet: TCustomADODataSet;
const Error: Error; var EventStatus: TEventStatus);
begin
AddSomethingToGit();
end;
the object i placed into the Global Interface Table is destroyed as soon as the callback returns, hitting the breakpoint in TInterfacedObject.
In reality i wouldn't be adding a dummy test object to the GIT during the ADO async callback, i would be adding an actual ADO interface. But when that didn't work we trim the failing code down to the bare-bones.
tl;dr: i try to add an object to the Global Interface Table, but it gets destroyed as soon as i put it in there.
Bonus Chatter
i thought maybe i had to manually call AddRef before placing the object into the GIT, but the GIT register method calls AddRef itself.
How to construct an IGlobalInterfaceTable:
class function CoGlobalInterfaceTable.Create: IGlobalInterfaceTable;
begin
// There is a single instance of the global interface table per process, so all calls to this function in a process return the same instance.
OleCheck(CoCreateInstance(CLSID_StdGlobalInterfaceTable, nil, CLSCTX_INPROC_SERVER, IGlobalInterfaceTable, Result));
end;
with the (not my) Delphi translation of the interface:
IGlobalInterfaceTable = interface(IUnknown)
['{00000146-0000-0000-C000-000000000046}']
function RegisterInterfaceInGlobal(pUnk: IUnknown; const riid: TIID; out dwCookie: DWORD): HRESULT; stdcall;
function RevokeInterfaceFromGlobal(dwCookie: DWORD): HRESULT; stdcall;
function GetInterfaceFromGlobal(dwCookie: DWORD; const riid: TIID; out ppv): HRESULT; stdcall;
end;
And for completeness:
const
CLSID_StdGlobalInterfaceTable : TGUID = '{00000323-0000-0000-C000-000000000046}';
Update One
i desperately wanted to avoid adding my own object, for fear someone would think my object was screwed up. That's why originally i demonstrated with Delphi's in-built TInterfacedObject. In order to confirm that it really is "my" object that's being destroyed, i changed references in the question from TInterfacedObject to TCounter:
TCounter = class(TInterfacedObject, IUnknown)
private
FFingerprint: string;
public
constructor Create;
destructor Destroy; override;
end;
{ TCounter }
constructor TCounter.Create;
begin
inherited Create;
FFingerprint := 'Rob Kennedy';
end;
destructor TCounter.Destroy;
begin
if FFingerprint = 'Rob Kennedy' then
Beep;
inherited;
end;
And my TCounter.Destroy is hit.

I know it's old, but you can simply schedule an anonymous method in another thread (that will go down at the exit of the application) where you create the object and store it into the GIT. Like that the apartment of this special thread will be managed by you and the object will live in that apartment.
Moroever, it seems from my tests that in git you can register objects created in other apartments too from an apartment. But part of the documentations states differently. I'm still working on this.

i figured out the problem; it's likely an (undocumented) fundamental limitation of IGlobalInterfaceTable that makes it essentially unusable:
Any object added to the GlobalInterfaceTable must be retrieved before the adding apartment is torn down.
Running the following from a separate thread:
procedure TAddToGitThread.Execute;
var
unk: IUnknown;
cookie: DWORD;
git: IGlobalInterfaceTable;
begin
CoInitialize(nil);
try
unk := TCounter.Create;
git := CoGlobalInterfaceTable.Create;
OleCheck(git.RegisterInterfaceInGlobal(unk, IUnknown, {out}cookie));
unk := nil;
finally
CoUninitialize; <--objects added from this apartment Released
end;
end;
As soon as the apartment associated with the separate thread is uninitialized: any objects still in the GlobalInterfaceTable are flushed.
This makes it impossible the post messages containing GIT cookie values between threads.
Even artificially inflating the reference count, to prevent object destruction won't help you:
procedure TAddToGitThread.Execute;
var
unk: IUnknown;
cookie: DWORD;
git: IGlobalInterfaceTable;
begin
CoInitialize(nil);
try
unk := TCounter.Create;
unk._AddRef; //inflate reference count to prevent destruction on apartment teardown
git := CoGlobalInterfaceTable.Create;
OleCheck(git.RegisterInterfaceInGlobal(unk, IUnknown, {out}cookie));
unk := nil;
finally
CoUninitialize; <--object added from this apartment is Released, but not freed
end;
end;
Even though the object was not destroyed (because we inflated the reference count), it will no longer be in the global interface table. Asking for it will just fail:
hr := _git.GetInterfaceFromGlobal(_cookie, IUnknown, {out}unk);
returns
0x80070057 The parameter is incorrect
You wanted to use that object added to the GIT? You had should have grabbed it while you didn't have the chance!
i hate bugs where i do nothing wrong, but it still fails.

Related

Delphi tstringlist.free erases result [duplicate]

This question already has answers here:
How do i return an object from a function in Delphi without causing Access Violation?
(10 answers)
Closed last month.
Ok, this I don't understand.
path:=tstringlist.create;
//load up the path with stuff
Result := path;
path.free;
exit;
I would have thought that result would actually equal the path but it apparently doesn't. If I remove path.free from the code above, the result works as it should and it = the path tstringlist but I get a memory leak. When I put path.free in there, the result becomes empty. I understand the memory leak but how is result getting erased if I free the path AFTER I make it := ????
And yes, the above code is inside multiple for loops which is why I'm using exit. I've tried break and try finally and had no luck making those work either.
Let me rephrase your variable and class names and add a few comments:
function MyNewHouse(): TStringList;
var
NewAddress: TStringList;
begin
// Construct a house with walls, windows, doors and a roof. Those
// are the properties and methods that we're able to use later.
NewAddress := House.Create();
// ...fill the house with content, using our walls, windows, doors...
// Only copy the new house's address, not the house in its entirety.
// And certainly not its content.
Result := NewAddress;
// Demolish/Tear down the house, which can only be made once. When
// the house is demolished, you can neither access it, nor tear it
// down anew. However, the address is still somewhat "valid". While
// everything but the spot where it once existed is gone.
NewAddress.Free();
Exit;
end;
Whenever you assign variables of a class type (such as TObject or TStringList or TForm) you're merely copying its address, not its entire content. For copying (believe it or not) the method .Assign() exists:
// Instead of only "Result := NewAddress;"
Result.Assign( NewAddress );
That copies its whole content. This method exists for many classes, and for each different class "copying its content" can mean different things, just like you may want to copy a TStringList's items, but not necessarily its other settings. But if you wanted it that way you would have used Result.Items := NewAddress.Items already in your example...
The reason why Result becomes empty when you include path.free is because Result is just a reference to path. When you call path.free, you are freeing the memory that path occupies, which makes the reference to that memory invalid. When you try to access Result after freeing path, you are trying to access invalid memory, which can result in undefined behavior.
You need to free the returned TStringList outside of the function, you should modify the function as follows:
function getPath: TStringList;
begin
Result := tstringlist.create;
//load up the path with stuff
end;
// usage:
var
path: TStringList;
begin
path := getPath;
try
// use path here
finally
path.Free;
end;
end;
This way, the returned TStringList is created inside the function and is passed as a reference to the caller. The caller is responsible for freeing the TStringList when it is no longer needed by calling Free on it. This is called "resource acquisition is initialization" (RAII) and is a common pattern in Delphi for managing resources such as dynamically allocated objects.
By using this pattern, you can ensure that the TStringList is always properly freed and avoid potential memory leaks.
More advanced trick (XE2+):
type
IScope<T: class> = interface
private
function GetIt: T;
public
property It: T read GetIt;
end;
TScope<T: class> = class(TInterfacedObject, IScope<T>)
private
FValue: T;
public
constructor Create(const AValue: T);
destructor Destroy; override;
function GetIt: T;
end;
constructor TScope<T>.Create(const AValue: T);
begin
inherited Create;
FValue := AValue;
end;
destructor TScope<T>.Destroy;
begin
FValue.Free;
inherited;
end;
function TScope<T>.GetIt: T;
begin
Result := FValue;
end;
function getPath: IScope<TStringList>;
var
path: TStringList;
begin
path := tstringlist.create;
//load up the path with stuff
Result := TScope<TStringList>.Create(path);
end;
// usage:
var
path: TStringList;
begin
path := getPath.It;
// use path here
end; // auto-free here

Is there memory leak here?

is this piece of code safe from memory leaks?
s := TStringList.Create; // create first object
try
// Here line comes that seems to be dangerous
s := GetSomeSettings; // Overrides reference to first object by second one
finally
s.free; // Destroying only second object, leave first object to live somewhere in memory
end;
function GetSomeSettings : TStringList;
var
rawString : string;
settings : TStringList;
begin
// Singleton pattern implementation
// Trying to find already existing settings in class variable
settings := TSettingsClass.fSettings;
// If there is no already defined settings then get them
if not Assigned(settings) then
begin
GetSettingsInDB(rawString);
TSettingsClass.fSettings := ParseSettingsString(rawString);
settings := TSettingsClass.fSettings;
end;
Result := settings;
end;
I'm wondering s := GetSomeSettings; potentially harmful and ignoring first object, keeps it in the memory?
Yes, the StringList created on line 1 is leaked.
Essentialy, you are doing:
s := TStringList.Create;
s := AnotherStringList;
AnotherStringList.Free;
As for the GetSomeSettings routine:
Normally it is not wise or encouraged to return newly created instances as function results, because you transfer the responsibility for ownership and destruction to the calling code. Unless you have a mechanism/framework in place that takes care of it, which seems to be the case with your TSettingsClass, but there is not enough evidence for that in this little piece of code.
Nevertheless, the combination of both pieces of code display another problem: After s.Free, TSettingsClass.fSettings is destroyed but not nil. Thus the second time GetSomeSettings is called, it returns a dangling pointer.
1) you should not ask when you can check in two minutes!
program {$AppType Console};
uses Classes, SysUtils;
type TCheckedSL = class(TStringList)
public
procedure BeforeDestruction; override;
procedure AfterConstruction; override;
end;
procedure TCheckedSL.BeforeDestruction;
begin
inherited;
WriteLn('List ',IntToHex(Self,8), ' going to be safely destroyed.');
end;
procedure TCheckedSL.AfterConstruction;
begin
WriteLn('List ',IntToHex(Self,8), ' was created - check whether it is has matched destruction.');
inherited;
end;
procedure DoTest; var s: TStrings;
function GetSomeSettings: TStrings;
begin Result := TCheckedSL.Create end;
begin
Writeln('Entered DoTest procedure');
s := TCheckedSL.Create; // create first object
try
// Here line comes that seems to be dangerous
s := GetSomeSettings; // Overrides reference to first object by second one
finally
s.free; // Destroying only second object, leave first object
end;
Writeln('Leaving DoTest procedure');
end;
BEGIN
DoTest;
Writeln;
Writeln('Check output and press Enter when done');
ReadLn;
END.
2) Still that could be safe in few niche cases.
in FPC (http://FreePascal.org) S could be a "global property" of some unit, having a setter which would free old list.
in Delphi Classic S could be of some interface type, supported by the created object. Granted, standard TStringList lacks any interface, but some libraries ( for example http://jcl.sf.net ) do offer interface-based string lists, with richer API (iJclStringList type and related).
in Delphi/LLVM all objects were made reference-counted, like interfaces without GUID's. So that code would be safe there.
You can declare S as a record - a so-called Extended Record having re-defined class operator Implicit so that the typecast s{record} := TStringList.Create would free the previous instance before assigning a new one. That is dangerous though, as it is VERY fragile and easy to misuse, and destroy the list in some other place leaving a dangling pointer inside the S record.
Your object may be not that vanilla TStringList, but some subclass, overriding constructors or AfterConstruction to register itself in some list, that would be all-at-once in some place. Kind of Mark/Sweep heap management around large chunk of workload. VCL TComponent may be seen as following this pattern: form is owning its component and frees them when needed. And this is what you - in reduced form - are trying to do with TSettingsClass.fSettings containter (any reference is 1-sized container). However those frameworks do require a loopback: when the object is freed it should also remove itself from all the containers, referencing it.
.
procedure TCheckedSL.BeforeDestruction;
begin
if Self = TSettingsClass.fSettings then TSettingsClass.fSettings := nil;
inherited;
end;
class procedure TSettingsClass.SetFSettings(Value);
var fSet2: TObject;
begin
if fSettings <> nil then begin
fSet2 := fSettings;
f_fSettings := nil; // breaking the loop-chain
fSet2.Destroy;
end;
f_fSettings := Value;
end;
class destructor TSettingsClass.Destroy;
begin
fSettings := nil;
end;
However then - by the obvious need to keep design symmetric - the registration should also be done as a part of the class. Who is responsible for de-registration is usually the one responsible for registration as well, unless there are reasons to skew the design.
procedure TCheckedSL.AfterConstruction;
begin
inherited;
TSettingsClass.fSettings := Self;
end;
...
if not Assigned(settings) then
begin
GetSettingsInDB(rawString);
TCheckedSL.Create.Text := ParseSettingsString(rawString);
settings := TSettingsClass.fSettings;
Assert( Assigned(settings), 'wrong class used for DB settings' );
end;
Result := settings;

Determine if running as VCL Forms or Service

I have code which is used both in services and within VCL Form applications (win32 application). How can I determine if the underlying application is running as a NT Service or as an application?
Thanks.
BEGIN OF EDIT
Since this still seems to be getting some attention I decided to update the answer with missing info and newer windows patches. In any case you should not copy / paste the code. The code is just a showcase on how the things should be done.
END OF EDIT:
You can check if the parent process is SCM (service control manager). If you are running as service this is always the case and never the case if running as standard application. Also I think that SCM has always the same PID.
You can check it like this:
type
TAppType = (atUnknown, atDesktop, atService);
var
AppType: TAppType;
function InternalIsService: Boolean;
var
PL: TProcessList;
MyProcessId: DWORD;
MyProcess: PPROCESSENTRY32;
ParentProcess: PPROCESSENTRY32;
GrandParentProcess: PPROCESSENTRY32;
begin
Result := False;
PL := TProcessList.Create;
try
PL.CreateSnapshot;
MyProcessId := GetCurrentProcessId;
MyProcess := PL.FindProcess(MyProcessId);
if MyProcess <> nil then
begin
ParentProcess := PL.FindProcess(MyProcess^.th32ParentProcessID);
if ParentProcess <> nil then
begin
GrandParentProcess := PL.FindProcess(ParentProcess^.th32ParentProcessID);
if GrandParentProcess <> nil then
begin
Result := SameText(string(ParentProcess^.szExeFile), 'services.exe') and
(SameText(string(GrandParentProcess^.szExeFile), 'winlogon.exe') or
SameText(string(GrandParentProcess^.szExeFile), 'wininit.exe'));
end;
end;
end;
finally
PL.Free;
end;
end;
function IsService: Boolean;
begin
if AppType = atUnknown then
begin
try
if InternalIsService then
AppType := atService
else
AppType := atDesktop;
except
AppType := atService;
end;
end;
Result := AppType = atService;
end;
initialization
AppType := atUnknown;
The TProcessList is implemented like this (again THashTable is not included but any hash table should be fine):
type
TProcessEntryList = class(TList)
private
function Get(Index: Integer): PPROCESSENTRY32;
procedure Put(Index: Integer; const Value: PPROCESSENTRY32);
public
property Items[Index: Integer]: PPROCESSENTRY32 read Get write Put; default;
function Add(const Entry: TProcessEntry32): Integer; reintroduce;
procedure Clear; override;
end;
TProcessList = class
private
ProcessIdHashTable: THashTable;
ProcessEntryList: TProcessEntryList;
public
constructor Create; reintroduce;
destructor Destroy; override;
procedure CreateSnapshot;
function FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
end;
implementation
{ TProcessEntryList }
procedure TProcessEntryList.Clear;
var
i: Integer;
begin
i := 0;
while i < Count do
begin
FreeMem(Items[i]);
Inc(i);
end;
inherited;
end;
procedure TProcessEntryList.Put(Index: Integer; const Value: PPROCESSENTRY32);
var
Item: Pointer;
begin
Item := inherited Get(Index);
CopyMemory(Item, Value, SizeOf(tagPROCESSENTRY32));
end;
function TProcessEntryList.Get(Index: Integer): PPROCESSENTRY32;
begin
Result := PPROCESSENTRY32(inherited Get(Index));
end;
function TProcessEntryList.Add(const Entry: TProcessEntry32): Integer;
var
EntryCopy: PPROCESSENTRY32;
begin
GetMem(EntryCopy, SizeOf(tagPROCESSENTRY32));
CopyMemory(EntryCopy, #Entry, SizeOf(tagPROCESSENTRY32));
Result := inherited Add(EntryCopy);
end;
{ TProcessList }
constructor TProcessList.Create;
begin
inherited;
ProcessEntryList := TProcessEntryList.Create;
ProcessIdHashTable := THashTable.Create;
end;
destructor TProcessList.Destroy;
begin
FreeAndNil(ProcessIdHashTable);
FreeAndNil(ProcessEntryList);
inherited;
end;
function TProcessList.FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
var
ItemIndex: Integer;
begin
Result := nil;
if not ProcessIdHashTable.ContainsKey(IntToStr(ProcessId)) then
Exit;
ItemIndex := Integer(ProcessIdHashTable.Item[IntToStr(ProcessId)]);
Result := ProcessEntryList.Items[ItemIndex];
end;
procedure TProcessList.CreateSnapshot;
var
SnapShot: THandle;
ProcessEntry: TProcessEntry32;
ItemIndex: Integer;
begin
SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapShot <> 0 then
try
ProcessEntry.dwSize := SizeOf(ProcessEntry);
if Process32First(SnapShot, ProcessEntry) then
repeat
ItemIndex := ProcessEntryList.Add(ProcessEntry);
ProcessIdHashTable.Add(IntToStr(ProcessEntry.th32ProcessID), TObject(ItemIndex));
until not Process32Next(SnapShot, ProcessEntry);
finally
CloseHandle(SnapShot);
end;
end;
The application object (Forms.application) mainform will be nil if it is not a forms based application.
uses
Forms, ... ;
function IsFormBased : boolean;
begin
Result := Assigned(Forms.Application.MainForm);
end;
How about matching GetCurrentProcessId against EnumServicesStatusEx?
The lpServices parameter points to a buffer that receives an array of ENUM_SERVICE_STATUS_PROCESS structures.
The match is done against the enumerated service process ID: ServiceStatusProcess.dwProcessId in that structure.
Another option is using WMI to query for Win32_Service instances where ProcessId=GetCurrentProcessId.
I doubt that
System.IsConsole
System.IsLibrary
will give you the expected results.
All I can think of is to pass an Application object as TObject to the method where you need to make that distinction and test for the passed object's classname being a
TServiceApplication
or
TApplication
That said, there shouldn't be a need for you to know if your code is running in a service or a GUI. You should probably rethink your design and make the caller to pass an object to handle messages you want (or don't want) to show. (I assume it is for showing messages/exceptions you'd like to know).
You can try something like this
Function IsMyformInsideaWindowsService(aForm:TObject) :Boolean;
Begin
Result:=aForm.ClassParent.ClassName='TService'; //When a form is running under a service the Class Parent is a TService
End;
A single project cannot (or I should say ideally is not) both a service and a forms application, at least not if you are able to distinguish between the Forms Application object and the SvcMgr Application object - you must presumably have separate projects for the forms code and the service code.
So perhaps the easiest solution is a project conditional define. i.e. in your project settings for the service project add "SERVICEAPP" to the Conditional Defines.
Then whenever you need to change behaviour simply:
{$ifdef SERVICEAPP}
{$else}
{$endif}
For belts and braces you might adopt one of the previously described tests within some startup code to ensure that your project has been compiled with the expected symbol defined.
program ... ;
:
begin
{$ifdef SERVICEAPP}
// test for service app - ASSERT if not
{$else}
// test for forms app - ASSERT if not
{$endif}
:
end.
It is possible that your Forms app is actually running as a service, using the crude technique that allows any application to be running as a service.
In that case of course your app will always be a Forms application and the easiest way to handle that situation is to have a command line switch that you specify only in the service definition for your executable so that your app can respond appropriate by testing for that command line switch.
This does allow you to more easily test your "service mode" behaviour of course, since you can run your app in "debug" mode with that switch defined from within the IDE, but it's not an ideal way to build a service application so I would not recommend it on the strength of that alone. It's a technique that is usually only used when you have an EXE that you wish to run as a service but have no way to modify the source code to turn it into a "proper" service.
The answer from "Runner" ( https://stackoverflow.com/a/1568462 ) looked very helpful, but I could not use it since neither TProcessList, nor CreateSnapshot is defined. Searching for "TProcessList CreateSnapshot" in Google will just find 7 pages, including this one and mirrors/quotes of this page. No code exists. Alas, my reputation is too low to send him a comment, asking where I can find the code of TProcessList.
Another problem: At my computer (Win7 x64), the "services.exe" is NOT inside "winlogon.exe". It is inside "wininit.exe". Since it seems to be an implementation detail of Windows, I would suggest not querying the grand parent. Also, services.exe does not need to be the direct parent, since processes could be forked.
So this is my version using TlHelp32 directly, solving all the problems:
uses
Classes, TlHelp32;
function IsRunningAsService: boolean;
function FindProcess(FSnapshotHandle: THandle; PID: DWORD; var lppe: TProcessEntry32): boolean;
var
ContinueLoop: BOOL;
begin
ContinueLoop := Process32First(FSnapshotHandle, lppe);
while Integer(ContinueLoop) <> 0 do
begin
if lppe.th32ProcessID = PID then
begin
result := true;
Exit;
end;
ContinueLoop := Process32Next(FSnapshotHandle, lppe);
end;
result := false;
end;
var
CurProcessId: DWORD;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
ExeName, PrevExeName: string;
DeadlockProtection: TList<Integer>;
begin
Result := false;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
DeadlockProtection := TList<Integer>.Create;
try
CurProcessId := GetCurrentProcessId;
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ExeName := '';
while FindProcess(FSnapshotHandle, CurProcessId, FProcessEntry32) do
begin
if DeadlockProtection.IndexOf(FProcessEntry32.th32ProcessID) > -1 then break;
DeadlockProtection.Add(FProcessEntry32.th32ProcessID);
PrevExeName := ExeName;
ExeName := FProcessEntry32.szExeFile;
(*
Result := SameText(PrevExeName, 'services.exe') and // Parent
SameText(ExeName, 'winlogon.exe'); // Grandparent
*)
Result := SameText(ExeName, 'services.exe'); // Parent
if Result then Exit;
CurProcessId := FProcessEntry32.th32ParentProcessID;
end;
finally
CloseHandle(FSnapshotHandle);
DeadlockProtection.Free;
end;
end;
This code works, also even in applications without MainForm (e.g. CLI apps).
you can use GetStdHandle method for get out console handle.when applications run as windows service has not output console.if GetStdHandle equals zero means your application run as windows service.
{$APPTYPE CONSOLE} // important
uses
uServerForm in 'uServerForm.pas' {ServerForm},
uWinService in 'uWinService.pas' {mofidWinServer: TService},
Windows,
System.SysUtils,
WinSvc,
SvcMgr,
Forms,etc;
function RunAsWinService: Boolean;
var
H: THandle;
begin
if FindCmdLineSwitch('install', ['-', '/'], True) then
Exit(True);
if FindCmdLineSwitch('uninstall', ['-', '/'], True) then
Exit(True);
H := GetStdHandle(STD_OUTPUT_HANDLE);
Result := H = 0;
end;
begin
if RunAsWinService then
begin
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TmofidWinServer, mofidWinServer);
SvcMgr.Application.Run;
end
else
begin
Forms.Application.Initialize;
Forms.Application.CreateForm(TServerForm, ServerForm);
Forms.Application.Run;
end;
end.
I didn't find the simple answer which can be used easily and does not require recompilation and allows using one exe as a service and an application. You can install your program as a service with the command line parameter like ā€œā€¦\myapp.exe ā€“sā€ and then check it from the program:
if ParamStr(ParamCount) = '-s' then
You can base the check on checking the session ID of the current process. All services runs with session ID = 0.
function IsServiceProcess: Boolean;
var
LSessionID, LSize: Cardinal;
LToken: THandle;
begin
Result := False;
LSize := 0;
if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, LToken) then
Exit;
try
if not GetTokenInformation(LToken, TokenSessionId, #LSessionID, SizeOf(LSessionID), LSize) then
Exit;
if LSize = 0 then
Exit;
Result := LSessionID = 0;
finally
CloseHandle(LToken);
end;
end;
I actually ended up checking the application.showmainform variable.
The problem with skamradt's isFormBased is that some of this code is called before the main form is created.
I am using a software library called SvCom_NTService from aldyn-software. One of purposes is for errors; either to log them or show a message. I totally agree with #Rob; our code should be better maintained and handle this outside of the functions.
The other intention is for failed database connections and queries; I have different logic in my functions to open queries. If it is a service then it will return nil but continue the process. But if failed queries/connections occur in an application then I would like to display a messaage and halt the application.
Check if your Applicatoin is an instance of TServiceApplication:
IsServiceApp := Application is TServiceApplication;

How to automatically free classes/objects?

What techniques exist to automatically free objects in delphi applications?
Use interfaces instead of objects. They are reference counted and freed automatically when the reference count reaches 0.
I have written a function GC(obj: TObject) (for Garbage Collect) which takes an object and frees it when the execution leaves the current method. It's kind of like a one-line shorthand function for a Try Finally Free block.
Instead of:
procedure Test;
var AQuery: TQuery;
begin
AQuery := TQuery.Create(nil);
try
...
finally
FreeAndNil(AQuery);
end;
end;
I just have:
procedure Test;
var AQuery: TQuery;
begin
AQuery := TQuery.Create(nil);
GC(AQuery);
...
end;
The GC function simply returns an object in the form of an interface.
function GC(obj: TObject): IGarbo;
begin
Result := TGarbo.Create(obj);
end;
Because the TGarbo class descends from TInterfacedObject, when the TGarbo object goes out of scope it will automatically get freed. In the destructor of the TGarbo object, it also frees the object you passed to it in it's constructor (the object you passed in the GC function).
type
IGarbo = interface
['{A6E17957-C233-4433-BCBD-3B53C0C2C596}']
function Obj: TObject;
end;
TGarbo = class(TInterfacedObject, IGarbo)
private
FObj: TObject;
public
constructor Create(AObjectToGC: TObject);
destructor Destroy; override;
function Obj: TObject;
end;
{ TGarbo }
constructor TGarbo.Create(AObjectToGC: TObject);
begin
inherited Create;
FObj := AObjectToGC;
end;
destructor TGarbo.Destroy;
begin
if Assigned(FObj) then
FreeAndNil(FObj);
inherited;
end;
function TGarbo.Obj: TObject;
begin
Result := FObj;
end;
Being stuck in the world of Delphi 7 with no sight of upgrading to a version of Delphi with built-in garbage collection in the near future, I'm addicted to using this short-hand method of easily freeing local temporary objects! :)
Along the lines of interfaces, you can try the Guard function in the JclSysUtils unit, part of the free Jedi Code Library. It allows you to associate an object with a separate interface reference, so when that interface reference is destroyed, the object is destroyed along with it. This can be useful when you don't have the option of modifying the classes you're using to make them support interfaces of their own.
var
G: ISafeGuard;
foo: TStrings;
begin
// Guard returns TObject, so a type-cast is necessary
foo := Guard(TStringList.Create, G) as TStrings;
// Use the object as normal
foo.Add('bar');
end; // foo gets freed automatically as G goes out of scope
There are overloads for objects and GetMem-allocated pointers. There is also IMultiSafeGuard, which can ensure that multiple objects get freed.
If you have a factory function, you might be creating an object, setting some of its properties, and then returning it. If an exception occurs while setting the properties, you'll want to make sure you free the object since you can't return it. One way to do that is like this:
function Slurp(const source: TFileName): TStrings;
begin
Result := TStringList.Create;
try
Result.LoadFromFile(source);
except
Result.Free;
raise;
end;
end;
With Guard, it would become this:
function Slurp(const source: TFileName): TStrings;
var
G: ISafeGuard;
begin
Result := Guard(TStringList.Create, G) as TStrings;
Result.LoadFromFile(source);
G.ReleaseItem;
end;
The ReleaseItem method revokes the ISafeGuard's ownership of the object. If an exception occurs before that happens, then as the stack unwinds and the interface is released, the guard will free the object.
I have to say, I don't like "hiding" the Free of an object. Far better to have the traditional code:
MyObject := TObject.Create;
try
// do stuff
finally
FreeAndNil(MyObject);
end;
No way it can go wrong, works as expected, and people recognise the pattern.
Use the object ownership of components that the VCL provides. As long as you create objects with a non-nil owner you don't need to free them explicitely. See also my answer to this question.
Here is the API for Boehm Garbage Collector DLL for Delphi. The Delphi API is written by Barry Kelly, who works for CodeGear writing the compiler now.
Smart Pointers work really well if you have Delphi 2009.
If you use Delphi for .Net / Delphi Prism you get Garbage Collection which takes care of all the freeing.

Freeing Multiply-referenced Objects

This is another post about me inheriting an Intraweb app that had a 2MB text file of memory leaks as reported by FastMM4, where I've got it down to 115 instances of one class leaking 52 bytes each.
The leaks are from a rather convoluted instantiation and handling of the class. Each instantiation of the class is needed to get the app to work right now. So I'm looking for some ways to either clone the class with some straight-forward cleanup of the clone, or referencing in a different way, or..?
The first instantiation of the class (TCwcBasicAdapter) is as a local variable that gets added to a TObjectList (not Owning) and destroyed with the TObjectList (FCDSAdapters):
procedure TCwcDeclaration.AttachAdapter(DS: TDataSource; const FormName, KeyFN, TitleFN: string; const Multiple: boolean = False;
const AllowAttachment: boolean = False; const AllowComment: boolean = False);
var
Forms : TCwcSessionForms;
Adapter: TCwcCDSAdapter;
KeyField, TitleField: TField;
begin
Forms := GetForms(FormName);
KeyField := DS.DataSet.FindField(KeyFN);
TitleField := DS.DataSet.FindField(TitleFN);
Adapter := TCwcBasicAdapter.Create(DS, KeyField, TitleField, Multiple);
Adapter.AttachDBPersist(Self.DBPersist);
Forms.AttachDataAdapter(Adapter);
Forms.SetAllowAttachments(AllowAttachment);
Forms.SetAllowComments(AllowComment);
end;
procedure TCwcSessionForms.AttachDataAdapter(aCDSAdapter: TCwcCDSAdapter);
var
Index: integer;
begin
if (FCDSAdapters.IndexOf(aCDSAdapter) -1)
then raise Exception.CreateFmt('Duplicate Adapter attempting to be attached on %0:s', [FFormClassName]);
Index := FCDSAdapters.Add(aCDSAdapter);
if (FDefaultAdapterIndex = -1)
then FDefaultAdapterIndex := Index;
end;
The second instantiation of the class is also as a local variable that gets added to a TObjectList (not Owning) and destroyed with the TObjectList (FAdapters):
procedure TCwcCDSMulticastList.InitializeAdapters(const aSessionForms: TCwcSessionForms);
var
i, Count: integer;
Adapter: TCwcCDSAdapter;
TempMulticast: TCwcCDSEventMulticast;
begin
Count := aSessionForms.GetDataAdapterCount;
for i := 0 to Pred(Count) do begin
Adapter := aSessionForms.GetDataAdapter(i);
TempMulticast := FindDataSource(Adapter.DataSource);
if (TempMulticast = nil) then begin
TempMulticast := TCwcCDSEventMulticast.Create(Adapter.DataSource);
try
FMulticastList.Add(TempMulticast);
except
FreeAndNil(TempMulticast);
raise;
end;
end;
TempMulticast.AddObserver(Adapter);
FAdapters.Add(Adapter);
end;
end;
The third instantiation of the class is as part of an observer pattern from the TempMulticast.AddObserver(Adapter) line above. The observer is added to TObjectList FObservers (Owning):
procedure TCwcCDSEventMulticast.AddObserver(const aCDSAdapter: TCwcCDSAdapter);
begin
FObservers.Add(TCwcCDSAdapterObserver.Create(aCDSAdapter));
end;
constructor TCwcCDSAdapterObserver.Create(const aCDSAdapter: TCwcCDSAdapter);
begin
inherited Create;
FOnStateChange := aCDSAdapter.OnStateChangeIntercept;
FOnAfterDelete := aCDSAdapter.AfterDeleteIntercept;
FInvalidateCursors := aCDSAdapter.InvalidateCursors;
end;
The TCwcBasicAdapter is leaked here, not cleaned up when FObservers is destroyed.
The latest thing I've tried is changing FObservers to not Owning, creating a private field for the Adapter, freeing the private field in TCwcCDSAdapterObserver.Destroy, but that causes errors.
Thanks,
Paul Rice
If the lists aren't owners, then they will not free the objects when the list is freed. Just calling Remove on each item won't do it either. You would have to iterate through the list and call Free on each item in the list, and then free the list itself.
If you make the lists owners, then they will do this for you when you free the list.
for i := 0 to FAdapters.Count do Free(FAdapters[i]);
FreeAndNil(FAdapters);
You realize you can dispose of objects by yourself without making their owners auto-dispose of them? I ask this because it feels like you're trying to make the automatics do the job in all cases.

Resources