destructor when stopping idhttp.get ( indy, delphi) - delphi

My application can download one picture from every url in memo1.
It uses idhttp.get and has a skipbutton. After skip it downloads the next picture.
Q1: Do you have code to put into the destructor and what is the code for " terminate" and "waitfor"?
I found this on another website:
destructor thread.destroy;
begin
try
Terminate;
If HTTP.Connected then HTTP.Disconnect;
finally
WaitFor;
FreeAndNil(HTTP);
end;
inherited;
end;
Q2: How do I call the destructor and make it work?
Q3: Do you have hints (especially security concerns) and additional lines of code?
the code of my application:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdHTTP;
type
thread = class
public
Constructor Create; overload;
Destructor Destroy; override;
end;
TForm1 = class(TForm)
IdHTTP1: TIdHTTP;
Memo1: TMemo;
Memo2: TMemo;
Memo3: TMemo;
startbutton: TButton;
skipbutton: TButton;
procedure startbuttonClick(Sender: TObject);
procedure skipbuttonClick(Sender: TObject);
procedure IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
end;
var
Form1: TForm1;
http: tidhttp;
s: boolean;
implementation
{$R *.dfm}
constructor thread.Create;
begin
HTTP := TIdHTTP.Create(nil);
inherited ;
end;
destructor thread.destroy;
begin
try
If HTTP.Connected then HTTP.Disconnect;
finally
FreeAndNil(HTTP);
end;
inherited;
end;
procedure TForm1.startbuttonClick(Sender: TObject);
var
i: integer;
fs : TFileStream ;
begin
for i:= 0 to memo1.lines.count-1 do begin
s:= false;
fs := TFileStream.Create(inttostr(i)+'abc.jpg', fmCreate);
http:= idhttp1;
try
try
HTTP.Get(memo1.lines[i],fs);
memo2.Lines.add(memo1.Lines[i]);
except
on E: Exception do
begin
memo3.lines.add(' ha ha ha not working '+syserrormessage(getlasterror));
end;
end;
finally
fs.free;
end;
end;
end;
procedure TForm1.skipbuttonClick(Sender: TObject);
begin
s:=true;
end;
procedure TForm1.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
begin
application.ProcessMessages;
if s = true then
http.Disconnect;
end;
end.

Since your are using IdHttp from the GUI (= main thread) and Indy is blocking, you have two options: a) use IdAntifreeze in combination with messages (just drop the component on the form), b) use threads.
Do NOT use Application.Processmessages as it will lead to strange side effects.
now to answer your questions:
Q1: the code you found on the internet implemented solution b) so this is not applicable for your current code
Q2: same as Q1
Q3 : here is a version that correctly implements solution a)
This code is still not 100% perfect as it does not implement logic for disabling/enabling the starttransfer and skiptransfer buttons (I leave that as an exercise for you :) ).
unit Unit16;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;
const
WM_TRANSFER = WM_USER + 1;
type
TForm1 = class(TForm)
IdHTTP1: TIdHTTP;
IdAntiFreeze1: TIdAntiFreeze;
Memo1: TMemo;
Btn_start: TButton;
Btn_skip: TButton;
Memo2: TMemo;
procedure IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
procedure Btn_startClick(Sender: TObject);
procedure Btn_skipClick(Sender: TObject);
private
{ Private declarations }
Transferring : Boolean;
UrlIndex : Integer;
procedure NextTransfer(var msg : TMessage); message WM_TRANSFER;
procedure StartTransfer;
procedure DoTransfer;
procedure SkipTransfer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.NextTransfer(var msg: TMessage);
begin
DoTransfer;
end;
procedure TForm1.SkipTransfer;
begin
Transferring := false;
end;
procedure TForm1.StartTransfer;
begin
UrlIndex := 0;
DoTransfer;
end;
procedure TForm1.DoTransfer;
var
Url : String;
Stream : TStringStream;
begin
if UrlIndex < Memo1.Lines.Count then
begin
Url := Memo1.Lines[UrlIndex];
Memo2.Lines.Add(Format('getting data from URL: %s', [Url]));
Inc(UrlIndex);
Transferring := True;
try
Stream := TStringStream.Create;
try
IdHttp1.Get(Url, Stream);
Memo2.Lines.Add(Format('Data: "%s"',[Stream.DataString]));
finally
Stream.Free;
end;
except
on E: Exception do
begin
Memo2.Lines.Add(Format('error during transfer: %s', [E.Message]));
end;
end;
Transferring := False;
PostMessage(Handle, WM_TRANSFER, 0, 0);
end;
end;
procedure TForm1.Btn_startClick(Sender: TObject);
begin
Memo2.Lines.Add('starting transfer');
StartTransfer;
end;
procedure TForm1.Btn_skipClick(Sender: TObject);
begin
Memo2.Lines.Add('skipping current transfer');
SkipTransfer;
end;
procedure TForm1.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
begin
Memo2.Lines.Add('work event');
if not Transferring and (AWorkMode = wmRead) then
try
Memo2.Lines.Add('disconnecting peer');
IdHttp1.Disconnect;
except
end;
end;
end.
DFM file:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 290
ClientWidth = 707
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo1: TMemo
Left = 92
Top = 12
Width = 213
Height = 257
Lines.Strings = (
'http://stackoverflow.com'
'http://www.google.com'
'http://www.hardocp.com'
'')
TabOrder = 0
WordWrap = False
end
object Btn_start: TButton
Left = 8
Top = 128
Width = 75
Height = 25
Caption = 'Btn_start'
TabOrder = 1
OnClick = Btn_startClick
end
object Btn_skip: TButton
Left = 8
Top = 159
Width = 75
Height = 25
Caption = 'Btn_skip'
TabOrder = 2
OnClick = Btn_skipClick
end
object Memo2: TMemo
Left = 320
Top = 12
Width = 373
Height = 257
TabOrder = 3
WordWrap = False
end
object IdHTTP1: TIdHTTP
OnWork = IdHTTP1Work
AllowCookies = True
ProxyParams.BasicAuthentication = False
ProxyParams.ProxyPort = 0
Request.ContentLength = -1
Request.ContentRangeEnd = -1
Request.ContentRangeStart = -1
Request.ContentRangeInstanceLength = -1
Request.Accept = 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8'
Request.BasicAuthentication = False
Request.UserAgent = 'Mozilla/3.0 (compatible; Indy Library)'
Request.Ranges.Units = 'bytes'
Request.Ranges = <>
HTTPOptions = [hoForceEncodeParams]
Left = 24
Top = 16
end
object IdAntiFreeze1: TIdAntiFreeze
Left = 16
Top = 72
end
end

Related

Delphi FMX TTreeView Argument out of range exception

Using Delphi 10.4.
I am hoping someone can explain what I am doing wrong with my FMX TTreeView that is causing an EArgumentOutOfRangeException. I am trying to create a custom TTreeViewItem class that allows me to associate some data with each node, as well as provide an in-place editor to allowing changing the node text.
The code below is a stripped down version of what I am doing. The FMX form has a TTreeview and two buttons on it, with the form's Onshow set to FormShow and the buttons set to the two button events.
The TVLinkTreeViewItem is my custom TTreeViewItem where I add a background and edit component for my in-place editor, which is displayed when a node is double clicked.
When you run the code as is, the program will throw the exception when the logic gets to the TreeView1.EndUpdate call at the end of the FormShow routine. The exception is thrown in FMX.Controls in the TControl.EndUpdate procedure.
If you comment out the ExpandAll call, the exception is not thrown, but if you mess with the expanding and collapsing of the nodes and resizing of the form, sooner or later the exception gets thrown. I left the ExpandAll line in the code below, as I assume the exception is being caused by the same error.
From what I can tell, the problem appears to be how I am setting up the fBackground and fEditor. If I don't call the AddObject routine and not set the Parent properties, I get no exception.
So can anybody tell me what I am doing wrong? Or is there a better way to do an in-place editor for the FMX TTreeViewItems component?
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.TreeView, FMX.Layouts, FMX.Controls.Presentation,
FMX.MultiView, FMX.Edit, FMX.Objects, FMX.StdCtrls;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Button1: TButton;
Button2: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
type
TVLinkTreeViewItem = class(TTreeViewItem)
private
fData: string;
fEditor: TEdit;
fBackground: TRectangle;
procedure TreeViewItem1DblClick(Sender: TObject);
procedure EditorExit(Sender: TObject);
procedure EditorKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
public
property Editor: TEdit read fEditor write fEditor;
property Data: string read fData write fData;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.ExpandAll;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TreeView1.CollapseAll;
end;
procedure TForm1.FormShow(Sender: TObject);
var
I, c, r, s: Integer;
vNode1,
vNode2,
vNode3,
vNode4: TVLinkTreeViewItem;
begin
TreeView1.BeginUpdate;
TreeView1.Clear;
for I := 0 to 4 do
begin
vNode1 := TVLinkTreeViewItem.Create(TreeView1);
vNode1.Text := 'Level 1 - '+ IntToStr(I);
TreeView1.AddObject(vNode1);
for c := 0 to 4 do
begin
vNode2 := TVLinkTreeViewItem.Create(vNode1);
vNode2.Text := 'Level 2 - '+ IntToStr(c);
vNode1.AddObject(vNode2);
for r := 0 to 4 do
begin
vNode3 := TVLinkTreeViewItem.Create(vNode2);
vNode3.Text := 'Level 3 - '+ IntToStr(r);
vNode2.AddObject(vNode3);
// for s := 0 to 4 do
// begin
// vNode4 := TVLinkTreeViewItem.Create(vNode3);
// vNode4.Text := 'Level 4 - '+ IntToStr(s);
// vNode3.AddObject(vNode4);
// end;
end;
end;
end;
//ExpandAll works when no parent is set for fBackGround and fEditor is not set in "TVLinkTreeViewItem.Create" below"
//If the Parents are set below, ExpandAll/EndUpdate causes "Augument out of range" exception.
TreeView1.ExpandAll;
treeView1.EndUpdate;
end;
{ TVLinkTreeViewItem }
constructor TVLinkTreeViewItem.Create(AOwner: TComponent);
begin
inherited;
fData := '';
fBackground := TRectangle.Create(AOwner);
//When ExpandAll is not called in FormShow,
// Calling "AddObject" or setting parent, as shown below, make all the code work,
// but will get intermident "Augument out of range" exceptions when resizing form,
// or when expanding or collapsing nodes using the buttons.
self.AddObject(fBackGround);
//fBackGround.Parent := self;
fBackGround.Visible := false;
fEditor := TEdit.Create(AOwner);
fBackGround.AddObject(fEditor);
//fEditor.Parent := fBackGround;
fEditor.Visible := false;
fEditor.Align := TAlignLayout.Client;
fEditor.OnKeyDown := EditorKeyUp;
self.OnDblClick := TreeViewItem1DblClick;
fEditor.OnExit := EditorExit;
end;
destructor TVLinkTreeViewItem.Destroy;
begin
inherited;
end;
procedure TVLinkTreeViewItem.TreeViewItem1DblClick(Sender: TObject);
begin
fBackGround.Visible := true;
fBackGround.Width := self.Width - 20;
fBackGround.Height := self.Height;
fBackGround.Position.X := 20;
fEditor.Enabled := true;
fEditor.Visible := true;
fEditor.Opacity := 1;
fBackGround.BringToFront;
fEditor.BringToFront;
fEditor.Text := Text;
fEditor.SetFocus;
fEditor.SelectAll;
end;
procedure TVLinkTreeViewItem.EditorKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
inherited;
if Key = vkReturn then
begin
Text := fEditor.Text;
fBackGround.Visible := false;
fEditor.Enabled := false;
end
else if Key in [vkEscape, vkCancel, vkTab, vkHardwareBack] then
begin
fBackGround.Visible := false;
fEditor.Enabled := false;
end;
end;
procedure TVLinkTreeViewItem.EditorExit(Sender: TObject);
begin
fBackGround.Visible := false;
fEditor.Enabled := false;
fEditor.Visible := false;
end;
end.
Here's the fmx content:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnShow = FormShow
DesignerMasterStyle = 0
object TreeView1: TTreeView
Align = Left
Size.Width = 269.000000000000000000
Size.Height = 480.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
Viewport.Width = 265.000000000000000000
Viewport.Height = 476.000000000000000000
end
object Button1: TButton
Position.X = 356.000000000000000000
Position.Y = 68.000000000000000000
TabOrder = 2
Text = 'Expand'
OnClick = Button1Click
end
object Button2: TButton
Position.X = 354.000000000000000000
Position.Y = 102.000000000000000000
TabOrder = 1
Text = 'Collapse'
OnClick = Button2Click
end
end

How to Implement Text Box with Gray Text Hint?

In many website, I can see text box with hint in gray text. The hint will tell the user what should be inputted and whenever user tries to input anything, the hint will disappear.
Below is a sample of it:
I just wonder how to implement such a feature in Windows desktop application. I am using Delphi XE3 and it is possible to implement such a feature with TTextBox? Or is there such a VCL component available?
Here is an implementation that works for Windows XP (and also Windows 7 and 8.1, haven't tested it on Windows 10). Beware: I mostly use it in Windows XP and 8.1 and with Delphi 2007 and XE2. There may be bugs that I haven't seen yet.
It's also probably not the most elegant solution but it works and is easy to understand.
Prerequisites: Delphi Custom Containers Pack
Just save the following to u_dzCueEdit.dfm and u_dzCueEdit.pas, create a runtime package with it, create a corresponding design time package with a Register procedure and install it.
dfm file:
object dzCueEdit: TdzCueEdit
Left = 0
Top = 0
Width = 258
Height = 21
TabOrder = 0
OnResize = BoxResize
object ed_Cue: TEdit
Left = 1
Top = 1
Width = 256
Height = 19
Align = alClient
TabOrder = 0
OnChange = ed_CueChange
OnClick = ed_CueClick
OnEnter = ed_CueEnter
OnExit = ed_CueExit
end
object p_Cue: TPanel
Left = 64
Top = 0
Width = 242
Height = 21
BevelOuter = bvNone
Color = clMoneyGreen
ParentBackground = False
TabOrder = 1
OnClick = p_CueClick
OnEnter = p_CueEnter
object l_Cue: TLabel
AlignWithMargins = True
Left = 88
Top = 0
Width = 93
Height = 13
Margins.Left = 1
Margins.Top = 1
Margins.Right = 1
Margins.Bottom = 1
Caption = 'Cue text goes here'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGray
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
OnClick = l_CueClick
end
end
end
pas file:
unit c_dzCueEdit;
interface
uses
Windows,
Messages,
SysUtils,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls,
ccBoxes;
type
TdzCueEdit = class(TBox)
p_Cue: TPanel;
l_Cue: TLabel;
procedure ed_CueClick(Sender: TObject);
procedure l_CueClick(Sender: TObject);
published
ed_Cue: TEdit;
procedure p_CueEnter(Sender: TObject);
procedure p_CueClick(Sender: TObject);
procedure ed_CueChange(Sender: TObject);
procedure ed_CueEnter(Sender: TObject);
procedure ed_CueExit(Sender: TObject);
procedure BoxResize(Sender: TObject);
private
procedure CheckCueBanner;
function GetCue: string;
function GetText: string;
procedure SetCue(const _Value: string);
procedure SetText(const _Value: string);
protected
public
constructor Create(_Owner: TComponent); override;
published
property Text: string read GetText write SetText;
property Cue: string read GetCue write SetCue;
end;
implementation
{$R *.DFM}
{ TdzCueEdit }
constructor TdzCueEdit.Create(_Owner: TComponent);
begin
inherited;
BevelOuter := bvNone;
l_Cue.Align := alClient;
p_Cue.Color := ed_Cue.Color;
end;
procedure TdzCueEdit.BoxResize(Sender: TObject);
var
Rect: TRect;
begin
Rect := ed_Cue.ClientRect;
// p_Cue.SetBounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
p_Cue.SetBounds(Rect.Left + 4, Rect.Top + 3, Rect.Right - Rect.Left - 2, Rect.Bottom - Rect.Top - 2);
end;
procedure TdzCueEdit.CheckCueBanner;
begin
if ed_Cue.Text <> '' then
p_Cue.Visible := False
else begin
// if ed_Cue.Focused then
// p_Cue.Visible := False
// else
p_Cue.Visible := True;
end;
end;
procedure TdzCueEdit.ed_CueChange(Sender: TObject);
begin
CheckCueBanner;
end;
procedure TdzCueEdit.ed_CueClick(Sender: TObject);
begin
CheckCueBanner;
end;
procedure TdzCueEdit.ed_CueEnter(Sender: TObject);
begin
CheckCueBanner;
end;
procedure TdzCueEdit.ed_CueExit(Sender: TObject);
begin
CheckCueBanner;
end;
function TdzCueEdit.GetCue: string;
begin
Result := l_Cue.Caption;
end;
procedure TdzCueEdit.SetCue(const _Value: string);
begin
l_Cue.Caption := _Value;
end;
function TdzCueEdit.GetText: string;
begin
Result := ed_Cue.Text;
end;
procedure TdzCueEdit.l_CueClick(Sender: TObject);
begin
ed_Cue.SetFocus;
CheckCueBanner;
end;
procedure TdzCueEdit.SetText(const _Value: string);
begin
ed_Cue.Text := _Value;
end;
procedure TdzCueEdit.p_CueClick(Sender: TObject);
begin
ed_Cue.SetFocus;
CheckCueBanner;
end;
procedure TdzCueEdit.p_CueEnter(Sender: TObject);
begin
ed_Cue.SetFocus;
CheckCueBanner;
end;
end.

How can free Interface implemented class?

I have a little problem. As the title says I want to release an object whose class implements an interface, however I get an error "invalid pointer operation".
My Interface:
Interface
Type
// An interface definition
IMessageEvents = Interface(IInterface)
['{BD27EFC6-CC9A-437A-A8B8-16F722518836}']
Procedure messageReceived(messageData: String);
End;
Implementation
My Class:
Type
TChatManager = Class(TInterfacedObject, IMessageEvents)
Private
Protected
Procedure messageReceived(messageData: String); Overload;
Public
Constructor Create; Overload;
Destructor Destroy; Override;
Procedure connect;
Procedure disconnect;
End;
Implementation
Constructor TChatManager.Create;
Begin
{ ....... }
End;
Procedure TChatManager.connect;
Begin
{ ....... }
End;
Procedure TChatManager.disconnect;
Begin
{ ....... }
End;
Procedure TChatManager.messageReceived(messageData: String);
Begin
{ ....... }
End;
Destructor TChatManager.Destroy;
Begin
Inherited Destroy;
End;
My Code:
self.chatMng := TChatManager.Create;
self.chatMng.Free;
Can anyone tell me what I'm doing wrong? Thanks in advance.
It would appear that chatMng is of type TChatManager. That can be deduced by the fact that you assign TChatManager.Create to it, and call Free on it.
However, TChatManager derives from TInterfacedObject. That means that its lifetime is controlled by the references that are taken to its interfaces. When the final reference is released, the object is destroyed.
The rule of thumb is that if you derive from TInterfacedObject then you must never take a reference to the object other than through an interface variable.
Steps to correct your code:
Change chatMng to be of type IMessageEvents.
Remove the call to chatMng.Free which the compiler will object to in any case.
He must not be showing us all the code...because what he shows should not cause a GPF...you can create a TInterfacedObject and free it...if you don't get a reference to it...but If you get a Reference you are no longer in charge of freeing it...
Here's the Interface
unit Unit3;
Interface
uses
Classes, SysUtils;
Type
// An interface definition
IMessageEvents = Interface(IInterface)
['{BD27EFC6-CC9A-437A-A8B8-16F722518836}']
Procedure messageReceived(messageData: String);
End;
Type
TChatManager = Class(TInterfacedObject, IMessageEvents)
Private
FStrings: TStrings;
Protected
Procedure messageReceived(messageData: String); Overload;
procedure UpdateStatus(aString: string);
Public
Constructor Create(aStrings: TStrings);
Destructor Destroy; Override;
Procedure connect;
Procedure disconnect;
End;
Implementation
Constructor TChatManager.Create(aStrings: TStrings);
Begin
{ ....... }
FStrings := aStrings;
UpdateStatus('Created');
Connect;
End;
Procedure TChatManager.connect;
Begin
{ ....... }
UpdateStatus('Connected');
End;
Procedure TChatManager.disconnect;
Begin
{ ....... }
UpdateStatus('DisConnected');
End;
Procedure TChatManager.messageReceived(messageData: String);
Begin
{ ....... }
UpdateStatus('Message Received');
UpdateStatus(messageData);
End;
procedure TChatManager.UpdateStatus(aString: string);
begin
FStrings.Add(aString);
FStrings.Add('RefCount: '+ IntToStr(Self.RefCount));
end;
Destructor TChatManager.Destroy;
Begin
Disconnect;
UpdateStatus('Destroyed');
Inherited Destroy;
End;
end.
Here's the form
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, unit3, StdCtrls;
type
TForm2 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
chatMng: TChatManager;
iChatMng: IMessageEvents;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
type
THackManager= class(TChatManager);
procedure TForm2.Button1Click(Sender: TObject);
begin
chatMng := TChatManager.Create(Memo1.Lines);
THackManager(ChatMng).messageReceived('Hello World from Button1');
chatMng.Free;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
iChatMng := TChatManager.Create(Memo1.Lines);
iChatMng.messageReceived('Hello World from Button2');
iChatMng := nil;
end;
procedure TForm2.Button3Click(Sender: TObject);
begin
ChatMng := TChatManager.Create(Memo1.Lines);
(ChatMng as IMessageEvents).messageReceived('Hello World from Button3');
//you can't call ChatMng...it's gone bye bye...
//ChatMng.Free; //this will cause a GPF if you call free
end;
procedure TForm2.Button4Click(Sender: TObject);
var
a_IChatMng: IMessageEvents;
begin
ChatMng := TChatManager.Create(Memo1.Lines);
a_IChatMng := chatMng;
(ChatMng as IMessageEvents).messageReceived('Hello World from Button4');
a_IChatMng.messageReceived('Hello World again from Button4');
//ChatMng.Free; //this will cause a GPF if you call free
end;
end.
Here's the dfm
object Form2: TForm2
Left = 326
Top = 94
Caption = 'Form2'
ClientHeight = 292
ClientWidth = 581
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 40
Top = 200
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object Memo1: TMemo
Left = 40
Top = 32
Width = 411
Height = 129
TabOrder = 1
end
object Button2: TButton
Left = 160
Top = 200
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 2
OnClick = Button2Click
end
object Button3: TButton
Left = 272
Top = 200
Width = 75
Height = 25
Caption = 'Button3'
TabOrder = 3
OnClick = Button3Click
end
object Button4: TButton
Left = 376
Top = 200
Width = 75
Height = 25
Caption = 'Button4'
TabOrder = 4
OnClick = Button4Click
end
end

Delphi XE2 Indy 10 TIdCmdTCPServer freezing application

I'm just starting to learn how to use the Indy 10 components in Delphi XE2. I started with a project that will use the command sockets (TIdCmdTCPServer and TIdCmdTCPClient). I've got everything set up and the client connects to the server, but after the client connects, any command the server sends to the client just freezes the server app, until it eventually crashes and closes (after a deep freeze).
Project Setup
The setup is very simple; there's a small server app and a small client app, each with its corresponding Indy command tcp socket component. There's only one command handler on the client.
Server App
On the server, I have a very simple wrapper for the context type TCli = class(TIdServerContext) which only contains one public property (the inheritance is practically a requirement of Indy).
Client App
The client on the other hand works just fine. It receives the command from the server and does its thing. The client has a timer which auto-connects if it's not already connected. It's currently set to try to connect after 1 second of the app starting, and keep attempting every 10 seconds if not connected already.
Problem Details
I am able to send one or two commands from the server to the client successfully (client responds properly), but the server freezes a few seconds after sending the command. I have event handlers for OnConnect, OnDisconnect, OnContextCreated, and OnException on the server, which all they do really is either post a log or handle connect/disconnect objects in a list view.
Screen Shot
Finally when the client app is gracefully closed, the server also gracefully snaps out of its frozen state. However if the client is forcefully closed, then the server is also forcefully closed. That's the pattern I'm seeing. It posts to a log on events with PostLog(const S: String) which simply appends short messages to a TMemo.
I've done two projects and had the problem on both. I've prepared a sample project...
Server Code (uServer.pas and uServer.dfm)
unit uServer;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdBaseComponent, IdComponent,
IdCustomTCPServer, IdTCPServer, IdCmdTCPServer, Vcl.StdCtrls, Vcl.Buttons,
Vcl.ComCtrls;
type
TCli = class(TIdServerContext)
private
function GetIP: String;
public
property IP: String read GetIP;
procedure DoTest;
end;
TForm3 = class(TForm)
Svr: TIdCmdTCPServer;
Lst: TListView;
Log: TMemo;
cmdDoCmdTest: TBitBtn;
procedure cmdDoCmdTestClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure SvrConnect(AContext: TIdContext);
procedure SvrContextCreated(AContext: TIdContext);
procedure SvrDisconnect(AContext: TIdContext);
procedure SvrException(AContext: TIdContext; AException: Exception);
private
public
procedure PostLog(const S: String);
function NewContext(AContext: TIdContext): TCli;
procedure DelContext(AContext: TIdContext);
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
{ TCli }
procedure TCli.DoTest;
begin
Connection.SendCmd('DoCmdTest');
end;
function TCli.GetIP: String;
begin
Result:= Binding.PeerIP;
end;
{ TForm3 }
procedure TForm3.PostLog(const S: String);
begin
Log.Lines.Append(S);
end;
procedure TForm3.SvrConnect(AContext: TIdContext);
var
C: TCli;
begin
C:= TCli(AContext);
PostLog(C.IP+': Connected');
end;
procedure TForm3.SvrContextCreated(AContext: TIdContext);
var
C: TCli;
begin
C:= NewContext(AContext);
PostLog(C.IP+': Context Created');
end;
procedure TForm3.SvrDisconnect(AContext: TIdContext);
var
C: TCli;
begin
C:= TCli(AContext);
PostLog(C.IP+': Disconnected');
DelContext(AContext);
end;
procedure TForm3.SvrException(AContext: TIdContext; AException: Exception);
var
C: TCli;
begin
C:= TCli(AContext);
PostLog(C.IP+': Exception: '+AException.Message);
end;
procedure TForm3.cmdDoCmdTestClick(Sender: TObject);
var
X: Integer;
C: TCli;
I: TListItem;
begin
for X := 0 to Lst.Items.Count - 1 do begin
I:= Lst.Items[X];
C:= TCli(I.Data);
C.DoTest;
end;
end;
procedure TForm3.DelContext(AContext: TIdContext);
var
I: TListItem;
X: Integer;
begin
for X := 0 to Lst.Items.Count - 1 do begin
I:= Lst.Items[X];
if I.Data = TCli(AContext) then begin
Lst.Items.Delete(X);
Break;
end;
end;
end;
procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Svr.Active:= False;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
Svr.Active:= True;
end;
function TForm3.NewContext(AContext: TIdContext): TCli;
var
I: TListItem;
begin
Result:= TCli(AContext);
I:= Lst.Items.Add;
I.Caption:= Result.IP;
I.Data:= Result;
end;
end.
//////// DFM ////////
object Form3: TForm3
Left = 315
Top = 113
Caption = 'Indy 10 Command TCP Server'
ClientHeight = 308
ClientWidth = 529
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
DesignSize = (
529
308)
PixelsPerInch = 96
TextHeight = 13
object Lst: TListView
Left = 336
Top = 8
Width = 185
Height = 292
Anchors = [akTop, akRight, akBottom]
Columns = <
item
AutoSize = True
end>
TabOrder = 0
ViewStyle = vsReport
ExplicitLeft = 333
ExplicitHeight = 288
end
object Log: TMemo
Left = 8
Top = 56
Width = 316
Height = 244
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = [fsBold]
ParentFont = False
ScrollBars = ssVertical
TabOrder = 1
end
object cmdDoCmdTest: TBitBtn
Left = 8
Top = 8
Width = 217
Height = 42
Caption = 'Send Test Command'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Tahoma'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 2
OnClick = cmdDoCmdTestClick
end
object Svr: TIdCmdTCPServer
Bindings = <>
DefaultPort = 8664
MaxConnections = 100
OnContextCreated = SvrContextCreated
OnConnect = SvrConnect
OnDisconnect = SvrDisconnect
OnException = SvrException
CommandHandlers = <>
ExceptionReply.Code = '500'
ExceptionReply.Text.Strings = (
'Unknown Internal Error')
Greeting.Code = '200'
Greeting.Text.Strings = (
'Welcome')
HelpReply.Code = '100'
HelpReply.Text.Strings = (
'Help follows')
MaxConnectionReply.Code = '300'
MaxConnectionReply.Text.Strings = (
'Too many connections. Try again later.')
ReplyTexts = <>
ReplyUnknownCommand.Code = '400'
ReplyUnknownCommand.Text.Strings = (
'Unknown Command')
Left = 288
Top = 8
end
end
Client Code (uClient.pas and uClient.dfm)
unit uClient;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.ExtCtrls,
IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdCmdTCPClient, IdCommandHandlers, Vcl.StdCtrls;
const // --- Change accordingly ---
TMR_INT = 10000; //how often to check for connection
SVR_IP = '192.168.4.100'; //Server IP Address
SVR_PORT = 8664; //Server Port
type
TForm4 = class(TForm)
Tmr: TTimer;
Cli: TIdCmdTCPClient;
Log: TMemo;
procedure CliCommandHandlers0Command(ASender: TIdCommand);
procedure TmrTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CliConnected(Sender: TObject);
procedure CliDisconnected(Sender: TObject);
private
procedure PostLog(const S: String);
public
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
procedure TForm4.PostLog(const S: String);
begin
Log.Lines.Append(S);
end;
procedure TForm4.CliCommandHandlers0Command(ASender: TIdCommand);
begin
PostLog('Received command successfully');
end;
procedure TForm4.CliConnected(Sender: TObject);
begin
PostLog('Connected to Server');
end;
procedure TForm4.CliDisconnected(Sender: TObject);
begin
PostLog('Disconnected from Server');
end;
procedure TForm4.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Cli.Disconnect;
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
Tmr.Enabled:= True;
end;
procedure TForm4.TmrTimer(Sender: TObject);
begin
if Tmr.Interval <> TMR_INT then
Tmr.Interval:= TMR_INT;
if not Cli.Connected then begin
try
Cli.Host:= SVR_IP;
Cli.Port:= SVR_PORT;
Cli.Connect;
except
on e: exception do begin
Cli.Disconnect;
end;
end;
end;
end;
end.
//////// DFM ////////
object Form4: TForm4
Left = 331
Top = 570
Caption = 'Indy 10 Command TCP Client'
ClientHeight = 317
ClientWidth = 305
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnCreate = FormCreate
DesignSize = (
305
317)
PixelsPerInch = 96
TextHeight = 13
object Log: TMemo
Left = 8
Top = 56
Width = 289
Height = 253
Anchors = [akLeft, akTop, akRight, akBottom]
ScrollBars = ssVertical
TabOrder = 0
ExplicitWidth = 221
ExplicitHeight = 245
end
object Tmr: TTimer
Enabled = False
OnTimer = TmrTimer
Left = 56
Top = 8
end
object Cli: TIdCmdTCPClient
OnDisconnected = CliDisconnected
OnConnected = CliConnected
ConnectTimeout = 0
Host = '192.168.4.100'
IPVersion = Id_IPv4
Port = 8664
ReadTimeout = -1
CommandHandlers = <
item
CmdDelimiter = ' '
Command = 'DoCmdTest'
Disconnect = False
Name = 'cmdDoCmdTest'
NormalReply.Code = '200'
ParamDelimiter = ' '
ParseParams = True
Tag = 0
OnCommand = CliCommandHandlers0Command
end>
ExceptionReply.Code = '500'
ExceptionReply.Text.Strings = (
'Unknown Internal Error')
Left = 16
Top = 8
end
end
The reason your server is freezing up is because you are deadlocking your server code.
For each client that connects to TIdCmdTCPServer, a worker thread is created that continuously reads inbound commands from that connection so it can trigger TIdCommandHandler.OnCommand events in the TIdCmdTCPServer.CommandHandlers collection. TCli.DoTest() calls TIdTCPConnection.SendCmd() to send a command to a client and read its response. You are calling TCli.DoTest() (and thus SendCmd()) in the context of the main thread, so you have two separate thread contexts trying to read from the same connection at the same time, causing a race condition. The worker thread running inside of TIdCmdTCPServer is likely reading portions of (if not all of) the data that SendCmd() is expecting and will never see, so SendCmd() does not exit properly, blocking the main message loop from being able to process new messages ever again, hense the freeze.
Placing a TIdAntiFreeze in the server app can help avoid the freezing, by allowing the main thread context to continue processing messages while SendCmd() is deadlocked. But that is not a true solution. To really fix this, you need to redesign your server app. For starters, do not use TIdCmdTCPServer with TIdCmdTCPClient, as they are not designed to be used together. If your server is going to send commands to the client, and the client is never sending commands to the server, then use a plain TIdTCPServer instead of TIdCmdTCPServer. But even if you do not make that change, you still have other problems with your current server code. Your server event handlers are not performing thread-safe operations, and you need to move the call to TCli.DoTest() out of the main thread context.
Try this code:
uServer.pas:
unit uServer;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, System.SyncObjs,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdBaseComponent, IdComponent,
IdTCPConnection, IdCustomTCPServer, IdTCPServer, IdThreadSafe, IdYarn, Vcl.StdCtrls, Vcl.Buttons,
Vcl.ComCtrls;
type
TCli = class(TIdServerContext)
private
fCmdQueue: TIdThreadSafeStringList;
fCmdEvent: TEvent;
function GetIP: String;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
destructor Destroy; override;
procedure PostCmd(const S: String);
property CmdQueue: TIdThreadSafeStringList read fCmdQueue;
property CmdEvent: TEvent read fCmdEvent;
property IP: String read GetIP;
end;
TForm3 = class(TForm)
Svr: TIdTCPServer;
Lst: TListView;
Log: TMemo;
cmdDoCmdTest: TBitBtn;
procedure cmdDoCmdTestClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure SvrConnect(AContext: TIdContext);
procedure SvrDisconnect(AContext: TIdContext);
procedure SvrExecute(AContext: TIdContext);
procedure SvrException(AContext: TIdContext; AException: Exception);
public
procedure NewContext(AContext: TCli);
procedure DelContext(AContext: TCli);
end;
var
Form3: TForm3;
implementation
uses
IdSync;
{$R *.dfm}
{ TLog }
type
TLog = class(TIdNotify)
protected
fMsg: String;
procedure DoNotify; override;
public
class procedure PostLog(const S: String);
end;
procedure TLog.DoNotify;
begin
Form3.Log.Lines.Append(fMsg);
end;
class procedure TLog.PostLog(const S: String);
begin
with Create do begin
fMsg := S;
Notify;
end;
end;
{ TCliList }
type
TCliList = class(TIdSync)
protected
fCtx: TCli;
fAdding: Boolean;
procedure DoSynchronize; override;
public
class procedure AddContext(AContext: TCli);
class procedure DeleteContext(AContext: TCli);
end;
procedure TCliList.DoSynchronize;
begin
if fAdding then
Form3.NewContext(fCtx)
else
Form3.DelContext(fCtx);
end;
class procedure TCliList.AddContext(AContext: TCli);
begin
with Create do try
fCtx := AContext;
fAdding := True;
Synchronize;
finally
Free;
end;
end;
class procedure TCliList.DeleteContext(AContext: TCli);
begin
with Create do try
fCtx := AContext;
fAdding := False;
Synchronize;
finally
Free;
end;
end;
{ TCli }
constructor TCli.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
fCmdQueue := TIdThreadSafeStringList.Create;
fCmdEvent := TEvent.Create(nil, True, False, '');
end;
destructor TCli.Destroy;
begin
fCmdQueue.Free;
fCmdEvent.Free;
inherited Destroy;
end;
procedure TCli.PostCmd;
var
L: TStringList;
begin
L := fCmdQueue.Lock;
try
L.Add('DoCmdTest');
fCmdEvent.SetEvent;
finally
fCmdQueue.Unlock;
end;
end;
function TCli.GetIP: String;
begin
Result := Binding.PeerIP;
end;
{ TForm3 }
procedure TForm3.SvrConnect(AContext: TIdContext);
var
C: TCli;
begin
C := TCli(AContext);
TCliList.AddContext(C);
TLog.PostLog(C.IP + ': Connected');
end;
procedure TForm3.SvrDisconnect(AContext: TIdContext);
var
C: TCli;
begin
C := TCli(AContext);
TCliList.DeleteContext(C);
TLog.PostLog(C.IP + ': Disconnected');
end;
procedure TForm3.SvrExecute(AContext: TIdContext);
var
C: TCli;
L, Q: TStringList;
X: Integer;
begin
C := TCli(AContext);
if C.CmdEvent.WaitFor(500) <> wrSignaled then Exit;
Q := TStringList.Create;
try
L := C.CmdQueue.Lock;
try
Q.Assign(L);
L.Clear;
C.CmdEvent.ResetEvent;
finally
C.CmdQueue.Unlock;
end;
for X := 0 to Q.Count - 1 do begin
AContext.Connection.SendCmd(Q.Strings[X]);
end;
finally
Q.Free;
end;
end;
procedure TForm3.SvrException(AContext: TIdContext; AException: Exception);
var
C: TCli;
begin
C := TCli(AContext);
TLog.PostLog(C.IP + ': Exception: ' + AException.Message);
end;
procedure TForm3.cmdDoCmdTestClick(Sender: TObject);
var
X: Integer;
L: TList;
begin
L := Svr.Contexts.LockList;
try
for X := 0 to L.Count - 1 do begin
TCli(L.Items[X]).PostCmd;
end;
finally
Svr.Contexts.UnlockList;
end;
end;
procedure TForm3.DelContext(AContext: TCli);
var
I: TListItem;
begin
I := Lst.FindData(0, AContext, true, false);
if I <> nil then I.Delete;
end;
procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Svr.Active := False;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
Svr.ContextClass := TCli;
Svr.Active := True;
end;
procedure TForm3.NewContext(AContext: TCli);
var
I: TListItem;
begin
I := Lst.Items.Add;
I.Caption := AContext.IP;
I.Data := AContext;
end;
end.
uServer.dfm:
object Form3: TForm3
Left = 315
Top = 113
Caption = 'Indy 10 Command TCP Server'
ClientHeight = 308
ClientWidth = 529
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
DesignSize = (
529
308)
PixelsPerInch = 96
TextHeight = 13
object Lst: TListView
Left = 336
Top = 8
Width = 185
Height = 292
Anchors = [akTop, akRight, akBottom]
Columns = <
item
AutoSize = True
end>
TabOrder = 0
ViewStyle = vsReport
ExplicitLeft = 333
ExplicitHeight = 288
end
object Log: TMemo
Left = 8
Top = 56
Width = 316
Height = 244
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = [fsBold]
ParentFont = False
ScrollBars = ssVertical
TabOrder = 1
end
object cmdDoCmdTest: TBitBtn
Left = 8
Top = 8
Width = 217
Height = 42
Caption = 'Send Test Command'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Tahoma'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 2
OnClick = cmdDoCmdTestClick
end
object Svr: TIdTCPServer
Bindings = <>
DefaultPort = 8664
MaxConnections = 100
OnConnect = SvrConnect
OnDisconnect = SvrDisconnect
OnExecute = SvrExecute
OnException = SvrException
Left = 288
Top = 8
end
end
uClient.pas:
unit uClient;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.ExtCtrls,
IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdCmdTCPClient, IdCommandHandlers, Vcl.StdCtrls;
const // --- Change accordingly ---
TMR_INT = 10000; //how often to check for connection
SVR_IP = '192.168.4.100'; //Server IP Address
SVR_PORT = 8664; //Server Port
type
TForm4 = class(TForm)
Tmr: TTimer;
Cli: TIdCmdTCPClient;
Log: TMemo;
procedure CliCommandHandlers0Command(ASender: TIdCommand);
procedure TmrTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CliConnected(Sender: TObject);
procedure CliDisconnected(Sender: TObject);
private
procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
procedure PostLog(const S: String);
procedure PostReconnect;
public
end;
var
Form4: TForm4;
implementation
uses
IdSync;
{$R *.dfm}
{ TLog }
type
TLog = class(TIdNotify)
protected
fMsg: String;
procedure DoNotify; override;
public
class procedure PostLog(const S: String);
end;
procedure TLog.DoNotify;
begin
Form4.Log.Lines.Append(fMsg);
end;
class procedure TLog.PostLog(const S: String);
begin
with Create do begin
fMsg := S;
Notify;
end;
end;
{ TForm4 }
const
WM_START_RECONNECT_TIMER = WM_USER + 100;
procedure TForm4.CliCommandHandlers0Command(ASender: TIdCommand);
begin
TLog.PostLog('Received command successfully');
end;
procedure TForm4.CliConnected(Sender: TObject);
begin
TLog.PostLog('Connected to Server');
end;
procedure TForm4.CliDisconnected(Sender: TObject);
begin
TLog.PostLog('Disconnected from Server');
PostReconnect;
end;
procedure TForm4.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Tmr.Enabled := False;
Application.OnMessage := nil;
Cli.Disconnect;
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
Tmr.Enabled := True;
end;
procedure TForm4.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
if Msg.message = WM_START_RECONNECT_TIMER then begin
Handled := True;
Tmr.Interval := TMR_INT;
Tmr.Enabled := True;
end;
end;
procedure TForm4.TmrTimer(Sender: TObject);
begin
Tmr.Enabled := False;
Cli.Disconnect;
try
Cli.Host := SVR_IP;
Cli.Port := SVR_PORT;
Cli.Connect;
except
PostReconnect;
end;
end;
procedure TForm4.PostReconnect;
begin
PostMessage(Application.Handle, WM_START_RECONNECT_TIMER, 0, 0);
end;
end.
uClient.dfm:
object Form4: TForm4
Left = 331
Top = 570
Caption = 'Indy 10 Command TCP Client'
ClientHeight = 317
ClientWidth = 305
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnCreate = FormCreate
DesignSize = (
305
317)
PixelsPerInch = 96
TextHeight = 13
object Log: TMemo
Left = 8
Top = 56
Width = 289
Height = 253
Anchors = [akLeft, akTop, akRight, akBottom]
ScrollBars = ssVertical
TabOrder = 0
ExplicitWidth = 221
ExplicitHeight = 245
end
object Tmr: TTimer
Enabled = False
OnTimer = TmrTimer
Left = 56
Top = 8
end
object Cli: TIdCmdTCPClient
OnDisconnected = CliDisconnected
OnConnected = CliConnected
ConnectTimeout = 0
Host = '192.168.4.100'
IPVersion = Id_IPv4
Port = 8664
ReadTimeout = -1
CommandHandlers = <
item
CmdDelimiter = ' '
Command = 'DoCmdTest'
Disconnect = False
Name = 'cmdDoCmdTest'
NormalReply.Code = '200'
ParamDelimiter = ' '
ParseParams = True
Tag = 0
OnCommand = CliCommandHandlers0Command
end>
ExceptionReply.Code = '500'
ExceptionReply.Text.Strings = (
'Unknown Internal Error')
Left = 16
Top = 8
end
end
Have you tried debugging the server?
The line
Result:= TCli(AContext);
(hard cast of TIdContext) looks like a potential reason for the freeze.
Have you read this, how to make the TIdCustomTCPServer aware of your own TIdServerContext class?
https://stackoverflow.com/a/5514932/80901
The relevant code in the answer:
constructor TOurServer.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
...
ContextClass := TOurContext;
...
end;

TClientDataSet Doesn't Release Memory

I have a DataSnap server that creates a TSQLQuery, TDataSetProvider and a TClientDataSet that are unique to a given user's session, which are used and reused to retrieve data from a database and send TClientDataSet.Data (an OleVariant) to the client. It works very well, except for one problem.
When I populate the TClientDataSet by calling its Open method, the memory that is allocated is not freed until the user disconnects their client from the DataSnap server. As the user uses the application and continues to retrieve data from the DataSnap server, memory continues to be allocated (hundreds of megs). When the user disconnects, all memory is freed. It needs to free the allocated memory after each request so that users that are connected for long periods of time don't crash the server by consuming all of its RAM.
I thought it might work to create the TSQLQuery, TDataSetProvider and TClientDataSet components when the user requests data, and then immediately destroy them after each request. This did not change the behavior. RAM continues to be allocated and not released until the user disconnects.
Why does the DataSnap server to hold on to the allocated memory when using a TClientDataSet, even when the components are destroyed after each request?
Thanks,
James
<<< Edit : 7/7/2011 6:23 PM >>>
Per Jeroen's recommendation, I have created a small program that duplicates the problem. There are two parts, the Server (4 source files) and the Client (4 source files). If there's a feature to attach files to this discussion, I can't use it yet -- not enough reputation points..., so I'm pasting the code below. The Server is a service so it must be registered after it is built (e.g., C:\ProjectFolder\Server.exe /install).
Before building the server, set the properties for SQLConnection1, and edit the SQL statements in ServerMethodsUnit1.pas. The only way to see the memory allocation issue is to retrieve a fair amount of data with each request (e.g., 500k). The tables I'm querying include uniqueidentifier, varchar(255), varchar(max), nvarchar(max), int, bit, datetime and other columns. I verified that all database datatypes exhibit the memory issue. The larger the dataset that is transferred to the client, the quicker the server allocates memory without releasing it.
Once both apps are built and the service is registered/started, use ProcessExplorer to view the memory used by the server service. Then start the client, click connect and click the buttons to get data. Notice the memory in ProcessExplorer increase for the server. Click Disconnect and watch the memory all be released.
Server.dpr
program Server;
uses
SvcMgr,
ServerMethodsUnit1 in 'ServerMethodsUnit1.pas',
ServerContainerUnit1 in 'ServerContainerUnit1.pas' {ServerContainer1: TService};
{$R *.RES}
begin
if not Application.DelayInitialize or Application.Installing then
Application.Initialize;
Application.CreateForm(TServerContainer1, ServerContainer1);
Application.Run;
end.
ServerContainerUnit1.dfm
object ServerContainer1: TServerContainer1
OldCreateOrder = False
OnCreate = ServiceCreate
DisplayName = 'DSServer'
OnStart = ServiceStart
Height = 271
Width = 415
object DSServer1: TDSServer
OnConnect = DSServer1Connect
AutoStart = True
HideDSAdmin = False
Left = 96
Top = 11
end
object DSTCPServerTransport1: TDSTCPServerTransport
Port = 212
PoolSize = 0
Server = DSServer1
BufferKBSize = 32
Filters = <>
Left = 96
Top = 73
end
object DSServerClass1: TDSServerClass
OnGetClass = DSServerClass1GetClass
Server = DSServer1
LifeCycle = 'Session'
Left = 200
Top = 11
end
object SQLConnection1: TSQLConnection
LoginPrompt = False
Left = 352
Top = 208
end
end
ServerContainerUnit1.pas
unit ServerContainerUnit1;
interface
uses
SysUtils, Classes,
SvcMgr,
DSTCPServerTransport,
DSServer, DSCommonServer, DSAuth, DB, SqlExpr, DBXMSSQL, ExtCtrls;
type
TServerContainer1 = class(TService)
DSServer1: TDSServer;
DSTCPServerTransport1: TDSTCPServerTransport;
DSServerClass1: TDSServerClass;
SQLConnection1: TSQLConnection;
procedure DSServerClass1GetClass(DSServerClass: TDSServerClass;
var PersistentClass: TPersistentClass);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure DSServer1Connect(DSConnectEventObject: TDSConnectEventObject);
procedure DoConnectToDBTimer(Sender: TObject);
procedure ServiceCreate(Sender: TObject);
private
FDBConnect: TTimer;
protected
function DoStop: Boolean; override;
function DoPause: Boolean; override;
function DoContinue: Boolean; override;
procedure DoInterrogate; override;
public
function GetServiceController: TServiceController; override;
end;
var
ServerContainer1: TServerContainer1;
implementation
uses Windows, ServerMethodsUnit1, DBXCommon;
{$R *.dfm}
procedure TServerContainer1.DSServer1Connect(DSConnectEventObject: TDSConnectEventObject);
begin
ServerMethodsUnit1.SQLConnection := SQLConnection1;
end;
procedure TServerContainer1.DSServerClass1GetClass(
DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := ServerMethodsUnit1.TDataUtils;
end;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
ServerContainer1.Controller(CtrlCode);
end;
function TServerContainer1.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TServerContainer1.DoConnectToDBTimer(Sender: TObject);
begin
// Connect to DB and free timer
FDBConnect.Enabled := False;
FreeAndNil(FDBConnect);
SQLConnection1.Open;
end;
function TServerContainer1.DoContinue: Boolean;
begin
Result := inherited;
DSServer1.Start;
end;
procedure TServerContainer1.DoInterrogate;
begin
inherited;
end;
function TServerContainer1.DoPause: Boolean;
begin
DSServer1.Stop;
Result := inherited;
end;
function TServerContainer1.DoStop: Boolean;
begin
DSServer1.Stop;
Result := inherited;
end;
procedure TServerContainer1.ServiceCreate(Sender: TObject);
begin
FDBConnect := TTimer.Create(Self);
end;
procedure TServerContainer1.ServiceStart(Sender: TService; var Started: Boolean);
begin
DSServer1.Start;
// Connecting to the DB here fails, so defer it 5 seconds
FDBConnect.Enabled := False;
FDBConnect.Interval := 5000;
FDBConnect.OnTimer := DoConnectToDBTimer;
FDBConnect.Enabled := True;
end;
end.
ServerMethodsUnit1.pas
unit ServerMethodsUnit1;
interface
uses
SysUtils, Classes, DSServer, DBXCommon, SQLExpr;
type
{$METHODINFO ON}
TDataUtils = class(TComponent)
private
FResult: OleVariant;
public
function GetData(const Option: Integer): OleVariant;
procedure FreeServerMemory;
end;
{$METHODINFO OFF}
threadvar
SQLConnection: TSQLConnection;
implementation
uses
DBClient, Provider;
{ TDataUtils }
procedure TDataUtils.FreeServerMemory;
begin
VarClear(FResult);
end;
function TDataUtils.GetData(const Option: Integer): OleVariant;
var
cds: TClientDataSet;
dsp: TDataSetProvider;
qry: TSQLQuery;
begin
qry := TSQLQuery.Create(nil);
try
qry.MaxBlobSize := -1;
qry.SQLConnection := SQLConnection;
dsp := TDataSetProvider.Create(nil);
try
dsp.ResolveToDataSet := True;
dsp.Exported := False;
dsp.DataSet := qry;
cds := TClientDataSet.Create(nil);
try
cds.DisableStringTrim := True;
cds.ReadOnly := True;
cds.SetProvider(dsp);
qry.Close;
case Option of
1:
begin
qry.CommandText := 'exec GetLMTree :alias, :levels'; // stored procedure; returns 330 rows; 550k of raw data
qry.Params.ParamByName('alias').Value := 'root';
qry.Params.ParamByName('levels').Value := -1;
end;
2:
begin
qry.CommandText := 'select * from az_item'; // returns 555 rows; 550k of raw data; 786k of raw data
end;
end;
cds.Open;
FResult := cds.Data;
finally
FreeAndNil(cds);
end;
finally
FreeAndNil(dsp);
end;
finally
FreeAndNil(qry);
end;
Exit(FResult);
end;
end.
Client.dpr
program Client;
uses
Forms,
ClientUnit1 in 'ClientUnit1.pas' {Form1},
ProxyMethods in 'ProxyMethods.pas';
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
ClientUnit1.dfm
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 301
ClientWidth = 562
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object DBGrid1: TDBGrid
Left = 8
Top = 39
Width = 546
Height = 254
DataSource = DataSource1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'Tahoma'
TitleFont.Style = []
end
object Button1: TButton
Left = 8
Top = 8
Width = 75
Height = 25
Caption = 'Connect'
TabOrder = 1
OnClick = Button1Click
end
object Button2: TButton
Left = 89
Top = 8
Width = 75
Height = 25
Caption = 'Get Data (1)'
TabOrder = 2
OnClick = Button2Click
end
object Button3: TButton
Left = 251
Top = 8
Width = 75
Height = 25
Caption = 'Disconnect'
TabOrder = 3
OnClick = Button3Click
end
object Button4: TButton
Left = 170
Top = 8
Width = 75
Height = 25
Caption = 'Get Data (2)'
TabOrder = 4
OnClick = Button2Click
end
object SQLConnection1: TSQLConnection
DriverName = 'Datasnap'
LoginPrompt = False
Params.Strings = (
'DriverUnit=DBXDataSnap'
'HostName=localhost'
'Port=212'
'CommunicationProtocol=tcp/ip'
'DatasnapContext=datasnap/'
'DriverAssemblyLoader=Borland.Data.TDBXClientDriverLoader,Borland' +
'.Data.DbxClientDriver,Version=$ASSEMBLY_VERSION$,Culture=neutral' +
',PublicKeyToken=91d62ebb5b0d1b1b'
'Filters={}')
Left = 520
Top = 256
UniqueId = '{F04CF8B5-7AE7-4010-81CF-7EBE29564C00}'
end
object ClientDataSet1: TClientDataSet
Aggregates = <>
Params = <>
Left = 456
Top = 256
end
object DataSource1: TDataSource
DataSet = ClientDataSet1
Left = 488
Top = 256
end
end
ClientUnit1.pas
unit ClientUnit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DBXDataSnap, DBXCommon, DB, SqlExpr, StdCtrls, Grids, DBGrids,
DBClient;
type
TForm1 = class(TForm)
SQLConnection1: TSQLConnection;
ClientDataSet1: TClientDataSet;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses ProxyMethods;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
SQLConnection1.Open;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
with ProxyMethods.TDataUtilsClient.Create(SQLConnection1.DBXConnection, True) do // let ProxyMethods do its own cleanup
try
ClientDataSet1.Close;
if Sender = Button2 then
ClientDataSet1.Data := GetData(1);
if Sender = Button4 then
ClientDataSet1.Data := GetData(2);
FreeServerMemory;
finally
//
// *** Answer to Server Memory Allocation Issue ***
//
// It appears that the server keeps its object in memory so long as the client
// keeps the objected created with ProxyMethods...Create in memory. We *must*
// explicitly free the object on the client side or the server will not release
// its object until the client disconnects. Doing this also solves a memory
// leak in the client.
Free;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
SQLConnection1.Close;
end;
end.
ProxyMethods.pas
//
// Created by the DataSnap proxy generator.
// 7/7/2011 5:43:35 PM
//
unit ProxyMethods;
interface
uses DBXCommon, DBXClient, DBXJSON, DSProxy, Classes, SysUtils, DB, SqlExpr, DBXDBReaders, DBXJSONReflect;
type
TDataUtilsClient = class(TDSAdminClient)
private
FGetDataCommand: TDBXCommand;
FFreeServerMemoryCommand: TDBXCommand;
public
constructor Create(ADBXConnection: TDBXConnection); overload;
constructor Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean); overload;
destructor Destroy; override;
function GetData(Option: Integer): OleVariant;
procedure FreeServerMemory;
end;
implementation
function TDataUtilsClient.GetData(Option: Integer): OleVariant;
begin
if FGetDataCommand = nil then
begin
FGetDataCommand := FDBXConnection.CreateCommand;
FGetDataCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FGetDataCommand.Text := 'TDataUtils.GetData';
FGetDataCommand.Prepare;
end;
FGetDataCommand.Parameters[0].Value.SetInt32(Option);
FGetDataCommand.ExecuteUpdate;
Result := FGetDataCommand.Parameters[1].Value.AsVariant;
end;
procedure TDataUtilsClient.FreeServerMemory;
begin
if FFreeServerMemoryCommand = nil then
begin
FFreeServerMemoryCommand := FDBXConnection.CreateCommand;
FFreeServerMemoryCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FFreeServerMemoryCommand.Text := 'TDataUtils.FreeServerMemory';
FFreeServerMemoryCommand.Prepare;
end;
FFreeServerMemoryCommand.ExecuteUpdate;
end;
constructor TDataUtilsClient.Create(ADBXConnection: TDBXConnection);
begin
inherited Create(ADBXConnection);
end;
constructor TDataUtilsClient.Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean);
begin
inherited Create(ADBXConnection, AInstanceOwner);
end;
destructor TDataUtilsClient.Destroy;
begin
FreeAndNil(FGetDataCommand);
FreeAndNil(FFreeServerMemoryCommand);
inherited;
end;
end.
When the client uses ProxyMethods.Create(...), you must remember to Free the object created on the client side. Doing this signals the server to release the object it created to service the request. If you do not Free the client-side object, then you end up with a memory leak on the client side, and the server doesn't know to release its correlating service object(s) until the client 'disconnects', which is what I observed. I'm glad it was a bug in my code and not the DataSnap Framework because Embarcadero doesn't ship all of the DataSnap code with XE, so I can't change and recompile the DataSnap Framework myself (see Is it possible to recompile the DataSnap packages in Delphi XE with a new/different version of Indy?).
I fixed the sample code above to Free the client-side object -- in case someone wants to use it as a sample DataSnap project.
James

Resources